diff options
897 files changed, 68056 insertions, 86790 deletions
diff --git a/ext/dbm/SDBM_File.c b/.dotest/last index e69de29bb2..e69de29bb2 100644 --- a/ext/dbm/SDBM_File.c +++ b/.dotest/last diff --git a/.package b/.package deleted file mode 100644 index 223efc558d..0000000000 --- a/.package +++ /dev/null @@ -1,16 +0,0 @@ -: basic variables -package=perl5 -baserev=5.0 -patchbranch=1 -mydiff='diff -c' -maintname='Larry Wall' -maintloc='lwall@netlabs.com' -ftpsite='' -orgname='NetLabs, Inc.' -newsgroups='comp.lang.perl' -recipients='' -ftpdir='' - -: derivative variables--do not change -revbranch="$baserev.$patchbranch" -packver='1' diff --git a/Bugs/delocalglob b/Bugs/delocalglob deleted file mode 100755 index 0a97695a24..0000000000 --- a/Bugs/delocalglob +++ /dev/null @@ -1,8 +0,0 @@ -#!./perl -$foo = GOOD; -{ - local(*foo) = \$bar; - $bar = BAR; - print $foo; -} -print $foo; diff --git a/Bugs/localenv b/Bugs/localenv deleted file mode 100644 index 6ab19308c6..0000000000 --- a/Bugs/localenv +++ /dev/null @@ -1,6 +0,0 @@ -{ - local(%ENV); - $ENV{OOPS} = OOPS; - system 'echo NOT $OOPS'; -} -system 'echo $OOPS'; @@ -47,8 +47,6 @@ New things Lexical scoping available via "my". eval can see the current lexical variables. - Saying "package;" requires explicit package name on global symbols. - The preferred package delimiter is now :: rather than '. tie/untie are now preferred to dbmopen/dbmclose. Multiple DBM @@ -58,10 +56,8 @@ New things New "and" and "or" operators work just like && and || but with a precedence lower than comma, so they work better with list operators. - New functions include: abs(), chr(), uc(), ucfirst(), lc(), lcfirst() - - require with a bare word now does an immediate require at compile time. - So "require POSIX" is equivalent to "BEGIN { require 'POSIX.pm' }". + New functions include: abs(), chr(), uc(), ucfirst(), lc(), lcfirst(), + chomp(), glob() require with a number checks to see that the version of Perl that is currently running is at least that number. @@ -86,15 +82,53 @@ New things routine, which will be called if a non-existent subroutine is called in that package. - There is now a pragma mechanism, using the keywords "aver" and "deny". - Current pragmas are "integer" and "strict". Unrecognized pragmas - are ignored. + Several previously added features have been subsumed under the new + keywords "use" and "no". Saying "use Module LIST" is short for + BEGIN { require Module; import Module LIST; } + The "no" keyword is identical except that it calls "unimport" instead. + The earlier pragma mechanism now uses this mechanism, and two new + modules have been added to the library to implement "use integer" + and variations of "use strict vars, refs, subs". + + Variables may now be interpolated literally into a pattern by prefixing + them with \Q, which works just like \U, but backwhacks non-alphanumerics + instead. There is also a corresponding quotemeta function. + + Any quantifier in a regular expression may now be followed by a ? to + indicate that the pattern is supposed to match as little as possible. + + Pattern matches may now be followed by an m or s modifier to explicitly + request multiline or singleline semantics. An s modifier makes . match + newline. + + Patterns may now contain \A to match only at the beginning of the string, + and \Z to match only at the end. These differ from ^ and $ in that + they ignore multiline semantics. In addition, \G matches where the + last interation of m//g or s///g left off. + + Non-backreference-producing parens of various sorts may now be + indicated by placing a ? directly after the opening parenthesis, + followed by a character that indicates the purpose of the parens. + An :, for instance, indicates simple grouping. (?:a|b|c) will + match any of a, b or c without producing a backreference. It does + "eat" the input. There are also assertions which do not eat the + input but do lookahead for you. (?=stuff) indicates that the next + thing must be "stuff". (?!nonsense) indicates that the next thing + must not be "nonsense". + + The negation operator now treats non-numeric strings specially. + A -"text" is turned into "-text", so that -bareword is the same + as "-bareword". If the string already begins with a + or -, it + is flipped to the other sign. Incompatibilities ----------------- @ now always interpolates an array in double-quotish strings. Some programs may now need to use backslash to protect any @ that shouldn't interpolate. + Ordinary variables starting with underscore are no longer forced into + package main. + s'$lhs'$rhs' now does no interpolation on either side. It used to interplolate $lhs but not $rhs. @@ -111,7 +145,7 @@ Incompatibilities You can't do a goto into a block that is optimized away. Darn. It is no longer syntactically legal to use whitespace as the name - of a variable. + of a variable, or as a delimiter for any kind of quote construct. Some error messages will be different. @@ -135,3 +169,13 @@ Incompatibilities The comma operator in a scalar context is now guaranteed to give a scalar context to its arguments. + + The ** operator now binds more tightly than unary minus. + + Setting $#array lower now discards array elements so that destructors + work reasonably. + + delete is not guaranteed to return the old value for tied arrays, + since this capability may be onerous for some modules to implement. + + Attempts to set $1 through $9 now result in a run-time error. @@ -18,9 +18,9 @@ # archive site. Check with Archie if you don't know where that can be.) # -# $Id: Head.U,v 3.0.1.3 1993/12/15 08:15:07 ram Exp $ +# $Id: Head.U,v 3.0.1.5 1994/08/29 16:03:44 ram Exp $ # -# Generated on Wed May 4 14:59:36 EDT 1994 [metaconfig 3.0 PL22] +# Generated on Tue Oct 11 22:49:31 EDT 1994 [metaconfig 3.0 PL35] cat >/tmp/c1$$ <<EOF ARGGGHHHH!!!!! @@ -46,17 +46,38 @@ true || exec sh $0 $argv:q (exit $?0) || exec sh $0 $argv:q rm -f /tmp/c1$$ /tmp/c2$$ -: Sanity checks -PATH=".:$PATH:/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/local:/usr/lbin" -PATH=$PATH:'/usr/5bin:/etc:/usr/gnu/bin:/usr/new:/usr/new/bin:/usr/nbin' -PATH=$PATH:'/sys5.3/bin:/sys5.3/usr/bin:/bsd4.3/bin:/bsd4.3/usr/ucb' -PATH=$PATH:'/bsd4.3/usr/bin:/usr/bsd:/bsd43/bin:/usr/ccs/bin' -PATH=$PATH:'/etc:/usr/lib:/usr/ucblib:/lib:/usr/ccs/lib' -PATH=$PATH:'/sbin:/usr/sbin:/usr/libexec' +: compute my invocation name +me=$0 +case "$0" in +*/*) + me=`echo $0 | sed -e 's!.*/\(.*\)!\1!' 2>/dev/null` + test "$me" || me=$0 + ;; +esac + + +: Proper PATH setting +paths='/bin /usr/bin /usr/local/bin /usr/ucb /usr/local /usr/lbin' +paths=$paths:'/usr/5bin /etc /usr/gnu/bin /usr/new /usr/new/bin /usr/nbin' +paths=$paths:'/sys5.3/bin /sys5.3/usr/bin /bsd4.3/bin /bsd4.3/usr/ucb' +paths=$paths:'/bsd4.3/usr/bin /usr/bsd /bsd43/bin /usr/ccs/bin' +paths=$paths:'/etc /usr/lib /usr/ucblib /lib /usr/ccs/lib' +paths=$paths:'/sbin /usr/sbin /usr/libexec' + +for p in $paths +do + case ":$PATH:" in + *:$p:*) ;; + *) test -d $p && PATH=$PATH:$p ;; + esac +done + +PATH=.:$PATH export PATH +: Sanity checks if test ! -t 0; then - echo "Say 'sh Configure', not 'sh <Configure'" + echo "Say 'sh $me', not 'sh <$me'" exit 1 fi @@ -73,8 +94,8 @@ EOM else : Warn them if they use ksh on other systems (PATH=.; alias -x) >/dev/null 2>&1 && \ - cat <<'EOM' -(I see you are using the Korn shell. Some ksh's blow up on Configure, + cat <<EOM +(I see you are using the Korn shell. Some ksh's blow up on $me, especially on exotic machines. If yours does, try the Bourne shell instead.) EOM fi @@ -83,7 +104,11 @@ fi test -d UU || mkdir UU cd UU && rm -f * +dynamic_ext='' extensions='' +known_extensions='' +static_ext='' +useposix='' d_eunice='' d_xenix='' eunicefix='' @@ -152,6 +177,7 @@ uniq='' uuname='' vi='' zcat='' +libswanted='' hint='' myuname='' osname='' @@ -167,7 +193,12 @@ Revision='' Source='' State='' afs='' -memalignbytes='' +alignbytes='' +archlib='' +archlibexp='' +archname='' +d_archlib='' +installarchlib='' bin='' binexp='' installbin='' @@ -182,11 +213,14 @@ optimize='' cf_by='' cf_time='' contains='' +cpp_stuff='' cpplast='' cppminus='' cpprun='' cppstdin='' d_access='' +d_alarm='' +d_attrib='' d_bcmp='' d_bcopy='' d_bzero='' @@ -194,48 +228,86 @@ d_casti32='' castflags='' d_castneg='' d_charsprf='' +d_chown='' +d_chroot='' d_chsize='' +d_closedir='' +d_void_closedir='' d_const='' cryptlib='' d_crypt='' d_csh='' +d_cuserid='' +d_dbl_dig='' +d_difftime='' +d_dlerror='' +d_dlopen='' +d_dlsymun='' d_dosuid='' +d_suidsafe='' +d_drem='' d_dup2='' d_fchmod='' d_fchown='' d_fcntl='' +d_fd_macros='' +d_fd_set='' +d_fds_bits='' +d_fgetpos='' d_flexfnam='' d_flock='' +d_fmod='' +d_fork='' +d_fsetpos='' +d_Gconvert='' d_getgrps='' d_gethent='' aphostname='' d_gethname='' d_phostname='' d_uname='' +d_getlogin='' d_getpgrp2='' d_getpgrp='' +d_getppid='' d_getprior='' +d_group='' d_htonl='' d_isascii='' d_killpg='' d_link='' +d_linuxstd='' +d_locconv='' +d_lockf='' d_lstat='' +d_mblen='' +d_mbstowcs='' +d_mbtowc='' d_memcmp='' d_memcpy='' d_memmove='' d_memset='' d_mkdir='' +d_mkfifo='' +d_mktime='' d_msg='' d_msgctl='' d_msgget='' d_msgrcv='' d_msgsnd='' +d_nice='' d_open3='' +d_passwd='' +d_fpathconf='' +d_pathconf='' +d_pause='' +d_pipe='' d_portable='' d_readdir='' d_rewinddir='' d_seekdir='' d_telldir='' +d_readlink='' d_rename='' d_rmdir='' d_safebcpy='' @@ -247,6 +319,7 @@ d_semget='' d_semop='' d_setegid='' d_seteuid='' +d_setlinebuf='' d_setlocale='' d_setpgid='' d_setpgrp2='' @@ -262,7 +335,8 @@ d_setruid='' d_setsid='' d_shm='' d_shmat='' -d_voidshmat='' +d_shmatprototype='' +shmattype='' d_shmctl='' d_shmdt='' d_shmget='' @@ -275,25 +349,28 @@ d_statblks='' d_stdstdio='' d_index='' d_strchr='' +d_strcoll='' d_strctcpy='' d_strerrm='' d_strerror='' d_sysernlst='' d_syserrlst='' +d_strxfrm='' d_symlink='' d_syscall='' +d_sysconf='' d_system='' +d_tcgetpgrp='' +d_tcsetpgrp='' d_time='' timetype='' clocktype='' d_times='' d_truncate='' -d_usendir='' -i_ndir='' -ndirc='' -ndirlib='' -ndiro='' +d_tzname='' +d_umask='' d_vfork='' +usevfork='' d_voidsig='' signal_t='' d_volatile='' @@ -301,25 +378,33 @@ d_charvspr='' d_vprintf='' d_wait4='' d_waitpid='' +d_wcstombs='' +d_wctomb='' +dlext='' cccdlflags='' ccdlflags='' -dldir='' -dlobj='' dlsrc='' lddlflags='' -shlibsuffix='' usedl='' +fpostype='' gidtype='' groupstype='' h_fcntl='' h_sysfile='' +i_db='' i_dbm='' d_dirnamlen='' +direntrytype='' i_dirent='' +i_dld='' i_dlfcn='' i_fcntl='' +i_float='' i_gdbm='' i_grp='' +i_limits='' +i_malloc='' +i_math='' i_memory='' i_ndbm='' i_neterrno='' @@ -332,19 +417,21 @@ d_pwcomment='' d_pwexpire='' d_pwquota='' i_pwd='' -i_sdbm='' -i_stdarg='' i_stddef='' +i_stdlib='' i_string='' strings='' i_sysdir='' i_sysfile='' d_voidtty='' i_bsdioctl='' +i_sysfilio='' i_sysioctl='' i_syssockio='' i_sysndir='' +i_sysparam='' i_sysselct='' +i_systimes='' i_sgtty='' i_termio='' i_termios='' @@ -354,13 +441,13 @@ i_time='' timeincl='' i_unistd='' i_utime='' +i_stdarg='' i_varargs='' i_varhdr='' i_vfork='' intsize='' -lib='' -libexp='' libc='' +glibpth='' libpth='' plibpth='' xlibpth='' @@ -382,6 +469,7 @@ medium='' models='' small='' split='' +modetype='' mydomain='' myhostname='' phostname='' @@ -394,19 +482,23 @@ orderlib='' ranlib='' package='' spackage='' +prefix='' installprivlib='' privlib='' privlibexp='' prototype='' -ptrsize='' randbits='' installscript='' scriptdir='' scriptdirexp='' +selecttype='' sig_name='' +sizetype='' +so='' sharpbang='' shsharp='' spitshell='' +ssizetype='' startsh='' stdchar='' sysman='' @@ -429,7 +521,16 @@ cat >extract <<'EOS' CONFIG=true echo "Doing variable substitutions on .SH files..." if test -f MANIFEST; then - set x `awk '{print $1}' <MANIFEST | grep '\.SH'` + shlist=`awk '{print $1}' <MANIFEST | grep '\.SH'` + : Pick up possible extension manifests. + for dir in ext/* ; do + if test -f $dir/MANIFEST; then + xxx=`awk '{print $1}' < $dir/MANIFEST | + sed -n "/\.SH$/ s@^@$dir/@p"` + shlist="$shlist $xxx" + fi + done + set x $shlist else echo "(Looking for .SH files under the current directory.)" set x `find . -name "*.SH" -print` @@ -464,7 +565,7 @@ EOS : produce awk script to parse command line options cat >options.awk <<'EOF' BEGIN { - optstr = "deEf:hrsSV"; # getopt-style specification + optstr = "deEf:hrsSD:U:V"; # getopt-style specification len = length(optstr); for (i = 1; i <= len; i++) { @@ -521,6 +622,7 @@ alldone='' error='' silent='' extractsh='' +optdef='optdef.sh' : option parsing while test $# -gt 0; do @@ -533,7 +635,7 @@ while test $# -gt 0; do if test -r "$1"; then config_sh="$1" else - echo "Configure: cannot read config file $1." >&2 + echo "$me: cannot read config file $1." >&2 error=true fi cd UU @@ -543,10 +645,34 @@ while test $# -gt 0; do -s) shift; silent=true;; -E) shift; alldone=exit;; -S) shift; extractsh=true;; - -V) echo "Configure generated by metaconfig 3.0 PL22." >&2 + -D) + shift + case "$1" in + *=) + echo "$me: use '-U symbol=', not '-D symbol='." >&2 + echo "$me: ignoring -D $1" >&2 + ;; + *=*) echo "$1" >> $optdef;; + *) echo "$1='define'" >> $optdef;; + esac + shift + ;; + -U) + shift + case "$1" in + *=) echo "$1" >> $optdef;; + *=*) + echo "$me: use '-D symbol=val', not '-U symbol=val'." >&2 + echo "$me: ignoring -U $1" >&2 + ;; + *) echo "$1='undef'" >> $optdef;; + esac + shift + ;; + -V) echo "$me generated by metaconfig 3.0 PL35." >&2 exit 0;; --) break;; - -*) echo "Configure: unknown option $1" >&2; shift; error=true;; + -*) echo "$me: unknown option $1" >&2; shift; error=true;; *) break;; esac done @@ -554,15 +680,22 @@ done case "$error" in true) cat >&2 <<EOM -Usage: Configure [-dehrESV] [-f config.sh] +Usage: $me [-dehrESV] [-f config.sh] [-D symbol] [-D symbol=value] + [-U symbol] [-U symbol=] -d : use defaults for all answers. -e : go on without questioning past the production of config.sh. -f : specify an alternate default configuration file. -h : print this help message and exit (with an error status). -r : reuse C symbols value if possible (skips costly nm extraction). -s : silent mode, only echoes questions and essential information. + -D : define symbol to have some value: + -D symbol symbol gets the value 'define' + -D symbol=value symbol gets the value 'value' -E : stop at the end of questions, after having produced config.sh. -S : perform variable substitutions on all .SH files (can mix with -f) + -U : undefine symbol: + -U symbol symbol gets the value 'undef' + -U symbol= symbol gets completely empty -V : print version number and exit (with a zero status). EOM exit 1 @@ -574,6 +707,11 @@ case "$silent" in true) exec 1>/dev/null;; esac +: run the defines and the undefines, if any +touch $optdef +. ./$optdef +rm -f $optdef + case "$extractsh" in true) case "$config_sh" in @@ -618,48 +756,103 @@ if test -f /etc/unixtovms.exe; then fi : list of known cpp symbols -attrlist="__alpha __bsdi__ BSD_NET2 DGUX M_I186 M_I286 M_I386" -attrlist="$attrlist M_I8086 M_XENIX UTS __DGUX__" -attrlist="$attrlist _AIX __STDC__ __m88k__ ansi bsd4_2 gcos gimpel" -attrlist="$attrlist hp9000s300 hp9000s400 hp9000s500 hp9000s700" -attrlist="$attrlist hp9000s800 hpux" -attrlist="$attrlist i186 i386 i486 i8086 iAPX286 ibm interdata" -attrlist="$attrlist m88k mc300 mc500 mc68000 mc68k mc700 mert" -attrlist="$attrlist mips NeXT ns16000 ns32000 nsc32000 os" -attrlist="$attrlist __osf__ pdp11 posix" -attrlist="$attrlist pyr sinix sony sparc sun tower tower32 tower32_600" -attrlist="$attrlist tower32_800 tss u3b2 u3b20 u3b200 u3b5 ultrix unix" -attrlist="$attrlist __unix__ vax venix xenix z8000" +al="AMIX BIT_MSF BSD BSD4_3 BSD_NET2 CRAY DGUX DOLPHIN DPX2" +al="$al GO32 HP700 I386 I80960 I960 Lynx M68000 M68K MACH" +al="$al MIPSEB MIPSEL MSDOS MTXINU MVS" +al="$al M_COFF M_I186 M_I286 M_I386 M_I8086 M_I86 M_I86SM" +al="$al M_SYS3 M_SYS5 M_SYSIII M_SYSV M_UNIX M_XENIX" +al="$al NeXT OCS88 OSF1 PARISC PC532 PORTAR POSIX" +al="$al PWB R3000 SVR3 SVR4" +al="$al SYSTYPE_BSD SYSTYPE_SVR4 SYSTYPE_SYSV" +al="$al UTEK UTS UTek UnicomPBB UnicomPBD Utek VMS" +al="$al _AIX _AIX32 _AM29000 _COFF _CRAY _EPI _IBMR2" +al="$al _MIPSEB _MIPSEL _M_COFF _M_I86 _M_I86SM _M_SYS3" +al="$al _M_SYS5 _M_SYSIII _M_SYSV _M_UNIX _M_XENIX _R3000" +al="$al _SYSTYPE_BSD _SYSTYPE_BSD43 _SYSTYPE_SVR4" +al="$al _SYSTYPE_SYSV _SYSV3 _UNICOS" +al="$al __386BSD__ __BIG_ENDIAN __BIG_ENDIAN__ __BSD_4_4__" +al="$al __DGUX__ __DPX2__ __H3050R __H3050RX" +al="$al __LITTLE_ENDIAN __LITTLE_ENDIAN__ __MACH__" +al="$al __MIPSEB __MIPSEB__ __MIPSEL __MIPSEL__" +al="$al __Next__ __OSF1__ __PARAGON__ __PWB __STDC__" +al="$al ____386BSD____ __alpha __alpha__ __amiga" +al="$al __bsd4_2 __bsd4_2__ __bsdi__ __convex__" +al="$al __host_mips__" +al="$al __hp9000s200 __hp9000s300 __hp9000s400 __hp9000s500" +al="$al __hp9000s500 __hp9000s700 __hp9000s800" +al="$al __hppa __hpux __i286 __i286__ __i386 __i386__" +al="$al __i486 __i486__ __i860 __i860__" +al="$al __m68k __m68k__ __m88100__ __m88k __m88k__" +al="$al __mc68000 __mc68000__ __mc68020 __mc68020__" +al="$al __mc68030 __mc68030__ __mc68040 __mc68040__" +al="$al __mc88100 __mc88100__ __mips __mips__" +al="$al __motorola__ __osf__ __pa_risc __sparc__ __stdc__" +al="$al __sun __sun__ __svr3__ __svr4__ __ultrix __ultrix__" +al="$al __unix __unix__ __vax __vax__" +al="$al _host_mips _mips _unix" +al="$al a29k aegis alliant am29000 amiga ansi" +al="$al bsd bsd43 bsd4_2 bsd4_3 bsd4_4 bull" +al="$al convex cray ctix encore gcos gimpel" +al="$al hcx host_mips hp200 hp300 hp700 hp800" +al="$al hp9000 hp9000s300 hp9000s400 hp9000s500" +al="$al hp9000s700 hp9000s800 hp9k8 hpux" +al="$al i186 i286 i386 i486 i8086" +al="$al i80960 i860 iAPX286 ibm interdata is68k" +al="$al linux luna luna88k m68k m88100 m88k" +al="$al mc300 mc500 mc68000 mc68010 mc68020 mc68030" +al="$al mc68040 mc68060 mc68k mc68k32 mc700" +al="$al mc88000 mc88100 merlin mert mips mvs n16" +al="$al ncl_el ncl_mr" +al="$al news1500 news1700 news1800 news1900 news3700" +al="$al news700 news800 news900 ns16000 ns32000" +al="$al ns32016 ns32332 ns32k nsc32000 os osf" +al="$al parisc pc532 pdp11 plexus posix pyr" +al="$al riscix riscos sequent sgi sinix sony sony_news" +al="$al sonyrisc sparc sparclite spectrum stratos" +al="$al sun sun3 sun386 svr4 sysV68 sysV88" +al="$al tower tower32 tower32_200 tower32_600 tower32_700" +al="$al tower32_800 tower32_850 tss u3b u3b2 u3b20 u3b200" +al="$al u3b5 ultrix unix unixpc unos vax venix vms" +al="$al xenix z8000" i_whoami='' -: List of extensions we want: -extensions='' -gccversion='' -: no include file wanted by default -inclwanted='' - -: File to use for dynamic loading -usedl='' -gidtype='' -groupstype='' : change the next line if compiling for Xenix/286 on Xenix/386 xlibpth='/usr/lib/386 /lib/386' : general looking path for locating libraries -libpth="/usr/lib/large /lib /usr/lib $xlibpth /lib/large" -libpth="$libpth /usr/lib/small /lib/small" -libpth="$libpth /usr/ccs/lib /usr/ucblib /usr/local/lib" +glibpth="/lib/pa1.1 /usr/lib/large /lib /usr/lib $xlibpth" +glibpth="$glibpth /lib/large /usr/lib/small /lib/small" +glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/local/lib /usr/shlib" : Private path used by Configure to find libraries. Its value -: is prepend to libpth. This variable takes care of special +: is prepended to libpth. This variable takes care of special : machines, like the mips. Usually, it should be empty. plibpth='' -libswanted=" net socket inet nsl nm sdbm gdbm ndbm dbm malloc dl dld sun m c_s posix cposix ndir dir ucb bsd BSD PW x " - : full support for void wanted by default defvoidused=15 +: set useposix=false in your hint file to disable the POSIX extension. +useposix=true +gccversion='' +: no include file wanted by default +inclwanted='' + +groupstype='' +: default library list +libswanted='' +: List of libraries we want. +libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl' +libswanted="$libswanted dld ld sun m c cposix posix ndir dir crypt" +libswanted="$libswanted ucb bsd BSD PW x" +: We want to search /usr/shlib before most other libraries. +: This is only used by ext/util/extliblist +glibpth=`echo " $glibpth " | sed -e 's! /usr/shlib ! !'` +glibpth="/usr/shlib $glibpth" +: Do not use vfork unless overridden by a hint file. +usevfork=false +: We can look for titanos too. +al="$al ardent titan" : Some greps do not return status, grrr. echo "grimblepritz" >grimble @@ -861,7 +1054,7 @@ if $needman; then cat <<EOH This installation shell script will examine your system and ask you questions -to determine how the perl package should be installed. If you get +to determine how the perl5 package should be installed. If you get stuck on a question, you may use a ! shell escape to start a subshell or execute a command. Many of the questions will have default answers in square brackets; typing carriage return will give you the default. @@ -929,7 +1122,9 @@ if sh -c '#' >/dev/null 2>&1 ; then spitshell=cat echo " " echo "Okay, let's see if #! works on this system..." - echo "#!/bin/cat" >try + xcat=/bin/cat + test -r $xcat || xcat=/usr/bin/cat + echo "#!$xcat" >try $eunicefix try chmod +x try ./try > today @@ -937,7 +1132,7 @@ if sh -c '#' >/dev/null 2>&1 ; then echo "It does." sharpbang='#!' else - echo "#! /bin/cat" > try + echo "#! $xcat" > try $eunicefix try chmod +x try ./try > today @@ -952,10 +1147,12 @@ if sh -c '#' >/dev/null 2>&1 ; then else echo "Your sh doesn't grok # comments--I will strip them later on." shsharp=false + cd .. echo "exec grep -v '^[ ]*#'" >spitshell chmod +x spitshell $eunicefix spitshell spitshell=`pwd`/spitshell + cd UU echo "I presume that if # doesn't work, #! won't work either!" sharpbang=': use ' fi @@ -1005,8 +1202,11 @@ for dir in \$*; do fi ;; *) - if test -f \$dir/\$thing; then - echo \$dir/\$thing + for thisthing in \$dir/\$thing; do + : Just loop through to pick last element + done + if test -f \$thisthing; then + echo \$thisthing exit 0 elif test -f \$dir/\$thing.exe; then : on Eunice apparently @@ -1027,10 +1227,11 @@ cat cp echo expr +find grep ln +ls mkdir -mv rm sed sort @@ -1046,7 +1247,6 @@ cpp csh date egrep -find line nroff perl @@ -1134,16 +1334,26 @@ FOO ;; esac +: determine whether symbolic links are supported +echo " " +$touch blurfl +if $ln -s blurfl sym > /dev/null 2>&1 ; then + echo "Symbolic links are supported." >&4 + lns="$ln -s" +else + echo "Symbolic links are NOT supported." >&4 + lns="$ln" +fi +$rm -f blurfl sym + : Try to determine whether config.sh was made on this system case "$config_sh" in '') myuname=`( ($uname -a) 2>/dev/null || hostname) 2>&1` -myuname=`echo $myuname | $sed -e 's/^[^=]*=//' | \ +myuname=`echo $myuname | $sed -e 's/^[^=]*=//' -e 's/\///g' | \ tr '[A-Z]' '[a-z]' | tr '\012' ' '` dflt=n -if test "$fastread" = yes; then - dflt=y -elif test -f ../config.sh; then +if test -f ../config.sh; then oldmyuname='' if $contains myuname= ../config.sh >/dev/null 2>&1; then eval "old`grep myuname= ../config.sh`" @@ -1185,19 +1395,20 @@ EOM : Half the following guesses are probably wrong... If you have better : tests or hints, please send them to lwall@netlabs.com : The metaconfig authors would also appreciate a copy... - $test -f /irix && osname=sgi + $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix $test -f /dynix && osname=dynix $test -f /dnix && osname=dnix + $test -f /unicos && osname=unicos && osvers=`$uname -r` $test -f /bin/mips && /bin/mips && osname=mips - $test -d /NextApps && test -f /usr/adm/software_version && osname=next + $test -d /NextApps && set X `hostinfo | grep 'NeXT Mach.*:' | sed -e 's/://' -e 's/\./_/'` && osname=next && osvers=$4 + $test -d /usr/apollo/bin && osname=apollo + $test -f /etc/saf/_sactab && osname=svr4 $test -d /usr/include/minix && osname=minix if $test -f $uname; then set X $myuname shift - $test -f $5.sh && dflt="$dflt $5" - case "$5" in fps*) osname=fps ;; mips*) @@ -1210,35 +1421,86 @@ EOM news*) osname=news ;; i386*) if $test -f /etc/kconfig; then osname=isc - if $contains _SYSV3 /usr/include/stdio.h > /dev/null 2>&1 ; then - osvers=3.2.3 + if test "$lns" = "ln -s"; then + osvers=4 + elif $contains _SYSV3 /usr/include/stdio.h > /dev/null 2>&1 ; then + osvers=3 elif $contains _POSIX_SOURCE /usr/include/stdio.h > /dev/null 2>&1 ; then - osvers=3.2.2 + osvers=2 fi fi ;; esac case "$1" in - aix) osname=aix_rs ;; + aix) osname=aix + tmp=`( (oslevel) 2>/dev/null || echo "not found") 2>&1` + case "$tmp" in + 'not found') osvers=3.2.0 ;; + '<3240'|'<>3240') osvers=3.2.0 ;; + '=3240'|'>3240'|'<3250'|'<>3250') osvers=3.2.4 ;; + '=3250'|'>3250') osvers=3.2.5 ;; + *) osvers='' ;; + esac + ;; + dnix) osname=dnix + osvers="$3" + ;; + domainos) osname=apollo + osvers="$3" + ;; + dgux) osname=dgux + osvers="$3" + ;; + freebsd) osname=freebsd + osvers="$3" ;; + genix) osname=genix ;; + hp*) osname=hpux + case "$3" in + *.08.*) osvers=9 ;; + *.09.*) osvers=9 ;; + *.10.*) osvers=10 ;; + esac + ;; + irix) osname=irix + case "$3" in + 4*) osvers=4 ;; + 5*) osvers=5 ;; + esac + ;; + linux) osname=linux + case "$3" in + 1*) osvers=1 ;; + *) osvers="$3" ;; + esac + ;; + netbsd*) osname=netbsd + osvers="$3" + ;; + bsd386) osname=bsd386 + osvers=`$uname -r` + ;; + next*) osname=next ;; + solaris) osname=solaris + case "$3" in + 5*) osvers=`echo $3 | $sed 's/^5/2/g'` ;; + esac + ;; sunos) osname=sunos case "$3" in - [34]*) osvers=$3 ;; 5*) osname=solaris osvers=`echo $3 | $sed 's/^5/2/g'` ;; + *) osvers="$3" ;; esac ;; - solaris) osname=solaris + titanos) osname=titanos case "$3" in - 5*) osvers=`echo $3 | $sed 's/^5/2/g'` ;; + 1*) osvers=1 ;; + 2*) osvers=2 ;; + 3*) osvers=3 ;; + 4*) osvers=4 ;; esac ;; - dnix) osname=dnix ;; - dgux) osname=dgux ;; - genix) osname=genix ;; - hp*ux) osname=hpux ;; - next) osname=next ;; - irix) osname=sgi ;; ultrix) osname=ultrix case "$3" in 1*) osvers=1 ;; @@ -1257,16 +1519,41 @@ EOM ;; hp*) osname=hp_osf1 ;; # TR mips) osname=mips_osf1 ;; # TR - # TR = Technology Releases: (un^N)supported + # TR = Technology Releases: unsupported esac ;; - uts) osname=uts ;; + uts) osname=uts + osvers="$3" + ;; $2) case "$osname" in *isc*) ;; + *freebsd*) ;; + svr*) + : svr4.x or possibly later + case "svr$3" in + ${osname}*) + osname=svr$3 + osvers=$4 + ;; + esac + case "$osname" in + svr4.0) + : Check for ESIX + if test -f /stand/boot ; then + eval `grep '^INITPROG=[a-z/0-9]*$' /stand/boot` + if test -n $INITPROG -a -f $INITPROG; then + isesix=`strings -a $INITPROG|grep 'ESIX SYSTEM V/386 Release 4.0'` + if test -n $isesix; then + osname=esix4 + fi + fi + fi + ;; + esac + ;; *) if test -f /etc/systemid; then - osname=sco - : Does anyone know if these next gyrations are needed - set `echo $3 | $sed 's/\./ /g'` $4 + osname=sco + set `echo $3 | $sed 's/\./ /g'` $4 if $test -f sco_$1_$2_$3.sh; then osvers=$1.$2.$3 elif $test -f sco_$1_$2.sh; then @@ -1274,10 +1561,24 @@ EOM elif $test -f sco_$1.sh; then osvers=$1 fi + else + case "$osname" in + '') : Still unknown. Probably a generic Sys V. + osname="sysv" + osvers="$3" + ;; + esac fi ;; esac ;; + *) case "$osname" in + '') : Still unknown. Probably a generic BSD. + osname="$1" + osvers="$3" + ;; + esac + ;; esac else if test -f /vmunix -a -f news_os.sh; then @@ -1289,23 +1590,44 @@ EOM fi fi - : Now look for a hint file osname_osvers - file=`echo "${osname}_${osvers}" | sed -e 's@\.@_@g' -e 's@_$@@'` - case "$file" in - '') dflt=none ;; - *) case "$osvers" in - '') dflt=$file - ;; - *) if $test -f $file.sh ; then - dflt=$file - elif $test -f "${osname}.sh" ; then - dflt="${osname}" - else - dflt=none - fi + : Now look for a hint file osname_osvers, unless one has been + : specified already. + case "$hintfile" in + ''|' ') + file=`echo "${osname}_${osvers}" | sed -e 's@\.@_@g' -e 's@_$@@'` + : Also try without trailing minor version numbers. + xfile=`echo $file | sed -e 's@_[^_]*$@@'` + xxfile=`echo $xfile | sed -e 's@_[^_]*$@@'` + xxxfile=`echo $xxfile | sed -e 's@_[^_]*$@@'` + xxxxfile=`echo $xxxfile | sed -e 's@_[^_]*$@@'` + case "$file" in + '') dflt=none ;; + *) case "$osvers" in + '') dflt=$file + ;; + *) if $test -f $file.sh ; then + dflt=$file + elif $test -f $xfile.sh ; then + dflt=$xfile + elif $test -f $xxfile.sh ; then + dflt=$xxfile + elif $test -f $xxxfile.sh ; then + dflt=$xxxfile + elif $test -f $xxxxfile.sh ; then + dflt=$xxxxfile + elif $test -f "${osname}.sh" ; then + dflt="${osname}" + else + dflt=none + fi + ;; + esac ;; esac ;; + *) + dflt=`echo $hintfile | sed 's/\.sh$//'` + ;; esac $cat <<EOM @@ -1345,9 +1667,9 @@ EOM hint=recommended : Remember our hint file for later. if $test -f "$file.sh" ; then - hintfile="$file.sh" + hintfile="$file" else - hintfile=none + hintfile='' fi cd .. @@ -1376,14 +1698,16 @@ for file in $loclist $trylist; do done cat << EOM + Configure uses the operating system name and version to set some defaults. Say "none" to leave it blank. + EOM case "$osname" in - ''|' ') + ''|' ') case "$hintfile" in - none) dflt=none ;; + ''|' '|none) dflt=none ;; *) dflt=`echo $hintfile | sed -e 's/\.sh$//' -e 's/_.*$//'` ;; esac ;; @@ -1395,38 +1719,24 @@ case "$ans" in none) osname='' ;; *) osname="$ans" ;; esac - -case "$osvers" in - ''|' ') - case "$hintfile" in - none) dflt=none ;; - *) dflt=`echo $hintfile | sed -e 's/\.sh$//' -e 's/^[^_]*//'` - dflt=`echo $dflt | sed -e 's/^_//' -e 's/_/./g'` ;; - esac - ;; - *) dflt="$osvers" ;; -esac -rp="Operating system version?" -. ./myread -case "$ans" in - none) osvers='' ;; - *) osvers="$ans" ;; -esac : who configured the system cf_time=`$date 2>&1` -cf_by=`( (logname) 2>/dev/null || whoami) 2>&1` +(logname > .temp) >/dev/null 2>&1 +$test -s .temp || (whoami > .temp) >/dev/null 2>&1 +$test -s .temp || echo unknown > .temp +cf_by=`$cat .temp` +$rm -f .temp : determine where manual pages are on this system echo " " case "$sysman" in '') - syspath='/usr/man/man1 /usr/man/man1 /usr/man/mann' - syspath="$syspath /usr/man/manl /usr/man/local/man1" + syspath='/usr/man/man1 /usr/man/mann /usr/man/manl /usr/man/local/man1' syspath="$syspath /usr/man/u_man/man1 /usr/share/man/man1" syspath="$syspath /usr/catman/u_man/man1 /usr/man/l_man/man1" syspath="$syspath /usr/local/man/u_man/man1 /usr/local/man/l_man/man1" - syspath="$syspath /usr/man/man.L /local/man/man1" - sysman=`./loc . $syspath` + syspath="$syspath /usr/man/man.L /local/man/man1 /usr/local/man/man1" + sysman=`./loc . /usr/man/man1 $syspath` ;; esac if $test -d "$sysman"; then @@ -1698,45 +2008,34 @@ else . ./myread cc="$ans" fi -case "$cc" in -gcc*) echo "Checking out which version of gcc" +echo "Checking if you are using GNU cc ..." >&4 $cat >gccvers.c <<EOM #include <stdio.h> -int main() -{ -char *v; -v = "unknown"; -#ifdef __GNUC__ -# ifdef __VERSION__ - v = __VERSION__; -# endif -#endif -switch((int) v[0]) - { - case '1': printf("1\n"); break; - case '2': printf("2\n"); break; - case '3': printf("3\n"); break; - default: break; - } +int main() { #ifdef __GNUC__ -return 0; +#ifdef __VERSION__ +printf("%s\n", __VERSION__); #else -return 1; +printf("%s\n", "1"); +#endif #endif +return 0; } EOM - if $cc -o gccvers gccvers.c >/dev/null 2>&1; then - gccversion=`./gccvers` - echo "You appear to have version $gccversion." - else - echo "Doesn't appear to be GNU cc." - fi - $rm -f gccvers* - if $test "$gccversion" = '1'; then - cpp=`./loc gcc-cpp $cpp $pth` - fi - ;; +if $cc -o gccvers gccvers.c >/dev/null 2>&1; then + gccversion=`./gccvers` + case "$gccversion" in + '') echo "You are not using GNU cc." ;; + *) echo "You are using GNU cc $gccversion." ;; + esac +else + echo "I can't compile the test program. I'll assume it's not GNU cc." +fi +$rm -f gccvers* +case "$gccversion" in +1*) cpp=`./loc gcc-cpp $cpp $pth` ;; esac + : decide how portable to be case "$d_portable" in "$define") dflt=y;; @@ -1776,7 +2075,7 @@ case "\$1" in ~*) if $test -f /bin/csh; then /bin/csh -f -c "glob \$1" - failed=$? + failed=\$? echo "" exit \$failed else @@ -1813,10 +2112,18 @@ already='' skip='' none_ok='' exp_file='' +nopath_ok='' orig_rp="$rp" orig_dflt="$dflt" case "$fn" in +*:*) + loc_file=`expr $fn : '.*:\(.*\)'` + fn=`expr $fn : '\(.*\):.*'` + ;; +esac + +case "$fn" in *~*) tilde=true;; esac case "$fn" in @@ -1831,11 +2138,14 @@ esac case "$fn" in *e*) exp_file=true;; esac +case "$fn" in +*p*) nopath_ok=true;; +esac case "$fn" in *f*) type='File';; *d*) type='Directory';; -*l*) type='Locate'; fn=`expr $fn : '.*:\(.*\)'`;; +*l*) type='Locate';; esac what="$type" @@ -1932,12 +2242,21 @@ while test "$type"; do ;; Locate) if test -d "$value"; then - echo "(Looking for $fn in directory $value.)" - value="$value/$fn" + echo "(Looking for $loc_file in directory $value.)" + value="$value/$loc_file" fi if test -f "$value"; then type='' fi + case "$nopath_ok" in + true) case "$value" in + */*) ;; + *) echo "Assuming $value will be in people's path." + type='' + ;; + esac + ;; + esac ;; esac @@ -1976,10 +2295,7 @@ EOSC : What should the include directory be ? echo " " $echo $n "Hmm... $c" -case "$usrinc" in -'') dflt='/usr/include';; -*) dflt=$usrinc;; -esac +dflt='/usr/include' incpath='' mips_type='' if $test -f /bin/mips && /bin/mips; then @@ -2005,15 +2321,157 @@ else $eunicefix mips fi echo " " +case "$usrinc" in +'') ;; +*) dflt="$usrinc";; +esac fn=d/ rp='Where are the include files you want to use?' . ./getfile usrinc="$ans" +: see how we invoke the C preprocessor +echo " " +echo "Now, how can we feed standard input to your C preprocessor..." >&4 +cat <<'EOT' >testcpp.c +#define ABC abc +#define XYZ xyz +ABC.XYZ +EOT +cd .. +echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin +chmod 755 cppstdin +wrapper=`pwd`/cppstdin +ok='false' +cd UU + +if $test "X$cppstdin" != "X" && \ + $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 +then + echo "You used to use $cppstdin $cppminus so we'll use that again." + case "$cpprun" in + '') echo "But let's see if we can live without a wrapper..." ;; + *) + if $cpprun $cpplast <testcpp.c >testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "(And we'll use $cpprun $cpplast to preprocess directly.)" + ok='true' + else + echo "(However, $cpprun $cpplast does not work, let's see...)" + fi + ;; + esac +else + case "$cppstdin" in + '') ;; + *) + echo "Good old $cppstdin $cppminus does not seem to be of any help..." + ;; + esac +fi + +if $ok; then + : nothing +elif echo 'Maybe "'"$cc"' -E" will work...'; \ + $cc -E <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ + $cc -E - <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus='-'; +elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ + $cc -P <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yipee, that works!" + x_cpp="$cc -P" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ + $cc -P - <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "At long last!" + x_cpp="$cc -P" + x_minus='-'; +elif echo 'No such luck, maybe "'$cpp'" will work...'; \ + $cpp <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "It works!" + x_cpp="$cpp" + x_minus=''; +elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ + $cpp - <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Hooray, it works! I was beginning to wonder." + x_cpp="$cpp" + x_minus='-'; +elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ + $wrapper <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + x_cpp="$wrapper" + x_minus='' + echo "Eureka!" +else + dflt='' + rp="No dice. I can't find a C preprocessor. Name one:" + . ./myread + x_cpp="$ans" + x_minus='' + $x_cpp <testcpp.c >testcpp.out 2>&1 + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "OK, that will do." >&4 + else +echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 + exit 1 + fi +fi + +case "$ok" in +false) + cppstdin="$x_cpp" + cppminus="$x_minus" + cpprun="$x_cpp" + cpplast="$x_minus" + set X $x_cpp + shift + case "$1" in + "$cpp") + echo "Perhaps can we force $cc -E using a wrapper..." + if $wrapper <testcpp.c >testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "Yup, we can." + cppstdin="$wrapper" + cppminus=''; + else + echo "Nope, we'll have to live without it..." + fi + ;; + esac + case "$cpprun" in + "$wrapper") + cpprun='' + cpplast='' + ;; + esac + ;; +esac + +case "$cppstdin" in +"$wrapper") ;; +*) $rm -f $wrapper;; +esac +$rm -f testcpp.c testcpp.out + : determine optimize, if desired, or use for debug flag also case "$optimize" in -' ') dflt="none";; -'') dflt="-g";; +' ') dflt='none';; +'') dflt='-O';; *) dflt="$optimize";; esac $cat <<EOH @@ -2034,17 +2492,16 @@ esac dflt='' case "$ccflags" in -'') case "$cc" in - *gcc*) if $test "$gccversion" = "1"; then - dflt='-fpcc-struct-return' - fi ;; +'') + case "$gccversion" in + 1*) dflt='-fpcc-struct-return' ;; esac case "$optimize" in *-g*) dflt="$dflt -DDEBUGGING";; esac - case "$cc" in - *gcc*) if test -d /etc/conf/kconfig.d && - $contains _POSIX_VERSION $usrinc/sys/unistd.h >/dev/null 2>&1 + case "$gccversion" in + 2*) if test -d /etc/conf/kconfig.d && + $contains _POSIX_VERSION $usrinc/sys/unistd.h >/dev/null 2>&1 then dflt="$dflt -posix" fi @@ -2104,10 +2561,11 @@ Your C compiler may want other flags. For this question you should include -I/whatever and -DWHATEVER flags and any other flags used by the C compiler, but you should NOT include libraries or ld flags like -lwhatever. If you want $package to honor its debug switch, you should include -DDEBUGGING here. +Your C compiler might also need additional flags, such as -D_POSIX_SOURCE, +-DHIDEMYMALLOC or -DCRIPPLED_CC. + To use no flags, specify the word "none". -Your C compiler might also need additional flags, such as -DJMPCLOBBER, --DHIDEMYMALLOC or -DCRIPPLED_CC. EOH set X $dflt shift @@ -2121,11 +2579,8 @@ esac : the following weeds options from ccflags that are of no interest to cpp cppflags="$ccflags" -case "$cc" in -*gcc*) case "$gccversion" in - 1) cppflags="$cppflags -D__GNUC__" ;; - esac - ;; +case "$gccversion" in +1*) cppflags="$cppflags -D__GNUC__" esac case "$mips_type" in '');; @@ -2133,17 +2588,44 @@ case "$mips_type" in esac case "$cppflags" in '');; -*) set X $cppflags +*) + echo " " + echo "Let me guess what the preprocessor flags are..." >&4 + set X $cppflags + shift cppflags='' - for flag + $cat >cpp.c <<'EOM' +#define BLURFL foo + +BLURFL xx LFRULB +EOM + previous='' + for flag in $* do - case $flag in - -D*|-I*|-traditional|-ansi|-nostdinc|-posix|-Xp) cppflags="$cppflags $flag";; + case "$flag" in + -*) ftry="$flag";; + *) ftry="$previous $flag";; esac + if $cppstdin -DLFRULB=bar $ftry $cppminus <cpp.c \ + >cpp1.out 2>/dev/null && \ + $cpprun -DLFRULB=bar $ftry $cpplast <cpp.c \ + >cpp2.out 2>/dev/null && \ + $contains 'foo.*xx.*bar' cpp1.out >/dev/null 2>&1 && \ + $contains 'foo.*xx.*bar' cpp2.out >/dev/null 2>&1 + then + cppflags="$cppflags $ftry" + previous='' + else + previous="$flag" + fi done + set X $cppflags + shift + cppflags=${1+"$@"} case "$cppflags" in - *-*) echo "(C preprocessor flags: $cppflags)";; + *-*) echo "They appear to be: $cppflags";; esac + $rm -f cpp.c cpp?.out ;; esac @@ -2152,8 +2634,14 @@ case "$ldflags" in '') if venix; then dflt='-i -z' else - dflt='none' + dflt='' fi + case "$ccflags" in + *-posix*) dflt="$dflt -posix" ;; + esac + case "$dflt" in + '') dflt='none' ;; + esac ;; *) dflt="$ldflags";; esac @@ -2166,41 +2654,72 @@ none) ldflags='';; esac rmlist="$rmlist pdp11" -: Initialize h_fcntl -h_fcntl=false - -: Initialize h_sysfile -h_sysfile=false - : Set private lib path case "$plibpth" in '') if mips; then plibpth="$incpath/usr/lib /usr/local/lib /usr/ccs/lib" fi;; esac -libpth="$plibpth $libpth" -: Now check and see which directories actually exist. -xxx='' -for yyy in $libpth +case "$libpth" in +' ') dlist='';; +'') dlist="$plibpth $glibpth";; +*) dlist="$libpth";; +esac + +: Now check and see which directories actually exist, avoiding duplicates +libpth='' +for xxx in $dlist do - if $test -d $yyy; then - xxx="$xxx $yyy" + if $test -d $xxx; then + case " $libpth " in + *" $xxx "*) ;; + *) libpth="$libpth $xxx";; + esac fi done -libpth="$xxx" -$cat <<EOM -Some systems have incompatible or broken versions of libraries. Where -should I look for libraries? -EOM +$cat <<'EOM' -dflt="$libpth" -echo " " +Some systems have incompatible or broken versions of libraries. Among +the directories listed in the question below, please remove any you +know not to be holding relevant libraries, and add any that are needed. +Say "none" for none. + +EOM +case "$libpth" in +'') dflt='none';; +*) + set X $libpth + shift + dflt=${1+"$@"} + ;; +esac rp="Directories to use for library searches?" . ./myread case "$ans" in none) libpth=' ';; *) libpth="$ans";; esac + +: compute shared library extension +case "$so" in +'') + if xxx=`./loc libc.sl X $libpth`; $test -f "$xxx"; then + dflt='sl' + else + dflt='so' + fi + ;; +*) dflt="$so";; +esac +$cat << EOM + +On some systems, shared libraries may be available. Answer 'none' if +you want to suppress searching of shared libraries. +EOM +rp='What is the file extension used for shared libraries?' +. ./myread +so="$ans" + : Looking for optional libraries echo " " echo "Checking for optional libraries..." >&4 @@ -2212,50 +2731,39 @@ case "$libswanted" in '') libswanted='c_s';; esac for thislib in $libswanted; do - case "$thislib" in - dbm) thatlib=ndbm;; - *_s) thatlib=NONE;; - *) thatlib=${thislib}_s;; - esac - xxx=`./loc lib$thislib.a X $libpth` - yyy=`./loc lib$thatlib.a X $libpth` - zzz=`./loc lib$thislib.so.[0-9]'*' X $libpth` - if $test -f $xxx; then + + if xxx=`./loc lib$thislib.$so.[0-9]'*' X $libpth`; $test -f "$xxx"; then + echo "Found -l$thislib (shared)." + case " $dflt " in + *"-l$thislib "*);; + *) dflt="$dflt -l$thislib";; + esac + elif xxx=`./loc lib$thislib.$so X $libpth` ; $test -f "$xxx"; then + echo "Found -l$thislib (shared)." + case " $dflt " in + *"-l$thislib "*);; + *) dflt="$dflt -l$thislib";; + esac + elif xxx=`./loc lib$thislib.a X $libpth`; $test -f "$xxx"; then echo "Found -l$thislib." - case "$dflt" in - *"-l$thislib "*|*-l$thislib|*"-l$thatlib "*|*-l$thatlib) ;; + case " $dflt " in + *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac - elif $test -f $yyy; then - echo "Found -l$thatlib." - case "$dflt" in - *"-l$thatlib "*|*-l$thatlib) ;; - *) dflt="$dflt -l$thatlib";; + elif xxx=`./loc lib${thislib}_s.a X $libpth`; $test -f "$xxx"; then + echo "Found -l${thislib}_s." + case " $dflt " in + *"-l$thislib "*);; + *) dflt="$dflt -l${thislib}_s";; esac - elif $test -f $zzz; then - echo "Found -$thislib." - case "$dflt" in - *"-l$thislib "*|*-l$thislib) ;; + elif xxx=`./loc Slib$thislib.a X $xlibpth`; $test -f "$xxx"; then + echo "Found -l$thislib." + case " $dflt " in + *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac else - xxx=`./loc Slib$thislib.a X $xlibpth` - yyy=`./loc Slib$thatlib.a X $xlibpth` - if $test -f $xxx; then - echo "Found -l$thislib." - case "$dflt" in - *"-l$thislib "*|*-l$thislib|*"-l$thatlib "*|*-l$thatlib) ;; - *) dflt="$dflt -l$thislib";; - esac - elif $test -f $yyy; then - echo "Found -l$thatlib." - case "$dflt" in - *"-l$thatlib "*|*-l$thatlib) ;; - *) dflt="$dflt -l$thatlib";; - esac - else - echo "No -l$thislib." - fi + echo "No -l$thislib." fi done set X $dflt @@ -2353,29 +2861,30 @@ case "$libc" in esac ;; esac -libpth="$plibpth $libpth" libnames=''; case "$libs" in '') ;; *) for thislib in $libs; do case "$thislib" in + -lc|-lc_s) + : Handle C library specially below. + ;; -l*) - thislib=`expr X$thislib : 'X-l\(.*\)'` - try=`./loc lib$thislib.a blurfl/dyick $libpth` - if test ! -f $try; then - try=`./loc lib$thislib blurfl/dyick $libpth` - if test ! -f $try; then - try=`./loc lib$thislib.so.'*' blurfl/dyick $libpth` - if test ! -f $try; then - try=`./loc $thislib blurfl/dyick $libpth` - if test ! -f $try; then - try=`./loc Slib$thislib.a blurfl/dyick $xlibpth` - if test ! -f $try; then - try='' - fi - fi - fi - fi + thislib=`echo X$thislib | $sed -e 's/^X//' -e 's/^-l//'` + if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib.a X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then + : + elif try=`./loc $thislib X $libpth`; $test -f "$try"; then + : + elif try=`./loc Slib$thislib.a X $xlibpth`; $test -f "$try"; then + : + else + try='' fi libnames="$libnames $try" ;; @@ -2387,10 +2896,11 @@ esac xxx=normal case "$libc" in unknown) - set /usr/ccs/lib/libc.so - $test -r $1 || set /usr/lib/libc.so - $test -r $1 || set /usr/shlib/libc.so - $test -r $1 || set /usr/lib/libc.so.[0-9]* + set /usr/ccs/lib/libc.$so + $test -r $1 || set /usr/lib/libc.$so + $test -r $1 || set /usr/shlib/libc.$so + $test -r $1 || set /usr/lib/libc.$so.[0-9]* + $test -r $1 || set /lib/libc.$so $test -r $1 || set /lib/libsys_s.a eval set \$$# ;; @@ -2476,13 +2986,12 @@ echo " " $sed 's/^/ /' libnames >&4 echo " " $echo $n "This may take a while...$c" >&4 - nm $nm_opt $* 2>/dev/null >libc.tmp $echo $n ".$c" $grep fprintf libc.tmp > libc.ptf xscan='eval "<libc.ptf $com >libc.list"; $echo $n ".$c" >&4' xrun='eval "<libc.tmp $com >libc.list"; echo "done" >&4' -if com="$sed -n -e 's/^.* [ADTS] *_[_.]*//p' -e 's/^.* [ADTS] //p'";\ +if com="$sed -n -e 's/^.* [ADTSI] *_[_.]*//p' -e 's/^.* [ADTSI] //p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun @@ -2519,6 +3028,10 @@ elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun +elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun else nm -p $* 2>/dev/null >libc.tmp com="$sed -n -e 's/^.* [ADTS] *_[_.]*//p' -e 's/^.* [ADTS] //p'";\ @@ -2639,143 +3152,65 @@ yes) esac;; esac' -: see how we invoke the C preprocessor -echo " " -echo "Now, how can we feed standard input to your C preprocessor..." >&4 -cat <<'EOT' >testcpp.c -#define ABC abc -#define XYZ xyz -ABC.XYZ -EOT -cd .. -echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin -chmod 755 cppstdin -wrapper=`pwd`/cppstdin -ok='false' -cd UU - -if $test "X$cppstdin" != "X" && \ - $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 -then - echo "You used to use $cppstdin $cppminus so we'll use that again." - case "$cpprun" in - '') echo "But let's see if we can live without a wrapper..." ;; - *) - if $cpprun $cpplast <testcpp.c >testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "(And we'll use $cpprun $cpplast to preprocess directly.)" - ok='true' - else - echo "(However, $cpprun $cpplast does not work, let's see...)" - fi - ;; - esac -else - case "$cppstdin" in - '') ;; - *) - echo "Good old $cppstdin $cppminus does not seem to be of any help..." - ;; - esac -fi +: see if gconvert exists +set gconvert d_gconvert +eval $inlibc -if $ok; then - : nothing -elif echo 'Maybe "'"$cc"' -E" will work...'; \ - $cc -E <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ - $cc -E - <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus='-'; -elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ - $cc -P <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yipee, that works!" - x_cpp="$cc -P" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ - $cc -P - <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "At long last!" - x_cpp="$cc -P" - x_minus='-'; -elif echo 'No such luck, maybe "'$cpp'" will work...'; \ - $cpp <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "It works!" - x_cpp="$cpp" - x_minus=''; -elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ - $cpp - <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Hooray, it works! I was beginning to wonder." - x_cpp="$cpp" - x_minus='-'; -elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ - $wrapper <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - x_cpp="$wrapper" - x_minus='' - echo "Eureka!" -else - dflt='' - rp="No dice. I can't find a C preprocessor. Name one:" - . ./myread - x_cpp="$ans" - x_minus='' - $x_cpp <testcpp.c >testcpp.out 2>&1 - if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "OK, that will do." >&4 - else -echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 - exit 1 - fi -fi +case "$d_gconvert" in +$define) + d_Gconvert="gconvert((x),(n),(t),(b))" + ;; +*) + : Maybe we can emulate it with gcvt. + set gcvt d_gcvt + eval $inlibc -case "$ok" in -false) - cppstdin="$x_cpp" - cppminus="$x_minus" - cpprun="$x_cpp" - cpplast="$x_minus" - set X $x_cpp - shift - case "$1" in - "$cpp") - echo "Perhaps can we force $cc -E using a wrapper..." - if $wrapper <testcpp.c >testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "Yup, we can." - cppstdin="$wrapper" - cppminus=''; + case "$d_gcvt" in + $define) + : Test whether gcvt drops a trailing decimal point + cat >try.c <<'EOP' +main() { +char buf[64]; +gcvt(1.0, 8, buf); +if (buf[0] != '1' || buf[1] != '\0') + return 1; +gcvt(0.0, 8, buf); +if (buf[0] != '0' || buf[1] != '\0') + return 1; +gcvt(-1.0, 8, buf); +if (buf[0] != '-' || buf[1] != '1' || buf[2] != '\0') + return 1; +return 0; +} +EOP + if $cc $ccflags $ldflags -o try try.c $libs > /dev/null 2>&1; then + if ./try; then + echo "Good, your gcvt() drops a trailing decimal point." + d_Gconvert="gcvt((x),(n),(b))" + else + echo "But your gcvt() keeps a trailing decimal point". + d_Gconvert='' + fi else - echo "Nope, we'll have to live without it..." + echo "Hmm. I can't compile the gcvt test program." + d_Gconvert='' fi + $rm -f try.c try ;; esac - case "$cpprun" in - "$wrapper") - cpprun='' - cpplast='' + case "$d_Gconvert" in + '') + echo "I'll use sprintf instead." >&4 + d_Gconvert='sprintf((b),"%.*g",(n),(x))' ;; esac - ;; esac -case "$cppstdin" in -"$wrapper") ;; -*) $rm -f $wrapper;; -esac -$rm -f testcpp.c testcpp.out +: Initialize h_fcntl +h_fcntl=false + +: Initialize h_sysfile +h_sysfile=false : determine filename position in cpp output echo " " @@ -2783,7 +3218,7 @@ echo "Computing filename position in cpp output for #include directives..." >&4 echo '#include <stdio.h>' > foo.c $cat >fieldn <<EOF $startsh -$cppstdin $cppminus $cppflags <foo.c 2>/dev/null | \ +$cppstdin $cppflags $cppminus <foo.c 2>/dev/null | \ $grep '^[ ]*#.*stdio\.h' | \ while read cline; do pos=1 @@ -2879,6 +3314,171 @@ EOCP esac $rm -f access* +: see if alarm exists +set alarm d_alarm +eval $inlibc + +: is AFS running? +echo " " +if test -d /afs; then + echo "AFS may be running... I'll be extra cautious then..." >&4 + afs=true +else + echo "AFS does not seem to be running..." >&4 + afs=false +fi + +: determine root of directory hierarchy where package will be installed. +case "$prefix" in +'') + dflt=`./loc . /usr/local /usr/local /local /opt /usr` + ;; +*) + dflt="$prefix" + ;; +esac +$cat <<EOM + +By default, $package will be installed in $dflt/bin, manual +pages under $dflt/man, etc..., i.e. with $dflt as prefix for +all installation directories. Typically set to /usr/local, but you +may choose /usr if you wish to install $package among your system +binaries. If you wish to have binaries under /bin but manual pages +under /usr/local/man, that's ok: you will be prompted separately +for each of the installation directories, the prefix being only used +to set defaults. + +EOM +fn=d~ +rp='Installation prefix to use?' +. ./getfile +prefix="$ans" + +: determine where private executables go +case "$privlib" in +'') + dflt=$prefix/lib/$package + ;; +*) dflt="$privlib" + ;; +esac +$cat <<EOM + +There are some auxiliary files for $package that need to be put into a +private library directory that is accessible by everyone. + +EOM +fn=d~+ +rp='Pathname where private library files will reside?' +. ./getfile +privlib="$ans" +privlibexp="$ansexp" +if $afs; then + $cat <<EOM + +Since you are running AFS, I need to distinguish the directory in which +private files reside from the directory in which they are installed (and from +which they are presumably copied to the former directory by occult means). + +EOM + case "$installprivlib" in + '') dflt=`echo $privlibexp | sed 's#^/afs/#/afs/.#'`;; + *) dflt="$installprivlib";; + esac + fn=de~ + rp='Where will private files be installed?' + . ./getfile + installprivlib="$ans" +else + installprivlib="$privlibexp" +fi + +: determine where public architecture dependent libraries go +case "$archname" in +'') tpath=`echo $PATH | sed -e 's/:/ /g'` + xxx=`./loc arch blurfl $tpath` + if test -f "$xxx"; then + tarchname=`arch` + archname="${tarchname}-${osname}" + else + archname="$osname" + fi + ;; +esac +case "$privlib" in +'') dflt=`./loc . "." $prefix/lib /usr/local/lib /usr/lib /lib`;; +*) dflt="$privlib/$archname";; +esac +fn=d~ +cat <<EOM + +$package contains architecture-dependent library files. If you are +sharing libraries in a heterogeneous environment, you might store +these files in a separate location. Otherwise, you can just include +them with the rest of the public library files. + +EOM +rp='Where do you want to put the public architecture-dependent libraries?' +. ./getfile +archlib="$ans" +archlibexp="$ansexp" + +if $afs; then + $cat <<EOM + +Since you are running AFS, I need to distinguish the directory in which +private files reside from the directory in which they are installed (and from +which they are presumably copied to the former directory by occult means). + +EOM + case "$installarchlib" in + '') dflt=`echo $archlibexp | sed 's#^/afs/#/afs/.#'`;; + *) dflt="$installarchlib";; + esac + fn=de~ + rp='Where will architecture-dependent library files be installed?' + . ./getfile + installarchlib="$ans" +else + installarchlib="$archlibexp" +fi +if $test X"$archlib" = X"$privlib"; then + d_archlib="$undef" +else + d_archlib="$define" +fi + + +: function used to set $1 to $val +setvar='var=$1; eval "was=\$$1"; td=$define; tu=$undef; +case "$val$was" in +$define$undef) . whoa; eval "$var=\$td";; +$undef$define) . whoa; eval "$var=\$tu";; +*) eval "$var=$val";; +esac' + +: Look for GNUC style attribute checking +echo " " +echo "Checking whether your compiler can handle __attribute__ ..." >&4 +$cat >attrib.c <<'EOCP' +void croak (char* pat,...) __attribute__((format(printf,1,2),noreturn)); +EOCP +if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then + if $contains 'warning' attrib.out >/dev/null 2>&1; then + echo "Your C compiler doesn't fully support __attribute__. ." + val="$undef" + else + echo "Your C compiler supports __attribute__. ." + val="$define" + fi +else + echo "Your C compiler doesn't seem to understand __attribute__. ." + val="$undef" +fi +set d_attrib +eval $setvar +$rm -f attrib* + : see if bcmp exists set bcmp d_bcmp eval $inlibc @@ -2887,6 +3487,51 @@ eval $inlibc set bcopy d_bcopy eval $inlibc +: see if setpgrp exists +set setpgrp d_setpgrp +eval $inlibc + +: see which flavor of setpgrp is in use +case "$d_setpgrp" in +"$define") + echo " " + $cat >set.c <<EOP +main() +{ + if (getuid() == 0) { + printf("(I see you are running Configure as super-user...)\n"); + setuid(1); + } + if (-1 == setpgrp(1, 1)) + exit(1); + exit(0); +} +EOP + if $cc $ccflags -o set $ldflags set.c $libs >/dev/null 2>&1; then + ./set 2>/dev/null + case $? in + 0) echo "You have to use setpgrp() instead of setpgrp(pid, pgrp)." >&4 + val="$undef";; + *) echo "You have to use setpgrp(pid, pgrp) instead of setpgrp()." >&4 + val="$define";; + esac + else + if usg; then + xxx="USG one, i.e. you use setpgrp()." + val="$undef" + else + xxx="BSD one, i.e. you use setpgrp(pid, pgrp)." + val="$define" + fi + echo "Assuming your setpgrp is a $xxx" >&4 + fi + ;; +*) val="$undef";; +esac +set d_bsdpgrp +eval $setvar +$rm -f set set.c + : see if bzero exists set bzero d_bzero eval $inlibc @@ -2919,39 +3564,30 @@ rp="What is the size of an integer (in bytes)?" intsize="$ans" $rm -f try.c try -: function used to set $1 to $val -setvar='var=$1; eval "was=\$$1"; td=$define; tu=$undef; -case "$val$was" in -$define$undef) . whoa; eval "$var=\$td";; -$undef$define) . whoa; eval "$var=\$tu";; -*) eval "$var=$val";; -esac' - : check for ability to cast large floats to 32-bit ints. echo " " echo 'Checking whether your C compiler can cast large floats to int32.' >&4 if $test "$intsize" -eq 4; then - xxx=int + xxx=int else - xxx=long + xxx=long fi - $cat >try.c <<EOCP #include <sys/types.h> #include <signal.h> blech() { exit(3); } main() { - $xxx i32; + $xxx i32; double f; int result = 0; signal(SIGFPE, blech); f = (double) 0x7fffffff; f = 10 * f; - i32 = ( $xxx )f; + i32 = ($xxx) f; - if (i32 != ( $xxx )f) + if (i32 != ($xxx) f) result |= 1; exit(result); } @@ -2960,6 +3596,7 @@ if $cc -o try $ccflags try.c >/dev/null 2>&1; then ./try yyy=$? else + echo "(I can't seem to compile the test program--assuming it can't)" yyy=1 fi case "$yyy" in @@ -2973,6 +3610,7 @@ esac set d_casti32 eval $setvar $rm -f try try.* + : check for ability to cast negative floats to unsigned echo " " echo 'Checking whether your C compiler can cast negative float to unsigned.' >&4 @@ -3094,6 +3732,14 @@ val=$val2 set d_charvspr eval $setvar +: see if chown exists +set chown d_chown +eval $inlibc + +: see if chroot exists +set chroot d_chroot +eval $inlibc + : see if chsize exists set chsize d_chsize eval $inlibc @@ -3160,6 +3806,79 @@ esac set d_csh eval $setvar +: see if cuserid exists +set cuserid d_cuserid +eval $inlibc + +: define an alternate in-header-list? function +inhdr='echo " "; td=$define; tu=$undef; yyy=$@; +cont=true; xxf="echo \"<\$1> found.\" >&4"; +case $# in 2) xxnf="echo \"<\$1> NOT found.\" >&4";; +*) xxnf="echo \"<\$1> NOT found, ...\" >&4";; +esac; +case $# in 4) instead=instead;; *) instead="at last";; esac; +while $test "$cont"; do + xxx=`./findhdr $1` + var=$2; eval "was=\$$2"; + if $test "$xxx" && $test -r "$xxx"; + then eval $xxf; + eval "case \"\$$var\" in $undef) . whoa; esac"; eval "$var=\$td"; + cont=""; + else eval $xxnf; + eval "case \"\$$var\" in $define) . whoa; esac"; eval "$var=\$tu"; fi; + set $yyy; shift; shift; yyy=$@; + case $# in 0) cont="";; + 2) xxf="echo \"but I found <\$1> $instead.\" >&4"; + xxnf="echo \"and I did not find <\$1> either.\" >&4";; + *) xxf="echo \"but I found <\$1\> instead.\" >&4"; + xxnf="echo \"there is no <\$1>, ...\" >&4";; + esac; +done; +while $test "$yyy"; +do set $yyy; var=$2; eval "was=\$$2"; + eval "case \"\$$var\" in $define) . whoa; esac"; eval "$var=\$tu"; + set $yyy; shift; shift; yyy=$@; +done' + +: see if this is a limits.h system +set limits.h i_limits +eval $inhdr + +: see if this is a float.h system +set float.h i_float +eval $inhdr + +: See if number of significant digits in a double precision number is known +echo " " +$cat >dbl_dig.c <<EOM +#$i_limits I_LIMITS +#$i_float I_FLOAT +#ifdef I_LIMITS +#include <limits.h> +#endif +#ifdef I_FLOAT +#include <float.h> +#endif +#ifdef DBL_DIG +printf("Contains DBL_DIG"); +#endif +EOM +$cppstdin $cppflags $cppminus < dbl_dig.c >dbl_dig.E 2>/dev/null +if $contains 'DBL_DIG' dbl_dig.E >/dev/null 2>&1; then + echo "DBL_DIG found." >&4 + val="$define" +else + echo "DBL_DIG NOT found." >&4 + val="$undef" +fi +$rm -f dbl_dig.? +set d_dbl_dig +eval $setvar + +: see if difftime exists +set difftime d_difftime +eval $inlibc + : see if this is a dirent system echo " " if xinc=`./findhdr dirent.h`; $test "$xinc"; then @@ -3178,6 +3897,42 @@ fi set i_dirent eval $setvar +: Look for type of directory structure. +echo " " +$cppstdin $cppflags $cppminus < "$xinc" > try.c + +case "$direntrytype" in +''|' ') + case "$i_dirent" in + $define) guess1='struct dirent' ;; + *) guess1='struct direct' ;; + esac + ;; +*) guess1="$direntrytype" + ;; +esac + +case "$guess1" in +'struct dirent') guess2='struct direct' ;; +*) guess2='struct dirent' ;; +esac + +if $contains "$guess1" try.c >/dev/null 2>&1; then + direntrytype="$guess1" + echo "Your directory entries are $direntrytype." >&4 +elif $contains "$guess2" try.c >/dev/null 2>&1; then + direntrytype="$guess2" + echo "Your directory entries seem to be $direntrytype." >&4 +else + echo "I don't recognize your system's directory entries." >&4 + rp="What type is used for directory entries on this system?" + dflt="$guess1" + . ./myread + direntrytype="$ans" +fi +$rm -f try.c + + : see if the directory entry stores field length echo " " if $contains 'd_namlen' $xinc >/dev/null 2>&1; then @@ -3190,27 +3945,381 @@ fi set d_dirnamlen eval $setvar -: now see if they want to do setuid emulation -case "$d_dosuid" in -'') dflt=n;; -"$undef") dflt=n;; -*) dflt=y;; +: see if dlerror exists +set dlerror d_dlerror +eval $inlibc + +: see if dld is available +set dld.h i_dld +eval $inhdr + +: see if dlopen exists +set dlopen d_dlopen +eval $inlibc + +: determine which dynamic loading, if any, to compile in +echo " " +dldir="ext/DynaLoader" +case "$usedl" in +$define|y|true) + dflt='y' + usedl="$define" + ;; +$undef|n|false) + dflt='n' + usedl="$undef" + ;; +*) + dflt='n' + case "$d_dlopen" in + define) dflt='y' ;; + esac + case "$i_dld" in + define) dflt='y' ;; + esac + : Does a dl_xxx.xs file exist for this operating system + $test -f ../$dldir/dl_${osname}.xs && dflt='y' + ;; +esac +rp="Do you wish to use dynamic loading?" +. ./myread +usedl="$ans" +case "$ans" in +y*) usedl="$define" + case "$dlsrc" in + '') + if $test -f ../$dldir/dl_${osname}.xs ; then + dflt="$dldir/dl_${osname}.xs" + elif $test "$d_dlopen" = "$define" ; then + dflt="$dldir/dl_dlopen.xs" + elif $test "$i_dld" = "$define" ; then + dflt="$dldir/dl_dld.xs" + else + dflt='' + fi + ;; + *) dflt="$dldir/$dlsrc" + ;; + esac + echo "The following dynamic loading files are available:" + : Can not go over to $dldir because getfile has path hard-coded in. + cd ..; ls -C $dldir/dl*.xs; cd UU + rp="Source file to use for dynamic loading" + fn="fne~" + . ./getfile + usedl="$define" + : emulate basename + dlsrc=`echo $ans | $sed -e 's@.*/\([^/]*\)$@\1@'` + $cat << EOM + +Some systems may require passing special flags to $cc -c to +compile modules that will be used to create a shared library. +To use no flags, say "none". + +EOM + case "$cccdlflags" in + ''|' ') case "$osname" in + hpux) dflt='+z' ;; + next) dflt='none' ;; + sunos) + case "$cc" in + *gcc*) dflt='-fpic' ;; + *) dflt='-pic' ;; + esac + ;; + solaris) + case "$cc" in + *gcc*) dflt='-fpic' ;; + *) dflt='-K pic' ;; + esac + ;; + *) dflt='none' ;; + esac + ;; + *) dflt="$cccdlflags" ;; + esac + rp="Any special flags to pass to $cc -c to compile shared library modules?" + . ./myread + case "$ans" in + none) cccdlflags='' ;; + *) cccdlflags="$ans" ;; + esac + + cat << 'EOM' + +Some systems may require passing special flags to ld to create a shared +library. If your ld flags include -L/local/path options to locate libraries +outside your loader's normal search path, you may need to specify those +-L options here as well. +To use no flags, say "none". + +EOM + case "$lddlflags" in + ''|' ') case "$osname" in + hpux) dflt='-b' ;; + next) dflt='none' ;; + solaris) dflt='-G' ;; + sunos) dflt='none' ;; + *) dflt='none' ;; + esac + ;; + *) dflt="$lddlflags" ;; + esac + rp="Any special flags to pass to ld to create a shared library?" + . ./myread + case "$ans" in + none) lddlflags='' ;; + *) lddlflags="$ans" ;; + esac + + cat <<EOM + +Some systems may require passing special flags to $cc to indicate that +the resulting executable will use dynamic linking. To use no flags, +say "none". + +EOM + case "$ccdlflags" in + ''|' ') + case "$osname" in + hpux) dflt='none' ;; + next) dflt='none' ;; + sunos) dflt='none' ;; + *) dflt='none' ;; + esac + ;; + *) dflt="$ccdlflags" + ;; + esac + rp="Any special flags to pass to $cc to use dynamic loading?" + . ./myread + case "$ans" in + none) ccdlflags='' ;; + *) ccdlflags="$ans" ;; + esac + ;; +*) usedl="$undef" + dlsrc='dl_none.xs' + lddlflags='' + ccdlflags='' + ;; +esac + +: see if dlfcn is available +set dlfcn.h i_dlfcn +eval $inhdr + +case "$usedl" in +$define|y|true) + $cat << EOM + +On a few systems, the dynamically loaded modules that perl generates and uses +will need a different extension then shared libs. The default will probably +be appropriate. + +EOM + case "$dlext" in + '') dflt="$so" ;; + *) dflt="$dlext" ;; + esac + rp='What is the extension of dynamically loaded modules' + . ./myread + dlext="$ans" + ;; +*) + dlext="none" + ;; +esac + +: Check if dlsym need a leading underscore +echo " " +val="$undef" + +case "$dlsrc" in +dl_dlopen.xs) + echo "Checking whether your dlsym() needs a leading underscore ..." >&4 + $cat >dyna.c <<'EOM' +fred () { } +EOM + +$cat >fred.c<<EOM + +#include <stdio.h> +#$i_dlfcn I_DLFCN +#ifdef I_DLFCN +#include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */ +#else +#include <sys/types.h> +#include <nlist.h> +#include <link.h> +#endif + +extern int fred() ; + +main() +{ + void * handle ; + void * symbol ; +#ifndef RTLD_LAZY + int mode = 1 ; +#else + int mode = RTLD_LAZY ; +#endif + handle = dlopen("./dyna.$dlext", mode) ; + if (handle == NULL) { + printf ("1\n") ; + exit(0); + } + symbol = dlsym(handle, "fred") ; + if (symbol == NULL) { + /* try putting a leading underscore */ + symbol = dlsym(handle, "_fred") ; + if (symbol == NULL) { + printf ("2\n") ; + exit(0); + } + printf ("3\n") ; + } + else + printf ("4\n") ; + exit(0); +} +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 + 1) echo "Test program failed using dlopen." >&4 + echo "Perhaps you should not use dynamic loading." >&4;; + 2) echo "Test program failed using dlsym." >&4 + echo "Perhaps you should not use dynamic loading." >&4;; + 3) echo "dlsym needs a leading underscore" >&4 + val="$define" ;; + 4) echo "dlsym doesn't need a leading underscore." >&4;; + esac + else + echo "I can't compile and run the test program." >&4 + fi + ;; esac + +$rm -f fred fred.? dyna.$dlext dyna.? + +set d_dlsymun +eval $setvar + +: see if setuid scripts can be secure cat <<EOM - -Some sites have disabled setuid #! scripts because of a bug in the kernel -that prevents them from being secure. If you are on such a system, the -setuid/setgid bits on scripts are currently useless. It is possible for -$package to detect those bits and emulate setuid/setgid in a secure fashion -until a better solution is devised for the kernel problem. + +Some kernels have a bug that prevents setuid #! scripts from being +secure. Some sites have disabled setuid #! scripts because of this. + +First let's decide if your kernel supports secure setuid #! scripts. +(If setuid #! scripts would be secure but have been disabled anyway, +don't say that they are secure if asked.) EOM -rp="Do you want to do setuid/setgid emulation?" -. ./myread -case "$ans" in -y*) d_dosuid="$define";; -*) d_dosuid="$undef";; + +val="$undef" +if $test -d /dev/fd; then + echo "#!$ls" >reflect + chmod +x,u+s reflect + ./reflect >flect 2>&1 + if $contains "/dev/fd" flect >/dev/null; then + echo "Congratulations, your kernel has secure setuid scripts!" >&4 + val="$define" + else + $cat <<EOM +If you are not sure if they are secure, I can check but I'll need a +username and password different from the one you are using right now. +If you don't have such a username or don't want me to test, simply +enter 'none'. + +EOM + rp='Other username to test security of setuid scripts with?' + dflt='none' + . ./myread + case "$ans" in + n|none) + case "$d_suidsafe" in + '') echo "I'll assume setuid scripts are *not* secure." >&4 + dflt=n;; + "$undef") + echo "Well, the $hint value is *not* secure." >&4 + dflt=n;; + *) echo "Well, the $hint value *is* secure." >&4 + dflt=y;; + esac + ;; + *) $rm -f reflect flect + echo "#!$ls" >reflect + chmod +x,u+s reflect + echo >flect + chmod a+w flect + echo '"su" will (probably) prompt you for '"$ans's password." + su $ans -c './reflect >flect' + if $contains "/dev/fd" flect >/dev/null; then + echo "Okay, it looks like setuid scripts are secure." >&4 + dflt=y + else + echo "I don't think setuid scripts are secure." >&4 + dflt=n + fi + ;; + esac + rp='Does your kernel have *secure* setuid scripts?' + . ./myread + case "$ans" in + [yY]*) val="$define";; + *) val="$undef";; + esac + fi +else + echo "I don't think setuid scripts are secure (no /dev/fd directory)." >&4 + val="$undef" +fi +set d_suidsafe +eval $setvar + +$rm -f reflect flect + +: now see if they want to do setuid emulation +cat <<EOM + +Some systems have disabled setuid scripts, especially systems where +setuid scripts cannot be secure. On systems where setuid scripts have +been disabled, the setuid/setgid bits on scripts are currently +useless. It is possible for $package to detect those bits and emulate +setuid/setgid in a secure fashion. This emulation will only work if +setuid scripts have been disabled in your kernel. + +EOM +val="$undef" +case "$d_suidsafe" in +"$define") + val="$undef" + echo "No need to emulate SUID scripts since they are secure here." >& 4 + ;; +*) + case "$d_dosuid" in + "$define") dflt=y ;; + *) dflt=n ;; + esac + rp="Do you want to do setuid/setgid emulation?" + . ./myread + case "$ans" in + [yY]*) val="$define";; + *) val="$undef";; + esac + ;; esac +set d_dosuid +eval $setvar + +: see if drem exists +set drem d_drem +eval $inlibc : see if dup2 exists set dup2 d_dup2 @@ -3228,6 +4337,10 @@ eval $inlibc set fcntl d_fcntl eval $inlibc +: see if fgetpos exists +set fgetpos d_fgetpos +eval $inlibc + : see if we can have long filenames echo " " rmlist="$rmlist /tmp/cf$$" @@ -3275,10 +4388,34 @@ $rm -rf /tmp/cf$$ 123456789abcde* set flock d_flock eval $inlibc +: see if fmod exists +set fmod d_fmod +eval $inlibc + +: see if fork exists +set fork d_fork +eval $inlibc + +: see if pathconf exists +set pathconf d_pathconf +eval $inlibc + +: see if fpathconf exists +set fpathconf d_fpathconf +eval $inlibc + +: see if fsetpos exists +set fsetpos d_fsetpos +eval $inlibc + : see if gethostent exists set gethostent d_gethent eval $inlibc +: see if getlogin exists +set getlogin d_getlogin +eval $inlibc + : see if getpgrp exists set getpgrp d_getpgrp eval $inlibc @@ -3287,97 +4424,135 @@ eval $inlibc set getpgrp2 d_getpgrp2 eval $inlibc +: see if getppid exists +set getppid d_getppid +eval $inlibc + : see if getpriority exists set getpriority d_getprior eval $inlibc -: define an alternate in-header-list? function -inhdr='echo " "; td=$define; tu=$undef; yyy=$@; -cont=true; xxf="echo \"<\$1> found.\" >&4"; -case $# in 2) xxnf="echo \"<\$1> NOT found.\" >&4";; -*) xxnf="echo \"<\$1> NOT found, ...\" >&4";; -esac; -case $# in 4) instead=instead;; *) instead="at last";; esac; -while $test "$cont"; do - xxx=`./findhdr $1` - var=$2; eval "was=\$$2"; - if $test "$xxx" && $test -r "$xxx"; - then eval $xxf; - eval "case \"\$$var\" in $undef) . whoa; esac"; eval "$var=\$td"; - cont=""; - else eval $xxnf; - eval "case \"\$$var\" in $define) . whoa; esac"; eval "$var=\$tu"; fi; - set $yyy; shift; shift; yyy=$@; - case $# in 0) cont="";; - 2) xxf="echo \"but I found <\$1> $instead.\" >&4"; - xxnf="echo \"and I did not find <\$1> either.\" >&4";; - *) xxf="echo \"but I found <\$1\> instead.\" >&4"; - xxnf="echo \"there is no <\$1>, ...\" >&4";; - esac; -done; -while $test "$yyy"; -do set $yyy; var=$2; eval "was=\$$2"; - eval "case \"\$$var\" in $define) . whoa; esac"; eval "$var=\$tu"; - set $yyy; shift; shift; yyy=$@; -done' +: see if group exists +set group d_group +eval $inlibc : see if this is a netinet/in.h or sys/in.h system set netinet/in.h i_niin sys/in.h i_sysin eval $inhdr : see if htonl --and friends-- exists -set htonl d_htonl +val='' +set htonl val eval $inlibc + : Maybe they are macros. -case "$d_htonl" in -'define') ;; -*) cat > try.c <<EOM +case "$val" in +$undef) + $cat >htonl.c <<EOM #include <stdio.h> #include <sys/types.h> #$i_niin I_NETINET_IN #$i_sysin I_SYS_IN #ifdef I_NETINET_IN -# include <netinet/in.h> +#include <netinet/in.h> #endif #ifdef I_SYS_IN -# include <sys/in.h> +#include <sys/in.h> +#endif +#ifdef htonl +printf("Defined as a macro."); #endif -int main() -{ - int x; - printf("x = ", htonl(7)); -} EOM - if $cc $ccflags -c try.c >/dev/null 2>&1; then - d_htonl="$define" - echo "But it seems to be defined as a macro." - fi - $rm -f try.* try - ;; + $cppstdin $cppflags $cppminus < htonl.c >htonl.E 2>/dev/null + if $contains 'Defined as a macro' htonl.E >/dev/null 2>&1; then + val="$define" + echo "But it seems to be defined as a macro." >&4 + fi + $rm -f htonl.? + ;; esac +set d_htonl +eval $setvar + +: see which of string.h or strings.h is needed +echo " " +strings=`./findhdr string.h` +if $test "$strings" && $test -r "$strings"; then + echo "Using <string.h> instead of <strings.h>." >&4 + val="$define" +else + val="$undef" + strings=`./findhdr strings.h` + if $test "$strings" && $test -r "$strings"; then + echo "Using <strings.h> instead of <string.h>." >&4 + else + echo "No string header found -- You'll surely have problems." >&4 + fi +fi +set i_string +eval $setvar +case "$i_string" in +"$undef") strings=`./findhdr strings.h`;; +*) strings=`./findhdr string.h`;; +esac + +: index or strchr +echo " " +if set index val -f; eval $csym; $val; then + if set strchr val -f d_strchr; eval $csym; $val; then + if $contains strchr "$strings" >/dev/null 2>&1 ; then + val="$define" + vali="$undef" + echo "strchr() found." >&4 + else + val="$undef" + vali="$define" + echo "index() found." >&4 + fi + else + val="$undef" + vali="$define" + echo "index() found." >&4 + fi +else + if set strchr val -f d_strchr; eval $csym; $val; then + val="$define" + vali="$undef" + echo "strchr() found." >&4 + else + echo "No index() or strchr() found!" >&4 + val="$undef" + vali="$undef" + fi +fi +set d_strchr; eval $setvar +val="$vali" +set d_index; eval $setvar + : Look for isascii echo " " $cat >isascii.c <<'EOCP' #include <stdio.h> #include <ctype.h> main() { - int c = 'A'; + int c = 'A'; if (isascii(c)) - exit(0); + exit(0); else - exit(1); + exit(1); } EOCP -if $cc $cppflags -o isascii isascii.c >/dev/null 2>&1 ; then - echo "isascii() found." - val="$define" +if $cc $ccflags $ldflags -o isascii isascii.c $libs >/dev/null 2>&1 ; then + echo "isascii() found." >&4 + val="$define" else - echo "isascii() NOT found." - val="$undef" + echo "isascii() NOT found." >&4 + val="$undef" fi set d_isascii eval $setvar $rm -f isascii* + : see if killpg exists set killpg d_killpg eval $inlibc @@ -3386,10 +4561,71 @@ eval $inlibc set link d_link eval $inlibc +: see if stdio is really std +echo " " +xxx=`./findhdr stdio.h` +if $contains 'char.*_ptr;' "$xxx" >/dev/null 2>&1 ; then + if $contains '_cnt;' "$xxx" >/dev/null 2>&1 ; then + echo "Your stdio is pretty std." >&4 + val="$define" + else + echo "Your stdio isn't very std." >&4 + val="$undef" + fi +else + echo "Your stdio isn't very std." >&4 + val="$undef" +fi +set d_stdstdio +eval $setvar + +: see if stdio is like that in linux +case "$d_stdstdio" in +"$undef") + echo " " + xxx=`./findhdr stdio.h` + $cppstdin $cppflags $cppminus < "$xxx" > stdio.E + if $contains 'char.*_IO_read_base' stdio.E >/dev/null 2>&1 && \ + $contains '_IO_read_ptr' stdio.E >/dev/null 2>&1 && \ + $contains '_IO_read_end' stdio.E >/dev/null 2>&1 ; then + echo "Your stdio looks like linux." >&4 + val="$define" + else + echo "You don't have linux stdio, either." >&4 + val="$undef" + fi + $rm -f stdio.E + ;; +*) val="$undef" ;; +esac + +set d_linuxstd +eval $setvar + +: see if localeconv exists +set localeconv d_locconv +eval $inlibc + +: see if lockf exists +set lockf d_lockf +eval $inlibc + : see if lstat exists set lstat d_lstat eval $inlibc +: see if mblen exists +set mblen d_mblen +eval $inlibc + +: see if mbstowcs exists +set mbstowcs d_mbstowcs +eval $inlibc + +: see if mbtowc exists +set mbtowc d_mbtowc +eval $inlibc + : see if memcmp exists set memcmp d_memcmp eval $inlibc @@ -3410,6 +4646,14 @@ eval $inlibc set mkdir d_mkdir eval $inlibc +: see if mkfifo exists +set mkfifo d_mkfifo +eval $inlibc + +: see if mktime exists +set mktime d_mktime +eval $inlibc + : see if msgctl exists set msgctl d_msgctl eval $inlibc @@ -3443,43 +4687,56 @@ fi set d_msg eval $setvar +: see if this is a malloc.h system +set malloc.h i_malloc +eval $inhdr + : determine which malloc to compile in -: Old versions had dflt='y' only for bsd or v7. echo " " case "$usemymalloc" in -'') - if bsd || v7; then - dflt='y' - else - dflt='y' - fi - ;; -*) dflt="$usemymalloc" - ;; +''|y*|true) dflt='y' ;; +n*|false) dflt='n' ;; +*) dflt="$usemymalloc" ;; esac rp="Do you wish to attempt to use the malloc that comes with $package?" . ./myread usemymalloc="$ans" case "$ans" in -y*) mallocsrc='malloc.c' - mallocobj='malloc.o' - d_mymalloc="$define" - ;; -*) mallocsrc='' - mallocobj='' - d_mymalloc="$undef" - ;; +y*|true) + usemymalloc='y' + mallocsrc='malloc.c' + mallocobj='malloc.o' + d_mymalloc="$define" + case "$libs" in + *-lmalloc*) + : Remove malloc from list of libraries to use + echo "Removing unneeded -lmalloc from library list" >&4 + set `echo X $libs | $sed -e 's/-lmalloc / /' -e 's/-lmalloc$//'` + shift + libs="$*" + echo "libs = $libs" >&4 + ;; + esac + ;; +*) + usemymalloc='n' + mallocsrc='' + mallocobj='' + d_mymalloc="$undef" + ;; esac : compute the type returned by malloc echo " " case "$malloctype" in '') - if $test `./findhdr malloc.h`; then - echo "#include <malloc.h>" > malloc.c - fi + $cat >malloc.c <<END +#$i_malloc I_MALLOC +#include <stdio.h> +#include <sys/types.h> +#ifdef I_MALLOC #include <malloc.h> - $cat >>malloc.c <<'END' +#endif void *malloc(); END if $cc $ccflags -c malloc.c >/dev/null 2>&1; then @@ -3492,57 +4749,8 @@ END esac echo "Your system wants malloc to return '$malloctype', it would seem." >&4 -socketlib='' -sockethdr='' -: see whether socket exists -echo " " -$echo $n "Hmm... $c" >&4 -if set socket val -f d_socket; eval $csym; $val; then - echo "Looks like you have Berkeley networking support." >&4 - d_socket="$define" - if set setsockopt val -f; eval $csym; $val; then - d_oldsock="$undef" - else - echo "...but it uses the old 4.1c interface, rather than 4.2" >&4 - d_oldsock="$define" - fi -else - if $contains socklib libc.list >/dev/null 2>&1; then - echo "Looks like you have Berkeley networking support." >&4 - d_socket="$define" - : we will have to assume that it supports the 4.2 BSD interface - d_oldsock="$undef" - else - echo "You don't have Berkeley networking in libc.a..." >&4 - if test -f /usr/lib/libnet.a; then - ( (nm $nm_opt /usr/lib/libnet.a | eval $nm_extract) || \ - ar t /usr/lib/libnet.a) 2>/dev/null >> libc.list - if $contains socket libc.list >/dev/null 2>&1; then - echo "...but the Wollongong group seems to have hacked it in." >&4 - socketlib="-lnet" - sockethdr="-I/usr/netinclude" - d_socket="$define" - if $contains setsockopt libc.list >/dev/null 2>&1; then - d_oldsock="$undef" - else - echo "...using the old 4.1c interface, rather than 4.2" >&4 - d_oldsock="$define" - fi - else - echo "or even in libnet.a, which is peculiar." >&4 - d_socket="$undef" - d_oldsock="$undef" - fi - else - echo "or anywhere else I see." >&4 - d_socket="$undef" - d_oldsock="$undef" - fi - fi -fi - -: see if socketpair exists -set socketpair d_sockpair +: see if nice exists +set nice d_nice eval $inlibc : Locate the flags for 'open()' @@ -3595,6 +4803,18 @@ set d_open3 eval $setvar $rm -f open3* +: see if passwd exists +set passwd d_passwd +eval $inlibc + +: see if pause exists +set pause d_pause +eval $inlibc + +: see if pipe exists +set pipe d_pipe +eval $inlibc + : see if this is a pwd system echo " " xxx=`./findhdr pwd.h` @@ -3654,6 +4874,10 @@ eval $inlibc set rewinddir d_rewinddir eval $inlibc +: see if readlink exists +set readlink d_readlink +eval $inlibc + : see if rename exists set rename d_rename eval $inlibc @@ -3676,6 +4900,7 @@ char *b; int len; int off; int align; + bcopy("abcdefghijklmnopqrstuvwxyz0123456789", abc, 36); for (align = 7; align >= 0; align--) { @@ -3693,7 +4918,7 @@ for (align = 7; align >= 0; align--) { exit(0); } EOCP - if $cc foo.c -o safebcpy $ccflags $libs >/dev/null 2>&1 ; then + if $cc foo.c -o safebcpy $ccflags $ldflags $libs >/dev/null 2>&1 ; then if ./safebcpy 2>/dev/null; then echo "Yes, it can." val="$define" @@ -3741,7 +4966,7 @@ for (align = 7; align >= 0; align--) { exit(0); } EOCP - if $cc foo.c -o safemcpy $ccflags $libs >/dev/null 2>&1 ; then + if $cc foo.c -o safemcpy $ccflags $ldflags $libs >/dev/null 2>&1 ; then if ./safemcpy 2>/dev/null; then echo "Yes, it can." val="$define" @@ -3798,17 +5023,18 @@ eval $inlibc set seteuid d_seteuid eval $inlibc +: see if setlinebuf exists +set setlinebuf d_setlinebuf +eval $inlibc + : see if setlocale exists set setlocale d_setlocale eval $inlibc + : see if setpgid exists set setpgid d_setpgid eval $inlibc -: see if setpgrp exists -set setpgrp d_setpgrp -eval $inlibc - : see if setpgrp2 exists set setpgrp2 d_setpgrp2 eval $inlibc @@ -3853,18 +5079,34 @@ eval $inlibc set shmat d_shmat eval $inlibc : see what shmat returns -d_voidshmat="$undef" case "$d_shmat" in -define) - $cppstdin $cppflags $cppminus < $usrinc/sys/shm.h >voidshmat.txt 2>/dev/null - if $contains "void.*shmat" voidshmat.txt >/dev/null 2>&1; then - echo "and shmat returns (void*)" - d_voidshmat="$define" - else - echo "and shmat returns (char*)" - fi - ;; +"$define") + $cat >shmat.c <<'END' +#include <sys/shm.h> +void *shmat(); +END + if $cc $ccflags -c shmat.c >/dev/null 2>&1; then + shmattype='void *' + else + shmattype='char *' + fi + echo "and it returns ($shmattype)." >&4 + : see if a prototype for shmat is available + $cppstdin $cppflags $cppminus < $usrinc/sys/shm.h > shmat.c 2>/dev/null + if $contains 'shmat.*(' shmat.c >/dev/null 2>&1; then + val="$define" + else + val="$undef" + fi + $rm -f shmat.[co] + ;; +*) + val="$undef" + ;; esac +set d_shmatprototype +eval $setvar + : see if shmdt exists set shmdt d_shmdt eval $inlibc @@ -3886,6 +5128,59 @@ fi set d_shm eval $setvar +socketlib='' +sockethdr='' +: see whether socket exists +echo " " +$echo $n "Hmm... $c" >&4 +if set socket val -f d_socket; eval $csym; $val; then + echo "Looks like you have Berkeley networking support." >&4 + d_socket="$define" + if set setsockopt val -f; eval $csym; $val; then + d_oldsock="$undef" + else + echo "...but it uses the old 4.1c interface, rather than 4.2" >&4 + d_oldsock="$define" + fi +else + if $contains socklib libc.list >/dev/null 2>&1; then + echo "Looks like you have Berkeley networking support." >&4 + d_socket="$define" + : we will have to assume that it supports the 4.2 BSD interface + d_oldsock="$undef" + else + echo "You don't have Berkeley networking in libc.a..." >&4 + if test -f /usr/lib/libnet.a; then + ( (nm $nm_opt /usr/lib/libnet.a | eval $nm_extract) || \ + ar t /usr/lib/libnet.a) 2>/dev/null >> libc.list + if $contains socket libc.list >/dev/null 2>&1; then + echo "...but the Wollongong group seems to have hacked it in." >&4 + socketlib="-lnet" + sockethdr="-I/usr/netinclude" + d_socket="$define" + if $contains setsockopt libc.list >/dev/null 2>&1; then + d_oldsock="$undef" + else + echo "...using the old 4.1c interface, rather than 4.2" >&4 + d_oldsock="$define" + fi + else + echo "or even in libnet.a, which is peculiar." >&4 + d_socket="$undef" + d_oldsock="$undef" + fi + else + echo "or anywhere else I see." >&4 + d_socket="$undef" + d_oldsock="$undef" + fi + fi +fi + +: see if socketpair exists +set socketpair d_sockpair +eval $inlibc + : see if stat knows about block sizes echo " " xxx=`./findhdr sys/stat.h` @@ -3904,78 +5199,9 @@ fi set d_statblks eval $setvar -: see if stdio is really std -echo " " -xxx=`./findhdr stdio.h` -if $contains 'char.*_ptr;' "$xxx" >/dev/null 2>&1 ; then - if $contains '_cnt;' "$xxx" >/dev/null 2>&1 ; then - echo "Your stdio is pretty std." >&4 - val="$define" - else - echo "Your stdio isn't very std." >&4 - val="$undef" - fi -else - echo "Your stdio isn't very std." >&4 - val="$undef" -fi -set d_stdstdio -eval $setvar - -: see which of string.h or strings.h is needed -echo " " -strings=`./findhdr string.h` -if $test "$strings" && $test -r "$strings"; then - echo "Using <string.h> instead of <strings.h>." >&4 - val="$define" -else - val="$undef" - strings=`./findhdr strings.h` - if $test "$strings" && $test -r "$strings"; then - echo "Using <strings.h> instead of <string.h>." >&4 - else - echo "No string header found -- You'll surely have problems." >&4 - fi -fi -set i_string -eval $setvar -case "$i_string" in -"$undef") strings=`./findhdr strings.h`;; -*) strings=`./findhdr string.h`;; -esac - -: index or strchr -echo " " -if set index val -f; eval $csym; $val; then - if set strchr val -f d_strchr; eval $csym; $val; then - if $contains strchr "$strings" >/dev/null 2>&1 ; then - val="$define" - vali="$undef" - echo "strchr() found." >&4 - else - val="$undef" - vali="$define" - echo "index() found." >&4 - fi - else - val="$undef" - vali="$define" - echo "index() found." >&4 - fi -else - if set strchr val -f d_strchr; eval $csym; $val; then - val="$define" - vali="$undef" - echo "strchr() found." >&4 - else - echo "No index() or strchr() found!" >&4 - val="$undef" - vali="$undef" - fi -fi -set d_strchr; eval $setvar -val="$vali" -set d_index; eval $setvar +: see if strcoll exists +set strcoll d_strcoll +eval $inlibc : check for structure copying echo " " @@ -4006,7 +5232,7 @@ echo " " if set strerror val -f d_strerror; eval $csym; $val; then echo 'strerror() found.' >&4 d_strerror="$define" - d_strerrm="$undef" + d_strerrm='strerror(e)' if set sys_errlist val -a d_syserrlst; eval $csym; $val; then echo "(You also have sys_errlist[], so we could roll our own strerror.)" d_syserrlst="$define" @@ -4018,7 +5244,7 @@ elif xxx=`./findhdr string.h`; test "$xxx" || xxx=`./findhdr strings.h`; \ $contains '#[ ]*define.*strerror' "$xxx" >/dev/null 2>&1; then echo 'strerror() found in string header.' >&4 d_strerror="$define" - d_strerrm="$undef" + d_strerrm='strerror(e)' if set sys_errlist val -a d_syserrlst; eval $csym; $val; then echo "(Most probably, strerror() uses sys_errlist[] for descriptions.)" d_syserrlst="$define" @@ -4030,14 +5256,18 @@ elif set sys_errlist val -a d_syserrlst; eval $csym; $val; then echo "strerror() not found, but you have sys_errlist[] so we'll use that." >&4 d_strerror="$undef" d_syserrlst="$define" - d_strerrm="$define" + d_strerrm='((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e])' else echo 'strerror() and sys_errlist[] NOT found.' >&4 d_strerror="$undef" d_syserrlst="$undef" - d_strerrm="$undef" + d_strerrm='"unknown"' fi +: see if strxfrm exists +set strxfrm d_strxfrm +eval $inlibc + : see if symlink exists set symlink d_symlink eval $inlibc @@ -4046,34 +5276,66 @@ eval $inlibc set syscall d_syscall eval $inlibc +: see if sysconf exists +set sysconf d_sysconf +eval $inlibc + : see if system exists set system d_system eval $inlibc +: see if tcgetpgrp exists +set tcgetpgrp d_tcgetpgrp +eval $inlibc + +: see if tcsetpgrp exists +set tcsetpgrp d_tcsetpgrp +eval $inlibc + +: define an is-a-typedef? function +typedef='type=$1; var=$2; def=$3; shift; shift; shift; inclist=$@; +case "$inclist" in +"") inclist="sys/types.h";; +esac; +eval "val=\$$var"; +case "$val" in +"") + $rm -f temp.c; + for inc in $inclist; do + echo "#include <$inc>" >>temp.c; + done; + $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null; + if $contains $type temp.E >/dev/null 2>&1; then + eval "$var=$type"; + else + eval "$var=$def"; + fi; + $rm -f temp.?;; +*) eval "$var=$val";; +esac' + +: see if this is a sys/times.h system +set sys/times.h i_systimes +eval $inhdr + : see if times exists echo " " if set times val -f d_times; eval $csym; $val; then echo 'times() found.' >&4 d_times="$define" - case "$clocktype" in - '') - if $contains 'clock_t;' `./findhdr sys/types.h` >/dev/null 2>&1 ; then - dflt='clock_t'; - elif $contains 'clock_t;' `./findhdr sys/times.h` >/dev/null 2>&1; then - dflt='clock_t'; - else - dflt='long'; - fi - ;; - *) dflt="$clocktype" - ;; + inc='' + case "$i_systimes" in + "$define") inc='sys/times.h';; esac + set clock_t clocktype long stdio.h sys/types.h $inc + eval $typedef + dflt="$clocktype" echo " " rp="What type is returned by times() on this sytem?" . ./myread clocktype="$ans" else - echo 'times() not found, hope that will do.' >&4 + echo 'times() NOT found, hope that will do.' >&4 d_times="$undef" clocktype='int' fi @@ -4082,6 +5344,22 @@ fi set truncate d_truncate eval $inlibc +: see if tzname[] exists +echo " " +if set tzname val -a d_tzname; eval $csym; $val; then + val="$define" + echo 'tzname[] found.' >&4 +else + val="$undef" + echo 'tzname[] NOT found.' >&4 +fi +set d_tzname +eval $setvar + +: see if umask exists +set umask d_umask +eval $inlibc + : see if we have to deal with yellow pages, now NIS. if $test -d /usr/etc/yp || $test -d /etc/yp; then if $test -f /usr/etc/nibindd; then @@ -4185,8 +5463,8 @@ myhostname=$1 : translate upper to lower if necessary case "$myhostname" in *[A-Z]*) - myhostname=`echo $myhostname | tr '[A-Z]' '[a-z]'` echo "(Normalizing case in your host name)" + myhostname=`echo $myhostname | tr '[A-Z]' '[a-z]'` ;; esac @@ -4213,7 +5491,7 @@ done case "$phostname" in '') ;; *) - case `$phostname` in + case `$phostname | tr '[A-Z]' '[a-z]'` in $myhostname$mydomain|$myhostname) ;; *) case "$phostname" in @@ -4266,24 +5544,104 @@ case "$d_phostname" in '') d_phostname="$undef";; esac +: backward compatibility for d_hvfork +if test X$d_hvfork != X; then + d_vfork="$d_hvfork" + d_hvfork='' +fi : see if there is a vfork -set vfork d_vfork +val='' +set vfork val eval $inlibc -: But do we want to use it. vfork is reportedly unreliable in -: perl in Solaris 2.x, and probably elsewhere. + +: Ok, but do we want to use it. vfork is reportedly unreliable in +: perl on Solaris 2.x, and probably elsewhere. +case "$val" in +$define) + echo " " + case "$usevfork" in + false) dflt='n';; + *) dflt='y';; + esac + rp="Some systems have problems with vfork(). Do you want to use it?" + . ./myread + case "$ans" in + y|Y) ;; + *) + echo "Ok, we won't use vfork()." + val="$undef" + ;; + esac + ;; +esac +set d_vfork +eval $setvar case "$d_vfork" in -define) - dflt='n' - rp="Some systems have problems with vork. Do you want to use it?" - . ./myread - case "$ans" in - y|Y) ;; - *) echo "Ok, we won't use vfork." - d_vfork="$undef" - ;; - esac - ;; +$define) usevfork='true';; +*) usevfork='false';; esac + +: see if this is an sysdir system +set sys/dir.h i_sysdir +eval $inhdr + +: see if this is an sysndir system +set sys/ndir.h i_sysndir +eval $inhdr + +: see if closedir exists +set closedir d_closedir +eval $inlibc + +case "$d_closedir" in +"$define") + echo " " + echo "Checking whether closedir() returns a status..." >&4 + cat > closedir.c <<EOM +#$i_dirent I_DIRENT /**/ +#$i_sysdir I_SYS_DIR /**/ +#$i_sysndir I_SYS_NDIR /**/ + +#if defined(I_DIRENT) +#include <dirent.h> +#if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */ +#include <sys/dir.h> +#endif +#else +#ifdef I_SYS_NDIR +#include <sys/ndir.h> +#else +#ifdef I_SYS_DIR +#ifdef hp9000s500 +#include <ndir.h> /* may be wrong in the future */ +#else +#include <sys/dir.h> +#endif +#endif +#endif +#endif +int main() { return closedir(opendir(".")); } +EOM + if $cc $ccflags $ldflags -o closedir closedir.c $libs > /dev/null 2>&1; then + if ./closedir > /dev/null 2>&1 ; then + echo "Yes, it does." + val="$undef" + else + echo "No, it doesn't." + val="$define" + fi + else + echo "(I can't seem to compile the test program--assuming it doesn't)" + val="$define" + fi + ;; +*) + val="$undef"; + ;; +esac +set d_void_closedir +eval $setvar +$rm -f closedir* : see if signal is declared as pointer to function returning int or void echo " " xxx=`./findhdr signal.h` @@ -4291,31 +5649,35 @@ $test "$xxx" && $cppstdin $cppminus $cppflags < $xxx >$$.tmp 2>/dev/null if $contains 'int.*\*[ ]*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have int (*signal())() instead of void." >&4 val="$undef" - signal_t="int" elif $contains 'void.*\*[ ]*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have void (*signal())() instead of int." >&4 val="$define" - signal_t="void" elif $contains 'extern[ ]*[(\*]*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have int (*signal())() instead of void." >&4 val="$undef" - signal_t="int" else case "$d_voidsig" in '') echo "I can't determine whether signal handler returns void or int..." >&4 dflt=void - rp="What type does your signal handler returns?" + rp="What type does your signal handler return?" . ./myread case "$ans" in - void) val="$define"; signal_t="void";; - *) val="$undef"; signal_t="int";; + v*) val="$define";; + *) val="$undef";; esac;; - *) echo "As you already told me, signal handler returns $signal_t." >&4;; + "$define") + echo "As you already told me, signal handler returns void." >&4;; + *) + echo "As you already told me, signal handler returns int." >&4;; esac fi set d_voidsig eval $setvar +case "$d_voidsig" in +"$define") signal_t="void";; +*) signal_t="int";; +esac $rm -f $$.tmp : check for volatile keyword @@ -4357,6 +5719,14 @@ eval $inlibc set waitpid d_waitpid eval $inlibc +: see if wcstombs exists +set wcstombs d_wcstombs +eval $inlibc + +: see if wctomb exists +set wctomb d_wctomb +eval $inlibc + : preserve RCS keywords in files with variable substitution, grrr Date='$Date' Id='$Id' @@ -4364,21 +5734,40 @@ Log='$Log' RCSfile='$RCSfile' Revision='$Revision' -: is AFS running? +: check for alignment requirements echo " " -if test -d /afs; then - echo "AFS may be running... I'll be extra cautious then..." >&4 - afs=true -else - echo "AFS does not seem to be running..." >&4 - afs=false -fi +case "$alignbytes" in +'') echo "Checking alignment constraints..." >&4 + $cat >try.c <<'EOCP' +struct foobar { + char foo; + double bar; +} try; +main() +{ + printf("%d\n", (char *)&try.bar - (char *)&try.foo); +} +EOCP + if $cc $ccflags try.c -o try >/dev/null 2>&1; then + dflt=`./try` + else + dflt='8' + echo"(I can't seem to compile the test program...)" + fi + ;; +*) dflt="$alignbytes" + ;; +esac +rp="Doubles must be aligned on a how-many-byte boundary?" +. ./myread +alignbytes="$ans" +$rm -f try.c try : determine where public executables go echo " " case "$bin" in '') - dflt=`./loc . /bin /usr/local/bin /usr/lbin /usr/local /usr/bin` + dflt="$prefix/bin" ;; *) dflt="$bin" @@ -4463,160 +5852,126 @@ rp="What is the order of bytes in a long?" byteorder="$ans" $rm -f try.c try -: see if dlfcn is available -set dlfcn.h i_dlfcn -eval $inhdr -: determine which dynamic loading, if any, to compile in +: how do we catenate cpp tokens here? echo " " -case "$usedl" in -'') case "$i_dlfcn" in - define) dflt='y' ;; - *) dflt='n' ;; - esac - : Does a dl.c file exist for this operating system - $test -f ../ext/dl/dl_${osname}.c && dflt='y' - ;; -define|y|true) dflt='y' - usedl="$define" - ;; -*) dflt='n' - ;; -esac -rp="Do you wish to attempt to use dynamic loading?" -. ./myread -usedl="$ans" -case "$ans" in -y*) usedl="$define" - if $test -f ../ext/dl/dl_${osname}.c ; then - dflt="ext/dl/dl_${osname}.c" - else - dflt='ext/dl/dl.c' - fi - echo "The following dynamic loading files are available:" - cd ..; ls -C ext/dl/dl*.c; cd UU - rp="Source file to use for dynamic loading" - fn="fne~" - . ./getfile - : emulate basename and dirname - xxx=`echo $ans | $sed -e 's@.*/\([^/]*\)$@\1@' -e 's@\.c$@@'` - dlobj=$xxx.o - dlsrc=$xxx.c - dldir=`echo $ans | $sed 's@\(.*\)/[^/]*$@\1@'` - case "$dldir" in - '') dldir="." ;; - *) ;; - esac - if $test -f ../$dldir/$dlsrc; then - usedl="$define" - else - echo "File $dlsrc does not exist -- ignored" - usedl="$undef" - fi - - cat << EOM - -Some systems may require passing special flags to $cc -c to -compile modules that will be used to create a shared library. -To use no flags, say "none". +echo "Checking to see how your cpp does stuff like catenate tokens..." >&4 +$cat >cpp_stuff.c <<'EOCP' +#define RCAT(a,b)a/**/b +#define ACAT(a,b)a ## b +RCAT(Rei,ser) +ACAT(Cir,cus) +EOCP +$cppstdin $cppflags $cppminus < cpp_stuff.c >cpp_stuff.out 2>&1 +if $contains 'Circus' cpp_stuff.out >/dev/null 2>&1; then + echo "Oh! Smells like ANSI's been here." + echo "We can catify or stringify, separately or together!" + cpp_stuff=42 +elif $contains 'Reiser' cpp_stuff.out >/dev/null 2>&1; then + echo "Ah, yes! The good old days!" + echo "However, in the good old days we don't know how to stringify and" + echo "catify at the same time." + cpp_stuff=1 +else + $cat >&4 <<EOM +Hmm, I don't seem to be able to catenate tokens with your cpp. You're going +to have to edit the values of CAT[2-5] in config.h... EOM - case "$cccdlflags" in - ''|' ') case "$osname" in - hpux) dflt='+z' ;; - next) dflt='none' ;; - sunos) dflt='none' ;; - *) dflt='none' ;; - esac - ;; - *) dflt="$cccdlflags" ;; - esac - rp="Any special flags to pass to $cc -c to compile shared library modules?" - . ./myread - case "$ans" in - none) cccdlflags='' ;; - *) cccdlflags="$ans" ;; - esac - - cat << 'EOM' + cpp_stuff="/* Help! How do we handle cpp_stuff? */*/" +fi -Some systems may require passing special flags to ld to -create a shared library. To use no flags, say "none". -EOM - case "$lddlflags" in - ''|' ') case "$osname" in - hpux) dflt='-b' ;; - next) dflt='none' ;; - sunos) dflt='none' ;; - *) dflt='none' ;; - esac - ;; - *) dflt="$lddlflags" ;; - esac - rp="Any special flags to pass to ld to create a shared library?" - . ./myread - case "$ans" in - none) lddlflags='' ;; - *) lddlflags="$ans" ;; - esac +: check for void type +echo " " +$cat >&4 <<EOM +Checking to see how well your C compiler groks the void type... - cat <<EOM + Support flag bits are: + 1: basic void declarations. + 2: arrays of pointers to functions returning void. + 4: operations between pointers to and addresses of void functions. + 8: generic void pointers. -Some systems may require passing special flags to $cc to indicate that -dynamic linking will be used. To use no flags, say "none". EOM - case "$ccdlflags" in - ''|' ') - case "$osname" in - hpux) dflt='none' ;; - next) dflt='none' ;; - sunos) dflt='none' ;; - *) dflt='none' ;; - esac - ;; - *) dflt="$ccdlflags" - ;; - esac - rp="Any special flags to pass to $cc to use dynamic loading?" - . ./myread - case "$ans" in - none) ccdlflags='' ;; - *) ccdlflags="$ans" ;; - esac - cat <<EOM - -Some systems may require using a special suffix for shared libraries. -To create the shared library for POSIX, for example, you may need to -actually build the file POSIX.so. +case "$voidflags" in +'') + $cat >try.c <<'EOCP' +#if TRY & 1 +void main() { +#else +main() { +#endif + extern void moo(); /* function returning void */ + void (*goo)(); /* ptr to func returning void */ +#if TRY & 8 + void *hue; /* generic ptr */ +#endif +#if TRY & 2 + void (*foo[10])(); +#endif -EOM - case "$shlibsuffix" in - '') - case "$osname" in - hpux) dflt='.sl' ;; - next) dflt='.so' ;; - sunos) dflt='.so' ;; - *) dflt='.so' ;; - esac - ;; - *) dflt="$shlibsuffix" - ;; - esac - rp="What is the suffix used for shared libraries?" - . ./myread - case "$ans" in - none) shlibsuffix='' ;; - *) shlibsuffix="$ans" ;; - esac - ;; -*) usedl="$undef" - : These are currently not used. - dlsrc='' - dlobj='' - dldir='' - lddlflags='' - ccdlflags='' - shlibsuffix='.o' - ;; +#if TRY & 4 + if(goo == moo) { + exit(0); + } +#endif + exit(0); +} +EOCP + if $cc -c -DTRY=$defvoidused try.c >.out 2>&1 ; then + voidflags=$defvoidused + echo "It appears to support void to the level $package wants ($defvoidused)." + if $contains warning .out >/dev/null 2>&1; then + echo "However, you might get some warnings that look like this:" + $cat .out + fi + else +echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 + if $cc -c -DTRY=1 try.c >/dev/null 2>&1 ; then + echo "It supports 1..." + if $cc -c -DTRY=3 try.c >/dev/null 2>&1 ; then + echo "It also supports 2..." + if $cc -c -DTRY=7 try.c >/dev/null 2>&1 ; then + voidflags=7 + echo "And it supports 4 but not 8 definitely." + else + echo "It doesn't support 4..." + if $cc -c -DTRY=11 try.c >/dev/null 2>&1 ; then + voidflags=11 + echo "But it supports 8." + else + voidflags=3 + echo "Neither does it support 8." + fi + fi + else + echo "It does not support 2..." + if $cc -c -DTRY=13 try.c >/dev/null 2>&1 ; then + voidflags=13 + echo "But it supports 4 and 8." + else + if $cc -c -DTRY=5 try.c >/dev/null 2>&1 ; then + voidflags=5 + echo "And it supports 4 but has not heard about 8." + else + echo "However it supports 8 but not 4." + fi + fi + fi + else + echo "There is no support at all for void." + voidflags=0 + fi + fi esac +dflt="$voidflags"; +rp="Your void support flags add up to what?" +. ./myread +voidflags="$ans" +$rm -f try.* .out + +: see if this is a db.h system +set db.h i_db +eval $inhdr + : see if we have the old dbm set dbm.h i_dbm eval $inhdr @@ -4629,185 +5984,192 @@ eval $inhdr set gdbm.h i_gdbm eval $inhdr -: see if sdbm.h is wanted echo " " -echo "$package includes an implementation of sdbm in ext/dbm/sdbm." -case "$i_sdbm" in - ''|' ') val="$define" ;; - *) val="$i_sdbm" ;; -esac -set i_sdbm -eval $setvar -case "$extensions" in -' '|'') echo "Looking for extensions..." - case "$find" in - *find*) - cd .. - extensions=`$find ext -type f -name \*.xs -print` - set X $extensions - shift - extensions="$*" - cd UU - ;; - *) extensions='ext/dbm/NDBM_File.xs ext/dbm/ODBM_File.xs ext/dbm/GDBM_File.xs ext/dbm/SDBM_File.xs ext/posix/POSIX.xs' - ;; - esac - ;; -none) extensions='' ;; -*) ;; -esac +echo "Looking for extensions..." >&4 +cd ../ext +known_extensions='' +for xxx in * ; do + if $test -f $xxx/$xxx.xs; then + known_extensions="$known_extensions $xxx" + fi +done +set X $known_extensions +shift +known_extensions="$*" +cd ../UU + : Now see which are supported on this system. -dflt="" -for xxx in $extensions ; do +avail_ext='' +for xxx in $known_extensions ; do case "$xxx" in - *ODBM*) case "$i_dbm" in - define) dflt="$dflt $xxx" ;; - *) ;; + DB_File) case "$i_db" in + $define) avail_ext="$avail_ext $xxx" ;; + esac + ;; + GDBM_File) case "$i_gdbm" in + $define) avail_ext="$avail_ext $xxx" ;; + esac + ;; + NDBM_File) case "$i_ndbm" in + $define) avail_ext="$avail_ext $xxx" ;; esac ;; - *NDBM*) case "$i_ndbm" in - define) dflt="$dflt $xxx" ;; - *) ;; + ODBM_File) case "$i_dbm" in + $define) avail_ext="$avail_ext $xxx" ;; esac ;; - *GDBM*) case "$i_gdbm" in - define) dflt="$dflt $xxx" ;; - *) ;; + POSIX) case "$useposix" in + true|define|y) avail_ext="$avail_ext $xxx" ;; esac ;; - *SDBM*) case "$i_sdbm" in - define) dflt="$dflt $xxx" ;; - *) ;; + Socket) case "$d_socket" in + $define) avail_ext="$avail_ext $xxx" ;; esac ;; - *) dflt="$dflt $xxx" + *) avail_ext="$avail_ext $xxx" ;; esac done -rp="What extensions do you wish to include?" +set X $avail_ext +shift +avail_ext="$*" + +case $usedl in +$define) + $cat <<EOM +A number of extensions are supplied with $package. You may choose to +compile these extensions for dynamic loading (the default), compile +them into the $package executable (static loading), or not include +them at all. Answer "none" to include no extensions. + +EOM + case "$dynamic_ext" in + ''|' ') dflt="$avail_ext" ;; + *) dflt="$dynamic_ext" ;; + esac + case "$dflt" in + '') dflt=none;; + esac + rp="What extensions do you wish to load dynamically?" + . ./myread + case "$ans" in + none) dynamic_ext='' ;; + *) dynamic_ext="$ans" ;; + esac + + case "$static_ext" in + ''|' ') + : Exclude those already listed in dynamic linking + dflt='' + for xxx in $avail_ext; do + case " $dynamic_ext " in + *" $xxx "*) ;; + *) dflt="$dflt $xxx" ;; + esac + done + set X $dflt + shift + dflt="$*" + ;; + *) dflt="$static_ext" + ;; + esac + + case "$dflt" in + '') dflt=none;; + esac + rp="What extensions do you wish to load statically?" + . ./myread + case "$ans" in + none) static_ext='' ;; + *) static_ext="$ans" ;; + esac + ;; +*) + $cat <<EOM +A number of extensions are supplied with $package. Answer "none" +to include no extensions. + +EOM + case "$static_ext" in + ''|' ') dflt="$avail_ext" ;; + *) dflt="$static_ext" ;; + esac + + case "$dflt" in + '') dflt=none;; + esac + rp="What extensions do you wish to include?" + . ./myread + case "$ans" in + none) static_ext='' ;; + *) static_ext="$ans" ;; + esac + ;; +esac + +set X $dynamic_ext $static_ext +shift +extensions="$*" + +: see what type file positions are declared as in the library +set fpos_t fpostype long stdio.h sys/types.h +eval $typedef +echo " " +dflt="$fpostype" +rp="What is the type for file position used by fsetpos()?" . ./myread -extensions="$ans" +fpostype="$ans" : see what type gids are declared as in the kernel +set gid_t gidtype xxx stdio.h sys/types.h +eval $typedef case "$gidtype" in -'') - if $contains 'gid_t;' `./findhdr sys/types.h` >/dev/null 2>&1 ; then - dflt='gid_t'; - else - xxx=`./findhdr sys/user.h` - set `grep 'groups\[NGROUPS\];' "$xxx" 2>/dev/null` unsigned short - case $1 in - unsigned) dflt="$1 $2" ;; - *) dflt="$1" ;; - esac - fi +xxx) + xxx=`./findhdr sys/user.h` + set `grep 'groups\[NGROUPS\];' "$xxx" 2>/dev/null` unsigned short + case $1 in + unsigned) dflt="$1 $2" ;; + *) dflt="$1" ;; + esac ;; -*) dflt="$gidtype";; +*) dflt="$gidtype";; esac echo " " rp="What is the type for group ids returned by getgid()?" . ./myread -val="$ans" -set gidtype -eval $setvar +gidtype="$ans" + : see if getgroups exists set getgroups d_getgrps eval $inlibc +: Find type of 2nd arg to getgroups +echo " " case "$d_getgrps" in 'define') - case "$groupstype" in + case "$groupstype" in '') dflt="$gidtype" ;; *) dflt="$groupstype" ;; - esac - echo " " - $cat <<EOM + esac + $cat <<EOM What is the type of the second argument to getgroups()? Usually this is the same as group ids, $gidtype, but not always. -EOM - rp="What type is the second arguement to getgroups()?" - . ./myread - val="$ans" - ;; -*) val="$gidtype";; -esac -set groupstype -eval $setvar -: determine where private executables go -case "$privlib" in -'') - dflt=/usr/lib/$package - $test -d /usr/local/lib && dflt=/usr/local/lib/$package - $test -d /local/lib && dflt=/local/lib/$package - ;; -*) dflt="$privlib" - ;; -esac -$cat <<EOM - -There are some auxiliary files for $package that need to be put into a -private library directory that is accessible by everyone. - -EOM -fn=d~+ -rp='Pathname where private library files will reside?' -. ./getfile -privlib="$ans" -privlibexp="$ansexp" -if $afs; then - $cat <<EOM - -Since you are running AFS, I need to distinguish the directory in which -private files reside from the directory in which they are installed (and from -which they are presumably copied to the former directory by occult means). EOM - case "$installprivlib" in - '') dflt=`echo $privlibexp | sed 's#^/afs/#/afs/.#'`;; - *) dflt="$installprivlib";; - esac - fn=de~ - rp='Where will private files be installed?' - . ./getfile - installprivlib="$ans" -else - installprivlib="$privlibexp" -fi - -: determine where public libraries go -case "$lib" in -'') dflt=`./loc . "." /usr/local/lib /usr/lib /lib`;; -*) dflt="$lib";; + rp='What type is the second argument to getgroups()?' + . ./myread + groupstype="$ans" + ;; +*) groupstype="$gidtype";; esac -echo " " -fn=d~ -rp='Where do you want to put the public libraries?' -. ./getfile -lib="$ans" -libexp="$ansexp" -: determine whether symbolic links are supported -$touch blurfl -if $ln -s blurfl sym > /dev/null 2>&1 ; then - lns="$ln -s" -else - lns="$ln" -fi -rm -f blurfl sym : see what type lseek is declared as in the kernel -case "$lseektype" in -'') - if $contains 'off_t;' `./findhdr sys/types.h` >/dev/null 2>&1 ; then - dflt='off_t'; - else - dflt='long'; - fi - ;; -*) dflt="$lseektype" - ;; -esac +set off_t lseektype long stdio.h sys/types.h +eval $typedef echo " " +dflt="$lseektype" rp="What type is lseek's offset on this system declared as?" . ./myread lseektype="$ans" @@ -4827,11 +6189,12 @@ esac echo "If you don't want the manual sources installed, answer 'none'." case "$mansrc" in '') - lookpath='/usr/local/man/man1 /usr/local/man/man1 /usr/man/manl' + lookpath="$prefix/man/man1 $prefix/man/u_man/man1 $prefix/man/l_man/man1" + lookpath="$lookpath /usr/local/man/man1 /usr/local/man/man1 /usr/man/manl" lookpath="$lookpath /usr/man/local/man1 /usr/man/l_man/man1" lookpath="$lookpath /usr/local/man/u_man/man1 /usr/local/man/l_man/man1" lookpath="$lookpath /usr/man/man.L" - mansrc=`./loc . $lookpath` + mansrc=`./loc . $prefix/man/man1 $lookpath` if $test -d "$mansrc"; then dflt="$mansrc" else @@ -4880,34 +6243,14 @@ case "$mansrc" in *) manext=1;; esac -: check for alignment requirements +: see what type is used for mode_t +set mode_t modetype int stdio.h sys/types.h +eval $typedef +dflt="$modetype" echo " " -case "$memalignbytes" in -'') echo "Checking alignment constraints..." >&4 - $cat >try.c <<'EOCP' -struct foobar { - char foo; - double bar; -} try; -main() -{ - printf("%d\n", (char *)&try.bar - (char *)&try.foo); -} -EOCP - if $cc $ccflags try.c -o try >/dev/null 2>&1; then - dflt=`./try` - else - dflt='8' - echo"(I can't seem to compile the test program...)" - fi - ;; -*) dflt="$memalignbytes" - ;; -esac -rp="Doubles must be aligned on a how-many-byte boundary?" +rp="What type is used for file modes?" . ./myread -memalignbytes="$ans" -$rm -f try.c try +modetype="$ans" : Cruising for prototypes echo " " @@ -4916,7 +6259,7 @@ $cat >prototype.c <<'EOCP' main(int argc, char *argv[]) { exit(0);} EOCP -if $cc -c prototype.c >prototype.out 2>&1 ; then +if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then echo "Your C compiler appears to support function prototypes." val="$define" else @@ -4927,34 +6270,6 @@ set prototype eval $setvar $rm -f prototype* -: check for length of pointer -echo " " -case "$ptrsize" in -'') - echo "Checking to see how big your pointers are..." >&4 - $cat >try.c <<'EOCP' -#include <stdio.h> -main() -{ - printf("%d\n", sizeof(char *)); -} -EOCP - if $cc $ccflags try.c -o try >/dev/null 2>&1 ; then - dflt=`./try` - else - dflt='4' - echo "(I can't seem to compile the test program. Guessing...)" - fi - ;; -*) - dflt="$ptrsize" - ;; -esac -rp="What is the size of a pointer (in bytes)?" -. ./myread -ptrsize="$ans" -$rm -f try.c try - : check for size of random number generator echo " " case "$randbits" in @@ -4996,30 +6311,33 @@ $rm -f try.c try : see if ar generates random libraries by itself echo " " echo "Checking how to generate random libraries on your machine..." >&4 -$cat >a.c <<EOP -f() { exit(0); } +echo 'int bar1() { return bar2(); }' > bar1.c +echo 'int bar2() { return 2; }' > bar2.c +$cat > foo.c <<'EOP' +main() { printf("%d\n", bar1()); exit(0); } EOP -cc -c a.c >/dev/null 2>&1 -ar rc ran.a a.o >/dev/null 2>&1 -$cat >b.c <<EOP -main() { f(); } -EOP -cp ran.a lib.a -if ar ts ran.a >/dev/null 2>&1; then - if $cc -o b b.c lib.a >/dev/null 2>&1; then - echo "ar appears to generate random libraries itself." - orderlib=false - ranlib=":" - else +$cc $ccflags -c bar1.c >/dev/null 2>&1 +$cc $ccflags -c bar2.c >/dev/null 2>&1 +$cc $ccflags -c foo.c >/dev/null 2>&1 +ar rc bar.a bar2.o bar1.o >/dev/null 2>&1 +if $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /dev/null 2>&1 && + ./foobar >/dev/null 2>&1; then + echo "ar appears to generate random libraries itself." + orderlib=false + ranlib=":" +elif ar ts bar.a >/dev/null 2>&1 && + $cc $ccflags $ldflags -o foobar foo.o bar.a $libs > /dev/null 2>&1 && + ./foobar >/dev/null 2>&1; then echo "a table of contents needs to be added with 'ar ts'." orderlib=false ranlib="ar ts" - fi else if $test -f /usr/bin/ranlib; then ranlib=/usr/bin/ranlib elif $test -f /bin/ranlib; then ranlib=/bin/ranlib + elif $test -f /usr/local/bin/ranlib; then + ranlib=/usr/local/bin/ranlib fi if $test -n "$ranlib"; then @@ -5032,9 +6350,9 @@ else ranlib=":" fi fi -$rm -f a.* b.c b.o b ran.a lib.a +$rm -f foo* bar* -: determine where public executables go +: determine where public executable scripts go case "$scriptdir" in '') dflt="$bin" @@ -5042,6 +6360,7 @@ case "$scriptdir" in $test -d /usr/share/scripts && dflt=/usr/share/scripts $test -d /usr/share/bin && dflt=/usr/share/bin $test -d /usr/local/script && dflt=/usr/local/script + $test -d $prefix/script && dflt=$prefix/script ;; *) dflt="$scriptdir" ;; @@ -5079,6 +6398,236 @@ else installscript="$scriptdirexp" fi +: see if sys/select.h has to be included +set sys/select.h i_sysselct +eval $inhdr + +: see if we should include time.h, sys/time.h, or both +echo " " +echo "Testing to see if we should include <time.h>, <sys/time.h> or both." >&4 +$echo $n "I'm now running the test program...$c" +$cat >try.c <<'EOCP' +#include <sys/types.h> +#ifdef I_TIME +#include <time.h> +#endif +#ifdef I_SYSTIME +#ifdef SYSTIMEKERNEL +#define KERNEL +#endif +#include <sys/time.h> +#endif +#ifdef I_SYSSELECT +#include <sys/select.h> +#endif +main() +{ + struct tm foo; +#ifdef S_TIMEVAL + struct timeval bar; +#endif +#ifdef S_TIMEZONE + struct timezone tzp; +#endif + if (foo.tm_sec == foo.tm_sec) + exit(0); +#ifdef S_TIMEVAL + if (bar.tv_sec == bar.tv_sec) + exit(0); +#endif + exit(1); +} +EOCP +flags='' +s_timezone='' +sysselect='' +for s_timeval in '-DS_TIMEVAL' ''; do +for i_systimek in '' '-DSYSTIMEKERNEL'; do +for i_time in '' '-DI_TIME'; do +for i_systime in '-DI_SYSTIME' ''; do + case "$flags" in + '') $echo $n ".$c" + if $cc $ccflags \ + $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \ + try.c -o try >/dev/null 2>&1 ; then + set X $i_time $i_systime $i_systimek $sysselect $s_timeval + shift + flags="$*" + echo " " + $echo $n "Succeeded with $flags$c" + fi + ;; + esac +done +done +done +done +timeincl='' +echo " " +case "$flags" in +*SYSTIMEKERNEL*) i_systimek="$define" + timeincl=`./findhdr sys/time.h` + echo "We'll include <sys/time.h> with KERNEL defined." >&4;; +*) i_systimek="$undef";; +esac +case "$flags" in +*I_TIME*) i_time="$define" + timeincl=`./findhdr time.h`" $timeincl" + echo "We'll include <time.h>." >&4;; +*) i_time="$undef";; +esac +case "$flags" in +*I_SYSTIME*) i_systime="$define" + timeincl=`./findhdr sys/time.h`" $timeincl" + echo "We'll include <sys/time.h>." >&4;; +*) i_systime="$undef";; +esac +$rm -f try.c try + +: check for fd_set items +$cat <<EOM + +Checking to see how well your C compiler handles fd_set and friends ... +EOM +$cat >fd_set.c <<EOCP +#$i_systime I_SYS_TIME +#$i_sysselct I_SYS_SELECT +#$d_socket HAS_SOCKET +#include <sys/types.h> +#ifdef HAS_SOCKET +#include <sys/socket.h> /* Might include <sys/bsdtypes.h> */ +#endif +#ifdef I_SYS_TIME +#include <sys/time.h> +#else +#ifdef I_SYS_SELECT +#include <sys/select.h> +#endif +#endif +main() { + fd_set fds; + +#ifdef TRYBITS + if(fds.fds_bits); +#endif + +#if defined(FD_SET) && defined(FD_CLR) && defined(FD_ISSET) && defined(FD_ZERO) + exit(0); +#else + exit(1); +#endif +} +EOCP +if $cc $ccflags -DTRYBITS fd_set.c -o fd_set >fd_set.out 2>&1 ; then + d_fds_bits="$define" + d_fd_set="$define" + echo "Well, your system knows about the normal fd_set typedef..." >&4 + if ./fd_set; then + echo "and you have the normal fd_set macros (just as I'd expect)." >&4 + d_fd_macros="$define" + else + $cat >&4 <<'EOM' +but not the normal fd_set macros! Gaaack! I'll have to cover for you. +EOM + d_fd_macros="$undef" + fi +else + $cat <<'EOM' +Hmm, your compiler has some difficulty with fd_set. Checking further... +EOM + if $cc $ccflags fd_set.c -o fd_set >fd_set.out 2>&1 ; then + d_fds_bits="$undef" + d_fd_set="$define" + echo "Well, your system has some sort of fd_set available..." >&4 + if ./fd_set; then + echo "and you have the normal fd_set macros." >&4 + d_fd_macros="$define" + else + $cat <<'EOM' +but not the normal fd_set macros! Gross! More work for me... +EOM + d_fd_macros="$undef" + fi + else + echo "Well, you got zip. That's OK, I can roll my own fd_set stuff." >&4 + d_fd_set="$undef" + d_fds_bits="$undef" + d_fd_macros="$undef" + fi +fi +$rm -f fd_set* + + +: check for type of arguments to select. This will only really +: work if the system supports prototypes and provides one for +: select. +case "$d_select" in +$define) + : Make initial guess + case "$selecttype" in + ''|' ') + case "$d_fd_set" in + $define) xxx='fd_set *' ;; + *) xxx='int *' ;; + esac + ;; + *) xxx="$selecttype" + ;; + esac + : backup guess + case "$xxx" in + 'fd_set *') yyy='int *' ;; + 'int *') yyy='fd_set *' ;; + esac + + $cat <<EOM + +Checking to see what type of arguments are expected by select(). +EOM + $cat >try.c <<EOCP +#$i_systime I_SYS_TIME +#$i_sysselct I_SYS_SELECT +#$d_socket HAS_SOCKET +#include <sys/types.h> +#ifdef HAS_SOCKET +#include <sys/socket.h> /* Might include <sys/bsdtypes.h> */ +#endif +#ifdef I_SYS_TIME +#include <sys/time.h> +#else +#ifdef I_SYS_SELECT +#include <sys/select.h> +#endif +#endif +main() +{ + int width; + Select_fd_set_t readfds; + Select_fd_set_t writefds; + Select_fd_set_t exceptfds; + struct timeval timeout; + select(width, readfds, writefds, exceptfds, &timeout); + exit(0); +} +EOCP + if $cc $ccflags -c -DSelect_fd_set_t="$xxx" try.c >/dev/null 2>&1 ; then + selecttype="$xxx" + echo "Your system uses $xxx for the arguments to select." >&4 + elif $cc $ccflags -c -DSelect_fd_set_t="$yyy" try.c >/dev/null 2>&1 ; then + selecttype="$yyy" + echo "Your system uses $yyy for the arguments to select." >&4 + else + rp='What is the type for the 2nd, 3rd, and 4th arguments to select?' + dflt="$xxx" + . ./myread + selecttype="$ans" + fi + $rm -f try.[co] + ;; +*) selecttype = 'int *' + ;; +esac + : generate list of signal names echo " " case "$sig_name" in @@ -5122,18 +6671,68 @@ END { ;; esac echo "The following signals are available:" -echo $sig_name | - $awk 'BEGIN { linelen = 0 } - { for (i = 1; i < NF; i++) - { - name = "SIG" $i " " - linelen = linelen + length(name) - if (linelen > 70) - { - printf "\n" - linelen = length(name) +echo " " +echo $sig_name | $awk \ +'BEGIN { linelen = 0 } +{ + for (i = 1; i < NF; i++) { + name = "SIG" $i " " + linelen = linelen + length(name) + if (linelen > 70) { + printf "\n" + linelen = length(name) } - printf "%s", name } }' + printf "%s", name + } +}' +echo " " + +: see what type is used for size_t +set size_t sizetype 'unsigned int' stdio.h sys/types.h +eval $typedef +dflt="$sizetype" +echo " " +rp="What type is used for the length parameter for string functions?" +. ./myread +sizetype="$ans" + +: see what type is used for signed size_t +set ssize_t ssizetype int stdio.h sys/types.h +eval $typedef +dflt="$ssizetype" +$cat > ssize.c <<EOM +#include <stdio.h> +#include <sys/types.h> +#define Size_t $sizetype +#define SSize_t $dflt +main() +{ + if (sizeof(Size_t) == sizeof(SSize_t)) + printf("$dflt\n"); + else if (sizeof(Size_t) == sizeof(int)) + printf("int\n"); + else + printf("long\n"); +} +EOM +echo " " +if $cc $ccflags $ldflags -o ssize ssize.c $libs > /dev/null 2>&1 ; then + ssizetype=`./ssize` + echo "I'll be using $ssizetype for functions returning a byte count." >&4 +else + echo "(I can't compile the test program--please enlighten me!)" + $cat <<EOM + +I need a type that is the same size as $sizetype, but is guaranteed to +be signed. Common values are int and long. + +EOM + rp="What signed type is the same size as $sizetype?" + . ./myread + ssizetype="$ans" +fi +$rm -f ssize ssize.[co] + : see what type of char stdio uses. echo " " if $contains 'unsigned.*char.*_ptr;' `./findhdr stdio.h` >/dev/null 2>&1 ; then @@ -5146,142 +6745,44 @@ fi : see if time exists echo " " -if set time val -f d_time; eval $csym; $val; then +if set time tval -f d_time; eval $csym; $tval; then echo 'time() found.' >&4 - val="$define" - case "$timetype" in - '') - if $contains 'time_t;' `./findhdr sys/types.h` >/dev/null 2>&1 ; then - dflt='time_t'; - else - dflt='long'; - fi - ;; - *) dflt="$timetype" - ;; - esac + tval="$define" + set time_t timetype long stdio.h sys/types.h + eval $typedef + dflt="$timetype" echo " " rp="What type is returned by time() on this sytem?" . ./myread timetype="$ans" else echo 'time() not found, hope that will do.' >&4 - val="$undef" + tval="$undef" timetype='int'; fi +val=$tval set d_time eval $setvar : see what type uids are declared as in the kernel +set uid_t uidtype xxx stdio.h sys/types.h +eval $typedef case "$uidtype" in -'') - if $contains 'uid_t;' `./findhdr sys/types.h` >/dev/null 2>&1 ; then - dflt='uid_t'; - else - xxx=`./findhdr sys/user.h` - set `grep '_ruid;' "$xxx" 2>/dev/null` unsigned short - case $1 in - unsigned) dflt="$1 $2" ;; - *) dflt="$1" ;; - esac - fi +xxx) + xxx=`./findhdr sys/user.h` + set `grep '_ruid;' "$xxx" 2>/dev/null` unsigned short + case $1 in + unsigned) dflt="$1 $2" ;; + *) dflt="$1" ;; + esac ;; -*) dflt="$uidtype";; +*) dflt="$uidtype";; esac echo " " -rp="What type are user ids on this system declared as?" +rp="What is the type for user ids returned by getuid()?" . ./myread uidtype="$ans" -: check for void type -echo " " -$cat >&4 <<EOM -Checking to see how well your C compiler groks the void type... - - Support flag bits are: - 1: basic void declarations. - 2: arrays of pointers to functions returning void. - 4: operations between pointers to and addresses of void functions. - 8: generic void pointers. - -EOM -case "$voidflags" in -'') - $cat >try.c <<'EOCP' -#if TRY & 1 -void main() { -#else -main() { -#endif - extern void moo(); /* function returning void */ - void (*goo)(); /* ptr to func returning void */ -#if TRY & 8 - void *hue; /* generic ptr */ -#endif -#if TRY & 2 - void (*foo[10])(); -#endif - -#if TRY & 4 - if(goo == moo) { - exit(0); - } -#endif - exit(0); -} -EOCP - if $cc -c -DTRY=$defvoidused try.c >.out 2>&1 ; then - voidflags=$defvoidused - echo "It appears to support void to the level $package wants ($defvoidused)." - if $contains warning .out >/dev/null 2>&1; then - echo "However, you might get some warnings that look like this:" - $cat .out - fi - else -echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 - if $cc -c -DTRY=1 try.c >/dev/null 2>&1 ; then - echo "It supports 1..." - if $cc -c -DTRY=3 try.c >/dev/null 2>&1 ; then - echo "It also supports 2..." - if $cc -c -DTRY=7 try.c >/dev/null 2>&1 ; then - voidflags=7 - echo "And it supports 4 but not 8 definitely." - else - echo "It doesn't support 4..." - if $cc -c -DTRY=11 try.c >/dev/null 2>&1 ; then - voidflags=11 - echo "But it supports 8." - else - voidflags=3 - echo "Neither does it support 8." - fi - fi - else - echo "It does not support 2..." - if $cc -c -DTRY=13 try.c >/dev/null 2>&1 ; then - voidflags=13 - echo "But it supports 4 and 8." - else - if $cc -c -DTRY=5 try.c >/dev/null 2>&1 ; then - voidflags=5 - echo "And it supports 4 but has not heard about 8." - else - echo "However it supports 8 but not 4." - fi - fi - fi - else - echo "There is no support at all for void." - voidflags=0 - fi - fi -esac -dflt="$voidflags"; -rp="Your void support flags add up to what?" -. ./myread -voidflags="$ans" -$rm -f try.* .out - : determine compiler compiler case "$yacc" in '') @@ -5290,18 +6791,15 @@ case "$yacc" in dflt="$yacc";; esac echo " " -rp="yacc" +comp='yacc' if $test -f "$byacc"; then dflt="$byacc" - rp="byacc or $rp" + comp="byacc or $comp" fi if $test -f "$bison"; then - rp="$rp or bison -y" + comp="$comp or bison -y" fi -$cat <<EOM -$package no longer requires a compiler compiler, so the following is optional. -EOM -rp="Which compiler compiler ($rp) shall I use?" +rp="Which compiler compiler ($comp) shall I use?" . ./myread yacc="$ans" case "$yacc" in @@ -5373,94 +6871,66 @@ eval $setvar set grp.h i_grp eval $inhdr +: see if this is a math.h system +set math.h i_math +eval $inhdr + : see if memory.h is available. -set memory.h i_memory +val='' +set memory.h val eval $inhdr + : See if it conflicts with string.h -case "$i_memory" in -define) - case "$strings" in - '') ;; - *) $cppstdin $cppflags $cppminus < $strings > mem.h - if $contains 'memcpy' mem.h >/dev/null 2>&1; then - echo "We won't be including <memory.h>" - i_memory="$undef" - fi - rm -f mem.h - ;; - esac +case "$val" in +$define) + case "$strings" in + '') ;; + *) + $cppstdin $cppflags $cppminus < $strings > mem.h + if $contains 'memcpy' mem.h >/dev/null 2>&1; then + echo " " + echo "We won't be including <memory.h>." + val="$undef" + fi + $rm -f mem.h + ;; + esac esac -: see if there are directory access routines out there -echo " " -if $test `./findhdr ndir.h` && \ - ( $test -r /usr/lib/libndir.a || $test -r /usr/local/lib/libndir.a ); then - echo "Ndir library found." >&4 - if $test -r /usr/lib/libndir.a; then - ndirlib='-lndir' - else - ndirlib="/usr/local/lib/libndir.a" - fi - i_ndir="$define" - d_usendir="$undef" - ndirc='' - ndiro='' -else - ndirlib='' - i_ndir="$undef" - if set readdir val -f; eval $csym; $val; then - echo "No ndir library found, but you have readdir() so we'll use that." >&4 - d_usendir="$undef" - ndirc='' - ndiro='' - else - echo "No ndir library found--using ./ndir.c." >&4 - d_usendir="$define" - ndirc='ndir.c' - ndiro='ndir.o' - fi -fi +set i_memory +eval $setvar : see if net/errno.h is available -set net/errno.h i_neterrno +val='' +set net/errno.h val eval $inhdr + : Unfortunately, it causes problems on some systems. Arrgh. -case '$i_neterrno' in -'define') echo "<net/errno.h> found." - cat > try.c <<'EOM' +case "$val" in +$define) + cat > try.c <<'EOM' #include <stdio.h> #include <errno.h> #include <net/errno.h> int func() { -int x; -x = ENOTSOCK; -return x; + return ENOTSOCK; } EOM - if $cc $ccflags -c try.c >/dev/null 2>&1; then - i_neterrno="$define" - else - echo "But it causes problems, so we won't include it" - i_neterrno="$undef" - fi - $rm -f try.* try - ;; + if $cc $ccflags -c try.c >/dev/null 2>&1; then + echo "We'll be including <net/errno.h>." >&4 + else + echo "We won't be including <net/errno.h>." >&4 + val="$undef" + fi + $rm -f try.* try + ;; esac -: see if stdarg is available -set stdarg.h i_stdarg -eval $inhdr - -: see if stddef is available -set stddef.h i_stddef -eval $inhdr - -: see if this is an sysdir system -set sys/dir.h i_sysdir -eval $inhdr +set i_neterrno +eval $setvar : get C preprocessor symbols handy echo " " -echo $attrlist | $tr ' ' '\012' >Cppsym.know +echo $al | $tr ' ' '\012' >Cppsym.know $cat <<EOSS >Cppsym $startsh case "\$1" in @@ -5507,7 +6977,7 @@ EOSS chmod +x Cppsym $eunicefix Cppsym echo "Your C preprocessor defines the following symbols:" -Cppsym -l $attrlist >Cppsym.true +Cppsym -l $al >Cppsym.true $cat Cppsym.true : see if this is a termio system @@ -5565,130 +7035,23 @@ set i_termio; eval $setvar val=$val2; set i_sgtty; eval $setvar val=$val3; set i_termios; eval $setvar -: see if ioctl defs are in sgtty/termio or sys/ioctl +: see if stdarg is available echo " " -if $test `./findhdr sys/ioctl.h`; then - val="$define" - echo "<sys/ioctl.h> found." >&4 +if $test `./findhdr stdarg.h`; then + echo "<stdarg.h> found." >&4 + valstd="$define" else - val="$undef" - $test $i_termio = "$define" && xxx="termio.h" - $test $i_termios = "$define" && xxx="termios.h" - $test $i_sgtty = "$define" && xxx="sgtty.h" -echo "No <sys/ioctl.h> found, assuming ioctl args are defined in <$xxx>." >&4 + echo "<stdarg.h> NOT found." >&4 + valstd="$undef" fi -set i_sysioctl -eval $setvar -: see if this is an sysndir system -set sys/ndir.h i_sysndir -eval $inhdr - -: see if sys/select.h has to be included -set sys/select.h i_sysselct -eval $inhdr - -: see if we should include time.h, sys/time.h, or both -echo " " -echo "Testing to see if we should include <time.h>, <sys/time.h> or both." >&4 -$echo $n "I'm now running the test program...$c" -$cat >try.c <<'EOCP' -#include <sys/types.h> -#ifdef I_TIME -#include <time.h> -#endif -#ifdef I_SYSTIME -#ifdef SYSTIMEKERNEL -#define KERNEL -#endif -#include <sys/time.h> -#endif -#ifdef I_SYSSELECT -#include <sys/select.h> -#endif -main() -{ - struct tm foo; -#ifdef S_TIMEVAL - struct timeval bar; -#endif -#ifdef S_TIMEZONE - struct timezone tzp; -#endif - if (foo.tm_sec == foo.tm_sec) - exit(0); -#ifdef S_TIMEVAL - if (bar.tv_sec == bar.tv_sec) - exit(0); -#endif - exit(1); -} -EOCP -flags='' -s_timezone='' -sysselect='' -for s_timeval in '-DS_TIMEVAL' ''; do -for i_systimek in '' '-DSYSTIMEKERNEL'; do -for i_time in '' '-DI_TIME'; do -for i_systime in '-DI_SYSTIME' ''; do - case "$flags" in - '') $echo $n ".$c" - if $cc $ccflags \ - $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \ - try.c -o try >/dev/null 2>&1 ; then - set X $i_time $i_systime $i_systimek $sysselect $s_timeval - shift - flags="$*" - echo " " - $echo $n "Succeeded with $flags$c" - fi - ;; - esac -done -done -done -done -timeincl='' -echo " " -case "$flags" in -*SYSTIMEKERNEL*) i_systimek="$define" - timeincl=`./findhdr sys/time.h` - echo "We'll include <sys/time.h> with KERNEL defined." >&4;; -*) i_systimek="$undef";; -esac -case "$flags" in -*I_TIME*) i_time="$define" - timeincl=`./findhdr time.h`" $timeincl" - echo "We'll include <time.h>." >&4;; -*) i_time="$undef";; -esac -case "$flags" in -*I_SYSTIME*) i_systime="$define" - timeincl=`./findhdr sys/time.h`" $timeincl" - echo "We'll include <sys/time.h>." >&4;; -*) i_systime="$undef";; -esac -$rm -f try.c try - -: see if this is a unistd.h system -set unistd.h i_unistd -eval $inhdr - -: see if this is an utime system -set utime.h i_utime -eval $inhdr - -: see if this is a varargs system +: see if varags is available echo " " if $test `./findhdr varargs.h`; then - val="$define" echo "<varargs.h> found." >&4 else - val="$undef" echo "<varargs.h> NOT found, but that's ok (I hope)." >&4 fi -set i_varargs -eval $setvar : set up the varargs testing programs $cat > varargs.c <<EOP @@ -5732,37 +7095,95 @@ chmod +x varargs : now check which varargs header should be included echo " " i_varhdr='' -case "$i_stdarg" in +case "$valstd" in "$define") if `./varargs I_STDARG`; then - i_varhdr='stdarg.h' - i_varargs="$undef" + val='stdarg.h' elif `./varargs I_VARARGS`; then - i_varhdr='varargs.h' - i_stdarg="$undef" + val='varargs.h' fi ;; *) if `./varargs I_VARARGS`; then - i_varhdr='varargs.h' + val='varargs.h' fi ;; esac -case "$i_varhdr" in +case "$val" in '') echo "I could not find the definition for va_dcl... You have problems..." >&4 + val="$undef"; set i_stdarg; eval $setvar + val="$undef"; set i_varargs; eval $setvar ;; -*) echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;; +*) + set i_varhdr + eval $setvar + case "$i_varhdr" in + stdarg.h) + val="$define"; set i_stdarg; eval $setvar + val="$undef"; set i_varargs; eval $setvar + ;; + varargs.h) + val="$undef"; set i_stdarg; eval $setvar + val="$define"; set i_varargs; eval $setvar + ;; + esac + echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;; esac $rm -f varargs* +: see if stddef is available +set stddef.h i_stddef +eval $inhdr + +: see if stdlib is available +set stdlib.h i_stdlib +eval $inhdr + +: see if ioctl defs are in sgtty, termio, sys/filio or sys/ioctl +set sys/filio.h i_sysfilio +eval $inhdr +echo " " +if $test `./findhdr sys/ioctl.h`; then + val="$define" + echo '<sys/ioctl.h> found.' >&4 +else + val="$undef" + if $test $i_sysfilio = "$define"; then + echo '<sys/ioctl.h> NOT found.' >&4 + else + $test $i_sgtty = "$define" && xxx="sgtty.h" + $test $i_termio = "$define" && xxx="termio.h" + $test $i_termios = "$define" && xxx="termios.h" +echo "No <sys/ioctl.h> found, assuming ioctl args are defined in <$xxx>." >&4 + fi +fi +set i_sysioctl +eval $setvar + +: see if this is a sys/param system +set sys/param.h i_sysparam +eval $inhdr + +: see if this is a unistd.h system +set unistd.h i_unistd +eval $inhdr + +: see if this is an utime system +set utime.h i_utime +eval $inhdr + : see if this is a vfork system case "$d_vfork" in -define) set vfork.h i_vfork +"$define") + set vfork.h i_vfork eval $inhdr ;; -*) i_vfork="$undef";; +*) + i_vfork="$undef" + ;; esac + : end of configuration questions echo " " echo "End of configuration questions." @@ -5803,7 +7224,11 @@ $startsh # Configured by: $cf_by # Target system: $myuname +dynamic_ext='$dynamic_ext' extensions='$extensions' +known_extensions='$known_extensions' +static_ext='$static_ext' +useposix='$useposix' d_eunice='$d_eunice' d_xenix='$d_xenix' eunicefix='$eunicefix' @@ -5872,6 +7297,7 @@ uniq='$uniq' uuname='$uuname' vi='$vi' zcat='$zcat' +libswanted='$libswanted' hint='$hint' myuname='$myuname' osname='$osname' @@ -5887,7 +7313,12 @@ Revision='$Revision' Source='$Source' State='$State' afs='$afs' -memalignbytes='$memalignbytes' +alignbytes='$alignbytes' +archlib='$archlib' +archlibexp='$archlibexp' +archname='$archname' +d_archlib='$d_archlib' +installarchlib='$installarchlib' bin='$bin' binexp='$binexp' installbin='$installbin' @@ -5902,11 +7333,14 @@ optimize='$optimize' cf_by='$cf_by' cf_time='$cf_time' contains='$contains' +cpp_stuff='$cpp_stuff' cpplast='$cpplast' cppminus='$cppminus' cpprun='$cpprun' cppstdin='$cppstdin' d_access='$d_access' +d_alarm='$d_alarm' +d_attrib='$d_attrib' d_bcmp='$d_bcmp' d_bcopy='$d_bcopy' d_bzero='$d_bzero' @@ -5914,48 +7348,86 @@ d_casti32='$d_casti32' castflags='$castflags' d_castneg='$d_castneg' d_charsprf='$d_charsprf' +d_chown='$d_chown' +d_chroot='$d_chroot' d_chsize='$d_chsize' +d_closedir='$d_closedir' +d_void_closedir='$d_void_closedir' d_const='$d_const' cryptlib='$cryptlib' d_crypt='$d_crypt' d_csh='$d_csh' +d_cuserid='$d_cuserid' +d_dbl_dig='$d_dbl_dig' +d_difftime='$d_difftime' +d_dlerror='$d_dlerror' +d_dlopen='$d_dlopen' +d_dlsymun='$d_dlsymun' d_dosuid='$d_dosuid' +d_suidsafe='$d_suidsafe' +d_drem='$d_drem' d_dup2='$d_dup2' d_fchmod='$d_fchmod' d_fchown='$d_fchown' d_fcntl='$d_fcntl' +d_fd_macros='$d_fd_macros' +d_fd_set='$d_fd_set' +d_fds_bits='$d_fds_bits' +d_fgetpos='$d_fgetpos' d_flexfnam='$d_flexfnam' d_flock='$d_flock' +d_fmod='$d_fmod' +d_fork='$d_fork' +d_fsetpos='$d_fsetpos' +d_Gconvert='$d_Gconvert' d_getgrps='$d_getgrps' d_gethent='$d_gethent' aphostname='$aphostname' d_gethname='$d_gethname' d_phostname='$d_phostname' d_uname='$d_uname' +d_getlogin='$d_getlogin' d_getpgrp2='$d_getpgrp2' d_getpgrp='$d_getpgrp' +d_getppid='$d_getppid' d_getprior='$d_getprior' +d_group='$d_group' d_htonl='$d_htonl' d_isascii='$d_isascii' d_killpg='$d_killpg' d_link='$d_link' +d_linuxstd='$d_linuxstd' +d_locconv='$d_locconv' +d_lockf='$d_lockf' d_lstat='$d_lstat' +d_mblen='$d_mblen' +d_mbstowcs='$d_mbstowcs' +d_mbtowc='$d_mbtowc' d_memcmp='$d_memcmp' d_memcpy='$d_memcpy' d_memmove='$d_memmove' d_memset='$d_memset' d_mkdir='$d_mkdir' +d_mkfifo='$d_mkfifo' +d_mktime='$d_mktime' d_msg='$d_msg' d_msgctl='$d_msgctl' d_msgget='$d_msgget' d_msgrcv='$d_msgrcv' d_msgsnd='$d_msgsnd' +d_nice='$d_nice' d_open3='$d_open3' +d_passwd='$d_passwd' +d_fpathconf='$d_fpathconf' +d_pathconf='$d_pathconf' +d_pause='$d_pause' +d_pipe='$d_pipe' d_portable='$d_portable' d_readdir='$d_readdir' d_rewinddir='$d_rewinddir' d_seekdir='$d_seekdir' d_telldir='$d_telldir' +d_readlink='$d_readlink' d_rename='$d_rename' d_rmdir='$d_rmdir' d_safebcpy='$d_safebcpy' @@ -5967,6 +7439,7 @@ d_semget='$d_semget' d_semop='$d_semop' d_setegid='$d_setegid' d_seteuid='$d_seteuid' +d_setlinebuf='$d_setlinebuf' d_setlocale='$d_setlocale' d_setpgid='$d_setpgid' d_setpgrp2='$d_setpgrp2' @@ -5982,7 +7455,8 @@ d_setruid='$d_setruid' d_setsid='$d_setsid' d_shm='$d_shm' d_shmat='$d_shmat' -d_voidshmat='$d_voidshmat' +d_shmatprototype='$d_shmatprototype' +shmattype='$shmattype' d_shmctl='$d_shmctl' d_shmdt='$d_shmdt' d_shmget='$d_shmget' @@ -5995,25 +7469,28 @@ d_statblks='$d_statblks' d_stdstdio='$d_stdstdio' d_index='$d_index' d_strchr='$d_strchr' +d_strcoll='$d_strcoll' d_strctcpy='$d_strctcpy' d_strerrm='$d_strerrm' d_strerror='$d_strerror' d_sysernlst='$d_sysernlst' d_syserrlst='$d_syserrlst' +d_strxfrm='$d_strxfrm' d_symlink='$d_symlink' d_syscall='$d_syscall' +d_sysconf='$d_sysconf' d_system='$d_system' +d_tcgetpgrp='$d_tcgetpgrp' +d_tcsetpgrp='$d_tcsetpgrp' d_time='$d_time' timetype='$timetype' clocktype='$clocktype' d_times='$d_times' d_truncate='$d_truncate' -d_usendir='$d_usendir' -i_ndir='$i_ndir' -ndirc='$ndirc' -ndirlib='$ndirlib' -ndiro='$ndiro' +d_tzname='$d_tzname' +d_umask='$d_umask' d_vfork='$d_vfork' +usevfork='$usevfork' d_voidsig='$d_voidsig' signal_t='$signal_t' d_volatile='$d_volatile' @@ -6021,25 +7498,33 @@ d_charvspr='$d_charvspr' d_vprintf='$d_vprintf' d_wait4='$d_wait4' d_waitpid='$d_waitpid' +d_wcstombs='$d_wcstombs' +d_wctomb='$d_wctomb' +dlext='$dlext' cccdlflags='$cccdlflags' ccdlflags='$ccdlflags' -dldir='$dldir' -dlobj='$dlobj' dlsrc='$dlsrc' lddlflags='$lddlflags' -shlibsuffix='$shlibsuffix' usedl='$usedl' +fpostype='$fpostype' gidtype='$gidtype' groupstype='$groupstype' h_fcntl='$h_fcntl' h_sysfile='$h_sysfile' +i_db='$i_db' i_dbm='$i_dbm' d_dirnamlen='$d_dirnamlen' +direntrytype='$direntrytype' i_dirent='$i_dirent' +i_dld='$i_dld' i_dlfcn='$i_dlfcn' i_fcntl='$i_fcntl' +i_float='$i_float' i_gdbm='$i_gdbm' i_grp='$i_grp' +i_limits='$i_limits' +i_malloc='$i_malloc' +i_math='$i_math' i_memory='$i_memory' i_ndbm='$i_ndbm' i_neterrno='$i_neterrno' @@ -6052,19 +7537,21 @@ d_pwcomment='$d_pwcomment' d_pwexpire='$d_pwexpire' d_pwquota='$d_pwquota' i_pwd='$i_pwd' -i_sdbm='$i_sdbm' -i_stdarg='$i_stdarg' i_stddef='$i_stddef' +i_stdlib='$i_stdlib' i_string='$i_string' strings='$strings' i_sysdir='$i_sysdir' i_sysfile='$i_sysfile' d_voidtty='$d_voidtty' i_bsdioctl='$i_bsdioctl' +i_sysfilio='$i_sysfilio' i_sysioctl='$i_sysioctl' i_syssockio='$i_syssockio' i_sysndir='$i_sysndir' +i_sysparam='$i_sysparam' i_sysselct='$i_sysselct' +i_systimes='$i_systimes' i_sgtty='$i_sgtty' i_termio='$i_termio' i_termios='$i_termios' @@ -6074,13 +7561,13 @@ i_time='$i_time' timeincl='$timeincl' i_unistd='$i_unistd' i_utime='$i_utime' +i_stdarg='$i_stdarg' i_varargs='$i_varargs' i_varhdr='$i_varhdr' i_vfork='$i_vfork' intsize='$intsize' -lib='$lib' -libexp='$libexp' libc='$libc' +glibpth='$glibpth' libpth='$libpth' plibpth='$plibpth' xlibpth='$xlibpth' @@ -6102,6 +7589,7 @@ medium='$medium' models='$models' small='$small' split='$split' +modetype='$modetype' mydomain='$mydomain' myhostname='$myhostname' phostname='$phostname' @@ -6114,19 +7602,23 @@ orderlib='$orderlib' ranlib='$ranlib' package='$package' spackage='$spackage' +prefix='$prefix' installprivlib='$installprivlib' privlib='$privlib' privlibexp='$privlibexp' prototype='$prototype' -ptrsize='$ptrsize' randbits='$randbits' installscript='$installscript' scriptdir='$scriptdir' scriptdirexp='$scriptdirexp' +selecttype='$selecttype' sig_name='$sig_name' +sizetype='$sizetype' +so='$so' sharpbang='$sharpbang' shsharp='$shsharp' spitshell='$spitshell' +ssizetype='$ssizetype' startsh='$startsh' stdchar='$stdchar' sysman='$sysman' @@ -6238,4 +7730,6 @@ fi $rm -f kit*isdone ark*isdone $rm -rf UU + : End of Configure + diff --git a/perl5-notes b/Doc/perl5-notes index c8bb4ba702..c8bb4ba702 100644 --- a/perl5-notes +++ b/Doc/perl5-notes @@ -1,20 +1,10 @@ -/* $RCSfile: EXTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:03 $ +/* EXTERN.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: EXTERN.h,v $ - * Revision 4.1 92/08/07 17:18:03 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.1 91/06/07 10:10:32 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 00:58:26 lwall - * 4.0 baseline. - * */ #undef EXT diff --git a/HelpWanted b/HelpWanted deleted file mode 100644 index d4dcca9334..0000000000 --- a/HelpWanted +++ /dev/null @@ -1,13 +0,0 @@ -Anything in Todo that strikes your fancy and I agree to the design of - -Configure support - Dynamic loading - libperl.so - Drop-in module directories - -Test suite enhancement - POSIX - -Extension interface - Documentation - xvarpp @@ -1,20 +1,10 @@ -/* $RCSfile: INTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:04 $ +/* INTERN.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: INTERN.h,v $ - * Revision 4.1 92/08/07 17:18:04 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.1 91/06/07 10:10:42 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 00:58:35 lwall - * 4.0 baseline. - * */ #undef EXT @@ -1,73 +1,37 @@ Artistic The "Artistic License" -Configure Portability tool +Changes Differences between Perl 4 and Perl 5 +Configure Portability tool Copying The GNU General Public License +Doc/perl5-notes Samples of new functionality EXTERN.h Included before foreign .h files INTERN.h Included before domestic .h files MANIFEST This list of files Makefile.SH A script that generates Makefile README The Instructions -README.ncr Special instructions for NCR -README.uport Special instructions for Microports -README.xenix Special instructions for Xenix -XSUB.h -atarist/FILES -atarist/README.ST -atarist/RESULTS -atarist/atarist.c -atarist/config.h -atarist/echo.c -atarist/explain -atarist/makefile.sm -atarist/makefile.st -atarist/osbind.pl -atarist/perldb.diff -atarist/perlglob.c -atarist/test/binhandl -atarist/test/ccon -atarist/test/dbm -atarist/test/err -atarist/test/gdbm -atarist/test/gdbm.t -atarist/test/glob -atarist/test/osexample.pl -atarist/test/pi.pl -atarist/test/printenv -atarist/test/readme -atarist/test/sig -atarist/test/tbinmode -atarist/usersub.c -atarist/usub/README.ATARI -atarist/usub/acurses.mus -atarist/usub/makefile.st -atarist/usub/usersub.c -atarist/wildmat.c -autosplit -av.c -av.h -bar.pm +README.vms Notes about VMS +Todo The Wishlist +XSUB.h Include file for extension subroutines +autosplit Splits up autoloader functions +av.c Array value code +av.h Array value header c2ph.SH program to translate dbx stabs to perl c2ph.doc documentation for c2ph cflags.SH A script that emits C compilation flags per file -client A client to test sockets config.H Sample config.h config_h.SH Produces config.h configpm Produces lib/Config.pm -cop.h -cv.h -deb.c -dlperl/Makefile -dlperl/dlperl.c -dlperl/dlperl.doc -dlperl/dlperl.man -dlperl/usersub.c +cop.h Control operator header +cv.h Code value header +deb.c Debugging routines doSH Script to run all the *.SH files doio.c I/O operations doop.c Support code for various operations -dosish.h +dosish.h Some defines for MS/DOSish machines dump.c Debugging output eg/ADB An adb wrapper to put in your crash dir eg/README Intro to example perl scripts eg/changes A program to list recently changed files +eg/client A sample client eg/down A program to do things to subdirectories eg/dus A program to do du -s on non-mounted dirs eg/findcp A find wrapper that implements a -cp switch @@ -93,86 +57,109 @@ eg/scan/scan_ps Scan for process anomalies eg/scan/scan_sudo Scan for sudo anomalies eg/scan/scan_suid Scan for setuid anomalies eg/scan/scanner An anomaly reporter +eg/server A sample server eg/shmkill A program to remove unused shared memory eg/sysvipc/README Intro to Sys V IPC examples eg/sysvipc/ipcmsg Example of SYS V IPC message queues eg/sysvipc/ipcsem Example of Sys V IPC semaphores eg/sysvipc/ipcshm Example of Sys V IPC shared memory eg/travesty A program to print travesties of its input text -eg/unuc.pats -eg/uudecode +eg/unuc Un-uppercases an all-uppercase text +eg/uudecode A version of uudecode eg/van/empty A program to empty the trashcan eg/van/unvanish A program to undo what vanish does eg/van/vanexp A program to expire vanished files eg/van/vanish A program to put files in a trashcan eg/who A sample who program -emacs/cperl-mode -emacs/emacs19 +eg/wrapsuid A setuid script wrapper generator +emacs/cperl-mode An alternate perl-mode +emacs/emacs19 Notes about emacs 19 emacs/perl-mode.el Emacs major mode for perl emacs/perldb.el Emacs debugging emacs/perldb.pl Emacs debugging emacs/tedstuff Some optional patches -embed_h.SH -ext/README -ext/curses/Makefile -ext/curses/bsdcurses.mus -ext/curses/curses.mus -ext/curses/pager -ext/dbm/GDBM_File.xs GDBM extension -ext/dbm/Makefile -ext/dbm/NDBM_File.xs NDBM extension -ext/dbm/ODBM_File.xs ODBM extension -ext/dbm/SDBM_File.xs SDBM extension -ext/dbm/sdbm/CHANGES -ext/dbm/sdbm/COMPARE -ext/dbm/sdbm/Makefile.SH -ext/dbm/sdbm/README.too -ext/dbm/sdbm/biblio -ext/dbm/sdbm/dba.c -ext/dbm/sdbm/dbd.c -ext/dbm/sdbm/dbe.1 -ext/dbm/sdbm/dbe.c -ext/dbm/sdbm/dbm.c -ext/dbm/sdbm/dbm.h -ext/dbm/sdbm/dbu.c -ext/dbm/sdbm/grind -ext/dbm/sdbm/hash.c -ext/dbm/sdbm/linux.patches -ext/dbm/sdbm/makefile.sdbm -ext/dbm/sdbm/pair.c -ext/dbm/sdbm/pair.h -ext/dbm/sdbm/readme.ms -ext/dbm/sdbm/readme.ps -ext/dbm/sdbm/sdbm.3 -ext/dbm/sdbm/sdbm.c -ext/dbm/sdbm/sdbm.h -ext/dbm/sdbm/tune.h -ext/dbm/sdbm/util.c -ext/dbm/typemap -ext/dl/dl_hpux.c Dynamic loading for HPUX. -ext/dl/dl_next.c Dynamic loading for NeXT -ext/dl/dl_sunos.c Dynamic loading for SunOS 4.1.? -ext/dl/eg/Makefile -ext/dl/eg/Makefile.att -ext/dl/eg/main.c -ext/dl/eg/test.c -ext/dl/eg/test1.c -ext/man2mus -ext/mus -ext/posix/POSIX.xs -ext/posix/typemap -ext/typemap -ext/typemap.oi -ext/typemap.xlib -ext/typemap.xpm -ext/xsubpp -ext/xvarpp +embed.h Maps symbols to safer names +embed_h.SH Produces embed.h +ext/DB_File/DB_File.pm Berkeley DB extension Perl module +ext/DB_File/DB_File.xs Berkeley DB extension external subroutines +ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder +ext/DB_File/Makefile.SH Berkeley DB extension makefile writer +ext/DB_File/typemap Berkeley DB extension interface types +ext/DynaLoader/DynaLoader.doc Dynamic Loader specification +ext/DynaLoader/DynaLoader.pm Dynamic Loader perl module +ext/DynaLoader/Makefile.SH Dynamic Loader makefile writer +ext/DynaLoader/README Dynamic Loader notes and intro +ext/DynaLoader/dl_aix.xs AIX implementation +ext/DynaLoader/dl_dld.xs GNU dld style implementation +ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation +ext/DynaLoader/dl_hpux.xs HP-UX implementation +ext/DynaLoader/dl_next.xs Next implementation +ext/DynaLoader/dl_none.xs Stub implementation +ext/DynaLoader/dl_vms.xs VMS implementation +ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files +ext/Fcntl/Fcntl.pm Fcntl extension Perl module +ext/Fcntl/Fcntl.xs Fcntl extension external subroutines +ext/Fcntl/MANIFEST Fcntl extension file list +ext/Fcntl/Makefile.SH Fcntl extension makefile writer +ext/GDBM_File/GDBM_File.pm GDBM extension Perl module +ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines +ext/GDBM_File/Makefile.SH GDBM extension makefile writer +ext/GDBM_File/typemap GDBM extension interface types +ext/NDBM_File/Makefile.SH NDBM extension makefile writer +ext/NDBM_File/NDBM_File.pm NDBM extension Perl module +ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines +ext/NDBM_File/typemap NDBM extension interface types +ext/ODBM_File/Makefile.SH ODBM extension makefile writer +ext/ODBM_File/ODBM_File.pm ODBM extension Perl module +ext/ODBM_File/ODBM_File.xs ODBM extension external subroutines +ext/ODBM_File/typemap ODBM extension interface types +ext/POSIX/Makefile.SH POSIX extension makefile writer +ext/POSIX/POSIX.pm POSIX extension Perl module +ext/POSIX/POSIX.xs POSIX extension external subroutines +ext/POSIX/typemap POSIX extension interface types +ext/SDBM_File/Makefile.SH SDBM extension makefile writer +ext/SDBM_File/SDBM_File.pm SDBM extension Perl module +ext/SDBM_File/SDBM_File.xs SDBM extension external subroutines +ext/SDBM_File/sdbm/CHANGES SDBM kit +ext/SDBM_File/sdbm/COMPARE SDBM kit +ext/SDBM_File/sdbm/Makefile.SH SDBM kit +ext/SDBM_File/sdbm/README SDBM kit +ext/SDBM_File/sdbm/README.too SDBM kit +ext/SDBM_File/sdbm/biblio SDBM kit +ext/SDBM_File/sdbm/dba.c SDBM kit +ext/SDBM_File/sdbm/dbd.c SDBM kit +ext/SDBM_File/sdbm/dbe.1 SDBM kit +ext/SDBM_File/sdbm/dbe.c SDBM kit +ext/SDBM_File/sdbm/dbm.c SDBM kit +ext/SDBM_File/sdbm/dbm.h SDBM kit +ext/SDBM_File/sdbm/dbu.c SDBM kit +ext/SDBM_File/sdbm/grind SDBM kit +ext/SDBM_File/sdbm/hash.c SDBM kit +ext/SDBM_File/sdbm/linux.patches SDBM kit +ext/SDBM_File/sdbm/makefile.sdbm SDBM kit +ext/SDBM_File/sdbm/pair.c SDBM kit +ext/SDBM_File/sdbm/pair.h SDBM kit +ext/SDBM_File/sdbm/readme.ms SDBM kit +ext/SDBM_File/sdbm/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/Socket/Makefile.SH Socket extension makefile writer +ext/Socket/Socket.pm Socket extension Perl module +ext/Socket/Socket.xs Socket extension external subroutines +ext/typemap Extension interface types +ext/util/extliblist Used by extension Makefile.SH to make lib lists +ext/util/make_ext Used by Makefile to execute extension Makefiles +ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info +ext/xsubpp External subroutine preprocessor form.h Public declarations for the above -gettest A little script to test the get* routines -global.sym -gv.c -gv.h -h2ph.SH A thing to turn C .h file into perl .ph files +global.sym Symbols that need hiding when embedded +gv.c Glob value code +gv.h Glob value header +h2ph.SH A thing to turn C .h files into perl .ph files h2pl/README How to turn .ph files into .pl files h2pl/cbreak.pl cbreak routines using .ph h2pl/cbreak2.pl cbreak routines using .pl @@ -181,209 +168,246 @@ h2pl/eg/sys/errno.pl Sample translated errno.pl h2pl/eg/sys/ioctl.pl Sample translated ioctl.pl h2pl/eg/sysexits.pl Sample translated sysexits.pl h2pl/getioctlsizes Program to extract types from ioctl.h -h2pl/mksizes Program to make %sizeof array. +h2pl/mksizes Program to make %sizeof array h2pl/mkvars Program to make .pl from .ph files h2pl/tcbreak cbreak test routine using .ph h2pl/tcbreak2 cbreak test routine using .pl +h2xs Program to make .xs files from C header files handy.h Handy definitions -hints/3b1.sh -hints/3b1cc -hints/3b2.sh -hints/aix_rs.sh -hints/aix_rt.sh -hints/altos486.sh -hints/apollo_C6_7.sh -hints/apollo_C6_8.sh -hints/aux.sh -hints/cray.sh -hints/dec_osf_1.sh -hints/dec_osf_2.sh -hints/dec_osf_3.sh -hints/dgux.sh -hints/dnix.sh -hints/dynix.sh -hints/fps.sh -hints/genix.sh -hints/greenhills.sh -hints/hp9000_300.sh -hints/hp9000_400.sh -hints/hp9000_700.sh -hints/hp9000_800.sh -hints/hpux.sh -hints/i386.sh -hints/isc_3_2_2.sh -hints/isc_3_2_3.sh -hints/mc6000.sh -hints/mips.sh -hints/mpc.sh -hints/ncr_tower.sh -hints/next.sh -hints/next_3_2.sh -hints/opus.sh -hints/osf1.sh -hints/sco_2_3_0.sh -hints/sco_2_3_1.sh -hints/sco_2_3_2.sh -hints/sco_2_3_3.sh -hints/sco_2_3_4.sh -hints/sco_3.sh -hints/sgi.sh -hints/solaris_2_0.sh -hints/solaris_2_1.sh -hints/solaris_2_2.sh -hints/solaris_2_3.sh -hints/stellar.sh -hints/sunos_3_4.sh -hints/sunos_3_5.sh -hints/sunos_4_0_1.sh -hints/sunos_4_0_2.sh -hints/sunos_4_1_2.sh -hints/sunos_4_1_3.sh -hints/svr4.sh -hints/ti1500.sh -hints/titan.sh -hints/ultrix_1.sh -hints/ultrix_3.sh -hints/ultrix_4.sh -hints/unisysdynix.sh -hints/utekv.sh -hints/uts.sh -hints/vax.sh -hv.c -hv.h -hvdbm.h +hints/3b1.sh Hints for named architecture +hints/3b1cc Hints for named architecture +hints/README.hints Hints for named architecture +hints/aix.sh Hints for named architecture +hints/altos486.sh Hints for named architecture +hints/apollo.sh Hints for named architecture +hints/aux.sh Hints for named architecture +hints/bsd386.sh Hints for named architecture +hints/dec_osf.sh Hints for named architecture +hints/dgux.sh Hints for named architecture +hints/dnix.sh Hints for named architecture +hints/dynix.sh Hints for named architecture +hints/esix4.sh Hints for named architecture +hints/fps.sh Hints for named architecture +hints/freebsd.sh Hints for named architecture +hints/genix.sh Hints for named architecture +hints/greenhills.sh Hints for named architecture +hints/hpux_9.sh Hints for named architecture +hints/i386.sh Hints for named architecture +hints/irix_4.sh Hints for named architecture +hints/irix_5.sh Hints for named architecture +hints/isc.sh Hints for named architecture +hints/isc_2.sh Hints for named architecture +hints/linux.sh Hints for named architecture +hints/mips.sh Hints for named architecture +hints/mpc.sh Hints for named architecture +hints/ncr_tower.sh Hints for named architecture +hints/netbsd.sh Hints for named architecture +hints/next_3_2.sh Hints for named architecture +hints/opus.sh Hints for named architecture +hints/sco_2_3_0.sh Hints for named architecture +hints/sco_2_3_1.sh Hints for named architecture +hints/sco_2_3_2.sh Hints for named architecture +hints/sco_2_3_3.sh Hints for named architecture +hints/sco_2_3_4.sh Hints for named architecture +hints/sco_3.sh Hints for named architecture +hints/solaris_2.sh Hints for named architecture +hints/stellar.sh Hints for named architecture +hints/sunos_4_0.sh Hints for named architecture +hints/sunos_4_1.sh Hints for named architecture +hints/svr4.sh Hints for named architecture +hints/ti1500.sh Hints for named architecture +hints/titanos.sh Hints for named architecture +hints/ultrix_4.sh Hints for named architecture +hints/unicos.sh Hints for named architecture +hints/unisysdynix.sh Hints for named architecture +hints/utekv.sh Hints for named architecture +hints/uts.sh Hints for named architecture +hv.c Hash value code +hv.h Hash value header installperl Perl script to do "make install" dirty work -interp.sym +interp.sym Interpreter specific symbols to hide in a struct ioctl.pl Sample ioctl.pl -keywords.h -lib/AutoLoader.pm -lib/English.pm -lib/Exporter.pm -lib/FOOBAR.pm -lib/FileHandle.pm -lib/Hostname.pm -lib/NDBM_File.pm -lib/POSIX.pm -lib/SDBM_File.pm +keywords.h The keyword numbers +keywords.pl Program to write keywords.h +lib/AnyDBM_File.pm Perl module to emulate dbmopen +lib/AutoLoader.pm Autoloader base class +lib/AutoSplit.pm A module to split up autoload functions +lib/Benchmark.pm A module to time pieces of code and such +lib/Carp.pm Error message base class +lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) +lib/English.pm Readable aliases for short variables +lib/Env.pm Map environment into ordinary variables +lib/Exporter.pm Exporter base class +lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions +lib/File/Basename.pm A module to emulate the basename program +lib/File/CheckTree.pm Perl module supporting wholesale file mode validation +lib/File/Find.pm Routines to do a find +lib/FileHandle.pm FileHandle methods +lib/Shell.pm A module to make AUTOLOADEed system() calls +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 +lib/IPC/Open2.pm Open a two-ended pipe +lib/IPC/Open3.pm Open a three-ended pipe! +lib/Math/BigInt.pm An arbitrary precision integer arithmetic package +lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package +lib/Math/Complex.pm A Complex package +lib/Net/Ping.pm Ping methods +lib/Search/Dict.pm A module to do binary search on dictionaries +lib/Sys/Hostname.pm Hostname methods +lib/Sys/Syslog.pm Perl module supporting syslogging +lib/Term/Cap.pm Perl module supporting termcap usage +lib/Term/Complete.pm A command completion subroutine +lib/Test/Harness.pm A test harness +lib/Text/Abbrev.pm An abbreviation table builder +lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter +lib/Text/Soundex.pm Perl module to implement Soundex +lib/Text/Tabs.pm Do expand and unexpand +lib/TieHash.pm Base class for tied hashes +lib/Time/Local.pm Reverse translation of localtime, gmtime lib/abbrev.pl An abbreviation table builder lib/assert.pl assertion and panic with stack trace lib/bigfloat.pl An arbitrary precision floating point package lib/bigint.pl An arbitrary precision integer arithmetic package lib/bigrat.pl An arbitrary precision rational arithmetic package lib/cacheout.pl Manages output filehandles when you need too many +lib/chat2.inter A chat2 with interaction lib/chat2.pl Randal's famous expect-ish routines lib/complete.pl A command completion subroutine lib/ctime.pl A ctime workalike -lib/dotsh.pl.art +lib/dotsh.pl Code to "dot" in a shell script lib/dumpvar.pl A variable dumper lib/exceptions.pl catch and throw routines lib/fastcwd.pl a faster but more dangerous getcwd lib/find.pl A find emulator--used by find2perl lib/finddepth.pl A depth-first find emulator--used by find2perl lib/flush.pl Routines to do single flush -lib/ftp.pl -lib/getcwd.pl a getcwd() emulator +lib/ftp.pl FTP code +lib/getcwd.pl A getcwd() emulator lib/getopt.pl Perl library supporting option parsing lib/getopts.pl Perl library supporting option parsing -lib/hostname.pl +lib/hostname.pl Old hostname code lib/importenv.pl Perl routine to get environment into variables +lib/integer.pm For "use integer" +lib/less.pm For "use less" lib/look.pl A "look" equivalent lib/newgetopt.pl A perl library supporting long option parsing -lib/open2.pl -lib/open3.pl -lib/perldb.pl Perl debugging routines +lib/open2.pl Open a two-ended pipe +lib/open3.pl Open a three-ended pipe +lib/perl5db.pl Perl debugging routines lib/pwd.pl Routines to keep track of PWD environment variable -lib/quotewords.pl.art lib/shellwords.pl Perl library to split into words with shell quoting -lib/soundex.pl.art +lib/sigtrap.pm For trapping an abort and giving traceback lib/stat.pl Perl library supporting stat function +lib/strict.pm For "use strict" +lib/subs.pm Declare overriding subs lib/syslog.pl Perl library supporting syslogging -lib/tainted.pl +lib/tainted.pl Old code for tainting lib/termcap.pl Perl library supporting termcap usage lib/timelocal.pl Perl library supporting inverse of localtime, gmtime lib/validate.pl Perl library supporting wholesale file mode validation makedepend.SH Precursor to makedepend makedir.SH Precursor to makedir -makefile.lib make libperl.a malloc.c A version of malloc you might not want -mg.c -mg.h -miniperlmain.c Basic perl w/o dynamic loading or extensions. -msdos/Changes.dds Expanation of MS-DOS patches by Diomidis Spinellis -msdos/Makefile MS-DOS makefile -msdos/README.msdos Compiling and usage information -msdos/Wishlist.dds My wishlist -msdos/chdir.c A chdir that can change drives -msdos/config.h Definitions for msdos -msdos/dir.h MS-DOS header for directory access functions -msdos/directory.c MS-DOS directory access functions. -msdos/eg/crlf.bat Convert files from unix to MS-DOS line termination -msdos/eg/drives.bat List the system drives and their characteristics -msdos/eg/lf.bat Convert files from MS-DOS to Unix line termination -msdos/glob.c A command equivalent to csh glob -msdos/msdos.c MS-DOS ioctl, sleep, gete?[gu]if, spawn, aspawn -msdos/popen.c My_popen and my_pclose for MS-DOS -msdos/usage.c How to invoke perl under MS-DOS -opcode.h -opcode.pl -os2/Makefile Makefile for OS/2 -os2/README.OS2 Notes for OS/2 -os2/a2p.cs Compiler script for a2p -os2/a2p.def Linker defs for a2p -os2/alarm.c An implementation of alarm() -os2/alarm.h Header file for same -os2/config.h Configuration file for OS/2 -os2/crypt.c -os2/dir.h Directory header -os2/director.c Directory routines -os2/eg/alarm.pl Example of alarm code -os2/eg/os2.pl Sample script for OS/2 -os2/eg/syscalls.pl Example of syscall on OS/2 -os2/glob.c Globbing routines -os2/makefile Make file -os2/mktemp.c Mktemp() using TMP -os2/os2.c Unix compatibility functions -os2/perl.bad names of protect-only API calls for BIND -os2/perl.cs Compiler script for perl -os2/perl.def Linker defs for perl -os2/perldb.dif Changes to make the debugger work -os2/perlglob.bad names of protect-only API calls for BIND -os2/perlglob.cs Compiler script for perlglob -os2/perlglob.def Linker defs for perlglob -os2/perlsh.cmd Poor man's shell for os2 -os2/popen.c Code for opening pipes -os2/s2p.cmd s2p as command file -os2/selfrun.bat A self running perl script for DOS -os2/selfrun.cmd Example of extproc feature -os2/suffix.c Code for creating backup filenames -os2/tests.dif +mg.c Magic code +mg.h Magic header +miniperlmain.c Basic perl w/o dynamic loading or extensions +mv-if-diff Script to mv a file if it changed +myconfig Prints summary of the current configuration +op.c Opcode syntax tree code +op.h Opcode syntax tree header +opcode.h Automatically generated opcode header +opcode.pl Opcode header generatore patchlevel.h The current patch level of perl perl.c main() perl.h Global declarations -perl.man The manual page(s) +perl_exp.SH Creates list of exported symbols for AIX. perlsh A poor man's perl shell -perly.c -perly.c.byacc -perly.c.diff -perly.c.yacc +perly.c A byacc'ed perly.y +perly.c.diff Fixup perly.c to allow recursion perly.fixer A program to remove yacc stack limitations -perly.h.yacc +perly.h The header file for perly.c perly.y Yacc grammar for perl -perly.y.save +pl2pm A pl to pm translator +pod/Makefile Make pods into something else +pod/modpods/Abbrev.pod Doc for Abbrev.pm +pod/modpods/AnyDBMFile.pod Doc for AnyDBMFile.pm +pod/modpods/AutoLoader.pod Doc for AutoLoader.pm +pod/modpods/AutoSplit.pod Doc for AutoSplit.pm +pod/modpods/Basename.pod Doc for Basename.pm +pod/modpods/Benchmark.pod Doc for Benchmark.pm +pod/modpods/Carp.pod Doc for Carp.pm +pod/modpods/CheckTree.pod Doc for CheckTree.pm +pod/modpods/Collate.pod Doc for Collate.pm +pod/modpods/Config.pod Doc for Config.pm +pod/modpods/Cwd.pod Doc for Cwd.pm +pod/modpods/DB_File.pod Doc for File.pm +pod/modpods/Dynaloader.pod Doc for Dynaloader.pm +pod/modpods/English.pod Doc for English.pm +pod/modpods/Env.pod Doc for Env.pm +pod/modpods/Exporter.pod Doc for Exporter.pm +pod/modpods/Fcntl.pod Doc for Fcntl.pm +pod/modpods/FileHandle.pod Doc for FileHandle.pm +pod/modpods/Find.pod Doc for Find.pm +pod/modpods/Finddepth.pod Doc for Finddepth.pm +pod/modpods/GetOptions.pod Doc for GetOptions.pm +pod/modpods/Getopt.pod Doc for Getopt.pm +pod/modpods/MakeMaker.pod Doc for MakeMaker.pm +pod/modpods/Open2.pod Doc for Open2.pm +pod/modpods/Open3.pod Doc for Open3.pm +pod/modpods/POSIX.pod Doc for POSIX.pm +pod/modpods/Ping.pod Doc for Ping.pm +pod/modpods/Socket.pod Doc for Socket.pm +pod/modpods/integer.pod Doc for integer.pm +pod/modpods/less.pod Doc for less.pm +pod/modpods/sigtrap.pod Doc for sigtrap.pm +pod/modpods/strict.pod Doc for strict.pm +pod/modpods/subs.pod Doc for subs.pm +pod/perl.pod Top level perl man page +pod/perlapi.pod XS api info +pod/perlbook.pod Book info +pod/perlbot.pod Object-oriented Bag o' Tricks +pod/perlcall.pod Callback info +pod/perldata.pod Data structure info +pod/perldebug.pod Debugger info +pod/perldiag.pod Diagnostic info +pod/perlembed.pod Embedding info +pod/perlform.pod Format info +pod/perlfunc.pod Function info +pod/perlguts.pod Internals info +pod/perlipc.pod IPC info +pod/perlmod.pod Module info +pod/perlobj.pod Object info +pod/perlop.pod Operator info +pod/perlovl.pod Overloading info +pod/perlpod.pod Pod info +pod/perlre.pod Regular expression info +pod/perlref.pod References info +pod/perlrun.pod Execution info +pod/perlsec.pod Security info +pod/perlstyle.pod Style info +pod/perlsub.pod Subroutine info +pod/perlsyn.pod Syntax info +pod/perltrap.pod Trap info +pod/perlvar.pod Variable info +pod/pod2html Translator to turn pod into HTML +pod/pod2man Translator to turn pod into manpage +pod/splitman Splits perlfunc into multiple man pages pp.c Push/Pop code pp.h Push/Pop code defs -proto.h -protos +pp_ctl.c Push/Pop code for control flow +pp_hot.c Push/Pop code for heavily used opcodes +pp_sys.c Push/Pop code for system interaction +proto.h Prototypes regcomp.c Regular expression compiler regcomp.h Private declarations for above regexec.c Regular expression evaluator regexp.h Public declarations for the above -scope.c -scope.h -server A server to test sockets -sortfunc -sv.c -sv.h +run.c The interpreter loop +scope.c Scope entry and exit code +scope.h Scope entry and exit header +sv.c Scalar value code +sv.h Scalar value header t/README Instructions for regression tests t/TEST The regression tester t/base/cond.t See if conditionals work @@ -411,10 +435,18 @@ t/io/inplace.t See if inplace editing works t/io/pipe.t See if secure pipes work t/io/print.t See if print commands work t/io/tell.t See if file seeking works -t/lib/bigint.t -t/lib/english.t -t/lib/ndbm.t -t/lib/sdbm.t +t/lib/anydbm.t See if AnyDBM_File works +t/lib/bigint.t See if bigint.pl works +t/lib/db-btree.t See if DB_File works +t/lib/db-hash.t See if DB_File works +t/lib/db-recno.t See if DB_File works +t/lib/english.t See if English 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/sdbm.t See if SDBM_File works +t/lib/soundex.t See if Soundex works t/op/append.t See if . works t/op/array.t See if array operations work t/op/auto.t See if autoincrement et all work @@ -437,18 +469,21 @@ t/op/join.t See if join works t/op/list.t See if array lists work t/op/local.t See if local works t/op/magic.t See if magic variables work +t/op/misc.t See if miscellaneous bugs have been fixed t/op/mkdir.t See if mkdir works -t/op/my.t +t/op/my.t See if lexical scoping works t/op/oct.t See if oct and hex work t/op/ord.t See if ord works t/op/pack.t See if pack and unpack work t/op/pat.t See if esoteric patterns work t/op/push.t See if push and pop work +t/op/quotemeta.t See if quotemeta works +t/op/rand.t See if rand works t/op/range.t See if .. works t/op/re_tests Input file for op.regexp t/op/read.t See if read() works t/op/readdir.t See if readdir() works -t/op/ref.t +t/op/ref.t See if refs and objects work t/op/regexp.t See if regular expressions work t/op/repeat.t See if x operator works t/op/sleep.t See if sleep works @@ -457,20 +492,35 @@ t/op/split.t See if split works t/op/sprintf.t See if sprintf works t/op/stat.t See if stat works t/op/study.t See if study works -t/op/subst.t +t/op/subst.t See if substitution works t/op/substr.t See if substr works t/op/time.t See if time functions work t/op/undef.t See if undef works t/op/unshift.t See if unshift works t/op/vec.t See if vectors work t/op/write.t See if write works -taint.c +t/re_tests Regular expressions for regexp.t +taint.c Tainting code toke.c The tokener -unixish.h -usersub.c User supplied (possibly proprietary) subroutines +unixish.h Defines that are assumed on Unix util.c Utility routines util.h Public declarations for the above -writemain.SH Generate perlmain.c from miniperlmain.c+extensions. +vms/config.vms VMS port +vms/descrip.mms VMS port +vms/genconfig.pl VMS port +vms/genopt.com VMS port +vms/gen_shrfls.pl VMS port +vms/makefile. VMS port +vms/mms2make.pl VMS port +vms/perlshr.c VMS port +vms/perlvms.pod VMS port +vms/sockadapt.c VMS port +vms/sockadapt.h VMS port +vms/test.com VMS port +vms/vms.c VMS port +vms/vmsish.h VMS port +vms/writemain.pl VMS port +writemain.SH Generate perlmain.c from miniperlmain.c+extensions x2p/EXTERN.h Same as above x2p/INTERN.h Same as above x2p/Makefile.SH Precursor to Makefile @@ -483,7 +533,7 @@ x2p/find2perl.SH A find to perl translator x2p/handy.h Handy definitions x2p/hash.c Associative arrays again x2p/hash.h Public declarations for the above -x2p/malloc.c +x2p/malloc.c Malloc code x2p/s2p.SH Sed to perl translator x2p/s2p.man Manual page for sed to perl translator x2p/str.c String handling package @@ -491,3 +541,4 @@ x2p/str.h Public declarations for the above x2p/util.c Utility routines x2p/util.h Public declarations for the above x2p/walk.c Parse tree walker +xf A script to translate Perl 4 symbols to Perl 5 diff --git a/MANIFEST.new b/MANIFEST.new deleted file mode 100644 index a71f86d46a..0000000000 --- a/MANIFEST.new +++ /dev/null @@ -1,493 +0,0 @@ -Artistic The "Artistic License" -Configure Portability tool -Copying The GNU General Public License -EXTERN.h Included before foreign .h files -INTERN.h Included before domestic .h files -MANIFEST This list of files -Makefile.SH A script that generates Makefile -README The Instructions -README.ncr Special instructions for NCR -README.uport Special instructions for Microports -README.xenix Special instructions for Xenix -XSUB.h -atarist/FILES -atarist/README.ST -atarist/RESULTS -atarist/atarist.c -atarist/config.h -atarist/echo.c -atarist/explain -atarist/makefile.sm -atarist/makefile.st -atarist/osbind.pl -atarist/perldb.diff -atarist/perlglob.c -atarist/test/binhandl -atarist/test/ccon -atarist/test/dbm -atarist/test/err -atarist/test/gdbm -atarist/test/gdbm.t -atarist/test/glob -atarist/test/osexample.pl -atarist/test/pi.pl -atarist/test/printenv -atarist/test/readme -atarist/test/sig -atarist/test/tbinmode -atarist/usersub.c -atarist/usub/README.ATARI -atarist/usub/acurses.mus -atarist/usub/makefile.st -atarist/usub/usersub.c -atarist/wildmat.c -autosplit -av.c -av.h -bar.pm -c2ph.SH program to translate dbx stabs to perl -c2ph.doc documentation for c2ph -cflags.SH A script that emits C compilation flags per file -client A client to test sockets -config.H Sample config.h -config_h.SH Produces config.h -configpm Produces lib/Config.pm -cop.h -cv.h -deb.c -dlperl/Makefile -dlperl/dlperl.c -dlperl/dlperl.doc -dlperl/dlperl.man -dlperl/usersub.c -doSH Script to run all the *.SH files -doio.c I/O operations -doop.c Support code for various operations -dosish.h -dump.c Debugging output -eg/ADB An adb wrapper to put in your crash dir -eg/README Intro to example perl scripts -eg/changes A program to list recently changed files -eg/down A program to do things to subdirectories -eg/dus A program to do du -s on non-mounted dirs -eg/findcp A find wrapper that implements a -cp switch -eg/findtar A find wrapper that pumps out a tar file -eg/g/gcp A program to do a global rcp -eg/g/gcp.man Manual page for gcp -eg/g/ged A program to do a global edit -eg/g/ghosts A sample /etc/ghosts file -eg/g/gsh A program to do a global rsh -eg/g/gsh.man Manual page for gsh -eg/muck A program to find missing make dependencies -eg/muck.man Manual page for muck -eg/myrup A program to find lightly loaded machines -eg/nih Script to insert #! workaround -eg/relink A program to change symbolic links -eg/rename A program to rename files -eg/rmfrom A program to feed doomed filenames to -eg/scan/scan_df Scan for filesystem anomalies -eg/scan/scan_last Scan for login anomalies -eg/scan/scan_messages Scan for console message anomalies -eg/scan/scan_passwd Scan for passwd file anomalies -eg/scan/scan_ps Scan for process anomalies -eg/scan/scan_sudo Scan for sudo anomalies -eg/scan/scan_suid Scan for setuid anomalies -eg/scan/scanner An anomaly reporter -eg/shmkill A program to remove unused shared memory -eg/sysvipc/README Intro to Sys V IPC examples -eg/sysvipc/ipcmsg Example of SYS V IPC message queues -eg/sysvipc/ipcsem Example of Sys V IPC semaphores -eg/sysvipc/ipcshm Example of Sys V IPC shared memory -eg/travesty A program to print travesties of its input text -eg/unuc.pats -eg/uudecode -eg/van/empty A program to empty the trashcan -eg/van/unvanish A program to undo what vanish does -eg/van/vanexp A program to expire vanished files -eg/van/vanish A program to put files in a trashcan -eg/who A sample who program -emacs/cperl-mode -emacs/emacs19 -emacs/perl-mode.el Emacs major mode for perl -emacs/perldb.el Emacs debugging -emacs/perldb.pl Emacs debugging -emacs/tedstuff Some optional patches -embed_h.SH -ext/README -ext/curses/Makefile -ext/curses/bsdcurses.mus -ext/curses/curses.mus -ext/curses/pager -ext/dbm/GDBM_File.xs GDBM extension -ext/dbm/Makefile -ext/dbm/NDBM_File.xs NDBM extension -ext/dbm/ODBM_File.xs ODBM extension -ext/dbm/SDBM_File.xs SDBM extension -ext/dbm/sdbm/CHANGES -ext/dbm/sdbm/COMPARE -ext/dbm/sdbm/Makefile.SH -ext/dbm/sdbm/README.too -ext/dbm/sdbm/biblio -ext/dbm/sdbm/dba.c -ext/dbm/sdbm/dbd.c -ext/dbm/sdbm/dbe.1 -ext/dbm/sdbm/dbe.c -ext/dbm/sdbm/dbm.c -ext/dbm/sdbm/dbm.h -ext/dbm/sdbm/dbu.c -ext/dbm/sdbm/grind -ext/dbm/sdbm/hash.c -ext/dbm/sdbm/linux.patches -ext/dbm/sdbm/makefile.sdbm -ext/dbm/sdbm/pair.c -ext/dbm/sdbm/pair.h -ext/dbm/sdbm/readme.ms -ext/dbm/sdbm/readme.ps -ext/dbm/sdbm/sdbm.3 -ext/dbm/sdbm/sdbm.c -ext/dbm/sdbm/sdbm.h -ext/dbm/sdbm/tune.h -ext/dbm/sdbm/util.c -ext/dbm/typemap -ext/dl/dl_hpux.c Dynamic loading for HPUX. -ext/dl/dl_next.c Dynamic loading for NeXT -ext/dl/dl_sunos.c Dynamic loading for SunOS 4.1.? -ext/dl/eg/Makefile -ext/dl/eg/Makefile.att -ext/dl/eg/main.c -ext/dl/eg/test.c -ext/dl/eg/test1.c -ext/man2mus -ext/mus -ext/posix/POSIX.xs -ext/posix/typemap -ext/typemap -ext/typemap.oi -ext/typemap.xlib -ext/typemap.xpm -ext/xsubpp -ext/xvarpp -form.h Public declarations for the above -gettest A little script to test the get* routines -global.sym -gv.c -gv.h -h2ph.SH A thing to turn C .h file into perl .ph files -h2pl/README How to turn .ph files into .pl files -h2pl/cbreak.pl cbreak routines using .ph -h2pl/cbreak2.pl cbreak routines using .pl -h2pl/eg/sizeof.ph Sample sizeof array initialization -h2pl/eg/sys/errno.pl Sample translated errno.pl -h2pl/eg/sys/ioctl.pl Sample translated ioctl.pl -h2pl/eg/sysexits.pl Sample translated sysexits.pl -h2pl/getioctlsizes Program to extract types from ioctl.h -h2pl/mksizes Program to make %sizeof array. -h2pl/mkvars Program to make .pl from .ph files -h2pl/tcbreak cbreak test routine using .ph -h2pl/tcbreak2 cbreak test routine using .pl -handy.h Handy definitions -hints/3b1.sh -hints/3b1cc -hints/3b2.sh -hints/aix_rs.sh -hints/aix_rt.sh -hints/altos486.sh -hints/apollo_C6_7.sh -hints/apollo_C6_8.sh -hints/aux.sh -hints/cray.sh -hints/dec_osf_1.sh -hints/dec_osf_2.sh -hints/dec_osf_3.sh -hints/dgux.sh -hints/dnix.sh -hints/dynix.sh -hints/fps.sh -hints/genix.sh -hints/greenhills.sh -hints/hp9000_300.sh -hints/hp9000_400.sh -hints/hp9000_700.sh -hints/hp9000_800.sh -hints/hpux.sh -hints/i386.sh -hints/isc_3_2_2.sh -hints/isc_3_2_3.sh -hints/mc6000.sh -hints/mips.sh -hints/mpc.sh -hints/ncr_tower.sh -hints/next.sh -hints/next_3_2.sh -hints/opus.sh -hints/osf1.sh -hints/sco_2_3_0.sh -hints/sco_2_3_1.sh -hints/sco_2_3_2.sh -hints/sco_2_3_3.sh -hints/sco_2_3_4.sh -hints/sco_3.sh -hints/sgi.sh -hints/solaris_2_0.sh -hints/solaris_2_1.sh -hints/solaris_2_2.sh -hints/solaris_2_3.sh -hints/stellar.sh -hints/sunos_3_4.sh -hints/sunos_3_5.sh -hints/sunos_4_0_1.sh -hints/sunos_4_0_2.sh -hints/sunos_4_1_2.sh -hints/sunos_4_1_3.sh -hints/svr4.sh -hints/ti1500.sh -hints/titan.sh -hints/ultrix_1.sh -hints/ultrix_3.sh -hints/ultrix_4.sh -hints/unisysdynix.sh -hints/utekv.sh -hints/uts.sh -hints/vax.sh -hv.c -hv.h -hvdbm.h -installperl Perl script to do "make install" dirty work -interp.sym -ioctl.pl Sample ioctl.pl -keywords.h -lib/AutoLoader.pm -lib/English.pm -lib/Exporter.pm -lib/FOOBAR.pm -lib/FileHandle.pm -lib/Hostname.pm -lib/NDBM_File.pm -lib/POSIX.pm -lib/SDBM_File.pm -lib/abbrev.pl An abbreviation table builder -lib/assert.pl assertion and panic with stack trace -lib/bigfloat.pl An arbitrary precision floating point package -lib/bigint.pl An arbitrary precision integer arithmetic package -lib/bigrat.pl An arbitrary precision rational arithmetic package -lib/cacheout.pl Manages output filehandles when you need too many -lib/chat2.pl Randal's famous expect-ish routines -lib/complete.pl A command completion subroutine -lib/ctime.pl A ctime workalike -lib/dotsh.pl.art -lib/dumpvar.pl A variable dumper -lib/exceptions.pl catch and throw routines -lib/fastcwd.pl a faster but more dangerous getcwd -lib/find.pl A find emulator--used by find2perl -lib/finddepth.pl A depth-first find emulator--used by find2perl -lib/flush.pl Routines to do single flush -lib/ftp.pl -lib/getcwd.pl a getcwd() emulator -lib/getopt.pl Perl library supporting option parsing -lib/getopts.pl Perl library supporting option parsing -lib/hostname.pl -lib/importenv.pl Perl routine to get environment into variables -lib/look.pl A "look" equivalent -lib/newgetopt.pl A perl library supporting long option parsing -lib/open2.pl -lib/open3.pl -lib/perldb.pl Perl debugging routines -lib/pwd.pl Routines to keep track of PWD environment variable -lib/quotewords.pl.art -lib/shellwords.pl Perl library to split into words with shell quoting -lib/soundex.pl.art -lib/stat.pl Perl library supporting stat function -lib/syslog.pl Perl library supporting syslogging -lib/tainted.pl -lib/termcap.pl Perl library supporting termcap usage -lib/timelocal.pl Perl library supporting inverse of localtime, gmtime -lib/validate.pl Perl library supporting wholesale file mode validation -makedepend.SH Precursor to makedepend -makedir.SH Precursor to makedir -makefile.lib make libperl.a -malloc.c A version of malloc you might not want -mg.c -mg.h -miniperlmain.c Basic perl w/o dynamic loading or extensions. -msdos/Changes.dds Expanation of MS-DOS patches by Diomidis Spinellis -msdos/Makefile MS-DOS makefile -msdos/README.msdos Compiling and usage information -msdos/Wishlist.dds My wishlist -msdos/chdir.c A chdir that can change drives -msdos/config.h Definitions for msdos -msdos/dir.h MS-DOS header for directory access functions -msdos/directory.c MS-DOS directory access functions. -msdos/eg/crlf.bat Convert files from unix to MS-DOS line termination -msdos/eg/drives.bat List the system drives and their characteristics -msdos/eg/lf.bat Convert files from MS-DOS to Unix line termination -msdos/glob.c A command equivalent to csh glob -msdos/msdos.c MS-DOS ioctl, sleep, gete?[gu]if, spawn, aspawn -msdos/popen.c My_popen and my_pclose for MS-DOS -msdos/usage.c How to invoke perl under MS-DOS -opcode.h -opcode.pl -os2/Makefile Makefile for OS/2 -os2/README.OS2 Notes for OS/2 -os2/a2p.cs Compiler script for a2p -os2/a2p.def Linker defs for a2p -os2/alarm.c An implementation of alarm() -os2/alarm.h Header file for same -os2/config.h Configuration file for OS/2 -os2/crypt.c -os2/dir.h Directory header -os2/director.c Directory routines -os2/eg/alarm.pl Example of alarm code -os2/eg/os2.pl Sample script for OS/2 -os2/eg/syscalls.pl Example of syscall on OS/2 -os2/glob.c Globbing routines -os2/makefile Make file -os2/mktemp.c Mktemp() using TMP -os2/os2.c Unix compatibility functions -os2/perl.bad names of protect-only API calls for BIND -os2/perl.cs Compiler script for perl -os2/perl.def Linker defs for perl -os2/perldb.dif Changes to make the debugger work -os2/perlglob.bad names of protect-only API calls for BIND -os2/perlglob.cs Compiler script for perlglob -os2/perlglob.def Linker defs for perlglob -os2/perlsh.cmd Poor man's shell for os2 -os2/popen.c Code for opening pipes -os2/s2p.cmd s2p as command file -os2/selfrun.bat A self running perl script for DOS -os2/selfrun.cmd Example of extproc feature -os2/suffix.c Code for creating backup filenames -os2/tests.dif -patchlevel.h The current patch level of perl -perl.c main() -perl.h Global declarations -perl.man The manual page(s) -perlsh A poor man's perl shell -perly.c -perly.c.byacc -perly.c.diff -perly.c.yacc -perly.fixer A program to remove yacc stack limitations -perly.h.yacc -perly.y Yacc grammar for perl -perly.y.save -pp.c Push/Pop code -pp.h Push/Pop code defs -proto.h -protos -regcomp.c Regular expression compiler -regcomp.h Private declarations for above -regexec.c Regular expression evaluator -regexp.h Public declarations for the above -scope.c -scope.h -server A server to test sockets -sortfunc -sv.c -sv.h -t/README Instructions for regression tests -t/TEST The regression tester -t/base/cond.t See if conditionals work -t/base/if.t See if if works -t/base/lex.t See if lexical items work -t/base/pat.t See if pattern matching works -t/base/term.t See if various terms work -t/cmd/elsif.t See if else-if works -t/cmd/for.t See if for loops work -t/cmd/mod.t See if statement modifiers work -t/cmd/subval.t See if subroutine values work -t/cmd/switch.t See if switch optimizations work -t/cmd/while.t See if while loops work -t/comp/cmdopt.t See if command optimization works -t/comp/cpp.t See if C preprocessor works -t/comp/decl.t See if declarations work -t/comp/multiline.t See if multiline strings work -t/comp/package.t See if packages work -t/comp/script.t See if script invokation works -t/comp/term.t See if more terms work -t/io/argv.t See if ARGV stuff works -t/io/dup.t See if >& works right -t/io/fs.t See if directory manipulations work -t/io/inplace.t See if inplace editing works -t/io/pipe.t See if secure pipes work -t/io/print.t See if print commands work -t/io/tell.t See if file seeking works -t/lib/bigint.t -t/lib/english.t -t/lib/ndbm.t -t/lib/sdbm.t -t/op/append.t See if . works -t/op/array.t See if array operations work -t/op/auto.t See if autoincrement et all work -t/op/chop.t See if chop works -t/op/cond.t See if conditional expressions work -t/op/delete.t See if delete works -t/op/do.t See if subroutines work -t/op/each.t See if associative iterators work -t/op/eval.t See if eval operator works -t/op/exec.t See if exec and system work -t/op/exp.t See if math functions work -t/op/flip.t See if range operator works -t/op/fork.t See if fork works -t/op/glob.t See if <*> works -t/op/goto.t See if goto works -t/op/groups.t See if $( works -t/op/index.t See if index works -t/op/int.t See if int works -t/op/join.t See if join works -t/op/list.t See if array lists work -t/op/local.t See if local works -t/op/magic.t See if magic variables work -t/op/mkdir.t See if mkdir works -t/op/my.t -t/op/oct.t See if oct and hex work -t/op/ord.t See if ord works -t/op/pack.t See if pack and unpack work -t/op/pat.t See if esoteric patterns work -t/op/push.t See if push and pop work -t/op/range.t See if .. works -t/op/re_tests Input file for op.regexp -t/op/read.t See if read() works -t/op/readdir.t See if readdir() works -t/op/ref.t -t/op/regexp.t See if regular expressions work -t/op/repeat.t See if x operator works -t/op/sleep.t See if sleep works -t/op/sort.t See if sort works -t/op/split.t See if split works -t/op/sprintf.t See if sprintf works -t/op/stat.t See if stat works -t/op/study.t See if study works -t/op/subst.t -t/op/substr.t See if substr works -t/op/time.t See if time functions work -t/op/undef.t See if undef works -t/op/unshift.t See if unshift works -t/op/vec.t See if vectors work -t/op/write.t See if write works -taint.c -toke.c The tokener -unixish.h -usersub.c User supplied (possibly proprietary) subroutines -util.c Utility routines -util.h Public declarations for the above -writemain.SH Generate perlmain.c from miniperlmain.c+extensions. -x2p/EXTERN.h Same as above -x2p/INTERN.h Same as above -x2p/Makefile.SH Precursor to Makefile -x2p/a2p.h Global declarations -x2p/a2p.man Manual page for awk to perl translator -x2p/a2p.y A yacc grammer for awk -x2p/a2py.c Awk compiler, sort of -x2p/cflags.SH A script that emits C compilation flags per file -x2p/find2perl.SH A find to perl translator -x2p/handy.h Handy definitions -x2p/hash.c Associative arrays again -x2p/hash.h Public declarations for the above -x2p/malloc.c -x2p/s2p.SH Sed to perl translator -x2p/s2p.man Manual page for sed to perl translator -x2p/str.c String handling package -x2p/str.h Public declarations for the above -x2p/util.c Utility routines -x2p/util.h Public declarations for the above -x2p/walk.c Parse tree walker diff --git a/Makefile b/Makefile deleted file mode 100644 index 8da9eee9b4..0000000000 --- a/Makefile +++ /dev/null @@ -1,311 +0,0 @@ -# .SH,v $Revision: 4.1 $Date: 92/08/07 17:18:08 $ -# 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. -# -# $Log: Makefile.SH,v $ -# Revision 4.1 92/08/07 17:18:08 lwall -# Stage 6 Snapshot -# -# Revision 4.0.1.4 92/06/08 11:40:43 lwall -# patch20: cray didn't give enough memory to /bin/sh -# patch20: various and sundry fixes -# -# Revision 4.0.1.3 91/11/05 15:48:11 lwall -# patch11: saberized perl -# patch11: added support for dbz -# -# Revision 4.0.1.2 91/06/07 10:14:43 lwall -# patch4: cflags now emits entire cc command except for the filename -# patch4: alternate make programs are now semi-supported -# patch4: uperl.o no longer tries to link in libraries prematurely -# patch4: installperl now installs x2p stuff too -# -# Revision 4.0.1.1 91/04/11 17:30:39 lwall -# patch1: C flags are now settable on a per-file basis -# -# Revision 4.0 91/03/20 00:58:54 lwall -# 4.0 baseline. -# -# - -# I now supply perly.c with the kits, so don't remake perly.c without byacc -BYACC = byacc -CC = cc -bin = /usr/local/bin -scriptdir = /usr/local/bin -privlib = /usr/local/lib/perl -mansrc = /usr/local/man/man1 -manext = 1 -LDFLAGS = -CLDFLAGS = - -SMALL = -LARGE = -mallocsrc = malloc.c -mallocobj = malloc.o -dlsrc = dl_sunos.c -dlobj = dl_sunos.o -dldir = ext/dl -LNS = /bin/ln -s -RMS = rm -f -ranlib = /usr/bin/ranlib - -# The following are used to build and install shared libraries for -# dynamic loading. -LDDLFLAGS = -CCDLFLAGS = -CCCDLFLAGS = -SHLIBSUFFIX = .so - -libs = -ldbm -ldl -lm -lposix - -public = perl - -shellflags = - -## To use an alternate make, set in config.sh. -MAKE = make - -CCCMD = `sh $(shellflags) cflags $@` - -private = - -scripts = h2ph - -manpages = perl.man h2ph.man - -util = - -sh = Makefile.SH cflags.SH embed_h.SH makedepend.SH makedir.SH writemain.SH - -h1 = EXTERN.h INTERN.h av.h cop.h config.h embed.h form.h handy.h -h2 = hv.h op.h opcode.h perl.h regcomp.h regexp.h gv.h sv.h util.h - -h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h -h2 = embed.h form.h gv.h handy.h hv.h hvdbm.h keywords.h mg.h op.h -h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h -h4 = regexp.h scope.h sv.h unixish.h util.h -h = $(h1) $(h2) $(h3) $(h4) - -c1 = av.c scope.c op.c doop.c doio.c dump.c hv.c -c2 = $(mallocsrc) mg.c perly.c pp.c regcomp.c regexec.c -c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c - -c = $(c1) $(c2) $(c3) $(dlsrc) miniperlmain.c perlmain.c - -s1 = av.c scope.c op.c doop.c doio.c dump.c hv.c -s2 = $(mallocsrc) mg.c perly.c pp.c regcomp.c regexec.c -s3 = gv.c sv.c taint.c toke.c util.c deb.c run.c perly.c - -saber = $(s1) $(s2) $(s3) $(dlsrc) - -obj1 = av.o scope.o op.o doop.o doio.o dump.o hv.o -obj2 = $(mallocobj) mg.o perly.o pp.o regcomp.o regexec.o -obj3 = gv.o sv.o taint.o toke.o util.o deb.o run.o - -obj = $(obj1) $(obj2) $(obj3) - -lintflags = -hbvxac - -addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 - -# grrr -SHELL = /bin/sh - -.c.o: - $(CCCMD) $*.c - -all: miniperl perl lib/Config.pm - -#all: $(public) $(private) $(util) $(scripts) -# cd x2p; $(MAKE) all -# touch all - -# Phony target to force checking subdirectories. -FORCE: - - -$(dlsrc): $(dldir)/$(dlsrc) - cp $(dldir)/$(dlsrc) $(dlsrc) - -$(dlobj): $(dlsrc) - $(CCCMD) $(dlsrc) - - -# NDBM_File extension -NDBM_File.o: NDBM_File.c - $(CCCMD) $(CCCDLFLAGS) $*.c - -NDBM_File.c: ext/dbm/NDBM_File.xs ext/xsubpp ext/typemap - test -f miniperl || make miniperl - ./miniperl ext/xsubpp ext/dbm/NDBM_File.xs >tmp - mv tmp NDBM_File.c - -lib/auto/NDBM_File/NDBM_File$(SHLIBSUFFIX): NDBM_File.o - test -d lib/auto/NDBM_File || mkdir lib/auto/NDBM_File - ld $(LDDLFLAGS) -o $@ NDBM_File.o - -# ODBM_File extension -ODBM_File.o: ODBM_File.c - $(CCCMD) $(CCCDLFLAGS) $*.c - -ODBM_File.c: ext/dbm/ODBM_File.xs ext/xsubpp ext/typemap - test -f miniperl || make miniperl - ./miniperl ext/xsubpp ext/dbm/ODBM_File.xs >tmp - mv tmp ODBM_File.c - -lib/auto/ODBM_File/ODBM_File$(SHLIBSUFFIX): ODBM_File.o - test -d lib/auto/ODBM_File || mkdir lib/auto/ODBM_File - ld $(LDDLFLAGS) -o $@ ODBM_File.o - -# SDBM_File extension -SDBM_File.o: SDBM_File.c - $(CCCMD) $(CCCDLFLAGS) $*.c - -SDBM_File.c: ext/dbm/SDBM_File.xs ext/xsubpp ext/typemap - test -f miniperl || make miniperl - ./miniperl ext/xsubpp ext/dbm/SDBM_File.xs >tmp - mv tmp SDBM_File.c - -lib/auto/SDBM_File/SDBM_File$(SHLIBSUFFIX): SDBM_File.o ext/dbm/sdbm/libsdbm.a - test -d lib/auto/SDBM_File || mkdir lib/auto/SDBM_File - ld $(LDDLFLAGS) -o $@ SDBM_File.o ext/dbm/sdbm/libsdbm.a - -# POSIX extension -POSIX.o: POSIX.c - $(CCCMD) $(CCCDLFLAGS) $*.c - -POSIX.c: ext/posix/POSIX.xs ext/xsubpp ext/typemap - test -f miniperl || make miniperl - ./miniperl ext/xsubpp ext/posix/POSIX.xs >tmp - mv tmp POSIX.c - -lib/auto/POSIX/POSIX$(SHLIBSUFFIX): POSIX.o - test -d lib/auto/POSIX || mkdir lib/auto/POSIX - ld $(LDDLFLAGS) -o $@ POSIX.o -lm - -# List of extensions (used by writemain) to generate perlmain.c -ext= NDBM_File ODBM_File SDBM_File POSIX -extsrc= NDBM_File.c ODBM_File.c SDBM_File.c POSIX.c -# Extension dependencies. -extdep= lib/auto/NDBM_File/NDBM_File$(SHLIBSUFFIX) lib/auto/ODBM_File/ODBM_File$(SHLIBSUFFIX) lib/auto/SDBM_File/SDBM_File$(SHLIBSUFFIX) lib/auto/POSIX/POSIX$(SHLIBSUFFIX) -# How to include extensions in linking command -extobj= - -ext/dbm/sdbm/libsdbm.a: ext/dbm/sdbm/sdbm.h ext/dbm/sdbm/sdbm.c - cd ext/dbm/sdbm; $(MAKE) -f Makefile libsdbm.a - -# The $& notation tells Sequent machines that it can do a parallel make, -# and is harmless otherwise. - -miniperl: $& miniperlmain.o perl.o $(obj) - $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain.o perl.o $(obj) $(libs) - -perlmain.c: miniperlmain.c - sh writemain $(ext) > perlmain.c - -perlmain.o: perlmain.c - -perl: $& perlmain.o perl.o $(obj) $(dlobj) $(extdep) - $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain.o perl.o $(obj) $(dlobj) $(extobj) $(libs) - -libperl.rlb: libperl.a - $(ranlib) libperl.a - touch libperl.rlb - -libperl.a: $& perl.o $(obj) - ar rcuv libperl.a $(obj) - -# This version, if specified in Configure, does ONLY those scripts which need -# set-id emulation. Suidperl must be setuid root. It contains the "taint" -# checks as well as the special code to validate that the script in question -# has been invoked correctly. - -suidperl: $& sperl.o perlmain.o libperl.rlb - $(CC) $(LARGE) $(CLDFLAGS) sperl.o perlmain.o libperl.a $(libs) -o suidperl - -lib/Config.pm: config.sh miniperl - ./miniperl configpm - -saber: $(saber) - # load $(saber) - # load /lib/libm.a - -sperl.o: perl.c perly.h patchlevel.h $(h) - $(RMS) sperl.c - $(LNS) perl.c sperl.c - $(CCCMD) -DIAMSUID sperl.c - $(RMS) sperl.c - -perly.h: perly.c - @ echo Dummy dependency for dumb parallel make - touch perly.h - -opcode.h: opcode.pl - - perl opcode.pl - -embed.h: embed_h.SH global.sym interp.sym - sh embed_h.SH - -perly.c: - @ echo 'Expect' 80 shift/reduce and 62 reduce/reduce conflicts - $(BYACC) -d perly.y - sh $(shellflags) ./perly.fixer y.tab.c perly.c - mv y.tab.h perly.h - echo 'extern YYSTYPE yylval;' >>perly.h - -perly.o: perly.c perly.h $(h) - $(CCCMD) perly.c - -install: all - ./perl installperl - -clean: - rm -f *.o all perl miniperl - rm -f POSIX.c ?DBM_File.c perlmain.c - rm -f ext/dbm/sdbm/libsdbm.a - cd ext/dbm/sdbm; $(MAKE) -f Makefile clean - cd x2p; $(MAKE) clean - -realclean: clean - cd x2p; $(MAKE) realclean - cd ext/dbm/sdbm; $(MAKE) -f Makefile realclean - rm -f *.orig */*.orig *~ */*~ core $(addedbyconf) h2ph h2ph.man - rm -f Makefile cflags embed_h makedepend makedir writemain - rm -f config.h t/perl makefile makefile.old cflags - rm -rf lib/auto/?DBM_File lib/auto/POSIX - rm -f x2p/Makefile x2p/makefile x2p/makefile.old x2p/cflags - rm -f lib/Config.pm - rm -f c2ph pstruct - -# The following lint has practically everything turned on. Unfortunately, -# you have to wade through a lot of mumbo jumbo that can't be suppressed. -# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message -# for that spot. - -lint: perly.c $(c) - lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz - -depend: makedepend - - test -f perly.h || cp /dev/null perly.h - ./makedepend - - test -s perly.h || /bin/rm -f perly.h - cd x2p; $(MAKE) depend - -test: perl lib/Config.pm - - cd t && chmod +x TEST */*.t - - cd t && (rm -f perl; $(LNS) ../perl perl) && ./perl TEST </dev/tty - -clist: $(c) - echo $(c) | tr ' ' '\012' >.clist - -hlist: $(h) - echo $(h) | tr ' ' '\012' >.hlist - -shlist: $(sh) - echo $(sh) | tr ' ' '\012' >.shlist - -# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE -# If this runs make out of memory, delete /usr/include lines. diff --git a/Makefile.SH b/Makefile.SH index 88b8b7194e..e1e666d883 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -22,51 +22,43 @@ case "$d_dosuid" in *) suidperl='';; esac -: Certain parts of Makefile need to be commented out if dynamic -: loading is not used. -case "$usedl" in -define) comment='' ;; -*) comment='#' ;; +: Configure sets byacc=byacc if byacc is not found. We reset it to '' +case "$byacc" in +''|'byacc') byacc='';; esac +: Prepare dependency lists for Makefile. +dynamic_list=' ' +for f in $dynamic_ext; do + : the dependency named here will never exist + dynamic_list="$dynamic_list $f.$dlext" +done + +static_list=' ' +static_ai_list=' ' +for f in $static_ext; do + base=`echo "$f" | sed 's/.*\///'` + static_list="$static_list ext/$f/$base.a" + 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)" -: This section of the file will have variable substitutions done on it. -: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. -: Protect any dollar signs and backticks that you do not want interpreted -: by putting a backslash in front. You may delete these comments. -$spitshell >Makefile <<!GROK!THIS! -# $Makefile.SH,v $Revision: 4.1 $Date: 92/08/07 17:18:08 $ +$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. # -# \$Log: Makefile.SH,v \$ -# Revision 4.1 92/08/07 17:18:08 lwall -# Stage 6 Snapshot -# -# Revision 4.0.1.4 92/06/08 11:40:43 lwall -# patch20: cray didn't give enough memory to /bin/sh -# patch20: various and sundry fixes -# -# Revision 4.0.1.3 91/11/05 15:48:11 lwall -# patch11: saberized perl -# patch11: added support for dbz -# -# Revision 4.0.1.2 91/06/07 10:14:43 lwall -# patch4: cflags now emits entire cc command except for the filename -# patch4: alternate make programs are now semi-supported -# patch4: uperl.o no longer tries to link in libraries prematurely -# patch4: installperl now installs x2p stuff too -# -# Revision 4.0.1.1 91/04/11 17:30:39 lwall -# patch1: C flags are now settable on a per-file basis -# -# Revision 4.0 91/03/20 00:58:54 lwall -# 4.0 baseline. -# # +!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 @@ -82,9 +74,6 @@ SMALL = $small LARGE = $large $split mallocsrc = $mallocsrc mallocobj = $mallocobj -dlsrc = $dlsrc -dlobj = $dlobj -dldir = $dldir LNS = $lns RMS = rm -f ranlib = $ranlib @@ -94,7 +83,13 @@ ranlib = $ranlib LDDLFLAGS = $lddlflags CCDLFLAGS = $ccdlflags CCCDLFLAGS = $cccdlflags -SHLIBSUFFIX = $shlibsuffix +DLSUFFIX = .$dlext + +dynamic_ext = $dynamic_list +static_ext = $static_list +ext = \$(dynamic_ext) \$(static_ext) +static_ext_autoinit = $static_ai_list +DYNALOADER = ext/DynaLoader/DynaLoader.a libs = $libs $cryptlib @@ -102,55 +97,57 @@ public = perl $suidperl shellflags = $shellflags -## To use an alternate make, set $altmake in config.sh. +## To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} !GROK!THIS! ## In the following dollars and backticks do not need the extra backslash. $spitshell >>Makefile <<'!NO!SUBS!' -CCCMD = `sh $(shellflags) cflags $@` +CCCMD = `sh $(shellflags) cflags $(perllib) $@` private = -scripts = h2ph +scripts = -manpages = perl.man h2ph.man +manpages = perl.man util = sh = Makefile.SH cflags.SH embed_h.SH makedepend.SH makedir.SH writemain.SH -h1 = EXTERN.h INTERN.h av.h cop.h config.h embed.h form.h handy.h -h2 = hv.h op.h opcode.h perl.h regcomp.h regexp.h gv.h sv.h util.h - h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h -h2 = embed.h form.h gv.h handy.h hv.h hvdbm.h keywords.h mg.h op.h +h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h h4 = regexp.h scope.h sv.h unixish.h util.h h = $(h1) $(h2) $(h3) $(h4) -c1 = av.c scope.c op.c doop.c doio.c dump.c hv.c -c2 = $(mallocsrc) mg.c perly.c pp.c regcomp.c regexec.c +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 -c = $(c1) $(c2) $(c3) $(dlsrc) miniperlmain.c perlmain.c - -s1 = av.c scope.c op.c doop.c doio.c dump.c hv.c -s2 = $(mallocsrc) mg.c perly.c pp.c regcomp.c regexec.c -s3 = gv.c sv.c taint.c toke.c util.c deb.c run.c perly.c - -saber = $(s1) $(s2) $(s3) $(dlsrc) +c = $(c1) $(c2) $(c3) miniperlmain.c perlmain.c -obj1 = av.o scope.o op.o doop.o doio.o dump.o hv.o -obj2 = $(mallocobj) mg.o perly.o pp.o regcomp.o regexec.o -obj3 = gv.o sv.o taint.o toke.o util.o deb.o run.o +obj1 = $(mallocobj) 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 obj = $(obj1) $(obj2) $(obj3) +# Once perl has been Configure'd and built ok you build different +# perl variants (Debugging, Embedded, Multiplicity etc) by saying: +# make clean; make perllib=libperl<type>.a +# where <type> is some combination of 'd' and(or) 'e' or 'm'. +# See cflags to understand how this works. +# +# Eventually some form of 'make-a-perl' script will automate this +# together with linking a perl executable with any desired +# static modules. +perllib = libperl.a + lintflags = -hbvxac -addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 +addedbyconf = UU # grrr SHELL = /bin/sh @@ -158,142 +155,55 @@ SHELL = /bin/sh .c.o: $(CCCMD) $*.c -all: miniperl perl lib/Config.pm - -#all: $(public) $(private) $(util) $(scripts) -# cd x2p; $(MAKE) all -# touch all +all: makefile miniperl preplibrary $(public) $(dynamic_ext) + @echo " "; echo " Making x2p stuff"; cd x2p; $(MAKE) all + @echo " "; echo " Making docs"; cd pod; $(MAKE) all; # Phony target to force checking subdirectories. FORCE: !NO!SUBS! -### Some makes have problems with the following dependency -### if $(dlsrc) or $(dlobj) is empty. -### Therefore, comment it out if dlsrc is null. -### -$spitshell >>Makefile <<!GROK!THIS! -${comment} -${comment}\$(dlsrc): \$(dldir)/\$(dlsrc) -${comment} cp \$(dldir)/\$(dlsrc) \$(dlsrc) - -${comment}\$(dlobj): \$(dlsrc) -${comment} \$(CCCMD) \$(dlsrc) - -!GROK!THIS! - -### -### Boilerplate for all the .xs files in the ext directory. -### XXX FIXME: At some point we also need to copy .pm files out of -### XXX the ext directory into lib. -### XXX FIXME: At some point we need to run autosplit on the .pm -### XXX files. -### Configure sets extensions to a string like -### "ext/dbm/NDBM_File.xs ext/dbm/ODBM_File.xs ext/dbm/GDBM_File.xs \ -### ext/dbm/SDBM_File.xs ext/posix/POSIX.xs" -ext=" " -extdep=" " -extobj=" " -extsrc=" " -# extradep gives any extra dependencies of this extension. -# extraobj gives any extra thinks to link with this extension. -for f in $extensions -do - base=`echo $f | $sed -e 's@.*/\(.*\).xs@\1@'` - ext="$ext $base" - extsrc="$extsrc $base.c" - case $base in - SDBM_File) extradep="ext/dbm/sdbm/libsdbm.a" - extraobj="ext/dbm/sdbm/libsdbm.a" ;; - POSIX) extradep="" - extraobj="-lm" ;; - *) extradep="" - extraobj="" ;; - esac - case "$usedl" in - define) extdep="$extdep lib/auto/$base/${base}\$(SHLIBSUFFIX)" - ;; - *) extdep="$extdep $base.o $extradep" - extobj="$extobj $base.o $extraobj" ;; - esac - - $spitshell >>Makefile <<!GROK!THIS! - -# $base extension -$base.o: $base.c - \$(CCCMD) \$(CCCDLFLAGS) \$*.c - -$base.c: $f ext/xsubpp ext/typemap - test -f miniperl || make miniperl - ./miniperl ext/xsubpp $f >tmp - mv tmp $base.c - -${comment}lib/auto/$base/$base\$(SHLIBSUFFIX): $base.o $extradep -${comment} test -d lib/auto/$base || mkdir lib/auto/$base -${comment} ld \$(LDDLFLAGS) -o \$@ $base.o $extraobj -!GROK!THIS! - -done - -$spitshell >>Makefile <<!GROK!THIS! - -# List of extensions (used by writemain) to generate perlmain.c -ext=$ext -extsrc=$extsrc -# Extension dependencies. -extdep=$extdep -# How to include extensions in linking command -extobj=$extobj - -ext/dbm/sdbm/libsdbm.a: ext/dbm/sdbm/sdbm.h ext/dbm/sdbm/sdbm.c - cd ext/dbm/sdbm; \$(MAKE) -f Makefile libsdbm.a - -!GROK!THIS! - -### Now on to the rest of the Makefile. +: Now on to the rest of the Makefile. $spitshell >>Makefile <<'!NO!SUBS!' # The $& notation tells Sequent machines that it can do a parallel make, # and is harmless otherwise. -miniperl: $& miniperlmain.o perl.o $(obj) - $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain.o perl.o $(obj) $(libs) +miniperl: $& miniperlmain.o $(perllib) + $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain.o $(perllib) $(libs) -perlmain.c: miniperlmain.c - sh writemain $(ext) > perlmain.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.o: perlmain.c -perl: $& perlmain.o perl.o $(obj) $(dlobj) $(extdep) - $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain.o perl.o $(obj) $(dlobj) $(extobj) $(libs) +# The file ext.libs is a list of libraries that must be linked in +# for static extensions, e.g. -lm -lgdbm, etc. The individual +# static extension Makefile's add to it. +ext.libs: $(static_ext) + -@test -f ext.libs || touch ext.libs -pureperl: $& perlmain.o perl.o $(obj) $(dlobj) $(extdep) - purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain.o perl.o $(obj) $(dlobj) $(extobj) $(libs) +perl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs + $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) -quantperl: $& perlmain.o perl.o $(obj) $(dlobj) $(extdep) - quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain.o perl.o $(obj) $(dlobj) $(extobj) $(libs) +pureperl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs + purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) -libperl.rlb: libperl.a - $(ranlib) libperl.a - touch libperl.rlb +quantperl: $& perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs + quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) -libperl.a: $& perl.o $(obj) - ar rcuv libperl.a $(obj) +$(perllib): $& perl.o $(obj) + ar rcu $(perllib) perl.o $(obj) + @$(ranlib) $(perllib) # This version, if specified in Configure, does ONLY those scripts which need # set-id emulation. Suidperl must be setuid root. It contains the "taint" # checks as well as the special code to validate that the script in question # has been invoked correctly. -suidperl: $& sperl.o perlmain.o libperl.rlb - $(CC) $(LARGE) $(CLDFLAGS) sperl.o perlmain.o libperl.a $(libs) -o suidperl - -lib/Config.pm: config.sh miniperl - ./miniperl configpm - -saber: $(saber) - # load $(saber) - # load /lib/libm.a +suidperl: $& sperl.o perlmain.o $(perllib) $(DYNALOADER) $(static_ext) ext.libs + $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain.o sperl.o $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) sperl.o: perl.c perly.h patchlevel.h $(h) $(RMS) sperl.c @@ -301,46 +211,109 @@ sperl.o: perl.c perly.h patchlevel.h $(h) $(CCCMD) -DIAMSUID sperl.c $(RMS) sperl.c -perly.h: perly.c - @ echo Dummy dependency for dumb parallel make - touch perly.h - opcode.h: opcode.pl - perl opcode.pl embed.h: embed_h.SH global.sym interp.sym sh embed_h.SH -perly.c: - @ echo 'Expect' 80 shift/reduce and 62 reduce/reduce conflicts - $(BYACC) -d perly.y - sh $(shellflags) ./perly.fixer y.tab.c perly.c - mv y.tab.h perly.h - echo 'extern YYSTYPE yylval;' >>perly.h +preplibrary: miniperl lib/Config.pm + @test -d lib/auto || mkdir lib/auto + @echo " AutoSplitting perl library" + @./miniperl -Ilib -e 'use AutoSplit; \ + autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm -perly.o: perly.c perly.h $(h) - $(CCCMD) perly.c +lib/Config.pm: config.sh miniperl + ./miniperl configpm install: all ./perl installperl +!NO!SUBS! + +: Only print out the rules for running byacc if the user _has_ byacc. +: Otherwise, comment them out. Users who really know what they are +: doing can uncomment them and run yacc or bison or whatever. +: Configure sets byacc=byacc if byacc is not found. +case "$byacc" in +''|'byacc') + comment1='#' + comment2='' ;; +*) comment1='' + comment2='#' ;; +esac + +$spitshell >>Makefile <<!GROK!THIS! + +perly.h: perly.c + @ echo Dummy dependency for dumb parallel make + touch perly.h + +# I now supply perly.c with the kits, so the following section is +# commented out if you don't have byacc. + +${comment1}perly.c: perly.y perly.c.diff +${comment1} @ echo 'Expect' 109 shift/reduce and 1 reduce/reduce conflict +${comment1} \$(BYACC) -d perly.y +${comment1} sh \$(shellflags) ./perly.fixer y.tab.c perly.c +${comment1} mv y.tab.h perly.h +${comment1} echo 'extern YYSTYPE yylval;' >>perly.h + +# This version is used only if you do not have byacc. +${comment2}perly.c: perly.y +${comment2} touch perly.c + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' +# Extensions: +# Names added to $(dynamic_ext) or $(static_ext) will automatically +# get built. There should ordinarily be no need to change any of +# this part of makefile. +# +# The dummy dependency is a place holder in case $(dynamic_ext) or +# $(static_ext) is empty. +# +# DynaLoader may be needed for extensions that use Makefile.PL. + +$(DYNALOADER): miniperl preplibrary FORCE + @sh ext/util/make_ext static $@ + +d_dummy $(dynamic_ext): miniperl preplibrary $(DYNALOADER) FORCE + @sh ext/util/make_ext dynamic $@ + +s_dummy $(static_ext): miniperl preplibrary $(DYNALOADER) FORCE + @sh ext/util/make_ext static $@ clean: - rm -f *.o all perl miniperl - rm -f POSIX.c ?DBM_File.c perlmain.c - rm -f ext/dbm/sdbm/libsdbm.a - cd ext/dbm/sdbm; $(MAKE) -f Makefile clean - cd x2p; $(MAKE) clean + rm -f *.o *.a all perl suidperl miniperl + rm -f perlmain.c + rm -f perl.exp ext.libs ext/util/extlibist + -cd x2p; $(MAKE) clean + -cd pod; $(MAKE) clean + -@for x in ext/* ; do \ + if test -f $$x/Makefile; then \ + echo " Making clean in $$x"; \ + cd $$x; $(MAKE) clean ; cd ../.. ; \ + fi ; \ + done realclean: clean - cd x2p; $(MAKE) realclean - cd ext/dbm/sdbm; $(MAKE) -f Makefile realclean - rm -f *.orig */*.orig *~ */*~ core $(addedbyconf) h2ph h2ph.man - rm -f Makefile cflags embed_h makedepend makedir writemain - rm -f config.h t/perl makefile makefile.old cflags - rm -rf lib/auto/?DBM_File lib/auto/POSIX + -cd x2p; $(MAKE) realclean + -@for x in ext/* ; do \ + if test -f $$x/Makefile; then \ + echo " Making realclean in $$x"; \ + cd $$x; $(MAKE) realclean ; cd ../.. ; \ + fi ; \ + done + rm -f *.orig */*.orig *~ */*~ core t/core + rm -rf $(addedbyconf) + rm -f Makefile cflags makedepend makedir writemain + rm -f config.h t/perl makefile makefile.old rm -f x2p/Makefile x2p/makefile x2p/makefile.old x2p/cflags rm -f lib/Config.pm - rm -f c2ph pstruct + rm -rf lib/auto + rm -f h2ph h2ph.man c2ph pstruct + rm -rf .config # The following lint has practically everything turned on. Unfortunately, # you have to wade through a lot of mumbo jumbo that can't be suppressed. @@ -350,13 +323,18 @@ realclean: clean lint: perly.c $(c) lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz +makefile: Makefile + make depend + +# When done, touch perlmain.c so that it doesn't get remade each time. depend: makedepend - test -f perly.h || cp /dev/null perly.h ./makedepend - test -s perly.h || /bin/rm -f perly.h + - test -s perlmain.c && touch perlmain.c cd x2p; $(MAKE) depend -test: perl lib/Config.pm +test: miniperl perl preplibrary $(dynamic_ext) - cd t && chmod +x TEST */*.t - cd t && (rm -f perl; $(LNS) ../perl perl) && ./perl TEST </dev/tty @@ -381,3 +359,5 @@ case `pwd` in ;; esac rm -f makefile + + diff --git a/NDBM_File.c b/NDBM_File.c deleted file mode 100644 index d257e89745..0000000000 --- a/NDBM_File.c +++ /dev/null @@ -1,296 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include <ndbm.h> - -typedef DBM* NDBM_File; -#define dbm_new(dbtype,filename,flags,mode) dbm_open(filename,flags,mode) -#define nextkey(db,key) dbm_nextkey(db) - -static int -XS_NDBM_File_dbm_new(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 4) { - croak("Usage: NDBM_File::new(dbtype, filename, flags, mode)"); - } - { - char * dbtype = SvPV(ST(1),na); - char * filename = SvPV(ST(2),na); - int flags = (int)SvIV(ST(3)); - int mode = (int)SvIV(ST(4)); - NDBM_File RETVAL; - - RETVAL = dbm_new(dbtype, filename, flags, mode); - ST(0) = sv_newmortal(); - sv_setptrobj(ST(0), RETVAL, "NDBM_File"); - } - return ax; -} - -static int -XS_NDBM_File_dbm_DESTROY(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: NDBM_File::DESTROY(db)"); - } - { - NDBM_File db; - - if (SvROK(ST(1))) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (NDBM_File) tmp; - } - else - croak("db is not a reference"); - dbm_close(db); - } - return ax; -} - -static int -XS_NDBM_File_dbm_fetch(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: NDBM_File::fetch(db, key)"); - } - { - NDBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (NDBM_File) tmp; - } - else - croak("db is not of type NDBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - RETVAL = dbm_fetch(db, key); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return ax; -} - -static int -XS_NDBM_File_dbm_store(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 3 || items > 4) { - croak("Usage: NDBM_File::store(db, key, value, flags = DBM_REPLACE)"); - } - { - NDBM_File db; - datum key; - datum value; - int flags; - int RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (NDBM_File) tmp; - } - else - croak("db is not of type NDBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - value.dptr = SvPV(ST(3), na); - value.dsize = (int)na;; - - if (items < 4) - flags = DBM_REPLACE; - else { - flags = (int)SvIV(ST(4)); - } - - RETVAL = dbm_store(db, key, value, flags); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_NDBM_File_dbm_delete(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: NDBM_File::delete(db, key)"); - } - { - NDBM_File db; - datum key; - int RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (NDBM_File) tmp; - } - else - croak("db is not of type NDBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - RETVAL = dbm_delete(db, key); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_NDBM_File_dbm_firstkey(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: NDBM_File::firstkey(db)"); - } - { - NDBM_File db; - datum RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (NDBM_File) tmp; - } - else - croak("db is not of type NDBM_File"); - - RETVAL = dbm_firstkey(db); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return ax; -} - -static int -XS_NDBM_File_nextkey(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: NDBM_File::nextkey(db, key)"); - } - { - NDBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (NDBM_File) tmp; - } - else - croak("db is not of type NDBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - RETVAL = nextkey(db, key); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return ax; -} - -static int -XS_NDBM_File_dbm_error(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: NDBM_File::error(db)"); - } - { - NDBM_File db; - int RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (NDBM_File) tmp; - } - else - croak("db is not of type NDBM_File"); - - RETVAL = dbm_error(db); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_NDBM_File_dbm_clearerr(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: NDBM_File::clearerr(db)"); - } - { - NDBM_File db; - int RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (NDBM_File) tmp; - } - else - croak("db is not of type NDBM_File"); - - RETVAL = dbm_clearerr(db); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -int boot_NDBM_File(ix,ax,items) -int ix; -int ax; -int items; -{ - char* file = __FILE__; - - newXSUB("NDBM_File::new", 0, XS_NDBM_File_dbm_new, file); - newXSUB("NDBM_File::DESTROY", 0, XS_NDBM_File_dbm_DESTROY, file); - newXSUB("NDBM_File::fetch", 0, XS_NDBM_File_dbm_fetch, file); - newXSUB("NDBM_File::store", 0, XS_NDBM_File_dbm_store, file); - newXSUB("NDBM_File::delete", 0, XS_NDBM_File_dbm_delete, file); - newXSUB("NDBM_File::firstkey", 0, XS_NDBM_File_dbm_firstkey, file); - newXSUB("NDBM_File::nextkey", 0, XS_NDBM_File_nextkey, file); - newXSUB("NDBM_File::error", 0, XS_NDBM_File_dbm_error, file); - newXSUB("NDBM_File::clearerr", 0, XS_NDBM_File_dbm_clearerr, file); -} diff --git a/ODBM_File.c b/ODBM_File.c deleted file mode 100644 index 8a073f3023..0000000000 --- a/ODBM_File.c +++ /dev/null @@ -1,271 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef NULL -#undef NULL -#endif -#include <dbm.h> - -#include <fcntl.h> - -typedef void* ODBM_File; - -#define odbm_fetch(db,key) fetch(key) -#define odbm_store(db,key,value,flags) store(key,value) -#define odbm_delete(db,key) delete(key) -#define odbm_firstkey(db) firstkey() -#define odbm_nextkey(db,key) nextkey(key) - -static int dbmrefcnt; - -#ifndef DBM_REPLACE -#define DBM_REPLACE 0 -#endif - -static int -XS_ODBM_File_odbm_new(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 4) { - croak("Usage: ODBM_File::new(dbtype, filename, flags, mode)"); - } - { - char * dbtype = SvPV(ST(1),na); - char * filename = SvPV(ST(2),na); - int flags = (int)SvIV(ST(3)); - int mode = (int)SvIV(ST(4)); - ODBM_File RETVAL; - { - char tmpbuf[1025]; - if (dbmrefcnt++) - croak("Old dbm can only open one database"); - sprintf(tmpbuf,"%s.dir",filename); - if (stat(tmpbuf, &statbuf) < 0) { - if (flags & O_CREAT) { - if (mode < 0 || close(creat(tmpbuf,mode)) < 0) - croak("ODBM_File: Can't create %s", filename); - sprintf(tmpbuf,"%s.pag",filename); - if (close(creat(tmpbuf,mode)) < 0) - croak("ODBM_File: Can't create %s", filename); - } - else - croak("ODBM_FILE: Can't open %s", filename); - } - RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setptrobj(ST(0), RETVAL, "ODBM_File"); - } - } - return ax; -} - -static int -XS_ODBM_File_DESTROY(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: ODBM_File::DESTROY(db)"); - } - { - ODBM_File db; - - if (SvROK(ST(1))) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (ODBM_File) tmp; - } - else - croak("db is not a reference"); - dbmrefcnt--; - dbmclose(); - } - return ax; -} - -static int -XS_ODBM_File_odbm_fetch(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: ODBM_File::fetch(db, key)"); - } - { - ODBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (ODBM_File) tmp; - } - else - croak("db is not of type ODBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - RETVAL = odbm_fetch(db, key); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return ax; -} - -static int -XS_ODBM_File_odbm_store(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 3 || items > 4) { - croak("Usage: ODBM_File::store(db, key, value, flags = DBM_REPLACE)"); - } - { - ODBM_File db; - datum key; - datum value; - int flags; - int RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (ODBM_File) tmp; - } - else - croak("db is not of type ODBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - value.dptr = SvPV(ST(3), na); - value.dsize = (int)na;; - - if (items < 4) - flags = DBM_REPLACE; - else { - flags = (int)SvIV(ST(4)); - } - - RETVAL = odbm_store(db, key, value, flags); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_ODBM_File_odbm_delete(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: ODBM_File::delete(db, key)"); - } - { - ODBM_File db; - datum key; - int RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (ODBM_File) tmp; - } - else - croak("db is not of type ODBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - RETVAL = odbm_delete(db, key); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_ODBM_File_odbm_firstkey(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: ODBM_File::firstkey(db)"); - } - { - ODBM_File db; - datum RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (ODBM_File) tmp; - } - else - croak("db is not of type ODBM_File"); - - RETVAL = odbm_firstkey(db); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return ax; -} - -static int -XS_ODBM_File_odbm_nextkey(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: ODBM_File::nextkey(db, key)"); - } - { - ODBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (ODBM_File) tmp; - } - else - croak("db is not of type ODBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - RETVAL = odbm_nextkey(db, key); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return ax; -} - -int boot_ODBM_File(ix,ax,items) -int ix; -int ax; -int items; -{ - char* file = __FILE__; - - newXSUB("ODBM_File::new", 0, XS_ODBM_File_odbm_new, file); - newXSUB("ODBM_File::DESTROY", 0, XS_ODBM_File_DESTROY, file); - newXSUB("ODBM_File::fetch", 0, XS_ODBM_File_odbm_fetch, file); - newXSUB("ODBM_File::store", 0, XS_ODBM_File_odbm_store, file); - newXSUB("ODBM_File::delete", 0, XS_ODBM_File_odbm_delete, file); - newXSUB("ODBM_File::firstkey", 0, XS_ODBM_File_odbm_firstkey, file); - newXSUB("ODBM_File::nextkey", 0, XS_ODBM_File_odbm_nextkey, file); -} diff --git a/Obsolete b/Obsolete deleted file mode 100644 index c8dbdd025c..0000000000 --- a/Obsolete +++ /dev/null @@ -1,25 +0,0 @@ - - File | Old symbol | New symbol ------------------------------------+----------------------+--------------------- -atarist/config.h | GIDTYPE | Gid_t -atarist/config.h | HAS_GDBM | I_GDBM -atarist/config.h | UIDTYPE | Uid_t -doio.c | STDSTDIO | USE_STD_STDIO -hvdbm.h | HAS_GDBM | I_GDBM -mg.c | GIDTYPE | Gid_t -mg.c | UIDTYPE | Uid_t -msdos/config.h | GIDTYPE | Gid_t -msdos/config.h | UIDTYPE | Uid_t -os2/config.h | GIDTYPE | Gid_t -os2/config.h | HAS_GDBM | I_GDBM -os2/config.h | UIDTYPE | Uid_t -perl.c | GIDTYPE | Gid_t -perl.c | UIDTYPE | Uid_t -perl.h | GIDTYPE | Gid_t -perl.h | UIDTYPE | Uid_t -pp.c | STATBLOCKS | USE_STAT_BLOCKS -pp.c | STDSTDIO | USE_STD_STDIO -sv.c | STDSTDIO | USE_STD_STDIO -usersub.c | STDSTDIO | USE_STD_STDIO -util.c | CHARVSPRINTF | USE_CHAR_VSPRINTF -util.c | SAFE_BCOPY | HAS_SAFE_BCOPY diff --git a/POSIX.c b/POSIX.c deleted file mode 100644 index b5036e5bc3..0000000000 --- a/POSIX.c +++ /dev/null @@ -1,3605 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <ctype.h> -#include <dirent.h> -#include <errno.h> -#include <fcntl.h> -#ifdef I_FLOAT -#include <float.h> -#endif -#include <grp.h> -#include <limits.h> -#include <locale.h> -#include <math.h> -#ifdef I_PWD -#include <pwd.h> -#endif -#include <setjmp.h> -#include <signal.h> -#ifdef I_STDARG -#include <stdarg.h> -#endif -#ifdef I_STDDEF -#include <stddef.h> -#endif -#include <stdio.h> -#include <stdlib.h> -#include <string.h> -#include <sys/stat.h> -#include <sys/times.h> -#include <sys/types.h> -#include <sys/utsname.h> -#include <sys/wait.h> -#if defined(I_TERMIOS) && !defined(CR3) -#include <termios.h> -#endif -#include <time.h> -#include <unistd.h> -#include <utime.h> - -typedef int SysRet; -typedef sigset_t* POSIX__SigSet; -typedef HV* POSIX__SigAction; - -#define HAS_UNAME - -#ifndef HAS_GETPGRP -#define getpgrp() not_here("getpgrp") -#endif -#ifndef HAS_NICE -#define nice(a) not_here("nice") -#endif -#ifndef HAS_READLINK -#define readlink(a,b,c) not_here("readlink") -#endif -#ifndef HAS_SETPGID -#define setpgid(a,b) not_here("setpgid") -#endif -#ifndef HAS_SETSID -#define setsid() not_here("setsid") -#endif -#ifndef HAS_SYMLINK -#define symlink(a,b) not_here("symlink") -#endif -#ifndef HAS_TCGETPGRP -#define tcgetpgrp(a) not_here("tcgetpgrp") -#endif -#ifndef HAS_TCSETPGRP -#define tcsetpgrp(a,b) not_here("tcsetpgrp") -#endif -#ifndef HAS_TIMES -#define times(a) not_here("times") -#endif -#ifndef HAS_UNAME -#define uname(a) not_here("uname") -#endif -#ifndef HAS_WAITPID -#define waitpid(a,b,c) not_here("waitpid") -#endif - -static int -not_here(s) -char *s; -{ - croak("POSIX::%s not implemented on this architecture", s); - return -1; -} - -int constant(name, arg) -char *name; -int arg; -{ - errno = 0; - switch (*name) { - case 'A': - if (strEQ(name, "ARG_MAX")) -#ifdef ARG_MAX - return ARG_MAX; -#else - goto not_there; -#endif - break; - case 'B': - if (strEQ(name, "BUFSIZ")) -#ifdef BUFSIZ - return BUFSIZ; -#else - goto not_there; -#endif - if (strEQ(name, "BRKINT")) -#ifdef BRKINT - return BRKINT; -#else - goto not_there; -#endif - if (strEQ(name, "B9600")) -#ifdef B9600 - return B9600; -#else - goto not_there; -#endif - if (strEQ(name, "B19200")) -#ifdef B19200 - return B19200; -#else - goto not_there; -#endif - if (strEQ(name, "B38400")) -#ifdef B38400 - return B38400; -#else - goto not_there; -#endif - if (strEQ(name, "B0")) -#ifdef B0 - return B0; -#else - goto not_there; -#endif - if (strEQ(name, "B110")) -#ifdef B110 - return B110; -#else - goto not_there; -#endif - if (strEQ(name, "B1200")) -#ifdef B1200 - return B1200; -#else - goto not_there; -#endif - if (strEQ(name, "B134")) -#ifdef B134 - return B134; -#else - goto not_there; -#endif - if (strEQ(name, "B150")) -#ifdef B150 - return B150; -#else - goto not_there; -#endif - if (strEQ(name, "B1800")) -#ifdef B1800 - return B1800; -#else - goto not_there; -#endif - if (strEQ(name, "B200")) -#ifdef B200 - return B200; -#else - goto not_there; -#endif - if (strEQ(name, "B2400")) -#ifdef B2400 - return B2400; -#else - goto not_there; -#endif - if (strEQ(name, "B300")) -#ifdef B300 - return B300; -#else - goto not_there; -#endif - if (strEQ(name, "B4800")) -#ifdef B4800 - return B4800; -#else - goto not_there; -#endif - if (strEQ(name, "B50")) -#ifdef B50 - return B50; -#else - goto not_there; -#endif - if (strEQ(name, "B600")) -#ifdef B600 - return B600; -#else - goto not_there; -#endif - if (strEQ(name, "B75")) -#ifdef B75 - return B75; -#else - goto not_there; -#endif - break; - case 'C': - if (strEQ(name, "CHAR_BIT")) -#ifdef CHAR_BIT - return CHAR_BIT; -#else - goto not_there; -#endif - if (strEQ(name, "CHAR_MAX")) -#ifdef CHAR_MAX - return CHAR_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "CHAR_MIN")) -#ifdef CHAR_MIN - return CHAR_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "CHILD_MAX")) -#ifdef CHILD_MAX - return CHILD_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "CLK_TCK")) -#ifdef CLK_TCK - return CLK_TCK; -#else - goto not_there; -#endif - if (strEQ(name, "CLOCAL")) -#ifdef CLOCAL - return CLOCAL; -#else - goto not_there; -#endif - if (strEQ(name, "CLOCKS_PER_SEC")) -#ifdef CLOCKS_PER_SEC - return CLOCKS_PER_SEC; -#else - goto not_there; -#endif - if (strEQ(name, "CREAD")) -#ifdef CREAD - return CREAD; -#else - goto not_there; -#endif - if (strEQ(name, "CS5")) -#ifdef CS5 - return CS5; -#else - goto not_there; -#endif - if (strEQ(name, "CS6")) -#ifdef CS6 - return CS6; -#else - goto not_there; -#endif - if (strEQ(name, "CS7")) -#ifdef CS7 - return CS7; -#else - goto not_there; -#endif - if (strEQ(name, "CS8")) -#ifdef CS8 - return CS8; -#else - goto not_there; -#endif - if (strEQ(name, "CSIZE")) -#ifdef CSIZE - return CSIZE; -#else - goto not_there; -#endif - if (strEQ(name, "CSTOPB")) -#ifdef CSTOPB - return CSTOPB; -#else - goto not_there; -#endif - break; - case 'D': - if (strEQ(name, "DBL_MAX")) -#ifdef DBL_MAX - return DBL_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MIN")) -#ifdef DBL_MIN - return DBL_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_DIG")) -#ifdef DBL_DIG - return DBL_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_EPSILON")) -#ifdef DBL_EPSILON - return DBL_EPSILON; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MANT_DIG")) -#ifdef DBL_MANT_DIG - return DBL_MANT_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MAX_10_EXP")) -#ifdef DBL_MAX_10_EXP - return DBL_MAX_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MAX_EXP")) -#ifdef DBL_MAX_EXP - return DBL_MAX_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MIN_10_EXP")) -#ifdef DBL_MIN_10_EXP - return DBL_MIN_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "DBL_MIN_EXP")) -#ifdef DBL_MIN_EXP - return DBL_MIN_EXP; -#else - goto not_there; -#endif - break; - case 'E': - switch (name[1]) { - case 'A': - if (strEQ(name, "EACCES")) -#ifdef EACCES - return EACCES; -#else - goto not_there; -#endif - if (strEQ(name, "EAGAIN")) -#ifdef EAGAIN - return EAGAIN; -#else - goto not_there; -#endif - break; - case 'B': - if (strEQ(name, "EBADF")) -#ifdef EBADF - return EBADF; -#else - goto not_there; -#endif - if (strEQ(name, "EBUSY")) -#ifdef EBUSY - return EBUSY; -#else - goto not_there; -#endif - break; - case 'C': - if (strEQ(name, "ECHILD")) -#ifdef ECHILD - return ECHILD; -#else - goto not_there; -#endif - if (strEQ(name, "ECHO")) -#ifdef ECHO - return ECHO; -#else - goto not_there; -#endif - if (strEQ(name, "ECHOE")) -#ifdef ECHOE - return ECHOE; -#else - goto not_there; -#endif - if (strEQ(name, "ECHOK")) -#ifdef ECHOK - return ECHOK; -#else - goto not_there; -#endif - if (strEQ(name, "ECHONL")) -#ifdef ECHONL - return ECHONL; -#else - goto not_there; -#endif - break; - case 'D': - if (strEQ(name, "EDEADLK")) -#ifdef EDEADLK - return EDEADLK; -#else - goto not_there; -#endif - if (strEQ(name, "EDOM")) -#ifdef EDOM - return EDOM; -#else - goto not_there; -#endif - break; - case 'E': - if (strEQ(name, "EEXIST")) -#ifdef EEXIST - return EEXIST; -#else - goto not_there; -#endif - break; - case 'F': - if (strEQ(name, "EFAULT")) -#ifdef EFAULT - return EFAULT; -#else - goto not_there; -#endif - if (strEQ(name, "EFBIG")) -#ifdef EFBIG - return EFBIG; -#else - goto not_there; -#endif - break; - case 'I': - if (strEQ(name, "EINTR")) -#ifdef EINTR - return EINTR; -#else - goto not_there; -#endif - if (strEQ(name, "EINVAL")) -#ifdef EINVAL - return EINVAL; -#else - goto not_there; -#endif - if (strEQ(name, "EIO")) -#ifdef EIO - return EIO; -#else - goto not_there; -#endif - if (strEQ(name, "EISDIR")) -#ifdef EISDIR - return EISDIR; -#else - goto not_there; -#endif - break; - case 'M': - if (strEQ(name, "EMFILE")) -#ifdef EMFILE - return EMFILE; -#else - goto not_there; -#endif - if (strEQ(name, "EMLINK")) -#ifdef EMLINK - return EMLINK; -#else - goto not_there; -#endif - break; - case 'N': - if (strEQ(name, "ENOMEM")) -#ifdef ENOMEM - return ENOMEM; -#else - goto not_there; -#endif - if (strEQ(name, "ENOSPC")) -#ifdef ENOSPC - return ENOSPC; -#else - goto not_there; -#endif - if (strEQ(name, "ENOEXEC")) -#ifdef ENOEXEC - return ENOEXEC; -#else - goto not_there; -#endif - if (strEQ(name, "ENOTTY")) -#ifdef ENOTTY - return ENOTTY; -#else - goto not_there; -#endif - if (strEQ(name, "ENOTDIR")) -#ifdef ENOTDIR - return ENOTDIR; -#else - goto not_there; -#endif - if (strEQ(name, "ENOTEMPTY")) -#ifdef ENOTEMPTY - return ENOTEMPTY; -#else - goto not_there; -#endif - if (strEQ(name, "ENFILE")) -#ifdef ENFILE - return ENFILE; -#else - goto not_there; -#endif - if (strEQ(name, "ENODEV")) -#ifdef ENODEV - return ENODEV; -#else - goto not_there; -#endif - if (strEQ(name, "ENOENT")) -#ifdef ENOENT - return ENOENT; -#else - goto not_there; -#endif - if (strEQ(name, "ENOLCK")) -#ifdef ENOLCK - return ENOLCK; -#else - goto not_there; -#endif - if (strEQ(name, "ENOSYS")) -#ifdef ENOSYS - return ENOSYS; -#else - goto not_there; -#endif - if (strEQ(name, "ENXIO")) -#ifdef ENXIO - return ENXIO; -#else - goto not_there; -#endif - if (strEQ(name, "ENAMETOOLONG")) -#ifdef ENAMETOOLONG - return ENAMETOOLONG; -#else - goto not_there; -#endif - break; - case 'O': - if (strEQ(name, "EOF")) -#ifdef EOF - return EOF; -#else - goto not_there; -#endif - break; - case 'P': - if (strEQ(name, "EPERM")) -#ifdef EPERM - return EPERM; -#else - goto not_there; -#endif - if (strEQ(name, "EPIPE")) -#ifdef EPIPE - return EPIPE; -#else - goto not_there; -#endif - break; - case 'R': - if (strEQ(name, "ERANGE")) -#ifdef ERANGE - return ERANGE; -#else - goto not_there; -#endif - if (strEQ(name, "EROFS")) -#ifdef EROFS - return EROFS; -#else - goto not_there; -#endif - break; - case 'S': - if (strEQ(name, "ESPIPE")) -#ifdef ESPIPE - return ESPIPE; -#else - goto not_there; -#endif - if (strEQ(name, "ESRCH")) -#ifdef ESRCH - return ESRCH; -#else - goto not_there; -#endif - break; - case 'X': - if (strEQ(name, "EXIT_FAILURE")) -#ifdef EXIT_FAILURE - return EXIT_FAILURE; -#else - return 1; -#endif - if (strEQ(name, "EXIT_SUCCESS")) -#ifdef EXIT_SUCCESS - return EXIT_SUCCESS; -#else - return 0; -#endif - if (strEQ(name, "EXDEV")) -#ifdef EXDEV - return EXDEV; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "E2BIG")) -#ifdef E2BIG - return E2BIG; -#else - goto not_there; -#endif - break; - case 'F': - if (strnEQ(name, "FLT_", 4)) { - if (strEQ(name, "FLT_MAX")) -#ifdef FLT_MAX - return FLT_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MIN")) -#ifdef FLT_MIN - return FLT_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_ROUNDS")) -#ifdef FLT_ROUNDS - return FLT_ROUNDS; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_DIG")) -#ifdef FLT_DIG - return FLT_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_EPSILON")) -#ifdef FLT_EPSILON - return FLT_EPSILON; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MANT_DIG")) -#ifdef FLT_MANT_DIG - return FLT_MANT_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MAX_10_EXP")) -#ifdef FLT_MAX_10_EXP - return FLT_MAX_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MAX_EXP")) -#ifdef FLT_MAX_EXP - return FLT_MAX_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MIN_10_EXP")) -#ifdef FLT_MIN_10_EXP - return FLT_MIN_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_MIN_EXP")) -#ifdef FLT_MIN_EXP - return FLT_MIN_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "FLT_RADIX")) -#ifdef FLT_RADIX - return FLT_RADIX; -#else - goto not_there; -#endif - break; - } - if (strnEQ(name, "F_", 2)) { - if (strEQ(name, "F_DUPFD")) -#ifdef F_DUPFD - return F_DUPFD; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETFD")) -#ifdef F_GETFD - return F_GETFD; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETFL")) -#ifdef F_GETFL - return F_GETFL; -#else - goto not_there; -#endif - if (strEQ(name, "F_GETLK")) -#ifdef F_GETLK - return F_GETLK; -#else - goto not_there; -#endif - if (strEQ(name, "F_OK")) -#ifdef F_OK - return F_OK; -#else - goto not_there; -#endif - if (strEQ(name, "F_RDLCK")) -#ifdef F_RDLCK - return F_RDLCK; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETFD")) -#ifdef F_SETFD - return F_SETFD; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETFL")) -#ifdef F_SETFL - return F_SETFL; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETLK")) -#ifdef F_SETLK - return F_SETLK; -#else - goto not_there; -#endif - if (strEQ(name, "F_SETLKW")) -#ifdef F_SETLKW - return F_SETLKW; -#else - goto not_there; -#endif - if (strEQ(name, "F_UNLCK")) -#ifdef F_UNLCK - return F_UNLCK; -#else - goto not_there; -#endif - if (strEQ(name, "F_WRLCK")) -#ifdef F_WRLCK - return F_WRLCK; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "FD_CLOEXEC")) return FD_CLOEXEC; - if (strEQ(name, "FILENAME_MAX")) -#ifdef FILENAME_MAX - return FILENAME_MAX; -#else - goto not_there; -#endif - break; - case 'H': - if (strEQ(name, "HUGE_VAL")) -#ifdef HUGE_VAL - return HUGE_VAL; -#else - goto not_there; -#endif - if (strEQ(name, "HUPCL")) -#ifdef HUPCL - return HUPCL; -#else - goto not_there; -#endif - break; - case 'I': - if (strEQ(name, "INT_MAX")) -#ifdef INT_MAX - return INT_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "INT_MIN")) -#ifdef INT_MIN - return INT_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "ICANON")) -#ifdef ICANON - return ICANON; -#else - goto not_there; -#endif - if (strEQ(name, "ICRNL")) -#ifdef ICRNL - return ICRNL; -#else - goto not_there; -#endif - if (strEQ(name, "IEXTEN")) -#ifdef IEXTEN - return IEXTEN; -#else - goto not_there; -#endif - if (strEQ(name, "IGNBRK")) -#ifdef IGNBRK - return IGNBRK; -#else - goto not_there; -#endif - if (strEQ(name, "IGNCR")) -#ifdef IGNCR - return IGNCR; -#else - goto not_there; -#endif - if (strEQ(name, "IGNPAR")) -#ifdef IGNPAR - return IGNPAR; -#else - goto not_there; -#endif - if (strEQ(name, "INLCR")) -#ifdef INLCR - return INLCR; -#else - goto not_there; -#endif - if (strEQ(name, "INPCK")) -#ifdef INPCK - return INPCK; -#else - goto not_there; -#endif - if (strEQ(name, "ISIG")) -#ifdef ISIG - return ISIG; -#else - goto not_there; -#endif - if (strEQ(name, "ISTRIP")) -#ifdef ISTRIP - return ISTRIP; -#else - goto not_there; -#endif - if (strEQ(name, "IXOFF")) -#ifdef IXOFF - return IXOFF; -#else - goto not_there; -#endif - if (strEQ(name, "IXON")) -#ifdef IXON - return IXON; -#else - goto not_there; -#endif - break; - case 'L': - if (strnEQ(name, "LC_", 3)) { - if (strEQ(name, "LC_ALL")) -#ifdef LC_ALL - return LC_ALL; -#else - goto not_there; -#endif - if (strEQ(name, "LC_COLLATE")) -#ifdef LC_COLLATE - return LC_COLLATE; -#else - goto not_there; -#endif - if (strEQ(name, "LC_CTYPE")) -#ifdef LC_CTYPE - return LC_CTYPE; -#else - goto not_there; -#endif - if (strEQ(name, "LC_MONETARY")) -#ifdef LC_MONETARY - return LC_MONETARY; -#else - goto not_there; -#endif - if (strEQ(name, "LC_NUMERIC")) -#ifdef LC_NUMERIC - return LC_NUMERIC; -#else - goto not_there; -#endif - if (strEQ(name, "LC_TIME")) -#ifdef LC_TIME - return LC_TIME; -#else - goto not_there; -#endif - break; - } - if (strnEQ(name, "LDBL_", 5)) { - if (strEQ(name, "LDBL_MAX")) -#ifdef LDBL_MAX - return LDBL_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MIN")) -#ifdef LDBL_MIN - return LDBL_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_DIG")) -#ifdef LDBL_DIG - return LDBL_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_EPSILON")) -#ifdef LDBL_EPSILON - return LDBL_EPSILON; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MANT_DIG")) -#ifdef LDBL_MANT_DIG - return LDBL_MANT_DIG; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MAX_10_EXP")) -#ifdef LDBL_MAX_10_EXP - return LDBL_MAX_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MAX_EXP")) -#ifdef LDBL_MAX_EXP - return LDBL_MAX_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MIN_10_EXP")) -#ifdef LDBL_MIN_10_EXP - return LDBL_MIN_10_EXP; -#else - goto not_there; -#endif - if (strEQ(name, "LDBL_MIN_EXP")) -#ifdef LDBL_MIN_EXP - return LDBL_MIN_EXP; -#else - goto not_there; -#endif - break; - } - if (strnEQ(name, "L_", 2)) { - if (strEQ(name, "L_ctermid")) -#ifdef L_ctermid - return L_ctermid; -#else - goto not_there; -#endif - if (strEQ(name, "L_cuserid")) -#ifdef L_cuserid - return L_cuserid; -#else - goto not_there; -#endif - if (strEQ(name, "L_tmpname")) -#ifdef L_tmpname - return L_tmpname; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "LONG_MAX")) -#ifdef LONG_MAX - return LONG_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "LONG_MIN")) -#ifdef LONG_MIN - return LONG_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "LINK_MAX")) -#ifdef LINK_MAX - return LINK_MAX; -#else - goto not_there; -#endif - break; - case 'M': - if (strEQ(name, "MAX_CANON")) -#ifdef MAX_CANON - return MAX_CANON; -#else - goto not_there; -#endif - if (strEQ(name, "MAX_INPUT")) -#ifdef MAX_INPUT - return MAX_INPUT; -#else - goto not_there; -#endif - if (strEQ(name, "MB_CUR_MAX")) -#ifdef MB_CUR_MAX - return MB_CUR_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "MB_LEN_MAX")) -#ifdef MB_LEN_MAX - return MB_LEN_MAX; -#else - goto not_there; -#endif - break; - case 'N': - if (strEQ(name, "NULL")) return NULL; - if (strEQ(name, "NAME_MAX")) -#ifdef NAME_MAX - return NAME_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "NCCS")) -#ifdef NCCS - return NCCS; -#else - goto not_there; -#endif - if (strEQ(name, "NGROUPS_MAX")) -#ifdef NGROUPS_MAX - return NGROUPS_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "NOFLSH")) -#ifdef NOFLSH - return NOFLSH; -#else - goto not_there; -#endif - break; - case 'O': - if (strnEQ(name, "O_", 2)) { - if (strEQ(name, "O_APPEND")) -#ifdef O_APPEND - return O_APPEND; -#else - goto not_there; -#endif - if (strEQ(name, "O_CREAT")) -#ifdef O_CREAT - return O_CREAT; -#else - goto not_there; -#endif - if (strEQ(name, "O_TRUNC")) -#ifdef O_TRUNC - return O_TRUNC; -#else - goto not_there; -#endif - if (strEQ(name, "O_RDONLY")) -#ifdef O_RDONLY - return O_RDONLY; -#else - goto not_there; -#endif - if (strEQ(name, "O_RDWR")) -#ifdef O_RDWR - return O_RDWR; -#else - goto not_there; -#endif - if (strEQ(name, "O_WRONLY")) -#ifdef O_WRONLY - return O_WRONLY; -#else - goto not_there; -#endif - if (strEQ(name, "O_EXCL")) -#ifdef O_EXCL - return O_EXCL; -#else - goto not_there; -#endif - if (strEQ(name, "O_NOCTTY")) -#ifdef O_NOCTTY - return O_NOCTTY; -#else - goto not_there; -#endif - if (strEQ(name, "O_NONBLOCK")) -#ifdef O_NONBLOCK - return O_NONBLOCK; -#else - goto not_there; -#endif - if (strEQ(name, "O_ACCMODE")) -#ifdef O_ACCMODE - return O_ACCMODE; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "OPEN_MAX")) -#ifdef OPEN_MAX - return OPEN_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "OPOST")) -#ifdef OPOST - return OPOST; -#else - goto not_there; -#endif - break; - case 'P': - if (strEQ(name, "PATH_MAX")) -#ifdef PATH_MAX - return PATH_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "PARENB")) -#ifdef PARENB - return PARENB; -#else - goto not_there; -#endif - if (strEQ(name, "PARMRK")) -#ifdef PARMRK - return PARMRK; -#else - goto not_there; -#endif - if (strEQ(name, "PARODD")) -#ifdef PARODD - return PARODD; -#else - goto not_there; -#endif - if (strEQ(name, "PIPE_BUF")) -#ifdef PIPE_BUF - return PIPE_BUF; -#else - goto not_there; -#endif - break; - case 'R': - if (strEQ(name, "RAND_MAX")) -#ifdef RAND_MAX - return RAND_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "R_OK")) -#ifdef R_OK - return R_OK; -#else - goto not_there; -#endif - break; - case 'S': - if (strnEQ(name, "SIG", 3)) { - if (name[3] == '_') { - if (strEQ(name, "SIG_BLOCK")) -#ifdef SIG_BLOCK - return SIG_BLOCK; -#else - goto not_there; -#endif -#ifdef SIG_DFL - if (strEQ(name, "SIG_DFL")) return (int)SIG_DFL; -#endif -#ifdef SIG_ERR - if (strEQ(name, "SIG_ERR")) return (int)SIG_ERR; -#endif -#ifdef SIG_IGN - if (strEQ(name, "SIG_IGN")) return (int)SIG_IGN; -#endif - if (strEQ(name, "SIG_SETMASK")) -#ifdef SIG_SETMASK - return SIG_SETMASK; -#else - goto not_there; -#endif - if (strEQ(name, "SIG_UNBLOCK")) -#ifdef SIG_UNBLOCK - return SIG_UNBLOCK; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "SIGABRT")) -#ifdef SIGABRT - return SIGABRT; -#else - goto not_there; -#endif - if (strEQ(name, "SIGALRM")) -#ifdef SIGALRM - return SIGALRM; -#else - goto not_there; -#endif - if (strEQ(name, "SIGCHLD")) -#ifdef SIGCHLD - return SIGCHLD; -#else - goto not_there; -#endif - if (strEQ(name, "SIGCONT")) -#ifdef SIGCONT - return SIGCONT; -#else - goto not_there; -#endif - if (strEQ(name, "SIGFPE")) -#ifdef SIGFPE - return SIGFPE; -#else - goto not_there; -#endif - if (strEQ(name, "SIGHUP")) -#ifdef SIGHUP - return SIGHUP; -#else - goto not_there; -#endif - if (strEQ(name, "SIGILL")) -#ifdef SIGILL - return SIGILL; -#else - goto not_there; -#endif - if (strEQ(name, "SIGINT")) -#ifdef SIGINT - return SIGINT; -#else - goto not_there; -#endif - if (strEQ(name, "SIGKILL")) -#ifdef SIGKILL - return SIGKILL; -#else - goto not_there; -#endif - if (strEQ(name, "SIGPIPE")) -#ifdef SIGPIPE - return SIGPIPE; -#else - goto not_there; -#endif - if (strEQ(name, "SIGQUIT")) -#ifdef SIGQUIT - return SIGQUIT; -#else - goto not_there; -#endif - if (strEQ(name, "SIGSEGV")) -#ifdef SIGSEGV - return SIGSEGV; -#else - goto not_there; -#endif - if (strEQ(name, "SIGSTOP")) -#ifdef SIGSTOP - return SIGSTOP; -#else - goto not_there; -#endif - if (strEQ(name, "SIGTERM")) -#ifdef SIGTERM - return SIGTERM; -#else - goto not_there; -#endif - if (strEQ(name, "SIGTSTP")) -#ifdef SIGTSTP - return SIGTSTP; -#else - goto not_there; -#endif - if (strEQ(name, "SIGTTIN")) -#ifdef SIGTTIN - return SIGTTIN; -#else - goto not_there; -#endif - if (strEQ(name, "SIGTTOU")) -#ifdef SIGTTOU - return SIGTTOU; -#else - goto not_there; -#endif - if (strEQ(name, "SIGUSR1")) -#ifdef SIGUSR1 - return SIGUSR1; -#else - goto not_there; -#endif - if (strEQ(name, "SIGUSR2")) -#ifdef SIGUSR2 - return SIGUSR2; -#else - goto not_there; -#endif - break; - } - if (name[1] == '_') { -#ifdef S_ISBLK - if (strEQ(name, "S_ISBLK")) return S_ISBLK(arg); -#endif -#ifdef S_ISCHR - if (strEQ(name, "S_ISCHR")) return S_ISCHR(arg); -#endif -#ifdef S_ISDIR - if (strEQ(name, "S_ISDIR")) return S_ISDIR(arg); -#endif -#ifdef S_ISFIFO - if (strEQ(name, "S_ISFIFO")) return S_ISFIFO(arg); -#endif -#ifdef S_ISREG - if (strEQ(name, "S_ISREG")) return S_ISREG(arg); -#endif - if (strEQ(name, "S_ISGID")) -#ifdef S_ISGID - return S_ISGID; -#else - goto not_there; -#endif - if (strEQ(name, "S_ISUID")) -#ifdef S_ISUID - return S_ISUID; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRGRP")) -#ifdef S_IRGRP - return S_IRGRP; -#else - goto not_there; -#endif - if (strEQ(name, "S_IROTH")) -#ifdef S_IROTH - return S_IROTH; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRUSR")) -#ifdef S_IRUSR - return S_IRUSR; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRWXG")) -#ifdef S_IRWXG - return S_IRWXG; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRWXO")) -#ifdef S_IRWXO - return S_IRWXO; -#else - goto not_there; -#endif - if (strEQ(name, "S_IRWXU")) -#ifdef S_IRWXU - return S_IRWXU; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWGRP")) -#ifdef S_IWGRP - return S_IWGRP; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWOTH")) -#ifdef S_IWOTH - return S_IWOTH; -#else - goto not_there; -#endif - if (strEQ(name, "S_IWUSR")) -#ifdef S_IWUSR - return S_IWUSR; -#else - goto not_there; -#endif - if (strEQ(name, "S_IXGRP")) -#ifdef S_IXGRP - return S_IXGRP; -#else - goto not_there; -#endif - if (strEQ(name, "S_IXOTH")) -#ifdef S_IXOTH - return S_IXOTH; -#else - goto not_there; -#endif - if (strEQ(name, "S_IXUSR")) -#ifdef S_IXUSR - return S_IXUSR; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "SEEK_CUR")) -#ifdef SEEK_CUR - return SEEK_CUR; -#else - goto not_there; -#endif - if (strEQ(name, "SEEK_END")) -#ifdef SEEK_END - return SEEK_END; -#else - goto not_there; -#endif - if (strEQ(name, "SEEK_SET")) -#ifdef SEEK_SET - return SEEK_SET; -#else - goto not_there; -#endif - if (strEQ(name, "STREAM_MAX")) -#ifdef STREAM_MAX - return STREAM_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "SHRT_MAX")) -#ifdef SHRT_MAX - return SHRT_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "SHRT_MIN")) -#ifdef SHRT_MIN - return SHRT_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "SA_NOCLDSTOP")) -#ifdef SA_NOCLDSTOP - return SA_NOCLDSTOP; -#else - goto not_there; -#endif - if (strEQ(name, "SCHAR_MAX")) -#ifdef SCHAR_MAX - return SCHAR_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "SCHAR_MIN")) -#ifdef SCHAR_MIN - return SCHAR_MIN; -#else - goto not_there; -#endif - if (strEQ(name, "SSIZE_MAX")) -#ifdef SSIZE_MAX - return SSIZE_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "STDIN_FILENO")) -#ifdef STDIN_FILENO - return STDIN_FILENO; -#else - goto not_there; -#endif - if (strEQ(name, "STDOUT_FILENO")) -#ifdef STDOUT_FILENO - return STDOUT_FILENO; -#else - goto not_there; -#endif - if (strEQ(name, "STRERR_FILENO")) -#ifdef STRERR_FILENO - return STRERR_FILENO; -#else - goto not_there; -#endif - break; - case 'T': - if (strEQ(name, "TCIFLUSH")) -#ifdef TCIFLUSH - return TCIFLUSH; -#else - goto not_there; -#endif - if (strEQ(name, "TCIOFF")) -#ifdef TCIOFF - return TCIOFF; -#else - goto not_there; -#endif - if (strEQ(name, "TCIOFLUSH")) -#ifdef TCIOFLUSH - return TCIOFLUSH; -#else - goto not_there; -#endif - if (strEQ(name, "TCION")) -#ifdef TCION - return TCION; -#else - goto not_there; -#endif - if (strEQ(name, "TCOFLUSH")) -#ifdef TCOFLUSH - return TCOFLUSH; -#else - goto not_there; -#endif - if (strEQ(name, "TCOOFF")) -#ifdef TCOOFF - return TCOOFF; -#else - goto not_there; -#endif - if (strEQ(name, "TCOON")) -#ifdef TCOON - return TCOON; -#else - goto not_there; -#endif - if (strEQ(name, "TCSADRAIN")) -#ifdef TCSADRAIN - return TCSADRAIN; -#else - goto not_there; -#endif - if (strEQ(name, "TCSAFLUSH")) -#ifdef TCSAFLUSH - return TCSAFLUSH; -#else - goto not_there; -#endif - if (strEQ(name, "TCSANOW")) -#ifdef TCSANOW - return TCSANOW; -#else - goto not_there; -#endif - if (strEQ(name, "TMP_MAX")) -#ifdef TMP_MAX - return TMP_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "TOSTOP")) -#ifdef TOSTOP - return TOSTOP; -#else - goto not_there; -#endif - if (strEQ(name, "TZNAME_MAX")) -#ifdef TZNAME_MAX - return TZNAME_MAX; -#else - goto not_there; -#endif - break; - case 'U': - if (strEQ(name, "UCHAR_MAX")) -#ifdef UCHAR_MAX - return UCHAR_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "UINT_MAX")) -#ifdef UINT_MAX - return UINT_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "ULONG_MAX")) -#ifdef ULONG_MAX - return ULONG_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "USHRT_MAX")) -#ifdef USHRT_MAX - return USHRT_MAX; -#else - goto not_there; -#endif - break; - case 'V': - if (strEQ(name, "VEOF")) -#ifdef VEOF - return VEOF; -#else - goto not_there; -#endif - if (strEQ(name, "VEOL")) -#ifdef VEOL - return VEOL; -#else - goto not_there; -#endif - if (strEQ(name, "VERASE")) -#ifdef VERASE - return VERASE; -#else - goto not_there; -#endif - if (strEQ(name, "VINTR")) -#ifdef VINTR - return VINTR; -#else - goto not_there; -#endif - if (strEQ(name, "VKILL")) -#ifdef VKILL - return VKILL; -#else - goto not_there; -#endif - if (strEQ(name, "VMIN")) -#ifdef VMIN - return VMIN; -#else - goto not_there; -#endif - if (strEQ(name, "VQUIT")) -#ifdef VQUIT - return VQUIT; -#else - goto not_there; -#endif - if (strEQ(name, "VSTART")) -#ifdef VSTART - return VSTART; -#else - goto not_there; -#endif - if (strEQ(name, "VSTOP")) -#ifdef VSTOP - return VSTOP; -#else - goto not_there; -#endif - if (strEQ(name, "VSUSP")) -#ifdef VSUSP - return VSUSP; -#else - goto not_there; -#endif - if (strEQ(name, "VTIME")) -#ifdef VTIME - return VTIME; -#else - goto not_there; -#endif - break; - case 'W': - if (strEQ(name, "W_OK")) -#ifdef W_OK - return W_OK; -#else - goto not_there; -#endif -#ifdef WEXITSTATUS - if (strEQ(name, "WEXITSTATUS")) return WEXITSTATUS(arg); -#endif -#ifdef WIFEXITED - if (strEQ(name, "WIFEXITED")) return WIFEXITED(arg); -#endif -#ifdef WIFSIGNALED - if (strEQ(name, "WIFSIGNALED")) return WIFSIGNALED(arg); -#endif -#ifdef WIFSTOPPED - if (strEQ(name, "WIFSTOPPED")) return WIFSTOPPED(arg); -#endif - if (strEQ(name, "WNOHANG")) -#ifdef WNOHANG - return WNOHANG; -#else - goto not_there; -#endif -#ifdef WSTOPSIG - if (strEQ(name, "WSTOPSIG")) return WSTOPSIG(arg); -#endif -#ifdef WTERMSIG - if (strEQ(name, "WTERMSIG")) return WTERMSIG(arg); -#endif - if (strEQ(name, "WUNTRACED")) -#ifdef WUNTRACED - return WUNTRACED; -#else - goto not_there; -#endif - break; - case 'X': - if (strEQ(name, "X_OK")) -#ifdef X_OK - return X_OK; -#else - goto not_there; -#endif - break; - case '_': - if (strnEQ(name, "_PC_", 4)) { - if (strEQ(name, "_PC_CHOWN_RESTRICTED")) -#ifdef _PC_CHOWN_RESTRICTED - return _PC_CHOWN_RESTRICTED; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_LINK_MAX")) -#ifdef _PC_LINK_MAX - return _PC_LINK_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_MAX_CANON")) -#ifdef _PC_MAX_CANON - return _PC_MAX_CANON; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_MAX_INPUT")) -#ifdef _PC_MAX_INPUT - return _PC_MAX_INPUT; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_NAME_MAX")) -#ifdef _PC_NAME_MAX - return _PC_NAME_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_NO_TRUNC")) -#ifdef _PC_NO_TRUNC - return _PC_NO_TRUNC; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_PATH_MAX")) -#ifdef _PC_PATH_MAX - return _PC_PATH_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_PIPE_BUF")) -#ifdef _PC_PIPE_BUF - return _PC_PIPE_BUF; -#else - goto not_there; -#endif - if (strEQ(name, "_PC_VDISABLE")) -#ifdef _PC_VDISABLE - return _PC_VDISABLE; -#else - goto not_there; -#endif - break; - } - if (strnEQ(name, "_POSIX_", 7)) { - if (strEQ(name, "_POSIX_ARG_MAX")) -#ifdef _POSIX_ARG_MAX - return _POSIX_ARG_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_CHILD_MAX")) -#ifdef _POSIX_CHILD_MAX - return _POSIX_CHILD_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_CHOWN_RESTRICTED")) -#ifdef _POSIX_CHOWN_RESTRICTED - return _POSIX_CHOWN_RESTRICTED; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_JOB_CONTROL")) -#ifdef _POSIX_JOB_CONTROL - return _POSIX_JOB_CONTROL; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_LINK_MAX")) -#ifdef _POSIX_LINK_MAX - return _POSIX_LINK_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_MAX_CANON")) -#ifdef _POSIX_MAX_CANON - return _POSIX_MAX_CANON; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_MAX_INPUT")) -#ifdef _POSIX_MAX_INPUT - return _POSIX_MAX_INPUT; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_NAME_MAX")) -#ifdef _POSIX_NAME_MAX - return _POSIX_NAME_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_NGROUPS_MAX")) -#ifdef _POSIX_NGROUPS_MAX - return _POSIX_NGROUPS_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_NO_TRUNC")) -#ifdef _POSIX_NO_TRUNC - return _POSIX_NO_TRUNC; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_OPEN_MAX")) -#ifdef _POSIX_OPEN_MAX - return _POSIX_OPEN_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_PATH_MAX")) -#ifdef _POSIX_PATH_MAX - return _POSIX_PATH_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_PIPE_BUF")) -#ifdef _POSIX_PIPE_BUF - return _POSIX_PIPE_BUF; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_SAVED_IDS")) -#ifdef _POSIX_SAVED_IDS - return _POSIX_SAVED_IDS; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_SSIZE_MAX")) -#ifdef _POSIX_SSIZE_MAX - return _POSIX_SSIZE_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_STREAM_MAX")) -#ifdef _POSIX_STREAM_MAX - return _POSIX_STREAM_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_TZNAME_MAX")) -#ifdef _POSIX_TZNAME_MAX - return _POSIX_TZNAME_MAX; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_VDISABLE")) -#ifdef _POSIX_VDISABLE - return _POSIX_VDISABLE; -#else - return 0; -#endif - if (strEQ(name, "_POSIX_VERSION")) -#ifdef _POSIX_VERSION - return _POSIX_VERSION; -#else - return 0; -#endif - break; - } - if (strnEQ(name, "_SC_", 4)) { - if (strEQ(name, "_SC_ARG_MAX")) -#ifdef _SC_ARG_MAX - return _SC_ARG_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_CHILD_MAX")) -#ifdef _SC_CHILD_MAX - return _SC_CHILD_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_CLK_TCK")) -#ifdef _SC_CLK_TCK - return _SC_CLK_TCK; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_JOB_CONTROL")) -#ifdef _SC_JOB_CONTROL - return _SC_JOB_CONTROL; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_NGROUPS_MAX")) -#ifdef _SC_NGROUPS_MAX - return _SC_NGROUPS_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_OPEN_MAX")) -#ifdef _SC_OPEN_MAX - return _SC_OPEN_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_SAVED_IDS")) -#ifdef _SC_SAVED_IDS - return _SC_SAVED_IDS; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_STREAM_MAX")) -#ifdef _SC_STREAM_MAX - return _SC_STREAM_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_TZNAME_MAX")) -#ifdef _SC_TZNAME_MAX - return _SC_TZNAME_MAX; -#else - goto not_there; -#endif - if (strEQ(name, "_SC_VERSION")) -#ifdef _SC_VERSION - return _SC_VERSION; -#else - goto not_there; -#endif - break; - } - if (strEQ(name, "_IOFBF")) -#ifdef _IOFBF - return _IOFBF; -#else - goto not_there; -#endif - if (strEQ(name, "_IOLBF")) -#ifdef _IOLBF - return _IOLBF; -#else - goto not_there; -#endif - if (strEQ(name, "_IONBF")) -#ifdef _IONBF - return _IONBF; -#else - goto not_there; -#endif - break; - } - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -static int -XS_POSIX__SigSet_new(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 0) { - croak("Usage: POSIX::SigSet::new(packname = \"POSIX::SigSet\", ...)"); - } - { - char * packname; - POSIX__SigSet RETVAL; - - if (items < 1) - packname = "POSIX::SigSet"; - else { - packname = SvPV(ST(1),na); - } - { - int i; - RETVAL = (sigset_t*)safemalloc(sizeof(sigset_t)); - sigemptyset(RETVAL); - for (i = 2; i <= items; i++) - sigaddset(RETVAL, SvIV(ST(i))); - } - ST(0) = sv_newmortal(); - sv_setptrobj(ST(0), RETVAL, "POSIX::SigSet"); - } - return ax; -} - -static int -XS_POSIX__SigSet_DESTROY(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::SigSet::DESTROY(sigset)"); - } - { - POSIX__SigSet sigset; - - if (SvROK(ST(1))) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - sigset = (POSIX__SigSet) tmp; - } - else - croak("sigset is not a reference"); - safefree(sigset); - } - return ax; -} - -static int -XS_POSIX__SigSet_sigaddset(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::SigSet::addset(sigset, sig)"); - } - { - POSIX__SigSet sigset; - int sig = (int)SvIV(ST(2)); - SysRet RETVAL; - - if (sv_isa(ST(1), "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - sigset = (POSIX__SigSet) tmp; - } - else - croak("sigset is not of type POSIX::SigSet"); - - RETVAL = sigaddset(sigset, sig); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX__SigSet_sigdelset(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::SigSet::delset(sigset, sig)"); - } - { - POSIX__SigSet sigset; - int sig = (int)SvIV(ST(2)); - SysRet RETVAL; - - if (sv_isa(ST(1), "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - sigset = (POSIX__SigSet) tmp; - } - else - croak("sigset is not of type POSIX::SigSet"); - - RETVAL = sigdelset(sigset, sig); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX__SigSet_sigemptyset(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::SigSet::emptyset(sigset)"); - } - { - POSIX__SigSet sigset; - SysRet RETVAL; - - if (sv_isa(ST(1), "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - sigset = (POSIX__SigSet) tmp; - } - else - croak("sigset is not of type POSIX::SigSet"); - - RETVAL = sigemptyset(sigset); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX__SigSet_sigfillset(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::SigSet::fillset(sigset)"); - } - { - POSIX__SigSet sigset; - SysRet RETVAL; - - if (sv_isa(ST(1), "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - sigset = (POSIX__SigSet) tmp; - } - else - croak("sigset is not of type POSIX::SigSet"); - - RETVAL = sigfillset(sigset); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX__SigSet_sigismember(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::SigSet::ismember(sigset, sig)"); - } - { - POSIX__SigSet sigset; - int sig = (int)SvIV(ST(2)); - int RETVAL; - - if (sv_isa(ST(1), "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - sigset = (POSIX__SigSet) tmp; - } - else - croak("sigset is not of type POSIX::SigSet"); - - RETVAL = sigismember(sigset, sig); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_constant(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::constant(name,arg)"); - } - { - char * name = SvPV(ST(1),na); - int arg = (int)SvIV(ST(2)); - int RETVAL; - - RETVAL = constant(name, arg); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_isalnum(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::isalnum(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!isalnum(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_isalpha(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::isalpha(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!isalpha(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_iscntrl(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::iscntrl(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!iscntrl(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_isdigit(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::isdigit(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!isdigit(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_isgraph(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::isgraph(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!isgraph(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_islower(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::islower(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!islower(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_isprint(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::isprint(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!isprint(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_ispunct(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::ispunct(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!ispunct(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_isspace(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::isspace(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!isspace(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_isupper(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::isupper(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!isupper(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_isxdigit(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::isxdigit(charstring)"); - } - { - char * charstring = SvPV(ST(1),na); - int RETVAL; - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) - if (!isxdigit(*s)) - RETVAL = 0; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_POSIX_open(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 1 || items > 3) { - croak("Usage: POSIX::open(filename, flags = O_RDONLY, mode = 0666)"); - } - { - char * filename = SvPV(ST(1),na); - int flags; - int mode; - SysRet RETVAL; - - if (items < 2) - flags = O_RDONLY; - else { - flags = (int)SvIV(ST(2)); - } - - if (items < 3) - mode = 0666; - else { - mode = (int)SvIV(ST(3)); - } - - RETVAL = open(filename, flags, mode); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_localeconv(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 0) { - croak("Usage: POSIX::localeconv()"); - } - { - HV * RETVAL; - struct lconv *lcbuf; - RETVAL = newHV(); - if (lcbuf = localeconv()) { - /* the strings */ - if (lcbuf->decimal_point && *lcbuf->decimal_point) - hv_store(RETVAL, "decimal_point", 13, - newSVpv(lcbuf->decimal_point, 0), 0); - if (lcbuf->thousands_sep && *lcbuf->thousands_sep) - hv_store(RETVAL, "thousands_sep", 13, - newSVpv(lcbuf->thousands_sep, 0), 0); - if (lcbuf->grouping && *lcbuf->grouping) - hv_store(RETVAL, "grouping", 8, - newSVpv(lcbuf->grouping, 0), 0); - if (lcbuf->int_curr_symbol && *lcbuf->int_curr_symbol) - hv_store(RETVAL, "int_curr_symbol", 15, - newSVpv(lcbuf->int_curr_symbol, 0), 0); - if (lcbuf->currency_symbol && *lcbuf->currency_symbol) - hv_store(RETVAL, "currency_symbol", 15, - newSVpv(lcbuf->currency_symbol, 0), 0); - if (lcbuf->mon_decimal_point && *lcbuf->mon_decimal_point) - hv_store(RETVAL, "mon_decimal_point", 17, - newSVpv(lcbuf->mon_decimal_point, 0), 0); - if (lcbuf->mon_thousands_sep && *lcbuf->mon_thousands_sep) - hv_store(RETVAL, "mon_thousands_sep", 17, - newSVpv(lcbuf->mon_thousands_sep, 0), 0); - if (lcbuf->mon_grouping && *lcbuf->mon_grouping) - hv_store(RETVAL, "mon_grouping", 12, - newSVpv(lcbuf->mon_grouping, 0), 0); - if (lcbuf->positive_sign && *lcbuf->positive_sign) - hv_store(RETVAL, "positive_sign", 13, - newSVpv(lcbuf->positive_sign, 0), 0); - if (lcbuf->negative_sign && *lcbuf->negative_sign) - hv_store(RETVAL, "negative_sign", 13, - newSVpv(lcbuf->negative_sign, 0), 0); - /* the integers */ - if (lcbuf->int_frac_digits != CHAR_MAX) - hv_store(RETVAL, "int_frac_digits", 15, - newSViv(lcbuf->int_frac_digits), 0); - if (lcbuf->frac_digits != CHAR_MAX) - hv_store(RETVAL, "frac_digits", 11, - newSViv(lcbuf->frac_digits), 0); - if (lcbuf->p_cs_precedes != CHAR_MAX) - hv_store(RETVAL, "p_cs_precedes", 13, - newSViv(lcbuf->p_cs_precedes), 0); - if (lcbuf->p_sep_by_space != CHAR_MAX) - hv_store(RETVAL, "p_sep_by_space", 14, - newSViv(lcbuf->p_sep_by_space), 0); - if (lcbuf->n_cs_precedes != CHAR_MAX) - hv_store(RETVAL, "n_cs_precedes", 13, - newSViv(lcbuf->n_cs_precedes), 0); - if (lcbuf->n_sep_by_space != CHAR_MAX) - hv_store(RETVAL, "n_sep_by_space", 14, - newSViv(lcbuf->n_sep_by_space), 0); - if (lcbuf->p_sign_posn != CHAR_MAX) - hv_store(RETVAL, "p_sign_posn", 11, - newSViv(lcbuf->p_sign_posn), 0); - if (lcbuf->n_sign_posn != CHAR_MAX) - hv_store(RETVAL, "n_sign_posn", 11, - newSViv(lcbuf->n_sign_posn), 0); - } - ST(0) = newRV((SV*)RETVAL); - sv_2mortal(ST(0)); - } - return ax; -} - -static int -XS_POSIX_setlocale(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::setlocale(category, locale)"); - } - { - int category = (int)SvIV(ST(1)); - char * locale = SvPV(ST(2),na); - char * RETVAL; - - RETVAL = setlocale(category, locale); - ST(0) = sv_newmortal(); - sv_setpv(ST(0), RETVAL); - } - return ax; -} - -static int -XS_POSIX_acos(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::acos(x)"); - } - { - double x = (double)SvNV(ST(1)); - double RETVAL; - - RETVAL = acos(x); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_asin(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::asin(x)"); - } - { - double x = (double)SvNV(ST(1)); - double RETVAL; - - RETVAL = asin(x); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_atan(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::atan(x)"); - } - { - double x = (double)SvNV(ST(1)); - double RETVAL; - - RETVAL = atan(x); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_ceil(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::ceil(x)"); - } - { - double x = (double)SvNV(ST(1)); - double RETVAL; - - RETVAL = ceil(x); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_cosh(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::cosh(x)"); - } - { - double x = (double)SvNV(ST(1)); - double RETVAL; - - RETVAL = cosh(x); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_floor(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::floor(x)"); - } - { - double x = (double)SvNV(ST(1)); - double RETVAL; - - RETVAL = floor(x); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_fmod(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::fmod(x,y)"); - } - { - double x = (double)SvNV(ST(1)); - double y = (double)SvNV(ST(2)); - double RETVAL; - - RETVAL = fmod(x, y); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_frexp(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::frexp(x)"); - } - { - double x = (double)SvNV(ST(1)); - dSP; - int expvar; - sp--; - /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); - PUSHs(sv_2mortal(newSViv(expvar))); - ax = sp - stack_base; - } - return ax; -} - -static int -XS_POSIX_ldexp(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::ldexp(x,exp)"); - } - { - double x = (double)SvNV(ST(1)); - int exp = (int)SvIV(ST(2)); - double RETVAL; - - RETVAL = ldexp(x, exp); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_log10(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::log10(x)"); - } - { - double x = (double)SvNV(ST(1)); - double RETVAL; - - RETVAL = log10(x); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_modf(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::modf(x)"); - } - { - double x = (double)SvNV(ST(1)); - dSP; - double intvar; - sp--; - /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(modf(x,&intvar)))); - PUSHs(sv_2mortal(newSVnv(intvar))); - ax = sp - stack_base; - } - return ax; -} - -static int -XS_POSIX_sinh(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::sinh(x)"); - } - { - double x = (double)SvNV(ST(1)); - double RETVAL; - - RETVAL = sinh(x); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_tanh(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::tanh(x)"); - } - { - double x = (double)SvNV(ST(1)); - double RETVAL; - - RETVAL = tanh(x); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_sigaction(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 2 || items > 3) { - croak("Usage: POSIX::sigaction(sig, action, oldaction = 0)"); - } - { - int sig = (int)SvIV(ST(1)); - POSIX__SigAction action; - POSIX__SigAction oldaction; - SysRet RETVAL; - - if (sv_isa(ST(2), "POSIX::SigAction")) - action = (HV*)SvRV(ST(2)); - else - croak("action is not of type POSIX::SigAction"); - - if (items < 3) - oldaction = 0; - else { - if (sv_isa(ST(3), "POSIX::SigAction")) - oldaction = (HV*)SvRV(ST(3)); - else - croak("oldaction is not of type POSIX::SigAction"); - } - - - if (!siggv) - gv_fetchpv("SIG", TRUE, SVt_PVHV); - - { - struct sigaction act; - struct sigaction oact; - POSIX__SigSet sigset; - SV** svp; - SV** sigsvp = hv_fetch(GvHVn(siggv), - sig_name[sig], - strlen(sig_name[sig]), - TRUE); - - /* Remember old handler name if desired. */ - if (oldaction) { - char *hand = SvPVx(*sigsvp, na); - svp = hv_fetch(oldaction, "HANDLER", 7, TRUE); - sv_setpv(*svp, *hand ? hand : "DEFAULT"); - } - - if (action) { - /* Vector new handler through %SIG. (We always use sighandler - for the C signal handler, which reads %SIG to dispatch.) */ - svp = hv_fetch(action, "HANDLER", 7, FALSE); - if (!svp) - croak("Can't supply an action without a HANDLER"); - sv_setpv(*sigsvp, SvPV(*svp, na)); - mg_set(*sigsvp); /* handles DEFAULT and IGNORE */ - act.sa_handler = sighandler; - - /* Set up any desired mask. */ - svp = hv_fetch(action, "MASK", 4, FALSE); - if (svp && sv_isa(*svp, "POSIX::SigSet")) { - sigset = (sigset_t*)(unsigned long)SvNV((SV*)SvRV(*svp)); - act.sa_mask = *sigset; - } - else - sigemptyset(& act.sa_mask); - - /* Set up any desired flags. */ - svp = hv_fetch(action, "FLAGS", 5, FALSE); - act.sa_flags = svp ? SvIV(*svp) : 0; - } - - /* Now work around sigaction oddities */ - if (action && oldaction) - RETVAL = sigaction(sig, & act, & oact); - else if (action) - RETVAL = sigaction(sig, & act, (struct sigaction*)0); - else if (oldaction) - RETVAL = sigaction(sig, (struct sigaction*)0, & oact); - - if (oldaction) { - /* Get back the mask. */ - svp = hv_fetch(oldaction, "MASK", 4, TRUE); - if (sv_isa(*svp, "POSIX::SigSet")) - sigset = (sigset_t*)(unsigned long)SvNV((SV*)SvRV(*svp)); - else { - sigset = (sigset_t*)safemalloc(sizeof(sigset_t)); - sv_setptrobj(*svp, sigset, "POSIX::SigSet"); - } - *sigset = oact.sa_mask; - - /* Get back the flags. */ - svp = hv_fetch(oldaction, "FLAGS", 5, TRUE); - sv_setiv(*svp, oact.sa_flags); - } - } - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_sigpending(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::sigpending(sigset)"); - } - { - POSIX__SigSet sigset; - SysRet RETVAL; - - if (sv_isa(ST(1), "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - sigset = (POSIX__SigSet) tmp; - } - else - croak("sigset is not of type POSIX::SigSet"); - - RETVAL = sigpending(sigset); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_sigprocmask(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 2 || items > 3) { - croak("Usage: POSIX::sigprocmask(how, sigset, oldsigset = 0)"); - } - { - int how = (int)SvIV(ST(1)); - POSIX__SigSet sigset; - POSIX__SigSet oldsigset; - SysRet RETVAL; - - if (sv_isa(ST(2), "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(2))); - sigset = (POSIX__SigSet) tmp; - } - else - croak("sigset is not of type POSIX::SigSet"); - - if (items < 3) - oldsigset = 0; - else { - if (sv_isa(ST(3), "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(3))); - oldsigset = (POSIX__SigSet) tmp; - } - else - croak("oldsigset is not of type POSIX::SigSet"); - } - - RETVAL = sigprocmask(how, sigset, oldsigset); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_sigsuspend(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::sigsuspend(signal_mask)"); - } - { - POSIX__SigSet signal_mask; - SysRet RETVAL; - - if (sv_isa(ST(1), "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - signal_mask = (POSIX__SigSet) tmp; - } - else - croak("signal_mask is not of type POSIX::SigSet"); - - RETVAL = sigsuspend(signal_mask); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX__exit(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::_exit(status)"); - } - { - int status = (int)SvIV(ST(1)); - - _exit(status); - } - return ax; -} - -static int -XS_POSIX_close(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::close(fd)"); - } - { - int fd = (int)SvIV(ST(1)); - SysRet RETVAL; - - RETVAL = close(fd); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_dup(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::dup(fd)"); - } - { - int fd = (int)SvIV(ST(1)); - SysRet RETVAL; - - RETVAL = dup(fd); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_dup2(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::dup2(fd1, fd2)"); - } - { - int fd1 = (int)SvIV(ST(1)); - int fd2 = (int)SvIV(ST(2)); - SysRet RETVAL; - - RETVAL = dup2(fd1, fd2); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_lseek(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 0) { - croak("Usage: POSIX::lseek()"); - } - { - int; - Off_t; - int; - SysRet RETVAL; - - RETVAL = lseek(); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_nice(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::nice(incr)"); - } - { - int incr = (int)SvIV(ST(1)); - SysRet RETVAL; - - RETVAL = nice(incr); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_pipe(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 0) { - croak("Usage: POSIX::pipe()"); - } - { - int RETVAL; - dSP; - int fds[2]; - sp--; - if (pipe(fds) != -1) { - EXTEND(sp,2); - PUSHs(sv_2mortal(newSViv(fds[0]))); - PUSHs(sv_2mortal(newSViv(fds[1]))); - } - ax = sp - stack_base; - } - return ax; -} - -static int -XS_POSIX_read(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 0) { - croak("Usage: POSIX::read()"); - } - { - SysRet RETVAL; - int fd; - char * buffer; - size_t nbytes; - - RETVAL = read(fd, buffer, nbytes); - croak("POSIX::read() not implemented yet\n"); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_setgid(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::setgid(gid)"); - } - { - Gid_t gid = (Gid_t)SvNV(ST(1)); - SysRet RETVAL; - - RETVAL = setgid(gid); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_setpgid(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::setpgid(pid, pgid)"); - } - { - pid_t pid = (pid_t)SvNV(ST(1)); - pid_t pgid = (pid_t)SvNV(ST(2)); - SysRet RETVAL; - - RETVAL = setpgid(pid, pgid); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_setsid(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 0) { - croak("Usage: POSIX::setsid()"); - } - { - pid_t RETVAL; - - RETVAL = setsid(); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_setuid(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::setuid(uid)"); - } - { - Uid_t uid = (Uid_t)SvNV(ST(1)); - SysRet RETVAL; - - RETVAL = setuid(uid); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_tcgetpgrp(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: POSIX::tcgetpgrp(fd)"); - } - { - int fd = (int)SvIV(ST(1)); - pid_t RETVAL; - - RETVAL = tcgetpgrp(fd); - ST(0) = sv_newmortal(); - sv_setnv(ST(0), (double)RETVAL); - } - return ax; -} - -static int -XS_POSIX_tcsetpgrp(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: POSIX::tcsetpgrp(fd, pgrp_id)"); - } - { - int fd = (int)SvIV(ST(1)); - pid_t pgrp_id = (pid_t)SvNV(ST(2)); - SysRet RETVAL; - - RETVAL = tcsetpgrp(fd, pgrp_id); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -static int -XS_POSIX_uname(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 0) { - croak("Usage: POSIX::uname()"); - } - { - int RETVAL; - dSP; - struct utsname buf; - sp--; - if (uname(&buf) >= 0) { - EXTEND(sp, 5); - PUSHs(sv_2mortal(newSVpv(buf.sysname, 0))); - PUSHs(sv_2mortal(newSVpv(buf.nodename, 0))); - PUSHs(sv_2mortal(newSVpv(buf.release, 0))); - PUSHs(sv_2mortal(newSVpv(buf.version, 0))); - PUSHs(sv_2mortal(newSVpv(buf.machine, 0))); - } - ax = sp - stack_base; - } - return ax; -} - -static int -XS_POSIX_write(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 0) { - croak("Usage: POSIX::write()"); - } - { - SysRet RETVAL; - int fd; - char * buffer; - size_t nbytes; - - RETVAL = write(fd, buffer, nbytes); - croak("POSIX::write() not implemented yet\n"); - ST(0) = sv_newmortal(); - if (RETVAL != -1) { - if (RETVAL == 0) - sv_setpvn(ST(0), "0 but true", 10); - else - sv_setiv(ST(0), (I32)RETVAL); - } - } - return ax; -} - -int boot_POSIX(ix,ax,items) -int ix; -int ax; -int items; -{ - char* file = __FILE__; - - newXSUB("POSIX::SigSet::new", 0, XS_POSIX__SigSet_new, file); - newXSUB("POSIX::SigSet::DESTROY", 0, XS_POSIX__SigSet_DESTROY, file); - newXSUB("POSIX::SigSet::addset", 0, XS_POSIX__SigSet_sigaddset, file); - newXSUB("POSIX::SigSet::delset", 0, XS_POSIX__SigSet_sigdelset, file); - newXSUB("POSIX::SigSet::emptyset", 0, XS_POSIX__SigSet_sigemptyset, file); - newXSUB("POSIX::SigSet::fillset", 0, XS_POSIX__SigSet_sigfillset, file); - newXSUB("POSIX::SigSet::ismember", 0, XS_POSIX__SigSet_sigismember, file); - newXSUB("POSIX::constant", 0, XS_POSIX_constant, file); - newXSUB("POSIX::isalnum", 0, XS_POSIX_isalnum, file); - newXSUB("POSIX::isalpha", 0, XS_POSIX_isalpha, file); - newXSUB("POSIX::iscntrl", 0, XS_POSIX_iscntrl, file); - newXSUB("POSIX::isdigit", 0, XS_POSIX_isdigit, file); - newXSUB("POSIX::isgraph", 0, XS_POSIX_isgraph, file); - newXSUB("POSIX::islower", 0, XS_POSIX_islower, file); - newXSUB("POSIX::isprint", 0, XS_POSIX_isprint, file); - newXSUB("POSIX::ispunct", 0, XS_POSIX_ispunct, file); - newXSUB("POSIX::isspace", 0, XS_POSIX_isspace, file); - newXSUB("POSIX::isupper", 0, XS_POSIX_isupper, file); - newXSUB("POSIX::isxdigit", 0, XS_POSIX_isxdigit, file); - newXSUB("POSIX::open", 0, XS_POSIX_open, file); - newXSUB("POSIX::localeconv", 0, XS_POSIX_localeconv, file); - newXSUB("POSIX::setlocale", 0, XS_POSIX_setlocale, file); - newXSUB("POSIX::acos", 0, XS_POSIX_acos, file); - newXSUB("POSIX::asin", 0, XS_POSIX_asin, file); - newXSUB("POSIX::atan", 0, XS_POSIX_atan, file); - newXSUB("POSIX::ceil", 0, XS_POSIX_ceil, file); - newXSUB("POSIX::cosh", 0, XS_POSIX_cosh, file); - newXSUB("POSIX::floor", 0, XS_POSIX_floor, file); - newXSUB("POSIX::fmod", 0, XS_POSIX_fmod, file); - newXSUB("POSIX::frexp", 0, XS_POSIX_frexp, file); - newXSUB("POSIX::ldexp", 0, XS_POSIX_ldexp, file); - newXSUB("POSIX::log10", 0, XS_POSIX_log10, file); - newXSUB("POSIX::modf", 0, XS_POSIX_modf, file); - newXSUB("POSIX::sinh", 0, XS_POSIX_sinh, file); - newXSUB("POSIX::tanh", 0, XS_POSIX_tanh, file); - newXSUB("POSIX::sigaction", 0, XS_POSIX_sigaction, file); - newXSUB("POSIX::sigpending", 0, XS_POSIX_sigpending, file); - newXSUB("POSIX::sigprocmask", 0, XS_POSIX_sigprocmask, file); - newXSUB("POSIX::sigsuspend", 0, XS_POSIX_sigsuspend, file); - newXSUB("POSIX::_exit", 0, XS_POSIX__exit, file); - newXSUB("POSIX::close", 0, XS_POSIX_close, file); - newXSUB("POSIX::dup", 0, XS_POSIX_dup, file); - newXSUB("POSIX::dup2", 0, XS_POSIX_dup2, file); - newXSUB("POSIX::lseek", 0, XS_POSIX_lseek, file); - newXSUB("POSIX::nice", 0, XS_POSIX_nice, file); - newXSUB("POSIX::pipe", 0, XS_POSIX_pipe, file); - newXSUB("POSIX::read", 0, XS_POSIX_read, file); - newXSUB("POSIX::setgid", 0, XS_POSIX_setgid, file); - newXSUB("POSIX::setpgid", 0, XS_POSIX_setpgid, file); - newXSUB("POSIX::setsid", 0, XS_POSIX_setsid, file); - newXSUB("POSIX::setuid", 0, XS_POSIX_setuid, file); - newXSUB("POSIX::tcgetpgrp", 0, XS_POSIX_tcgetpgrp, file); - newXSUB("POSIX::tcsetpgrp", 0, XS_POSIX_tcsetpgrp, file); - newXSUB("POSIX::uname", 0, XS_POSIX_uname, file); - newXSUB("POSIX::write", 0, XS_POSIX_write, file); -} @@ -51,10 +51,9 @@ -------------------------------------------------------------------------- Perl is a language that combines some of the features of C, sed, awk -and shell. See the manual page for more hype. There's also a Nutshell -Handbook published by O'Reilly & Assoc. Their U.S. number is -1-800-998-9938 and their international number is 1-707-829-0515. -E-mail to nuts@ora.com. +and shell. See the manual page for more hype. There are also two Nutshell +Handbooks published by O'Reilly & Assoc. See pod/perlbook.pod +for more information. Please read all the directions below before you proceed any further, and then follow them carefully. @@ -65,10 +64,25 @@ in MANIFEST. Installation 1) Run Configure. This will figure out various things about your system. - Some things Configure will figure out for itself, other things it will - ask you about. It will then proceed to make config.h, config.sh, and - Makefile. If you're a hotshot, run Configure -d to take all the - defaults and then edit config.sh to patch up any flaws. + Some things Configure will figure out for itself, other things it + will ask you about. It will then proceed to make config.h, + config.sh, and Makefile. You may have to explicitly say + sh Configure to ensure that Configure is run under sh. + If you're a hotshot, run Configure -d to take all the defaults and + then edit config.sh to patch up any flaws. + + Configure supports a number of useful options. Run Configure -h + to get a listing. To compile with gcc, for example, you can run + Configure -Dcc=gcc, or answer 'gcc' at the cc prompt. + + By default, perl will be installed in /usr/local/{bin, lib, man}. + You can specify a different prefix for the default installation + directory, when Configure prompts you or by using something like + Configure -Dprefix=/whatever. + + You can also supply a file config.over to over-ride Configure's + guesses. It will get loaded up at the very end, just before + config.sh is created. You might possibly have to trim # comments from the front of Configure if your sh doesn't handle them, but all other # comments will be taken @@ -82,9 +96,8 @@ Installation If you have any additional changes to make to the C definitions, they can be done in cflags.SH. For instance, to turn off the optimizer - on eval.c, find the line in the switch structure for eval.c and - put the command $optimize='-g' before the ;;. You will probably - want to change the entry for teval.c too. To change the C flags + on toke.c, find the line in the switch structure for toke.c and + put the command optimize='-g' before the ;;. To change the C flags for all the files, edit config.sh and change either $ccflags or $optimize. 3) make depend @@ -111,46 +124,30 @@ Installation Makefile.SH, since a default rule only takes effect in the absence of a specific rule. - Most of the following hints are now done automatically by Configure. + Many of the following hints are now done automatically by Configure. + Some of the hints here were for Perl 4, and are probably obsolete. + They're left here for the moment just to give you some ideas for + what to try if you're having trouble. - The 3b2 needs to turn off -O. - Compilers with limited switch tables may have to define -DSMALLSWITCHES - Domain/OS 10.3 (at least) native C 6.7 may need -opt 2 for eval.c AIX/RT may need a -a switch and -DCRIPPLED_CC. - AIX RS/6000 needs to use system malloc and avoid -O on eval.c and toke.c. - AIX RS/6000 needs -D_NO_PROTO. - SUNOS 4.0.[12] needs -DFPUTS_BOTCH. - SUNOS 3.[45] should use the system malloc. - SGI machines may need -Ddouble="long float" and -O1. - Vax-based systems may need to hand assemble teval.s with a -J switch. - Ultrix on MIPS machines may need -DLANGUAGE_C. - Ultrix 4.0 on MIPS machines may need -Olimit 2900 or so. Ultrix 3.[01] on MIPS needs to undefine WAITPID--the system call is busted. - MIPS machines need /bin before /bsd43/bin in PATH. MIPS machines may need to undef d_volatile. - MIPS machines may need to turn off -O on cmd.c, perl.c and tperl.c. + MIPS machines may need to turn off -O on some files. Some MIPS machines may need to undefine CASTNEGFLOAT. - Xenix 386 needs -Sm11000 for yacc, and may need -UM_I86. - SCO Xenix may need -m25000 for yacc. See also README.xenix. - Genix needs to use libc rather than libc_s, or #undef VARARGS. + Xenix 386 may need -UM_I86. See also README.xenix. + Genix may need to use libc rather than libc_s, or #undef VARARGS. NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR. - A/UX may appears to work with -O -B/usr/lib/big/ optimizer flags. - A/UX needs -lposix to find rewinddir. + A/UX may appear to work with -O -B/usr/lib/big/ optimizer flags. + A/UX may need -lposix to find rewinddir. A/UX may need -ZP -DPOSIX, and -g if big cc is used. - FPS machines may need -J and -DBADSWITCH. UTS may need one or more of -DCRIPPLED_CC, -K or -g, and undef LSTAT. - dynix may need to undefine CASTNEGFLOAT (d_castneg='undef' in config.sh). - Dnix (not dynix) may need to remove -O. - IRIX 3.3 may need to undefine VFORK. - HP/UX may need to pull cerror.o and syscall.o out of libc.a and link - them in explicitly. - If you get syntax errors on '(', try -DCRIPPLED_CC or -DBADSWITCH or both. - Machines with half-implemented dbm routines will need to #undef ODBM & NDBM. - If you have GDBM available and want it instead of NDBM, say -DHAS_GDBM. - C's that don't try to restore registers on longjmp() may need -DJMPCLOBBER. - (Try this if you get random glitches.) + If you get syntax errors on '(', try -DCRIPPLED_CC. + Machines with half-implemented dbm routines will need to #undef I_ODBM + SCO prior to 3.2.4 may be missing dbmclose(). An upgrade to 3.2.4 + that includes libdbm.nfs (which includes dbmclose()) may be available. If you get duplicates upon linking for malloc et al, say -DHIDEMYMALLOC. - Turn on support for 64-bit integers (long longs) with -DQUAD. + If you get duplicate function definitions (a perl function has the + same name as another function on your system) try -DEMBED. 5) make test @@ -170,7 +167,12 @@ Installation you are not root, you must own the directories in question and you should ignore any messages about chown not working. -7) Read the manual entry before running perl. + Most of the documentation in the pod/ directory is also available + in HTML format. Type + cd pod; make html; cd .. + to generate the html versions. + +7) Read the manual entries before running perl. 8) IMPORTANT! Help save the world! Communicate any problems and suggested patches to me, lwall@netlabs.com (Larry Wall), so we can diff --git a/README.Conf b/README.Conf deleted file mode 100644 index 807b457afc..0000000000 --- a/README.Conf +++ /dev/null @@ -1,146 +0,0 @@ -From: doughera@lafcol.lafayette.edu (Andy Dougherty) -Subject: RE: First stab at Configure Support for perl5alpha -Date: Fri Apr 29 16:43:18 EDT 1994 - -I have incorporated various fixes/suggestions into the Configure -support for perl5alpha8. The main changes are the following: - -Better incorporation of extensions in Makefile.SH. - -miniperlmain.c no longer requires dynamic loading. - -perl can use dynamic loading if available, but extensions can - also be compiled in statically, if desired. - -perlmain.c now built from miniperlmain.c by writemain.SH, - which is called in the makefile. Only the requested extensions - are compiled in. - -dynamic loading broken up into dl_sunos.c, dl_next.c, dl_hpux.c. - Configure will look for dl_$osname.c, where osname is determined - at the same time as hints are suggested. - -Configure support added for sdbm library (ext/dbm/sdbm/libsdbm.a). - This still needs testing. - -Tests for extensions now check in %Config to see if that extension - is available. Note, however, the sdbm is not an *optional* - extension, so it will fail (and make test will complain) - if sdbm is not installed. Thus perl programmers can safely assume - that at least sdbm is available. - -configpm now correctly handles comments at the end of config.sh - (which Configure places there if a hints file tries to propagate - unknown variables, such as libswanted). - -makedepend now works in UU/ subdirectory (so it doesn't delete - miniperlmain.c on systems with 14-character file name limits). - -ext/typemap: My compiler couldn't handle some of the more complex - casts, so an intermediate unsigned long variable has been introduced. - I should probably re-do this in terms of a CRIPPLED_CC macro in - XSUB.h, but it's not clear to me that it's worth it. - -some new or updated hints files. - -miscellaneous bug fixes. - -Problems remaining: - - -POSIX module is still under construction. - -Dynamic loading of extensions works on SunOS 4.1.3, but it - might need modifications to work with other systems. - -It is possible to do mixed dynamic/static loading, that is, - load commonly used modules statically and other modules - dynamically. Currently, this must be done by hand by setting - extobj in makefile and hand-editing perlmain.c. - The newXSUB line for the static module must be moved into - the #ifdef USE_DYNAMIC_LOADING section in perlmain.c, and the - module .o file must be added to the extobj= line in makefile. - -lib/[sn]dbm.t tests create a new file with a hard-wired set of - flags. These should be replaced with O_CREAT | O_RDWR, which - will be available from POSIX.pm, once it is up and running. - For now, you might have to change the 0x202 to 0x102 (or perhaps - 0x402) in lib/[sn]dbm.t for the tests to succeed. - -I have applied several suggested fixes for use on the DEC alpha, - but I haven't been able to keep up with all of them. - -Though CRIPPLED_CC works, it might be desireable to have Configure - try to figure it out. - -To apply: Obtain a clean copy of perl5alpha8 - cd <your perl5alpha8 directory> - patch -p1 < <this patch> - -As before, I am willing to continue to coordinate and develop the -Configure support. - -Thanks to the following for various and often quite substantial -patches and suggestions: - Peter Galbavy <peter@wonderland.org> - Jarkko Hietaniemi <jhi@alpha.hut.fi> - Andreas Koenig <koen1830@w203zrz.zrz.tu-berlin.de> - Raphael Manfredi <ram@acri.fr> - David Meyer <dmm0t@rincewind.mech.virginia.edu> - Jeff Okamoto <okamoto@hpcc101.corp.hp.com> - John Stoffel <john@WPI.EDU> - Larry Wall (lwall@netlabs.com> - - Andy Dougherty doughera@lafcol.lafayette.edu - Dept. of Physics Phone: (610) 250-5212 - Lafayette College FAX: (610) 250-9263 - Easton, PA 18042-1782 - -================================================================= - -From: doughera@lafcol.lafayette.edu (Andy Dougherty) -Subject: First stab at Configure Support for perl5alpha -Date: Mon Apr 4 15:13:50 EDT 1994 - -I've updated Configure to support perl5alpha7. Consider this a -first attempt. I am willing to continue to develop and coordinate -improvement on this. I've included the metaconfig units (in the U/ -directory) that I developed for this. New units, or fixes to these, -are welcome. - -Here's what should work: - -You should be able to Configure and run miniperl on any platform - that supported perl4. - - -Configure should be more amenable to hints. In particular, - you can remove directories from the library search path with - a hints file. See hints/solaris_2_3.sh for an example. - -Here's what needs improvement: - -Including dynamic loading on works on SunOS 4.1.x, as far as I - know, but nowhere else. I don't understand enough about what's - going on to put in stub functions for those who might want/have to - use another dynamic linking package or static linking. Configure - assumes you want to use the dl.c source file if you try to use - dynamic linking. Still, you should be able to get miniperl up and - running. - - -I haven't made any changes to installperl. - - -Makefile.SH (and hence makefile) should arrange to pick up the - appropriate .pm modules from the extensions directory and install - them. I haven't done anything about that. - - -I didn't incorporate any of the Configure changes into the - extension files, partly because I couldn't get past the dynamic - loading problem on my main machine, but mostly because I haven't - had the time yet. That's near the top of the ToDo list. - - -I made no changes to the x2p/ subdirectory, though some might - be probably needed. - - -Lots of the hints files are probably now out of date. - The solaris_2_[23].sh ones are completely untested guesses. - Fixed/updated version are welcome. - - -The defaults are to use perl's malloc and compile with - -g -DDEBUGGING. I was unable to get perl to pass all tests - with anything else. Part of the problem may be the stupid stub - functions I inserted in dump.c and sv.c, but there may be other - malloc/free problems elsewhere. - - -Whatever else I broke to get this to work. - -Thanks to - Tim Bunce <timbo@ig.co.uk>, - Manoj Srivastava <srivasta@pilgrim.umass.edu>, and - Bill Hertzing <wgh@fns.com> -for various suggestions and help. Thanks to Raphael Manfredi for -much work on dist-3.0. - - Andy Dougherty doughera@lafcol.lafayette.edu - Dept. of Physics Phone: (610) 250-5212 - Lafayette College FAX: (610) 250-9263 - Easton, PA 18042-1782 diff --git a/README.ncr b/README.ncr deleted file mode 100644 index a21e0f279b..0000000000 --- a/README.ncr +++ /dev/null @@ -1,151 +0,0 @@ -From: lreed@ncratl.AtlantaGA.NCR.COM (Len Reed) -Newsgroups: comp.lang.perl -Subject: Fixes for Perl 4.019 on NCR Tower V.3 -Date: 17 Feb 92 16:41:30 GMT -Organization: Holos Software, Inc. - -Here are the fixes needed to make perl 4.019 on the NCR Tower V.3 system. -I have bundled this as a shar file: feed everything below the CUT line -to /bin/sh. - -The file hints/ncr_tower.sh fixes several problems. It replaces the -standard copy thereof. Note that I use perl's malloc. Note also -that I have turned the optimizer completely off (-O0). Optimizing -at -O1 or -O2 produces some errors that the test suite doesn't catch. -(Problems with alloca() and setjmp/longjmp, I think.) It should be -possible to optimize some modules but I haven't experimented with this. - -[NOTE: this hints file is already installed--lwall] - -I'm don't know if mkdir(2) works: I've left it undef'ed. It is certainly -broken in V.2. If you need fast mkdir's you may want to experiment with -this. - -The file patch.twg fixes a stupidity in /usr/netinclude/sys/time.h. -You'll need this if you have WIN-TCP; you can't use it if you don't -have WIN-TCP. If needed, apply this patch *before* running Configure. - -Make sure you tell Configure that any config.sh it finds is to be ignored. - -After running Configure and make depend, edit config.h so that -the CPPSTDIN definition has DEFAULT_CPP=/dev/null prepended. It should -look this this: - -#define CPPSTDIN "DEFAULT_CPP=/dev/null cc -E" - -This must be done by hand after running "make depend" and before running -make. I was unable to encode this into the hints file. - -This resulting perl should pass all tests. - --Len Reed -Holos Software, Inc. -holos0!lbr@gatech.edu (my main account) -lreed@ncratl.atlantaga.ncr.com (this account--on a customer's machine) - ------CUT HERE---- -#!/bin/sh -# This is a shell archive (shar 3.32) -# made 02/17/1992 16:36 UTC by lreed@ncratl -# Source directory /usr/acct/lreed/,q -# -# existing files WILL be overwritten -# -# This shar contains: -# length mode name -# ------ ---------- ------------------------------------------ -# 1593 -rw-rw-rw- patch.twg -# 176 -rw-r--r-- hints/ncr_tower.sh -# -if touch 2>&1 | fgrep 'amc' > /dev/null - then TOUCH=touch - else TOUCH=true -fi -# ============= patch.twg ============== -echo "x - extracting patch.twg (Text)" -sed 's/^X//' << 'SHAR_EOF' > patch.twg && -XThe following patch fixes /usr/netinclude/sys/time.h on the Tower V.3. -XPulling in <sys/time.h> with -I/usr/inetinclude makes a mess unless -Xthe <sys/twg_config.h> file is pulled in, too. It's stupid that an -Xapplication (e.g., perl) should have to do this. Thus, I fixed -Xthe system header file. The alternative is to make each application -Xget the header file itself. (The #if allows the application to do -Xit, though, for compatibility with existing applications.) -X -XTo apply this patch, chdir to /usr/netinclude/sys and run -X patch <this_file -X -XIf the patch fails, fix the file by hand. All I've done is put -X#ifndef HDEF -X /* Len Reed 5/6/91 -- pulling in <sys/time.h> shouldn't cause -X HDEF to blow up the compile--auto pull in its defining file. -X */ -X# include <sys/twg_config.h> -X#endif -X -Xbefore HDEF is used. -X -X-----The patch starts below this line -X -X*** time.h.old Fri Feb 14 12:06:46 1992 -X--- time.h Fri Feb 14 12:04:32 1992 -X*************** -X*** 4,12 **** -X /* time.h 6.1 83/07/29 */ -X /* " @(#)time.h (TWG) 2.2 88/05/17 " */ -X -X! /* -X HDEF( "@(#)$RCSfile: README.ncr,v $$Revision: 4.1 $$Date: 92/08/07 17:18:12 $" ) -X- */ -X -X /* -X * Structure returned by gettimeofday(2) system call, -X--- 4,17 ---- -X /* time.h 6.1 83/07/29 */ -X /* " @(#)time.h (TWG) 2.2 88/05/17 " */ -X -X! #ifndef HDEF -X! /* Len Reed 5/6/91 -- pulling in <sys/time.h> shouldn't cause -X! HDEF to blow up the compile--auto pull in its defining file. -X! */ -X! # include <sys/twg_config.h> -X! #endif -X! -X HDEF( "@(#)$RCSfile: README.ncr,v $$Revision: 4.1 $$Date: 92/08/07 17:18:12 $" ) -X -X /* -X * Structure returned by gettimeofday(2) system call, -SHAR_EOF -$TOUCH -am 0217113592 patch.twg && -chmod 0666 patch.twg || -echo "restore of patch.twg failed" -set `wc -c patch.twg`;Wc_c=$1 -if test "$Wc_c" != "1593"; then - echo original size 1593, current size $Wc_c -fi -# ============= hints/ncr_tower.sh ============== -if test ! -d 'hints'; then - echo "x - creating directory hints" - mkdir 'hints' -fi -echo "x - extracting hints/ncr_tower.sh (Text)" -sed 's/^X//' << 'SHAR_EOF' > hints/ncr_tower.sh && -Xoptimize='-O0' -Xccflags="$ccflags -W2,-Sl,2000" -Xeval_cflags='large="-W0,-XL"' -Xteval_cflags=$eval_cflags -Xd_mkdir=$undef -Xusemymalloc='y' -Xmallocsrc='malloc.c' -Xmallocobj='malloc.o' -SHAR_EOF -$TOUCH -am 0214073692 hints/ncr_tower.sh && -chmod 0644 hints/ncr_tower.sh || -echo "restore of hints/ncr_tower.sh failed" -set `wc -c hints/ncr_tower.sh`;Wc_c=$1 -if test "$Wc_c" != "176"; then - echo original size 176, current size $Wc_c -fi -exit 0 - - diff --git a/README.uport b/README.uport deleted file mode 100644 index b2b5712e86..0000000000 --- a/README.uport +++ /dev/null @@ -1,34 +0,0 @@ -From dwm@uf.msc.umn.edu Tue Dec 19 15:03:27 1989 -Subject: perl on Microport Un*x 2.4 - -Here are the steps to get perl patchlevel 6 running on Microport Un*x 2.4. - -(1) Get the directory routines (opendir, readdir, etc) from an archive - somewhere. I got mine from uunet: comp.sources.unix/volume9/gwyn-dir-lib - and comp.sources.unix/volume10/dir-lib.pch. Compile a large memory - version of the library and put it in /usr/lib/large/dir.a. Also put - the dir.h include file in /usr/include/sys. [ If you don't want to - do this make sure I_SYSDIR does not defined in config.sh ] - -(2) Configure causes sh to get a segmentation fault when it does the - ". config.sh" near line 2551. You will have to remove that line - from Configure and make sure you get your configuration info right - the first time or start over if you make a mistake. - -[Or just run the .SH files by hand and proceed to the make depend.] - -(3) If you are using C-shell, put a blank line at the start of Configure so it - wont get executed by the C-shell. If you are using ksh, you will have to - execute Configure with 'sh Configure'. Configure does not work with - ksh. - -(4) When you run Configure, select compilation option -DCRIPPLED_CC. - I also selected -DDEBUGGING to make debugging easier. I recommend it. - You can use -O, but you will then have to compile consarg.c and util.c - separately without -O because the optimizer generates bad code for these - routines. The optimizer also dies harmlessly while optimizing cmd.c, - eval.c (who can blame it? [sorry, Larry]), and toke.c. - I am still trying to isolate the remaining optimization problems in - consarg.c and util.c. - -[The rest of the previously published instructions are no longer necessary.] diff --git a/README.vms b/README.vms new file mode 100644 index 0000000000..dbf6251311 --- /dev/null +++ b/README.vms @@ -0,0 +1,232 @@ +Last revised: 09-Oct-1994 by Charles Bailey bailey@genetics.upenn.edu + +The VMS port of perl5 is still under development. At this time, the perl +binaries built under VMS handle internal operations properly, for the most +part, as well as most of the system calls which have close equivalents under +VMS. There are still some incompatibilities in process handling (e.g the +fork/exec model for creating subprocesses doesn't do what you might expect +under Unix), and there remain some file handling differences from Unix. There +is a VMS implementation of the DynaLoader, but it hasn't been tested much, so +it may still have some bugs in it. Over the longer term, we'll try to get many +of the useful VMS system services integrated as well, depending on time and +people available. Of course, if you'd like to add something yourself, or join +the porting team, we'd love to have you! + +The current sources and build procedures have been tested on a VAX using VAXC +and on an AXP using DECC. IF you run into problems with other compilers, +please let us know. + + +* Other software required + +At the moment, in addition to basic VMS, you'll need two things: + - a C compiler: VAXC, DECC, or gcc for the VAX; DECC for the AXP + - a make tool: DEC's MMS or the free analog MMK (available from ftp.spc.edu) + or a standard make utility (e.g. GNU make, also available from + ftp.spc.edu). +In addition, you may include socket support if you have a IP stack running +on your system. See the topic "Socket support" for more information. + +* Socket support + +Perl5 includes a number of IP socket routines among its builtin functions, +which are available if you choose to compile perl with socket support. Since +IP networking is an optional addition to VMS, there are several different IP +stacks available, it's difficult to automate the process of building perl5 with +socket support in a way which will work on all systems. + +By default, perl5 is built without IP socket support. If you define the macro +SOCKET when invoking MMS, however, socket support will be included. As +distributed, perl5 for VMS includes support for the SOCKETSHR socket library, +which is layered on MadGoat software's vendor-independent NETLIB interface. +This provides support for all socket calls used by perl5 except the +[g|s]et*ent() routines, which are replaced for the moment by stubs which +generate a fatal error if a perl script attempts to call one of these routines. +If you'd like to link perl directly to your IP stack to take advantage of these +routines or to eliminate the intermediate NETLIB, then make the following +changes: + - In Descrip.MMS, locate the section beginning with .ifdef SOCKET, and + change the SOCKLIB macro so that it translates to the filespec of your + IP stack's socket library. This will be added to the RTL options file. + - Edit the file SockAdapt.H in the [.VMS] subdirectory so that it + includes the In.H, NetDb.H, and, if necessary, Errno.H header files + for your IP stack, or so that it declares the standard TCP/IP data + structures appropriately (see the distributed copy of SockAdapt.H + for a collection of the structures needed by perl.) You should also + define any logical names necessary to find these files before invoking + MMS to build perl. + - Edit the file SockAdapt.C in the [.VMS] subdirectory so that it + contains routines which substitute for any IP library routines + required by perl which your IP stack does not provide. This may + require a little trial and error; we'll try to compile a complete + list soon of socket routines required by perl5. + +* Building perl under VMS + +Since you're reading this, presumable you've unpacked the perl distribution +into its directory tree, in which you will find a [.vms] subdirectory below +the directory in which this file is found. If this isn't the case, then you'll +need to unpack the distribution properly, or manually edit Descrip.MMS or +the VMS Makefile. to alter directory paths as necessary. (I'd advise using the +`normal' directory tree, at least for the first time through.) This +subdirectory contains several files, among which are the following: + Config.VMS - A template C header file set up for VMS. + Descrip.MMS - The MMS/MMK dependency file for building perl + GenConfig.Pl - A perl script to generate Config.SH retrospectively + from Config.VMS, since the Configure shell script which + normally generates Config.SH doesn't run under VMS. + GenOpt.Com - A little DCL procedure used to write some linker options + files, since not all make utilities can do this easily. + Gen_ShrFls.Pl - A perl script which generates linker options files and + MACRO declarations for PerlShr.Exe. + Makefile. - The make dependency file for building perl + MMS2Make.Pl - A perl script used to generate Makefile. from Descrip.MMS + VMSish.H - C header file containing VMS-specific definitions + VMS.C - C source code for VMS-specific routines + WriteMain.Pl - A perl script used to generate perlmain.c during the build. +There may also be other files pertaining to features under development; for the +most part, you can ignore them. + +Config.VMS and Decrip.MMS/Makefile. are set up to build a version of perl which +includes all features known to work when this release was assembled. If you +have code at your site which would support additional features (e.g. emulation +of Unix system calls), feel free to make the appropriate changes to these +files. (Note: Do not use or edit config.h in the main perl source directory; +it is superseded by the current Config.VMS during the build.) You may also +wish to make site-specific changes to Descrip.MMS or Makefile. to reflect local +conventions for naming of files, etc. + +At the moment, system-specific information which becomes part of the perl5 +Config extension is hard-coded into the file genconfig.pl in the vms +subdirectory. Before you build perl, you should make any changes to the list +at the end of this file necessary to reflect your system (e.g your hostname and +VMS version). + +Examine the information at the beginning of Descrip.MMS for information about +specifying alternate C compilers or building a version of perl with debugging +support. For instance, if you want to use DECC, you'll need to include the +/macro="decc=1" qualifier to MMS (If you're using make, these options are not +supported.) If you're on an AXP system, define the macro __AXP__ (MMK does +this for you), and DECC will automatically be selected. + +To start the build, set default to the main source directory. +Then, if you are using MMS or MMK, issue the command +$ MMS/Descrip=[.VMS] ! or MMK +If you are using make, issue the command +$ Make -f [.VMS]Makefile. +Note that the Makefile. doesn't support conditional compilation, and is +set up to use VAXC on a VAX, and does not include socket support. You can +either edit the Makefile. by hand, using Descrip.MMS as a guide, or use the +Makefile. to build Miniperl.Exe, and then run the Perl script MMS@Make.pl, +found in the [.VMS] subdirectory, to generate a new Makefile with the options +appropriate to your site. + +Note for sites using early versions of DECC: A bug in some versions of the +DECC RTL causes newlines to be lost when writing to a pipe. This causes +Gen_ShrFls.pl to fail, since it can't read the preprocessor output to identify +global variables and routines. You can work around this problem by defining +the macro DECC_PIPES_BROKEN when you invoke MMS or MMK. + +This will build the following files: + Miniperl.Exe - a stand-alone version of without any extensions. + Miniperl has all the intrinsic capabilities of perl, + but cannot make use of the DynaLoader or any + extensions which use XS code. + PerlShr.Exe - a shareable image containing most of perl's internal + routines and global variables. Perl.Exe is linked to + this image, as are all dynamic extensions, so everyone's + using the same set of global variables and routines. + Perl.Exe - the main perl executable image. It's contains the + main() routine, plus code for any statically linked + extensions. + PerlShr_Attr.Opt - A linker options file which specifies psect attributes + matching those in PerlShr.Exe. It should be used when + linking images against PerlShr.Exe + [.Lib]Config.pm - the perl extension which saves configuration information + about perl and your system. + [.lib]DynaLoader.pm - The perl extension which performs dynamic linking of + shareable images for extensions. +There are, of course, a number of other files created for use during the build. +Once you've got the binaries built, you may wish to `build' the `tidy' or +`clean' targets to remove extra files. + + +* Installing perl once it's built + +Once the build is complete, you'll need to do the following: + - Put PerlShr.Exe in a common directory, and make it world-readable. + If you place it in a location other than Sys$Share, you'll need to + define the logical name PerlShr to point to the image. + - Put Perl.Exe in a common directory, and make it world executable + - Define a foreign command to invoke perl, using a statement like + $ Perl == "$dev:[dir]Perl.Exe" + - Create a world-readable directory tree for perl library modules, + scripts, and what-have-you, and define PERL_ROOT as a rooted logical + name pointing to the top of this tree (i.e. if your perl files were + going to live in DKA1:[Perl5...], then you should + $ Define/Translation=Concealed Perl_Root DKA1:[Perl5.] + - Define the logical name PERLSHR as the full file specification of + PERLSHR.EXE, so executable images linked to it can find it. Alternatively, + you can justput PERLSHR.EXE int SYS$SHARE. + - Place the files from the [.lib] subdirectory in the distribution package + into a [.lib] subdirectory off the root directory described above. + - Most of the perl5 documentation lives in the [.pod] subdirectory, and + is written in a simple markup format which can be easily read. In this + directory as well are pod2man and pod2html translators to reformat the + docs for common display engines; a pod2hlp translator is under development. + Information on perl5 can also be gleaned from the files in the [.doc] + subdirectory (internals documents and summaries of changes), and from + the test scripts in the [.t...] subdirectories. +For now, that's it. + + +* For more information + +If you're interested in more information on perl in general, consult the Usenet +newsgroup comp.lang.perl. The FAQ for that group provides pointers to other +online sources of information, as well as books describing perl in depth. + +If you're interested in up-to-date information on perl5 development and +internals, you might want to subscribe to the perl5-porters mailing list. You +can do this by sending a message to perl5-porters-request@isi.edu, containing +the single line +subscribe perl5-porters Your Name Here +This is a moderately high-volume list at the moment (25-50 messages/day). + +Finally, if you're interested in ongoing information about the VMS port, you +can subscribe to the VMSperl mailing list by sending a request to +bailey@genetics.upenn.edu (it's to a human, not a list server - this is a small +operation at the moment). And, as always, we welcome any help or code you'd +like to offer - you can send mail to bailey@genetics.upenn.edu or directly to +the VMSperl list at vmsperl@genetics.upenn.edu. + +Good luck using perl. Please let us know how it works for you - we can't +guarantee that we'll be able to fix bugs quickly, but we'll try, and we'd +certainly like to know they're out there. + + +* Acknowledgements + +There are, of course, far too many people involved in the porting and testing +of perl5 to mention everyone who deserves it, so please forgive us if we've +missed someone. That said, special thanks are due to the following: + David Denholm <denholm@conmat.phys.soton.ac.uk> + for extensive testing and provision of pipe and SocketShr code, + Mark Pizzolato <mark@infocomm.com> + for the getredirection() code + Rich Salz <rsalz@bbn.com> + for readdir() and related routines + Denis Haskin <DWH@epub.ziff.com> + for work on a pod-to-hlp translator for the perl5 documentation + Richard Dyson <dyson@blaze.physics.uiowa.edu> and + Kent Covert <kacovert@miavx1.acs.muohio.edu> + for additional testing on the AXP. +and to the entire VMSperl group for useful advice and suggestions. In addition +the perl5-porters, especially Andy Dougherty <doughera@lafcol.lafayette.edu> +and Tim Bunce <Tim.Bunce@ig.co.uk>, deserve credit for their creativity and +willingness to work with the VMS newcomers. Finally, the greatest debt of +gratitude is due to Larry Wall <lwall@netlabs.com>, for having the ideas which +have made our sleepless nights possible. + +Thanks, +The VMSperl group diff --git a/README.xenix b/README.xenix deleted file mode 100644 index ca9a060880..0000000000 --- a/README.xenix +++ /dev/null @@ -1,53 +0,0 @@ -From jpl-devvax!elroy.jpl.nasa.gov!sdd.hp.com!spool.mu.edu!uunet!mcsun!ukc!stl!robobar!ronald Thu Mar 7 09:51:06 PST 1991 -Article 4564 of comp.lang.perl: -Path: jpl-devvax!elroy.jpl.nasa.gov!sdd.hp.com!spool.mu.edu!uunet!mcsun!ukc!stl!robobar!ronald ->From: ronald@robobar.co.uk (Ronald S H Khoo) -Newsgroups: comp.lang.perl -Subject: Re: directory entries chopped on SCO Unix -Message-ID: <1991Mar7.083046.14410@robobar.co.uk> -Date: 7 Mar 91 08:30:46 GMT -References: <18097@ogicse.ogi.edu> <DJM.91Mar5054514@egypt.eng.umd.edu> <498@stephsf.stephsf.com> -Organization: Robobar Ltd., Perivale, Middx., ENGLAND. -Lines: 38 -Status: OR - -wengland@stephsf.stephsf.com (Bill England) writes: - -> Would modification of the config to -> drop the Xenix specific test and also dropping the -lx library -> work better on Xenix boxes ? Sorry I can't test Xenix here. - -This is a difficult question to answer, mostly because it's hard to -tell exactly what kind of Xenix you have. - - Early releases didn't have any kind of ndir -- no problem - - Many releases have only sys/ndir + -lx -- no problem - - SCO Xenix 2.3.[012] have ndir + dirent, but dirent is reputedly - broken on .0 and .1, hence the hack to undef it. - - *However*, the kernel upgrade to 2.3.3 (where dirent apparently works) - from any lower 2.3.? is a free upgrade, which you can anon FTP or UUCP. - -I use dirent -- I had to make a decision which set of directory routines -to throw out (so that there would be no confusion), so I threw out the -old ones. This means I have to manually remove the ! defined(M_XENIX) -hacks from the source which is very ugh. - -My opinion is that the hacks should be removed seeing as they only apply -to a small number of operating system versions which you upgrade for -free anyway. Chip may disagree with me. It all rather depends on your -particular point of view. - -You could hack Configure to do case "`uname -r`" in 2.3.[01]) -I guess. It's a lot of code to handle just one specific case, -since you have to determine whether to do it or not as well. - -In short, I Really Don't Know But It's All Very Annoying. - -Just another Xenix user, --- -Ronald Khoo <ronald@robobar.co.uk> +44 81 991 1142 (O) +44 71 229 7741 (H) - - diff --git a/SDBM_File.c b/SDBM_File.c deleted file mode 100644 index fcf2259448..0000000000 --- a/SDBM_File.c +++ /dev/null @@ -1,296 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include "ext/dbm/sdbm/sdbm.h" - -typedef DBM* SDBM_File; -#define sdbm_new(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode) -#define nextkey(db,key) sdbm_nextkey(db) - -static int -XS_SDBM_File_sdbm_new(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 4) { - croak("Usage: SDBM_File::new(dbtype, filename, flags, mode)"); - } - { - char * dbtype = SvPV(ST(1),na); - char * filename = SvPV(ST(2),na); - int flags = (int)SvIV(ST(3)); - int mode = (int)SvIV(ST(4)); - SDBM_File RETVAL; - - RETVAL = sdbm_new(dbtype, filename, flags, mode); - ST(0) = sv_newmortal(); - sv_setptrobj(ST(0), RETVAL, "SDBM_File"); - } - return ax; -} - -static int -XS_SDBM_File_sdbm_DESTROY(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: SDBM_File::DESTROY(db)"); - } - { - SDBM_File db; - - if (SvROK(ST(1))) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (SDBM_File) tmp; - } - else - croak("db is not a reference"); - sdbm_close(db); - } - return ax; -} - -static int -XS_SDBM_File_sdbm_fetch(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: SDBM_File::fetch(db, key)"); - } - { - SDBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (SDBM_File) tmp; - } - else - croak("db is not of type SDBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - RETVAL = sdbm_fetch(db, key); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return ax; -} - -static int -XS_SDBM_File_sdbm_store(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 3 || items > 4) { - croak("Usage: SDBM_File::store(db, key, value, flags = DBM_REPLACE)"); - } - { - SDBM_File db; - datum key; - datum value; - int flags; - int RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (SDBM_File) tmp; - } - else - croak("db is not of type SDBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - value.dptr = SvPV(ST(3), na); - value.dsize = (int)na;; - - if (items < 4) - flags = DBM_REPLACE; - else { - flags = (int)SvIV(ST(4)); - } - - RETVAL = sdbm_store(db, key, value, flags); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_SDBM_File_sdbm_delete(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: SDBM_File::delete(db, key)"); - } - { - SDBM_File db; - datum key; - int RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (SDBM_File) tmp; - } - else - croak("db is not of type SDBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - RETVAL = sdbm_delete(db, key); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_SDBM_File_sdbm_firstkey(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: SDBM_File::firstkey(db)"); - } - { - SDBM_File db; - datum RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (SDBM_File) tmp; - } - else - croak("db is not of type SDBM_File"); - - RETVAL = sdbm_firstkey(db); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return ax; -} - -static int -XS_SDBM_File_nextkey(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 2) { - croak("Usage: SDBM_File::nextkey(db, key)"); - } - { - SDBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (SDBM_File) tmp; - } - else - croak("db is not of type SDBM_File"); - - key.dptr = SvPV(ST(2), na); - key.dsize = (int)na;; - - RETVAL = nextkey(db, key); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return ax; -} - -static int -XS_SDBM_File_sdbm_error(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: SDBM_File::error(db)"); - } - { - SDBM_File db; - int RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (SDBM_File) tmp; - } - else - croak("db is not of type SDBM_File"); - - RETVAL = sdbm_error(db); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -static int -XS_SDBM_File_sdbm_clearerr(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items != 1) { - croak("Usage: SDBM_File::clearerr(db)"); - } - { - SDBM_File db; - int RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(ST(1))); - db = (SDBM_File) tmp; - } - else - croak("db is not of type SDBM_File"); - - RETVAL = sdbm_clearerr(db); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (I32)RETVAL); - } - return ax; -} - -int boot_SDBM_File(ix,ax,items) -int ix; -int ax; -int items; -{ - char* file = __FILE__; - - newXSUB("SDBM_File::new", 0, XS_SDBM_File_sdbm_new, file); - newXSUB("SDBM_File::DESTROY", 0, XS_SDBM_File_sdbm_DESTROY, file); - newXSUB("SDBM_File::fetch", 0, XS_SDBM_File_sdbm_fetch, file); - newXSUB("SDBM_File::store", 0, XS_SDBM_File_sdbm_store, file); - newXSUB("SDBM_File::delete", 0, XS_SDBM_File_sdbm_delete, file); - newXSUB("SDBM_File::firstkey", 0, XS_SDBM_File_sdbm_firstkey, file); - newXSUB("SDBM_File::nextkey", 0, XS_SDBM_File_nextkey, file); - newXSUB("SDBM_File::error", 0, XS_SDBM_File_sdbm_error, file); - newXSUB("SDBM_File::clearerr", 0, XS_SDBM_File_sdbm_clearerr, file); -} @@ -1,6 +1,6 @@ -Modules - POSIX (in progress) +Modules needed X/Motif/Tk etc. + Curses Tie Modules VecArray Implement array using vec() @@ -8,34 +8,18 @@ Tie Modules VirtualArray Implement array using a file ShiftSplice Defines shift et al in terms of splice method -Bugs - Make yyparse recursion longjmp() proof. - Make "delete $array{$key} while ($key) = each %array" safe - <$handle> doesn't work intuitively if $handle is ARGV - Anything in the Bugs directory - -Regexp extensions - /m for multiline - /\Afoo/ (beginning of string, or where previous g match left off) - /foo\Z/ (end of string only) - negative regexp assertions? - /<>/x for grouping? - /f for fixed variable interpolation? - Rewrite regexp parser for better integrated optimization - Would be nice to have Profiler pack "(stuff)*" Contiguous bitfields in pack/unpack lexperl Bundled perl preprocessor - Make $[ compile-time instead of run-time Use posix calls internally where possible const variables gettimeofday bytecompiler format BOTTOM - willcall() + $obj->can("method") to probe method inheritance -iprefix. -i rename file only when successfully changed All ARGV input should act like <> @@ -44,30 +28,33 @@ Would be nice to have report HANDLE [formats]. tie(FILEHANDLE, ...) __DATA__ + support in perlmain to rerun debugger + make 'r' print return value like gdb 'fini' -Possible averments +Possible pragmas debugger - optimize + optimize (use less memory, CPU) Optimizations - Optimize switch statements - Optimize foreach on array - Optimize foreach (1..1000000) + constant function cache + switch structures + foreach(@array) + foreach (1..1000000) + foreach(reverse...) Set KEEP on constant split Cache eval tree (unless lexical outer scope used (mark in &compiling?)) rcatmaybe Shrink opcode tables via multiple implementations selected in peep - Cache hash value? + Cache hash value? (Not a win, according to Guido) Optimize away @_ where possible sfio? "one pass" global destruction Optimize sort by { $a <=> $b } + Rewrite regexp parser for better integrated optimization -Need to think more about +Vague possibilities ref function in list context Populate %SIG at startup if appropriate - -Vague possibilities sub mysplice(@, $, $, ...) data prettyprint function? (or is it, as I suspect, a lib routine?) Nested destructors @@ -82,3 +69,7 @@ Vague possibilities structured types paren counting in tokener to queue remote expectations autocroak? + Modifiable $1 et al + substr EXPR,OFFSET,LENGTH,STRING + locally capture warnings into an array + diff --git a/U/Extensions.U b/U/Extensions.U deleted file mode 100644 index ec14205ac1..0000000000 --- a/U/Extensions.U +++ /dev/null @@ -1,71 +0,0 @@ -?RCS: $Id: Extensions.U,v$ -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: Extensions.U,v $ -?RCS: -?MAKE:extensions : find Myread i_dbm i_ndbm i_gdbm i_sdbm -?MAKE: -pick add $@ %< -?S:extensions: -?S: This variable holds a list of extension files we want to -?S: include in perl. -?S:. -?T:xxx -?INIT:: List of extensions we want: -?INIT:extensions='' -?X: -case "$extensions" in -' '|'') echo "Looking for extensions..." - case "$find" in - *find*) - cd .. - extensions=`$find ext -type f -name \*.xs -print` - set X $extensions - shift - extensions="$*" - cd UU - ;; - *) extensions='ext/dbm/NDBM_File.xs ext/dbm/ODBM_File.xs ext/dbm/GDBM_File.xs ext/dbm/SDBM_File.xs ext/posix/POSIX.xs' - ;; - esac - ;; -none) extensions='' ;; -*) ;; -esac -: Now see which are supported on this system. -dflt="" -for xxx in $extensions ; do - case "$xxx" in - *ODBM*) case "$i_dbm" in - define) dflt="$dflt $xxx" ;; - *) ;; - esac - ;; - *NDBM*) case "$i_ndbm" in - define) dflt="$dflt $xxx" ;; - *) ;; - esac - ;; - *GDBM*) case "$i_gdbm" in - define) dflt="$dflt $xxx" ;; - *) ;; - esac - ;; - *SDBM*) case "$i_sdbm" in - define) dflt="$dflt $xxx" ;; - *) ;; - esac - ;; - *) dflt="$dflt $xxx" - ;; - esac -done - -rp="What extensions do you wish to include?" -. ./myread -extensions="$ans" - diff --git a/U/Guess.U b/U/Guess.U deleted file mode 100644 index c7566db87b..0000000000 --- a/U/Guess.U +++ /dev/null @@ -1,153 +0,0 @@ -?RCS: $Id: Guess.U,v 3.0.1.3 1993/12/15 08:14:35 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: Guess.U,v $ -?RCS: Revision 3.0.1.3 1993/12/15 08:14:35 ram -?RCS: patch15: variable d_bsd was not always set properly -?RCS: -?RCS: Revision 3.0.1.2 1993/08/30 08:57:14 ram -?RCS: patch8: fixed comment which wrongly attributed the usrinc symbol -?RCS: patch8: no more ugly messages when no /usr/include/ctype.h -?RCS: -?RCS: Revision 3.0.1.1 1993/08/27 14:37:37 ram -?RCS: patch7: added support for OSF/1 machines -?RCS: -?RCS: Revision 3.0 1993/08/18 12:04:57 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?X: -?X: This unit hazards some guesses as to what the general nature of the system -?X: is. The information it collects here is used primarily to establish default -?X: answers to other questions. -?X: -?MAKE:Guess d_eunice d_xenix: cat test echo n c contains rm Loc eunicefix -?MAKE: -pick add $@ %< -?S:d_eunice: -?S: This variable conditionally defines the symbols EUNICE and VAX, which -?S: alerts the C program that it must deal with ideosyncracies of VMS. -?S:. -?S:d_xenix: -?S: This variable conditionally defines the symbol XENIX, which alerts -?S: the C program that it runs under Xenix. -?S:. -?X:We don't use BSD in the source. It's too vague, and often defined -?X:in header files anyway (e.g. NetBSD). -?X:?S:d_bsd: -?X:?S: This symbol conditionally defines the symbol BSD when running on a -?X:?S: BSD system. -?X:?S:. -?C:EUNICE: -?C: This symbol, if defined, indicates that the program is being compiled -?C: under the EUNICE package under VMS. The program will need to handle -?C: things like files that don't go away the first time you unlink them, -?C: due to version numbering. It will also need to compensate for lack -?C: of a respectable link() command. -?C:. -?C:VMS: -?C: This symbol, if defined, indicates that the program is running under -?C: VMS. It is currently only set in conjunction with the EUNICE symbol. -?C:. -?C:XENIX: -?C: This symbol, if defined, indicates thet the program is running under -?C: Xenix (at least 3.0 ?). -?C:. -?X:We don't use BSD in the source. It's too vague. -?X:?C:BSD: -?X:?C: This symbol, if defined, indicates that the program is running under -?X:?C: a BSD system. -?X:?C:. -?H:#$d_eunice EUNICE /**/ -?H:#$d_eunice VMS /**/ -?H:#$d_xenix XENIX /**/ -?X:?H:#$d_bsd BSD /**/ -?H:. -?T:xxx -: make some quick guesses about what we are up against -echo " " -$echo $n "Hmm... $c" -echo exit 1 >bsd -echo exit 1 >usg -echo exit 1 >v7 -echo exit 1 >osf1 -echo exit 1 >eunice -echo exit 1 >xenix -echo exit 1 >venix -?X: -?X: Do not use 'usrinc', or we get a circular dependency. because -?X: usrinc is defined in usrinc.U, which relies on us... -?X: -$cat /usr/include/signal.h /usr/include/sys/signal.h >foo 2>/dev/null -if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1 -then - echo "Looks kind of like an OSF/1 system, but we'll see..." - echo exit 0 >osf1 -elif test `echo abc | tr a-z A-Z` = Abc ; then - xxx=`./loc addbib blurfl $pth` - if $test -f $xxx; then - echo "Looks kind of like a USG system with BSD features, but we'll see..." - echo exit 0 >bsd - echo exit 0 >usg - else - if $contains SIGTSTP foo >/dev/null 2>&1 ; then - echo "Looks kind of like an extended USG system, but we'll see..." - else - echo "Looks kind of like a USG system, but we'll see..." - fi - echo exit 0 >usg - fi -elif $contains SIGTSTP foo >/dev/null 2>&1 ; then - echo "Looks kind of like a BSD system, but we'll see..." - echo exit 0 >bsd -else - echo "Looks kind of like a Version 7 system, but we'll see..." - echo exit 0 >v7 -fi -case "$eunicefix" in -*unixtovms*) - $cat <<'EOI' -There is, however, a strange, musty smell in the air that reminds me of -something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit. -EOI - echo exit 0 >eunice - d_eunice="$define" -: it so happens the Eunice I know will not run shell scripts in Unix format - ;; -*) - echo " " - echo "Congratulations. You aren't running Eunice." - d_eunice="$undef" - ;; -esac -if test -f /xenix; then - echo "Actually, this looks more like a XENIX system..." - echo exit 0 >xenix - d_xenix="$define" -else - echo " " - echo "It's not Xenix..." - d_xenix="$undef" -fi -chmod +x xenix -$eunicefix xenix -if test -f /venix; then - echo "Actually, this looks more like a VENIX system..." - echo exit 0 >venix -else - echo " " - if xenix; then - : null - else - echo "Nor is it Venix..." - fi -fi -chmod +x bsd usg v7 osf1 eunice xenix venix -$eunicefix bsd usg v7 osf1 eunice xenix venix -$rm -f foo - diff --git a/U/Loc.U b/U/Loc.U deleted file mode 100644 index fcb7a64403..0000000000 --- a/U/Loc.U +++ /dev/null @@ -1,252 +0,0 @@ -?RCS: $Id: Loc.U,v 3.0.1.3 1994/01/24 14:01:44 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: $Log: Loc.U,v $ -?RCS: Revision 3.0.1.3 1994/01/24 14:01:44 ram -?RCS: patch16: added metalint hint on changed PATH variable -?RCS: -?RCS: Revision 3.0.1.2 1993/12/15 08:16:52 ram -?RCS: patch15: now set _test variable when test is built-in -?RCS: patch15: fixed rare cases where echo is not needed -?RCS: -?RCS: Revision 3.0.1.1 1993/09/13 15:47:13 ram -?RCS: patch10: test program not always in /bin/test (WAD) -?RCS: -?RCS: Revision 3.0 1993/08/18 12:05:05 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?X: -?X: This unit produces a shell script "loc" which can be used to find out -?X: where in a list of directories something is. It then uses loc to -?X: determine the location of commonly used programs. It leaves loc sitting -?X: around for other Configure units to use, but arranges for its demise -?X: at the end of Configure. -?X: -?X: To add a new program to find, add it both to the ?MAKE: line and to either -?X: the loclist or trylist variable. -?X: -?X: I put startsh at the end of the dependency list, in order to avoid the -?X: loading of the spitshell unit before the instructions. -?X: -?MAKE:Loc Mcc awk bash bison byacc cat chgrp chmod chown compress cp cpio \ - cpp csh date echo egrep emacs expr find flex gcc grep inews ksh \ - less line lint ln lp lpr ls mail mailx make mkdir more mv nroff \ - perl pg pmake pr rm rmail sed sendmail sh shar sleep smail sort \ - submit tail tar tbl test touch tr troff uname uniq uuname vi \ - zcat: eunicefix n c Instruct Myread startsh -?MAKE: -pick weed $@ %< -?LINT:describe Loc Mcc awk bash bison byacc cat chgrp chmod chown compress \ - cp cpio cpp csh date echo egrep emacs expr find flex gcc grep \ - inews ksh less line lint ln lp lpr ls mail mailx make mkdir more \ - mv nroff perl pg pmake pr rm rmail sed sendmail sh shar sleep \ - smail sort submit tail tar tbl test touch tr troff uname uniq \ - uuname vi zcat -?V::pth loclist trylist -?T:thing xxx dir file say _test -?LINT:change PATH -: find out where common programs are -echo " " -echo "Locating common programs..." >&4 -cat <<EOSC >loc -$startsh -case \$# in -0) exit 1;; -esac -thing=\$1 -shift -dflt=\$1 -shift -for dir in \$*; do - case "\$thing" in - .) - if test -d \$dir/\$thing; then - echo \$dir - exit 0 - fi - ;; - *) - if test -f \$dir/\$thing; then - echo \$dir/\$thing - exit 0 - elif test -f \$dir/\$thing.exe; then - : on Eunice apparently - echo \$dir/\$thing - exit 0 - fi - ;; - esac -done -echo \$dflt -exit 1 -EOSC -chmod +x loc -$eunicefix loc -loclist=" -?awk:awk -?cat:cat -?chgrp:chgrp -?chmod:chmod -?chown:chown -?cp:cp -?echo:echo -?expr:expr -?grep:grep -?ln:ln -?ls:ls -?make:make -?mkdir:mkdir -?mv:mv -?rm:rm -?sed:sed -?sleep:sleep -?sort:sort -?tail:tail -?touch:touch -?tr:tr -?uniq:uniq -" -trylist=" -?Mcc:Mcc -?bash:bash -?bison:bison -?byacc:byacc -?compress:compress -?cpio:cpio -?cpp:cpp -?csh:csh -?date:date -?egrep:egrep -?emacs:emacs -?find:find -?flex:flex -?gcc:gcc -?inews:inews -?ksh:ksh -?less:less -?line:line -?lint:lint -?lp:lp -?lpr:lpr -?mail:mail -?mailx:mailx -?more:more -?nroff:nroff -?perl:perl -?pg:pg -?pmake:pmake -?pr:pr -?rmail:rmail -?sendmail:sendmail -?sh:sh -?shar:shar -?smail:smail -?submit:submit -?tar:tar -?tbl:tbl -?test:test -?troff:troff -?uname:uname -?uuname:uuname -?vi:vi -?zcat:zcat -" -?LINT:set Loc Mcc awk bash bison byacc cat chgrp chmod chown compress cp \ - cpio cpp csh date echo egrep emacs expr find flex gcc grep inews \ - ksh less line lint ln lp lpr ls mail mailx make mkdir more mv \ - nroff perl pg pmake pr rm rmail sed sendmail sh shar sleep \ - smail sort submit tail tar tbl test touch tr troff uname uniq \ - uuname vi zcat -pth=`echo $PATH | sed -e 's/:/ /g'` -pth="$pth /lib /usr/lib" -for file in $loclist; do - xxx=`./loc $file $file $pth` - eval $file=$xxx - eval _$file=$xxx - case "$xxx" in - /*) - echo $file is in $xxx. - ;; - *) - echo "I don't know where $file is. I hope it's in everyone's PATH." - ;; - esac -done -echo " " -echo "Don't worry if any of the following aren't found..." -say=offhand -for file in $trylist; do - xxx=`./loc $file $file $pth` - eval $file=$xxx - eval _$file=$xxx - case "$xxx" in - /*) - echo $file is in $xxx. - ;; - *) - echo "I don't see $file out there, $say." - say=either - ;; - esac -done -case "$egrep" in -egrep) - echo "Substituting grep for egrep." - egrep=$grep - ;; -esac -case "$test" in -test) - echo "Hopefully test is built into your sh." - ;; -*) - if sh -c "PATH= test true" >/dev/null 2>&1; then - echo "Using the test built into your sh." -?X: -?X: We need to set both test and _test, since Oldconfig.U will use the _test -?X: value to systematically restore computed paths, which may be wrong if -?X: we choose to load an old config.sh generated on another platform. -?X: - test=test - _test=test - fi - ;; -esac -?LINT:change n c -case "$echo" in -echo) - echo "Hopefully echo is built into your sh." - ;; -?X: For those rare cases where we don't need $echo... -'') ;; -*) - echo " " -echo "Checking compatibility between $echo and builtin echo (if any)..." >&4 - $echo $n "hi there$c" >foo1 - echo $n "hi there$c" >foo2 - if cmp foo1 foo2 >/dev/null 2>&1; then - echo "They are compatible. In fact, they may be identical." - else - case "$n" in - '-n') n='' c='\c';; - *) n='-n' c='';; - esac - cat <<FOO -They are not compatible! You are probably running ksh on a non-USG system. -I'll have to use $echo instead of the builtin, since Bourne shell doesn't -have echo built in and we may have to run some Bourne shell scripts. That -means I'll have to use '$n$c' to suppress newlines now. Life is ridiculous. - -FOO - $echo $n "The star should be here-->$c" - $echo "*" - fi - $rm -f foo1 foo2 - ;; -esac - diff --git a/U/Oldconfig.U b/U/Oldconfig.U deleted file mode 100644 index 2b6d3a0157..0000000000 --- a/U/Oldconfig.U +++ /dev/null @@ -1,369 +0,0 @@ -?RCS: $Id: Oldconfig.U,v 3.0.1.2 1994/01/24 14:05:02 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: Oldconfig.U,v $ -?RCS: Revision 3.0.1.2 1994/01/24 14:05:02 ram -?RCS: patch16: added post-processing on myuname for Xenix targets -?RCS: patch16: message proposing config.sh defaults made consistent -?RCS: -?RCS: Revision 3.0.1.1 1993/09/13 15:56:32 ram -?RCS: patch10: force use of config.sh when -d option is used (WAD) -?RCS: patch10: complain about non-existent hint files (WAD) -?RCS: patch10: added Options dependency for fastread variable -?RCS: -?RCS: Revision 3.0 1993/08/18 12:05:12 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?X: -?X: This unit tries to remember what we did last time we ran Configure, mostly -?X: for the sake of setting defaults. -?X: -?MAKE:Oldconfig hint myuname osname osvers: Instruct Myread uname \ - sed test cat rm n c contains Loc Options -?MAKE: -pick wipe $@ %< -?S:myuname: -?S: The output of 'uname -a' if available, otherwise the hostname. On Xenix, -?S: pseudo variables assignments in the output are stripped, thank you. The -?S: whole thing is then lower-cased. -?S:. -?S:hint: -?S: Gives the type of hints used for previous answers. May be one of -?S: "default", "recommended" or "previous". -?S:. -?S:osname: -?S: This variable contains the operating system name (e.g. sunos, -?S: solaris, hpux, etc.). It can be useful later on for setting -?S: defaults. It is set to '' if we can't figure it out. -?S:. -?S:osvers: -?S: This variable contains the operating system version (e.g. -?S: 4.1.3, 5.2, etc.). It is primarily used for helping select -?S: an appropriate hints file, but might be useful elsewhere for -?S: setting defaults. It is set to '' if we can't figure it out. -?S:. -?T:tmp file oldmyuname hintfile tans _ -?LINT:change n c -: Try to determine whether config.sh was made on this system -case "$config_sh" in -'') -?X: indentation wrong on purpose--RAM -?X: Leave a white space between first two '(' for ksh. The sub-shell is needed -?X: on some machines to avoid the error message when uname is not found; e.g. -?X: old SUN-OS 3.2 would not execute hostname in (uname -a || hostname). Sigh! -myuname=`( ($uname -a) 2>/dev/null || hostname) 2>&1` -?X: Special mention for Xenix, whose 'uname -a' gives us output like this: -?X: sysname=XENIX -?X: nodename=whatever -?X: release=2.3.2 .. etc... -?X: Therefore, we strip all this variable assignment junk and remove all the -?X: new lines to keep the myuname variable sane... --RAM -myuname=`echo $myuname | $sed -e 's/^[^=]*=//' | \ - tr '[A-Z]' '[a-z]' | tr '\012' ' '` -dflt=n -if test "$fastread" = yes; then - dflt=y -elif test -f ../config.sh; then -?X: The value from config.sh will superseed the one we've just computed -?X: ... but not if we choose to ignore config.sh, so eval oldmyuname here. - oldmyuname='' - if $contains myuname= ../config.sh >/dev/null 2>&1; then - eval "old`grep myuname= ../config.sh`" - fi - if test "X$myuname" = "X$oldmyuname"; then - dflt=y - fi -fi - -@if {test -d ../hints} -: Get old answers from old config file if Configure was run on the -: same system, otherwise use the hints. -hint=default -cd .. -if test -f config.sh; then - echo " " - rp="I see a config.sh file. Shall I use it to set the defaults?" - . UU/myread - case "$ans" in - n*|N*) echo "OK, I'll ignore it."; mv config.sh config.sh.old;; - *) echo "Fetching default answers from your old config.sh file..." >&4 - tmp="$n" - tans="$c" - . ./config.sh - cp config.sh UU - n="$tmp" - c="$tans" - hint=previous - ;; - esac -fi -if test ! -f config.sh; then - $cat <<EOM - -First time through, eh? I have some defaults handy for the following systems: - -EOM - cd hints; ls -C *.sh | $sed 's/\.sh/ /g' >&4 - dflt='' - : Half the following guesses are probably wrong... If you have better - : tests or hints, please send them to <MAINTLOC> - : The metaconfig authors would also appreciate a copy... - $test -f /irix && osname=sgi - $test -f /xenix && osname=sco_xenix - $test -f /dynix && osname=dynix - $test -f /dnix && osname=dnix - $test -f /bin/mips && /bin/mips && osname=mips - $test -d /NextApps && test -f /usr/adm/software_version && osname=next - $test -d /usr/include/minix && osname=minix -?X: If we have uname, we already computed a suitable uname -a output, correctly -?X: formatted for Xenix, and it lies in $myuname. - if $test -f $uname; then - set X $myuname - shift - - $test -f $5.sh && dflt="$dflt $5" - - case "$5" in - fps*) osname=fps ;; - mips*) - case "$4" in - umips) osname=umips ;; - *) osname=mips ;; - esac;; - [23]100) osname=mips ;; - next*) osname=next ;; - news*) osname=news ;; - i386*) if $test -f /etc/kconfig; then - osname=isc - if $contains _SYSV3 /usr/include/stdio.h > /dev/null 2>&1 ; then - osvers=3.2.3 - elif $contains _POSIX_SOURCE /usr/include/stdio.h > /dev/null 2>&1 ; then - osvers=3.2.2 - fi - fi - ;; - esac - - case "$1" in - aix) osname=aix_rs ;; - sunos) osname=sunos - case "$3" in - [34]*) osvers=$3 ;; - 5*) osname=solaris - osvers=`echo $3 | $sed 's/^5/2/g'` ;; - esac - ;; - solaris) osname=solaris - case "$3" in - 5*) osvers=`echo $3 | $sed 's/^5/2/g'` ;; - esac - ;; - dnix) osname=dnix ;; - dgux) osname=dgux ;; - genix) osname=genix ;; - hp*ux) osname=hpux ;; - next) osname=next ;; - irix) osname=sgi ;; - ultrix) osname=ultrix - case "$3" in - 1*) osvers=1 ;; - 2*) osvers=2 ;; - 3*) osvers=3 ;; - 4*) osvers=4 ;; - esac - ;; - osf1) case "$5" in - alpha) osname=dec_osf - case "$3" in - [vt]1\.*) osvers=1 ;; - [vt]2\.*) osvers=2 ;; - [vt]3\.*) osvers=3 ;; - esac - ;; - hp*) osname=hp_osf1 ;; # TR - mips) osname=mips_osf1 ;; # TR - # TR = Technology Releases: (un^N)supported - esac - ;; - uts) osname=uts ;; - $2) case "$osname" in - *isc*) ;; - *) if test -f /etc/systemid; then - osname=sco - : Does anyone know if these next gyrations are needed - set `echo $3 | $sed 's/\./ /g'` $4 - if $test -f sco_$1_$2_$3.sh; then - osvers=$1.$2.$3 - elif $test -f sco_$1_$2.sh; then - osvers=$1.$2 - elif $test -f sco_$1.sh; then - osvers=$1 - fi - fi - ;; - esac - ;; - esac - else -?X: Try to identify sony's NEWS-OS (BSD unix) - if test -f /vmunix -a -f news_os.sh; then - (what /vmunix | tr '[A-Z]' '[a-z]') > ../UU/kernel.what 2>&1 - if $contains news-os ../UU/kernel.what >/dev/null 2>&1; then - osname=news_os - fi - $rm -f ../UU/kernel.what - fi - fi - - : Now look for a hint file osname_osvers - file=`echo "${osname}_${osvers}" | sed -e 's@\.@_@g' -e 's@_$@@'` - case "$file" in - '') dflt=none ;; - *) case "$osvers" in - '') dflt=$file - ;; - *) if $test -f $file.sh ; then - dflt=$file - elif $test -f "${osname}.sh" ; then - dflt="${osname}" - else - dflt=none - fi - ;; - esac - ;; - esac - - $cat <<EOM - -You may give one or more space-separated answers, or "none" if appropriate. -If your OS version has no hints, DO NOT give a wrong version -- say "none". - -EOM - rp="Which of these apply, if any?" - . ../UU/myread - tans=$ans - for file in $tans; do - if $test -f $file.sh; then - . ./$file.sh - $cat $file.sh >> ../UU/config.sh - elif $test X$tans = X -o X$tans = Xnone ; then - : nothing - else - : Give one chance to correct a possible typo. - echo "$file.sh does not exist" - dflt=$file - rp="hint to use instead?" - . ../UU/myread - for file in $ans; do - if $test -f "$file.sh"; then - . ./$file.sh - $cat $file.sh >> ../UU/config.sh - elif $test X$ans = X -o X$ans = Xnone ; then - : nothing - else - echo "$file.sh does not exist -- ignored." - fi - done - fi - done - - hint=recommended - : Remember our hint file for later. - if $test -f "$file.sh" ; then - hintfile="$file.sh" - else - hintfile=none - fi - - cd .. -fi -cd UU -@else -: Get old answers, if there is a config file out there -hint=default -if test -f ../config.sh; then - echo " " - rp="I see a config.sh file. Shall I use it to set the defaults?" - . ./myread - case "$ans" in - n*|N*) echo "OK, I'll ignore it.";; - *) echo "Fetching default answers from your old config.sh file..." >&4 - tmp="$n" - tans="$c" - . ../config.sh - cp ../config.sh . - n="$tmp" - c="$tans" - hint=previous - ;; - esac -fi -@end -?X: remember, indentation is wrong--RAM -;; -*) - echo " " - echo "Fetching default answers from $config_sh..." >&4 - tmp="$n" - tans="$c" - cd .. -?X: preserve symbolic links, if any - cp $config_sh config.sh 2>/dev/null - . ./config.sh - cd UU - cp ../config.sh . - n="$tmp" - c="$tans" - hint=previous - ;; -esac - -: Restore computed paths -for file in $loclist $trylist; do - eval $file="\$_$file" -done - -cat << EOM -Configure uses the operating system name and version to set some defaults. -Say "none" to leave it blank. -EOM - -case "$osname" in - ''|' ') - case "$hintfile" in - none) dflt=none ;; - *) dflt=`echo $hintfile | sed -e 's/\.sh$//' -e 's/_.*$//'` ;; - esac - ;; - *) dflt="$osname" ;; -esac -rp="Operating system name?" -. ./myread -case "$ans" in - none) osname='' ;; - *) osname="$ans" ;; -esac - -case "$osvers" in - ''|' ') - case "$hintfile" in - none) dflt=none ;; - *) dflt=`echo $hintfile | sed -e 's/\.sh$//' -e 's/^[^_]*//'` - dflt=`echo $dflt | sed -e 's/^_//' -e 's/_/./g'` ;; - esac - ;; - *) dflt="$osvers" ;; -esac -rp="Operating system version?" -. ./myread -case "$ans" in - none) osvers='' ;; - *) osvers="$ans" ;; -esac diff --git a/U/README.U b/U/README.U deleted file mode 100644 index 4d4f9645a0..0000000000 --- a/U/README.U +++ /dev/null @@ -1,15 +0,0 @@ -?X: These units are based on the ones supplied with dist-3.0 -?X: patchlevel 22. They have been changed or enhanced to work with -?X: perl5alpha. I would appreciate hearing about any changes, -?X: corrections, or enhancements. -?X: Andy Dougherty doughera@lafcol.lafayette.edu -?X: Dept. of Physics -?X: Lafayette College -?X: Easton, PA 18042-1782 -?X: Sat Apr 2 15:45:17 EST 1994 -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0, or in the perl distribution. diff --git a/U/alignbytes.U b/U/alignbytes.U deleted file mode 100644 index 38526465a0..0000000000 --- a/U/alignbytes.U +++ /dev/null @@ -1,57 +0,0 @@ -?RCS: $Id: alignbytes.U,v 3.0 1993/08/18 12:05:23 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: alignbytes.U,v $ -?RCS: Revision 3.0 1993/08/18 12:05:23 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:memalignbytes: Myread cat cc ccflags rm -?MAKE: -pick add $@ %< -?S:memalignbytes: -?S: This variable holds the number of bytes required to align a -?S: double. Usual values are 2, 4 and 8. -?S:. -?X: This used to be called ALIGNBYTES, but that conflicts with -?X: <machines/param.h> in NetBSD. -?C:MEM_ALIGNBYTES (ALIGNBYTES): -?C: This symbol contains the number of bytes required to align a -?C: double. Usual values are 2, 4 and 8. -?C:. -?H:#define MEM_ALIGNBYTES $memalignbytes /**/ -?H:. -: check for alignment requirements -echo " " -case "$memalignbytes" in -'') echo "Checking alignment constraints..." >&4 - $cat >try.c <<'EOCP' -struct foobar { - char foo; - double bar; -} try; -main() -{ - printf("%d\n", (char *)&try.bar - (char *)&try.foo); -} -EOCP - if $cc $ccflags try.c -o try >/dev/null 2>&1; then - dflt=`./try` - else - dflt='8' - echo"(I can't seem to compile the test program...)" - fi - ;; -*) dflt="$memalignbytes" - ;; -esac -rp="Doubles must be aligned on a how-many-byte boundary?" -. ./myread -memalignbytes="$ans" -$rm -f try.c try - diff --git a/U/cc.U b/U/cc.U deleted file mode 100644 index 04950176c0..0000000000 --- a/U/cc.U +++ /dev/null @@ -1,111 +0,0 @@ -?RCS: $Id: cc.U,v 3.0 1993/08/18 12:05:30 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: cc.U,v $ -?RCS: Revision 3.0 1993/08/18 12:05:30 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:gccversion cc: cat contains sysman +large cpp rm test \ - Mcc Myread Guess Oldconfig Loc -?MAKE: -pick add $@ %< -?S:cc: -?S: This variable holds the name of a command to execute a C compiler which -?S: can resolve multiple global references that happen to have the same -?S: name. Usual values are "cc", "Mcc", "cc -M", and "gcc". -?S:. -?S:gccversion: -?S: If GNU cc (gcc) is used, this variable holds '1' or '2' to -?S: indicate whether the compiler is version 1 or 2. This is used in -?S: setting some of the default cflags. -?S:. -?D:cc='cc' -?INIT:gccversion='' -?LINT:change cpp -: see if we need a special compiler -echo " " -if usg; then - case "$cc" in - '') case "$Mcc" in - /*) dflt='Mcc';; - *) case "$large" in - -M*) dflt='cc';; - *) if $contains '\-M' $sysman/cc.1 >/dev/null 2>&1 ; then - if $contains '\-M' $sysman/cpp.1 >/dev/null 2>&1; then - dflt='cc' - else - dflt='cc -M' - fi - else - dflt='cc' - fi;; - esac;; - esac;; - *) dflt="$cc";; - esac - $cat <<'EOM' -On some systems the default C compiler will not resolve multiple global -references that happen to have the same name. On some such systems the "Mcc" -command may be used to force these to be resolved. On other systems a "cc -M" -command is required. (Note that the -M flag on other systems indicates a -memory model to use!) If you have the Gnu C compiler, you might wish to use -that instead. - -EOM - rp="What command will force resolution on this system?" - . ./myread - cc="$ans" -else - case "$cc" in - '') dflt=cc;; - *) dflt="$cc";; - esac - rp="Use which C compiler?" - . ./myread - cc="$ans" -fi -case "$cc" in -gcc*) echo "Checking out which version of gcc" -$cat >gccvers.c <<EOM -#include <stdio.h> -int main() -{ -char *v; -v = "unknown"; -#ifdef __GNUC__ -# ifdef __VERSION__ - v = __VERSION__; -# endif -#endif -switch((int) v[0]) - { - case '1': printf("1\n"); break; - case '2': printf("2\n"); break; - case '3': printf("3\n"); break; - default: break; - } -#ifdef __GNUC__ -return 0; -#else -return 1; -#endif -} -EOM - if $cc -o gccvers gccvers.c >/dev/null 2>&1; then - gccversion=`./gccvers` - echo "You appear to have version $gccversion." - else - echo "Doesn't appear to be GNU cc." - fi - $rm -f gccvers* - if $test "$gccversion" = '1'; then - cpp=`./loc gcc-cpp $cpp $pth` - fi - ;; -esac diff --git a/U/ccflags.U b/U/ccflags.U deleted file mode 100644 index 1b9bf39829..0000000000 --- a/U/ccflags.U +++ /dev/null @@ -1,236 +0,0 @@ -?RCS: $Id: ccflags.U,v 3.0.1.3 1993/09/13 15:58:29 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: ccflags.U,v $ -?RCS: Revision 3.0.1.3 1993/09/13 15:58:29 ram -?RCS: patch10: explicitely mention -DDEBUG just in case they need it (WAD) -?RCS: patch10: removed all the "tans" variable usage (WAD) -?RCS: -?RCS: Revision 3.0.1.2 1993/08/27 14:39:38 ram -?RCS: patch7: added support for OSF/1 machines -?RCS: -?RCS: Revision 3.0.1.1 1993/08/25 14:00:24 ram -?RCS: patch6: added defaults for cppflags, ccflags and ldflags -?RCS: -?RCS: Revision 3.0 1993/08/18 12:05:31 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:ccflags ldflags lkflags cppflags optimize: test cat Myread Guess \ - Oldconfig cc gccversion mips_type +usrinc package contains -?MAKE: -pick add $@ %< -?S:ccflags: -?S: This variable contains any additional C compiler flags desired by -?S: the user. It is up to the Makefile to use this. -?S:. -?S:cppflags: -?S: This variable holds the flags that will be passed to the C pre- -?S: processor. It is up to the Makefile to use it. -?S:. -?S:optimize: -?S: This variable contains any optimizer/debugger flag that should be used. -?S: It is up to the Makefile to use it. -?S:. -?S:ldflags: -?S: This variable contains any additional C loader flags desired by -?S: the user. It is up to the Makefile to use this. -?S:. -?S:lkflags: -?S: This variable contains any additional C partial linker flags desired by -?S: the user. It is up to the Makefile to use this. -?S:. -?T:inctest thisincl xxx flag inclwanted -?D:cppflags='' -?D:ccflags='' -?D:ldflags='' -?INIT:: no include file wanted by default -?INIT:inclwanted='' -?INIT: -: determine optimize, if desired, or use for debug flag also -case "$optimize" in -' ') dflt="none";; -'') dflt="-g";; -*) dflt="$optimize";; -esac -$cat <<EOH - -Some C compilers have problems with their optimizers, by default, $package -compiles with the -O flag to use the optimizer. Alternately, you might want -to use the symbolic debugger, which uses the -g flag (on traditional Unix -systems). Either flag can be specified here. To use neither flag, specify -the word "none". - -EOH -rp="What optimizer/debugger flag should be used?" -. ./myread -optimize="$ans" -case "$optimize" in -'none') optimize=" ";; -esac - -dflt='' -case "$ccflags" in -'') case "$cc" in - *gcc*) if $test "$gccversion" = "1"; then - dflt='-fpcc-struct-return' - fi ;; - esac - case "$optimize" in - *-g*) dflt="$dflt -DDEBUGGING";; - esac -?X: check for POSIXized ISC - case "$cc" in - *gcc*) if test -d /etc/conf/kconfig.d && - $contains _POSIX_VERSION $usrinc/sys/unistd.h >/dev/null 2>&1 - then - dflt="$dflt -posix" - fi - ;; - esac - ;; -esac - -?X: In USG mode, a MIPS system may need some BSD includes -case "$mips_type" in -*BSD*) ;; -'') ;; -*) inclwanted="$inclwanted $usrinc/bsd";; -esac -for thisincl in $inclwanted; do - if $test -d $thisincl; then - if $test x$thisincl != x$usrinc; then - case "$dflt" in - *$thisincl*);; - *) dflt="$dflt -I$thisincl";; - esac - fi - fi -done - -?X: Include test function (header, symbol) -inctest='if $contains $2 $usrinc/$1 >/dev/null 2>&1; then - xxx=true; -elif $contains $2 $usrinc/sys/$1 >/dev/null 2>&1; then - xxx=true; -else - xxx=false; -fi; -if $xxx; then - case "$dflt" in - *$2*);; - *) dflt="$dflt -D$2";; - esac; -fi' - -?X: -?X: SCO unix uses NO_PROTOTYPE instead of _NO_PROTO -?X: OSF/1 uses __LANGUAGE_C__ instead of LANGUAGE_C -?X: -if ./osf1; then - set signal.h __LANGUAGE_C__; eval $inctest -else - set signal.h LANGUAGE_C; eval $inctest -fi -set signal.h NO_PROTOTYPE; eval $inctest -set signal.h _NO_PROTO; eval $inctest - -case "$dflt" in -'') dflt=none;; -esac -case "$ccflags" in -'') ;; -*) dflt="$ccflags";; -esac -$cat <<EOH - -Your C compiler may want other flags. For this question you should include --I/whatever and -DWHATEVER flags and any other flags used by the C compiler, -but you should NOT include libraries or ld flags like -lwhatever. If you -want $package to honor its debug switch, you should include -DDEBUGGING here. -To use no flags, specify the word "none". - -Your C compiler might also need additional flags, such as -DJMPCLOBBER, --DHIDEMYMALLOC or -DCRIPPLED_CC. -EOH -?X: strip leading space -set X $dflt -shift -dflt=${1+"$@"} -rp="Any additional cc flags?" -. ./myread -case "$ans" in -none) ccflags='';; -*) ccflags="$ans";; -esac - -: the following weeds options from ccflags that are of no interest to cpp -cppflags="$ccflags" -case "$cc" in -*gcc*) case "$gccversion" in - 1) cppflags="$cppflags -D__GNUC__" ;; - esac - ;; -esac -case "$mips_type" in -'');; -*BSD*) cppflags="$cppflags -DSYSTYPE_BSD43";; -esac -case "$cppflags" in -'');; -*) set X $cppflags - cppflags='' - for flag - do - case $flag in - -D*|-I*|-traditional|-ansi|-nostdinc|-posix|-Xp) cppflags="$cppflags $flag";; - esac - done - case "$cppflags" in - *-*) echo "(C preprocessor flags: $cppflags)";; - esac - ;; -esac - -: flags used in final linking phase -case "$ldflags" in -'') if venix; then - dflt='-i -z' - else - dflt='none' - fi - ;; -*) dflt="$ldflags";; -esac -echo " " -rp="Any additional ld flags (NOT including libraries)?" -. ./myread -case "$ans" in -none) ldflags='';; -*) ldflags="$ans";; -esac -rmlist="$rmlist pdp11" - -@if lkflags -: partial linking may need other flags -case "$lkflags" in -'') case "$ldflags" in - '') dflt='none';; - *) dflt="$ldflags";; - esac;; -*) dflt="$lkflags";; -esac -echo " " -rp="Partial linking flags to be used (NOT including -r)?" -. ./myread -case "$ans" in -none) lkflags='';; -*) lkflags="$ans";; -esac - -@end diff --git a/U/d_casti32.U b/U/d_casti32.U deleted file mode 100644 index f33b5f811f..0000000000 --- a/U/d_casti32.U +++ /dev/null @@ -1,77 +0,0 @@ -?RCS: $Id: d_casti32.U,v 3.0 1993/08/18 12:05:47 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_casti32.U,v $ -?RCS: Revision 3.0 1993/08/18 12:05:47 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?X: -?X: Can the compiler cast large floats to 32-bit integers? -?X: -?MAKE:d_casti32: cat cc ccflags rm intsize Setvar test -?MAKE: -pick add $@ %< -?S:d_casti32: -?S: This variable conditionally defines CASTI32, which indicates -?S: wether the C compiler can cast large floats to 32-bit ints. -?S:. -?T:xxx yyy -?C:CASTI32: -?C: This symbol is defined if the C compiler can cast negative -?C: or large floating point numbers to 32-bit ints. -?C:. -?H:#$d_casti32 CASTI32 /**/ -?H:. -?LINT:set d_casti32 -: check for ability to cast large floats to 32-bit ints. -echo " " -echo 'Checking whether your C compiler can cast large floats to int32.' >&4 -if $test "$intsize" -eq 4; then - xxx=int -else - xxx=long -fi - -$cat >try.c <<EOCP -#include <sys/types.h> -#include <signal.h> -blech() { exit(3); } -main() -{ - $xxx i32; - double f; - int result = 0; - signal(SIGFPE, blech); - - f = (double) 0x7fffffff; - f = 10 * f; - i32 = ( $xxx )f; - - if (i32 != ( $xxx )f) - result |= 1; - exit(result); -} -EOCP -if $cc -o try $ccflags try.c >/dev/null 2>&1; then - ./try - yyy=$? -else - yyy=1 -fi -case "$yyy" in -0) val="$define" - echo "Yup, it can." - ;; -*) val="$undef" - echo "Nope, it can't." - ;; -esac -set d_casti32 -eval $setvar -$rm -f try try.* diff --git a/U/d_htonl.U b/U/d_htonl.U deleted file mode 100644 index 0cb16479d4..0000000000 --- a/U/d_htonl.U +++ /dev/null @@ -1,76 +0,0 @@ -?RCS: $Id: d_htonl.U,v 3.0 1993/08/18 12:06:22 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_htonl.U,v $ -?RCS: Revision 3.0 1993/08/18 12:06:22 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:d_htonl: cc ccflags Inlibc i_niin i_sysin rm -?MAKE: -pick add $@ %< -?S:d_htonl: -?S: This variable conditionally defines HAS_HTONL if htonl() and its -?S: friends are available to do network order byte swapping. -?S:. -?C:HAS_HTONL (HTONL): -?C: This symbol, if defined, indicates that the htonl() routine (and -?C: friends htons() ntohl() ntohs()) are available to do network -?C: order byte swapping. -?C:. -?C:HAS_HTONS (HTONS): -?C: This symbol, if defined, indicates that the htons() routine (and -?C: friends htonl() ntohl() ntohs()) are available to do network -?C: order byte swapping. -?C:. -?C:HAS_NTOHL (NTOHL): -?C: This symbol, if defined, indicates that the ntohl() routine (and -?C: friends htonl() htons() ntohs()) are available to do network -?C: order byte swapping. -?C:. -?C:HAS_NTOHS (NTOHS): -?C: This symbol, if defined, indicates that the ntohs() routine (and -?C: friends htonl() htons() ntohl()) are available to do network -?C: order byte swapping. -?C:. -?H:#$d_htonl HAS_HTONL /**/ -?H:#$d_htonl HAS_HTONS /**/ -?H:#$d_htonl HAS_NTOHL /**/ -?H:#$d_htonl HAS_NTOHS /**/ -?H:. -?LINT:set d_htonl -: see if htonl --and friends-- exists -set htonl d_htonl -eval $inlibc -: Maybe they are macros. -case "$d_htonl" in -'define') ;; -*) cat > try.c <<EOM -#include <stdio.h> -#include <sys/types.h> -#$i_niin I_NETINET_IN -#$i_sysin I_SYS_IN -#ifdef I_NETINET_IN -# include <netinet/in.h> -#endif -#ifdef I_SYS_IN -# include <sys/in.h> -#endif -int main() -{ - int x; - printf("x = ", htonl(7)); -} -EOM - if $cc $ccflags -c try.c >/dev/null 2>&1; then - d_htonl="$define" - echo "But it seems to be defined as a macro." - fi - $rm -f try.* try - ;; -esac diff --git a/U/d_isascii.U b/U/d_isascii.U deleted file mode 100644 index 70fba1998a..0000000000 --- a/U/d_isascii.U +++ /dev/null @@ -1,50 +0,0 @@ -?RCS: $Id: d_isascii.U,v 3.0 1993/08/18 12:06:44 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_isascii.U,v $ -?RCS: Revision 3.0 1993/08/18 12:06:44 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:d_isascii: cc cat cppflags rm Setvar Findhdr -?MAKE: -pick add $@ %< -?S:d_isascii: -?S: This variable conditionally defines the HAS_ISASCII manifest constant, -?S: which indicates to the C program that isascii() is available. -?S:. -?C:HAS_ISASCII (ISASCII): -?C: This manifest constant lets the C program know that the -?C: isascii is available. -?C:. -?H:#$d_isascii HAS_ISASCII /**/ -?H:. -?LINT:set d_isascii -: Look for isascii -echo " " -$cat >isascii.c <<'EOCP' -#include <stdio.h> -#include <ctype.h> -main() { - int c = 'A'; - if (isascii(c)) - exit(0); - else - exit(1); -} -EOCP -if $cc $cppflags -o isascii isascii.c >/dev/null 2>&1 ; then - echo "isascii() found." - val="$define" -else - echo "isascii() NOT found." - val="$undef" -fi -set d_isascii -eval $setvar -$rm -f isascii* diff --git a/U/d_readdir.U b/U/d_readdir.U deleted file mode 100644 index e9364b4121..0000000000 --- a/U/d_readdir.U +++ /dev/null @@ -1,70 +0,0 @@ -?RCS: $Id: d_readdir.U,v 3.0 1993/08/18 12:06:52 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_readdir.U,v $ -?RCS: Revision 3.0 1993/08/18 12:06:52 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?X: Force checking for <dirent.h> inclusion -?X:INC: i_dirent -?MAKE:d_readdir d_seekdir d_telldir d_rewinddir: Inlibc -?MAKE: -pick add $@ %< -?S:d_readdir: -?S: This variable conditionally defines HAS_READDIR if readdir() is -?S: available to read directory entries. -?S:. -?C:HAS_READDIR (READDIR): -?C: This symbol, if defined, indicates that the readdir routine is -?C: available to read directory entries. You may have to include -?C: <dirent.h>. See I_DIRENT. -?C:. -?H:#$d_readdir HAS_READDIR /**/ -?H:. -?S:d_seekdir: -?S: This variable conditionally defines HAS_SEEKDIR if seekdir() is -?S: available. -?S:. -?C:HAS_SEEKDIR: -?C: This symbol, if defined, indicates that the seekdir routine is -?C: available. You may have to include <dirent.h>. See I_DIRENT. -?C:. -?H:#$d_seekdir HAS_SEEKDIR /**/ -?H:. -?S:d_telldir: -?S: This variable conditionally defines HAS_TELLDIR if telldir() is -?S: available. -?S:. -?C:HAS_TELLDIR: -?C: This symbol, if defined, indicates that the telldir routine is -?C: available. You may have to include <dirent.h>. See I_DIRENT. -?C:. -?H:#$d_telldir HAS_TELLDIR /**/ -?H:. -?S:d_rewinddir: -?S: This variable conditionally defines HAS_REWINDDIR if rewinddir() is -?S: available. -?S:. -?C:HAS_REWINDDIR: -?C: This symbol, if defined, indicates that the rewinddir routine is -?C: available. You may have to include <dirent.h>. See I_DIRENT. -?C:. -?H:#$d_rewinddir HAS_REWINDDIR /**/ -?H:. -?LINT:set d_readdir d_seekdir d_telldir d_rewinddir -: see if readdir and friends exist -set readdir d_readdir -eval $inlibc -set seekdir d_seekdir -eval $inlibc -set telldir d_telldir -eval $inlibc -set rewinddir d_rewinddir -eval $inlibc - diff --git a/U/d_safebcpy.U b/U/d_safebcpy.U deleted file mode 100644 index b7373a0791..0000000000 --- a/U/d_safebcpy.U +++ /dev/null @@ -1,81 +0,0 @@ -?RCS: $Id: d_safebcpy.U,v 3.0 1993/08/18 12:06:58 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_safebcpy.U,v $ -?RCS: -?RCS: Copy "abcde..." string to char abc[] so that gcc doesn't -?RCS: try to store the string in read-only memory. -?RCS: -?RCS: Revision 3.0 1993/08/18 12:06:58 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:d_safebcpy: cat d_bcopy +cc +ccflags +libs rm Oldconfig Setvar -?MAKE: -pick add $@ %< -?S:d_safebcpy: -?S: This variable conditionally defines the HAS_SAFE_BCOPY symbol if -?S: the bcopy() routine can do overlapping copies. -?S:. -?C:HAS_SAFE_BCOPY (SAFE_BCOPY): -?C: This symbol, if defined, indicates that the bcopy routine is available -?C: to copy potentially overlapping memory blocks. Otherwise you should -?C: probably use memmove() or memcpy(). If neither is defined, roll your -?C: own version. -?C:. -?H:#$d_safebcpy HAS_SAFE_BCOPY /**/ -?H:. -?LINT: set d_safebcpy -: can bcopy handle overlapping blocks? -?X: assume the worst -val="$undef" -case "$d_bcopy" in -"$define") - echo " " - echo "Checking to see if your bcopy() can do overlapping copies..." >&4 - $cat >foo.c <<'EOCP' -main() -{ -char buf[128], abc[128]; -char *b; -int len; -int off; -int align; -bcopy("abcdefghijklmnopqrstuvwxyz0123456789", abc, 36); - -for (align = 7; align >= 0; align--) { - for (len = 36; len; len--) { - b = buf+align; - bcopy(abc, b, len); - for (off = 1; off <= len; off++) { - bcopy(b, b+off, len); - bcopy(b+off, b, len); - if (bcmp(b, abc, len)) - exit(1); - } - } -} -exit(0); -} -EOCP - if $cc foo.c -o safebcpy $ccflags $libs >/dev/null 2>&1 ; then - if ./safebcpy 2>/dev/null; then - echo "Yes, it can." - val="$define" - else - echo "It can't, sorry." - fi - else - echo "(I can't compile the test program, so we'll assume not...)" - fi - ;; -esac -$rm -f foo.* safebcpy core -set d_safebcpy -eval $setvar - diff --git a/U/d_safemcpy.U b/U/d_safemcpy.U deleted file mode 100644 index 2f32680709..0000000000 --- a/U/d_safemcpy.U +++ /dev/null @@ -1,82 +0,0 @@ -?RCS: $Id: d_safemcpy.U,v 3.0 1993/08/18 12:06:58 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_safemcpy.U,v $ -?RCS: -?RCS: Copy "abcde..." string to char abc[] so that -?RCS: gcc doesn't try to store the string in read-only memory. -?RCS: -?RCS: Revision 3.0 1993/08/18 12:06:58 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:d_safemcpy: cat d_memcpy +cc +ccflags +libs rm Oldconfig Setvar -?MAKE: -pick add $@ %< -?S:d_safemcpy: -?S: This variable conditionally defines the HAS_SAFE_MEMCPY symbol if -?S: the memcpy() routine can do overlapping copies. -?S:. -?C:HAS_SAFE_MEMCPY (SAFE_MEMCPY): -?C: This symbol, if defined, indicates that the memcpy routine is available -?C: to copy potentially overlapping memory blocks. Otherwise you should -?C: probably use memmove() or memcpy(). If neither is defined, roll your -?C: own version. -?C:. -?H:#$d_safemcpy HAS_SAFE_MEMCPY /**/ -?H:. -?LINT: set d_safemcpy -: can memcpy handle overlapping blocks? -?X: assume the worst -val="$undef" -case "$d_memcpy" in -"$define") - echo " " - echo "Checking to see if your memcpy() can do overlapping copies..." >&4 - $cat >foo.c <<'EOCP' -main() -{ -char buf[128], abc[128]; -char *b; -int len; -int off; -int align; - -memcpy(abc, "abcdefghijklmnopqrstuvwxyz0123456789", 36); - -for (align = 7; align >= 0; align--) { - for (len = 36; len; len--) { - b = buf+align; - memcpy(abc, b, len); - for (off = 1; off <= len; off++) { - memcpy(b, b+off, len); - memcpy(b+off, b, len); - if (memcmp(b, abc, len)) - exit(1); - } - } -} -exit(0); -} -EOCP - if $cc foo.c -o safemcpy $ccflags $libs >/dev/null 2>&1 ; then - if ./safemcpy 2>/dev/null; then - echo "Yes, it can." - val="$define" - else - echo "It can't, sorry." - fi - else - echo "(I can't compile the test program, so we'll assume not...)" - fi - ;; -esac -$rm -f foo.* safemcpy core -set d_safemcpy -eval $setvar - diff --git a/U/d_setlocale.U b/U/d_setlocale.U deleted file mode 100644 index 14ce63890e..0000000000 --- a/U/d_setlocale.U +++ /dev/null @@ -1,30 +0,0 @@ -?RCS: $Id: d_setlocale.U,v 3.0 1993/08/18 12:07:36 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_setlocale.U,v $ -?RCS: Revision 3.0 1993/08/18 12:07:36 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:d_setlocale: Inlibc -?MAKE: -pick add $@ %< -?S:d_setlocale: -?S: This variable conditionally defines HAS_SETLOCALE if setlocale() is -?S: available to handle locale-specific ctype implementations. -?S:. -?C:HAS_SETLOCALE: -?C: This symbol, if defined, indicates that the setlocale routine is -?C: available to handle locale-specific ctype implementations. -?C:. -?H:#$d_setlocale HAS_SETLOCALE /**/ -?H:. -?LINT:set d_setlocale -: see if setlocale exists -set setlocale d_setlocale -eval $inlibc diff --git a/U/d_shmat.U b/U/d_shmat.U deleted file mode 100644 index e3f8097a0d..0000000000 --- a/U/d_shmat.U +++ /dev/null @@ -1,54 +0,0 @@ -?RCS: $Id: d_shmat.U,v 3.0 1993/08/18 12:07:18 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_shmat.U,v $ -?RCS: Revision 3.0 1993/08/18 12:07:18 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:d_shmat d_voidshmat: Inlibc cppstdin cppflags cppminus usrinc \ - contains -?MAKE: -pick add $@ %< -?S:d_shmat: -?S: This variable conditionally defines the HAS_SHMAT symbol, which -?S: indicates to the C program that the shmat() routine is available. -?S:. -?S:d_voidshmat: -?S: This symbol, if defined, indicates that the shmat() routine -?S: returns a pointer of type void*. Otherwise, char* is assumed. -?S:. -?C:HAS_SHMAT: -?C: This symbol, if defined, indicates that the shmat() routine is -?C: available to attach a shared memory segment to the process space. -?C:. -?H:#$d_shmat HAS_SHMAT /**/ -?H:. -?C:VOIDSHMAT: -?C: This symbol, if defined, indicates that the shmat() routine -?C: returns a pointer of type void*. Otherwise, char* is assumed. -?C:. -?H:#$d_voidshmat VOIDSHMAT /**/ -?H:. -?LINT:set d_shmat d_voidshmat -: see if shmat exists -set shmat d_shmat -eval $inlibc -: see what shmat returns -d_voidshmat="$undef" -case "$d_shmat" in -define) - $cppstdin $cppflags $cppminus < $usrinc/sys/shm.h >voidshmat.txt 2>/dev/null - if $contains "void.*shmat" voidshmat.txt >/dev/null 2>&1; then - echo "and shmat returns (void*)" - d_voidshmat="$define" - else - echo "and shmat returns (char*)" - fi - ;; -esac diff --git a/U/d_strerror.U b/U/d_strerror.U deleted file mode 100644 index 252d9df296..0000000000 --- a/U/d_strerror.U +++ /dev/null @@ -1,113 +0,0 @@ -?RCS: $Id: d_strerror.U,v 3.0.1.1 1994/01/24 14:08:56 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_strerror.U,v $ -?RCS: Revision 3.0.1.1 1994/01/24 14:08:56 ram -?RCS: patch16: protected code looking for sys_errnolist[] with @if -?RCS: patch16: added default value for d_sysernlst -?RCS: -?RCS: Revision 3.0 1993/08/18 12:07:35 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:d_strerror d_syserrlst d_sysernlst d_strerrm: contains Csym Findhdr -?MAKE: -pick add $@ %< -?S:d_strerror: -?S: This variable conditionally defines HAS_STRERROR if strerror() is -?S: available to translate error numbers to strings. -?S:. -?S:d_syserrlst: -?S: This variable conditionally defines HAS_SYS_ERRLIST if sys_errlist[] is -?S: available to translate error numbers to strings. -?S:. -?S:d_sysernlst: -?S: This variable conditionally defines HAS_SYS_ERRNOLIST if sys_errnolist[] -?S: is available to translate error numbers to the symbolic name. -?S:. -?S:d_strerrm: -?S: This variable conditionally defines strerrr as a macro if the -?S: sys_errlist[] array is defined. -?S:. -?C:HAS_STRERROR (STRERROR): -?C: This symbol, if defined, indicates that the strerror routine is -?C: available to translate error numbers to strings. See the writeup -?C: of Strerror() in this file before you try to define your own. -?C:. -?C:HAS_SYS_ERRLIST (SYSERRLIST): -?C: This symbol, if defined, indicates that the sys_errlist array is -?C: available to translate error numbers to strings. The extern int -?C: sys_nerr gives the size of that table. -?C:. -?C:HAS_SYS_ERRNOLIST (SYSERRNOLIST): -?C: This symbol, if defined, indicates that the sys_errnolist array is -?C: available to translate an errno code into its symbolic name (e.g. -?C: ENOENT). The extern int sys_nerrno gives the size of that table. -?C:. -?C:Strerror: -?C: This preprocessor symbol is defined as a macro if strerror() is -?C: not available to translate error numbers to strings but sys_errlist[] -?C: array is there. -?C:. -?H:#$d_strerror HAS_STRERROR /**/ -?H:#$d_syserrlst HAS_SYS_ERRLIST /**/ -?H:#$d_sysernlst HAS_SYS_ERRNOLIST /**/ -?H:?%<:#ifdef HAS_STRERROR -?H:?%<:# define Strerror strerror -?H:?%<:#else -?H:#$d_strerrm Strerror(e) ((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e]) /**/ -?H:?%<:#endif -?H:. -?D:d_sysernlst='' -?T:xxx val -: see if strerror and/or sys_errlist[] exist -echo " " -if set strerror val -f d_strerror; eval $csym; $val; then - echo 'strerror() found.' >&4 - d_strerror="$define" - d_strerrm="$undef" - if set sys_errlist val -a d_syserrlst; eval $csym; $val; then - echo "(You also have sys_errlist[], so we could roll our own strerror.)" - d_syserrlst="$define" - else - echo "(Since you don't have sys_errlist[], sterror() is welcome.)" - d_syserrlst="$undef" - fi -elif xxx=`./findhdr string.h`; test "$xxx" || xxx=`./findhdr strings.h`; \ - $contains '#[ ]*define.*strerror' "$xxx" >/dev/null 2>&1; then - echo 'strerror() found in string header.' >&4 - d_strerror="$define" - d_strerrm="$undef" - if set sys_errlist val -a d_syserrlst; eval $csym; $val; then - echo "(Most probably, strerror() uses sys_errlist[] for descriptions.)" - d_syserrlst="$define" - else - echo "(You don't appear to have any sys_errlist[], how can this be?)" - d_syserrlst="$undef" - fi -elif set sys_errlist val -a d_syserrlst; eval $csym; $val; then -echo "strerror() not found, but you have sys_errlist[] so we'll use that." >&4 - d_strerror="$undef" - d_syserrlst="$define" - d_strerrm="$define" -else - echo 'strerror() and sys_errlist[] NOT found.' >&4 - d_strerror="$undef" - d_syserrlst="$undef" - d_strerrm="$undef" -fi -@if d_sysernlst || HAS_SYS_ERRNOLIST -if set sys_errnolist val -a d_sysernlst; eval $csym; $val; then - echo "(Symbolic error codes can be fetched via the sys_errnolist[] array.)" - d_sysernlst="$define" -else - echo "(However, I can't extract the symbolic error code out of errno.)" - d_sysernlst="$undef" -fi -@end - diff --git a/U/d_vfork.U b/U/d_vfork.U deleted file mode 100644 index fb674340e2..0000000000 --- a/U/d_vfork.U +++ /dev/null @@ -1,56 +0,0 @@ -?RCS: $Id: d_vfork.U,v 3.0.1.2 1993/10/16 13:49:39 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: d_vfork.U,v $ -?RCS: Revision 3.0.1.2 1993/10/16 13:49:39 ram -?RCS: patch12: added magic for vfork() -?RCS: -?RCS: Revision 3.0.1.1 1993/09/13 16:06:57 ram -?RCS: patch10: removed automatic remapping of vfork on fork (WAD) -?RCS: patch10: added compatibility code for older config.sh (WAD) -?RCS: -?RCS: Revision 3.0 1993/08/18 12:07:55 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:d_vfork: Inlibc -?MAKE: -pick add $@ %< -?S:d_vfork: -?S: This variable conditionally defines the HAS_VFORK symbol, which -?S: indicates the vfork() routine is available. -?S:. -?C:HAS_VFORK (VFORK): -?C: This symbol, if defined, indicates that vfork() exists. -?C:. -?H:#$d_vfork HAS_VFORK /**/ -?H:. -?M:vfork: HAS_VFORK -?M:#ifndef HAS_VFORK -?M:#define vfork fork -?M:#endif -?M:. -?LINT:set d_vfork -: see if there is a vfork -set vfork d_vfork -eval $inlibc -: But do we want to use it. vfork is reportedly unreliable in -: perl in Solaris 2.x, and probably elsewhere. -case "$d_vfork" in -define) - dflt='n' - rp="Some systems have problems with vork. Do you want to use it?" - . ./myread - case "$ans" in - y|Y) ;; - *) echo "Ok, we won't use vfork." - d_vfork="$undef" - ;; - esac - ;; -esac diff --git a/U/dlsrc.U b/U/dlsrc.U deleted file mode 100644 index 616818d346..0000000000 --- a/U/dlsrc.U +++ /dev/null @@ -1,230 +0,0 @@ -?RCS: $Id: dlsrc.U,v$ -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: dlsrc.U,v $ -?RCS: -?X: hpux support thanks to Jeff Okamoto <okamoto@hpcc101.corp.hp.com> -?X: -?X: To create a shared library, you must compile ALL source files in the -?X: library with +z (or possibly +Z if the library is whopping huge), -?X: then link the library with -b. Example: -?X: cc -c +z module_a.c -?X: cc -c +z module_b.c -?X: ld -b module_a.o module_b.o -o module.sl -?X: -?MAKE:usedl dlsrc dlobj dldir cccdlflags lddlflags ccdlflags \ - shlibsuffix: Getfile Myread test osname sed i_dlfcn Findhdr cc -?MAKE: -pick add $@ %< -?S:usedl: -?S: This variable contains indicates if the the system supports dynamic -?S: loading of some sort. See also dlsrc and dlobj. -?S:. -?S:dlsrc: -?S: This variable contains the name of the dynamic loading file that -?S: will be used with the package. -?S:. -?S:dlobj: -?S: This variable contains the name of the dynamic loading object -?S: file that will be used with the package. This is used in Makefile. -?S:. -?S:dldir: -?S: This variable contains the directory from which to fetch dlsrc. -?S: It is up to the makefile to use it. -?S:. -?S:cccdlflags: -?S: This variable contains any special flags that might need to be -?S: passed with cc -c to compile modules to be used to create a shared -?S: library that will be used for dynamic loading. For hpux, this -?S: should be +z. It is up to the makefile to use it. -?S:. -?S:lddlflags: -?S: This variable contains any special flags that might need to be -?S: passed to ld to create a shared library suitable for dynamic -?S: loading. It is up to the makefile to use it. For hpux, it -?S: should be -b. For sunos 4.1, it is empty. -?S:. -?S:ccdlflags: -?S: This variable contains any special flags that might need to be -?S: passed to cc to link with a shared library for dynamic loading. -?S: It is up to the makefile to use it. For sunos 4.1, it should -?S: be empty. -?S:. -?S:shlibsuffix: -?S: Shared libraries are built by Makefile in the form -?S: lib/auto/xxx/xxx${shsuffix}, where xxx is -?S: the name of the library, e.g. /lib/auto/POSIX/POSIX.so -?S:. -?C:USE_DYNAMIC_LOADING ~ %<: -?C: This symbol, if defined, indicates that dynamic loading of -?C: some sort is available. -?C:. -?H:?%<:#$usedl USE_DYNAMIC_LOADING /**/ -?H:. -?W:%<:dlopen -?INIT:: File to use for dynamic loading -?INIT:usedl='' -?T:xxx -?X: -?X: We select a default of 'define' for usedl if either dl_$osname.c -?X: exists or if i_dlfcn is defined (which probably means dl_sunos.c -?X: will work.) -?X: -: determine which dynamic loading, if any, to compile in -echo " " -case "$usedl" in -'') case "$i_dlfcn" in - define) dflt='y' ;; - *) dflt='n' ;; - esac - : Does a dl.c file exist for this operating system - $test -f ../ext/dl/dl_${osname}.c && dflt='y' - ;; -define|y|true) dflt='y' - usedl="$define" - ;; -*) dflt='n' - ;; -esac -rp="Do you wish to attempt to use dynamic loading?" -. ./myread -usedl="$ans" -case "$ans" in -y*) usedl="$define" - if $test -f ../ext/dl/dl_${osname}.c ; then - dflt="ext/dl/dl_${osname}.c" - else - dflt='ext/dl/dl.c' - fi - echo "The following dynamic loading files are available:" - cd ..; ls -C ext/dl/dl*.c; cd UU - rp="Source file to use for dynamic loading" - fn="fne~" - . ./getfile - : emulate basename and dirname - xxx=`echo $ans | $sed -e 's@.*/\([^/]*\)$@\1@' -e 's@\.c$@@'` - dlobj=$xxx.o - dlsrc=$xxx.c - dldir=`echo $ans | $sed 's@\(.*\)/[^/]*$@\1@'` - case "$dldir" in - '') dldir="." ;; - *) ;; - esac - if $test -f ../$dldir/$dlsrc; then - usedl="$define" - else - echo "File $dlsrc does not exist -- ignored" - usedl="$undef" - fi - - cat << EOM - -Some systems may require passing special flags to $cc -c to -compile modules that will be used to create a shared library. -To use no flags, say "none". -EOM - case "$cccdlflags" in - ''|' ') case "$osname" in - hpux) dflt='+z' ;; - next) dflt='none' ;; - sunos) dflt='none' ;; - *) dflt='none' ;; - esac - ;; - *) dflt="$cccdlflags" ;; - esac - rp="Any special flags to pass to $cc -c to compile shared library modules?" - . ./myread - case "$ans" in - none) cccdlflags='' ;; - *) cccdlflags="$ans" ;; - esac - - cat << 'EOM' - -Some systems may require passing special flags to ld to -create a shared library. To use no flags, say "none". -EOM -?X: I have received one report that NeXT requires -r here. -?X: On SunOS 4.1.3, that makes the library no longer shared. - case "$lddlflags" in - ''|' ') case "$osname" in - hpux) dflt='-b' ;; - next) dflt='none' ;; - sunos) dflt='none' ;; - *) dflt='none' ;; - esac - ;; - *) dflt="$lddlflags" ;; - esac - rp="Any special flags to pass to ld to create a shared library?" - . ./myread - case "$ans" in - none) lddlflags='' ;; - *) lddlflags="$ans" ;; - esac - - cat <<EOM - -Some systems may require passing special flags to $cc to indicate that -dynamic linking will be used. To use no flags, say "none". -EOM - case "$ccdlflags" in - ''|' ') - case "$osname" in - hpux) dflt='none' ;; - next) dflt='none' ;; - sunos) dflt='none' ;; - *) dflt='none' ;; - esac - ;; - *) dflt="$ccdlflags" - ;; - esac - rp="Any special flags to pass to $cc to use dynamic loading?" - . ./myread - case "$ans" in - none) ccdlflags='' ;; - *) ccdlflags="$ans" ;; - esac - cat <<EOM - -Some systems may require using a special suffix for shared libraries. -To create the shared library for POSIX, for example, you may need to -actually build the file POSIX.so. - -EOM - case "$shlibsuffix" in - '') - case "$osname" in - hpux) dflt='.sl' ;; - next) dflt='.so' ;; - sunos) dflt='.so' ;; - *) dflt='.so' ;; - esac - ;; - *) dflt="$shlibsuffix" - ;; - esac - rp="What is the suffix used for shared libraries?" - . ./myread - case "$ans" in - none) shlibsuffix='' ;; - *) shlibsuffix="$ans" ;; - esac - ;; -?X: End of usedl=y section -*) usedl="$undef" - : These are currently not used. - dlsrc='' - dlobj='' - dldir='' - lddlflags='' - ccdlflags='' - shlibsuffix='.o' - ;; -esac diff --git a/U/gidtype.U b/U/gidtype.U deleted file mode 100644 index 962f3d8a6b..0000000000 --- a/U/gidtype.U +++ /dev/null @@ -1,54 +0,0 @@ -?RCS: $Id: gidtype.U,v 3.0 1993/08/18 12:08:11 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: gidtype.U,v $ -?RCS: Revision 3.0 1993/08/18 12:08:11 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:gidtype: Myread Oldconfig contains Findhdr Setvar -?MAKE: -pick add $@ %< -?S:gidtype: -?S: This variable defines Gid_t to be something like gid_t, int, -?S: ushort, or whatever type is used to declare the return type -?S: of getgid(). Typically, it is the type of group ids in the kernel. -?S:. -?C:Gid_t (GIDTYPE): -?C: This symbol holds the return type of getgid() and the type of -?C: argument to setrgid() and related functions. Typically, -?C: it is the type of group ids in the kernel. -?C: It can be int, ushort, uid_t, etc... It may be necessary to include -?C: <sys/types.h> to get any typedef'ed information. -?C:. -?H:#define Gid_t $gidtype /* Type for getgid(), etc... */ -?H:. -?T:xxx -?INIT:gidtype='' -: see what type gids are declared as in the kernel -case "$gidtype" in -'') - if $contains 'gid_t;' `./findhdr sys/types.h` >/dev/null 2>&1 ; then - dflt='gid_t'; - else - xxx=`./findhdr sys/user.h` - set `grep 'groups\[NGROUPS\];' "$xxx" 2>/dev/null` unsigned short - case $1 in - unsigned) dflt="$1 $2" ;; - *) dflt="$1" ;; - esac - fi - ;; -*) dflt="$gidtype";; -esac -echo " " -rp="What is the type for group ids returned by getgid()?" -. ./myread -val="$ans" -set gidtype -eval $setvar diff --git a/U/groupstype.U b/U/groupstype.U deleted file mode 100644 index 355ea14980..0000000000 --- a/U/groupstype.U +++ /dev/null @@ -1,51 +0,0 @@ -?RCS: $Id: groupstype.U,v$ -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: groupstype.U,v $ -?RCS: -?MAKE:groupstype: gidtype d_getgrps Myread Oldconfig Findhdr cat Setvar -?MAKE: -pick add $@ %< -?INIT:groupstype='' -?S:groupstype: -?S: This variable defines GROUPSTYPE to be something like gid_t, int, -?S: ushort, or whatever type is used for the second argument to -?S: getgroups(). Usually, this is the same of gidtype, but -?S: sometimes it isn't. -?S:. -?C:GROUPSTYPE: -?C: This symbol holds the type used for the second argument to -?C: getgroups(). Usually, this is the same of gidtype, but -?C: sometimes it isn't. It can be int, ushort, uid_t, etc... -?C: It may be necessary to include <sys/types.h> to get any -?C: typedef'ed information. This is only required if you have -?C: getgroups(). -?C:. -?H:?%<:#ifdef HAS_GETGROUPS -?H:?%<:#define GROUPSTYPE $groupstype /* Type for 2nd arg to getgroups() */ -?H:?%<:#endif -?H:. -?W:%<:getgroups HAS_GETGROUPS -case "$d_getgrps" in -'define') - case "$groupstype" in - '') dflt="$gidtype" ;; - *) dflt="$groupstype" ;; - esac - echo " " - $cat <<EOM -What is the type of the second argument to getgroups()? Usually this -is the same as group ids, $gidtype, but not always. -EOM - rp="What type is the second arguement to getgroups()?" - . ./myread - val="$ans" - ;; -*) val="$gidtype";; -esac -set groupstype -eval $setvar diff --git a/U/i_dlfcn.U b/U/i_dlfcn.U deleted file mode 100644 index dcffe126bf..0000000000 --- a/U/i_dlfcn.U +++ /dev/null @@ -1,27 +0,0 @@ -?RCS: $Id: i_dlfcn.U,v $ -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: i_dlfcn.U,v $ -?RCS: -?MAKE:i_dlfcn: Inhdr -?MAKE: -pick add $@ %< -?S:i_dlfcn: -?S: This variable conditionally defines the I_DLFCN symbol, which -?S: indicates to the C program that <dlfcn.h> exists and should -?S: be included. -?S:. -?C:I_DLFCN: -?C: This symbol, if defined, indicates that <dlfcn.h> exists and should -?C: be included. -?C:. -?H:#$i_dlfcn I_DLFCN /**/ -?H:. -?LINT:set i_dlfcn -: see if dlfcn is available -set dlfcn.h i_dlfcn -eval $inhdr diff --git a/U/i_net_errno.U b/U/i_net_errno.U deleted file mode 100644 index c5fb9116a0..0000000000 --- a/U/i_net_errno.U +++ /dev/null @@ -1,50 +0,0 @@ -?RCS: $Id: i_net_errno.U,v $ -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: i_net_errno.U,v $ -?RCS: -?MAKE:i_neterrno: Inhdr cc ccflags rm -?MAKE: -pick add $@ %< -?S:i_neterrno: -?S: This variable conditionally defines the I_NET_ERRNO symbol, which -?S: indicates to the C program that <net/errno.h> exists and should -?S: be included. -?S:. -?C:I_NET_ERRNO: -?C: This symbol, if defined, indicates that <net/errno.h> exists and -?C: should be included. -?C:. -?H:#$i_neterrno I_NET_ERRNO /**/ -?H:. -?LINT:set i_neterrno -: see if net/errno.h is available -set net/errno.h i_neterrno -eval $inhdr -: Unfortunately, it causes problems on some systems. Arrgh. -case '$i_neterrno' in -'define') echo "<net/errno.h> found." - cat > try.c <<'EOM' -#include <stdio.h> -#include <errno.h> -#include <net/errno.h> -int func() -{ -int x; -x = ENOTSOCK; -return x; -} -EOM - if $cc $ccflags -c try.c >/dev/null 2>&1; then - i_neterrno="$define" - else - echo "But it causes problems, so we won't include it" - i_neterrno="$undef" - fi - $rm -f try.* try - ;; -esac diff --git a/U/i_pwd.U b/U/i_pwd.U deleted file mode 100644 index 69aa030706..0000000000 --- a/U/i_pwd.U +++ /dev/null @@ -1,134 +0,0 @@ -?RCS: $Id: i_pwd.U,v 3.0 1993/08/18 12:08:25 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: i_pwd.U,v $ -?RCS: Revision 3.0 1993/08/18 12:08:25 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?X: -?X: This unit looks wether there is a pwd system or not -?X: -?MAKE:i_pwd d_pwquota d_pwage d_pwchange d_pwclass d_pwexpire d_pwcomment: \ - test contains rm cppstdin cppflags cppminus Findhdr -?MAKE: -pick add $@ %< -?S:i_pwd: -?S: This variable conditionally defines I_PWD, which indicates -?S: to the C program that it should include <pwd.h>. -?S:. -?S:d_pwquota: -?S: This varaible conditionally defines PWQUOTA, which indicates -?S: that struct passwd contains pw_quota. -?S:. -?S:d_pwage: -?S: This varaible conditionally defines PWAGE, which indicates -?S: that struct passwd contains pw_age. -?S:. -?S:d_pwchange: -?S: This varaible conditionally defines PWCHANGE, which indicates -?S: that struct passwd contains pw_change. -?S:. -?S:d_pwclass: -?S: This varaible conditionally defines PWCLASS, which indicates -?S: that struct passwd contains pw_class. -?S:. -?S:d_pwexpire: -?S: This varaible conditionally defines PWEXPIRE, which indicates -?S: that struct passwd contains pw_expire. -?S:. -?S:d_pwcomment: -?S: This varaible conditionally defines PWCOMMENT, which indicates -?S: that struct passwd contains pw_comment. -?S:. -?C:I_PWD: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <pwd.h>. -?C:. -?C:PWQUOTA: -?C: This symbol, if defined, indicates to the C program that struct passwd -?C: contains pw_quota. -?C:. -?C:PWAGE: -?C: This symbol, if defined, indicates to the C program that struct passwd -?C: contains pw_age. -?C:. -?C:PWCHANGE: -?C: This symbol, if defined, indicates to the C program that struct passwd -?C: contains pw_change. -?C:. -?C:PWCLASS: -?C: This symbol, if defined, indicates to the C program that struct passwd -?C: contains pw_class. -?C:. -?C:PWEXPIRE: -?C: This symbol, if defined, indicates to the C program that struct passwd -?C: contains pw_expire. -?C:. -?C:PWCOMMENT: -?C: This symbol, if defined, indicates to the C program that struct passwd -?C: contains pw_comment. -?C:. -?H:#$i_pwd I_PWD /**/ -?H:#$d_pwquota PWQUOTA /**/ -?H:#$d_pwage PWAGE /**/ -?H:#$d_pwchange PWCHANGE /**/ -?H:#$d_pwclass PWCLASS /**/ -?H:#$d_pwexpire PWEXPIRE /**/ -?H:#$d_pwcomment PWCOMMENT /**/ -?H:. -?T:xxx -: see if this is a pwd system -echo " " -xxx=`./findhdr pwd.h` -if $test "$xxx"; then - i_pwd="$define" - echo "<pwd.h> found." >&4 - $cppstdin $cppflags $cppminus < $xxx >$$.h - if $contains 'pw_quota' $$.h >/dev/null 2>&1; then - d_pwquota="$define" - else - d_pwquota="$undef" - fi - if $contains 'pw_age' $$.h >/dev/null 2>&1; then - d_pwage="$define" - else - d_pwage="$undef" - fi - if $contains 'pw_change' $$.h >/dev/null 2>&1; then - d_pwchange="$define" - else - d_pwchange="$undef" - fi - if $contains 'pw_class' $$.h >/dev/null 2>&1; then - d_pwclass="$define" - else - d_pwclass="$undef" - fi - if $contains 'pw_expire' $$.h >/dev/null 2>&1; then - d_pwexpire="$define" - else - d_pwexpire="$undef" - fi - if $contains 'pw_comment' $$.h >/dev/null 2>&1; then - d_pwcomment="$define" - else - d_pwcomment="$undef" - fi - $rm -f $$.h -else - i_pwd="$undef" - d_pwquota="$undef" - d_pwage="$undef" - d_pwchange="$undef" - d_pwclass="$undef" - d_pwexpire="$undef" - d_pwcomment="$undef" - echo "<pwd.h> NOT found." >&4 -fi - diff --git a/U/i_sdbm.U b/U/i_sdbm.U deleted file mode 100644 index 3e01615670..0000000000 --- a/U/i_sdbm.U +++ /dev/null @@ -1,37 +0,0 @@ -?RCS: $Id: i_sdbm.U,v $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: i_sdbm.U,v $ -?RCS: -?MAKE:i_sdbm: Inhdr package Setvar -?MAKE: -pick add $@ %< -?S:i_sdbm: -?S: This variable conditionally defines the I_SDBM symbol, which -?S: indicates to the C program that sdbm.h exists and should -?S: be included. -?S:. -?C:I_SDBM (HAS_SDBM): -?C: This symbol, if defined, indicates that sdbm.h exists and should -?C: be included. -?C:. -?H:#$i_sdbm I_SDBM /**/ -?H:. -?LINT:set i_sdbm -: see if sdbm.h is wanted -?X: Since perl includes sdbm, don't ask here. Always include it. -?X: But, we'll allow a hints file to over-rule us. -echo " " -echo "$package includes an implementation of sdbm in ext/dbm/sdbm." -case "$i_sdbm" in - ''|' ') val="$define" ;; - *) val="$i_sdbm" ;; -esac -set i_sdbm -eval $setvar diff --git a/U/i_sgtty.U b/U/i_sgtty.U deleted file mode 100644 index b890d78811..0000000000 --- a/U/i_sgtty.U +++ /dev/null @@ -1,128 +0,0 @@ -?MAKE:i_sgtty: Inhdr -?MAKE: -pick add $@ %< -?S:i_sgtty: -?S: This variable conditionally defines the I_SGTTY symbol, and -?S: indicates whether a C program should include <sgtty.h>. -?S:. -?C:I_SGTTY: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <sgtty.h>. -?C:. -?H:#$i_sgtty I_SGTTY /**/ -?H:. -?LINT:set i_sgtty -: see if this is a sgtty.h system -set sgtty.h i_sgtty -eval $inhdr -?MAKE:i_sgtty: Inhdr -?MAKE: -pick add $@ %< -?S:i_sgtty: -?S: This variable conditionally defines the I_SGTTY symbol, and -?S: indicates whether a C program should include <sgtty.h>. -?S:. -?C:I_SGTTY: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <sgtty.h>. -?C:. -?H:#$i_sgtty I_SGTTY /**/ -?H:. -?LINT:set i_sgtty -: see if this is a sgtty.h system -set sgtty.h i_sgtty -eval $inhdr -?MAKE:i_sgtty: Inhdr -?MAKE: -pick add $@ %< -?S:i_sgtty: -?S: This variable conditionally defines the I_SGTTY symbol, and -?S: indicates whether a C program should include <sgtty.h>. -?S:. -?C:I_SGTTY: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <sgtty.h>. -?C:. -?H:#$i_sgtty I_SGTTY /**/ -?H:. -?LINT:set i_sgtty -: see if this is a sgtty.h system -set sgtty.h i_sgtty -eval $inhdr -?MAKE:i_sgtty: Inhdr -?MAKE: -pick add $@ %< -?S:i_sgtty: -?S: This variable conditionally defines the I_SGTTY symbol, and -?S: indicates whether a C program should include <sgtty.h>. -?S:. -?C:I_SGTTY: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <sgtty.h>. -?C:. -?H:#$i_sgtty I_SGTTY /**/ -?H:. -?LINT:set i_sgtty -: see if this is a sgtty.h system -set sgtty.h i_sgtty -eval $inhdr -?MAKE:i_sgtty: Inhdr -?MAKE: -pick add $@ %< -?S:i_sgtty: -?S: This variable conditionally defines the I_SGTTY symbol, and -?S: indicates whether a C program should include <sgtty.h>. -?S:. -?C:I_SGTTY: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <sgtty.h>. -?C:. -?H:#$i_sgtty I_SGTTY /**/ -?H:. -?LINT:set i_sgtty -: see if this is a sgtty.h system -set sgtty.h i_sgtty -eval $inhdr -?MAKE:i_sgtty: Inhdr -?MAKE: -pick add $@ %< -?S:i_sgtty: -?S: This variable conditionally defines the I_SGTTY symbol, and -?S: indicates whether a C program should include <sgtty.h>. -?S:. -?C:I_SGTTY: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <sgtty.h>. -?C:. -?H:#$i_sgtty I_SGTTY /**/ -?H:. -?LINT:set i_sgtty -: see if this is a sgtty.h system -set sgtty.h i_sgtty -eval $inhdr -?MAKE:i_sgtty: Inhdr -?MAKE: -pick add $@ %< -?S:i_sgtty: -?S: This variable conditionally defines the I_SGTTY symbol, and -?S: indicates whether a C program should include <sgtty.h>. -?S:. -?C:I_SGTTY: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <sgtty.h>. -?C:. -?H:#$i_sgtty I_SGTTY /**/ -?H:. -?LINT:set i_sgtty -: see if this is a sgtty.h system -set sgtty.h i_sgtty -eval $inhdr -?MAKE:i_sgtty: Inhdr -?MAKE: -pick add $@ %< -?S:i_sgtty: -?S: This variable conditionally defines the I_SGTTY symbol, and -?S: indicates whether a C program should include <sgtty.h>. -?S:. -?C:I_SGTTY: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <sgtty.h>. -?C:. -?H:#$i_sgtty I_SGTTY /**/ -?H:. -?LINT:set i_sgtty -: see if this is a sgtty.h system -set sgtty.h i_sgtty -eval $inhdr diff --git a/U/i_termio.U b/U/i_termio.U deleted file mode 100644 index f1eb947503..0000000000 --- a/U/i_termio.U +++ /dev/null @@ -1,117 +0,0 @@ -?RCS: $Id: i_termio.U,v 3.0 1993/08/18 12:08:44 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: i_termio.U,v $ -?RCS: Revision 3.0 1993/08/18 12:08:44 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?X: -?X: Include all three (possible) definitions in config_h.SH. -?X: There are enough implementations of posix termios.h out there -?X: that do not work well with other system headers or are -?X: incomplete. This makes it easier for the user to back off -?X: and try sgtty.h or i_termio.h instead. -?X: -?MAKE:i_termio i_sgtty i_termios: test Inlibc Cppsym Guess Setvar Findhdr -?MAKE: -pick add $@ %< -?S:i_termio: -?S: This variable conditionally defines the I_TERMIO symbol, which -?S: indicates to the C program that it should include <termio.h> rather -?S: than <sgtty.h>. -?S:. -?S:i_termios: -?S: This variable conditionally defines the I_TERMIOS symbol, which -?S: indicates to the C program that the POSIX <termios.h> file is -?S: to be included. -?S:. -?S:i_sgtty: -?S: This variable conditionally defines the I_SGTTY symbol, which -?S: indicates to the C program that it should include <sgtty.h> rather -?S: than <termio.h>. -?S:. -?C:I_TERMIO ~ %<: -?C: This symbol, if defined, indicates that the program should include -?C: <termio.h> rather than <sgtty.h>. There are also differences in -?C: the ioctl() calls that depend on the value of this symbol. -?C:. -?C:I_TERMIOS ~ %<: -?C: This symbol, if defined, indicates that the program should include -?C: the POSIX termios.h rather than sgtty.h or termio.h. -?C: There are also differences in the ioctl() calls that depend on the -?C: value of this symbol. -?C:. -?C:I_SGTTY ~ %<: -?C: This symbol, if defined, indicates that the program should include -?C: <sgtty.h> rather than <termio.h>. There are also differences in -?C: the ioctl() calls that depend on the value of this symbol. -?C:. -?H:?%<:#$i_termio I_TERMIO /**/ -?H:?%<:#$i_termios I_TERMIOS /**/ -?H:?%<:#$i_sgtty I_SGTTY /**/ -?H:. -?T:val2 val3 -?LINT:set i_termio i_sgtty i_termios -: see if this is a termio system -val="$undef" -val2="$undef" -val3="$undef" -?X: Prefer POSIX-approved termios.h over all else -if $test `./findhdr termios.h`; then - set tcsetattr i_termios - eval $inlibc - val3="$i_termios" -fi -echo " " -case "$val3" in -"$define") echo "You have POSIX termios.h... good!" >&4;; -*) if Cppsym pyr; then - case "`/bin/universe`" in - ucb) if $test `./findhdr sgtty.h`; then - val2="$define" - echo "<sgtty.h> found." >&4 - else - echo "System is pyramid with BSD universe." - echo "<sgtty.h> not found--you could have problems." >&4 - fi;; - *) if $test `./findhdr termio.h`; then - val="$define" - echo "<termio.h> found." >&4 - else - echo "System is pyramid with USG universe." - echo "<termio.h> not found--you could have problems." >&4 - fi;; - esac -?X: Start with USG to avoid problems if both usg/bsd was guessed - elif usg; then - if $test `./findhdr termio.h`; then - echo "<termio.h> found." >&4 - val="$define" - elif $test `./findhdr sgtty.h`; then - echo "<sgtty.h> found." >&4 - val2="$define" - else -echo "Neither <termio.h> nor <sgtty.h> found--you could have problems." >&4 - fi - else - if $test `./findhdr sgtty.h`; then - echo "<sgtty.h> found." >&4 - val2="$define" - elif $test `./findhdr termio.h`; then - echo "<termio.h> found." >&4 - val="$define" - else -echo "Neither <sgtty.h> nor <termio.h> found--you could have problems." >&4 - fi - fi;; -esac -set i_termio; eval $setvar -val=$val2; set i_sgtty; eval $setvar -val=$val3; set i_termios; eval $setvar - diff --git a/U/i_termios.U b/U/i_termios.U deleted file mode 100644 index f676710e40..0000000000 --- a/U/i_termios.U +++ /dev/null @@ -1,64 +0,0 @@ -?MAKE:i_termios: Inhdr -?MAKE: -pick add $@ %< -?S:i_termios: -?S: This variable conditionally defines the I_TERMIOS symbol, and -?S: indicates whether a C program should include <sys/termios.h>. -?S:. -?C:I_TERMIOS: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <termios.h>. -?C:. -?H:#$i_termios I_TERMIOS /**/ -?H:. -?LINT:set i_termios -: see if this is a termios.h system -set termios.h i_termios -eval $inhdr -?MAKE:i_termios: Inhdr -?MAKE: -pick add $@ %< -?S:i_termios: -?S: This variable conditionally defines the I_TERMIOS symbol, and -?S: indicates whether a C program should include <sys/termios.h>. -?S:. -?C:I_TERMIOS: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <termios.h>. -?C:. -?H:#$i_termios I_TERMIOS /**/ -?H:. -?LINT:set i_termios -: see if this is a termios.h system -set termios.h i_termios -eval $inhdr -?MAKE:i_termios: Inhdr -?MAKE: -pick add $@ %< -?S:i_termios: -?S: This variable conditionally defines the I_TERMIOS symbol, and -?S: indicates whether a C program should include <sys/termios.h>. -?S:. -?C:I_TERMIOS: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <termios.h>. -?C:. -?H:#$i_termios I_TERMIOS /**/ -?H:. -?LINT:set i_termios -: see if this is a termios.h system -set termios.h i_termios -eval $inhdr -?MAKE:i_termios: Inhdr -?MAKE: -pick add $@ %< -?S:i_termios: -?S: This variable conditionally defines the I_TERMIOS symbol, and -?S: indicates whether a C program should include <sys/termios.h>. -?S:. -?C:I_TERMIOS: -?C: This symbol, if defined, indicates to the C program that it should -?C: include <termios.h>. -?C:. -?H:#$i_termios I_TERMIOS /**/ -?H:. -?LINT:set i_termios -: see if this is a termios.h system -set termios.h i_termios -eval $inhdr diff --git a/U/i_vfork.U b/U/i_vfork.U deleted file mode 100644 index 19af424af1..0000000000 --- a/U/i_vfork.U +++ /dev/null @@ -1,34 +0,0 @@ -?RCS: $Id: i_vfork.U,v 3.0 1993/08/18 12:08:50 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: i_vfork.U,v $ -?RCS: Revision 3.0 1993/08/18 12:08:50 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:i_vfork: Inhdr d_vfork -?MAKE: -pick add $@ %< -?S:i_vfork: -?S: This variable conditionally defines the I_VFORK symbol, and indicates -?S: whether a C program should include vfork.h. -?S:. -?C:I_VFORK: -?C: This symbol, if defined, indicates to the C program that it should -?C: include vfork.h. -?C:. -?H:#$i_vfork I_VFORK /**/ -?H:. -?LINT:set i_vfork -: see if this is a vfork system -case "$d_vfork" in -define) set vfork.h i_vfork - eval $inhdr - ;; -*) i_vfork="$undef";; -esac diff --git a/U/libc.U b/U/libc.U deleted file mode 100644 index 9f497f1ba0..0000000000 --- a/U/libc.U +++ /dev/null @@ -1,288 +0,0 @@ -?RCS: $Id: libc.U,v 3.0.1.3 1994/01/24 14:12:17 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: libc.U,v $ -?RCS: Revision 3.0.1.3 1994/01/24 14:12:17 ram -?RCS: patch16: can now export nm_extract as an internal-use only variable -?RCS: -?RCS: Revision 3.0.1.2 1993/09/13 16:09:03 ram -?RCS: patch10: added special handling for Apollo systems (WAD) -?RCS: -?RCS: Revision 3.0.1.1 1993/08/27 14:40:03 ram -?RCS: patch7: added entry for /usr/shlib/libc.so (OSF/1 machines) -?RCS: -?RCS: Revision 3.0 1993/08/18 12:08:57 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:libc +nm_extract: echo n c rm test grep Getfile Myread Oldconfig Loc \ - sed libs incpath libpth runnm nm_opt contains plibpth xlibpth -?MAKE: -pick add $@ %< -?S:libc: -?S: This variable contains the location of the C library. -?S:. -?S:nm_extract: -?S: This variable holds the name of the extraction command used to process -?S: the output of nm and yield the list of defined symbols. It is used -?S: internally by Configure. -?S:. -?T:thislib try libnames xxx xscan xrun thisname com tans -?LINT:change libpth nm_opt -case "$runnm" in -true) -?X: indentation is wrong on purpose--RAM -: get list of predefined functions in a handy place -echo " " -case "$libc" in -'') libc=unknown - case "$libs" in - *-lc_s*) libc=`./loc libc_s.a $libc $libpth` - esac - ;; -esac -libpth="$plibpth $libpth" -libnames=''; -case "$libs" in -'') ;; -*) for thislib in $libs; do - case "$thislib" in - -l*) - thislib=`expr X$thislib : 'X-l\(.*\)'` - try=`./loc lib$thislib.a blurfl/dyick $libpth` - if test ! -f $try; then - try=`./loc lib$thislib blurfl/dyick $libpth` - if test ! -f $try; then - try=`./loc lib$thislib.so.'*' blurfl/dyick $libpth` - if test ! -f $try; then - try=`./loc $thislib blurfl/dyick $libpth` - if test ! -f $try; then - try=`./loc Slib$thislib.a blurfl/dyick $xlibpth` - if test ! -f $try; then - try='' - fi - fi - fi - fi - fi - libnames="$libnames $try" - ;; - *) libnames="$libnames $thislib" ;; - esac - done - ;; -esac -?X: -?X: Some systems (e.g. DG/UX) use "environmental" links, which make the test -?X: -f fail. Ditto for symbolic links. So in order to reliably check the -?X: existence of a file, we use test -r. It will still fail with DG/UX links -?X: though, but at least it will detect symbolic links. At some strategic -?X: points, we make use of (test -h), using a sub-shell in case builtin test -?X: does not implement the -h check for symbolic links. This makes it -?X: possible to preset libc in a hint file for instance and have it show up -?X: as-is in the question. -?X: -xxx=normal -case "$libc" in -unknown) - set /usr/ccs/lib/libc.so - $test -r $1 || set /usr/lib/libc.so - $test -r $1 || set /usr/shlib/libc.so - $test -r $1 || set /usr/lib/libc.so.[0-9]* - $test -r $1 || set /lib/libsys_s.a - eval set \$$# - ;; -*) -?X: ensure the test below for the (shared) C library will fail - set blurfl - ;; -esac -if $test -r "$1"; then - echo "Your (shared) C library seems to be in $1." - libc="$1" -elif $test -r /lib/libc && $test -r /lib/clib; then -?X: -?X: Apollo has its C library in /lib/clib AND /lib/libc -?X: not to mention its math library in /lib/syslib... -?X: - echo "Your C library seems to be in both /lib/clib and /lib/libc." - xxx=apollo - libc='/lib/clib /lib/libc' - if $test -r /lib/syslib; then - echo "(Your math library is in /lib/syslib.)" -?X: Put syslib in libc -- not quite right, but won't hurt - libc="$libc /lib/syslib" - fi -elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then - echo "Your C library seems to be in $libc, as you said before." -?X: For mips, and... -elif $test -r $incpath/usr/lib/libc.a; then - libc=$incpath/usr/lib/libc.a; - echo "Your C library seems to be in $libc. That's fine." -elif $test -r /lib/libc.a; then - libc=/lib/libc.a; - echo "Your C library seems to be in $libc. You're normal." -else - if tans=`./loc libc.a blurfl/dyick $libpth`; $test -r "$tans"; then - : - elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then - libnames="$libnames "`./loc clib blurfl/dyick $libpth` - elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then - : - elif tans=`./loc Slibc.a blurfl/dyick $xlibpth`; $test -r "$tans"; then - : - elif tans=`./loc Mlibc.a blurfl/dyick $xlibpth`; $test -r "$tans"; then - : - else - tans=`./loc Llibc.a blurfl/dyick $xlibpth` - fi - if $test -r "$tans"; then - echo "Your C library seems to be in $tans, of all places." - libc=$tans - else - libc='blurfl' - fi -fi -if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then - dflt="$libc" - cat <<EOM - -If the guess above is wrong (which it might be if you're using a strange -compiler, or your machine supports multiple models), you can override it here. - -EOM -else - dflt='' - echo $libpth | tr ' ' '\012' | sort | uniq > libpath - cat >&4 <<EOM -I can't seem to find your C library. I've looked in the following places: - -EOM - $sed 's/^/ /' libpath - cat <<EOM - -None of these seems to contain your C library. I need to get its name... - -EOM -fi -fn=f -rp='Where is your C library?' -. ./getfile -libc="$ans" - -echo " " -echo $libc $libnames | tr ' ' '\012' | sort | uniq > libnames -set X `cat libnames` -shift -xxx=files -case $# in 1) xxx=file; esac -echo "Extracting names from the following $xxx for later perusal:" >&4 -echo " " -$sed 's/^/ /' libnames >&4 -echo " " -$echo $n "This may take a while...$c" >&4 - -nm $nm_opt $* 2>/dev/null >libc.tmp -$echo $n ".$c" -?X: -?X: To accelerate processing, we look at the correct 'sed' command -?X: by using a small subset of libc.tmp, i.e. fprintf function. -?X: When we know which sed command to use, do the name extraction -?X: -$grep fprintf libc.tmp > libc.ptf -?X: -?X: In order to ehance readability and save some space, we define -?X: some variables that will be "eval"ed. -?X: -xscan='eval "<libc.ptf $com >libc.list"; $echo $n ".$c" >&4' -xrun='eval "<libc.tmp $com >libc.list"; echo "done" >&4' -?X: BSD-like output -if com="$sed -n -e 's/^.* [ADTS] *_[_.]*//p' -e 's/^.* [ADTS] //p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -?X: SYSV-like output -elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \ - -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -?X: mips nm output (sysV) -elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -else - nm -p $* 2>/dev/null >libc.tmp - com="$sed -n -e 's/^.* [ADTS] *_[_.]*//p' -e 's/^.* [ADTS] //p'";\ - eval "<libc.tmp $com >libc.list" - if $contains '^fprintf$' libc.list >/dev/null 2>&1; then - nm_opt='-p' - echo "done" >&4 - else - echo " " - echo "nm didn't seem to work right. Trying ar instead..." >&4 - com='' - if ar t $libc > libc.tmp; then - for thisname in $libnames; do - ar t $thisname >>libc.tmp - done - $sed -e 's/\.o$//' < libc.tmp > libc.list - echo "Ok." >&4 - else - echo "ar didn't seem to work right." >&4 - echo "Maybe this is a Cray...trying bld instead..." >&4 - if bld t $libc | $sed -e 's/.*\///' -e 's/\.o:.*$//' > libc.list; then - for thisname in $libnames; do - bld t $libnames | \ - $sed -e 's/.*\///' -e 's/\.o:.*$//' >>libc.list - ar t $thisname >>libc.tmp - done - echo "Ok." >&4 - else - echo "That didn't work either. Giving up." >&4 - exit 1 - fi - fi - fi -fi -nm_extract="$com" -if $test -f /lib/syscalls.exp; then - echo " " - echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4 - $sed -n 's/^\([^ ]*\)[ ]*syscall$/\1/p' /lib/syscalls.exp >>libc.list -fi -?X: remember, indentation is wrong on purpose--RAM -;; -esac -$rm -f libnames libpath - diff --git a/U/libpth.U b/U/libpth.U deleted file mode 100644 index 2c030c296c..0000000000 --- a/U/libpth.U +++ /dev/null @@ -1,74 +0,0 @@ -?RCS: $Id: libpth.U,v 3.0 1993/08/18 12:09:02 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: libpth.U,v $ -?RCS: Revision 3.0 1993/08/18 12:09:02 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?X: -?X: This unit initializes the path for C library lookup. -?X: -?MAKE:libpth xlibpth plibpth: mips incpath test cat Myread -?MAKE: -pick add $@ %< -?S:libpth: -?S: This variable holds the general path used to find libraries. It is -?S: intended to be used by other units. -?S:. -?S:plibpth: -?S: Holds the private path used by Configure to find out the libraries. -?S: Its value is prepended to libpth. This variable takes care of special -?S: machines, like the mips. Usually, it should be empty. -?S:. -?T: xxx yyy -?INIT:: change the next line if compiling for Xenix/286 on Xenix/386 -?INIT:xlibpth='/usr/lib/386 /lib/386' -?INIT: -?INIT:: general looking path for locating libraries -?INIT:libpth="/usr/lib/large /lib /usr/lib $xlibpth /lib/large" -?INIT:libpth="$libpth /usr/lib/small /lib/small" -?INIT:libpth="$libpth /usr/ccs/lib /usr/ucblib /usr/local/lib" -?INIT: -?INIT:: Private path used by Configure to find libraries. Its value -?INIT:: is prepend to libpth. This variable takes care of special -?INIT:: machines, like the mips. Usually, it should be empty. -?INIT:plibpth='' -?INIT: -?LINT:describe xlibpth -?LINT:use mips -: Set private lib path -case "$plibpth" in -'') if mips; then -?X: on mips, we DO NOT want /lib, and we want $incpath/usr/lib - plibpth="$incpath/usr/lib /usr/local/lib /usr/ccs/lib" - fi;; -esac -libpth="$plibpth $libpth" -: Now check and see which directories actually exist. -xxx='' -for yyy in $libpth -do - if $test -d $yyy; then - xxx="$xxx $yyy" - fi -done -libpth="$xxx" -$cat <<EOM -Some systems have incompatible or broken versions of libraries. Where -should I look for libraries? -EOM - -dflt="$libpth" -echo " " -rp="Directories to use for library searches?" -. ./myread -case "$ans" in -none) libpth=' ';; -*) libpth="$ans";; -esac diff --git a/U/libs.U b/U/libs.U deleted file mode 100644 index 45625abc1b..0000000000 --- a/U/libs.U +++ /dev/null @@ -1,131 +0,0 @@ -?RCS: $Id: libs.U,v 3.0.1.1 1993/08/25 14:02:31 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: libs.U,v $ -?RCS: Revision 3.0.1.1 1993/08/25 14:02:31 ram -?RCS: patch6: added default for libs -?RCS: -?RCS: Revision 3.0 1993/08/18 12:09:03 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:libs: test cat Myread Oldconfig Loc libpth package xlibpth -?MAKE: -pick add $@ %< -?S:libs: -?S: This variable holds the additional libraries we want to use. -?S: It is up to the Makefile to deal with it. -?S:. -?T:xxx yyy zzz thislib thatlib libswanted -?D:libs='' -?X: -?X: This order is chosen so that libraries -lndir, -ldir, -lucb, -lbsd, -?X: -lBSD, -lPW, and -lx only get used if there are unresolved -?X: routines at link time. Usually, these are backwards compatability -?X: libraries, and may not be as reliable as the standard c library. -?X: -?X: The -lsocket -linet -lnsl order has been reported to be necessary -?X: for at least one SVR4 implementation. -?X: -?X: The ordering of c_s, posix, and cposix is a guess and almost -?X: certainly wrong on about half of all systems. -?X: -?X: The extra space at the beginning and end is for some old hints -?X: files which assumed there was always a space around each library. -?X: -?INIT:libswanted=" net socket inet nsl nm sdbm gdbm ndbm dbm malloc dl dld sun m c_s posix cposix ndir dir ucb bsd BSD PW x " -?INIT: -: Looking for optional libraries -echo " " -echo "Checking for optional libraries..." >&4 -case "$libs" in -' '|'') dflt='';; -*) dflt="$libs";; -esac -case "$libswanted" in -'') libswanted='c_s';; -esac -for thislib in $libswanted; do - case "$thislib" in - dbm) thatlib=ndbm;; - *_s) thatlib=NONE;; - *) thatlib=${thislib}_s;; - esac - xxx=`./loc lib$thislib.a X $libpth` - yyy=`./loc lib$thatlib.a X $libpth` - zzz=`./loc lib$thislib.so.[0-9]'*' X $libpth` - if $test -f $xxx; then - echo "Found -l$thislib." - case "$dflt" in - *"-l$thislib "*|*-l$thislib|*"-l$thatlib "*|*-l$thatlib) ;; - *) dflt="$dflt -l$thislib";; - esac - elif $test -f $yyy; then - echo "Found -l$thatlib." - case "$dflt" in - *"-l$thatlib "*|*-l$thatlib) ;; - *) dflt="$dflt -l$thatlib";; - esac - elif $test -f $zzz; then - echo "Found -$thislib." - case "$dflt" in - *"-l$thislib "*|*-l$thislib) ;; - *) dflt="$dflt -l$thislib";; - esac - else - xxx=`./loc Slib$thislib.a X $xlibpth` - yyy=`./loc Slib$thatlib.a X $xlibpth` - if $test -f $xxx; then - echo "Found -l$thislib." - case "$dflt" in - *"-l$thislib "*|*-l$thislib|*"-l$thatlib "*|*-l$thatlib) ;; - *) dflt="$dflt -l$thislib";; - esac - elif $test -f $yyy; then - echo "Found -l$thatlib." - case "$dflt" in - *"-l$thatlib "*|*-l$thatlib) ;; - *) dflt="$dflt -l$thatlib";; - esac - else - echo "No -l$thislib." - fi - fi -done -set X $dflt -shift -dflt="$*" -case "$libs" in -'') dflt="$dflt";; -*) dflt="$libs";; -esac -case "$dflt" in -' '|'') dflt='none';; -esac - -$cat <<EOM - -Some versions of Unix support shared libraries, which make executables smaller -but make load time slightly longer. - -On some systems, mostly newer Unix System V's, the shared library is included -by putting the option "-lc_s" as the last thing on the cc command line when -linking. Other systems use shared libraries by default. There may be other -libraries needed to compile $package on your machine as well. If your system -needs the "-lc_s" option, include it here. Include any other special libraries -here as well. Say "none" for none. -EOM - -echo " " -rp="Any additional libraries?" -. ./myread -case "$ans" in -none) libs=' ';; -*) libs="$ans";; -esac - diff --git a/U/libyacc.U b/U/libyacc.U deleted file mode 100644 index c12e5a5ad1..0000000000 --- a/U/libyacc.U +++ /dev/null @@ -1,60 +0,0 @@ -?RCS: $Id: libyacc.U,v 3.0.1.1 1994/01/24 14:13:49 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: libyacc.U,v $ -?RCS: Revision 3.0.1.1 1994/01/24 14:13:49 ram -?RCS: patch16: un-obsoleted this unit for smooth yacc compilations -?RCS: -?RCS: Revision 3.0 1993/08/18 12:09:04 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:libyacc: Loc yacc libpth test -?MAKE: -pick add $@ %< -?S:libyacc: -?S: This variable contains the argument to pass to the loader in order -?S: to get the yacc library routines. If there is no yacc or yacc -?S: library, it is null. -?S:. -?T:xxx -: see if we should include -ly -echo " " -case "$yacc" in -*byacc*) - echo "You are using byacc, so I won't look for a yacc library." >&4 - libyacc='' - ;; -*yacc) - if $test -r /usr/lib/liby.a || $test -r /usr/local/lib/liby.a ; then - echo "-ly found." >&4 - libyacc='-ly' - else - xxx=`./loc liby.a x $libpth` - case "$xxx" in - x) - echo "No yacc library found." >&4 - libyacc='' - ;; - *) - echo "yacc library found in $xxx." >&4 - libyacc="$xxx" - ;; - esac - fi - ;; -*bison*) - echo "You are using bison, so I won't look for a yacc library." >&4 - libyacc='' - ;; -*) -echo "You don't seem to have yacc, so I won't look for the yacc library." >&4 - libyacc='' - ;; -esac - diff --git a/U/lns.U b/U/lns.U deleted file mode 100644 index fcefb1fa32..0000000000 --- a/U/lns.U +++ /dev/null @@ -1,21 +0,0 @@ -?RCS: $Id: lns.U,v $ -?RCS: -?RCS: $Log: lns.U,v $ -?RCS: -?MAKE:lns: ln touch -?MAKE: -pick add $@ %< -?S:lns: -?S: This variable holds the name of the command to make -?S: symbolic links (if they are supported). It can be used -?S: in the Makefile. It is either 'ln -s' or 'ln' -?S:. -?X: We can't rely on d_symlink because that may be listed in the -?X: C library but unimplemented. -: determine whether symbolic links are supported -$touch blurfl -if $ln -s blurfl sym > /dev/null 2>&1 ; then - lns="$ln -s" -else - lns="$ln" -fi -rm -f blurfl sym diff --git a/U/loc_sed.U b/U/loc_sed.U deleted file mode 100644 index 9eb8b21e14..0000000000 --- a/U/loc_sed.U +++ /dev/null @@ -1,10 +0,0 @@ -?RCS: $Id: loc_sed.U,v $ -?RCS: -?MAKE:: sed -?MAKE: -pick add $@ %< -?C:LOC_SED: -?C: This symbol holds the complete pathname to the sed program. -?C:. -?H:#define LOC_SED "$sed" /**/ -?H:. -?X: This is used in perl.c. diff --git a/U/mallocsrc.U b/U/mallocsrc.U deleted file mode 100644 index 9fd5382533..0000000000 --- a/U/mallocsrc.U +++ /dev/null @@ -1,108 +0,0 @@ -?RCS: $Id: mallocsrc.U,v 3.0 1993/08/18 12:09:12 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: mallocsrc.U,v $ -?RCS: Revision 3.0 1993/08/18 12:09:12 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:mallocsrc mallocobj usemymalloc malloctype d_mymalloc: Myread Oldconfig package \ - Guess Setvar test rm cat +cc +ccflags Findhdr -?MAKE: -pick add $@ %< -?S:usemymalloc: -?S: This variable contains y if the malloc that comes with this package -?S: is desired over the system's version of malloc. People often include -?S: special versions of malloc for effiency, but such versions are often -?S: less portable. See also mallocsrc and mallocobj. -?S:. -?S:mallocsrc: -?S: This variable contains the name of the malloc.c that comes with -?S: the package, if that malloc.c is preferred over the system malloc. -?S: Otherwise the value is null. This variable is intended for generating -?S: Makefiles. -?S:. -?S:d_mymalloc: -?S: This variable conditionally defines MYMALLOC in case other parts -?S: of the source want to take special action if MYMALLOC is used. -?S: This may include different sorts of profiling or error detection. -?S:. -?S:mallocobj: -?S: This variable contains the name of the malloc.o that this package -?S: generates, if that malloc.o is preferred over the system malloc. -?S: Otherwise the value is null. This variable is intended for generating -?S: Makefiles. See mallocsrc. -?S:. -?S:malloctype: -?S: This variable contains the kind of ptr returned by malloc and realloc. -?S:. -?C:Malloc_t (MALLOCPTRTYPE): -?C: This symbol is the type of pointer returned by malloc and realloc. -?C:. -?H:#define Malloc_t $malloctype /**/ -?H:. -?C:MYMALLOC: -?C: This symbol, if defined, indicates that we're using our own malloc. -?C:. -?H:#$d_mymalloc MYMALLOC /**/ -?H:. -?X: Cannot test for mallocsrc; it is the unit's name and there is a bug in -?X: the interpreter which defines all the names, even though they are not used. -@if mallocobj -: determine which malloc to compile in -: Old versions had dflt='y' only for bsd or v7. -echo " " -case "$usemymalloc" in -'') - if bsd || v7; then - dflt='y' - else - dflt='y' - fi - ;; -*) dflt="$usemymalloc" - ;; -esac -rp="Do you wish to attempt to use the malloc that comes with $package?" -. ./myread -usemymalloc="$ans" -case "$ans" in -y*) mallocsrc='malloc.c' - mallocobj='malloc.o' - d_mymalloc="$define" - ;; -*) mallocsrc='' - mallocobj='' - d_mymalloc="$undef" - ;; -esac -@end - -@if MALLOCPTRTYPE || Malloc_t -: compute the type returned by malloc -echo " " -case "$malloctype" in -'') - if $test `./findhdr malloc.h`; then - echo "#include <malloc.h>" > malloc.c - fi -#include <malloc.h> - $cat >>malloc.c <<'END' -void *malloc(); -END - if $cc $ccflags -c malloc.c >/dev/null 2>&1; then - malloctype='void *' - else - malloctype='char *' - fi - $rm -f malloc.[co] - ;; -esac -echo "Your system wants malloc to return '$malloctype', it would seem." >&4 - -@end diff --git a/U/prototype.U b/U/prototype.U deleted file mode 100644 index b0332f5655..0000000000 --- a/U/prototype.U +++ /dev/null @@ -1,115 +0,0 @@ -?RCS: $Id: prototype.U,v 3.0.1.2 1994/01/24 14:15:36 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: prototype.U,v $ -?RCS: Revision 3.0.1.2 1994/01/24 14:15:36 ram -?RCS: patch16: prototype handling macros now appear only when needed -?RCS: -?RCS: Revision 3.0.1.1 1993/08/25 14:03:12 ram -?RCS: patch6: defines were referring to non-existent VOID symbol -?RCS: -?RCS: Revision 3.0 1993/08/18 12:09:36 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:prototype: Myread Oldconfig cat +cc rm Setvar -?MAKE: -pick add $@ %< -?S:prototype: -?S: This variable holds the eventual value of CAN_PROTOTYPE, which -?S: indicates the C compiler can handle funciton prototypes. -?S:. -?C:CAN_PROTOTYPE ~ %<: -?C: If defined, this macro indicates that the C compiler can handle -?C: function prototypes. -?C:. -?C:DOTS: -?C: This macro is used to specify the ... in function prototypes which -?C: have arbitrary additional arguments. -?C:. -?C:NXT_ARG: -?C: This macro is used to separate arguments in the declared argument list. -?C:. -?C:P_FUNC: -?C: This macro is used to declare "private" (static) functions. -?C: It takes three arguments: the function type and name, a parenthesized -?C: traditional (comma separated) argument list, and the declared argument -?C: list (in which arguments are separated with NXT_ARG, and additional -?C: arbitrary arguments are specified with DOTS). For example: -?C: -?C: P_FUNC(int foo, (bar, baz), int bar NXT_ARG char *baz[]) -?C:. -?C:P_FUNC_VOID: -?C: This macro is used to declare "private" (static) functions that have -?C: no arguments. The macro takes one argument: the function type and name. -?C: For example: -?C: -?C: P_FUNC_VOID(int subr) -?C:. -?C:V_FUNC: -?C: This macro is used to declare "public" (non-static) functions. -?C: It takes three arguments: the function type and name, a parenthesized -?C: traditional (comma separated) argument list, and the declared argument -?C: list (in which arguments are separated with NXT_ARG, and additional -?C: arbitrary arguments are specified with DOTS). For example: -?C: -?C: V_FUNC(int main, (argc, argv), int argc NXT_ARG char *argv[]) -?C:. -?C:V_FUNC_VOID: -?C: This macro is used to declare "public" (non-static) functions that have -?C: no arguments. The macro takes one argument: the function type and name. -?C: For example: -?C: -?C: V_FUNC_VOID(int fork) -?C:. -?C:P: -?C: This macro is used to declare function parameters for folks who want -?C: to make declarations with prototypes using a different style than -?C: the above macros. Use double parentheses. For example: -?C: -?C: int main P((int argc, char *argv[])); -?C:. -?H:?%<:#$prototype CAN_PROTOTYPE /**/ -?H:?%<:#ifdef CAN_PROTOTYPE -?H:?NXT_ARG:#define NXT_ARG , -?H:?DOTS:#define DOTS , ... -?H:?V_FUNC:#define V_FUNC(name, arglist, args)name(args) -?H:?P_FUNC:#define P_FUNC(name, arglist, args)static name(args) -?H:?V_FUNC_VOID:#define V_FUNC_VOID(name)name(void) -?H:?P_FUNC_VOID:#define P_FUNC_VOID(name)static name(void) -?H:?P:#define P(args) args -?H:?%<:#else -?H:?NXT_ARG:#define NXT_ARG ; -?H:?DOTS:#define DOTS -?H:?V_FUNC:#define V_FUNC(name, arglist, args)name arglist args; -?H:?P_FUNC:#define P_FUNC(name, arglist, args)static name arglist args; -?H:?V_FUNC_VOID:#define V_FUNC_VOID(name)name() -?H:?P_FUNC_VOID:#define P_FUNC_VOID(name)static name() -?H:?P:#define P(args) () -?H:?%<:#endif -?H:. -?W:%<:NXT_ARG DOTS V_FUNC P_FUNC V_FUNC_VOID P_FUNC_VOID _ -?LINT:set prototype -: Cruising for prototypes -echo " " -echo "Checking out function prototypes..." >&4 -$cat >prototype.c <<'EOCP' -main(int argc, char *argv[]) { - exit(0);} -EOCP -if $cc -c prototype.c >prototype.out 2>&1 ; then - echo "Your C compiler appears to support function prototypes." - val="$define" -else - echo "Your C compiler doesn't seem to understand function prototypes." - val="$undef" -fi -set prototype -eval $setvar -$rm -f prototype* - diff --git a/U/sig_name.U b/U/sig_name.U deleted file mode 100644 index 9b3f9e3440..0000000000 --- a/U/sig_name.U +++ /dev/null @@ -1,86 +0,0 @@ -?RCS: $Id: sig_name.U,v 3.0 1993/08/18 12:09:47 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: sig_name.U,v $ -?RCS: Revision 3.0 1993/08/18 12:09:47 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:sig_name: awk rm Findhdr -?MAKE: -pick add $@ %< -?S:sig_name: -?S: This variable holds the signal names, space separated. The leading -?S: SIG in signals name is removed. -?S:. -?C:SIG_NAME: -?C: This symbol contains a list of signal names in order. This is intended -?C: to be used as a static array initialization, like this: -?C: char *sig_name[] = { SIG_NAME }; -?C: The signals in the list are separated with commas, and each signal -?C: is surrounded by double quotes. There is no leading SIG in the signal -?C: name, i.e. SIGQUIT is known as "QUIT". -?C:. -?H:#define SIG_NAME "`echo $sig_name | sed 's/ /","/g'`" /**/ -?H:. -?T:xxx -: generate list of signal names -echo " " -case "$sig_name" in -'') - echo "Generating a list of signal names..." >&4 - xxx=`./findhdr signal.h`" "`./findhdr sys/signal.h` - set X `cat $xxx 2>&1 | $awk ' -$1 ~ /^#define$/ && $2 ~ /^SIG[A-Z0-9]*$/ && $3 ~ /^[1-9][0-9]*$/ { - sig[$3] = substr($2,4,20) - if (max < $3 && $3 < 60) { - max = $3 - } -} - -END { - for (i = 1; i <= max; i++) { - if (sig[i] == "") - printf "%d", i - else - printf "%s", sig[i] - if (i < max) - printf " " - } - printf "\n" -} -'` - shift - case $# in - 0) - echo 'kill -l' >/tmp/foo$$ - set X `csh -f </tmp/foo$$` - $rm -f /tmp/foo$$ - shift - case $# in - 0)set HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM - ;; - esac - ;; - esac - sig_name="ZERO $*" - ;; -esac -echo "The following signals are available:" -echo $sig_name | - $awk 'BEGIN { linelen = 0 } - { for (i = 1; i < NF; i++) - { - name = "SIG" $i " " - linelen = linelen + length(name) - if (linelen > 70) - { - printf "\n" - linelen = length(name) - } - printf "%s", name } }' diff --git a/U/voidflags.U b/U/voidflags.U deleted file mode 100644 index 7d9a0d06ba..0000000000 --- a/U/voidflags.U +++ /dev/null @@ -1,148 +0,0 @@ -?RCS: $Id: voidflags.U,v 3.0 1993/08/18 12:10:01 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: voidflags.U,v $ -?RCS: Revision 3.0 1993/08/18 12:10:01 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:voidflags defvoidused: cat rm contains cc package Oldconfig Myread -?MAKE: -pick add $@ %< -?S:voidflags: -?S: This variable contains the eventual value of the VOIDFLAGS symbol, -?S: which indicates how much support of the void type is given by this -?S: compiler. See VOIDFLAGS for more info. -?S:. -?X: Exceptionally, we have to explicitely alias the symbol name for -?X: config_h.SH, otherwise the comment would not appear. -?C:VOIDFLAGS ~ %<: -?C: This symbol indicates how much support of the void type is given by this -?C: compiler. What various bits mean: -?C: -?C: 1 = supports declaration of void -?C: 2 = supports arrays of pointers to functions returning void -?C: 4 = supports comparisons between pointers to void functions and -?C: addresses of void functions -?C: 8 = suports declaration of generic void pointers -?C: -?C: The package designer should define VOIDUSED to indicate the requirements -?C: of the package. This can be done either by #defining VOIDUSED before -?C: including config.h, or by defining defvoidused in Myinit.U. If the -?C: latter approach is taken, only those flags will be tested. If the -?C: level of void support necessary is not present, defines void to int. -?C:. -?H:?%<:#ifndef VOIDUSED -?H:?%<:# define VOIDUSED $defvoidused -?H:?%<:#endif -?H:?%<:#define VOIDFLAGS $voidflags -?H:?%<:#if (VOIDFLAGS & VOIDUSED) != VOIDUSED -?H:?%<:# define void int /* is void to be avoided? */ -?H:?%<:# define M_VOID /* Xenix strikes again */ -?H:?%<:# define VOID -?H:?%<:#else -?H:?%<:# define VOID void -?H:?%<:#endif -?H:. -?W:%<:void VOID VOIDUSED -?INIT:: full support for void wanted by default -?INIT:defvoidused=15 -?INIT: -?LINT:describe defvoidused -?LINT:known void M_VOID VOIDUSED -: check for void type -echo " " -$cat >&4 <<EOM -Checking to see how well your C compiler groks the void type... - - Support flag bits are: - 1: basic void declarations. - 2: arrays of pointers to functions returning void. - 4: operations between pointers to and addresses of void functions. - 8: generic void pointers. - -EOM -case "$voidflags" in -'') - $cat >try.c <<'EOCP' -#if TRY & 1 -void main() { -#else -main() { -#endif - extern void moo(); /* function returning void */ - void (*goo)(); /* ptr to func returning void */ -#if TRY & 8 - void *hue; /* generic ptr */ -#endif -#if TRY & 2 - void (*foo[10])(); -#endif - -#if TRY & 4 - if(goo == moo) { - exit(0); - } -#endif - exit(0); -} -EOCP -?X: This unit used to use cc -S in those tests to try to speed up things, but -?X: unfortunately, AIX 3.2 does not support this option. - if $cc -c -DTRY=$defvoidused try.c >.out 2>&1 ; then - voidflags=$defvoidused - echo "It appears to support void to the level $package wants ($defvoidused)." - if $contains warning .out >/dev/null 2>&1; then - echo "However, you might get some warnings that look like this:" - $cat .out - fi - else -echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 - if $cc -c -DTRY=1 try.c >/dev/null 2>&1 ; then - echo "It supports 1..." - if $cc -c -DTRY=3 try.c >/dev/null 2>&1 ; then - echo "It also supports 2..." - if $cc -c -DTRY=7 try.c >/dev/null 2>&1 ; then - voidflags=7 - echo "And it supports 4 but not 8 definitely." - else - echo "It doesn't support 4..." - if $cc -c -DTRY=11 try.c >/dev/null 2>&1 ; then - voidflags=11 - echo "But it supports 8." - else - voidflags=3 - echo "Neither does it support 8." - fi - fi - else - echo "It does not support 2..." - if $cc -c -DTRY=13 try.c >/dev/null 2>&1 ; then - voidflags=13 - echo "But it supports 4 and 8." - else - if $cc -c -DTRY=5 try.c >/dev/null 2>&1 ; then - voidflags=5 - echo "And it supports 4 but has not heard about 8." - else - echo "However it supports 8 but not 4." - fi - fi - fi - else - echo "There is no support at all for void." - voidflags=0 - fi - fi -esac -dflt="$voidflags"; -rp="Your void support flags add up to what?" -. ./myread -voidflags="$ans" -$rm -f try.* .out - diff --git a/U/yacc.U b/U/yacc.U deleted file mode 100644 index 679970c34e..0000000000 --- a/U/yacc.U +++ /dev/null @@ -1,81 +0,0 @@ -?RCS: $Id: yacc.U,v 3.0 1993/08/18 12:10:03 ram Exp $ -?RCS: -?RCS: Copyright (c) 1991-1993, Raphael Manfredi -?RCS: -?RCS: You may redistribute only under the terms of the Artistic Licence, -?RCS: as specified in the README file that comes with the distribution. -?RCS: You may reuse parts of this distribution only within the terms of -?RCS: that same Artistic Licence; a copy of which may be found at the root -?RCS: of the source tree for dist 3.0. -?RCS: -?RCS: $Log: yacc.U,v $ -?RCS: Revision 3.0 1993/08/18 12:10:03 ram -?RCS: Baseline for dist 3.0 netwide release. -?RCS: -?MAKE:yacc yaccflags: Guess Myread Oldconfig byacc bison cat test package -?MAKE: -pick add $@ %< -?S:yacc: -?S: This variable holds the name of the compiler compiler we -?S: want to use in the Makefile. It can be yacc, byacc, or bison -y. -?S:. -?S:yaccflags: -?S: This variable contains any additional yacc flags desired by the -?S: user. It is up to the Makefile to use this. -?S:. -: determine compiler compiler -case "$yacc" in -'') - dflt=yacc;; -*) - dflt="$yacc";; -esac -echo " " -rp="yacc" -if $test -f "$byacc"; then - dflt="$byacc" - rp="byacc or $rp" -fi -if $test -f "$bison"; then - rp="$rp or bison -y" -fi -$cat <<EOM -$package no longer requires a compiler compiler, so the following is optional. -EOM -rp="Which compiler compiler ($rp) shall I use?" -. ./myread -yacc="$ans" -case "$yacc" in -*bis*) - case "$yacc" in - *-y*) ;; - *) - yacc="$yacc -y" - echo "(Adding -y option to bison to get yacc-compatible behaviour.)" - ;; - esac - ;; -esac - -@if yaccflags -: see if we need extra yacc flags -dflt="$yaccflags" -case "$dflt" in -'') dflt=none;; -esac -$cat <<EOH - -Your yacc program may need extra flags to normally process the parser sources. -Do NOT specify any -d or -v flags here, since those are explicitely known -by the various Makefiles. However, if your machine has strange/undocumented -options (like -Sr# on SCO to specify the maximum number of grammar rules), then -please add them here. To use no flags, specify the word "none". - -EOH -rp="Any additional yacc flags?" -. ./myread -case "$ans" in -none) yaccflags='';; -*) yaccflags="$ans";; -esac - -@end diff --git a/Wanted b/Wanted deleted file mode 100644 index 4bc9551d08..0000000000 --- a/Wanted +++ /dev/null @@ -1,361 +0,0 @@ -!>CHARVSPRINTF -!>GIDTYPE -!>HAS_GDBM -!>SAFE_BCOPY -!>STATBLOCKS -!>STDSTDIO -!>UIDTYPE ->ALIGNBYTES ->BIN ->BSD ->BYTEORDER ->CASTFLAGS ->CASTI32 ->CASTNEGFLOAT ->CHARSPRINTF ->CPPMINUS ->CPPSTDIN ->CSH ->DIRNAMLEN ->DOSUID ->EUNICE ->FLEXFILENAMES ->F_OK ->GROUPSTYPE ->Gid_t ->HASVOLATILE ->HAS_BCMP ->HAS_BCOPY ->HAS_BZERO ->HAS_CHSIZE ->HAS_CRYPT ->HAS_DUP2 ->HAS_FCHMOD ->HAS_FCHOWN ->HAS_FCNTL ->HAS_FLOCK ->HAS_GETGROUPS ->HAS_GETHOSTENT ->HAS_GETPGRP ->HAS_GETPGRP2 ->HAS_GETPRIORITY ->HAS_HTONL ->HAS_HTONS ->HAS_ISASCII ->HAS_KILLPG ->HAS_LINK ->HAS_LSTAT ->HAS_MEMCMP ->HAS_MEMCPY ->HAS_MEMMOVE ->HAS_MEMSET ->HAS_MKDIR ->HAS_MSG ->HAS_MSGCTL ->HAS_MSGGET ->HAS_MSGRCV ->HAS_MSGSND ->HAS_NTOHL ->HAS_NTOHS ->HAS_OPEN3 ->HAS_READDIR ->HAS_RENAME ->HAS_RMDIR ->HAS_SAFE_BCOPY ->HAS_SAFE_MEMCPY ->HAS_SELECT ->HAS_SEM ->HAS_SEMCTL ->HAS_SEMGET ->HAS_SEMOP ->HAS_SETEGID ->HAS_SETEUID ->HAS_SETLOCALE ->HAS_SETPGID ->HAS_SETPGRP ->HAS_SETPGRP2 ->HAS_SETPRIORITY ->HAS_SETREGID ->HAS_SETRESGID ->HAS_SETRESUID ->HAS_SETREUID ->HAS_SETRGID ->HAS_SETRUID ->HAS_SETSID ->HAS_SHM ->HAS_SHMAT ->HAS_SHMCTL ->HAS_SHMDT ->HAS_SHMGET ->HAS_SOCKET ->HAS_SOCKETPAIR ->HAS_STRERROR ->HAS_SYMLINK ->HAS_SYSCALL ->HAS_SYSTEM ->HAS_SYS_ERRLIST ->HAS_TIMES ->HAS_TRUNCATE ->HAS_UNAME ->HAS_VFORK ->HAS_VPRINTF ->HAS_WAIT4 ->HAS_WAITPID ->INTSIZE ->I_DBM ->I_DIRENT ->I_FCNTL ->I_GDBM ->I_GRP ->I_NDBM ->I_NDIR ->I_NETINET_IN ->I_PWD ->I_STDARG ->I_STDDEF ->I_SYS_DIR ->I_SYS_FILE ->I_SYS_IN ->I_SYS_IOCTL ->I_SYS_NDIR ->I_SYS_SELECT ->I_SYS_TIME ->I_TIME ->I_UTIME ->I_VARARGS ->I_VFORK ->Malloc_t ->O_APPEND ->O_CREAT ->O_EXCL ->O_RDONLY ->O_RDWR ->O_TRUNC ->O_WRONLY ->PRIVLIB ->PWAGE ->PWCHANGE ->PWCLASS ->PWCOMMENT ->PWEXPIRE ->PWQUOTA ->RANDBITS ->R_OK ->SCRIPTDIR ->SIG_NAME ->STDCHAR ->Strerror ->USE_CHAR_VSPRINTF ->USE_OLDSOCKET ->USE_STAT_BLOCKS ->USE_STD_STDIO ->USE_STRUCT_COPY ->Uid_t ->VMS ->VOID ->VOIDSIG ->VOIDWANT ->W_OK ->X_OK ->_ ->bcmp ->bcopy ->bzero ->const ->dlopen ->getgroups ->index ->rindex ->va_dcl ->vfork ->void ->volatile -Date -Log -RCSfile -Revision -alignbytes -bin -byacc -byteorder -c -castflags -cat -cc -ccflags -cp -cppflags -cppminus -cppstdin -cryptlib -csh -d_access -d_bcmp -d_bcopy -d_bsd -d_bzero -d_casti32 -d_castneg -d_charsprf -d_charvspr -d_chsize -d_const -d_crypt -d_csh -d_dirnamlen -d_dosuid -d_dup2 -d_eunice -d_fchmod -d_fchown -d_fcntl -d_flexfnam -d_flock -d_gethent -d_getpgrp -d_getpgrp2 -d_getprior -d_htonl -d_isascii -d_killpg -d_link -d_lstat -d_memcmp -d_memcpy -d_memmove -d_memset -d_mkdir -d_msg -d_msgctl -d_msgget -d_msgrcv -d_msgsnd -d_oldsock -d_open3 -d_pwage -d_pwchange -d_pwclass -d_pwcomment -d_pwexpire -d_pwquota -d_readdir -d_rename -d_rmdir -d_safebcpy -d_safemcpy -d_select -d_sem -d_semctl -d_semget -d_semop -d_setegid -d_seteuid -d_setlocale -d_setpgid -d_setpgrp -d_setpgrp2 -d_setprior -d_setregid -d_setresgid -d_setresuid -d_setreuid -d_setrgid -d_setruid -d_setsid -d_shm -d_shmat -d_shmctl -d_shmdt -d_shmget -d_socket -d_sockpair -d_statblks -d_stdstdio -d_strchr -d_strctcpy -d_strerrm -d_strerror -d_symlink -d_syscall -d_syserrlst -d_system -d_times -d_truncate -d_uname -d_vfork -d_voidsig -d_volatile -d_vprintf -d_wait4 -d_waitpid -dlobj -dlsrc -echo -egrep -eunicefix -expr -extensions -find -gidtype -groupstype -i_dbm -i_dirent -i_fcntl -i_gdbm -i_grp -i_ndbm -i_ndir -i_niin -i_pwd -i_stdarg -i_stddef -i_sysdir -i_sysfile -i_sysin -i_sysioctl -i_sysndir -i_sysselct -i_systime -i_time -i_utime -i_varargs -i_varhdr -i_vfork -installbin -installprivlib -intsize -large -ldflags -lib -libs -line -mallocobj -mallocsrc -malloctype -manext -mansrc -mkdir -mv -n -optimize -perl -privlib -prototype -randbits -rm -scriptdir -sed -sig_name -small -sort -spitshell -split -startsh -stdchar -test -tr -uidtype -uname -uniq -voidflags -yacc @@ -1 +1,22 @@ -#define ST(s) stack_base[ax + s] +#define ST(off) stack_base[ax + off] + +#ifdef CAN_PROTOTYPE +#define XS(name) void name(CV* cv) +#else +#define XS(name) void name(cv) CV* cv; +#endif + +#define dXSARGS \ + dSP; dMARK; \ + I32 ax = mark - stack_base + 1; \ + I32 items = sp - mark + +#define XSANY CvXSUBANY(cv) + +#define dXSI32 I32 ix = XSANY.any_i32 + +#define XSRETURN(off) stack_sp = stack_base + ax + ((off) - 1); return + +#define XSRETURNNO ST(0)=sv_mortalcopy(&sv_no); XSRETURN(1) +#define XSRETURNYES ST(0)=sv_mortalcopy(&sv_yes); XSRETURN(1) +#define XSRETURNUNDEF ST(0)=sv_mortalcopy(&sv_undef); XSRETURN(1) diff --git a/atarist/FILES b/atarist/FILES deleted file mode 100644 index 752f8e2a9f..0000000000 --- a/atarist/FILES +++ /dev/null @@ -1,48 +0,0 @@ - -Shipping list for the perl 4.019 atariST port: - -perl.diffs contains diffs from the following perl 4.019 files: - - perl.h arg.h handy.h doarg.c doio.c eval.c malloc.c perl.c regcomp.c - str.c toke.c util.c - - the file `explain' contains a brief explaination of the diffs in - `perl.diffs' - -The following files are supplied whole (not as diffs) and replace files with -the same name from the perl 4.019 distribution: - - config.h usersub.c - -The following files are specific to this atariST port: - - atarist.c echo.c wildmat.c perlglob.c - makefile.sm makefile.st - -The following files are in usub/ - - makefile.st README.ATARI usersub.c acurses.mus - -The following files should be added to the perl 4.019 library: - - osbind.pl perldb.diff (diffs against perldb.pl in perl 4.019 lib) - -AtariST specific tests - - test/* - -Misc: - - FILES README.ST (read this) RESULTS (explains results of tests) - explain (explains perl.diffs) - -Some binary distributions will also contain: - perl.ttp uperl.a cperl.ttp (cursesperl) perld.ttp - (these are all buildable using the material above). - -If you are missing any of the files on this list, please mail me. Please -dont ask me to mail binaries. Some of the binaries are available at -various atari archives, including atari.archive.umich.edu in -atari/languages/perl4019.zoo. - - ++jrb bammi@cadence.com diff --git a/atarist/README.ST b/atarist/README.ST deleted file mode 100644 index 0d42ba0c6d..0000000000 --- a/atarist/README.ST +++ /dev/null @@ -1,186 +0,0 @@ -See: FILES for a shipping list of files in this archive. -See: explain for a brief explaination of the diffs in perl.diffs. - -Here is a port of perl 4.0 Patchlevel 19 to the atariST series.: - -Whats new since atariST perl 4.010 - - many minor problems fixed. - - - configuration cleaned up. - - - makefiles now have a uperl.a target, so that usub's can be - linked. (see usub/* to see how to make cursesperl) - - - perl will now compile and run correctly with or without - the malloc that comes with perl. - - - FILEs opened for write now correctly contain CR/LF unless - they are binmode'ed. - - - complete support for gemdos/xbios/bios calls. see osbind.pl - and osexample.pl on how to use this facility. - - - tracked perl to Patchlevel 19. - -known problems: - - $! still does'nt contain the correct value when there is no error. - i still have'nt been able to track this down. - -------------------------------------------------------------------------- - -Here is a port of perl 4.0 Patchlevel 10 to the atariST series. - -What you'll need: - - a decent shell (i use gulam for obvious reasons), other - highly recommended ones are bash 1.08/1.10, gemini/mufpel, okami, - microCsh, init from apratt for MiNT. avoid neodesk. avoid the - desktop like the plague. The shell should be setup to use - atari/mwc conventions for command lines and environment setup - and passing. (in gulam be sure to `set env_style mw'). - - - a decent set of file utils (ls, rm, mv, etc etc) in your $PATH. - if you dont have these, look on atari.archive. the gnuFileutils - are available there. - - - included here are echo and perlglob that you will need. - - - setting UNIXMODE is recommended but not required. If you are - going to run the perl tests, then set UNIXMODE to atleast - "/.,LAd", else you will get a lot of unnecessary failures. - (alternately you will have to go in and edit long path names. - get rid of things dealing with links, and rename paths - beginning with "/dev/..." etc) - - - if you are going to compile: you'll need gcc distribution, - (i used gcc-1.40 and libs at Patchlevel 73 initially. i - currently use gcc-2.1 and libs at Patchlevel 80). Also you will - need the port of gdbm (i used v1.5). you'll also need bison. - all these are available on atari.archive, in atari/gnustuff/tos - the diffs as enclosed in this kit assume you have gcc libs at - Patchlevel 80. - -Compiling: - - get and install gnu gdbm (i used v1.5 -- see README.ST in - the gdbm distribution on how to make the gdbm library). - - - get the perl kit at Patchlevel 19 - - - copy config.h usersub.c atarist.c echo.c wildmat.c perlglob.c - makefile.sm makefile.smd makefile.st makefile.std makefile.stm - - - apply the diffs in file `perl.diffs' using patch - - - decide which makefile you want to use: - makefile.st perl with gcc library malloc - makefile.sm perl with malloc that comes with perl - - - hit make -f <MAKEFILE>. (if you are not cross-compiling, - you'll have to adjust the makefile yourself -- watchout for - perly.fixer). - This will result in 3 executables, perl.ttp, perlglob.ttp - and echo.ttp. Put all these executables in a sub-directory - in your $PATH (and depending on your shell, issue a rehash). - (if you use makefile.std instead of makefile.st, the executable - will be called perld.ttp. this is perl compiled with - -DDEBUGGING) - -Compiling usubs: - see the files in usub/* and the makefile.st there. - -Testing: - - run perl from a decent shell. i use either gulam or bash - if you are going to be running from gulam, be sure to - set env_style mw - (this can be done automatically by including the above - line in the gulam.g startup file). bash always uses - atari/mwc conventions so you dont have to do anything special. - (if you run perl from the desktop, you are asking for trouble!) - - - you'll have to run the tests by hand. Almost all the tests - pass. You'll have to judge for yourself when a test fails - if it should have. I was able to explain all failures. If you - cant, ask me via mail. (one day i will cook up a script to - do this). - - - It helps to have all the gnu fileutils in your PATH here. - especially echo.ttp and perlglob.ttp. - - - Also a lot more tests will pass if you have UNIXMODE setup - i use "/.,LAd". If you dont use UNIXMODE, you'll have to hack - some of the tests. - - - You may have to fix up a few Pathnames in the tests if you - are cd'ing to a particular test sub-directory to run the tests. - - - Compare your tests with the results i got -- see file RESULTS. - -General: - - setenv PERLLIB to point at the subdirectory containing lib/* - (if you want PERLLIB to contain more than one path, seperate - them with commas) - - - UNIXMODE is supported not required. - - - Pipes are a little flakey sometimes, but mostly work fine. - Pipes, `prog` etc are much more efficient if you have set - the environment var TEMP to point to a ramdisk. Note, when - you set TEMP, it should contain *no* tailing backslash (or slash). - - - to force binary mode use "binmode FILE" - - - browse thru config.h to see whats supported - - - should MiNT'ize this much more. - - - avoid using the backtick (`commands`). Use 'open(FOO, "command |")' - and use the filehandle FOO as appro. - - - the command passed to system etc can contain - redirections of stdin/out, but system does not understand - fancy pipelines etc. - - - syscall() to make gemdos/bios/xbios are fully supported now. - (note: we dont use ioctl like messy-dos to do this, as we can do - real ioctl's on devices) - - - i still need to cons up the lineA stuff. - it should be just as easy to cons up aes/vdi outcalls too. imagine - graphics from perl!. - - - watch out for re-directions. TOS blows up if you try to - re-direct a re-directed handle. atari has greatly improved this - situation. hopefully, the next general release of TOS will contain - these fixes. - - - in the perl libs (particularly perldb.pl) you will - need to s?/dev/tty?/dev/console?. perl -d works just fine. - for instance: (for this to work, UNIXMODE should include the - 'd' option): -*** /home/bammi/etc/src/perl/lib/perldb.pl Tue Jun 11 17:40:17 1991 ---- perldb.pl Mon Oct 7 21:46:28 1991 -*************** -*** 49,56 **** - # - # - -! open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin -! open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout - select(OUT); - $| = 1; # for DB'OUT - select(STDOUT); ---- 49,56 ---- - # - # - -! open(IN, "</dev/console") || open(IN, "<&STDIN"); # so we don't dingle stdin -! open(OUT,">/dev/console") || open(OUT, ">&STDOUT"); # so we don't dongle stdout - select(OUT); - $| = 1; # for DB'OUT - select(STDOUT); - -cheers, --- -bang: uunet!cadence!bammi jwahar r. bammi -domain: bammi@cadence.com -GEnie: J.Bammi -CIS: 71515,155 diff --git a/atarist/RESULTS b/atarist/RESULTS deleted file mode 100644 index d2768908c2..0000000000 --- a/atarist/RESULTS +++ /dev/null @@ -1,120 +0,0 @@ -t/base: - -cond.t -if.t -lex.t -pat.t -term.t - -all of these pass. if you are running from this directory -make sure you have a file ..\Makefile for term.t to pass. - -================================= - -t/cmd: - -elsif.t -for.t -mod.t -subval.t -switch.t -while.t - -all of these passed. be sure to set UNIXMODE for these to pass. -make sure there is a file called ./TEST if you run in this sub-directory -for mod.t. - -================================= - -t/comp: - -cmdopt.t -decl.t -package.t -script.t -term.t -multiline.t - -all these work. if you are running in this subdir then cp perl.ttp ./perl -before running. - -cpp.t - fails. i need to fix for -P. -================================= - -t/io: - -if you are running in this subdir make sure: --- there is a file ../Makefile --- have a ./perl - -argv.t: 2 & 3 fail - `.....` with pipes will not work. redirections may (have'nt checked) - -dup.t: only 1 will pass. what the hell is the rest doing (the atari goes - into in infinite loop) - -pipe.t: fails. have to look into this. pipe() on the atari sort of -work most of the time. see gcc-lib/pipe.c - -print.t: all pass -tell.t: all pass -================================= - -t/lib: - -bit.t : pass -================================= - -t/op: - -append.t pass -array.t pass -auto.t pass -chop.t pass -cond.t pass -dbm.t -- cant possibly work with gdbm, it does'nt create .pag etc files -gdbm.t added new test to test gdbm based perl -delete.t pass -do.t pass -each.t pass -eval.t pass -exec.t 4,5,6 fail rest pass (obviously) -exp.t pass -flip.t pass -fork.t correctly fails -glob.t 1 fails rest pass (as i said dont depend on `....` to work on the ST) -goto.t 1,2 pass 3 fail (again because of `...`) -groups.t makes no sense on the ST -index.t pass -int.t pass -join.t pass -list.t pass -local.t pass -magic.t fail obviously -mkdir.t the failure is obvious, rest pass (our err strings dont match unix's) -oct.t pass -ord.t pass -pack.t pass -pat.t pass!!!! (works with lib malloc too now, yeah!) -push.t pass -range.t pass -read.t pass -regexp.t pass! (make sure re_tests is in cwd if running in cwd, and edit - path in regexp.t) -repeat.t pass -s.t pass -sleep.t pass -sort.t pass -split.t pass -sprintf.t pass -stat.t obvious ones fail, looks good -study.t pass -substr.t pass -time.t pass -undef.t pass -unshift.t pass -vec.t pass -write.t fail due to `...` -================================= - diff --git a/atarist/atarist.c b/atarist/atarist.c deleted file mode 100644 index 2d69c9db62..0000000000 --- a/atarist/atarist.c +++ /dev/null @@ -1,282 +0,0 @@ -/* - * random stuff for atariST - */ - -#include "EXTERN.h" -#include "perl.h" - -/* call back stuff, atari specific stuff below */ -/* Be sure to refetch the stack pointer after calling these routines. */ - -int -callback(subname, sp, gimme, hasargs, numargs) -char *subname; -int sp; /* stack pointer after args are pushed */ -int gimme; /* called in array or scalar context */ -int hasargs; /* whether to create a @_ array for routine */ -int numargs; /* how many args are pushed on the stack */ -{ - static ARG myarg[3]; /* fake syntax tree node */ - int arglast[3]; - - arglast[2] = sp; - sp -= numargs; - arglast[1] = sp--; - arglast[0] = sp; - - if (!myarg[0].arg_ptr.arg_str) - myarg[0].arg_ptr.arg_str = str_make("",0); - - myarg[1].arg_type = A_WORD; - myarg[1].arg_ptr.arg_stab = stabent(subname, FALSE); - - myarg[2].arg_type = hasargs ? A_EXPR : A_NULL; - - return do_subr(myarg, gimme, arglast); -} - -int -callv(subname, sp, gimme, argv) -char *subname; -register int sp; /* current stack pointer */ -int gimme; /* called in array or scalar context */ -register char **argv; /* null terminated arg list, NULL for no arglist */ -{ - register int items = 0; - int hasargs = (argv != 0); - - astore(stack, ++sp, Nullstr); /* reserve spot for 1st return arg */ - if (hasargs) { - while (*argv) { - astore(stack, ++sp, str_2mortal(str_make(*argv,0))); - items++; - argv++; - } - } - return callback(subname, sp, gimme, hasargs, items); -} - -#include <process.h> -#include <stdio.h> - -long _stksize = 64*1024L; -unsigned long __DEFAULT_BUFSIZ__ = 4 * 1024L; - -/* - * The following code is based on the do_exec and do_aexec functions - * in file doio.c - */ -int -do_aspawn(really,arglast) -STR *really; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register int items = arglast[2] - sp; - register char **a; - char **argv; - char *tmps; - int status; - - if (items) { - New(1101,argv, items+1, char*); - a = argv; - for (st += ++sp; items > 0; items--,st++) { - if (*st) - *a++ = str_get(*st); - else - *a++ = ""; - } - *a = Nullch; - if (really && *(tmps = str_get(really))) - status = spawnvp(-P_WAIT,tmps,argv); /* -P_WAIT is a hack, see spawnvp.c in the lib */ - else - status = spawnvp(-P_WAIT,argv[0],argv); - Safefree(argv); - } - return status; -} - - -int -do_spawn(cmd) -char *cmd; -{ - return system(cmd); -} - -#if 0 /* patchlevel 79 onwards we can */ -/* - * we unfortunately cannot use the super efficient fread/write from the lib - */ -size_t fread(void *data, size_t size, size_t count, FILE *fp) -{ - size_t i, j; - unsigned char *buf = (unsigned char *)data; - int c; - - for(i = 0; i < count; i++) - { - for(j = 0; j < size; j++) - { - if((c = getc(fp)) == EOF) - return 0; - *buf++ = c; - } - } - return i; -} - -size_t fwrite(const void *data, size_t size, size_t count, FILE *fp) -{ - size_t i, j; - const unsigned char *buf = (const unsigned char *)data; - - for(i = 0; i < count; i++) - { - for(j = 0; j < size; j++) - { - if(fputc(*buf++, fp) == EOF) - return 0; - } - } - return i; -} -#endif - -#ifdef HAS_SYSCALL -#define __NO_INLINE__ -#include <osbind.h> /* must include this for proper protos */ - -/* these must match osbind.pl */ -#define TRAP_1_W 1 -#define TRAP_1_WW 2 -#define TRAP_1_WL 3 -#define TRAP_1_WLW 4 -#define TRAP_1_WWW 5 -#define TRAP_1_WLL 6 -#define TRAP_1_WWLL 7 -#define TRAP_1_WLWW 8 -#define TRAP_1_WWLLL 9 -#define TRAP_13_W 10 -#define TRAP_13_WW 11 -#define TRAP_13_WL 12 -#define TRAP_13_WWW 13 -#define TRAP_13_WWL 14 -#define TRAP_13_WWLWWW 15 -#define TRAP_14_W 16 -#define TRAP_14_WW 17 -#define TRAP_14_WL 18 -#define TRAP_14_WWW 19 -#define TRAP_14_WWL 20 -#define TRAP_14_WWLL 21 -#define TRAP_14_WLLW 22 -#define TRAP_14_WLLL 23 -#define TRAP_14_WWWL 24 -#define TRAP_14_WWWWL 25 -#define TRAP_14_WLLWW 26 -#define TRAP_14_WWWWWWW 27 -#define TRAP_14_WLLWWWWW 28 -#define TRAP_14_WLLWWWWLW 29 -#define TRAP_14_WLLWWWWWLW 30 - -int syscall(trap, fn, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12 ) -unsigned long trap, fn, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12; -{ - /* for now */ - switch(trap) - { - case TRAP_1_W: - return trap_1_w(fn); - - case TRAP_1_WW: - return trap_1_ww(fn, a1); - - case TRAP_1_WL: - return trap_1_wl(fn, a1); - - case TRAP_1_WLW: - return trap_1_wlw(fn, a1, a2); - - case TRAP_1_WWW: - return trap_1_www(fn, a1, a2); - - case TRAP_1_WLL: - return trap_1_wll(fn, a1, a2); - - case TRAP_1_WWLL: - return trap_1_wwll(fn, a1, a2, a3); - - case TRAP_1_WLWW: - return trap_1_wlww(fn, a1, a2, a3); - - case TRAP_1_WWLLL: - return trap_1_wwlll(fn, a1, a2, a3, a4); - - case TRAP_13_W: - return trap_13_w(fn); - - case TRAP_13_WW: - return trap_13_ww(fn, a1); - - case TRAP_13_WL: - return trap_13_wl(fn, a1); - - case TRAP_13_WWW: - return trap_13_www(fn, a1, a2); - - case TRAP_13_WWL: - return trap_13_wwl(fn, a1, a2); - - case TRAP_13_WWLWWW: - return trap_13_wwlwww(fn, a1, a2, a3, a4, a5); - - case TRAP_14_W: - return trap_14_w(fn); - - case TRAP_14_WW: - return trap_14_ww(fn, a1); - - case TRAP_14_WL: - return trap_14_wl(fn, a1); - - case TRAP_14_WWW: - return trap_14_www(fn, a1, a2); - - case TRAP_14_WWL: - return trap_14_wwl(fn, a1, a2); - - case TRAP_14_WWLL: - return trap_14_wwll(fn, a1, a2, a3); - - case TRAP_14_WLLW: - return trap_14_wllw(fn, a1, a2, a3); - - case TRAP_14_WLLL: - return trap_14_wlll(fn, a1, a2, a3); - - case TRAP_14_WWWL: - return trap_14_wwwl(fn, a1, a2, a3); - - case TRAP_14_WWWWL: - return trap_14_wwwwl(fn, a1, a2, a3, a4); - - case TRAP_14_WLLWW: - return trap_14_wllww(fn, a1, a2, a3, a4); - - case TRAP_14_WWWWWWW: - return trap_14_wwwwwww(fn, a1, a2, a3, a4, a5, a6); - - case TRAP_14_WLLWWWWW: - return trap_14_wllwwwww(fn, a1, a2, a3, a4, a5, a6, a7); - - case TRAP_14_WLLWWWWLW: - return trap_14_wllwwwwlw(fn, a1, a2, a3, a4, a5, a6, a7, a8); - - case TRAP_14_WLLWWWWWLW: - return trap_14_wllwwwwwlw(fn, a1, a2, a3, a4, a5, a6, a7, a8, a9); - } -} -#endif - diff --git a/atarist/config.h b/atarist/config.h deleted file mode 100644 index 7e432546f9..0000000000 --- a/atarist/config.h +++ /dev/null @@ -1,912 +0,0 @@ -#ifndef config_h -#define config_h -/* config.h - * 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. - */ - /*SUPPRESS 460*/ - - -/* EUNICE - * This symbol, if defined, indicates that the program is being compiled - * under the EUNICE package under VMS. The program will need to handle - * things like files that don't go away the first time you unlink them, - * due to version numbering. It will also need to compensate for lack - * of a respectable link() command. - */ -/* VMS - * This symbol, if defined, indicates that the program is running under - * VMS. It is currently only set in conjunction with the EUNICE symbol. - */ -/*#undef EUNICE /**/ -/*#undef VMS /**/ - -/* ALIGNBYTES - * This symbol contains the number of bytes required to align a double. - * Usual values are 2, 4, and 8. - */ -#define ALIGNBYTES 2 /**/ - -/* BIN - * This symbol holds the name of the directory in which the user wants - * to keep publicly executable images for the package in question. It - * is most often a local directory such as /usr/local/bin. - */ -#define BIN "/bin" /**/ - -/* BYTEORDER - * This symbol contains an encoding of the order of bytes in a long. - * Usual values (in hex) are 0x1234, 0x4321, 0x2143, 0x3412... - */ -#define BYTEORDER 0x4321 /**/ - -/* 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". - */ -/* 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 "gcc -E" -#define CPPMINUS "" - -/* HAS_BCMP - * This symbol, if defined, indicates that the bcmp routine is available - * to compare blocks of memory. If undefined, use memcmp. If that's - * not available, roll your own. - */ -#define HAS_BCMP /**/ - -/* HAS_BCOPY - * This symbol, if defined, indicates that the bcopy routine is available - * to copy blocks of memory. Otherwise you should probably use memcpy(). - * If neither is defined, roll your own. - */ -/* SAFE_BCOPY - * This symbol, if defined, indicates that the bcopy routine is available - * to copy potentially overlapping copy blocks of bcopy. Otherwise you - * should probably use memmove() or memcpy(). If neither is defined, - * roll your own. - */ -#define HAS_BCOPY /**/ -#define SAFE_BCOPY /**/ - -/* HAS_BZERO - * This symbol, if defined, indicates that the bzero routine is available - * to zero blocks of memory. Otherwise you should probably use memset() - * or roll your own. - */ -#define HAS_BZERO /**/ - -/* CASTNEGFLOAT - * This symbol, if defined, indicates that this C compiler knows how to - * cast negative or large floating point 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: - * 1 = couldn't cast < 0 - * 2 = couldn't cast >= 0x80000000 - */ -#define CASTNEGFLOAT /**/ -#define CASTFLAGS 0 /**/ - -/* CHARSPRINTF - * This symbol is defined if this system declares "char *sprintf()" in - * stdio.h. The trend seems to be to declare it as "int sprintf()". It - * is up to the package author to declare sprintf correctly based on the - * symbol. - */ -/* #define CHARSPRINTF /**/ - -/* 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 /**/ - -/* HAS_CRYPT - * This symbol, if defined, indicates that the crypt routine is available - * to encrypt passwords and the like. - */ -/* #define HAS_CRYPT /**/ - -/* CSH - * This symbol, if defined, indicates that the C-shell exists. - * If defined, contains the full pathname of csh. - */ -/* #define CSH "/bin/csh" /**/ - -/* 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. - */ -/*#undef DOSUID /**/ - -/* HAS_DUP2 - * This symbol, if defined, indicates that the dup2 routine is available - * to dup file descriptors. Otherwise you should use dup(). - */ -#define HAS_DUP2 /**/ - -/* HAS_FCHMOD - * This symbol, if defined, indicates that the fchmod routine is available - * to change mode of opened files. If unavailable, use chmod(). - */ -/* #define HAS_FCHMOD /**/ - -/* HAS_FCHOWN - * This symbol, if defined, indicates that the fchown routine is available - * to change ownership of opened files. If unavailable, use chown(). - */ -/* #define HAS_FCHOWN /**/ - -/* HAS_FCNTL - * This symbol, if defined, indicates to the C program that - * the fcntl() function exists. - */ -/* #define HAS_FCNTL /**/ - -/* FLEXFILENAMES - * This symbol, if defined, indicates that the system supports filenames - * longer than 14 characters. - */ -/* #define FLEXFILENAMES /**/ - -/* HAS_FLOCK - * This symbol, if defined, indicates that the flock() routine is - * available to do file locking. - */ -/* #define HAS_FLOCK /**/ - -/* HAS_GETGROUPS - * This symbol, if defined, indicates that the getgroups() routine is - * available to get the list of process groups. If unavailable, multiple - * groups are probably not supported. - */ -/* #define HAS_GETGROUPS /**/ - -/* HAS_GETHOSTENT - * This symbol, if defined, indicates that the gethostent() routine is - * available to lookup host names in some data base or other. - */ -/* #define HAS_GETHOSTENT /**/ - -/* HAS_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_GETPRIORITY - * This symbol, if defined, indicates that the getpriority() routine is - * available to get a process's priority. - */ -/* #define HAS_GETPRIORITY /**/ - -/* HAS_HTONS - * This symbol, if defined, indicates that the htons routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_HTONL - * This symbol, if defined, indicates that the htonl routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_NTOHS - * This symbol, if defined, indicates that the ntohs routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_NTOHL - * This symbol, if defined, indicates that the ntohl routine (and friends) - * are available to do network order byte swapping. - */ -/* #define HAS_HTONS /**/ -/* #define HAS_HTONL /**/ -/* #define HAS_NTOHS /**/ -/* #define HAS_NTOHL /**/ - -/* index - * This preprocessor symbol is defined, along with rindex, if the system - * uses the strchr and strrchr routines instead. - */ -/* rindex - * This preprocessor symbol is defined, along with index, if the system - * uses the strchr and strrchr routines instead. - */ -/* #define index strchr /* cultural */ -/* #define rindex strrchr /* differences? */ -#include <string.h> - -/* HAS_ISASCII - * This symbol, if defined, indicates that the isascii routine is available - * to test characters for asciiness. - */ -#define HAS_ISASCII /**/ - -/* HAS_KILLPG - * This symbol, if defined, indicates that the killpg routine is available - * to kill process groups. If unavailable, you probably should use kill - * with a negative process number. - */ -/* #define HAS_KILLPG /**/ - -/* HAS_LSTAT - * This symbol, if defined, indicates that the lstat() routine is - * available to stat symbolic links. - */ -#define HAS_LSTAT /**/ - -/* HAS_MEMCMP - * This symbol, if defined, indicates that the memcmp routine is available - * to compare blocks of memory. If undefined, roll your own. - */ -#define HAS_MEMCMP /**/ - -/* HAS_MEMCPY - * This symbol, if defined, indicates that the memcpy routine is available - * to copy blocks of memory. Otherwise you should probably use bcopy(). - * If neither is defined, roll your own. - */ -/* SAFE_MEMCPY - * This symbol, if defined, indicates that the memcpy routine is available - * to copy potentially overlapping copy blocks of memory. Otherwise you - * should probably use memmove() or bcopy(). If neither is defined, - * roll your own. - */ -#define HAS_MEMCPY /**/ -/*#undef SAFE_MEMCPY /**/ - -/* HAS_MEMMOVE - * This symbol, if defined, indicates that the memmove routine is available - * to move potentially overlapping blocks of memory. Otherwise you - * should use bcopy() or roll your own. - */ -/*#undef HAS_MEMMOVE /**/ - -/* HAS_MEMSET - * This symbol, if defined, indicates that the memset routine is available - * to set a block of memory to a character. If undefined, roll your own. - */ -#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_MSG - * This symbol, if defined, indicates that the entire msg*(2) library is - * supported. - */ -/* #define HAS_MSG /**/ - -/* HAS_MSGCTL - * This symbol, if defined, indicates that the msgctl() routine is - * available to control message passing. - */ -/* #define HAS_MSGCTL /**/ - -/* HAS_MSGGET - * This symbol, if defined, indicates that the msgget() routine is - * available to get messages. - */ -/* #define HAS_MSGGET /**/ - -/* HAS_MSGRCV - * This symbol, if defined, indicates that the msgrcv() routine is - * available to receive messages. - */ -/* #define HAS_MSGRCV /**/ - -/* HAS_MSGSND - * This symbol, if defined, indicates that the msgsnd() routine is - * available to send messages. - */ -/* #define HAS_MSGSND /**/ - -/* HAS_NDBM - * This symbol, if defined, indicates that ndbm.h exists and should - * be included. - */ -/* #define HAS_NDBM /**/ - -/* HAS_ODBM - * This symbol, if defined, indicates that dbm.h exists and should - * be included. - */ -/* #define HAS_ODBM /**/ - -/* HAS_OPEN3 - * This manifest constant lets the C program know that the three - * argument form of open(2) is available. - */ -#define HAS_OPEN3 /**/ - -/* HAS_READDIR - * This symbol, if defined, indicates that the readdir routine is available - * from the C library to read directories. - */ -#define HAS_READDIR /**/ - -/* 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_REWINDDIR - * This symbol, if defined, indicates that the rewindir routine is - * available to rewind directories. - */ -#define HAS_REWINDDIR /**/ - -/* 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_SEEKDIR - * This symbol, if defined, indicates that the seekdir routine is - * available to seek into directories. - */ -#define HAS_SEEKDIR /**/ - -/* HAS_SELECT - * This symbol, if defined, indicates that the select() subroutine - * exists. - */ -/* #define HAS_SELECT /**/ - -/* HAS_SEM - * This symbol, if defined, indicates that the entire sem*(2) library is - * supported. - */ -/* #define HAS_SEM /**/ - -/* HAS_SEMCTL - * This symbol, if defined, indicates that the semctl() routine is - * available to control semaphores. - */ -/* #define HAS_SEMCTL /**/ - -/* HAS_SEMGET - * This symbol, if defined, indicates that the semget() routine is - * available to get semaphores ids. - */ -/* #define HAS_SEMGET /**/ - -/* HAS_SEMOP - * This symbol, if defined, indicates that the semop() routine is - * available to perform semaphore operations. - */ -/* #define HAS_SEMOP /**/ - -/* HAS_SETEGID - * This symbol, if defined, indicates that the setegid routine is available - * to change the effective gid of the current program. - */ -#define HAS_SETEGID /**/ - -/* HAS_SETEUID - * This symbol, if defined, indicates that the seteuid routine is available - * to change the effective uid of the current program. - */ -#define HAS_SETEUID /**/ - -/* HAS_SETPGRP - * This symbol, if defined, indicates that the setpgrp() routine is - * available to set the current process group. - */ -#define HAS_SETPGRP /**/ - -/* HAS_SETPGRP2 - * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) - * routine is available to set the current process group. - */ -/*#undef HAS_SETPGRP2 /**/ - -/* HAS_SETPRIORITY - * This symbol, if defined, indicates that the setpriority() routine is - * available to set a process's priority. - */ -/* #define HAS_SETPRIORITY /**/ - -/* HAS_SETREGID - * This symbol, if defined, indicates that the setregid routine is - * available to change the real and effective gid of the current program. - */ -/* HAS_SETRESGID - * This symbol, if defined, indicates that the setresgid routine is - * available to change the real, effective and saved gid of the current - * program. - */ -/* #define 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 program. - */ -/* HAS_SETRESUID - * This symbol, if defined, indicates that the setresuid routine is - * available to change the real, effective and saved uid of the current - * program. - */ -/* #define 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. - */ -/* #define HAS_SETRGID /**/ - -/* HAS_SETRUID - * This symbol, if defined, indicates that the setruid routine is available - * to change the real uid of the current program. - */ -/* #define HAS_SETRUID /**/ - -/* HAS_SHM - * This symbol, if defined, indicates that the entire shm*(2) library is - * supported. - */ -/* #define HAS_SHM /**/ - -/* HAS_SHMAT - * This symbol, if defined, indicates that the shmat() routine is - * available to attach a shared memory segment. - */ -/* VOID_SHMAT - * This symbol, if defined, indicates that the shmat() routine - * returns a pointer of type void*. - */ -/* #define HAS_SHMAT /**/ - -/*#undef VOIDSHMAT /**/ - -/* HAS_SHMCTL - * This symbol, if defined, indicates that the shmctl() routine is - * available to control a shared memory segment. - */ -/* #define HAS_SHMCTL /**/ - -/* HAS_SHMDT - * This symbol, if defined, indicates that the shmdt() routine is - * available to detach a shared memory segment. - */ -/* #define HAS_SHMDT /**/ - -/* HAS_SHMGET - * This symbol, if defined, indicates that the shmget() routine is - * available to get a shared memory segment id. - */ -/* #define HAS_SHMGET /**/ - -/* 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. - */ -/* OLDSOCKET - * This symbol, if defined, indicates that the 4.1c BSD socket interface - * is supported instead of the 4.2/4.3 BSD socket interface. - */ -/* #define HAS_SOCKET /**/ - -/* #define HAS_SOCKETPAIR /**/ - -/*#undef OLDSOCKET /**/ - -/* STATBLOCKS - * This symbol is defined if this system has a stat structure declaring - * st_blksize and st_blocks. - */ -#define STATBLOCKS /**/ - -/* STDSTDIO - * This symbol is defined if this system has a FILE structure declaring - * _ptr and _cnt in stdio.h. - */ -/* #define STDSTDIO /**/ /* we do, but semantics are different */ - -/* STRUCTCOPY - * 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 STRUCTCOPY /**/ - -/* HAS_STRERROR - * This symbol, if defined, indicates that the strerror() routine is - * available to translate error numbers to strings. - */ -#define HAS_STRERROR /**/ - -/* HAS_SYMLINK - * This symbol, if defined, indicates that the symlink routine is available - * to create symbolic links. - */ -#define HAS_SYMLINK /**/ - -/* HAS_SYSCALL - * This symbol, if defined, indicates that the syscall routine is available - * to call arbitrary system calls. If undefined, that's tough. - */ -#define HAS_SYSCALL /**/ - -/* HAS_TELLDIR - * This symbol, if defined, indicates that the telldir routine is - * available to tell your location in directories. - */ -#define HAS_TELLDIR /**/ - -/* HAS_TRUNCATE - * This symbol, if defined, indicates that the truncate routine is - * available to truncate files. - */ -/* #define HAS_TRUNCATE /**/ - -/* HAS_VFORK - * This symbol, if defined, indicates that vfork() exists. - */ -#ifdef __MINT__ -#define HAS_VFORK /**/ -#endif - -/* VOIDSIG - * This symbol is defined if this system declares "void (*signal())()" in - * signal.h. The old way was to declare it as "int (*signal())()". It - * is up to the package author to declare things correctly based on the - * symbol. - */ -/* TO_SIGNAL - * This symbol's value is either "void" or "int", corresponding to the - * appropriate return "type" of a signal handler. Thus, one can declare - * a signal handler using "TO_SIGNAL (*handler())()", and define the - * handler using "TO_SIGNAL handler(sig)". - */ -#define VOIDSIG /**/ -#define TO_SIGNAL void /**/ - -/* HASVOLATILE - * This symbol, if defined, indicates that this C compiler knows about - * the volatile declaration. - */ -#define HASVOLATILE /**/ - -/* 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(). - */ -/* CHARVSPRINTF - * 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 CHARVSPRINTF /**/ - -/* HAS_WAIT4 - * This symbol, if defined, indicates that wait4() exists. - */ -/* #define HAS_WAIT4 /**/ - -/* HAS_WAITPID - * This symbol, if defined, indicates that waitpid() exists. - */ -/*#undef HAS_WAITPID /**/ - -/* GIDTYPE - * This symbol has a value like gid_t, int, ushort, or whatever type is - * used to declare group ids in the kernel. - */ -#define GIDTYPE gid_t /**/ - -/* GROUPSTYPE - * This symbol has a value like gid_t, int, ushort, or whatever type is - * used in the return value of getgroups(). - */ -/* #define GROUPSTYPE unsigned short /**/ - -/* I_FCNTL - * This manifest constant tells the C program to include <fcntl.h>. - */ -#define I_FCNTL /**/ - -/* I_GDBM - * This symbol, if defined, indicates that gdbm.h exists and should - * be included. - */ -#define I_GDBM /**/ -#define HAS_GDBM - -/* I_GRP - * This symbol, if defined, indicates to the C program that it should - * include grp.h. - */ -/* #define I_GRP /**/ - -/* I_NETINET_IN - * This symbol, if defined, indicates to the C program that it should - * include netinet/in.h. - */ -/* I_SYS_IN - * This symbol, if defined, indicates to the C program that it should - * include sys/in.h. - */ -/* #define I_NETINET_IN /**/ -/*#undef I_SYS_IN /**/ - -/* I_PWD - * This symbol, if defined, indicates to the C program that it should - * include pwd.h. - */ -/* PWQUOTA - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_quota. - */ -/* PWAGE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_age. - */ -/* PWCHANGE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_change. - */ -/* PWCLASS - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_class. - */ -/* PWEXPIRE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_expire. - */ -/* PWCOMMENT - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_comment. - */ -#define I_PWD /**/ -/* #define PWQUOTA /**/ -/*#undef PWAGE /**/ -/*#undef PWCHANGE /**/ -/*#undef PWCLASS /**/ -/*#undef PWEXPIRE /**/ -/* #define PWCOMMENT /**/ - -/* I_SYS_FILE - * This manifest constant tells the C program to include <sys/file.h>. - */ -/* #define I_SYS_FILE /**/ - -/* I_SYSIOCTL - * This symbol, if defined, indicates that sys/ioctl.h exists and should - * be included. - */ -#define I_SYSIOCTL /**/ - -/* I_TIME - * This symbol is defined if the program should include <time.h>. - */ -/* I_SYS_TIME - * This symbol is defined if the program should include <sys/time.h>. - */ -/* SYSTIMEKERNEL - * This symbol is defined if the program should include <sys/time.h> - * with KERNEL defined. - */ -/* I_SYS_SELECT - * This symbol is defined if the program should include <sys/select.h>. - */ -#define I_TIME /**/ -/* #define I_SYS_TIME /**/ -/*#undef SYSTIMEKERNEL /**/ -/*#undef I_SYS_SELECT /**/ - -/* I_UTIME - * This symbol, if defined, indicates to the C program that it should - * include utime.h. - */ -/*#undef I_UTIME /**/ - -/* I_VARARGS - * This symbol, if defined, indicates to the C program that it should - * include varargs.h. - */ -#define I_VARARGS /**/ - -/* I_VFORK - * This symbol, if defined, indicates to the C program that it should - * include vfork.h. - */ -/* #define I_VFORK /**/ - -/* INTSIZE - * This symbol contains the size of an int, so that the C preprocessor - * can make decisions based on it. - */ -#ifdef __MSHORT__ -#define INTSIZE 2 /**/ -#else -#define INTSIZE 4 /**/ -#endif - -/* I_DIRENT - * This symbol, if defined, indicates that the program should use the - * P1003-style directory routines, and include <dirent.h>. - */ -/* I_SYS_DIR - * This symbol, if defined, indicates that the program should use the - * directory functions by including <sys/dir.h>. - */ -/* I_NDIR - * This symbol, if defined, indicates that the program should include the - * system's version of ndir.h, rather than the one with this package. - */ -/* I_SYS_NDIR - * This symbol, if defined, indicates that the program should include the - * system's version of sys/ndir.h, rather than the one with this package. - */ -/* I_MY_DIR - * This symbol, if defined, indicates that the program should compile - * the ndir.c code provided with the package. - */ -/* 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. - */ -#define I_DIRENT /**/ -/*#undef I_SYS_DIR /**/ -/*#undef I_NDIR /**/ -/*#undef I_SYS_NDIR /**/ -/*#undef I_MY_DIR /**/ -/*#undef DIRNAMLEN /**/ - -/* MYMALLOC - * This symbol, if defined, indicates that we're using our own malloc. - */ -/* MALLOCPTRTYPE - * This symbol defines the kind of ptr returned by malloc and realloc. - */ -/* #define MYMALLOC /**/ -#define MALLOCPTRTYPE void /**/ - - - -/* RANDBITS - * This symbol contains the number of bits of random number the rand() - * function produces. Usual values are 15, 16, and 31. - */ -#ifdef __MSHORT__ -#define RANDBITS 15 /**/ -#else -#define RANDBITS 31 /**/ -#endif - -/* SCRIPTDIR - * This symbol holds the name of the directory in which the user wants - * to keep publicly executable scripts for the package in question. It - * is often a directory that is mounted across diverse architectures. - */ -#define SCRIPTDIR "/bin" /**/ - -/* SIG_NAME - * This symbol contains an list of signal names in order. - */ -#define SIG_NAME "NULL","HUP","INT","QUIT","ILL","TRAP","ABRT","PRIV","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CHLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","USR1","USR2" - -/* STDCHAR - * This symbol is defined to be the type of char used in stdio.h. - * It has the values "unsigned char" or "char". - */ -#define STDCHAR unsigned char /**/ - -/* UIDTYPE - * This symbol has a value like uid_t, int, ushort, or whatever type is - * used to declare user ids in the kernel. - */ -#define UIDTYPE uid_t /**/ - -/* VOIDHAVE - * 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 - * - * The package designer should define VOIDWANT to indicate the requirements - * of the package. This can be done either by #defining VOIDWANT before - * including config.h, or by defining voidwant in Myinit.U. If the level - * of void support necessary is not present, config.h defines void to "int", - * VOID to the empty string, and VOIDP to "char *". - */ -/* void - * This symbol is used for void casts. On implementations which support - * void appropriately, its value is "void". Otherwise, its value maps - * to "int". - */ -/* VOID - * This symbol's value is "void" if the implementation supports void - * appropriately. Otherwise, its value is the empty string. The primary - * use of this symbol is in specifying void parameter lists for function - * prototypes. - */ -/* VOIDP - * This symbol is used for casting generic pointers. On implementations - * which support void appropriately, its value is "void *". Otherwise, - * its value is "char *". - */ -#ifndef VOIDWANT -#define VOIDWANT 7 -#endif -#define VOIDHAVE 7 -#if (VOIDHAVE & VOIDWANT) != VOIDWANT -#define void int /* is void to be avoided? */ -#define VOID -#define VOIDP (char *) -#define M_VOID /* Xenix strikes again */ -#else -#define VOID void -#define VOIDP (void *) -#endif - -/* PRIVLIB - * This symbol contains the name of the private library for this package. - * The library is private in the sense that it needn't be in anyone's - * execution path, but it should be accessible by the world. The program - * should be prepared to do ~ expansion. - */ -/* #define PRIVLIB "/usr/lib/perl" /**/ -extern char *PRIVLIB; /* $PERLIB or /lib */ - -/* param.h does'nt really need types, but is #define'ed to make sure types.h - * is included - */ -#define PARAM_NEEDS_TYPES - -/* These are selective unix services in the gcc-st lib - */ -#define HAS_GETLOGIN -#define HAS_GETPPID -#define HAS_KILL -#define HAS_UMASK -#define HAS_PASSWD -#endif diff --git a/atarist/echo.c b/atarist/echo.c deleted file mode 100644 index 0853d62a4b..0000000000 --- a/atarist/echo.c +++ /dev/null @@ -1,98 +0,0 @@ -/* - * echo args, globbing is necessary. - * usage: - * echo [-n] [args ...] - * \n \r \b \c \v \\ \f \t \NNN escapes supported - * -n and \c mean dont echo the final newline. - * - * ++jrb bammi@cadence.com - */ - -#include <stdio.h> - -#if __STDC__ -# include <compiler.h> -#else -# define __PROTO(X) () -#endif - -char **glob __PROTO((char *patt, int decend_dir)); -int contains_wild __PROTO((char *patt)); -void free_all __PROTO((void)); - - -int final_newline = 1; /* turned off by -n or \c */ - -int main(argc, argv) -int argc; -char **argv; -{ - --argc; ++argv; - if((*argv)[0] == '-') - { - if ((*argv)[1] == 'n') - final_newline = 0; - else - { - fputs("usage: echo [-n] [arguement ... ]\n", stderr); - return 1; - } - --argc; ++argv; - } - - while(argc--) - { - char *word = *argv; - char **list; - - if(contains_wild(word) && (list = glob(word, 0))) - { - while(*list) - { - fputs(*list, stdout); - if(*++list) putchar(' '); - } - free_all(); - } - else - { - char c; - for(c = *word; c; c = (*word)? *++word : 0) - { - if(c != '\\') - putchar(c); - else - { - switch(*++word) - { - case 'b': putchar('\b'); break; - case 'f': putchar('\f'); break; - case 'n': putchar('\n'); break; - case 'r': putchar('\r'); break; - case 't': putchar('\t'); break; - case 'v': putchar('\v'); break; - case '\\': putchar('\\'); break; - case 'c': final_newline = 0; break; - default: putchar(*word); /* ?? */ - case '0': - { - int n = 0; - for(c = *++word; (c >= '0') && (c <= '7'); c = *++word) - n = (n << 3) + (c - '0'); - putchar(n); - } - } - } - } - } - if(*++argv) putchar(' '); - } - if(final_newline) putchar('\n'); - return 0; -} - - - - - - diff --git a/atarist/explain b/atarist/explain deleted file mode 100644 index 9e8fca03a2..0000000000 --- a/atarist/explain +++ /dev/null @@ -1,77 +0,0 @@ -Here is a brief explaination of the diffs in perl.diffs. If anything -is unclear please just ask: - -General: - Many of the #ifdef MSDOS where required for the atari too. In order -to avoid cluttering up the source, upfront in perl.h we #define -MSDOS_OR_ATARI if either defined(MSDOS) or defined(atarist). - - Some of the diffs that i felt were universally applicable are not protected -with #ifdef's. In the explainations below i has indicated all such -changes. - -perl.h: - -- define MSDOS_OR_ATARI if appro. - -- typedef size_t - assume its there in <stddef.h> if STANDARD_C otherwise - typedef it to unsigned int (i would have ideally liked unsigned long, - but we get into trouble with half-assed headers from sun etc) -(this change not protected with a #ifdef since hopefully its universally appli) - - -- make the type of STRLEN size_t for all systems -(this change not protected with a #ifdef since hopefully its universally appli) - - -- more #ifdef MSDOS -> #ifdef MSDOS_OR_ATARI changes. - -arg.h: - -- in the atari headers we already have O_PIPE. Change all instances of - O_PIPE to PERL_O_PIPE. All such changes protected with #ifdef atarist. - -handy.h: - -- make MEM_SIZE size_t like STRLEN. -(this change not protected with a #ifdef since hopefully its universally appli) - -doarg.c: - -- accomodate the large number of args needed for the atari syscall(). - -- do the 9 thru 14 arg versions of syscall for the atarist. - -doio.c: - -- mode[] needed to be initialized. -(this change not protected with a #ifdef since hopefully its universally appli) - - -- you may find this strange, we do not define STDSTDIO, because even - though we have the "standard" field in FILE, the semantics are - different. However, some contexts will work correctly, and there - you will see #if defined(STDSTDIO) || defined(atarist) - - -- more #ifdef MSDOS -> #ifdef MSDOS_OR_ATARI changes. - -eval.c: - -- more #ifdef MSDOS -> #ifdef MSDOS_OR_ATARI changes. - -malloc.c:: - -- instead of bashfully using ints to hold sizes use MEM_SIZE. - adjust some casts and printf format specifiers due to this. - (atarigcc can run in two modes, with 16 or 32 bit ints, so...) -(this change not protected with a #ifdef since hopefully its universally appli) - - -- atarist changes sometimes ||'ed with I286 as appro. - -perl.c: - -- more #ifdef MSDOS -> #ifdef MSDOS_OR_ATARI changes. - -regcomp.c: - -- like O_PIPE the atarist headers already has META defined. Change all - instances of META to PERL_META. All such changes protected with - #ifdef atarist. - -str.c: - -- more #ifdef MSDOS -> #ifdef MSDOS_OR_ATARI changes. - -token.c:: - -- META -> PERL_META renaming for atari - -util.c:: - -- more adjustments for memory sizes being MEM_SIZE instead of int. - -- more #ifdef MSDOS -> #ifdef MSDOS_OR_ATARI changes. - -++jrb bammi@cadence.com diff --git a/atarist/makefile.sm b/atarist/makefile.sm deleted file mode 100644 index 069645e38e..0000000000 --- a/atarist/makefile.sm +++ /dev/null @@ -1,460 +0,0 @@ -# : Makefile.SH,v 9820Revision: 4.0.1.2 9820Date: 91/06/07 10:14:43 $ -# -# $Log: makefile.sm,v $ -# Revision 4.1 92/08/07 17:18:37 lwall -# Stage 6 Snapshot -# -# Revision 4.0.1.1 92/06/08 11:50:00 lwall -# Initial revision -# -# Revision 4.0.1.2 91/06/07 10:14:43 lwall -# patch4: cflags now emits entire cc command except for the filename -# patch4: alternate make programs are now semi-supported -# patch4: uperl.o no longer tries to link in libraries prematurely -# patch4: installperl now installs x2p stuff too -# -# Revision 4.0.1.1 91/04/11 17:30:39 lwall -# patch1: C flags are now settable on a per-file basis -# -# Revision 4.0 91/03/20 00:58:54 lwall -# 4.0 baseline. -# -# - -CC = cgcc -YACC = bison -y -LDFLAGS = -CLDFLAGS = -SMALL = -LARGE = -mallocsrc = malloc.c -mallocobj = malloc.o -SLN = ln -s - -libs = -lgdbm -lpml - -public = perl.ttp - -# To use an alternate make, set in config.sh. -MAKE = make - - -CCCMD = $(CC) -O2 -fomit-frame-pointer -fstrength-reduce -c -DMYMALLOC - -private = - -scripts = - -manpages = perl.man h2ph.man - -util = echo.ttp perlglob.ttp - -sh = Makefile.SH makedepend.SH h2ph.SH - -h1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h form.h handy.h -h2 = hash.h perl.h regcomp.h regexp.h spat.h stab.h str.h util.h - -h = $(h1) $(h2) - -c1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c -c2 = eval.c form.c hash.c $(mallocsrc) perl.c regcomp.c regexec.c -c3 = stab.c str.c toke.c util.c atarist.c usersub.c - -c = $(c1) $(c2) $(c3) - -obj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o -obj2 = eval.o form.o hash.o $(mallocobj) perl.o regcomp.o regexec.o -obj3 = stab.o str.o toke.o util.o atarist.o - -obj = $(obj1) $(obj2) $(obj3) - -lintflags = -hbvxac - -# grrr -SHELL = /bin/sh - -.c.o: - $(CCCMD) $*.c - -all: $(public) $(util) - -# This is the standard version that contains no "taint" checks and is -# used for all scripts that aren't set-id or running under something set-id. -# The $& notation is tells Sequent machines that it can do a parallel make, -# and is harmless otherwise. - -perl.ttp: perly.o $(obj) usersub.o - $(CC) $(LARGE) $(CLDFLAGS) $(obj) perly.o usersub.o $(libs) -o perl.ttp -v -s - -echo.ttp: wildmat.o echo.c - $(CC) -O -mshort -fomit-frame-pointer -o echo.ttp \ - echo.c wildmat.o -liio16 -s - -perlglob.ttp: wildmat.o perlglob.c - $(CC) -O -mshort -fomit-frame-pointer -o perlglob.ttp \ - perlglob.c wildmat.o -liio16 -s - -wildmat.o: wildmat.c - $(CC) -O -mshort -fomit-frame-pointer -c wildmat.c - -perly.h: perly.c - @ echo Dummy dependency for dumb parallel make - touch perly.h - -perly.c: perly.y perly.fixer - @ echo 'Expect either' 29 shift/reduce and 59 reduce/reduce conflicts... - @ echo ' or' 27 shift/reduce and 61 reduce/reduce conflicts... - $(YACC) -d perly.y - sh ./perly.fixer y.tab.c perly.c - mv y.tab.h perly.h - echo 'extern YYSTYPE yylval;' >>perly.h - -perly.o: perly.c perly.h $(h) - $(CCCMD) perly.c - - -clean: - rm -f *.o - -realclean: clean - rm -f *.ttp report core - rm -f perly.c perly.h - -# The following lint has practically everything turned on. Unfortunately, -# you have to wade through a lot of mumbo jumbo that can't be suppressed. -# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message -# for that spot. - -lint: perly.c $(c) - lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz - -depend: makedepend - - test -f perly.h || cp /dev/null perly.h - ./makedepend - - test -s perly.h || /bin/rm -f perly.h - -test: perl - - cd t && chmod +x TEST */*.t - - cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST </dev/tty - -clist: - echo $(c) | tr ' ' '\012' >.clist - -hlist: - echo $(h) | tr ' ' '\012' >.hlist - -shlist: - echo $(sh) | tr ' ' '\012' >.shlist - -# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE -# If this runs make out of memory, delete /usr/include lines. -array.o: EXTERN.h -array.o: arg.h -array.o: array.c -array.o: array.h -array.o: cmd.h -array.o: config.h -array.o: form.h -array.o: handy.h -array.o: hash.h -array.o: perl.h -array.o: regexp.h -array.o: spat.h -array.o: stab.h -array.o: str.h -array.o: util.h -cmd.o: EXTERN.h -cmd.o: arg.h -cmd.o: array.h -cmd.o: cmd.c -cmd.o: cmd.h -cmd.o: config.h -cmd.o: form.h -cmd.o: handy.h -cmd.o: hash.h -cmd.o: perl.h -cmd.o: regexp.h -cmd.o: spat.h -cmd.o: stab.h -cmd.o: str.h -cmd.o: util.h -cons.o: EXTERN.h -cons.o: arg.h -cons.o: array.h -cons.o: cmd.h -cons.o: config.h -cons.o: cons.c -cons.o: form.h -cons.o: handy.h -cons.o: hash.h -cons.o: perl.h -cons.o: perly.h -cons.o: regexp.h -cons.o: spat.h -cons.o: stab.h -cons.o: str.h -cons.o: util.h -consarg.o: EXTERN.h -consarg.o: arg.h -consarg.o: array.h -consarg.o: cmd.h -consarg.o: config.h -consarg.o: consarg.c -consarg.o: form.h -consarg.o: handy.h -consarg.o: hash.h -consarg.o: perl.h -consarg.o: regexp.h -consarg.o: spat.h -consarg.o: stab.h -consarg.o: str.h -consarg.o: util.h -doarg.o: EXTERN.h -doarg.o: arg.h -doarg.o: array.h -doarg.o: cmd.h -doarg.o: config.h -doarg.o: doarg.c -doarg.o: form.h -doarg.o: handy.h -doarg.o: hash.h -doarg.o: perl.h -doarg.o: regexp.h -doarg.o: spat.h -doarg.o: stab.h -doarg.o: str.h -doarg.o: util.h -doio.o: EXTERN.h -doio.o: arg.h -doio.o: array.h -doio.o: cmd.h -doio.o: config.h -doio.o: doio.c -doio.o: form.h -doio.o: handy.h -doio.o: hash.h -doio.o: perl.h -doio.o: regexp.h -doio.o: spat.h -doio.o: stab.h -doio.o: str.h -doio.o: util.h -dolist.o: EXTERN.h -dolist.o: arg.h -dolist.o: array.h -dolist.o: cmd.h -dolist.o: config.h -dolist.o: dolist.c -dolist.o: form.h -dolist.o: handy.h -dolist.o: hash.h -dolist.o: perl.h -dolist.o: regexp.h -dolist.o: spat.h -dolist.o: stab.h -dolist.o: str.h -dolist.o: util.h -dump.o: EXTERN.h -dump.o: arg.h -dump.o: array.h -dump.o: cmd.h -dump.o: config.h -dump.o: dump.c -dump.o: form.h -dump.o: handy.h -dump.o: hash.h -dump.o: perl.h -dump.o: regexp.h -dump.o: spat.h -dump.o: stab.h -dump.o: str.h -dump.o: util.h -eval.o: EXTERN.h -eval.o: arg.h -eval.o: array.h -eval.o: cmd.h -eval.o: config.h -eval.o: eval.c -eval.o: form.h -eval.o: handy.h -eval.o: hash.h -eval.o: perl.h -eval.o: regexp.h -eval.o: spat.h -eval.o: stab.h -eval.o: str.h -eval.o: util.h -form.o: EXTERN.h -form.o: arg.h -form.o: array.h -form.o: cmd.h -form.o: config.h -form.o: form.c -form.o: form.h -form.o: handy.h -form.o: hash.h -form.o: perl.h -form.o: regexp.h -form.o: spat.h -form.o: stab.h -form.o: str.h -form.o: util.h -hash.o: EXTERN.h -hash.o: arg.h -hash.o: array.h -hash.o: cmd.h -hash.o: config.h -hash.o: form.h -hash.o: handy.h -hash.o: hash.c -hash.o: hash.h -hash.o: perl.h -hash.o: regexp.h -hash.o: spat.h -hash.o: stab.h -hash.o: str.h -hash.o: util.h -perl.o: EXTERN.h -perl.o: arg.h -perl.o: array.h -perl.o: cmd.h -perl.o: config.h -perl.o: form.h -perl.o: handy.h -perl.o: hash.h -perl.o: patchlevel.h -perl.o: perl.c -perl.o: perl.h -perl.o: perly.h -perl.o: regexp.h -perl.o: spat.h -perl.o: stab.h -perl.o: str.h -perl.o: util.h -regcomp.o: EXTERN.h -regcomp.o: INTERN.h -regcomp.o: arg.h -regcomp.o: array.h -regcomp.o: cmd.h -regcomp.o: config.h -regcomp.o: form.h -regcomp.o: handy.h -regcomp.o: hash.h -regcomp.o: perl.h -regcomp.o: regcomp.c -regcomp.o: regcomp.h -regcomp.o: regexp.h -regcomp.o: spat.h -regcomp.o: stab.h -regcomp.o: str.h -regcomp.o: util.h -regexec.o: EXTERN.h -regexec.o: arg.h -regexec.o: array.h -regexec.o: cmd.h -regexec.o: config.h -regexec.o: form.h -regexec.o: handy.h -regexec.o: hash.h -regexec.o: perl.h -regexec.o: regcomp.h -regexec.o: regexec.c -regexec.o: regexp.h -regexec.o: spat.h -regexec.o: stab.h -regexec.o: str.h -regexec.o: util.h -stab.o: EXTERN.h -stab.o: arg.h -stab.o: array.h -stab.o: cmd.h -stab.o: config.h -stab.o: form.h -stab.o: handy.h -stab.o: hash.h -stab.o: perl.h -stab.o: regexp.h -stab.o: spat.h -stab.o: stab.c -stab.o: stab.h -stab.o: str.h -stab.o: util.h -str.o: EXTERN.h -str.o: arg.h -str.o: array.h -str.o: cmd.h -str.o: config.h -str.o: form.h -str.o: handy.h -str.o: hash.h -str.o: perl.h -str.o: perly.h -str.o: regexp.h -str.o: spat.h -str.o: stab.h -str.o: str.c -str.o: str.h -str.o: util.h -toke.o: EXTERN.h -toke.o: arg.h -toke.o: array.h -toke.o: cmd.h -toke.o: config.h -toke.o: form.h -toke.o: handy.h -toke.o: hash.h -toke.o: perl.h -toke.o: perly.h -toke.o: regexp.h -toke.o: spat.h -toke.o: stab.h -toke.o: str.h -toke.o: toke.c -toke.o: util.h -util.o: EXTERN.h -util.o: arg.h -util.o: array.h -util.o: cmd.h -util.o: config.h -util.o: form.h -util.o: handy.h -util.o: hash.h -util.o: perl.h -util.o: regexp.h -util.o: spat.h -util.o: stab.h -util.o: str.h -util.o: util.c -util.o: util.h -atarist.o: EXTERN.h -atarist.o: arg.h -atarist.o: array.h -atarist.o: cmd.h -atarist.o: config.h -atarist.o: form.h -atarist.o: handy.h -atarist.o: hash.h -atarist.o: perl.h -atarist.o: regexp.h -atarist.o: spat.h -atarist.o: stab.h -atarist.o: str.h -atarist.o: atarist.c -atarist.o: util.h - -malloc.o: EXTERN.h -malloc.o: arg.h -malloc.o: array.h -malloc.o: cmd.h -malloc.o: config.h -malloc.o: form.h -malloc.o: handy.h -malloc.o: hash.h -malloc.o: perl.h -malloc.o: regexp.h -malloc.o: spat.h -malloc.o: stab.h -malloc.o: str.h -malloc.o: malloc.c -malloc.o: util.h - diff --git a/atarist/makefile.st b/atarist/makefile.st deleted file mode 100644 index 98fa64585c..0000000000 --- a/atarist/makefile.st +++ /dev/null @@ -1,465 +0,0 @@ -# : Makefile.SH,v 9820Revision: 4.0.1.2 9820Date: 91/06/07 10:14:43 $ -# -# $Log: makefile.st,v $ -# Revision 4.1 92/08/07 17:18:40 lwall -# Stage 6 Snapshot -# -# Revision 4.0.1.1 92/06/08 11:50:13 lwall -# Initial revision -# -# Revision 4.0.1.2 91/06/07 10:14:43 lwall -# patch4: cflags now emits entire cc command except for the filename -# patch4: alternate make programs are now semi-supported -# patch4: uperl.o no longer tries to link in libraries prematurely -# patch4: installperl now installs x2p stuff too -# -# Revision 4.0.1.1 91/04/11 17:30:39 lwall -# patch1: C flags are now settable on a per-file basis -# -# Revision 4.0 91/03/20 00:58:54 lwall -# 4.0 baseline. -# -# - -CC = cgcc -YACC = bison -y -LDFLAGS = -CLDFLAGS = -SMALL = -LARGE = -mallocsrc = -mallocobj = -SLN = ln -s - -libs = -lgdbm -lpml - -public = perl.ttp - -# To use an alternate make, set in config.sh. -MAKE = make - - -CCCMD = $(CC) -O2 -fomit-frame-pointer -fstrength-reduce -c - -private = - -scripts = - -manpages = perl.man h2ph.man - -util = echo.ttp perlglob.ttp - -sh = Makefile.SH makedepend.SH h2ph.SH - -h1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h form.h handy.h -h2 = hash.h perl.h regcomp.h regexp.h spat.h stab.h str.h util.h - -h = $(h1) $(h2) - -c1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c -c2 = eval.c form.c hash.c $(mallocsrc) perl.c regcomp.c regexec.c -c3 = stab.c str.c toke.c util.c atarist.c usersub.c - -c = $(c1) $(c2) $(c3) - -obj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o -obj2 = eval.o form.o hash.o $(mallocobj) perl.o regcomp.o regexec.o -obj3 = stab.o str.o toke.o util.o atarist.o - -obj = $(obj1) $(obj2) $(obj3) - -lintflags = -hbvxac - -# grrr -SHELL = /bin/sh - -.c.o: - $(CCCMD) $*.c - -all: $(public) $(util) - -# This is the standard version that contains no "taint" checks and is -# used for all scripts that aren't set-id or running under something set-id. -# The $& notation is tells Sequent machines that it can do a parallel make, -# and is harmless otherwise. - -perl.ttp: perly.o $(obj) usersub.o - $(CC) $(LARGE) $(CLDFLAGS) $(obj) perly.o usersub.o $(libs) -o perl.ttp -v -s - -echo.ttp: wildmat.o echo.c - $(CC) -O -mshort -fomit-frame-pointer -o echo.ttp \ - echo.c wildmat.o -liio16 -s - -perlglob.ttp: wildmat.o perlglob.c - $(CC) -O -mshort -fomit-frame-pointer -o perlglob.ttp \ - perlglob.c wildmat.o -liio16 -s - -# we cant do a uperl.o, so we do our best. -# -uperl.a: perly.o $(obj) - car rs uperl.a perly.o $(obj) - -wildmat.o: wildmat.c - $(CC) -O -mshort -fomit-frame-pointer -c wildmat.c - -perly.h: perly.c - @ echo Dummy dependency for dumb parallel make - touch perly.h - -perly.c: perly.y perly.fixer - @ echo 'Expect either' 29 shift/reduce and 59 reduce/reduce conflicts... - @ echo ' or' 27 shift/reduce and 61 reduce/reduce conflicts... - $(YACC) -d perly.y - sh ./perly.fixer y.tab.c perly.c - mv y.tab.h perly.h - echo 'extern YYSTYPE yylval;' >>perly.h - -perly.o: perly.c perly.h $(h) - $(CCCMD) perly.c - - -clean: - rm -f *.o - -realclean: clean - rm -f *.ttp report core - rm -f perly.c perly.h - -# The following lint has practically everything turned on. Unfortunately, -# you have to wade through a lot of mumbo jumbo that can't be suppressed. -# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message -# for that spot. - -lint: perly.c $(c) - lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz - -depend: makedepend - - test -f perly.h || cp /dev/null perly.h - ./makedepend - - test -s perly.h || /bin/rm -f perly.h - -test: perl - - cd t && chmod +x TEST */*.t - - cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST </dev/tty - -clist: - echo $(c) | tr ' ' '\012' >.clist - -hlist: - echo $(h) | tr ' ' '\012' >.hlist - -shlist: - echo $(sh) | tr ' ' '\012' >.shlist - -# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE -# If this runs make out of memory, delete /usr/include lines. -array.o: EXTERN.h -array.o: arg.h -array.o: array.c -array.o: array.h -array.o: cmd.h -array.o: config.h -array.o: form.h -array.o: handy.h -array.o: hash.h -array.o: perl.h -array.o: regexp.h -array.o: spat.h -array.o: stab.h -array.o: str.h -array.o: util.h -cmd.o: EXTERN.h -cmd.o: arg.h -cmd.o: array.h -cmd.o: cmd.c -cmd.o: cmd.h -cmd.o: config.h -cmd.o: form.h -cmd.o: handy.h -cmd.o: hash.h -cmd.o: perl.h -cmd.o: regexp.h -cmd.o: spat.h -cmd.o: stab.h -cmd.o: str.h -cmd.o: util.h -cons.o: EXTERN.h -cons.o: arg.h -cons.o: array.h -cons.o: cmd.h -cons.o: config.h -cons.o: cons.c -cons.o: form.h -cons.o: handy.h -cons.o: hash.h -cons.o: perl.h -cons.o: perly.h -cons.o: regexp.h -cons.o: spat.h -cons.o: stab.h -cons.o: str.h -cons.o: util.h -consarg.o: EXTERN.h -consarg.o: arg.h -consarg.o: array.h -consarg.o: cmd.h -consarg.o: config.h -consarg.o: consarg.c -consarg.o: form.h -consarg.o: handy.h -consarg.o: hash.h -consarg.o: perl.h -consarg.o: regexp.h -consarg.o: spat.h -consarg.o: stab.h -consarg.o: str.h -consarg.o: util.h -doarg.o: EXTERN.h -doarg.o: arg.h -doarg.o: array.h -doarg.o: cmd.h -doarg.o: config.h -doarg.o: doarg.c -doarg.o: form.h -doarg.o: handy.h -doarg.o: hash.h -doarg.o: perl.h -doarg.o: regexp.h -doarg.o: spat.h -doarg.o: stab.h -doarg.o: str.h -doarg.o: util.h -doio.o: EXTERN.h -doio.o: arg.h -doio.o: array.h -doio.o: cmd.h -doio.o: config.h -doio.o: doio.c -doio.o: form.h -doio.o: handy.h -doio.o: hash.h -doio.o: perl.h -doio.o: regexp.h -doio.o: spat.h -doio.o: stab.h -doio.o: str.h -doio.o: util.h -dolist.o: EXTERN.h -dolist.o: arg.h -dolist.o: array.h -dolist.o: cmd.h -dolist.o: config.h -dolist.o: dolist.c -dolist.o: form.h -dolist.o: handy.h -dolist.o: hash.h -dolist.o: perl.h -dolist.o: regexp.h -dolist.o: spat.h -dolist.o: stab.h -dolist.o: str.h -dolist.o: util.h -dump.o: EXTERN.h -dump.o: arg.h -dump.o: array.h -dump.o: cmd.h -dump.o: config.h -dump.o: dump.c -dump.o: form.h -dump.o: handy.h -dump.o: hash.h -dump.o: perl.h -dump.o: regexp.h -dump.o: spat.h -dump.o: stab.h -dump.o: str.h -dump.o: util.h -eval.o: EXTERN.h -eval.o: arg.h -eval.o: array.h -eval.o: cmd.h -eval.o: config.h -eval.o: eval.c -eval.o: form.h -eval.o: handy.h -eval.o: hash.h -eval.o: perl.h -eval.o: regexp.h -eval.o: spat.h -eval.o: stab.h -eval.o: str.h -eval.o: util.h -form.o: EXTERN.h -form.o: arg.h -form.o: array.h -form.o: cmd.h -form.o: config.h -form.o: form.c -form.o: form.h -form.o: handy.h -form.o: hash.h -form.o: perl.h -form.o: regexp.h -form.o: spat.h -form.o: stab.h -form.o: str.h -form.o: util.h -hash.o: EXTERN.h -hash.o: arg.h -hash.o: array.h -hash.o: cmd.h -hash.o: config.h -hash.o: form.h -hash.o: handy.h -hash.o: hash.c -hash.o: hash.h -hash.o: perl.h -hash.o: regexp.h -hash.o: spat.h -hash.o: stab.h -hash.o: str.h -hash.o: util.h -perl.o: EXTERN.h -perl.o: arg.h -perl.o: array.h -perl.o: cmd.h -perl.o: config.h -perl.o: form.h -perl.o: handy.h -perl.o: hash.h -perl.o: patchlevel.h -perl.o: perl.c -perl.o: perl.h -perl.o: perly.h -perl.o: regexp.h -perl.o: spat.h -perl.o: stab.h -perl.o: str.h -perl.o: util.h -regcomp.o: EXTERN.h -regcomp.o: INTERN.h -regcomp.o: arg.h -regcomp.o: array.h -regcomp.o: cmd.h -regcomp.o: config.h -regcomp.o: form.h -regcomp.o: handy.h -regcomp.o: hash.h -regcomp.o: perl.h -regcomp.o: regcomp.c -regcomp.o: regcomp.h -regcomp.o: regexp.h -regcomp.o: spat.h -regcomp.o: stab.h -regcomp.o: str.h -regcomp.o: util.h -regexec.o: EXTERN.h -regexec.o: arg.h -regexec.o: array.h -regexec.o: cmd.h -regexec.o: config.h -regexec.o: form.h -regexec.o: handy.h -regexec.o: hash.h -regexec.o: perl.h -regexec.o: regcomp.h -regexec.o: regexec.c -regexec.o: regexp.h -regexec.o: spat.h -regexec.o: stab.h -regexec.o: str.h -regexec.o: util.h -stab.o: EXTERN.h -stab.o: arg.h -stab.o: array.h -stab.o: cmd.h -stab.o: config.h -stab.o: form.h -stab.o: handy.h -stab.o: hash.h -stab.o: perl.h -stab.o: regexp.h -stab.o: spat.h -stab.o: stab.c -stab.o: stab.h -stab.o: str.h -stab.o: util.h -str.o: EXTERN.h -str.o: arg.h -str.o: array.h -str.o: cmd.h -str.o: config.h -str.o: form.h -str.o: handy.h -str.o: hash.h -str.o: perl.h -str.o: perly.h -str.o: regexp.h -str.o: spat.h -str.o: stab.h -str.o: str.c -str.o: str.h -str.o: util.h -toke.o: EXTERN.h -toke.o: arg.h -toke.o: array.h -toke.o: cmd.h -toke.o: config.h -toke.o: form.h -toke.o: handy.h -toke.o: hash.h -toke.o: perl.h -toke.o: perly.h -toke.o: regexp.h -toke.o: spat.h -toke.o: stab.h -toke.o: str.h -toke.o: toke.c -toke.o: util.h -util.o: EXTERN.h -util.o: arg.h -util.o: array.h -util.o: cmd.h -util.o: config.h -util.o: form.h -util.o: handy.h -util.o: hash.h -util.o: perl.h -util.o: regexp.h -util.o: spat.h -util.o: stab.h -util.o: str.h -util.o: util.c -util.o: util.h -atarist.o: EXTERN.h -atarist.o: arg.h -atarist.o: array.h -atarist.o: cmd.h -atarist.o: config.h -atarist.o: form.h -atarist.o: handy.h -atarist.o: hash.h -atarist.o: perl.h -atarist.o: regexp.h -atarist.o: spat.h -atarist.o: stab.h -atarist.o: str.h -atarist.o: atarist.c -atarist.o: util.h - -malloc.o: EXTERN.h -malloc.o: arg.h -malloc.o: array.h -malloc.o: cmd.h -malloc.o: config.h -malloc.o: form.h -malloc.o: handy.h -malloc.o: hash.h -malloc.o: perl.h -malloc.o: regexp.h -malloc.o: spat.h -malloc.o: stab.h -malloc.o: str.h -malloc.o: malloc.c -malloc.o: util.h - diff --git a/atarist/osbind.pl b/atarist/osbind.pl deleted file mode 100644 index 84f64fb2ae..0000000000 --- a/atarist/osbind.pl +++ /dev/null @@ -1,382 +0,0 @@ -# -# gemdos/xbios/bios interface on the atari -# -# ++jrb bammi@cadence.com -# - -# camel book pp204 -sub enum { - local($_) = @_; - local(@specs) = split(/,/); - local($val); - for(@specs) { - if(/=/) { - $val = eval $_; - } else { - eval $_ . ' = ++$val'; - } - } -} - -# these must match the defines in atarist.c - -&enum(<<'EOL'); -$_trap_1_w=1, $_trap_1_ww, $_trap_1_wl, $_trap_1_wlw, $_trap_1_www, -$_trap_1_wll, $_trap_1_wwll, $_trap_1_wlww, $_trap_1_wwlll, $_trap_13_w, -$_trap_13_ww, $_trap_13_wl, $_trap_13_www, $_trap_13_wwl, $_trap_13_wwlwww, -$_trap_14_w, $_trap_14_ww, $_trap_14_wl, $_trap_14_www, $_trap_14_wwl, -$_trap_14_wwll, $_trap_14_wllw, $_trap_14_wlll, $_trap_14_wwwl, -$_trap_14_wwwwl, $_trap_14_wllww, $_trap_14_wwwwwww, $_trap_14_wllwwwww, -$_trap_14_wllwwwwlw, $_trap_14_wllwwwwwlw -EOL - -sub Pterm0 { - syscall($_trap_1_w, 0x00); -} -sub Cconin { - syscall($_trap_1_w, 0x01); -} -sub Cconout { - syscall($_trap_1_ww, 0x02, @_); -} -sub Cauxin { - syscall($_trap_1_w, 0x03); -} -sub Cauxout { - syscall($_trap_1_ww, 0x04, @_); -} -sub Cprnout { - syscall($_trap_1_ww, 0x05, @_); -} -sub Crawio { - syscall($_trap_1_ww, 0x06, @_); -} -sub Crawcin { - syscall($_trap_1_w, 0x07); -} -sub Cnecin { - syscall($_trap_1_w, 0x08); -} -sub Cconws { - syscall($_trap_1_wl, 0x09, @_); -} -sub Cconrs { - syscall($_trap_1_wl, 0x0A, @_); -} -sub Cconis { - syscall($_trap_1_w, 0x0B); -} -sub Dsetdrv { - syscall($_trap_1_ww, 0x0E, @_); -} -sub Cconos { - syscall($_trap_1_w, 0x10); -} -sub Cprnos { - syscall($_trap_1_w, 0x11); -} -sub Cauxis { - syscall($_trap_1_w, 0x12); -} -sub Cauxos { - syscall($_trap_1_w, 0x13); -} -sub Dgetdrv { - syscall($_trap_1_w, 0x19); -} -sub Fsetdta { - syscall($_trap_1_wl, 0x1A, @_); -} -sub Super { - syscall($_trap_1_wl, 0x20, @_); -} -sub Tgetdate { - syscall($_trap_1_w, 0x2A); -} -sub Tsetdate { - syscall($_trap_1_ww, 0x2B, @_); -} -sub Tgettime { - syscall($_trap_1_w, 0x2C); -} -sub Tsettime { - syscall($_trap_1_ww, 0x2D, @_); -} -sub Fgetdta { - syscall($_trap_1_w, 0x2F); -} -sub Sversion { - syscall($_trap_1_w, 0x30); -} -sub Ptermres { - syscall($_trap_1_wlw, 0x31, @_); -} -sub Dfree { - syscall($_trap_1_wlw, 0x36, @_); -} -sub Dcreate { - syscall($_trap_1_wl, 0x39, @_); -} -sub Ddelete { - syscall($_trap_1_wl, 0x3A, @_); -} -sub Dsetpath { - syscall($_trap_1_wl, 0x3B, @_); -} -sub Fcreate { - syscall($_trap_1_wlw, 0x3C, @_); -} -sub Fopen { - syscall($_trap_1_wlw, 0x3D, @_); -} -sub Fclose { - syscall($_trap_1_ww, 0x3E, @_); -} -sub Fread { - syscall($_trap_1_wwll, 0x3F, @_); -} -sub Fwrite { - syscall($_trap_1_wwll, 0x40, @_); -} -sub Fdelete { - syscall($_trap_1_wl, 0x41, @_); -} -sub Fseek { - syscall($_trap_1_wlww, 0x42, @_); -} -sub Fattrib { - syscall($_trap_1_wlww, 0x43, @_); -} -sub Fdup { - syscall($_trap_1_ww, 0x45, @_); -} -sub Fforce { - syscall($_trap_1_www, 0x46, @_); -} -sub Dgetpath { - syscall($_trap_1_wlw, 0x47, @_); -} -sub Malloc { - syscall($_trap_1_wl, 0x48, @_); -} -sub Mfree { - syscall($_trap_1_wl, 0x49, @_); -} -sub Mshrink { - syscall($_trap_1_wwll, 0x4A, @_); -} -sub Pexec { - syscall($_trap_1_wwlll, 0x4B, @_); -} -sub Pterm { - syscall($_trap_1_ww, 0x4C, @_); -} -sub Fsfirst { - syscall($_trap_1_wlw, 0x4E, @_); -} -sub Fsnext { - syscall($_trap_1_w, 0x4F); -} -sub Frename { - syscall($_trap_1_wwll, 0x56, @_); -} -sub Fdatime { - syscall($_trap_1_wlww, 0x57, @_); -} -sub Getmpb { - syscall($_trap_13_wl, 0x00, @_); -} -sub Bconstat { - syscall($_trap_13_ww, 0x01, @_); -} -sub Bconin { - syscall($_trap_13_ww, 0x02, @_); -} -sub Bconout { - syscall($_trap_13_www, 0x03, @_); -} -sub Rwabs { - syscall($_trap_13_wwlwww, 0x04, @_); -} -sub Setexc { - syscall($_trap_13_wwl, 0x05, @_); -} -sub Tickcal { - syscall($_trap_13_w, 0x06); -} -sub Getbpb { - syscall($_trap_13_ww, 0x07, @_); -} -sub Bcostat { - syscall($_trap_13_ww, 0x08, @_); -} -sub Mediach { - syscall($_trap_13_ww, 0x09, @_); -} -sub Drvmap { - syscall($_trap_13_w, 0x0A); -} -sub Kbshift { - syscall($_trap_13_ww, 0x0B, @_); -} -sub Getshift { - &Kbshift(-1); -} -sub Initmous { - syscall($_trap_14_wwll, 0x00, @_); -} -sub Ssbrk { - syscall($_trap_14_ww, 0x01, @_); -} -sub Physbase { - syscall($_trap_14_w, 0x02); -} -sub Logbase { - syscall($_trap_14_w, 0x03); -} -sub Getrez { - syscall($_trap_14_w, 0x04); -} -sub Setscreen { - syscall($_trap_14_wllw, 0x05, @_); -} -sub Setpallete { - syscall($_trap_14_wl, 0x06, @_); -} -sub Setcolor { - syscall($_trap_14_www, 0x07, @_); -} -sub Floprd { - syscall($_trap_14_wllwwwww, 0x08, @_); -} -sub Flopwr { - syscall($_trap_14_wllwwwww, 0x09, @_); -} -sub Flopfmt { - syscall($_trap_14_wllwwwwwlw, 0x0A, @_); -} -sub Midiws { - syscall($_trap_14_wwl, 0x0C, @_); -} -sub Mfpint { - syscall($_trap_14_wwl, 0x0D, @_); -} -sub Iorec { - syscall($_trap_14_ww, 0x0E, @_); -} -sub Rsconf { - syscall($_trap_14_wwwwwww, 0x0F, @_); -} -sub Keytbl { - syscall($_trap_14_wlll, 0x10, @_); -} -sub Random { - syscall($_trap_14_w, 0x11); -} -sub Protobt { - syscall($_trap_14_wllww, 0x12, @_); -} -sub Flopver { - syscall($_trap_14_wllwwwww, 0x13, @_); -} -sub Scrdmp { - syscall($_trap_14_w, 0x14); -} -sub Cursconf { - syscall($_trap_14_www, 0x15, @_); -} -sub Settime { - syscall($_trap_14_wl, 0x16, @_); -} -sub Gettime { - syscall($_trap_14_w, 0x17); -} -sub Bioskeys { - syscall($_trap_14_w, 0x18); -} -sub Ikbdws { - syscall($_trap_14_wwl, 0x19, @_); -} -sub Jdisint { - syscall($_trap_14_ww, 0x1A, @_); -} -sub Jenabint { - syscall($_trap_14_ww, 0x1B, @_); -} -sub Giaccess { - syscall($_trap_14_www, 0x1C, @_); -} -sub Offgibit { - syscall($_trap_14_ww, 0x1D, @_); -} -sub Ongibit { - syscall($_trap_14_ww, 0x1E, @_); -} -sub Xbtimer { - syscall($_trap_14_wwwwl, 0x1E, @_); -} -sub Dosound { - syscall($_trap_14_wl, 0x20, @_); -} -sub Setprt { - syscall($_trap_14_ww, 0x21, @_); -} -sub Kbdvbase { - syscall($_trap_14_w, 0x22); -} -sub Kbrate { - syscall($_trap_14_www, 0x23, @_); -} -sub Prtblk { - syscall($_trap_14_wl, 0x24, @_); -} -sub Vsync { - syscall($_trap_14_w, 0x25); -} -sub Supexec { - syscall($_trap_14_wl, 0x26, @_); -} -sub Blitmode { - syscall($_trap_14_ww, 0x40, @_); -} -sub Mxalloc { - syscall($_trap_1_wlw, 0x44, @_); -} -sub Maddalt { - syscall($_trap_1_wll, 0x14, @_); -} -sub Setpalette { - syscall($_trap_14_wl, 0x06, @_); -} -sub EsetShift { - syscall($_trap_14_ww, 80, @_); -} -sub EgetShift { - syscall($_trap_14_w, 81); -} -sub EsetBank { - syscall($_trap_14_ww, 82, @_); -} -sub EsetColor { - syscall($_trap_14_www, 83, @_); -} -sub EsetPalette { - syscall($_trap_14_wwwl, 84, @_); -} -sub EgetPalette { - syscall($_trap_14_wwwl, 85, @_); -} -sub EsetGray { - syscall($_trap_14_ww, 86, @_); -} -sub EsetSmear { - syscall($_trap_14_ww, 87, @_); -} -sub Bconmap { - syscall($_trap_14_ww, 0x2b, @_); -} -sub Bconctl { - syscall($_trap_14_wwl, 0x2d, @_); -} - -1; diff --git a/atarist/perldb.diff b/atarist/perldb.diff deleted file mode 100644 index 8b78159bd5..0000000000 --- a/atarist/perldb.diff +++ /dev/null @@ -1,182 +0,0 @@ -*** ../../../lib/perldb.pl Mon Nov 11 10:40:22 1991 ---- perldb.pl Mon May 18 17:00:56 1992 -*************** -*** 1,10 **** - package DB; - -! # modified Perl debugger, to be run from Emacs in perldb-mode -! # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 -! # Johan Vromans -- upgrade to 4.0 pl 10 -! -! $header = '$RCSfile: perldb.diff,v $$Revision: 4.1 $$Date: 92/08/07 17:18:44 $'; - # - # This file is automatically included if you do perl -d. - # It's probably not useful to include this yourself. ---- 1,6 ---- - package DB; - -! $header = '$RCSfile: perldb.diff,v $$Revision: 4.1 $$Date: 92/08/07 17:18:44 $'; - # - # This file is automatically included if you do perl -d. - # It's probably not useful to include this yourself. -*************** -*** 14,22 **** - # have a breakpoint. It also inserts a do 'perldb.pl' before the first line. - # - # $Log: perldb.diff,v $ - # Revision 4.1 92/08/07 17:18:44 lwall - # Stage 6 Snapshot - # - # Revision 4.0.1.1 92/06/08 11:50:28 lwall - # Initial revision - # -- # Revision 4.0.1.2 91/11/05 17:55:58 lwall -- # patch11: perldb.pl modified to run within emacs in perldb-mode -- # - # Revision 4.0.1.1 91/06/07 11:17:44 lwall - # patch4: added $^P variable to control calling of perldb routines - # patch4: debugger sometimes listed wrong number of lines for a statement ---- 10,15 ---- -*************** -*** 56,63 **** - # - # - -! open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin -! open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout - select(OUT); - $| = 1; # for DB'OUT - select(STDOUT); ---- 49,56 ---- - # - # - -! open(IN, "</dev/console") || open(IN, "<&STDIN"); # so we don't dingle stdin -! open(OUT,">/dev/console") || open(OUT, ">&STDOUT"); # so we don't dongle stdout - select(OUT); - $| = 1; # for DB'OUT - select(STDOUT); -*************** -*** 64,79 **** - $| = 1; # for real STDOUT - $sub = ''; - -- # Is Perl being run from Emacs? -- $emacs = $main'ARGV[$[] eq '-emacs'; -- shift(@main'ARGV) if $emacs; -- - $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; -! print OUT "\nLoading DB routines from $header\n"; -! print OUT ("Emacs support ", -! $emacs ? "enabled" : "available", -! ".\n"); -! print OUT "\nEnter h for help.\n\n"; - - sub DB { - &save; ---- 57,64 ---- - $| = 1; # for real STDOUT - $sub = ''; - - $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; -! print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n"; - - sub DB { - &save; -*************** -*** 93,107 **** - } - } - if ($single || $trace || $signal) { -! if ($emacs) { -! print OUT "\032\032$filename:$line:0\n"; -! } else { -! print OUT "$package'" unless $sub =~ /'/; -! print OUT "$sub($filename:$line):\t",$dbline[$line]; -! for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { -! last if $dbline[$i] =~ /^\s*(}|#|\n)/; -! print OUT "$sub($filename:$i):\t",$dbline[$i]; -! } - } - } - $evalarg = $action, &eval if $action; ---- 78,88 ---- - } - } - if ($single || $trace || $signal) { -! print OUT "$package'" unless $sub =~ /'/; -! print OUT "$sub($filename:$line):\t",$dbline[$line]; -! for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { -! last if $dbline[$i] =~ /^\s*(;|}|#|\n)/; -! print OUT "$sub($filename:$i):\t",$dbline[$i]; - } - } - $evalarg = $action, &eval if $action; -*************** -*** 263,276 **** - $i = $2; - $i = $line if $i eq '.'; - $i = 1 if $i < 1; -! if ($emacs) { -! print OUT "\032\032$filename:$i:0\n"; -! $i = $end; -! } else { -! for (; $i <= $end; $i++) { -! print OUT "$i:\t", $dbline[$i]; -! last if $signal; -! } - } - $start = $i; # remember in case they want more - $start = $max if $start > $max; ---- 244,252 ---- - $i = $2; - $i = $line if $i eq '.'; - $i = 1 if $i < 1; -! for (; $i <= $end; $i++) { -! print OUT "$i:\t", $dbline[$i]; -! last if $signal; - } - $start = $i; # remember in case they want more - $start = $max if $start > $max; -*************** -*** 417,427 **** - $start = 1 if ($start > $max); - last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { -! if ($emacs) { -! print OUT "\032\032$filename:$start:0\n"; -! } else { -! print OUT "$start:\t", $dbline[$start], "\n"; -! } - last; - } - } '; ---- 393,399 ---- - $start = 1 if ($start > $max); - last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { -! print OUT "$start:\t", $dbline[$start], "\n"; - last; - } - } '; -*************** -*** 445,455 **** - $start = $max if ($start <= 0); - last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { -! if ($emacs) { -! print OUT "\032\032$filename:$start:0\n"; -! } else { -! print OUT "$start:\t", $dbline[$start], "\n"; -! } - last; - } - } '; ---- 417,423 ---- - $start = $max if ($start <= 0); - last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { -! print OUT "$start:\t", $dbline[$start], "\n"; - last; - } - } '; diff --git a/atarist/perlglob.c b/atarist/perlglob.c deleted file mode 100644 index 002639ede2..0000000000 --- a/atarist/perlglob.c +++ /dev/null @@ -1,45 +0,0 @@ -/* - * glob and echo any globbed args - * - * ++jrb bammi@cadence.com - */ - -#include <stdio.h> - -#if __STDC__ -# include <compiler.h> -#else -# define __PROTO(X) () -#endif - -char **glob __PROTO((char *patt, int decend_dir)); -int contains_wild __PROTO((char *patt)); -void free_all __PROTO((void)); - - -int main(argc, argv) -int argc; -char **argv; -{ - --argc; ++argv; - while(argc--) - { - char *word = *argv; - char **list; - int did_some = 0; - - if(contains_wild(word) && (list = glob(word, 0))) - { - while(*list) - { - fputs(*list, stdout); - if(*++list) putchar(' '); - } - free_all(); - did_some = 1; - } - if(*++argv && did_some) putchar(' '); - } - putchar('\0'); - return 0; -} diff --git a/atarist/test/binhandl b/atarist/test/binhandl deleted file mode 100644 index 6f62f4d6cc..0000000000 --- a/atarist/test/binhandl +++ /dev/null @@ -1,15 +0,0 @@ -die "Usage: binhandl files ...\n" if $#ARGV < $[; - -NEXTFILE: -while ($FILEHAND = shift) { - unless (open(FILEHAND)) { - printf STDERR "Can't open \"$FILEHAND\"\n"; - next NEXTFILE; - } - if (-B FILEHAND) { - print "\"$FILEHAND\" is binary\n"; - } else { - print "\"$FILEHAND\" is text\n"; - } - close(FILEHAND); -} diff --git a/atarist/test/ccon b/atarist/test/ccon deleted file mode 100644 index 47bc8e2f05..0000000000 --- a/atarist/test/ccon +++ /dev/null @@ -1,5 +0,0 @@ -require 'osbind.pl'; - - &Cconws("Hello World\r\n"); - $str = "This is a string being printed by Fwrite Gemdos trap\r\n"; - &Fwrite(1, length($str), $str); diff --git a/atarist/test/dbm b/atarist/test/dbm deleted file mode 100644 index b73e07dccb..0000000000 --- a/atarist/test/dbm +++ /dev/null @@ -1,124 +0,0 @@ -die "cant create dbmtest" unless dbmopen(%keys, "dbmtest", 0666); - -print "Writing...\n"; -$keys{'key0'} = 0; -$keys{'key1'} = 1; -$keys{'key2'} = 2; -$keys{'key3'} = 3; -$keys{'key4'} = 4; -$keys{'key5'} = 5; -$keys{'key6'} = 6; -$keys{'key7'} = 7; -$keys{'key8'} = 8; -$keys{'key9'} = 9; -$keys{'key10'} = 10; -$keys{'key11'} = 11; -$keys{'key12'} = 12; -$keys{'key13'} = 13; -$keys{'key14'} = 14; -$keys{'key15'} = 15; -$keys{'key16'} = 16; -$keys{'key17'} = 17; -$keys{'key18'} = 18; -$keys{'key19'} = 19; -$keys{'key20'} = 20; -$keys{'key21'} = 21; -$keys{'key22'} = 22; -$keys{'key23'} = 23; -$keys{'key24'} = 24; -$keys{'key25'} = 25; -$keys{'key26'} = 26; -$keys{'key27'} = 27; -$keys{'key28'} = 28; -$keys{'key29'} = 29; -$keys{'key30'} = 30; -$keys{'key31'} = 31; -$keys{'key32'} = 32; -$keys{'key33'} = 33; -$keys{'key34'} = 34; -$keys{'key35'} = 35; -$keys{'key36'} = 36; -$keys{'key37'} = 37; -$keys{'key38'} = 38; -$keys{'key39'} = 39; -$keys{'key40'} = 40; -$keys{'key41'} = 41; -$keys{'key42'} = 42; -$keys{'key43'} = 43; -$keys{'key44'} = 44; -$keys{'key45'} = 45; -$keys{'key46'} = 46; -$keys{'key47'} = 47; -$keys{'key48'} = 48; -$keys{'key49'} = 49; -$keys{'key50'} = 50; -$keys{'key51'} = 51; -$keys{'key52'} = 52; -$keys{'key53'} = 53; -$keys{'key54'} = 54; -$keys{'key55'} = 55; -$keys{'key56'} = 56; -$keys{'key57'} = 57; -$keys{'key58'} = 58; -$keys{'key59'} = 59; -$keys{'key60'} = 60; -$keys{'key61'} = 61; -$keys{'key62'} = 62; -$keys{'key63'} = 63; -$keys{'key64'} = 64; -$keys{'key65'} = 65; -$keys{'key66'} = 66; -$keys{'key67'} = 67; -$keys{'key68'} = 68; -$keys{'key69'} = 69; -$keys{'key70'} = 70; -$keys{'key71'} = 71; -$keys{'key72'} = 72; -$keys{'key73'} = 73; -$keys{'key74'} = 74; -$keys{'key75'} = 75; -$keys{'key76'} = 76; -$keys{'key77'} = 77; -$keys{'key78'} = 78; -$keys{'key79'} = 79; -$keys{'key80'} = 80; -$keys{'key81'} = 81; -$keys{'key82'} = 82; -$keys{'key83'} = 83; -$keys{'key84'} = 84; -$keys{'key85'} = 85; -$keys{'key86'} = 86; -$keys{'key87'} = 87; -$keys{'key88'} = 88; -$keys{'key89'} = 89; -$keys{'key90'} = 90; -$keys{'key91'} = 91; -$keys{'key92'} = 92; -$keys{'key93'} = 93; -$keys{'key94'} = 94; -$keys{'key95'} = 95; -$keys{'key96'} = 96; -$keys{'key97'} = 97; -$keys{'key98'} = 98; -$keys{'key99'} = 99; -$keys{'key9998'} = 9998; -$keys{'key9999'} = 9999; -print "Done\n"; - -dbmclose (%keys); - -die "cant read dbmtest" unless dbmopen(%rkeys, "dbmtest", undef); - -$i = 0; -print "Reading...\n"; -while (($key, $val) = each %rkeys) -{ - if ($keys{$key} != $val) - { - print 'Incorrect val ', $key, ' = ', $val, ' expecting ', $keys{$key}, "\n"; - $i = $i + 1; - } -} -print "Done\n"; -dbmclose (%keys); -print $i, "Error(s)\n"; diff --git a/atarist/test/err b/atarist/test/err deleted file mode 100644 index cf32624c0f..0000000000 --- a/atarist/test/err +++ /dev/null @@ -1,4 +0,0 @@ -$! = 0 + 0; -print $!, "\n"; -$e = $! + 0; -print $e, "\n"; diff --git a/atarist/test/gdbm b/atarist/test/gdbm deleted file mode 100644 index 207eea39a1..0000000000 --- a/atarist/test/gdbm +++ /dev/null @@ -1,28 +0,0 @@ -die "cant create dbmtest" unless dbmopen(%keys, "dbmtest", 0666); - -print "Writing...\n"; - -foreach (0..100) { - $keys{"$_"} = $_; -} - -print "Done\n"; - -dbmclose (%keys); - -die "cant read dbmtest" unless dbmopen(%rkeys, "dbmtest", undef); - -$i = 0; -print "Reading...\n"; -while (($key, $val) = each %rkeys) -{ - if ($keys{$key} != $val) - { - print 'Incorrect val ', $key, ' = ', $val, ' expecting ', $keys{$key}, "\n"; - $i = $i + 1; - } -} -print "Done\n"; -dbmclose (%keys); -print $i, " Error(s)\n"; -unlink "dbmtest"; diff --git a/atarist/test/glob b/atarist/test/glob deleted file mode 100644 index c090c56b8e..0000000000 --- a/atarist/test/glob +++ /dev/null @@ -1,4 +0,0 @@ -while(<*.pl>) -{ - print $_, "\n"; -} diff --git a/atarist/test/osexample.pl b/atarist/test/osexample.pl deleted file mode 100644 index 47bc8e2f05..0000000000 --- a/atarist/test/osexample.pl +++ /dev/null @@ -1,5 +0,0 @@ -require 'osbind.pl'; - - &Cconws("Hello World\r\n"); - $str = "This is a string being printed by Fwrite Gemdos trap\r\n"; - &Fwrite(1, length($str), $str); diff --git a/atarist/test/pi.pl b/atarist/test/pi.pl deleted file mode 100644 index b7766bb7e3..0000000000 --- a/atarist/test/pi.pl +++ /dev/null @@ -1,174 +0,0 @@ -# --------------------------------------------------------------------------- -# pi.perl computes pi (3.14...) about 5120 Digits -# -# W. Kebsch, July-1988 {uunet!mcvax}!unido!nixpbe!kebsch - -$my_name = $0; -$version = $my_name . "-1.2"; - -# some working parameter - -$smax = 5120; # max digits -$lmax = 4; # digits per one array element -$hmax = 10000; # one array element contains: 0..9999 -$smin = $lmax; # min digits -$mag = 7; # magic number - -# subroutines - -sub mul_tm # multiply the tm array with a long value -{ - $cb = pop(@_); # elements(array) - $x = pop(@_); # value - - $c = 0; - for($i = 1; $i <= $cb; $i++) - { - $z = $tm[$i] * $x + $c; - $c = int($z / $hmax); - $tm[$i] = $z - $c * $hmax; - } -} - -sub mul_pm # multiply the pm array with a long value -{ - $cb = pop(@_); # elements(array) - $x = pop(@_); # value - - $c = 0; - for($i = 1; $i <= $cb; $i++) - { - $z = $pm[$i] * $x + $c; - $c = int($z / $hmax); - $pm[$i] = $z - $c * $hmax; - } -} - -sub divide # divide the tm array by a long value -{ - $cb = pop(@_); # elements(array) - $x = pop(@_); # value - - $c = 0; - for($i = $cb; $i >= 1; $i--) - { - $z = $tm[$i] + $c; - $q = int($z / $x); - $tm[$i] = $q; - $c = ($z - $q * $x) * $hmax; - } -} - -sub add # add tm array to pm array -{ - $cb = pop(@_); # elements(array) - - $c = 0; - for($i = 1; $i <= $cb; $i++) - { - $z = $pm[$i] + $tm[$i] + $c; - if($z >= $hmax) - { - $pm[$i] = $z - $hmax; - $c = 1; - } - else - { - $pm[$i] = $z; - $c = 0; - } - } -} - -$m0 = 0; $m1 = 0; $m2 = 0; - -sub check_xb # reduce current no. of elements (speed up!) -{ - $cb = pop(@_); # current no. of elements - - if(($pm[$cb] == $m0) && ($pm[$cb - 1] == $m1) && ($pm[$cb - 2] == $m2)) - { - $cb--; - } - $m0 = $pm[$cb]; - $m1 = $pm[$cb - 1]; - $m2 = $pm[$cb - 2]; - $cb; -} - -sub display # show the result -{ - $cb = pop(@_); # elements(array); - - printf("\n%3d.", $pm[$cb]); - $j = $mag - $lmax; - for($i = $cb - 1; $i >= $j; $i--) - { - printf(" %04d", $pm[$i]); - } - print "\n"; -} - -sub the_job # let's do the job -{ - $s = pop(@_); # no. of digits - - $s = int(($s + $lmax - 1) / $lmax) * $lmax; - $b = int($s / $lmax) + $mag - $lmax; - $xb = $b; - $t = int($s * 5 / 3); - - for($i = 1; $i <= $b; $i++) # init arrays - { - $pm[$i] = 0; - $tm[$i] = 0; - } - $pm[$b - 1] = $hmax / 2; - $tm[$b - 1] = $hmax / 2; - - printf("digits:%5d, terms:%5d, elements:%5d\n", $s, $t, $b); - for($n = 1; $n <= $t; $n++) - { - printf("\r\t\t\t term:%5d", $n); - if($n < 200) - { - do mul_tm((4 * ($n * $n - $n) + 1), $xb); - } - else - { - do mul_tm((2 * $n - 1), $xb); - do mul_tm((2 * $n - 1), $xb); - } - if($n < 100) - { - do divide(($n * (16 * $n + 8)), $xb); - } - else - { - do divide((8 * $n), $xb); - do divide((2 * $n + 1), $xb); - } - do add($xb); - if($xb > $mag) - { - $xb = do check_xb($xb); - } - } - do mul_pm(6, $b); - do display($b); - ($user,$sys,$cuser,$csys) = times; - printf("\n[u=%g s=%g cu=%g cs=%g]\n",$user, $sys, $cuser, $csys); -} - -# main block ---------------------------------------------------------------- - -$no_of_args = $#ARGV + 1; -print("$version, "); -die("usage: $my_name <no. of digits>") unless($no_of_args == 1); -$digits = int($ARGV[0]); -die("no. of digits out of range [$smin\..$smax]") - unless(($digits >= $smin) && ($digits <= $smax)); -do the_job($digits); -exit 0; - -# That's all ---------------------------------------------------------------- diff --git a/atarist/test/printenv b/atarist/test/printenv deleted file mode 100644 index 6c2619ae49..0000000000 --- a/atarist/test/printenv +++ /dev/null @@ -1,16 +0,0 @@ -$exit = 0; -$\ = "\n"; -if($#ARGV >= 0) { - foreach (@ARGV) { - if(defined $ENV{$_}) { - print $ENV{$_}; - } else { - $exit = 1; - } - } -} else { - foreach (sort keys %ENV) { - print $_, '=', $ENV{$_}; - } -} -exit $exit; diff --git a/atarist/test/readme b/atarist/test/readme deleted file mode 100644 index 9b75f99b91..0000000000 --- a/atarist/test/readme +++ /dev/null @@ -1,3 +0,0 @@ -this directory contain simple tests for the atariST port. to run a test -simply enter - perl file diff --git a/atarist/test/sig b/atarist/test/sig deleted file mode 100644 index ac1b2b2fee..0000000000 --- a/atarist/test/sig +++ /dev/null @@ -1,12 +0,0 @@ -sub handler { - local($sig) = @_; - print "Caught SIG$sig\n"; - exit(0); -} - -$SIG{'INT'} = 'handler'; - -print "Hit CRTL-C to see if it is trapped\n"; -while($_ = <ARGV>) { - print $_; -} diff --git a/atarist/test/tbinmode b/atarist/test/tbinmode deleted file mode 100644 index 4cf4f7827f..0000000000 --- a/atarist/test/tbinmode +++ /dev/null @@ -1,12 +0,0 @@ -open(FP, ">bintest") || die "Can't open bintest for write\n"; -binmode FP; -print FP pack("C*", 0xaa, 0x55, 0xaa, 0x55, - 0xff, 0x0d, 0x0a); -close FP; - -open(FP, "<bintest") || die "Can't open bintest for read\n"; -binmode FP; -@got = unpack("C*", <FP>); -close FP; -printf "expect:\t7 elements: aa 55 aa 55 ff 0d 0a\n"; -printf "got:\t%d elements: %x %x %x %x %x %02x %02x\n", $#got+1-$[, @got; diff --git a/atarist/usersub.c b/atarist/usersub.c deleted file mode 100644 index aba53d7903..0000000000 --- a/atarist/usersub.c +++ /dev/null @@ -1,9 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include <stdio.h> - -int userinit() -{ - install_null(); /* install device /dev/null or NUL: */ - return 0; -} diff --git a/atarist/usub/README.ATARI b/atarist/usub/README.ATARI deleted file mode 100644 index 89174ebe1b..0000000000 --- a/atarist/usub/README.ATARI +++ /dev/null @@ -1 +0,0 @@ -For the atariST bsd derived curses use acurses.mus (its got its own wrinkles!) diff --git a/atarist/usub/acurses.mus b/atarist/usub/acurses.mus deleted file mode 100644 index 67e6b74e0f..0000000000 --- a/atarist/usub/acurses.mus +++ /dev/null @@ -1,704 +0,0 @@ -/* $RCSfile: acurses.mus,v $$Revision: 4.1 $$Date: 92/08/07 17:19:04 $ - * - * $Log: acurses.mus,v $ - * Revision 4.1 92/08/07 17:19:04 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.1 92/06/08 11:54:30 lwall - * Initial revision - * - * Revision 4.0.1.1 91/11/05 19:04:53 lwall - * initial checkin - * - * Revision 4.0 91/03/20 01:56:13 lwall - * 4.0 baseline. - * - * Revision 3.0.1.1 90/08/09 04:05:21 lwall - * patch19: Initial revision - * - */ - -#include "EXTERN.h" -#include "perl.h" - -char *savestr(); - -#ifdef atarist /* save and restore definition of VOID around curses.h */ -# define __SAVEVOID VOID -# undef VOID -#endif - -#include <curses.h> - -static enum uservars { - UV_curscr, - UV_stdscr, - UV_Def_term, - UV_My_term, - UV_ttytype, - UV_LINES, - UV_COLS, - UV_ERR, - UV_OK, -}; - -static enum usersubs { - US_addch, - US_waddch, - US_addstr, - US_waddstr, - US_box, - US_clear, - US_wclear, - US_clearok, - US_clrtobot, - US_wclrtobot, - US_clrtoeol, - US_wclrtoeol, - US_delch, - US_wdelch, - US_deleteln, - US_wdeleteln, - US_erase, - US_werase, - US_flushok, - US_idlok, - US_insch, - US_winsch, - US_insertln, - US_winsertln, - US_move, - US_wmove, - US_overlay, - US_overwrite, - US_printw, - US_wprintw, - US_refresh, - US_wrefresh, - US_standout, - US_wstandout, - US_standend, - US_wstandend, - US_cbreak, - US_nocbreak, - US_echo, - US_noecho, - US_getch, - US_wgetch, - US_getstr, - US_wgetstr, - US_raw, - US_noraw, - US_scanw, - US_wscanw, - US_baudrate, - US_delwin, - US_endwin, - US_erasechar, - US_getcap, - US_getyx, - US_inch, - US_winch, - US_initscr, - US_killchar, - US_leaveok, - US_longname, - US_fullname, - US_mvwin, - US_newwin, - US_nl, - US_nonl, - US_scrollok, - US_subwin, - US_touchline, - US_touchoverlap, - US_touchwin, - US_unctrl, - US_gettmode, - US_mvcur, - US_scroll, - US_savetty, - US_resetty, - US_setterm, - US_tstp, - US__putchar, - US_testcallback, -}; - -static int usersub(); -static int userset(); -static int userval(); - -int -init_curses() -{ - struct ufuncs uf; - char *filename = "curses.c"; - - uf.uf_set = userset; - uf.uf_val = userval; - -#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf) - - MAGICVAR("curscr", UV_curscr); - MAGICVAR("stdscr", UV_stdscr); - MAGICVAR("Def_term",UV_Def_term); - MAGICVAR("My_term", UV_My_term); - MAGICVAR("ttytype", UV_ttytype); - MAGICVAR("LINES", UV_LINES); - MAGICVAR("COLS", UV_COLS); - MAGICVAR("ERR", UV_ERR); - MAGICVAR("OK", UV_OK); - - make_usub("addch", US_addch, usersub, filename); - make_usub("waddch", US_waddch, usersub, filename); - make_usub("addstr", US_addstr, usersub, filename); - make_usub("waddstr", US_waddstr, usersub, filename); - make_usub("box", US_box, usersub, filename); - make_usub("clear", US_clear, usersub, filename); - make_usub("wclear", US_wclear, usersub, filename); - make_usub("clearok", US_clearok, usersub, filename); - make_usub("clrtobot", US_clrtobot, usersub, filename); - make_usub("wclrtobot", US_wclrtobot, usersub, filename); - make_usub("clrtoeol", US_clrtoeol, usersub, filename); - make_usub("wclrtoeol", US_wclrtoeol, usersub, filename); - make_usub("delch", US_delch, usersub, filename); - make_usub("wdelch", US_wdelch, usersub, filename); - make_usub("deleteln", US_deleteln, usersub, filename); - make_usub("wdeleteln", US_wdeleteln, usersub, filename); - make_usub("erase", US_erase, usersub, filename); - make_usub("werase", US_werase, usersub, filename); - make_usub("flushok", US_flushok, usersub, filename); - make_usub("idlok", US_idlok, usersub, filename); - make_usub("insch", US_insch, usersub, filename); - make_usub("winsch", US_winsch, usersub, filename); - make_usub("insertln", US_insertln, usersub, filename); - make_usub("winsertln", US_winsertln, usersub, filename); - make_usub("move", US_move, usersub, filename); - make_usub("wmove", US_wmove, usersub, filename); - make_usub("overlay", US_overlay, usersub, filename); - make_usub("overwrite", US_overwrite, usersub, filename); - make_usub("printw", US_printw, usersub, filename); - make_usub("wprintw", US_wprintw, usersub, filename); - make_usub("refresh", US_refresh, usersub, filename); - make_usub("wrefresh", US_wrefresh, usersub, filename); - make_usub("standout", US_standout, usersub, filename); - make_usub("wstandout", US_wstandout, usersub, filename); - make_usub("standend", US_standend, usersub, filename); - make_usub("wstandend", US_wstandend, usersub, filename); - make_usub("cbreak", US_cbreak, usersub, filename); - make_usub("nocbreak", US_nocbreak, usersub, filename); - make_usub("echo", US_echo, usersub, filename); - make_usub("noecho", US_noecho, usersub, filename); - make_usub("getch", US_getch, usersub, filename); - make_usub("wgetch", US_wgetch, usersub, filename); - make_usub("getstr", US_getstr, usersub, filename); - make_usub("wgetstr", US_wgetstr, usersub, filename); - make_usub("raw", US_raw, usersub, filename); - make_usub("noraw", US_noraw, usersub, filename); - make_usub("scanw", US_scanw, usersub, filename); - make_usub("wscanw", US_wscanw, usersub, filename); - make_usub("baudrate", US_baudrate, usersub, filename); - make_usub("delwin", US_delwin, usersub, filename); - make_usub("endwin", US_endwin, usersub, filename); - make_usub("erasechar", US_erasechar, usersub, filename); - make_usub("getcap", US_getcap, usersub, filename); - make_usub("getyx", US_getyx, usersub, filename); - make_usub("inch", US_inch, usersub, filename); - make_usub("winch", US_winch, usersub, filename); - make_usub("initscr", US_initscr, usersub, filename); - make_usub("killchar", US_killchar, usersub, filename); - make_usub("leaveok", US_leaveok, usersub, filename); - make_usub("longname", US_longname, usersub, filename); - make_usub("fullname", US_fullname, usersub, filename); - make_usub("mvwin", US_mvwin, usersub, filename); - make_usub("newwin", US_newwin, usersub, filename); - make_usub("nl", US_nl, usersub, filename); - make_usub("nonl", US_nonl, usersub, filename); - make_usub("scrollok", US_scrollok, usersub, filename); - make_usub("subwin", US_subwin, usersub, filename); - make_usub("touchline", US_touchline, usersub, filename); - make_usub("touchoverlap", US_touchoverlap,usersub, filename); - make_usub("touchwin", US_touchwin, usersub, filename); - make_usub("unctrl", US_unctrl, usersub, filename); - make_usub("gettmode", US_gettmode, usersub, filename); - make_usub("mvcur", US_mvcur, usersub, filename); - make_usub("scroll", US_scroll, usersub, filename); - make_usub("savetty", US_savetty, usersub, filename); - make_usub("resetty", US_resetty, usersub, filename); - make_usub("setterm", US_setterm, usersub, filename); - make_usub("tstp", US_tstp, usersub, filename); - make_usub("_putchar", US__putchar, usersub, filename); - make_usub("testcallback", US_testcallback,usersub, filename); -}; - -static int -usersub(ix, sp, items) -int ix; -register int sp; -register int items; -{ - STR **st = stack->ary_array + sp; - register int i; - register char *tmps; - register STR *Str; /* used in str_get and str_gnum macros */ - - switch (ix) { -CASE int addch -I char ch -END - -CASE int waddch -I WINDOW* win -I char ch -END - -CASE int addstr -I char* str -END - -CASE int waddstr -I WINDOW* win -I char* str -END - -CASE void box -I WINDOW* win -I char vert -I char hor -END - -CASE int clear -END - -CASE int wclear -I WINDOW* win -END - -CASE int clearok -I WINDOW* win -I bool boolf -END - -CASE void clrtobot -END - -CASE void wclrtobot -I WINDOW* win -END - -CASE void clrtoeol -END - -CASE void wclrtoeol -I WINDOW* win -END - -CASE int delch -END - -CASE int wdelch -I WINDOW* win -END - -CASE int deleteln -END - -CASE int wdeleteln -I WINDOW* win -END - -CASE void erase -END - -CASE void werase -I WINDOW* win -END - -CASE int flushok -I WINDOW* win -I bool boolf -END - -CASE void idlok -I WINDOW* win -I bool boolf -END - -CASE int insch -I char c -END - -CASE int winsch -I WINDOW* win -I char c -END - -CASE void insertln -END - -CASE void winsertln -I WINDOW* win -END - -CASE int move -I int y -I int x -END - -CASE int wmove -I WINDOW* win -I int y -I int x -END - -CASE void overlay -I WINDOW* win1 -I WINDOW* win2 -END - -CASE void overwrite -I WINDOW* win1 -I WINDOW* win2 -END - - case US_printw: - if (items < 1) - fatal("Usage: &printw($fmt, $arg1, $arg2, ... )"); - else { - int retval; - STR* str = str_new(0); - - do_sprintf(str, items - 1, st + 1); - retval = addstr(str->str_ptr); - str_numset(st[0], (double) retval); - str_free(str); - } - return sp; - - case US_wprintw: - if (items < 2) - fatal("Usage: &wprintw($win, $fmt, $arg1, $arg2, ... )"); - else { - int retval; - STR* str = str_new(0); - WINDOW* win = *(WINDOW**) str_get(st[1]); - - do_sprintf(str, items - 1, st + 1); - retval = waddstr(win, str->str_ptr); - str_numset(st[0], (double) retval); - str_free(str); - } - return sp; - -CASE int refresh -END - -CASE int wrefresh -I WINDOW* win -END - -CASE int standout -END - -CASE void wstandout -I WINDOW* win -END - -CASE int standend -END - -CASE void wstandend -I WINDOW* win -END - -CASE int cbreak -END - -CASE int nocbreak -END - -CASE int echo -END - -CASE int noecho -END - - case US_getch: - if (items != 0) - fatal("Usage: &getch()"); - else { - int retval; - char retch; - - retval = getch(); - if (retval == EOF) - st[0] = &str_undef; - else { - retch = retval; - str_nset(st[0], &retch, 1); - } - } - return sp; - - case US_wgetch: - if (items != 1) - fatal("Usage: &wgetch($win)"); - else { - int retval; - char retch; - WINDOW* win = *(WINDOW**) str_get(st[1]); - - retval = wgetch(win); - if (retval == EOF) - st[0] = &str_undef; - else { - retch = retval; - str_nset(st[0], &retch, 1); - } - } - return sp; - -CASE int getstr -IO char* str -END - -CASE int wgetstr -I WINDOW* win -IO char* str -END - -CASE int raw -END - -CASE int noraw -END - -CASE int baudrate -END - -CASE void delwin -I WINDOW* win -END - -CASE void endwin -END - -CASE int erasechar -END - - case US_getcap: - if (items != 1) - fatal("Usage: &getcap($str)"); - else { - char* retval; - char* str = (char*) str_get(st[1]); - char output[50], *outputp = output; - - retval = tgetstr(str, &outputp); - str_set(st[0], (char*) retval); - } - return sp; - - case US_getyx: - if (items != 3) - fatal("Usage: &getyx($win, $y, $x)"); - else { - int retval; - STR* str = str_new(0); - WINDOW* win = *(WINDOW**) str_get(st[1]); - int y; - int x; - - do_sprintf(str, items - 1, st + 1); - retval = getyx(win, y, x); - str_numset(st[2], (double)y); - str_numset(st[3], (double)x); - str_numset(st[0], (double) retval); - str_free(str); - } - return sp; - - -CASE int inch -END - -CASE int winch -I WINDOW* win -END - -CASE WINDOW* initscr -END - -CASE int killchar -END - -CASE int leaveok -I WINDOW* win -I bool boolf -END - -CASE char* longname -I char* termbuf -IO char* name -END - -CASE int fullname -I char* termbuf -IO char* name -END - -CASE int mvwin -I WINDOW* win -I int y -I int x -END - -CASE WINDOW* newwin -I int lines -I int cols -I int begin_y -I int begin_x -END - -CASE int nl -END - -CASE int nonl -END - -CASE int scrollok -I WINDOW* win -I bool boolf -END - -CASE WINDOW* subwin -I WINDOW* win -I int lines -I int cols -I int begin_y -I int begin_x -END - -CASE void touchline -I WINDOW* win -I int y -I int startx -I int endx -END - -CASE void touchoverlap -I WINDOW* win1 -I WINDOW* win2 -END - -CASE void touchwin -I WINDOW* win -END - -CASE char* unctrl -I char ch -END - -CASE void gettmode -END - -CASE void mvcur -I int lasty -I int lastx -I int newy -I int newx -END - -CASE int scroll -I WINDOW* win -END - -CASE int savetty -END - -CASE void resetty -END - -CASE int setterm -I char* name -END - -CASE void tstp -END - -CASE int _putchar -I char ch -END - - case US_testcallback: - sp = callback("callback", sp + items, curcsv->wantarray, 1, items); - break; - - default: - fatal("Unimplemented user-defined subroutine"); - } - return sp; -} - -static int -userval(ix, str) -int ix; -STR *str; -{ - switch (ix) { - case UV_COLS: - str_numset(str, (double)COLS); - break; - case UV_Def_term: - str_set(str, Def_term); - break; - case UV_ERR: - str_numset(str, (double)ERR); - break; - case UV_LINES: - str_numset(str, (double)LINES); - break; - case UV_My_term: - str_numset(str, (double)My_term); - break; - case UV_OK: - str_numset(str, (double)OK); - break; - case UV_curscr: - str_nset(str, &curscr, sizeof(WINDOW*)); - break; - case UV_stdscr: - str_nset(str, &stdscr, sizeof(WINDOW*)); - break; - case UV_ttytype: - str_set(str, ttytype); - break; - } - return 0; -} - -static int -userset(ix, str) -int ix; -STR *str; -{ - switch (ix) { - case UV_COLS: - COLS = (int)str_gnum(str); - break; - case UV_Def_term: - Def_term = savestr(str_get(str)); /* never freed */ - break; - case UV_LINES: - LINES = (int)str_gnum(str); - break; - case UV_My_term: - My_term = (bool)str_gnum(str); - break; - case UV_ttytype: - strcpy(ttytype, str_get(str)); /* hope it fits */ - break; - } - return 0; -} diff --git a/atarist/usub/makefile.st b/atarist/usub/makefile.st deleted file mode 100644 index ede484f336..0000000000 --- a/atarist/usub/makefile.st +++ /dev/null @@ -1,17 +0,0 @@ -CC = cgcc -SRC = .. -GLOBINCS = -LOCINCS = -LIBS = -lcurses -lgdbm -lpml -lgnu - -cperl.ttp: $(SRC)/uperl.a usersub.o curses.o - $(CC) $(SRC)/uperl.a usersub.o curses.o $(LIBS) -o cperl.ttp - -usersub.o: usersub.c - $(CC) -c -I$(SRC) $(GLOBINCS) -O usersub.c - -curses.o: curses.c - $(CC) -c -I$(SRC) $(GLOBINCS) -O curses.c - -curses.c: acurses.mus - perl mus acurses.mus >curses.c diff --git a/atarist/usub/usersub.c b/atarist/usub/usersub.c deleted file mode 100644 index 5083db1177..0000000000 --- a/atarist/usub/usersub.c +++ /dev/null @@ -1,30 +0,0 @@ -/* $RCSfile: usersub.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:07 $ - * - * $Log: usersub.c,v $ - * Revision 4.1 92/08/07 17:19:07 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.1 92/06/08 11:54:52 lwall - * Initial revision - * - * Revision 4.0.1.1 91/11/05 19:07:24 lwall - * patch11: there are now subroutines for calling back from C into Perl - * - * Revision 4.0 91/03/20 01:56:34 lwall - * 4.0 baseline. - * - * Revision 3.0.1.1 90/08/09 04:06:10 lwall - * patch19: Initial revision - * - */ - -#include "EXTERN.h" -#include "perl.h" - -int -userinit() -{ - install_null(); /* install device /dev/null or NUL: */ - init_curses(); - return 0; -} diff --git a/atarist/wildmat.c b/atarist/wildmat.c deleted file mode 100644 index 98a3182bfa..0000000000 --- a/atarist/wildmat.c +++ /dev/null @@ -1,507 +0,0 @@ -/* $Revision: 4.1 $ -** -** Do shell-style pattern matching for ?, \, [], and * characters. -** Might not be robust in face of malformed patterns; e.g., "foo[a-" -** could cause a segmentation violation. It is 8bit clean. -** -** Written by Rich $alz, mirror!rs, Wed Nov 26 19:03:17 EST 1986. -** Rich $alz is now <rsalz@bbn.com>. -** April, 1991: Replaced mutually-recursive calls with in-line code -** for the star character. -** -** Special thanks to Lars Mathiesen <thorinn@diku.dk> for the ABORT code. -** This can greatly speed up failing wildcard patterns. For example: -** pattern: -*-*-*-*-*-*-12-*-*-*-m-*-*-* -** text 1: -adobe-courier-bold-o-normal--12-120-75-75-m-70-iso8859-1 -** text 2: -adobe-courier-bold-o-normal--12-120-75-75-X-70-iso8859-1 -** Text 1 matches with 51 calls, while text 2 fails with 54 calls. Without -** the ABORT, then it takes 22310 calls to fail. Ugh. The following -** explanation is from Lars: -** The precondition that must be fulfilled is that DoMatch will consume -** at least one character in text. This is true if *p is neither '*' nor -** '\0'.) The last return has ABORT instead of FALSE to avoid quadratic -** behaviour in cases like pattern "*a*b*c*d" with text "abcxxxxx". With -** FALSE, each star-loop has to run to the end of the text; with ABORT -** only the last one does. -** -** Once the control of one instance of DoMatch enters the star-loop, that -** instance will return either TRUE or ABORT, and any calling instance -** will therefore return immediately after (without calling recursively -** again). In effect, only one star-loop is ever active. It would be -** possible to modify the code to maintain this context explicitly, -** eliminating all recursive calls at the cost of some complication and -** loss of clarity (and the ABORT stuff seems to be unclear enough by -** itself). I think it would be unwise to try to get this into a -** released version unless you have a good test data base to try it out -** on. -*/ - -#define TRUE 1 -#define FALSE 0 -#define ABORT -1 - - - /* What character marks an inverted character class? */ -#define NEGATE_CLASS '^' - /* Is "*" a common pattern? */ -#define OPTIMIZE_JUST_STAR - /* Do tar(1) matching rules, which ignore a trailing slash? */ -#undef MATCH_TAR_PATTERN - - -/* -** Match text and p, return TRUE, FALSE, or ABORT. -*/ -static int -DoMatch(text, p) - char *text; - char *p; -{ - int last; - int matched; - int reverse; - - for ( ; *p; text++, p++) { - if (*text == '\0' && *p != '*') - return ABORT; - switch (*p) { - case '\\': - /* Literal match with following character. */ - p++; - /* FALLTHROUGH */ - default: - if (*text != *p) - return FALSE; - continue; - case '?': - /* Match anything. */ - continue; - case '*': - while (*++p == '*') - /* Consecutive stars act just like one. */ - continue; - if (*p == '\0') - /* Trailing star matches everything. */ - return TRUE; - while (*text) - if ((matched = DoMatch(text++, p)) != FALSE) - return matched; - return ABORT; - case '[': - reverse = p[1] == NEGATE_CLASS ? TRUE : FALSE; - if (reverse) - /* Inverted character class. */ - p++; - for (last = 0400, matched = FALSE; *++p && *p != ']'; last = *p) - /* This next line requires a good C compiler. */ - if (*p == '-' ? *text <= *++p && *text >= last : *text == *p) - matched = TRUE; - if (matched == reverse) - return FALSE; - continue; - } - } - -#ifdef MATCH_TAR_PATTERN - if (*text == '/') - return TRUE; -#endif /* MATCH_TAR_ATTERN */ - return *text == '\0'; -} - - -/* -** User-level routine. Returns TRUE or FALSE. -*/ -int -wildmat(text, p) - char *text; - char *p; -{ -#ifdef OPTIMIZE_JUST_STAR - if (p[0] == '*' && p[1] == '\0') - return TRUE; -#endif /* OPTIMIZE_JUST_STAR */ - return DoMatch(text, p) == TRUE; -} - -#include <stdio.h> -#include <sys/types.h> -#include <dirent.h> -#include <sys/stat.h> -#if __STDC__ -#ifdef unix -#define _SIZE_T /* unix defines size_t in sys/types.h */ -#endif -#ifndef _COMPILER_H -# include <compiler.h> -#endif -#include <stddef.h> -#include <stdlib.h> -#else -extern char *malloc(), *realloc(); -extern char *rindex(), *strdup(); -#define __PROTO(x) () -#endif -#include <string.h> - -#define MAX_DIR 32 /* max depth of dir recursion */ -static struct { - char *dir, *patt; -} dir_stack[MAX_DIR]; -static int stack_p; -static char **matches; -static int nmatches; - -static void *ck_memalloc __PROTO((void *)); -#define ck_strdup(p) ck_memalloc(strdup(p)) -#define ck_malloc(s) ck_memalloc(malloc(s)) -#define ck_realloc(p, s) ck_memalloc(realloc(p, s)) - - -#define DEBUGX(x) - -/* - * return true if patt contains a wildcard char - */ -int contains_wild(patt) -char *patt; -{ - char c; - char *p; - - /* only check for wilds in the basename part of the pathname only */ - if((p = rindex(patt, '/')) == NULL) - p = rindex(patt, '\\'); - if(!p) - p = patt; - - while((c = *p++)) - if((c == '*') || (c == '?') || (c == '[')) - return 1; - return 0; -} - -#ifndef ZOO -void free_all() -{ - char **p; - - if(!matches) - return; - - for(p = matches; *p; p++) - free(*p); - free(matches); - matches = NULL; -} -#endif - -static void push(dir, patt) -char *dir; -char *patt; -{ - if(stack_p < (MAX_DIR - 2)) - stack_p++; - else - { - fprintf(stderr,"directory stack overflow\n"); - exit(99); - } - dir_stack[stack_p].dir = dir; - dir_stack[stack_p].patt = patt; -} - -/* - * glob patt - * if decend_dir is true, recursively decend any directories encountered. - * returns pointer to all matches encountered. - * if the initial patt is a directory, and decend_dir is true, it is - * equivalent to specifying the pattern "patt\*" - * - * Restrictions: - * - handles wildcards only in the base part of a pathname - * ie: will not handle \foo\*\bar\ (wildcard in the middle of pathname) - * - * - max dir recursion is MAX_DIR - * - * - on certain failures it will just skip potential matches as if they - * were not present. - * - * ++jrb bammi@cadence.com - */ -static char **do_match __PROTO((int decend_dir)); - -char **glob(patt, decend_dir) -char *patt; -int decend_dir; -{ - char *dir, *basepatt, *p; - struct stat s; - - DEBUGX((fprintf(stderr,"glob(%s, %d)\n", patt, decend_dir))); - matches = NULL; - nmatches = 0; - stack_p = -1; - - /* first check for wildcards */ - if(contains_wild(patt)) - { - /* break it up into dir and base patt, do_matches and return */ - p = ck_strdup(patt); - if((basepatt = rindex(p, '/')) == NULL) - basepatt = rindex(p, '\\'); - if(basepatt) - { - dir = p; - *basepatt++ = '\0'; - basepatt = ck_strdup(basepatt); - } - else - { - dir = ck_strdup("."); - basepatt = p; - } - - if(strcmp(basepatt, "*.*") == 0) - { - /* the desktop, and other braindead shells strike again */ - basepatt[1] = '\0'; - } - push(dir, basepatt); - DEBUGX((fprintf(stderr, "calling %s, %s\n", dir, basepatt))); - return do_match(decend_dir); - } - - /* if no wilds, check for dir */ - if(decend_dir && (!stat(patt, &s))) - { - if((s.st_mode & S_IFMT) == S_IFDIR) - { /* is a dir */ - size_t len = strlen(patt); - - dir = ck_strdup(patt); - --len; - if(len && ((dir[len] == '/') -#ifdef atarist - || (dir[len] == '\\') -#endif - )) - dir[len] = '\0'; - basepatt = ck_strdup("*"); - push(dir, basepatt); - DEBUGX((fprintf(stderr, "calling %s, %s\n", dir, basepatt))); - return do_match(decend_dir); - } - } - return NULL; -} - -static char **do_match(decend_dir) -int decend_dir; -{ - DIR *dirp; - struct dirent *d; - struct stat s; - char *dir, *basepatt; - - while(stack_p >= 0) - { - dir = ck_strdup(dir_stack[stack_p].dir); - free(dir_stack[stack_p].dir); - basepatt = ck_strdup(dir_stack[stack_p].patt); - free(dir_stack[stack_p--].patt); - - DEBUGX((fprintf(stderr,"dir %s patt %s stack %d\n", dir, basepatt, stack_p))); - - dirp = opendir(dir); - if(!dirp) - { - free(dir); - DEBUGX((fprintf(stderr,"no dir\n"))); - continue; - } - - while((d = readdir(dirp))) - { - char *p = ck_malloc(strlen(dir) + strlen(d->d_name) + 2L); - if(strcmp(dir, ".")) - /* If we have a full pathname then */ - { /* let's append the directory info */ - strcpy(p, dir); -#ifndef unix - strcat(p, "\\"); -#else - strcat(p, "/"); -#endif - strcat(p, d->d_name); - } - else /* Otherwise, the name is just fine, */ - strcpy(p, d->d_name); /* there's no need for './' -- bjsjr */ - - DEBUGX((fprintf(stderr, "Testing %s\n", p))); - if(!stat(p, &s)) /* if stat fails, ignore it */ - { - if( ((s.st_mode & S_IFMT) == S_IFREG) || - ((s.st_mode & S_IFMT) == S_IFLNK) ) - { /* it is a file/symbolic link */ - if(wildmat(d->d_name, basepatt)) - { /* it matches pattern */ - DEBUGX((fprintf(stderr,"File Matched\n"))); - if(matches == NULL) - matches = (char **)ck_malloc(sizeof(char *)); - else - matches = (char **) - ck_realloc(matches, (nmatches+1)*sizeof(char *)); - matches[nmatches++] = p; - } /* no match */ - else - { - DEBUGX((fprintf(stderr,"No File Match\n"))); - free(p); - } - } else if(decend_dir && ((s.st_mode & S_IFMT) == S_IFDIR)) - { - if(!((!strcmp(d->d_name,".")) || (!strcmp(d->d_name, "..") -#ifdef atarist - || (!strcmp(d->d_name, ".dir")) -#endif - ))) - { - char *push_p = ck_strdup("*"); - push(p, push_p); - DEBUGX((fprintf(stderr,"Dir pushed\n"))); - } - else - { - DEBUGX((fprintf(stderr, "DIR skipped\n"))); - free(p); - } - } - else - { - DEBUGX((fprintf(stderr, "Not a dir/no decend\n"))); - free(p); - } - } /* stat */ - else - { - DEBUGX((fprintf(stderr, "Stat failed\n"))); - free(p); - } - } /* while readdir */ - closedir(dirp); - free(basepatt); - free(dir); - DEBUGX((fprintf(stderr, "Dir done\n\n"))); - } /* while dirs in stack */ - - if(!nmatches) - { - DEBUGX((fprintf(stderr, "No matches\n"))); - return NULL; - } - - matches = (char **)realloc(matches, (nmatches+1)*sizeof(char *)); - if(!matches) - { return NULL; } - matches[nmatches] = NULL; - DEBUGX((fprintf(stderr, "%d matches\n", nmatches))); - return matches; -} - -#ifdef ZOO -#include "errors.i" -#endif - -static void *ck_memalloc(p) -void *p; -{ - if(!p) - { -#ifndef ZOO - fprintf(stderr, "Out of memory\n"); - exit(98); -#else - prterror('f', no_memory); -#endif - } - return p; -} - -#ifdef TEST_GLOB -void test(path, dec) -char *path; -int dec; -{ - char **m; - char **matches; - - printf("Testing %s %d\n", path, dec); - matches = glob(path, dec); - if(!matches) - { - printf("No matches\n"); - } - else - { - for(m = matches; *m; m++) - printf("%s\n", *m); - putchar('\n'); - free_all(); - } -} - -int main() -{ -#ifndef unix - test("e:\\lib\\*.olb", 0); - test("e:\\lib", 0); - test("e:\\lib\\", 1); -#else - test("/net/acae127/home/bammi/News/comp.sources.misc/*.c", 0); - test("/net/acae127/home/bammi/News/comp.sources.misc", 0); - test("/net/acae127/home/bammi/News/comp.sources.misc", 1); - test("/net/acae127/home/bammi/atari/cross-gcc", 1); -#endif - - return 0; -} - -#endif - -#ifdef TEST_WILDMAT -#include <stdio.h> - -/* Yes, we use gets not fgets. Sue me. */ -extern char *gets(); - - -main() -{ - char pattern[80]; - char text[80]; - - printf("Wildmat tester. Enter pattern, then strings to test.\n"); - printf("A blank line gets prompts for a new pattern; a blank pattern\n"); - printf("exits the program.\n\n"); - - for ( ; ; ) { - printf("Enter pattern: "); - if (gets(pattern) == NULL) - break; - for ( ; ; ) { - printf("Enter text: "); - if (gets(text) == NULL) - exit(0); - if (text[0] == '\0') - /* Blank line; go back and get a new pattern. */ - break; - printf(" %s\n", wildmat(text, pattern) ? "YES" : "NO"); - } - } - - exit(0); - /* NOTREACHED */ -} -#endif /* TEST_WILDMAT */ @@ -1,29 +1,4 @@ #!./miniperl - -chdir "lib" if -d "lib"; - -$package = shift; - -$filename = "$package.pm"; -open(IN, $filename) || die "Can't open $filename: $!\n"; -while (<IN>) { - last if /^__END__/; -} -$_ or die "Can't find __END__ in $filename\n"; - -mkdir "auto/$package", 0777 unless -d "auto/$package"; -while (<IN>) { - if (/^sub ([\w:]+)/) { - $name = $1; - print OUT "1;\n"; - $newname = "auto/$package/$name.al"; - open(OUT, ">$newname") or warn "Can't create $newname: $!\n"; - print OUT <<"END"; -# NOTE: Derived from $package.pm. Changes made here will be lost. -package $package; - -END - } - print OUT $_; -} -print OUT "1;\n"; +BEGIN { unshift @INC, "lib" } +use AutoSplit; +autosplit_lib_modules(@ARGV); @@ -1,32 +1,98 @@ -/* $RCSfile: array.c,v $$Revision: 4.1 $$Date: 92/08/07 17:18:22 $ +/* av.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: array.c,v $ - * Revision 4.1 92/08/07 17:18:22 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.3 92/06/08 11:45:05 lwall - * patch20: Perl now distinguishes overlapped copies from non-overlapped - * - * Revision 4.0.1.2 91/11/05 16:00:14 lwall - * patch11: random cleanup - * patch11: passing non-existend array elements to subrouting caused core dump - * - * Revision 4.0.1.1 91/06/07 10:19:08 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:03:32 lwall - * 4.0 baseline. - * + */ + +/* + * "...for the Entwives desired order, and plenty, and peace (by which they + * meant that things should remain where they had set them)." --Treebeard */ #include "EXTERN.h" #include "perl.h" +static void av_reify _((AV* av)); + +static void +av_reify(av) +AV* av; +{ + I32 key; + SV* sv; + + key = AvMAX(av) + 1; + while (key > AvFILL(av) + 1) + AvARRAY(av)[--key] = &sv_undef; + while (key) { + sv = AvARRAY(av)[--key]; + assert(sv); + if (sv != &sv_undef) + (void)SvREFCNT_inc(sv); + } + AvREAL_on(av); +} + +void +av_extend(av,key) +AV *av; +I32 key; +{ + if (key > AvMAX(av)) { + SV** ary; + I32 tmp; + I32 newmax; + + if (AvALLOC(av) != AvARRAY(av)) { + ary = AvALLOC(av) + AvFILL(av) + 1; + tmp = AvARRAY(av) - AvALLOC(av); + Move(AvARRAY(av), AvALLOC(av), AvFILL(av)+1, SV*); + AvMAX(av) += tmp; + SvPVX(av) = (char*)AvALLOC(av); + if (AvREAL(av)) { + while (tmp) + ary[--tmp] = &sv_undef; + } + + if (key > AvMAX(av) - 10) { + newmax = key + AvMAX(av); + goto resize; + } + } + else { + if (AvALLOC(av)) { + newmax = key + AvMAX(av) / 5; + resize: + Renew(AvALLOC(av),newmax+1, SV*); + 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; + } + } + else { + newmax = key < 4 ? 4 : key; + New(2,AvALLOC(av), newmax+1, SV*); + ary = AvALLOC(av) + 1; + tmp = newmax; + AvALLOC(av)[0] = &sv_undef; /* For the stacks */ + } + if (AvREAL(av)) { + while (tmp) + ary[--tmp] = &sv_undef; + } + + SvPVX(av) = (char*)AvALLOC(av); + AvMAX(av) = newmax; + } + } +} + SV** av_fetch(av,key,lval) register AV *av; @@ -35,38 +101,33 @@ I32 lval; { SV *sv; + if (!av) + return 0; + if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P')) { - if (key < 0) - return 0; sv = sv_newmortal(); mg_copy((SV*)av, sv, 0, key); - if (!lval) { - mg_get((SV*)sv); - sv_unmagic(sv,'p'); - } Sv = sv; return &Sv; } } - if (key < 0 || key > AvFILL(av)) { - if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return 0; - } - else { - if (!lval) - return 0; - if (AvREAL(av)) - sv = NEWSV(5,0); - else - sv = sv_newmortal(); - return av_store(av,key,sv); - } + if (key < 0) { + key += AvFILL(av) + 1; + if (key < 0) + return 0; + } + else if (key > AvFILL(av)) { + if (!lval) + return 0; + if (AvREALISH(av)) + sv = NEWSV(5,0); + else + sv = sv_newmortal(); + return av_store(av,key,sv); } - if (!AvARRAY(av)[key]) { + if (AvARRAY(av)[key] == &sv_undef) { if (lval) { sv = NEWSV(6,0); return av_store(av,key,sv); @@ -82,14 +143,10 @@ register AV *av; I32 key; SV *val; { - I32 tmp; SV** ary; - if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return 0; - } + if (!av) + return 0; if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P')) { @@ -98,52 +155,38 @@ SV *val; } } - if (key > AvMAX(av)) { - I32 newmax; - - if (AvALLOC(av) != AvARRAY(av)) { - tmp = AvARRAY(av) - AvALLOC(av); - Move(AvARRAY(av), AvALLOC(av), AvMAX(av)+1, SV*); - Zero(AvALLOC(av)+AvMAX(av)+1, tmp, SV*); - AvMAX(av) += tmp; - SvPVX(av) = (char*)(AvARRAY(av) - tmp); - if (key > AvMAX(av) - 10) { - newmax = key + AvMAX(av); - goto resize; - } - } - else { - if (AvALLOC(av)) { - newmax = key + AvMAX(av) / 5; - resize: - Renew(AvALLOC(av),newmax+1, SV*); - Zero(&AvALLOC(av)[AvMAX(av)+1], newmax - AvMAX(av), SV*); - } - else { - newmax = key < 4 ? 4 : key; - Newz(2,AvALLOC(av), newmax+1, SV*); - } - SvPVX(av) = (char*)AvALLOC(av); - AvMAX(av) = newmax; - } + if (key < 0) { + key += AvFILL(av) + 1; + if (key < 0) + return 0; } + if (!val) + val = &sv_undef; + + if (key > AvMAX(av)) + av_extend(av,key); + if (AvREIFY(av)) + av_reify(av); + ary = AvARRAY(av); - if (AvREAL(av)) { - if (AvFILL(av) < key) { - while (++AvFILL(av) < key) { - if (ary[AvFILL(av)] != Nullsv) { - SvREFCNT_dec(ary[AvFILL(av)]); - ary[AvFILL(av)] = Nullsv; - } - } + 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; + while (AvFILL(av) < key); } - if (ary[key]) - SvREFCNT_dec(ary[key]); + AvFILL(av) = key; } + else if (AvREAL(av)) + SvREFCNT_dec(ary[key]); ary[key] = val; if (SvSMAGICAL(av)) { - MAGIC* mg = SvMAGIC(av); - sv_magic(val, (SV*)av, tolower(mg->mg_type), 0, key); + if (val != &sv_undef) { + MAGIC* mg = SvMAGIC(av); + sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key); + } mg_set((SV*)av); } return &ary[key]; @@ -154,9 +197,8 @@ newAV() { register AV *av; - Newz(1,av,1,AV); - SvREFCNT(av) = 1; - sv_upgrade(av,SVt_PVAV); + av = (AV*)NEWSV(3,0); + sv_upgrade((SV *)av, SVt_PVAV); AvREAL_on(av); AvALLOC(av) = 0; SvPVX(av) = 0; @@ -173,23 +215,20 @@ register SV **strp; register I32 i; register SV** ary; - Newz(3,av,1,AV); - sv_upgrade(av,SVt_PVAV); + av = (AV*)NEWSV(8,0); + sv_upgrade((SV *) av,SVt_PVAV); New(4,ary,size+1,SV*); AvALLOC(av) = ary; - Zero(ary,size,SV*); - AvREAL_on(av); + AvFLAGS(av) = AVf_REAL; SvPVX(av) = (char*)ary; AvFILL(av) = size - 1; AvMAX(av) = size - 1; for (i = 0; i < size; i++) { - if (*strp) { - ary[i] = NEWSV(7,0); - sv_setsv(ary[i], *strp); - } + assert (*strp); + ary[i] = NEWSV(7,0); + sv_setsv(ary[i], *strp); strp++; } - SvOK_on(av); return av; } @@ -201,22 +240,20 @@ register SV **strp; register AV *av; register SV** ary; - Newz(3,av,1,AV); - SvREFCNT(av) = 1; - sv_upgrade(av,SVt_PVAV); + av = (AV*)NEWSV(9,0); + sv_upgrade((SV *)av, SVt_PVAV); New(4,ary,size+1,SV*); AvALLOC(av) = ary; Copy(strp,ary,size,SV*); - AvREAL_off(av); + AvFLAGS(av) = AVf_REIFY; SvPVX(av) = (char*)ary; AvFILL(av) = size - 1; AvMAX(av) = size - 1; while (size--) { - if (*strp) - SvTEMP_off(*strp); + assert (*strp); + SvTEMP_off(*strp); strp++; } - SvOK_on(av); return av; } @@ -225,18 +262,25 @@ av_clear(av) register AV *av; { register I32 key; + SV** ary; - if (!av || !AvREAL(av) || AvMAX(av) < 0) + if (!av || AvMAX(av) < 0) return; /*SUPPRESS 560*/ + + if (AvREAL(av)) { + ary = AvARRAY(av); + key = AvFILL(av) + 1; + while (key) { + SvREFCNT_dec(ary[--key]); + ary[key] = &sv_undef; + } + } if (key = AvARRAY(av) - AvALLOC(av)) { AvMAX(av) += key; - SvPVX(av) = (char*)(AvARRAY(av) - key); + SvPVX(av) = (char*)AvALLOC(av); } - for (key = 0; key <= AvMAX(av); key++) - SvREFCNT_dec(AvARRAY(av)[key]); AvFILL(av) = -1; - Zero(AvARRAY(av), AvMAX(av)+1, SV*); } void @@ -248,13 +292,14 @@ register AV *av; if (!av) return; /*SUPPRESS 560*/ + if (AvREAL(av)) { + key = AvFILL(av) + 1; + while (key) + SvREFCNT_dec(AvARRAY(av)[--key]); + } if (key = AvARRAY(av) - AvALLOC(av)) { AvMAX(av) += key; - SvPVX(av) = (char*)(AvARRAY(av) - key); - } - if (AvREAL(av)) { - for (key = 0; key <= AvMAX(av); key++) - SvREFCNT_dec(AvARRAY(av)[key]); + SvPVX(av) = (char*)AvALLOC(av); } Safefree(AvALLOC(av)); AvALLOC(av) = 0; @@ -262,12 +307,14 @@ register AV *av; AvMAX(av) = AvFILL(av) = -1; } -bool +void av_push(av,val) register AV *av; SV *val; { - return av_store(av,++(AvFILL(av)),val) != 0; + if (!av) + return; + av_store(av,AvFILL(av)+1,val); } SV * @@ -276,27 +323,16 @@ register AV *av; { SV *retval; - if (AvFILL(av) < 0) - return Nullsv; + if (!av || AvFILL(av) < 0) + return &sv_undef; retval = AvARRAY(av)[AvFILL(av)]; - AvARRAY(av)[AvFILL(av)--] = Nullsv; + AvARRAY(av)[AvFILL(av)--] = &sv_undef; if (SvSMAGICAL(av)) mg_set((SV*)av); return retval; } void -av_popnulls(av) -register AV *av; -{ - register I32 fill = AvFILL(av); - - while (fill >= 0 && !AvARRAY(av)[fill]) - fill--; - AvFILL(av) = fill; -} - -void av_unshift(av,num) register AV *av; register I32 num; @@ -304,30 +340,40 @@ register I32 num; register I32 i; register SV **sstr,**dstr; - if (num <= 0) + if (!av || num <= 0) return; - if (AvARRAY(av) - AvALLOC(av) >= num) { - AvMAX(av) += num; - AvFILL(av) += num; - while (num--) { - SvPVX(av) = (char*)(AvARRAY(av) - 1); - *AvARRAY(av) = Nullsv; - } + if (!AvREAL(av)) { + if (AvREIFY(av)) + av_reify(av); + else + croak("Can't unshift"); } - else { - (void)av_store(av,AvFILL(av)+num,(SV*)0); /* maybe extend array */ + i = AvARRAY(av) - AvALLOC(av); + if (i) { + if (i > num) + i = num; + num -= i; + + AvMAX(av) += i; + AvFILL(av) += i; + SvPVX(av) = (char*)(AvARRAY(av) - i); + } + if (num) { + av_extend(av,AvFILL(av)+num); + AvFILL(av) += num; dstr = AvARRAY(av) + AvFILL(av); sstr = dstr - num; #ifdef BUGGY_MSC5 # pragma loop_opt(off) /* don't loop-optimize the following code */ #endif /* BUGGY_MSC5 */ - for (i = AvFILL(av) - num; i >= 0; i--) { + for (i = AvFILL(av) - num; i >= 0; --i) { *dstr-- = *sstr--; #ifdef BUGGY_MSC5 # pragma loop_opt() /* loop-optimization back to command-line setting */ #endif /* BUGGY_MSC5 */ } - Zero(AvARRAY(av), num, SV*); + while (num) + AvARRAY(av)[--num] = &sv_undef; } } @@ -337,10 +383,11 @@ register AV *av; { SV *retval; - if (AvFILL(av) < 0) - return Nullsv; + if (!av || AvFILL(av) < 0) + return &sv_undef; retval = *AvARRAY(av); - *AvARRAY(av) = Nullsv; + if (AvREAL(av)) + *AvARRAY(av) = &sv_undef; SvPVX(av) = (char*)(AvARRAY(av) + 1); AvMAX(av)--; AvFILL(av)--; @@ -361,15 +408,29 @@ av_fill(av, fill) register AV *av; I32 fill; { + if (!av) + croak("panic: null array"); if (fill < 0) fill = -1; if (fill <= AvMAX(av)) { + I32 key = AvFILL(av); + SV** ary = AvARRAY(av); + + if (AvREAL(av)) { + while (key > fill) { + SvREFCNT_dec(ary[key]); + ary[key--] = &sv_undef; + } + } + else { + while (key < fill) + ary[++key] = &sv_undef; + } + AvFILL(av) = fill; if (SvSMAGICAL(av)) mg_set((SV*)av); } - else { - AvFILL(av) = fill - 1; /* don't clobber in-between values */ - (void)av_store(av,fill,Nullsv); - } + else + (void)av_store(av,fill,&sv_undef); } @@ -1,30 +1,17 @@ -/* $RCSfile: array.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:24 $ +/* av.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: array.h,v $ - * Revision 4.1 92/08/07 17:18:24 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.2 92/06/08 11:45:57 lwall - * patch20: removed implicit int declarations on funcions - * - * Revision 4.0.1.1 91/06/07 10:19:20 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:03:44 lwall - * 4.0 baseline. - * */ struct xpvav { - char * xav_array; /* pointer to malloced string */ - int xav_fill; - int xav_max; - int xof_off; /* ptr is incremented by offset */ + char* xav_array; /* pointer to malloced string */ + SSize_t xav_fill; + SSize_t xav_max; + IV xof_off; /* ptr is incremented by offset */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ @@ -35,6 +22,7 @@ struct xpvav { }; #define AVf_REAL 1 /* free old entries */ +#define AVf_REIFY 2 /* can become real */ #define Nullav Null(AV*) @@ -45,6 +33,12 @@ struct xpvav { #define AvARYLEN(av) ((XPVAV*) SvANY(av))->xav_arylen #define AvFLAGS(av) ((XPVAV*) SvANY(av))->xav_flags -#define AvREAL(av) (((XPVAV*) SvANY(av))->xav_flags & AVf_REAL) -#define AvREAL_on(av) (((XPVAV*) SvANY(av))->xav_flags |= AVf_REAL) -#define AvREAL_off(av) (((XPVAV*) SvANY(av))->xav_flags &= ~AVf_REAL) +#define AvREAL(av) (AvFLAGS(av) & AVf_REAL) +#define AvREAL_on(av) (AvFLAGS(av) |= AVf_REAL) +#define AvREAL_off(av) (AvFLAGS(av) &= ~AVf_REAL) +#define AvREIFY(av) (AvFLAGS(av) & AVf_REIFY) +#define AvREIFY_on(av) (AvFLAGS(av) |= AVf_REIFY) +#define AvREIFY_off(av) (AvFLAGS(av) &= ~AVf_REIFY) + +#define AvREALISH(av) AvFLAGS(av) /* REAL or REIFY -- shortcut */ + @@ -1,35 +0,0 @@ -#!./perl - -BEGIN {require POSIX; import POSIX; } - - -print POSIX::pipe(), "\n"; - -$sigset = new POSIX::SigSet 1,3; -delset $sigset 1; -if (ismember $sigset 1) { print "BAD\n" } -if (ismember $sigset 3) { print "GOOD\n" } -$mask = new POSIX::SigSet &SIGINT; -$action = new POSIX::SigAction 'main::SigHUP', $mask, 0; -sigaction(&SIGHUP, $action); -kill HUP, $$; -print "DONE\n"; - -sub SigHUP { - print "SigHUP1\n"; - sleep 10; - print "SigHUP2\n"; -} - -__END__ -print &_POSIX_OPEN_MAX, "\n"; - -$x = setlocale(&LC_NUMERIC, "En_TRY"); -print $x,"\n"; -$! = 12; - -print +POSIX::errno(), "\n"; -print 123.45,"\n"; -__END__ -$lconv = localeconv(); -print %$lconv, "\n"; diff --git a/bench/fib b/bench/fib deleted file mode 100755 index 022d9d0159..0000000000 --- a/bench/fib +++ /dev/null @@ -1,20 +0,0 @@ -#!./perl - -sub fib -{ - ($_[0] < 2) ? $_[0] : &fib($_[0]-1) + &fib($_[0]-2); -} - -sub myruntime -{ - local(@t) = times; # in seconds - $t[0] + $t[1]; -} - -$x = (shift || 20); -print "Starting fib($x)\n"; -$before = &myruntime; -$y = &fib($x); -$after = &myruntime; -printf("Done. Result $y in %g cpu seconds.\n", $after-$before); - diff --git a/byacc b/byacc deleted file mode 120000 index 14034ef03e..0000000000 --- a/byacc +++ /dev/null @@ -1 +0,0 @@ -../perl-byacc1.8.2/byacc
\ No newline at end of file @@ -1,1071 +0,0 @@ -#!/usr/local/bin/perl -# -# -# c2ph (aka pstruct) -# Tom Christiansen, <tchrist@convex.com> -# -# As pstruct, dump C structures as generated from 'cc -g -S' stabs. -# As c2ph, do this PLUS generate perl code for getting at the structures. -# -# See the usage message for more. If this isn't enough, read the code. -# - -$RCSID = '$RCSfile: c2ph.SH,v $$Revision: 4.1 $$Date: 92/08/07 17:19:10 $'; - - -###################################################################### - -# some handy data definitions. many of these can be reset later. - -$bitorder = 'b'; # ascending; set to B for descending bit fields - -%intrinsics = -%template = ( - 'char', 'c', - 'unsigned char', 'C', - 'short', 's', - 'short int', 's', - 'unsigned short', 'S', - 'unsigned short int', 'S', - 'short unsigned int', 'S', - 'int', 'i', - 'unsigned int', 'I', - 'long', 'l', - 'long int', 'l', - 'unsigned long', 'L', - 'unsigned long', 'L', - 'long unsigned int', 'L', - 'unsigned long int', 'L', - 'long long', 'q', - 'long long int', 'q', - 'unsigned long long', 'Q', - 'unsigned long long int', 'Q', - 'float', 'f', - 'double', 'd', - 'pointer', 'p', - 'null', 'x', - 'neganull', 'X', - 'bit', $bitorder, -); - -&buildscrunchlist; -delete $intrinsics{'neganull'}; -delete $intrinsics{'bit'}; -delete $intrinsics{'null'}; - -# use -s to recompute sizes -%sizeof = ( - 'char', '1', - 'unsigned char', '1', - 'short', '2', - 'short int', '2', - 'unsigned short', '2', - 'unsigned short int', '2', - 'short unsigned int', '2', - 'int', '4', - 'unsigned int', '4', - 'long', '4', - 'long int', '4', - 'unsigned long', '4', - 'unsigned long int', '4', - 'long unsigned int', '4', - 'long long', '8', - 'long long int', '8', - 'unsigned long long', '8', - 'unsigned long long int', '8', - 'float', '4', - 'double', '8', - 'pointer', '4', -); - -($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); - -($offset_fmt, $size_fmt) = ('d', 'd'); - -$indent = 2; - -$CC = 'cc'; -$CFLAGS = '-g -S'; -$DEFINES = ''; - -$perl++ if $0 =~ m#/?c2ph$#; - -require 'getopts.pl'; - -eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; - -&Getopts('aixdpvtnws:') || &usage(0); - -$opt_d && $debug++; -$opt_t && $trace++; -$opt_p && $perl++; -$opt_v && $verbose++; -$opt_n && ($perl = 0); - -if ($opt_w) { - ($type_width, $member_width, $offset_width) = (45, 35, 8); -} -if ($opt_x) { - ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); -} - -eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; - -sub PLUMBER { - select(STDERR); - print "oops, apperent pager foulup\n"; - $isatty++; - &usage(1); -} - -sub usage { - local($oops) = @_; - unless (-t STDOUT) { - select(STDERR); - } elsif (!$oops) { - $isatty++; - $| = 1; - print "hit <RETURN> for further explanation: "; - <STDIN>; - open (PIPE, "|". ($ENV{PAGER} || 'more')); - $SIG{PIPE} = PLUMBER; - select(PIPE); - } - - print "usage: $0 [-dpnP] [var=val] [files ...]\n"; - - exit unless $isatty; - - print <<EOF; - -Options: - --w wide; short for: type_width=45 member_width=35 offset_width=8 --x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04 - --n do not generate perl code (default when invoked as pstruct) --p generate perl code (default when invoked as c2ph) --v generate perl code, with C decls as comments - --i do NOT recompute sizes for intrinsic datatypes --a dump information on intrinsics also - --t trace execution --d spew reams of debugging output - --slist give comma-separated list a structures to dump - - -Var Name Default Value Meaning - -EOF - - &defvar('CC', 'which_compiler to call'); - &defvar('CFLAGS', 'how to generate *.s files with stabs'); - &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U'); - - print "\n"; - - &defvar('type_width', 'width of type field (column 1)'); - &defvar('member_width', 'width of member field (column 2)'); - &defvar('offset_width', 'width of offset field (column 3)'); - &defvar('size_width', 'width of size field (column 4)'); - - print "\n"; - - &defvar('offset_fmt', 'sprintf format type for offset'); - &defvar('size_fmt', 'sprintf format type for size'); - - print "\n"; - - &defvar('indent', 'how far to indent each nesting level'); - - print <<'EOF'; - - If any *.[ch] files are given, these will be catted together into - a temporary *.c file and sent through: - $CC $CFLAGS $DEFINES - and the resulting *.s groped for stab information. If no files are - supplied, then stdin is read directly with the assumption that it - contains stab information. All other liens will be ignored. At - most one *.s file should be supplied. - -EOF - close PIPE; - exit 1; -} - -sub defvar { - local($var, $msg) = @_; - printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg; -} - -$recurse = 1; - -if (@ARGV) { - if (grep(!/\.[csh]$/,@ARGV)) { - warn "Only *.[csh] files expected!\n"; - &usage; - } - elsif (grep(/\.s$/,@ARGV)) { - if (@ARGV > 1) { - warn "Only one *.s file allowed!\n"; - &usage; - } - } - elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { - local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; - $chdir = "cd $dir; " if $dir; - &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; - $ARGV[0] =~ s/\.c$/.s/; - } - else { - $TMP = "/tmp/c2ph.$$.c"; - &system("cat @ARGV > $TMP") && exit 1; - &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1; - unlink $TMP; - $TMP =~ s/\.c$/.s/; - @ARGV = ($TMP); - } -} - -if ($opt_s) { - for (split(/[\s,]+/, $opt_s)) { - $interested{$_}++; - } -} - - -$| = 1 if $debug; - -main: { - - if ($trace) { - if (-t && !@ARGV) { - print STDERR "reading from your keyboard: "; - } else { - print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": "; - } - } - -STAB: while (<>) { - if ($trace && !($. % 10)) { - $lineno = $..''; - print STDERR $lineno, "\b" x length($lineno); - } - next unless /^\s*\.stabs\s+/; - $line = $_; - s/^\s*\.stabs\s+//; - &stab; - } - print STDERR "$.\n" if $trace; - unlink $TMP if $TMP; - - &compute_intrinsics if $perl && !$opt_i; - - print STDERR "resolving types\n" if $trace; - - &resolve_types; - &adjust_start_addrs; - - $sum = 2 + $type_width + $member_width; - $pmask1 = "%-${type_width}s %-${member_width}s"; - $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; - - if ($perl) { - # resolve template -- should be in stab define order, but even this isn't enough. - print STDERR "\nbuilding type templates: " if $trace; - for $i (reverse 0..$#type) { - next unless defined($name = $type[$i]); - next unless defined $struct{$name}; - $build_recursed = 0; - &build_template($name) unless defined $template{&psou($name)} || - $opt_s && !$interested{$name}; - } - print STDERR "\n\n" if $trace; - } - - print STDERR "dumping structs: " if $trace; - - - foreach $name (sort keys %struct) { - next if $opt_s && !$interested{$name}; - print STDERR "$name " if $trace; - - undef @sizeof; - undef @typedef; - undef @offsetof; - undef @indices; - undef @typeof; - - $mname = &munge($name); - - $fname = &psou($name); - - print "# " if $perl && $verbose; - $pcode = ''; - print "$fname {\n" if !$perl || $verbose; - $template{$fname} = &scrunch($template{$fname}) if $perl; - &pstruct($name,$name,0); - print "# " if $perl && $verbose; - print "}\n" if !$perl || $verbose; - print "\n" if $perl && $verbose; - - if ($perl) { - print "$pcode"; - - printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); - - print <<EOF; -sub ${mname}'typedef { - local(\$${mname}'index) = shift; - defined \$${mname}'index - ? \$${mname}'typedef[\$${mname}'index] - : \$${mname}'typedef; -} -EOF - - print <<EOF; -sub ${mname}'sizeof { - local(\$${mname}'index) = shift; - defined \$${mname}'index - ? \$${mname}'sizeof[\$${mname}'index] - : \$${mname}'sizeof; -} -EOF - - print <<EOF; -sub ${mname}'offsetof { - local(\$${mname}'index) = shift; - defined \$${mname}index - ? \$${mname}'offsetof[\$${mname}'index] - : \$${mname}'sizeof; -} -EOF - - print <<EOF; -sub ${mname}'typeof { - local(\$${mname}'index) = shift; - defined \$${mname}index - ? \$${mname}'typeof[\$${mname}'index] - : '$name'; -} -EOF - - - print "\$${mname}'typedef = '" . &scrunch($template{$fname}) - . "';\n"; - - print "\$${mname}'sizeof = $sizeof{$name};\n\n"; - - - print "\@${mname}'indices = (", &squishseq(@indices), ");\n"; - - print "\n"; - - print "\@${mname}'typedef[\@${mname}'indices] = (", - join("\n\t", '', @typedef), "\n );\n\n"; - print "\@${mname}'sizeof[\@${mname}'indices] = (", - join("\n\t", '', @sizeof), "\n );\n\n"; - print "\@${mname}'offsetof[\@${mname}'indices] = (", - join("\n\t", '', @offsetof), "\n );\n\n"; - print "\@${mname}'typeof[\@${mname}'indices] = (", - join("\n\t", '', @typeof), "\n );\n\n"; - - $template_printed{$fname}++; - $size_printed{$fname}++; - } - print "\n"; - } - - print STDERR "\n" if $trace; - - unless ($perl && $opt_a) { - print "\n1;\n"; - exit; - } - - - - foreach $name (sort bysizevalue keys %intrinsics) { - next if $size_printed{$name}; - print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n"; - } - - print "\n"; - - sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; } - - - foreach $name (sort keys %intrinsics) { - print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; - } - - print "\n1;\n"; - - exit; -} - -######################################################################################## - - -sub stab { - next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun - s/"// || next; - s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; - - next if /^\s*$/; - - $size = $3 if $3; - - - $line = $_; - - if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { - print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; - &pdecl($pdecl); - next; - } - - - - if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { - local($ident) = $2; - push(@intrinsics, $ident); - $typeno = &typeno($3); - $type[$typeno] = $ident; - print STDERR "intrinsic $ident in new type $typeno\n" if $debug; - next; - } - - if (($name, $typeordef, $typeno, $extra, $struct, $_) - = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) - { - $typeno = &typeno($typeno); # sun foolery - } - elsif (/^[\$\w]+:/) { - next; # variable - } - else { - warn "can't grok stab: <$_> in: $line " if $_; - next; - } - - #warn "got size $size for $name\n"; - $sizeof{$name} = $size if $size; - - s/;[-\d]*;[-\d]*;$//; # we don't care about ranges - - $typenos{$name} = $typeno; - - unless (defined $type[$typeno]) { - &panic("type 0??") unless $typeno; - $type[$typeno] = $name unless defined $type[$typeno]; - printf "new type $typeno is $name" if $debug; - if ($extra =~ /\*/ && defined $type[$struct]) { - print ", a typedef for a pointer to " , $type[$struct] if $debug; - } - } else { - printf "%s is type %d", $name, $typeno if $debug; - print ", a typedef for " , $type[$typeno] if $debug; - } - print "\n" if $debug; - #next unless $extra =~ /[su*]/; - - #$type[$struct] = $name; - - if ($extra =~ /[us*]/) { - &sou($name, $extra); - $_ = &sdecl($name, $_, 0); - } - elsif (/^=ar/) { - print "it's a bare array typedef -- that's pretty sick\n" if $debug; - $_ = "$typeno$_"; - $scripts = ''; - $_ = &adecl($_,1); - - } - elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc - push(@intrinsics, $2); - $typeno = &typeno($3); - $type[$typeno] = $2; - print STDERR "intrinsic $2 in new type $typeno\n" if $debug; - } - elsif (s/^=e//) { # blessed by thy compiler; mine won't do this - &edecl; - } - else { - warn "Funny remainder for $name on line $_ left in $line " if $_; - } -} - -sub typeno { # sun thinks types are (0,27) instead of just 27 - local($_) = @_; - s/\(\d+,(\d+)\)/$1/; - $_; -} - -sub pstruct { - local($what,$prefix,$base) = @_; - local($field, $fieldname, $typeno, $count, $offset, $entry); - local($fieldtype); - local($type, $tname); - local($mytype, $mycount, $entry2); - local($struct_count) = 0; - local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); - local($bits,$bytes); - local($template); - - - local($mname) = &munge($name); - - sub munge { - local($_) = @_; - s/[\s\$\.]/_/g; - $_; - } - - local($sname) = &psou($what); - - $nesting++; - - for $field (split(/;/, $struct{$what})) { - $pad = $prepad = 0; - $entry = ''; - ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); - - $type = $type[$typeno]; - - $type =~ /([^[]*)(\[.*\])?/; - $mytype = $1; - $count .= $2; - $fieldtype = &psou($mytype); - - local($fname) = &psou($name); - - if ($build_templates) { - - $pad = ($offset - ($lastoffset + $lastlength))/8 - if defined $lastoffset; - - if (! $finished_template{$sname}) { - if ($isaunion{$what}) { - $template{$sname} .= 'X' x $revpad . ' ' if $revpad; - } else { - $template{$sname} .= 'x' x $pad . ' ' if $pad; - } - } - - $template = &fetch_template($type) x - ($count ? &scripts2count($count) : 1); - - if (! $finished_template{$sname}) { - $template{$sname} .= $template; - } - - $revpad = $length/8 if $isaunion{$what}; - - ($lastoffset, $lastlength) = ($offset, $length); - - } else { - print '# ' if $perl && $verbose; - $entry = sprintf($pmask1, - ' ' x ($nesting * $indent) . $fieldtype, - "$prefix.$fieldname" . $count); - - $entry =~ s/(\*+)( )/$2$1/; - - printf $pmask2, - $entry, - ($base+$offset)/8, - ($bits = ($base+$offset)%8) ? ".$bits" : " ", - $length/8, - ($bits = $length % 8) ? ".$bits": "" - if !$perl || $verbose; - - - if ($perl && $nesting == 1) { - $template = &scrunch(&fetch_template($type) x - ($count ? &scripts2count($count) : 1)); - push(@sizeof, int($length/8) .",\t# $fieldname"); - push(@offsetof, int($offset/8) .",\t# $fieldname"); - push(@typedef, "'$template', \t# $fieldname"); - $type =~ s/(struct|union) //; - push(@typeof, "'$type" . ($count ? $count : '') . - "',\t# $fieldname"); - } - - print ' ', ' ' x $indent x $nesting, $template - if $perl && $verbose; - - print "\n" if !$perl || $verbose; - - } - if ($perl) { - local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; - $mycount *= &scripts2count($count) if $count; - if ($nesting==1 && !$build_templates) { - $pcode .= sprintf("sub %-32s { %4d; }\n", - "${mname}'${fieldname}", $struct_count); - push(@indices, $struct_count); - } - $struct_count += $mycount; - } - - - &pstruct($type, "$prefix.$fieldname", $base+$offset) - if $recurse && defined $struct{$type}; - } - - $countof{$what} = $struct_count unless defined $countof{$whati}; - - $template{$sname} .= '$' if $build_templates; - $finished_template{$sname}++; - - if ($build_templates && !defined $sizeof{$name}) { - local($fmt) = &scrunch($template{$sname}); - print STDERR "no size for $name, punting with $fmt..." if $debug; - eval '$sizeof{$name} = length(pack($fmt, ()))'; - if ($@) { - chop $@; - warn "couldn't get size for \$name: $@"; - } else { - print STDERR $sizeof{$name}, "\n" if $debUg; - } - } - - --$nesting; -} - - -sub psize { - local($me) = @_; - local($amstruct) = $struct{$me} ? 'struct ' : ''; - - print '$sizeof{\'', $amstruct, $me, '\'} = '; - printf "%d;\n", $sizeof{$me}; -} - -sub pdecl { - local($pdecl) = @_; - local(@pdecls); - local($tname); - - warn "pdecl: $pdecl\n" if $debug; - - $pdecl =~ s/\(\d+,(\d+)\)/$1/g; - $pdecl =~ s/\*//g; - @pdecls = split(/=/, $pdecl); - $typeno = $pdecls[0]; - $tname = pop @pdecls; - - if ($tname =~ s/^f//) { $tname = "$tname&"; } - #else { $tname = "$tname*"; } - - for (reverse @pdecls) { - $tname .= s/^f// ? "&" : "*"; - #$tname =~ s/^f(.*)/$1&/; - print "type[$_] is $tname\n" if $debug; - $type[$_] = $tname unless defined $type[$_]; - } -} - - - -sub adecl { - ($arraytype, $unknown, $lower, $upper) = (); - #local($typeno); - # global $typeno, @type - local($_, $typedef) = @_; - - while (s/^((\d+)=)?ar(\d+);//) { - ($arraytype, $unknown) = ($2, $3); - if (s/^(\d+);(\d+);//) { - ($lower, $upper) = ($1, $2); - $scripts .= '[' . ($upper+1) . ']'; - } else { - warn "can't find array bounds: $_"; - } - } - if (s/^([\d*f=]*),(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - local($whatis) = $1; - if ($whatis =~ /^(\d+)=/) { - $typeno = $1; - &pdecl($whatis); - } else { - $typeno = $whatis; - } - } elsif (s/^(\d+)(=[*suf]\d*)//) { - local($whatis) = $2; - - if ($whatis =~ /[f*]/) { - &pdecl($whatis); - } elsif ($whatis =~ /[su]/) { # - print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" - if $debug; - #$type[$typeno] = $name unless defined $type[$typeno]; - ##printf "new type $typeno is $name" if $debug; - $typeno = $1; - $type[$typeno] = "$prefix.$fieldname"; - local($name) = $type[$typeno]; - &sou($name, $whatis); - $_ = &sdecl($name, $_, $start+$offset); - 1; - $start = $start{$name}; - $offset = $sizeof{$name}; - $length = $offset; - } else { - warn "what's this? $whatis in $line "; - } - } elsif (/^\d+$/) { - $typeno = $_; - } else { - warn "bad array stab: $_ in $line "; - next STAB; - } - #local($wasdef) = defined($type[$typeno]) && $debug; - #if ($typedef) { - #print "redefining $type[$typeno] to " if $wasdef; - #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; - #print "$type[$typeno]\n" if $wasdef; - #} else { - #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; - #} - $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; - print "type[$arraytype] is $type[$arraytype]\n" if $debug; - print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; - $_; -} - - - -sub sdecl { - local($prefix, $_, $offset) = @_; - - local($fieldname, $scripts, $type, $arraytype, $unknown, - $whatis, $pdecl, $upper,$lower, $start,$length) = (); - local($typeno,$sou); - - -SFIELD: - while (/^([^;]+);/) { - $scripts = ''; - warn "sdecl $_\n" if $debug; - if (s/^([\$\w]+)://) { - $fieldname = $1; - } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # - $typeno = &typeno($1); - $type[$typeno] = "$prefix.$fieldname"; - local($name) = "$prefix.$fieldname"; - &sou($name,$2); - $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - $start = $start{$name}; - $offset += $sizeof{$name}; - #print "done with anon, start is $start, offset is $offset\n"; - #next SFIELD; - } else { - warn "weird field $_ of $line" if $debug; - next STAB; - #$fieldname = &gensym; - #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - } - - if (/^\d+=ar/) { - $_ = &adecl($_); - } - elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - &panic("no length?") unless $length; - $typeno = &typeno($1) if $1; - } - elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { - ($pdecl, $start, $length) = ($1,$5,$6); - &pdecl($pdecl); - } - elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct - ($typeno, $sou) = ($1, $2); - $typeno = &typeno($typeno); - if (defined($type[$typeno])) { - warn "now how did we get type $1 in $fieldname of $line?"; - } else { - print "anon type $typeno is $prefix.$fieldname\n" if $debug; - $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; - }; - local($name) = "$prefix.$fieldname"; - &sou($name,$sou); - print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; - $type[$typeno] = "$prefix.$fieldname"; - $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - $start = $start{$name}; - $length = $sizeof{$name}; - } - else { - warn "can't grok stab for $name ($_) in line $line "; - next STAB; - } - - &panic("no length for $prefix.$fieldname") unless $length; - $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; - } - if (s/;\d*,(\d+),(\d+);//) { - local($start, $size) = ($1, $2); - $sizeof{$prefix} = $size; - print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; - $start{$prefix} = $start; - } - $_; -} - -sub edecl { - s/;$//; - $enum{$name} = $_; - $_ = ''; -} - -sub resolve_types { - local($sou); - for $i (0 .. $#type) { - next unless defined $type[$i]; - $_ = $type[$i]; - unless (/\d/) { - print "type[$i] $type[$i]\n" if $debug; - next; - } - print "type[$i] $_ ==> " if $debug; - s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; - s/^(\d+)\&/&type($1)/e; - s/^(\d+)/&type($1)/e; - s/(\*+)([^*]+)(\*+)/$1$3$2/; - s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; - s/^(\d+)([\*\[].*)/&type($1).$2/e; - #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; - $type[$i] = $_; - print "$_\n" if $debug; - } -} -sub type { &psou($type[$_[0]] || "<UNDEFINED>"); } - -sub adjust_start_addrs { - for (sort keys %start) { - ($basename = $_) =~ s/\.[^.]+$//; - $start{$_} += $start{$basename}; - print "start: $_ @ $start{$_}\n" if $debug; - } -} - -sub sou { - local($what, $_) = @_; - /u/ && $isaunion{$what}++; - /s/ && $isastruct{$what}++; -} - -sub psou { - local($what) = @_; - local($prefix) = ''; - if ($isaunion{$what}) { - $prefix = 'union '; - } elsif ($isastruct{$what}) { - $prefix = 'struct '; - } - $prefix . $what; -} - -sub scrunch { - local($_) = @_; - - study; - - s/\$//g; - s/ / /g; - 1 while s/(\w) \1/$1$1/g; - - # i wanna say this, but perl resists my efforts: - # s/(\w)(\1+)/$2 . length($1)/ge; - - &quick_scrunch; - - s/ $//; - - $_; -} - -sub buildscrunchlist { - $scrunch_code = "sub quick_scrunch {\n"; - for (values %intrinsics) { - $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n"; - } - $scrunch_code .= "}\n"; - print "$scrunch_code" if $debug; - eval $scrunch_code; - &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; -} - -sub fetch_template { - local($mytype) = @_; - local($fmt); - local($count) = 1; - - &panic("why do you care?") unless $perl; - - if ($mytype =~ s/(\[\d+\])+$//) { - $count .= $1; - } - - if ($mytype =~ /\*/) { - $fmt = $template{'pointer'}; - } - elsif (defined $template{$mytype}) { - $fmt = $template{$mytype}; - } - elsif (defined $struct{$mytype}) { - if (!defined $template{&psou($mytype)}) { - &build_template($mytype) unless $mytype eq $name; - } - elsif ($template{&psou($mytype)} !~ /\$$/) { - #warn "incomplete template for $mytype\n"; - } - $fmt = $template{&psou($mytype)} || '?'; - } - else { - warn "unknown fmt for $mytype\n"; - $fmt = '?'; - } - - $fmt x $count . ' '; -} - -sub compute_intrinsics { - local($TMP) = "/tmp/c2ph-i.$$.c"; - open (TMP, ">$TMP") || die "can't open $TMP: $!"; - select(TMP); - - print STDERR "computing intrinsic sizes: " if $trace; - - undef %intrinsics; - - print <<'EOF'; -main() { - char *mask = "%d %s\n"; -EOF - - for $type (@intrinsics) { - next if $type eq 'void'; - print <<"EOF"; - printf(mask,sizeof($type), "$type"); -EOF - } - - print <<'EOF'; - printf(mask,sizeof(char *), "pointer"); - exit(0); -} -EOF - close TMP; - - select(STDOUT); - open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|"); - while (<PIPE>) { - chop; - split(' ',$_,2);; - print "intrinsic $_[1] is size $_[0]\n" if $debug; - $sizeof{$_[1]} = $_[0]; - $intrinsics{$_[1]} = $template{$_[0]}; - } - close(PIPE) || die "couldn't read intrinsics!"; - unlink($TMP, '/tmp/a.out'); - print STDERR "done\n" if $trace; -} - -sub scripts2count { - local($_) = @_; - - s/^\[//; - s/\]$//; - s/\]\[/*/g; - $_ = eval; - &panic("$_: $@") if $@; - $_; -} - -sub system { - print STDERR "@_\n" if $trace; - system @_; -} - -sub build_template { - local($name) = @_; - - &panic("already got a template for $name") if defined $template{$name}; - - local($build_templates) = 1; - - local($lparen) = '(' x $build_recursed; - local($rparen) = ')' x $build_recursed; - - print STDERR "$lparen$name$rparen " if $trace; - $build_recursed++; - &pstruct($name,$name,0); - print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; - --$build_recursed; -} - - -sub panic { - - select(STDERR); - - print "\npanic: @_\n"; - - exit 1 if $] <= 4.003; # caller broken - - local($i,$_); - local($p,$f,$l,$s,$h,$a,@a,@sub); - for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { - @a = @DB'args; - for (@a) { - if (/^StB\000/ && length($_) == length($_main{'_main'})) { - $_ = sprintf("%s",$_); - } - else { - s/'/\\'/g; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - push(@sub, "$w&$s$a from file $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print $sub[$i]; - } - exit 1; -} - -sub squishseq { - local($num); - local($last) = -1e8; - local($string); - local($seq) = '..'; - - while (defined($num = shift)) { - if ($num == ($last + 1)) { - $string .= $seq unless $inseq++; - $last = $num; - next; - } elsif ($inseq) { - $string .= $last unless $last == -1e8; - } - - $string .= ',' if defined $string; - $string .= $num; - $last = $num; - $inseq = 0; - } - $string .= $last if $inseq && $last != -e18; - $string; -} @@ -37,7 +37,7 @@ $spitshell >>c2ph <<'!NO!SUBS!' # See the usage message for more. If this isn't enough, read the code. # -$RCSID = '$RCSfile: c2ph.SH,v $$Revision: 4.1 $$Date: 92/08/07 17:19:10 $'; +$RCSID = 'c2ph.SH'; ###################################################################### diff --git a/cflags b/cflags deleted file mode 100755 index a2ee6275d8..0000000000 --- a/cflags +++ /dev/null @@ -1,79 +0,0 @@ -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -case $CONFIG in -'') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi 2>/dev/null - . ./config.sh - ;; -esac - -also=': ' -case $# in -1) also='echo 1>&2 " CCCMD = "' -esac - -case $# in -0) set *.c; echo "The current C flags are:" ;; -esac - -set `echo "$* " | sed 's/\.[oc] / /g'` - -for file do - - case "$#" in - 1) ;; - *) echo $n " $file.c $c" ;; - esac - - : allow variables like toke_cflags to be evaluated - - eval 'eval ${'"${file}_cflags"'-""}' - - : or customize here - - case "$file" in - NDBM_File) ;; - ODBM_File) ;; - POSIX) ;; - SDBM_File) ;; - av) ;; - deb) ;; - dl) ;; - doio) ;; - doop) ;; - dump) ;; - gv) ;; - hv) ;; - main) ;; - malloc) ;; - mg) ;; - miniperlmain) ;; - op) ;; - perl) ;; - perlmain) ;; - perly) ;; - pp) ;; - regcomp) ;; - regexec) ;; - run) ;; - scope) ;; - sv) ;; - taint) ;; - toke) ;; - usersub) ;; - util) ;; - *) ;; - esac - - echo "$cc -c $ccflags $optimize $large $split" - eval "$also "'"$cc -c $ccflags $optimize $large $split"' - - . ./config.sh - -done @@ -1,13 +1,15 @@ case $CONFIG in '') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi - . ./config.sh - ;; + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. @@ -19,25 +21,37 @@ echo "Extracting cflags (with variable substitutions)" : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. -rm -f cflags $spitshell >cflags <<!GROK!THIS! !GROK!THIS! : In the following dollars and backticks do not need the extra backslash. $spitshell >>cflags <<'!NO!SUBS!' -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac case $CONFIG in '') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi 2>/dev/null - . ./config.sh - ;; + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; +esac + +perltype='' +optdebug='' # ensure -g used if building a -DDEBUGGING libperl +case $# in +2) case $1 in + *perl.*) perltype='';; + *perld.*) perltype='-DDEBUGGING'; optdebug='-g' ;; + *perle.*) perltype='-DEMBED';; + *perlde.*) perltype='-DDEBUGGING -DEMBED'; optdebug='-g' ;; + *perlm.*) perltype='-DEMBED -DMULTIPLICITY';; + *perldm.*) perltype='-DDEBUGGING -DEMBED -DMULTIPLICITY'; optdebug='-g' ;; + esac + shift ;; esac also=': ' @@ -65,6 +79,8 @@ for file do : or customize here case "$file" in + DB_File) ;; + GDBM_File) ;; NDBM_File) ;; ODBM_File) ;; POSIX) ;; @@ -86,6 +102,9 @@ for file do perlmain) ;; perly) ;; pp) ;; + pp_ctl) ;; + pp_hot) ;; + pp_sys) ;; regcomp) ;; regexec) ;; run) ;; @@ -98,12 +117,16 @@ for file do *) ;; esac - echo "$cc -c $ccflags $optimize $large $split" - eval "$also "'"$cc -c $ccflags $optimize $large $split"' + if test "X$optdebug" != "X"; then + optimize="$optdebug" + fi + + echo "$cc -c $ccflags $optimize $perltype $large $split" + eval "$also "'"$cc -c $ccflags $optimize $perltype $large $split"' - . ./config.sh + . $TOP/config.sh done !NO!SUBS! -chmod +x cflags +chmod 755 cflags $eunicefix cflags @@ -1,6 +1,6 @@ -/* config.H: This is a sample config.h file. config.h is produced - from config_h.SH by Configure. This file is intended only for - those having problems with the regular Configure process. +/* 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 @@ -14,14 +14,20 @@ * $Id: Config_h.U,v 3.0.1.2 1993/08/24 12:13:20 ram Exp $ */ -/* Configuration time: Thu Apr 28 11:13:38 EDT 1994 - * Configured by: doughera - * Target system: sunos einstein 4.1.3 3 sun4c +/* Configuration time: Thu Oct 6 18:27:36 EDT 1994 + * Configured by: andy + * Target system: crystal crystal 3.2 2 i386 */ #ifndef _config_h_ #define _config_h_ +/* MEM_ALIGNBYTES: + * This symbol contains the number of bytes required to align a + * double. Usual values are 2, 4 and 8. + */ +#define MEM_ALIGNBYTES 4 /**/ + /* 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. @@ -32,7 +38,7 @@ * This symbol hold the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... */ -#define BYTEORDER 0x4321 /* large digits for MSB */ +#define BYTEORDER 0x1234 /* large digits for MSB */ /* CPPSTDIN: * This symbol contains the first part of the string which will invoke @@ -46,8 +52,14 @@ * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ -#define CPPSTDIN "/home/doughera/src/perl5a8-ad/cppstdin" -#define CPPMINUS "" +#define CPPSTDIN "gcc -E" +#define CPPMINUS "-" + +/* HAS_ALARM: + * This symbol, if defined, indicates that the alarm routine is + * available. + */ +#define HAS_ALARM /**/ /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to @@ -67,6 +79,12 @@ */ #define HAS_BZERO /**/ +/* CASTI32: + * This symbol is defined if the C compiler can cast negative + * or large floating point numbers to 32-bit ints. + */ +/*#define CASTI32 /**/ + /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. @@ -87,13 +105,25 @@ * is up to the package author to declare sprintf correctly based on the * symbol. */ -#define CHARSPRINTF /**/ +/*#define CHARSPRINTF /**/ + +/* HAS_CHOWN: + * This symbol, if defined, indicates that the chown routine is + * available. + */ +#define HAS_CHOWN /**/ + +/* HAS_CHROOT: + * This symbol, if defined, indicates that the chroot routine is + * available. + */ +#define HAS_CHROOT /**/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ -/*#define HAS_CHSIZE /**/ +#define HAS_CHSIZE /**/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about @@ -101,7 +131,7 @@ * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ -/*#define HASCONST /**/ +#define HASCONST /**/ #ifndef HASCONST #define const #endif @@ -116,22 +146,27 @@ * This symbol, if defined, indicates that the C-shell exists. * If defined, contains the full pathname of csh. */ -#define CSH "/usr/bin/csh" /**/ +#define CSH "/bin/csh" /**/ -/* 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. +/* HAS_CUSERID: + * This symbol, if defined, indicates that the cuserid routine is + * available to get character login names. */ -/*#define DOSUID /**/ +#define HAS_CUSERID /**/ + +/* HAS_DBL_DIG: + * This symbol, if defined, indicates that this system's <float.h> + * or <limits.h> defines the symbol DBL_DIG, which is the number + * of significant digits in a double precision number. If this + * symbol is not defined, a guess of 15 is usually pretty good. + */ +#define HAS_DBL_DIG /* */ + +/* HAS_DIFFTIME: + * This symbol, if defined, indicates that the difftime routine is + * available. + */ +#define HAS_DIFFTIME /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is @@ -143,13 +178,13 @@ * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ -#define HAS_FCHMOD /**/ +/*#define HAS_FCHMOD /**/ /* HAS_FCHOWN: * This symbol, if defined, indicates that the fchown routine is available * to change ownership of opened files. If unavailable, use chown(). */ -#define HAS_FCHOWN /**/ +/*#define HAS_FCHOWN /**/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that @@ -157,17 +192,35 @@ */ #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 /**/ +/*#define FLEXFILENAMES /**/ /* HAS_FLOCK: * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ -#define HAS_FLOCK /**/ +/*#define HAS_FLOCK /**/ + +/* HAS_FORK: + * This symbol, if defined, indicates that the fork routine is + * 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 @@ -180,7 +233,7 @@ * This symbol, if defined, indicates that the gethostent routine is * available to lookup host names in some data base or other. */ -#define HAS_GETHOSTENT /**/ +/*#define HAS_GETHOSTENT /**/ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the @@ -189,6 +242,12 @@ */ #define HAS_UNAME /**/ +/* HAS_GETLOGIN: + * This symbol, if defined, indicates that the getlogin routine is + * available to get the login name. + */ +#define HAS_GETLOGIN /**/ + /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. @@ -201,18 +260,55 @@ */ /*#define HAS_GETPGRP2 /**/ +/* HAS_GETPPID: + * This symbol, if defined, indicates that the getppid routine is + * available to get the parent process ID. + */ +#define HAS_GETPPID /**/ + /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ -#define HAS_GETPRIORITY /**/ +/*#define HAS_GETPRIORITY /**/ + +/* HAS_GROUP: + * This symbol, if defined, indicates that the group routine is + * available. + */ +/*#define HAS_GROUP /**/ + +/* 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_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ -#define HAS_KILLPG /**/ +/*#define HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is @@ -220,12 +316,36 @@ */ #define HAS_LINK /**/ +/* HAS_LOCKF: + * This symbol, if defined, indicates that the lockf routine is + * available to do file locking. + */ +#define HAS_LOCKF /**/ + /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ #define HAS_LSTAT /**/ +/* HAS_MBLEN: + * This symbol, if defined, indicates that the mblen routine is available + * to find the number of bytes in a multibye character. + */ +/*#define HAS_MBLEN /**/ + +/* HAS_MBSTOWCS: + * This symbol, if defined, indicates that the mbstowcs routine is + * available to covert a multibyte string into a wide character string. + */ +/*#define HAS_MBSTOWCS /**/ + +/* HAS_MBTOWC: + * This symbol, if defined, indicates that the mbtowc routine is available + * to covert a multibyte to a wide character. + */ +/*#define HAS_MBTOWC /**/ + /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. @@ -259,41 +379,78 @@ */ #define HAS_MKDIR /**/ +/* HAS_MKTIME: + * This symbol, if defined, indicates that the mktime routine is + * available. + */ +#define HAS_MKTIME /**/ + /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ #define HAS_MSG /**/ -/* HAS_MSGCTL: - * This symbol, if defined, indicates that the msgctl() routine is - * available to perform message control operations. +/* HAS_NICE: + * This symbol, if defined, indicates that the nice routine is + * available. */ -#define HAS_MSGCTL /**/ +#define HAS_NICE /**/ -/* HAS_MSGGET: - * This symbol, if defined, indicates that the msgget() routine is - * available to get a new message queue. +/* HAS_OPEN3: + * This manifest constant lets the C program know that the three + * argument form of open(2) is available. */ -#define HAS_MSGGET /**/ +#define HAS_OPEN3 /**/ -/* HAS_MSGRCV: - * This symbol, if defined, indicates that the msgrcv() routine is - * available to extract a message from the message queue. +/* HAS_PASSWD: + * This symbol, if defined, indicates that the passwd routine is + * available. */ -#define HAS_MSGRCV /**/ +/*#define HAS_PASSWD /**/ -/* HAS_MSGSND: - * This symbol, if defined, indicates that the msgsnd() routine is - * available to send a message into the message queue. +/* HAS_PAUSE: + * This symbol, if defined, indicates that the pause routine is + * available to suspend a process until a signal is received. */ -#define HAS_MSGSND /**/ +#define HAS_PAUSE /**/ -/* HAS_OPEN3: - * This manifest constant lets the C program know that the three - * argument form of open(2) is available. +/* HAS_PIPE: + * This symbol, if defined, indicates that the pipe routine is + * available to create an inter-process channel. */ -#define HAS_OPEN3 /**/ +#define HAS_PIPE /**/ + +/* HAS_READDIR: + * This symbol, if defined, indicates that the readdir routine is + * available to read directory entries. You may have to include + * <dirent.h>. See I_DIRENT. + */ +#define HAS_READDIR /**/ + +/* HAS_SEEKDIR: + * This symbol, if defined, indicates that the seekdir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_SEEKDIR /**/ + +/* HAS_TELLDIR: + * This symbol, if defined, indicates that the telldir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_TELLDIR /**/ + +/* HAS_REWINDDIR: + * This symbol, if defined, indicates that the rewinddir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_REWINDDIR /**/ + +/* HAS_READLINK: + * This symbol, if defined, indicates that the readlink routine is + * available to read the value of a symbolic link. + */ +#define HAS_READLINK /**/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available @@ -322,24 +479,6 @@ */ #define HAS_SEM /**/ -/* HAS_SEMCTL: - * This symbol, if defined, indicates that the semctl() routine is - * available to perform semaphore control operations. - */ -#define HAS_SEMCTL /**/ - -/* HAS_SEMGET: - * This symbol, if defined, indicates that the semget() routine is - * available to get a set of semaphores. - */ -#define HAS_SEMGET /**/ - -/* HAS_SEMOP: - * This symbol, if defined, indicates that the semop() routine is - * available to execute semaphore operations. - */ -#define HAS_SEMOP /**/ - /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. @@ -352,6 +491,19 @@ */ #define HAS_SETEUID /**/ +/* HAS_SETLINEBUF: + * This symbol, if defined, indicates that the setlinebuf routine is + * available to change stderr or stdout from block-buffered or unbuffered + * to a line-buffered mode. + */ +/*#define HAS_SETLINEBUF /**/ + +/* HAS_SETLOCALE: + * This symbol, if defined, indicates that the setlocale routine is + * available to handle locale-specific ctype implementations. + */ +#define HAS_SETLOCALE /**/ + /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid routine is * available to set process group ID. @@ -374,7 +526,7 @@ * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ -#define HAS_SETPRIORITY /**/ +/*#define HAS_SETPRIORITY /**/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is @@ -406,13 +558,13 @@ * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. */ -#define HAS_SETRGID /**/ +/*#define HAS_SETRGID /**/ /* HAS_SETRUID: * This symbol, if defined, indicates that the setruid routine is available * to change the real uid of the current program. */ -#define HAS_SETRUID /**/ +/*#define HAS_SETRUID /**/ /* HAS_SETSID: * This symbol, if defined, indicates that the setsid routine is @@ -426,23 +578,19 @@ */ #define HAS_SHM /**/ -/* HAS_SHMCTL: - * This symbol, if defined, indicates that the shmctl() routine is - * available to perform shared memory control operations. +/* Shmat_t: + * This symbol holds the return type of the shmat() system call. + * Usually set to 'void *' or 'char *'. */ -#define HAS_SHMCTL /**/ - -/* HAS_SHMDT: - * This symbol, if defined, indicates that the shmdt() routine is - * available to detach a shared memory segment from the process space. +/* HAS_SHMAT_PROTOTYPE: + * This symbol, if defined, indicates that the sys/shm.h includes + * a prototype for shmat(). Otherwise, it is up to the program to + * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess, + * but not always right so it should be emitted by the program only + * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ -#define HAS_SHMDT /**/ - -/* HAS_SHMGET: - * This symbol, if defined, indicates that the shmget() routine is - * available to request a shared memory segment from the kernel. - */ -#define HAS_SHMGET /**/ +#define Shmat_t char * /**/ +/*#define HAS_SHMAT_PROTOTYPE /**/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is @@ -452,20 +600,14 @@ * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* USE_OLDSOCKET: - * This symbol, if defined, indicates that the 4.1c BSD socket interface - * is supported instead of the 4.2/4.3 BSD socket interface. For instance, - * there is no setsockopt() call. - */ #define HAS_SOCKET /**/ -#define HAS_SOCKETPAIR /**/ -/*#define USE_OLDSOCKET /**/ +/*#define HAS_SOCKETPAIR /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ -#define USE_STAT_BLOCKS /**/ +/*#define USE_STAT_BLOCKS /**/ /* USE_STD_STDIO: * This symbol is defined if this system has a FILE structure declaring @@ -473,6 +615,24 @@ */ #define USE_STD_STDIO /**/ +/* HAS_STRCHR: + * This symbol is defined to indicate that the strchr()/strrchr() + * functions are available for string searching. If not, try the + * index()/rindex() pair. + */ +/* HAS_INDEX: + * This symbol is defined to indicate that the index()/rindex() + * functions are available for string searching. + */ +#define HAS_STRCHR /**/ +/*#define HAS_INDEX /**/ + +/* HAS_STRCOLL: + * This symbol, if defined, indicates that the strcoll routine is + * available to compare strings using collating information. + */ +#define HAS_STRCOLL /**/ + /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy @@ -480,6 +640,31 @@ */ #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. @@ -498,12 +683,17 @@ */ #define HAS_SYSTEM /**/ -/* 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). +/* 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 Time_t long /* Time type */ +#define HAS_TCSETPGRP /**/ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. @@ -516,13 +706,24 @@ * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ -#define HAS_TRUNCATE /**/ +/*#define HAS_TRUNCATE /**/ + +/* HAS_TZNAME: + * This symbol, if defined, indicates that the tzname[] array is + * available to access timezone names. + */ +#define HAS_TZNAME /**/ + +/* HAS_UMASK: + * This symbol, if defined, indicates that the umask routine is + * available to set and get the value of the file creation mask. + */ +#define HAS_UMASK /**/ -/* I_NDIR: - * This symbol, if defined, indicates that the program should include the - * system's version of ndir.h, rather than the one with this package. +/* HAS_VFORK: + * This symbol, if defined, indicates that vfork() exists. */ -/*#define I_NDIR /**/ +/*#define HAS_VFORK /**/ /* VOIDSIG: * This symbol is defined if this system declares "void (*signal(...))()" in @@ -536,7 +737,7 @@ * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ -/*#define HASVOLATILE /**/ +#define HASVOLATILE /**/ #ifndef HASVOLATILE #define volatile #endif @@ -553,12 +754,12 @@ * symbol. */ #define HAS_VPRINTF /**/ -#define USE_CHAR_VSPRINTF /**/ +/*#define USE_CHAR_VSPRINTF /**/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ -#define HAS_WAIT4 /**/ +/*#define HAS_WAIT4 /**/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is @@ -566,11 +767,33 @@ */ #define HAS_WAITPID /**/ -/* I_DBM: - * This symbol, if defined, indicates to the C program that it should - * include <dbm.h>. +/* 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 I_DBM /**/ +/*#define HAS_WCTOMB /**/ + +/* Fpos_t: + * This symbol holds the type used to declare file positions in libc. + * It can be fpos_t, long, uint, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Fpos_t fpos_t /* File position type */ + +/* Gid_t: + * This symbol holds the return type of getgid() and the type of + * argument to setrgid() and related functions. Typically, + * it is the type of group ids in the kernel. It can be int, ushort, + * uid_t, etc... It may be necessary to include <sys/types.h> to get + * any typedef'ed information. + */ +#define Gid_t gid_t /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should @@ -583,24 +806,32 @@ * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ +/* Direntry_t: + * This symbol is set to 'struct direct' or 'struct dirent' depending on + * whether dirent is available or not. You should use this pseudo type to + * portably declare your directory entries. + */ #define I_DIRENT /**/ /*#define DIRNAMLEN /**/ -#ifdef I_DIRENT #define Direntry_t struct dirent -#else -#define Direntry_t struct direct -#endif + +/* I_DLFCN: + * This symbol, if defined, indicates that <dlfcn.h> exists and should + * be included. + */ +/*#define I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include <fcntl.h>. */ -/*#define I_FCNTL /**/ +#define I_FCNTL /**/ -/* I_GDBM: - * This symbol, if defined, indicates that gdbm.h exists and should - * be included. +/* 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_GDBM /**/ +#define I_FLOAT /**/ /* I_GRP: * This symbol, if defined, indicates to the C program that it should @@ -608,6 +839,25 @@ */ #define I_GRP /**/ +/* I_LIMITS: + * This symbol, if defined, indicates to the C program that it should + * include <limits.h> to get definition of symbols like WORD_BIT or + * LONG_MAX, i.e. machine dependant limitations. + */ +#define I_LIMITS /**/ + +/* I_MATH: + * This symbol, if defined, indicates to the C program that it should + * include <math.h>. + */ +#define I_MATH /**/ + +/* I_MEMORY: + * This symbol, if defined, indicates to the C program that it should + * include <memory.h>. + */ +/*#define I_MEMORY /**/ + /* I_NDBM: * This symbol, if defined, indicates that ndbm.h exists and should * be included. @@ -618,18 +868,43 @@ * This symbol, if defined, indicates to the C program that it should * include <netinet/in.h>. Otherwise, you may try <sys/in.h>. */ -/* I_SYS_IN: - * This symbol, if defined, indicates to the C program that it should - * include <sys/in.h> instead of <netinet/in.h>. - */ #define I_NETINET_IN /**/ -/*#define I_SYS_IN /**/ -/* I_STDARG: - * This symbol, if defined, indicates that <stdarg.h> exists and should - * be included. +/* 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. */ -/*#define I_STDARG /**/ +/* PWCLASS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_class. + */ +/* PWEXPIRE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_expire. + */ +/* PWCOMMENT: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_comment. + */ +#define I_PWD /**/ +/*#define PWQUOTA /**/ +#define PWAGE /**/ +/*#define PWCHANGE /**/ +/*#define PWCLASS /**/ +/*#define PWEXPIRE /**/ +#define PWCOMMENT /**/ /* I_STDDEF: * This symbol, if defined, indicates that <stddef.h> exists and should @@ -637,6 +912,12 @@ */ #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). @@ -653,7 +934,7 @@ * This symbol, if defined, indicates to the C program that it should * include <sys/file.h> to get definition of R_OK and friends. */ -#define I_SYS_FILE /**/ +/*#define I_SYS_FILE /**/ /* I_SYS_IOCTL: * This symbol, if defined, indicates that <sys/ioctl.h> exists and should @@ -667,12 +948,44 @@ */ /*#define I_SYS_NDIR /**/ +/* I_SYS_PARAM: + * This symbol, if defined, indicates to the C program that it should + * include <sys/param.h>. + */ +#define I_SYS_PARAM /**/ + /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include <sys/select.h> in order to get definition of struct timeval. */ /*#define I_SYS_SELECT /**/ +/* I_SYS_TIMES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/times.h>. + */ +#define I_SYS_TIMES /**/ + +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * <termio.h> rather than <sgtty.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * <sgtty.h> rather than <termio.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/*#define I_TERMIO /**/ +#define I_TERMIOS /**/ +/*#define I_SGTTY /**/ + /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include <time.h>. @@ -689,17 +1002,34 @@ #define I_SYS_TIME /**/ /*#define I_SYS_TIME_KERNEL /**/ +/* I_UNISTD: + * This symbol, if defined, indicates to the C program that it should + * include <unistd.h>. + */ +#define I_UNISTD /**/ + /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include <utime.h>. */ #define I_UTIME /**/ +/* I_STDARG: + * This symbol, if defined, indicates that <stdarg.h> exists and should + * be included. + */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include <varargs.h>. */ -#define I_VARARGS /**/ +#define I_STDARG /**/ +/*#define I_VARARGS /**/ + +/* I_VFORK: + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +/*#define I_VFORK /**/ /* INTSIZE: * This symbol contains the size of an int, so that the C preprocessor @@ -720,13 +1050,31 @@ * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ -#define PRIVLIB "/usr/local/lib/perl" /**/ +#define PRIVLIB "/usr/local/lib/perl5" /**/ + +/* CAN_PROTOTYPE: + * If defined, this macro indicates that the C compiler can handle + * function prototypes. + */ +/* _: + * This macro is used to declare function parameters for folks who want + * to make declarations with prototypes using a different style than + * the above macros. Use double parentheses. For example: + * + * int main _((int argc, char *argv[])); + */ +#define CAN_PROTOTYPE /**/ +#ifdef CAN_PROTOTYPE +#define _(args) args +#else +#define _(args) () +#endif /* RANDBITS: * This symbol contains the number of bits of random number the rand() * function produces. Usual values are 15, 16, and 31. */ -#define RANDBITS 31 /**/ +#define RANDBITS 15 /**/ /* SCRIPTDIR: * This symbol holds the name of the directory in which the user wants @@ -736,6 +1084,32 @@ */ #define SCRIPTDIR "/usr/local/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 * /**/ + +/* SIG_NAME: + * This symbol contains a list of signal names in order. This is intended + * to be used as a static array initialization, like this: + * 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". + */ +#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CLD","PWR","WINCH","21","POLL","CONT","STOP","TSTP","TTIN","TTOU" /**/ + +/* 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 */ + /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". @@ -749,6 +1123,31 @@ */ #define Uid_t uid_t /* UID type */ +/* VOIDFLAGS: + * This symbol indicates how much support of the void type is given by this + * compiler. What various bits mean: + * + * 1 = supports declaration of void + * 2 = supports arrays of pointers to functions returning void + * 4 = supports comparisons between pointers to void functions and + * addresses of void functions + * 8 = suports declaration of generic void pointers + * + * The package designer should define VOIDUSED to indicate the requirements + * of the package. This can be done either by #defining VOIDUSED before + * including config.h, or by defining defvoidused in Myinit.U. If the + * latter approach is taken, only those flags will be tested. If the + * level of void support necessary is not present, defines void to int. + */ +#ifndef VOIDUSED +#define VOIDUSED 15 +#endif +#define VOIDFLAGS 15 +#if (VOIDFLAGS & VOIDUSED) != VOIDUSED +#define void int /* is void to be avoided? */ +#define M_VOID /* Xenix strikes again */ +#endif + /* EUNICE: * This symbol, if defined, indicates that the program is being compiled * under the EUNICE package under VMS. The program will need to handle @@ -763,73 +1162,155 @@ /*#define EUNICE /**/ /*#define VMS /**/ -/* MEM_ALIGNBYTES: - * This symbol contains the number of bytes required to align a - * double. Usual values are 2, 4 and 8. +/* LOC_SED: + * This symbol holds the complete pathname to the sed program. */ -#define MEM_ALIGNBYTES 8 /**/ +#define LOC_SED "/bin/sed" /**/ + +/* ARCHLIB: + * This variable, if defined, holds the name of the directory in + * which the user wants to put architecture-dependent public + * library files for perl5. It is most often a local directory + * such as /usr/local/lib. Programs using this variable must be + * prepared to deal with filename expansion. If ARCHLIB is the + * same as PRIVLIB, it is not defined, since presumably the + * program already searches PRIVLIB. + */ +#define ARCHLIB "/usr/local/lib/perl5/isc" /**/ + +/* CAT2: + * This macro catenates 2 tokens together. + */ +#if 42 == 1 +#define CAT2(a,b)a/**/b +#define CAT3(a,b,c)a/**/b/**/c +#define CAT4(a,b,c,d)a/**/b/**/c/**/d +#define CAT5(a,b,c,d,e)a/**/b/**/c/**/d/**/e +#define STRINGIFY(a)"a" + /* If you can get stringification with catify, tell me how! */ +#endif +#if 42 == 42 +#define CAT2(a,b)a ## b +#define CAT3(a,b,c)a ## b ## c +#define CAT4(a,b,c,d)a ## b ## c ## d +#define CAT5(a,b,c,d,e)a ## b ## c ## d ## e +#define StGiFy(a)# a +#define STRINGIFY(a)StGiFy(a) +#define SCAT2(a,b)StGiFy(a) StGiFy(b) +#define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c) +#define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) +#define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e) +#endif +#ifndef CAT2 +#include "Bletch: How does this C preprocessor catenate tokens?" +#endif -/* CASTI32: - * This symbol is defined if the C compiler can cast negative - * or large floating point numbers to 32-bit ints. +/* GNUC_ATTRIBUTE_CHECK: + * This symbol indicates the C compiler can check for function attributes, + * such as printf formats. */ -#define CASTI32 /**/ +#define GNUC_ATTRIBUTE_CHECK /* */ -/* HAS_HTONL: - * This symbol, if defined, indicates that the htonl() routine (and - * friends htons() ntohl() ntohs()) are available to do network - * order byte swapping. +/* VOID_CLOSEDIR: + * This symbol, if defined, indicates that the closedir() routine + * does not return a value. */ -/* HAS_HTONS: - * This symbol, if defined, indicates that the htons() routine (and - * friends htonl() ntohl() ntohs()) are available to do network - * order byte swapping. +/*#define VOID_CLOSEDIR /**/ + +/* HAS_DLERROR: + * This symbol, if defined, indicates that the dlerror routine is + * available. */ -/* HAS_NTOHL: - * This symbol, if defined, indicates that the ntohl() routine (and - * friends htonl() htons() ntohs()) are available to do network - * order byte swapping. +/*#define HAS_DLERROR /**/ + +/* 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. */ -/* 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 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. */ -#define HAS_HTONL /**/ -#define HAS_HTONS /**/ -#define HAS_NTOHL /**/ -#define HAS_NTOHS /**/ +/* DOSUID: + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +/*#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ + +/*#define DOSUID /**/ + +/* HAS_DREM: + * This symbol, if defined, indicates that the drem routine is + * available. This is a Pyramid routine that is the same as + * fmod. + */ +/*#define HAS_DREM /**/ + +/* HAS_FMOD: + * This symbol, if defined, indicates that the fmod routine is + * available. + */ +#define HAS_FMOD /**/ + +/* 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. + */ +#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) /* HAS_ISASCII: - * This manifest constant lets the C program know that the - * isascii is available. + * This manifest constant lets the C program know that isascii + * is available. */ #define HAS_ISASCII /**/ -/* 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. +/* USE_LINUX_STDIO: + * This symbol is defined if this system has a FILE structure declaring + * _IO_read_base, _IO_read_ptr, and _IO_read_end in stdio.h. */ -#define HAS_READDIR /**/ +/*#define USE_LINUX_STDIO /**/ -/* HAS_SEEKDIR: - * This symbol, if defined, indicates that the seekdir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. +/* HAS_LOCALECONV: + * This symbol, if defined, indicates that the localeconv routine is + * available for numeric and monetary formatting conventions. */ -#define HAS_SEEKDIR /**/ +#define HAS_LOCALECONV /**/ -/* HAS_TELLDIR: - * This symbol, if defined, indicates that the telldir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. +/* HAS_MKFIFO: + * This symbol, if defined, indicates that the mkfifo routine is + * available. */ -#define HAS_TELLDIR /**/ +#define HAS_MKFIFO /**/ -/* HAS_REWINDDIR: - * This symbol, if defined, indicates that the rewinddir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. +/* HAS_PATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given filename. */ -#define HAS_REWINDDIR /**/ +/* 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_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available @@ -845,70 +1326,28 @@ * probably use memmove() or memcpy(). If neither is defined, roll your * own version. */ -/*#define HAS_SAFE_MEMCPY /**/ - -/* HAS_SETLOCALE: - * This symbol, if defined, indicates that the setlocale routine is - * available to handle locale-specific ctype implementations. - */ -#define HAS_SETLOCALE /**/ - -/* HAS_SHMAT: - * This symbol, if defined, indicates that the shmat() routine is - * available to attach a shared memory segment to the process space. - */ -#define HAS_SHMAT /**/ +#define HAS_SAFE_MEMCPY /**/ -/* VOIDSHMAT: - * This symbol, if defined, indicates that the shmat() routine - * returns a pointer of type void*. Otherwise, char* is assumed. +/* HAS_SYSCONF: + * This symbol, if defined, indicates that sysconf() is available + * to determine system related limits and options. */ -/*#define VOIDSHMAT /**/ +#define HAS_SYSCONF /**/ -/* 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 /**/ -#ifdef HAS_STRERROR -# define Strerror strerror -#else -#define Strerror(e) ((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e]) /**/ -#endif - -/* HAS_VFORK: - * This symbol, if defined, indicates that vfork() exists. +/* 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 HAS_VFORK /**/ +#define Time_t time_t /* Time type */ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. */ -#define USE_DYNAMIC_LOADING /**/ - -/* Gid_t: - * This symbol holds the return type of getgid() and the type of - * argument to setrgid() and related functions. Typically, - * it is the type of group ids in the kernel. - * It can be int, ushort, uid_t, etc... It may be necessary to include - * <sys/types.h> to get any typedef'ed information. - */ -#define Gid_t gid_t /* Type for getgid(), etc... */ +/*#define USE_DYNAMIC_LOADING /**/ -/* GROUPSTYPE: +/* 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... @@ -917,226 +1356,41 @@ * getgroups(). */ #ifdef HAS_GETGROUPS -#define GROUPSTYPE int /* Type for 2nd arg to getgroups() */ +#define Groups_t gid_t /* Type for 2nd arg to getgroups() */ #endif -/* I_DLFCN: - * This symbol, if defined, indicates that <dlfcn.h> exists and should - * be included. - */ -#define I_DLFCN /**/ - -/* I_MEMORY: - * This symbol, if defined, indicates to the C program that it should - * include <memory.h>. - */ -#define I_MEMORY /**/ - /* I_NET_ERRNO: * This symbol, if defined, indicates that <net/errno.h> exists and * should be included. */ -/*#define I_NET_ERRNO /**/ - -/* I_PWD: - * This symbol, if defined, indicates to the C program that it should - * include <pwd.h>. - */ -/* PWQUOTA: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_quota. - */ -/* PWAGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_age. - */ -/* PWCHANGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_change. - */ -/* PWCLASS: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_class. - */ -/* PWEXPIRE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_expire. - */ -/* PWCOMMENT: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_comment. - */ -#define I_PWD /**/ -/*#define PWQUOTA /**/ -#define PWAGE /**/ -/*#define PWCHANGE /**/ -/*#define PWCLASS /**/ -/*#define PWEXPIRE /**/ -#define PWCOMMENT /**/ - -/* I_TERMIO: - * This symbol, if defined, indicates that the program should include - * <termio.h> rather than <sgtty.h>. There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/* I_TERMIOS: - * This symbol, if defined, indicates that the program should include - * the POSIX termios.h rather than sgtty.h or termio.h. - * There are also differences in the ioctl() calls that depend on the - * value of this symbol. - */ -/* I_SGTTY: - * This symbol, if defined, indicates that the program should include - * <sgtty.h> rather than <termio.h>. There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/*#define I_TERMIO /**/ -#define I_TERMIOS /**/ -/*#define I_SGTTY /**/ - -/* I_VFORK: - * This symbol, if defined, indicates to the C program that it should - * include vfork.h. - */ -/*#define I_VFORK /**/ - -/* LOC_SED: - * This symbol holds the complete pathname to the sed program. - */ -#define LOC_SED "/usr/bin/sed" /**/ +#define I_NET_ERRNO /**/ /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ -#define Malloc_t char * /**/ +#define Malloc_t void * /**/ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ #define MYMALLOC /**/ -/* CAN_PROTOTYPE: - * If defined, this macro indicates that the C compiler can handle - * function prototypes. - */ -/*#define CAN_PROTOTYPE /**/ -#ifdef CAN_PROTOTYPE -#else -#endif - -/* PTRSIZE: - * This symbol contains the size of a pointer to a long so that - * the C preprocessor can make decisions based on it. +/* 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 PTRSIZE 4 /**/ - -/* SIG_NAME: - * This symbol contains a list of signal names in order. This is intended - * to be used as a static array initialization, like this: - * 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". - */ -#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","LOST","USR1","USR2" /**/ - -/* VOIDFLAGS: - * This symbol indicates how much support of the void type is given by this - * compiler. What various bits mean: - * - * 1 = supports declaration of void - * 2 = supports arrays of pointers to functions returning void - * 4 = supports comparisons between pointers to void functions and - * addresses of void functions - * 8 = suports declaration of generic void pointers - * - * The package designer should define VOIDUSED to indicate the requirements - * of the package. This can be done either by #defining VOIDUSED before - * including config.h, or by defining defvoidused in Myinit.U. If the - * latter approach is taken, only those flags will be tested. If the - * level of void support necessary is not present, defines void to int. - */ -#ifndef VOIDUSED -# define VOIDUSED 15 -#endif -#define VOIDFLAGS 15 -#if (VOIDFLAGS & VOIDUSED) != VOIDUSED -# define void int /* is void to be avoided? */ -# define M_VOID /* Xenix strikes again */ -# define VOID -#else -# define VOID void -#endif +#define Mode_t mode_t /* file mode parameter for system calls*/ -/* - * The following symbols are obsolete. They are mapped to the the new - * symbols only to ease the transition process. The sources should be - * updated so as to use the new symbols only, as the support for these - * obsolete symbols may end without notice. +/* 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). */ - -#ifdef MEM_ALIGNBYTES -#define ALIGNBYTES MEM_ALIGNBYTES -#endif - -#ifdef USE_CHAR_VSPRINTF -#define CHARVSPRINTF USE_CHAR_VSPRINTF -#endif - -#ifdef Gid_t -#define GIDTYPE Gid_t -#endif - -#ifdef I_GDBM -#define HAS_GDBM I_GDBM -#endif - -#ifdef I_NDBM -#define HAS_NDBM I_NDBM -#endif - -#ifdef I_DBM -#define HAS_ODBM I_DBM -#endif - -#ifdef I_SYS_IOCTL -#define I_SYSIOCTL I_SYS_IOCTL -#endif - -#ifdef Malloc_t -#define MALLOCPTRTYPE Malloc_t -#endif - -#ifdef USE_OLDSOCKET -#define OLDSOCKET USE_OLDSOCKET -#endif - -#ifdef HAS_SAFE_BCOPY -#define SAFE_BCOPY HAS_SAFE_BCOPY -#endif - -#ifdef HAS_SAFE_MEMCPY -#define SAFE_MEMCPY HAS_SAFE_MEMCPY -#endif - -#ifdef USE_STAT_BLOCKS -#define STATBLOCKS USE_STAT_BLOCKS -#endif - -#ifdef USE_STD_STDIO -#define STDSTDIO USE_STD_STDIO -#endif - -#ifdef USE_STRUCT_COPY -#define STRUCTCOPY USE_STRUCT_COPY -#endif - -#ifdef Uid_t -#define UIDTYPE Uid_t -#endif - -#ifdef HAS_SYSTEM -#define SYSTEM HAS_SYSTEM -#endif +#define SSize_t int /* signed count of bytes */ #endif diff --git a/config.sh b/config.sh deleted file mode 100644 index 640042f7fc..0000000000 --- a/config.sh +++ /dev/null @@ -1,353 +0,0 @@ -#!/bin/sh -# -# This file was produced by running the Configure script. It holds all the -# definitions figured out by Configure. Should you modify one of these values, -# do not forget to propagate your changes by running "Configure -der". You may -# instead choose to run each of the .SH files by yourself, or "Configure -S". -# - -# Configuration time: Wed May 4 15:10:39 PDT 1994 -# Configured by: lwall -# Target system: sunos scalpel 4.1.3 3 sun4c - -extensions=' ext/dbm/NDBM_File.xs ext/dbm/ODBM_File.xs ext/dbm/SDBM_File.xs ext/posix/POSIX.xs' -d_eunice='undef' -d_xenix='undef' -eunicefix=':' -Mcc='Mcc' -awk='/bin/awk' -bash='' -bison='/usr/local/bin/bison' -byacc='byacc' -cat='/bin/cat' -chgrp='' -chmod='' -chown='' -compress='' -cp='/bin/cp' -cpio='' -cpp='/usr/lib/cpp' -csh='/bin/csh' -date='/bin/date' -echo='/bin/echo' -egrep='/bin/egrep' -emacs='' -expr='/bin/expr' -find='/bin/find' -flex='' -gcc='' -grep='/bin/grep' -inews='' -ksh='' -less='' -line='/bin/line' -lint='' -ln='/bin/ln' -lp='' -lpr='' -ls='' -mail='' -mailx='' -make='' -mkdir='/bin/mkdir' -more='' -mv='/bin/mv' -nroff='/bin/nroff' -perl='/home/netlabs1/lwall/pl/perl' -pg='' -pmake='' -pr='' -rm='/bin/rm' -rmail='' -sed='/bin/sed' -sendmail='' -sh='' -shar='' -sleep='' -smail='' -sort='/bin/sort' -submit='' -tail='' -tar='' -tbl='' -test='test' -touch='/bin/touch' -tr='/bin/tr' -troff='' -uname='/bin/uname' -uniq='/bin/uniq' -uuname='' -vi='' -zcat='' -hint='recommended' -myuname='sunos scalpel 4.1.3 3 sun4c ' -osname='sunos' -osvers='4.1.3' -Author='' -Date='$Date' -Header='' -Id='$Id' -Locker='' -Log='$Log' -RCSfile='$RCSfile' -Revision='$Revision' -Source='' -State='' -afs='false' -memalignbytes='8' -bin='/usr/local/bin' -binexp='/usr/local/bin' -installbin='/usr/local/bin' -byteorder='4321' -cc='cc' -gccversion='' -ccflags='-DDEBUGGING' -cppflags=' -DDEBUGGING' -ldflags='' -lkflags='' -optimize='-g' -cf_by='lwall' -cf_time='Wed May 4 15:10:39 PDT 1994' -contains='grep' -cpplast='' -cppminus='' -cpprun='/usr/lib/cpp' -cppstdin='/tmp_mnt/net/vaccine/export/src/local/lwall/perl5/cppstdin' -d_access='define' -d_bcmp='define' -d_bcopy='define' -d_bzero='define' -d_casti32='define' -castflags='0' -d_castneg='define' -d_charsprf='define' -d_chsize='undef' -d_const='undef' -cryptlib='' -d_crypt='define' -d_csh='define' -d_dosuid='undef' -d_dup2='define' -d_fchmod='define' -d_fchown='define' -d_fcntl='define' -d_flexfnam='define' -d_flock='define' -d_getgrps='define' -d_gethent='undef' -aphostname='' -d_gethname='undef' -d_phostname='undef' -d_uname='define' -d_getpgrp2='undef' -d_getpgrp='define' -d_getprior='define' -d_htonl='define' -d_isascii='define' -d_killpg='define' -d_link='define' -d_lstat='define' -d_memcmp='define' -d_memcpy='define' -d_memmove='undef' -d_memset='define' -d_mkdir='define' -d_msg='define' -d_msgctl='define' -d_msgget='define' -d_msgrcv='define' -d_msgsnd='define' -d_open3='define' -d_portable='undef' -d_readdir='define' -d_rewinddir='define' -d_seekdir='define' -d_telldir='define' -d_rename='define' -d_rmdir='define' -d_safebcpy='define' -d_safemcpy='undef' -d_select='define' -d_sem='define' -d_semctl='define' -d_semget='define' -d_semop='define' -d_setegid='define' -d_seteuid='define' -d_setlocale='define' -d_setpgid='define' -d_setpgrp2='undef' -d_bsdpgrp='' -d_setpgrp='define' -d_setprior='define' -d_setregid='define' -d_setresgid='undef' -d_setresuid='undef' -d_setreuid='define' -d_setrgid='define' -d_setruid='define' -d_setsid='define' -d_shm='define' -d_shmat='define' -d_voidshmat='undef' -d_shmctl='define' -d_shmdt='define' -d_shmget='define' -d_oldsock='undef' -d_socket='define' -d_sockpair='define' -sockethdr='' -socketlib='' -d_statblks='define' -d_stdstdio='define' -d_index='undef' -d_strchr='define' -d_strctcpy='define' -d_strerrm='define' -d_strerror='undef' -d_sysernlst='' -d_syserrlst='define' -d_symlink='define' -d_syscall='define' -d_system='define' -d_time='define' -timetype='long' -clocktype='long' -d_times='define' -d_truncate='define' -d_usendir='undef' -i_ndir='undef' -ndirc='' -ndirlib='' -ndiro='' -d_vfork='undef' -d_voidsig='define' -signal_t='void' -d_volatile='undef' -d_charvspr='define' -d_vprintf='define' -d_wait4='define' -d_waitpid='define' -cccdlflags='' -ccdlflags='' -dldir='ext/dl' -dlobj='dl_sunos.o' -dlsrc='dl_sunos.c' -lddlflags='' -shlibsuffix='.so' -usedl='define' -gidtype='gid_t' -groupstype='int' -h_fcntl='false' -h_sysfile='true' -i_dbm='define' -d_dirnamlen='undef' -i_dirent='define' -i_dlfcn='define' -i_fcntl='undef' -i_gdbm='undef' -i_grp='define' -i_memory='define' -i_ndbm='define' -i_neterrno='undef' -i_niin='define' -i_sysin='undef' -d_pwage='define' -d_pwchange='undef' -d_pwclass='undef' -d_pwcomment='define' -d_pwexpire='undef' -d_pwquota='undef' -i_pwd='define' -i_sdbm='define' -i_stdarg='undef' -i_stddef='define' -i_string='define' -strings='/usr/include/string.h' -i_sysdir='define' -i_sysfile='define' -d_voidtty='' -i_bsdioctl='' -i_sysioctl='define' -i_syssockio='' -i_sysndir='undef' -i_sysselct='undef' -i_sgtty='undef' -i_termio='undef' -i_termios='define' -i_systime='define' -i_systimek='undef' -i_time='undef' -timeincl='/usr/include/sys/time.h ' -i_unistd='define' -i_utime='define' -i_varargs='define' -i_varhdr='varargs.h' -i_vfork='undef' -intsize='4' -lib='/usr/local/lib' -libexp='/usr/local/lib' -libc='/usr/lib/libc.so.1.8.1' -libpth=' /lib /usr/lib /usr/ucblib /usr/local/lib' -plibpth='' -xlibpth='/usr/lib/386 /lib/386' -libs='-ldbm -ldl -lm -lposix' -lns='/bin/ln -s' -lseektype='off_t' -d_mymalloc='define' -mallocobj='malloc.o' -mallocsrc='malloc.c' -malloctype='char *' -usemymalloc='y' -installmansrc='/usr/local/man/man1' -manext='1' -mansrc='/usr/local/man/man1' -mansrcexp='/usr/local/man/man1' -huge='' -large='' -medium='' -models='none' -small='' -split='' -mydomain='' -myhostname='scalpel' -phostname='hostname' -c='' -n='-n' -groupcat='' -hostcat='ypcat hosts' -passcat='' -orderlib='false' -ranlib='/usr/bin/ranlib' -package='perl' -spackage='' -installprivlib='/usr/local/lib/perl' -privlib='/usr/local/lib/perl' -privlibexp='/usr/local/lib/perl' -prototype='undef' -ptrsize='4' -randbits='31' -installscript='/usr/local/bin' -scriptdir='/usr/local/bin' -scriptdirexp='/usr/local/bin' -sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH LOST USR1 USR2' -sharpbang='#!' -shsharp='true' -spitshell='cat' -startsh='#!/bin/sh' -stdchar='unsigned char' -sysman='/usr/man/man1' -uidtype='uid_t' -nm_opt='' -runnm='true' -usenm='true' -incpath='' -mips='' -mips_type='' -usrinc='/usr/include' -defvoidused='15' -voidflags='15' -yacc='yacc' -yaccflags='' -PATCHLEVEL=0 -CONFIG=true diff --git a/config_c++.h b/config_c++.h deleted file mode 100644 index 53666bd8e5..0000000000 --- a/config_c++.h +++ /dev/null @@ -1,895 +0,0 @@ -#ifndef config_h -#define config_h -/* config.h - * 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. - */ - /*SUPPRESS 460*/ - - -/* EUNICE - * This symbol, if defined, indicates that the program is being compiled - * under the EUNICE package under VMS. The program will need to handle - * things like files that don't go away the first time you unlink them, - * due to version numbering. It will also need to compensate for lack - * of a respectable link() command. - */ -/* VMS - * This symbol, if defined, indicates that the program is running under - * VMS. It is currently only set in conjunction with the EUNICE symbol. - */ -/*#undef EUNICE */ -/*#undef VMS */ - -/* LOC_SED - * This symbol holds the complete pathname to the sed program. - */ -#define LOC_SED "/bin/sed" /**/ - -/* ALIGNBYTES - * This symbol contains the number of bytes required to align a double. - * Usual values are 2, 4, and 8. - */ -#define ALIGNBYTES 8 /**/ - -/* BIN - * This symbol holds the name of the directory in which the user wants - * to keep publicly executable images for the package in question. It - * is most often a local directory such as /usr/local/bin. - */ -#define BIN "/usr/local/bin" /**/ - -/* BYTEORDER - * This symbol contains an encoding of the order of bytes in a long. - * Usual values (in hex) are 0x1234, 0x4321, 0x2143, 0x3412... - */ -#define BYTEORDER 0x4321 /**/ - -/* 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". - */ -/* 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 "/usr/lib/cpp" -#define CPPMINUS "" - -/* HAS_BCMP - * This symbol, if defined, indicates that the bcmp routine is available - * to compare blocks of memory. If undefined, use memcmp. If that's - * not available, roll your own. - */ -#define HAS_BCMP /**/ - -/* HAS_BCOPY - * This symbol, if defined, indicates that the bcopy routine is available - * to copy blocks of memory. Otherwise you should probably use memcpy(). - * If neither is defined, roll your own. - */ -/* SAFE_BCOPY - * This symbol, if defined, indicates that the bcopy routine is available - * to copy potentially overlapping copy blocks of bcopy. Otherwise you - * should probably use memmove() or memcpy(). If neither is defined, - * roll your own. - */ -#define HAS_BCOPY /**/ -#define SAFE_BCOPY /**/ - -/* HAS_BZERO - * This symbol, if defined, indicates that the bzero routine is available - * to zero blocks of memory. Otherwise you should probably use memset() - * or roll your own. - */ -#define HAS_BZERO /**/ - -/* CASTNEGFLOAT - * This symbol, if defined, indicates that this C compiler knows how to - * cast negative or large floating point 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: - * 1 = couldn't cast < 0 - * 2 = couldn't cast >= 0x80000000 - */ -#define CASTNEGFLOAT /**/ -#define CASTFLAGS 0 /**/ - -/* CHARSPRINTF - * This symbol is defined if this system declares "char *sprintf()" in - * stdio.h. The trend seems to be to declare it as "int sprintf()". It - * is up to the package author to declare sprintf correctly based on the - * symbol. - */ -#define CHARSPRINTF /**/ - -/* 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 */ - -/* HAS_CRYPT - * This symbol, if defined, indicates that the crypt routine is available - * to encrypt passwords and the like. - */ -#define HAS_CRYPT /**/ - -/* CSH - * This symbol, if defined, indicates that the C-shell exists. - * If defined, contains the full pathname of csh. - */ -#define CSH "/bin/csh" /**/ - -/* 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. - */ -/*#undef DOSUID */ - -/* HAS_DUP2 - * This symbol, if defined, indicates that the dup2 routine is available - * to dup file descriptors. Otherwise you should use dup(). - */ -#define HAS_DUP2 /**/ - -/* HAS_FCHMOD - * This symbol, if defined, indicates that the fchmod routine is available - * to change mode of opened files. If unavailable, use chmod(). - */ -#define HAS_FCHMOD /**/ - -/* HAS_FCHOWN - * This symbol, if defined, indicates that the fchown routine is available - * to change ownership of opened files. If unavailable, use chown(). - */ -#define HAS_FCHOWN /**/ - -/* HAS_FCNTL - * This symbol, if defined, indicates to the C program that - * the fcntl() function exists. - */ -#define HAS_FCNTL /**/ - -/* FLEXFILENAMES - * This symbol, if defined, indicates that the system supports filenames - * longer than 14 characters. - */ -#define FLEXFILENAMES /**/ - -/* HAS_FLOCK - * This symbol, if defined, indicates that the flock() routine is - * available to do file locking. - */ -#define HAS_FLOCK /**/ - -/* HAS_GETGROUPS - * This symbol, if defined, indicates that the getgroups() routine is - * available to get the list of process groups. If unavailable, multiple - * groups are probably not supported. - */ -#define HAS_GETGROUPS /**/ - -/* HAS_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 */ - -/* 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_GETPRIORITY - * This symbol, if defined, indicates that the getpriority() routine is - * available to get a process's priority. - */ -#define HAS_GETPRIORITY /**/ - -/* HAS_HTONS - * This symbol, if defined, indicates that the htons routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_HTONL - * This symbol, if defined, indicates that the htonl routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_NTOHS - * This symbol, if defined, indicates that the ntohs routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_NTOHL - * This symbol, if defined, indicates that the ntohl routine (and friends) - * are available to do network order byte swapping. - */ -#define HAS_HTONS /**/ -#define HAS_HTONL /**/ -#define HAS_NTOHS /**/ -#define HAS_NTOHL /**/ - -/* index - * This preprocessor symbol is defined, along with rindex, if the system - * uses the strchr and strrchr routines instead. - */ -/* rindex - * This preprocessor symbol is defined, along with index, if the system - * uses the strchr and strrchr routines instead. - */ -/*#undef index strchr cultural */ -/*#undef rindex strrchr differences? */ - -/* HAS_ISASCII - * This symbol, if defined, indicates that the isascii routine is available - * to test characters for asciiness. - */ -#define HAS_ISASCII /**/ - -/* HAS_KILLPG - * This symbol, if defined, indicates that the killpg routine is available - * to kill process groups. If unavailable, you probably should use kill - * with a negative process number. - */ -#define HAS_KILLPG /**/ - -/* HAS_LSTAT - * This symbol, if defined, indicates that the lstat() routine is - * available to stat symbolic links. - */ -#define HAS_LSTAT /**/ - -/* HAS_MEMCMP - * This symbol, if defined, indicates that the memcmp routine is available - * to compare blocks of memory. If undefined, roll your own. - */ -#define HAS_MEMCMP /**/ - -/* HAS_MEMCPY - * This symbol, if defined, indicates that the memcpy routine is available - * to copy blocks of memory. Otherwise you should probably use bcopy(). - * If neither is defined, roll your own. - */ -/* SAFE_MEMCPY - * This symbol, if defined, indicates that the memcpy routine is available - * to copy potentially overlapping copy blocks of memory. Otherwise you - * should probably use memmove() or bcopy(). If neither is defined, - * roll your own. - */ -#define HAS_MEMCPY /**/ -/*#undef SAFE_MEMCPY */ - -/* HAS_MEMMOVE - * This symbol, if defined, indicates that the memmove routine is available - * to move potentially overlapping blocks of memory. Otherwise you - * should use bcopy() or roll your own. - */ -/*#undef HAS_MEMMOVE */ - -/* HAS_MEMSET - * This symbol, if defined, indicates that the memset routine is available - * to set a block of memory to a character. If undefined, roll your own. - */ -#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_MSG - * This symbol, if defined, indicates that the entire msg*(2) library is - * supported. - */ -#define HAS_MSG /**/ - -/* HAS_MSGCTL - * This symbol, if defined, indicates that the msgctl() routine is - * available to control message passing. - */ -#define HAS_MSGCTL /**/ - -/* HAS_MSGGET - * This symbol, if defined, indicates that the msgget() routine is - * available to get messages. - */ -#define HAS_MSGGET /**/ - -/* HAS_MSGRCV - * This symbol, if defined, indicates that the msgrcv() routine is - * available to receive messages. - */ -#define HAS_MSGRCV /**/ - -/* HAS_MSGSND - * This symbol, if defined, indicates that the msgsnd() routine is - * available to send messages. - */ -#define HAS_MSGSND /**/ - -/* HAS_NDBM - * This symbol, if defined, indicates that ndbm.h exists and should - * be included. - */ -#define HAS_NDBM /**/ - -/* HAS_ODBM - * This symbol, if defined, indicates that dbm.h exists and should - * be included. - */ -#define HAS_ODBM /**/ - -/* HAS_OPEN3 - * This manifest constant lets the C program know that the three - * argument form of open(2) is available. - */ -#define HAS_OPEN3 /**/ - -/* HAS_READDIR - * This symbol, if defined, indicates that the readdir routine is available - * from the C library to read directories. - */ -#define HAS_READDIR /**/ - -/* 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_REWINDDIR - * This symbol, if defined, indicates that the rewindir routine is - * available to rewind directories. - */ -/*#undef HAS_REWINDDIR */ - -/* 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_SEEKDIR - * This symbol, if defined, indicates that the seekdir routine is - * available to seek into directories. - */ -#define HAS_SEEKDIR /**/ - -/* HAS_SELECT - * This symbol, if defined, indicates that the select() subroutine - * exists. - */ -#define HAS_SELECT /**/ - -/* HAS_SEM - * This symbol, if defined, indicates that the entire sem*(2) library is - * supported. - */ -#define HAS_SEM /**/ - -/* HAS_SEMCTL - * This symbol, if defined, indicates that the semctl() routine is - * available to control semaphores. - */ -#define HAS_SEMCTL /**/ - -/* HAS_SEMGET - * This symbol, if defined, indicates that the semget() routine is - * available to get semaphores ids. - */ -#define HAS_SEMGET /**/ - -/* HAS_SEMOP - * This symbol, if defined, indicates that the semop() routine is - * available to perform semaphore operations. - */ -#define HAS_SEMOP /**/ - -/* HAS_SETEGID - * This symbol, if defined, indicates that the setegid routine is available - * to change the effective gid of the current program. - */ -#define HAS_SETEGID /**/ - -/* HAS_SETEUID - * This symbol, if defined, indicates that the seteuid routine is available - * to change the effective uid of the current program. - */ -#define HAS_SETEUID /**/ - -/* HAS_SETPGRP - * This symbol, if defined, indicates that the setpgrp() routine is - * available to set the current process group. - */ -#define HAS_SETPGRP /**/ - -/* HAS_SETPGRP2 - * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) - * routine is available to set the current process group. - */ -/*#undef HAS_SETPGRP2 */ - -/* HAS_SETPRIORITY - * This symbol, if defined, indicates that the setpriority() routine is - * available to set a process's priority. - */ -#define HAS_SETPRIORITY /**/ - -/* HAS_SETREGID - * This symbol, if defined, indicates that the setregid routine is - * available to change the real and effective gid of the current program. - */ -/* HAS_SETRESGID - * This symbol, if defined, indicates that the setresgid routine is - * available to change the real, effective and saved gid of the current - * program. - */ -#define 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 program. - */ -/* HAS_SETRESUID - * This symbol, if defined, indicates that the setresuid routine is - * available to change the real, effective and saved uid of the current - * program. - */ -#define 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. - */ -#define HAS_SETRGID /**/ - -/* HAS_SETRUID - * This symbol, if defined, indicates that the setruid routine is available - * to change the real uid of the current program. - */ -#define HAS_SETRUID /**/ - -/* HAS_SHM - * This symbol, if defined, indicates that the entire shm*(2) library is - * supported. - */ -#define HAS_SHM /**/ - -/* HAS_SHMAT - * This symbol, if defined, indicates that the shmat() routine is - * available to attach a shared memory segment. - */ -/* VOID_SHMAT - * This symbol, if defined, indicates that the shmat() routine - * returns a pointer of type void*. - */ -#define HAS_SHMAT /**/ - -/*#undef VOIDSHMAT */ - -/* HAS_SHMCTL - * This symbol, if defined, indicates that the shmctl() routine is - * available to control a shared memory segment. - */ -#define HAS_SHMCTL /**/ - -/* HAS_SHMDT - * This symbol, if defined, indicates that the shmdt() routine is - * available to detach a shared memory segment. - */ -#define HAS_SHMDT /**/ - -/* HAS_SHMGET - * This symbol, if defined, indicates that the shmget() routine is - * available to get a shared memory segment id. - */ -#define HAS_SHMGET /**/ - -/* 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. - */ -/* OLDSOCKET - * This symbol, if defined, indicates that the 4.1c BSD socket interface - * is supported instead of the 4.2/4.3 BSD socket interface. - */ -#define HAS_SOCKET /**/ - -#define HAS_SOCKETPAIR /**/ - -/*#undef OLDSOCKET */ - -/* STATBLOCKS - * This symbol is defined if this system has a stat structure declaring - * st_blksize and st_blocks. - */ -#define STATBLOCKS /**/ - -/* STDSTDIO - * This symbol is defined if this system has a FILE structure declaring - * _ptr and _cnt in stdio.h. - */ -#define STDSTDIO /**/ - -/* STRUCTCOPY - * 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 STRUCTCOPY /**/ - -/* HAS_STRERROR - * This symbol, if defined, indicates that the strerror() routine is - * available to translate error numbers to strings. - */ -/*#undef HAS_STRERROR */ - -/* HAS_SYMLINK - * This symbol, if defined, indicates that the symlink routine is available - * to create symbolic links. - */ -#define HAS_SYMLINK /**/ - -/* HAS_SYSCALL - * This symbol, if defined, indicates that the syscall routine is available - * to call arbitrary system calls. If undefined, that's tough. - */ -#define HAS_SYSCALL /**/ - -/* HAS_TELLDIR - * This symbol, if defined, indicates that the telldir routine is - * available to tell your location in directories. - */ -#define HAS_TELLDIR /**/ - -/* HAS_TRUNCATE - * This symbol, if defined, indicates that the truncate routine is - * available to truncate files. - */ -#define HAS_TRUNCATE /**/ - -/* HAS_VFORK - * This symbol, if defined, indicates that vfork() exists. - */ -#define HAS_VFORK /**/ - -/* VOIDSIG - * This symbol is defined if this system declares "void (*signal())()" in - * signal.h. The old way was to declare it as "int (*signal())()". It - * is up to the package author to declare things correctly based on the - * symbol. - */ -/* TO_SIGNAL - * This symbol's value is either "void" or "int", corresponding to the - * appropriate return "type" of a signal handler. Thus, one can declare - * a signal handler using "TO_SIGNAL (*handler())()", and define the - * handler using "TO_SIGNAL handler(sig)". - */ -#define VOIDSIG /**/ -#define TO_SIGNAL int /**/ - -/* HASVOLATILE - * This symbol, if defined, indicates that this C compiler knows about - * the volatile declaration. - */ -/*#undef HASVOLATILE */ - -/* 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(). - */ -/* CHARVSPRINTF - * 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 CHARVSPRINTF /**/ - -/* HAS_WAIT4 - * This symbol, if defined, indicates that wait4() exists. - */ -#define HAS_WAIT4 /**/ - -/* HAS_WAITPID - * This symbol, if defined, indicates that waitpid() exists. - */ -#define HAS_WAITPID /**/ - -/* GIDTYPE - * This symbol has a value like gid_t, int, ushort, or whatever type is - * used to declare group ids in the kernel. - */ -#define GIDTYPE int /**/ - -/* GROUPSTYPE - * This symbol has a value like gid_t, int, ushort, or whatever type is - * used in the return value of getgroups(). - */ -#define GROUPSTYPE int /**/ - -/* I_FCNTL - * This manifest constant tells the C program to include <fcntl.h>. - */ -/*#undef I_FCNTL */ - -/* I_GDBM - * This symbol, if defined, indicates that gdbm.h exists and should - * be included. - */ -/*#undef I_GDBM */ - -/* I_GRP - * This symbol, if defined, indicates to the C program that it should - * include grp.h. - */ -#define I_GRP /**/ - -/* I_NETINET_IN - * This symbol, if defined, indicates to the C program that it should - * include netinet/in.h. - */ -/* I_SYS_IN - * This symbol, if defined, indicates to the C program that it should - * include sys/in.h. - */ -#define I_NETINET_IN /**/ -/*#undef I_SYS_IN */ - -/* I_PWD - * This symbol, if defined, indicates to the C program that it should - * include pwd.h. - */ -/* PWQUOTA - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_quota. - */ -/* PWAGE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_age. - */ -/* PWCHANGE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_change. - */ -/* PWCLASS - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_class. - */ -/* PWEXPIRE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_expire. - */ -/* PWCOMMENT - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_comment. - */ -#define I_PWD /**/ -/*#undef PWQUOTA */ -#define PWAGE /**/ -/*#undef PWCHANGE */ -/*#undef PWCLASS */ -/*#undef PWEXPIRE */ -#define PWCOMMENT /**/ - -/* I_SYS_FILE - * This manifest constant tells the C program to include <sys/file.h>. - */ -#define I_SYS_FILE /**/ - -/* I_SYSIOCTL - * This symbol, if defined, indicates that sys/ioctl.h exists and should - * be included. - */ -#define I_SYSIOCTL /**/ - -/* I_TIME - * This symbol is defined if the program should include <time.h>. - */ -/* I_SYS_TIME - * This symbol is defined if the program should include <sys/time.h>. - */ -/* SYSTIMEKERNEL - * This symbol is defined if the program should include <sys/time.h> - * with KERNEL defined. - */ -/* I_SYS_SELECT - * This symbol is defined if the program should include <sys/select.h>. - */ -/*#undef I_TIME */ -#define I_SYS_TIME /**/ -/*#undef SYSTIMEKERNEL */ -/*#undef I_SYS_SELECT */ - -/* I_UTIME - * This symbol, if defined, indicates to the C program that it should - * include utime.h. - */ -#define I_UTIME /**/ - -/* I_VARARGS - * This symbol, if defined, indicates to the C program that it should - * include varargs.h. - */ -#define I_VARARGS /**/ - -/* I_VFORK - * This symbol, if defined, indicates to the C program that it should - * include vfork.h. - */ -#define I_VFORK /**/ - -/* INTSIZE - * This symbol contains the size of an int, so that the C preprocessor - * can make decisions based on it. - */ -#define INTSIZE 4 /**/ - -/* I_DIRENT - * This symbol, if defined, indicates that the program should use the - * P1003-style directory routines, and include <dirent.h>. - */ -/* I_SYS_DIR - * This symbol, if defined, indicates that the program should use the - * directory functions by including <sys/dir.h>. - */ -/* I_NDIR - * This symbol, if defined, indicates that the program should include the - * system's version of ndir.h, rather than the one with this package. - */ -/* I_SYS_NDIR - * This symbol, if defined, indicates that the program should include the - * system's version of sys/ndir.h, rather than the one with this package. - */ -/* I_MY_DIR - * This symbol, if defined, indicates that the program should compile - * the ndir.c code provided with the package. - */ -/* 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. - */ -#define I_DIRENT /**/ -/*#undef I_SYS_DIR */ -/*#undef I_NDIR */ -/*#undef I_SYS_NDIR */ -/*#undef I_MY_DIR */ -/*#undef DIRNAMLEN */ - -/* MYMALLOC - * This symbol, if defined, indicates that we're using our own malloc. - */ -/* MALLOCPTRTYPE - * This symbol defines the kind of ptr returned by malloc and realloc. - */ -#define MYMALLOC /**/ - -#define MALLOCPTRTYPE char /**/ - - -/* RANDBITS - * This symbol contains the number of bits of random number the rand() - * function produces. Usual values are 15, 16, and 31. - */ -#define RANDBITS 31 /**/ - -/* SCRIPTDIR - * This symbol holds the name of the directory in which the user wants - * to keep publicly executable scripts for the package in question. It - * is often a directory that is mounted across diverse architectures. - */ -#define SCRIPTDIR "/usr/local/bin" /**/ - -/* SIG_NAME - * This symbol contains an list of signal names in order. - */ -#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","LOST","USR1","USR2" /**/ - -/* STDCHAR - * This symbol is defined to be the type of char used in stdio.h. - * It has the values "unsigned char" or "char". - */ -#define STDCHAR unsigned char /**/ - -/* UIDTYPE - * This symbol has a value like uid_t, int, ushort, or whatever type is - * used to declare user ids in the kernel. - */ -#define UIDTYPE int /**/ - -/* VOIDHAVE - * 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 - * - * The package designer should define VOIDWANT to indicate the requirements - * of the package. This can be done either by #defining VOIDWANT before - * including config.h, or by defining voidwant in Myinit.U. If the level - * of void support necessary is not present, config.h defines void to "int", - * VOID to the empty string, and VOIDP to "char *". - */ -/* void - * This symbol is used for void casts. On implementations which support - * void appropriately, its value is "void". Otherwise, its value maps - * to "int". - */ -/* VOID - * This symbol's value is "void" if the implementation supports void - * appropriately. Otherwise, its value is the empty string. The primary - * use of this symbol is in specifying void parameter lists for function - * prototypes. - */ -/* VOIDP - * This symbol is used for casting generic pointers. On implementations - * which support void appropriately, its value is "void *". Otherwise, - * its value is "char *". - */ -#ifndef VOIDWANT -#define VOIDWANT 7 -#endif -#define VOIDHAVE 7 -#if (VOIDHAVE & VOIDWANT) != VOIDWANT -#define void int /* is void to be avoided? */ -#define VOID -#define VOIDP (char *) -#define M_VOID /* Xenix strikes again */ -#else -#define VOID void -#define VOIDP (void *) -#endif - -/* PRIVLIB - * This symbol contains the name of the private library for this package. - * The library is private in the sense that it needn't be in anyone's - * execution path, but it should be accessible by the world. The program - * should be prepared to do ~ expansion. - */ -#define PRIVLIB "/usr/local/lib/perl" /**/ - -#define I_MATH - -#endif - diff --git a/config_h.SH b/config_h.SH index 65b8f9f4cd..19304be0fb 100755 --- a/config_h.SH +++ b/config_h.SH @@ -25,7 +25,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' * that running config.h.SH again will wipe out any changes you've made. * For a more permanent change edit config.sh and rerun config.h.SH. * - * \$Id: Config_h.U,v 3.0.1.2 1993/08/24 12:13:20 ram Exp $ + * Config_h.U */ /* Configuration time: $cf_time @@ -36,6 +36,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' #ifndef _config_h_ #define _config_h_ +/* MEM_ALIGNBYTES: + * This symbol contains the number of bytes required to align a + * double. Usual values are 2, 4 and 8. + */ +#define MEM_ALIGNBYTES $alignbytes /**/ + /* 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. @@ -63,6 +69,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' #define CPPSTDIN "$cppstdin" #define CPPMINUS "$cppminus" +/* HAS_ALARM: + * This symbol, if defined, indicates that the alarm routine is + * available. + */ +#$d_alarm HAS_ALARM /**/ + /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. @@ -81,6 +93,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_bzero HAS_BZERO /**/ +/* CASTI32: + * This symbol is defined if the C compiler can cast negative + * or large floating point numbers to 32-bit ints. + */ +#$d_casti32 CASTI32 /**/ + /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative * numbers to unsigned longs, ints and shorts. @@ -103,6 +121,18 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_charsprf CHARSPRINTF /**/ +/* HAS_CHOWN: + * This symbol, if defined, indicates that the chown routine is + * available. + */ +#$d_chown HAS_CHOWN /**/ + +/* HAS_CHROOT: + * This symbol, if defined, indicates that the chroot routine is + * available. + */ +#$d_chroot HAS_CHROOT /**/ + /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. @@ -132,20 +162,25 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_csh CSH "$csh" /**/ -/* 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. +/* HAS_CUSERID: + * This symbol, if defined, indicates that the cuserid routine is + * available to get character login names. */ -#$d_dosuid DOSUID /**/ +#$d_cuserid HAS_CUSERID /**/ + +/* HAS_DBL_DIG: + * This symbol, if defined, indicates that this system's <float.h> + * or <limits.h> defines the symbol DBL_DIG, which is the number + * of significant digits in a double precision number. If this + * symbol is not defined, a guess of 15 is usually pretty good. + */ +#$d_dbl_dig HAS_DBL_DIG /* */ + +/* HAS_DIFFTIME: + * This symbol, if defined, indicates that the difftime routine is + * available. + */ +#$d_difftime HAS_DIFFTIME /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is @@ -171,6 +206,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_fcntl HAS_FCNTL /**/ +/* HAS_FGETPOS: + * This symbol, if defined, indicates that the fgetpos routine is + * available to get the file position indicator, similar to ftell(). + */ +#$d_fgetpos HAS_FGETPOS /**/ + /* FLEXFILENAMES: * This symbol, if defined, indicates that the system supports filenames * longer than 14 characters. @@ -183,6 +224,18 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_flock HAS_FLOCK /**/ +/* HAS_FORK: + * This symbol, if defined, indicates that the fork routine is + * available. + */ +#$d_fork HAS_FORK /**/ + +/* HAS_FSETPOS: + * This symbol, if defined, indicates that the fsetpos routine is + * available to set the file position indicator, similar to fseek(). + */ +#$d_fsetpos HAS_FSETPOS /**/ + /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple @@ -203,6 +256,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_uname HAS_UNAME /**/ +/* HAS_GETLOGIN: + * This symbol, if defined, indicates that the getlogin routine is + * available to get the login name. + */ +#$d_getlogin HAS_GETLOGIN /**/ + /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. @@ -215,12 +274,49 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_getpgrp2 HAS_GETPGRP2 /**/ +/* HAS_GETPPID: + * This symbol, if defined, indicates that the getppid routine is + * available to get the parent process ID. + */ +#$d_getppid HAS_GETPPID /**/ + /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ #$d_getprior HAS_GETPRIORITY /**/ +/* HAS_GROUP: + * This symbol, if defined, indicates that the group routine is + * available. + */ +#$d_group HAS_GROUP /**/ + +/* HAS_HTONL: + * This symbol, if defined, indicates that the htonl() routine (and + * friends htons() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_HTONS: + * This symbol, if defined, indicates that the htons() routine (and + * friends htonl() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHL: + * This symbol, if defined, indicates that the ntohl() routine (and + * friends htonl() htons() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHS: + * This symbol, if defined, indicates that the ntohs() routine (and + * friends htonl() htons() ntohl()) are available to do network + * order byte swapping. + */ +#$d_htonl HAS_HTONL /**/ +#$d_htonl HAS_HTONS /**/ +#$d_htonl HAS_NTOHL /**/ +#$d_htonl HAS_NTOHS /**/ + /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill @@ -234,12 +330,36 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_link HAS_LINK /**/ +/* HAS_LOCKF: + * This symbol, if defined, indicates that the lockf routine is + * available to do file locking. + */ +#$d_lockf HAS_LOCKF /**/ + /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ #$d_lstat HAS_LSTAT /**/ +/* HAS_MBLEN: + * This symbol, if defined, indicates that the mblen routine is available + * to find the number of bytes in a multibye character. + */ +#$d_mblen HAS_MBLEN /**/ + +/* HAS_MBSTOWCS: + * This symbol, if defined, indicates that the mbstowcs routine is + * available to covert a multibyte string into a wide character string. + */ +#$d_mbstowcs HAS_MBSTOWCS /**/ + +/* HAS_MBTOWC: + * This symbol, if defined, indicates that the mbtowc routine is available + * to covert a multibyte to a wide character. + */ +#$d_mbtowc HAS_MBTOWC /**/ + /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available * to compare blocks of memory. @@ -273,41 +393,78 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_mkdir HAS_MKDIR /**/ +/* HAS_MKTIME: + * This symbol, if defined, indicates that the mktime routine is + * available. + */ +#$d_mktime HAS_MKTIME /**/ + /* HAS_MSG: * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ #$d_msg HAS_MSG /**/ -/* HAS_MSGCTL: - * This symbol, if defined, indicates that the msgctl() routine is - * available to perform message control operations. +/* HAS_NICE: + * This symbol, if defined, indicates that the nice routine is + * available. */ -#$d_msgctl HAS_MSGCTL /**/ +#$d_nice HAS_NICE /**/ -/* HAS_MSGGET: - * This symbol, if defined, indicates that the msgget() routine is - * available to get a new message queue. +/* HAS_OPEN3: + * This manifest constant lets the C program know that the three + * argument form of open(2) is available. */ -#$d_msgget HAS_MSGGET /**/ +#$d_open3 HAS_OPEN3 /**/ -/* HAS_MSGRCV: - * This symbol, if defined, indicates that the msgrcv() routine is - * available to extract a message from the message queue. +/* HAS_PASSWD: + * This symbol, if defined, indicates that the passwd routine is + * available. */ -#$d_msgrcv HAS_MSGRCV /**/ +#$d_passwd HAS_PASSWD /**/ -/* HAS_MSGSND: - * This symbol, if defined, indicates that the msgsnd() routine is - * available to send a message into the message queue. +/* HAS_PAUSE: + * This symbol, if defined, indicates that the pause routine is + * available to suspend a process until a signal is received. */ -#$d_msgsnd HAS_MSGSND /**/ +#$d_pause HAS_PAUSE /**/ -/* HAS_OPEN3: - * This manifest constant lets the C program know that the three - * argument form of open(2) is available. +/* HAS_PIPE: + * This symbol, if defined, indicates that the pipe routine is + * available to create an inter-process channel. */ -#$d_open3 HAS_OPEN3 /**/ +#$d_pipe HAS_PIPE /**/ + +/* HAS_READDIR: + * This symbol, if defined, indicates that the readdir routine is + * available to read directory entries. You may have to include + * <dirent.h>. See I_DIRENT. + */ +#$d_readdir HAS_READDIR /**/ + +/* HAS_SEEKDIR: + * This symbol, if defined, indicates that the seekdir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#$d_seekdir HAS_SEEKDIR /**/ + +/* HAS_TELLDIR: + * This symbol, if defined, indicates that the telldir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#$d_telldir HAS_TELLDIR /**/ + +/* HAS_REWINDDIR: + * This symbol, if defined, indicates that the rewinddir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#$d_rewinddir HAS_REWINDDIR /**/ + +/* HAS_READLINK: + * This symbol, if defined, indicates that the readlink routine is + * available to read the value of a symbolic link. + */ +#$d_readlink HAS_READLINK /**/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available @@ -336,24 +493,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_sem HAS_SEM /**/ -/* HAS_SEMCTL: - * This symbol, if defined, indicates that the semctl() routine is - * available to perform semaphore control operations. - */ -#$d_semctl HAS_SEMCTL /**/ - -/* HAS_SEMGET: - * This symbol, if defined, indicates that the semget() routine is - * available to get a set of semaphores. - */ -#$d_semget HAS_SEMGET /**/ - -/* HAS_SEMOP: - * This symbol, if defined, indicates that the semop() routine is - * available to execute semaphore operations. - */ -#$d_semop HAS_SEMOP /**/ - /* HAS_SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. @@ -366,18 +505,25 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_seteuid HAS_SETEUID /**/ +/* HAS_SETLINEBUF: + * This symbol, if defined, indicates that the setlinebuf routine is + * available to change stderr or stdout from block-buffered or unbuffered + * to a line-buffered mode. + */ +#$d_setlinebuf HAS_SETLINEBUF /**/ + +/* HAS_SETLOCALE: + * This symbol, if defined, indicates that the setlocale routine is + * available to handle locale-specific ctype implementations. + */ +#$d_setlocale HAS_SETLOCALE /**/ + /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid routine is * available to set process group ID. */ #$d_setpgid HAS_SETPGID /**/ -/* HAS_SETPGRP: - * This symbol, if defined, indicates that the setpgrp routine is - * available to set the current process group. - */ -#$d_setpgrp HAS_SETPGRP /**/ - /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. @@ -440,23 +586,19 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_shm HAS_SHM /**/ -/* HAS_SHMCTL: - * This symbol, if defined, indicates that the shmctl() routine is - * available to perform shared memory control operations. +/* Shmat_t: + * This symbol holds the return type of the shmat() system call. + * Usually set to 'void *' or 'char *'. */ -#$d_shmctl HAS_SHMCTL /**/ - -/* HAS_SHMDT: - * This symbol, if defined, indicates that the shmdt() routine is - * available to detach a shared memory segment from the process space. - */ -#$d_shmdt HAS_SHMDT /**/ - -/* HAS_SHMGET: - * This symbol, if defined, indicates that the shmget() routine is - * available to request a shared memory segment from the kernel. +/* 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. */ -#$d_shmget HAS_SHMGET /**/ +#define Shmat_t $shmattype /**/ +#$d_shmatprototype HAS_SHMAT_PROTOTYPE /**/ /* HAS_SOCKET: * This symbol, if defined, indicates that the BSD socket interface is @@ -466,14 +608,8 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* USE_OLDSOCKET: - * This symbol, if defined, indicates that the 4.1c BSD socket interface - * is supported instead of the 4.2/4.3 BSD socket interface. For instance, - * there is no setsockopt() call. - */ #$d_socket HAS_SOCKET /**/ #$d_sockpair HAS_SOCKETPAIR /**/ -#$d_oldsock USE_OLDSOCKET /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring @@ -487,6 +623,24 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_stdstdio USE_STD_STDIO /**/ +/* HAS_STRCHR: + * This symbol is defined to indicate that the strchr()/strrchr() + * functions are available for string searching. If not, try the + * index()/rindex() pair. + */ +/* HAS_INDEX: + * This symbol is defined to indicate that the index()/rindex() + * functions are available for string searching. + */ +#$d_strchr HAS_STRCHR /**/ +#$d_index HAS_INDEX /**/ + +/* HAS_STRCOLL: + * This symbol, if defined, indicates that the strcoll routine is + * available to compare strings using collating information. + */ +#$d_strcoll HAS_STRCOLL /**/ + /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how * to copy structures. If undefined, you'll need to use a block copy @@ -494,6 +648,31 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_strctcpy USE_STRUCT_COPY /**/ +/* HAS_STRERROR: + * This symbol, if defined, indicates that the strerror routine is + * available to translate error numbers to strings. See the writeup + * of Strerror() in this file before you try to define your own. + */ +/* HAS_SYS_ERRLIST: + * This symbol, if defined, indicates that the sys_errlist array is + * available to translate error numbers to strings. The extern int + * sys_nerr gives the size of that table. + */ +/* Strerror: + * This preprocessor symbol is defined as a macro if strerror() is + * not available to translate error numbers to strings but sys_errlist[] + * array is there. + */ +#$d_strerror HAS_STRERROR /**/ +#$d_syserrlst HAS_SYS_ERRLIST /**/ +#define Strerror(e) $d_strerrm + +/* HAS_STRXFRM: + * This symbol, if defined, indicates that the strxfrm() routine is + * available to transform strings. + */ +#$d_strxfrm HAS_STRXFRM /**/ + /* HAS_SYMLINK: * This symbol, if defined, indicates that the symlink routine is available * to create symbolic links. @@ -512,12 +691,17 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_system HAS_SYSTEM /**/ -/* 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). +/* HAS_TCGETPGRP: + * This symbol, if defined, indicates that the tcgetpgrp routine is + * available to get foreground process group ID. */ -#define Time_t $timetype /* Time type */ +#$d_tcgetpgrp HAS_TCGETPGRP /**/ + +/* HAS_TCSETPGRP: + * This symbol, if defined, indicates that the tcsetpgrp routine is + * available to set foreground process group ID. + */ +#$d_tcsetpgrp HAS_TCSETPGRP /**/ /* HAS_TIMES: * This symbol, if defined, indicates that the times() routine exists. @@ -532,11 +716,22 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_truncate HAS_TRUNCATE /**/ -/* I_NDIR: - * This symbol, if defined, indicates that the program should include the - * system's version of ndir.h, rather than the one with this package. +/* HAS_TZNAME: + * This symbol, if defined, indicates that the tzname[] array is + * available to access timezone names. */ -#$i_ndir I_NDIR /**/ +#$d_tzname HAS_TZNAME /**/ + +/* HAS_UMASK: + * This symbol, if defined, indicates that the umask routine is + * available to set and get the value of the file creation mask. + */ +#$d_umask HAS_UMASK /**/ + +/* HAS_VFORK: + * This symbol, if defined, indicates that vfork() exists. + */ +#$d_vfork HAS_VFORK /**/ /* VOIDSIG: * This symbol is defined if this system declares "void (*signal(...))()" in @@ -580,11 +775,33 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_waitpid HAS_WAITPID /**/ -/* I_DBM: - * This symbol, if defined, indicates to the C program that it should - * include <dbm.h>. +/* HAS_WCSTOMBS: + * This symbol, if defined, indicates that the wcstombs routine is + * available to convert wide character strings to multibyte strings. */ -#$i_dbm I_DBM /**/ +#$d_wcstombs HAS_WCSTOMBS /**/ + +/* HAS_WCTOMB: + * This symbol, if defined, indicates that the wctomb routine is available + * to covert a wide character to a multibyte. + */ +#$d_wctomb HAS_WCTOMB /**/ + +/* Fpos_t: + * This symbol holds the type used to declare file positions in libc. + * It can be fpos_t, long, uint, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Fpos_t $fpostype /* File position type */ + +/* Gid_t: + * This symbol holds the return type of getgid() and the type of + * argument to setrgid() and related functions. Typically, + * it is the type of group ids in the kernel. It can be int, ushort, + * uid_t, etc... It may be necessary to include <sys/types.h> to get + * any typedef'ed information. + */ +#define Gid_t $gidtype /* Type for getgid(), etc... */ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should @@ -597,24 +814,32 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ +/* Direntry_t: + * This symbol is set to 'struct direct' or 'struct dirent' depending on + * whether dirent is available or not. You should use this pseudo type to + * portably declare your directory entries. + */ #$i_dirent I_DIRENT /**/ #$d_dirnamlen DIRNAMLEN /**/ -#ifdef I_DIRENT -#define Direntry_t struct dirent -#else -#define Direntry_t struct direct -#endif +#define Direntry_t $direntrytype + +/* I_DLFCN: + * This symbol, if defined, indicates that <dlfcn.h> exists and should + * be included. + */ +#$i_dlfcn I_DLFCN /**/ /* I_FCNTL: * This manifest constant tells the C program to include <fcntl.h>. */ #$i_fcntl I_FCNTL /**/ -/* I_GDBM: - * This symbol, if defined, indicates that gdbm.h exists and should - * be included. +/* I_FLOAT: + * This symbol, if defined, indicates to the C program that it should + * include <float.h> to get definition of symbols like DBL_MAX or + * DBL_MIN, i.e. machine dependent floating point values. */ -#$i_gdbm I_GDBM /**/ +#$i_float I_FLOAT /**/ /* I_GRP: * This symbol, if defined, indicates to the C program that it should @@ -622,6 +847,25 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$i_grp 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. + */ +#$i_limits I_LIMITS /**/ + +/* I_MATH: + * This symbol, if defined, indicates to the C program that it should + * include <math.h>. + */ +#$i_math I_MATH /**/ + +/* I_MEMORY: + * This symbol, if defined, indicates to the C program that it should + * include <memory.h>. + */ +#$i_memory I_MEMORY /**/ + /* I_NDBM: * This symbol, if defined, indicates that ndbm.h exists and should * be included. @@ -632,18 +876,43 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' * This symbol, if defined, indicates to the C program that it should * include <netinet/in.h>. Otherwise, you may try <sys/in.h>. */ -/* I_SYS_IN: - * This symbol, if defined, indicates to the C program that it should - * include <sys/in.h> instead of <netinet/in.h>. - */ #$i_niin I_NETINET_IN /**/ -#$i_sysin I_SYS_IN /**/ -/* I_STDARG: - * This symbol, if defined, indicates that <stdarg.h> exists and should - * be included. +/* I_PWD: + * This symbol, if defined, indicates to the C program that it should + * include <pwd.h>. */ -#$i_stdarg I_STDARG /**/ +/* 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. + */ +#$i_pwd I_PWD /**/ +#$d_pwquota PWQUOTA /**/ +#$d_pwage PWAGE /**/ +#$d_pwchange PWCHANGE /**/ +#$d_pwclass PWCLASS /**/ +#$d_pwexpire PWEXPIRE /**/ +#$d_pwcomment PWCOMMENT /**/ /* I_STDDEF: * This symbol, if defined, indicates that <stddef.h> exists and should @@ -651,6 +920,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$i_stddef I_STDDEF /**/ +/* I_STDLIB: + * This symbol, if defined, indicates that <stdlib.h> exists and should + * be included. + */ +#$i_stdlib I_STDLIB /**/ + /* I_STRING: * This symbol, if defined, indicates to the C program that it should * include <string.h> (USG systems) instead of <strings.h> (BSD systems). @@ -681,12 +956,44 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$i_sysndir I_SYS_NDIR /**/ +/* I_SYS_PARAM: + * This symbol, if defined, indicates to the C program that it should + * include <sys/param.h>. + */ +#$i_sysparam I_SYS_PARAM /**/ + /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include <sys/select.h> in order to get definition of struct timeval. */ #$i_sysselct I_SYS_SELECT /**/ +/* I_SYS_TIMES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/times.h>. + */ +#$i_systimes I_SYS_TIMES /**/ + +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * <termio.h> rather than <sgtty.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * <sgtty.h> rather than <termio.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +#$i_termio I_TERMIO /**/ +#$i_termios I_TERMIOS /**/ +#$i_sgtty I_SGTTY /**/ + /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include <time.h>. @@ -715,11 +1022,22 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$i_utime I_UTIME /**/ +/* I_STDARG: + * This symbol, if defined, indicates that <stdarg.h> exists and should + * be included. + */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include <varargs.h>. */ -#$i_varargs I_VARARGS /**/ +#$i_stdarg I_STDARG /**/ +#$i_varargs I_VARARGS /**/ + +/* I_VFORK: + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +#$i_vfork I_VFORK /**/ /* INTSIZE: * This symbol contains the size of an int, so that the C preprocessor @@ -742,11 +1060,23 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define PRIVLIB "$privlib" /**/ -/* PTRSIZE: - * This symbol contains the size of a pointer, so that the C preprocessor - * can make decisions based on it. +/* CAN_PROTOTYPE: + * If defined, this macro indicates that the C compiler can handle + * function prototypes. */ -#define PTRSIZE $ptrsize /**/ +/* _: + * This macro is used to declare function parameters for folks who want + * to make declarations with prototypes using a different style than + * the above macros. Use double parentheses. For example: + * + * int main _((int argc, char *argv[])); + */ +#$prototype CAN_PROTOTYPE /**/ +#ifdef CAN_PROTOTYPE +#define _(args) args +#else +#define _(args) () +#endif /* RANDBITS: * This symbol contains the number of bits of random number the rand() @@ -762,6 +1092,32 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define SCRIPTDIR "$scriptdir" /**/ +/* Select_fd_set_t: + * This symbol holds the type used for the 2nd, 3rd, and 4th + * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET + * is defined, and 'int *' otherwise. This is only useful if you + * have select(), of course. + */ +#define Select_fd_set_t $selecttype /**/ + +/* SIG_NAME: + * This symbol contains a list of signal names in order. This is intended + * to be used as a static array initialization, like this: + * 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". + */ +#define SIG_NAME "`echo $sig_name | sed 's/ /","/g'`" /**/ + +/* Size_t: + * This symbol holds the type used to declare length parameters + * for string functions. It is usually size_t, but may be + * unsigned long, int, etc. It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Size_t $sizetype /* length paramater for string functions */ + /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". @@ -775,6 +1131,31 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define Uid_t $uidtype /* UID type */ +/* VOIDFLAGS: + * This symbol indicates how much support of the void type is given by this + * compiler. What various bits mean: + * + * 1 = supports declaration of void + * 2 = supports arrays of pointers to functions returning void + * 4 = supports comparisons between pointers to void functions and + * addresses of void functions + * 8 = suports declaration of generic void pointers + * + * The package designer should define VOIDUSED to indicate the requirements + * of the package. This can be done either by #defining VOIDUSED before + * including config.h, or by defining defvoidused in Myinit.U. If the + * latter approach is taken, only those flags will be tested. If the + * level of void support necessary is not present, defines void to int. + */ +#ifndef VOIDUSED +#define VOIDUSED $defvoidused +#endif +#define VOIDFLAGS $voidflags +#if (VOIDFLAGS & VOIDUSED) != VOIDUSED +#define void int /* is void to be avoided? */ +#define M_VOID /* Xenix strikes again */ +#endif + /* EUNICE: * This symbol, if defined, indicates that the program is being compiled * under the EUNICE package under VMS. The program will need to handle @@ -789,73 +1170,158 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' #$d_eunice EUNICE /**/ #$d_eunice VMS /**/ -/* MEM_ALIGNBYTES: - * This symbol contains the number of bytes required to align a - * double. Usual values are 2, 4 and 8. +/* LOC_SED: + * This symbol holds the complete pathname to the sed program. */ -#define MEM_ALIGNBYTES $memalignbytes /**/ +#define LOC_SED "$sed" /**/ -/* CASTI32: - * This symbol is defined if the C compiler can cast negative - * or large floating point numbers to 32-bit ints. +/* ARCHLIB: + * This variable, if defined, holds the name of the directory in + * which the user wants to put architecture-dependent public + * library files for $package. It is most often a local directory + * such as /usr/local/lib. Programs using this variable must be + * prepared to deal with filename expansion. If ARCHLIB is the + * same as PRIVLIB, it is not defined, since presumably the + * program already searches PRIVLIB. + */ +#$d_archlib ARCHLIB "$archlib" /**/ + +/* CAT2: + * This macro catenates 2 tokens together. + */ +/* STRINGIFY: + * This macro surrounds its token with double quotes. + */ +#if $cpp_stuff == 1 +#define CAT2(a,b)a/**/b +#define CAT3(a,b,c)a/**/b/**/c +#define CAT4(a,b,c,d)a/**/b/**/c/**/d +#define CAT5(a,b,c,d,e)a/**/b/**/c/**/d/**/e +#define STRINGIFY(a)"a" + /* If you can get stringification with catify, tell me how! */ +#endif +#if $cpp_stuff == 42 +#define CAT2(a,b)a ## b +#define CAT3(a,b,c)a ## b ## c +#define CAT4(a,b,c,d)a ## b ## c ## d +#define CAT5(a,b,c,d,e)a ## b ## c ## d ## e +#define StGiFy(a)# a +#define STRINGIFY(a)StGiFy(a) +#define SCAT2(a,b)StGiFy(a) StGiFy(b) +#define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c) +#define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) +#define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e) +#endif +#ifndef CAT2 +#include "Bletch: How does this C preprocessor catenate tokens?" +#endif + +/* GNUC_ATTRIBUTE_CHECK: + * This symbol indicates the C compiler can check for function attributes, + * such as printf formats. */ -#$d_casti32 CASTI32 /**/ +#$d_attrib GNUC_ATTRIBUTE_CHECK /* */ -/* HAS_HTONL: - * This symbol, if defined, indicates that the htonl() routine (and - * friends htons() ntohl() ntohs()) are available to do network - * order byte swapping. +/* VOID_CLOSEDIR: + * This symbol, if defined, indicates that the closedir() routine + * does not return a value. */ -/* HAS_HTONS: - * This symbol, if defined, indicates that the htons() routine (and - * friends htonl() ntohl() ntohs()) are available to do network - * order byte swapping. +#$d_void_closedir VOID_CLOSEDIR /**/ + +/* HAS_DLERROR: + * This symbol, if defined, indicates that the dlerror routine is + * available. */ -/* HAS_NTOHL: - * This symbol, if defined, indicates that the ntohl() routine (and - * friends htonl() htons() ntohs()) are available to do network - * order byte swapping. +#$d_dlerror HAS_DLERROR /**/ + +/* 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. */ -/* HAS_NTOHS: - * This symbol, if defined, indicates that the ntohs() routine (and - * friends htonl() htons() ntohl()) are available to do network - * order byte swapping. +#$d_dlsymun 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. */ -#$d_htonl HAS_HTONL /**/ -#$d_htonl HAS_HTONS /**/ -#$d_htonl HAS_NTOHL /**/ -#$d_htonl HAS_NTOHS /**/ +/* DOSUID: + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +#$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW /**/ + +#$d_dosuid DOSUID /**/ + +/* HAS_DREM: + * This symbol, if defined, indicates that the drem routine is + * available. This is a Pyramid routine that is the same as + * fmod. + */ +#$d_drem HAS_DREM /**/ + +/* HAS_FMOD: + * This symbol, if defined, indicates that the fmod routine is + * available. + */ +#$d_fmod HAS_FMOD /**/ + +/* 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. + */ +#define Gconvert(x,n,t,b) $d_Gconvert /* HAS_ISASCII: - * This manifest constant lets the C program know that the - * isascii is available. + * This manifest constant lets the C program know that isascii + * is available. */ #$d_isascii HAS_ISASCII /**/ -/* 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. +/* USE_LINUX_STDIO: + * This symbol is defined if this system has a FILE structure declaring + * _IO_read_base, _IO_read_ptr, and _IO_read_end in stdio.h. */ -#$d_readdir HAS_READDIR /**/ +#$d_linuxstd USE_LINUX_STDIO /**/ -/* HAS_SEEKDIR: - * This symbol, if defined, indicates that the seekdir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. +/* HAS_LOCALECONV: + * This symbol, if defined, indicates that the localeconv routine is + * available for numeric and monetary formatting conventions. */ -#$d_seekdir HAS_SEEKDIR /**/ +#$d_locconv HAS_LOCALECONV /**/ -/* HAS_TELLDIR: - * This symbol, if defined, indicates that the telldir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. +/* HAS_MKFIFO: + * This symbol, if defined, indicates that the mkfifo routine is + * available. */ -#$d_telldir HAS_TELLDIR /**/ +#$d_mkfifo HAS_MKFIFO /**/ -/* HAS_REWINDDIR: - * This symbol, if defined, indicates that the rewinddir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. +/* HAS_PATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given filename. */ -#$d_rewinddir HAS_REWINDDIR /**/ +/* HAS_FPATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given open file descriptor. + */ +#$d_pathconf HAS_PATHCONF /**/ +#$d_fpathconf HAS_FPATHCONF /**/ /* HAS_SAFE_BCOPY: * This symbol, if defined, indicates that the bcopy routine is available @@ -873,51 +1339,30 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_safemcpy HAS_SAFE_MEMCPY /**/ -/* HAS_SETLOCALE: - * This symbol, if defined, indicates that the setlocale routine is - * available to handle locale-specific ctype implementations. - */ -#$d_setlocale HAS_SETLOCALE /**/ - -/* HAS_SHMAT: - * This symbol, if defined, indicates that the shmat() routine is - * available to attach a shared memory segment to the process space. +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. */ -#$d_shmat HAS_SHMAT /**/ - -/* VOIDSHMAT: - * This symbol, if defined, indicates that the shmat() routine - * returns a pointer of type void*. Otherwise, char* is assumed. +/* USE_BSDPGRP: + * This symbol, if defined, indicates that the BSD notion of process + * group is to be used. For instance, you have to say setpgrp(pid, pgrp) + * instead of the USG setpgrp(). */ -#$d_voidshmat VOIDSHMAT /**/ +#$d_setpgrp HAS_SETPGRP /**/ +#$d_bsdpgrp USE_BSDPGRP /**/ -/* 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. +/* HAS_SYSCONF: + * This symbol, if defined, indicates that sysconf() is available + * to determine system related limits and options. */ -#$d_strerror HAS_STRERROR /**/ -#$d_syserrlst HAS_SYS_ERRLIST /**/ -#ifdef HAS_STRERROR -# define Strerror strerror -#else -#$d_strerrm Strerror(e) ((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e]) /**/ -#endif +#$d_sysconf HAS_SYSCONF /**/ -/* HAS_VFORK: - * This symbol, if defined, indicates that vfork() exists. +/* 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). */ -#$d_vfork HAS_VFORK /**/ +#define Time_t $timetype /* Time type */ /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of @@ -925,16 +1370,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$usedl USE_DYNAMIC_LOADING /**/ -/* Gid_t: - * This symbol holds the return type of getgid() and the type of - * argument to setrgid() and related functions. Typically, - * it is the type of group ids in the kernel. - * It can be int, ushort, uid_t, etc... It may be necessary to include - * <sys/types.h> to get any typedef'ed information. - */ -#define Gid_t $gidtype /* Type for getgid(), etc... */ - -/* GROUPSTYPE: +/* 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... @@ -943,94 +1379,15 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' * getgroups(). */ #ifdef HAS_GETGROUPS -#define GROUPSTYPE $groupstype /* Type for 2nd arg to getgroups() */ +#define Groups_t $groupstype /* Type for 2nd arg to getgroups() */ #endif -/* I_DLFCN: - * This symbol, if defined, indicates that <dlfcn.h> exists and should - * be included. - */ -#$i_dlfcn I_DLFCN /**/ - -/* I_MEMORY: - * This symbol, if defined, indicates to the C program that it should - * include <memory.h>. - */ -#$i_memory I_MEMORY /**/ - /* I_NET_ERRNO: * This symbol, if defined, indicates that <net/errno.h> exists and * should be included. */ #$i_neterrno I_NET_ERRNO /**/ -/* 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. - */ -#$i_pwd I_PWD /**/ -#$d_pwquota PWQUOTA /**/ -#$d_pwage PWAGE /**/ -#$d_pwchange PWCHANGE /**/ -#$d_pwclass PWCLASS /**/ -#$d_pwexpire PWEXPIRE /**/ -#$d_pwcomment PWCOMMENT /**/ - -/* I_TERMIO: - * This symbol, if defined, indicates that the program should include - * <termio.h> rather than <sgtty.h>. There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/* I_TERMIOS: - * This symbol, if defined, indicates that the program should include - * the POSIX termios.h rather than sgtty.h or termio.h. - * There are also differences in the ioctl() calls that depend on the - * value of this symbol. - */ -/* I_SGTTY: - * This symbol, if defined, indicates that the program should include - * <sgtty.h> rather than <termio.h>. There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -#$i_termio I_TERMIO /**/ -#$i_termios I_TERMIOS /**/ -#$i_sgtty I_SGTTY /**/ - -/* I_VFORK: - * This symbol, if defined, indicates to the C program that it should - * include vfork.h. - */ -#$i_vfork I_VFORK /**/ - -/* LOC_SED: - * This symbol holds the complete pathname to the sed program. - */ -#define LOC_SED "$sed" /**/ - /* Malloc_t: * This symbol is the type of pointer returned by malloc and realloc. */ @@ -1041,123 +1398,23 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$d_mymalloc MYMALLOC /**/ -/* CAN_PROTOTYPE: - * If defined, this macro indicates that the C compiler can handle - * function prototypes. +/* 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. */ -#$prototype CAN_PROTOTYPE /**/ -#ifdef CAN_PROTOTYPE -#else -#endif +#define Mode_t $modetype /* file mode parameter for system calls*/ -/* SIG_NAME: - * This symbol contains a list of signal names in order. This is intended - * to be used as a static array initialization, like this: - * 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". +/* 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 SIG_NAME "`echo $sig_name | sed 's/ /","/g'`" /**/ - -/* VOIDFLAGS: - * This symbol indicates how much support of the void type is given by this - * compiler. What various bits mean: - * - * 1 = supports declaration of void - * 2 = supports arrays of pointers to functions returning void - * 4 = supports comparisons between pointers to void functions and - * addresses of void functions - * 8 = suports declaration of generic void pointers - * - * The package designer should define VOIDUSED to indicate the requirements - * of the package. This can be done either by #defining VOIDUSED before - * including config.h, or by defining defvoidused in Myinit.U. If the - * latter approach is taken, only those flags will be tested. If the - * level of void support necessary is not present, defines void to int. - */ -#ifndef VOIDUSED -# define VOIDUSED $defvoidused -#endif -#define VOIDFLAGS $voidflags -#if (VOIDFLAGS & VOIDUSED) != VOIDUSED -# define void int /* is void to be avoided? */ -# define M_VOID /* Xenix strikes again */ -# define VOID -#else -# define VOID void -#endif - -/* - * The following symbols are obsolete. They are mapped to the the new - * symbols only to ease the transition process. The sources should be - * updated so as to use the new symbols only, as the support for these - * obsolete symbols may end without notice. - */ - -#ifdef MEM_ALIGNBYTES -#define ALIGNBYTES MEM_ALIGNBYTES -#endif - -#ifdef USE_CHAR_VSPRINTF -#define CHARVSPRINTF USE_CHAR_VSPRINTF -#endif - -#ifdef Gid_t -#define GIDTYPE Gid_t -#endif - -#ifdef I_GDBM -#define HAS_GDBM I_GDBM -#endif - -#ifdef I_NDBM -#define HAS_NDBM I_NDBM -#endif - -#ifdef I_DBM -#define HAS_ODBM I_DBM -#endif - -#ifdef I_SYS_IOCTL -#define I_SYSIOCTL I_SYS_IOCTL -#endif - -#ifdef Malloc_t -#define MALLOCPTRTYPE Malloc_t -#endif - -#ifdef USE_OLDSOCKET -#define OLDSOCKET USE_OLDSOCKET -#endif - -#ifdef HAS_SAFE_BCOPY -#define SAFE_BCOPY HAS_SAFE_BCOPY -#endif - -#ifdef HAS_SAFE_MEMCPY -#define SAFE_MEMCPY HAS_SAFE_MEMCPY -#endif - -#ifdef USE_STAT_BLOCKS -#define STATBLOCKS USE_STAT_BLOCKS -#endif - -#ifdef USE_STD_STDIO -#define STDSTDIO USE_STD_STDIO -#endif - -#ifdef USE_STRUCT_COPY -#define STRUCTCOPY USE_STRUCT_COPY -#endif - -#ifdef HAS_SYSTEM -#define SYSTEM HAS_SYSTEM -#endif - -#ifdef Uid_t -#define UIDTYPE Uid_t -#endif +#define SSize_t $ssizetype /* signed count of bytes */ #endif !GROK!THIS! @@ -1,11 +1,18 @@ -#!./miniperl +#!./miniperl -w @ARGV = "./config.sh"; +$config_pm = 'lib/Config.pm'; -open STDOUT, ">lib/Config.pm" - or die "Can't open lib/Config.pm: $!\n"; +# list names to put first (and hence lookup fastest) +@fast = qw(osname osvers so libpth archlib + sharpbang startsh shsharp + dynamic_ext static_ext extensions dl_src + sig_name ccflags cppflags intsize); + + +open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n"; $myver = sprintf("%.3f", $]); -print <<"ENDOFBEG"; +print CONFIG <<"ENDOFBEG"; package Config; require Exporter; \@ISA = (Exporter); @@ -14,15 +21,101 @@ require Exporter; \$] == $myver or die sprintf "Perl lib version ($myver) doesn't match executable version (%.3f)\\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. + ENDOFBEG +@fast{@fast} = @fast; +@non_v=(); +@v_fast=(); +@v_others=(); + while (<>) { - s:^#!/bin/sh::; - s/'undef'/undef/; # So we can say "if $Config{'foo'}". - s/=true$/='true'/; # Catch CONFIG=true line from Configure. - s/^(\w+)=/\$Config{'$1'} = /; - s/$/;/ unless (/^#/ || /^$/); - print $_; + next if m:^#!/bin/sh:; + # Catch CONFIG=true and PATCHLEVEL=n line from Configure. + s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/; + unless (m/^(\w+)='(.*)'\s*$/){ + push(@non_v, "#$_"); # not a name='value' line + next; + } + if (!$fast{$1}){ push(@v_others, $_); next; } + push(@v_fast,$_); +} + +foreach(@non_v){ print CONFIG $_ } + +print CONFIG "\n", + "\$config_sh=<<'!END!OF!CONFIG!';\n", + join("", @v_fast, sort @v_others), + "!END!OF!CONFIG!\n\n"; + + +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]}); + + my($value); # search for the item in the big $config_sh string + return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m); + + $value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}". + $_[0]->{$_[1]} = $value; # cache it + return $value; +} + +sub FIRSTKEY { + $prevpos = 0; + my $key; + ($key) = $config_sh =~ m/^(.*)=/; + $key; +} + +sub NEXTKEY { + my ($pos, $len); + $pos = $prevpos; + $pos = index( $config_sh, "\n", $pos) + 1; + $prevpos = $pos; + $len = index( $config_sh, "=", $pos) - $pos; + $len > 0 ? substr( $config_sh, $pos, $len) : undef; } -print "1;\n"; + +sub EXISTS{ + exists($_[0]->{$_[1]}) or $config_sh =~ m/^$_[1]=/m; +} + +sub readonly { die "\%Config::Config is read-only\n" } + +sub STORE { &readonly } +sub DELETE{ &readonly } +sub CLEAR { &readonly } + + +1; +ENDOFEND + +close(CONFIG); + +# Now do some simple tests on the Config.pm file we have created +unshift(@INC,'lib'); +require $config_pm; +import Config; + +die "$0: $config_pm not valid" + unless $Config{'CONFIG'} eq 'true'; + +die "$0: error processing $config_pm" + if defined($Config{'an impossible name'}) + or $Config{'CONFIG'} ne 'true' # test cache + ; + +die "$0: error processing $config_pm" + if eval '$Config{"cc"} = 1' + or eval 'delete $Config{"cc"}' + ; + + exit 0; @@ -1,61 +1,20 @@ -/* $RCSfile: cmd.h,v $$Revision: 4.1 $$Date: 92/08/07 17:19:19 $ +/* cop.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: cmd.h,v $ - * Revision 4.1 92/08/07 17:19:19 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.2 92/06/08 12:01:02 lwall - * patch20: removed implicit int declarations on funcions - * - * Revision 4.0.1.1 91/06/07 10:28:50 lwall - * patch4: new copyright notice - * patch4: length($`), length($&), length($') now optimized to avoid string copy - * - * Revision 4.0 91/03/20 01:04:34 lwall - * 4.0 baseline. - * */ -struct acop { - GV *acop_gv; /* a symbol table entry */ - OP *acop_expr; /* any associated expression */ -}; - -struct ccop { - OP *ccop_true; /* normal code to do on if and while */ - OP *ccop_alt; /* else cmd ptr or continue code */ -}; - -struct scop { - OP **scop_next; /* array of pointers to commands */ - short scop_offset; /* first value - 1 */ - short scop_max; /* last value + 1 */ -}; - struct cop { BASEOP - OP *cop_expr; /* conditional expression */ - OP *cop_head; /* head of this command list */ - SV *cop_short; /* string to match as shortcut */ - GV *cop_gv; /* a symbol table entry, mostly for fp */ - char *cop_label; /* label for this construct */ - union uop { - struct acop acop; /* normal command */ - struct ccop ccop; /* compound command */ - struct scop scop; /* switch command */ - } uop; - U32 cop_seq; /* parse sequence number */ - short cop_slen; /* len of cop_short, if not null */ - VOL short cop_flags; /* optimization flags--see above */ + char * cop_label; /* label for this construct */ HV * cop_stash; /* package line was compiled in */ GV * cop_filegv; /* file the following line # is from */ + U32 cop_seq; /* parse sequence number */ + I32 cop_arybase; /* array base this line was compiled with */ line_t cop_line; /* line # of this command */ - char cop_type; /* what this command does */ }; #define Nullcop Null(COP*) @@ -92,8 +51,7 @@ struct block_sub { } \ if (cx->blk_sub.cv) { \ if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \ - if (CvDELETED(cx->blk_sub.cv)) \ - SvREFCNT_dec((SV*)cx->blk_sub.cv); \ + SvREFCNT_dec((SV*)cx->blk_sub.cv); \ } \ } @@ -184,20 +142,20 @@ struct block { cx->blk_oldretsp = retstack_ix, \ cx->blk_oldpm = curpm, \ cx->blk_gimme = gimme; \ - DEBUG_l( fprintf(stderr,"Entering block %d, type %s\n", \ - cxstack_ix, block_type[t]); ) + DEBUG_l( fprintf(stderr,"Entering block %ld, type %s\n", \ + (long)cxstack_ix, block_type[t]); ) /* Exit a block (RETURN and LAST). */ -#define POPBLOCK(cx) cx = &cxstack[cxstack_ix--], \ +#define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \ newsp = stack_base + cx->blk_oldsp, \ curcop = cx->blk_oldcop, \ markstack_ptr = markstack + cx->blk_oldmarksp, \ scopestack_ix = cx->blk_oldscopesp, \ retstack_ix = cx->blk_oldretsp, \ - curpm = cx->blk_oldpm, \ + pm = cx->blk_oldpm, \ gimme = cx->blk_gimme; \ - DEBUG_l( fprintf(stderr,"Leaving block %d, type %s\n", \ - cxstack_ix+1,block_type[cx->cx_type]); ) + DEBUG_l( fprintf(stderr,"Leaving block %ld, type %s\n", \ + (long)cxstack_ix+1,block_type[cx->cx_type]); ) /* Continue a block elsewhere (NEXT and REDO). */ #define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \ @@ -264,6 +222,10 @@ struct context { #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc())) /* "gimme" values */ -#define G_SCALAR 0 -#define G_ARRAY 1 +#define G_SCALAR 0 +#define G_ARRAY 1 +/* extra flags for perl_call_* routines */ +#define G_DISCARD 2 /* Call FREETMPS. */ +#define G_EVAL 4 /* Assume eval {} around subroutine call. */ +#define G_NOARGS 8 /* Don't construct a @_ array. */ diff --git a/cppstdin b/cppstdin deleted file mode 100755 index 908d4941d7..0000000000 --- a/cppstdin +++ /dev/null @@ -1 +0,0 @@ -cat >.$$.c; cc -E ${1+"$@"} .$$.c; rm .$$.c @@ -1,18 +1,17 @@ -/* $RCSfile: cv.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:42 $ +/* cv.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: cv.h,v $ */ struct xpvcv { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xp_pv as a C string */ STRLEN xpv_len; /* allocated size */ - STRLEN xof_off; /* ptr is incremented by offset */ + IV xof_off; /* integer value */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ @@ -20,23 +19,23 @@ struct xpvcv { HV * xcv_stash; OP * xcv_start; OP * xcv_root; - I32 (*xcv_usersub)(); - I32 xcv_userindex; + void (*xcv_xsub) _((CV*)); + ANY xcv_xsubany; GV * xcv_gv; GV * xcv_filegv; long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; - bool xcv_deleted; + bool xcv_oldstyle; }; #define Nullcv Null(CV*) #define CvSTASH(sv) ((XPVCV*)SvANY(sv))->xcv_stash #define CvSTART(sv) ((XPVCV*)SvANY(sv))->xcv_start #define CvROOT(sv) ((XPVCV*)SvANY(sv))->xcv_root -#define CvUSERSUB(sv) ((XPVCV*)SvANY(sv))->xcv_usersub -#define CvUSERINDEX(sv) ((XPVCV*)SvANY(sv))->xcv_userindex +#define CvXSUB(sv) ((XPVCV*)SvANY(sv))->xcv_xsub +#define CvXSUBANY(sv) ((XPVCV*)SvANY(sv))->xcv_xsubany #define CvGV(sv) ((XPVCV*)SvANY(sv))->xcv_gv #define CvFILEGV(sv) ((XPVCV*)SvANY(sv))->xcv_filegv #define CvDEPTH(sv) ((XPVCV*)SvANY(sv))->xcv_depth #define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist -#define CvDELETED(sv) ((XPVCV*)SvANY(sv))->xcv_deleted +#define CvOLDSTYLE(sv) ((XPVCV*)SvANY(sv))->xcv_oldstyle @@ -1,45 +1,22 @@ -/* $RCSfile: op.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:16 $ +/* deb.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: op.c,v $ - * Revision 4.1 92/08/07 17:19:16 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.5 92/06/08 12:00:39 lwall - * patch20: the switch optimizer didn't do anything in subroutines - * patch20: removed implicit int declarations on funcions - * - * Revision 4.0.1.4 91/11/11 16:29:33 lwall - * patch19: do {$foo ne "bar";} returned wrong value - * patch19: some earlier patches weren't propagated to alternate 286 code - * - * Revision 4.0.1.3 91/11/05 16:07:43 lwall - * patch11: random cleanup - * patch11: "foo\0" eq "foo" was sometimes optimized to true - * patch11: foreach on null list could spring memory leak - * - * Revision 4.0.1.2 91/06/07 10:26:45 lwall - * patch4: new copyright notice - * patch4: made some allowances for "semi-standard" C - * - * Revision 4.0.1.1 91/04/11 17:36:16 lwall - * patch1: you may now use "die" and "caller" in a signal handler - * - * Revision 4.0 91/03/20 01:04:18 lwall - * 4.0 baseline. - * + */ + +/* + * "Didst thou think that the eyes of the White Tower were blind? Nay, I + * have seen more than thou knowest, Gray Fool." --Denethor */ #include "EXTERN.h" #include "perl.h" -void deb_growlevel(); - -#if !defined(STANDARD_C) && !defined(I_VARARGS) +#ifdef DEBUGGING +#if !defined(I_STDARG) && !defined(I_VARARGS) /* * Fallback on the old hackers way of doing varargs @@ -51,15 +28,17 @@ deb(pat,a1,a2,a3,a4,a5,a6,a7,a8) char *pat; { register I32 i; + GV* gv = curcop->cop_filegv; fprintf(stderr,"(%s:%ld)\t", - SvPVX(GvSV(curcop->cop_filegv)),(long)curcop->cop_line); + 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(STANDARD_C) && !defined(I_VARARGS) */ +#else /* !defined(I_STDARG) && !defined(I_VARARGS) */ # ifdef STANDARD_C void @@ -74,13 +53,15 @@ deb(pat, va_alist) { va_list args; register I32 i; + GV* gv = curcop->cop_filegv; fprintf(stderr,"(%s:%ld)\t", - SvPVX(GvSV(curcop->cop_filegv)),(long)curcop->cop_line); + 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]); -# if STANDARD_C +# ifdef I_STDARG va_start(args, pat); # else va_start(args); @@ -88,7 +69,7 @@ deb(pat, va_alist) (void) vfprintf(stderr,pat,args); va_end( args ); } -#endif /* !defined(STANDARD_C) && !defined(I_VARARGS) */ +#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ void deb_growlevel() @@ -102,30 +83,50 @@ I32 debstackptrs() { fprintf(stderr, "%8lx %8lx %8ld %8ld %8ld\n", - stack, stack_base, *markstack_ptr, stack_sp-stack_base, stack_max-stack_base); - fprintf(stderr, "%8lx %8lx %8ld %l8d %8ld\n", - mainstack, AvARRAY(stack), mainstack, AvFILL(stack), AvMAX(stack)); + (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; } I32 debstack() { - register I32 i; - I32 markoff = markstack_ptr > markstack ? *markstack_ptr : -1; + I32 top = stack_sp - stack_base; + register I32 i = top - 30; + I32 *markscan = markstack; + + if (i < 0) + i = 0; + + while (++markscan <= markstack_ptr) + if (*markscan >= i) + break; - fprintf(stderr, " =>"); - if (stack_base[0] || stack_sp < stack_base) + fprintf(stderr, i ? " => ... " : " => "); + if (stack_base[0] != &sv_undef || stack_sp < stack_base) fprintf(stderr, " [STACK UNDERFLOW!!!]\n"); - for (i = 1; i <= 30; i++) { - if (stack_sp >= &stack_base[i]) - { - fprintf(stderr, "\t%-4s%s%s", SvPEEK(stack_base[i]), - markoff == i ? " [" : "", - stack_sp == &stack_base[i] ? - (markoff == i ? "]" : " ]") : ""); + 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 +static int dummy; /* avoid totally empty deb.o file */ +#endif /* DEBUGGING */ @@ -1,54 +0,0 @@ -#include <dlfcn.h> - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -static int -XS_DynamicLoader_bootstrap(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: DynamicLoader::bootstrap(package)"); - } - { - char* package = SvPV(ST(1),na); - void* obj = 0; - int (*bootproc)(); - char tmpbuf[1024]; - char tmpbuf2[128]; - AV *av = GvAVn(incgv); - I32 i; - - for (i = 0; i <= AvFILL(av); i++) { - (void)sprintf(tmpbuf, "%s/auto/%s/%s.so", - SvPVx(*av_fetch(av, i, TRUE), na), package, package); - if (obj = dlopen(tmpbuf,1)) - break; - } - if (!obj) - croak("Can't find loadable object for package %s in @INC", package); - - sprintf(tmpbuf2, "boot_%s", package); - bootproc = (int (*)())dlsym(obj, tmpbuf2); - if (!bootproc) - croak("Shared object %s contains no %s function", tmpbuf, tmpbuf2); - bootproc(); - - ST(0) = sv_mortalcopy(&sv_yes); - } - return ax; -} - -int -boot_DynamicLoader(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("DynamicLoader::bootstrap", 0, XS_DynamicLoader_bootstrap, file); -} diff --git a/dl_sunos.c b/dl_sunos.c deleted file mode 100644 index badd66d678..0000000000 --- a/dl_sunos.c +++ /dev/null @@ -1,56 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef I_DLFCN -# include <dlfcn.h> -#endif - -static int -XS_DynamicLoader_bootstrap(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: DynamicLoader::bootstrap(package)"); - } - { - char* package = SvPV(ST(1),na); - void* obj = 0; - int (*bootproc)(); - char tmpbuf[1024]; - char tmpbuf2[128]; - AV *av = GvAVn(incgv); - I32 i; - - for (i = 0; i <= AvFILL(av); i++) { - (void)sprintf(tmpbuf, "%s/auto/%s/%s.so", - SvPVx(*av_fetch(av, i, TRUE), na), package, package); - if (obj = dlopen(tmpbuf,1)) - break; - } - if (!obj) - croak("Can't find loadable object for package %s in @INC", package); - - sprintf(tmpbuf2, "boot_%s", package); - bootproc = (int (*)())dlsym(obj, tmpbuf2); - if (!bootproc) - croak("Shared object %s contains no %s function", tmpbuf, tmpbuf2); - bootproc(); - - ST(0) = sv_mortalcopy(&sv_yes); - } - return ax; -} - -int -boot_DynamicLoader(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("DynamicLoader::bootstrap", 0, XS_DynamicLoader_bootstrap, file); -} @@ -1,54 +1,17 @@ -/* $RCSfile: doio.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:42 $ +/* doio.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: doio.c,v $ - * Revision 4.1 92/08/07 17:19:42 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.6 92/06/11 21:08:16 lwall - * patch34: some systems don't declare h_errno extern in header files - * - * Revision 4.0.1.5 92/06/08 13:00:21 lwall - * patch20: some machines don't define ENOTSOCK in errno.h - * patch20: new warnings for failed use of stat operators on filenames with \n - * patch20: wait failed when STDOUT or STDERR reopened to a pipe - * patch20: end of file latch not reset on reopen of STDIN - * patch20: seek(HANDLE, 0, 1) went to eof because of ancient Ultrix workaround - * patch20: fixed memory leak on system() for vfork() machines - * patch20: get*by* routines now return something useful in a scalar context - * patch20: h_errno now accessible via $? - * - * Revision 4.0.1.4 91/11/05 16:51:43 lwall - * patch11: prepared for ctype implementations that don't define isascii() - * patch11: perl mistook some streams for sockets because they return mode 0 too - * patch11: reopening STDIN, STDOUT and STDERR failed on some machines - * patch11: certain perl errors should set EBADF so that $! looks better - * patch11: truncate on a closed filehandle could dump - * patch11: stats of _ forgot whether prior stat was actually lstat - * patch11: -T returned true on NFS directory - * - * Revision 4.0.1.3 91/06/10 01:21:19 lwall - * patch10: read didn't work from character special files open for writing - * patch10: close-on-exec wrongly set on system file descriptors - * - * Revision 4.0.1.2 91/06/07 10:53:39 lwall - * patch4: new copyright notice - * patch4: system fd's are now treated specially - * patch4: added $^F variable to specify maximum system fd, default 2 - * patch4: character special files now opened with bidirectional stdio buffers - * patch4: taintchecks could improperly modify parent in vfork() - * patch4: many, many itty-bitty portability fixes - * - * Revision 4.0.1.1 91/04/11 17:41:06 lwall - * patch1: hopefully straightened out some of the Xenix mess - * - * Revision 4.0 91/03/20 01:07:06 lwall - * 4.0 baseline. - * + */ + +/* + * "Far below them they saw the white waters pour into a foaming bowl, and + * then swirl darkly about a deep oval basin in the rocks, until they found + * their way out again through a narrow gate, and flowed away, fuming and + * chattering, into calmer and more level reaches." */ #include "EXTERN.h" @@ -64,6 +27,9 @@ #endif #ifdef HAS_SHM #include <sys/shm.h> +# ifndef HAS_SHMAT_PROTOTYPE + extern Shmat_t shmat _((int, char *, int)); +# endif #endif #endif @@ -77,18 +43,26 @@ #include <sys/file.h> #endif +/* Omit -- it causes too much grief on mixed systems. +#ifdef I_UNISTD +#include <unistd.h> +#endif +*/ + bool -do_open(gv,name,len) +do_open(gv,name,len,supplied_fp) GV *gv; register char *name; I32 len; +FILE *supplied_fp; { FILE *fp; - register IO *io = GvIO(gv); - char *myname = savestr(name); + register IO *io = GvIOn(gv); + char *myname = savepv(name); int result; int fd; int writing = 0; + int dodup; char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ FILE *saveifp = Nullfp; FILE *saveofp = Nullfp; @@ -100,9 +74,7 @@ I32 len; forkprocess = 1; /* assume true if no fork */ while (len && isSPACE(name[len-1])) name[--len] = '\0'; - if (!io) - io = GvIO(gv) = newIO(); - else if (IoIFP(io)) { + if (IoIFP(io)) { fd = fileno(IoIFP(io)); if (IoTYPE(io) == '-') result = 0; @@ -145,6 +117,8 @@ I32 len; if (strNE(name,"-")) TAINT_ENV(); TAINT_PROPER("piped open"); + if (dowarn && name[strlen(name)-1] == '|') + warn("Can't do bidirectional pipe"); fp = my_popen(name,"w"); writing = 1; } @@ -160,29 +134,41 @@ I32 len; writing = 1; if (*name == '&') { duplicity: + dodup = 1; name++; - while (isSPACE(*name)) + if (*name == '=') { + dodup = 0; name++; - if (isDIGIT(*name)) - fd = atoi(name); + } + if (!*name && supplied_fp) + fp = supplied_fp; else { - gv = gv_fetchpv(name,FALSE,SVt_PVIO); - if (!gv || !GvIO(gv)) { + while (isSPACE(*name)) + name++; + if (isDIGIT(*name)) + fd = atoi(name); + else { + IO* thatio; + gv = gv_fetchpv(name,FALSE,SVt_PVIO); + thatio = GvIO(gv); + if (!thatio) { #ifdef EINVAL - errno = EINVAL; + errno = EINVAL; #endif - goto say_false; - } - if (GvIO(gv) && IoIFP(GvIO(gv))) { - fd = fileno(IoIFP(GvIO(gv))); - if (IoTYPE(GvIO(gv)) == 's') - IoTYPE(io) = 's'; + goto say_false; + } + if (IoIFP(thatio)) { + fd = fileno(IoIFP(thatio)); + if (IoTYPE(thatio) == 's') + IoTYPE(io) = 's'; + } + else + fd = -1; } - else - fd = -1; - } - if (!(fp = fdopen(fd = dup(fd),mode))) { - close(fd); + if (dodup) + fd = dup(fd); + if (!(fp = fdopen(fd,mode))) + close(fd); } } else { @@ -243,7 +229,7 @@ I32 len; } if (IoTYPE(io) && IoTYPE(io) != '|' && IoTYPE(io) != '-') { - if (fstat(fileno(fp),&statbuf) < 0) { + if (Fstat(fileno(fp),&statbuf) < 0) { (void)fclose(fp); goto say_false; } @@ -257,8 +243,8 @@ I32 len; !statbuf.st_mode #endif ) { - I32 buflen = sizeof tokenbuf; - if (getsockname(fileno(fp), tokenbuf, &buflen) >= 0 + int buflen = sizeof tokenbuf; + if (getsockname(fileno(fp), (struct sockaddr *)tokenbuf, &buflen) >= 0 || errno != ENOTSOCK) IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */ /* but some return 0 for streams too, sigh */ @@ -281,11 +267,11 @@ I32 len; dup2(fileno(fp), fd); sv = *av_fetch(fdpid,fileno(fp),TRUE); - SvUPGRADE(sv, SVt_IV); + (void)SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); SvIVX(sv) = 0; sv = *av_fetch(fdpid,fd,TRUE); - SvUPGRADE(sv, SVt_IV); + (void)SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; fclose(fp); @@ -293,9 +279,9 @@ I32 len; fp = saveifp; clearerr(fp); } -#if defined(HAS_FCNTL) && defined(FFt_SETFD) +#if defined(HAS_FCNTL) && defined(F_SETFD) fd = fileno(fp); - fcntl(fd,FFt_SETFD,fd > maxsysfd); + fcntl(fd,F_SETFD,fd > maxsysfd); #endif IoIFP(io) = fp; if (writing) { @@ -334,7 +320,7 @@ register GV *gv; if (!argvoutgv) argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO); if (filemode & (S_ISUID|S_ISGID)) { - fflush(IoIFP(GvIO(argvoutgv))); /* chmod must follow last write */ + fflush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */ #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); #else @@ -349,12 +335,12 @@ register GV *gv; sv_setsv(GvSV(gv),sv); SvSETMAGIC(GvSV(gv)); oldname = SvPVx(GvSV(gv), len); - if (do_open(gv,oldname,len)) { + if (do_open(gv,oldname,len,Nullfp)) { if (inplace) { TAINT_PROPER("inplace open"); if (strEQ(oldname,"-")) { defoutgv = gv_fetchpv("STDOUT",TRUE,SVt_PVIO); - return IoIFP(GvIO(gv)); + return IoIFP(GvIOp(gv)); } #ifndef FLEXFILENAMES filedev = statbuf.st_dev; @@ -376,7 +362,7 @@ register GV *gv; sv_catpv(sv,inplace); #endif #ifndef FLEXFILENAMES - if (stat(SvPVX(sv),&statbuf) >= 0 + if (Stat(SvPVX(sv),&statbuf) >= 0 && statbuf.st_dev == filedev && statbuf.st_ino == fileino ) { warn("Can't do inplace edit: %s > 14 characters", @@ -397,7 +383,7 @@ register GV *gv; do_close(gv,FALSE); (void)unlink(SvPVX(sv)); (void)rename(oldname,SvPVX(sv)); - do_open(gv,SvPVX(sv),SvCUR(GvSV(gv))); + do_open(gv,SvPVX(sv),SvCUR(GvSV(gv)),Nullfp); #endif /* MSDOS */ #else (void)UNLINK(SvPVX(sv)); @@ -426,15 +412,15 @@ register GV *gv; sv_setpvn(sv,">",1); sv_catpv(sv,oldname); errno = 0; /* in case sprintf set errno */ - if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv))) { + if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),Nullfp)) { warn("Can't do inplace edit on %s: %s", oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } defoutgv = argvoutgv; - lastfd = fileno(IoIFP(GvIO(argvoutgv))); - (void)fstat(lastfd,&statbuf); + lastfd = fileno(IoIFP(GvIOp(argvoutgv))); + (void)Fstat(lastfd,&statbuf); #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); #else @@ -450,7 +436,7 @@ register GV *gv; #endif } } - return IoIFP(GvIO(gv)); + return IoIFP(GvIOp(gv)); } else fprintf(stderr,"Can't open %s: %s\n",SvPV(sv, na), Strerror(errno)); @@ -478,16 +464,12 @@ GV *wgv; if (!wgv) goto badexit; - rstio = GvIO(rgv); - wstio = GvIO(wgv); + rstio = GvIOn(rgv); + wstio = GvIOn(wgv); - if (!rstio) - rstio = GvIO(rgv) = newIO(); - else if (IoIFP(rstio)) + if (IoIFP(rstio)) do_close(rgv,FALSE); - if (!wstio) - wstio = GvIO(wgv) = newIO(); - else if (IoIFP(wstio)) + if (IoIFP(wstio)) do_close(wgv,FALSE); if (pipe(fd) < 0) @@ -515,13 +497,13 @@ badexit: #endif bool -#ifndef STANDARD_C +#ifndef CAN_PROTOTYPE do_close(gv,explicit) GV *gv; bool explicit; #else do_close(GV *gv, bool explicit) -#endif /* STANDARD_C */ +#endif /* CAN_PROTOTYPE */ { bool retval = FALSE; register IO *io; @@ -529,7 +511,7 @@ do_close(GV *gv, bool explicit) if (!gv) gv = argvgv; - if (!gv) { + if (!gv || SvTYPE(gv) != SVt_PVGV) { errno = EBADF; return FALSE; } @@ -660,79 +642,7 @@ nuts: return FALSE; } -I32 -do_ctl(optype,gv,func,argstr) -I32 optype; -GV *gv; -I32 func; -SV *argstr; -{ - register IO *io; - register char *s; - I32 retval; - - if (!gv || !argstr || !(io = GvIO(gv)) || !IoIFP(io)) { - errno = EBADF; /* well, sort of... */ - return -1; - } - - if (SvPOK(argstr) || !SvNIOK(argstr)) { - if (!SvPOK(argstr)) - s = SvPV(argstr, na); - -#ifdef IOCPARM_MASK -#ifndef IOCPARM_LEN -#define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK) -#endif -#endif -#ifdef IOCPARM_LEN - retval = IOCPARM_LEN(func); /* on BSDish systes we're safe */ -#else - retval = 256; /* otherwise guess at what's safe */ -#endif - if (SvCUR(argstr) < retval) { - Sv_Grow(argstr,retval+1); - SvCUR_set(argstr, retval); - } - - s = SvPVX(argstr); - s[SvCUR(argstr)] = 17; /* a little sanity check here */ - } - else { - retval = SvIV(argstr); -#ifdef DOSISH - s = (char*)(long)retval; /* ouch */ -#else - s = (char*)retval; /* ouch */ -#endif - } - -#ifndef lint - if (optype == OP_IOCTL) - retval = ioctl(fileno(IoIFP(io)), func, s); - else -#ifdef DOSISH - croak("fcntl is not implemented"); -#else -#ifdef HAS_FCNTL - retval = fcntl(fileno(IoIFP(io)), func, s); -#else - croak("fcntl is not implemented"); -#endif -#endif -#else /* lint */ - retval = 0; -#endif /* lint */ - - if (SvPOK(argstr)) { - if (s[SvCUR(argstr)] != 17) - croak("Return value overflowed string"); - s[SvCUR(argstr)] = 0; /* put our null back */ - } - return retval; -} - -#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(FFt_FREESP) +#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) /* code courtesy of William Kucharski */ #define HAS_CHSIZE @@ -744,7 +654,7 @@ Off_t length; /* length to set file to */ struct flock fl; struct stat filebuf; - if (fstat(fd, &filebuf) < 0) + if (Fstat(fd, &filebuf) < 0) return -1; if (filebuf.st_size < length) { @@ -765,24 +675,24 @@ Off_t length; /* length to set file to */ fl.l_whence = 0; fl.l_len = 0; fl.l_start = length; - fl.l_type = FFt_WRLCK; /* write lock on file space */ + fl.l_type = F_WRLCK; /* write lock on file space */ /* - * This relies on the UNDOCUMENTED FFt_FREESP argument to + * This relies on the UNDOCUMENTED F_FREESP argument to * fcntl(2), which truncates the file so that it ends at the * position indicated by fl.l_start. * * Will minor miracles never cease? */ - if (fcntl(fd, FFt_FREESP, &fl) < 0) + if (fcntl(fd, F_FREESP, &fl) < 0) return -1; } return 0; } -#endif /* FFt_FREESP */ +#endif /* F_FREESP */ I32 looks_like_number(sv) @@ -840,7 +750,6 @@ register SV *sv; FILE *fp; { register char *tmps; - SV* tmpstr; STRLEN len; /* assuming fp is checked earlier */ @@ -865,15 +774,18 @@ FILE *fp; warn(warn_uninit); return TRUE; case SVt_IV: - if (SvGMAGICAL(sv)) - mg_get(sv); - fprintf(fp, "%d", SvIVX(sv)); - return !ferror(fp); + if (SvIOK(sv)) { + if (SvGMAGICAL(sv)) + mg_get(sv); + fprintf(fp, "%ld", (long)SvIVX(sv)); + return !ferror(fp); + } + /* FALL THROUGH */ default: tmps = SvPV(sv, len); break; } - if (len && (fwrite(tmps,1,len,fp) == 0 || ferror(fp))) + if (len && (fwrite1(tmps,1,len,fp) == 0 || ferror(fp))) return FALSE; return TRUE; } @@ -885,14 +797,14 @@ dARGS dSP; IO *io; - if (op->op_flags & OPf_SPECIAL) { + if (op->op_flags & OPf_REF) { EXTEND(sp,1); io = GvIO(cGVOP->op_gv); if (io && IoIFP(io)) { statgv = cGVOP->op_gv; sv_setpv(statname,""); laststype = OP_STAT; - return (laststatval = fstat(fileno(IoIFP(io)), &statcache)); + return (laststatval = Fstat(fileno(IoIFP(io)), &statcache)); } else { if (cGVOP->op_gv == defgv) @@ -911,7 +823,7 @@ dARGS statgv = Nullgv; sv_setpv(statname,SvPV(sv, na)); laststype = OP_STAT; - laststatval = stat(SvPV(sv, na),&statcache); + laststatval = Stat(SvPV(sv, na),&statcache); if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) warn(warn_nl, "stat"); return laststatval; @@ -924,7 +836,7 @@ dARGS { dSP; SV *sv; - if (op->op_flags & OPf_SPECIAL) { + if (op->op_flags & OPf_REF) { EXTEND(sp,1); if (cGVOP->op_gv == defgv) { if (laststype != OP_LSTAT) @@ -942,7 +854,7 @@ dARGS #ifdef HAS_LSTAT laststatval = lstat(SvPV(sv, na),&statcache); #else - laststatval = stat(SvPV(sv, na),&statcache); + laststatval = Stat(SvPV(sv, na),&statcache); #endif if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) warn(warn_nl, "lstat"); @@ -974,6 +886,8 @@ register SV **sp; execvp(tmps,Argv); else execvp(Argv[0],Argv); + if (dowarn) + warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; @@ -1047,7 +961,7 @@ char *cmd; } } New(402,Argv, (s - cmd) / 2 + 2, char*); - Cmd = nsavestr(cmd, s-cmd); + Cmd = savepvn(cmd, s-cmd); a = Argv; for (s = Cmd; *s;) { while (*s && isSPACE(*s)) s++; @@ -1064,6 +978,8 @@ char *cmd; do_execfree(); goto doshell; } + if (dowarn) + warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; @@ -1104,9 +1020,9 @@ register SV **sp; case OP_CHOWN: TAINT_PROPER("chown"); if (sp - mark > 2) { - tot = sp - mark; val = SvIVx(*++mark); val2 = SvIVx(*++mark); + tot = sp - mark; while (++mark <= sp) { if (chown(SvPVx(*mark, na),val,val2)) tot--; @@ -1160,7 +1076,7 @@ register SV **sp; #ifdef HAS_LSTAT if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) #else - if (stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) + if (Stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) #endif tot--; else { @@ -1170,6 +1086,7 @@ register SV **sp; } } break; +#ifdef HAS_UTIME case OP_UTIME: TAINT_PROPER("utime"); if (sp - mark > 2) { @@ -1194,12 +1111,13 @@ register SV **sp; else tot = 0; break; +#endif } return tot; } /* Do the permissions allow some operation? Assumes statcache already set. */ - +#ifndef VMS /* VMS' cando is in vms.c */ I32 cando(bit, effective, statbufp) I32 bit; @@ -1253,6 +1171,7 @@ register struct stat *statbufp; return FALSE; #endif /* ! MSDOS */ } +#endif /* ! VMS */ I32 ingroup(testgid,effective) @@ -1266,7 +1185,7 @@ I32 effective; #define NGROUPS 32 #endif { - GROUPSTYPE gary[NGROUPS]; + Groups_t gary[NGROUPS]; I32 anum; anum = getgroups(NGROUPS,gary); @@ -1323,7 +1242,8 @@ SV **sp; { SV *astr; char *a; - I32 id, n, cmd, infosize, getinfo, ret; + I32 id, n, cmd, infosize, getinfo; + I32 ret = -1; id = SvIVx(*++mark); n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0; @@ -1370,20 +1290,14 @@ SV **sp; if (infosize) { + STRLEN len; if (getinfo) { - if (SvTHINKFIRST(astr)) { - if (SvREADONLY(astr)) - croak("Can't %s to readonly var", op_name[optype]); - if (SvROK(astr)) - sv_unref(astr); - } - SvGROW(astr, infosize+1); - a = SvPV(astr, na); + SvPV_force(astr, len); + a = SvGROW(astr, infosize+1); } else { - STRLEN len; a = SvPV(astr, len); if (len != infosize) croak("Bad arg length for %s, is %d, should be %d", @@ -1417,6 +1331,7 @@ SV **sp; if (getinfo && ret >= 0) { SvCUR_set(astr, infosize); *SvEND(astr) = '\0'; + SvSETMAGIC(astr); } return ret; } @@ -1468,11 +1383,9 @@ SV **sp; if (SvROK(mstr)) sv_unref(mstr); } - mbuf = SvPV(mstr, len); - if (len < sizeof(long)+msize+1) { - SvGROW(mstr, sizeof(long)+msize+1); - mbuf = SvPV(mstr, len); - } + SvPV_force(mstr, len); + mbuf = SvGROW(mstr, sizeof(long)+msize+1); + errno = 0; ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); if (ret >= 0) { @@ -1523,9 +1436,6 @@ SV **sp; I32 id, mpos, msize; STRLEN len; struct shmid_ds shmds; -#ifndef VOIDSHMAT - extern char *shmat P((int, char *, int)); -#endif id = SvIVx(*++mark); mstr = *++mark; @@ -1538,28 +1448,22 @@ SV **sp; errno = EFAULT; /* can't do as caller requested */ return -1; } - shm = (char*)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); + shm = (Shmat_t)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); if (shm == (char *)-1) /* I hate System V IPC, I really do */ return -1; - mbuf = SvPV(mstr, len); if (optype == OP_SHMREAD) { - if (SvTHINKFIRST(mstr)) { - if (SvREADONLY(mstr)) - croak("Can't shmread to readonly var"); - if (SvROK(mstr)) - sv_unref(mstr); - } - if (len < msize) { - SvGROW(mstr, msize+1); - mbuf = SvPV(mstr, len); - } + SvPV_force(mstr, len); + mbuf = SvGROW(mstr, msize+1); + Copy(shm + mpos, mbuf, msize, char); SvCUR_set(mstr, msize); *SvEND(mstr) = '\0'; + SvSETMAGIC(mstr); } else { I32 n; + mbuf = SvPV(mstr, len); if ((n = len) > msize) n = msize; Copy(mbuf, shm + mpos, n, char); @@ -1,60 +1,14 @@ -/* $RCSfile: doarg.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:37 $ +/* doop.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: doarg.c,v $ - * Revision 4.1 92/08/07 17:19:37 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.7 92/06/11 21:07:11 lwall - * patch34: join with null list attempted negative allocation - * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd " - * - * Revision 4.0.1.6 92/06/08 12:34:30 lwall - * patch20: removed implicit int declarations on funcions - * patch20: pattern modifiers i and o didn't interact right - * patch20: join() now pre-extends target string to avoid excessive copying - * patch20: fixed confusion between a *var's real name and its effective name - * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly - * patch20: usersub routines didn't reclaim temp values soon enough - * patch20: ($<,$>) = ... didn't work on some architectures - * patch20: added Atari ST portability - * - * Revision 4.0.1.5 91/11/11 16:31:58 lwall - * patch19: added little-endian pack/unpack options - * - * Revision 4.0.1.4 91/11/05 16:35:06 lwall - * patch11: /$foo/o optimizer could access deallocated data - * patch11: minimum match length calculation in regexp is now cumulative - * patch11: added some support for 64-bit integers - * patch11: prepared for ctype implementations that don't define isascii() - * patch11: sprintf() now supports any length of s field - * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work - * patch11: defined(&$foo) and undef(&$foo) didn't work - * - * Revision 4.0.1.3 91/06/10 01:18:41 lwall - * patch10: pack(hh,1) dumped core - * - * Revision 4.0.1.2 91/06/07 10:42:17 lwall - * patch4: new copyright notice - * patch4: // wouldn't use previous pattern if it started with a null character - * patch4: //o and s///o now optimize themselves fully at runtime - * patch4: added global modifier for pattern matches - * patch4: undef @array disabled "@array" interpolation - * patch4: chop("") was returning "\0" rather than "" - * patch4: vector logical operations &, | and ^ sometimes returned null string - * patch4: syscall couldn't pass numbers with most significant bit set on sparcs - * - * Revision 4.0.1.1 91/04/11 17:40:14 lwall - * patch1: fixed undefined environ problem - * patch1: fixed debugger coredump on subroutines - * - * Revision 4.0 91/03/20 01:06:42 lwall - * 4.0 baseline. - * + */ + +/* + * "'So that was the job I felt I had to do when I started,' thought Sam." */ #include "EXTERN.h" @@ -68,8 +22,6 @@ #pragma function(memcmp) #endif /* BUGGY_MSC */ -static void doencodes(); - #ifdef BUGGY_MSC #pragma intrinsic(memcmp) #endif /* BUGGY_MSC */ @@ -88,8 +40,15 @@ OP *arg; register I32 squash = op->op_private & OPpTRANS_SQUASH; STRLEN len; + if (SvREADONLY(sv)) + croak(no_modify); tbl = (short*) cPVOP->op_pv; s = SvPV(sv, len); + if (!len) + return 0; + if (!SvPOKp(sv)) + s = SvPV_force(sv, len); + (void)SvPOK_only(sv); send = s + len; if (!tbl || !s) croak("panic: do_trans"); @@ -214,7 +173,7 @@ register SV **sarg; sv_setpv(sv,""); len--; /* don't count pattern string */ - t = s = SvPV(*sarg, arglen); + t = s = SvPV(*sarg, arglen); /* XXX Don't know t is writeable */ send = s + arglen; sarg++; for ( ; ; len--) { @@ -386,13 +345,23 @@ SV *sv; register unsigned char *s; register unsigned long lval; I32 mask; + STRLEN targlen; + STRLEN len; if (!targ) return; - s = (unsigned char*)SvPVX(targ); + s = (unsigned char*)SvPV_force(targ, targlen); lval = U_L(SvNV(sv)); offset = LvTARGOFF(sv); size = LvTARGLEN(sv); + + len = (offset + size + 7) / 8; + if (len > targlen) { + s = (unsigned char*)SvGROW(targ, len + 1); + (void)memzero(s + targlen, len - targlen + 1); + SvCUR_set(targ, len); + } + if (size < 8) { mask = (1 << size) - 1; size = offset & 7; @@ -402,6 +371,7 @@ SV *sv; s[offset] |= lval << size; } else { + offset >>= 3; if (size == 8) s[offset] = lval & 255; else if (size == 16) { @@ -422,49 +392,112 @@ do_chop(astr,sv) register SV *astr; register SV *sv; { - register char *tmps; - register I32 i; - AV *ary; - HV *hv; - HE *entry; STRLEN len; - - if (!sv) - return; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) - croak("Can't chop readonly value"); - if (SvROK(sv)) - sv_unref(sv); - } + char *s; + if (SvTYPE(sv) == SVt_PVAV) { - I32 max; - SV **array = AvARRAY(sv); - max = AvFILL(sv); - for (i = 0; i <= max; i++) - do_chop(astr,array[i]); - return; + register I32 i; + I32 max; + AV* av = (AV*)sv; + max = AvFILL(av); + for (i = 0; i <= max; i++) { + sv = (SV*)av_fetch(av, i, FALSE); + if (sv && ((sv = *(SV**)sv), sv != &sv_undef)) + do_chop(astr, sv); + } + return; } if (SvTYPE(sv) == SVt_PVHV) { - hv = (HV*)sv; - (void)hv_iterinit(hv); - /*SUPPRESS 560*/ - while (entry = hv_iternext(hv)) - do_chop(astr,hv_iterval(hv,entry)); - return; + HV* hv = (HV*)sv; + HE* entry; + (void)hv_iterinit(hv); + /*SUPPRESS 560*/ + while (entry = hv_iternext(hv)) + do_chop(astr,hv_iterval(hv,entry)); + return; } - tmps = SvPV(sv, len); - if (tmps && len) { - tmps += len - 1; - sv_setpvn(astr,tmps,1); /* remember last char */ - *tmps = '\0'; /* wipe it out */ - SvCUR_set(sv, tmps - SvPVX(sv)); - SvNOK_off(sv); - SvSETMAGIC(sv); + s = SvPV(sv, len); + if (len && !SvPOKp(sv)) + s = SvPV_force(sv, len); + if (s && len) { + s += --len; + sv_setpvn(astr, s, 1); + *s = '\0'; + SvCUR_set(sv, len); + SvNIOK_off(sv); } else - sv_setpvn(astr,"",0); -} + sv_setpvn(astr, "", 0); + SvSETMAGIC(sv); +} + +I32 +do_chomp(sv) +register SV *sv; +{ + register I32 count = 0; + STRLEN len; + char *s; + + if (SvTYPE(sv) == SVt_PVAV) { + register I32 i; + I32 max; + AV* av = (AV*)sv; + max = AvFILL(av); + for (i = 0; i <= max; i++) { + sv = (SV*)av_fetch(av, i, FALSE); + if (sv && ((sv = *(SV**)sv), sv != &sv_undef)) + count += do_chomp(sv); + } + return count; + } + if (SvTYPE(sv) == SVt_PVHV) { + HV* hv = (HV*)sv; + HE* entry; + (void)hv_iterinit(hv); + /*SUPPRESS 560*/ + while (entry = hv_iternext(hv)) + count += do_chomp(hv_iterval(hv,entry)); + return count; + } + s = SvPV(sv, len); + if (len && !SvPOKp(sv)) + s = SvPV_force(sv, len); + if (s && len) { + s += --len; + if (rspara) { + if (*s != '\n') + goto nope; + ++count; + while (len && s[-1] == '\n') { + --len; + --s; + ++count; + } + } + else if (rslen == 1) { + if (*s != rschar) + goto nope; + ++count; + } + else { + if (len < rslen - 1) + goto nope; + len -= rslen - 1; + s -= rslen - 1; + if (bcmp(s, rs, rslen)) + goto nope; + count += rslen; + } + + *s = '\0'; + SvCUR_set(sv, len); + SvNIOK_off(sv); + } + nope: + SvSETMAGIC(sv); + return count; +} void do_vop(optype,sv,left,right) @@ -484,29 +517,17 @@ SV *right; register char *lc = SvPV(left, leftlen); register char *rc = SvPV(right, rightlen); register I32 len; + I32 lensave; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) - croak("Can't do %s to readonly value", op_name[optype]); - if (SvROK(sv)) - sv_unref(sv); - } + dc = SvPV_force(sv,na); len = leftlen < rightlen ? leftlen : rightlen; - if (SvTYPE(sv) < SVt_PV) - sv_upgrade(sv, SVt_PV); - if (SvCUR(sv) > len) - SvCUR_set(sv, len); - else if (SvCUR(sv) < len) { - SvGROW(sv,len); - (void)memzero(SvPVX(sv) + SvCUR(sv), len - SvCUR(sv)); - SvCUR_set(sv, len); - } - SvPOK_only(sv); - dc = SvPVX(sv); - if (!dc) { - sv_setpvn(sv,"",0); - dc = SvPVX(sv); + lensave = len; + if (SvCUR(sv) < len) { + dc = SvGROW(sv,len + 1); + (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); } + SvCUR_set(sv, len); + (void)SvPOK_only(sv); #ifdef LIBERAL if (len >= sizeof(long)*4 && !((long)dc % sizeof(long)) && @@ -529,7 +550,7 @@ SV *right; *dl++ = *ll++ & *rl++; } break; - case OP_XOR: + case OP_BIT_XOR: while (len--) { *dl++ = *ll++ ^ *rl++; *dl++ = *ll++ ^ *rl++; @@ -553,25 +574,30 @@ SV *right; len = remainder; } #endif - switch (optype) { - case OP_BIT_AND: - while (len--) - *dc++ = *lc++ & *rc++; - break; - case OP_XOR: - while (len--) - *dc++ = *lc++ ^ *rc++; - goto mop_up; - case OP_BIT_OR: - while (len--) - *dc++ = *lc++ | *rc++; - mop_up: - len = SvCUR(sv); - if (rightlen > len) - sv_catpvn(sv, SvPVX(right) + len, rightlen - len); - else if (leftlen > len) - sv_catpvn(sv, SvPVX(left) + len, leftlen - len); - break; + { + char *lsave = lc; + char *rsave = rc; + + switch (optype) { + case OP_BIT_AND: + while (len--) + *dc++ = *lc++ & *rc++; + break; + case OP_BIT_XOR: + while (len--) + *dc++ = *lc++ ^ *rc++; + goto mop_up; + case OP_BIT_OR: + while (len--) + *dc++ = *lc++ | *rc++; + mop_up: + len = lensave; + if (rightlen > len) + sv_catpvn(sv, rsave + len, rightlen - len); + else if (leftlen > len) + sv_catpvn(sv, lsave + len, leftlen - len); + break; + } } } @@ -581,13 +607,15 @@ dARGS { dSP; HV *hv = (HV*)POPs; - register AV *ary = stack; I32 i; register HE *entry; char *tmps; SV *tmpstr; - I32 dokeys = (op->op_type == OP_KEYS || op->op_type == OP_RV2HV); - I32 dovalues = (op->op_type == OP_VALUES || op->op_type == OP_RV2HV); + I32 dokeys = (op->op_type == OP_KEYS); + I32 dovalues = (op->op_type == OP_VALUES); + + if (op->op_type == OP_RV2HV || op->op_type == OP_PADHV) + dokeys = dovalues = TRUE; if (!hv) RETURN; @@ -1 +1,14 @@ #define ABORT() abort(); + +/* + * 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 my_getenv(var) getenv(var) @@ -1,24 +1,15 @@ -/* $RCSfile: dump.c,v $$Revision: 4.1 $$Date: 92/08/07 17:20:03 $ +/* dump.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: dump.c,v $ - * Revision 4.1 92/08/07 17:20:03 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.2 92/06/08 13:14:22 lwall - * patch20: removed implicit int declarations on funcions - * patch20: fixed confusion between a *var's real name and its effective name - * - * Revision 4.0.1.1 91/06/07 10:58:44 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:08:25 lwall - * 4.0 baseline. - * + */ + +/* + * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and + * it has not been hard for me to read your mind and memory.'" */ #include "EXTERN.h" @@ -50,12 +41,12 @@ void dump_packsubs(stash) HV* stash; { - U32 i; + I32 i; HE *entry; if (!HvARRAY(stash)) return; - for (i = 0; i <= HvMAX(stash); i++) { + 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; @@ -63,8 +54,8 @@ HV* stash; dump_sub(gv); if (GvFORM(gv)) dump_form(gv); - if (*entry->hent_key == '_' && (hv = GvHV(gv)) && HvNAME(hv) && - hv != defstash) + if (entry->hent_key[entry->hent_klen-1] == ':' && + (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash) dump_packsubs(hv); /* nested package */ } } @@ -78,10 +69,10 @@ GV* gv; gv_fullname(sv,gv); dump("\nSUB %s = ", SvPVX(sv)); - if (CvUSERSUB(GvCV(gv))) + if (CvXSUB(GvCV(gv))) dump("(xsub 0x%x %d)\n", - (long)CvUSERSUB(GvCV(gv)), - CvUSERINDEX(GvCV(gv))); + (long)CvXSUB(GvCV(gv)), + CvXSUBANY(GvCV(gv)).any_i32); else if (CvROOT(GvCV(gv))) dump_op(CvROOT(GvCV(gv))); else @@ -105,10 +96,6 @@ GV* gv; void dump_eval() { - register I32 i; - register GV *gv; - register HE *entry; - dump_op(eval_root); } @@ -158,10 +145,10 @@ register OP *op; (void)strcat(buf,"PARENS,"); if (op->op_flags & OPf_STACKED) (void)strcat(buf,"STACKED,"); - if (op->op_flags & OPf_LVAL) - (void)strcat(buf,"LVAL,"); - if (op->op_flags & OPf_INTRO) - (void)strcat(buf,"INTRO,"); + if (op->op_flags & OPf_REF) + (void)strcat(buf,"REF,"); + if (op->op_flags & OPf_MOD) + (void)strcat(buf,"MOD,"); if (op->op_flags & OPf_SPECIAL) (void)strcat(buf,"SPECIAL,"); if (*buf) @@ -174,6 +161,10 @@ register OP *op; if (op->op_private & OPpASSIGN_COMMON) (void)strcat(buf,"COMMON,"); } + else if (op->op_type == OP_SASSIGN) { + if (op->op_private & OPpASSIGN_BACKWARDS) + (void)strcat(buf,"BACKWARDS,"); + } else if (op->op_type == OP_TRANS) { if (op->op_private & OPpTRANS_SQUASH) (void)strcat(buf,"SQUASH,"); @@ -186,7 +177,7 @@ register OP *op; if (op->op_private & OPpREPEAT_DOLIST) (void)strcat(buf,"DOLIST,"); } - else if (op->op_type == OP_ENTERSUBR || + else if (op->op_type == OP_ENTERSUB || op->op_type == OP_RV2SV || op->op_type == OP_RV2AV || op->op_type == OP_RV2HV || @@ -215,6 +206,8 @@ register OP *op; if (op->op_private & OPpFLIP_LINENUM) (void)strcat(buf,"LINENUM,"); } + if (op->op_flags & OPf_MOD && op->op_private & OPpLVAL_INTRO) + (void)strcat(buf,"INTRO,"); if (*buf) { buf[strlen(buf)-1] = '\0'; dump("PRIVATE = (%s)\n",buf); @@ -274,10 +267,10 @@ register OP *op; else fprintf(stderr, "DONE\n"); break; + case OP_MAPWHILE: case OP_GREPWHILE: case OP_OR: case OP_AND: - case OP_METHOD: dump("OTHER ===> "); if (cLOGOP->op_other) fprintf(stderr, "%d\n", cLOGOP->op_other->op_seq); @@ -289,6 +282,8 @@ register OP *op; case OP_SUBST: dump_pm((PMOP*)op); break; + default: + break; } if (op->op_flags & OPf_KIDS) { OP *kid; @@ -5,15 +5,6 @@ # $RCSfile: relink,v $$Revision: 4.1 $$Date: 92/08/07 17:20:29 $ # # $Log: relink,v $ -# Revision 4.1 92/08/07 17:20:29 lwall -# Stage 6 Snapshot -# -# Revision 4.0 91/03/20 01:11:40 lwall -# 4.0 baseline. -# -# Revision 3.0.1.2 90/08/09 03:17:44 lwall -# patch19: added man page for relink and rename -# ($op = shift) || die "Usage: relink perlexpr [filenames]\n"; if (!@ARGV) { @@ -5,15 +5,6 @@ # $RCSfile: rename,v $$Revision: 4.1 $$Date: 92/08/07 17:20:30 $ # # $Log: rename,v $ -# Revision 4.1 92/08/07 17:20:30 lwall -# Stage 6 Snapshot -# -# Revision 4.0 91/03/20 01:11:53 lwall -# 4.0 baseline. -# -# Revision 3.0.1.2 90/08/09 03:17:57 lwall -# patch19: added man page for relink and rename -# ($op = shift) || die "Usage: rename perlexpr [filenames]\n"; if (!@ARGV) { diff --git a/eg/unuc.pats b/eg/unuc.pats deleted file mode 100644 index 6924dc6a0d..0000000000 --- a/eg/unuc.pats +++ /dev/null @@ -1,138 +0,0 @@ -A.M. -Air Force -Air Force Base -Air Force Station -American -Apr. -Ariane -Aug. -August -Bureau of Labor Statistics -CIT -Caltech -Cape Canaveral -Challenger -China -Corporation -Crippen -Daily News in Brief -Daniel Quayle -Dec. -Discovery -Edwards -Endeavour -Feb. -Ford Aerospace -Fri. -General Dynamics -George Bush -Headline News -HOTOL -I -II -III -IV -IX -Institute of Technology -JPL -Jan. -Jul. -Jun. -Kennedy Space Center -LDEF -Long Duration Exposure Facility -Long March -Mar. -March -Martin -Martin Marietta -Mercury -Mon. -in May -s/\bmay (\d)/May $1/g; -s/\boffice of (\w)/'Office of ' . (($tmp = $1) =~ y:a-z:A-Z:,$tmp)/eg; -National Science Foundation -NASA Select -New Mexico -Nov. -OMB -Oct. -Office of Management and Budget -President -President Bush -Richard Truly -Rocketdyne -Russian -Russians -Sat. -Sep. -Soviet -Soviet Union -Soviets -Space Shuttle -Sun. -Thu. -Tue. -U.S. -Union of Soviet Socialist Republics -United States -VI -VII -VIII -Vice President -Vice President Quayle -Wed. -White Sands -Kaman Aerospace -Aerospace Daily -Aviation Week -Space Technology -Washington Post -Los Angeles Times -New York Times -Aerospace Industries Association -president of -Johnson Space Center -Space Services -Inc. -Co. -Hughes Aircraft -Company -Orbital Sciences -Swedish Space -Arnauld -Nicogosian -Magellan -Galileo -Mir -Jet Propulsion Laboratory -University -Department of Defense -Orbital Science -OMS -United Press International -United Press -UPI -Associated Press -AP -Cable News Network -Cape York -Zenit -SYNCOM -Eastern -Western -Test Range -Jcsat -Japanese Satellite Communications -Defence Ministry -Defense Ministry -Skynet -Fixed Service Structure -Launch Processing System -Asiasat -Launch Control Center -Earth -CNES -Glavkosmos -Pacific -Atlantic diff --git a/eg/wrapsuid b/eg/wrapsuid new file mode 100755 index 0000000000..3b1fc6e5b8 --- /dev/null +++ b/eg/wrapsuid @@ -0,0 +1,104 @@ +#!/usr/bin/perl +'di'; +'ig00'; +# +# $Header: wrapsuid,v 1.1 90/08/11 13:51:29 lwall Locked $ +# +# $Log: wrapsuid,v $ +# Revision 1.1 90/08/11 13:51:29 lwall +# Initial revision +# + +$xdev = '-xdev' unless -d '/dev/iop'; + +if ($#ARGV >= 0) { + @list = @ARGV; + foreach $name (@ARGV) { + die "You must use absolute pathnames.\n" unless $name =~ m|^/|; + } +} +else { + open(DF,"/etc/mount|") || die "Can't run /etc/mount"; + + while (<DF>) { + chop; + $_ .= <DF> if length($_) < 50; + @ary = split; + push(@list,$ary[2]) if ($ary[0] =~ m|^/dev|); + } +} +$fslist = join(' ',@list); + +die "Can't find local filesystems" unless $fslist; + +open(FIND, + "find $fslist $xdev -type f \\( -perm -04000 -o -perm -02000 \\) -print|"); + +while (<FIND>) { + chop; + next unless -T; + print "Fixing ", $_, "\n"; + ($dir,$file) = m|(.*)/(.*)|; + chdir $dir || die "Can't chdir to $dir"; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($file); + die "Can't stat $_" unless $ino; + chmod $mode & 01777, $file; # wipe out set[ug]id bits + rename($file,".$file"); + open(C,">.tmp$$.c") || die "Can't write C program for $_"; + $real = "$dir/.$file"; + print C ' +main(argc,argv) +int argc; +char **argv; +{ + execv("' . $real . '",argv); +} +'; + close C; + system '/bin/cc', ".tmp$$.c", '-o', $file; + die "Can't compile new $_" if $?; + chmod $mode, $file; + chown $uid, $gid, $file; + unlink ".tmp$$.c"; + chdir '/'; +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +'; __END__ ############# From here on it's a standard manual page ############ +.TH SUIDSCRIPT 1 "July 30, 1990" +.AT 3 +.SH NAME +wrapsuid \- puts a compiled C wrapper around a setuid or setgid script +.SH SYNOPSIS +.B wrapsuid [dirlist] +.SH DESCRIPTION +.I Wrapsuid +creates a small C program to execute a script with setuid or setgid privileges +without having to set the setuid or setgid bit on the script, which is +a security problem on many machines. +Specify the list of directories or files that you wish to process. +The names must be absolute pathnames. +With no arguments it will attempt to process all the local directories +for this machine. +The scripts to be processed must have the setuid or setgid bit set. +The wrapsuid program will delete the bits and set them on the wrapper. +.PP +Non-superusers may only process their own files. +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +None. +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +.SH DIAGNOSTICS +.SH BUGS +.ex diff --git a/emacs/perldb.pl b/emacs/perldb.pl index 71c2d8cfa1..958e58d874 100644 --- a/emacs/perldb.pl +++ b/emacs/perldb.pl @@ -13,43 +13,6 @@ $header = '$RCSfile: perldb.pl,v $$Revision: 4.1 $$Date: 92/08/07 17:20:59 $'; # have a breakpoint. It also inserts a do 'perldb.pl' before the first line. # # $Log: perldb.pl,v $ -# Revision 4.1 92/08/07 17:20:59 lwall -# Stage 6 Snapshot -# -# Revision 4.0 91/03/20 01:18:58 lwall -# 4.0 baseline. -# -# Revision 3.0.1.6 91/01/11 18:08:58 lwall -# patch42: @_ couldn't be accessed from debugger -# -# Revision 3.0.1.5 90/11/10 01:40:26 lwall -# patch38: the debugger wouldn't stop correctly or do action routines -# -# Revision 3.0.1.4 90/10/15 17:40:38 lwall -# patch29: added caller -# patch29: the debugger now understands packages and evals -# patch29: scripts now run at almost full speed under the debugger -# patch29: more variables are settable from debugger -# -# Revision 3.0.1.3 90/08/09 04:00:58 lwall -# patch19: debugger now allows continuation lines -# patch19: debugger can now dump lists of variables -# patch19: debugger can now add aliases easily from prompt -# -# Revision 3.0.1.2 90/03/12 16:39:39 lwall -# patch13: perl -d didn't format stack traces of *foo right -# patch13: perl -d wiped out scalar return values of subroutines -# -# Revision 3.0.1.1 89/10/26 23:14:02 lwall -# patch1: RCS expanded an unintended $Header in lib/perldb.pl -# -# Revision 3.0 89/10/18 15:19:46 lwall -# 3.0 baseline -# -# Revision 2.0 88/06/05 00:09:45 root -# Baseline version 2.0. -# -# open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout @@ -5,872 +5,978 @@ #ifdef EMBED /* globals we need to hide from the world */ -#define No perl_No -#define Sv perl_Sv -#define Xpv perl_Xpv -#define Yes perl_Yes -#define additem perl_additem -#define an perl_an -#define buf perl_buf -#define bufend perl_bufend -#define bufptr perl_bufptr -#define check perl_check -#define coeff perl_coeff -#define compiling perl_compiling -#define comppad perl_comppad -#define comppad_name perl_comppad_name -#define comppad_name_fill perl_comppad_name_fill -#define cop_seqmax perl_cop_seqmax -#define cryptseen perl_cryptseen -#define cshlen perl_cshlen -#define cshname perl_cshname -#define curinterp perl_curinterp -#define curpad perl_curpad -#define dc perl_dc -#define di perl_di -#define ds perl_ds -#define egid perl_egid -#define error_count perl_error_count -#define euid perl_euid -#define evalseq perl_evalseq -#define evstr perl_evstr -#define expect perl_expect -#define expectterm perl_expectterm -#define fold perl_fold -#define freq perl_freq -#define gid perl_gid -#define hexdigit perl_hexdigit -#define hints perl_hints -#define in_my perl_in_my -#define know_next perl_know_next -#define last_lop perl_last_lop -#define last_lop_op perl_last_lop_op -#define last_uni perl_last_uni -#define linestr perl_linestr -#define markstack perl_markstack -#define markstack_max perl_markstack_max -#define markstack_ptr perl_markstack_ptr -#define max_intro_pending perl_max_intro_pending -#define min_intro_pending perl_min_intro_pending -#define multi_close perl_multi_close -#define multi_end perl_multi_end -#define multi_open perl_multi_open -#define multi_start perl_multi_start -#define na perl_na -#define nexttype perl_nexttype -#define nextval perl_nextval -#define no_aelem perl_no_aelem -#define no_dir_func perl_no_dir_func -#define no_func perl_no_func -#define no_helem perl_no_helem -#define no_mem perl_no_mem -#define no_modify perl_no_modify -#define no_security perl_no_security -#define no_sock_func perl_no_sock_func -#define no_usym perl_no_usym -#define nointrp perl_nointrp -#define nomem perl_nomem -#define nomemok perl_nomemok -#define oldbufptr perl_oldbufptr -#define oldoldbufptr perl_oldoldbufptr -#define op perl_op -#define op_name perl_op_name -#define op_seqmax perl_op_seqmax -#define opargs perl_opargs -#define origalen perl_origalen -#define origenviron perl_origenviron -#define padix perl_padix -#define patleave perl_patleave -#define ppaddr perl_ppaddr -#define rcsid perl_rcsid -#define reall_srchlen perl_reall_srchlen -#define regarglen perl_regarglen -#define regbol perl_regbol -#define regcode perl_regcode -#define regdummy perl_regdummy -#define regendp perl_regendp -#define regeol perl_regeol -#define regfold perl_regfold -#define reginput perl_reginput -#define reglastparen perl_reglastparen -#define regmyendp perl_regmyendp -#define regmyp_size perl_regmyp_size -#define regmystartp perl_regmystartp -#define regnarrate perl_regnarrate -#define regnpar perl_regnpar -#define regparse perl_regparse -#define regprecomp perl_regprecomp -#define regprev perl_regprev -#define regsawback perl_regsawback -#define regsawbracket perl_regsawbracket -#define regsize perl_regsize -#define regstartp perl_regstartp -#define regtill perl_regtill -#define regxend perl_regxend -#define retstack perl_retstack -#define retstack_ix perl_retstack_ix -#define retstack_max perl_retstack_max -#define rsfp perl_rsfp -#define savestack perl_savestack -#define savestack_ix perl_savestack_ix -#define savestack_max perl_savestack_max -#define saw_return perl_saw_return -#define scopestack perl_scopestack -#define scopestack_ix perl_scopestack_ix -#define scopestack_max perl_scopestack_max -#define scrgv perl_scrgv -#define sig_name perl_sig_name -#define simple perl_simple -#define stack_base perl_stack_base -#define stack_max perl_stack_max -#define stack_sp perl_stack_sp -#define statbuf perl_statbuf -#define sub_generation perl_sub_generation -#define subline perl_subline -#define subname perl_subname -#define sv_no perl_sv_no -#define sv_undef perl_sv_undef -#define sv_yes perl_sv_yes -#define thisexpr perl_thisexpr -#define timesbuf perl_timesbuf -#define tokenbuf perl_tokenbuf -#define uid perl_uid -#define varies perl_varies -#define vert perl_vert -#define vtbl_arylen perl_vtbl_arylen -#define vtbl_bm perl_vtbl_bm -#define vtbl_dbline perl_vtbl_dbline -#define vtbl_env perl_vtbl_env -#define vtbl_envelem perl_vtbl_envelem -#define vtbl_glob perl_vtbl_glob -#define vtbl_isa perl_vtbl_isa -#define vtbl_isaelem perl_vtbl_isaelem -#define vtbl_mglob perl_vtbl_mglob -#define vtbl_pack perl_vtbl_pack -#define vtbl_packelem perl_vtbl_packelem -#define vtbl_sig perl_vtbl_sig -#define vtbl_sigelem perl_vtbl_sigelem -#define vtbl_substr perl_vtbl_substr -#define vtbl_sv perl_vtbl_sv -#define vtbl_taint perl_vtbl_taint -#define vtbl_uvar perl_vtbl_uvar -#define vtbl_vec perl_vtbl_vec -#define warn_nl perl_warn_nl -#define warn_nosemi perl_warn_nosemi -#define warn_reserved perl_warn_reserved -#define watchaddr perl_watchaddr -#define watchok perl_watchok -#define yychar perl_yychar -#define yycheck perl_yycheck -#define yydebug perl_yydebug -#define yydefred perl_yydefred -#define yydgoto perl_yydgoto -#define yyerrflag perl_yyerrflag -#define yygindex perl_yygindex -#define yylen perl_yylen -#define yylhs perl_yylhs -#define yylval perl_yylval -#define yyname perl_yyname -#define yynerrs perl_yynerrs -#define yyrindex perl_yyrindex -#define yyrule perl_yyrule -#define yysindex perl_yysindex -#define yytable perl_yytable -#define yyval perl_yyval -#define append_elem perl_append_elem -#define append_list perl_append_list -#define apply perl_apply -#define av_clear perl_av_clear -#define av_fake perl_av_fake -#define av_fetch perl_av_fetch -#define av_fill perl_av_fill -#define av_len perl_av_len -#define av_make perl_av_make -#define av_pop perl_av_pop -#define av_popnulls perl_av_popnulls -#define av_push perl_av_push -#define av_shift perl_av_shift -#define av_store perl_av_store -#define av_undef perl_av_undef -#define av_unshift perl_av_unshift -#define bind_match perl_bind_match -#define block_head perl_block_head -#define calllist perl_calllist -#define cando perl_cando -#define check_uni perl_check_uni -#define checkcomma perl_checkcomma -#define ck_aelem perl_ck_aelem -#define ck_chop perl_ck_chop -#define ck_concat perl_ck_concat -#define ck_eof perl_ck_eof -#define ck_eval perl_ck_eval -#define ck_exec perl_ck_exec -#define ck_formline perl_ck_formline -#define ck_ftst perl_ck_ftst -#define ck_fun perl_ck_fun -#define ck_glob perl_ck_glob -#define ck_grep perl_ck_grep -#define ck_gvconst perl_ck_gvconst -#define ck_index perl_ck_index -#define ck_lengthconst perl_ck_lengthconst -#define ck_lfun perl_ck_lfun -#define ck_listiob perl_ck_listiob -#define ck_match perl_ck_match -#define ck_null perl_ck_null -#define ck_repeat perl_ck_repeat -#define ck_retarget perl_ck_retarget -#define ck_rvconst perl_ck_rvconst -#define ck_select perl_ck_select -#define ck_shift perl_ck_shift -#define ck_sort perl_ck_sort -#define ck_split perl_ck_split -#define ck_subr perl_ck_subr -#define ck_trunc perl_ck_trunc -#define convert perl_convert -#define cpy7bit perl_cpy7bit -#define cpytill perl_cpytill -#define croak perl_croak -#define cv_undef perl_cv_undef -#define cxinc perl_cxinc -#define deb perl_deb -#define deb_growlevel perl_deb_growlevel -#define debop perl_debop -#define debstack perl_debstack -#define debstackptrs perl_debstackptrs -#define die perl_die -#define die_where perl_die_where -#define do_aexec perl_do_aexec -#define do_chop perl_do_chop -#define do_close perl_do_close -#define do_ctl perl_do_ctl -#define do_eof perl_do_eof -#define do_exec perl_do_exec -#define do_execfree perl_do_execfree -#define do_ipcctl perl_do_ipcctl -#define do_ipcget perl_do_ipcget -#define do_join perl_do_join -#define do_kv perl_do_kv -#define do_msgrcv perl_do_msgrcv -#define do_msgsnd perl_do_msgsnd -#define do_open perl_do_open -#define do_pipe perl_do_pipe -#define do_print perl_do_print -#define do_readline perl_do_readline -#define do_seek perl_do_seek -#define do_semop perl_do_semop -#define do_shmio perl_do_shmio -#define do_sprintf perl_do_sprintf -#define do_tell perl_do_tell -#define do_trans perl_do_trans -#define do_vecset perl_do_vecset -#define do_vop perl_do_vop -#define doeval perl_doeval -#define dofindlabel perl_dofindlabel -#define dopoptoeval perl_dopoptoeval -#define dump_all perl_dump_all -#define dump_eval perl_dump_eval -#define dump_gv perl_dump_gv -#define dump_op perl_dump_op -#define dump_packsubs perl_dump_packsubs -#define dump_pm perl_dump_pm -#define dump_sub perl_dump_sub -#define fbm_compile perl_fbm_compile -#define fbm_instr perl_fbm_instr -#define fetch_gv perl_fetch_gv -#define fetch_io perl_fetch_io -#define fetch_stash perl_fetch_stash -#define fold_constants perl_fold_constants -#define force_ident perl_force_ident -#define force_next perl_force_next -#define force_word perl_force_word -#define free_tmps perl_free_tmps -#define gen_constant_list perl_gen_constant_list -#define getgimme perl_getgimme -#define gp_free perl_gp_free -#define gp_ref perl_gp_ref -#define gv_AVadd perl_gv_AVadd -#define gv_HVadd perl_gv_HVadd -#define gv_check perl_gv_check -#define gv_efullname perl_gv_efullname -#define gv_fetchfile perl_gv_fetchfile -#define gv_fetchmeth perl_gv_fetchmeth -#define gv_fetchmethod perl_gv_fetchmethod -#define gv_fetchpv perl_gv_fetchpv -#define gv_fullname perl_gv_fullname -#define gv_init perl_gv_init -#define he_delayfree perl_he_delayfree -#define he_free perl_he_free -#define hint perl_hint -#define hoistmust perl_hoistmust -#define hv_clear perl_hv_clear -#define hv_delete perl_hv_delete -#define hv_fetch perl_hv_fetch -#define hv_iterinit perl_hv_iterinit -#define hv_iterkey perl_hv_iterkey -#define hv_iternext perl_hv_iternext -#define hv_iterval perl_hv_iterval -#define hv_magic perl_hv_magic -#define hv_store perl_hv_store -#define hv_undef perl_hv_undef -#define ibcmp perl_ibcmp -#define ingroup perl_ingroup -#define instr perl_instr -#define intuit_more perl_intuit_more -#define invert perl_invert -#define jmaybe perl_jmaybe -#define keyword perl_keyword -#define leave_scope perl_leave_scope -#define lex_end perl_lex_end -#define lex_start perl_lex_start -#define linklist perl_linklist -#define list perl_list -#define listkids perl_listkids -#define localize perl_localize -#define looks_like_number perl_looks_like_number -#define magic_clearpack perl_magic_clearpack -#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_gettaint perl_magic_gettaint -#define magic_getuvar perl_magic_getuvar -#define magic_len perl_magic_len -#define magic_nextpack perl_magic_nextpack -#define magic_set perl_magic_set -#define magic_setarylen perl_magic_setarylen -#define magic_setbm perl_magic_setbm -#define magic_setdbline perl_magic_setdbline -#define magic_setenv perl_magic_setenv -#define magic_setglob perl_magic_setglob -#define magic_setisa perl_magic_setisa -#define magic_setmglob perl_magic_setmglob -#define magic_setpack perl_magic_setpack -#define magic_setsig perl_magic_setsig -#define magic_setsubstr perl_magic_setsubstr -#define magic_settaint perl_magic_settaint -#define magic_setuvar perl_magic_setuvar -#define magic_setvec perl_magic_setvec -#define magicname perl_magicname -#define mess perl_mess -#define mg_clear perl_mg_clear -#define mg_copy perl_mg_copy -#define mg_find perl_mg_find -#define mg_free perl_mg_free -#define mg_get perl_mg_get -#define mg_len perl_mg_len -#define mg_magical perl_mg_magical -#define mg_set perl_mg_set -#define mod perl_mod -#define modkids perl_modkids -#define moreswitches perl_moreswitches -#define my perl_my -#define my_exit perl_my_exit -#define my_lstat perl_my_lstat -#define my_pclose perl_my_pclose -#define my_popen perl_my_popen -#define my_setenv perl_my_setenv -#define my_stat perl_my_stat -#define my_unexec perl_my_unexec -#define newANONHASH perl_newANONHASH -#define newANONLIST perl_newANONLIST -#define newASSIGNOP perl_newASSIGNOP -#define newAV perl_newAV -#define newAVREF perl_newAVREF -#define newBINOP perl_newBINOP -#define newCONDOP perl_newCONDOP -#define newCVOP perl_newCVOP -#define newCVREF perl_newCVREF -#define newFORM perl_newFORM -#define newFOROP perl_newFOROP -#define newGVOP perl_newGVOP -#define newGVREF perl_newGVREF -#define newGVgen perl_newGVgen -#define newHV perl_newHV -#define newHVREF perl_newHVREF -#define newIO perl_newIO -#define newLISTOP perl_newLISTOP -#define newLOGOP perl_newLOGOP -#define newLOOPEX perl_newLOOPEX -#define newLOOPOP perl_newLOOPOP -#define newMETHOD perl_newMETHOD -#define newNULLLIST perl_newNULLLIST -#define newOP perl_newOP -#define newPMOP perl_newPMOP -#define newPVOP perl_newPVOP -#define newRANGE perl_newRANGE -#define newSLICEOP perl_newSLICEOP -#define newSTATEOP perl_newSTATEOP -#define newSUB perl_newSUB -#define newSV perl_newSV -#define newSVOP perl_newSVOP -#define newSVREF perl_newSVREF -#define newSViv perl_newSViv -#define newSVnv perl_newSVnv -#define newSVpv perl_newSVpv -#define newSVsv perl_newSVsv -#define newUNOP perl_newUNOP -#define newWHILEOP perl_newWHILEOP -#define newXSUB perl_newXSUB -#define nextargv perl_nextargv -#define ninstr perl_ninstr -#define no_fh_allowed perl_no_fh_allowed -#define no_op perl_no_op -#define nsavestr perl_nsavestr -#define oopsAV perl_oopsAV -#define oopsCV perl_oopsCV -#define oopsHV perl_oopsHV -#define op_free perl_op_free -#define package perl_package -#define pad_alloc perl_pad_alloc -#define pad_allocmy perl_pad_allocmy -#define pad_findmy perl_pad_findmy -#define pad_free perl_pad_free -#define pad_leavemy perl_pad_leavemy -#define pad_reset perl_pad_reset -#define pad_sv perl_pad_sv -#define pad_swipe perl_pad_swipe -#define peep perl_peep -#define pidgone perl_pidgone -#define pmruntime perl_pmruntime -#define pmtrans perl_pmtrans -#define pop_return perl_pop_return -#define pop_scope perl_pop_scope -#define pp_aassign perl_pp_aassign -#define pp_accept perl_pp_accept -#define pp_add perl_pp_add -#define pp_aelem perl_pp_aelem -#define pp_aelemfast perl_pp_aelemfast -#define pp_alarm perl_pp_alarm -#define pp_and perl_pp_and -#define pp_andassign perl_pp_andassign -#define pp_anonhash perl_pp_anonhash -#define pp_anonlist perl_pp_anonlist -#define pp_aslice perl_pp_aslice -#define pp_atan2 perl_pp_atan2 -#define pp_av2arylen perl_pp_av2arylen -#define pp_backtick perl_pp_backtick -#define pp_bind perl_pp_bind -#define pp_binmode perl_pp_binmode -#define pp_bit_and perl_pp_bit_and -#define pp_bit_or perl_pp_bit_or -#define pp_bless perl_pp_bless -#define pp_caller perl_pp_caller -#define pp_chdir perl_pp_chdir -#define pp_chmod perl_pp_chmod -#define pp_chop perl_pp_chop -#define pp_chown perl_pp_chown -#define pp_chroot perl_pp_chroot -#define pp_close perl_pp_close -#define pp_closedir perl_pp_closedir -#define pp_complement perl_pp_complement -#define pp_concat perl_pp_concat -#define pp_cond_expr perl_pp_cond_expr -#define pp_connect perl_pp_connect -#define pp_const perl_pp_const -#define pp_cos perl_pp_cos -#define pp_crypt perl_pp_crypt -#define pp_cswitch perl_pp_cswitch -#define pp_dbmclose perl_pp_dbmclose -#define pp_dbmopen perl_pp_dbmopen -#define pp_dbstate perl_pp_dbstate -#define pp_defined perl_pp_defined -#define pp_delete perl_pp_delete -#define pp_die perl_pp_die -#define pp_divide perl_pp_divide -#define pp_dofile perl_pp_dofile -#define pp_done perl_pp_done -#define pp_dump perl_pp_dump -#define pp_each perl_pp_each -#define pp_egrent perl_pp_egrent -#define pp_ehostent perl_pp_ehostent -#define pp_enetent perl_pp_enetent -#define pp_enter perl_pp_enter -#define pp_entereval perl_pp_entereval -#define pp_enteriter perl_pp_enteriter -#define pp_enterloop perl_pp_enterloop -#define pp_entersubr perl_pp_entersubr -#define pp_entertry perl_pp_entertry -#define pp_enterwrite perl_pp_enterwrite -#define pp_eof perl_pp_eof -#define pp_eprotoent perl_pp_eprotoent -#define pp_epwent perl_pp_epwent -#define pp_eq perl_pp_eq -#define pp_eservent perl_pp_eservent -#define pp_evalonce perl_pp_evalonce -#define pp_exec perl_pp_exec -#define pp_exit perl_pp_exit -#define pp_exp perl_pp_exp -#define pp_fcntl perl_pp_fcntl -#define pp_fileno perl_pp_fileno -#define pp_flip perl_pp_flip -#define pp_flock perl_pp_flock -#define pp_flop perl_pp_flop -#define pp_fork perl_pp_fork -#define pp_formline perl_pp_formline -#define pp_ftatime perl_pp_ftatime -#define pp_ftbinary perl_pp_ftbinary -#define pp_ftblk perl_pp_ftblk -#define pp_ftchr perl_pp_ftchr -#define pp_ftctime perl_pp_ftctime -#define pp_ftdir perl_pp_ftdir -#define pp_fteexec perl_pp_fteexec -#define pp_fteowned perl_pp_fteowned -#define pp_fteread perl_pp_fteread -#define pp_ftewrite perl_pp_ftewrite -#define pp_ftfile perl_pp_ftfile -#define pp_ftis perl_pp_ftis -#define pp_ftlink perl_pp_ftlink -#define pp_ftmtime perl_pp_ftmtime -#define pp_ftpipe perl_pp_ftpipe -#define pp_ftrexec perl_pp_ftrexec -#define pp_ftrowned perl_pp_ftrowned -#define pp_ftrread perl_pp_ftrread -#define pp_ftrwrite perl_pp_ftrwrite -#define pp_ftsgid perl_pp_ftsgid -#define pp_ftsize perl_pp_ftsize -#define pp_ftsock perl_pp_ftsock -#define pp_ftsuid perl_pp_ftsuid -#define pp_ftsvtx perl_pp_ftsvtx -#define pp_fttext perl_pp_fttext -#define pp_fttty perl_pp_fttty -#define pp_ftzero perl_pp_ftzero -#define pp_ge perl_pp_ge -#define pp_getc perl_pp_getc -#define pp_getlogin perl_pp_getlogin -#define pp_getpeername perl_pp_getpeername -#define pp_getpgrp perl_pp_getpgrp -#define pp_getppid perl_pp_getppid -#define pp_getpriority perl_pp_getpriority -#define pp_getsockname perl_pp_getsockname -#define pp_ggrent perl_pp_ggrent -#define pp_ggrgid perl_pp_ggrgid -#define pp_ggrnam perl_pp_ggrnam -#define pp_ghbyaddr perl_pp_ghbyaddr -#define pp_ghbyname perl_pp_ghbyname -#define pp_ghostent perl_pp_ghostent -#define pp_glob perl_pp_glob -#define pp_gmtime perl_pp_gmtime -#define pp_gnbyaddr perl_pp_gnbyaddr -#define pp_gnbyname perl_pp_gnbyname -#define pp_gnetent perl_pp_gnetent -#define pp_goto perl_pp_goto -#define pp_gpbyname perl_pp_gpbyname -#define pp_gpbynumber perl_pp_gpbynumber -#define pp_gprotoent perl_pp_gprotoent -#define pp_gpwent perl_pp_gpwent -#define pp_gpwnam perl_pp_gpwnam -#define pp_gpwuid perl_pp_gpwuid -#define pp_grepstart perl_pp_grepstart -#define pp_grepwhile perl_pp_grepwhile -#define pp_gsbyname perl_pp_gsbyname -#define pp_gsbyport perl_pp_gsbyport -#define pp_gservent perl_pp_gservent -#define pp_gsockopt perl_pp_gsockopt -#define pp_gt perl_pp_gt -#define pp_gv perl_pp_gv -#define pp_gvsv perl_pp_gvsv -#define pp_helem perl_pp_helem -#define pp_hex perl_pp_hex -#define pp_hslice perl_pp_hslice -#define pp_index perl_pp_index -#define pp_indread perl_pp_indread -#define pp_int perl_pp_int -#define pp_interp perl_pp_interp -#define pp_ioctl perl_pp_ioctl -#define pp_iter perl_pp_iter -#define pp_join perl_pp_join -#define pp_keys perl_pp_keys -#define pp_kill perl_pp_kill -#define pp_last perl_pp_last -#define pp_lc perl_pp_lc -#define pp_lcfirst perl_pp_lcfirst -#define pp_le perl_pp_le -#define pp_leave perl_pp_leave -#define pp_leaveeval perl_pp_leaveeval -#define pp_leaveloop perl_pp_leaveloop -#define pp_leavesubr perl_pp_leavesubr -#define pp_leavetry perl_pp_leavetry -#define pp_leavewrite perl_pp_leavewrite -#define pp_left_shift perl_pp_left_shift -#define pp_length perl_pp_length -#define pp_lineseq perl_pp_lineseq -#define pp_link perl_pp_link -#define pp_list perl_pp_list -#define pp_listen perl_pp_listen -#define pp_localtime perl_pp_localtime -#define pp_log perl_pp_log -#define pp_lslice perl_pp_lslice -#define pp_lstat perl_pp_lstat -#define pp_lt perl_pp_lt -#define pp_match perl_pp_match -#define pp_method perl_pp_method -#define pp_mkdir perl_pp_mkdir -#define pp_modulo perl_pp_modulo -#define pp_msgctl perl_pp_msgctl -#define pp_msgget perl_pp_msgget -#define pp_msgrcv perl_pp_msgrcv -#define pp_msgsnd perl_pp_msgsnd -#define pp_multiply perl_pp_multiply -#define pp_ncmp perl_pp_ncmp -#define pp_ne perl_pp_ne -#define pp_negate perl_pp_negate -#define pp_next perl_pp_next -#define pp_nextstate perl_pp_nextstate -#define pp_not perl_pp_not -#define pp_nswitch perl_pp_nswitch -#define pp_null perl_pp_null -#define pp_oct perl_pp_oct -#define pp_open perl_pp_open -#define pp_open_dir perl_pp_open_dir -#define pp_or perl_pp_or -#define pp_orassign perl_pp_orassign -#define pp_ord perl_pp_ord -#define pp_pack perl_pp_pack -#define pp_padav perl_pp_padav -#define pp_padhv perl_pp_padhv -#define pp_padsv perl_pp_padsv -#define pp_pipe_op perl_pp_pipe_op -#define pp_pop perl_pp_pop -#define pp_postdec perl_pp_postdec -#define pp_postinc perl_pp_postinc -#define pp_pow perl_pp_pow -#define pp_predec perl_pp_predec -#define pp_preinc perl_pp_preinc -#define pp_print perl_pp_print -#define pp_prtf perl_pp_prtf -#define pp_push perl_pp_push -#define pp_pushmark perl_pp_pushmark -#define pp_pushre perl_pp_pushre -#define pp_rand perl_pp_rand -#define pp_range perl_pp_range -#define pp_rcatline perl_pp_rcatline -#define pp_read perl_pp_read -#define pp_readdir perl_pp_readdir -#define pp_readline perl_pp_readline -#define pp_readlink perl_pp_readlink -#define pp_recv perl_pp_recv -#define pp_redo perl_pp_redo -#define pp_ref perl_pp_ref -#define pp_refgen perl_pp_refgen -#define pp_regcmaybe perl_pp_regcmaybe -#define pp_regcomp perl_pp_regcomp -#define pp_rename perl_pp_rename -#define pp_repeat perl_pp_repeat -#define pp_require perl_pp_require -#define pp_reset perl_pp_reset -#define pp_return perl_pp_return -#define pp_reverse perl_pp_reverse -#define pp_rewinddir perl_pp_rewinddir -#define pp_right_shift perl_pp_right_shift -#define pp_rindex perl_pp_rindex -#define pp_rmdir perl_pp_rmdir -#define pp_rv2av perl_pp_rv2av -#define pp_rv2cv perl_pp_rv2cv -#define pp_rv2gv perl_pp_rv2gv -#define pp_rv2hv perl_pp_rv2hv -#define pp_rv2sv perl_pp_rv2sv -#define pp_sassign perl_pp_sassign -#define pp_scalar perl_pp_scalar -#define pp_schop perl_pp_schop -#define pp_scmp perl_pp_scmp -#define pp_scope perl_pp_scope -#define pp_seek perl_pp_seek -#define pp_seekdir perl_pp_seekdir -#define pp_select perl_pp_select -#define pp_semctl perl_pp_semctl -#define pp_semget perl_pp_semget -#define pp_semop perl_pp_semop -#define pp_send perl_pp_send -#define pp_seq perl_pp_seq -#define pp_setpgrp perl_pp_setpgrp -#define pp_setpriority perl_pp_setpriority -#define pp_sge perl_pp_sge -#define pp_sgrent perl_pp_sgrent -#define pp_sgt perl_pp_sgt -#define pp_shift perl_pp_shift -#define pp_shmctl perl_pp_shmctl -#define pp_shmget perl_pp_shmget -#define pp_shmread perl_pp_shmread -#define pp_shmwrite perl_pp_shmwrite -#define pp_shostent perl_pp_shostent -#define pp_shutdown perl_pp_shutdown -#define pp_sin perl_pp_sin -#define pp_sle perl_pp_sle -#define pp_sleep perl_pp_sleep -#define pp_slt perl_pp_slt -#define pp_sne perl_pp_sne -#define pp_snetent perl_pp_snetent -#define pp_socket perl_pp_socket -#define pp_sockpair perl_pp_sockpair -#define pp_sort perl_pp_sort -#define pp_splice perl_pp_splice -#define pp_split perl_pp_split -#define pp_sprintf perl_pp_sprintf -#define pp_sprotoent perl_pp_sprotoent -#define pp_spwent perl_pp_spwent -#define pp_sqrt perl_pp_sqrt -#define pp_srand perl_pp_srand -#define pp_sselect perl_pp_sselect -#define pp_sservent perl_pp_sservent -#define pp_ssockopt perl_pp_ssockopt -#define pp_stat perl_pp_stat -#define pp_stub perl_pp_stub -#define pp_study perl_pp_study -#define pp_subst perl_pp_subst -#define pp_substcont perl_pp_substcont -#define pp_substr perl_pp_substr -#define pp_subtract perl_pp_subtract -#define pp_sv2len perl_pp_sv2len -#define pp_symlink perl_pp_symlink -#define pp_syscall perl_pp_syscall -#define pp_sysread perl_pp_sysread -#define pp_system perl_pp_system -#define pp_syswrite perl_pp_syswrite -#define pp_tell perl_pp_tell -#define pp_telldir perl_pp_telldir -#define pp_tie perl_pp_tie -#define pp_time perl_pp_time -#define pp_tms perl_pp_tms -#define pp_trans perl_pp_trans -#define pp_truncate perl_pp_truncate -#define pp_uc perl_pp_uc -#define pp_ucfirst perl_pp_ucfirst -#define pp_umask perl_pp_umask -#define pp_undef perl_pp_undef -#define pp_unlink perl_pp_unlink -#define pp_unpack perl_pp_unpack -#define pp_unshift perl_pp_unshift -#define pp_unstack perl_pp_unstack -#define pp_untie perl_pp_untie -#define pp_utime perl_pp_utime -#define pp_values perl_pp_values -#define pp_vec perl_pp_vec -#define pp_wait perl_pp_wait -#define pp_waitpid perl_pp_waitpid -#define pp_wantarray perl_pp_wantarray -#define pp_warn perl_pp_warn -#define pp_xor perl_pp_xor -#define prepend_elem perl_prepend_elem -#define push_return perl_push_return -#define push_scope perl_push_scope -#define q perl_q -#define ref perl_ref -#define refkids perl_refkids -#define regcomp perl_regcomp -#define regdump perl_regdump -#define regexec perl_regexec -#define regfree perl_regfree -#define regnext perl_regnext -#define regprop perl_regprop -#define repeatcpy perl_repeatcpy -#define rninstr perl_rninstr -#define run perl_run -#define save_I32 perl_save_I32 -#define save_aptr perl_save_aptr -#define save_ary perl_save_ary -#define save_clearsv perl_save_clearsv -#define save_delete perl_save_delete -#define save_freeop perl_save_freeop -#define save_freepv perl_save_freepv -#define save_freesv perl_save_freesv -#define save_hash perl_save_hash -#define save_hptr perl_save_hptr -#define save_int perl_save_int -#define save_item perl_save_item -#define save_list perl_save_list -#define save_nogv perl_save_nogv -#define save_scalar perl_save_scalar -#define save_sptr perl_save_sptr -#define save_svref perl_save_svref -#define savestack_grow perl_savestack_grow -#define savestr perl_savestr -#define sawparens perl_sawparens -#define scalar perl_scalar -#define scalarkids perl_scalarkids -#define scalarseq perl_scalarseq -#define scalarvoid perl_scalarvoid -#define scan_const perl_scan_const -#define scan_formline perl_scan_formline -#define scan_heredoc perl_scan_heredoc -#define scan_hex perl_scan_hex -#define scan_ident perl_scan_ident -#define scan_inputsymbol perl_scan_inputsymbol -#define scan_num perl_scan_num -#define scan_oct perl_scan_oct -#define scan_pat perl_scan_pat -#define scan_prefix perl_scan_prefix -#define scan_str perl_scan_str -#define scan_subst perl_scan_subst -#define scan_trans perl_scan_trans -#define scan_word perl_scan_word -#define scope perl_scope -#define screaminstr perl_screaminstr -#define setenv_getix perl_setenv_getix -#define skipspace perl_skipspace -#define start_subparse perl_start_subparse -#define sublex_done perl_sublex_done -#define sublex_start perl_sublex_start -#define sv_2bool perl_sv_2bool -#define sv_2cv perl_sv_2cv -#define sv_2iv perl_sv_2iv -#define sv_2mortal perl_sv_2mortal -#define sv_2nv perl_sv_2nv -#define sv_2pv perl_sv_2pv -#define sv_backoff perl_sv_backoff -#define sv_catpv perl_sv_catpv -#define sv_catpvn perl_sv_catpvn -#define sv_catsv perl_sv_catsv -#define sv_chop perl_sv_chop -#define sv_clean_all perl_sv_clean_all -#define sv_clean_magic perl_sv_clean_magic -#define sv_clean_refs perl_sv_clean_refs -#define sv_clear perl_sv_clear -#define sv_cmp perl_sv_cmp -#define sv_dec perl_sv_dec -#define sv_dump perl_sv_dump -#define sv_eq perl_sv_eq -#define sv_free perl_sv_free -#define sv_gets perl_sv_gets -#define sv_grow perl_sv_grow -#define sv_inc perl_sv_inc -#define sv_insert perl_sv_insert -#define sv_isa perl_sv_isa -#define sv_len perl_sv_len -#define sv_magic perl_sv_magic -#define sv_mortalcopy perl_sv_mortalcopy -#define sv_newmortal perl_sv_newmortal -#define sv_peek perl_sv_peek -#define sv_ref perl_sv_ref -#define sv_replace perl_sv_replace -#define sv_report_used perl_sv_report_used -#define sv_reset perl_sv_reset -#define sv_setiv perl_sv_setiv -#define sv_setnv perl_sv_setnv -#define sv_setptrobj perl_sv_setptrobj -#define sv_setpv perl_sv_setpv -#define sv_setpvn perl_sv_setpvn -#define sv_setsv perl_sv_setsv -#define sv_unmagic perl_sv_unmagic -#define sv_upgrade perl_sv_upgrade -#define sv_usepvn perl_sv_usepvn -#define taint_env perl_taint_env -#define taint_not perl_taint_not -#define taint_proper perl_taint_proper -#define too_few_arguments perl_too_few_arguments -#define too_many_arguments perl_too_many_arguments -#define wait4pid perl_wait4pid -#define warn perl_warn -#define watch perl_watch -#define whichsig perl_whichsig -#define xiv_root perl_xiv_root -#define xnv_root perl_xnv_root -#define xpv_root perl_xpv_root -#define xrv_root perl_xrv_root -#define yyerror perl_yyerror -#define yyerror perl_yyerror -#define yylex perl_yylex -#define yyparse perl_yyparse -#define yywarn perl_yywarn +#define AMG_names Perl_AMG_names +#define No Perl_No +#define Sv Perl_Sv +#define Xpv Perl_Xpv +#define Yes Perl_Yes +#define abs_amg Perl_abs_amg +#define add_amg Perl_add_amg +#define add_ass_amg Perl_add_ass_amg +#define additem Perl_additem +#define amagic_generation Perl_amagic_generation +#define an Perl_an +#define atan2_amg Perl_atan2_amg +#define autoboot_preamble Perl_autoboot_preamble +#define band_amg Perl_band_amg +#define bool__amg Perl_bool__amg +#define bor_amg Perl_bor_amg +#define buf Perl_buf +#define bufend Perl_bufend +#define bufptr Perl_bufptr +#define bxor_amg Perl_bxor_amg +#define check Perl_check +#define coeff Perl_coeff +#define compiling Perl_compiling +#define compl_amg Perl_compl_amg +#define comppad Perl_comppad +#define comppad_name Perl_comppad_name +#define comppad_name_fill Perl_comppad_name_fill +#define concat_amg Perl_concat_amg +#define concat_ass_amg Perl_concat_ass_amg +#define cop_seqmax Perl_cop_seqmax +#define cos_amg Perl_cos_amg +#define cryptseen Perl_cryptseen +#define cryptswitch_add Perl_cryptswitch_add +#define cshlen Perl_cshlen +#define cshname Perl_cshname +#define curcop Perl_curcop +#define curinterp Perl_curinterp +#define curpad Perl_curpad +#define dc Perl_dc +#define dec_amg Perl_dec_amg +#define di Perl_di +#define div_amg Perl_div_amg +#define div_ass_amg Perl_div_ass_amg +#define ds Perl_ds +#define egid Perl_egid +#define envgv Perl_envgv +#define eq_amg Perl_eq_amg +#define error_count Perl_error_count +#define euid Perl_euid +#define evalseq Perl_evalseq +#define exp_amg Perl_exp_amg +#define expect Perl_expect +#define expectterm Perl_expectterm +#define fallback_amg Perl_fallback_amg +#define fold Perl_fold +#define freq Perl_freq +#define ge_amg Perl_ge_amg +#define gid Perl_gid +#define gt_amg Perl_gt_amg +#define hexdigit Perl_hexdigit +#define hints Perl_hints +#define in_my Perl_in_my +#define inc_amg Perl_inc_amg +#define know_next Perl_know_next +#define last_lop Perl_last_lop +#define last_lop_op Perl_last_lop_op +#define last_uni Perl_last_uni +#define le_amg Perl_le_amg +#define lex_state Perl_lex_state +#define lex_defer Perl_lex_defer +#define lex_expect Perl_lex_expect +#define lex_brackets Perl_lex_brackets +#define lex_formbrack Perl_lex_formbrack +#define lex_fakebrack Perl_lex_fakebrack +#define lex_casemods Perl_lex_casemods +#define lex_dojoin Perl_lex_dojoin +#define lex_starts Perl_lex_starts +#define lex_stuff Perl_lex_stuff +#define lex_repl Perl_lex_repl +#define lex_op Perl_lex_op +#define lex_inpat Perl_lex_inpat +#define lex_inwhat Perl_lex_inwhat +#define lex_brackstack Perl_lex_brackstack +#define lex_casestack Perl_lex_casestack +#define linestr Perl_linestr +#define log_amg Perl_log_amg +#define lshift_amg Perl_lshift_amg +#define lshift_ass_amg Perl_lshift_ass_amg +#define lt_amg Perl_lt_amg +#define markstack Perl_markstack +#define markstack_max Perl_markstack_max +#define markstack_ptr Perl_markstack_ptr +#define max_intro_pending Perl_max_intro_pending +#define min_intro_pending Perl_min_intro_pending +#define mod_amg Perl_mod_amg +#define mod_ass_amg Perl_mod_ass_amg +#define mult_amg Perl_mult_amg +#define mult_ass_amg Perl_mult_ass_amg +#define multi_close Perl_multi_close +#define multi_end Perl_multi_end +#define multi_open Perl_multi_open +#define multi_start Perl_multi_start +#define na Perl_na +#define ncmp_amg Perl_ncmp_amg +#define nextval Perl_nextval +#define nexttype Perl_nexttype +#define nexttoke Perl_nexttoke +#define ne_amg Perl_ne_amg +#define neg_amg Perl_neg_amg +#define nexttype Perl_nexttype +#define nextval Perl_nextval +#define no_aelem Perl_no_aelem +#define no_dir_func Perl_no_dir_func +#define no_func Perl_no_func +#define no_helem Perl_no_helem +#define no_mem Perl_no_mem +#define no_modify Perl_no_modify +#define no_security Perl_no_security +#define no_sock_func Perl_no_sock_func +#define no_usym Perl_no_usym +#define nointrp Perl_nointrp +#define nomem Perl_nomem +#define nomemok Perl_nomemok +#define nomethod_amg Perl_nomethod_amg +#define not_amg Perl_not_amg +#define numer_amg Perl_numer_amg +#define oldbufptr Perl_oldbufptr +#define oldoldbufptr Perl_oldoldbufptr +#define op Perl_op +#define op_name Perl_op_name +#define op_seqmax Perl_op_seqmax +#define opargs Perl_opargs +#define origalen Perl_origalen +#define origenviron Perl_origenviron +#define padix Perl_padix +#define patleave Perl_patleave +#define pow_amg Perl_pow_amg +#define pow_ass_amg Perl_pow_ass_amg +#define ppaddr Perl_ppaddr +#define profiledata Perl_profiledata +#define qrt_amg Perl_qrt_amg +#define rcsid Perl_rcsid +#define reall_srchlen Perl_reall_srchlen +#define regarglen Perl_regarglen +#define regbol Perl_regbol +#define regcode Perl_regcode +#define regdummy Perl_regdummy +#define regendp Perl_regendp +#define regeol Perl_regeol +#define regfold Perl_regfold +#define reginput Perl_reginput +#define reglastparen Perl_reglastparen +#define regmyendp Perl_regmyendp +#define regmyp_size Perl_regmyp_size +#define regmystartp Perl_regmystartp +#define regnarrate Perl_regnarrate +#define regnaughty Perl_regnaughty +#define regnpar Perl_regnpar +#define regparse Perl_regparse +#define regprecomp Perl_regprecomp +#define regprev Perl_regprev +#define regsawback Perl_regsawback +#define regsize Perl_regsize +#define regstartp Perl_regstartp +#define regtill Perl_regtill +#define regxend Perl_regxend +#define repeat_amg Perl_repeat_amg +#define repeat_ass_amg Perl_repeat_ass_amg +#define retstack Perl_retstack +#define retstack_ix Perl_retstack_ix +#define retstack_max Perl_retstack_max +#define rsfp Perl_rsfp +#define rshift_amg Perl_rshift_amg +#define rshift_ass_amg Perl_rshift_ass_amg +#define savestack Perl_savestack +#define savestack_ix Perl_savestack_ix +#define savestack_max Perl_savestack_max +#define saw_return Perl_saw_return +#define scmp_amg Perl_scmp_amg +#define scopestack Perl_scopestack +#define scopestack_ix Perl_scopestack_ix +#define scopestack_max Perl_scopestack_max +#define scrgv Perl_scrgv +#define seq_amg Perl_seq_amg +#define sge_amg Perl_sge_amg +#define sgt_amg Perl_sgt_amg +#define sig_name Perl_sig_name +#define siggv Perl_siggv +#define sighandler Perl_sighandler +#define simple Perl_simple +#define sin_amg Perl_sin_amg +#define sle_amg Perl_sle_amg +#define slt_amg Perl_slt_amg +#define sne_amg Perl_sne_amg +#define stack Perl_stack +#define stack_base Perl_stack_base +#define stack_max Perl_stack_max +#define stack_sp Perl_stack_sp +#define statbuf Perl_statbuf +#define string_amg Perl_string_amg +#define sub_generation Perl_sub_generation +#define subline Perl_subline +#define subname Perl_subname +#define subtr_amg Perl_subtr_amg +#define subtr_ass_amg Perl_subtr_ass_amg +#define sv_no Perl_sv_no +#define sv_undef Perl_sv_undef +#define sv_yes Perl_sv_yes +#define tainting Perl_tainting +#define thisexpr Perl_thisexpr +#define timesbuf Perl_timesbuf +#define tokenbuf Perl_tokenbuf +#define uid Perl_uid +#define varies Perl_varies +#define vert Perl_vert +#define vtbl_amagic Perl_vtbl_amagic +#define vtbl_amagicelem Perl_vtbl_amagicelem +#define vtbl_arylen Perl_vtbl_arylen +#define vtbl_bm Perl_vtbl_bm +#define vtbl_dbline Perl_vtbl_dbline +#define vtbl_env Perl_vtbl_env +#define vtbl_envelem Perl_vtbl_envelem +#define vtbl_glob Perl_vtbl_glob +#define vtbl_isa Perl_vtbl_isa +#define vtbl_isaelem Perl_vtbl_isaelem +#define vtbl_mglob Perl_vtbl_mglob +#define vtbl_pack Perl_vtbl_pack +#define vtbl_packelem Perl_vtbl_packelem +#define vtbl_pos Perl_vtbl_pos +#define vtbl_sig Perl_vtbl_sig +#define vtbl_sigelem Perl_vtbl_sigelem +#define vtbl_substr Perl_vtbl_substr +#define vtbl_sv Perl_vtbl_sv +#define vtbl_taint Perl_vtbl_taint +#define vtbl_uvar Perl_vtbl_uvar +#define vtbl_vec Perl_vtbl_vec +#define warn_nl Perl_warn_nl +#define warn_nosemi Perl_warn_nosemi +#define warn_reserved Perl_warn_reserved +#define watchaddr Perl_watchaddr +#define watchok Perl_watchok +#define yychar Perl_yychar +#define yycheck Perl_yycheck +#define yydebug Perl_yydebug +#define yydefred Perl_yydefred +#define yydgoto Perl_yydgoto +#define yyerrflag Perl_yyerrflag +#define yygindex Perl_yygindex +#define yylen Perl_yylen +#define yylhs Perl_yylhs +#define yylval Perl_yylval +#define yyname Perl_yyname +#define yynerrs Perl_yynerrs +#define yyrindex Perl_yyrindex +#define yyrule Perl_yyrule +#define yysindex Perl_yysindex +#define yytable Perl_yytable +#define yyval Perl_yyval +#define append_elem Perl_append_elem +#define append_list Perl_append_list +#define apply Perl_apply +#define av_clear Perl_av_clear +#define av_fake Perl_av_fake +#define av_fetch Perl_av_fetch +#define av_fill Perl_av_fill +#define av_len Perl_av_len +#define av_make Perl_av_make +#define av_pop Perl_av_pop +#define av_push Perl_av_push +#define av_shift Perl_av_shift +#define av_store Perl_av_store +#define av_undef Perl_av_undef +#define av_unshift Perl_av_unshift +#define bind_match Perl_bind_match +#define block_end Perl_block_end +#define block_start Perl_block_start +#define calllist Perl_calllist +#define cando Perl_cando +#define check_uni Perl_check_uni +#define checkcomma Perl_checkcomma +#define ck_aelem Perl_ck_aelem +#define ck_concat Perl_ck_concat +#define ck_eof Perl_ck_eof +#define ck_eval Perl_ck_eval +#define ck_exec Perl_ck_exec +#define ck_formline Perl_ck_formline +#define ck_ftst Perl_ck_ftst +#define ck_fun Perl_ck_fun +#define ck_glob Perl_ck_glob +#define ck_grep Perl_ck_grep +#define ck_gvconst Perl_ck_gvconst +#define ck_index Perl_ck_index +#define ck_lengthconst Perl_ck_lengthconst +#define ck_lfun Perl_ck_lfun +#define ck_listiob Perl_ck_listiob +#define ck_match Perl_ck_match +#define ck_null Perl_ck_null +#define ck_repeat Perl_ck_repeat +#define ck_retarget Perl_ck_retarget +#define ck_rvconst Perl_ck_rvconst +#define ck_select Perl_ck_select +#define ck_shift Perl_ck_shift +#define ck_sort Perl_ck_sort +#define ck_spair Perl_ck_spair +#define ck_split Perl_ck_split +#define ck_subr Perl_ck_subr +#define ck_trunc Perl_ck_trunc +#define convert Perl_convert +#define cpytill Perl_cpytill +#define croak Perl_croak +#define cv_undef Perl_cv_undef +#define cxinc Perl_cxinc +#define deb Perl_deb +#define deb_growlevel Perl_deb_growlevel +#define debop Perl_debop +#define debstack Perl_debstack +#define debstackptrs Perl_debstackptrs +#define deprecate Perl_deprecate +#define die Perl_die +#define die_where Perl_die_where +#define do_aexec Perl_do_aexec +#define do_chop Perl_do_chop +#define do_close Perl_do_close +#define do_eof Perl_do_eof +#define do_exec Perl_do_exec +#define do_execfree Perl_do_execfree +#define do_ipcctl Perl_do_ipcctl +#define do_ipcget Perl_do_ipcget +#define do_join Perl_do_join +#define do_kv Perl_do_kv +#define do_msgrcv Perl_do_msgrcv +#define do_msgsnd Perl_do_msgsnd +#define do_open Perl_do_open +#define do_pipe Perl_do_pipe +#define do_print Perl_do_print +#define do_readline Perl_do_readline +#define do_chomp Perl_do_chomp +#define do_seek Perl_do_seek +#define do_semop Perl_do_semop +#define do_shmio Perl_do_shmio +#define do_sprintf Perl_do_sprintf +#define do_tell Perl_do_tell +#define do_trans Perl_do_trans +#define do_vecset Perl_do_vecset +#define do_vop Perl_do_vop +#define doeval Perl_doeval +#define dofindlabel Perl_dofindlabel +#define dopoptoeval Perl_dopoptoeval +#define dump_all Perl_dump_all +#define dump_eval Perl_dump_eval +#define dump_gv Perl_dump_gv +#define dump_op Perl_dump_op +#define dump_packsubs Perl_dump_packsubs +#define dump_pm Perl_dump_pm +#define dump_sub Perl_dump_sub +#define fbm_compile Perl_fbm_compile +#define fbm_instr Perl_fbm_instr +#define fetch_gv Perl_fetch_gv +#define fetch_io Perl_fetch_io +#define fold_constants Perl_fold_constants +#define force_ident Perl_force_ident +#define force_next Perl_force_next +#define force_word Perl_force_word +#define free_tmps Perl_free_tmps +#define gen_constant_list Perl_gen_constant_list +#define gp_free Perl_gp_free +#define gp_ref Perl_gp_ref +#define gv_AVadd Perl_gv_AVadd +#define gv_HVadd Perl_gv_HVadd +#define gv_check Perl_gv_check +#define gv_efullname Perl_gv_efullname +#define gv_fetchfile Perl_gv_fetchfile +#define gv_fetchmeth Perl_gv_fetchmeth +#define gv_fetchmethod Perl_gv_fetchmethod +#define gv_fetchpv Perl_gv_fetchpv +#define gv_fullname Perl_gv_fullname +#define gv_init Perl_gv_init +#define gv_stashpv Perl_gv_stashpv +#define gv_stashsv Perl_gv_stashsv +#define he_delayfree Perl_he_delayfree +#define he_free Perl_he_free +#define hoistmust Perl_hoistmust +#define hv_clear Perl_hv_clear +#define hv_delete Perl_hv_delete +#define hv_exists Perl_hv_exists +#define hv_fetch Perl_hv_fetch +#define hv_stashpv Perl_hv_stashpv +#define hv_iterinit Perl_hv_iterinit +#define hv_iterkey Perl_hv_iterkey +#define hv_iternext Perl_hv_iternext +#define hv_iterval Perl_hv_iterval +#define hv_magic Perl_hv_magic +#define hv_store Perl_hv_store +#define hv_undef Perl_hv_undef +#define ibcmp Perl_ibcmp +#define ingroup Perl_ingroup +#define instr Perl_instr +#define intuit_more Perl_intuit_more +#define invert Perl_invert +#define jmaybe Perl_jmaybe +#define keyword Perl_keyword +#define leave_scope Perl_leave_scope +#define lex_end Perl_lex_end +#define lex_start Perl_lex_start +#define linklist Perl_linklist +#define list Perl_list +#define listkids Perl_listkids +#define localize Perl_localize +#define looks_like_number Perl_looks_like_number +#define magic_clearpack Perl_magic_clearpack +#define magic_get Perl_magic_get +#define magic_getarylen Perl_magic_getarylen +#define magic_getglob Perl_magic_getglob +#define magic_getpack Perl_magic_getpack +#define magic_getpos Perl_magic_getpos +#define magic_gettaint Perl_magic_gettaint +#define magic_getuvar Perl_magic_getuvar +#define magic_len Perl_magic_len +#define magic_nextpack Perl_magic_nextpack +#define magic_set Perl_magic_set +#define magic_setamagic Perl_magic_setamagic +#define magic_setarylen Perl_magic_setarylen +#define magic_setbm Perl_magic_setbm +#define magic_setdbline Perl_magic_setdbline +#define magic_setenv Perl_magic_setenv +#define magic_setglob Perl_magic_setglob +#define magic_setisa Perl_magic_setisa +#define magic_setmglob Perl_magic_setmglob +#define magic_setpack Perl_magic_setpack +#define magic_setpos Perl_magic_setpos +#define magic_setsig Perl_magic_setsig +#define magic_setsubstr Perl_magic_setsubstr +#define magic_settaint Perl_magic_settaint +#define magic_setuvar Perl_magic_setuvar +#define magic_setvec Perl_magic_setvec +#define magic_wipepack Perl_magic_wipepack +#define magicname Perl_magicname +#define markstack_grow Perl_markstack_grow +#define mess Perl_mess +#define mg_clear Perl_mg_clear +#define mg_copy Perl_mg_copy +#define mg_find Perl_mg_find +#define mg_free Perl_mg_free +#define mg_get Perl_mg_get +#define mg_len Perl_mg_len +#define mg_magical Perl_mg_magical +#define mg_set Perl_mg_set +#define mod Perl_mod +#define modkids Perl_modkids +#define moreswitches Perl_moreswitches +#define my Perl_my +#define my_exit Perl_my_exit +#define my_lstat Perl_my_lstat +#define my_pclose Perl_my_pclose +#define my_popen Perl_my_popen +#define my_setenv Perl_my_setenv +#define my_stat Perl_my_stat +#define my_unexec Perl_my_unexec +#define newANONHASH Perl_newANONHASH +#define newANONLIST Perl_newANONLIST +#define newASSIGNOP Perl_newASSIGNOP +#define newAV Perl_newAV +#define newAVREF Perl_newAVREF +#define newBINOP Perl_newBINOP +#define newCONDOP Perl_newCONDOP +#define newCVOP Perl_newCVOP +#define newCVREF Perl_newCVREF +#define newFORM Perl_newFORM +#define newFOROP Perl_newFOROP +#define newGVOP Perl_newGVOP +#define newGVREF Perl_newGVREF +#define newGVgen Perl_newGVgen +#define newHV Perl_newHV +#define newHVREF Perl_newHVREF +#define newIO Perl_newIO +#define newLISTOP Perl_newLISTOP +#define newLOGOP Perl_newLOGOP +#define newLOOPEX Perl_newLOOPEX +#define newLOOPOP Perl_newLOOPOP +#define newMETHOD Perl_newMETHOD +#define newNULLLIST Perl_newNULLLIST +#define newOP Perl_newOP +#define newPROG Perl_newPROG +#define newPMOP Perl_newPMOP +#define newPVOP Perl_newPVOP +#define newRANGE Perl_newRANGE +#define newRV Perl_newRV +#define newSLICEOP Perl_newSLICEOP +#define newSTATEOP Perl_newSTATEOP +#define newSUB Perl_newSUB +#define newSV Perl_newSV +#define newSVOP Perl_newSVOP +#define newSVREF Perl_newSVREF +#define newSViv Perl_newSViv +#define newSVnv Perl_newSVnv +#define newSVpv Perl_newSVpv +#define newSVsv Perl_newSVsv +#define newUNOP Perl_newUNOP +#define newWHILEOP Perl_newWHILEOP +#define newXSUB Perl_newXSUB +#define newXS Perl_newXS +#define nextargv Perl_nextargv +#define ninstr Perl_ninstr +#define no_fh_allowed Perl_no_fh_allowed +#define no_op Perl_no_op +#define oopsAV Perl_oopsAV +#define oopsCV Perl_oopsCV +#define oopsHV Perl_oopsHV +#define op_free Perl_op_free +#define package Perl_package +#define pad_alloc Perl_pad_alloc +#define pad_allocmy Perl_pad_allocmy +#define pad_findmy Perl_pad_findmy +#define pad_free Perl_pad_free +#define pad_leavemy Perl_pad_leavemy +#define pad_reset Perl_pad_reset +#define pad_sv Perl_pad_sv +#define pad_swipe Perl_pad_swipe +#define peep Perl_peep +#define pidgone Perl_pidgone +#define pmruntime Perl_pmruntime +#define pmtrans Perl_pmtrans +#define pop_return Perl_pop_return +#define pop_scope Perl_pop_scope +#define pp_aassign Perl_pp_aassign +#define pp_accept Perl_pp_accept +#define pp_add Perl_pp_add +#define pp_aelem Perl_pp_aelem +#define pp_aelemfast Perl_pp_aelemfast +#define pp_alarm Perl_pp_alarm +#define pp_and Perl_pp_and +#define pp_andassign Perl_pp_andassign +#define pp_anonhash Perl_pp_anonhash +#define pp_anonlist Perl_pp_anonlist +#define pp_aslice Perl_pp_aslice +#define pp_atan2 Perl_pp_atan2 +#define pp_av2arylen Perl_pp_av2arylen +#define pp_backtick Perl_pp_backtick +#define pp_bind Perl_pp_bind +#define pp_binmode Perl_pp_binmode +#define pp_bit_and Perl_pp_bit_and +#define pp_bit_or Perl_pp_bit_or +#define pp_bless Perl_pp_bless +#define pp_caller Perl_pp_caller +#define pp_chdir Perl_pp_chdir +#define pp_chmod Perl_pp_chmod +#define pp_chop Perl_pp_chop +#define pp_chown Perl_pp_chown +#define pp_chroot Perl_pp_chroot +#define pp_close Perl_pp_close +#define pp_closedir Perl_pp_closedir +#define pp_complement Perl_pp_complement +#define pp_concat Perl_pp_concat +#define pp_cond_expr Perl_pp_cond_expr +#define pp_connect Perl_pp_connect +#define pp_const Perl_pp_const +#define pp_cos Perl_pp_cos +#define pp_crypt Perl_pp_crypt +#define pp_cswitch Perl_pp_cswitch +#define pp_dbmclose Perl_pp_dbmclose +#define pp_dbmopen Perl_pp_dbmopen +#define pp_dbstate Perl_pp_dbstate +#define pp_defined Perl_pp_defined +#define pp_delete Perl_pp_delete +#define pp_die Perl_pp_die +#define pp_divide Perl_pp_divide +#define pp_dofile Perl_pp_dofile +#define pp_dump Perl_pp_dump +#define pp_each Perl_pp_each +#define pp_egrent Perl_pp_egrent +#define pp_ehostent Perl_pp_ehostent +#define pp_enetent Perl_pp_enetent +#define pp_enter Perl_pp_enter +#define pp_entereval Perl_pp_entereval +#define pp_enteriter Perl_pp_enteriter +#define pp_enterloop Perl_pp_enterloop +#define pp_entersub Perl_pp_entersub +#define pp_entersubr Perl_pp_entersubr +#define pp_entertry Perl_pp_entertry +#define pp_enterwrite Perl_pp_enterwrite +#define pp_eof Perl_pp_eof +#define pp_eprotoent Perl_pp_eprotoent +#define pp_epwent Perl_pp_epwent +#define pp_eq Perl_pp_eq +#define pp_eservent Perl_pp_eservent +#define pp_evalonce Perl_pp_evalonce +#define pp_exec Perl_pp_exec +#define pp_exists Perl_pp_exists +#define pp_exit Perl_pp_exit +#define pp_exp Perl_pp_exp +#define pp_fcntl Perl_pp_fcntl +#define pp_fileno Perl_pp_fileno +#define pp_flip Perl_pp_flip +#define pp_flock Perl_pp_flock +#define pp_flop Perl_pp_flop +#define pp_fork Perl_pp_fork +#define pp_formline Perl_pp_formline +#define pp_ftatime Perl_pp_ftatime +#define pp_ftbinary Perl_pp_ftbinary +#define pp_ftblk Perl_pp_ftblk +#define pp_ftchr Perl_pp_ftchr +#define pp_ftctime Perl_pp_ftctime +#define pp_ftdir Perl_pp_ftdir +#define pp_fteexec Perl_pp_fteexec +#define pp_fteowned Perl_pp_fteowned +#define pp_fteread Perl_pp_fteread +#define pp_ftewrite Perl_pp_ftewrite +#define pp_ftfile Perl_pp_ftfile +#define pp_ftis Perl_pp_ftis +#define pp_ftlink Perl_pp_ftlink +#define pp_ftmtime Perl_pp_ftmtime +#define pp_ftpipe Perl_pp_ftpipe +#define pp_ftrexec Perl_pp_ftrexec +#define pp_ftrowned Perl_pp_ftrowned +#define pp_ftrread Perl_pp_ftrread +#define pp_ftrwrite Perl_pp_ftrwrite +#define pp_ftsgid Perl_pp_ftsgid +#define pp_ftsize Perl_pp_ftsize +#define pp_ftsock Perl_pp_ftsock +#define pp_ftsuid Perl_pp_ftsuid +#define pp_ftsvtx Perl_pp_ftsvtx +#define pp_fttext Perl_pp_fttext +#define pp_fttty Perl_pp_fttty +#define pp_ftzero Perl_pp_ftzero +#define pp_ge Perl_pp_ge +#define pp_getc Perl_pp_getc +#define pp_getlogin Perl_pp_getlogin +#define pp_getpeername Perl_pp_getpeername +#define pp_getpgrp Perl_pp_getpgrp +#define pp_getppid Perl_pp_getppid +#define pp_getpriority Perl_pp_getpriority +#define pp_getsockname Perl_pp_getsockname +#define pp_ggrent Perl_pp_ggrent +#define pp_ggrgid Perl_pp_ggrgid +#define pp_ggrnam Perl_pp_ggrnam +#define pp_ghbyaddr Perl_pp_ghbyaddr +#define pp_ghbyname Perl_pp_ghbyname +#define pp_ghostent Perl_pp_ghostent +#define pp_glob Perl_pp_glob +#define pp_gmtime Perl_pp_gmtime +#define pp_gnbyaddr Perl_pp_gnbyaddr +#define pp_gnbyname Perl_pp_gnbyname +#define pp_gnetent Perl_pp_gnetent +#define pp_goto Perl_pp_goto +#define pp_gpbyname Perl_pp_gpbyname +#define pp_gpbynumber Perl_pp_gpbynumber +#define pp_gprotoent Perl_pp_gprotoent +#define pp_gpwent Perl_pp_gpwent +#define pp_gpwnam Perl_pp_gpwnam +#define pp_gpwuid Perl_pp_gpwuid +#define pp_grepstart Perl_pp_grepstart +#define pp_grepwhile Perl_pp_grepwhile +#define pp_gsbyname Perl_pp_gsbyname +#define pp_gsbyport Perl_pp_gsbyport +#define pp_gservent Perl_pp_gservent +#define pp_gsockopt Perl_pp_gsockopt +#define pp_gt Perl_pp_gt +#define pp_gv Perl_pp_gv +#define pp_gvsv Perl_pp_gvsv +#define pp_helem Perl_pp_helem +#define pp_hex Perl_pp_hex +#define pp_hslice Perl_pp_hslice +#define pp_index Perl_pp_index +#define pp_indread Perl_pp_indread +#define pp_int Perl_pp_int +#define pp_interp Perl_pp_interp +#define pp_ioctl Perl_pp_ioctl +#define pp_iter Perl_pp_iter +#define pp_join Perl_pp_join +#define pp_keys Perl_pp_keys +#define pp_kill Perl_pp_kill +#define pp_last Perl_pp_last +#define pp_lc Perl_pp_lc +#define pp_lcfirst Perl_pp_lcfirst +#define pp_le Perl_pp_le +#define pp_leave Perl_pp_leave +#define pp_leaveeval Perl_pp_leaveeval +#define pp_leaveloop Perl_pp_leaveloop +#define pp_leavesub Perl_pp_leavesub +#define pp_leavetry Perl_pp_leavetry +#define pp_leavewrite Perl_pp_leavewrite +#define pp_left_shift Perl_pp_left_shift +#define pp_length Perl_pp_length +#define pp_lineseq Perl_pp_lineseq +#define pp_link Perl_pp_link +#define pp_list Perl_pp_list +#define pp_listen Perl_pp_listen +#define pp_localtime Perl_pp_localtime +#define pp_log Perl_pp_log +#define pp_lslice Perl_pp_lslice +#define pp_lstat Perl_pp_lstat +#define pp_lt Perl_pp_lt +#define pp_map Perl_pp_map +#define pp_match Perl_pp_match +#define pp_method Perl_pp_method +#define pp_mkdir Perl_pp_mkdir +#define pp_modulo Perl_pp_modulo +#define pp_msgctl Perl_pp_msgctl +#define pp_msgget Perl_pp_msgget +#define pp_msgrcv Perl_pp_msgrcv +#define pp_msgsnd Perl_pp_msgsnd +#define pp_multiply Perl_pp_multiply +#define pp_ncmp Perl_pp_ncmp +#define pp_ne Perl_pp_ne +#define pp_negate Perl_pp_negate +#define pp_next Perl_pp_next +#define pp_nextstate Perl_pp_nextstate +#define pp_not Perl_pp_not +#define pp_nswitch Perl_pp_nswitch +#define pp_null Perl_pp_null +#define pp_oct Perl_pp_oct +#define pp_open Perl_pp_open +#define pp_open_dir Perl_pp_open_dir +#define pp_or Perl_pp_or +#define pp_orassign Perl_pp_orassign +#define pp_ord Perl_pp_ord +#define pp_pack Perl_pp_pack +#define pp_padav Perl_pp_padav +#define pp_padhv Perl_pp_padhv +#define pp_padsv Perl_pp_padsv +#define pp_pipe_op Perl_pp_pipe_op +#define pp_pop Perl_pp_pop +#define pp_pos Perl_pp_pos +#define pp_postdec Perl_pp_postdec +#define pp_postinc Perl_pp_postinc +#define pp_pow Perl_pp_pow +#define pp_predec Perl_pp_predec +#define pp_preinc Perl_pp_preinc +#define pp_print Perl_pp_print +#define pp_prtf Perl_pp_prtf +#define pp_push Perl_pp_push +#define pp_pushmark Perl_pp_pushmark +#define pp_pushre Perl_pp_pushre +#define pp_rand Perl_pp_rand +#define pp_range Perl_pp_range +#define pp_rcatline Perl_pp_rcatline +#define pp_read Perl_pp_read +#define pp_readdir Perl_pp_readdir +#define pp_readline Perl_pp_readline +#define pp_readlink Perl_pp_readlink +#define pp_recv Perl_pp_recv +#define pp_redo Perl_pp_redo +#define pp_ref Perl_pp_ref +#define pp_refgen Perl_pp_refgen +#define pp_regcmaybe Perl_pp_regcmaybe +#define pp_regcomp Perl_pp_regcomp +#define pp_rename Perl_pp_rename +#define pp_repeat Perl_pp_repeat +#define pp_require Perl_pp_require +#define pp_reset Perl_pp_reset +#define pp_return Perl_pp_return +#define pp_reverse Perl_pp_reverse +#define pp_rewinddir Perl_pp_rewinddir +#define pp_right_shift Perl_pp_right_shift +#define pp_rindex Perl_pp_rindex +#define pp_rmdir Perl_pp_rmdir +#define pp_rv2av Perl_pp_rv2av +#define pp_rv2cv Perl_pp_rv2cv +#define pp_rv2gv Perl_pp_rv2gv +#define pp_rv2hv Perl_pp_rv2hv +#define pp_rv2sv Perl_pp_rv2sv +#define pp_chomp Perl_pp_chomp +#define pp_sassign Perl_pp_sassign +#define pp_scalar Perl_pp_scalar +#define pp_schop Perl_pp_schop +#define pp_scmp Perl_pp_scmp +#define pp_scope Perl_pp_scope +#define pp_seek Perl_pp_seek +#define pp_seekdir Perl_pp_seekdir +#define pp_select Perl_pp_select +#define pp_semctl Perl_pp_semctl +#define pp_semget Perl_pp_semget +#define pp_semop Perl_pp_semop +#define pp_send Perl_pp_send +#define pp_seq Perl_pp_seq +#define pp_setpgrp Perl_pp_setpgrp +#define pp_setpriority Perl_pp_setpriority +#define pp_sge Perl_pp_sge +#define pp_sgrent Perl_pp_sgrent +#define pp_sgt Perl_pp_sgt +#define pp_shift Perl_pp_shift +#define pp_shmctl Perl_pp_shmctl +#define pp_shmget Perl_pp_shmget +#define pp_shmread Perl_pp_shmread +#define pp_shmwrite Perl_pp_shmwrite +#define pp_shostent Perl_pp_shostent +#define pp_shutdown Perl_pp_shutdown +#define pp_sin Perl_pp_sin +#define pp_sle Perl_pp_sle +#define pp_sleep Perl_pp_sleep +#define pp_slt Perl_pp_slt +#define pp_sne Perl_pp_sne +#define pp_snetent Perl_pp_snetent +#define pp_socket Perl_pp_socket +#define pp_sockpair Perl_pp_sockpair +#define pp_sort Perl_pp_sort +#define pp_splice Perl_pp_splice +#define pp_split Perl_pp_split +#define pp_sprintf Perl_pp_sprintf +#define pp_sprotoent Perl_pp_sprotoent +#define pp_spwent Perl_pp_spwent +#define pp_sqrt Perl_pp_sqrt +#define pp_srand Perl_pp_srand +#define pp_srefgen Perl_pp_srefgen +#define pp_schomp Perl_pp_schomp +#define pp_sselect Perl_pp_sselect +#define pp_sservent Perl_pp_sservent +#define pp_ssockopt Perl_pp_ssockopt +#define pp_stat Perl_pp_stat +#define pp_stub Perl_pp_stub +#define pp_study Perl_pp_study +#define pp_subst Perl_pp_subst +#define pp_substcont Perl_pp_substcont +#define pp_substr Perl_pp_substr +#define pp_subtract Perl_pp_subtract +#define pp_sv2len Perl_pp_sv2len +#define pp_symlink Perl_pp_symlink +#define pp_syscall Perl_pp_syscall +#define pp_sysread Perl_pp_sysread +#define pp_system Perl_pp_system +#define pp_syswrite Perl_pp_syswrite +#define pp_tell Perl_pp_tell +#define pp_telldir Perl_pp_telldir +#define pp_tie Perl_pp_tie +#define pp_time Perl_pp_time +#define pp_tms Perl_pp_tms +#define pp_trans Perl_pp_trans +#define pp_truncate Perl_pp_truncate +#define pp_uc Perl_pp_uc +#define pp_ucfirst Perl_pp_ucfirst +#define pp_umask Perl_pp_umask +#define pp_undef Perl_pp_undef +#define pp_unlink Perl_pp_unlink +#define pp_unpack Perl_pp_unpack +#define pp_unshift Perl_pp_unshift +#define pp_unstack Perl_pp_unstack +#define pp_untie Perl_pp_untie +#define pp_utime Perl_pp_utime +#define pp_values Perl_pp_values +#define pp_vec Perl_pp_vec +#define pp_wait Perl_pp_wait +#define pp_waitpid Perl_pp_waitpid +#define pp_wantarray Perl_pp_wantarray +#define pp_warn Perl_pp_warn +#define pp_xor Perl_pp_xor +#define prepend_elem Perl_prepend_elem +#define push_return Perl_push_return +#define push_scope Perl_push_scope +#define q Perl_q +#define ref Perl_ref +#define refkids Perl_refkids +#define regcomp Perl_regcomp +#define regdump Perl_regdump +#define regexec Perl_regexec +#define regfree Perl_regfree +#define regnext Perl_regnext +#define regprop Perl_regprop +#define repeatcpy Perl_repeatcpy +#define rninstr Perl_rninstr +#define run Perl_run +#define savepv Perl_savepv +#define savepvn Perl_savepvn +#define save_I32 Perl_save_I32 +#define save_aptr Perl_save_aptr +#define save_ary Perl_save_ary +#define save_clearsv Perl_save_clearsv +#define save_delete Perl_save_delete +#define save_freeop Perl_save_freeop +#define save_freepv Perl_save_freepv +#define save_freesv Perl_save_freesv +#define save_hash Perl_save_hash +#define save_hptr Perl_save_hptr +#define save_int Perl_save_int +#define save_item Perl_save_item +#define save_list Perl_save_list +#define save_nogv Perl_save_nogv +#define save_scalar Perl_save_scalar +#define save_sptr Perl_save_sptr +#define save_svref Perl_save_svref +#define savestack_grow Perl_savestack_grow +#define sawparens Perl_sawparens +#define scalar Perl_scalar +#define scalarkids Perl_scalarkids +#define scalarseq Perl_scalarseq +#define scalarvoid Perl_scalarvoid +#define scan_const Perl_scan_const +#define scan_formline Perl_scan_formline +#define scan_heredoc Perl_scan_heredoc +#define scan_hex Perl_scan_hex +#define scan_ident Perl_scan_ident +#define scan_inputsymbol Perl_scan_inputsymbol +#define scan_num Perl_scan_num +#define scan_oct Perl_scan_oct +#define scan_pat Perl_scan_pat +#define scan_prefix Perl_scan_prefix +#define scan_str Perl_scan_str +#define scan_subst Perl_scan_subst +#define scan_trans Perl_scan_trans +#define scan_word Perl_scan_word +#define scope Perl_scope +#define screaminstr Perl_screaminstr +#define setenv_getix Perl_setenv_getix +#define skipspace Perl_skipspace +#define stack_grow Perl_stack_grow +#define start_subparse Perl_start_subparse +#define sublex_done Perl_sublex_done +#define sublex_start Perl_sublex_start +#define sv_2bool Perl_sv_2bool +#define sv_2cv Perl_sv_2cv +#define sv_2io Perl_sv_2io +#define sv_2iv Perl_sv_2iv +#define sv_2mortal Perl_sv_2mortal +#define sv_2nv Perl_sv_2nv +#define sv_2pv Perl_sv_2pv +#define sv_backoff Perl_sv_backoff +#define sv_bless Perl_sv_bless +#define sv_catpv Perl_sv_catpv +#define sv_catpvn Perl_sv_catpvn +#define sv_catsv Perl_sv_catsv +#define sv_chop Perl_sv_chop +#define sv_clean_all Perl_sv_clean_all +#define sv_clean_objs Perl_sv_clean_objs +#define sv_clear Perl_sv_clear +#define sv_cmp Perl_sv_cmp +#define sv_dec Perl_sv_dec +#define sv_dump Perl_sv_dump +#define sv_eq Perl_sv_eq +#define sv_free Perl_sv_free +#define sv_gets Perl_sv_gets +#define sv_grow Perl_sv_grow +#define sv_inc Perl_sv_inc +#define sv_insert Perl_sv_insert +#define sv_isa Perl_sv_isa +#define sv_len Perl_sv_len +#define sv_magic Perl_sv_magic +#define sv_mortalcopy Perl_sv_mortalcopy +#define sv_newmortal Perl_sv_newmortal +#define sv_peek Perl_sv_peek +#define sv_ref Perl_sv_ref +#define sv_replace Perl_sv_replace +#define sv_report_used Perl_sv_report_used +#define sv_reset Perl_sv_reset +#define sv_setiv Perl_sv_setiv +#define sv_setnv Perl_sv_setnv +#define sv_setptrobj Perl_sv_setptrobj +#define sv_setpv Perl_sv_setpv +#define sv_setpvn Perl_sv_setpvn +#define sv_setref_iv Perl_sv_setref_iv +#define sv_setref_pv Perl_sv_setref_pv +#define sv_setsv Perl_sv_setsv +#define sv_unmagic Perl_sv_unmagic +#define sv_upgrade Perl_sv_upgrade +#define sv_usepvn Perl_sv_usepvn +#define taint_env Perl_taint_env +#define taint_not Perl_taint_not +#define taint_proper Perl_taint_proper +#define too_few_arguments Perl_too_few_arguments +#define too_many_arguments Perl_too_many_arguments +#define wait4pid Perl_wait4pid +#define warn Perl_warn +#define watch Perl_watch +#define whichsig Perl_whichsig +#define xiv_arenaroot Perl_xiv_arenaroot +#define xiv_root Perl_xiv_root +#define xnv_root Perl_xnv_root +#define xpv_root Perl_xpv_root +#define xrv_root Perl_xrv_root +#define yyerror Perl_yyerror +#define yyerror Perl_yyerror +#define yylex Perl_yylex +#define yyparse Perl_yyparse +#define yywarn Perl_yywarn #endif /* EMBED */ @@ -890,7 +996,6 @@ #define ampergv (curinterp->Iampergv) #define argvgv (curinterp->Iargvgv) #define argvoutgv (curinterp->Iargvoutgv) -#define arybase (curinterp->Iarybase) #define basetime (curinterp->Ibasetime) #define beginav (curinterp->Ibeginav) #define bodytarget (curinterp->Ibodytarget) @@ -900,7 +1005,6 @@ #define curblock (curinterp->Icurblock) #define curcop (curinterp->Icurcop) #define curcsv (curinterp->Icurcsv) -#define curoutgv (curinterp->Icuroutgv) #define curpm (curinterp->Icurpm) #define curstash (curinterp->Icurstash) #define curstname (curinterp->Icurstname) @@ -994,6 +1098,7 @@ #define rschar (curinterp->Irschar) #define rslen (curinterp->Irslen) #define rspara (curinterp->Irspara) +#define runlevel (curinterp->Irunlevel) #define sawampersand (curinterp->Isawampersand) #define sawi (curinterp->Isawi) #define sawstudy (curinterp->Isawstudy) @@ -1015,7 +1120,7 @@ #define stdingv (curinterp->Istdingv) #define strchop (curinterp->Istrchop) #define sv_count (curinterp->Isv_count) -#define sv_rvcount (curinterp->Isv_rvcount) +#define sv_objcount (curinterp->Isv_objcount) #define sv_root (curinterp->Isv_root) #define sv_arenaroot (curinterp->Isv_arenaroot) #define tainted (curinterp->Itainted) @@ -1042,7 +1147,6 @@ #define Iampergv ampergv #define Iargvgv argvgv #define Iargvoutgv argvoutgv -#define Iarybase arybase #define Ibasetime basetime #define Ibeginav beginav #define Ibodytarget bodytarget @@ -1052,7 +1156,6 @@ #define Icurblock curblock #define Icurcop curcop #define Icurcsv curcsv -#define Icuroutgv curoutgv #define Icurpm curpm #define Icurstash curstash #define Icurstname curstname @@ -1146,6 +1249,7 @@ #define Irschar rschar #define Irslen rslen #define Irspara rspara +#define Irunlevel runlevel #define Isawampersand sawampersand #define Isawi sawi #define Isawstudy sawstudy @@ -1167,7 +1271,7 @@ #define Istdingv stdingv #define Istrchop strchop #define Isv_count sv_count -#define Isv_rvcount sv_rvcount +#define Isv_objcount sv_objcount #define Isv_root sv_root #define Isv_arenaroot sv_arenaroot #define Itainted tainted diff --git a/embed_h.SH b/embed_h.SH index 2ba9fe2ae9..159ab0ed81 100755 --- a/embed_h.SH +++ b/embed_h.SH @@ -13,7 +13,7 @@ END sed <global.sym >>embed.h \ -e 's/[ ]*#.*//' \ -e '/^[ ]*$/d' \ - -e 's/\(.*\)/#define \1 perl_\1/' \ + -e 's/\(.*\)/#define \1 Perl_\1/' \ -e 's/\(................ \) /\1/' cat <<'END' >> embed.h @@ -1,318 +0,0 @@ - -void -save_lines(array, sv) -AV *array; -SV *sv; -{ - register char *s = sv->sv_ptr; - register char *send = sv->sv_ptr + sv->sv_cur; - register char *t; - register int line = 1; - - while (s && s < send) { - SV *tmpstr = NEWSV(85,0); - - t = index(s, '\n'); - if (t) - t++; - else - t = send; - - sv_setpvn(tmpstr, s, t - s); - av_store(array, line++, tmpstr); - s = t; - } -} - -int -do_eval(sv,optype,stash,savecmd,gimme,arglast) -SV *sv; -int optype; -HV *stash; -int savecmd; -int gimme; -int *arglast; -{ - SV **st = stack->av_array; - int retval; - COP *myroot = Nullcop; - AV *ar; - int i; - COP * VOL oldcurcmd = curcmd; - VOL int oldtmps_floor = tmps_floor; - VOL int oldsave = savestack->av_fill; - VOL int oldperldb = perldb; - PM * VOL oldspat = curspat; - PM * VOL oldlspat = lastspat; - - VOL int sp = arglast[0]; - char *specfilename; - char *tmpfilename; - int parsing = 1; - - tmps_floor = tmps_ix; - if (curstash != stash) { - (void)save_hptr(&curstash); - curstash = stash; - } - sv_setpv(GvSV(gv_fetchpv("@",TRUE)),""); - if (curcmd->cop_line == 0) /* don't debug debugger... */ - perldb = FALSE; - curcmd = &compiling; - if (optype == OP_EVAL) { /* normal oldeval */ - curcmd->cop_filestab = gv_fetchfile("(oldeval)"); - curcmd->cop_line = 1; - sv_setsv(linestr,sv); - sv_catpv(linestr,";\n;\n"); /* be kind to them */ - if (perldb) - save_lines(GvAV(curcmd->cop_filestab), linestr); - } - else { - if (last_root && !in_eval) { - Safefree(last_eval); - last_eval = Nullch; - cop_free(last_root); - last_root = Nullcop; - } - specfilename = SvPV(sv); - sv_setpv(linestr,""); - if (optype == OP_REQUIRE && &sv_undef != - hv_fetch(GvHVn(incstab), specfilename, strlen(specfilename), 0)) { - curcmd = oldcurcmd; - tmps_floor = oldtmps_floor; - st[++sp] = &sv_yes; - perldb = oldperldb; - return sp; - } - tmpfilename = savestr(specfilename); - if (*tmpfilename == '/' || - (*tmpfilename == '.' && - (tmpfilename[1] == '/' || - (tmpfilename[1] == '.' && tmpfilename[2] == '/')))) - { - rsfp = fopen(tmpfilename,"r"); - } - else { - ar = GvAVn(incstab); - for (i = 0; i <= ar->av_fill; i++) { - (void)sprintf(buf, "%s/%s", - SvPV(av_fetch(ar,i,TRUE)), specfilename); - rsfp = fopen(buf,"r"); - if (rsfp) { - char *s = buf; - - if (*s == '.' && s[1] == '/') - s += 2; - Safefree(tmpfilename); - tmpfilename = savestr(s); - break; - } - } - } - curcmd->cop_filestab = gv_fetchfile(tmpfilename); - Safefree(tmpfilename); - tmpfilename = Nullch; - if (!rsfp) { - curcmd = oldcurcmd; - tmps_floor = oldtmps_floor; - if (optype == OP_REQUIRE) { - sprintf(tokenbuf,"Can't locate %s in @INC", specfilename); - if (instr(tokenbuf,".h ")) - strcat(tokenbuf," (change .h to .ph maybe?)"); - if (instr(tokenbuf,".ph ")) - strcat(tokenbuf," (did you run h2ph?)"); - fatal("%s",tokenbuf); - } - if (gimme != G_ARRAY) - st[++sp] = &sv_undef; - perldb = oldperldb; - return sp; - } - curcmd->cop_line = 0; - } - in_eval++; - oldoldbufptr = oldbufptr = bufptr = SvPV(linestr); - bufend = bufptr + linestr->sv_cur; - if (++cxstack_ix >= block_max) { - block_max += 128; - Renew(block_stack, block_max, struct loop); - } - block_stack[cxstack_ix].block_label = "_EVAL_"; - block_stack[cxstack_ix].block_sp = sp; -#ifdef DEBUGGING - if (debug & 4) { - deb("(Pushing label #%d _EVAL_)\n", cxstack_ix); - } -#endif - eval_root = Nullcop; - if (setjmp(block_stack[cxstack_ix].block_env)) { - retval = 1; - } - else { - error_count = 0; - if (rsfp) { - retval = yyparse(); - retval |= error_count; - } - else if (last_root && last_elen == bufend - bufptr - && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){ - retval = 0; - eval_root = last_root; /* no point in reparsing */ - } - else if (in_eval == 1 && !savecmd) { - if (last_root) { - Safefree(last_eval); - last_eval = Nullch; - cop_free(last_root); - } - last_root = Nullcop; - last_elen = bufend - bufptr; - last_eval = nsavestr(bufptr, last_elen); - retval = yyparse(); - retval |= error_count; - if (!retval) - last_root = eval_root; - if (!last_root) { - Safefree(last_eval); - last_eval = Nullch; - } - } - else - retval = yyparse(); - } - myroot = eval_root; /* in case cop_exec does another oldeval! */ - - if (retval || error_count) { - st = stack->av_array; - sp = arglast[0]; - if (gimme != G_ARRAY) - st[++sp] = &sv_undef; - if (parsing) { -#ifndef MANGLEDPARSE -#ifdef DEBUGGING - if (debug & 128) - fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root); -#endif - cop_free(eval_root); -#endif - /*SUPPRESS 29*/ /*SUPPRESS 30*/ - if ((COP*)eval_root == last_root) - last_root = Nullcop; - eval_root = myroot = Nullcop; - } - if (rsfp) { - fclose(rsfp); - rsfp = 0; - } - } - else { - parsing = 0; - sp = cop_exec(eval_root,gimme,sp); - st = stack->av_array; - for (i = arglast[0] + 1; i <= sp; i++) - st[i] = sv_mortalcopy(st[i]); - /* if we don't save result, free zaps it */ - if (savecmd) - eval_root = myroot; - else if (in_eval != 1 && myroot != last_root) - cop_free(myroot); - } - - perldb = oldperldb; - in_eval--; -#ifdef DEBUGGING - if (debug & 4) { - char *tmps = block_stack[cxstack_ix].block_label; - deb("(Popping label #%d %s)\n",cxstack_ix, - tmps ? tmps : "" ); - } -#endif - cxstack_ix--; - tmps_floor = oldtmps_floor; - curspat = oldspat; - lastspat = oldlspat; - if (savestack->av_fill > oldsave) /* let them use local() */ - leave_scope(oldsave); - - if (optype != OP_EVAL) { - if (retval) { - if (optype == OP_REQUIRE) - fatal("%s", SvPV(GvSV(gv_fetchpv("@",TRUE)))); - } - else { - curcmd = oldcurcmd; - if (gimme == G_SCALAR ? SvTRUE(st[sp]) : sp > arglast[0]) { - (void)hv_store(GvHVn(incstab), specfilename, - strlen(specfilename), newSVsv(GvSV(curcmd->cop_filestab)), - 0 ); - } - else if (optype == OP_REQUIRE) - fatal("%s did not return a true value", specfilename); - } - } - curcmd = oldcurcmd; - return sp; -} - -int -do_try(cmd,gimme,arglast) -COP *cmd; -int gimme; -int *arglast; -{ - SV **st = stack->av_array; - - COP * VOL oldcurcmd = curcmd; - VOL int oldtmps_floor = tmps_floor; - VOL int oldsave = savestack->av_fill; - PM * VOL oldspat = curspat; - PM * VOL oldlspat = lastspat; - VOL int sp = arglast[0]; - - tmps_floor = tmps_ix; - sv_setpv(GvSV(gv_fetchpv("@",TRUE)),""); - in_eval++; - if (++cxstack_ix >= block_max) { - block_max += 128; - Renew(block_stack, block_max, struct loop); - } - block_stack[cxstack_ix].block_label = "_EVAL_"; - block_stack[cxstack_ix].block_sp = sp; -#ifdef DEBUGGING - if (debug & 4) { - deb("(Pushing label #%d _EVAL_)\n", cxstack_ix); - } -#endif - if (setjmp(block_stack[cxstack_ix].block_env)) { - st = stack->av_array; - sp = arglast[0]; - if (gimme != G_ARRAY) - st[++sp] = &sv_undef; - } - else { - sp = cop_exec(cmd,gimme,sp); - st = stack->av_array; -/* for (i = arglast[0] + 1; i <= sp; i++) - st[i] = sv_mortalcopy(st[i]); not needed, I think */ - /* if we don't save result, free zaps it */ - } - - in_eval--; -#ifdef DEBUGGING - if (debug & 4) { - char *tmps = block_stack[cxstack_ix].block_label; - deb("(Popping label #%d %s)\n",cxstack_ix, - tmps ? tmps : "" ); - } -#endif - cxstack_ix--; - tmps_floor = oldtmps_floor; - curspat = oldspat; - lastspat = oldlspat; - curcmd = oldcurcmd; - if (savestack->av_fill > oldsave) /* let them use local() */ - leave_scope(oldsave); - - return sp; -} - diff --git a/eval.c.save b/eval.c.save deleted file mode 100644 index 964bc0301f..0000000000 --- a/eval.c.save +++ /dev/null @@ -1,3048 +0,0 @@ -/* $RCSfile: eval.c,v $$Revision: 4.1 $$Date: 92/08/07 18:20:29 $ - * - * Copyright (c) 1991, Larry Wall - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - * $Log: eval.c,v $ - * Revision 4.1 92/08/07 18:20:29 lwall - * - * Revision 4.0.1.4 92/06/08 13:20:20 lwall - * patch20: added explicit time_t support - * patch20: fixed confusion between a *var's real name and its effective name - * patch20: added Atari ST portability - * patch20: new warning for use of x with non-numeric right operand - * patch20: modulus with highest bit in left operand set didn't always work - * patch20: dbmclose(%array) didn't work - * patch20: added ... as variant on .. - * patch20: O_PIPE conflicted with Atari - * - * Revision 4.0.1.3 91/11/05 17:15:21 lwall - * patch11: prepared for ctype implementations that don't define isascii() - * patch11: various portability fixes - * patch11: added sort {} LIST - * patch11: added eval {} - * patch11: sysread() in socket was substituting recv() - * patch11: a last statement outside any block caused occasional core dumps - * patch11: missing arguments caused core dump in -D8 code - * patch11: eval 'stuff' now optimized to eval {stuff} - * - * Revision 4.0.1.2 91/06/07 11:07:23 lwall - * patch4: new copyright notice - * patch4: length($`), length($&), length($') now optimized to avoid string copy - * patch4: assignment wasn't correctly de-tainting the assigned variable. - * patch4: default top-of-form format is now FILEHANDLE_TOP - * patch4: added $^P variable to control calling of perldb routines - * patch4: taintchecks could improperly modify parent in vfork() - * patch4: many, many itty-bitty portability fixes - * - * Revision 4.0.1.1 91/04/11 17:43:48 lwall - * patch1: fixed failed fork to return undef as documented - * patch1: reduced maximum branch distance in eval.c - * - * Revision 4.0 91/03/20 01:16:48 lwall - * 4.0 baseline. - * - */ - -#include "EXTERN.h" -#include "perl.h" - -extern int (*ppaddr[])(); -extern int mark[]; - -#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) -#include <signal.h> -#endif - -#ifdef I_FCNTL -#include <fcntl.h> -#endif -#ifdef MSDOS -/* I_FCNTL *MUST* not be defined for MS-DOS and OS/2 - but fcntl.h is required for O_BINARY */ -#include <fcntl.h> -#endif -#ifdef I_SYS_FILE -#include <sys/file.h> -#endif -#ifdef I_VFORK -# include <vfork.h> -#endif - -double sin(), cos(), atan2(), pow(); - -char *getlogin(); - -int -eval(arg,gimme,sp) -register ARG *arg; -int gimme; -register int sp; -{ - register STR *str; - register int anum; - register int optype; - register STR **st; - int maxarg; - double value; - register char *tmps; - char *tmps2; - int argflags; - int argtype; - union argptr argptr; - int arglast[8]; /* highest sp for arg--valid only for non-O_LIST args */ - unsigned long tmpulong; - long tmplong; - time_t when; - STRLEN tmplen; - FILE *fp; - STR *tmpstr; - FCMD *form; - STAB *stab; - STAB *stab2; - STIO *stio; - ARRAY *ary; - int old_rslen; - int old_rschar; - VOIDRET (*ihand)(); /* place to save signal during system() */ - VOIDRET (*qhand)(); /* place to save signal during system() */ - bool assigning = FALSE; - int mymarkbase = savestack->ary_fill; - - if (!arg) - goto say_undef; - optype = arg->arg_type; - maxarg = arg->arg_len; - arglast[0] = sp; - str = arg->arg_ptr.arg_str; - if (sp + maxarg > stack->ary_max) - astore(stack, sp + maxarg, Nullstr); - st = stack->ary_array; - -#ifdef DEBUGGING - if (debug) { - if (debug & 8) { - deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg); - } - debname[dlevel] = opname[optype][0]; - debdelim[dlevel] = ':'; - if (++dlevel >= dlmax) - grow_dlevel(); - } -#endif - - if (mark[optype]) { - saveint(&markbase); - markbase = mymarkbase; - saveint(&stack_mark); - stack_mark = sp; - } - for (anum = 1; anum <= maxarg; anum++) { - argflags = arg[anum].arg_flags; - argtype = arg[anum].arg_type; - argptr = arg[anum].arg_ptr; - re_eval: - switch (argtype) { - default: - if (!ppaddr[optype] || optype == O_SUBR || optype == O_DBSUBR) { - st[++sp] = &str_undef; - } -#ifdef DEBUGGING - tmps = "NULL"; -#endif - break; - case A_EXPR: -#ifdef DEBUGGING - if (debug & 8) { - tmps = "EXPR"; - deb("%d.EXPR =>\n",anum); - } -#endif - sp = eval(argptr.arg_arg, - (argflags & AF_ARYOK) ? G_ARRAY : G_SCALAR, sp); - if (sp + (maxarg - anum) > stack->ary_max) - astore(stack, sp + (maxarg - anum), Nullstr); - st = stack->ary_array; /* possibly reallocated */ - break; - case A_CMD: -#ifdef DEBUGGING - if (debug & 8) { - tmps = "CMD"; - deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd); - } -#endif - sp = cmd_exec(argptr.arg_cmd, gimme, sp); - if (sp + (maxarg - anum) > stack->ary_max) - astore(stack, sp + (maxarg - anum), Nullstr); - st = stack->ary_array; /* possibly reallocated */ - break; - case A_LARYSTAB: - ++sp; - switch (optype) { - case O_ITEM2: argtype = 2; break; - case O_ITEM3: argtype = 3; break; - default: argtype = anum; break; - } - str = afetch(stab_array(argptr.arg_stab), - arg[argtype].arg_len - arybase, TRUE); -#ifdef DEBUGGING - if (debug & 8) { - (void)sprintf(buf,"LARYSTAB $%s[%d]",stab_name(argptr.arg_stab), - arg[argtype].arg_len); - tmps = buf; - } -#endif - goto do_crement; - case A_ARYSTAB: - switch (optype) { - case O_ITEM2: argtype = 2; break; - case O_ITEM3: argtype = 3; break; - default: argtype = anum; break; - } - st[++sp] = afetch(stab_array(argptr.arg_stab), - arg[argtype].arg_len - arybase, FALSE); -#ifdef DEBUGGING - if (debug & 8) { - (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab), - arg[argtype].arg_len); - tmps = buf; - } -#endif - break; - case A_STAR: - stab = argptr.arg_stab; - st[++sp] = (STR*)stab; - if (!stab_xarray(stab)) - aadd(stab); - if (!stab_xhash(stab)) - hadd(stab); - if (!stab_io(stab)) - stab_io(stab) = stio_new(); -#ifdef DEBUGGING - if (debug & 8) { - (void)sprintf(buf,"STAR *%s -> *%s", - stab_name(argptr.arg_stab), stab_ename(argptr.arg_stab)); - tmps = buf; - } -#endif - break; - case A_LSTAR: - str = st[++sp] = (STR*)argptr.arg_stab; -#ifdef DEBUGGING - if (debug & 8) { - (void)sprintf(buf,"LSTAR *%s -> *%s", - stab_name(argptr.arg_stab), stab_ename(argptr.arg_stab)); - tmps = buf; - } -#endif - break; - case A_STAB: - st[++sp] = STAB_STR(argptr.arg_stab); -#ifdef DEBUGGING - if (debug & 8) { - (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab)); - tmps = buf; - } -#endif - break; - case A_LENSTAB: - str_numset(str, (double)STAB_LEN(argptr.arg_stab)); - st[++sp] = str; -#ifdef DEBUGGING - if (debug & 8) { - (void)sprintf(buf,"LENSTAB $%s",stab_name(argptr.arg_stab)); - tmps = buf; - } -#endif - break; - case A_LEXPR: -#ifdef DEBUGGING - if (debug & 8) { - tmps = "LEXPR"; - deb("%d.LEXPR =>\n",anum); - } -#endif - if (argflags & AF_ARYOK) { - sp = eval(argptr.arg_arg, G_ARRAY, sp); - if (sp + (maxarg - anum) > stack->ary_max) - astore(stack, sp + (maxarg - anum), Nullstr); - st = stack->ary_array; /* possibly reallocated */ - } - else { - sp = eval(argptr.arg_arg, G_SCALAR, sp); - st = stack->ary_array; /* possibly reallocated */ - str = st[sp]; - goto do_crement; - } - break; - case A_LVAL: -#ifdef DEBUGGING - if (debug & 8) { - (void)sprintf(buf,"LVAL $%s",stab_name(argptr.arg_stab)); - tmps = buf; - } -#endif - ++sp; - str = STAB_STR(argptr.arg_stab); - if (!str) - fatal("panic: A_LVAL"); - do_crement: - assigning = TRUE; - if (argflags & AF_PRE) { - if (argflags & AF_UP) - str_inc(str); - else - str_dec(str); - STABSET(str); - st[sp] = str; - str = arg->arg_ptr.arg_str; - } - else if (argflags & AF_POST) { - st[sp] = str_mortal(str); - if (argflags & AF_UP) - str_inc(str); - else - str_dec(str); - STABSET(str); - str = arg->arg_ptr.arg_str; - } - else - st[sp] = str; - break; - case A_LARYLEN: - ++sp; - stab = argptr.arg_stab; - str = stab_array(argptr.arg_stab)->ary_magic; - if (optype != O_SASSIGN || argflags & (AF_PRE|AF_POST)) - str_numset(str,(double)(stab_array(stab)->ary_fill+arybase)); -#ifdef DEBUGGING - tmps = "LARYLEN"; -#endif - if (!str) - fatal("panic: A_LEXPR"); - goto do_crement; - case A_ARYLEN: - stab = argptr.arg_stab; - st[++sp] = stab_array(stab)->ary_magic; - str_numset(st[sp],(double)(stab_array(stab)->ary_fill+arybase)); -#ifdef DEBUGGING - tmps = "ARYLEN"; -#endif - break; - case A_SINGLE: - st[++sp] = argptr.arg_str; -#ifdef DEBUGGING - tmps = "SINGLE"; -#endif - break; - case A_DOUBLE: - (void) interp(str,argptr.arg_str,sp); - st = stack->ary_array; - st[++sp] = str; -#ifdef DEBUGGING - tmps = "DOUBLE"; -#endif - break; - case A_BACKTICK: - tmps = str_get(interp(str,argptr.arg_str,sp)); - st = stack->ary_array; -#ifdef TAINT - TAINT_PROPER("``"); -#endif - fp = mypopen(tmps,"r"); - str_set(str,""); - if (fp) { - if (gimme == G_SCALAR) { - while (str_gets(str,fp,str->str_cur) != Nullch) - /*SUPPRESS 530*/ - ; - } - else { - for (;;) { - if (++sp > stack->ary_max) { - astore(stack, sp, Nullstr); - st = stack->ary_array; - } - str = st[sp] = Str_new(56,80); - if (str_gets(str,fp,0) == Nullch) { - sp--; - break; - } - if (str->str_len - str->str_cur > 20) { - str->str_len = str->str_cur+1; - Renew(str->str_ptr, str->str_len, char); - } - str_2mortal(str); - } - } - statusvalue = mypclose(fp); - } - else - statusvalue = -1; - - if (gimme == G_SCALAR) - st[++sp] = str; -#ifdef DEBUGGING - tmps = "BACK"; -#endif - break; - case A_WANTARRAY: - { - if (curcsv->wantarray == G_ARRAY) - st[++sp] = &str_yes; - else - st[++sp] = &str_no; - } -#ifdef DEBUGGING - tmps = "WANTARRAY"; -#endif - break; - case A_INDREAD: - last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE); - old_rschar = rschar; - old_rslen = rslen; - goto do_read; - case A_GLOB: - argflags |= AF_POST; /* enable newline chopping */ - last_in_stab = argptr.arg_stab; - old_rschar = rschar; - old_rslen = rslen; - rslen = 1; -#ifdef DOSISH - rschar = 0; -#else -#ifdef CSH - rschar = 0; -#else - rschar = '\n'; -#endif /* !CSH */ -#endif /* !MSDOS */ - goto do_read; - case A_READ: - last_in_stab = argptr.arg_stab; - old_rschar = rschar; - old_rslen = rslen; - do_read: - if (anum > 1) /* assign to scalar */ - gimme = G_SCALAR; /* force context to scalar */ - if (gimme == G_ARRAY) - str = Str_new(57,0); - ++sp; - fp = Nullfp; - if (stab_io(last_in_stab)) { - fp = stab_io(last_in_stab)->ifp; - if (!fp) { - if (stab_io(last_in_stab)->flags & IOF_ARGV) { - if (stab_io(last_in_stab)->flags & IOF_START) { - stab_io(last_in_stab)->flags &= ~IOF_START; - stab_io(last_in_stab)->lines = 0; - if (alen(stab_array(last_in_stab)) < 0) { - tmpstr = str_make("-",1); /* assume stdin */ - (void)apush(stab_array(last_in_stab), tmpstr); - } - } - fp = nextargv(last_in_stab); - if (!fp) { /* Note: fp != stab_io(last_in_stab)->ifp */ - (void)do_close(last_in_stab,FALSE); /* now it does*/ - stab_io(last_in_stab)->flags |= IOF_START; - } - } - else if (argtype == A_GLOB) { - (void) interp(str,stab_val(last_in_stab),sp); - st = stack->ary_array; - tmpstr = Str_new(55,0); -#ifdef DOSISH - str_set(tmpstr, "perlglob "); - str_scat(tmpstr,str); - str_cat(tmpstr," |"); -#else -#ifdef CSH - str_nset(tmpstr,cshname,cshlen); - str_cat(tmpstr," -cf 'set nonomatch; glob "); - str_scat(tmpstr,str); - str_cat(tmpstr,"'|"); -#else - str_set(tmpstr, "echo "); - str_scat(tmpstr,str); - str_cat(tmpstr, - "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); -#endif /* !CSH */ -#endif /* !MSDOS */ - (void)do_open(last_in_stab,tmpstr->str_ptr, - tmpstr->str_cur); - fp = stab_io(last_in_stab)->ifp; - str_free(tmpstr); - } - } - } - if (!fp && dowarn) - warn("Read on closed filehandle <%s>",stab_ename(last_in_stab)); - tmplen = str->str_len; /* remember if already alloced */ - if (!tmplen) - Str_Grow(str,80); /* try short-buffering it */ - keepgoing: - if (!fp) - st[sp] = &str_undef; - else if (!str_gets(str,fp, optype == O_RCAT ? str->str_cur : 0)) { - clearerr(fp); - if (stab_io(last_in_stab)->flags & IOF_ARGV) { - fp = nextargv(last_in_stab); - if (fp) - goto keepgoing; - (void)do_close(last_in_stab,FALSE); - stab_io(last_in_stab)->flags |= IOF_START; - } - else if (argflags & AF_POST) { - (void)do_close(last_in_stab,FALSE); - } - st[sp] = &str_undef; - rschar = old_rschar; - rslen = old_rslen; - if (gimme == G_ARRAY) { - --sp; - str_2mortal(str); - goto array_return; - } - break; - } - else { - stab_io(last_in_stab)->lines++; - st[sp] = str; -#ifdef TAINT - str->str_tainted = 1; /* Anything from the outside world...*/ -#endif - if (argflags & AF_POST) { - if (str->str_cur > 0) - str->str_cur--; - if (str->str_ptr[str->str_cur] == rschar) - str->str_ptr[str->str_cur] = '\0'; - else - str->str_cur++; - for (tmps = str->str_ptr; *tmps; tmps++) - if (!isALPHA(*tmps) && !isDIGIT(*tmps) && - index("$&*(){}[]'\";\\|?<>~`",*tmps)) - break; - if (*tmps && stat(str->str_ptr,&statbuf) < 0) - goto keepgoing; /* unmatched wildcard? */ - } - if (gimme == G_ARRAY) { - if (str->str_len - str->str_cur > 20) { - str->str_len = str->str_cur+1; - Renew(str->str_ptr, str->str_len, char); - } - str_2mortal(str); - if (++sp > stack->ary_max) { - astore(stack, sp, Nullstr); - st = stack->ary_array; - } - str = Str_new(58,80); - goto keepgoing; - } - else if (!tmplen && str->str_len - str->str_cur > 80) { - /* try to reclaim a bit of scalar space on 1st alloc */ - if (str->str_cur < 60) - str->str_len = 80; - else - str->str_len = str->str_cur+40; /* allow some slop */ - Renew(str->str_ptr, str->str_len, char); - } - } - rschar = old_rschar; - rslen = old_rslen; -#ifdef DEBUGGING - tmps = "READ"; -#endif - break; - } -#ifdef DEBUGGING - if (debug & 8) { - if (strEQ(tmps, "NULL")) - deb("%d.%s\n",anum,tmps); - else - deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp])); - } -#endif - if (anum < 8) - arglast[anum] = sp; - } - - if (ppaddr[optype]) { - int status; - - /* pretend like we've been maintaining stack_* all along */ - stack_ary = stack->ary_array; - stack_sp = stack_ary + sp; - if (mark[optype] && stack_mark != arglast[0]) - warn("Inconsistent stack mark %d != %d", stack_mark, arglast[0]); - stack_max = stack_ary + stack->ary_max; - - status = (*ppaddr[optype])(str, arg, gimme); - - if (savestack->ary_fill > mymarkbase) { - warn("Inconsistent stack base"); - restorelist(mymarkbase); - } - sp = stack_sp - stack_ary; - if (sp < arglast[0]) - warn("TOO MANY POPS"); - st += arglast[0]; - goto array_return; - } - - st += arglast[0]; - -#ifdef SMALLSWITCHES - if (optype < O_CHOWN) -#endif - switch (optype) { - case O_RCAT: - STABSET(str); - break; - case O_ITEM: - if (gimme == G_ARRAY) - goto array_return; - /* FALL THROUGH */ - case O_SCALAR: - STR_SSET(str,st[1]); - STABSET(str); - break; - case O_ITEM2: - if (gimme == G_ARRAY) - goto array_return; - --anum; - STR_SSET(str,st[arglast[anum]-arglast[0]]); - STABSET(str); - break; - case O_ITEM3: - if (gimme == G_ARRAY) - goto array_return; - --anum; - STR_SSET(str,st[arglast[anum]-arglast[0]]); - STABSET(str); - break; - case O_CONCAT: - STR_SSET(str,st[1]); - str_scat(str,st[2]); - STABSET(str); - break; - case O_REPEAT: - if (gimme == G_ARRAY && arg[1].arg_flags & AF_ARYOK) { - sp = do_repeatary(arglast); - goto array_return; - } - STR_SSET(str,st[1]); - anum = (int)str_gnum(st[2]); - if (anum >= 1) { - tmpstr = Str_new(50, 0); - tmps = str_get(str); - str_nset(tmpstr,tmps,str->str_cur); - tmps = str_get(tmpstr); /* force to be string */ - STR_GROW(str, (anum * str->str_cur) + 1); - repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum); - str->str_cur *= anum; - str->str_ptr[str->str_cur] = '\0'; - str->str_nok = 0; - str_free(tmpstr); - } - else { - if (dowarn && st[2]->str_pok && !looks_like_number(st[2])) - warn("Right operand of x is not numeric"); - str_sset(str,&str_no); - } - STABSET(str); - break; - case O_MATCH: - sp = do_match(str,arg, - gimme,arglast); - if (gimme == G_ARRAY) - goto array_return; - STABSET(str); - break; - case O_NMATCH: - sp = do_match(str,arg, - G_SCALAR,arglast); - str_sset(str, str_true(str) ? &str_no : &str_yes); - STABSET(str); - break; - case O_SUBST: - sp = do_subst(str,arg,arglast[0]); - goto array_return; - case O_NSUBST: - sp = do_subst(str,arg,arglast[0]); - str = arg->arg_ptr.arg_str; - str_set(str, str_true(str) ? No : Yes); - goto array_return; - case O_ASSIGN: - if (arg[1].arg_flags & AF_ARYOK) { - if (arg->arg_len == 1) { - arg->arg_type = O_LOCAL; - goto local; - } - else { - arg->arg_type = O_AASSIGN; - goto aassign; - } - } - else { - arg->arg_type = O_SASSIGN; - goto sassign; - } - case O_LOCAL: - local: - arglast[2] = arglast[1]; /* push a null array */ - /* FALL THROUGH */ - case O_AASSIGN: - aassign: - sp = do_assign(arg, - gimme,arglast); - goto array_return; - case O_SASSIGN: - sassign: -#ifdef TAINT - if (tainted && !st[2]->str_tainted) - tainted = 0; -#endif - STR_SSET(str, st[2]); - STABSET(str); - break; - case O_CHOP: - st -= arglast[0]; - str = arg->arg_ptr.arg_str; - for (sp = arglast[0] + 1; sp <= arglast[1]; sp++) - do_chop(str,st[sp]); - st += arglast[0]; - break; - case O_DEFINED: - if (arg[1].arg_type & A_DONT) { - sp = do_defined(str,arg, - gimme,arglast); - goto array_return; - } - else if (str->str_pok || str->str_nok) - goto say_yes; - goto say_no; - case O_UNDEF: - if (arg[1].arg_type & A_DONT) { - sp = do_undef(str,arg, - gimme,arglast); - goto array_return; - } - else if (str != stab_val(defstab)) { - if (str->str_len) { - if (str->str_state == SS_INCR) - Str_Grow(str,0); - Safefree(str->str_ptr); - str->str_ptr = Nullch; - str->str_len = 0; - } - str->str_pok = str->str_nok = 0; - STABSET(str); - } - goto say_undef; - case O_STUDY: - sp = do_study(str,arg, - gimme,arglast); - goto array_return; - case O_POW: - value = str_gnum(st[1]); - value = pow(value,str_gnum(st[2])); - goto donumset; - case O_MULTIPLY: - value = str_gnum(st[1]); - value *= str_gnum(st[2]); - goto donumset; - case O_DIVIDE: - if ((value = str_gnum(st[2])) == 0.0) - fatal("Illegal division by zero"); -#ifdef SLOPPYDIVIDE - /* insure that 20./5. == 4. */ - { - double x; - int k; - x = str_gnum(st[1]); - if ((double)(int)x == x && - (double)(int)value == value && - (k = (int)x/(int)value)*(int)value == (int)x) { - value = k; - } else { - value = x/value; - } - } -#else - value = str_gnum(st[1]) / value; -#endif - goto donumset; - case O_MODULO: - tmpulong = (unsigned long) str_gnum(st[2]); - if (tmpulong == 0L) - fatal("Illegal modulus zero"); -#ifndef lint - value = str_gnum(st[1]); - if (value >= 0.0) - value = (double)(((unsigned long)value) % tmpulong); - else { - tmplong = (long)value; - value = (double)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1; - } -#endif - goto donumset; - case O_ADD: - value = str_gnum(st[1]); - value += str_gnum(st[2]); - goto donumset; - case O_SUBTRACT: - value = str_gnum(st[1]); - value -= str_gnum(st[2]); - goto donumset; - case O_LEFT_SHIFT: - value = str_gnum(st[1]); - anum = (int)str_gnum(st[2]); -#ifndef lint - value = (double)(U_L(value) << anum); -#endif - goto donumset; - case O_RIGHT_SHIFT: - value = str_gnum(st[1]); - anum = (int)str_gnum(st[2]); -#ifndef lint - value = (double)(U_L(value) >> anum); -#endif - goto donumset; - case O_LT: - value = str_gnum(st[1]); - value = (value < str_gnum(st[2])) ? 1.0 : 0.0; - goto donumset; - case O_GT: - value = str_gnum(st[1]); - value = (value > str_gnum(st[2])) ? 1.0 : 0.0; - goto donumset; - case O_LE: - value = str_gnum(st[1]); - value = (value <= str_gnum(st[2])) ? 1.0 : 0.0; - goto donumset; - case O_GE: - value = str_gnum(st[1]); - value = (value >= str_gnum(st[2])) ? 1.0 : 0.0; - goto donumset; - case O_EQ: - if (dowarn) { - if ((!st[1]->str_nok && !looks_like_number(st[1])) || - (!st[2]->str_nok && !looks_like_number(st[2])) ) - warn("Possible use of == on string value"); - } - value = str_gnum(st[1]); - value = (value == str_gnum(st[2])) ? 1.0 : 0.0; - goto donumset; - case O_NE: - value = str_gnum(st[1]); - value = (value != str_gnum(st[2])) ? 1.0 : 0.0; - goto donumset; - case O_NCMP: - value = str_gnum(st[1]); - value -= str_gnum(st[2]); - if (value > 0.0) - value = 1.0; - else if (value < 0.0) - value = -1.0; - goto donumset; - case O_BIT_AND: - if (!sawvec || st[1]->str_nok || st[2]->str_nok) { - value = str_gnum(st[1]); -#ifndef lint - value = (double)(U_L(value) & U_L(str_gnum(st[2]))); -#endif - goto donumset; - } - else - do_vop(optype,str,st[1],st[2]); - break; - case O_XOR: - if (!sawvec || st[1]->str_nok || st[2]->str_nok) { - value = str_gnum(st[1]); -#ifndef lint - value = (double)(U_L(value) ^ U_L(str_gnum(st[2]))); -#endif - goto donumset; - } - else - do_vop(optype,str,st[1],st[2]); - break; - case O_BIT_OR: - if (!sawvec || st[1]->str_nok || st[2]->str_nok) { - value = str_gnum(st[1]); -#ifndef lint - value = (double)(U_L(value) | U_L(str_gnum(st[2]))); -#endif - goto donumset; - } - else - do_vop(optype,str,st[1],st[2]); - break; -/* use register in evaluating str_true() */ - case O_AND: - if (str_true(st[1])) { - anum = 2; - optype = O_ITEM2; - argflags = arg[anum].arg_flags; - if (gimme == G_ARRAY) - argflags |= AF_ARYOK; - argtype = arg[anum].arg_type & A_MASK; - argptr = arg[anum].arg_ptr; - maxarg = anum = 1; - sp = arglast[0]; - st -= sp; - goto re_eval; - } - else { - if (assigning) { - str_sset(str, st[1]); - STABSET(str); - } - else - str = st[1]; - break; - } - case O_OR: - if (str_true(st[1])) { - if (assigning) { - str_sset(str, st[1]); - STABSET(str); - } - else - str = st[1]; - break; - } - else { - anum = 2; - optype = O_ITEM2; - argflags = arg[anum].arg_flags; - if (gimme == G_ARRAY) - argflags |= AF_ARYOK; - argtype = arg[anum].arg_type & A_MASK; - argptr = arg[anum].arg_ptr; - maxarg = anum = 1; - sp = arglast[0]; - st -= sp; - goto re_eval; - } - case O_COND_EXPR: - anum = (str_true(st[1]) ? 2 : 3); - optype = (anum == 2 ? O_ITEM2 : O_ITEM3); - argflags = arg[anum].arg_flags; - if (gimme == G_ARRAY) - argflags |= AF_ARYOK; - argtype = arg[anum].arg_type & A_MASK; - argptr = arg[anum].arg_ptr; - maxarg = anum = 1; - sp = arglast[0]; - st -= sp; - goto re_eval; - case O_COMMA: - if (gimme == G_ARRAY) - goto array_return; - str = st[2]; - break; - case O_NEGATE: - value = -str_gnum(st[1]); - goto donumset; - case O_NOT: -#ifdef NOTNOT - { char xxx = str_true(st[1]); value = (double) !xxx; } -#else - value = (double) !str_true(st[1]); -#endif - goto donumset; - case O_COMPLEMENT: - if (!sawvec || st[1]->str_nok) { -#ifndef lint - value = (double) ~U_L(str_gnum(st[1])); -#endif - goto donumset; - } - else { - STR_SSET(str,st[1]); - tmps = str_get(str); - for (anum = str->str_cur; anum; anum--, tmps++) - *tmps = ~*tmps; - } - break; - case O_SELECT: - stab_efullname(str,defoutstab); - if (maxarg > 0) { - if ((arg[1].arg_type & A_MASK) == A_WORD) - defoutstab = arg[1].arg_ptr.arg_stab; - else - defoutstab = stabent(str_get(st[1]),TRUE); - if (!stab_io(defoutstab)) - stab_io(defoutstab) = stio_new(); - curoutstab = defoutstab; - } - STABSET(str); - break; - case O_WRITE: - if (maxarg == 0) - stab = defoutstab; - else if ((arg[1].arg_type & A_MASK) == A_WORD) { - if (!(stab = arg[1].arg_ptr.arg_stab)) - stab = defoutstab; - } - else - stab = stabent(str_get(st[1]),TRUE); - if (!stab_io(stab)) { - str_set(str, No); - STABSET(str); - break; - } - curoutstab = stab; - fp = stab_io(stab)->ofp; - if (stab_io(stab)->fmt_stab) - form = stab_form(stab_io(stab)->fmt_stab); - else - form = stab_form(stab); - if (!form || !fp) { - if (dowarn) { - if (form) - warn("No format for filehandle"); - else { - if (stab_io(stab)->ifp) - warn("Filehandle only opened for input"); - else - warn("Write on closed filehandle"); - } - } - str_set(str, No); - STABSET(str); - break; - } - format(&outrec,form,sp); - do_write(&outrec,stab,sp); - if (stab_io(stab)->flags & IOF_FLUSH) - (void)fflush(fp); - str_set(str, Yes); - STABSET(str); - break; - case O_DBMOPEN: -#ifdef SOME_DBM - anum = arg[1].arg_type & A_MASK; - if (anum == A_WORD || anum == A_STAB) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if (st[3]->str_nok || st[3]->str_pok) - anum = (int)str_gnum(st[3]); - else - anum = -1; - value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum); - goto donumset; -#else - fatal("No dbm or ndbm on this machine"); -#endif - case O_DBMCLOSE: -#ifdef SOME_DBM - anum = arg[1].arg_type & A_MASK; - if (anum == A_WORD || anum == A_STAB) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - hdbmclose(stab_hash(stab)); - goto say_yes; -#else - fatal("No dbm or ndbm on this machine"); -#endif - case O_OPEN: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - tmps = str_get(st[2]); - if (do_open(stab,tmps,st[2]->str_cur)) { - value = (double)forkprocess; - stab_io(stab)->lines = 0; - goto donumset; - } - else if (forkprocess == 0) /* we are a new child */ - goto say_zero; - else - goto say_undef; - /* break; */ - case O_TRANS: - value = (double) do_trans(str,arg); - str = arg->arg_ptr.arg_str; - goto donumset; - case O_NTRANS: - str_set(arg->arg_ptr.arg_str, do_trans(str,arg) == 0 ? Yes : No); - str = arg->arg_ptr.arg_str; - break; - case O_CLOSE: - if (maxarg == 0) - stab = defoutstab; - else if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - str_set(str, do_close(stab,TRUE) ? Yes : No ); - STABSET(str); - break; - case O_EACH: - sp = do_each(str,stab_hash(arg[1].arg_ptr.arg_stab), - gimme,arglast); - goto array_return; - case O_VALUES: - case O_KEYS: - sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype, - gimme,arglast); - goto array_return; - case O_LARRAY: - str->str_nok = str->str_pok = 0; - str->str_u.str_stab = arg[1].arg_ptr.arg_stab; - str->str_state = SS_ARY; - break; - case O_ARRAY: - ary = stab_array(arg[1].arg_ptr.arg_stab); - maxarg = ary->ary_fill + 1; - if (gimme == G_ARRAY) { /* array wanted */ - sp = arglast[0]; - st -= sp; - if (maxarg > 0 && sp + maxarg > stack->ary_max) { - astore(stack,sp + maxarg, Nullstr); - st = stack->ary_array; - } - st += sp; - Copy(ary->ary_array, &st[1], maxarg, STR*); - sp += maxarg; - goto array_return; - } - else { - value = (double)maxarg; - goto donumset; - } - case O_AELEM: - anum = ((int)str_gnum(st[2])) - arybase; - str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,FALSE); - break; - case O_DELETE: - tmpstab = arg[1].arg_ptr.arg_stab; - tmps = str_get(st[2]); - str = hdelete(stab_hash(tmpstab),tmps,st[2]->str_cur); - if (tmpstab == envstab) - my_setenv(tmps,Nullch); - if (!str) - goto say_undef; - break; - case O_LHASH: - str->str_nok = str->str_pok = 0; - str->str_u.str_stab = arg[1].arg_ptr.arg_stab; - str->str_state = SS_HASH; - break; - case O_HASH: - if (gimme == G_ARRAY) { /* array wanted */ - sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype, - gimme,arglast); - goto array_return; - } - else { - tmpstab = arg[1].arg_ptr.arg_stab; - if (!stab_hash(tmpstab)->tbl_fill) - goto say_zero; - sprintf(buf,"%d/%d",stab_hash(tmpstab)->tbl_fill, - stab_hash(tmpstab)->tbl_max+1); - str_set(str,buf); - } - break; - case O_HELEM: - tmpstab = arg[1].arg_ptr.arg_stab; - tmps = str_get(st[2]); - str = hfetch(stab_hash(tmpstab),tmps,st[2]->str_cur,FALSE); - break; - case O_LAELEM: - anum = ((int)str_gnum(st[2])) - arybase; - str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,TRUE); - if (!str || str == &str_undef) - fatal("Assignment to non-creatable value, subscript %d",anum); - break; - case O_LHELEM: - tmpstab = arg[1].arg_ptr.arg_stab; - tmps = str_get(st[2]); - anum = st[2]->str_cur; - str = hfetch(stab_hash(tmpstab),tmps,anum,TRUE); - if (!str || str == &str_undef) - fatal("Assignment to non-creatable value, subscript \"%s\"",tmps); - if (tmpstab == envstab) /* heavy wizardry going on here */ - str_magic(str, tmpstab, 'E', tmps, anum); /* str is now magic */ - /* he threw the brick up into the air */ - else if (tmpstab == sigstab) - str_magic(str, tmpstab, 'S', tmps, anum); -#ifdef SOME_DBM - else if (stab_hash(tmpstab)->tbl_dbm) - str_magic(str, tmpstab, 'D', tmps, anum); -#endif - else if (tmpstab == DBline) - str_magic(str, tmpstab, 'L', tmps, anum); - break; - case O_LSLICE: - anum = 2; - argtype = FALSE; - goto do_slice_already; - case O_ASLICE: - anum = 1; - argtype = FALSE; - goto do_slice_already; - case O_HSLICE: - anum = 0; - argtype = FALSE; - goto do_slice_already; - case O_LASLICE: - anum = 1; - argtype = TRUE; - goto do_slice_already; - case O_LHSLICE: - anum = 0; - argtype = TRUE; - do_slice_already: - sp = do_slice(arg[1].arg_ptr.arg_stab,str,anum,argtype, - gimme,arglast); - goto array_return; - case O_SPLICE: - sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),gimme,arglast); - goto array_return; - case O_PUSH: - if (arglast[2] - arglast[1] != 1) - str = do_push(stab_array(arg[1].arg_ptr.arg_stab),arglast); - else { - str = Str_new(51,0); /* must copy the STR */ - str_sset(str,st[2]); - (void)apush(stab_array(arg[1].arg_ptr.arg_stab),str); - } - break; - case O_POP: - str = apop(ary = stab_array(arg[1].arg_ptr.arg_stab)); - goto staticalization; - case O_SHIFT: - str = ashift(ary = stab_array(arg[1].arg_ptr.arg_stab)); - staticalization: - if (!str) - goto say_undef; - if (ary->ary_flags & ARF_REAL) - (void)str_2mortal(str); - break; - case O_UNPACK: - sp = do_unpack(str,gimme,arglast); - goto array_return; - case O_SPLIT: - value = str_gnum(st[3]); - sp = do_split(str, arg[2].arg_ptr.arg_spat, (int)value, - gimme,arglast); - goto array_return; - case O_LENGTH: - if (maxarg < 1) - value = (double)str_len(stab_val(defstab)); - else - value = (double)str_len(st[1]); - goto donumset; - case O_SPRINTF: - do_sprintf(str, sp-arglast[0], st+1); - break; - case O_SUBSTR: - anum = ((int)str_gnum(st[2])) - arybase; /* anum=where to start*/ - tmps = str_get(st[1]); /* force conversion to string */ - /*SUPPRESS 560*/ - if (argtype = (str == st[1])) - str = arg->arg_ptr.arg_str; - if (anum < 0) - anum += st[1]->str_cur + arybase; - if (anum < 0 || anum > st[1]->str_cur) - str_nset(str,"",0); - else { - optype = maxarg < 3 ? st[1]->str_cur : (int)str_gnum(st[3]); - if (optype < 0) - optype = 0; - tmps += anum; - anum = st[1]->str_cur - anum; /* anum=how many bytes left*/ - if (anum > optype) - anum = optype; - str_nset(str, tmps, anum); - if (argtype) { /* it's an lvalue! */ - Lstring *lstr = (Lstring*)str; - - str->str_magic = st[1]; - st[1]->str_rare = 's'; - lstr->lstr_offset = tmps - str_get(st[1]); - lstr->lstr_len = anum; - } - } - break; - case O_PACK: - /*SUPPRESS 701*/ - (void)do_pack(str,arglast); - break; - case O_GREP: - sp = do_grep(arg,str,gimme,arglast); - goto array_return; - case O_JOIN: - do_join(str,arglast); - break; - case O_SLT: - tmps = str_get(st[1]); - value = (double) (str_cmp(st[1],st[2]) < 0); - goto donumset; - case O_SGT: - tmps = str_get(st[1]); - value = (double) (str_cmp(st[1],st[2]) > 0); - goto donumset; - case O_SLE: - tmps = str_get(st[1]); - value = (double) (str_cmp(st[1],st[2]) <= 0); - goto donumset; - case O_SGE: - tmps = str_get(st[1]); - value = (double) (str_cmp(st[1],st[2]) >= 0); - goto donumset; - case O_SEQ: - tmps = str_get(st[1]); - value = (double) str_eq(st[1],st[2]); - goto donumset; - case O_SNE: - tmps = str_get(st[1]); - value = (double) !str_eq(st[1],st[2]); - goto donumset; - case O_SCMP: - tmps = str_get(st[1]); - value = (double) str_cmp(st[1],st[2]); - goto donumset; - case O_SUBR: - sp = do_subr(arg,gimme,arglast); - st = stack->ary_array + arglast[0]; /* maybe realloced */ - goto array_return; - case O_DBSUBR: - sp = do_subr(arg,gimme,arglast); - st = stack->ary_array + arglast[0]; /* maybe realloced */ - goto array_return; - case O_CALLER: - sp = do_caller(arg,maxarg,gimme,arglast); - st = stack->ary_array + arglast[0]; /* maybe realloced */ - goto array_return; - case O_SORT: - sp = do_sort(str,arg, - gimme,arglast); - goto array_return; - case O_REVERSE: - if (gimme == G_ARRAY) - sp = do_reverse(arglast); - else - sp = do_sreverse(str, arglast); - goto array_return; - case O_WARN: - if (arglast[2] - arglast[1] != 1) { - do_join(str,arglast); - tmps = str_get(str); - } - else { - str = st[2]; - tmps = str_get(st[2]); - } - if (!tmps || !*tmps) - tmps = "Warning: something's wrong"; - warn("%s",tmps); - goto say_yes; - case O_DIE: - if (arglast[2] - arglast[1] != 1) { - do_join(str,arglast); - tmps = str_get(str); - } - else { - str = st[2]; - tmps = str_get(st[2]); - } - if (!tmps || !*tmps) - tmps = "Died"; - fatal("%s",tmps); - goto say_zero; - case O_PRTF: - case O_PRINT: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if (!stab) - stab = defoutstab; - if (!stab_io(stab)) { - if (dowarn) - warn("Filehandle never opened"); - goto say_zero; - } - if (!(fp = stab_io(stab)->ofp)) { - if (dowarn) { - if (stab_io(stab)->ifp) - warn("Filehandle opened only for input"); - else - warn("Print on closed filehandle"); - } - goto say_zero; - } - else { - if (optype == O_PRTF || arglast[2] - arglast[1] != 1) - value = (double)do_aprint(arg,fp,arglast); - else { - value = (double)do_print(st[2],fp); - if (orslen && optype == O_PRINT) - if (fwrite(ors, 1, orslen, fp) == 0) - goto say_zero; - } - if (stab_io(stab)->flags & IOF_FLUSH) - if (fflush(fp) == EOF) - goto say_zero; - } - goto donumset; - case O_CHDIR: - if (maxarg < 1) - tmps = Nullch; - else - tmps = str_get(st[1]); - if (!tmps || !*tmps) { - tmpstr = hfetch(stab_hash(envstab),"HOME",4,FALSE); - tmps = str_get(tmpstr); - } - if (!tmps || !*tmps) { - tmpstr = hfetch(stab_hash(envstab),"LOGDIR",6,FALSE); - tmps = str_get(tmpstr); - } -#ifdef TAINT - TAINT_PROPER("chdir"); -#endif - value = (double)(chdir(tmps) >= 0); - goto donumset; - case O_EXIT: - if (maxarg < 1) - anum = 0; - else - anum = (int)str_gnum(st[1]); - my_exit(anum); - goto say_zero; - case O_RESET: - if (maxarg < 1) - tmps = ""; - else - tmps = str_get(st[1]); - str_reset(tmps,curcmd->c_stash); - value = 1.0; - goto donumset; - case O_LIST: - if (gimme == G_ARRAY) - goto array_return; - if (maxarg > 0) - str = st[sp - arglast[0]]; /* unwanted list, return last item */ - else - str = &str_undef; - break; - case O_EOF: - if (maxarg <= 0) - stab = last_in_stab; - else if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - str_set(str, do_eof(stab) ? Yes : No); - STABSET(str); - break; - case O_GETC: - if (maxarg <= 0) - stab = stdinstab; - else if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if (!stab) - stab = argvstab; - if (!stab || do_eof(stab)) /* make sure we have fp with something */ - goto say_undef; - else { -#ifdef TAINT - tainted = 1; -#endif - str_set(str," "); - *str->str_ptr = getc(stab_io(stab)->ifp); /* should never be EOF */ - } - STABSET(str); - break; - case O_TELL: - if (maxarg <= 0) - stab = last_in_stab; - else if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); -#ifndef lint - value = (double)do_tell(stab); -#else - (void)do_tell(stab); -#endif - goto donumset; - case O_RECV: - case O_READ: - case O_SYSREAD: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - tmps = str_get(st[2]); - anum = (int)str_gnum(st[3]); - errno = 0; - maxarg = sp - arglast[0]; - if (maxarg > 4) - warn("Too many args on read"); - if (maxarg == 4) - maxarg = (int)str_gnum(st[4]); - else - maxarg = 0; - if (!stab_io(stab) || !stab_io(stab)->ifp) - goto say_undef; -#ifdef HAS_SOCKET - if (optype == O_RECV) { - argtype = sizeof buf; - STR_GROW(st[2], anum+1), (tmps = str_get(st[2])); /* sneaky */ - anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, maxarg, - buf, &argtype); - if (anum >= 0) { - st[2]->str_cur = anum; - st[2]->str_ptr[anum] = '\0'; - str_nset(str,buf,argtype); - } - else - str_sset(str,&str_undef); - break; - } -#else - if (optype == O_RECV) - goto badsock; -#endif - STR_GROW(st[2], anum+maxarg+1), (tmps = str_get(st[2])); /* sneaky */ - if (optype == O_SYSREAD) { - anum = read(fileno(stab_io(stab)->ifp), tmps+maxarg, anum); - } - else -#ifdef HAS_SOCKET - if (stab_io(stab)->type == 's') { - argtype = sizeof buf; - anum = recvfrom(fileno(stab_io(stab)->ifp), tmps+maxarg, anum, 0, - buf, &argtype); - } - else -#endif - anum = fread(tmps+maxarg, 1, anum, stab_io(stab)->ifp); - if (anum < 0) - goto say_undef; - st[2]->str_cur = anum+maxarg; - st[2]->str_ptr[anum+maxarg] = '\0'; - value = (double)anum; - goto donumset; - case O_SYSWRITE: - case O_SEND: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - tmps = str_get(st[2]); - anum = (int)str_gnum(st[3]); - errno = 0; - stio = stab_io(stab); - maxarg = sp - arglast[0]; - if (!stio || !stio->ifp) { - anum = -1; - if (dowarn) { - if (optype == O_SYSWRITE) - warn("Syswrite on closed filehandle"); - else - warn("Send on closed socket"); - } - } - else if (optype == O_SYSWRITE) { - if (maxarg > 4) - warn("Too many args on syswrite"); - if (maxarg == 4) - optype = (int)str_gnum(st[4]); - else - optype = 0; - anum = write(fileno(stab_io(stab)->ifp), tmps+optype, anum); - } -#ifdef HAS_SOCKET - else if (maxarg >= 4) { - if (maxarg > 4) - warn("Too many args on send"); - tmps2 = str_get(st[4]); - anum = sendto(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, - anum, tmps2, st[4]->str_cur); - } - else - anum = send(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, anum); -#else - else - goto badsock; -#endif - if (anum < 0) - goto say_undef; - value = (double)anum; - goto donumset; - case O_SEEK: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - value = str_gnum(st[2]); - str_set(str, do_seek(stab, - (long)value, (int)str_gnum(st[3]) ) ? Yes : No); - STABSET(str); - break; - case O_RETURN: - tmps = "_SUB_"; /* just fake up a "last _SUB_" */ - optype = O_LAST; - if (curcsv && curcsv->wantarray == G_ARRAY) { - lastretstr = Nullstr; - lastspbase = arglast[1]; - lastsize = arglast[2] - arglast[1]; - } - else - lastretstr = str_mortal(st[arglast[2] - arglast[0]]); - goto dopop; - case O_REDO: - case O_NEXT: - case O_LAST: - tmps = Nullch; - if (maxarg > 0) { - tmps = str_get(arg[1].arg_ptr.arg_str); - dopop: - while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label || - strNE(tmps,loop_stack[loop_ptr].loop_label) )) { -#ifdef DEBUGGING - if (debug & 4) { - deb("(Skipping label #%d %s)\n",loop_ptr, - loop_stack[loop_ptr].loop_label); - } -#endif - loop_ptr--; - } -#ifdef DEBUGGING - if (debug & 4) { - deb("(Found label #%d %s)\n",loop_ptr, - loop_stack[loop_ptr].loop_label); - } -#endif - } - if (loop_ptr < 0) { - if (tmps && strEQ(tmps, "_SUB_")) - fatal("Can't return outside a subroutine"); - fatal("Bad label: %s", maxarg > 0 ? tmps : "<null>"); - } - if (!lastretstr && optype == O_LAST && lastsize) { - st -= arglast[0]; - st += lastspbase + 1; - optype = loop_stack[loop_ptr].loop_sp - lastspbase; /* negative */ - if (optype) { - for (anum = lastsize; anum > 0; anum--,st++) - st[optype] = str_mortal(st[0]); - } - longjmp(loop_stack[loop_ptr].loop_env, O_LAST); - } - longjmp(loop_stack[loop_ptr].loop_env, optype); - case O_DUMP: - case O_GOTO:/* shudder */ - goto_targ = str_get(arg[1].arg_ptr.arg_str); - if (!*goto_targ) - goto_targ = Nullch; /* just restart from top */ - if (optype == O_DUMP) { - do_undump = TRUE; - my_unexec(); - } - longjmp(top_env, 1); - case O_INDEX: - tmps = str_get(st[1]); - if (maxarg < 3) - anum = 0; - else { - anum = (int) str_gnum(st[3]) - arybase; - if (anum < 0) - anum = 0; - else if (anum > st[1]->str_cur) - anum = st[1]->str_cur; - } -#ifndef lint - if (!(tmps2 = fbminstr((unsigned char*)tmps + anum, - (unsigned char*)tmps + st[1]->str_cur, st[2]))) -#else - if (tmps2 = fbminstr(Null(unsigned char*),Null(unsigned char*),Nullstr)) -#endif - value = (double)(-1 + arybase); - else - value = (double)(tmps2 - tmps + arybase); - goto donumset; - case O_RINDEX: - tmps = str_get(st[1]); - tmps2 = str_get(st[2]); - if (maxarg < 3) - anum = st[1]->str_cur; - else { - anum = (int) str_gnum(st[3]) - arybase + st[2]->str_cur; - if (anum < 0) - anum = 0; - else if (anum > st[1]->str_cur) - anum = st[1]->str_cur; - } -#ifndef lint - if (!(tmps2 = rninstr(tmps, tmps + anum, - tmps2, tmps2 + st[2]->str_cur))) -#else - if (tmps2 = rninstr(Nullch,Nullch,Nullch,Nullch)) -#endif - value = (double)(-1 + arybase); - else - value = (double)(tmps2 - tmps + arybase); - goto donumset; - case O_TIME: -#ifndef lint - value = (double) time(Null(long*)); -#endif - goto donumset; - case O_TMS: - sp = do_tms(str,gimme,arglast); - goto array_return; - case O_LOCALTIME: - if (maxarg < 1) - (void)time(&when); - else - when = (time_t)str_gnum(st[1]); - sp = do_time(str,localtime(&when), - gimme,arglast); - goto array_return; - case O_GMTIME: - if (maxarg < 1) - (void)time(&when); - else - when = (time_t)str_gnum(st[1]); - sp = do_time(str,gmtime(&when), - gimme,arglast); - goto array_return; - case O_TRUNCATE: - sp = do_truncate(str,arg, - gimme,arglast); - goto array_return; - case O_LSTAT: - case O_STAT: - sp = do_stat(str,arg, - gimme,arglast); - goto array_return; - case O_CRYPT: -#ifdef HAS_CRYPT - tmps = str_get(st[1]); -#ifdef FCRYPT - str_set(str,fcrypt(tmps,str_get(st[2]))); -#else - str_set(str,crypt(tmps,str_get(st[2]))); -#endif -#else - fatal( - "The crypt() function is unimplemented due to excessive paranoia."); -#endif - break; - case O_ATAN2: - value = str_gnum(st[1]); - value = atan2(value,str_gnum(st[2])); - goto donumset; - case O_SIN: - if (maxarg < 1) - value = str_gnum(stab_val(defstab)); - else - value = str_gnum(st[1]); - value = sin(value); - goto donumset; - case O_COS: - if (maxarg < 1) - value = str_gnum(stab_val(defstab)); - else - value = str_gnum(st[1]); - value = cos(value); - goto donumset; - case O_RAND: - if (maxarg < 1) - value = 1.0; - else - value = str_gnum(st[1]); - if (value == 0.0) - value = 1.0; -#if RANDBITS == 31 - value = rand() * value / 2147483648.0; -#else -#if RANDBITS == 16 - value = rand() * value / 65536.0; -#else -#if RANDBITS == 15 - value = rand() * value / 32768.0; -#else - value = rand() * value / (double)(((unsigned long)1) << RANDBITS); -#endif -#endif -#endif - goto donumset; - case O_SRAND: - if (maxarg < 1) { - (void)time(&when); - anum = when; - } - else - anum = (int)str_gnum(st[1]); - (void)srand(anum); - goto say_yes; - case O_EXP: - if (maxarg < 1) - value = str_gnum(stab_val(defstab)); - else - value = str_gnum(st[1]); - value = exp(value); - goto donumset; - case O_LOG: - if (maxarg < 1) - value = str_gnum(stab_val(defstab)); - else - value = str_gnum(st[1]); - if (value <= 0.0) - fatal("Can't take log of %g\n", value); - value = log(value); - goto donumset; - case O_SQRT: - if (maxarg < 1) - value = str_gnum(stab_val(defstab)); - else - value = str_gnum(st[1]); - if (value < 0.0) - fatal("Can't take sqrt of %g\n", value); - value = sqrt(value); - goto donumset; - case O_INT: - if (maxarg < 1) - value = str_gnum(stab_val(defstab)); - else - value = str_gnum(st[1]); - if (value >= 0.0) - (void)modf(value,&value); - else { - (void)modf(-value,&value); - value = -value; - } - goto donumset; - case O_ORD: - if (maxarg < 1) - tmps = str_get(stab_val(defstab)); - else - tmps = str_get(st[1]); -#ifndef I286 - value = (double) (*tmps & 255); -#else - anum = (int) *tmps; - value = (double) (anum & 255); -#endif - goto donumset; - case O_ALARM: -#ifdef HAS_ALARM - if (maxarg < 1) - tmps = str_get(stab_val(defstab)); - else - tmps = str_get(st[1]); - if (!tmps) - tmps = "0"; - anum = alarm((unsigned int)atoi(tmps)); - if (anum < 0) - goto say_undef; - value = (double)anum; - goto donumset; -#else - fatal("Unsupported function alarm"); - break; -#endif - case O_SLEEP: - if (maxarg < 1) - tmps = Nullch; - else - tmps = str_get(st[1]); - (void)time(&when); - if (!tmps || !*tmps) - sleep((32767<<16)+32767); - else - sleep((unsigned int)atoi(tmps)); -#ifndef lint - value = (double)when; - (void)time(&when); - value = ((double)when) - value; -#endif - goto donumset; - case O_RANGE: - sp = do_range(gimme,arglast); - goto array_return; - case O_F_OR_R: - if (gimme == G_ARRAY) { /* it's a range */ - /* can we optimize to constant array? */ - if ((arg[1].arg_type & A_MASK) == A_SINGLE && - (arg[2].arg_type & A_MASK) == A_SINGLE) { - st[2] = arg[2].arg_ptr.arg_str; - sp = do_range(gimme,arglast); - st = stack->ary_array; - maxarg = sp - arglast[0]; - str_free(arg[1].arg_ptr.arg_str); - arg[1].arg_ptr.arg_str = Nullstr; - str_free(arg[2].arg_ptr.arg_str); - arg[2].arg_ptr.arg_str = Nullstr; - arg->arg_type = O_ARRAY; - arg[1].arg_type = A_STAB|A_DONT; - arg->arg_len = 1; - stab = arg[1].arg_ptr.arg_stab = aadd(genstab()); - ary = stab_array(stab); - afill(ary,maxarg - 1); - anum = maxarg; - st += arglast[0]+1; - while (maxarg-- > 0) - ary->ary_array[maxarg] = str_smake(st[maxarg]); - st -= arglast[0]+1; - goto array_return; - } - arg->arg_type = optype = O_RANGE; - maxarg = arg->arg_len = 2; - anum = 2; - arg[anum].arg_flags &= ~AF_ARYOK; - argflags = arg[anum].arg_flags; - argtype = arg[anum].arg_type & A_MASK; - arg[anum].arg_type = argtype; - argptr = arg[anum].arg_ptr; - sp = arglast[0]; - st -= sp; - sp++; - goto re_eval; - } - arg->arg_type = O_FLIP; - /* FALL THROUGH */ - case O_FLIP: - if ((arg[1].arg_type & A_MASK) == A_SINGLE ? - last_in_stab && (int)str_gnum(st[1]) == stab_io(last_in_stab)->lines - : - str_true(st[1]) ) { - arg[2].arg_type &= ~A_DONT; - arg[1].arg_type |= A_DONT; - arg->arg_type = optype = O_FLOP; - if (arg->arg_flags & AF_COMMON) { - str_numset(str,0.0); - anum = 2; - argflags = arg[2].arg_flags; - argtype = arg[2].arg_type & A_MASK; - argptr = arg[2].arg_ptr; - sp = arglast[0]; - st -= sp++; - goto re_eval; - } - else { - str_numset(str,1.0); - break; - } - } - str_set(str,""); - break; - case O_FLOP: - str_inc(str); - if ((arg[2].arg_type & A_MASK) == A_SINGLE ? - last_in_stab && (int)str_gnum(st[2]) == stab_io(last_in_stab)->lines - : - str_true(st[2]) ) { - arg->arg_type = O_FLIP; - arg[1].arg_type &= ~A_DONT; - arg[2].arg_type |= A_DONT; - str_cat(str,"E0"); - } - break; - case O_FORK: -#ifdef HAS_FORK - anum = fork(); - if (anum < 0) - goto say_undef; - if (!anum) { - /*SUPPRESS 560*/ - if (tmpstab = stabent("$",allstabs)) - str_numset(STAB_STR(tmpstab),(double)getpid()); - hclear(pidstatus, FALSE); /* no kids, so don't wait for 'em */ - } - value = (double)anum; - goto donumset; -#else - fatal("Unsupported function fork"); - break; -#endif - case O_WAIT: -#ifdef HAS_WAIT -#ifndef lint - anum = wait(&argflags); - if (anum > 0) - pidgone(anum,argflags); - value = (double)anum; -#endif - statusvalue = (unsigned short)argflags; - goto donumset; -#else - fatal("Unsupported function wait"); - break; -#endif - case O_WAITPID: -#ifdef HAS_WAIT -#ifndef lint - anum = (int)str_gnum(st[1]); - optype = (int)str_gnum(st[2]); - anum = wait4pid(anum, &argflags,optype); - value = (double)anum; -#endif - statusvalue = (unsigned short)argflags; - goto donumset; -#else - fatal("Unsupported function wait"); - break; -#endif - case O_SYSTEM: -#ifdef HAS_FORK -#ifdef TAINT - if (arglast[2] - arglast[1] == 1) { - taintenv(); - tainted |= st[2]->str_tainted; - TAINT_PROPER("system"); - } -#endif - while ((anum = vfork()) == -1) { - if (errno != EAGAIN) { - value = -1.0; - goto donumset; - } - sleep(5); - } - if (anum > 0) { -#ifndef lint - ihand = signal(SIGINT, SIG_IGN); - qhand = signal(SIGQUIT, SIG_IGN); - argtype = wait4pid(anum, &argflags, 0); -#else - ihand = qhand = 0; -#endif - (void)signal(SIGINT, ihand); - (void)signal(SIGQUIT, qhand); - statusvalue = (unsigned short)argflags; - if (argtype < 0) - value = -1.0; - else { - value = (double)((unsigned int)argflags & 0xffff); - } - do_execfree(); /* free any memory child malloced on vfork */ - goto donumset; - } - if ((arg[1].arg_type & A_MASK) == A_STAB) - value = (double)do_aexec(st[1],arglast); - else if (arglast[2] - arglast[1] != 1) - value = (double)do_aexec(Nullstr,arglast); - else { - value = (double)do_exec(str_get(str_mortal(st[2]))); - } - _exit(-1); -#else /* ! FORK */ - if ((arg[1].arg_type & A_MASK) == A_STAB) - value = (double)do_aspawn(st[1],arglast); - else if (arglast[2] - arglast[1] != 1) - value = (double)do_aspawn(Nullstr,arglast); - else { - value = (double)do_spawn(str_get(str_mortal(st[2]))); - } - goto donumset; -#endif /* FORK */ - case O_EXEC_OP: - if ((arg[1].arg_type & A_MASK) == A_STAB) - value = (double)do_aexec(st[1],arglast); - else if (arglast[2] - arglast[1] != 1) - value = (double)do_aexec(Nullstr,arglast); - else { -#ifdef TAINT - taintenv(); - tainted |= st[2]->str_tainted; - TAINT_PROPER("exec"); -#endif - value = (double)do_exec(str_get(str_mortal(st[2]))); - } - goto donumset; - case O_HEX: - if (maxarg < 1) - tmps = str_get(stab_val(defstab)); - else - tmps = str_get(st[1]); - value = (double)scanhex(tmps, 99, &argtype); - goto donumset; - - case O_OCT: - if (maxarg < 1) - tmps = str_get(stab_val(defstab)); - else - tmps = str_get(st[1]); - while (*tmps && (isSPACE(*tmps) || *tmps == '0')) - tmps++; - if (*tmps == 'x') - value = (double)scanhex(++tmps, 99, &argtype); - else - value = (double)scanoct(tmps, 99, &argtype); - goto donumset; - -/* These common exits are hidden here in the middle of the switches for the - benefit of those machines with limited branch addressing. Sigh. */ - -array_return: -#ifdef DEBUGGING - if (debug) { - dlevel--; - if (debug & 8) { - anum = sp - arglast[0]; - switch (anum) { - case 0: - deb("%s RETURNS ()\n",opname[optype]); - break; - case 1: - deb("%s RETURNS (\"%s\")\n",opname[optype], - st[1] ? str_get(st[1]) : ""); - break; - default: - tmps = st[1] ? str_get(st[1]) : ""; - deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\")\n",opname[optype], - anum,tmps,anum==2?"":"...,", - st[anum] ? str_get(st[anum]) : ""); - break; - } - } - } -#endif - stack_ary = stack->ary_array; - stack_max = stack_ary + stack->ary_max; - stack_sp = stack_ary + sp; - return sp; - -say_yes: - str = &str_yes; - goto normal_return; - -say_no: - str = &str_no; - goto normal_return; - -say_undef: - str = &str_undef; - goto normal_return; - -say_zero: - value = 0.0; - /* FALL THROUGH */ - -donumset: - str_numset(str,value); - STABSET(str); - st[1] = str; -#ifdef DEBUGGING - if (debug) { - dlevel--; - if (debug & 8) - deb("%s RETURNS \"%f\"\n",opname[optype],value); - } -#endif - stack_ary = stack->ary_array; - stack_max = stack_ary + stack->ary_max; - stack_sp = stack_ary + arglast[0] + 1; - return arglast[0] + 1; -#ifdef SMALLSWITCHES - } - else - switch (optype) { -#endif - case O_CHOWN: -#ifdef HAS_CHOWN - value = (double)apply(optype,arglast); - goto donumset; -#else - fatal("Unsupported function chown"); - break; -#endif - case O_KILL: -#ifdef HAS_KILL - value = (double)apply(optype,arglast); - goto donumset; -#else - fatal("Unsupported function kill"); - break; -#endif - case O_UNLINK: - case O_CHMOD: - case O_UTIME: - value = (double)apply(optype,arglast); - goto donumset; - case O_UMASK: -#ifdef HAS_UMASK - if (maxarg < 1) { - anum = umask(0); - (void)umask(anum); - } - else - anum = umask((int)str_gnum(st[1])); - value = (double)anum; -#ifdef TAINT - TAINT_PROPER("umask"); -#endif - goto donumset; -#else - fatal("Unsupported function umask"); - break; -#endif -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - case O_MSGGET: - case O_SHMGET: - case O_SEMGET: - if ((anum = do_ipcget(optype, arglast)) == -1) - goto say_undef; - value = (double)anum; - goto donumset; - case O_MSGCTL: - case O_SHMCTL: - case O_SEMCTL: - anum = do_ipcctl(optype, arglast); - if (anum == -1) - goto say_undef; - if (anum != 0) { - value = (double)anum; - goto donumset; - } - str_set(str,"0 but true"); - STABSET(str); - break; - case O_MSGSND: - value = (double)(do_msgsnd(arglast) >= 0); - goto donumset; - case O_MSGRCV: - value = (double)(do_msgrcv(arglast) >= 0); - goto donumset; - case O_SEMOP: - value = (double)(do_semop(arglast) >= 0); - goto donumset; - case O_SHMREAD: - case O_SHMWRITE: - value = (double)(do_shmio(optype, arglast) >= 0); - goto donumset; -#else /* not SYSVIPC */ - case O_MSGGET: - case O_MSGCTL: - case O_MSGSND: - case O_MSGRCV: - case O_SEMGET: - case O_SEMCTL: - case O_SEMOP: - case O_SHMGET: - case O_SHMCTL: - case O_SHMREAD: - case O_SHMWRITE: - fatal("System V IPC is not implemented on this machine"); -#endif /* not SYSVIPC */ - case O_RENAME: - tmps = str_get(st[1]); - tmps2 = str_get(st[2]); -#ifdef TAINT - TAINT_PROPER("rename"); -#endif -#ifdef HAS_RENAME - value = (double)(rename(tmps,tmps2) >= 0); -#else - if (same_dirent(tmps2, tmps)) /* can always rename to same name */ - anum = 1; - else { - if (euid || stat(tmps2,&statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) - (void)UNLINK(tmps2); - if (!(anum = link(tmps,tmps2))) - anum = UNLINK(tmps); - } - value = (double)(anum >= 0); -#endif - goto donumset; - case O_LINK: -#ifdef HAS_LINK - tmps = str_get(st[1]); - tmps2 = str_get(st[2]); -#ifdef TAINT - TAINT_PROPER("link"); -#endif - value = (double)(link(tmps,tmps2) >= 0); - goto donumset; -#else - fatal("Unsupported function link"); - break; -#endif - case O_MKDIR: - tmps = str_get(st[1]); - anum = (int)str_gnum(st[2]); -#ifdef TAINT - TAINT_PROPER("mkdir"); -#endif -#ifdef HAS_MKDIR - value = (double)(mkdir(tmps,anum) >= 0); - goto donumset; -#else - (void)strcpy(buf,"mkdir "); -#endif -#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) - one_liner: - for (tmps2 = buf+6; *tmps; ) { - *tmps2++ = '\\'; - *tmps2++ = *tmps++; - } - (void)strcpy(tmps2," 2>&1"); - rsfp = mypopen(buf,"r"); - if (rsfp) { - *buf = '\0'; - tmps2 = fgets(buf,sizeof buf,rsfp); - (void)mypclose(rsfp); - if (tmps2 != Nullch) { - for (errno = 1; errno < sys_nerr; errno++) { - if (instr(buf,sys_errlist[errno])) /* you don't see this */ - goto say_zero; - } - errno = 0; -#ifndef EACCES -#define EACCES EPERM -#endif - if (instr(buf,"cannot make")) - errno = EEXIST; - else if (instr(buf,"existing file")) - errno = EEXIST; - else if (instr(buf,"ile exists")) - errno = EEXIST; - else if (instr(buf,"non-exist")) - errno = ENOENT; - else if (instr(buf,"does not exist")) - errno = ENOENT; - else if (instr(buf,"not empty")) - errno = EBUSY; - else if (instr(buf,"cannot access")) - errno = EACCES; - else - errno = EPERM; - goto say_zero; - } - else { /* some mkdirs return no failure indication */ - tmps = str_get(st[1]); - anum = (stat(tmps,&statbuf) >= 0); - if (optype == O_RMDIR) - anum = !anum; - if (anum) - errno = 0; - else - errno = EACCES; /* a guess */ - value = (double)anum; - } - goto donumset; - } - else - goto say_zero; -#endif - case O_RMDIR: - if (maxarg < 1) - tmps = str_get(stab_val(defstab)); - else - tmps = str_get(st[1]); -#ifdef TAINT - TAINT_PROPER("rmdir"); -#endif -#ifdef HAS_RMDIR - value = (double)(rmdir(tmps) >= 0); - goto donumset; -#else - (void)strcpy(buf,"rmdir "); - goto one_liner; /* see above in HAS_MKDIR */ -#endif - case O_GETPPID: -#ifdef HAS_GETPPID - value = (double)getppid(); - goto donumset; -#else - fatal("Unsupported function getppid"); - break; -#endif - case O_GETPGRP: -#ifdef HAS_GETPGRP - if (maxarg < 1) - anum = 0; - else - anum = (int)str_gnum(st[1]); -#ifdef _POSIX_SOURCE - if (anum != 0) - fatal("POSIX getpgrp can't take an argument"); - value = (double)getpgrp(); -#else - value = (double)getpgrp(anum); -#endif - goto donumset; -#else - fatal("The getpgrp() function is unimplemented on this machine"); - break; -#endif - case O_SETPGRP: -#ifdef HAS_SETPGRP - argtype = (int)str_gnum(st[1]); - anum = (int)str_gnum(st[2]); -#ifdef TAINT - TAINT_PROPER("setpgrp"); -#endif - value = (double)(setpgrp(argtype,anum) >= 0); - goto donumset; -#else - fatal("The setpgrp() function is unimplemented on this machine"); - break; -#endif - case O_GETPRIORITY: -#ifdef HAS_GETPRIORITY - argtype = (int)str_gnum(st[1]); - anum = (int)str_gnum(st[2]); - value = (double)getpriority(argtype,anum); - goto donumset; -#else - fatal("The getpriority() function is unimplemented on this machine"); - break; -#endif - case O_SETPRIORITY: -#ifdef HAS_SETPRIORITY - argtype = (int)str_gnum(st[1]); - anum = (int)str_gnum(st[2]); - optype = (int)str_gnum(st[3]); -#ifdef TAINT - TAINT_PROPER("setpriority"); -#endif - value = (double)(setpriority(argtype,anum,optype) >= 0); - goto donumset; -#else - fatal("The setpriority() function is unimplemented on this machine"); - break; -#endif - case O_CHROOT: -#ifdef HAS_CHROOT - if (maxarg < 1) - tmps = str_get(stab_val(defstab)); - else - tmps = str_get(st[1]); -#ifdef TAINT - TAINT_PROPER("chroot"); -#endif - value = (double)(chroot(tmps) >= 0); - goto donumset; -#else - fatal("Unsupported function chroot"); - break; -#endif - case O_FCNTL: - case O_IOCTL: - if (maxarg <= 0) - stab = last_in_stab; - else if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - argtype = U_I(str_gnum(st[2])); -#ifdef TAINT - TAINT_PROPER("ioctl"); -#endif - anum = do_ctl(optype,stab,argtype,st[3]); - if (anum == -1) - goto say_undef; - if (anum != 0) { - value = (double)anum; - goto donumset; - } - str_set(str,"0 but true"); - STABSET(str); - break; - case O_FLOCK: -#ifdef HAS_FLOCK - if (maxarg <= 0) - stab = last_in_stab; - else if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if (stab && stab_io(stab)) - fp = stab_io(stab)->ifp; - else - fp = Nullfp; - if (fp) { - argtype = (int)str_gnum(st[2]); - value = (double)(flock(fileno(fp),argtype) >= 0); - } - else - value = 0; - goto donumset; -#else - fatal("The flock() function is unimplemented on this machine"); - break; -#endif - case O_UNSHIFT: - ary = stab_array(arg[1].arg_ptr.arg_stab); - if (arglast[2] - arglast[1] != 1) - do_unshift(ary,arglast); - else { - STR *tmpstr = Str_new(52,0); /* must copy the STR */ - str_sset(tmpstr,st[2]); - aunshift(ary,1); - (void)astore(ary,0,tmpstr); - } - value = (double)(ary->ary_fill + 1); - goto donumset; - - case O_TRY: - sp = do_try(arg[1].arg_ptr.arg_cmd, - gimme,arglast); - goto array_return; - - case O_EVALONCE: - sp = do_eval(st[1], O_EVAL, curcmd->c_stash, TRUE, - gimme,arglast); - if (eval_root) { - str_free(arg[1].arg_ptr.arg_str); - arg[1].arg_ptr.arg_cmd = eval_root; - arg[1].arg_type = (A_CMD|A_DONT); - arg[0].arg_type = O_TRY; - } - goto array_return; - - case O_REQUIRE: - case O_DOFILE: - case O_EVAL: - if (maxarg < 1) - tmpstr = stab_val(defstab); - else - tmpstr = - (arg[1].arg_type & A_MASK) != A_NULL ? st[1] : stab_val(defstab); -#ifdef TAINT - tainted |= tmpstr->str_tainted; - TAINT_PROPER("eval"); -#endif - sp = do_eval(tmpstr, optype, curcmd->c_stash, FALSE, - gimme,arglast); - goto array_return; - - case O_FTRREAD: - argtype = 0; - anum = S_IRUSR; - goto check_perm; - case O_FTRWRITE: - argtype = 0; - anum = S_IWUSR; - goto check_perm; - case O_FTREXEC: - argtype = 0; - anum = S_IXUSR; - goto check_perm; - case O_FTEREAD: - argtype = 1; - anum = S_IRUSR; - goto check_perm; - case O_FTEWRITE: - argtype = 1; - anum = S_IWUSR; - goto check_perm; - case O_FTEEXEC: - argtype = 1; - anum = S_IXUSR; - check_perm: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (cando(anum,argtype,&statcache)) - goto say_yes; - goto say_no; - - case O_FTIS: - if (mystat(arg,st[1]) < 0) - goto say_undef; - goto say_yes; - case O_FTEOWNED: - case O_FTROWNED: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (statcache.st_uid == (optype == O_FTEOWNED ? euid : uid) ) - goto say_yes; - goto say_no; - case O_FTZERO: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (!statcache.st_size) - goto say_yes; - goto say_no; - case O_FTSIZE: - if (mystat(arg,st[1]) < 0) - goto say_undef; - value = (double)statcache.st_size; - goto donumset; - - case O_FTMTIME: - if (mystat(arg,st[1]) < 0) - goto say_undef; - value = (double)(basetime - statcache.st_mtime) / 86400.0; - goto donumset; - case O_FTATIME: - if (mystat(arg,st[1]) < 0) - goto say_undef; - value = (double)(basetime - statcache.st_atime) / 86400.0; - goto donumset; - case O_FTCTIME: - if (mystat(arg,st[1]) < 0) - goto say_undef; - value = (double)(basetime - statcache.st_ctime) / 86400.0; - goto donumset; - - case O_FTSOCK: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (S_ISSOCK(statcache.st_mode)) - goto say_yes; - goto say_no; - case O_FTCHR: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (S_ISCHR(statcache.st_mode)) - goto say_yes; - goto say_no; - case O_FTBLK: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (S_ISBLK(statcache.st_mode)) - goto say_yes; - goto say_no; - case O_FTFILE: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (S_ISREG(statcache.st_mode)) - goto say_yes; - goto say_no; - case O_FTDIR: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (S_ISDIR(statcache.st_mode)) - goto say_yes; - goto say_no; - case O_FTPIPE: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (S_ISFIFO(statcache.st_mode)) - goto say_yes; - goto say_no; - case O_FTLINK: - if (mylstat(arg,st[1]) < 0) - goto say_undef; - if (S_ISLNK(statcache.st_mode)) - goto say_yes; - goto say_no; - case O_SYMLINK: -#ifdef HAS_SYMLINK - tmps = str_get(st[1]); - tmps2 = str_get(st[2]); -#ifdef TAINT - TAINT_PROPER("symlink"); -#endif - value = (double)(symlink(tmps,tmps2) >= 0); - goto donumset; -#else - fatal("Unsupported function symlink"); -#endif - case O_READLINK: -#ifdef HAS_SYMLINK - if (maxarg < 1) - tmps = str_get(stab_val(defstab)); - else - tmps = str_get(st[1]); - anum = readlink(tmps,buf,sizeof buf); - if (anum < 0) - goto say_undef; - str_nset(str,buf,anum); - break; -#else - goto say_undef; /* just pretend it's a normal file */ -#endif - case O_FTSUID: -#ifdef S_ISUID - anum = S_ISUID; - goto check_xid; -#else - goto say_no; -#endif - case O_FTSGID: -#ifdef S_ISGID - anum = S_ISGID; - goto check_xid; -#else - goto say_no; -#endif - case O_FTSVTX: -#ifdef S_ISVTX - anum = S_ISVTX; -#else - goto say_no; -#endif - check_xid: - if (mystat(arg,st[1]) < 0) - goto say_undef; - if (statcache.st_mode & anum) - goto say_yes; - goto say_no; - case O_FTTTY: - if (arg[1].arg_type & A_DONT) { - stab = arg[1].arg_ptr.arg_stab; - tmps = ""; - } - else - stab = stabent(tmps = str_get(st[1]),FALSE); - if (stab && stab_io(stab) && stab_io(stab)->ifp) - anum = fileno(stab_io(stab)->ifp); - else if (isDIGIT(*tmps)) - anum = atoi(tmps); - else - goto say_undef; - if (isatty(anum)) - goto say_yes; - goto say_no; - case O_FTTEXT: - case O_FTBINARY: - str = do_fttext(arg,st[1]); - break; -#ifdef HAS_SOCKET - case O_SOCKET: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); -#ifndef lint - value = (double)do_socket(stab,arglast); -#else - (void)do_socket(stab,arglast); -#endif - goto donumset; - case O_BIND: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); -#ifndef lint - value = (double)do_bind(stab,arglast); -#else - (void)do_bind(stab,arglast); -#endif - goto donumset; - case O_CONNECT: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); -#ifndef lint - value = (double)do_connect(stab,arglast); -#else - (void)do_connect(stab,arglast); -#endif - goto donumset; - case O_LISTEN: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); -#ifndef lint - value = (double)do_listen(stab,arglast); -#else - (void)do_listen(stab,arglast); -#endif - goto donumset; - case O_ACCEPT: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if ((arg[2].arg_type & A_MASK) == A_WORD) - stab2 = arg[2].arg_ptr.arg_stab; - else - stab2 = stabent(str_get(st[2]),TRUE); - do_accept(str,stab,stab2); - STABSET(str); - break; - case O_GHBYNAME: - if (maxarg < 1) - goto say_undef; - case O_GHBYADDR: - case O_GHOSTENT: - sp = do_ghent(optype, - gimme,arglast); - goto array_return; - case O_GNBYNAME: - if (maxarg < 1) - goto say_undef; - case O_GNBYADDR: - case O_GNETENT: - sp = do_gnent(optype, - gimme,arglast); - goto array_return; - case O_GPBYNAME: - if (maxarg < 1) - goto say_undef; - case O_GPBYNUMBER: - case O_GPROTOENT: - sp = do_gpent(optype, - gimme,arglast); - goto array_return; - case O_GSBYNAME: - if (maxarg < 1) - goto say_undef; - case O_GSBYPORT: - case O_GSERVENT: - sp = do_gsent(optype, - gimme,arglast); - goto array_return; - case O_SHOSTENT: - value = (double) sethostent((int)str_gnum(st[1])); - goto donumset; - case O_SNETENT: - value = (double) setnetent((int)str_gnum(st[1])); - goto donumset; - case O_SPROTOENT: - value = (double) setprotoent((int)str_gnum(st[1])); - goto donumset; - case O_SSERVENT: - value = (double) setservent((int)str_gnum(st[1])); - goto donumset; - case O_EHOSTENT: - value = (double) endhostent(); - goto donumset; - case O_ENETENT: - value = (double) endnetent(); - goto donumset; - case O_EPROTOENT: - value = (double) endprotoent(); - goto donumset; - case O_ESERVENT: - value = (double) endservent(); - goto donumset; - case O_SOCKPAIR: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if ((arg[2].arg_type & A_MASK) == A_WORD) - stab2 = arg[2].arg_ptr.arg_stab; - else - stab2 = stabent(str_get(st[2]),TRUE); -#ifndef lint - value = (double)do_spair(stab,stab2,arglast); -#else - (void)do_spair(stab,stab2,arglast); -#endif - goto donumset; - case O_SHUTDOWN: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); -#ifndef lint - value = (double)do_shutdown(stab,arglast); -#else - (void)do_shutdown(stab,arglast); -#endif - goto donumset; - case O_GSOCKOPT: - case O_SSOCKOPT: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - sp = do_sopt(optype,stab,arglast); - goto array_return; - case O_GETSOCKNAME: - case O_GETPEERNAME: - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if (!stab) - goto say_undef; - sp = do_getsockname(optype,stab,arglast); - goto array_return; - -#else /* HAS_SOCKET not defined */ - case O_SOCKET: - case O_BIND: - case O_CONNECT: - case O_LISTEN: - case O_ACCEPT: - case O_SOCKPAIR: - case O_GHBYNAME: - case O_GHBYADDR: - case O_GHOSTENT: - case O_GNBYNAME: - case O_GNBYADDR: - case O_GNETENT: - case O_GPBYNAME: - case O_GPBYNUMBER: - case O_GPROTOENT: - case O_GSBYNAME: - case O_GSBYPORT: - case O_GSERVENT: - case O_SHOSTENT: - case O_SNETENT: - case O_SPROTOENT: - case O_SSERVENT: - case O_EHOSTENT: - case O_ENETENT: - case O_EPROTOENT: - case O_ESERVENT: - case O_SHUTDOWN: - case O_GSOCKOPT: - case O_SSOCKOPT: - case O_GETSOCKNAME: - case O_GETPEERNAME: - badsock: - fatal("Unsupported socket function"); -#endif /* HAS_SOCKET */ - case O_SSELECT: -#ifdef HAS_SELECT - sp = do_select(gimme,arglast); - goto array_return; -#else - fatal("select not implemented"); -#endif - case O_FILENO: - if (maxarg < 1) - goto say_undef; - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp)) - goto say_undef; - value = fileno(fp); - goto donumset; - case O_BINMODE: - if (maxarg < 1) - goto say_undef; - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp)) - goto say_undef; -#ifdef DOSISH -#ifdef atarist - if(fflush(fp)) - str_set(str, No); - else - { - fp->_flag |= _IOBIN; - str_set(str, Yes); - } -#else - str_set(str, (setmode(fileno(fp), O_BINARY) != -1) ? Yes : No); -#endif -#else - str_set(str, Yes); -#endif - STABSET(str); - break; - case O_VEC: - sp = do_vec(str == st[1], arg->arg_ptr.arg_str, arglast); - goto array_return; - case O_GPWNAM: - case O_GPWUID: - case O_GPWENT: -#ifdef HAS_PASSWD - sp = do_gpwent(optype, - gimme,arglast); - goto array_return; - case O_SPWENT: - value = (double) setpwent(); - goto donumset; - case O_EPWENT: - value = (double) endpwent(); - goto donumset; -#else - case O_EPWENT: - case O_SPWENT: - fatal("Unsupported password function"); - break; -#endif - case O_GGRNAM: - case O_GGRGID: - case O_GGRENT: -#ifdef HAS_GROUP - sp = do_ggrent(optype, - gimme,arglast); - goto array_return; - case O_SGRENT: - value = (double) setgrent(); - goto donumset; - case O_EGRENT: - value = (double) endgrent(); - goto donumset; -#else - case O_EGRENT: - case O_SGRENT: - fatal("Unsupported group function"); - break; -#endif - case O_GETLOGIN: -#ifdef HAS_GETLOGIN - if (!(tmps = getlogin())) - goto say_undef; - str_set(str,tmps); -#else - fatal("Unsupported function getlogin"); -#endif - break; - case O_OPEN_DIR: - case O_READDIR: - case O_TELLDIR: - case O_SEEKDIR: - case O_REWINDDIR: - case O_CLOSEDIR: - if (maxarg < 1) - goto say_undef; - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if (!stab) - goto say_undef; - sp = do_dirop(optype,stab,gimme,arglast); - goto array_return; - case O_SYSCALL: - value = (double)do_syscall(arglast); - goto donumset; - case O_PIPE_OP: -#ifdef HAS_PIPE - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if ((arg[2].arg_type & A_MASK) == A_WORD) - stab2 = arg[2].arg_ptr.arg_stab; - else - stab2 = stabent(str_get(st[2]),TRUE); - do_pipe(str,stab,stab2); - STABSET(str); -#else - fatal("Unsupported function pipe"); -#endif - break; - } - - normal_return: - st[1] = str; -#ifdef DEBUGGING - if (debug) { - dlevel--; - if (debug & 8) - deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str)); - } -#endif - stack_ary = stack->ary_array; - stack_max = stack_ary + stack->ary_max; - stack_sp = stack_ary + arglast[0] + 1; - return arglast[0] + 1; -} diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm new file mode 100644 index 0000000000..d66ab2cabe --- /dev/null +++ b/ext/DB_File/DB_File.pm @@ -0,0 +1,248 @@ +# DB_File.pm -- Perl 5 interface to Berkeley DB +# +# written by Paul Marquess (pmarquess@bfsec.bt.co.uk) +# last modified 23rd June 1994 +# version 0.1 + +package DB_File::HASHINFO ; +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 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 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 Carp; + +#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 TieHash; +require Exporter; +require AutoLoader; +require DynaLoader; +@ISA = (TieHash, Exporter, AutoLoader, DynaLoader); +@EXPORT = qw( + $DB_BTREE $DB_HASH $DB_RECNO + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED +); + +sub AUTOLOAD { + if (@_ > 1) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + local($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + croak "Your vendor has not defined DB macro $constname, used at $file line $line. +"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +@liblist = (); +@liblist = split ' ', $Config::Config{"DB_File_loadlibs"} + if defined $Config::Config{"DB_File_loadlibs"}; + +bootstrap DB_File @liblist; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +1; +__END__ diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs new file mode 100644 index 0000000000..c83f976d93 --- /dev/null +++ b/ext/DB_File/DB_File.xs @@ -0,0 +1,945 @@ +/* + + DB_File.xs -- Perl 5 interface to Berkeley DB + + written by Paul Marquess (pmarquess@bfsec.bt.co.uk) + last modified 23rd June 1994 + version 0.1 + + All comments/suggestions/problems are welcome + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <db.h> + +#include <fcntl.h> + +#ifndef DBXS_HASH_TYPE +#define DBXS_HASH_TYPE u_int32_t +#endif + +#ifndef DBXS_PREFIX_TYPE +#define DBXS_PREFIX_TYPE size_t +#endif + +typedef DB * DB_File; +typedef DBT DBTKEY ; + +union INFO { + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; + } ; + +typedef struct { + SV * sub ; + } CallBackInfo ; + + +/* #define TRACE */ + +#define db_DESTROY(db) (db->close)(db) +#define db_DELETE(db, key, flags) (db->del)(db, &key, flags) +#define db_STORE(db, key, value, flags) (db->put)(db, &key, &value, flags) +#define db_FETCH(db, key, flags) (db->get)(db, &key, &value, flags) + +#define db_close(db) (db->close)(db) +#define db_del(db, key, flags) (db->del)(db, &key, flags) +#define db_fd(db) (db->fd)(db) +#define db_put(db, key, value, flags) (db->put)(db, &key, &value, flags) +#define db_get(db, key, value, flags) (db->get)(db, &key, &value, flags) +#define db_seq(db, key, value, flags) (db->seq)(db, &key, &value, flags) +#define db_sync(db, flags) (db->sync)(db, flags) + + +#define OutputValue(arg, name) \ + { if (RETVAL == 0) sv_setpvn(arg, name.data, name.size) ; } + +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->close != DB_recno_close) \ + sv_setpvn(arg, name.data, name.size); \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + } \ + } + +/* Internal Global Data */ + +static recno_t Value ; +static int (*DB_recno_close)() = NULL ; + +static CallBackInfo hash_callback = { 0 } ; +static CallBackInfo compare_callback = { 0 } ; +static CallBackInfo prefix_callback = { 0 } ; + + +static int +btree_compare(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +{ + dSP ; + void * data1, * data2 ; + int retval ; + int count ; + + data1 = key1->data ; + data2 = key2->data ; + + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; + + ENTER ; + SAVETMPS; + + PUSHMARK(sp) ; + EXTEND(sp,2) ; + PUSHs(sv_2mortal(newSVpv(data1,key1->size))); + PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(compare_callback.sub, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + return (retval) ; + +} + +static DBXS_PREFIX_TYPE +btree_prefix(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +{ + dSP ; + void * data1, * data2 ; + int retval ; + int count ; + + data1 = key1->data ; + data2 = key2->data ; + + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; + + ENTER ; + SAVETMPS; + + PUSHMARK(sp) ; + EXTEND(sp,2) ; + PUSHs(sv_2mortal(newSVpv(data1,key1->size))); + PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(prefix_callback.sub, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + +static DBXS_HASH_TYPE +hash_cb(data, size) +const void * data ; +size_t size ; +{ + dSP ; + int retval ; + int count ; + + if (size == 0) + data = "" ; + + PUSHMARK(sp) ; + XPUSHs(sv_2mortal(newSVpv((char*)data,size))); + PUTBACK ; + + count = perl_call_sv(hash_callback.sub, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + + +#ifdef TRACE + +static void +PrintHash(hash) +HASHINFO hash ; +{ + printf ("HASH Info\n") ; + printf (" hash = %s\n", (hash.hash != NULL ? "redefined" : "default")) ; + printf (" bsize = %d\n", hash.bsize) ; + printf (" ffactor = %d\n", hash.ffactor) ; + printf (" nelem = %d\n", hash.nelem) ; + printf (" cachesize = %d\n", hash.cachesize) ; + printf (" lorder = %d\n", hash.lorder) ; + +} + +static void +PrintRecno(recno) +RECNOINFO recno ; +{ + printf ("RECNO Info\n") ; + printf (" flags = %d\n", recno.flags) ; + printf (" cachesize = %d\n", recno.cachesize) ; + printf (" psize = %d\n", recno.psize) ; + printf (" lorder = %d\n", recno.lorder) ; + printf (" reclen = %d\n", recno.reclen) ; + printf (" bval = %d\n", recno.bval) ; + printf (" bfname = %s\n", recno.bfname) ; +} + +PrintBtree(btree) +BTREEINFO btree ; +{ + printf ("BTREE Info\n") ; + printf (" compare = %s\n", (btree.compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", (btree.prefix ? "redefined" : "default")) ; + printf (" flags = %d\n", btree.flags) ; + printf (" cachesize = %d\n", btree.cachesize) ; + printf (" psize = %d\n", btree.psize) ; + printf (" maxkeypage = %d\n", btree.maxkeypage) ; + printf (" minkeypage = %d\n", btree.minkeypage) ; + printf (" lorder = %d\n", btree.lorder) ; +} + +#else + +#define PrintRecno(recno) +#define PrintHash(hash) +#define PrintBtree(btree) + +#endif /* TRACE */ + + +static I32 +GetArrayLength(db) +DB_File db ; +{ + DBT key ; + DBT value ; + int RETVAL ; + + RETVAL = (db->seq)(db, &key, &value, R_LAST) ; + if (RETVAL == 0) + RETVAL = *(I32 *)key.data ; + else if (RETVAL == 1) /* No key means empty file */ + RETVAL = 0 ; + + return (RETVAL) ; +} + +static DB_File +ParseOpenInfo(name, flags, mode, sv, string) +char * name ; +int flags ; +int mode ; +SV * sv ; +char * string ; +{ + SV ** svp; + HV * action ; + union INFO info ; + DB_File RETVAL ; + void * openinfo = NULL ; + DBTYPE type = DB_HASH ; + + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + action = (HV*)SvRV(sv); + if (sv_isa(sv, "DB_File::HASHINFO")) + { + type = DB_HASH ; + openinfo = (void*)&info ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + info.hash.hash = hash_cb ; + hash_callback.sub = *svp ; + } + else + info.hash.hash = NULL ; + + svp = hv_fetch(action, "bsize", 5, FALSE); + info.hash.bsize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "ffactor", 7, FALSE); + info.hash.ffactor = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "nelem", 5, FALSE); + info.hash.nelem = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info.hash.cachesize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info.hash.lorder = svp ? SvIV(*svp) : 0; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + type = DB_BTREE ; + openinfo = (void*)&info ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + info.btree.compare = btree_compare ; + compare_callback.sub = *svp ; + } + else + info.btree.compare = NULL ; + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + info.btree.prefix = btree_prefix ; + prefix_callback.sub = *svp ; + } + else + info.btree.prefix = NULL ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info.btree.flags = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info.btree.cachesize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "minkeypage", 10, FALSE); + info.btree.minkeypage = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "maxkeypage", 10, FALSE); + info.btree.maxkeypage = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "psize", 5, FALSE); + info.btree.psize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info.btree.lorder = svp ? SvIV(*svp) : 0; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + type = DB_RECNO ; + openinfo = (void *)&info ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info.recno.flags = (u_long) svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "psize", 5, FALSE); + info.recno.psize = (int) svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info.recno.lorder = (int) svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "reclen", 6, FALSE); + info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "bval", 4, FALSE); + if (svp && SvOK(*svp)) + { + if (SvPOK(*svp)) + info.recno.bval = (u_char)*SvPV(*svp, na) ; + else + info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ; + } + else + { + if (info.recno.flags & R_FIXEDLEN) + info.recno.bval = (u_char) ' ' ; + else + info.recno.bval = (u_char) '\n' ; + } + + svp = hv_fetch(action, "bfname", 6, FALSE); + info.recno.bfname = (char *) svp ? SvPV(*svp,na) : 0; + + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + + RETVAL = dbopen(name, flags, mode, type, openinfo) ; + + if (RETVAL == 0) + croak("DB_File::%s failed, reason: %s", string, Strerror(errno)) ; + + /* 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 (type == DB_RECNO) + DB_recno_close = RETVAL->close ; + + + return (RETVAL) ; +} + + +static int +not_here(s) +char *s; +{ + croak("DB_File::%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + switch (*name) { + case 'A': + break; + case 'B': + if (strEQ(name, "BTREEMAGIC")) +#ifdef BTREEMAGIC + return BTREEMAGIC; +#else + goto not_there; +#endif + if (strEQ(name, "BTREEVERSION")) +#ifdef BTREEVERSION + return BTREEVERSION; +#else + goto not_there; +#endif + break; + case 'C': + break; + case 'D': + if (strEQ(name, "DB_LOCK")) +#ifdef DB_LOCK + return DB_LOCK; +#else + goto not_there; +#endif + if (strEQ(name, "DB_SHMEM")) +#ifdef DB_SHMEM + return DB_SHMEM; +#else + goto not_there; +#endif + if (strEQ(name, "DB_TXN")) +#ifdef DB_TXN + return (U32)DB_TXN; +#else + goto not_there; +#endif + break; + case 'E': + break; + case 'F': + break; + case 'G': + break; + case 'H': + if (strEQ(name, "HASHMAGIC")) +#ifdef HASHMAGIC + return HASHMAGIC; +#else + goto not_there; +#endif + if (strEQ(name, "HASHVERSION")) +#ifdef HASHVERSION + return HASHVERSION; +#else + goto not_there; +#endif + break; + case 'I': + break; + case 'J': + break; + case 'K': + break; + case 'L': + break; + case 'M': + if (strEQ(name, "MAX_PAGE_NUMBER")) +#ifdef MAX_PAGE_NUMBER + return (U32)MAX_PAGE_NUMBER; +#else + goto not_there; +#endif + if (strEQ(name, "MAX_PAGE_OFFSET")) +#ifdef MAX_PAGE_OFFSET + return MAX_PAGE_OFFSET; +#else + goto not_there; +#endif + if (strEQ(name, "MAX_REC_NUMBER")) +#ifdef MAX_REC_NUMBER + return (U32)MAX_REC_NUMBER; +#else + goto not_there; +#endif + break; + case 'N': + break; + case 'O': + break; + case 'P': + break; + case 'Q': + break; + case 'R': + if (strEQ(name, "RET_ERROR")) +#ifdef RET_ERROR + return RET_ERROR; +#else + goto not_there; +#endif + if (strEQ(name, "RET_SPECIAL")) +#ifdef RET_SPECIAL + return RET_SPECIAL; +#else + goto not_there; +#endif + if (strEQ(name, "RET_SUCCESS")) +#ifdef RET_SUCCESS + return RET_SUCCESS; +#else + goto not_there; +#endif + if (strEQ(name, "R_CURSOR")) +#ifdef R_CURSOR + return R_CURSOR; +#else + goto not_there; +#endif + if (strEQ(name, "R_DUP")) +#ifdef R_DUP + return R_DUP; +#else + goto not_there; +#endif + if (strEQ(name, "R_FIRST")) +#ifdef R_FIRST + return R_FIRST; +#else + goto not_there; +#endif + if (strEQ(name, "R_FIXEDLEN")) +#ifdef R_FIXEDLEN + return R_FIXEDLEN; +#else + goto not_there; +#endif + if (strEQ(name, "R_IAFTER")) +#ifdef R_IAFTER + return R_IAFTER; +#else + goto not_there; +#endif + if (strEQ(name, "R_IBEFORE")) +#ifdef R_IBEFORE + return R_IBEFORE; +#else + goto not_there; +#endif + if (strEQ(name, "R_LAST")) +#ifdef R_LAST + return R_LAST; +#else + goto not_there; +#endif + if (strEQ(name, "R_NEXT")) +#ifdef R_NEXT + return R_NEXT; +#else + goto not_there; +#endif + if (strEQ(name, "R_NOKEY")) +#ifdef R_NOKEY + return R_NOKEY; +#else + goto not_there; +#endif + if (strEQ(name, "R_NOOVERWRITE")) +#ifdef R_NOOVERWRITE + return R_NOOVERWRITE; +#else + goto not_there; +#endif + if (strEQ(name, "R_PREV")) +#ifdef R_PREV + return R_PREV; +#else + goto not_there; +#endif + if (strEQ(name, "R_RECNOSYNC")) +#ifdef R_RECNOSYNC + return R_RECNOSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "R_SETCURSOR")) +#ifdef R_SETCURSOR + return R_SETCURSOR; +#else + goto not_there; +#endif + if (strEQ(name, "R_SNAPSHOT")) +#ifdef R_SNAPSHOT + return R_SNAPSHOT; +#else + goto not_there; +#endif + break; + case 'S': + break; + case 'T': + break; + case 'U': + break; + case 'V': + break; + case 'W': + break; + case 'X': + break; + case 'Y': + break; + case 'Z': + break; + case '_': + if (strEQ(name, "__R_UNUSED")) +#ifdef __R_UNUSED + return __R_UNUSED; +#else + goto not_there; +#endif + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +MODULE = DB_File PACKAGE = DB_File PREFIX = db_ + +double +constant(name,arg) + char * name + int arg + + +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 ; + SV * sv = (SV *) NULL ; + + if (items >= 2 && SvOK(ST(1))) + name = (char*) SvPV(ST(1), na) ; + + if (items == 5) + sv = ST(4) ; + + RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ; + } + OUTPUT: + RETVAL + +BOOT: + newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file); + +int +db_DESTROY(db) + DB_File db + + +int +db_DELETE(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + +int +db_FETCH(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + CODE: + { + DBT value ; + + RETVAL = (db->get)(db, &key, &value, flags) ; + ST(0) = sv_newmortal(); + if (RETVAL == 0) + sv_setpvn(ST(0), value.data, value.size); + } + +int +db_STORE(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + + +int +db_FIRSTKEY(db) + DB_File db + CODE: + { + DBTKEY key ; + DBT value ; + + RETVAL = (db->seq)(db, &key, &value, R_FIRST) ; + ST(0) = sv_newmortal(); + if (RETVAL == 0) + { + if (db->type != DB_RECNO) + sv_setpvn(ST(0), key.data, key.size); + else + sv_setiv(ST(0), (I32)*(I32*)key.data - 1); + } + } + +int +db_NEXTKEY(db, key) + DB_File db + DBTKEY key + CODE: + { + DBT value ; + + RETVAL = (db->seq)(db, &key, &value, R_NEXT) ; + ST(0) = sv_newmortal(); + if (RETVAL == 0) + { + if (db->type != DB_RECNO) + sv_setpvn(ST(0), key.data, key.size); + else + sv_setiv(ST(0), (I32)*(I32*)key.data - 1); + } + } + +# +# These would be nice for RECNO +# + +int +unshift(db, ...) + DB_File db + CODE: + { + DBTKEY key ; + DBT value ; + int i ; + int One ; + + RETVAL = -1 ; + for (i = items-1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), na) ; + value.size = na ; + One = 1 ; + key.data = &One ; + key.size = sizeof(int) ; + RETVAL = (db->put)(db, &key, &value, R_IBEFORE) ; + if (RETVAL != 0) + break; + } + } + OUTPUT: + RETVAL + +I32 +pop(db) + DB_File db + CODE: + { + DBTKEY key ; + DBT value ; + + /* First get the final value */ + RETVAL = (db->seq)(db, &key, &value, R_LAST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + RETVAL = (db->del)(db, &key, R_CURSOR) ; + if (RETVAL == 0) + sv_setpvn(ST(0), value.data, value.size); + } + } + +I32 +shift(db) + DB_File db + CODE: + { + DBTKEY key ; + DBT value ; + + /* get the first value */ + RETVAL = (db->seq)(db, &key, &value, R_FIRST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + RETVAL = (db->del)(db, &key, R_CURSOR) ; + if (RETVAL == 0) + sv_setpvn(ST(0), value.data, value.size); + } + } + + +I32 +push(db, ...) + DB_File db + CODE: + { + DBTKEY key ; + DBT value ; + int i ; + + /* Set the Cursor to the Last element */ + RETVAL = (db->seq)(db, &key, &value, R_LAST) ; + if (RETVAL == 0) + { + /* for (i = 1 ; i < items ; ++i) */ + for (i = items - 1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), na) ; + value.size = na ; + RETVAL = (db->put)(db, &key, &value, R_IAFTER) ; + if (RETVAL != 0) + break; + } + } + } + OUTPUT: + RETVAL + + +I32 +length(db) + DB_File db + CODE: + RETVAL = GetArrayLength(db) ; + OUTPUT: + RETVAL + + +# +# Now provide an interface to the rest of the DB functionality +# + +int +db_del(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + + +int +db_get(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + OUTPUT: + value + +int +db_put(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + OUTPUT: + key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key); + +int +db_fd(db) + DB_File db + +int +db_sync(db, flags=0) + DB_File db + u_int flags + + +int +db_seq(db, key, value, flags) + DB_File db + DBTKEY key + DBT value + u_int flags + OUTPUT: + key + value diff --git a/ext/DB_File/DB_File_BS b/ext/DB_File/DB_File_BS new file mode 100644 index 0000000000..9282c49881 --- /dev/null +++ b/ext/DB_File/DB_File_BS @@ -0,0 +1,6 @@ +# NeXT needs /usr/lib/libposix.a to load along with DB_File.so +if ( $dlsrc eq "dl_next.xs" ) { + @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' ); +} + +1; diff --git a/ext/DB_File/Makefile.SH b/ext/DB_File/Makefile.SH new file mode 100644 index 0000000000..7422b00eab --- /dev/null +++ b/ext/DB_File/Makefile.SH @@ -0,0 +1,207 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +potential_libs="-ldb " +. $TOP/ext/util/extliblist + +: This extension might need bootstrap support +if test -f ${ext}_BS; then + bootdep=${ext}_BS +else + bootdep='' +fi + +case "$dlsrc" in +dl_aix*) + echo "#!" > $ext.exp + echo "boot_$ext" >> $ext.exp + ;; +esac + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# $ext might have its own bootstrap support +BOOTDEP = $bootdep +BOOTSTRAP = $ext.bs + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs +INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: dynamic +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) + +$(INSTALLDYNAMIC): $(EXT).o + @test -d $(AUTO) || mkdir $(AUTO) + @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) + ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) + +$(BOOTSTRAP): Makefile $(BOOTDEP) + $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) + touch $(BOOTSTRAP) + +$(INSTALLBOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(EXT).xs >tmp + mv tmp $@ + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile + diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap new file mode 100644 index 0000000000..242fa041d2 --- /dev/null +++ b/ext/DB_File/typemap @@ -0,0 +1,39 @@ +# 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 +# +# + +u_int T_U_INT +DB_File T_PTROBJ +DBT T_dbtdatum +DBTKEY T_dbtkeydatum + +INPUT +T_dbtkeydatum + if (db->close != DB_recno_close) + { + $var.data = SvPV($arg, na); + $var.size = (int)na; + } + else + { + Value = SvIV($arg) ; + ++ Value ; + $var.data = & Value; + $var.size = (int)sizeof(recno_t); + } +T_dbtdatum + $var.data = SvPV($arg, na); + $var.size = (int)na; + +OUTPUT + +T_dbtkeydatum + OutputKey($arg, $var) +T_dbtdatum + OutputValue($arg, $var) diff --git a/ext/DynaLoader/DynaLoader.doc b/ext/DynaLoader/DynaLoader.doc new file mode 100644 index 0000000000..85d606ff9b --- /dev/null +++ b/ext/DynaLoader/DynaLoader.doc @@ -0,0 +1,257 @@ +======================================================================= +Specification for the Generic Dynamic Linking 'DynaLoader' Module + +This specification defines a standard generic interface to the dynamic +linking mechanisms available on many platforms. Its primary purpose is +to implement automatic dynamic loading of perl modules. + +The DynaLoader is designed to be a very simple high-level +interface that is sufficiently general to cover the requirements +of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. + +It is also hoped that the interface will cover the needs of OS/2, +NT etc and allow pseudo-dynamic linking (using ld -A at runtime). + +This document serves as both a specification for anyone wishing to +implement the DynaLoader for a new platform and as a guide for +anyone wishing to use the DynaLoader directly in an application. + +It must be stressed that the DynaLoader, by itself, is practically +useless for accessing non-perl libraries because it provides almost no +perl-to-C 'glue'. There is, for example, no mechanism for calling a C +library function or supplying arguments. It is anticipated that any +glue that may be developed in the future will be implemented in a +seperate dynamically loaded module. + +This interface is based on the work and comments of (in no particular +order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno +Siegel, Thomas Neumann, Paul Marquess, Charles Bailey and others. + +Larry Wall designed the elegant inherited bootstrap mechanism and +implemented the first perl 5 dynamic loader using it. + +Tim Bunce +11th August 1994 + +---------------------------------------------------------------------- +DynaLoader Interface Summary + + @dl_library_path + @dl_resolve_using + @dl_require_symbols + $dl_debug + Implemented in: + bootstrap($modulename) Perl + @filepaths = dl_findfile(@names) Perl + + $libref = dl_load_file($filename) C + $symref = dl_find_symbol($libref, $symbol) C + @symbols = dl_undef_symbols() C + dl_install_xsub($name, $symref [, $filename]) C + $message = dl_error C + + +---------------------------------------------------------------------- +@dl_library_path + +The standard/default list of directories in which dl_findfile() will +search for libraries etc. Directories are searched in order: +$dl_library_path[0], [1], ... etc + +@dl_library_path is initialised to hold the list of 'normal' directories +(/usr/lib etc) determined by Configure ($Config{'libpth'}). This should +ensure portability across a wide range of platforms. + +@dl_library_path should also be initialised with any other directories +that can be determined from the environment at runtime (such as +LD_LIBRARY_PATH for SunOS). + +After initialisation @dl_library_path can be manipulated by an +application using push and unshift before calling dl_findfile(). +Unshift can be used to add directories to the front of the search order +either to save search time or to override libraries with the same name +in the 'normal' directories. + +The load function that dl_load_file() calls may require an absolute +pathname. The dl_findfile() function and @dl_library_path can be +used to search for and return the absolute pathname for the +library/object that you wish to load. + + +---------------------------------------------------------------------- +@dl_resolve_using + +A list of additional libraries or other shared objects which can be +used to resolve any undefined symbols that might be generated by a +later call to load_file(). + +This is only required on some platforms which do not handle dependent +libraries automatically. For example the Socket perl extension library +(auto/Socket/Socket.so) contains references to many socket functions +which need to be resolved when it's loaded. Most platforms will +automatically know where to find the 'dependent' library (e.g., +/usr/lib/libsocket.so). A few platforms need to to be told the location +of the dependent library explicitly. Use @dl_resolve_using for this. + +Example usage: @dl_resolve_using = dl_findfile('-lsocket'); + + +---------------------------------------------------------------------- +@dl_require_symbols + +A list of one or more symbol names that are in the library/object file +to be dynamically loaded. This is only required on some platforms. + + +---------------------------------------------------------------------- +$message = dl_error + +Error message text from the last failed DynaLoader function. Note +that, similar to errno in unix, a successful function call does not +reset this message. + +Implementations should detect the error as soon as it occurs in any of +the other functions and save the corresponding message for later +retrieval. This will avoid problems on some platforms (such as SunOS) +where the error message is very temporary (e.g., dlerror()). + + +---------------------------------------------------------------------- +$dl_debug + +Internal debugging messages are enabled when $dl_debug is set true. +Currently setting $dl_debug only affects the perl side of the +DynaLoader. These messages should help an application developer to +resolve any DynaLoader usage problems. + +$dl_debug is set to $ENV{'PERL_DL_DEBUG'} if defined. + +For the DynaLoader developer/porter there is a similar debugging +variable added to the C code (see dlutils.c) and enabled if perl is +compiled with the -DDEBUGGING flag. This can also be set via the +PERL_DL_DEBUG environment variable. Set to 1 for minimal information or +higher for more. + + +---------------------------------------------------------------------- +@filepaths = dl_findfile(@names) + +Determine the full paths (including file suffix) of one or more +loadable files given their generic names and optionally one or more +directories. Searches directories in @dl_library_path by default and +returns an empty list if no files were found. + +Names can be specified in a variety of platform independent forms. Any +names in the form '-lname' are converted into 'libname.*', where .* is +an appropriate suffix for the platform. + +If a name does not already have a suitable prefix and/or suffix then +the corresponding file will be searched for by trying combinations of +prefix and suffix appropriate to the platform: "$name.o", "lib$name.*" +and "$name". + +If any directories are included in @names they are searched before +@dl_library_path. Directories may be specified as -Ldir. Any other names +are treated as filenames to be searched for. + +Using arguments of the form -Ldir and -lname is recommended. + +Example: @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); + + +---------------------------------------------------------------------- +$filepath = dl_expandspec($spec) + +Some unusual systems, such as VMS, require special filename handling in +order to deal with symbolic names for files (i.e., VMS's Logical Names). + +To support these systems a dl_expandspec function can be implemented +either in the dl_*.xs file or code can be added to the autoloadable +dl_expandspec function in DynaLoader.pm. See DynaLoader.pm for more +information. + + + +---------------------------------------------------------------------- +$libref = dl_load_file($filename) + +Dynamically load $filename, which must be the path to a shared object +or library. An opaque 'library reference' is returned as a handle for +the loaded object. Returns undef on error. + +(On systems that provide a handle for the loaded object such as SunOS +and HPUX, $libref will be that handle. On other systems $libref will +typically be $filename or a pointer to a buffer containing $filename. +The application should not examine or alter $libref in any way.) + +This is function that does the real work. It should use the current +values of @dl_require_symbols and @dl_resolve_using if required. + +SunOS: dlopen($filename) +HP-UX: shl_load($filename) +Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) +NeXT: rld_load($filename, @dl_resolve_using) +VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) + + +---------------------------------------------------------------------- +$symref = dl_find_symbol($libref, $symbol) + +Return the address of the symbol $symbol or undef if not found. If the +target system has separate functions to search for symbols of different +types then dl_find_symbol should search for function symbols first and +then other types. + +The exact manner in which the address is returned in $symref is not +currently defined. The only initial requirement is that $symref can +be passed to, and understood by, dl_install_xsub(). + +SunOS: dlsym($libref, $symbol) +HP-UX: shl_findsym($libref, $symbol) +Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) +NeXT: rld_lookup("_$symbol") +VMS: lib$find_image_symbol($libref,$symbol) + + +---------------------------------------------------------------------- +@symbols = dl_undef_symbols() + +Return a list of symbol names which remain undefined after load_file(). +Returns () if not known. Don't worry if your platform does not provide +a mechanism for this. Most do not need it and hence do not provide it. + + +---------------------------------------------------------------------- +dl_install_xsub($perl_name, $symref [, $filename]) + +Create a new Perl external subroutine named $perl_name using $symref as +a pointer to the function which implements the routine. This is simply +a direct call to newXSUB(). Returns a reference to the installed +function. + +The $filename parameter is used by Perl to identify the source file for +the function if required by die(), caller() or the debugger. If +$filename is not defined then "DynaLoader" will be used. + + +---------------------------------------------------------------------- +bootstrap($module) + +This is the normal entry point for automatic dynamic loading in Perl. + +It performs the following actions: + 1. locates an auto/$module directory by searching @INC + 2. uses dl_findfile() to determine the filename to load + 3. sets @dl_require_symbols to ("boot_$module") + 4. executes an auto/$module/$^R/$module.bs file if it exists + (typically used to add to @dl_resolve_using any files which + are required to load the module on the current platform) + 5. calls dl_load_file() to load the file + 6. calls dl_undef_symbols() and warns if any symbols are undefined + 7. calls dl_find_symbol() for "boot_$module" + 8. calls dl_install_xsub() to install it as "${module}::bootstrap" + 9. calls &{"${module}::bootstrap"} to bootstrap the module + + +====================================================================== +End. diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm new file mode 100644 index 0000000000..61d9a8566e --- /dev/null +++ b/ext/DynaLoader/DynaLoader.pm @@ -0,0 +1,243 @@ +package DynaLoader; + +# +# And Gandalf said: 'Many folk like to know beforehand what is to +# be set on the table; but those who have laboured to prepare the +# feast like to keep their secret; for wonder makes the words of +# praise louder.' +# + +# Quote from Tolkien sugested by Anno Siegel. +# +# Read ext/DynaLoader/README and DynaLoader.doc for +# detailed information. +# +# Tim.Bunce@ig.co.uk, August 1994 + +use Config; +use Carp; +use AutoLoader; + +@ISA=(AutoLoader); + + +# enable messages from DynaLoader perl code +$dl_debug = 0 unless $dl_debug; +$dl_debug = $ENV{'PERL_DL_DEBUG'} if $ENV{'PERL_DL_DEBUG'}; + +$dl_so = $dl_dlext = ""; # avoid typo warnings +$dl_so = $Config{'so'}; # suffix for shared libraries +$dl_dlext = $Config{'dlext'}; # suffix for dynamic modules + +# Some systems need special handling to expand file specifications +# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) +# See dl_expandspec() for more details. Should be harmless but +# inefficient to define on systems that don't need it. +$do_expand = ($Config{'osname'} eq 'VMS'); + +@dl_require_symbols = (); # names of symbols we need +@dl_resolve_using = (); # names of files to link with +@dl_library_path = (); # path to look for files + +# This is a fix to support DLD's unfortunate desire to relink -lc +@dl_resolve_using = dl_findfile('-lc') if $Config{'dlsrc'} eq "dl_dld.xs"; + +# Initialise @dl_library_path with the 'standard' library path +# for this platform as determined by Configure +push(@dl_library_path, split(' ',$Config{'libpth'})); + +# Add to @dl_library_path any extra directories we can gather from +# environment variables. So far LD_LIBRARY_PATH is the only known +# variable used for this purpose. Others may be added later. +push(@dl_library_path, split(/:/, $ENV{'LD_LIBRARY_PATH'})) + if $ENV{'LD_LIBRARY_PATH'}; + + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +&boot_DynaLoader if defined &boot_DynaLoader; + +print STDERR "DynaLoader.pm loaded (@dl_library_path)\n" + if ($dl_debug >= 2); + +# Temporary interface checks for recent changes (Aug 1994) +if (defined(&dl_load_file)){ +die "dl_error not defined" unless defined (&dl_error); +die "dl_undef_symbols not defined" unless defined (&dl_undef_symbols); +} + +1; # End of main code + + +# The bootstrap function cannot be autoloaded (without complications) +# so we define it here: + +sub bootstrap { + # use local vars to enable $module.bs script to edit values + local(@args) = @_; + local($module) = $args[0]; + local(@dirs, $file); + + croak "Usage: DynaLoader::bootstrap(module)" + unless ($module); + + croak "Can't load module $module, DynaLoader not linked into this perl" + unless defined(&dl_load_file); + + print STDERR "DynaLoader::bootstrap($module)\n" if $dl_debug; + + my(@modparts) = split(/::/,$module); + my($modfname) = $modparts[-1]; + my($modpname) = join('/',@modparts); + foreach (@INC) { + my $dir = "$_/auto/$modpname"; + next unless -d $dir; # skip over uninteresting directories + + # check for common cases to avoid autoload of dl_findfile + last if ($file=_check_file("$dir/$modfname.$dl_dlext")); + + # no luck here, save dir for possible later dl_findfile search + push(@dirs, "-L$dir"); + } + # last resort, let dl_findfile have a go in all known locations + $file = dl_findfile(@dirs, map("-L$_",@INC), $modfname) unless $file; + + croak "Can't find loadable object for module $module in \@INC" + unless $file; + + my($bootname) = "boot_$module"; + $bootname =~ s/\W/_/g; + @dl_require_symbols = ($bootname); + + # Execute optional '.bootstrap' perl script for this module. + # The .bs file can be used to configure @dl_resolve_using etc to + # match the needs of the individual module on this architecture. + my $bs = $file; + $bs =~ s/\.$dl_dlext$/\.bs/o; # look for .bs 'beside' the library + if (-f $bs) { + local($osname, $dlsrc) = @Config{'osname','dlsrc'}; + print STDERR "$bs ($osname, $dlsrc)\n" if $dl_debug; + $@ = ""; + do $bs; + warn "$bs: $@\n" if $@; + } + + my $libref = DynaLoader::dl_load_file($file) or + croak "Can't load '$file' for module $module: ".&dl_error."\n"; + + my(@unresolved) = dl_undef_symbols(); + carp "Undefined symbols present after loading $file: @unresolved\n" + if (@unresolved); + + my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or + croak "Can't find '$bootname' symbol in $file\n"; + + dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + &{"${module}::bootstrap"}(@args); +} + + +sub _check_file{ # private utility to handle dl_expandspec vs -f tests + my($file) = @_; + return $file if (!$do_expand && -f $file); # the common case + return $file if ( $do_expand && ($file=dl_expandspec($file))); + return undef; +} + + +# Let autosplit and the autoloader deal with these functions: +__END__ + + +sub dl_findfile { + # Read ext/DynaLoader/DynaLoader.doc for detailed information. + # This function does not automatically consider the architecture + # or the perl library auto directories. + my (@args) = @_; + my (@dirs, $dir); # which directories to search + my (@found); # full paths to real files we have found + my ($vms) = ($Config{'osname'} eq 'VMS'); + + print STDERR "dl_findfile(@args)\n" if $dl_debug; + + # accumulate directories but process files as they appear + arg: foreach(@args) { + # Special fast case: full filepath requires no search + if (m:/: && -f $_ && !$do_expand){ + push(@found,$_); + last arg unless wantarray; + next; + } + + # Deal with directories first: + # Using a -L prefix is the preferred option (faster and more robust) + if (m:^-L:){ s/^-L//; push(@dirs, $_); next; } + # Otherwise we try to try to spot directories by a heuristic + # (this is a more complicated issue than it first appears) + if (m:/: && -d $_){ push(@dirs, $_); next; } + # VMS: we may be using native VMS directry syntax instead of + # Unix emulation, so check this as well + if ($vms && /[:>\]]/ && -d $_){ push(@dirs, $_); next; } + + # Only files should get this far... + my(@names, $name); # what filenames to look for + if (m:-l: ){ # convert -lname to appropriate library name + s/-l//; + push(@names,"lib$_.$dl_so"); + push(@names,"lib$_.a"); + }else{ # Umm, a bare name. Try various alternatives: + # these should be ordered with the most likely first + push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; + push(@names,"lib$_.$dl_so") unless m:/:; + push(@names,"$_.o") unless m/\.(o|$dl_so)$/o; + push(@names,"$_.a") unless m/\.a$/; + push(@names, $_); + } + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + foreach $name (@names) { + my($file) = "$dir/$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + $file = _check_file($file); + if ($file){ + push(@found, $file); + next arg; # no need to look any further + } + } + } + } + if ($dl_debug) { + foreach(@dirs) { + print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; + } + print STDERR "dl_findfile found: @found\n"; + } + return $found[0] unless wantarray; + @found; +} + + +sub dl_expandspec{ + my($spec) = @_; + # Optional function invoked if DynaLoader.pm sets $do_expand. + # Most systems do not require or use this function. + # Some systems may implement it in the dl_*.xs file in which case + # this autoload version will not be called but is harmless. + + # This function is designed to deal with systems which treat some + # 'filenames' in a special way. For example VMS 'Logical Names' + # (something like unix environment variables - but different). + # This function should recognise such names and expand them into + # full file paths. + # Must return undef if $spec is invalid or file does not exist. + + my($file) = $spec; # default output to input + my($osname) = $Config{'osname'}; + + if ($osname eq 'VMS'){ # dl_expandspec should be defined in dl_vms.xs + croak "dl_expandspec: should be defined in XS file!\n"; + }else{ + return undef unless -f $file; + } + print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; + $file; +} diff --git a/ext/DynaLoader/Makefile.SH b/ext/DynaLoader/Makefile.SH new file mode 100644 index 0000000000..2b10fefd1a --- /dev/null +++ b/ext/DynaLoader/Makefile.SH @@ -0,0 +1,185 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +potential_libs="" +. $TOP/ext/util/extliblist + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# + +DLSRC = $dlsrc +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: static +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +# If we hit here, there's a mistake somewhere. +dynamic: static + @echo "The DynaLoader extension must be built for static linking" + false + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(DLSRC) dlutils.c $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(DLSRC) >tmp + mv tmp $@ + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +# Perform very simple tests just to check for major gaffs. +# We can't do much more for platforms we are not executing on. +test-xs: + for i in dl_*xs; do $(PERL) $(XSUBPP) $$i > /dev/null; done + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLSTATIC) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile + diff --git a/ext/DynaLoader/README b/ext/DynaLoader/README new file mode 100644 index 0000000000..19dd8e72f6 --- /dev/null +++ b/ext/DynaLoader/README @@ -0,0 +1,53 @@ +Perl 5 DynaLoader + +See DynaLoader.doc for detailed specification. + +This module is very similar to the other Perl 5 modules except that +Configure selects which dl_*.xs file to use. + +After Configure has been run the Makefile.SH will generate a Makefile +which will run xsubpp on a specific dl_*.xs file and write the output +to DynaLoader.c + +After that the processing is the same as any other module. + +Note that, to be effective, the DynaLoader module must be _statically_ +linked into perl! Configure should arrange this. + +This interface is based on the work and comments of (in no particular +order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno +Siegel, Thomas Neumann, Paul Marquess, Charles Bailey and others. + +The dl_*.xs files should either be named after the dynamic linking +operating system interface used if that interface is available on more +than one type of system, e.g.: + dlopen for dlopen()/dlsym() type functions (SunOS, BSD) + dld for the GNU dld library functions (linux, ?) +or else the osname, e.g., hpux, next, vms etc. + +Both are determined by Configure and so only those specific names that +Configure knows/uses will work. + +If porting the DynaLoader to a platform that has a core dynamic linking +interface similar to an existing generic type, e.g., dlopen or dld, +please try to port the corresponding dl_*.xs file (using #ifdef's if +required). + +Otherwise, or if that proves too messy, create a new dl_*.xs file named +after your osname. Configure will give preference to a dl_$osname.xs +file if one exists. + +The file dl_dlopen.xs is a reference implementation by Paul Marquess +which is a good place to start if porting from scratch. For more complex +platforms take a look at dl_dld.xs. The dlutils.c file holds some +common definitions that are #included into the dl_*.xs files. + +After the initial implementation of a new DynaLoader dl_*.xs file +you may need to edit or create ext/MODULE/MODULE.bs files to reflect +the needs of your platform and linking software. + +Refer to DynaLoader.doc, ext/utils/mkbootstrap and any existing +ext/MODULE/MODULE.bs files for more information. + +Tim Bunce. +August 1994 diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs new file mode 100644 index 0000000000..f8bace1314 --- /dev/null +++ b/ext/DynaLoader/dl_aix.xs @@ -0,0 +1,582 @@ +/* dl_aix.xs + * + * Written: 8/31/94 by Wayne Scott (wscott@ichips.intel.com) + * + * All I did was take Jens-Uwe Mager's libdl emulation library for + * AIX and merged it with the dl_dlopen.xs file to create a dynamic library + * package that works for AIX. + * + * I did change all malloc's, free's, strdup's, calloc's to use the perl + * equilvant. I also removed some stuff we will not need. Call fini() + * on statup... It can probably be trimmed more. + */ + +/* + * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17 + * This is an unpublished work copyright (c) 1992 Helios Software GmbH + * 3000 Hannover 1, Germany + */ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <stdio.h> +#include <errno.h> +#include <string.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/ldr.h> +#include <a.out.h> +#include <ldfcn.h> + +/* + * We simulate dlopen() et al. through a call to load. Because AIX has + * no call to find an exported symbol we read the loader section of the + * loaded module and build a list of exported symbols and their virtual + * address. + */ + +typedef struct { + char *name; /* the symbols's name */ + void *addr; /* its relocated virtual address */ +} Export, *ExportPtr; + +/* + * The void * handle returned from dlopen is actually a ModulePtr. + */ +typedef struct Module { + struct Module *next; + char *name; /* module name for refcounting */ + int refCnt; /* the number of references */ + void *entry; /* entry point from load */ + int nExports; /* the number of exports found */ + ExportPtr exports; /* the array of exports */ +} Module, *ModulePtr; + +/* + * We keep a list of all loaded modules to be able to call the fini + * handlers at atexit() time. + */ +static ModulePtr modList; + +/* + * The last error from one of the dl* routines is kept in static + * variables here. Each error is returned only once to the caller. + */ +static char errbuf[BUFSIZ]; +static int errvalid; + +static void caterr(char *); +static int readExports(ModulePtr); +static void terminate(void); +static void *findMain(void); + + +/* ARGSUSED */ +void *dlopen(char *path, int mode) +{ + register ModulePtr mp; + static void *mainModule; + + /* + * Upon the first call register a terminate handler that will + * close all libraries. Also get a reference to the main module + * for use with loadbind. + */ + if (!mainModule) { + if ((mainModule = findMain()) == NULL) + return NULL; + atexit(terminate); + } + /* + * Scan the list of modules if have the module already loaded. + */ + for (mp = modList; mp; mp = mp->next) + if (strcmp(mp->name, path) == 0) { + mp->refCnt++; + return mp; + } + Newz(1000,mp,1,Module); + if (mp == NULL) { + errvalid++; + strcpy(errbuf, "Newz: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + + if ((mp->name = savepv(path)) == NULL) { + errvalid++; + strcpy(errbuf, "savepv: "); + strcat(errbuf, strerror(errno)); + safefree(mp); + return NULL; + } + /* + * load should be declared load(const char *...). Thus we + * cast the path to a normal char *. Ugly. + */ + if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { + safefree(mp->name); + safefree(mp); + errvalid++; + strcpy(errbuf, "dlopen: "); + strcat(errbuf, path); + strcat(errbuf, ": "); + /* + * If AIX says the file is not executable, the error + * can be further described by querying the loader about + * the last error. + */ + if (errno == ENOEXEC) { + char *tmp[BUFSIZ/sizeof(char *)]; + if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) + strcpy(errbuf, strerror(errno)); + else { + char **p; + for (p = tmp; *p; p++) + caterr(*p); + } + } else + strcat(errbuf, strerror(errno)); + return NULL; + } + mp->refCnt = 1; + mp->next = modList; + modList = mp; + if (loadbind(0, mainModule, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + if (readExports(mp) == -1) { + dlclose(mp); + return NULL; + } + return mp; +} + +/* + * Attempt to decipher an AIX loader error message and append it + * to our static error message buffer. + */ +static void caterr(char *s) +{ + register char *p = s; + + while (*p >= '0' && *p <= '9') + p++; + switch(atoi(s)) { + case L_ERROR_TOOMANY: + strcat(errbuf, "to many errors"); + break; + case L_ERROR_NOLIB: + strcat(errbuf, "can't load library"); + strcat(errbuf, p); + break; + case L_ERROR_UNDEF: + strcat(errbuf, "can't find symbol"); + strcat(errbuf, p); + break; + case L_ERROR_RLDBAD: + strcat(errbuf, "bad RLD"); + strcat(errbuf, p); + break; + case L_ERROR_FORMAT: + strcat(errbuf, "bad exec format in"); + strcat(errbuf, p); + break; + case L_ERROR_ERRNO: + strcat(errbuf, strerror(atoi(++p))); + break; + default: + strcat(errbuf, s); + break; + } +} + +void *dlsym(void *handle, const char *symbol) +{ + register ModulePtr mp = (ModulePtr)handle; + register ExportPtr ep; + register int i; + + /* + * Could speed up search, but I assume that one assigns + * the result to function pointers anyways. + */ + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (strcmp(ep->name, symbol) == 0) + return ep->addr; + errvalid++; + strcpy(errbuf, "dlsym: undefined symbol "); + strcat(errbuf, symbol); + return NULL; +} + +char *dlerror(void) +{ + if (errvalid) { + errvalid = 0; + return errbuf; + } + return NULL; +} + +int dlclose(void *handle) +{ + register ModulePtr mp = (ModulePtr)handle; + int result; + register ModulePtr mp1; + + if (--mp->refCnt > 0) + return 0; + result = unload(mp->entry); + if (result == -1) { + errvalid++; + strcpy(errbuf, strerror(errno)); + } + if (mp->exports) { + register ExportPtr ep; + register int i; + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (ep->name) + safefree(ep->name); + safefree(mp->exports); + } + if (mp == modList) + modList = mp->next; + else { + for (mp1 = modList; mp1; mp1 = mp1->next) + if (mp1->next == mp) { + mp1->next = mp->next; + break; + } + } + safefree(mp->name); + safefree(mp); + return result; +} + +static void terminate(void) +{ + while (modList) + dlclose(modList); +} + +/* Added by Wayne Scott + * This is needed because the ldopen system call calls + * calloc to allocated a block of date. The ldclose call calls free. + * Without this we get this system calloc and perl's free, resulting + * in a "Bad free" message. This way we always use perl's malloc. + */ +void *calloc(size_t ne, size_t sz) +{ + void *out; + + out = (void *) safemalloc(ne*sz); + memzero(out, ne*sz); + return(out); +} + +/* + * Build the export table from the XCOFF .loader section. + */ +static int readExports(ModulePtr mp) +{ + LDFILE *ldp = NULL; + SCNHDR sh; + LDHDR *lhp; + char *ldbuf; + LDSYM *ls; + int i; + ExportPtr ep; + + if ((ldp = ldopen(mp->name, ldp)) == NULL) { + struct ld_info *lp; + char *buf; + int size = 4*1024; + if (errno != ENOENT) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + /* + * The module might be loaded due to the LIBPATH + * environment variable. Search for the loaded + * module using L_GETINFO. + */ + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + safefree(buf); + size += 4*1024; + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + safefree(buf); + return -1; + } + /* + * Traverse the list of loaded modules. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + while (lp) { + if (lp->ldinfo_dataorg == mp->entry) { + ldp = ldopen(lp->ldinfo_filename, ldp); + break; + } + if (lp->ldinfo_next == 0) + lp = NULL; + else + lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); + } + safefree(buf); + if (!ldp) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + } + if (TYPE(ldp) != U802TOCMAGIC) { + errvalid++; + strcpy(errbuf, "readExports: bad magic"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section header"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * We read the complete loader section in one chunk, this makes + * finding long symbol names residing in the string table easier. + */ + if ((ldbuf = (char *)safemalloc(sh.s_size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { + errvalid++; + strcpy(errbuf, "readExports: cannot seek to loader section"); + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section"); + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + lhp = (LDHDR *)ldbuf; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + /* + * Count the number of exports to include in our export table. + */ + for (i = lhp->l_nsyms; i; i--, ls++) { + if (!LDR_EXPORT(*ls)) + continue; + mp->nExports++; + } + Newz(1001, mp->exports, mp->nExports, Export); + if (mp->exports == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * Fill in the export table. All entries are relative to + * the entry point we got from load. + */ + ep = mp->exports; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + for (i = lhp->l_nsyms; i; i--, ls++) { + char *symname; + if (!LDR_EXPORT(*ls)) + continue; + if (ls->l_zeroes == 0) + symname = ls->l_offset+lhp->l_stoff+ldbuf; + else + symname = ls->l_name; + ep->name = savepv(symname); + ep->addr = (void *)((unsigned long)mp->entry + ls->l_value); + ep++; + } + safefree(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return 0; +} + +/* + * Find the main modules entry point. This is used as export pointer + * for loadbind() to be able to resolve references to the main part. + */ +static void * findMain(void) +{ + struct ld_info *lp; + char *buf; + int size = 4*1024; + int i; + void *ret; + + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + safefree(buf); + size += 4*1024; + if ((buf = safemalloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + safefree(buf); + return NULL; + } + /* + * The first entry is the main module. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + ret = lp->ldinfo_dataorg; + safefree(buf); + return ret; +} + +/* dl_dlopen.xs + * + * Platform: SunOS/Solaris, possibly others which use dlopen. + * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Created: 10th July 1994 + * + * Modified: + * 15th July 1994 - Added code to explicitly save any error messages. + * 3rd August 1994 - Upgraded to v3 spec. + * 9th August 1994 - Changed to use IV + * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, + * basic FreeBSD support, removed ClearError + * + */ + +/* Porting notes: + + see dl_dlopen.xs + +*/ + +#include "dlutils.c" /* SaveError() etc */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename) + char * filename + CODE: + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + RETVAL = dlopen(filename, 1) ; + DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/ext/DynaLoader/dl_dld.xs b/ext/DynaLoader/dl_dld.xs new file mode 100644 index 0000000000..31f625a26d --- /dev/null +++ b/ext/DynaLoader/dl_dld.xs @@ -0,0 +1,173 @@ +/* + * Written 3/1/94, Robert Sanders <Robert.Sanders@linux.org> + * + * based upon the file "dl.c", which is + * Copyright (c) 1994, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Date: 1994/03/07 00:21:43 $ + * $Source: /home/rsanders/src/perl5alpha6/RCS/dld_dl.c,v $ + * $Revision: 1.4 $ + * $State: Exp $ + * + * $Log: dld_dl.c,v $ + * Removed implicit link against libc. 1994/09/14 William Setzer. + * + * Integrated other DynaLoader changes. 1994/06/08 Tim Bunce. + * + * rewrote dl_load_file, misc updates. 1994/09/03 William Setzer. + * + * Revision 1.4 1994/03/07 00:21:43 rsanders + * added min symbol count for load_libs and switched order so system libs + * are loaded after app-specified libs. + * + * Revision 1.3 1994/03/05 01:17:26 rsanders + * added path searching. + * + * Revision 1.2 1994/03/05 00:52:39 rsanders + * added package-specified libraries. + * + * Revision 1.1 1994/03/05 00:33:40 rsanders + * Initial revision + * + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <dld.h> /* GNU DLD header file */ +#include <unistd.h> + +#include "dlutils.c" /* for SaveError() etc */ + +static void +dl_private_init() +{ + int dlderr; + dl_generic_private_init(); +#ifdef __linux__ + dlderr = dld_init("/proc/self/exe"); + if (dlderr) { +#endif + dlderr = dld_init(dld_find_executable(origargv[0])); + if (dlderr) { + char *msg = dld_strerror(dlderr); + SaveError("dld_init(%s) failed: %s", origargv[0], msg); + DLDEBUG(1,fprintf(stderr,"%s", LastError)); + } +#ifdef __linux__ + } +#endif +} + + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +char * +dl_load_file(filename) + char * filename + CODE: + int dlderr,x,max; + GV *gv; + AV *av; + RETVAL = filename; + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s)\n", filename)); + gv = gv_fetchpv("DynaLoader::dl_require_symbols", FALSE, SVt_PVAV); + if (gv) { + av = GvAV(gv); + max = AvFILL(av); + for (x = 0; x <= max; x++) { + char *sym = SvPVX(*av_fetch(av, x, 0)); + DLDEBUG(1,fprintf(stderr, "dld_create_ref(%s)\n", sym)); + if (dlderr = dld_create_reference(sym)) { + SaveError("dld_create_reference(%s): %s", sym, + dld_strerror(dlderr)); + goto haverror; + } + } + } + DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", filename)); + if (dlderr = dld_link(filename)) { + SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); + goto haverror; + } + gv = gv_fetchpv("DynaLoader::dl_resolve_using", FALSE, SVt_PVAV); + if (gv) { + av = GvAV(gv); + max = AvFILL(av); + for (x = 0; x <= max; x++) { + char *sym = SvPVX(*av_fetch(av, x, 0)); + DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", sym)); + if (dlderr = dld_link(sym)) { + SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); + goto haverror; + } + } + } + DLDEBUG(2,fprintf(stderr,"libref=%s\n", RETVAL)); +haverror: + ST(0) = sv_newmortal() ; + if (dlderr == 0) + sv_setiv(ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = (void *)dld_get_func(symbolname); + /* if RETVAL==NULL we should try looking for a non-function symbol */ + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; + else + sv_setiv(ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + if (dld_undefined_sym_count) { + int x; + char **undef_syms = dld_list_undefined_sym(); + EXTEND(sp, dld_undefined_sym_count); + for (x=0; x < dld_undefined_sym_count; x++) + PUSHs(sv_2mortal(newSVpv(undef_syms[x]+1, 0))); + free(undef_syms); + } + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/ext/DynaLoader/dl_dlopen.xs b/ext/DynaLoader/dl_dlopen.xs new file mode 100644 index 0000000000..ffd3dbc422 --- /dev/null +++ b/ext/DynaLoader/dl_dlopen.xs @@ -0,0 +1,201 @@ +/* dl_dlopen.xs + * + * Platform: SunOS/Solaris, possibly others which use dlopen. + * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Created: 10th July 1994 + * + * Modified: + * 15th July 1994 - Added code to explicitly save any error messages. + * 3rd August 1994 - Upgraded to v3 spec. + * 9th August 1994 - Changed to use IV + * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, + * basic FreeBSD support, removed ClearError + * + */ + +/* Porting notes: + + + Definition of Sunos dynamic Linking functions + ============================================= + In order to make this implementation easier to understand here is a + quick definition of the SunOS Dynamic Linking functions which are + used here. + + dlopen + ------ + void * + dlopen(path, mode) + char * path; + int mode; + + This function takes the name of a dynamic object file and returns + a descriptor which can be used by dlsym later. It returns NULL on + error. + + The mode parameter must be set to 1 for Solaris 1 and to + RTLD_LAZY on Solaris 2. + + + dlsym + ------ + void * + dlsym(handle, symbol) + void * handle; + char * symbol; + + Takes the handle returned from dlopen and the name of a symbol to + get the address of. If the symbol was found a pointer is + returned. It returns NULL on error. If DL_PREPEND_UNDERSCORE is + defined an underscore will be added to the start of symbol. This + is required on some platforms (freebsd). + + dlerror + ------ + char * dlerror() + + Returns a null-terminated string which describes the last error + that occurred with either dlopen or dlsym. After each call to + dlerror the error message will be reset to a null pointer. The + SaveError function is used to save the error as soo as it happens. + + + Return Types + ============ + In this implementation the two functions, dl_load_file & + dl_find_symbol, return void *. This is because the underlying SunOS + dynamic linker calls also return void *. This is not necessarily + the case for all architectures. For example, some implementation + will want to return a char * for dl_load_file. + + If void * is not appropriate for your architecture, you will have to + change the void * to whatever you require. If you are not certain of + how Perl handles C data types, I suggest you start by consulting + Dean Roerich's Perl 5 API document. Also, have a look in the typemap + file (in the ext directory) for a fairly comprehensive list of types + that are already supported. If you are completely stuck, I suggest you + post a message to perl5-porters, comp.lang.perl or if you are really + desperate to me. + + Remember when you are making any changes that the return value from + dl_load_file is used as a parameter in the dl_find_symbol + function. Also the return value from find_symbol is used as a parameter + to install_xsub. + + + Dealing with Error Messages + ============================ + In order to make the handling of dynamic linking errors as generic as + possible you should store any error messages associated with your + implementation with the StoreError function. + + In the case of SunOS the function dlerror returns the error message + associated with the last dynamic link error. As the SunOS dynamic + linker functions dlopen & dlsym both return NULL on error every call + to a SunOS dynamic link routine is coded like this + + RETVAL = dlopen(filename, 1) ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + + Note that SaveError() takes a printf format string. Use a "%s" as + the first parameter if the error may contain and % characters. + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef I_DLFCN +#include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */ +#else +#include <nlist.h> +#include <link.h> +#endif + +#ifndef HAS_DLERROR +#define dlerror() "Unknown error - dlerror() not implemented" +#endif + + +#include "dlutils.c" /* SaveError() etc */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename) + char * filename + CODE: + int mode = 1; /* Solaris 1 */ +#ifdef RTLD_LAZY + mode = RTLD_LAZY; /* Solaris 2 */ +#endif + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: +#ifdef DLSYM_NEEDS_UNDERSCORE + char symbolname_buf[1024]; + symbolname = dl_add_underscore(symbolname, symbolname_buf); +#endif + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs new file mode 100644 index 0000000000..0558e40eaa --- /dev/null +++ b/ext/DynaLoader/dl_hpux.xs @@ -0,0 +1,101 @@ +/* + * Author: Jeff Okamoto (okamoto@corp.hp.com) + */ + +#ifdef __hp9000s300 +#define magic hpux_magic +#define MAGIC HPUX_MAGIC +#endif + +#include <dl.h> +#ifdef __hp9000s300 +#undef magic +#undef MAGIC +#endif + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + + +#include "dlutils.c" /* for SaveError() etc */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + +void * +dl_load_file(filename) + char * filename + CODE: + shl_t obj = NULL; + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s): ", filename)); + obj = shl_load(filename, + BIND_IMMEDIATE | BIND_NONFATAL | BIND_NOSTART | BIND_VERBOSE, 0L); + DLDEBUG(2,fprintf(stderr," libref=%x\n", obj)); + ST(0) = sv_newmortal() ; + if (obj == NULL) + SaveError("%s",Strerror(errno)) ; + else + sv_setiv( ST(0), (IV)obj); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + shl_t obj = (shl_t) libhandle; + void *symaddr = NULL; + int status; +#ifdef __hp9000s300 + char symbolname_buf[MAXPATHLEN]; + symbolname = dl_add_underscore(symbolname, symbolname_buf); +#endif + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", symaddr)); + ST(0) = sv_newmortal() ; + if (status == -1) + SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + else + sv_setiv( ST(0), (IV)symaddr); + + +int +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs new file mode 100644 index 0000000000..9bc5cd81c2 --- /dev/null +++ b/ext/DynaLoader/dl_next.xs @@ -0,0 +1,213 @@ +/* dl_next.xs + * + * Platform: NeXT NS 3.2 + * Author: Anno Siegel (siegel@zrz.TU-Berlin.DE) + * Based on: dl_dlopen.xs by Paul Marquess + * Created: Aug 15th, 1994 + * + */ + +/* + And Gandalf said: 'Many folk like to know beforehand what is to + be set on the table; but those who have laboured to prepare the + feast like to keep their secret; for wonder makes the words of + praise louder.' +*/ + +/* Porting notes: + +dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess. It +should not be used as a base for further ports though it may be used +as an example for how dl_dlopen.xs can be ported to other platforms. + +The method used here is just to supply the sun style dlopen etc. +functions in terms of NeXTs rld_*. The xs code proper is unchanged +from Paul's original. + +The port could use some streamlining. For one, error handling could +be simplified. + +Anno Siegel + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* SaveError() etc */ + + +#include <mach-o/rld.h> +#include <streams/streams.h> + +static char * dl_last_error = (char *) 0; + +NXStream * +OpenError() +{ + return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY); +} + +void +TransferError( s) +NXStream *s; +{ + char *buffer; + int len, maxlen; + + if ( dl_last_error ) { + safefree(dl_last_error); + } + NXGetMemoryBuffer(s, &buffer, &len, &maxlen); + dl_last_error = safemalloc(len); + 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 = OpenError(); + AV * av_resolve; + I32 i, psize; + char *result; + char **p; + + av_resolve = GvAVn(gv_fetchpv( + "DynaLoader::dl_resolve_using", FALSE, SVt_PVAV)); + psize = AvFILL(av_resolve) + 3; + p = (char **) safemalloc(psize * sizeof(char*)); + p[0] = path; + for(i=1; i<psize-1; i++) { + p[i] = SvPVx(*av_fetch(av_resolve, i-1, TRUE), na); + } + p[psize-1] = 0; + rld_success = rld_load(nxerr, (struct mach_header **)0, p, + (const char *) 0); + safefree((char*) p); + if (rld_success) { + result = path; + } else { + TransferError(nxerr); + result = (char*) 0; + } + CloseError(nxerr); + return result; +} + +int +dlclose(handle) /* stub only */ +void *handle; +{ + return 0; +} + +void * +dlsym(handle, symbol) +void *handle; +char *symbol; +{ + NXStream *nxerr = OpenError(); + char symbuf[1024]; + unsigned long symref = 0; + + sprintf(symbuf, "_%s", symbol); + if (!rld_lookup(nxerr, symbuf, &symref)) { + TransferError(nxerr); + } + CloseError(nxerr); + return (void*) symref; +} + + +/* ----- code from dl_dlopen.xs below here ----- */ + + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + + + +void * +dl_load_file(filename) + char * filename + CODE: + int mode = 1; + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%s",dlerror()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/ext/DynaLoader/dl_none.xs b/ext/DynaLoader/dl_none.xs new file mode 100644 index 0000000000..5a193e4346 --- /dev/null +++ b/ext/DynaLoader/dl_none.xs @@ -0,0 +1,19 @@ +/* dl_none.xs + * + * Stubs for platforms that do not support dynamic linking + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +MODULE = DynaLoader PACKAGE = DynaLoader + +char * +dl_error() + CODE: + RETVAL = "Not implemented"; + OUTPUT: + RETVAL + +# end. diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs new file mode 100644 index 0000000000..8486ae260c --- /dev/null +++ b/ext/DynaLoader/dl_vms.xs @@ -0,0 +1,324 @@ +/* dl_vms.xs + * + * Platform: OpenVMS, VAX or AXP + * Author: Charles Bailey bailey@genetics.upenn.edu + * Revised: 4-Sep-1994 + * + * Implementation Note + * This section is added as an aid to users and DynaLoader developers, in + * order to clarify the process of dynamic linking under VMS. + * dl_vms.xs uses the supported VMS dynamic linking call, which allows + * a running program to map an arbitrary file of executable code and call + * routines within that file. This is done via the VMS RTL routine + * lib$find_image_symbol, whose calling sequence is as follows: + * status = lib$find_image_symbol(imgname,symname,symval,defspec); + * where + * status = a standard VMS status value (unsigned long int) + * imgname = a fixed-length string descriptor, passed by + * reference, containing the NAME ONLY of the image + * file to be mapped. An attempt will be made to + * translate this string as a logical name, so it may + * not contain any characters which are not allowed in + * logical names. If no translation is found, imgname + * is used directly as the name of the image file. + * symname = a fixed-length string descriptor, passed by + * reference, containing the name of the routine + * to be located. + * symval = an unsigned long int, passed by reference, into + * which is written the entry point address of the + * routine whose name is specified in symname. + * defspec = a fixed-length string descriptor, passed by + * reference, containing a default file specification + * whichis used to fill in any missing parts of the + * image file specification after the imgname argument + * is processed. + * In order to accommodate the handling of the imgname argument, the routine + * dl_expandspec() is provided for use by perl code (e.g. dl_findfile) + * which wants to see what image file lib$find_image_symbol would use if + * it were passed a given file specification. The file specification passed + * to dl_expandspec() and dl_load_file() can be partial or complete, and can + * use VMS or Unix syntax; these routines perform the necessary conversions. + * In general, writers of perl extensions need only conform to the + * procedures set out in the DynaLoader documentation, and let the details + * be taken care of by the routines here and in DynaLoader.pm. If anyone + * comes across any incompatibilities, please let me know. Thanks. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* dl_debug, LastError; SaveError not used */ +/* N.B.: + * dl_debug and LastError are static vars; you'll need to deal + * with them appropriately if you need context independence + */ + +#include <descrip.h> +#include <fscndef.h> +#include <lib$routines.h> +#include <rms.h> +#include <ssdef.h> + +typedef unsigned long int vmssts; + +struct libref { + struct dsc$descriptor_s name; + struct dsc$descriptor_s defspec; +}; + +/* Static data for dl_expand_filespec() - This is static to save + * initialization on each call; if you need context-independence, + * just make these auto variables in dl_expandspec() and dl_load_file() + */ +static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS]; +static struct FAB dlfab; +static struct NAM dlnam; + +/* $PutMsg action routine - records error message in LastError */ +static vmssts +copy_errmsg(msg,unused) + struct dsc$descriptor_s * msg; + vmssts unused; +{ + if (*(msg->dsc$a_pointer) = '%') { /* first line */ + if (LastError) + strncpy((LastError = saferealloc(LastError,msg->dsc$w_length)), + msg->dsc$a_pointer, msg->dsc$w_length); + else + strncpy((LastError = safemalloc(msg->dsc$w_length)), + msg->dsc$a_pointer, msg->dsc$w_length); + return 0; + } + else { /* continuation line */ + int errlen = strlen(LastError); + LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 1); + LastError[errlen] = '\n'; LastError[errlen+1] = '\0'; + strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length); + } +} + +/* Use $PutMsg to retrieve error message for failure status code */ +static void +dl_set_error(sts,stv) + vmssts sts; + vmssts stv; +{ + vmssts vec[3],pmsts; + + vec[0] = stv ? 2 : 1; + vec[1] = sts; vec[2] = stv; + if (!(pmsts = sys$putmsg(vec,copy_errmsg,0,0)) & 1) + croak("Fatal $PUTMSG error: %d",pmsts); +} + +static void +dl_private_init() +{ + dl_generic_private_init(); + /* Set up the static control blocks for dl_expand_filespec() */ + dlfab = cc$rms_fab; + dlnam = cc$rms_nam; + dlfab.fab$l_nam = &dlnam; + dlnam.nam$l_esa = dlesa; + dlnam.nam$b_ess = sizeof dlesa; + dlnam.nam$l_rsa = dlrsa; + dlnam.nam$b_rss = sizeof dlrsa; +} +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +SV * +dl_expandspec(filespec) + char * filespec + CODE: + char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS]; + size_t deflen; + vmssts sts; + + tovmsspec(filespec,vmsspec); + dlfab.fab$l_fna = vmsspec; + dlfab.fab$b_fns = strlen(vmsspec); + dlfab.fab$l_dna = 0; + dlfab.fab$b_dns = 0; + DLDEBUG(1,fprintf(stderr,"dl_expand_filespec(%s):\n",vmsspec)); + /* On the first pass, just parse the specification string */ + dlnam.nam$b_nop = NAM$M_SYNCHK; + sts = sys$parse(&dlfab); + DLDEBUG(2,fprintf(stderr,"\tSYNCHK sys$parse = %d\n",sts)); + if (!(sts & 1)) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &sv_undef; + } + else { + /* Now set up a default spec - everything but the name */ + deflen = dlnam.nam$l_type - dlesa; + memcpy(defspec,dlesa,deflen); + memcpy(defspec+deflen,dlnam.nam$l_type, + dlnam.nam$b_type + dlnam.nam$b_ver); + deflen += dlnam.nam$b_type + dlnam.nam$b_ver; + memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name); + DLDEBUG(2,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n", + dlnam.nam$b_name,vmsspec,defspec,deflen)); + /* . . . and go back to expand it */ + dlnam.nam$b_nop = 0; + dlfab.fab$l_dna = defspec; + dlfab.fab$b_dns = deflen; + dlfab.fab$b_fns = dlnam.nam$b_name; + sts = sys$parse(&dlfab); + DLDEBUG(2,fprintf(stderr,"\tname/default sys$parse = %d\n",sts)); + if (!(sts & 1)) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &sv_undef; + } + else { + /* Now find the actual file */ + sts = sys$search(&dlfab); + DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts)); + if (!(sts & 1) && sts != RMS$_FNF) { + dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); + ST(0) = &sv_undef; + } + else { + ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); + DLDEBUG(1,fprintf(stderr,"\tresult = \\%.*s\\\n", + dlnam.nam$b_rsl,dlnam.nam$l_rsa)); + } + } + } + +void * +dl_load_file(filespec) + char * filespec + CODE: + char vmsspec[NAM$C_MAXRSS]; + AV *reqAV; + SV *reqSV, **reqSVhndl; + STRLEN deflen; + struct dsc$descriptor_s + specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, + symdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct fscnlst { + unsigned short int len; + unsigned short int code; + char *string; + } namlst[2] = {0,FSCN$_NAME,0, 0,0,0}; + struct libref *dlptr; + vmssts sts, failed = 0; + void *entry; + + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec)); + specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); + specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); + DLDEBUG(2,fprintf(stderr,"\tVMS-ified filespec is %s\n", + specdsc.dsc$a_pointer)); + dlptr = safemalloc(sizeof(struct libref)); + dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T; + dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S; + sts = sys$filescan(&specdsc,namlst,0); + DLDEBUG(2,fprintf(stderr,"\tsys$filescan: returns %d, name is %.*s\n", + sts,namlst[0].len,namlst[0].string)); + if (!(sts & 1)) { + failed = 1; + dl_set_error(sts,0); + } + else { + dlptr->name.dsc$w_length = namlst[0].len; + dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len); + dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len; + dlptr->defspec.dsc$a_pointer = safemalloc(dlptr->defspec.dsc$w_length + 1); + deflen = namlst[0].string - specdsc.dsc$a_pointer; + memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen); + memcpy(dlptr->defspec.dsc$a_pointer + deflen, + namlst[0].string + namlst[0].len, + dlptr->defspec.dsc$w_length - deflen); + DLDEBUG(2,fprintf(stderr,"\tlibref = name: %s, defspec: %.*s\n", + dlptr->name.dsc$a_pointer, + dlptr->defspec.dsc$w_length, + dlptr->defspec.dsc$a_pointer)); + if (!(reqAV = GvAV(gv_fetchpv("DynaLoader::dl_require_symbols", + FALSE,SVt_PVAV))) + || !(reqSVhndl = av_fetch(reqAV,0,FALSE)) || !(reqSV = *reqSVhndl)) { + DLDEBUG(2,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n")); + } + else { + symdsc.dsc$w_length = SvCUR(reqSV); + symdsc.dsc$a_pointer = SvPVX(reqSV); + DLDEBUG(2,fprintf(stderr,"\t$dl_require_symbols[0] = %.*s\n", + symdsc.dsc$w_length, symdsc.dsc$a_pointer)); + sts = lib$find_image_symbol(&(dlptr->name),&symdsc, + &entry,&(dlptr->defspec)); + DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); + if (!(sts&1)) { + failed = 1; + dl_set_error(sts,0); + } + } + } + + if (failed) { + Safefree(dlptr->name.dsc$a_pointer); + Safefree(dlptr->defspec.dsc$a_pointer); + Safefree(dlptr); + ST(0) = &sv_undef; + } + else { + ST(0) = sv_2mortal(newSViv(dlptr)); + } + + +void * +dl_find_symbol(librefptr,symname) + void * librefptr + SV * symname + CODE: + struct libref thislib = *((struct libref *)librefptr); + struct dsc$descriptor_s + symdsc = {SvCUR(symname),DSC$K_DTYPE_T,DSC$K_CLASS_S,SvPVX(symname)}; + void (*entry)(); + vmssts sts; + + DLDEBUG(1,fprintf(stderr,"dl_find_dymbol(%.*s,%.*s):\n", + thislib.name.dsc$w_length, thislib.name.dsc$a_pointer, + symdsc.dsc$w_length,symdsc.dsc$a_pointer)); + sts = lib$find_image_symbol(&(thislib.name),&symdsc, + &entry,&(thislib.defspec)); + DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n", + (unsigned long int) entry)); + if (!(sts & 1)) { + dl_set_error(sts,0); + ST(0) = &sv_undef; + } + else ST(0) = sv_2mortal(newSViv(entry)); + + +void +dl_undef_symbols() + PPCODE: + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c new file mode 100644 index 0000000000..0ce082182c --- /dev/null +++ b/ext/DynaLoader/dlutils.c @@ -0,0 +1,85 @@ +/* dlutils.c - handy functions and definitions for dl_*.xs files + * + * Currently this file is simply #included into dl_*.xs/.c files. + * It should really be split into a dlutils.h and dlutils.c + * + */ + + +/* pointer to allocated memory for last error message */ +static char *LastError = (char*)NULL; + + + +#ifdef DEBUGGING +/* currently not connected to $DynaLoader::dl_error but should be */ +static int dl_debug = 0; +#define DLDEBUG(level,code) if(dl_debug>=level){ code; } +#else +#define DLDEBUG(level,code) +#endif + + +static void +dl_generic_private_init() /* called by dl_*.xs dl_private_init() */ +{ +#ifdef DEBUGGING + char *perl_dl_debug = getenv("PERL_DL_DEBUG"); + if (perl_dl_debug) + dl_debug = atoi(perl_dl_debug); +#endif +} + + +/* SaveError() takes printf style args and saves the result in LastError */ +#ifdef STANDARD_C +static void +SaveError(char* pat, ...) +#else +/*VARARGS0*/ +static void +SaveError(pat, va_alist) + char *pat; + va_dcl +#endif +{ + va_list args; + char *message; + int len; + + /* This code is based on croak/warn but I'm not sure where mess() */ + /* gets its buffer space from! */ + +#ifdef I_STDARG + va_start(args, pat); +#else + va_start(args); +#endif + message = mess(pat, &args); + va_end(args); + + len = strlen(message) + 1 ; /* include terminating null char */ + + /* Allocate some memory for the error message */ + if (LastError) + LastError = (char*)saferealloc(LastError, len) ; + else + LastError = safemalloc(len) ; + + /* Copy message into LastError (including terminating null char) */ + strncpy(LastError, message, len) ; + DLDEBUG(2,fprintf(stderr,"DynaLoader: stored error msg '%s'\n",LastError)); +} + + +/* prepend underscore to s. write into buf. return buf. */ +char * +dl_add_underscore(s, buf) +char *s; +char *buf; +{ + *buf = '_'; + (void)strcpy(buf + 1, s); + return buf; +} + diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm new file mode 100644 index 0000000000..c4fd2ff550 --- /dev/null +++ b/ext/Fcntl/Fcntl.pm @@ -0,0 +1,51 @@ +package Fcntl; + +require Exporter; +require AutoLoader; +require DynaLoader; +@ISA = (Exporter, AutoLoader, DynaLoader); +# Items to export into callers namespace by default +# (move infrequently used names to @EXPORT_OK below) +@EXPORT = + qw( + F_DUPFD F_GETFD F_GETLK F_SETFD F_GETFL F_SETFL F_SETLK F_SETLKW + FD_CLOEXEC F_RDLCK F_UNLCK F_WRLCK + O_CREAT O_EXCL O_NOCTTY O_TRUNC + O_APPEND O_NONBLOCK + O_NDELAY + O_RDONLY O_RDWR O_WRONLY + ); +# Other items we are prepared to export if requested +@EXPORT_OK = qw( +); + +sub AUTOLOAD { + if (@_ > 1) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + local($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Fcntl macro $constname, used at $file line $line. +"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Fcntl; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. +package Fcntl; # return to package Fcntl so AutoSplit is happy +1; +__END__ diff --git a/ext/Fcntl/Fcntl.xs b/ext/Fcntl/Fcntl.xs new file mode 100644 index 0000000000..2a360951f9 --- /dev/null +++ b/ext/Fcntl/Fcntl.xs @@ -0,0 +1,181 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <fcntl.h> + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + switch (*name) { + case 'F': + if (strnEQ(name, "F_", 2)) { + if (strEQ(name, "F_DUPFD")) +#ifdef F_DUPFD + return F_DUPFD; +#else + goto not_there; +#endif + if (strEQ(name, "F_GETFD")) +#ifdef F_GETFD + return F_GETFD; +#else + goto not_there; +#endif + if (strEQ(name, "F_GETLK")) +#ifdef F_GETLK + return F_GETLK; +#else + goto not_there; +#endif + if (strEQ(name, "F_SETFD")) +#ifdef F_SETFD + return F_SETFD; +#else + goto not_there; +#endif + if (strEQ(name, "F_GETFL")) +#ifdef F_GETFL + return F_GETFL; +#else + goto not_there; +#endif + if (strEQ(name, "SETFL")) +#ifdef SETFL + return SETFL; +#else + goto not_there; +#endif + if (strEQ(name, "F_SETLK")) +#ifdef F_SETLK + return F_SETLK; +#else + goto not_there; +#endif + if (strEQ(name, "F_SETLKW")) +#ifdef F_SETLKW + return F_SETLKW; +#else + goto not_there; +#endif + if (strEQ(name, "F_RDLCK")) +#ifdef F_RDLCK + return F_RDLCK; +#else + goto not_there; +#endif + if (strEQ(name, "F_UNLCK")) +#ifdef F_UNLCK + return F_UNLCK; +#else + goto not_there; +#endif + if (strEQ(name, "F_WRLCK")) +#ifdef F_WRLCK + return F_WRLCK; +#else + goto not_there; +#endif + errno = EINVAL; + return 0; + } else + if (strEQ(name, "FD_CLOEXEC")) +#ifdef FD_CLOEXEC + return FD_CLOEXEC; +#else + goto not_there; +#endif + break; + case 'O': + if (strnEQ(name, "O_", 2)) { + if (strEQ(name, "O_CREAT")) +#ifdef O_CREAT + return O_CREAT; +#else + goto not_there; +#endif + if (strEQ(name, "O_EXCL")) +#ifdef O_EXCL + return O_EXCL; +#else + goto not_there; +#endif + if (strEQ(name, "O_NOCTTY")) +#ifdef O_NOCTTY + return O_NOCTTY; +#else + goto not_there; +#endif + if (strEQ(name, "O_TRUNC")) +#ifdef O_TRUNC + return O_TRUNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_APPEND")) +#ifdef O_APPEND + return O_APPEND; +#else + goto not_there; +#endif + if (strEQ(name, "O_NONBLOCK")) +#ifdef O_NONBLOCK + return O_NONBLOCK; +#else + goto not_there; +#endif + if (strEQ(name, "O_NDELAY")) +#ifdef O_NDELAY + return O_NDELAY; +#else + goto not_there; +#endif + if (strEQ(name, "O_RDONLY")) +#ifdef O_RDONLY + return O_RDONLY; +#else + goto not_there; +#endif + if (strEQ(name, "O_RDWR")) +#ifdef O_RDWR + return O_RDWR; +#else + goto not_there; +#endif + if (strEQ(name, "O_WRONLY")) +#ifdef O_WRONLY + return O_WRONLY; +#else + goto not_there; +#endif + } else + goto not_there; + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + + +MODULE = Fcntl PACKAGE = Fcntl + +double +constant(name,arg) + char * name + int arg + diff --git a/ext/Fcntl/MANIFEST b/ext/Fcntl/MANIFEST new file mode 100644 index 0000000000..e5ff6bfe76 --- /dev/null +++ b/ext/Fcntl/MANIFEST @@ -0,0 +1,4 @@ +Fcntl.pm +Fcntl.xs +MANIFEST +Makefile.PL diff --git a/ext/Fcntl/Makefile.SH b/ext/Fcntl/Makefile.SH new file mode 100644 index 0000000000..064228e512 --- /dev/null +++ b/ext/Fcntl/Makefile.SH @@ -0,0 +1,207 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +potential_libs=" " +. $TOP/ext/util/extliblist + +: This extension might need bootstrap support +if test -f ${ext}_BS; then + bootdep=${ext}_BS +else + bootdep='' +fi + +case "$dlsrc" in +dl_aix*) + echo "#!" > $ext.exp + echo "boot_$ext" >> $ext.exp + ;; +esac + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# $ext might have its own bootstrap support +BOOTDEP = $bootdep +BOOTSTRAP = $ext.bs + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs +INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: dynamic +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) + +$(INSTALLDYNAMIC): $(EXT).o + @test -d $(AUTO) || mkdir $(AUTO) + @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) + ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) + +$(BOOTSTRAP): Makefile $(BOOTDEP) + $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) + touch $(BOOTSTRAP) + +$(INSTALLBOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(EXT).xs >tmp + mv tmp $@ + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile + diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm new file mode 100644 index 0000000000..23422f7a2e --- /dev/null +++ b/ext/GDBM_File/GDBM_File.pm @@ -0,0 +1,47 @@ +package GDBM_File; + +require Carp; +require TieHash; +require Exporter; +require AutoLoader; +require DynaLoader; +@ISA = (TieHash, Exporter, AutoLoader, DynaLoader); +@EXPORT = qw( + GDBM_CACHESIZE + GDBM_FAST + GDBM_INSERT + GDBM_NEWDB + GDBM_READER + GDBM_REPLACE + GDBM_WRCREAT + GDBM_WRITER +); + +sub AUTOLOAD { + if (@_ > 1) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + local($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + Carp::croak("Your vendor has not defined GDBM_File macro $constname, used"); + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap GDBM_File; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +1; +__END__ diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs new file mode 100644 index 0000000000..c6dc484fa1 --- /dev/null +++ b/ext/GDBM_File/GDBM_File.xs @@ -0,0 +1,218 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <gdbm.h> +#include <fcntl.h> + +typedef GDBM_FILE GDBM_File; + +#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */ +#define gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func) \ + gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func) + +#define gdbm_FETCH(db,key) gdbm_fetch(db,key) +#define gdbm_STORE(db,key,value,flags) gdbm_store(db,key,value,flags) +#define gdbm_DELETE(db,key) gdbm_delete(db,key) +#define gdbm_FIRSTKEY(db) gdbm_firstkey(db) +#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db,key) + +typedef datum gdatum; + +typedef void (*FATALFUNC)(); + +static int +not_here(s) +char *s; +{ + croak("GDBM_File::%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + switch (*name) { + case 'A': + break; + case 'B': + break; + case 'C': + break; + case 'D': + break; + case 'E': + break; + case 'F': + break; + case 'G': + if (strEQ(name, "GDBM_CACHESIZE")) +#ifdef GDBM_CACHESIZE + return GDBM_CACHESIZE; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_FAST")) +#ifdef GDBM_FAST + return GDBM_FAST; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_FASTMODE")) +#ifdef GDBM_FASTMODE + return GDBM_FASTMODE; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_INSERT")) +#ifdef GDBM_INSERT + return GDBM_INSERT; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_NEWDB")) +#ifdef GDBM_NEWDB + return GDBM_NEWDB; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_READER")) +#ifdef GDBM_READER + return GDBM_READER; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_REPLACE")) +#ifdef GDBM_REPLACE + return GDBM_REPLACE; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_WRCREAT")) +#ifdef GDBM_WRCREAT + return GDBM_WRCREAT; +#else + goto not_there; +#endif + if (strEQ(name, "GDBM_WRITER")) +#ifdef GDBM_WRITER + return GDBM_WRITER; +#else + goto not_there; +#endif + break; + case 'H': + break; + case 'I': + break; + case 'J': + break; + case 'K': + break; + case 'L': + break; + case 'M': + break; + case 'N': + break; + case 'O': + break; + case 'P': + break; + case 'Q': + break; + case 'R': + break; + case 'S': + break; + case 'T': + break; + case 'U': + break; + case 'V': + break; + case 'W': + break; + case 'X': + break; + case 'Y': + break; + case 'Z': + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_ + +double +constant(name,arg) + char * name + int arg + + +GDBM_File +gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak) + char * dbtype + char * name + int read_write + int mode + FATALFUNC fatal_func + +void +gdbm_close(db) + GDBM_File db + CLEANUP: + +void +gdbm_DESTROY(db) + GDBM_File db + CODE: + gdbm_close(db); + +gdatum +gdbm_FETCH(db, key) + GDBM_File db + datum key + +int +gdbm_STORE(db, key, value, flags = GDBM_REPLACE) + GDBM_File db + datum key + datum value + int flags + CLEANUP: + if (RETVAL) { + if (RETVAL < 0 && errno == EPERM) + croak("No write permission to gdbm file"); + warn("gdbm store returned %d, errno %d, key \"%.*s\"", + RETVAL,errno,key.dsize,key.dptr); + /* gdbm_clearerr(db); */ + } + +int +gdbm_DELETE(db, key) + GDBM_File db + datum key + +gdatum +gdbm_FIRSTKEY(db) + GDBM_File db + +gdatum +gdbm_NEXTKEY(db, key) + GDBM_File db + datum key + +int +gdbm_reorganize(db) + GDBM_File db + diff --git a/ext/GDBM_File/Makefile.SH b/ext/GDBM_File/Makefile.SH new file mode 100644 index 0000000000..974c8deef8 --- /dev/null +++ b/ext/GDBM_File/Makefile.SH @@ -0,0 +1,213 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +potential_libs="-lgdbm" +. $TOP/ext/util/extliblist +case "${extralibs}${dynaloadlibs}${statloadlibs}" in +'') : Try again. Maybe they have -ldbm instead + potential_libs='-ldbm' + . $TOP/ext/util/extliblist + ;; +esac + +: This extension might need bootstrap support +if test -f ${ext}_BS; then + bootdep=${ext}_BS +else + bootdep='' +fi + +case "$dlsrc" in +dl_aix*) + echo "#!" > $ext.exp + echo "boot_$ext" >> $ext.exp + ;; +esac + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# $ext might have its own bootstrap support +BOOTDEP = $bootdep +BOOTSTRAP = $ext.bs + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs +INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: dynamic +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) + +$(INSTALLDYNAMIC): $(EXT).o + @test -d $(AUTO) || mkdir $(AUTO) + @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) + ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) + +$(BOOTSTRAP): Makefile $(BOOTDEP) + $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) + touch $(BOOTSTRAP) + +$(INSTALLBOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(EXT).xs >tmp + mv tmp $@ + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile + diff --git a/ext/dbm/typemap b/ext/GDBM_File/typemap index a6b0e5faa8..a6b0e5faa8 100644 --- a/ext/dbm/typemap +++ b/ext/GDBM_File/typemap diff --git a/ext/NDBM_File/Makefile.SH b/ext/NDBM_File/Makefile.SH new file mode 100644 index 0000000000..56016cae03 --- /dev/null +++ b/ext/NDBM_File/Makefile.SH @@ -0,0 +1,213 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +potential_libs="-lndbm" +. $TOP/ext/util/extliblist +case "${extralibs}${dynaloadlibs}${statloadlibs}" in +'') : Try again. Maybe they have -ldbm instead + potential_libs='-ldbm' + . $TOP/ext/util/extliblist + ;; +esac + +: This extension might need bootstrap support +if test -f ${ext}_BS; then + bootdep=${ext}_BS +else + bootdep='' +fi + +case "$dlsrc" in +dl_aix*) + echo "#!" > $ext.exp + echo "boot_$ext" >> $ext.exp + ;; +esac + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# $ext might have its own bootstrap support +BOOTDEP = $bootdep +BOOTSTRAP = $ext.bs + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs +INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: dynamic +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) + +$(INSTALLDYNAMIC): $(EXT).o + @test -d $(AUTO) || mkdir $(AUTO) + @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) + ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) + +$(BOOTSTRAP): Makefile $(BOOTDEP) + $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) + touch $(BOOTSTRAP) + +$(INSTALLBOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(EXT).xs >tmp + mv tmp $@ + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile + diff --git a/ext/NDBM_File/NDBM_File.pm b/ext/NDBM_File/NDBM_File.pm new file mode 100644 index 0000000000..e40fe854fe --- /dev/null +++ b/ext/NDBM_File/NDBM_File.pm @@ -0,0 +1,11 @@ +package NDBM_File; + +require TieHash; +require DynaLoader; +@ISA = qw(TieHash DynaLoader); + +bootstrap NDBM_File; + +1; + +__END__ diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs new file mode 100644 index 0000000000..52c08ebe76 --- /dev/null +++ b/ext/NDBM_File/NDBM_File.xs @@ -0,0 +1,70 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <ndbm.h> + +typedef DBM* NDBM_File; +#define dbm_TIEHASH(dbtype,filename,flags,mode) dbm_open(filename,flags,mode) +#define dbm_FETCH(db,key) dbm_fetch(db,key) +#define dbm_STORE(db,key,value,flags) dbm_store(db,key,value,flags) +#define dbm_DELETE(db,key) dbm_delete(db,key) +#define dbm_FIRSTKEY(db) dbm_firstkey(db) +#define dbm_NEXTKEY(db,key) dbm_nextkey(db) + +MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = dbm_ + +NDBM_File +dbm_TIEHASH(dbtype, filename, flags, mode) + char * dbtype + char * filename + int flags + int mode + +void +dbm_DESTROY(db) + NDBM_File db + CODE: + dbm_close(db); + +datum +dbm_FETCH(db, key) + NDBM_File db + datum key + +int +dbm_STORE(db, key, value, flags = DBM_REPLACE) + NDBM_File db + datum key + datum value + int flags + CLEANUP: + if (RETVAL) { + if (RETVAL < 0 && errno == EPERM) + croak("No write permission to ndbm file"); + warn("ndbm store returned %d, errno %d, key \"%s\"", + RETVAL,errno,key.dptr); + dbm_clearerr(db); + } + +int +dbm_DELETE(db, key) + NDBM_File db + datum key + +datum +dbm_FIRSTKEY(db) + NDBM_File db + +datum +dbm_NEXTKEY(db, key) + NDBM_File db + datum key + +int +dbm_error(db) + NDBM_File db + +void +dbm_clearerr(db) + NDBM_File db + diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap new file mode 100644 index 0000000000..a6b0e5faa8 --- /dev/null +++ b/ext/NDBM_File/typemap @@ -0,0 +1,25 @@ +# +#################################### DBM SECTION +# + +datum T_DATUM +gdatum T_GDATUM +NDBM_File T_PTROBJ +GDBM_File T_PTROBJ +SDBM_File T_PTROBJ +ODBM_File T_PTROBJ +DB_File T_PTROBJ +DBZ_File T_PTROBJ +FATALFUNC T_OPAQUEPTR + +INPUT +T_DATUM + $var.dptr = SvPV($arg, na); + $var.dsize = (int)na; +T_GDATUM + UNIMPLEMENTED +OUTPUT +T_DATUM + sv_setpvn($arg, $var.dptr, $var.dsize); +T_GDATUM + sv_usepvn($arg, $var.dptr, $var.dsize); diff --git a/ext/ODBM_File/Makefile.SH b/ext/ODBM_File/Makefile.SH new file mode 100644 index 0000000000..02cf6e13ab --- /dev/null +++ b/ext/ODBM_File/Makefile.SH @@ -0,0 +1,213 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +: dbm.nfs is an SCO library. +potential_libs="-ldbm.nfs" +. $TOP/ext/util/extliblist +case "${extralibs}${dynaloadlibs}${statloadlibs}" in +'') : Try again. Most systems have -ldbm instead + potential_libs='-ldbm' + . $TOP/ext/util/extliblist + ;; +esac + +: This extension might need bootstrap support +if test -f ${ext}_BS; then + bootdep=${ext}_BS +else + bootdep='' +fi + +case "$dlsrc" in +dl_aix*) + echo "#!" > $ext.exp + echo "boot_$ext" >> $ext.exp + ;; +esac + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# $ext might have its own bootstrap support +BOOTDEP = $bootdep +BOOTSTRAP = $ext.bs + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs +INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: dynamic +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) + +$(INSTALLDYNAMIC): $(EXT).o + @test -d $(AUTO) || mkdir $(AUTO) + @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) + ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) + +$(BOOTSTRAP): Makefile $(BOOTDEP) + $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) + touch $(BOOTSTRAP) + +$(INSTALLBOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(EXT).xs >tmp + mv tmp $@ + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile diff --git a/ext/ODBM_File/ODBM_File.pm b/ext/ODBM_File/ODBM_File.pm new file mode 100644 index 0000000000..d844c673c3 --- /dev/null +++ b/ext/ODBM_File/ODBM_File.pm @@ -0,0 +1,11 @@ +package ODBM_File; + +require TieHash; +require DynaLoader; +@ISA = qw(TieHash DynaLoader); + +bootstrap ODBM_File; + +1; + +__END__ diff --git a/ext/dbm/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs index 04d7b9e7cf..15737a0de8 100644 --- a/ext/dbm/ODBM_File.xs +++ b/ext/ODBM_File/ODBM_File.xs @@ -11,11 +11,11 @@ typedef void* ODBM_File; -#define odbm_fetch(db,key) fetch(key) -#define odbm_store(db,key,value,flags) store(key,value) -#define odbm_delete(db,key) delete(key) -#define odbm_firstkey(db) firstkey() -#define odbm_nextkey(db,key) nextkey(key) +#define odbm_FETCH(db,key) fetch(key) +#define odbm_STORE(db,key,value,flags) store(key,value) +#define odbm_DELETE(db,key) delete(key) +#define odbm_FIRSTKEY(db) firstkey() +#define odbm_NEXTKEY(db,key) nextkey(key) static int dbmrefcnt; @@ -26,7 +26,7 @@ static int dbmrefcnt; MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_ ODBM_File -odbm_new(dbtype, filename, flags, mode) +odbm_TIEHASH(dbtype, filename, flags, mode) char * dbtype char * filename int flags @@ -61,28 +61,35 @@ DESTROY(db) dbmclose(); datum -odbm_fetch(db, key) +odbm_FETCH(db, key) ODBM_File db datum key int -odbm_store(db, key, value, flags = DBM_REPLACE) +odbm_STORE(db, key, value, flags = DBM_REPLACE) ODBM_File db datum key datum value int flags + CLEANUP: + if (RETVAL) { + if (RETVAL < 0 && errno == EPERM) + croak("No write permission to odbm file"); + warn("odbm store returned %d, errno %d, key \"%s\"", + RETVAL,errno,key.dptr); + } int -odbm_delete(db, key) +odbm_DELETE(db, key) ODBM_File db datum key datum -odbm_firstkey(db) +odbm_FIRSTKEY(db) ODBM_File db datum -odbm_nextkey(db, key) +odbm_NEXTKEY(db, key) ODBM_File db datum key diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap new file mode 100644 index 0000000000..a6b0e5faa8 --- /dev/null +++ b/ext/ODBM_File/typemap @@ -0,0 +1,25 @@ +# +#################################### DBM SECTION +# + +datum T_DATUM +gdatum T_GDATUM +NDBM_File T_PTROBJ +GDBM_File T_PTROBJ +SDBM_File T_PTROBJ +ODBM_File T_PTROBJ +DB_File T_PTROBJ +DBZ_File T_PTROBJ +FATALFUNC T_OPAQUEPTR + +INPUT +T_DATUM + $var.dptr = SvPV($arg, na); + $var.dsize = (int)na; +T_GDATUM + UNIMPLEMENTED +OUTPUT +T_DATUM + sv_setpvn($arg, $var.dptr, $var.dsize); +T_GDATUM + sv_usepvn($arg, $var.dptr, $var.dsize); diff --git a/ext/POSIX/Makefile.SH b/ext/POSIX/Makefile.SH new file mode 100644 index 0000000000..13a8faa116 --- /dev/null +++ b/ext/POSIX/Makefile.SH @@ -0,0 +1,207 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +potential_libs="-lm -lposix -lcposix " +. $TOP/ext/util/extliblist + +: This extension might need bootstrap support +if test -f ${ext}_BS; then + bootdep=${ext}_BS +else + bootdep='' +fi + +case "$dlsrc" in +dl_aix*) + echo "#!" > $ext.exp + echo "boot_$ext" >> $ext.exp + ;; +esac + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# $ext might have its own bootstrap support +BOOTDEP = $bootdep +BOOTSTRAP = $ext.bs + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs +INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: dynamic +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) + +$(INSTALLDYNAMIC): $(EXT).o + @test -d $(AUTO) || mkdir $(AUTO) + @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) + ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) + +$(BOOTSTRAP): Makefile $(BOOTDEP) + $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) + touch $(BOOTSTRAP) + +$(INSTALLBOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(EXT).xs >tmp + mv tmp $@ + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile + diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm new file mode 100644 index 0000000000..3fa292df6a --- /dev/null +++ b/ext/POSIX/POSIX.pm @@ -0,0 +1,1023 @@ +package POSIX; + +use Carp; +require Exporter; +require AutoLoader; +require DynaLoader; +require Config; +@ISA = (Exporter, AutoLoader, DynaLoader); + +$H{assert_h} = [qw(assert NDEBUG)]; + +$H{ctype_h} = [qw(isalnum isalpha iscntrl isdigit isgraph islower + isprint ispunct isspace isupper isxdigit tolower toupper)]; + +$H{dirent_h} = [qw()]; + +$H{errno_h} = [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM + EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE + EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK + ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO + EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)]; + +$H{fcntl_h} = [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK + F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK + O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK + O_RDONLY O_RDWR O_TRUNC O_WRONLY + creat + SEEK_CUR SEEK_END SEEK_SET + S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID + S_IWGRP S_IWOTH S_IWUSR)]; + +$H{float_h} = [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG + DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP + DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP + FLT_DIG FLT_EPSILON FLT_MANT_DIG + FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP + FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP + FLT_RADIX FLT_ROUNDS + LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG + LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP + LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)]; + +$H{grp_h} = [qw()]; + +$H{limits_h} = [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX + INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON + MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX + PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN + SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX + ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX + _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT + _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX + _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX + _POSIX_STREADM_MAX _POSIX_TZNAME_MAX)]; + +$H{locale_h} = [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC + LC_TIME NULL localeconv setlocale)]; + +$H{math_h} = [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod + frexp ldexp log10 modf pow sinh tanh)]; + +$H{pwd_h} = [qw()]; + +$H{setjmp_h} = [qw(longjmp setjmp siglongjmp sigsetjmp)]; + +$H{signal_h} = [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE + SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV + SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 + SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK + raise sigaction signal sigpending sigprocmask + sigsuspend)]; + +$H{stdarg_h} = [qw()]; + +$H{stddef_h} = [qw(NULL offsetof)]; + +$H{stdio_h} = [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid + L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET STREAM_MAX + TMP_MAX stderr stdin stdout _IOFBF _IOLBF _IONBF + clearerr fclose fdopen feof ferror fflush fgetc fgetpos + fgets fopen fprintf fputc fputs fread freopen + fscanf fseek fsetpos ftell fwrite getchar gets + perror putc putchar puts remove rewind + scanf setbuf setvbuf sscanf tmpfile tmpnam + ungetc vfprintf vprintf vsprintf)]; + +$H{stdlib_h} = [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX + abort atexit atof atoi atol bsearch calloc div + free getenv labs ldiv malloc mblen mbstowcs mbtowc + qsort realloc strtod strtol stroul wcstombs wctomb)]; + +$H{string_h} = [qw(NULL memchr memcmp memcpy memmove memset strcat + strchr strcmp strcoll strcpy strcspn strerror strlen + strncat strncmp strncpy strpbrk strrchr strspn strstr + strtok strxfrm)]; + +$H{sys_stat_h} = [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG + S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR + fstat mkfifo)]; + +$H{sys_times_h} = [qw()]; + +$H{sys_types_h} = [qw()]; + +$H{sys_utsname_h} = [qw(uname)]; + +$H{sys_wait_h} = [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED + WNOHANG WSTOPSIG WTERMSIG WUNTRACED)]; + +$H{termios_h} = [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 + B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL + CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK + ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR + INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST + PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION + TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW + TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART + VSTOP VSUSP VTIME + cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain + tcflow tcflush tcgetattr tcsendbreak tcsetattr )]; + +$H{time_h} = [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime + difftime mktime strftime tzset tzname)]; + +$H{unistd_h} = [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET + STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK + _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON + _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX + _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED + _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS + _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX + _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL + _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS + _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION + _exit access ctermid cuserid + dup2 dup execl execle execlp execv execve execvp + fpathconf getcwd getegid geteuid getgid getgroups + getpid getuid isatty lseek pathconf pause setgid setpgid + setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)]; + +$H{utime_h} = [qw()]; + +sub expand { + local (@mylist); + foreach $entry (@_) { + if ($H{$entry}) { + push(@mylist, @{$H{$entry}}); + } + else { + push(@mylist, $entry); + } + } + @mylist; +} + +@EXPORT = expand qw(assert_h ctype_h dirent_h errno_h fcntl_h float_h + grp_h limits_h locale_h math_h pwd_h setjmp_h signal_h + stdarg_h stddef_h stdio_h stdlib_h string_h sys_stat_h + sys_times_h sys_types_h sys_utsname_h sys_wait_h + termios_h time_h unistd_h utime_h); + +@EXPORT_OK = qw( + closedir opendir readdir rewinddir + fcntl open + getgrgid getgrnam + atan2 cos exp log sin sqrt tan + getpwnam getpwuid + kill + fileno getc printf rename sprintf + abs exit rand srand system + chmod mkdir stat umask + times + wait waitpid + gmtime localtime time + alarm chdir chown close fork getlogin getppid getpgrp link + pipe read rmdir sleep unlink write + utime +); + +sub import { + my $this = shift; + my @list = expand @_; + local $Exporter::ExportLevel = 1; + Exporter::import($this,@list); +} + +sub AUTOLOAD { + if ($AUTOLOAD =~ /::(_?[a-z])/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD + } + local $constname = $AUTOLOAD; + $constname =~ s/.*:://; + $val = constant($constname, $_[0]); + if ($! != 0) { + if ($! =~ /Invalid/) { + croak "$constname is not a valid POSIX macro"; + } + else { + croak "Your vendor has not defined POSIX macro $constname, used"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +@liblist = (); +@liblist = split ' ', $Config::Config{"POSIX_loadlibs"} + if defined $Config::Config{"POSIX_loadlibs"}; +bootstrap POSIX @liblist; + +sub usage { + local ($mess) = @_; + croak "Usage: POSIX::$mess"; +} + +sub redef { + local ($mess) = @_; + croak "Use method $mess instead"; +} + +sub unimpl { + local ($mess) = @_; + $mess =~ s/xxx//; + croak "Unimplemented: POSIX::$mess"; +} + +$gensym = "SYM000"; + +sub gensym { + *{"POSIX::" . $gensym++}; +} + +sub ungensym { + local($x) = shift; + $x =~ s/.*:://; + delete $::_POSIX{$x}; +} + +############################ +package POSIX::SigAction; + +sub new { + bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3]}; +} + +############################ +package FileHandle; + +sub new { + POSIX::usage "FileHandle->new(filename, posixmode)" if @_ != 3; + local($class,$filename,$mode) = @_; + local($glob) = &POSIX::gensym; + $mode =~ s/a.*/>>/ || + $mode =~ s/w.*/>/ || + ($mode = '<'); + open($glob, "$mode $filename"); + bless \$glob; +} + +sub new_from_fd { + POSIX::usage "FileHandle->new_from_fd(fd,mode)" if @_ != 3; + local($class,$fd,$mode) = @_; + local($glob) = &POSIX::gensym; + $mode =~ s/a.*/>>/ || + $mode =~ s/w.*/>/ || + ($mode = '<'); + open($glob, "$mode&=$fd"); + bless \$glob; +} + +sub clearerr { + POSIX::usage "clearerr(filehandle)" if @_ != 1; + seek($_[0], 0, 1); +} + +sub close { + POSIX::usage "close(filehandle)" if @_ != 1; + close($_[0]); + ungensym($_[0]); +} + +sub eof { + POSIX::usage "eof(filehandle)" if @_ != 1; + eof($_[0]); +} + +sub getc { + POSIX::usage "getc(filehandle)" if @_ != 1; + getc($_[0]); +} + +sub gets { + POSIX::usage "gets(filehandle)" if @_ != 1; + local($handle) = @_; + scalar <$handle>; +} + +sub fileno { + POSIX::usage "fileno(filehandle)" if @_ != 1; + fileno($_[0]); +} + +sub seek { + POSIX::usage "seek(filehandle,pos,whence)" if @_ != 3; + seek($_[0], $_[1], $_[2]); +} + +sub tell { + POSIX::usage "tell(filehandle)" if @_ != 1; + tell($_[0]); +} +############################ +package POSIX; # return to package POSIX so AutoSplit is happy +1; +__END__ + +sub assert { + usage "assert(expr)" if @_ != 1; + if (!$_[0]) { + croak "Assertion failed"; + } +} + +sub tolower { + usage "tolower(string)" if @_ != 1; + lc($_[0]); +} + +sub toupper { + usage "toupper(string)" if @_ != 1; + uc($_[0]); +} + +sub closedir { + usage "closedir(dirhandle)" if @_ != 1; + closedir($_[0]); + ungensym($_[0]); +} + +sub opendir { + usage "opendir(directory)" if @_ != 1; + local($dirhandle) = &gensym; + opendir($dirhandle, $_[0]) + ? $dirhandle + : (ungensym($dirhandle), undef); +} + +sub readdir { + usage "readdir(dirhandle)" if @_ != 1; + readdir($_[0]); +} + +sub rewinddir { + usage "rewinddir(dirhandle)" if @_ != 1; + rewinddir($_[0]); +} + +sub errno { + usage "errno()" if @_ != 0; + $! + 0; +} + +sub creat { + usage "creat(filename, mode)" if @_ != 2; + &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[2]); +} + +sub fcntl { + usage "fcntl(filehandle, cmd, arg)" if @_ != 3; + fcntl($_[0], $_[1], $_[2]); +} + +sub getgrgid { + usage "getgrgid(gid)" if @_ != 1; + getgrgid($_[0]); +} + +sub getgrnam { + usage "getgrnam(name)" if @_ != 1; + getgrnam($_[0]); +} + +sub atan2 { + usage "atan2(x,y)" if @_ != 2; + atan2($_[0], $_[1]); +} + +sub cos { + usage "cos(x)" if @_ != 1; + cos($_[0]); +} + +sub exp { + usage "exp(x)" if @_ != 1; + exp($_[0]); +} + +sub fabs { + usage "fabs(x)" if @_ != 1; + abs($_[0]); +} + +sub log { + usage "log(x)" if @_ != 1; + log($_[0]); +} + +sub pow { + usage "pow(x,exponent)" if @_ != 2; + $_[0] ** $_[1]; +} + +sub sin { + usage "sin(x)" if @_ != 1; + sin($_[0]); +} + +sub sqrt { + usage "sqrt(x)" if @_ != 1; + sqrt($_[0]); +} + +sub tan { + usage "tan(x)" if @_ != 1; + tan($_[0]); +} + +sub getpwnam { + usage "getpwnam(name)" if @_ != 1; + getpwnam($_[0]); +} + +sub getpwuid { + usage "getpwuid(uid)" if @_ != 1; + getpwuid($_[0]); +} + +sub longjmp { + unimpl "longjmp() is C-specific: use die instead"; +} + +sub setjmp { + unimpl "setjmp() is C-specific: use eval {} instead"; +} + +sub siglongjmp { + unimpl "siglongjmp() is C-specific: use die instead"; +} + +sub sigsetjmp { + unimpl "sigsetjmp() is C-specific: use eval {} instead"; +} + +sub kill { + usage "kill(pid, sig)" if @_ != 2; + kill $_[1], $_[0]; +} + +sub raise { + usage "raise(sig)" if @_ != 1; + kill $$, $_[0]; # Is this good enough? +} + +sub offsetof { + unimpl "offsetof() is C-specific, stopped"; +} + +sub clearerr { + redef "$filehandle->clearerr(filehandle)"; +} + +sub fclose { + redef "$filehandle->fclose(filehandle)"; +} + +sub fdopen { + redef "FileHandle->new_from_fd(fd,mode)"; +} + +sub feof { + redef "$filehandle->eof()"; +} + +sub fgetc { + redef "$filehandle->getc()"; +} + +sub fgets { + redef "$filehandle->gets()"; +} + +sub fileno { + redef "$filehandle->fileno()"; +} + +sub fopen { + redef "FileHandle->open()"; +} + +sub fprintf { + unimpl "fprintf() is C-specific--use printf instead"; +} + +sub fputc { + unimpl "fputc() is C-specific--use print instead"; +} + +sub fputs { + unimpl "fputs() is C-specific--use print instead"; +} + +sub fread { + unimpl "fread() is C-specific--use read instead"; +} + +sub freopen { + unimpl "freopen() is C-specific--use open instead"; +} + +sub fscanf { + unimpl "fscanf() is C-specific--use <> and regular expressions instead"; +} + +sub fseek { + redef "$filehandle->seek(pos,whence)"; +} + +sub ferror { + redef "$filehandle->error()"; +} + +sub fflush { + redef "$filehandle->flush()"; +} + +sub fgetpos { + redef "$filehandle->getpos()"; +} + +sub fsetpos { + redef "$filehandle->setpos(pos)"; +} + +sub ftell { + redef "$filehandle->tell()"; +} + +sub fwrite { + unimpl "fwrite() is C-specific--use print instead"; +} + +sub getc { + usage "getc(handle)" if @_ != 1; + getc($_[0]); +} + +sub getchar { + usage "getchar()" if @_ != 0; + getc(STDIN); +} + +sub gets { + usage "gets()" if @_ != 0; + scalar <STDIN>; +} + +sub perror { + print STDERR "@_: " if @_; + print STDERR $!,"\n"; +} + +sub printf { + usage "printf(pattern, args...)" if @_ < 1; + printf STDOUT @_; +} + +sub putc { + unimpl "putc() is C-specific--use print instead"; +} + +sub putchar { + unimpl "putchar() is C-specific--use print instead"; +} + +sub puts { + unimpl "puts() is C-specific--use print instead"; +} + +sub remove { + usage "remove(filename)" if @_ != 1; + unlink($_[0]); +} + +sub rename { + usage "rename(oldfilename, newfilename)" if @_ != 2; + rename($_[0], $_[1]); +} + +sub rewind { + usage "rewind(filehandle)" if @_ != 1; + seek($_[0],0,0); +} + +sub scanf { + unimpl "scanf() is C-specific--use <> and regular expressions instead"; +} + +sub sprintf { + usage "sprintf(pattern,args)" if @_ == 0; + sprintf(shift,@_); +} + +sub sscanf { + unimpl "sscanf() is C-specific--use regular expressions instead"; +} + +sub tmpfile { + redef "FileHandle->new_tmpfile()"; +} + +sub ungetc { + redef "$filehandle->ungetc(char)"; +} + +sub vfprintf { + unimpl "vfprintf() is C-specific"; +} + +sub vprintf { + unimpl "vprintf() is C-specific"; +} + +sub vsprintf { + unimpl "vsprintf() is C-specific"; +} + +sub abs { + usage "abs(x)" if @_ != 1; + abs($_[0]); +} + +sub atexit { + unimpl "atexit() is C-specific: use END {} instead"; +} + +sub atof { + unimpl "atof() is C-specific, stopped"; +} + +sub atoi { + unimpl "atoi() is C-specific, stopped"; +} + +sub atol { + unimpl "atol() is C-specific, stopped"; +} + +sub bsearch { + unimpl "bsearch(xxx)" if @_ != 123; + bsearch($_[0]); +} + +sub calloc { + unimpl "calloc() is C-specific, stopped"; +} + +sub div { + unimpl "div() is C-specific, stopped"; +} + +sub exit { + usage "exit(status)" if @_ != 1; + exit($_[0]); +} + +sub free { + unimpl "free() is C-specific, stopped"; + free($_[0]); +} + +sub getenv { + usage "getenv(name)" if @_ != 1; + $ENV{$_[0]}; +} + +sub labs { + unimpl "labs() is C-specific, use abs instead"; +} + +sub ldiv { + unimpl "ldiv() is C-specific, use / and int instead"; +} + +sub malloc { + unimpl "malloc() is C-specific, stopped"; +} + +sub qsort { + unimpl "qsort() is C-specific, use sort instead"; +} + +sub rand { + unimpl "rand() is non-portable, use Perl's rand instead"; +} + +sub realloc { + unimpl "realloc() is C-specific, stopped"; +} + +sub srand { + unimpl "srand()"; +} + +sub strtod { + unimpl "strtod() is C-specific, stopped"; +} + +sub strtol { + unimpl "strtol() is C-specific, stopped"; +} + +sub stroul { + unimpl "stroul() is C-specific, stopped"; +} + +sub system { + usage "system(command)" if @_ != 1; + system($_[0]); +} + +sub memchr { + unimpl "memchr() is C-specific, use index() instead"; +} + +sub memcmp { + unimpl "memcmp() is C-specific, use eq instead"; +} + +sub memcpy { + unimpl "memcpy() is C-specific, use = instead"; + memcpy($_[0]); + +sub memmove { + unimpl "memmove() is C-specific, use = instead"; +} + +sub memset { + unimpl "memset() is C-specific, use x instead"; +} + +sub strcat { + unimpl "strcat() is C-specific, use .= instead"; +} + +sub strchr { + unimpl "strchr() is C-specific, use index() instead"; +} + +sub strcmp { + unimpl "strcmp() is C-specific, use eq instead"; +} + +sub strcpy { + unimpl "strcpy() is C-specific, use = instead"; +} + +sub strcspn { + unimpl "strcspn() is C-specific, use regular expressions instead"; +} + +sub strerror { + usage "strerror(errno)" if @_ != 1; + local $! = $_[0]; + $! . ""; +} + +sub strlen { + unimpl "strlen() is C-specific, use length instead"; +} + +sub strncat { + unimpl "strncat() is C-specific, use .= instead"; +} + +sub strncmp { + unimpl "strncmp() is C-specific, use eq instead"; +} + +sub strncpy { + unimpl "strncpy() is C-specific, use = instead"; +} + +sub strpbrk { + unimpl "strpbrk() is C-specific, stopped"; +} + +sub strrchr { + unimpl "strrchr() is C-specific, use rindex() instead"; +} + +sub strspn { + unimpl "strspn() is C-specific, stopped"; +} + +sub strstr { + usage "strstr(big, little)" if @_ != 2; + index($_[0], $_[1]); +} + +sub strtok { + unimpl "strtok() is C-specific, stopped"; +} + +sub chmod { + usage "chmod(filename, mode)" if @_ != 2; + chmod($_[0], $_[1]); +} + +sub fstat { + usage "fstat(fd)" if @_ != 1; + local(*TMP); + open(TMP, "<&$_[0]"); # Gross. + local(@l) = stat(TMP); + close(TMP); + @l; +} + +sub mkdir { + usage "mkdir(directoryname, mode)" if @_ != 2; + mkdir($_[0], $_[1]); +} + +sub stat { + usage "stat(filename)" if @_ != 1; + stat($_[0]); +} + +sub umask { + usage "umask(mask)" if @_ != 1; + umask($_[0]); +} + +sub times { + usage "times()" if @_ != 0; + times(); +} + +sub wait { + usage "wait(statusvariable)" if @_ != 1; + local $result = wait(); + $_[0] = $?; + $result; +} + +sub waitpid { + usage "waitpid(pid, statusvariable, options)" if @_ != 3; + local $result = waitpid($_[0], $_[2]); + $_[1] = $?; + $result; +} + +sub gmtime { + usage "gmtime(time)" if @_ != 1; + gmtime($_[0]); +} + +sub localtime { + usage "localtime(time)" if @_ != 1; + localtime($_[0]); +} + +sub time { + unimpl "time()" if @_ != 0; + time; +} + +sub alarm { + usage "alarm(seconds)" if @_ != 1; + alarm($_[0]); +} + +sub chdir { + usage "chdir(directory)" if @_ != 1; + chdir($_[0]); +} + +sub chown { + usage "chown(filename, uid, gid)" if @_ != 3; + chown($_[0], $_[1], $_[2]); +} + +sub execl { + unimpl "execl() is C-specific, stopped"; + execl($_[0]); +} + +sub execle { + unimpl "execle() is C-specific, stopped"; + execle($_[0]); +} + +sub execlp { + unimpl "execlp() is C-specific, stopped"; + execlp($_[0]); +} + +sub execv { + unimpl "execv() is C-specific, stopped"; + execv($_[0]); +} + +sub execve { + unimpl "execve() is C-specific, stopped"; + execve($_[0]); +} + +sub execvp { + unimpl "execvp() is C-specific, stopped"; + execvp($_[0]); +} + +sub fork { + usage "fork()" if @_ != 0; + fork; +} + +sub getcwd +{ + usage "getcwd()" if @_ != 0; + chop($cwd = `pwd`); + $cwd; +} + +sub getegid { + usage "getegid()" if @_ != 0; + $) + 0; +} + +sub geteuid { + usage "geteuid()" if @_ != 0; + $> + 0; +} + +sub getgid { + usage "getgid()" if @_ != 0; + $( + 0; +} + +sub getgroups { + usage "getgroups()" if @_ != 0; + local(%seen) = (); + grep(!$seen{$_}++, split(' ', $) )); +} + +sub getlogin { + usage "getlogin()" if @_ != 0; + getlogin(); +} + +sub getpgrp { + usage "getpgrp()" if @_ != 0; + getpgrp($_[0]); +} + +sub getpid { + usage "getpid()" if @_ != 0; + $$; +} + +sub getppid { + usage "getppid()" if @_ != 0; + getppid; +} + +sub getuid { + usage "getuid()" if @_ != 0; + $<; +} + +sub isatty { + usage "isatty(filehandle)" if @_ != 1; + -t $_[0]; +} + +sub link { + usage "link(oldfilename, newfilename)" if @_ != 2; + link($_[0], $_[1]); +} + +sub rmdir { + usage "rmdir(directoryname)" if @_ != 1; + rmdir($_[0]); +} + +sub setgid { + usage "setgid(gid)" if @_ != 1; + $( = $_[0]; +} + +sub setuid { + usage "setuid(uid)" if @_ != 1; + $< = $_[0]; +} + +sub sleep { + usage "sleep(seconds)" if @_ != 1; + sleep($_[0]); +} + +sub unlink { + usage "unlink(filename)" if @_ != 1; + unlink($_[0]); +} + +sub utime { + usage "utime(filename, atime, mtime)" if @_ != 3; + utime($_[1], $_[2], $_[0]); +} + diff --git a/ext/posix/POSIX.xs b/ext/POSIX/POSIX.xs index a439494dac..941e59a795 100644 --- a/ext/posix/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -1,16 +1,19 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" - #include <ctype.h> +#ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */ #include <dirent.h> +#endif #include <errno.h> #include <fcntl.h> #ifdef I_FLOAT #include <float.h> #endif #include <grp.h> +#ifdef I_LIMITS #include <limits.h> +#endif #include <locale.h> #include <math.h> #ifdef I_PWD @@ -24,33 +27,83 @@ #ifdef I_STDDEF #include <stddef.h> #endif +/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to + metaconfig for future extension writers. We don't use them in POSIX. + (This is really sneaky :-) --AD +*/ +#if defined(I_TERMIOS) +#include <termios.h> +#endif #include <stdio.h> +#ifdef I_STDLIB #include <stdlib.h> +#endif #include <string.h> #include <sys/stat.h> #include <sys/times.h> #include <sys/types.h> +#ifdef HAS_UNAME #include <sys/utsname.h> -#include <sys/wait.h> -#if defined(I_TERMIOS) && !defined(CR3) -#include <termios.h> #endif +#include <sys/wait.h> #include <time.h> #include <unistd.h> +#ifdef I_UTIME #include <utime.h> +#endif +typedef FILE * InputStream; +typedef FILE * OutputStream; typedef int SysRet; +typedef long SysRetLong; typedef sigset_t* POSIX__SigSet; typedef HV* POSIX__SigAction; - -#define HAS_UNAME - -#ifndef HAS_GETPGRP -#define getpgrp() not_here("getpgrp") +#ifdef I_TERMIOS +typedef struct termios* POSIX__Termios; +#else /* Define termios types to int, and call not_here for the functions.*/ +#define POSIX__Termios int +#define speed_t int +#define tcflag_t int +#define cc_t int +#define cfgetispeed(x) not_here("cfgetispeed") +#define cfgetospeed(x) not_here("cfgetospeed") +#define tcdrain(x) not_here("tcdrain") +#define tcflush(x,y) not_here("tcflush") +#define tcsendbreak(x,y) not_here("tcsendbreak") +#define cfsetispeed(x,y) not_here("cfsetispeed") +#define cfsetospeed(x,y) not_here("cfsetospeed") +#define ctermid(x) (char *) not_here("ctermid") +#define tcflow(x,y) not_here("tcflow") +#define tcgetattr(x,y) not_here("tcgetattr") +#define tcsetattr(x,y,z) not_here("tcsetattr") +#endif + +/* Possibly needed prototypes */ +char *cuserid _((char *)); + +#ifndef HAS_CUSERID +#define cuserid(a) (char *) not_here("cuserid") +#endif +#ifndef HAS_DIFFTIME +#ifndef difftime +#define difftime(a,b) not_here("difftime") +#endif +#endif +#ifndef HAS_FPATHCONF +#define fpathconf(f,n) (SysRetLong) not_here("fpathconf") +#endif +#ifndef HAS_MKTIME +#define mktime(a) not_here("mktime") #endif #ifndef HAS_NICE #define nice(a) not_here("nice") #endif +#ifndef HAS_PATHCONF +#define pathconf(f,n) (SysRetLong) not_here("pathconf") +#endif +#ifndef HAS_SYSCONF +#define sysconf(n) (SysRetLong) not_here("sysconf") +#endif #ifndef HAS_READLINK #define readlink(a,b,c) not_here("readlink") #endif @@ -60,8 +113,11 @@ typedef HV* POSIX__SigAction; #ifndef HAS_SETSID #define setsid() not_here("setsid") #endif -#ifndef HAS_SYMLINK -#define symlink(a,b) not_here("symlink") +#ifndef HAS_STRCOLL +#define strcoll(s1,s2) not_here("strcoll") +#endif +#ifndef HAS_STRXFRM +#define strxfrm(s1,s2,n) not_here("strxfrm") #endif #ifndef HAS_TCGETPGRP #define tcgetpgrp(a) not_here("tcgetpgrp") @@ -79,6 +135,63 @@ typedef HV* POSIX__SigAction; #define waitpid(a,b,c) not_here("waitpid") #endif +#ifndef HAS_FGETPOS +#define fgetpos(a,b) not_here("fgetpos") +#endif +#ifndef HAS_FSETPOS +#define fsetpos(a,b) not_here("fsetpos") +#endif + +#ifndef HAS_MBLEN +#ifndef mblen +#define mblen(a,b) not_here("mblen") +#endif +#endif +#ifndef HAS_MBSTOWCS +#define mbstowcs(s, pwcs, n) not_here("mbstowcs") +#endif +#ifndef HAS_MBTOWC +#define mbtowc(pwc, s, n) not_here("mbtowc") +#endif +#ifndef HAS_WCSTOMBS +#define wcstombs(s, pwcs, n) not_here("wcstombs") +#endif +#ifndef HAS_WCTOMB +#define wctomb(s, wchar) not_here("wcstombs") +#endif +#if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB) +/* If we don't have these functions, then we wouldn't have gotten a typedef + for wchar_t, the wide character type. Defining wchar_t allows the + functions referencing it to compile. Its actual type is then meaningless, + since without the above functions, all sections using it end up calling + not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */ +#ifndef wchar_t +#define wchar_t char +#endif +#endif + +#ifndef HAS_LOCALECONV +#define localeconv() not_here("localeconv") +#endif + +#ifdef HAS_TZNAME +extern char *tzname[]; +#else +char *tzname[] = { "" , "" }; +#endif + +#ifndef HAS_LONG_DOUBLE /* XXX What to do about long doubles? */ +#ifdef LDBL_MAX +#undef LDBL_MAX +#endif +#ifdef LDBL_MIN +#undef LDBL_MIN +#endif +#ifdef LDBL_EPSILON +#undef LDBL_EPSILON +#endif +#endif + static int not_here(s) char *s; @@ -87,7 +200,8 @@ char *s; return -1; } -int constant(name, arg) +static double +constant(name, arg) char *name; int arg; { @@ -1066,7 +1180,7 @@ int arg; #endif break; case 'N': - if (strEQ(name, "NULL")) return NULL; + if (strEQ(name, "NULL")) return 0; if (strEQ(name, "NAME_MAX")) #ifdef NAME_MAX return NAME_MAX; @@ -2040,7 +2154,7 @@ new(packname = "POSIX::SigSet", ...) int i; RETVAL = (sigset_t*)safemalloc(sizeof(sigset_t)); sigemptyset(RETVAL); - for (i = 2; i <= items; i++) + for (i = 1; i < items; i++) sigaddset(RETVAL, SvIV(ST(i))); } OUTPUT: @@ -2050,7 +2164,7 @@ void DESTROY(sigset) POSIX::SigSet sigset CODE: - safefree(sigset); + safefree((char *)sigset); SysRet sigaddset(sigset, sig) @@ -2076,9 +2190,252 @@ sigismember(sigset, sig) int sig -MODULE = POSIX PACKAGE = POSIX +MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf + +POSIX::Termios +new(packname = "POSIX::Termios", ...) + char * packname + CODE: + { +#ifdef I_TERMIOS + RETVAL = (struct termios*)safemalloc(sizeof(struct termios)); +#else + not_here("termios"); +#endif + } + OUTPUT: + RETVAL + +void +DESTROY(termios_ref) + POSIX::Termios termios_ref + CODE: +#ifdef I_TERMIOS + safefree((char *)termios_ref); +#else + not_here("termios"); +#endif + +SysRet +getattr(termios_ref, fd = 0) + POSIX::Termios termios_ref + int fd + CODE: + RETVAL = tcgetattr(fd, termios_ref); + OUTPUT: + RETVAL + +SysRet +setattr(termios_ref, fd = 0, optional_actions = 0) + POSIX::Termios termios_ref + int fd + int optional_actions + CODE: + RETVAL = tcsetattr(fd, optional_actions, termios_ref); + OUTPUT: + RETVAL + +speed_t +cfgetispeed(termios_ref) + POSIX::Termios termios_ref + +speed_t +cfgetospeed(termios_ref) + POSIX::Termios termios_ref + +tcflag_t +getiflag(termios_ref) + POSIX::Termios termios_ref + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + RETVAL = termios_ref->c_iflag; +#else + not_here("getiflag"); +#endif + OUTPUT: + RETVAL + +tcflag_t +getoflag(termios_ref) + POSIX::Termios termios_ref + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + RETVAL = termios_ref->c_oflag; +#else + not_here("getoflag"); +#endif + OUTPUT: + RETVAL + +tcflag_t +getcflag(termios_ref) + POSIX::Termios termios_ref + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + RETVAL = termios_ref->c_cflag; +#else + not_here("getcflag"); +#endif + OUTPUT: + RETVAL + +tcflag_t +getlflag(termios_ref) + POSIX::Termios termios_ref + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + RETVAL = termios_ref->c_lflag; +#else + not_here("getlflag"); +#endif + OUTPUT: + RETVAL + +cc_t +getcc(termios_ref, ccix) + POSIX::Termios termios_ref + int ccix + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + if (ccix >= NCCS) + croak("Bad getcc subscript"); + RETVAL = termios_ref->c_cc[ccix]; +#else + not_here("getcc"); +#endif + OUTPUT: + RETVAL + +SysRet +cfsetispeed(termios_ref, speed) + POSIX::Termios termios_ref + speed_t speed + +SysRet +cfsetospeed(termios_ref, speed) + POSIX::Termios termios_ref + speed_t speed + +void +setiflag(termios_ref, iflag) + POSIX::Termios termios_ref + tcflag_t iflag + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + termios_ref->c_iflag = iflag; +#else + not_here("setiflag"); +#endif + +void +setoflag(termios_ref, oflag) + POSIX::Termios termios_ref + tcflag_t oflag + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + termios_ref->c_oflag = oflag; +#else + not_here("setoflag"); +#endif + +void +setcflag(termios_ref, cflag) + POSIX::Termios termios_ref + tcflag_t cflag + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + termios_ref->c_cflag = cflag; +#else + not_here("setcflag"); +#endif + +void +setlflag(termios_ref, lflag) + POSIX::Termios termios_ref + tcflag_t lflag + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + termios_ref->c_lflag = lflag; +#else + not_here("setlflag"); +#endif + +void +setcc(termios_ref, ccix, cc) + POSIX::Termios termios_ref + int ccix + cc_t cc + CODE: +#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ + if (ccix >= NCCS) + croak("Bad setcc subscript"); + termios_ref->c_cc[ccix] = cc; +#else + not_here("setcc"); +#endif + + + +MODULE = FileHandle PACKAGE = FileHandle PREFIX = f + +SV * +fgetpos(handle) + InputStream handle + CODE: + { + Fpos_t pos; + fgetpos(handle, &pos); + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } + +SysRet +fsetpos(handle, pos) + InputStream handle + SV * pos + CODE: + RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos)); + OUTPUT: + RETVAL + +int +ungetc(handle, c) + InputStream handle + int c + CODE: + RETVAL = ungetc(c, handle); + OUTPUT: + RETVAL + +OutputStream +new_tmpfile() + CODE: + RETVAL = tmpfile(); + OUTPUT: + RETVAL int +ferror(handle) + InputStream handle + +SysRet +fflush(handle) + OutputStream handle + +void +setbuf(handle, buf) + OutputStream handle + char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; + +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 + +MODULE = POSIX PACKAGE = POSIX + +double constant(name,arg) char * name int arg @@ -2219,11 +2576,12 @@ SysRet open(filename, flags = O_RDONLY, mode = 0666) char * filename int flags - int mode + Mode_t mode HV * localeconv() CODE: +#ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); if (lcbuf = localeconv()) { @@ -2284,6 +2642,9 @@ localeconv() hv_store(RETVAL, "n_sign_posn", 11, newSViv(lcbuf->n_sign_posn), 0); } +#else + localeconv(); /* A stub to call not_here(). */ +#endif OUTPUT: RETVAL @@ -2326,7 +2687,6 @@ frexp(x) double x PPCODE: int expvar; - sp--; /* (We already know stack is long enough.) */ PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); PUSHs(sv_2mortal(newSViv(expvar))); @@ -2345,7 +2705,6 @@ modf(x) double x PPCODE: double intvar; - sp--; /* (We already know stack is long enough.) */ PUSHs(sv_2mortal(newSVnv(modf(x,&intvar)))); PUSHs(sv_2mortal(newSVnv(intvar))); @@ -2401,7 +2760,9 @@ sigaction(sig, action, oldaction = 0) /* Set up any desired mask. */ svp = hv_fetch(action, "MASK", 4, FALSE); if (svp && sv_isa(*svp, "POSIX::SigSet")) { - sigset = (sigset_t*)(unsigned long)SvNV((SV*)SvRV(*svp)); + unsigned long tmp; + tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); + sigset = (sigset_t*) tmp; act.sa_mask = *sigset; } else @@ -2419,12 +2780,17 @@ sigaction(sig, action, oldaction = 0) RETVAL = sigaction(sig, & act, (struct sigaction*)0); else if (oldaction) RETVAL = sigaction(sig, (struct sigaction*)0, & oact); + else + RETVAL = -1; if (oldaction) { /* Get back the mask. */ svp = hv_fetch(oldaction, "MASK", 4, TRUE); - if (sv_isa(*svp, "POSIX::SigSet")) - sigset = (sigset_t*)(unsigned long)SvNV((SV*)SvRV(*svp)); + if (sv_isa(*svp, "POSIX::SigSet")) { + unsigned long tmp; + tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); + sigset = (sigset_t*) tmp; + } else { sigset = (sigset_t*)safemalloc(sizeof(sigset_t)); sv_setptrobj(*svp, sigset, "POSIX::SigSet"); @@ -2453,21 +2819,6 @@ SysRet sigsuspend(signal_mask) POSIX::SigSet signal_mask -############ Work in progress - -#FileHandle -#fdopen(fd, type) -# int fd -# char * type - -#int -#ferror(handle) -# FileHandle handle - -#SysRet -#fflush(handle) -# OutputHandle handle - void _exit(status) int status @@ -2486,7 +2837,7 @@ dup2(fd1, fd2) int fd2 SysRet -lseek() +lseek(fd, offset, whence) int fd Off_t offset int whence @@ -2499,7 +2850,6 @@ int pipe() PPCODE: int fds[2]; - sp--; if (pipe(fds) != -1) { EXTEND(sp,2); PUSHs(sv_2mortal(newSViv(fds[0]))); @@ -2507,16 +2857,18 @@ pipe() } SysRet -read() - CODE: - int fd; - char * buffer; - size_t nbytes; - - RETVAL = read(fd, buffer, nbytes); - croak("POSIX::read() not implemented yet\n"); - OUTPUT: - RETVAL +read(fd, buffer, nbytes) + int fd + char * buffer = sv_grow(ST(1),SvIV(ST(2))+1); + size_t nbytes + CLEANUP: + if (RETVAL >= 0) { + SvCUR(ST(1)) = RETVAL; + SvPOK_only(ST(1)); + *SvEND(ST(1)) = '\0'; + if (tainting) + sv_magic(ST(1), 0, 't', 0, 0); + } SysRet setgid(gid) @@ -2546,8 +2898,8 @@ tcsetpgrp(fd, pgrp_id) int uname() PPCODE: +#ifdef HAS_UNAME struct utsname buf; - sp--; if (uname(&buf) >= 0) { EXTEND(sp, 5); PUSHs(sv_2mortal(newSVpv(buf.sysname, 0))); @@ -2556,15 +2908,241 @@ uname() PUSHs(sv_2mortal(newSVpv(buf.version, 0))); PUSHs(sv_2mortal(newSVpv(buf.machine, 0))); } +#else + uname((char *) 0); /* A stub to call not_here(). */ +#endif SysRet -write() +write(fd, buffer, nbytes) + int fd + char * buffer + size_t nbytes + +char * +tmpnam(s = 0) + char * s = 0; + +void +abort() + +int +mblen(s, n) + char * s + size_t n + +size_t +mbstowcs(s, pwcs, n) + wchar_t * s + char * pwcs + size_t n + +int +mbtowc(pwc, s, n) + wchar_t * pwc + char * s + size_t n + +int +wcstombs(s, pwcs, n) + char * s + wchar_t * pwcs + size_t n + +int +wctomb(s, wchar) + char * s + wchar_t wchar + +int +strcoll(s1, s2) + char * s1 + char * s2 + +SV * +strxfrm(src) + SV * src CODE: - int fd; - char * buffer; - size_t nbytes; + { + STRLEN srclen; + STRLEN dstlen; + char *p = SvPV(src,srclen); + srclen++; + ST(0) = sv_2mortal(newSV(srclen)); + dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen); + if (dstlen > srclen) { + dstlen++; + SvGROW(ST(0), dstlen); + strxfrm(SvPVX(ST(0)), p, (size_t)dstlen); + dstlen--; + } + SvCUR(ST(0)) = dstlen; + SvPOK_only(ST(0)); + } + +SysRet +mkfifo(filename, mode) + char * filename + Mode_t mode + +SysRet +tcdrain(fd) + int fd + + +SysRet +tcflow(fd, action) + int fd + int action + + +SysRet +tcflush(fd, queue_selector) + int fd + int queue_selector + +SysRet +tcsendbreak(fd, duration) + int fd + int duration + +char * +asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) + int sec + int min + int hour + int mday + int mon + int year + int wday + int yday + int isdst + CODE: + { + struct tm mytm; + mytm.tm_sec = sec; + mytm.tm_min = min; + mytm.tm_hour = hour; + mytm.tm_mday = mday; + mytm.tm_mon = mon; + mytm.tm_year = year; + mytm.tm_wday = wday; + mytm.tm_yday = yday; + mytm.tm_isdst = isdst; + RETVAL = asctime(&mytm); + } + OUTPUT: + RETVAL + +long +clock() + +char * +ctime(time) + Time_t * time - RETVAL = write(fd, buffer, nbytes); - croak("POSIX::write() not implemented yet\n"); +double +difftime(time1, time2) + Time_t time1 + Time_t time2 + +SysRetLong +mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) + int sec + int min + int hour + int mday + int mon + int year + int wday + int yday + int isdst + CODE: + { + struct tm mytm; + mytm.tm_sec = sec; + mytm.tm_min = min; + mytm.tm_hour = hour; + mytm.tm_mday = mday; + mytm.tm_mon = mon; + mytm.tm_year = year; + mytm.tm_wday = wday; + mytm.tm_yday = yday; + mytm.tm_isdst = isdst; + RETVAL = mktime(&mytm); + } OUTPUT: RETVAL + +char * +strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) + char * fmt + int sec + int min + int hour + int mday + int mon + int year + int wday + int yday + int isdst + CODE: + { + char tmpbuf[128]; + struct tm mytm; + int len; + mytm.tm_sec = sec; + mytm.tm_min = min; + mytm.tm_hour = hour; + mytm.tm_mday = mday; + mytm.tm_mon = mon; + mytm.tm_year = year; + mytm.tm_wday = wday; + mytm.tm_yday = yday; + mytm.tm_isdst = isdst; + len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm); + ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); + } + +void +tzset() + +void +tzname() + PPCODE: + EXTEND(sp,2); + PUSHs(sv_2mortal(newSVpv(tzname[0],strlen(tzname[0])))); + PUSHs(sv_2mortal(newSVpv(tzname[1],strlen(tzname[1])))); + +SysRet +access(filename, mode) + char * filename + Mode_t mode + +char * +ctermid(s = 0) + char * s = 0; + +char * +cuserid(s = 0) + char * s = 0; + +SysRetLong +fpathconf(fd, name) + int fd + int name + +SysRetLong +pathconf(filename, name) + char * filename + int name + +SysRet +pause() + +SysRetLong +sysconf(name) + int name + +char * +ttyname(fd) + int fd diff --git a/ext/POSIX/typemap b/ext/POSIX/typemap new file mode 100644 index 0000000000..45e0862ff0 --- /dev/null +++ b/ext/POSIX/typemap @@ -0,0 +1,13 @@ +Mode_t T_NV +pid_t T_NV +Uid_t T_NV +Time_t T_NV +Gid_t T_NV +Off_t T_NV +fd T_IV +speed_t T_IV +tcflag_t T_IV +cc_t T_IV +POSIX::SigSet T_PTROBJ +POSIX::Termios T_PTROBJ +POSIX::SigAction T_HVREF diff --git a/ext/README b/ext/README deleted file mode 100644 index a80a650d7b..0000000000 --- a/ext/README +++ /dev/null @@ -1,114 +0,0 @@ -This directory contains an example of how you might link in C subroutines -with perl to make your own special copy of perl. In the perl distribution -directory, there will be (after make is run) a file called uperl.o, which -is all of perl except for a single undefined subroutine, named userinit(). -See usersub.c. - -The sole purpose of the userinit() routine is to call the initialization -routines for any modules that you want to link in. In this example, we just -call init_curses(), which sets up to link in the System V curses routines. -You'll find this in the file curses.c, which is the processed output of -curses.mus. (To get BSD curses, replace curses.mus with bsdcurses.mus.) - -The magicname() routine adds variable names into the symbol table. Along -with the name of the variable as Perl knows it, we pass a structure containing -an index identifying the variable, and the names of two C functions that -know how to set or evaluate a variable given the index of the variable. -Our example uses a macro to handle this conveniently. - -The init routine calls make_usub() to add user-defined subroutine names -into the symbol table. The arguments are - - make_usub(subname, subindex, subfunc, filename); - char *subname; - int subindex; - int subfunc(); - char *filename; - -The subname is the name that will be used in the Perl program. The subindex -will be passed to subfunc() when it is called to tell it which C function -is desired. subfunc() is a glue routine that translates the arguments -from Perl internal stack form to the form required by the routine in -question, calls the desired C function, and then translates any return -value back into the stack format. The glue routine used by curses just -has a large switch statement, each branch of which does the processing -for a particular C function. The subindex could, however, be used to look -up a function in a dynamically linked library. No example of this is -provided. - -As a help in producing the glue routine, a preprocessor called "mus" lets -you specify argument and return value types in a tabular format. An entry -such as: - - CASE int waddstr - I WINDOW* win - I char* str - END - -indicates that waddstr takes two input arguments, the first of which is a -pointer to a window, and the second of which is an ordinary C string. It -also indicates that an integer is returned. The mus program turns this into: - - case US_waddstr: - if (items != 2) - fatal("Usage: &waddstr($win, $str)"); - else { - int retval; - WINDOW* win = *(WINDOW**) str_get(st[1]); - char* str = (char*) str_get(st[2]); - - retval = waddstr(win, str); - str_numset(st[0], (double) retval); - } - return sp; - -It's also possible to have output parameters, indicated by O, and input/ouput -parameters indicated by IO. - -The mus program isn't perfect. You'll note that curses.mus has some -cases which are hand coded. They'll be passed straight through unmodified. -You can produce similar cases by analogy to what's in curses.c, as well -as similar routines in the doarg.c, dolist.c and doio.c routines of Perl. -The mus program is only intended to get you about 90% there. It's not clear, -for instance, how a given structure should be passed to Perl. But that -shouldn't bother you--if you've gotten this far, it's already obvious -that you are totally mad. - -Here's an example of how to return an array value: - - case US_appl_errlist: - if (!wantarray) { - str_numset(st[0], (double) appl_nerr); - return sp; - } - astore(stack, sp + appl_nerr, Nullstr); /* extend stack */ - st = stack->ary_array + sp; /* possibly realloced */ - for (i = 0; i < appl_nerr; i++) { - tmps = appl_errlist[i]; - st[i] = str_2mortal(str_make(tmps,strlen(tmps))); - } - return sp + appl_nerr - 1; - - -In addition, there is a program, man2mus, that will scan a man page for -function prototypes and attempt to construct a mus CASE entry for you. It has -to guess about input/output parameters, so you'll have to tidy up after it. -But it can save you a lot of time if the man pages for a library are -reasonably well formed. - -If you happen to have curses on your machine, you might try compiling -a copy of curseperl. The "pager" program in this directory is a rudimentary -start on writing a pager--don't believe the help message, which is stolen -from the less program. - -User-defined subroutines may not currently be called as a signal handler, -though a signal handler may itself call a user-defined subroutine. - -There are now glue routines to call back from C into Perl. In usersub.c -in this directory, you'll find callback() and callv(). The callback() -routine presumes that any arguments to pass to the Perl subroutine -have already been pushed onto the Perl stack. The callv() routine -is a wrapper that pushes an argv-style array of strings onto the -stack for you, and then calls callback(). Be sure to recheck your -stack pointer after returning from these routine, since the Perl code -may have reallocated it. diff --git a/ext/SDBM_File/Makefile.SH b/ext/SDBM_File/Makefile.SH new file mode 100644 index 0000000000..1f181e3b09 --- /dev/null +++ b/ext/SDBM_File/Makefile.SH @@ -0,0 +1,216 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +potential_libs=" " +. $TOP/ext/util/extliblist + +: This extension might need bootstrap support +if test -f ${ext}_BS; then + bootdep=${ext}_BS +else + bootdep='' +fi + +case "$dlsrc" in +dl_aix*) + echo "#!" > $ext.exp + echo "boot_$ext" >> $ext.exp + ;; +esac + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# $ext might have its own bootstrap support +BOOTDEP = $bootdep +BOOTSTRAP = $ext.bs + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs +INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: dynamic +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) + +$(INSTALLDYNAMIC): $(EXT).o sdbm/libsdbm.a + @test -d $(AUTO) || mkdir $(AUTO) + @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) + ld $(LDDLFLAGS) -o $@ $(EXT).o sdbm/libsdbm.a $(STATLOADLIBS) + +$(BOOTSTRAP): Makefile $(BOOTDEP) + $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) + touch $(BOOTSTRAP) + +$(INSTALLBOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o sdbm/libsdbm.a + cp sdbm/libsdbm.a $@ + ar r $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(EXT).xs >tmp + mv tmp $@ + +sdbm/libsdbm.a: FORCE + @cd sdbm; \ + if test ! -f Makefile ; then \ + test -f Makefile.SH && sh Makefile.SH ; \ + fi ; $(MAKE) + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +clean: + -cd sdbm; $(MAKE) clean + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp + +realclean: clean + -cd sdbm; $(MAKE) realclean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile + diff --git a/ext/SDBM_File/SDBM_File.pm b/ext/SDBM_File/SDBM_File.pm new file mode 100644 index 0000000000..1f93e52893 --- /dev/null +++ b/ext/SDBM_File/SDBM_File.pm @@ -0,0 +1,11 @@ +package SDBM_File; + +require TieHash; +require DynaLoader; +@ISA = qw(TieHash DynaLoader); + +bootstrap SDBM_File; + +1; + +__END__ diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs new file mode 100644 index 0000000000..97f9c1f9f4 --- /dev/null +++ b/ext/SDBM_File/SDBM_File.xs @@ -0,0 +1,71 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "sdbm/sdbm.h" + +typedef DBM* SDBM_File; +#define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode) +#define sdbm_FETCH(db,key) sdbm_fetch(db,key) +#define sdbm_STORE(db,key,value,flags) sdbm_store(db,key,value,flags) +#define sdbm_DELETE(db,key) sdbm_delete(db,key) +#define sdbm_FIRSTKEY(db) sdbm_firstkey(db) +#define sdbm_NEXTKEY(db,key) sdbm_nextkey(db) + + +MODULE = SDBM_File PACKAGE = SDBM_File PREFIX = sdbm_ + +SDBM_File +sdbm_TIEHASH(dbtype, filename, flags, mode) + char * dbtype + char * filename + int flags + int mode + +void +sdbm_DESTROY(db) + SDBM_File db + CODE: + sdbm_close(db); + +datum +sdbm_FETCH(db, key) + SDBM_File db + datum key + +int +sdbm_STORE(db, key, value, flags = DBM_REPLACE) + SDBM_File db + datum key + datum value + int flags + CLEANUP: + if (RETVAL) { + if (RETVAL < 0 && errno == EPERM) + croak("No write permission to sdbm file"); + warn("sdbm store returned %d, errno %d, key \"%s\"", + RETVAL,errno,key.dptr); + sdbm_clearerr(db); + } + +int +sdbm_DELETE(db, key) + SDBM_File db + datum key + +datum +sdbm_FIRSTKEY(db) + SDBM_File db + +datum +sdbm_NEXTKEY(db, key) + SDBM_File db + datum key + +int +sdbm_error(db) + SDBM_File db + +int +sdbm_clearerr(db) + SDBM_File db + diff --git a/ext/dbm/sdbm/CHANGES b/ext/SDBM_File/sdbm/CHANGES index f7296d1b3a..f7296d1b3a 100644 --- a/ext/dbm/sdbm/CHANGES +++ b/ext/SDBM_File/sdbm/CHANGES diff --git a/ext/dbm/sdbm/COMPARE b/ext/SDBM_File/sdbm/COMPARE index a595e831d2..a595e831d2 100644 --- a/ext/dbm/sdbm/COMPARE +++ b/ext/SDBM_File/sdbm/COMPARE diff --git a/ext/dbm/sdbm/Makefile.SH b/ext/SDBM_File/sdbm/Makefile.SH index 9a19fa2ed5..521c97270a 100644 --- a/ext/dbm/sdbm/Makefile.SH +++ b/ext/SDBM_File/sdbm/Makefile.SH @@ -1,3 +1,10 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + if test -f config.sh; then TOP=.; elif test -f ../config.sh; then TOP=..; elif test -f ../../config.sh; then TOP=../..; @@ -6,19 +13,18 @@ elif test -f ../../../../config.sh; then TOP=../../../..; else echo "Can't find config.sh."; exit 1 fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + case $CONFIG in '') . $TOP/config.sh ;; esac -: This forces SH files to create target in same directory as SH file. -: This is so that make depend always knows where to find SH derivatives. -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac - -echo "Extracting ext/dbm/sdbm/Makefile (with variable substitutions)" +echo "Extracting ext/SDBM_File/sdbm/Makefile (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted @@ -33,16 +39,23 @@ $spitshell >Makefile <<!GROK!THIS! # # CC = $cc -ranlib = $ranlib +RANLIB = $ranlib TOP = $TOP +ABSTOP = $ABSTOP LDFLAGS = $ldflags CLDFLAGS = $ldflags SMALL = $small LARGE = $large $split -# To use an alternate make, set $altmake in config.sh. +# To use an alternate make, set \$altmake in config.sh. MAKE = ${altmake-make} +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags + !GROK!THIS! : In the following dollars and backticks do not need the extra backslash. @@ -51,15 +64,17 @@ SHELL = /bin/sh CCCMD = `sh $(shellflags) $(TOP)/cflags $@` .c.o: - $(CCCMD) -I$(TOP) -DSDBM -DDUFF $*.c + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) -DSDBM -DDUFF $*.c LIBOBJS = sdbm.o pair.o hash.o LIBSRCS = sdbm.c pair.c hash.c HDRS = tune.h sdbm.h pair.h $(TOP)/config.h +all: libsdbm.a + libsdbm.a: $(LIBOBJS) ar cr libsdbm.a $(LIBOBJS) - $(ranlib) libsdbm.a + $(RANLIB) libsdbm.a $(LIBOBJS): $(HDRS) @@ -75,6 +90,10 @@ realclean: clean purge: realclean +sdbm.o : sdbm.c $(TOP)/config.h sdbm.h tune.h pair.h +hash.o : hash.c $(TOP)/config.h sdbm.h +pair.o : pair.c $(TOP)/config.h sdbm.h tune.h pair.h + !NO!SUBS! chmod 755 Makefile $eunicefix Makefile diff --git a/ext/dbm/sdbm/README b/ext/SDBM_File/sdbm/README index cd7312cc57..cd7312cc57 100644 --- a/ext/dbm/sdbm/README +++ b/ext/SDBM_File/sdbm/README diff --git a/ext/dbm/sdbm/README.too b/ext/SDBM_File/sdbm/README.too index c2d095944d..c2d095944d 100644 --- a/ext/dbm/sdbm/README.too +++ b/ext/SDBM_File/sdbm/README.too diff --git a/ext/dbm/sdbm/biblio b/ext/SDBM_File/sdbm/biblio index 0be09fa005..0be09fa005 100644 --- a/ext/dbm/sdbm/biblio +++ b/ext/SDBM_File/sdbm/biblio diff --git a/ext/dbm/sdbm/dba.c b/ext/SDBM_File/sdbm/dba.c index 4f227e5245..4f227e5245 100644 --- a/ext/dbm/sdbm/dba.c +++ b/ext/SDBM_File/sdbm/dba.c diff --git a/ext/dbm/sdbm/dbd.c b/ext/SDBM_File/sdbm/dbd.c index 697a547597..697a547597 100644 --- a/ext/dbm/sdbm/dbd.c +++ b/ext/SDBM_File/sdbm/dbd.c diff --git a/ext/dbm/sdbm/dbe.1 b/ext/SDBM_File/sdbm/dbe.1 index 3b32272684..3b32272684 100644 --- a/ext/dbm/sdbm/dbe.1 +++ b/ext/SDBM_File/sdbm/dbe.1 diff --git a/ext/dbm/sdbm/dbe.c b/ext/SDBM_File/sdbm/dbe.c index 2a306f276e..2a306f276e 100644 --- a/ext/dbm/sdbm/dbe.c +++ b/ext/SDBM_File/sdbm/dbe.c diff --git a/ext/dbm/sdbm/dbm.c b/ext/SDBM_File/sdbm/dbm.c index 1388230e2d..1388230e2d 100644 --- a/ext/dbm/sdbm/dbm.c +++ b/ext/SDBM_File/sdbm/dbm.c diff --git a/ext/dbm/sdbm/dbm.h b/ext/SDBM_File/sdbm/dbm.h index 1196953d96..1196953d96 100644 --- a/ext/dbm/sdbm/dbm.h +++ b/ext/SDBM_File/sdbm/dbm.h diff --git a/ext/dbm/sdbm/dbu.c b/ext/SDBM_File/sdbm/dbu.c index 106262872e..106262872e 100644 --- a/ext/dbm/sdbm/dbu.c +++ b/ext/SDBM_File/sdbm/dbu.c diff --git a/ext/dbm/sdbm/grind b/ext/SDBM_File/sdbm/grind index 23728b7d49..23728b7d49 100755 --- a/ext/dbm/sdbm/grind +++ b/ext/SDBM_File/sdbm/grind diff --git a/ext/dbm/sdbm/hash.c b/ext/SDBM_File/sdbm/hash.c index eb585ac102..eb585ac102 100644 --- a/ext/dbm/sdbm/hash.c +++ b/ext/SDBM_File/sdbm/hash.c diff --git a/ext/dbm/sdbm/linux.patches b/ext/SDBM_File/sdbm/linux.patches index cb7b1b7d8e..cb7b1b7d8e 100644 --- a/ext/dbm/sdbm/linux.patches +++ b/ext/SDBM_File/sdbm/linux.patches diff --git a/ext/dbm/sdbm/makefile.sdbm b/ext/SDBM_File/sdbm/makefile.sdbm index c959c1fab5..c959c1fab5 100644 --- a/ext/dbm/sdbm/makefile.sdbm +++ b/ext/SDBM_File/sdbm/makefile.sdbm diff --git a/ext/dbm/sdbm/pair.c b/ext/SDBM_File/sdbm/pair.c index 575b34c6c1..a02c73f28f 100644 --- a/ext/dbm/sdbm/pair.c +++ b/ext/SDBM_File/sdbm/pair.c @@ -193,6 +193,8 @@ datum key; } #else #ifdef HAS_MEMMOVE + dst -= m; + src -= m; memmove(dst, src, m); #else while (m--) diff --git a/ext/dbm/sdbm/pair.h b/ext/SDBM_File/sdbm/pair.h index bd66d02fd2..bd66d02fd2 100644 --- a/ext/dbm/sdbm/pair.h +++ b/ext/SDBM_File/sdbm/pair.h diff --git a/ext/dbm/sdbm/readme.ms b/ext/SDBM_File/sdbm/readme.ms index 01ca17ccdf..01ca17ccdf 100644 --- a/ext/dbm/sdbm/readme.ms +++ b/ext/SDBM_File/sdbm/readme.ms diff --git a/ext/dbm/sdbm/readme.ps b/ext/SDBM_File/sdbm/readme.ps index 2b0c675595..2b0c675595 100644 --- a/ext/dbm/sdbm/readme.ps +++ b/ext/SDBM_File/sdbm/readme.ps diff --git a/ext/dbm/sdbm/sdbm.3 b/ext/SDBM_File/sdbm/sdbm.3 index f0f2d07c84..f0f2d07c84 100644 --- a/ext/dbm/sdbm/sdbm.3 +++ b/ext/SDBM_File/sdbm/sdbm.3 diff --git a/ext/dbm/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index d09adccdd3..d09adccdd3 100644 --- a/ext/dbm/sdbm/sdbm.c +++ b/ext/SDBM_File/sdbm/sdbm.c diff --git a/ext/dbm/sdbm/sdbm.h b/ext/SDBM_File/sdbm/sdbm.h index f94b054999..927e2c2e30 100644 --- a/ext/dbm/sdbm/sdbm.h +++ b/ext/SDBM_File/sdbm/sdbm.h @@ -123,12 +123,6 @@ extern long sdbm_hash proto((char *, int)); # define STANDARD_C 1 #endif -#if defined(STANDARD_C) -# define P(args) args -#else -# define P(args) () -#endif - #include <stdio.h> #include <ctype.h> #include <setjmp.h> @@ -150,10 +144,6 @@ extern long sdbm_hash proto((char *, int)); # endif #endif -#ifdef I_UNISTD -#include <unistd.h> -#endif - #include <sys/stat.h> #ifndef SEEK_SET @@ -167,25 +157,28 @@ extern long sdbm_hash proto((char *, int)); /* Use all the "standard" definitions? */ #ifdef STANDARD_C # include <stdlib.h> -# ifdef I_STRING -# include <string.h> -# endif -# define MEM_SIZE size_t -#else -# ifdef I_MEMORY -# include <memory.h> -# endif - typedef unsigned int MEM_SIZE; #endif /* STANDARD_C */ -#if defined(HAS_MEMCMP) && defined(mips) && defined(ultrix) +#define MEM_SIZE Size_t + +#ifdef I_STRING +#include <string.h> +#else +#include <strings.h> +#endif + +#ifdef I_MEMORY +#include <memory.h> +#endif + +#if defined(mips) && defined(ultrix) && !defined(__STDC__) # undef HAS_MEMCMP #endif #ifdef HAS_MEMCPY # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcpy - extern char * memcpy P((char*, char*, int)); + extern char * memcpy _((char*, char*, int)); # endif # endif #else @@ -201,7 +194,7 @@ extern long sdbm_hash proto((char *, int)); #ifdef HAS_MEMSET # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memset - extern char *memset P((char*, int, int)); + extern char *memset _((char*, int, int)); # endif # endif # define memzero(d,l) memset(d,0,l) @@ -218,7 +211,7 @@ extern long sdbm_hash proto((char *, int)); #ifdef HAS_MEMCMP # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcmp - extern int memcmp P((char*, char*, int)); + extern int memcmp _((char*, char*, int)); # endif # endif #else diff --git a/ext/dbm/sdbm/tune.h b/ext/SDBM_File/sdbm/tune.h index b95c8c8634..b95c8c8634 100644 --- a/ext/dbm/sdbm/tune.h +++ b/ext/SDBM_File/sdbm/tune.h diff --git a/ext/dbm/sdbm/util.c b/ext/SDBM_File/sdbm/util.c index 4b03d89f09..4b03d89f09 100644 --- a/ext/dbm/sdbm/util.c +++ b/ext/SDBM_File/sdbm/util.c diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap new file mode 100644 index 0000000000..a6b0e5faa8 --- /dev/null +++ b/ext/SDBM_File/typemap @@ -0,0 +1,25 @@ +# +#################################### DBM SECTION +# + +datum T_DATUM +gdatum T_GDATUM +NDBM_File T_PTROBJ +GDBM_File T_PTROBJ +SDBM_File T_PTROBJ +ODBM_File T_PTROBJ +DB_File T_PTROBJ +DBZ_File T_PTROBJ +FATALFUNC T_OPAQUEPTR + +INPUT +T_DATUM + $var.dptr = SvPV($arg, na); + $var.dsize = (int)na; +T_GDATUM + UNIMPLEMENTED +OUTPUT +T_DATUM + sv_setpvn($arg, $var.dptr, $var.dsize); +T_GDATUM + sv_usepvn($arg, $var.dptr, $var.dsize); diff --git a/ext/Socket/Makefile.SH b/ext/Socket/Makefile.SH new file mode 100644 index 0000000000..064228e512 --- /dev/null +++ b/ext/Socket/Makefile.SH @@ -0,0 +1,207 @@ +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +potential_libs=" " +. $TOP/ext/util/extliblist + +: This extension might need bootstrap support +if test -f ${ext}_BS; then + bootdep=${ext}_BS +else + bootdep='' +fi + +case "$dlsrc" in +dl_aix*) + echo "#!" > $ext.exp + echo "boot_$ext" >> $ext.exp + ;; +esac + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# $ext might have its own bootstrap support +BOOTDEP = $bootdep +BOOTSTRAP = $ext.bs + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so +DLEXT = $dlext + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs +INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(DLEXT) +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: dynamic +# Phony target to force checking subdirectories. +FORCE: + +config: + +# Target for Dynamic Loading: +dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) + +$(INSTALLDYNAMIC): $(EXT).o + @test -d $(AUTO) || mkdir $(AUTO) + @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) + ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) + +$(BOOTSTRAP): Makefile $(BOOTDEP) + $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) + touch $(BOOTSTRAP) + +$(INSTALLBOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(EXT).xs >tmp + mv tmp $@ + +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 644 Makefile +$eunicefix Makefile + diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm new file mode 100644 index 0000000000..a05c0a0a0c --- /dev/null +++ b/ext/Socket/Socket.pm @@ -0,0 +1,116 @@ +package Socket; +use Carp; + +require Exporter; +require AutoLoader; +require DynaLoader; +@ISA = (Exporter, AutoLoader, DynaLoader); +@EXPORT = qw( + AF_802 + AF_APPLETALK + AF_CCITT + AF_CHAOS + AF_DATAKIT + AF_DECnet + AF_DLI + AF_ECMA + AF_GOSIP + AF_HYLINK + AF_IMPLINK + AF_INET + AF_LAT + AF_MAX + AF_NBS + AF_NIT + AF_NS + AF_OSI + AF_OSINET + AF_PUP + AF_SNA + AF_UNIX + AF_UNSPEC + AF_X25 + MSG_DONTROUTE + MSG_MAXIOVLEN + MSG_OOB + MSG_PEEK + PF_802 + PF_APPLETALK + PF_CCITT + PF_CHAOS + PF_DATAKIT + PF_DECnet + PF_DLI + PF_ECMA + PF_GOSIP + PF_HYLINK + PF_IMPLINK + PF_INET + PF_LAT + PF_MAX + PF_NBS + PF_NIT + PF_NS + PF_OSI + PF_OSINET + PF_PUP + PF_SNA + PF_UNIX + PF_UNSPEC + PF_X25 + SOCK_DGRAM + SOCK_RAW + SOCK_RDM + SOCK_SEQPACKET + SOCK_STREAM + SOL_SOCKET + SOMAXCONN + SO_ACCEPTCONN + SO_BROADCAST + SO_DEBUG + SO_DONTLINGER + SO_DONTROUTE + SO_ERROR + SO_KEEPALIVE + SO_LINGER + SO_OOBINLINE + SO_RCVBUF + SO_RCVLOWAT + SO_RCVTIMEO + SO_REUSEADDR + SO_SNDBUF + SO_SNDLOWAT + SO_SNDTIMEO + SO_TYPE + SO_USELOOPBACK +); + +sub AUTOLOAD { + if (@_ > 1) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + local($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + croak "Your vendor has not defined Socket macro $constname, used"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Socket; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +1; +__END__ diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs new file mode 100644 index 0000000000..7a0bf465b2 --- /dev/null +++ b/ext/Socket/Socket.xs @@ -0,0 +1,565 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <sys/socket.h> + +#ifndef AF_NBS +#undef PF_NBS +#endif + +#ifndef AF_X25 +#undef PF_X25 +#endif + +static int +not_here(s) +char *s; +{ + croak("Socket::%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + switch (*name) { + case 'A': + if (strEQ(name, "AF_802")) +#ifdef AF_802 + return AF_802; +#else + goto not_there; +#endif + if (strEQ(name, "AF_APPLETALK")) +#ifdef AF_APPLETALK + return AF_APPLETALK; +#else + goto not_there; +#endif + if (strEQ(name, "AF_CCITT")) +#ifdef AF_CCITT + return AF_CCITT; +#else + goto not_there; +#endif + if (strEQ(name, "AF_CHAOS")) +#ifdef AF_CHAOS + return AF_CHAOS; +#else + goto not_there; +#endif + if (strEQ(name, "AF_DATAKIT")) +#ifdef AF_DATAKIT + return AF_DATAKIT; +#else + goto not_there; +#endif + if (strEQ(name, "AF_DECnet")) +#ifdef AF_DECnet + return AF_DECnet; +#else + goto not_there; +#endif + if (strEQ(name, "AF_DLI")) +#ifdef AF_DLI + return AF_DLI; +#else + goto not_there; +#endif + if (strEQ(name, "AF_ECMA")) +#ifdef AF_ECMA + return AF_ECMA; +#else + goto not_there; +#endif + if (strEQ(name, "AF_GOSIP")) +#ifdef AF_GOSIP + return AF_GOSIP; +#else + goto not_there; +#endif + if (strEQ(name, "AF_HYLINK")) +#ifdef AF_HYLINK + return AF_HYLINK; +#else + goto not_there; +#endif + if (strEQ(name, "AF_IMPLINK")) +#ifdef AF_IMPLINK + return AF_IMPLINK; +#else + goto not_there; +#endif + if (strEQ(name, "AF_INET")) +#ifdef AF_INET + return AF_INET; +#else + goto not_there; +#endif + if (strEQ(name, "AF_LAT")) +#ifdef AF_LAT + return AF_LAT; +#else + goto not_there; +#endif + if (strEQ(name, "AF_MAX")) +#ifdef AF_MAX + return AF_MAX; +#else + goto not_there; +#endif + if (strEQ(name, "AF_NBS")) +#ifdef AF_NBS + return AF_NBS; +#else + goto not_there; +#endif + if (strEQ(name, "AF_NIT")) +#ifdef AF_NIT + return AF_NIT; +#else + goto not_there; +#endif + if (strEQ(name, "AF_NS")) +#ifdef AF_NS + return AF_NS; +#else + goto not_there; +#endif + if (strEQ(name, "AF_OSI")) +#ifdef AF_OSI + return AF_OSI; +#else + goto not_there; +#endif + if (strEQ(name, "AF_OSINET")) +#ifdef AF_OSINET + return AF_OSINET; +#else + goto not_there; +#endif + if (strEQ(name, "AF_PUP")) +#ifdef AF_PUP + return AF_PUP; +#else + goto not_there; +#endif + if (strEQ(name, "AF_SNA")) +#ifdef AF_SNA + return AF_SNA; +#else + goto not_there; +#endif + if (strEQ(name, "AF_UNIX")) +#ifdef AF_UNIX + return AF_UNIX; +#else + goto not_there; +#endif + if (strEQ(name, "AF_UNSPEC")) +#ifdef AF_UNSPEC + return AF_UNSPEC; +#else + goto not_there; +#endif + if (strEQ(name, "AF_X25")) +#ifdef AF_X25 + return AF_X25; +#else + goto not_there; +#endif + break; + case 'B': + break; + case 'C': + break; + case 'D': + break; + case 'E': + break; + case 'F': + break; + case 'G': + break; + case 'H': + break; + case 'I': + break; + case 'J': + break; + case 'K': + break; + case 'L': + break; + case 'M': + if (strEQ(name, "MSG_DONTROUTE")) +#ifdef MSG_DONTROUTE + return MSG_DONTROUTE; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_MAXIOVLEN")) +#ifdef MSG_MAXIOVLEN + return MSG_MAXIOVLEN; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_OOB")) +#ifdef MSG_OOB + return MSG_OOB; +#else + goto not_there; +#endif + if (strEQ(name, "MSG_PEEK")) +#ifdef MSG_PEEK + return MSG_PEEK; +#else + goto not_there; +#endif + break; + case 'N': + break; + case 'O': + break; + case 'P': + if (strEQ(name, "PF_802")) +#ifdef PF_802 + return PF_802; +#else + goto not_there; +#endif + if (strEQ(name, "PF_APPLETALK")) +#ifdef PF_APPLETALK + return PF_APPLETALK; +#else + goto not_there; +#endif + if (strEQ(name, "PF_CCITT")) +#ifdef PF_CCITT + return PF_CCITT; +#else + goto not_there; +#endif + if (strEQ(name, "PF_CHAOS")) +#ifdef PF_CHAOS + return PF_CHAOS; +#else + goto not_there; +#endif + if (strEQ(name, "PF_DATAKIT")) +#ifdef PF_DATAKIT + return PF_DATAKIT; +#else + goto not_there; +#endif + if (strEQ(name, "PF_DECnet")) +#ifdef PF_DECnet + return PF_DECnet; +#else + goto not_there; +#endif + if (strEQ(name, "PF_DLI")) +#ifdef PF_DLI + return PF_DLI; +#else + goto not_there; +#endif + if (strEQ(name, "PF_ECMA")) +#ifdef PF_ECMA + return PF_ECMA; +#else + goto not_there; +#endif + if (strEQ(name, "PF_GOSIP")) +#ifdef PF_GOSIP + return PF_GOSIP; +#else + goto not_there; +#endif + if (strEQ(name, "PF_HYLINK")) +#ifdef PF_HYLINK + return PF_HYLINK; +#else + goto not_there; +#endif + if (strEQ(name, "PF_IMPLINK")) +#ifdef PF_IMPLINK + return PF_IMPLINK; +#else + goto not_there; +#endif + if (strEQ(name, "PF_INET")) +#ifdef PF_INET + return PF_INET; +#else + goto not_there; +#endif + if (strEQ(name, "PF_LAT")) +#ifdef PF_LAT + return PF_LAT; +#else + goto not_there; +#endif + if (strEQ(name, "PF_MAX")) +#ifdef PF_MAX + return PF_MAX; +#else + goto not_there; +#endif + if (strEQ(name, "PF_NBS")) +#ifdef PF_NBS + return PF_NBS; +#else + goto not_there; +#endif + if (strEQ(name, "PF_NIT")) +#ifdef PF_NIT + return PF_NIT; +#else + goto not_there; +#endif + if (strEQ(name, "PF_NS")) +#ifdef PF_NS + return PF_NS; +#else + goto not_there; +#endif + if (strEQ(name, "PF_OSI")) +#ifdef PF_OSI + return PF_OSI; +#else + goto not_there; +#endif + if (strEQ(name, "PF_OSINET")) +#ifdef PF_OSINET + return PF_OSINET; +#else + goto not_there; +#endif + if (strEQ(name, "PF_PUP")) +#ifdef PF_PUP + return PF_PUP; +#else + goto not_there; +#endif + if (strEQ(name, "PF_SNA")) +#ifdef PF_SNA + return PF_SNA; +#else + goto not_there; +#endif + if (strEQ(name, "PF_UNIX")) +#ifdef PF_UNIX + return PF_UNIX; +#else + goto not_there; +#endif + if (strEQ(name, "PF_UNSPEC")) +#ifdef PF_UNSPEC + return PF_UNSPEC; +#else + goto not_there; +#endif + if (strEQ(name, "PF_X25")) +#ifdef PF_X25 + return PF_X25; +#else + goto not_there; +#endif + break; + case 'Q': + break; + case 'R': + break; + case 'S': + if (strEQ(name, "SOCK_DGRAM")) +#ifdef SOCK_DGRAM + return SOCK_DGRAM; +#else + goto not_there; +#endif + if (strEQ(name, "SOCK_RAW")) +#ifdef SOCK_RAW + return SOCK_RAW; +#else + goto not_there; +#endif + if (strEQ(name, "SOCK_RDM")) +#ifdef SOCK_RDM + return SOCK_RDM; +#else + goto not_there; +#endif + if (strEQ(name, "SOCK_SEQPACKET")) +#ifdef SOCK_SEQPACKET + return SOCK_SEQPACKET; +#else + goto not_there; +#endif + if (strEQ(name, "SOCK_STREAM")) +#ifdef SOCK_STREAM + return SOCK_STREAM; +#else + goto not_there; +#endif + if (strEQ(name, "SOL_SOCKET")) +#ifdef SOL_SOCKET + return SOL_SOCKET; +#else + goto not_there; +#endif + if (strEQ(name, "SOMAXCONN")) +#ifdef SOMAXCONN + return SOMAXCONN; +#else + goto not_there; +#endif + if (strEQ(name, "SO_ACCEPTCONN")) +#ifdef SO_ACCEPTCONN + return SO_ACCEPTCONN; +#else + goto not_there; +#endif + if (strEQ(name, "SO_BROADCAST")) +#ifdef SO_BROADCAST + return SO_BROADCAST; +#else + goto not_there; +#endif + if (strEQ(name, "SO_DEBUG")) +#ifdef SO_DEBUG + return SO_DEBUG; +#else + goto not_there; +#endif + if (strEQ(name, "SO_DONTLINGER")) +#ifdef SO_DONTLINGER + return SO_DONTLINGER; +#else + goto not_there; +#endif + if (strEQ(name, "SO_DONTROUTE")) +#ifdef SO_DONTROUTE + return SO_DONTROUTE; +#else + goto not_there; +#endif + if (strEQ(name, "SO_ERROR")) +#ifdef SO_ERROR + return SO_ERROR; +#else + goto not_there; +#endif + if (strEQ(name, "SO_KEEPALIVE")) +#ifdef SO_KEEPALIVE + return SO_KEEPALIVE; +#else + goto not_there; +#endif + if (strEQ(name, "SO_LINGER")) +#ifdef SO_LINGER + return SO_LINGER; +#else + goto not_there; +#endif + if (strEQ(name, "SO_OOBINLINE")) +#ifdef SO_OOBINLINE + return SO_OOBINLINE; +#else + goto not_there; +#endif + if (strEQ(name, "SO_RCVBUF")) +#ifdef SO_RCVBUF + return SO_RCVBUF; +#else + goto not_there; +#endif + if (strEQ(name, "SO_RCVLOWAT")) +#ifdef SO_RCVLOWAT + return SO_RCVLOWAT; +#else + goto not_there; +#endif + if (strEQ(name, "SO_RCVTIMEO")) +#ifdef SO_RCVTIMEO + return SO_RCVTIMEO; +#else + goto not_there; +#endif + if (strEQ(name, "SO_REUSEADDR")) +#ifdef SO_REUSEADDR + return SO_REUSEADDR; +#else + goto not_there; +#endif + if (strEQ(name, "SO_REUSEPORT")) +#ifdef SO_REUSEPORT + return SO_REUSEPORT; +#else + goto not_there; +#endif + if (strEQ(name, "SO_SNDBUF")) +#ifdef SO_SNDBUF + return SO_SNDBUF; +#else + goto not_there; +#endif + if (strEQ(name, "SO_SNDLOWAT")) +#ifdef SO_SNDLOWAT + return SO_SNDLOWAT; +#else + goto not_there; +#endif + if (strEQ(name, "SO_SNDTIMEO")) +#ifdef SO_SNDTIMEO + return SO_SNDTIMEO; +#else + goto not_there; +#endif + if (strEQ(name, "SO_TYPE")) +#ifdef SO_TYPE + return SO_TYPE; +#else + goto not_there; +#endif + if (strEQ(name, "SO_USELOOPBACK")) +#ifdef SO_USELOOPBACK + return SO_USELOOPBACK; +#else + goto not_there; +#endif + break; + case 'T': + break; + case 'U': + break; + case 'V': + break; + case 'W': + break; + case 'X': + break; + case 'Y': + break; + case 'Z': + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +MODULE = Socket PACKAGE = Socket + +double +constant(name,arg) + char * name + int arg + diff --git a/ext/curses/Makefile b/ext/curses/Makefile deleted file mode 100644 index 107702f303..0000000000 --- a/ext/curses/Makefile +++ /dev/null @@ -1,16 +0,0 @@ -SRC = .. -GLOBINCS = -LOCINCS = -LIBS = -lcurses -ltermlib `. $(SRC)/config.sh; echo $$libs` - -curseperl: $(SRC)/uperl.o usersub.o curses.o - cc $(SRC)/uperl.o usersub.o curses.o $(LIBS) -o curseperl - -usersub.o: usersub.c - cc -c -I$(SRC) $(GLOBINCS) -DDEBUGGING -g usersub.c - -curses.o: curses.c - cc -c -I$(SRC) $(GLOBINCS) -DDEBUGGING -g curses.c - -curses.c: curses.mus - mus curses.mus >curses.c diff --git a/ext/curses/bsdcurses.mus b/ext/curses/bsdcurses.mus deleted file mode 100644 index 7129418ab6..0000000000 --- a/ext/curses/bsdcurses.mus +++ /dev/null @@ -1,698 +0,0 @@ -/* $RCSfile: bsdcurses.mus,v $$Revision: 4.1 $$Date: 92/08/07 18:28:50 $ - * - * $Log: bsdcurses.mus,v $ - * Revision 4.1 92/08/07 18:28:50 lwall - * - * Revision 4.0.1.2 92/06/08 16:05:28 lwall - * patch20: &getcap eventually dumped core in bsdcurses - * - * Revision 4.0.1.1 91/11/05 19:04:53 lwall - * initial checkin - * - * Revision 4.0 91/03/20 01:56:13 lwall - * 4.0 baseline. - * - * Revision 3.0.1.1 90/08/09 04:05:21 lwall - * patch19: Initial revision - * - */ - -#include "EXTERN.h" -#include "perl.h" - -char *savestr(); - -#include <curses.h> - -static enum uservars { - UV_curscr, - UV_stdscr, - UV_Def_term, - UV_My_term, - UV_ttytype, - UV_LINES, - UV_COLS, - UV_ERR, - UV_OK, -}; - -static enum usersubs { - US_addch, - US_waddch, - US_addstr, - US_waddstr, - US_box, - US_clear, - US_wclear, - US_clearok, - US_clrtobot, - US_wclrtobot, - US_clrtoeol, - US_wclrtoeol, - US_delch, - US_wdelch, - US_deleteln, - US_wdeleteln, - US_erase, - US_werase, - US_flushok, - US_idlok, - US_insch, - US_winsch, - US_insertln, - US_winsertln, - US_move, - US_wmove, - US_overlay, - US_overwrite, - US_printw, - US_wprintw, - US_refresh, - US_wrefresh, - US_standout, - US_wstandout, - US_standend, - US_wstandend, - US_cbreak, - US_nocbreak, - US_echo, - US_noecho, - US_getch, - US_wgetch, - US_getstr, - US_wgetstr, - US_raw, - US_noraw, - US_scanw, - US_wscanw, - US_baudrate, - US_delwin, - US_endwin, - US_erasechar, - US_getcap, - US_getyx, - US_inch, - US_winch, - US_initscr, - US_killchar, - US_leaveok, - US_longname, - US_fullname, - US_mvwin, - US_newwin, - US_nl, - US_nonl, - US_scrollok, - US_subwin, - US_touchline, - US_touchoverlap, - US_touchwin, - US_unctrl, - US_gettmode, - US_mvcur, - US_scroll, - US_savetty, - US_resetty, - US_setterm, - US_tstp, - US__putchar, - US_testcallback, -}; - -static int usersub(); -static int userset(); -static int userval(); - -int -init_curses() -{ - struct ufuncs uf; - char *filename = "curses.c"; - - uf.uf_set = userset; - uf.uf_val = userval; - -#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf) - - MAGICVAR("curscr", UV_curscr); - MAGICVAR("stdscr", UV_stdscr); - MAGICVAR("Def_term",UV_Def_term); - MAGICVAR("My_term", UV_My_term); - MAGICVAR("ttytype", UV_ttytype); - MAGICVAR("LINES", UV_LINES); - MAGICVAR("COLS", UV_COLS); - MAGICVAR("ERR", UV_ERR); - MAGICVAR("OK", UV_OK); - - make_usub("addch", US_addch, usersub, filename); - make_usub("waddch", US_waddch, usersub, filename); - make_usub("addstr", US_addstr, usersub, filename); - make_usub("waddstr", US_waddstr, usersub, filename); - make_usub("box", US_box, usersub, filename); - make_usub("clear", US_clear, usersub, filename); - make_usub("wclear", US_wclear, usersub, filename); - make_usub("clearok", US_clearok, usersub, filename); - make_usub("clrtobot", US_clrtobot, usersub, filename); - make_usub("wclrtobot", US_wclrtobot, usersub, filename); - make_usub("clrtoeol", US_clrtoeol, usersub, filename); - make_usub("wclrtoeol", US_wclrtoeol, usersub, filename); - make_usub("delch", US_delch, usersub, filename); - make_usub("wdelch", US_wdelch, usersub, filename); - make_usub("deleteln", US_deleteln, usersub, filename); - make_usub("wdeleteln", US_wdeleteln, usersub, filename); - make_usub("erase", US_erase, usersub, filename); - make_usub("werase", US_werase, usersub, filename); - make_usub("flushok", US_flushok, usersub, filename); - make_usub("idlok", US_idlok, usersub, filename); - make_usub("insch", US_insch, usersub, filename); - make_usub("winsch", US_winsch, usersub, filename); - make_usub("insertln", US_insertln, usersub, filename); - make_usub("winsertln", US_winsertln, usersub, filename); - make_usub("move", US_move, usersub, filename); - make_usub("wmove", US_wmove, usersub, filename); - make_usub("overlay", US_overlay, usersub, filename); - make_usub("overwrite", US_overwrite, usersub, filename); - make_usub("printw", US_printw, usersub, filename); - make_usub("wprintw", US_wprintw, usersub, filename); - make_usub("refresh", US_refresh, usersub, filename); - make_usub("wrefresh", US_wrefresh, usersub, filename); - make_usub("standout", US_standout, usersub, filename); - make_usub("wstandout", US_wstandout, usersub, filename); - make_usub("standend", US_standend, usersub, filename); - make_usub("wstandend", US_wstandend, usersub, filename); - make_usub("cbreak", US_cbreak, usersub, filename); - make_usub("nocbreak", US_nocbreak, usersub, filename); - make_usub("echo", US_echo, usersub, filename); - make_usub("noecho", US_noecho, usersub, filename); - make_usub("getch", US_getch, usersub, filename); - make_usub("wgetch", US_wgetch, usersub, filename); - make_usub("getstr", US_getstr, usersub, filename); - make_usub("wgetstr", US_wgetstr, usersub, filename); - make_usub("raw", US_raw, usersub, filename); - make_usub("noraw", US_noraw, usersub, filename); - make_usub("scanw", US_scanw, usersub, filename); - make_usub("wscanw", US_wscanw, usersub, filename); - make_usub("baudrate", US_baudrate, usersub, filename); - make_usub("delwin", US_delwin, usersub, filename); - make_usub("endwin", US_endwin, usersub, filename); - make_usub("erasechar", US_erasechar, usersub, filename); - make_usub("getcap", US_getcap, usersub, filename); - make_usub("getyx", US_getyx, usersub, filename); - make_usub("inch", US_inch, usersub, filename); - make_usub("winch", US_winch, usersub, filename); - make_usub("initscr", US_initscr, usersub, filename); - make_usub("killchar", US_killchar, usersub, filename); - make_usub("leaveok", US_leaveok, usersub, filename); - make_usub("longname", US_longname, usersub, filename); - make_usub("fullname", US_fullname, usersub, filename); - make_usub("mvwin", US_mvwin, usersub, filename); - make_usub("newwin", US_newwin, usersub, filename); - make_usub("nl", US_nl, usersub, filename); - make_usub("nonl", US_nonl, usersub, filename); - make_usub("scrollok", US_scrollok, usersub, filename); - make_usub("subwin", US_subwin, usersub, filename); - make_usub("touchline", US_touchline, usersub, filename); - make_usub("touchoverlap", US_touchoverlap,usersub, filename); - make_usub("touchwin", US_touchwin, usersub, filename); - make_usub("unctrl", US_unctrl, usersub, filename); - make_usub("gettmode", US_gettmode, usersub, filename); - make_usub("mvcur", US_mvcur, usersub, filename); - make_usub("scroll", US_scroll, usersub, filename); - make_usub("savetty", US_savetty, usersub, filename); - make_usub("resetty", US_resetty, usersub, filename); - make_usub("setterm", US_setterm, usersub, filename); - make_usub("tstp", US_tstp, usersub, filename); - make_usub("_putchar", US__putchar, usersub, filename); - make_usub("testcallback", US_testcallback,usersub, filename); -}; - -static int -usersub(ix, sp, items) -int ix; -register int sp; -register int items; -{ - STR **st = stack->ary_array + sp; - register int i; - register char *tmps; - register STR *Str; /* used in str_get and str_gnum macros */ - - switch (ix) { -CASE int addch -I char ch -END - -CASE int waddch -I WINDOW* win -I char ch -END - -CASE int addstr -I char* str -END - -CASE int waddstr -I WINDOW* win -I char* str -END - -CASE int box -I WINDOW* win -I char vert -I char hor -END - -CASE int clear -END - -CASE int wclear -I WINDOW* win -END - -CASE int clearok -I WINDOW* win -I bool boolf -END - -CASE int clrtobot -END - -CASE int wclrtobot -I WINDOW* win -END - -CASE int clrtoeol -END - -CASE int wclrtoeol -I WINDOW* win -END - -CASE int delch -END - -CASE int wdelch -I WINDOW* win -END - -CASE int deleteln -END - -CASE int wdeleteln -I WINDOW* win -END - -CASE int erase -END - -CASE int werase -I WINDOW* win -END - -CASE int flushok -I WINDOW* win -I bool boolf -END - -CASE int idlok -I WINDOW* win -I bool boolf -END - -CASE int insch -I char c -END - -CASE int winsch -I WINDOW* win -I char c -END - -CASE int insertln -END - -CASE int winsertln -I WINDOW* win -END - -CASE int move -I int y -I int x -END - -CASE int wmove -I WINDOW* win -I int y -I int x -END - -CASE int overlay -I WINDOW* win1 -I WINDOW* win2 -END - -CASE int overwrite -I WINDOW* win1 -I WINDOW* win2 -END - - case US_printw: - if (items < 1) - fatal("Usage: &printw($fmt, $arg1, $arg2, ... )"); - else { - int retval; - STR* str = str_new(0); - - do_sprintf(str, items, st + 1); - retval = addstr(str->str_ptr); - str_numset(st[0], (double) retval); - str_free(str); - } - return sp; - - case US_wprintw: - if (items < 2) - fatal("Usage: &wprintw($win, $fmt, $arg1, $arg2, ... )"); - else { - int retval; - STR* str = str_new(0); - WINDOW* win = *(WINDOW**) str_get(st[1]); - - do_sprintf(str, items - 1, st + 1); - retval = waddstr(win, str->str_ptr); - str_numset(st[0], (double) retval); - str_free(str); - } - return sp; - -CASE int refresh -END - -CASE int wrefresh -I WINDOW* win -END - -CASE int standout -END - -CASE int wstandout -I WINDOW* win -END - -CASE int standend -END - -CASE int wstandend -I WINDOW* win -END - -CASE int cbreak -END - -CASE int nocbreak -END - -CASE int echo -END - -CASE int noecho -END - - case US_getch: - if (items != 0) - fatal("Usage: &getch()"); - else { - int retval; - char retch; - - retval = getch(); - if (retval == EOF) - st[0] = &str_undef; - else { - retch = retval; - str_nset(st[0], &retch, 1); - } - } - return sp; - - case US_wgetch: - if (items != 1) - fatal("Usage: &wgetch($win)"); - else { - int retval; - char retch; - WINDOW* win = *(WINDOW**) str_get(st[1]); - - retval = wgetch(win); - if (retval == EOF) - st[0] = &str_undef; - else { - retch = retval; - str_nset(st[0], &retch, 1); - } - } - return sp; - -CASE int getstr -IO char* str -END - -CASE int wgetstr -I WINDOW* win -IO char* str -END - -CASE int raw -END - -CASE int noraw -END - -CASE int baudrate -END - -CASE int delwin -I WINDOW* win -END - -CASE int endwin -END - -CASE int erasechar -END - - case US_getcap: - if (items != 1) - fatal("Usage: &getcap($str)"); - else { - char* retval; - char* str = (char*) str_get(st[1]); - char output[50], *outputp = output; - - retval = tgetstr(str, &outputp); - str_set(st[0], (char*) retval); - } - return sp; - - case US_getyx: - if (items != 3) - fatal("Usage: &getyx($win, $y, $x)"); - else { - int retval; - STR* str = str_new(0); - WINDOW* win = *(WINDOW**) str_get(st[1]); - int y; - int x; - - do_sprintf(str, items - 1, st + 1); - retval = getyx(win, y, x); - str_numset(st[2], (double)y); - str_numset(st[3], (double)x); - str_numset(st[0], (double) retval); - str_free(str); - } - return sp; - - -CASE int inch -END - -CASE int winch -I WINDOW* win -END - -CASE WINDOW* initscr -END - -CASE int killchar -END - -CASE int leaveok -I WINDOW* win -I bool boolf -END - -CASE char* longname -I char* termbuf -IO char* name -END - -CASE int fullname -I char* termbuf -IO char* name -END - -CASE int mvwin -I WINDOW* win -I int y -I int x -END - -CASE WINDOW* newwin -I int lines -I int cols -I int begin_y -I int begin_x -END - -CASE int nl -END - -CASE int nonl -END - -CASE int scrollok -I WINDOW* win -I bool boolf -END - -CASE WINDOW* subwin -I WINDOW* win -I int lines -I int cols -I int begin_y -I int begin_x -END - -CASE int touchline -I WINDOW* win -I int y -I int startx -I int endx -END - -CASE int touchoverlap -I WINDOW* win1 -I WINDOW* win2 -END - -CASE int touchwin -I WINDOW* win -END - -CASE char* unctrl -I char ch -END - -CASE int gettmode -END - -CASE int mvcur -I int lasty -I int lastx -I int newy -I int newx -END - -CASE int scroll -I WINDOW* win -END - -CASE int savetty -END - -CASE void resetty -END - -CASE int setterm -I char* name -END - -CASE int tstp -END - -CASE int _putchar -I char ch -END - - case US_testcallback: - sp = callback("callback", sp + items, curcsv->wantarray, 1, items); - break; - - default: - fatal("Unimplemented user-defined subroutine"); - } - return sp; -} - -static int -userval(ix, str) -int ix; -STR *str; -{ - switch (ix) { - case UV_COLS: - str_numset(str, (double)COLS); - break; - case UV_Def_term: - str_set(str, Def_term); - break; - case UV_ERR: - str_numset(str, (double)ERR); - break; - case UV_LINES: - str_numset(str, (double)LINES); - break; - case UV_My_term: - str_numset(str, (double)My_term); - break; - case UV_OK: - str_numset(str, (double)OK); - break; - case UV_curscr: - str_nset(str, &curscr, sizeof(WINDOW*)); - break; - case UV_stdscr: - str_nset(str, &stdscr, sizeof(WINDOW*)); - break; - case UV_ttytype: - str_set(str, ttytype); - break; - } - return 0; -} - -static int -userset(ix, str) -int ix; -STR *str; -{ - switch (ix) { - case UV_COLS: - COLS = (int)str_gnum(str); - break; - case UV_Def_term: - Def_term = savestr(str_get(str)); /* never freed */ - break; - case UV_LINES: - LINES = (int)str_gnum(str); - break; - case UV_My_term: - My_term = (bool)str_gnum(str); - break; - case UV_ttytype: - strcpy(ttytype, str_get(str)); /* hope it fits */ - break; - } - return 0; -} diff --git a/ext/curses/curses.mus b/ext/curses/curses.mus deleted file mode 100644 index 35510f4da7..0000000000 --- a/ext/curses/curses.mus +++ /dev/null @@ -1,889 +0,0 @@ -/* $RCSfile: curses.mus,v $$Revision: 4.1 $$Date: 92/08/07 18:28:53 $ - * - * $Log: curses.mus,v $ - * Revision 4.1 92/08/07 18:28:53 lwall - * - * Revision 4.0.1.2 92/06/08 16:06:12 lwall - * patch20: function key support added to curses.mus - * - * Revision 4.0.1.1 91/11/05 19:06:19 lwall - * patch11: usub/curses.mus now supports SysV curses - * - * Revision 4.0 91/03/20 01:56:13 lwall - * 4.0 baseline. - * - * Revision 3.0.1.1 90/08/09 04:05:21 lwall - * patch19: Initial revision - * - */ - -#include "EXTERN.h" -#include "perl.h" - -char *savestr(); - -#undef bool -#include <curses.h> - -#ifndef A_UNDERLINE -#define NOSETATTR -#define A_STANDOUT 0x0200 -#define A_UNDERLINE 0x0100 -#define A_REVERSE 0x0200 -#define A_BLINK 0x0400 -#define A_BOLD 0x0800 -#define A_ALTCHARSET 0x1000 -#define A_NORMAL 0 -#endif - -#ifdef USG -static char *tcbuf = NULL; -#endif - -#ifdef NOSETATTR -static unsigned curattr = NORMAL; -#endif - -static enum uservars { - UV_curscr, - UV_stdscr, - UV_ttytype, - UV_LINES, - UV_COLS, - UV_ERR, - UV_OK, -#ifdef BSD - UV_Def_term, - UV_My_term, -#endif - UV_A_STANDOUT, - UV_A_UNDERLINE, - UV_A_REVERSE, - UV_A_BLINK, - UV_A_DIM, - UV_A_BOLD, - UV_A_NORMAL, -}; - -static enum usersubs { - US_addch, - US_waddch, - US_addstr, - US_waddstr, - US_box, - US_clear, - US_wclear, - US_clearok, - US_clrtobot, - US_wclrtobot, - US_clrtoeol, - US_wclrtoeol, - US_delch, - US_wdelch, - US_deleteln, - US_wdeleteln, - US_erase, - US_werase, - US_idlok, - US_insch, - US_winsch, - US_insertln, - US_winsertln, - US_move, - US_wmove, - US_overlay, - US_overwrite, - US_refresh, - US_wrefresh, - US_standout, - US_wstandout, - US_standend, - US_wstandend, - US_cbreak, - US_nocbreak, - US_echo, - US_noecho, - US_getch, - US_wgetch, - US_getstr, - US_wgetstr, - US_raw, - US_noraw, - US_baudrate, - US_delwin, - US_endwin, - US_erasechar, - US_getyx, - US_inch, - US_winch, - US_initscr, - US_killchar, - US_leaveok, - US_longname, - US_mvwin, - US_newwin, - US_nl, - US_nonl, - US_scrollok, - US_subwin, - US_touchline, - US_touchwin, - US_unctrl, - US_gettmode, - US_mvcur, - US_scroll, - US_savetty, - US_resetty, - US_setterm, - US_attroff, - US_wattroff, - US_attron, - US_wattron, - US_attrset, - US_wattrset, -#ifdef CURSEFMT - US_printw, /* remove */ - US_wprintw, /* remove */ - US_scanw, /* delete */ - US_wscanw, /* delete */ -#endif - US_getcap, -#ifdef BSD - US_flushok, - US_fullname, - US_touchoverlap, - US_tstp, - US__putchar, -#endif - US_mysub, - US_testcallback, -}; - -static int usersub(); -static int userset(); -static int userval(); - -int -init_curses() -{ - struct ufuncs uf; - char *filename = "curses.c"; - - uf.uf_set = userset; - uf.uf_val = userval; - -#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf) - - MAGICVAR("curscr", UV_curscr); - MAGICVAR("stdscr", UV_stdscr); - MAGICVAR("ttytype", UV_ttytype); - MAGICVAR("LINES", UV_LINES); - MAGICVAR("COLS", UV_COLS); - MAGICVAR("ERR", UV_ERR); - MAGICVAR("OK", UV_OK); -#ifdef BSD - MAGICVAR("Def_term",UV_Def_term); - MAGICVAR("My_term", UV_My_term); -#endif - MAGICVAR("A_STANDOUT", UV_A_STANDOUT); - MAGICVAR("A_UNDERLINE", UV_A_UNDERLINE); - MAGICVAR("A_REVERSE", UV_A_REVERSE); - MAGICVAR("A_BLINK", UV_A_BLINK); - MAGICVAR("A_DIM", UV_A_DIM); - MAGICVAR("A_BOLD", UV_A_BOLD); - MAGICVAR("A_NORMAL", UV_A_NORMAL); - - make_usub("addch", US_addch, usersub, filename); - make_usub("waddch", US_waddch, usersub, filename); - make_usub("addstr", US_addstr, usersub, filename); - make_usub("waddstr", US_waddstr, usersub, filename); - make_usub("box", US_box, usersub, filename); - make_usub("clear", US_clear, usersub, filename); - make_usub("wclear", US_wclear, usersub, filename); - make_usub("clearok", US_clearok, usersub, filename); - make_usub("clrtobot", US_clrtobot, usersub, filename); - make_usub("wclrtobot", US_wclrtobot, usersub, filename); - make_usub("clrtoeol", US_clrtoeol, usersub, filename); - make_usub("wclrtoeol", US_wclrtoeol, usersub, filename); - make_usub("delch", US_delch, usersub, filename); - make_usub("wdelch", US_wdelch, usersub, filename); - make_usub("deleteln", US_deleteln, usersub, filename); - make_usub("wdeleteln", US_wdeleteln, usersub, filename); - make_usub("erase", US_erase, usersub, filename); - make_usub("werase", US_werase, usersub, filename); - make_usub("idlok", US_idlok, usersub, filename); - make_usub("insch", US_insch, usersub, filename); - make_usub("winsch", US_winsch, usersub, filename); - make_usub("insertln", US_insertln, usersub, filename); - make_usub("winsertln", US_winsertln, usersub, filename); - make_usub("move", US_move, usersub, filename); - make_usub("wmove", US_wmove, usersub, filename); - make_usub("overlay", US_overlay, usersub, filename); - make_usub("overwrite", US_overwrite, usersub, filename); - make_usub("refresh", US_refresh, usersub, filename); - make_usub("wrefresh", US_wrefresh, usersub, filename); - make_usub("standout", US_standout, usersub, filename); - make_usub("wstandout", US_wstandout, usersub, filename); - make_usub("standend", US_standend, usersub, filename); - make_usub("wstandend", US_wstandend, usersub, filename); - make_usub("cbreak", US_cbreak, usersub, filename); - make_usub("nocbreak", US_nocbreak, usersub, filename); - make_usub("echo", US_echo, usersub, filename); - make_usub("noecho", US_noecho, usersub, filename); - make_usub("getch", US_getch, usersub, filename); - make_usub("wgetch", US_wgetch, usersub, filename); - make_usub("getstr", US_getstr, usersub, filename); - make_usub("wgetstr", US_wgetstr, usersub, filename); - make_usub("raw", US_raw, usersub, filename); - make_usub("noraw", US_noraw, usersub, filename); - make_usub("baudrate", US_baudrate, usersub, filename); - make_usub("delwin", US_delwin, usersub, filename); - make_usub("endwin", US_endwin, usersub, filename); - make_usub("erasechar", US_erasechar, usersub, filename); - make_usub("getyx", US_getyx, usersub, filename); - make_usub("inch", US_inch, usersub, filename); - make_usub("winch", US_winch, usersub, filename); - make_usub("initscr", US_initscr, usersub, filename); - make_usub("killchar", US_killchar, usersub, filename); - make_usub("leaveok", US_leaveok, usersub, filename); - make_usub("longname", US_longname, usersub, filename); - make_usub("mvwin", US_mvwin, usersub, filename); - make_usub("newwin", US_newwin, usersub, filename); - make_usub("nl", US_nl, usersub, filename); - make_usub("nonl", US_nonl, usersub, filename); - make_usub("scrollok", US_scrollok, usersub, filename); - make_usub("subwin", US_subwin, usersub, filename); - make_usub("touchline", US_touchline, usersub, filename); - make_usub("touchwin", US_touchwin, usersub, filename); - make_usub("unctrl", US_unctrl, usersub, filename); - make_usub("gettmode", US_gettmode, usersub, filename); - make_usub("mvcur", US_mvcur, usersub, filename); - make_usub("scroll", US_scroll, usersub, filename); - make_usub("savetty", US_savetty, usersub, filename); - make_usub("resetty", US_resetty, usersub, filename); - make_usub("setterm", US_setterm, usersub, filename); - make_usub("getcap", US_getcap, usersub, filename); - make_usub("attroff", US_attroff, usersub, filename); - make_usub("wattroff", US_wattroff, usersub, filename); - make_usub("attron", US_attron, usersub, filename); - make_usub("wattron", US_wattron, usersub, filename); - make_usub("attrset", US_attrset, usersub, filename); - make_usub("wattrset", US_wattrset, usersub, filename); -#ifdef CURSEFMT - make_usub("printw", US_printw, usersub, filename); - make_usub("wprintw", US_wprintw, usersub, filename); - make_usub("scanw", US_scanw, usersub, filename); - make_usub("wscanw", US_wscanw, usersub, filename); -#endif -#ifdef BSD - make_usub("flushok", US_flushok, usersub, filename); - make_usub("fullname", US_fullname, usersub, filename); - make_usub("touchoverlap", US_touchoverlap,usersub, filename); - make_usub("tstp", US_tstp, usersub, filename); - make_usub("_putchar", US__putchar, usersub, filename); -#endif - make_usub("testcallback", US_testcallback,usersub, filename); - }; - -#ifdef USG -static char -*getcap(cap) -register char *cap; -{ - static char nocaperr[] = "Cannot read termcap entry."; - - extern char *tgetstr(); - - if (tcbuf == NULL) { - if ((tcbuf = malloc(1024)) == NULL) { - fatal(nocaperr); - } - if (tgetent(tcbuf, ttytype) == -1) { - fatal(nocaperr); - } - } - - return (tgetstr(cap, NULL)); -} -#endif - -#ifdef NOSETATTR -#define attron(attr) wattron(stdscr, attr) -#define attroff(attr) wattroff(stdscr, attr) -#define attset(attr) wattset(stdscr, attr) - -int -wattron(win, attr) -WINDOW *win; -chtype attr; -{ - curattr |= attr; - if (curattr & A_STANDOUT) { - return(wstandout(win)); - } else { - return(wstandend(win)); - } -} - -int -wattroff(win, attr) -WINDOW *win; -chtype attr; -{ - curattr &= (~attr); - if (curattr & A_STANDOUT) { - return(wstandout(win)); - } else { - return(wstandend(win)); - } -} - -int -wattrset(win, attr) -WINDOW *win; -chtype attr; -{ - curattr = attr; - if (curattr & A_STANDOUT) { - return(wstandout(win)); - } else { - return(wstandend(win)); - } -} - -#endif - -static int -usersub(ix, sp, items) -int ix; -register int sp; -register int items; -{ - STR **st = stack->ary_array + sp; - register int i; - register char *tmps; - register STR *Str; /* used in str_get and str_gnum macros */ - - switch (ix) { -CASE int addch -I char ch -END - -CASE int waddch -I WINDOW* win -I char ch -END - -CASE int addstr -I char* str -END - -CASE int waddstr -I WINDOW* win -I char* str -END - -CASE int box -I WINDOW* win -I char vert -I char hor -END - -CASE int clear -END - -CASE int wclear -I WINDOW* win -END - -CASE int clearok -I WINDOW* win -I bool boolf -END - -CASE int clrtobot -END - -CASE int wclrtobot -I WINDOW* win -END - -CASE int clrtoeol -END - -CASE int wclrtoeol -I WINDOW* win -END - -CASE int delch -END - -CASE int wdelch -I WINDOW* win -END - -CASE int deleteln -END - -CASE int wdeleteln -I WINDOW* win -END - -CASE int erase -END - -CASE int werase -I WINDOW* win -END - -CASE int idlok -I WINDOW* win -I bool boolf -END - -CASE int insch -I char c -END - -CASE int winsch -I WINDOW* win -I char c -END - -CASE int insertln -END - -CASE int winsertln -I WINDOW* win -END - -CASE int move -I int y -I int x -END - -CASE int wmove -I WINDOW* win -I int y -I int x -END - -CASE int overlay -I WINDOW* win1 -I WINDOW* win2 -END - -CASE int overwrite -I WINDOW* win1 -I WINDOW* win2 -END - -CASE int refresh -END - -CASE int wrefresh -I WINDOW* win -END - -CASE int standout -END - -CASE int wstandout -I WINDOW* win -END - -CASE int standend -END - -CASE int wstandend -I WINDOW* win -END - -CASE int cbreak -END - -CASE int nocbreak -END - -CASE int echo -END - -CASE int noecho -END - - case US_getch: - if (items != 0) - fatal("Usage: &getch()"); - else { - int retval; - char retch; - - retval = getch(); - if (retval == EOF) - st[0] = &str_undef; - else { - retch = retval; - if (retval > 0377) - str_numset(st[0], (double) retval); - else - str_nset(st[0], &retch, 1); - } - } - return sp; - - case US_wgetch: - if (items != 1) - fatal("Usage: &wgetch($win)"); - else { - int retval; - char retch; - WINDOW* win = *(WINDOW**) str_get(st[1]); - - retval = wgetch(win); - if (retval == EOF) - st[0] = &str_undef; - else { - retch = retval; - if (retval > 0377) - str_numset(st[0], (double) retval); - else - str_nset(st[0], &retch, 1); - } - } - return sp; - -CASE int getstr -O char* str -END - -CASE int wgetstr -I WINDOW* win -O char* str -END - -CASE int raw -END - -CASE int noraw -END - -CASE int baudrate -END - -CASE int delwin -I WINDOW* win -END - -CASE int endwin -END - -CASE int erasechar -END - - case US_getyx: - if (items != 3) - fatal("Usage: &getyx($win, $y, $x)"); - else { - int retval; - STR* str = str_new(0); - WINDOW* win = *(WINDOW**) str_get(st[1]); - int y; - int x; - - do_sprintf(str, items - 1, st + 1); - retval = getyx(win, y, x); - str_numset(st[2], (double)y); - str_numset(st[3], (double)x); - str_numset(st[0], (double) retval); - str_free(str); - } - return sp; - -CASE int inch -END - -CASE int winch -I WINDOW* win -END - -CASE WINDOW* initscr -END - -CASE int killchar -END - -CASE int leaveok -I WINDOW* win -I bool boolf -END - -#ifdef BSD -CASE char* longname -I char* termbuf -IO char* name -END -#else -CASE char* longname -I char* termbug -I char* name -END -#endif - -CASE int mvwin -I WINDOW* win -I int y -I int x -END - -CASE WINDOW* newwin -I int lines -I int cols -I int begin_y -I int begin_x -END - -CASE int nl -END - -CASE int nonl -END - -CASE int scrollok -I WINDOW* win -I bool boolf -END - -CASE WINDOW* subwin -I WINDOW* win -I int lines -I int cols -I int begin_y -I int begin_x -END - -CASE int touchline -I WINDOW* win -I int y -I int startx -I int endx -END - -CASE int touchwin -I WINDOW* win -END - -CASE char* unctrl -I char ch -END - -CASE int gettmode -END - -CASE int mvcur -I int lasty -I int lastx -I int newy -I int newx -END - -CASE int scroll -I WINDOW* win -END - -CASE int savetty -END - -CASE void resetty -END - -CASE int setterm -I char* name -END - -CASE int attroff -I chtype str -END - -CASE int wattroff -I chtype str -END - -CASE int wattron -I chtype str -END - -CASE int attron -I chtype str -END - -CASE int attrset -I chtype str -END - -CASE int wattrset -I chtype str -END - -#ifdef CURSEFMT - case US_printw: - if (items < 1) - fatal("Usage: &printw($fmt, $arg1, $arg2, ... )"); - else { - int retval; - STR* str = str_new(0); - - do_sprintf(str, items, st + 1); - retval = addstr(str->str_ptr); - str_numset(st[0], (double) retval); - str_free(str); - } - return sp; - - case US_wprintw: - if (items < 2) - fatal("Usage: &wprintw($win, $fmt, $arg1, $arg2, ... )"); - else { - int retval; - STR* str = str_new(0); - WINDOW* win = *(WINDOW**) str_get(st[1]); - - do_sprintf(str, items - 1, st + 1); - retval = waddstr(win, str->str_ptr); - str_numset(st[0], (double) retval); - str_free(str); - } - return sp; - -#endif - -CASE char* getcap -I char* str -END - -#ifdef BSD -CASE int flushok -I WINDOW* win -I bool boolf -END - -CASE int fullname -I char* termbuf -IO char* name -END - -CASE int touchoverlap -I WINDOW* win1 -I WINDOW* win2 -END - -CASE int tstp -END - -CASE int _putchar -I char ch -END - - case US_testcallback: - sp = callback("callback", sp + items, curcsv->wantarray, 1, items); - break; - -#endif - - default: - fatal("Unimplemented user-defined subroutine"); - } - return sp; -} - -static int -userval(ix, str) -int ix; -STR *str; -{ - switch (ix) { - case UV_COLS: - str_numset(str, (double)COLS); - break; - case UV_ERR: - str_numset(str, (double)ERR); - break; - case UV_LINES: - str_numset(str, (double)LINES); - break; - case UV_OK: - str_numset(str, (double)OK); - break; - case UV_curscr: - str_nset(str, &curscr, sizeof(WINDOW*)); - break; - case UV_stdscr: - str_nset(str, &stdscr, sizeof(WINDOW*)); - break; - case UV_ttytype: - str_set(str, ttytype); - break; -#ifdef BSD - case UV_Def_term: - str_set(str, Def_term); - break; - case UV_My_term: - str_numset(str, (double)My_term); - break; -#endif - case UV_A_STANDOUT: - str_numset(str, (double)A_STANDOUT); - break; - case UV_A_UNDERLINE: - str_numset(str, (double)A_UNDERLINE); - break; - case UV_A_REVERSE: - str_numset(str, (double)A_REVERSE); - break; - case UV_A_BLINK: - str_numset(str, (double)A_BLINK); - break; - case UV_A_DIM: - str_numset(str, (double)A_DIM); - break; - case UV_A_BOLD: - str_numset(str, (double)A_BOLD); - break; - case UV_A_NORMAL: - str_numset(str, (double)A_NORMAL); - break; - } - return 0; -} - -static int -userset(ix, str) -int ix; -STR *str; -{ - switch (ix) { - case UV_COLS: - COLS = (int)str_gnum(str); - break; - case UV_LINES: - LINES = (int)str_gnum(str); - break; - case UV_ttytype: - strcpy(ttytype, str_get(str)); /* hope it fits */ -#ifdef USG - if (tcbuf != NULL) { - free(tcbuf); - tcbuf = NULL; - } -#endif - break; -#ifdef BSD - case UV_Def_term: - Def_term = savestr(str_get(str)); /* never freed */ - break; - case UV_My_term: - My_term = (bool)str_gnum(str); - break; -#endif - } - return 0; -} diff --git a/ext/curses/pager b/ext/curses/pager deleted file mode 100644 index 407bc50670..0000000000 --- a/ext/curses/pager +++ /dev/null @@ -1,190 +0,0 @@ -#!./curseperl - -eval <<'EndOfMain'; $evaloffset = __LINE__; - - $SIG{'INT'} = 'endit'; - $| = 1; # command buffering on stdout - &initterm; - &inithelp; - &slurpfile && &pagearray; - -EndOfMain - -&endit; - -################################################################################ - -sub initterm { - - &initscr; &cbreak; &noecho; &scrollok($stdscr, 1); - &defbell unless defined &bell; - - $lines = $LINES; $lines1 = $lines - 1; $lines2 = $lines - 2; - $cols = $COLS; $cols1 = $cols - 1; $cols2 = $cols - 2;; - - $dl = &getcap('dl'); - $al = &getcap('al'); - $ho = &getcap('ho'); - $ce = &getcap('ce'); -} - -sub slurpfile { - while (<>) { - s/^(\t+)/' ' x length($1)/e; - &expand($_) if /\t/; - if (length($_) < $cols) { - push(@lines, $_); - } - else { - while ($_ && $_ ne "\n") { - push(@lines, substr($_,0,$cols)); - substr($_,0,$cols) = ''; - } - } - } - 1; -} - -sub drawscreen { - &move(0,0); - for ($line .. $line + $lines2) { - &addstr($lines[$_]); - } - &clrtobot; - &percent; - &refresh; -} - -sub expand { - while (($off = index($_[0],"\t")) >= 0) { - substr($_[0], $off, 1) = ' ' x (8 - $off % 8); - } -} - -sub pagearray { - $line = 0; - - $| = 1; - - for (&drawscreen;;&drawscreen) { - - $ch = &getch; - $ch = 'j' if $ch eq "\n"; - - if ($ch eq ' ') { - last if $percent >= 100; - &move(0,0); - $line += $lines1; - } - elsif ($ch eq 'b') { - $line -= $lines1; - &move(0,0); - $line = 0 if $line < 0; - } - elsif ($ch eq 'j') { - next if $percent >= 100; - $line += 1; - if ($dl && $ho) { - print $ho, $dl; - &mvcur(0,0,$lines2,0); - print $ce,$lines[$line+$lines2],$ce; - &wmove($curscr,0,0); - &wdeleteln($curscr); - &wmove($curscr,$lines2,0); - &waddstr($curscr,$lines[$line+$lines2]); - } - &wmove($stdscr,0,0); - &wdeleteln($stdscr); - &wmove($stdscr,$lines2,0); - &waddstr($stdscr,$lines[$line+$lines2]); - &percent; - &refresh; - redo; - } - elsif ($ch eq 'k') { - next if $line <= 0; - $line -= 1; - if ($al && $ho && $ce) { - print $ho, $al, $ce, $lines[$line]; - &wmove($curscr,0,0); - &winsertln($curscr); - &waddstr($curscr,$lines[$line]); - } - &wmove($stdscr,0,0); - &winsertln($stdscr); - &waddstr($stdscr,$lines[$line]); - &percent; - &refresh; - redo; - } - elsif ($ch eq "\f") { - &clear; - } - elsif ($ch eq 'q') { - last; - } - elsif ($ch eq 'h') { - &clear; - &help; - &clear; - } - else { - &bell; - } - } -} - -sub defbell { - eval q# - sub bell { - print "\007"; - } - #; -} - -sub help { - local(*lines) = *helplines; - local($line); - &pagearray; -} - -sub inithelp { - @helplines = split(/\n/,<<'EOT'); - - h Display this help. - q Exit. - - SPACE Forward screen. - b Backward screen. - j, CR Forward 1 line. - k Backward 1 line. - FF Repaint screen. -EOT - for (@helplines) { - s/$/\n/; - } -} - -sub percent { - &standout; - $percent = int(($line + $lines1) * 100 / @lines); - &move($lines1,0); - &addstr("($percent%)"); - &standend; - &clrtoeol; -} - -sub endit { - &move($lines1,0); - &clrtoeol; - &refresh; - &endwin; - - if ($@) { - print ""; # force flush of stdout - $@ =~ s/\(eval\)/$0/ && $@ =~ s/line (\d+)/'line ' . ($1 + $evaloffset)/e; - die $@; - } - - exit; -} diff --git a/ext/dbm/GDBM_File.c b/ext/dbm/GDBM_File.c deleted file mode 100644 index f940a594cc..0000000000 --- a/ext/dbm/GDBM_File.c +++ /dev/null @@ -1,310 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include <gdbm.h> - -#include <fcntl.h> - -typedef GDBM_FILE GDBM_File; - -#define gdbm_new(dbtype, name, block_size, read_write, mode, fatal_func) \ - gdbm_open(name, block_size, read_write, mode, fatal_func) - -typedef datum gdatum; - -typedef void (*FATALFUNC)(); - -static int -XS_GDBM_File_gdbm_new(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 5 || items > 6) { - croak("Usage: GDBM_File::new(dbtype, name, block_size, read_write, mode, fatal_func = (FATALFUNC)croak)"); - } - { - char * dbtype = SvPV(ST(1),na); - char * name = SvPV(ST(2),na); - int block_size = (int)SvIV(ST(3)); - int read_write = (int)SvIV(ST(4)); - int mode = (int)SvIV(ST(5)); - FATALFUNC fatal_func; - GDBM_File RETVAL; - - if (items < 6) - fatal_func = (FATALFUNC)croak; - else { - fatal_func = (FATALFUNC)SvPV(ST(6),na); - } - - RETVAL = gdbm_new(dbtype, name, block_size, read_write, mode, fatal_func); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setptrobj(ST(0), RETVAL, "GDBM_File"); - } - return sp; -} - -static int -XS_GDBM_File_gdbm_open(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 4 || items > 5) { - croak("Usage: GDBM_File::open(name, block_size, read_write, mode, fatal_func = (FATALFUNC)croak)"); - } - { - char * name = SvPV(ST(1),na); - int block_size = (int)SvIV(ST(2)); - int read_write = (int)SvIV(ST(3)); - int mode = (int)SvIV(ST(4)); - FATALFUNC fatal_func; - GDBM_File RETVAL; - - if (items < 5) - fatal_func = (FATALFUNC)croak; - else { - fatal_func = (FATALFUNC)SvPV(ST(5),na); - } - - RETVAL = gdbm_open(name, block_size, read_write, mode, fatal_func); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setptrobj(ST(0), RETVAL, "GDBM_File"); - } - return sp; -} - -static int -XS_GDBM_File_gdbm_close(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: GDBM_File::close(db)"); - } - { - GDBM_File db; - - if (sv_isa(ST(1), "GDBM_File")) - db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type GDBM_File"); - - gdbm_close(db); - } - return sp; -} - -static int -XS_GDBM_File_gdbm_DESTROY(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: GDBM_File::DESTROY(db)"); - } - { - GDBM_File db; - - if (sv_isa(ST(1), "GDBM_File")) - db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type GDBM_File"); - gdbm_close(db); - } - return sp; -} - -static int -XS_GDBM_File_gdbm_fetch(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - croak("Usage: GDBM_File::fetch(db, key)"); - } - { - GDBM_File db; - datum key; - gdatum RETVAL; - - if (sv_isa(ST(1), "GDBM_File")) - db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type GDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = gdbm_fetch(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_usepvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_GDBM_File_gdbm_store(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 3 || items > 4) { - croak("Usage: GDBM_File::store(db, key, value, flags = GDBM_REPLACE)"); - } - { - GDBM_File db; - datum key; - datum value; - int flags; - int RETVAL; - - if (sv_isa(ST(1), "GDBM_File")) - db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type GDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - value.dptr = SvPV(ST(3), value.dsize);; - - if (items < 4) - flags = GDBM_REPLACE; - else { - flags = (int)SvIV(ST(4)); - } - - RETVAL = gdbm_store(db, key, value, flags); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_GDBM_File_gdbm_delete(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - croak("Usage: GDBM_File::delete(db, key)"); - } - { - GDBM_File db; - datum key; - int RETVAL; - - if (sv_isa(ST(1), "GDBM_File")) - db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type GDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = gdbm_delete(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_GDBM_File_gdbm_firstkey(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: GDBM_File::firstkey(db)"); - } - { - GDBM_File db; - gdatum RETVAL; - - if (sv_isa(ST(1), "GDBM_File")) - db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type GDBM_File"); - - RETVAL = gdbm_firstkey(db); - ST(0) = sv_mortalcopy(&sv_undef); - sv_usepvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_GDBM_File_gdbm_nextkey(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - croak("Usage: GDBM_File::nextkey(db, key)"); - } - { - GDBM_File db; - datum key; - gdatum RETVAL; - - if (sv_isa(ST(1), "GDBM_File")) - db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type GDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = gdbm_nextkey(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_usepvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_GDBM_File_gdbm_reorganize(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: GDBM_File::reorganize(db)"); - } - { - GDBM_File db; - int RETVAL; - - if (sv_isa(ST(1), "GDBM_File")) - db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type GDBM_File"); - - RETVAL = gdbm_reorganize(db); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -int boot_GDBM_File(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("GDBM_File::new", 0, XS_GDBM_File_gdbm_new, file); - newXSUB("GDBM_File::open", 0, XS_GDBM_File_gdbm_open, file); - newXSUB("GDBM_File::close", 0, XS_GDBM_File_gdbm_close, file); - newXSUB("GDBM_File::DESTROY", 0, XS_GDBM_File_gdbm_DESTROY, file); - newXSUB("GDBM_File::fetch", 0, XS_GDBM_File_gdbm_fetch, file); - newXSUB("GDBM_File::store", 0, XS_GDBM_File_gdbm_store, file); - newXSUB("GDBM_File::delete", 0, XS_GDBM_File_gdbm_delete, file); - newXSUB("GDBM_File::firstkey", 0, XS_GDBM_File_gdbm_firstkey, file); - newXSUB("GDBM_File::nextkey", 0, XS_GDBM_File_gdbm_nextkey, file); - newXSUB("GDBM_File::reorganize", 0, XS_GDBM_File_gdbm_reorganize, file); -} diff --git a/ext/dbm/GDBM_File.xs b/ext/dbm/GDBM_File.xs deleted file mode 100644 index 2c619cbe42..0000000000 --- a/ext/dbm/GDBM_File.xs +++ /dev/null @@ -1,76 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include <gdbm.h> - -#include <fcntl.h> - -typedef GDBM_FILE GDBM_File; - -#define gdbm_new(dbtype, name, block_size, read_write, mode, fatal_func) \ - gdbm_open(name, block_size, read_write, mode, fatal_func) - -typedef datum gdatum; - -typedef void (*FATALFUNC)(); - -MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_ - -GDBM_File -gdbm_new(dbtype, name, block_size, read_write, mode, fatal_func = (FATALFUNC)croak) - char * dbtype - char * name - int block_size - int read_write - int mode - FATALFUNC fatal_func - -GDBM_File -gdbm_open(name, block_size, read_write, mode, fatal_func = (FATALFUNC)croak) - char * name - int block_size - int read_write - int mode - FATALFUNC fatal_func - -void -gdbm_close(db) - GDBM_File db - CLEANUP: - -void -gdbm_DESTROY(db) - GDBM_File db - CODE: - gdbm_close(db); - -gdatum -gdbm_fetch(db, key) - GDBM_File db - datum key - -int -gdbm_store(db, key, value, flags = GDBM_REPLACE) - GDBM_File db - datum key - datum value - int flags - -int -gdbm_delete(db, key) - GDBM_File db - datum key - -gdatum -gdbm_firstkey(db) - GDBM_File db - -gdatum -gdbm_nextkey(db, key) - GDBM_File db - datum key - -int -gdbm_reorganize(db) - GDBM_File db - diff --git a/ext/dbm/GDBM_File.xs.bak b/ext/dbm/GDBM_File.xs.bak deleted file mode 100644 index 03b86c5739..0000000000 --- a/ext/dbm/GDBM_File.xs.bak +++ /dev/null @@ -1,122 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include <gdbm.h> - -#include <fcntl.h> - -typedef GDBM_FILE GDBM_File; - -#define gdbm_new(dbtype,filename,flags,mode) \ - gdbm_open(filename, 0, flags & O_CREAT ? GDBM_WRCREAT : GDBM_WRITER, \ - mode, fatal) - -typedef datum gdatum; - -typedef struct gdbm_file_desc { - GDBM_File ptr; - SV* curkey; -} GDBM_FILE_DESC; - -GDBM_FILE_DESC* GDBM_File_desc; - -GDBM_FILE_DESC* -newGDBM_FILE_DESC(ptr) -void* ptr; -{ - New(0, GDBM_File_desc, 1, GDBM_FILE_DESC); - GDBM_File_desc->ptr = ptr; - GDBM_File_desc->curkey = 0; - return GDBM_File_desc; -} - -void -deleteGDBM_FILE_DESC() -{ - sv_free(GDBM_File_desc->curkey); - Safefree(GDBM_File_desc); -} - -typedef void (*FATALFUNC)(); - -static datum -get_current_key() -{ - datum key; - key.dptr = SvPVn( GDBM_File_desc->curkey, key.dsize); - return key; -} - -static void -set_current_key(sv) -SV *sv; -{ - sv_free(GDBM_File_desc->curkey); - GDBM_File_desc->curkey = sv_ref(sv); -} - - -MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_ - -GDBM_File -gdbm_new(dbtype, filename, flags, mode) - char * dbtype - char * filename - int flags - int mode - -GDBM_File -gdbm_open(name, block_size, read_write, mode, fatal_func = (FATALFUNC)fatal) - char * name - int block_size - int read_write - int mode - FATALFUNC fatal_func - -void -gdbm_close(db) - GDBM_File db - CLEANUP: - deleteGDBM_FILE_DESC(); - -void -gdbm_DESTROY(db) - GDBM_File db - CODE: - gdbm_close(db); - deleteGDBM_FILE_DESC(); - -gdatum -gdbm_fetch(db, key) - GDBM_File db - datum key - -int -gdbm_store(db, key, value, flags = GDBM_REPLACE) - GDBM_File db - datum key - datum value - int flags - -int -gdbm_delete(db, key) - GDBM_File db - datum key - -gdatum -gdbm_firstkey(db) - GDBM_File db - CLEANUP: - set_current_key(ST(0)); - -gdatum -gdbm_nextkey(db, key = get_current_key()) - GDBM_File db - datum key - CLEANUP: - set_current_key(ST(0)); - -int -gdbm_reorganize(db) - GDBM_File db - diff --git a/ext/dbm/Makefile b/ext/dbm/Makefile deleted file mode 100644 index 970724dd2a..0000000000 --- a/ext/dbm/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -all: NDBM_File.c ODBM_File.c GDBM_File.c SDBM_File.c - -NDBM_File.c: NDBM_File.xs - ../xsubpp NDBM_File.xs >NDBM_File.c - -SDBM_File.c: SDBM_File.xs - ../xsubpp SDBM_File.xs >SDBM_File.c - -SDBM_File.o: SDBM_File.c - cc -g -I../.. -pic -c SDBM_File.c - -SDBM_File.so: SDBM_File.o sdbm/libsdbm.a - ld -o SDBM_File.so SDBM_File.o sdbm/libsdbm.a - -ODBM_File.c: ODBM_File.xs - ../xsubpp ODBM_File.xs >ODBM_File.c - -GDBM_File.c: GDBM_File.xs - ../xsubpp GDBM_File.xs >GDBM_File.c - diff --git a/ext/dbm/NDBM_File.c b/ext/dbm/NDBM_File.c deleted file mode 100644 index b321ac4252..0000000000 --- a/ext/dbm/NDBM_File.c +++ /dev/null @@ -1,267 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include <ndbm.h> - -typedef DBM* NDBM_File; -#define dbm_new(dbtype,filename,flags,mode) dbm_open(filename,flags,mode) -#define nextkey(db,key) dbm_nextkey(db) - -static int -XS_NDBM_File_dbm_new(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 4 || items > 4) { - fatal("Usage: NDBM_File::new(dbtype, filename, flags, mode)"); - } - { - char * dbtype = SvPV(ST(1),na); - char * filename = SvPV(ST(2),na); - int flags = (int)SvIV(ST(3)); - int mode = (int)SvIV(ST(4)); - NDBM_File RETVAL; - - RETVAL = dbm_new(dbtype, filename, flags, mode); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setptrobj(ST(0), RETVAL, "NDBM_File"); - } - return sp; -} - -static int -XS_NDBM_File_dbm_DESTROY(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - fatal("Usage: NDBM_File::DESTROY(db)"); - } - { - NDBM_File db; - - if (sv_isa(ST(1), "NDBM_File")) - db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1))); - else - fatal("db is not of type NDBM_File"); - dbm_close(db); - } - return sp; -} - -static int -XS_NDBM_File_dbm_fetch(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - fatal("Usage: NDBM_File::fetch(db, key)"); - } - { - NDBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) - db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1))); - else - fatal("db is not of type NDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = dbm_fetch(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_NDBM_File_dbm_store(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 3 || items > 4) { - fatal("Usage: NDBM_File::store(db, key, value, flags = DBM_REPLACE)"); - } - { - NDBM_File db; - datum key; - datum value; - int flags; - int RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) - db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1))); - else - fatal("db is not of type NDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - value.dptr = SvPV(ST(3), value.dsize);; - - if (items < 4) - flags = DBM_REPLACE; - else { - flags = (int)SvIV(ST(4)); - } - - RETVAL = dbm_store(db, key, value, flags); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_NDBM_File_dbm_delete(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - fatal("Usage: NDBM_File::delete(db, key)"); - } - { - NDBM_File db; - datum key; - int RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) - db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1))); - else - fatal("db is not of type NDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = dbm_delete(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_NDBM_File_dbm_firstkey(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - fatal("Usage: NDBM_File::firstkey(db)"); - } - { - NDBM_File db; - datum RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) - db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1))); - else - fatal("db is not of type NDBM_File"); - - RETVAL = dbm_firstkey(db); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_NDBM_File_nextkey(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - fatal("Usage: NDBM_File::nextkey(db, key)"); - } - { - NDBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) - db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1))); - else - fatal("db is not of type NDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = nextkey(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_NDBM_File_dbm_error(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - fatal("Usage: NDBM_File::error(db)"); - } - { - NDBM_File db; - int RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) - db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1))); - else - fatal("db is not of type NDBM_File"); - - RETVAL = dbm_error(db); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_NDBM_File_dbm_clearerr(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - fatal("Usage: NDBM_File::clearerr(db)"); - } - { - NDBM_File db; - int RETVAL; - - if (sv_isa(ST(1), "NDBM_File")) - db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1))); - else - fatal("db is not of type NDBM_File"); - - RETVAL = dbm_clearerr(db); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -int init_NDBM_File(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("NDBM_File::new", 0, XS_NDBM_File_dbm_new, file); - newXSUB("NDBM_File::DESTROY", 0, XS_NDBM_File_dbm_DESTROY, file); - newXSUB("NDBM_File::fetch", 0, XS_NDBM_File_dbm_fetch, file); - newXSUB("NDBM_File::store", 0, XS_NDBM_File_dbm_store, file); - newXSUB("NDBM_File::delete", 0, XS_NDBM_File_dbm_delete, file); - newXSUB("NDBM_File::firstkey", 0, XS_NDBM_File_dbm_firstkey, file); - newXSUB("NDBM_File::nextkey", 0, XS_NDBM_File_nextkey, file); - newXSUB("NDBM_File::error", 0, XS_NDBM_File_dbm_error, file); - newXSUB("NDBM_File::clearerr", 0, XS_NDBM_File_dbm_clearerr, file); -} diff --git a/ext/dbm/NDBM_File.xs b/ext/dbm/NDBM_File.xs deleted file mode 100644 index 5f4f78b974..0000000000 --- a/ext/dbm/NDBM_File.xs +++ /dev/null @@ -1,58 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include <ndbm.h> - -typedef DBM* NDBM_File; -#define dbm_new(dbtype,filename,flags,mode) dbm_open(filename,flags,mode) -#define nextkey(db,key) dbm_nextkey(db) - -MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = dbm_ - -NDBM_File -dbm_new(dbtype, filename, flags, mode) - char * dbtype - char * filename - int flags - int mode - -void -dbm_DESTROY(db) - NDBM_File db - CODE: - dbm_close(db); - -datum -dbm_fetch(db, key) - NDBM_File db - datum key - -int -dbm_store(db, key, value, flags = DBM_REPLACE) - NDBM_File db - datum key - datum value - int flags - -int -dbm_delete(db, key) - NDBM_File db - datum key - -datum -dbm_firstkey(db) - NDBM_File db - -datum -nextkey(db, key) - NDBM_File db - datum key - -int -dbm_error(db) - NDBM_File db - -int -dbm_clearerr(db) - NDBM_File db - diff --git a/ext/dbm/ODBM_File.c b/ext/dbm/ODBM_File.c deleted file mode 100644 index 1aea2cec53..0000000000 --- a/ext/dbm/ODBM_File.c +++ /dev/null @@ -1,246 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef NULL -#undef NULL -#endif -#include <dbm.h> - -#include <fcntl.h> - -typedef void* ODBM_File; - -#define odbm_fetch(db,key) fetch(key) -#define odbm_store(db,key,value,flags) store(key,value) -#define odbm_delete(db,key) delete(key) -#define odbm_firstkey(db) firstkey() -#define odbm_nextkey(db,key) nextkey(key) - -static int dbmrefcnt; - -#define DBM_REPLACE 0 - -static int -XS_ODBM_File_odbm_new(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 4 || items > 4) { - croak("Usage: ODBM_File::new(dbtype, filename, flags, mode)"); - } - { - char * dbtype = SvPV(ST(1),na); - char * filename = SvPV(ST(2),na); - int flags = (int)SvIV(ST(3)); - int mode = (int)SvIV(ST(4)); - ODBM_File RETVAL; - { - char tmpbuf[1025]; - if (dbmrefcnt++) - croak("Old dbm can only open one database"); - sprintf(tmpbuf,"%s.dir",filename); - if (stat(tmpbuf, &statbuf) < 0) { - if (flags & O_CREAT) { - if (mode < 0 || close(creat(tmpbuf,mode)) < 0) - croak("ODBM_File: Can't create %s", filename); - sprintf(tmpbuf,"%s.pag",filename); - if (close(creat(tmpbuf,mode)) < 0) - croak("ODBM_File: Can't create %s", filename); - } - else - croak("ODBM_FILE: Can't open %s", filename); - } - RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setptrobj(ST(0), RETVAL, "ODBM_File"); - } - } - return sp; -} - -static int -XS_ODBM_File_DESTROY(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: ODBM_File::DESTROY(db)"); - } - { - ODBM_File db; - - if (sv_isa(ST(1), "ODBM_File")) - db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type ODBM_File"); - dbmrefcnt--; - dbmclose(); - } - return sp; -} - -static int -XS_ODBM_File_odbm_fetch(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - croak("Usage: ODBM_File::fetch(db, key)"); - } - { - ODBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) - db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type ODBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = odbm_fetch(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_ODBM_File_odbm_store(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 3 || items > 4) { - croak("Usage: ODBM_File::store(db, key, value, flags = DBM_REPLACE)"); - } - { - ODBM_File db; - datum key; - datum value; - int flags; - int RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) - db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type ODBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - value.dptr = SvPV(ST(3), value.dsize);; - - if (items < 4) - flags = DBM_REPLACE; - else { - flags = (int)SvIV(ST(4)); - } - - RETVAL = odbm_store(db, key, value, flags); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_ODBM_File_odbm_delete(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - croak("Usage: ODBM_File::delete(db, key)"); - } - { - ODBM_File db; - datum key; - int RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) - db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type ODBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = odbm_delete(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_ODBM_File_odbm_firstkey(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: ODBM_File::firstkey(db)"); - } - { - ODBM_File db; - datum RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) - db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type ODBM_File"); - - RETVAL = odbm_firstkey(db); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_ODBM_File_odbm_nextkey(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - croak("Usage: ODBM_File::nextkey(db, key)"); - } - { - ODBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "ODBM_File")) - db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type ODBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = odbm_nextkey(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -int boot_ODBM_File(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("ODBM_File::new", 0, XS_ODBM_File_odbm_new, file); - newXSUB("ODBM_File::DESTROY", 0, XS_ODBM_File_DESTROY, file); - newXSUB("ODBM_File::fetch", 0, XS_ODBM_File_odbm_fetch, file); - newXSUB("ODBM_File::store", 0, XS_ODBM_File_odbm_store, file); - newXSUB("ODBM_File::delete", 0, XS_ODBM_File_odbm_delete, file); - newXSUB("ODBM_File::firstkey", 0, XS_ODBM_File_odbm_firstkey, file); - newXSUB("ODBM_File::nextkey", 0, XS_ODBM_File_odbm_nextkey, file); -} diff --git a/ext/dbm/SDBM_File.c.bak b/ext/dbm/SDBM_File.c.bak deleted file mode 100644 index 06fedb383d..0000000000 --- a/ext/dbm/SDBM_File.c.bak +++ /dev/null @@ -1,267 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include "ext/dbm/sdbm/sdbm.h" - -typedef DBM* SDBM_File; -#define sdbm_new(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode) -#define nextkey(db,key) sdbm_nextkey(db) - -static int -XS_SDBM_File_sdbm_new(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 4 || items > 4) { - croak("Usage: SDBM_File::new(dbtype, filename, flags, mode)"); - } - { - char * dbtype = SvPV(ST(1),na); - char * filename = SvPV(ST(2),na); - int flags = (int)SvIV(ST(3)); - int mode = (int)SvIV(ST(4)); - SDBM_File RETVAL; - - RETVAL = sdbm_new(dbtype, filename, flags, mode); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setptrobj(ST(0), RETVAL, "SDBM_File"); - } - return sp; -} - -static int -XS_SDBM_File_sdbm_DESTROY(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: SDBM_File::DESTROY(db)"); - } - { - SDBM_File db; - - if (SvROK(ST(1))) - db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not a reference"); - sdbm_close(db); - } - return sp; -} - -static int -XS_SDBM_File_sdbm_fetch(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - croak("Usage: SDBM_File::fetch(db, key)"); - } - { - SDBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) - db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type SDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = sdbm_fetch(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_SDBM_File_sdbm_store(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 3 || items > 4) { - croak("Usage: SDBM_File::store(db, key, value, flags = DBM_REPLACE)"); - } - { - SDBM_File db; - datum key; - datum value; - int flags; - int RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) - db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type SDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - value.dptr = SvPV(ST(3), value.dsize);; - - if (items < 4) - flags = DBM_REPLACE; - else { - flags = (int)SvIV(ST(4)); - } - - RETVAL = sdbm_store(db, key, value, flags); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_SDBM_File_sdbm_delete(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - croak("Usage: SDBM_File::delete(db, key)"); - } - { - SDBM_File db; - datum key; - int RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) - db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type SDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = sdbm_delete(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_SDBM_File_sdbm_firstkey(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: SDBM_File::firstkey(db)"); - } - { - SDBM_File db; - datum RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) - db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type SDBM_File"); - - RETVAL = sdbm_firstkey(db); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_SDBM_File_nextkey(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 2 || items > 2) { - croak("Usage: SDBM_File::nextkey(db, key)"); - } - { - SDBM_File db; - datum key; - datum RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) - db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type SDBM_File"); - - key.dptr = SvPV(ST(2), key.dsize);; - - RETVAL = nextkey(db, key); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize); - } - return sp; -} - -static int -XS_SDBM_File_sdbm_error(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: SDBM_File::error(db)"); - } - { - SDBM_File db; - int RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) - db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type SDBM_File"); - - RETVAL = sdbm_error(db); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -static int -XS_SDBM_File_sdbm_clearerr(ix, sp, items) -register int ix; -register int sp; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: SDBM_File::clearerr(db)"); - } - { - SDBM_File db; - int RETVAL; - - if (sv_isa(ST(1), "SDBM_File")) - db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1))); - else - croak("db is not of type SDBM_File"); - - RETVAL = sdbm_clearerr(db); - ST(0) = sv_mortalcopy(&sv_undef); - sv_setiv(ST(0), (I32)RETVAL); - } - return sp; -} - -int boot_SDBM_File(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("SDBM_File::new", 0, XS_SDBM_File_sdbm_new, file); - newXSUB("SDBM_File::DESTROY", 0, XS_SDBM_File_sdbm_DESTROY, file); - newXSUB("SDBM_File::fetch", 0, XS_SDBM_File_sdbm_fetch, file); - newXSUB("SDBM_File::store", 0, XS_SDBM_File_sdbm_store, file); - newXSUB("SDBM_File::delete", 0, XS_SDBM_File_sdbm_delete, file); - newXSUB("SDBM_File::firstkey", 0, XS_SDBM_File_sdbm_firstkey, file); - newXSUB("SDBM_File::nextkey", 0, XS_SDBM_File_nextkey, file); - newXSUB("SDBM_File::error", 0, XS_SDBM_File_sdbm_error, file); - newXSUB("SDBM_File::clearerr", 0, XS_SDBM_File_sdbm_clearerr, file); -} diff --git a/ext/dbm/SDBM_File.so b/ext/dbm/SDBM_File.so Binary files differdeleted file mode 100755 index 87f4749b2c..0000000000 --- a/ext/dbm/SDBM_File.so +++ /dev/null diff --git a/ext/dbm/SDBM_File.xs b/ext/dbm/SDBM_File.xs deleted file mode 100644 index 25cb67c1fc..0000000000 --- a/ext/dbm/SDBM_File.xs +++ /dev/null @@ -1,58 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include "ext/dbm/sdbm/sdbm.h" - -typedef DBM* SDBM_File; -#define sdbm_new(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode) -#define nextkey(db,key) sdbm_nextkey(db) - -MODULE = SDBM_File PACKAGE = SDBM_File PREFIX = sdbm_ - -SDBM_File -sdbm_new(dbtype, filename, flags, mode) - char * dbtype - char * filename - int flags - int mode - -void -sdbm_DESTROY(db) - SDBM_File db - CODE: - sdbm_close(db); - -datum -sdbm_fetch(db, key) - SDBM_File db - datum key - -int -sdbm_store(db, key, value, flags = DBM_REPLACE) - SDBM_File db - datum key - datum value - int flags - -int -sdbm_delete(db, key) - SDBM_File db - datum key - -datum -sdbm_firstkey(db) - SDBM_File db - -datum -nextkey(db, key) - SDBM_File db - datum key - -int -sdbm_error(db) - SDBM_File db - -int -sdbm_clearerr(db) - SDBM_File db - diff --git a/ext/dbm/perl b/ext/dbm/perl deleted file mode 120000 index 899dc46edb..0000000000 --- a/ext/dbm/perl +++ /dev/null @@ -1 +0,0 @@ -../../perl
\ No newline at end of file diff --git a/ext/dbm/sdbm/.pure b/ext/dbm/sdbm/.pure deleted file mode 100644 index e69de29bb2..0000000000 --- a/ext/dbm/sdbm/.pure +++ /dev/null diff --git a/ext/dbm/sdbm/.r b/ext/dbm/sdbm/.r deleted file mode 100755 index c72dbf15f5..0000000000 --- a/ext/dbm/sdbm/.r +++ /dev/null @@ -1,5884 +0,0 @@ -if test -f 'CHANGES' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'CHANGES'\" -else -echo shar: Extracting \"'CHANGES'\" \(900 characters\) -sed "s/^X//" >'CHANGES' <<'END_OF_FILE' -XChanges from the earlier BETA releases. -X -Xo dbm_prep does everything now, so dbm_open is just a simple -X wrapper that builds the default filenames. dbm_prep no longer -X requires a (DBM *) db parameter: it allocates one itself. It -X returns (DBM *) db or (DBM *) NULL. -X -Xo makroom is now reliable. In the common-case optimization of the page -X split, the page into which the incoming key/value pair is to be inserted -X is write-deferred (if the split is successful), thereby saving a cosly -X write. BUT, if the split does not make enough room (unsuccessful), the -X deferred page is written out, as the failure-window is now dependent on -X the number of split attempts. -X -Xo if -DDUFF is defined, hash function will also use the DUFF construct. -X This may look like a micro-performance tweak (maybe it is), but in fact, -X the hash function is the third most-heavily used function, after read -X and write. -END_OF_FILE -if test 900 -ne `wc -c <'CHANGES'`; then - echo shar: \"'CHANGES'\" unpacked with wrong size! -fi -# end of 'CHANGES' -fi -if test -f 'COMPARE' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'COMPARE'\" -else -echo shar: Extracting \"'COMPARE'\" \(2832 characters\) -sed "s/^X//" >'COMPARE' <<'END_OF_FILE' -X -XScript started on Thu Sep 28 15:41:06 1989 -X% uname -a -Xtitan titan 4_0 UMIPS mips -X% make all x-dbm -X cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbm.c -X cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c sdbm.c -X cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c pair.c -X cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c hash.c -X ar cr libsdbm.a sdbm.o pair.o hash.o -X ranlib libsdbm.a -X cc -o dbm dbm.o libsdbm.a -X cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dba.c -X cc -o dba dba.o -X cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbd.c -X cc -o dbd dbd.o -X cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -o x-dbm dbm.o -X% -X% -X% wc history -X 65110 218344 3204883 history -X% -X% /bin/time dbm build foo <history -X -Xreal 5:56.9 -Xuser 13.3 -Xsys 26.3 -X% ls -s -Xtotal 14251 -X 5 README 2 dbd.c 1 hash.c 1 pair.h -X 0 SCRIPT 5 dbd.o 1 hash.o 5 pair.o -X 1 WISHLIST 62 dbm 3130 history 1 port.h -X 46 dba 5 dbm.c 11 howtodbm.txt 11 sdbm.c -X 3 dba.c 8 dbm.o 14 libsdbm.a 2 sdbm.h -X 6 dba.o 4 foo.dir 1 makefile 8 sdbm.o -X 46 dbd 10810 foo.pag 6 pair.c 60 x-dbm -X% ls -l foo.* -X-rw-r--r-- 1 oz 4096 Sep 28 15:48 foo.dir -X-rw-r--r-- 1 oz 11069440 Sep 28 15:48 foo.pag -X% -X% /bin/time x-dbm build bar <history -X -Xreal 5:59.4 -Xuser 24.7 -Xsys 29.1 -X% -X% ls -s -Xtotal 27612 -X 5 README 46 dbd 1 hash.c 5 pair.o -X 1 SCRIPT 2 dbd.c 1 hash.o 1 port.h -X 1 WISHLIST 5 dbd.o 3130 history 11 sdbm.c -X 4 bar.dir 62 dbm 11 howtodbm.txt 2 sdbm.h -X13356 bar.pag 5 dbm.c 14 libsdbm.a 8 sdbm.o -X 46 dba 8 dbm.o 1 makefile 60 x-dbm -X 3 dba.c 4 foo.dir 6 pair.c -X 6 dba.o 10810 foo.pag 1 pair.h -X% -X% ls -l bar.* -X-rw-r--r-- 1 oz 4096 Sep 28 15:54 bar.dir -X-rw-r--r-- 1 oz 13676544 Sep 28 15:54 bar.pag -X% -X% dba foo | tail -X#10801: ok. no entries. -X#10802: ok. no entries. -X#10803: ok. no entries. -X#10804: ok. no entries. -X#10805: ok. no entries. -X#10806: ok. no entries. -X#10807: ok. no entries. -X#10808: ok. no entries. -X#10809: ok. 11 entries 67% used free 337. -X10810 pages (6036 holes): 65073 entries -X% -X% dba bar | tail -X#13347: ok. no entries. -X#13348: ok. no entries. -X#13349: ok. no entries. -X#13350: ok. no entries. -X#13351: ok. no entries. -X#13352: ok. no entries. -X#13353: ok. no entries. -X#13354: ok. no entries. -X#13355: ok. 7 entries 33% used free 676. -X13356 pages (8643 holes): 65073 entries -X% -X% exit -Xscript done on Thu Sep 28 16:08:45 1989 -X -END_OF_FILE -if test 2832 -ne `wc -c <'COMPARE'`; then - echo shar: \"'COMPARE'\" unpacked with wrong size! -fi -# end of 'COMPARE' -fi -if test -f 'README' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'README'\" -else -echo shar: Extracting \"'README'\" \(11457 characters\) -sed "s/^X//" >'README' <<'END_OF_FILE' -X -X -X -X -X -X -X sdbm - Substitute DBM -X or -X Berkeley ndbm for Every UN*X[1] Made Simple -X -X Ozan (oz) Yigit -X -X The Guild of PD Software Toolmakers -X Toronto - Canada -X -X oz@nexus.yorku.ca -X -X -X -XImplementation is the sincerest form of flattery. - L. Peter -XDeutsch -X -XA The Clone of the ndbm library -X -X The sources accompanying this notice - sdbm - consti- -Xtute the first public release (Dec. 1990) of a complete -Xclone of the Berkeley UN*X ndbm library. The sdbm library is -Xmeant to clone the proven functionality of ndbm as closely -Xas possible, including a few improvements. It is practical, -Xeasy to understand, and compatible. The sdbm library is not -Xderived from any licensed, proprietary or copyrighted -Xsoftware. -X -X The sdbm implementation is based on a 1978 algorithm -X[Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''. -XIn the course of searching for a substitute for ndbm, I pro- -Xtotyped three different external-hashing algorithms [Lar78, -XFag79, Lit80] and ultimately chose Larson's algorithm as a -Xbasis of the sdbm implementation. The Bell Labs dbm (and -Xtherefore ndbm) is based on an algorithm invented by Ken -XThompson, [Tho90, Tor87] and predates Larson's work. -X -X The sdbm programming interface is totally compatible -Xwith ndbm and includes a slight improvement in database ini- -Xtialization. It is also expected to be binary-compatible -Xunder most UN*X versions that support the ndbm library. -X -X The sdbm implementation shares the shortcomings of the -Xndbm library, as a side effect of various simplifications to -Xthe original Larson algorithm. It does produce holes in the -Xpage file as it writes pages past the end of file. (Larson's -Xpaper include a clever solution to this problem that is a -Xresult of using the hash value directly as a block address.) -XOn the other hand, extensive tests seem to indicate that -Xsdbm creates fewer holes in general, and the resulting page- -Xfiles are smaller. The sdbm implementation is also faster -Xthan ndbm in database creation. Unlike the ndbm, the sdbm -X_________________________ -X -X [1] UN*X is not a trademark of any (dis)organization. -X -X -X -X -X -X -X -X -X -X - 2 - -X -X -Xstore operation will not ``wander away'' trying to split its -Xdata pages to insert a datum that cannot (due to elaborate -Xworst-case situations) be inserted. (It will fail after a -Xpre-defined number of attempts.) -X -XImportant Compatibility Warning -X -X The sdbm and ndbm libraries cannot share databases: one -Xcannot read the (dir/pag) database created by the other. -XThis is due to the differences between the ndbm and sdbm -Xalgorithms[2], and the hash functions used. It is easy to -Xconvert between the dbm/ndbm databases and sdbm by ignoring -Xthe index completely: see dbd, dbu etc. -X -X -XNotice of Intellectual Property -X -XThe entire sdbm library package, as authored by me, Ozan S. -XYigit, is hereby placed in the public domain. As such, the -Xauthor is not responsible for the consequences of use of -Xthis software, no matter how awful, even if they arise from -Xdefects in it. There is no expressed or implied warranty for -Xthe sdbm library. -X -X Since the sdbm library package is in the public domain, -Xthis original release or any additional public-domain -Xreleases of the modified original cannot possibly (by defin- -Xition) be withheld from you. Also by definition, You (singu- -Xlar) have all the rights to this code (including the right -Xto sell without permission, the right to hoard[3] and the -Xright to do other icky things as you see fit) but those -Xrights are also granted to everyone else. -X -X Please note that all previous distributions of this -Xsoftware contained a copyright (which is now dropped) to -Xprotect its origins and its current public domain status -Xagainst any possible claims and/or challenges. -X -XAcknowledgments -X -X Many people have been very helpful and supportive. A -Xpartial list would necessarily include Rayan Zacherissen -X(who contributed the man page, and also hacked a MMAP -X_________________________ -X -X [2] Torek's discussion [Tor87] indicates that -Xdbm/ndbm implementations use the hash value to traverse -Xthe radix trie differently than sdbm and as a result, -Xthe page indexes are generated in different order. For -Xmore information, send e-mail to the author. -X [3] You cannot really hoard something that is avail- -Xable to the public at large, but try if it makes you -Xfeel any better. -X -X -X -X -X -X -X -X -X -X -X - 3 - -X -X -Xversion of sdbm), Arnold Robbins, Chris Lewis, Bill David- -Xsen, Henry Spencer, Geoff Collyer, Rich Salz (who got me -Xstarted in the first place), Johannes Ruschein (who did the -Xminix port) and David Tilbrook. I thank you all. -X -XDistribution Manifest and Notes -X -XThis distribution of sdbm includes (at least) the following: -X -X CHANGES change log -X README this file. -X biblio a small bibliography on external hashing -X dba.c a crude (n/s)dbm page file analyzer -X dbd.c a crude (n/s)dbm page file dumper (for conversion) -X dbe.1 man page for dbe.c -X dbe.c Janick's database editor -X dbm.c a dbm library emulation wrapper for ndbm/sdbm -X dbm.h header file for the above -X dbu.c a crude db management utility -X hash.c hashing function -X makefile guess. -X pair.c page-level routines (posted earlier) -X pair.h header file for the above -X readme.ms troff source for the README file -X sdbm.3 man page -X sdbm.c the real thing -X sdbm.h header file for the above -X tune.h place for tuning & portability thingies -X util.c miscellaneous -X -X dbu is a simple database manipulation program[4] that -Xtries to look like Bell Labs' cbt utility. It is currently -Xincomplete in functionality. I use dbu to test out the rou- -Xtines: it takes (from stdin) tab separated key/value pairs -Xfor commands like build or insert or takes keys for commands -Xlike delete or look. -X -X dbu <build|creat|look|insert|cat|delete> dbmfile -X -X dba is a crude analyzer of dbm/sdbm/ndbm page files. It -Xscans the entire page file, reporting page level statistics, -Xand totals at the end. -X -X dbd is a crude dump program for dbm/ndbm/sdbm data- -Xbases. It ignores the bitmap, and dumps the data pages in -Xsequence. It can be used to create input for the dbu util- -Xity. Note that dbd will skip any NULLs in the key and data -Xfields, thus is unsuitable to convert some peculiar -X_________________________ -X -X [4] The dbd, dba, dbu utilities are quick hacks and -Xare not fit for production use. They were developed -Xlate one night, just to test out sdbm, and convert some -Xdatabases. -X -X -X -X -X -X -X -X -X -X - 4 - -X -X -Xdatabases that insist in including the terminating null. -X -X I have also included a copy of the dbe (ndbm DataBase -XEditor) by Janick Bergeron [janick@bnr.ca] for your pleas- -Xure. You may find it more useful than the little dbu util- -Xity. -X -X dbm.[ch] is a dbm library emulation on top of ndbm (and -Xhence suitable for sdbm). Written by Robert Elz. -X -X The sdbm library has been around in beta test for quite -Xa long time, and from whatever little feedback I received -X(maybe no news is good news), I believe it has been func- -Xtioning without any significant problems. I would, of -Xcourse, appreciate all fixes and/or improvements. Portabil- -Xity enhancements would especially be useful. -X -XImplementation Issues -X -X Hash functions: The algorithm behind sdbm implementa- -Xtion needs a good bit-scrambling hash function to be effec- -Xtive. I ran into a set of constants for a simple hash func- -Xtion that seem to help sdbm perform better than ndbm for -Xvarious inputs: -X -X /* -X * polynomial conversion ignoring overflows -X * 65599 nice. 65587 even better. -X */ -X long -X dbm_hash(char *str, int len) { -X register unsigned long n = 0; -X -X while (len--) -X n = n * 65599 + *str++; -X return n; -X } -X -X There may be better hash functions for the purposes of -Xdynamic hashing. Try your favorite, and check the pagefile. -XIf it contains too many pages with too many holes, (in rela- -Xtion to this one for example) or if sdbm simply stops work- -Xing (fails after SPLTMAX attempts to split) when you feed -Xyour NEWS history file to it, you probably do not have a -Xgood hashing function. If you do better (for different -Xtypes of input), I would like to know about the function you -Xuse. -X -X Block sizes: It seems (from various tests on a few -Xmachines) that a page file block size PBLKSIZ of 1024 is by -Xfar the best for performance, but this also happens to limit -Xthe size of a key/value pair. Depending on your needs, you -Xmay wish to increase the page size, and also adjust PAIRMAX -X(the maximum size of a key/value pair allowed: should always -X -X -X -X -X -X -X -X -X -X - 5 - -X -X -Xbe at least three words smaller than PBLKSIZ.) accordingly. -XThe system-wide version of the library should probably be -Xconfigured with 1024 (distribution default), as this appears -Xto be sufficient for most common uses of sdbm. -X -XPortability -X -X This package has been tested in many different UN*Xes -Xeven including minix, and appears to be reasonably portable. -XThis does not mean it will port easily to non-UN*X systems. -X -XNotes and Miscellaneous -X -X The sdbm is not a very complicated package, at least -Xnot after you familiarize yourself with the literature on -Xexternal hashing. There are other interesting algorithms in -Xexistence that ensure (approximately) single-read access to -Xa data value associated with any key. These are directory- -Xless schemes such as linear hashing [Lit80] (+ Larson varia- -Xtions), spiral storage [Mar79] or directory schemes such as -Xextensible hashing [Fag79] by Fagin et al. I do hope these -Xsources provide a reasonable playground for experimentation -Xwith other algorithms. See the June 1988 issue of ACM Com- -Xputing Surveys [Enb88] for an excellent overview of the -Xfield. -X -XReferences -X -X -X[Lar78] -X P.-A. Larson, ``Dynamic Hashing'', BIT, vol. 18, pp. -X 184-201, 1978. -X -X[Tho90] -X Ken Thompson, private communication, Nov. 1990 -X -X[Lit80] -X W. Litwin, `` Linear Hashing: A new tool for file and -X table addressing'', Proceedings of the 6th Conference on -X Very Large Dabatases (Montreal), pp. 212-223, Very -X Large Database Foundation, Saratoga, Calif., 1980. -X -X[Fag79] -X R. Fagin, J. Nievergelt, N. Pippinger, and H. R. -X Strong, ``Extendible Hashing - A Fast Access Method for -X Dynamic Files'', ACM Trans. Database Syst., vol. 4, -X no.3, pp. 315-344, Sept. 1979. -X -X[Wal84] -X Rich Wales, ``Discussion of "dbm" data base system'', -X USENET newsgroup unix.wizards, Jan. 1984. -X -X[Tor87] -X Chris Torek, ``Re: dbm.a and ndbm.a archives'', -X -X -X -X -X -X -X -X -X -X - 6 - -X -X -X USENET newsgroup comp.unix, 1987. -X -X[Mar79] -X G. N. Martin, ``Spiral Storage: Incrementally Augment- -X able Hash Addressed Storage'', Technical Report #27, -X University of Varwick, Coventry, U.K., 1979. -X -X[Enb88] -X R. J. Enbody and H. C. Du, ``Dynamic Hashing -X Schemes'',ACM Computing Surveys, vol. 20, no. 2, pp. -X 85-113, June 1988. -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -X -END_OF_FILE -if test 11457 -ne `wc -c <'README'`; then - echo shar: \"'README'\" unpacked with wrong size! -fi -# end of 'README' -fi -if test -f 'biblio' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'biblio'\" -else -echo shar: Extracting \"'biblio'\" \(1012 characters\) -sed "s/^X//" >'biblio' <<'END_OF_FILE' -X%A R. J. Enbody -X%A H. C. Du -X%T Dynamic Hashing Schemes -X%J ACM Computing Surveys -X%V 20 -X%N 2 -X%D June 1988 -X%P 85-113 -X%K surveys -X -X%A P.-A. Larson -X%T Dynamic Hashing -X%J BIT -X%V 18 -X%P 184-201 -X%D 1978 -X%K dynamic -X -X%A W. Litwin -X%T Linear Hashing: A new tool for file and table addressing -X%J Proceedings of the 6th Conference on Very Large Dabatases (Montreal) -X%I Very Large Database Foundation -X%C Saratoga, Calif. -X%P 212-223 -X%D 1980 -X%K linear -X -X%A R. Fagin -X%A J. Nievergelt -X%A N. Pippinger -X%A H. R. Strong -X%T Extendible Hashing - A Fast Access Method for Dynamic Files -X%J ACM Trans. Database Syst. -X%V 4 -X%N 3 -X%D Sept. 1979 -X%P 315-344 -X%K extend -X -X%A G. N. Martin -X%T Spiral Storage: Incrementally Augmentable Hash Addressed Storage -X%J Technical Report #27 -X%I University of Varwick -X%C Coventry, U.K. -X%D 1979 -X%K spiral -X -X%A Chris Torek -X%T Re: dbm.a and ndbm.a archives -X%B USENET newsgroup comp.unix -X%D 1987 -X%K torek -X -X%A Rich Wales -X%T Discusson of "dbm" data base system -X%B USENET newsgroup unix.wizards -X%D Jan. 1984 -X%K rich -X -X -X -X -X -X -END_OF_FILE -if test 1012 -ne `wc -c <'biblio'`; then - echo shar: \"'biblio'\" unpacked with wrong size! -fi -# end of 'biblio' -fi -if test -f 'dba.c' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'dba.c'\" -else -echo shar: Extracting \"'dba.c'\" \(1273 characters\) -sed "s/^X//" >'dba.c' <<'END_OF_FILE' -X/* -X * dba dbm analysis/recovery -X */ -X -X#include <stdio.h> -X#include <sys/file.h> -X#include "sdbm.h" -X -Xchar *progname; -Xextern void oops(); -X -Xint -Xmain(argc, argv) -Xchar **argv; -X{ -X int n; -X char *p; -X char *name; -X int pagf; -X -X progname = argv[0]; -X -X if (p = argv[1]) { -X name = (char *) malloc((n = strlen(p)) + 5); -X strcpy(name, p); -X strcpy(name + n, ".pag"); -X -X if ((pagf = open(name, O_RDONLY)) < 0) -X oops("cannot open %s.", name); -X -X sdump(pagf); -X } -X else -X oops("usage: %s dbname", progname); -X -X return 0; -X} -X -Xsdump(pagf) -Xint pagf; -X{ -X register b; -X register n = 0; -X register t = 0; -X register o = 0; -X register e; -X char pag[PBLKSIZ]; -X -X while ((b = read(pagf, pag, PBLKSIZ)) > 0) { -X printf("#%d: ", n); -X if (!okpage(pag)) -X printf("bad\n"); -X else { -X printf("ok. "); -X if (!(e = pagestat(pag))) -X o++; -X else -X t += e; -X } -X n++; -X } -X -X if (b == 0) -X printf("%d pages (%d holes): %d entries\n", n, o, t); -X else -X oops("read failed: block %d", n); -X} -X -Xpagestat(pag) -Xchar *pag; -X{ -X register n; -X register free; -X register short *ino = (short *) pag; -X -X if (!(n = ino[0])) -X printf("no entries.\n"); -X else { -X free = ino[n] - (n + 1) * sizeof(short); -X printf("%3d entries %2d%% used free %d.\n", -X n / 2, ((PBLKSIZ - free) * 100) / PBLKSIZ, free); -X } -X return n / 2; -X} -END_OF_FILE -if test 1273 -ne `wc -c <'dba.c'`; then - echo shar: \"'dba.c'\" unpacked with wrong size! -fi -# end of 'dba.c' -fi -if test -f 'dbd.c' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'dbd.c'\" -else -echo shar: Extracting \"'dbd.c'\" \(1719 characters\) -sed "s/^X//" >'dbd.c' <<'END_OF_FILE' -X/* -X * dbd - dump a dbm data file -X */ -X -X#include <stdio.h> -X#include <sys/file.h> -X#include "sdbm.h" -X -Xchar *progname; -Xextern void oops(); -X -X -X#define empty(page) (((short *) page)[0] == 0) -X -Xint -Xmain(argc, argv) -Xchar **argv; -X{ -X int n; -X char *p; -X char *name; -X int pagf; -X -X progname = argv[0]; -X -X if (p = argv[1]) { -X name = (char *) malloc((n = strlen(p)) + 5); -X strcpy(name, p); -X strcpy(name + n, ".pag"); -X -X if ((pagf = open(name, O_RDONLY)) < 0) -X oops("cannot open %s.", name); -X -X sdump(pagf); -X } -X else -X oops("usage: %s dbname", progname); -X return 0; -X} -X -Xsdump(pagf) -Xint pagf; -X{ -X register r; -X register n = 0; -X register o = 0; -X char pag[PBLKSIZ]; -X -X while ((r = read(pagf, pag, PBLKSIZ)) > 0) { -X if (!okpage(pag)) -X fprintf(stderr, "%d: bad page.\n", n); -X else if (empty(pag)) -X o++; -X else -X dispage(pag); -X n++; -X } -X -X if (r == 0) -X fprintf(stderr, "%d pages (%d holes).\n", n, o); -X else -X oops("read failed: block %d", n); -X} -X -X -X#ifdef OLD -Xdispage(pag) -Xchar *pag; -X{ -X register i, n; -X register off; -X register short *ino = (short *) pag; -X -X off = PBLKSIZ; -X for (i = 1; i < ino[0]; i += 2) { -X printf("\t[%d]: ", ino[i]); -X for (n = ino[i]; n < off; n++) -X putchar(pag[n]); -X putchar(' '); -X off = ino[i]; -X printf("[%d]: ", ino[i + 1]); -X for (n = ino[i + 1]; n < off; n++) -X putchar(pag[n]); -X off = ino[i + 1]; -X putchar('\n'); -X } -X} -X#else -Xdispage(pag) -Xchar *pag; -X{ -X register i, n; -X register off; -X register short *ino = (short *) pag; -X -X off = PBLKSIZ; -X for (i = 1; i < ino[0]; i += 2) { -X for (n = ino[i]; n < off; n++) -X if (pag[n] != 0) -X putchar(pag[n]); -X putchar('\t'); -X off = ino[i]; -X for (n = ino[i + 1]; n < off; n++) -X if (pag[n] != 0) -X putchar(pag[n]); -X putchar('\n'); -X off = ino[i + 1]; -X } -X} -X#endif -END_OF_FILE -if test 1719 -ne `wc -c <'dbd.c'`; then - echo shar: \"'dbd.c'\" unpacked with wrong size! -fi -# end of 'dbd.c' -fi -if test -f 'dbe.1' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'dbe.1'\" -else -echo shar: Extracting \"'dbe.1'\" \(1454 characters\) -sed "s/^X//" >'dbe.1' <<'END_OF_FILE' -X.TH dbe 1 "ndbm(3) EDITOR" -X.SH NAME -Xdbe \- Edit a ndbm(3) database -X.SH USAGE -Xdbe <database> [-m r|w|rw] [-crtvx] -a|-d|-f|-F|-s [<key> [<content>]] -X.SH DESCRIPTION -X\fIdbme\fP operates on ndbm(3) databases. -XIt can be used to create them, look at them or change them. -XWhen specifying the value of a key or the content of its associated entry, -X\\nnn, \\0, \\n, \\t, \\f and \\r are interpreted as usual. -XWhen displaying key/content pairs, non-printable characters are displayed -Xusing the \\nnn notation. -X.SH OPTIONS -X.IP -a -XList all entries in the database. -X.IP -c -XCreate the database if it does not exist. -X.IP -d -XDelete the entry associated with the specified key. -X.IP -f -XFetch and display the entry associated with the specified key. -X.IP -F -XFetch and display all the entries whose key match the specified -Xregular-expression -X.IP "-m r|w|rw" -XOpen the database in read-only, write-only or read-write mode -X.IP -r -XReplace the entry associated with the specified key if it already exists. -XSee option -s. -X.IP -s -XStore an entry under a specific key. -XAn error occurs if the key already exists and the option -r was not specified. -X.IP -t -XRe-initialize the database before executing the command. -X.IP -v -XVerbose mode. -XConfirm stores and deletions. -X.IP -x -XIf option -x is used with option -c, then if the database already exists, -Xan error occurs. -XThis can be used to implement a simple exclusive access locking mechanism. -X.SH SEE ALSO -Xndbm(3) -X.SH AUTHOR -Xjanick@bnr.ca -X -END_OF_FILE -if test 1454 -ne `wc -c <'dbe.1'`; then - echo shar: \"'dbe.1'\" unpacked with wrong size! -fi -# end of 'dbe.1' -fi -if test -f 'dbe.c' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'dbe.c'\" -else -echo shar: Extracting \"'dbe.c'\" \(9799 characters\) -sed "s/^X//" >'dbe.c' <<'END_OF_FILE' -X#include <stdio.h> -X#ifndef VMS -X#include <sys/file.h> -X#include <ndbm.h> -X#else -X#include "file.h" -X#include "ndbm.h" -X#endif -X#include <ctype.h> -X -X/***************************************************************************\ -X** ** -X** Function name: getopt() ** -X** Author: Henry Spencer, UofT ** -X** Coding date: 84/04/28 ** -X** ** -X** Description: ** -X** ** -X** Parses argv[] for arguments. ** -X** Works with Whitesmith's C compiler. ** -X** ** -X** Inputs - The number of arguments ** -X** - The base address of the array of arguments ** -X** - A string listing the valid options (':' indicates an ** -X** argument to the preceding option is required, a ';' ** -X** indicates an argument to the preceding option is optional) ** -X** ** -X** Outputs - Returns the next option character, ** -X** '?' for non '-' arguments ** -X** or ':' when there is no more arguments. ** -X** ** -X** Side Effects + The argument to an option is pointed to by 'optarg' ** -X** ** -X***************************************************************************** -X** ** -X** REVISION HISTORY: ** -X** ** -X** DATE NAME DESCRIPTION ** -X** YY/MM/DD ------------------ ------------------------------------ ** -X** 88/10/20 Janick Bergeron Returns '?' on unamed arguments ** -X** returns '!' on unknown options ** -X** and 'EOF' only when exhausted. ** -X** 88/11/18 Janick Bergeron Return ':' when no more arguments ** -X** 89/08/11 Janick Bergeron Optional optarg when ';' in optstring ** -X** ** -X\***************************************************************************/ -X -Xchar *optarg; /* Global argument pointer. */ -X -X#ifdef VMS -X#define index strchr -X#endif -X -Xchar -Xgetopt(argc, argv, optstring) -Xint argc; -Xchar **argv; -Xchar *optstring; -X{ -X register int c; -X register char *place; -X extern char *index(); -X static int optind = 0; -X static char *scan = NULL; -X -X optarg = NULL; -X -X if (scan == NULL || *scan == '\0') { -X -X if (optind == 0) -X optind++; -X if (optind >= argc) -X return ':'; -X -X optarg = place = argv[optind++]; -X if (place[0] != '-' || place[1] == '\0') -X return '?'; -X if (place[1] == '-' && place[2] == '\0') -X return '?'; -X scan = place + 1; -X } -X -X c = *scan++; -X place = index(optstring, c); -X if (place == NULL || c == ':' || c == ';') { -X -X (void) fprintf(stderr, "%s: unknown option %c\n", argv[0], c); -X scan = NULL; -X return '!'; -X } -X if (*++place == ':') { -X -X if (*scan != '\0') { -X -X optarg = scan; -X scan = NULL; -X -X } -X else { -X -X if (optind >= argc) { -X -X (void) fprintf(stderr, "%s: %c requires an argument\n", -X argv[0], c); -X return '!'; -X } -X optarg = argv[optind]; -X optind++; -X } -X } -X else if (*place == ';') { -X -X if (*scan != '\0') { -X -X optarg = scan; -X scan = NULL; -X -X } -X else { -X -X if (optind >= argc || *argv[optind] == '-') -X optarg = NULL; -X else { -X optarg = argv[optind]; -X optind++; -X } -X } -X } -X return c; -X} -X -X -Xvoid -Xprint_datum(db) -Xdatum db; -X{ -X int i; -X -X putchar('"'); -X for (i = 0; i < db.dsize; i++) { -X if (isprint(db.dptr[i])) -X putchar(db.dptr[i]); -X else { -X putchar('\\'); -X putchar('0' + ((db.dptr[i] >> 6) & 0x07)); -X putchar('0' + ((db.dptr[i] >> 3) & 0x07)); -X putchar('0' + (db.dptr[i] & 0x07)); -X } -X } -X putchar('"'); -X} -X -X -Xdatum -Xread_datum(s) -Xchar *s; -X{ -X datum db; -X char *p; -X int i; -X -X db.dsize = 0; -X db.dptr = (char *) malloc(strlen(s) * sizeof(char)); -X for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) { -X if (*s == '\\') { -X if (*++s == 'n') -X *p = '\n'; -X else if (*s == 'r') -X *p = '\r'; -X else if (*s == 'f') -X *p = '\f'; -X else if (*s == 't') -X *p = '\t'; -X else if (isdigit(*s) && isdigit(*(s + 1)) && isdigit(*(s + 2))) { -X i = (*s++ - '0') << 6; -X i |= (*s++ - '0') << 3; -X i |= *s - '0'; -X *p = i; -X } -X else if (*s == '0') -X *p = '\0'; -X else -X *p = *s; -X } -X else -X *p = *s; -X } -X -X return db; -X} -X -X -Xchar * -Xkey2s(db) -Xdatum db; -X{ -X char *buf; -X char *p1, *p2; -X -X buf = (char *) malloc((db.dsize + 1) * sizeof(char)); -X for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++); -X *p1 = '\0'; -X return buf; -X} -X -X -Xmain(argc, argv) -Xint argc; -Xchar **argv; -X{ -X typedef enum { -X YOW, FETCH, STORE, DELETE, SCAN, REGEXP -X } commands; -X char opt; -X int flags; -X int giveusage = 0; -X int verbose = 0; -X commands what = YOW; -X char *comarg[3]; -X int st_flag = DBM_INSERT; -X int argn; -X DBM *db; -X datum key; -X datum content; -X -X flags = O_RDWR; -X argn = 0; -X -X while ((opt = getopt(argc, argv, "acdfFm:rstvx")) != ':') { -X switch (opt) { -X case 'a': -X what = SCAN; -X break; -X case 'c': -X flags |= O_CREAT; -X break; -X case 'd': -X what = DELETE; -X break; -X case 'f': -X what = FETCH; -X break; -X case 'F': -X what = REGEXP; -X break; -X case 'm': -X flags &= ~(000007); -X if (strcmp(optarg, "r") == 0) -X flags |= O_RDONLY; -X else if (strcmp(optarg, "w") == 0) -X flags |= O_WRONLY; -X else if (strcmp(optarg, "rw") == 0) -X flags |= O_RDWR; -X else { -X fprintf(stderr, "Invalid mode: \"%s\"\n", optarg); -X giveusage = 1; -X } -X break; -X case 'r': -X st_flag = DBM_REPLACE; -X break; -X case 's': -X what = STORE; -X break; -X case 't': -X flags |= O_TRUNC; -X break; -X case 'v': -X verbose = 1; -X break; -X case 'x': -X flags |= O_EXCL; -X break; -X case '!': -X giveusage = 1; -X break; -X case '?': -X if (argn < 3) -X comarg[argn++] = optarg; -X else { -X fprintf(stderr, "Too many arguments.\n"); -X giveusage = 1; -X } -X break; -X } -X } -X -X if (giveusage | what == YOW | argn < 1) { -X fprintf(stderr, "Usage: %s databse [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]); -X exit(-1); -X } -X -X if ((db = dbm_open(comarg[0], flags, 0777)) == NULL) { -X fprintf(stderr, "Error opening database \"%s\"\n", comarg[0]); -X exit(-1); -X } -X -X if (argn > 1) -X key = read_datum(comarg[1]); -X if (argn > 2) -X content = read_datum(comarg[2]); -X -X switch (what) { -X -X case SCAN: -X key = dbm_firstkey(db); -X if (dbm_error(db)) { -X fprintf(stderr, "Error when fetching first key\n"); -X goto db_exit; -X } -X while (key.dptr != NULL) { -X content = dbm_fetch(db, key); -X if (dbm_error(db)) { -X fprintf(stderr, "Error when fetching "); -X print_datum(key); -X printf("\n"); -X goto db_exit; -X } -X print_datum(key); -X printf(": "); -X print_datum(content); -X printf("\n"); -X if (dbm_error(db)) { -X fprintf(stderr, "Error when fetching next key\n"); -X goto db_exit; -X } -X key = dbm_nextkey(db); -X } -X break; -X -X case REGEXP: -X if (argn < 2) { -X fprintf(stderr, "Missing regular expression.\n"); -X goto db_exit; -X } -X if (re_comp(comarg[1])) { -X fprintf(stderr, "Invalid regular expression\n"); -X goto db_exit; -X } -X key = dbm_firstkey(db); -X if (dbm_error(db)) { -X fprintf(stderr, "Error when fetching first key\n"); -X goto db_exit; -X } -X while (key.dptr != NULL) { -X if (re_exec(key2s(key))) { -X content = dbm_fetch(db, key); -X if (dbm_error(db)) { -X fprintf(stderr, "Error when fetching "); -X print_datum(key); -X printf("\n"); -X goto db_exit; -X } -X print_datum(key); -X printf(": "); -X print_datum(content); -X printf("\n"); -X if (dbm_error(db)) { -X fprintf(stderr, "Error when fetching next key\n"); -X goto db_exit; -X } -X } -X key = dbm_nextkey(db); -X } -X break; -X -X case FETCH: -X if (argn < 2) { -X fprintf(stderr, "Missing fetch key.\n"); -X goto db_exit; -X } -X content = dbm_fetch(db, key); -X if (dbm_error(db)) { -X fprintf(stderr, "Error when fetching "); -X print_datum(key); -X printf("\n"); -X goto db_exit; -X } -X if (content.dptr == NULL) { -X fprintf(stderr, "Cannot find "); -X print_datum(key); -X printf("\n"); -X goto db_exit; -X } -X print_datum(key); -X printf(": "); -X print_datum(content); -X printf("\n"); -X break; -X -X case DELETE: -X if (argn < 2) { -X fprintf(stderr, "Missing delete key.\n"); -X goto db_exit; -X } -X if (dbm_delete(db, key) || dbm_error(db)) { -X fprintf(stderr, "Error when deleting "); -X print_datum(key); -X printf("\n"); -X goto db_exit; -X } -X if (verbose) { -X print_datum(key); -X printf(": DELETED\n"); -X } -X break; -X -X case STORE: -X if (argn < 3) { -X fprintf(stderr, "Missing key and/or content.\n"); -X goto db_exit; -X } -X if (dbm_store(db, key, content, st_flag) || dbm_error(db)) { -X fprintf(stderr, "Error when storing "); -X print_datum(key); -X printf("\n"); -X goto db_exit; -X } -X if (verbose) { -X print_datum(key); -X printf(": "); -X print_datum(content); -X printf(" STORED\n"); -X } -X break; -X } -X -Xdb_exit: -X dbm_clearerr(db); -X dbm_close(db); -X if (dbm_error(db)) { -X fprintf(stderr, "Error closing database \"%s\"\n", comarg[0]); -X exit(-1); -X } -X} -END_OF_FILE -if test 9799 -ne `wc -c <'dbe.c'`; then - echo shar: \"'dbe.c'\" unpacked with wrong size! -fi -# end of 'dbe.c' -fi -if test -f 'dbm.c' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'dbm.c'\" -else -echo shar: Extracting \"'dbm.c'\" \(2426 characters\) -sed "s/^X//" >'dbm.c' <<'END_OF_FILE' -X/* -X * Copyright (c) 1985 The Regents of the University of California. -X * All rights reserved. -X * -X * Redistribution and use in source and binary forms are permitted -X * provided that the above copyright notice and this paragraph are -X * duplicated in all such forms and that any documentation, -X * advertising materials, and other materials related to such -X * distribution and use acknowledge that the software was developed -X * by the University of California, Berkeley. The name of the -X * University may not be used to endorse or promote products derived -X * from this software without specific prior written permission. -X * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR -X * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED -X * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. -X */ -X -X#ifndef lint -Xstatic char sccsid[] = "@(#)dbm.c 5.4 (Berkeley) 5/24/89"; -X#endif /* not lint */ -X -X#include "dbm.h" -X -X#define NODB ((DBM *)0) -X -Xstatic DBM *cur_db = NODB; -X -Xstatic char no_db[] = "dbm: no open database\n"; -X -Xdbminit(file) -X char *file; -X{ -X if (cur_db != NODB) -X dbm_close(cur_db); -X -X cur_db = dbm_open(file, 2, 0); -X if (cur_db == NODB) { -X cur_db = dbm_open(file, 0, 0); -X if (cur_db == NODB) -X return (-1); -X } -X return (0); -X} -X -Xlong -Xforder(key) -Xdatum key; -X{ -X if (cur_db == NODB) { -X printf(no_db); -X return (0L); -X } -X return (dbm_forder(cur_db, key)); -X} -X -Xdatum -Xfetch(key) -Xdatum key; -X{ -X datum item; -X -X if (cur_db == NODB) { -X printf(no_db); -X item.dptr = 0; -X return (item); -X } -X return (dbm_fetch(cur_db, key)); -X} -X -Xdelete(key) -Xdatum key; -X{ -X if (cur_db == NODB) { -X printf(no_db); -X return (-1); -X } -X if (dbm_rdonly(cur_db)) -X return (-1); -X return (dbm_delete(cur_db, key)); -X} -X -Xstore(key, dat) -Xdatum key, dat; -X{ -X if (cur_db == NODB) { -X printf(no_db); -X return (-1); -X } -X if (dbm_rdonly(cur_db)) -X return (-1); -X -X return (dbm_store(cur_db, key, dat, DBM_REPLACE)); -X} -X -Xdatum -Xfirstkey() -X{ -X datum item; -X -X if (cur_db == NODB) { -X printf(no_db); -X item.dptr = 0; -X return (item); -X } -X return (dbm_firstkey(cur_db)); -X} -X -Xdatum -Xnextkey(key) -Xdatum key; -X{ -X datum item; -X -X if (cur_db == NODB) { -X printf(no_db); -X item.dptr = 0; -X return (item); -X } -X return (dbm_nextkey(cur_db, key)); -X} -END_OF_FILE -if test 2426 -ne `wc -c <'dbm.c'`; then - echo shar: \"'dbm.c'\" unpacked with wrong size! -fi -# end of 'dbm.c' -fi -if test -f 'dbm.h' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'dbm.h'\" -else -echo shar: Extracting \"'dbm.h'\" \(1186 characters\) -sed "s/^X//" >'dbm.h' <<'END_OF_FILE' -X/* -X * Copyright (c) 1983 The Regents of the University of California. -X * All rights reserved. -X * -X * Redistribution and use in source and binary forms are permitted -X * provided that the above copyright notice and this paragraph are -X * duplicated in all such forms and that any documentation, -X * advertising materials, and other materials related to such -X * distribution and use acknowledge that the software was developed -X * by the University of California, Berkeley. The name of the -X * University may not be used to endorse or promote products derived -X * from this software without specific prior written permission. -X * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR -X * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED -X * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. -X * -X * @(#)dbm.h 5.2 (Berkeley) 5/24/89 -X */ -X -X#ifndef NULL -X/* -X * this is lunacy, we no longer use it (and never should have -X * unconditionally defined it), but, this whole file is for -X * backwards compatability - someone may rely on this. -X */ -X#define NULL ((char *) 0) -X#endif -X -X#include <ndbm.h> -X -Xdatum fetch(); -Xdatum firstkey(); -Xdatum nextkey(); -END_OF_FILE -if test 1186 -ne `wc -c <'dbm.h'`; then - echo shar: \"'dbm.h'\" unpacked with wrong size! -fi -# end of 'dbm.h' -fi -if test -f 'dbu.c' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'dbu.c'\" -else -echo shar: Extracting \"'dbu.c'\" \(4408 characters\) -sed "s/^X//" >'dbu.c' <<'END_OF_FILE' -X#include <stdio.h> -X#include <sys/file.h> -X#ifdef SDBM -X#include "sdbm.h" -X#else -X#include <ndbm.h> -X#endif -X#include <string.h> -X -X#ifdef BSD42 -X#define strchr index -X#endif -X -Xextern int getopt(); -Xextern char *strchr(); -Xextern void oops(); -X -Xchar *progname; -X -Xstatic int rflag; -Xstatic char *usage = "%s [-R] cat | look |... dbmname"; -X -X#define DERROR 0 -X#define DLOOK 1 -X#define DINSERT 2 -X#define DDELETE 3 -X#define DCAT 4 -X#define DBUILD 5 -X#define DPRESS 6 -X#define DCREAT 7 -X -X#define LINEMAX 8192 -X -Xtypedef struct { -X char *sname; -X int scode; -X int flags; -X} cmd; -X -Xstatic cmd cmds[] = { -X -X "fetch", DLOOK, O_RDONLY, -X "get", DLOOK, O_RDONLY, -X "look", DLOOK, O_RDONLY, -X "add", DINSERT, O_RDWR, -X "insert", DINSERT, O_RDWR, -X "store", DINSERT, O_RDWR, -X "delete", DDELETE, O_RDWR, -X "remove", DDELETE, O_RDWR, -X "dump", DCAT, O_RDONLY, -X "list", DCAT, O_RDONLY, -X "cat", DCAT, O_RDONLY, -X "creat", DCREAT, O_RDWR | O_CREAT | O_TRUNC, -X "new", DCREAT, O_RDWR | O_CREAT | O_TRUNC, -X "build", DBUILD, O_RDWR | O_CREAT, -X "squash", DPRESS, O_RDWR, -X "compact", DPRESS, O_RDWR, -X "compress", DPRESS, O_RDWR -X}; -X -X#define CTABSIZ (sizeof (cmds)/sizeof (cmd)) -X -Xstatic cmd *parse(); -Xstatic void badk(), doit(), prdatum(); -X -Xint -Xmain(argc, argv) -Xint argc; -Xchar *argv[]; -X{ -X int c; -X register cmd *act; -X extern int optind; -X extern char *optarg; -X -X progname = argv[0]; -X -X while ((c = getopt(argc, argv, "R")) != EOF) -X switch (c) { -X case 'R': /* raw processing */ -X rflag++; -X break; -X -X default: -X oops("usage: %s", usage); -X break; -X } -X -X if ((argc -= optind) < 2) -X oops("usage: %s", usage); -X -X if ((act = parse(argv[optind])) == NULL) -X badk(argv[optind]); -X optind++; -X doit(act, argv[optind]); -X return 0; -X} -X -Xstatic void -Xdoit(act, file) -Xregister cmd *act; -Xchar *file; -X{ -X datum key; -X datum val; -X register DBM *db; -X register char *op; -X register int n; -X char *line; -X#ifdef TIME -X long start; -X extern long time(); -X#endif -X -X if ((db = dbm_open(file, act->flags, 0644)) == NULL) -X oops("cannot open: %s", file); -X -X if ((line = (char *) malloc(LINEMAX)) == NULL) -X oops("%s: cannot get memory", "line alloc"); -X -X switch (act->scode) { -X -X case DLOOK: -X while (fgets(line, LINEMAX, stdin) != NULL) { -X n = strlen(line) - 1; -X line[n] = 0; -X key.dptr = line; -X key.dsize = n; -X val = dbm_fetch(db, key); -X if (val.dptr != NULL) { -X prdatum(stdout, val); -X putchar('\n'); -X continue; -X } -X prdatum(stderr, key); -X fprintf(stderr, ": not found.\n"); -X } -X break; -X case DINSERT: -X break; -X case DDELETE: -X while (fgets(line, LINEMAX, stdin) != NULL) { -X n = strlen(line) - 1; -X line[n] = 0; -X key.dptr = line; -X key.dsize = n; -X if (dbm_delete(db, key) == -1) { -X prdatum(stderr, key); -X fprintf(stderr, ": not found.\n"); -X } -X } -X break; -X case DCAT: -X for (key = dbm_firstkey(db); key.dptr != 0; -X key = dbm_nextkey(db)) { -X prdatum(stdout, key); -X putchar('\t'); -X prdatum(stdout, dbm_fetch(db, key)); -X putchar('\n'); -X } -X break; -X case DBUILD: -X#ifdef TIME -X start = time(0); -X#endif -X while (fgets(line, LINEMAX, stdin) != NULL) { -X n = strlen(line) - 1; -X line[n] = 0; -X key.dptr = line; -X if ((op = strchr(line, '\t')) != 0) { -X key.dsize = op - line; -X *op++ = 0; -X val.dptr = op; -X val.dsize = line + n - op; -X } -X else -X oops("bad input; %s", line); -X -X if (dbm_store(db, key, val, DBM_REPLACE) < 0) { -X prdatum(stderr, key); -X fprintf(stderr, ": "); -X oops("store: %s", "failed"); -X } -X } -X#ifdef TIME -X printf("done: %d seconds.\n", time(0) - start); -X#endif -X break; -X case DPRESS: -X break; -X case DCREAT: -X break; -X } -X -X dbm_close(db); -X} -X -Xstatic void -Xbadk(word) -Xchar *word; -X{ -X register int i; -X -X if (progname) -X fprintf(stderr, "%s: ", progname); -X fprintf(stderr, "bad keywd %s. use one of\n", word); -X for (i = 0; i < (int)CTABSIZ; i++) -X fprintf(stderr, "%-8s%c", cmds[i].sname, -X ((i + 1) % 6 == 0) ? '\n' : ' '); -X fprintf(stderr, "\n"); -X exit(1); -X /*NOTREACHED*/ -X} -X -Xstatic cmd * -Xparse(str) -Xregister char *str; -X{ -X register int i = CTABSIZ; -X register cmd *p; -X -X for (p = cmds; i--; p++) -X if (strcmp(p->sname, str) == 0) -X return p; -X return NULL; -X} -X -Xstatic void -Xprdatum(stream, d) -XFILE *stream; -Xdatum d; -X{ -X register int c; -X register char *p = d.dptr; -X register int n = d.dsize; -X -X while (n--) { -X c = *p++ & 0377; -X if (c & 0200) { -X fprintf(stream, "M-"); -X c &= 0177; -X } -X if (c == 0177 || c < ' ') -X fprintf(stream, "^%c", (c == 0177) ? '?' : c + '@'); -X else -X putc(c, stream); -X } -X} -X -X -END_OF_FILE -if test 4408 -ne `wc -c <'dbu.c'`; then - echo shar: \"'dbu.c'\" unpacked with wrong size! -fi -# end of 'dbu.c' -fi -if test -f 'grind' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'grind'\" -else -echo shar: Extracting \"'grind'\" \(201 characters\) -sed "s/^X//" >'grind' <<'END_OF_FILE' -X#!/bin/sh -Xrm -f /tmp/*.dir /tmp/*.pag -Xawk -e '{ -X printf "%s\t", $0 -X for (i = 0; i < 40; i++) -X printf "%s.", $0 -X printf "\n" -X}' < /usr/dict/words | $1 build /tmp/$2 -X -END_OF_FILE -if test 201 -ne `wc -c <'grind'`; then - echo shar: \"'grind'\" unpacked with wrong size! -fi -chmod +x 'grind' -# end of 'grind' -fi -if test -f 'hash.c' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'hash.c'\" -else -echo shar: Extracting \"'hash.c'\" \(922 characters\) -sed "s/^X//" >'hash.c' <<'END_OF_FILE' -X/* -X * sdbm - ndbm work-alike hashed database library -X * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). -X * author: oz@nexus.yorku.ca -X * status: public domain. keep it that way. -X * -X * hashing routine -X */ -X -X#include "sdbm.h" -X/* -X * polynomial conversion ignoring overflows -X * [this seems to work remarkably well, in fact better -X * then the ndbm hash function. Replace at your own risk] -X * use: 65599 nice. -X * 65587 even better. -X */ -Xlong -Xdbm_hash(str, len) -Xregister char *str; -Xregister int len; -X{ -X register unsigned long n = 0; -X -X#ifdef DUFF -X -X#define HASHC n = *str++ + 65599 * n -X -X if (len > 0) { -X register int loop = (len + 8 - 1) >> 3; -X -X switch(len & (8 - 1)) { -X case 0: do { -X HASHC; case 7: HASHC; -X case 6: HASHC; case 5: HASHC; -X case 4: HASHC; case 3: HASHC; -X case 2: HASHC; case 1: HASHC; -X } while (--loop); -X } -X -X } -X#else -X while (len--) -X n = *str++ + 65599 * n; -X#endif -X return n; -X} -END_OF_FILE -if test 922 -ne `wc -c <'hash.c'`; then - echo shar: \"'hash.c'\" unpacked with wrong size! -fi -# end of 'hash.c' -fi -if test -f 'makefile' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'makefile'\" -else -echo shar: Extracting \"'makefile'\" \(1147 characters\) -sed "s/^X//" >'makefile' <<'END_OF_FILE' -X# -X# makefile for public domain ndbm-clone: sdbm -X# DUFF: use duff's device (loop unroll) in parts of the code -X# -XCFLAGS = -O -DSDBM -DDUFF -DBSD42 -X#LDFLAGS = -p -X -XOBJS = sdbm.o pair.o hash.o -XSRCS = sdbm.c pair.c hash.c dbu.c dba.c dbd.c util.c -XHDRS = tune.h sdbm.h pair.h -XMISC = README CHANGES COMPARE sdbm.3 dbe.c dbe.1 dbm.c dbm.h biblio \ -X readme.ms readme.ps -X -Xall: dbu dba dbd dbe -X -Xdbu: dbu.o sdbm util.o -X cc $(LDFLAGS) -o dbu dbu.o util.o libsdbm.a -X -Xdba: dba.o util.o -X cc $(LDFLAGS) -o dba dba.o util.o -Xdbd: dbd.o util.o -X cc $(LDFLAGS) -o dbd dbd.o util.o -Xdbe: dbe.o sdbm -X cc $(LDFLAGS) -o dbe dbe.o libsdbm.a -X -Xsdbm: $(OBJS) -X ar cr libsdbm.a $(OBJS) -X ranlib libsdbm.a -X### cp libsdbm.a /usr/lib/libsdbm.a -X -Xdba.o: sdbm.h -Xdbu.o: sdbm.h -Xutil.o:sdbm.h -X -X$(OBJS): sdbm.h tune.h pair.h -X -X# -X# dbu using berkelezoid ndbm routines [if you have them] for testing -X# -X#x-dbu: dbu.o util.o -X# cc $(CFLAGS) -o x-dbu dbu.o util.o -Xlint: -X lint -abchx $(SRCS) -X -Xclean: -X rm -f *.o mon.out core -X -Xpurge: clean -X rm -f dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag -X -Xshar: -X shar $(MISC) makefile $(SRCS) $(HDRS) >SDBM.SHAR -X -Xreadme: -X nroff -ms readme.ms | col -b >README -END_OF_FILE -if test 1147 -ne `wc -c <'makefile'`; then - echo shar: \"'makefile'\" unpacked with wrong size! -fi -# end of 'makefile' -fi -if test -f 'pair.c' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'pair.c'\" -else -echo shar: Extracting \"'pair.c'\" \(5720 characters\) -sed "s/^X//" >'pair.c' <<'END_OF_FILE' -X/* -X * sdbm - ndbm work-alike hashed database library -X * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). -X * author: oz@nexus.yorku.ca -X * status: public domain. -X * -X * page-level routines -X */ -X -X#ifndef lint -Xstatic char rcsid[] = "$Id: pair.c,v 1.10 90/12/13 13:00:35 oz Exp $"; -X#endif -X -X#include "sdbm.h" -X#include "tune.h" -X#include "pair.h" -X -X#ifndef BSD42 -X#include <memory.h> -X#endif -X -X#define exhash(item) dbm_hash((item).dptr, (item).dsize) -X -X/* -X * forward -X */ -Xstatic int seepair proto((char *, int, char *, int)); -X -X/* -X * page format: -X * +------------------------------+ -X * ino | n | keyoff | datoff | keyoff | -X * +------------+--------+--------+ -X * | datoff | - - - ----> | -X * +--------+---------------------+ -X * | F R E E A R E A | -X * +--------------+---------------+ -X * | <---- - - - | data | -X * +--------+-----+----+----------+ -X * | key | data | key | -X * +--------+----------+----------+ -X * -X * calculating the offsets for free area: if the number -X * of entries (ino[0]) is zero, the offset to the END of -X * the free area is the block size. Otherwise, it is the -X * nth (ino[ino[0]]) entry's offset. -X */ -X -Xint -Xfitpair(pag, need) -Xchar *pag; -Xint need; -X{ -X register int n; -X register int off; -X register int free; -X register short *ino = (short *) pag; -X -X off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ; -X free = off - (n + 1) * sizeof(short); -X need += 2 * sizeof(short); -X -X debug(("free %d need %d\n", free, need)); -X -X return need <= free; -X} -X -Xvoid -Xputpair(pag, key, val) -Xchar *pag; -Xdatum key; -Xdatum val; -X{ -X register int n; -X register int off; -X register short *ino = (short *) pag; -X -X off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ; -X/* -X * enter the key first -X */ -X off -= key.dsize; -X (void) memcpy(pag + off, key.dptr, key.dsize); -X ino[n + 1] = off; -X/* -X * now the data -X */ -X off -= val.dsize; -X (void) memcpy(pag + off, val.dptr, val.dsize); -X ino[n + 2] = off; -X/* -X * adjust item count -X */ -X ino[0] += 2; -X} -X -Xdatum -Xgetpair(pag, key) -Xchar *pag; -Xdatum key; -X{ -X register int i; -X register int n; -X datum val; -X register short *ino = (short *) pag; -X -X if ((n = ino[0]) == 0) -X return nullitem; -X -X if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0) -X return nullitem; -X -X val.dptr = pag + ino[i + 1]; -X val.dsize = ino[i] - ino[i + 1]; -X return val; -X} -X -X#ifdef SEEDUPS -Xint -Xduppair(pag, key) -Xchar *pag; -Xdatum key; -X{ -X register short *ino = (short *) pag; -X return ino[0] > 0 && seepair(pag, ino[0], key.dptr, key.dsize) > 0; -X} -X#endif -X -Xdatum -Xgetnkey(pag, num) -Xchar *pag; -Xint num; -X{ -X datum key; -X register int off; -X register short *ino = (short *) pag; -X -X num = num * 2 - 1; -X if (ino[0] == 0 || num > ino[0]) -X return nullitem; -X -X off = (num > 1) ? ino[num - 1] : PBLKSIZ; -X -X key.dptr = pag + ino[num]; -X key.dsize = off - ino[num]; -X -X return key; -X} -X -Xint -Xdelpair(pag, key) -Xchar *pag; -Xdatum key; -X{ -X register int n; -X register int i; -X register short *ino = (short *) pag; -X -X if ((n = ino[0]) == 0) -X return 0; -X -X if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0) -X return 0; -X/* -X * found the key. if it is the last entry -X * [i.e. i == n - 1] we just adjust the entry count. -X * hard case: move all data down onto the deleted pair, -X * shift offsets onto deleted offsets, and adjust them. -X * [note: 0 < i < n] -X */ -X if (i < n - 1) { -X register int m; -X register char *dst = pag + (i == 1 ? PBLKSIZ : ino[i - 1]); -X register char *src = pag + ino[i + 1]; -X register int zoo = dst - src; -X -X debug(("free-up %d ", zoo)); -X/* -X * shift data/keys down -X */ -X m = ino[i + 1] - ino[n]; -X#ifdef DUFF -X#define MOVB *--dst = *--src -X -X if (m > 0) { -X register int loop = (m + 8 - 1) >> 3; -X -X switch (m & (8 - 1)) { -X case 0: do { -X MOVB; case 7: MOVB; -X case 6: MOVB; case 5: MOVB; -X case 4: MOVB; case 3: MOVB; -X case 2: MOVB; case 1: MOVB; -X } while (--loop); -X } -X } -X#else -X#ifdef MEMMOVE -X memmove(dst, src, m); -X#else -X while (m--) -X *--dst = *--src; -X#endif -X#endif -X/* -X * adjust offset index up -X */ -X while (i < n - 1) { -X ino[i] = ino[i + 2] + zoo; -X i++; -X } -X } -X ino[0] -= 2; -X return 1; -X} -X -X/* -X * search for the key in the page. -X * return offset index in the range 0 < i < n. -X * return 0 if not found. -X */ -Xstatic int -Xseepair(pag, n, key, siz) -Xchar *pag; -Xregister int n; -Xregister char *key; -Xregister int siz; -X{ -X register int i; -X register int off = PBLKSIZ; -X register short *ino = (short *) pag; -X -X for (i = 1; i < n; i += 2) { -X if (siz == off - ino[i] && -X memcmp(key, pag + ino[i], siz) == 0) -X return i; -X off = ino[i + 1]; -X } -X return 0; -X} -X -Xvoid -Xsplpage(pag, new, sbit) -Xchar *pag; -Xchar *new; -Xlong sbit; -X{ -X datum key; -X datum val; -X -X register int n; -X register int off = PBLKSIZ; -X char cur[PBLKSIZ]; -X register short *ino = (short *) cur; -X -X (void) memcpy(cur, pag, PBLKSIZ); -X (void) memset(pag, 0, PBLKSIZ); -X (void) memset(new, 0, PBLKSIZ); -X -X n = ino[0]; -X for (ino++; n > 0; ino += 2) { -X key.dptr = cur + ino[0]; -X key.dsize = off - ino[0]; -X val.dptr = cur + ino[1]; -X val.dsize = ino[0] - ino[1]; -X/* -X * select the page pointer (by looking at sbit) and insert -X */ -X (void) putpair((exhash(key) & sbit) ? new : pag, key, val); -X -X off = ino[1]; -X n -= 2; -X } -X -X debug(("%d split %d/%d\n", ((short *) cur)[0] / 2, -X ((short *) new)[0] / 2, -X ((short *) pag)[0] / 2)); -X} -X -X/* -X * check page sanity: -X * number of entries should be something -X * reasonable, and all offsets in the index should be in order. -X * this could be made more rigorous. -X */ -Xint -Xchkpage(pag) -Xchar *pag; -X{ -X register int n; -X register int off; -X register short *ino = (short *) pag; -X -X if ((n = ino[0]) < 0 || n > PBLKSIZ / sizeof(short)) -X return 0; -X -X if (n > 0) { -X off = PBLKSIZ; -X for (ino++; n > 0; ino += 2) { -X if (ino[0] > off || ino[1] > off || -X ino[1] > ino[0]) -X return 0; -X off = ino[1]; -X n -= 2; -X } -X } -X return 1; -X} -END_OF_FILE -if test 5720 -ne `wc -c <'pair.c'`; then - echo shar: \"'pair.c'\" unpacked with wrong size! -fi -# end of 'pair.c' -fi -if test -f 'pair.h' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'pair.h'\" -else -echo shar: Extracting \"'pair.h'\" \(378 characters\) -sed "s/^X//" >'pair.h' <<'END_OF_FILE' -Xextern int fitpair proto((char *, int)); -Xextern void putpair proto((char *, datum, datum)); -Xextern datum getpair proto((char *, datum)); -Xextern int delpair proto((char *, datum)); -Xextern int chkpage proto((char *)); -Xextern datum getnkey proto((char *, int)); -Xextern void splpage proto((char *, char *, long)); -X#ifdef SEEDUPS -Xextern int duppair proto((char *, datum)); -X#endif -END_OF_FILE -if test 378 -ne `wc -c <'pair.h'`; then - echo shar: \"'pair.h'\" unpacked with wrong size! -fi -# end of 'pair.h' -fi -if test -f 'readme.ms' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'readme.ms'\" -else -echo shar: Extracting \"'readme.ms'\" \(11691 characters\) -sed "s/^X//" >'readme.ms' <<'END_OF_FILE' -X.\" tbl | readme.ms | [tn]roff -ms | ... -X.\" note the "C" (courier) and "CB" fonts: you will probably have to -X.\" change these. -X.\" $Id: readme.ms,v 1.1 90/12/13 13:09:15 oz Exp Locker: oz $ -X -X.de P1 -X.br -X.nr dT 4 -X.nf -X.ft C -X.sp .5 -X.nr t \\n(dT*\\w'x'u -X.ta 1u*\\ntu 2u*\\ntu 3u*\\ntu 4u*\\ntu 5u*\\ntu 6u*\\ntu 7u*\\ntu 8u*\\ntu 9u*\\ntu 10u*\\ntu 11u*\\ntu 12u*\\ntu 13u*\\ntu 14u*\\ntu -X.. -X.de P2 -X.br -X.ft 1 -X.br -X.sp .5 -X.br -X.fi -X.. -X.\" CW uses the typewriter/courier font. -X.de CW -X\fC\\$1\\fP\\$2 -X.. -X -X.\" Footnote numbering [by Henry Spencer] -X.\" <text>\*f for a footnote number.. -X.\" .FS -X.\" \*F <footnote text> -X.\" .FE -X.\" -X.ds f \\u\\s-2\\n+f\\s+2\\d -X.nr f 0 1 -X.ds F \\n+F. -X.nr F 0 1 -X -X.ND -X.LP -X.TL -X\fIsdbm\fP \(em Substitute DBM -X.br -Xor -X.br -XBerkeley \fIndbm\fP for Every UN*X\** Made Simple -X.AU -XOzan (oz) Yigit -X.AI -XThe Guild of PD Software Toolmakers -XToronto - Canada -X.sp -Xoz@nexus.yorku.ca -X.LP -X.FS -XUN*X is not a trademark of any (dis)organization. -X.FE -X.sp 2 -X\fIImplementation is the sincerest form of flattery. \(em L. Peter Deutsch\fP -X.SH -XA The Clone of the \fIndbm\fP library -X.PP -XThe sources accompanying this notice \(em \fIsdbm\fP \(em constitute -Xthe first public release (Dec. 1990) of a complete clone of -Xthe Berkeley UN*X \fIndbm\fP library. The \fIsdbm\fP library is meant to -Xclone the proven functionality of \fIndbm\fP as closely as possible, -Xincluding a few improvements. It is practical, easy to understand, and -Xcompatible. -XThe \fIsdbm\fP library is not derived from any licensed, proprietary or -Xcopyrighted software. -X.PP -XThe \fIsdbm\fP implementation is based on a 1978 algorithm -X[Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''. -XIn the course of searching for a substitute for \fIndbm\fP, I -Xprototyped three different external-hashing algorithms [Lar78, Fag79, Lit80] -Xand ultimately chose Larson's algorithm as a basis of the \fIsdbm\fP -Ximplementation. The Bell Labs -X\fIdbm\fP (and therefore \fIndbm\fP) is based on an algorithm invented by -XKen Thompson, [Tho90, Tor87] and predates Larson's work. -X.PP -XThe \fIsdbm\fR programming interface is totally compatible -Xwith \fIndbm\fP and includes a slight improvement in database initialization. -XIt is also expected to be binary-compatible under most UN*X versions that -Xsupport the \fIndbm\fP library. -X.PP -XThe \fIsdbm\fP implementation shares the shortcomings of the \fIndbm\fP -Xlibrary, as a side effect of various simplifications to the original Larson -Xalgorithm. It does produce \fIholes\fP in the page file as it writes -Xpages past the end of file. (Larson's paper include a clever solution to -Xthis problem that is a result of using the hash value directly as a block -Xaddress.) On the other hand, extensive tests seem to indicate that \fIsdbm\fP -Xcreates fewer holes in general, and the resulting pagefiles are -Xsmaller. The \fIsdbm\fP implementation is also faster than \fIndbm\fP -Xin database creation. -XUnlike the \fIndbm\fP, the \fIsdbm\fP -X.CW store -Xoperation will not ``wander away'' trying to split its -Xdata pages to insert a datum that \fIcannot\fP (due to elaborate worst-case -Xsituations) be inserted. (It will fail after a pre-defined number of attempts.) -X.SH -XImportant Compatibility Warning -X.PP -XThe \fIsdbm\fP and \fIndbm\fP -Xlibraries \fIcannot\fP share databases: one cannot read the (dir/pag) -Xdatabase created by the other. This is due to the differences -Xbetween the \fIndbm\fP and \fIsdbm\fP algorithms\**, -X.FS -XTorek's discussion [Tor87] -Xindicates that \fIdbm/ndbm\fP implementations use the hash -Xvalue to traverse the radix trie differently than \fIsdbm\fP -Xand as a result, the page indexes are generated in \fIdifferent\fP order. -XFor more information, send e-mail to the author. -X.FE -Xand the hash functions -Xused. -XIt is easy to convert between the \fIdbm/ndbm\fP databases and \fIsdbm\fP -Xby ignoring the index completely: see -X.CW dbd , -X.CW dbu -Xetc. -X.R -X.LP -X.SH -XNotice of Intellectual Property -X.LP -X\fIThe entire\fP sdbm \fIlibrary package, as authored by me,\fP Ozan S. Yigit, -X\fIis hereby placed in the public domain.\fP As such, the author is not -Xresponsible for the consequences of use of this software, no matter how -Xawful, even if they arise from defects in it. There is no expressed or -Ximplied warranty for the \fIsdbm\fP library. -X.PP -XSince the \fIsdbm\fP -Xlibrary package is in the public domain, this \fIoriginal\fP -Xrelease or any additional public-domain releases of the modified original -Xcannot possibly (by definition) be withheld from you. Also by definition, -XYou (singular) have all the rights to this code (including the right to -Xsell without permission, the right to hoard\** -X.FS -XYou cannot really hoard something that is available to the public at -Xlarge, but try if it makes you feel any better. -X.FE -Xand the right to do other icky things as -Xyou see fit) but those rights are also granted to everyone else. -X.PP -XPlease note that all previous distributions of this software contained -Xa copyright (which is now dropped) to protect its -Xorigins and its current public domain status against any possible claims -Xand/or challenges. -X.SH -XAcknowledgments -X.PP -XMany people have been very helpful and supportive. A partial list would -Xnecessarily include Rayan Zacherissen (who contributed the man page, -Xand also hacked a MMAP version of \fIsdbm\fP), -XArnold Robbins, Chris Lewis, -XBill Davidsen, Henry Spencer, Geoff Collyer, Rich Salz (who got me started -Xin the first place), Johannes Ruschein -X(who did the minix port) and David Tilbrook. I thank you all. -X.SH -XDistribution Manifest and Notes -X.LP -XThis distribution of \fIsdbm\fP includes (at least) the following: -X.P1 -X CHANGES change log -X README this file. -X biblio a small bibliography on external hashing -X dba.c a crude (n/s)dbm page file analyzer -X dbd.c a crude (n/s)dbm page file dumper (for conversion) -X dbe.1 man page for dbe.c -X dbe.c Janick's database editor -X dbm.c a dbm library emulation wrapper for ndbm/sdbm -X dbm.h header file for the above -X dbu.c a crude db management utility -X hash.c hashing function -X makefile guess. -X pair.c page-level routines (posted earlier) -X pair.h header file for the above -X readme.ms troff source for the README file -X sdbm.3 man page -X sdbm.c the real thing -X sdbm.h header file for the above -X tune.h place for tuning & portability thingies -X util.c miscellaneous -X.P2 -X.PP -X.CW dbu -Xis a simple database manipulation program\** that tries to look -X.FS -XThe -X.CW dbd , -X.CW dba , -X.CW dbu -Xutilities are quick hacks and are not fit for production use. They were -Xdeveloped late one night, just to test out \fIsdbm\fP, and convert some -Xdatabases. -X.FE -Xlike Bell Labs' -X.CW cbt -Xutility. It is currently incomplete in functionality. -XI use -X.CW dbu -Xto test out the routines: it takes (from stdin) tab separated -Xkey/value pairs for commands like -X.CW build -Xor -X.CW insert -Xor takes keys for -Xcommands like -X.CW delete -Xor -X.CW look . -X.P1 -X dbu <build|creat|look|insert|cat|delete> dbmfile -X.P2 -X.PP -X.CW dba -Xis a crude analyzer of \fIdbm/sdbm/ndbm\fP -Xpage files. It scans the entire -Xpage file, reporting page level statistics, and totals at the end. -X.PP -X.CW dbd -Xis a crude dump program for \fIdbm/ndbm/sdbm\fP -Xdatabases. It ignores the -Xbitmap, and dumps the data pages in sequence. It can be used to create -Xinput for the -X.CW dbu -Xutility. -XNote that -X.CW dbd -Xwill skip any NULLs in the key and data -Xfields, thus is unsuitable to convert some peculiar databases that -Xinsist in including the terminating null. -X.PP -XI have also included a copy of the -X.CW dbe -X(\fIndbm\fP DataBase Editor) by Janick Bergeron [janick@bnr.ca] for -Xyour pleasure. You may find it more useful than the little -X.CW dbu -Xutility. -X.PP -X.CW dbm.[ch] -Xis a \fIdbm\fP library emulation on top of \fIndbm\fP -X(and hence suitable for \fIsdbm\fP). Written by Robert Elz. -X.PP -XThe \fIsdbm\fP -Xlibrary has been around in beta test for quite a long time, and from whatever -Xlittle feedback I received (maybe no news is good news), I believe it has been -Xfunctioning without any significant problems. I would, of course, appreciate -Xall fixes and/or improvements. Portability enhancements would especially be -Xuseful. -X.SH -XImplementation Issues -X.PP -XHash functions: -XThe algorithm behind \fIsdbm\fP implementation needs a good bit-scrambling -Xhash function to be effective. I ran into a set of constants for a simple -Xhash function that seem to help \fIsdbm\fP perform better than \fIndbm\fP -Xfor various inputs: -X.P1 -X /* -X * polynomial conversion ignoring overflows -X * 65599 nice. 65587 even better. -X */ -X long -X dbm_hash(char *str, int len) { -X register unsigned long n = 0; -X -X while (len--) -X n = n * 65599 + *str++; -X return n; -X } -X.P2 -X.PP -XThere may be better hash functions for the purposes of dynamic hashing. -XTry your favorite, and check the pagefile. If it contains too many pages -Xwith too many holes, (in relation to this one for example) or if -X\fIsdbm\fP -Xsimply stops working (fails after -X.CW SPLTMAX -Xattempts to split) when you feed your -XNEWS -X.CW history -Xfile to it, you probably do not have a good hashing function. -XIf you do better (for different types of input), I would like to know -Xabout the function you use. -X.PP -XBlock sizes: It seems (from various tests on a few machines) that a page -Xfile block size -X.CW PBLKSIZ -Xof 1024 is by far the best for performance, but -Xthis also happens to limit the size of a key/value pair. Depending on your -Xneeds, you may wish to increase the page size, and also adjust -X.CW PAIRMAX -X(the maximum size of a key/value pair allowed: should always be at least -Xthree words smaller than -X.CW PBLKSIZ .) -Xaccordingly. The system-wide version of the library -Xshould probably be -Xconfigured with 1024 (distribution default), as this appears to be sufficient -Xfor most common uses of \fIsdbm\fP. -X.SH -XPortability -X.PP -XThis package has been tested in many different UN*Xes even including minix, -Xand appears to be reasonably portable. This does not mean it will port -Xeasily to non-UN*X systems. -X.SH -XNotes and Miscellaneous -X.PP -XThe \fIsdbm\fP is not a very complicated package, at least not after you -Xfamiliarize yourself with the literature on external hashing. There are -Xother interesting algorithms in existence that ensure (approximately) -Xsingle-read access to a data value associated with any key. These are -Xdirectory-less schemes such as \fIlinear hashing\fP [Lit80] (+ Larson -Xvariations), \fIspiral storage\fP [Mar79] or directory schemes such as -X\fIextensible hashing\fP [Fag79] by Fagin et al. I do hope these sources -Xprovide a reasonable playground for experimentation with other algorithms. -XSee the June 1988 issue of ACM Computing Surveys [Enb88] for an -Xexcellent overview of the field. -X.PG -X.SH -XReferences -X.LP -X.IP [Lar78] 4m -XP.-A. Larson, -X``Dynamic Hashing'', \fIBIT\fP, vol. 18, pp. 184-201, 1978. -X.IP [Tho90] 4m -XKen Thompson, \fIprivate communication\fP, Nov. 1990 -X.IP [Lit80] 4m -XW. Litwin, -X`` Linear Hashing: A new tool for file and table addressing'', -X\fIProceedings of the 6th Conference on Very Large Dabatases (Montreal)\fP, -Xpp. 212-223, Very Large Database Foundation, Saratoga, Calif., 1980. -X.IP [Fag79] 4m -XR. Fagin, J. Nievergelt, N. Pippinger, and H. R. Strong, -X``Extendible Hashing - A Fast Access Method for Dynamic Files'', -X\fIACM Trans. Database Syst.\fP, vol. 4, no.3, pp. 315-344, Sept. 1979. -X.IP [Wal84] 4m -XRich Wales, -X``Discussion of "dbm" data base system'', \fIUSENET newsgroup unix.wizards\fP, -XJan. 1984. -X.IP [Tor87] 4m -XChris Torek, -X``Re: dbm.a and ndbm.a archives'', \fIUSENET newsgroup comp.unix\fP, -X1987. -X.IP [Mar79] 4m -XG. N. Martin, -X``Spiral Storage: Incrementally Augmentable Hash Addressed Storage'', -X\fITechnical Report #27\fP, University of Varwick, Coventry, U.K., 1979. -X.IP [Enb88] 4m -XR. J. Enbody and H. C. Du, -X``Dynamic Hashing Schemes'',\fIACM Computing Surveys\fP, -Xvol. 20, no. 2, pp. 85-113, June 1988. -END_OF_FILE -if test 11691 -ne `wc -c <'readme.ms'`; then - echo shar: \"'readme.ms'\" unpacked with wrong size! -fi -# end of 'readme.ms' -fi -if test -f 'readme.ps' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'readme.ps'\" -else -echo shar: Extracting \"'readme.ps'\" \(33302 characters\) -sed "s/^X//" >'readme.ps' <<'END_OF_FILE' -X%!PS-Adobe-1.0 -X%%Creator: yetti:oz (Ozan Yigit) -X%%Title: stdin (ditroff) -X%%CreationDate: Thu Dec 13 15:56:08 1990 -X%%EndComments -X% lib/psdit.pro -- prolog for psdit (ditroff) files -X% Copyright (c) 1984, 1985 Adobe Systems Incorporated. All Rights Reserved. -X% last edit: shore Sat Nov 23 20:28:03 1985 -X% RCSID: $Header: psdit.pro,v 2.1 85/11/24 12:19:43 shore Rel $ -X -X/$DITroff 140 dict def $DITroff begin -X/fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def -X/xi {0 72 11 mul translate 72 resolution div dup neg scale 0 0 moveto -X /fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def F -X /pagesave save def}def -X/PB{save /psv exch def currentpoint translate -X resolution 72 div dup neg scale 0 0 moveto}def -X/PE{psv restore}def -X/arctoobig 90 def /arctoosmall .05 def -X/m1 matrix def /m2 matrix def /m3 matrix def /oldmat matrix def -X/tan{dup sin exch cos div}def -X/point{resolution 72 div mul}def -X/dround {transform round exch round exch itransform}def -X/xT{/devname exch def}def -X/xr{/mh exch def /my exch def /resolution exch def}def -X/xp{}def -X/xs{docsave restore end}def -X/xt{}def -X/xf{/fontname exch def /slotno exch def fontnames slotno get fontname eq not -X {fonts slotno fontname findfont put fontnames slotno fontname put}if}def -X/xH{/fontheight exch def F}def -X/xS{/fontslant exch def F}def -X/s{/fontsize exch def /fontheight fontsize def F}def -X/f{/fontnum exch def F}def -X/F{fontheight 0 le {/fontheight fontsize def}if -X fonts fontnum get fontsize point 0 0 fontheight point neg 0 0 m1 astore -X fontslant 0 ne{1 0 fontslant tan 1 0 0 m2 astore m3 concatmatrix}if -X makefont setfont .04 fontsize point mul 0 dround pop setlinewidth}def -X/X{exch currentpoint exch pop moveto show}def -X/N{3 1 roll moveto show}def -X/Y{exch currentpoint pop exch moveto show}def -X/S{show}def -X/ditpush{}def/ditpop{}def -X/AX{3 -1 roll currentpoint exch pop moveto 0 exch ashow}def -X/AN{4 2 roll moveto 0 exch ashow}def -X/AY{3 -1 roll currentpoint pop exch moveto 0 exch ashow}def -X/AS{0 exch ashow}def -X/MX{currentpoint exch pop moveto}def -X/MY{currentpoint pop exch moveto}def -X/MXY{moveto}def -X/cb{pop}def % action on unknown char -- nothing for now -X/n{}def/w{}def -X/p{pop showpage pagesave restore /pagesave save def}def -X/abspoint{currentpoint exch pop add exch currentpoint pop add exch}def -X/distance{dup mul exch dup mul add sqrt}def -X/dstroke{currentpoint stroke moveto}def -X/Dl{2 copy gsave rlineto stroke grestore rmoveto}def -X/arcellipse{/diamv exch def /diamh exch def oldmat currentmatrix pop -X currentpoint translate 1 diamv diamh div scale /rad diamh 2 div def -X currentpoint exch rad add exch rad -180 180 arc oldmat setmatrix}def -X/Dc{dup arcellipse dstroke}def -X/De{arcellipse dstroke}def -X/Da{/endv exch def /endh exch def /centerv exch def /centerh exch def -X /cradius centerv centerv mul centerh centerh mul add sqrt def -X /eradius endv endv mul endh endh mul add sqrt def -X /endang endv endh atan def -X /startang centerv neg centerh neg atan def -X /sweep startang endang sub dup 0 lt{360 add}if def -X sweep arctoobig gt -X {/midang startang sweep 2 div sub def /midrad cradius eradius add 2 div def -X /midh midang cos midrad mul def /midv midang sin midrad mul def -X midh neg midv neg endh endv centerh centerv midh midv Da -X currentpoint moveto Da} -X {sweep arctoosmall ge -X {/controldelt 1 sweep 2 div cos sub 3 sweep 2 div sin mul div 4 mul def -X centerv neg controldelt mul centerh controldelt mul -X endv neg controldelt mul centerh add endh add -X endh controldelt mul centerv add endv add -X centerh endh add centerv endv add rcurveto dstroke} -X {centerh endh add centerv endv add rlineto dstroke}ifelse}ifelse}def -X -X/Barray 200 array def % 200 values in a wiggle -X/D~{mark}def -X/D~~{counttomark Barray exch 0 exch getinterval astore /Bcontrol exch def pop -X /Blen Bcontrol length def Blen 4 ge Blen 2 mod 0 eq and -X {Bcontrol 0 get Bcontrol 1 get abspoint /Ycont exch def /Xcont exch def -X Bcontrol 0 2 copy get 2 mul put Bcontrol 1 2 copy get 2 mul put -X Bcontrol Blen 2 sub 2 copy get 2 mul put -X Bcontrol Blen 1 sub 2 copy get 2 mul put -X /Ybi /Xbi currentpoint 3 1 roll def def 0 2 Blen 4 sub -X {/i exch def -X Bcontrol i get 3 div Bcontrol i 1 add get 3 div -X Bcontrol i get 3 mul Bcontrol i 2 add get add 6 div -X Bcontrol i 1 add get 3 mul Bcontrol i 3 add get add 6 div -X /Xbi Xcont Bcontrol i 2 add get 2 div add def -X /Ybi Ycont Bcontrol i 3 add get 2 div add def -X /Xcont Xcont Bcontrol i 2 add get add def -X /Ycont Ycont Bcontrol i 3 add get add def -X Xbi currentpoint pop sub Ybi currentpoint exch pop sub rcurveto -X }for dstroke}if}def -Xend -X/ditstart{$DITroff begin -X /nfonts 60 def % NFONTS makedev/ditroff dependent! -X /fonts[nfonts{0}repeat]def -X /fontnames[nfonts{()}repeat]def -X/docsave save def -X}def -X -X% character outcalls -X/oc {/pswid exch def /cc exch def /name exch def -X /ditwid pswid fontsize mul resolution mul 72000 div def -X /ditsiz fontsize resolution mul 72 div def -X ocprocs name known{ocprocs name get exec}{name cb} -X ifelse}def -X/fractm [.65 0 0 .6 0 0] def -X/fraction -X {/fden exch def /fnum exch def gsave /cf currentfont def -X cf fractm makefont setfont 0 .3 dm 2 copy neg rmoveto -X fnum show rmoveto currentfont cf setfont(\244)show setfont fden show -X grestore ditwid 0 rmoveto} def -X/oce {grestore ditwid 0 rmoveto}def -X/dm {ditsiz mul}def -X/ocprocs 50 dict def ocprocs begin -X(14){(1)(4)fraction}def -X(12){(1)(2)fraction}def -X(34){(3)(4)fraction}def -X(13){(1)(3)fraction}def -X(23){(2)(3)fraction}def -X(18){(1)(8)fraction}def -X(38){(3)(8)fraction}def -X(58){(5)(8)fraction}def -X(78){(7)(8)fraction}def -X(sr){gsave 0 .06 dm rmoveto(\326)show oce}def -X(is){gsave 0 .15 dm rmoveto(\362)show oce}def -X(->){gsave 0 .02 dm rmoveto(\256)show oce}def -X(<-){gsave 0 .02 dm rmoveto(\254)show oce}def -X(==){gsave 0 .05 dm rmoveto(\272)show oce}def -Xend -X -X% an attempt at a PostScript FONT to implement ditroff special chars -X% this will enable us to -X% cache the little buggers -X% generate faster, more compact PS out of psdit -X% confuse everyone (including myself)! -X50 dict dup begin -X/FontType 3 def -X/FontName /DIThacks def -X/FontMatrix [.001 0 0 .001 0 0] def -X/FontBBox [-260 -260 900 900] def% a lie but ... -X/Encoding 256 array def -X0 1 255{Encoding exch /.notdef put}for -XEncoding -X dup 8#040/space put %space -X dup 8#110/rc put %right ceil -X dup 8#111/lt put %left top curl -X dup 8#112/bv put %bold vert -X dup 8#113/lk put %left mid curl -X dup 8#114/lb put %left bot curl -X dup 8#115/rt put %right top curl -X dup 8#116/rk put %right mid curl -X dup 8#117/rb put %right bot curl -X dup 8#120/rf put %right floor -X dup 8#121/lf put %left floor -X dup 8#122/lc put %left ceil -X dup 8#140/sq put %square -X dup 8#141/bx put %box -X dup 8#142/ci put %circle -X dup 8#143/br put %box rule -X dup 8#144/rn put %root extender -X dup 8#145/vr put %vertical rule -X dup 8#146/ob put %outline bullet -X dup 8#147/bu put %bullet -X dup 8#150/ru put %rule -X dup 8#151/ul put %underline -X pop -X/DITfd 100 dict def -X/BuildChar{0 begin -X /cc exch def /fd exch def -X /charname fd /Encoding get cc get def -X /charwid fd /Metrics get charname get def -X /charproc fd /CharProcs get charname get def -X charwid 0 fd /FontBBox get aload pop setcachedevice -X 2 setlinejoin 40 setlinewidth -X newpath 0 0 moveto gsave charproc grestore -X end}def -X/BuildChar load 0 DITfd put -X%/UniqueID 5 def -X/CharProcs 50 dict def -XCharProcs begin -X/space{}def -X/.notdef{}def -X/ru{500 0 rls}def -X/rn{0 840 moveto 500 0 rls}def -X/vr{0 800 moveto 0 -770 rls}def -X/bv{0 800 moveto 0 -1000 rls}def -X/br{0 750 moveto 0 -1000 rls}def -X/ul{0 -140 moveto 500 0 rls}def -X/ob{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath stroke}def -X/bu{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath fill}def -X/sq{80 0 rmoveto currentpoint dround newpath moveto -X 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath stroke}def -X/bx{80 0 rmoveto currentpoint dround newpath moveto -X 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath fill}def -X/ci{500 360 rmoveto currentpoint newpath 333 0 360 arc -X 50 setlinewidth stroke}def -X -X/lt{0 -200 moveto 0 550 rlineto currx 800 2cx s4 add exch s4 a4p stroke}def -X/lb{0 800 moveto 0 -550 rlineto currx -200 2cx s4 add exch s4 a4p stroke}def -X/rt{0 -200 moveto 0 550 rlineto currx 800 2cx s4 sub exch s4 a4p stroke}def -X/rb{0 800 moveto 0 -500 rlineto currx -200 2cx s4 sub exch s4 a4p stroke}def -X/lk{0 800 moveto 0 300 -300 300 s4 arcto pop pop 1000 sub -X 0 300 4 2 roll s4 a4p 0 -200 lineto stroke}def -X/rk{0 800 moveto 0 300 s2 300 s4 arcto pop pop 1000 sub -X 0 300 4 2 roll s4 a4p 0 -200 lineto stroke}def -X/lf{0 800 moveto 0 -1000 rlineto s4 0 rls}def -X/rf{0 800 moveto 0 -1000 rlineto s4 neg 0 rls}def -X/lc{0 -200 moveto 0 1000 rlineto s4 0 rls}def -X/rc{0 -200 moveto 0 1000 rlineto s4 neg 0 rls}def -Xend -X -X/Metrics 50 dict def Metrics begin -X/.notdef 0 def -X/space 500 def -X/ru 500 def -X/br 0 def -X/lt 416 def -X/lb 416 def -X/rt 416 def -X/rb 416 def -X/lk 416 def -X/rk 416 def -X/rc 416 def -X/lc 416 def -X/rf 416 def -X/lf 416 def -X/bv 416 def -X/ob 350 def -X/bu 350 def -X/ci 750 def -X/bx 750 def -X/sq 750 def -X/rn 500 def -X/ul 500 def -X/vr 0 def -Xend -X -XDITfd begin -X/s2 500 def /s4 250 def /s3 333 def -X/a4p{arcto pop pop pop pop}def -X/2cx{2 copy exch}def -X/rls{rlineto stroke}def -X/currx{currentpoint pop}def -X/dround{transform round exch round exch itransform} def -Xend -Xend -X/DIThacks exch definefont pop -Xditstart -X(psc)xT -X576 1 1 xr -X1(Times-Roman)xf 1 f -X2(Times-Italic)xf 2 f -X3(Times-Bold)xf 3 f -X4(Times-BoldItalic)xf 4 f -X5(Helvetica)xf 5 f -X6(Helvetica-Bold)xf 6 f -X7(Courier)xf 7 f -X8(Courier-Bold)xf 8 f -X9(Symbol)xf 9 f -X10(DIThacks)xf 10 f -X10 s -X1 f -Xxi -X%%EndProlog -X -X%%Page: 1 1 -X10 s 0 xH 0 xS 1 f -X8 s -X2 f -X12 s -X1778 672(sdbm)N -X3 f -X2004(\320)X -X2124(Substitute)X -X2563(DBM)X -X2237 768(or)N -X1331 864(Berkeley)N -X2 f -X1719(ndbm)X -X3 f -X1956(for)X -X2103(Every)X -X2373(UN*X)X -X1 f -X10 s -X2628 832(1)N -X3 f -X12 s -X2692 864(Made)N -X2951(Simple)X -X2 f -X10 s -X2041 1056(Ozan)N -X2230(\(oz\))X -X2375(Yigit)X -X1 f -X1658 1200(The)N -X1803(Guild)X -X2005(of)X -X2092(PD)X -X2214(Software)X -X2524(Toolmakers)X -X2000 1296(Toronto)N -X2278(-)X -X2325(Canada)X -X1965 1488(oz@nexus.yorku.ca)N -X2 f -X555 1804(Implementation)N -X1078(is)X -X1151(the)X -X1269(sincerest)X -X1574(form)X -X1745(of)X -X1827(\257attery.)X -X2094(\320)X -X2185(L.)X -X2269(Peter)X -X2463(Deutsch)X -X3 f -X555 1996(A)N -X633(The)X -X786(Clone)X -X1006(of)X -X1093(the)X -X2 f -X1220(ndbm)X -X3 f -X1418(library)X -X1 f -X755 2120(The)N -X903(sources)X -X1167(accompanying)X -X1658(this)X -X1796(notice)X -X2015(\320)X -X2 f -X2118(sdbm)X -X1 f -X2309(\320)X -X2411(constitute)X -X2744(the)X -X2864(\256rst)X -X3010(public)X -X3232(release)X -X3478(\(Dec.)X -X3677(1990\))X -X3886(of)X -X3975(a)X -X555 2216(complete)N -X874(clone)X -X1073(of)X -X1165(the)X -X1288(Berkeley)X -X1603(UN*X)X -X2 f -X1842(ndbm)X -X1 f -X2045(library.)X -X2304(The)X -X2 f -X2454(sdbm)X -X1 f -X2648(library)X -X2887(is)X -X2965(meant)X -X3186(to)X -X3273(clone)X -X3472(the)X -X3594(proven)X -X3841(func-)X -X555 2312(tionality)N -X846(of)X -X2 f -X938(ndbm)X -X1 f -X1141(as)X -X1233(closely)X -X1485(as)X -X1576(possible,)X -X1882(including)X -X2208(a)X -X2268(few)X -X2413(improvements.)X -X2915(It)X -X2988(is)X -X3065(practical,)X -X3386(easy)X -X3553(to)X -X3639(understand,)X -X555 2408(and)N -X691(compatible.)X -X1107(The)X -X2 f -X1252(sdbm)X -X1 f -X1441(library)X -X1675(is)X -X1748(not)X -X1870(derived)X -X2131(from)X -X2307(any)X -X2443(licensed,)X -X2746(proprietary)X -X3123(or)X -X3210(copyrighted)X -X3613(software.)X -X755 2532(The)N -X2 f -X910(sdbm)X -X1 f -X1109(implementation)X -X1641(is)X -X1723(based)X -X1935(on)X -X2044(a)X -X2109(1978)X -X2298(algorithm)X -X2638([Lar78])X -X2913(by)X -X3022(P.-A.)X -X3220(\(Paul\))X -X3445(Larson)X -X3697(known)X -X3944(as)X -X555 2628(``Dynamic)N -X934(Hashing''.)X -X1326(In)X -X1424(the)X -X1553(course)X -X1794(of)X -X1892(searching)X -X2231(for)X -X2355(a)X -X2421(substitute)X -X2757(for)X -X2 f -X2881(ndbm)X -X1 f -X3059(,)X -X3109(I)X -X3166(prototyped)X -X3543(three)X -X3734(different)X -X555 2724(external-hashing)N -X1119(algorithms)X -X1490([Lar78,)X -X1758(Fag79,)X -X2007(Lit80])X -X2236(and)X -X2381(ultimately)X -X2734(chose)X -X2946(Larson's)X -X3256(algorithm)X -X3596(as)X -X3692(a)X -X3756(basis)X -X3944(of)X -X555 2820(the)N -X2 f -X680(sdbm)X -X1 f -X875(implementation.)X -X1423(The)X -X1574(Bell)X -X1733(Labs)X -X2 f -X1915(dbm)X -X1 f -X2079(\(and)X -X2248(therefore)X -X2 f -X2565(ndbm)X -X1 f -X2743(\))X -X2796(is)X -X2875(based)X -X3084(on)X -X3190(an)X -X3292(algorithm)X -X3629(invented)X -X3931(by)X -X555 2916(Ken)N -X709(Thompson,)X -X1091([Tho90,)X -X1367(Tor87])X -X1610(and)X -X1746(predates)X -X2034(Larson's)X -X2335(work.)X -X755 3040(The)N -X2 f -X903(sdbm)X -X1 f -X1095(programming)X -X1553(interface)X -X1857(is)X -X1932(totally)X -X2158(compatible)X -X2536(with)X -X2 f -X2700(ndbm)X -X1 f -X2900(and)X -X3038(includes)X -X3327(a)X -X3385(slight)X -X3584(improvement)X -X555 3136(in)N -X641(database)X -X942(initialization.)X -X1410(It)X -X1483(is)X -X1560(also)X -X1713(expected)X -X2023(to)X -X2109(be)X -X2208(binary-compatible)X -X2819(under)X -X3025(most)X -X3203(UN*X)X -X3440(versions)X -X3730(that)X -X3873(sup-)X -X555 3232(port)N -X704(the)X -X2 f -X822(ndbm)X -X1 f -X1020(library.)X -X755 3356(The)N -X2 f -X909(sdbm)X -X1 f -X1107(implementation)X -X1638(shares)X -X1868(the)X -X1995(shortcomings)X -X2455(of)X -X2551(the)X -X2 f -X2678(ndbm)X -X1 f -X2885(library,)X -X3148(as)X -X3244(a)X -X3309(side)X -X3467(effect)X -X3680(of)X -X3775(various)X -X555 3452(simpli\256cations)N -X1046(to)X -X1129(the)X -X1248(original)X -X1518(Larson)X -X1762(algorithm.)X -X2114(It)X -X2183(does)X -X2350(produce)X -X2 f -X2629(holes)X -X1 f -X2818(in)X -X2900(the)X -X3018(page)X -X3190(\256le)X -X3312(as)X -X3399(it)X -X3463(writes)X -X3679(pages)X -X3882(past)X -X555 3548(the)N -X680(end)X -X823(of)X -X917(\256le.)X -X1066(\(Larson's)X -X1400(paper)X -X1605(include)X -X1867(a)X -X1929(clever)X -X2152(solution)X -X2435(to)X -X2523(this)X -X2664(problem)X -X2957(that)X -X3103(is)X -X3182(a)X -X3244(result)X -X3448(of)X -X3541(using)X -X3740(the)X -X3864(hash)X -X555 3644(value)N -X758(directly)X -X1032(as)X -X1128(a)X -X1193(block)X -X1400(address.\))X -X1717(On)X -X1844(the)X -X1971(other)X -X2165(hand,)X -X2370(extensive)X -X2702(tests)X -X2873(seem)X -X3067(to)X -X3158(indicate)X -X3441(that)X -X2 f -X3590(sdbm)X -X1 f -X3787(creates)X -X555 3740(fewer)N -X762(holes)X -X954(in)X -X1039(general,)X -X1318(and)X -X1456(the)X -X1576(resulting)X -X1878(page\256les)X -X2185(are)X -X2306(smaller.)X -X2584(The)X -X2 f -X2731(sdbm)X -X1 f -X2922(implementation)X -X3446(is)X -X3521(also)X -X3672(faster)X -X3873(than)X -X2 f -X555 3836(ndbm)N -X1 f -X757(in)X -X843(database)X -X1144(creation.)X -X1467(Unlike)X -X1709(the)X -X2 f -X1831(ndbm)X -X1 f -X2009(,)X -X2053(the)X -X2 f -X2175(sdbm)X -X7 f -X2396(store)X -X1 f -X2660(operation)X -X2987(will)X -X3134(not)X -X3259(``wander)X -X3573(away'')X -X3820(trying)X -X555 3932(to)N -X642(split)X -X804(its)X -X904(data)X -X1063(pages)X -X1271(to)X -X1358(insert)X -X1561(a)X -X1622(datum)X -X1847(that)X -X2 f -X1992(cannot)X -X1 f -X2235(\(due)X -X2403(to)X -X2490(elaborate)X -X2810(worst-case)X -X3179(situations\))X -X3537(be)X -X3637(inserted.)X -X3935(\(It)X -X555 4028(will)N -X699(fail)X -X826(after)X -X994(a)X -X1050(pre-de\256ned)X -X1436(number)X -X1701(of)X -X1788(attempts.\))X -X3 f -X555 4220(Important)N -X931(Compatibility)X -X1426(Warning)X -X1 f -X755 4344(The)N -X2 f -X904(sdbm)X -X1 f -X1097(and)X -X2 f -X1237(ndbm)X -X1 f -X1439(libraries)X -X2 f -X1726(cannot)X -X1 f -X1968(share)X -X2162(databases:)X -X2515(one)X -X2654(cannot)X -X2891(read)X -X3053(the)X -X3174(\(dir/pag\))X -X3478(database)X -X3778(created)X -X555 4440(by)N -X657(the)X -X777(other.)X -X984(This)X -X1148(is)X -X1222(due)X -X1359(to)X -X1442(the)X -X1561(differences)X -X1940(between)X -X2229(the)X -X2 f -X2348(ndbm)X -X1 f -X2547(and)X -X2 f -X2684(sdbm)X -X1 f -X2874(algorithms)X -X8 s -X3216 4415(2)N -X10 s -X4440(,)Y -X3289(and)X -X3426(the)X -X3545(hash)X -X3713(functions)X -X555 4536(used.)N -X769(It)X -X845(is)X -X925(easy)X -X1094(to)X -X1182(convert)X -X1449(between)X -X1743(the)X -X2 f -X1867(dbm/ndbm)X -X1 f -X2231(databases)X -X2565(and)X -X2 f -X2707(sdbm)X -X1 f -X2902(by)X -X3008(ignoring)X -X3305(the)X -X3429(index)X -X3633(completely:)X -X555 4632(see)N -X7 f -X706(dbd)X -X1 f -X(,)S -X7 f -X918(dbu)X -X1 f -X1082(etc.)X -X3 f -X555 4852(Notice)N -X794(of)X -X881(Intellectual)X -X1288(Property)X -X2 f -X555 4976(The)N -X696(entire)X -X1 f -X904(sdbm)X -X2 f -X1118(library)X -X1361(package,)X -X1670(as)X -X1762(authored)X -X2072(by)X -X2169(me,)X -X1 f -X2304(Ozan)X -X2495(S.)X -X2580(Yigit,)X -X2 f -X2785(is)X -X2858(hereby)X -X3097(placed)X -X3331(in)X -X3413(the)X -X3531(public)X -X3751(domain.)X -X1 f -X555 5072(As)N -X670(such,)X -X863(the)X -X987(author)X -X1218(is)X -X1297(not)X -X1425(responsible)X -X1816(for)X -X1936(the)X -X2060(consequences)X -X2528(of)X -X2621(use)X -X2754(of)X -X2847(this)X -X2988(software,)X -X3310(no)X -X3415(matter)X -X3645(how)X -X3808(awful,)X -X555 5168(even)N -X727(if)X -X796(they)X -X954(arise)X -X1126(from)X -X1302(defects)X -X1550(in)X -X1632(it.)X -X1716(There)X -X1924(is)X -X1997(no)X -X2097(expressed)X -X2434(or)X -X2521(implied)X -X2785(warranty)X -X3091(for)X -X3205(the)X -X2 f -X3323(sdbm)X -X1 f -X3512(library.)X -X8 s -X10 f -X555 5316(hhhhhhhhhhhhhhhhhh)N -X6 s -X1 f -X635 5391(1)N -X8 s -X691 5410(UN*X)N -X877(is)X -X936(not)X -X1034(a)X -X1078(trademark)X -X1352(of)X -X1421(any)X -X1529(\(dis\)organization.)X -X6 s -X635 5485(2)N -X8 s -X691 5504(Torek's)N -X908(discussion)X -X1194([Tor87])X -X1411(indicates)X -X1657(that)X -X2 f -X1772(dbm/ndbm)X -X1 f -X2061(implementations)X -X2506(use)X -X2609(the)X -X2705(hash)X -X2840(value)X -X2996(to)X -X3064(traverse)X -X3283(the)X -X3379(radix)X -X3528(trie)X -X3631(dif-)X -X555 5584(ferently)N -X772(than)X -X2 f -X901(sdbm)X -X1 f -X1055(and)X -X1166(as)X -X1238(a)X -X1285(result,)X -X1462(the)X -X1559(page)X -X1698(indexes)X -X1912(are)X -X2008(generated)X -X2274(in)X -X2 f -X2343(different)X -X1 f -X2579(order.)X -X2764(For)X -X2872(more)X -X3021(information,)X -X3357(send)X -X3492(e-mail)X -X3673(to)X -X555 5664(the)N -X649(author.)X -X -X2 p -X%%Page: 2 2 -X8 s 0 xH 0 xS 1 f -X10 s -X2216 384(-)N -X2263(2)X -X2323(-)X -X755 672(Since)N -X971(the)X -X2 f -X1107(sdbm)X -X1 f -X1314(library)X -X1566(package)X -X1868(is)X -X1959(in)X -X2058(the)X -X2193(public)X -X2430(domain,)X -X2727(this)X -X2 f -X2879(original)X -X1 f -X3173(release)X -X3434(or)X -X3538(any)X -X3691(additional)X -X555 768(public-domain)N -X1045(releases)X -X1323(of)X -X1413(the)X -X1534(modi\256ed)X -X1841(original)X -X2112(cannot)X -X2348(possibly)X -X2636(\(by)X -X2765(de\256nition\))X -X3120(be)X -X3218(withheld)X -X3520(from)X -X3698(you.)X -X3860(Also)X -X555 864(by)N -X659(de\256nition,)X -X1009(You)X -X1170(\(singular\))X -X1505(have)X -X1680(all)X -X1783(the)X -X1904(rights)X -X2109(to)X -X2194(this)X -X2332(code)X -X2507(\(including)X -X2859(the)X -X2980(right)X -X3154(to)X -X3239(sell)X -X3373(without)X -X3640(permission,)X -X555 960(the)N -X679(right)X -X856(to)X -X944(hoard)X -X8 s -X1127 935(3)N -X10 s -X1185 960(and)N -X1327(the)X -X1451(right)X -X1628(to)X -X1716(do)X -X1821(other)X -X2011(icky)X -X2174(things)X -X2394(as)X -X2486(you)X -X2631(see)X -X2759(\256t\))X -X2877(but)X -X3004(those)X -X3198(rights)X -X3405(are)X -X3529(also)X -X3683(granted)X -X3949(to)X -X555 1056(everyone)N -X870(else.)X -X755 1180(Please)N -X997(note)X -X1172(that)X -X1329(all)X -X1446(previous)X -X1759(distributions)X -X2195(of)X -X2298(this)X -X2449(software)X -X2762(contained)X -X3110(a)X -X3182(copyright)X -X3525(\(which)X -X3784(is)X -X3873(now)X -X555 1276(dropped\))N -X868(to)X -X953(protect)X -X1199(its)X -X1297(origins)X -X1542(and)X -X1681(its)X -X1779(current)X -X2030(public)X -X2253(domain)X -X2516(status)X -X2721(against)X -X2970(any)X -X3108(possible)X -X3392(claims)X -X3623(and/or)X -X3850(chal-)X -X555 1372(lenges.)N -X3 f -X555 1564(Acknowledgments)N -X1 f -X755 1688(Many)N -X966(people)X -X1204(have)X -X1380(been)X -X1556(very)X -X1723(helpful)X -X1974(and)X -X2114(supportive.)X -X2515(A)X -X2596(partial)X -X2824(list)X -X2944(would)X -X3167(necessarily)X -X3547(include)X -X3806(Rayan)X -X555 1784(Zacherissen)N -X963(\(who)X -X1152(contributed)X -X1541(the)X -X1663(man)X -X1824(page,)X -X2019(and)X -X2158(also)X -X2310(hacked)X -X2561(a)X -X2620(MMAP)X -X2887(version)X -X3146(of)X -X2 f -X3236(sdbm)X -X1 f -X3405(\),)X -X3475(Arnold)X -X3725(Robbins,)X -X555 1880(Chris)N -X763(Lewis,)X -X1013(Bill)X -X1166(Davidsen,)X -X1523(Henry)X -X1758(Spencer,)X -X2071(Geoff)X -X2293(Collyer,)X -X2587(Rich)X -X2772(Salz)X -X2944(\(who)X -X3143(got)X -X3279(me)X -X3411(started)X -X3659(in)X -X3755(the)X -X3887(\256rst)X -X555 1976(place\),)N -X792(Johannes)X -X1106(Ruschein)X -X1424(\(who)X -X1609(did)X -X1731(the)X -X1849(minix)X -X2055(port\))X -X2231(and)X -X2367(David)X -X2583(Tilbrook.)X -X2903(I)X -X2950(thank)X -X3148(you)X -X3288(all.)X -X3 f -X555 2168(Distribution)N -X992(Manifest)X -X1315(and)X -X1463(Notes)X -X1 f -X555 2292(This)N -X717(distribution)X -X1105(of)X -X2 f -X1192(sdbm)X -X1 f -X1381(includes)X -X1668(\(at)X -X1773(least\))X -X1967(the)X -X2085(following:)X -X7 f -X747 2436(CHANGES)N -X1323(change)X -X1659(log)X -X747 2532(README)N -X1323(this)X -X1563(file.)X -X747 2628(biblio)N -X1323(a)X -X1419(small)X -X1707(bibliography)X -X2331(on)X -X2475(external)X -X2907(hashing)X -X747 2724(dba.c)N -X1323(a)X -X1419(crude)X -X1707(\(n/s\)dbm)X -X2139(page)X -X2379(file)X -X2619(analyzer)X -X747 2820(dbd.c)N -X1323(a)X -X1419(crude)X -X1707(\(n/s\)dbm)X -X2139(page)X -X2379(file)X -X2619(dumper)X -X2955(\(for)X -X3195(conversion\))X -X747 2916(dbe.1)N -X1323(man)X -X1515(page)X -X1755(for)X -X1947(dbe.c)X -X747 3012(dbe.c)N -X1323(Janick's)X -X1755(database)X -X2187(editor)X -X747 3108(dbm.c)N -X1323(a)X -X1419(dbm)X -X1611(library)X -X1995(emulation)X -X2475(wrapper)X -X2859(for)X -X3051(ndbm/sdbm)X -X747 3204(dbm.h)N -X1323(header)X -X1659(file)X -X1899(for)X -X2091(the)X -X2283(above)X -X747 3300(dbu.c)N -X1323(a)X -X1419(crude)X -X1707(db)X -X1851(management)X -X2379(utility)X -X747 3396(hash.c)N -X1323(hashing)X -X1707(function)X -X747 3492(makefile)N -X1323(guess.)X -X747 3588(pair.c)N -X1323(page-level)X -X1851(routines)X -X2283(\(posted)X -X2667(earlier\))X -X747 3684(pair.h)N -X1323(header)X -X1659(file)X -X1899(for)X -X2091(the)X -X2283(above)X -X747 3780(readme.ms)N -X1323(troff)X -X1611(source)X -X1947(for)X -X2139(the)X -X2331(README)X -X2667(file)X -X747 3876(sdbm.3)N -X1323(man)X -X1515(page)X -X747 3972(sdbm.c)N -X1323(the)X -X1515(real)X -X1755(thing)X -X747 4068(sdbm.h)N -X1323(header)X -X1659(file)X -X1899(for)X -X2091(the)X -X2283(above)X -X747 4164(tune.h)N -X1323(place)X -X1611(for)X -X1803(tuning)X -X2139(&)X -X2235(portability)X -X2811(thingies)X -X747 4260(util.c)N -X1323(miscellaneous)X -X755 4432(dbu)N -X1 f -X924(is)X -X1002(a)X -X1063(simple)X -X1301(database)X -X1603(manipulation)X -X2050(program)X -X8 s -X2322 4407(4)N -X10 s -X2379 4432(that)N -X2524(tries)X -X2687(to)X -X2774(look)X -X2941(like)X -X3086(Bell)X -X3244(Labs')X -X7 f -X3480(cbt)X -X1 f -X3649(utility.)X -X3884(It)X -X3958(is)X -X555 4528(currently)N -X867(incomplete)X -X1245(in)X -X1329(functionality.)X -X1800(I)X -X1849(use)X -X7 f -X2006(dbu)X -X1 f -X2172(to)X -X2255(test)X -X2387(out)X -X2510(the)X -X2629(routines:)X -X2930(it)X -X2995(takes)X -X3181(\(from)X -X3385(stdin\))X -X3588(tab)X -X3707(separated)X -X555 4624(key/value)N -X898(pairs)X -X1085(for)X -X1210(commands)X -X1587(like)X -X7 f -X1765(build)X -X1 f -X2035(or)X -X7 f -X2160(insert)X -X1 f -X2478(or)X -X2575(takes)X -X2770(keys)X -X2947(for)X -X3071(commands)X -X3448(like)X -X7 f -X3626(delete)X -X1 f -X3944(or)X -X7 f -X555 4720(look)N -X1 f -X(.)S -X7 f -X747 4864(dbu)N -X939(<build|creat|look|insert|cat|delete>)X -X2715(dbmfile)X -X755 5036(dba)N -X1 f -X927(is)X -X1008(a)X -X1072(crude)X -X1279(analyzer)X -X1580(of)X -X2 f -X1675(dbm/sdbm/ndbm)X -X1 f -X2232(page)X -X2412(\256les.)X -X2593(It)X -X2670(scans)X -X2872(the)X -X2998(entire)X -X3209(page)X -X3389(\256le,)X -X3538(reporting)X -X3859(page)X -X555 5132(level)N -X731(statistics,)X -X1046(and)X -X1182(totals)X -X1375(at)X -X1453(the)X -X1571(end.)X -X7 f -X755 5256(dbd)N -X1 f -X925(is)X -X1004(a)X -X1066(crude)X -X1271(dump)X -X1479(program)X -X1777(for)X -X2 f -X1897(dbm/ndbm/sdbm)X -X1 f -X2452(databases.)X -X2806(It)X -X2881(ignores)X -X3143(the)X -X3267(bitmap,)X -X3534(and)X -X3675(dumps)X -X3913(the)X -X555 5352(data)N -X717(pages)X -X928(in)X -X1018(sequence.)X -X1361(It)X -X1437(can)X -X1576(be)X -X1679(used)X -X1853(to)X -X1942(create)X -X2162(input)X -X2353(for)X -X2474(the)X -X7 f -X2627(dbu)X -X1 f -X2798(utility.)X -X3055(Note)X -X3238(that)X -X7 f -X3413(dbd)X -X1 f -X3584(will)X -X3735(skip)X -X3895(any)X -X8 s -X10 f -X555 5432(hhhhhhhhhhhhhhhhhh)N -X6 s -X1 f -X635 5507(3)N -X8 s -X691 5526(You)N -X817(cannot)X -X1003(really)X -X1164(hoard)X -X1325(something)X -X1608(that)X -X1720(is)X -X1779(available)X -X2025(to)X -X2091(the)X -X2185(public)X -X2361(at)X -X2423(large,)X -X2582(but)X -X2680(try)X -X2767(if)X -X2822(it)X -X2874(makes)X -X3053(you)X -X3165(feel)X -X3276(any)X -X3384(better.)X -X6 s -X635 5601(4)N -X8 s -X691 5620(The)N -X7 f -X829(dbd)X -X1 f -X943(,)X -X7 f -X998(dba)X -X1 f -X1112(,)X -X7 f -X1167(dbu)X -X1 f -X1298(utilities)X -X1508(are)X -X1602(quick)X -X1761(hacks)X -X1923(and)X -X2032(are)X -X2126(not)X -X2225(\256t)X -X2295(for)X -X2385(production)X -X2678(use.)X -X2795(They)X -X2942(were)X -X3081(developed)X -X3359(late)X -X3467(one)X -X3575(night,)X -X555 5700(just)N -X664(to)X -X730(test)X -X835(out)X -X2 f -X933(sdbm)X -X1 f -X1068(,)X -X1100(and)X -X1208(convert)X -X1415(some)X -X1566(databases.)X -X -X3 p -X%%Page: 3 3 -X8 s 0 xH 0 xS 1 f -X10 s -X2216 384(-)N -X2263(3)X -X2323(-)X -X555 672(NULLs)N -X821(in)X -X903(the)X -X1021(key)X -X1157(and)X -X1293(data)X -X1447(\256elds,)X -X1660(thus)X -X1813(is)X -X1886(unsuitable)X -X2235(to)X -X2317(convert)X -X2578(some)X -X2767(peculiar)X -X3046(databases)X -X3374(that)X -X3514(insist)X -X3702(in)X -X3784(includ-)X -X555 768(ing)N -X677(the)X -X795(terminating)X -X1184(null.)X -X755 892(I)N -X841(have)X -X1052(also)X -X1240(included)X -X1575(a)X -X1670(copy)X -X1885(of)X -X2011(the)X -X7 f -X2195(dbe)X -X1 f -X2397(\()X -X2 f -X2424(ndbm)X -X1 f -X2660(DataBase)X -X3026(Editor\))X -X3311(by)X -X3449(Janick)X -X3712(Bergeron)X -X555 988([janick@bnr.ca])N -X1098(for)X -X1212(your)X -X1379(pleasure.)X -X1687(You)X -X1845(may)X -X2003(\256nd)X -X2147(it)X -X2211(more)X -X2396(useful)X -X2612(than)X -X2770(the)X -X2888(little)X -X7 f -X3082(dbu)X -X1 f -X3246(utility.)X -X7 f -X755 1112(dbm.[ch])N -X1 f -X1169(is)X -X1252(a)X -X2 f -X1318(dbm)X -X1 f -X1486(library)X -X1730(emulation)X -X2079(on)X -X2188(top)X -X2319(of)X -X2 f -X2415(ndbm)X -X1 f -X2622(\(and)X -X2794(hence)X -X3011(suitable)X -X3289(for)X -X2 f -X3412(sdbm)X -X1 f -X3581(\).)X -X3657(Written)X -X3931(by)X -X555 1208(Robert)N -X793(Elz.)X -X755 1332(The)N -X2 f -X901(sdbm)X -X1 f -X1090(library)X -X1324(has)X -X1451(been)X -X1623(around)X -X1866(in)X -X1948(beta)X -X2102(test)X -X2233(for)X -X2347(quite)X -X2527(a)X -X2583(long)X -X2745(time,)X -X2927(and)X -X3063(from)X -X3239(whatever)X -X3554(little)X -X3720(feedback)X -X555 1428(I)N -X609(received)X -X909(\(maybe)X -X1177(no)X -X1284(news)X -X1476(is)X -X1555(good)X -X1741(news\),)X -X1979(I)X -X2032(believe)X -X2290(it)X -X2360(has)X -X2493(been)X -X2671(functioning)X -X3066(without)X -X3336(any)X -X3478(signi\256cant)X -X3837(prob-)X -X555 1524(lems.)N -X752(I)X -X805(would,)X -X1051(of)X -X1144(course,)X -X1400(appreciate)X -X1757(all)X -X1863(\256xes)X -X2040(and/or)X -X2271(improvements.)X -X2774(Portability)X -X3136(enhancements)X -X3616(would)X -X3841(espe-)X -X555 1620(cially)N -X753(be)X -X849(useful.)X -X3 f -X555 1812(Implementation)N -X1122(Issues)X -X1 f -X755 1936(Hash)N -X944(functions:)X -X1288(The)X -X1437(algorithm)X -X1772(behind)X -X2 f -X2014(sdbm)X -X1 f -X2207(implementation)X -X2733(needs)X -X2939(a)X -X2998(good)X -X3181(bit-scrambling)X -X3671(hash)X -X3841(func-)X -X555 2032(tion)N -X702(to)X -X787(be)X -X886(effective.)X -X1211(I)X -X1261(ran)X -X1387(into)X -X1534(a)X -X1593(set)X -X1705(of)X -X1795(constants)X -X2116(for)X -X2233(a)X -X2292(simple)X -X2528(hash)X -X2698(function)X -X2988(that)X -X3130(seem)X -X3317(to)X -X3401(help)X -X2 f -X3561(sdbm)X -X1 f -X3752(perform)X -X555 2128(better)N -X758(than)X -X2 f -X916(ndbm)X -X1 f -X1114(for)X -X1228(various)X -X1484(inputs:)X -X7 f -X747 2272(/*)N -X795 2368(*)N -X891(polynomial)X -X1419(conversion)X -X1947(ignoring)X -X2379(overflows)X -X795 2464(*)N -X891(65599)X -X1179(nice.)X -X1467(65587)X -X1755(even)X -X1995(better.)X -X795 2560(*/)N -X747 2656(long)N -X747 2752(dbm_hash\(char)N -X1419(*str,)X -X1707(int)X -X1899(len\))X -X2139({)X -X939 2848(register)N -X1371(unsigned)X -X1803(long)X -X2043(n)X -X2139(=)X -X2235(0;)X -X939 3040(while)N -X1227(\(len--\))X -X1131 3136(n)N -X1227(=)X -X1323(n)X -X1419(*)X -X1515(65599)X -X1803(+)X -X1899(*str++;)X -X939 3232(return)N -X1275(n;)X -X747 3328(})N -X1 f -X755 3500(There)N -X975(may)X -X1145(be)X -X1253(better)X -X1467(hash)X -X1645(functions)X -X1974(for)X -X2099(the)X -X2228(purposes)X -X2544(of)X -X2642(dynamic)X -X2949(hashing.)X -X3269(Try)X -X3416(your)X -X3594(favorite,)X -X3895(and)X -X555 3596(check)N -X766(the)X -X887(page\256le.)X -X1184(If)X -X1261(it)X -X1328(contains)X -X1618(too)X -X1743(many)X -X1944(pages)X -X2150(with)X -X2315(too)X -X2440(many)X -X2641(holes,)X -X2853(\(in)X -X2965(relation)X -X3233(to)X -X3318(this)X -X3456(one)X -X3595(for)X -X3712(example\))X -X555 3692(or)N -X656(if)X -X2 f -X739(sdbm)X -X1 f -X942(simply)X -X1193(stops)X -X1391(working)X -X1692(\(fails)X -X1891(after)X -X7 f -X2101(SPLTMAX)X -X1 f -X2471(attempts)X -X2776(to)X -X2872(split\))X -X3070(when)X -X3278(you)X -X3432(feed)X -X3604(your)X -X3784(NEWS)X -X7 f -X555 3788(history)N -X1 f -X912(\256le)X -X1035(to)X -X1118(it,)X -X1203(you)X -X1344(probably)X -X1650(do)X -X1751(not)X -X1874(have)X -X2047(a)X -X2104(good)X -X2285(hashing)X -X2555(function.)X -X2883(If)X -X2958(you)X -X3099(do)X -X3200(better)X -X3404(\(for)X -X3545(different)X -X3842(types)X -X555 3884(of)N -X642(input\),)X -X873(I)X -X920(would)X -X1140(like)X -X1280(to)X -X1362(know)X -X1560(about)X -X1758(the)X -X1876(function)X -X2163(you)X -X2303(use.)X -X755 4008(Block)N -X967(sizes:)X -X1166(It)X -X1236(seems)X -X1453(\(from)X -X1657(various)X -X1914(tests)X -X2077(on)X -X2178(a)X -X2235(few)X -X2377(machines\))X -X2727(that)X -X2867(a)X -X2923(page)X -X3095(\256le)X -X3217(block)X -X3415(size)X -X7 f -X3588(PBLKSIZ)X -X1 f -X3944(of)X -X555 4104(1024)N -X738(is)X -X814(by)X -X917(far)X -X1030(the)X -X1150(best)X -X1301(for)X -X1417(performance,)X -X1866(but)X -X1990(this)X -X2127(also)X -X2278(happens)X -X2563(to)X -X2647(limit)X -X2819(the)X -X2939(size)X -X3086(of)X -X3175(a)X -X3233(key/value)X -X3567(pair.)X -X3734(Depend-)X -X555 4200(ing)N -X681(on)X -X785(your)X -X956(needs,)X -X1183(you)X -X1327(may)X -X1489(wish)X -X1663(to)X -X1748(increase)X -X2035(the)X -X2156(page)X -X2331(size,)X -X2499(and)X -X2638(also)X -X2790(adjust)X -X7 f -X3032(PAIRMAX)X -X1 f -X3391(\(the)X -X3539(maximum)X -X3886(size)X -X555 4296(of)N -X648(a)X -X710(key/value)X -X1048(pair)X -X1199(allowed:)X -X1501(should)X -X1740(always)X -X1989(be)X -X2090(at)X -X2173(least)X -X2345(three)X -X2531(words)X -X2752(smaller)X -X3013(than)X -X7 f -X3204(PBLKSIZ)X -X1 f -X(.\))S -X3612(accordingly.)X -X555 4392(The)N -X706(system-wide)X -X1137(version)X -X1399(of)X -X1492(the)X -X1616(library)X -X1856(should)X -X2095(probably)X -X2406(be)X -X2508(con\256gured)X -X2877(with)X -X3044(1024)X -X3229(\(distribution)X -X3649(default\),)X -X3944(as)X -X555 4488(this)N -X690(appears)X -X956(to)X -X1038(be)X -X1134(suf\256cient)X -X1452(for)X -X1566(most)X -X1741(common)X -X2041(uses)X -X2199(of)X -X2 f -X2286(sdbm)X -X1 f -X2455(.)X -X3 f -X555 4680(Portability)N -X1 f -X755 4804(This)N -X917(package)X -X1201(has)X -X1328(been)X -X1500(tested)X -X1707(in)X -X1789(many)X -X1987(different)X -X2284(UN*Xes)X -X2585(even)X -X2757(including)X -X3079(minix,)X -X3305(and)X -X3441(appears)X -X3707(to)X -X3789(be)X -X3885(rea-)X -X555 4900(sonably)N -X824(portable.)X -X1127(This)X -X1289(does)X -X1456(not)X -X1578(mean)X -X1772(it)X -X1836(will)X -X1980(port)X -X2129(easily)X -X2336(to)X -X2418(non-UN*X)X -X2799(systems.)X -X3 f -X555 5092(Notes)N -X767(and)X -X915(Miscellaneous)X -X1 f -X755 5216(The)N -X2 f -X913(sdbm)X -X1 f -X1115(is)X -X1201(not)X -X1336(a)X -X1405(very)X -X1581(complicated)X -X2006(package,)X -X2323(at)X -X2414(least)X -X2594(not)X -X2729(after)X -X2910(you)X -X3063(familiarize)X -X3444(yourself)X -X3739(with)X -X3913(the)X -X555 5312(literature)N -X879(on)X -X993(external)X -X1286(hashing.)X -X1589(There)X -X1811(are)X -X1944(other)X -X2143(interesting)X -X2514(algorithms)X -X2889(in)X -X2984(existence)X -X3316(that)X -X3469(ensure)X -X3712(\(approxi-)X -X555 5408(mately\))N -X825(single-read)X -X1207(access)X -X1438(to)X -X1525(a)X -X1586(data)X -X1745(value)X -X1944(associated)X -X2299(with)X -X2466(any)X -X2607(key.)X -X2768(These)X -X2984(are)X -X3107(directory-less)X -X3568(schemes)X -X3864(such)X -X555 5504(as)N -X2 f -X644(linear)X -X857(hashing)X -X1 f -X1132([Lit80])X -X1381(\(+)X -X1475(Larson)X -X1720(variations\),)X -X2 f -X2105(spiral)X -X2313(storage)X -X1 f -X2575([Mar79])X -X2865(or)X -X2954(directory)X -X3265(schemes)X -X3558(such)X -X3726(as)X -X2 f -X3814(exten-)X -X555 5600(sible)N -X731(hashing)X -X1 f -X1009([Fag79])X -X1288(by)X -X1393(Fagin)X -X1600(et)X -X1683(al.)X -X1786(I)X -X1838(do)X -X1943(hope)X -X2124(these)X -X2314(sources)X -X2579(provide)X -X2848(a)X -X2908(reasonable)X -X3276(playground)X -X3665(for)X -X3783(experi-)X -X555 5696(mentation)N -X907(with)X -X1081(other)X -X1277(algorithms.)X -X1690(See)X -X1837(the)X -X1966(June)X -X2144(1988)X -X2335(issue)X -X2526(of)X -X2624(ACM)X -X2837(Computing)X -X3227(Surveys)X -X3516([Enb88])X -X3810(for)X -X3935(an)X -X555 5792(excellent)N -X865(overview)X -X1184(of)X -X1271(the)X -X1389(\256eld.)X -X -X4 p -X%%Page: 4 4 -X10 s 0 xH 0 xS 1 f -X2216 384(-)N -X2263(4)X -X2323(-)X -X3 f -X555 672(References)N -X1 f -X555 824([Lar78])N -X875(P.-A.)X -X1064(Larson,)X -X1327(``Dynamic)X -X1695(Hashing'',)X -X2 f -X2056(BIT)X -X1 f -X(,)S -X2216(vol.)X -X2378(18,)X -X2518(pp.)X -X2638(184-201,)X -X2945(1978.)X -X555 948([Tho90])N -X875(Ken)X -X1029(Thompson,)X -X2 f -X1411(private)X -X1658(communication)X -X1 f -X2152(,)X -X2192(Nov.)X -X2370(1990)X -X555 1072([Lit80])N -X875(W.)X -X992(Litwin,)X -X1246(``)X -X1321(Linear)X -X1552(Hashing:)X -X1862(A)X -X1941(new)X -X2096(tool)X -X2261(for)X -X2396(\256le)X -X2539(and)X -X2675(table)X -X2851(addressing'',)X -X2 f -X3288(Proceedings)X -X3709(of)X -X3791(the)X -X3909(6th)X -X875 1168(Conference)N -X1269(on)X -X1373(Very)X -X1548(Large)X -X1782(Dabatases)X -X2163(\(Montreal\))X -X1 f -X2515(,)X -X2558(pp.)X -X2701(212-223,)X -X3031(Very)X -X3215(Large)X -X3426(Database)X -X3744(Founda-)X -X875 1264(tion,)N -X1039(Saratoga,)X -X1360(Calif.,)X -X1580(1980.)X -X555 1388([Fag79])N -X875(R.)X -X969(Fagin,)X -X1192(J.)X -X1284(Nievergelt,)X -X1684(N.)X -X1803(Pippinger,)X -X2175(and)X -X2332(H.)X -X2451(R.)X -X2544(Strong,)X -X2797(``Extendible)X -X3218(Hashing)X -X3505(-)X -X3552(A)X -X3630(Fast)X -X3783(Access)X -X875 1484(Method)N -X1144(for)X -X1258(Dynamic)X -X1572(Files'',)X -X2 f -X1821(ACM)X -X2010(Trans.)X -X2236(Database)X -X2563(Syst.)X -X1 f -X2712(,)X -X2752(vol.)X -X2894(4,)X -X2994(no.3,)X -X3174(pp.)X -X3294(315-344,)X -X3601(Sept.)X -X3783(1979.)X -X555 1608([Wal84])N -X875(Rich)X -X1055(Wales,)X -X1305(``Discussion)X -X1739(of)X -X1835("dbm")X -X2072(data)X -X2235(base)X -X2406(system'',)X -X2 f -X2730(USENET)X -X3051(newsgroup)X -X3430(unix.wizards)X -X1 f -X3836(,)X -X3884(Jan.)X -X875 1704(1984.)N -X555 1828([Tor87])N -X875(Chris)X -X1068(Torek,)X -X1300(``Re:)X -X1505(dbm.a)X -X1743(and)X -X1899(ndbm.a)X -X2177(archives'',)X -X2 f -X2539(USENET)X -X2852(newsgroup)X -X3223(comp.unix)X -X1 f -X3555(,)X -X3595(1987.)X -X555 1952([Mar79])N -X875(G.)X -X974(N.)X -X1073(Martin,)X -X1332(``Spiral)X -X1598(Storage:)X -X1885(Incrementally)X -X2371(Augmentable)X -X2843(Hash)X -X3048(Addressed)X -X3427(Storage'',)X -X2 f -X3766(Techni-)X -X875 2048(cal)N -X993(Report)X -X1231(#27)X -X1 f -X(,)S -X1391(University)X -X1749(of)X -X1836(Varwick,)X -X2153(Coventry,)X -X2491(U.K.,)X -X2687(1979.)X -X555 2172([Enb88])N -X875(R.)X -X977(J.)X -X1057(Enbody)X -X1335(and)X -X1480(H.)X -X1586(C.)X -X1687(Du,)X -X1833(``Dynamic)X -X2209(Hashing)X -X2524(Schemes'',)X -X2 f -X2883(ACM)X -X3080(Computing)X -X3463(Surveys)X -X1 f -X3713(,)X -X3761(vol.)X -X3911(20,)X -X875 2268(no.)N -X995(2,)X -X1075(pp.)X -X1195(85-113,)X -X1462(June)X -X1629(1988.)X -X -X4 p -X%%Trailer -Xxt -X -Xxs -END_OF_FILE -if test 33302 -ne `wc -c <'readme.ps'`; then - echo shar: \"'readme.ps'\" unpacked with wrong size! -fi -# end of 'readme.ps' -fi -if test -f 'sdbm.3' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'sdbm.3'\" -else -echo shar: Extracting \"'sdbm.3'\" \(8952 characters\) -sed "s/^X//" >'sdbm.3' <<'END_OF_FILE' -X.\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $ -X.TH SDBM 3 "1 March 1990" -X.SH NAME -Xsdbm, dbm_open, dbm_prep, dbm_close, dbm_fetch, dbm_store, dbm_delete, dbm_firstkey, dbm_nextkey, dbm_hash, dbm_rdonly, dbm_error, dbm_clearerr, dbm_dirfno, dbm_pagfno \- data base subroutines -X.SH SYNOPSIS -X.nf -X.ft B -X#include <sdbm.h> -X.sp -Xtypedef struct { -X char *dptr; -X int dsize; -X} datum; -X.sp -Xdatum nullitem = { NULL, 0 }; -X.sp -X\s-1DBM\s0 *dbm_open(char *file, int flags, int mode) -X.sp -X\s-1DBM\s0 *dbm_prep(char *dirname, char *pagname, int flags, int mode) -X.sp -Xvoid dbm_close(\s-1DBM\s0 *db) -X.sp -Xdatum dbm_fetch(\s-1DBM\s0 *db, key) -X.sp -Xint dbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) -X.sp -Xint dbm_delete(\s-1DBM\s0 *db, datum key) -X.sp -Xdatum dbm_firstkey(\s-1DBM\s0 *db) -X.sp -Xdatum dbm_nextkey(\s-1DBM\s0 *db) -X.sp -Xlong dbm_hash(char *string, int len) -X.sp -Xint dbm_rdonly(\s-1DBM\s0 *db) -Xint dbm_error(\s-1DBM\s0 *db) -Xdbm_clearerr(\s-1DBM\s0 *db) -Xint dbm_dirfno(\s-1DBM\s0 *db) -Xint dbm_pagfno(\s-1DBM\s0 *db) -X.ft R -X.fi -X.SH DESCRIPTION -X.IX "database library" sdbm "" "\fLsdbm\fR" -X.IX dbm_open "" "\fLdbm_open\fR \(em open \fLsdbm\fR database" -X.IX dbm_prep "" "\fLdbm_prep\fR \(em prepare \fLsdbm\fR database" -X.IX dbm_close "" "\fLdbm_close\fR \(em close \fLsdbm\fR routine" -X.IX dbm_fetch "" "\fLdbm_fetch\fR \(em fetch \fLsdbm\fR database data" -X.IX dbm_store "" "\fLdbm_store\fR \(em add data to \fLsdbm\fR database" -X.IX dbm_delete "" "\fLdbm_delete\fR \(em remove data from \fLsdbm\fR database" -X.IX dbm_firstkey "" "\fLdbm_firstkey\fR \(em access \fLsdbm\fR database" -X.IX dbm_nextkey "" "\fLdbm_nextkey\fR \(em access \fLsdbm\fR database" -X.IX dbm_hash "" "\fLdbm_hash\fR \(em string hash for \fLsdbm\fR database" -X.IX dbm_rdonly "" "\fLdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode" -X.IX dbm_error "" "\fLdbm_error\fR \(em return \fLsdbm\fR database error condition" -X.IX dbm_clearerr "" "\fLdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition" -X.IX dbm_dirfno "" "\fLdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor" -X.IX dbm_pagfno "" "\fLdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor" -X.IX "database functions \(em \fLsdbm\fR" dbm_open "" \fLdbm_open\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_prep "" \fLdbm_prep\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_close "" \fLdbm_close\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_fetch "" \fLdbm_fetch\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_store "" \fLdbm_store\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_delete "" \fLdbm_delete\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_firstkey "" \fLdbm_firstkey\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_nextkey "" \fLdbm_nextkey\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_rdonly "" \fLdbm_rdonly\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_error "" \fLdbm_error\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_clearerr "" \fLdbm_clearerr\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_dirfno "" \fLdbm_dirfno\fP -X.IX "database functions \(em \fLsdbm\fR" dbm_pagfno "" \fLdbm_pagfno\fP -X.LP -XThis package allows an application to maintain a mapping of <key,value> pairs -Xin disk files. This is not to be considered a real database system, but is -Xstill useful in many simple applications built around fast retrieval of a data -Xvalue from a key. This implementation uses an external hashing scheme, -Xcalled Dynamic Hashing, as described by Per-Aake Larson in BIT 18 (1978) pp. -X184-201. Retrieval of any item usually requires a single disk access. -XThe application interface is compatible with the -X.IR ndbm (3) -Xlibrary. -X.LP -XAn -X.B sdbm -Xdatabase is kept in two files usually given the extensions -X.B \.dir -Xand -X.BR \.pag . -XThe -X.B \.dir -Xfile contains a bitmap representing a forest of binary hash trees, the leaves -Xof which indicate data pages in the -X.B \.pag -Xfile. -X.LP -XThe application interface uses the -X.B datum -Xstructure to describe both -X.I keys -Xand -X.IR value s. -XA -X.B datum -Xspecifies a byte sequence of -X.I dsize -Xsize pointed to by -X.IR dptr . -XIf you use -X.SM ASCII -Xstrings as -X.IR key s -Xor -X.IR value s, -Xthen you must decide whether or not to include the terminating -X.SM NUL -Xbyte which sometimes defines strings. Including it will require larger -Xdatabase files, but it will be possible to get sensible output from a -X.IR strings (1) -Xcommand applied to the data file. -X.LP -XIn order to allow a process using this package to manipulate multiple -Xdatabases, the applications interface always requires a -X.IR handle , -Xa -X.BR "DBM *" , -Xto identify the database to be manipulated. Such a handle can be obtained -Xfrom the only routines that do not require it, namely -X.BR dbm_open (\|) -Xor -X.BR dbm_prep (\|). -XEither of these will open or create the two necessary files. The -Xdifference is that the latter allows explicitly naming the bitmap and data -Xfiles whereas -X.BR dbm_open (\|) -Xwill take a base file name and call -X.BR dbm_prep (\|) -Xwith the default extensions. -XThe -X.I flags -Xand -X.I mode -Xparameters are the same as for -X.BR open (2). -X.LP -XTo free the resources occupied while a database handle is active, call -X.BR dbm_close (\|). -X.LP -XGiven a handle, one can retrieve data associated with a key by using the -X.BR dbm_fetch (\|) -Xroutine, and associate data with a key by using the -X.BR dbm_store (\|) -Xroutine. -X.LP -XThe values of the -X.I flags -Xparameter for -X.BR dbm_store (\|) -Xcan be either -X.BR \s-1DBM_INSERT\s0 , -Xwhich will not change an existing entry with the same key, or -X.BR \s-1DBM_REPLACE\s0 , -Xwhich will replace an existing entry with the same key. -XKeys are unique within the database. -X.LP -XTo delete a key and its associated value use the -X.BR dbm_delete (\|) -Xroutine. -X.LP -XTo retrieve every key in the database, use a loop like: -X.sp -X.nf -X.ft B -Xfor (key = dbm_firstkey(db); key.dptr != NULL; key = dbm_nextkey(db)) -X ; -X.ft R -X.fi -X.LP -XThe order of retrieval is unspecified. -X.LP -XIf you determine that the performance of the database is inadequate or -Xyou notice clustering or other effects that may be due to the hashing -Xalgorithm used by this package, you can override it by supplying your -Xown -X.BR dbm_hash (\|) -Xroutine. Doing so will make the database unintelligable to any other -Xapplications that do not use your specialized hash function. -X.sp -X.LP -XThe following macros are defined in the header file: -X.IP -X.BR dbm_rdonly (\|) -Xreturns true if the database has been opened read\-only. -X.IP -X.BR dbm_error (\|) -Xreturns true if an I/O error has occurred. -X.IP -X.BR dbm_clearerr (\|) -Xallows you to clear the error flag if you think you know what the error -Xwas and insist on ignoring it. -X.IP -X.BR dbm_dirfno (\|) -Xreturns the file descriptor associated with the bitmap file. -X.IP -X.BR dbm_pagfno (\|) -Xreturns the file descriptor associated with the data file. -X.SH SEE ALSO -X.IR open (2). -X.SH DIAGNOSTICS -XFunctions that return a -X.B "DBM *" -Xhandle will use -X.SM NULL -Xto indicate an error. -XFunctions that return an -X.B int -Xwill use \-1 to indicate an error. The normal return value in that case is 0. -XFunctions that return a -X.B datum -Xwill return -X.B nullitem -Xto indicate an error. -X.LP -XAs a special case of -X.BR dbm_store (\|), -Xif it is called with the -X.B \s-1DBM_INSERT\s0 -Xflag and the key already exists in the database, the return value will be 1. -X.LP -XIn general, if a function parameter is invalid, -X.B errno -Xwill be set to -X.BR \s-1EINVAL\s0 . -XIf a write operation is requested on a read-only database, -X.B errno -Xwill be set to -X.BR \s-1ENOPERM\s0 . -XIf a memory allocation (using -X.IR malloc (3)) -Xfailed, -X.B errno -Xwill be set to -X.BR \s-1ENOMEM\s0 . -XFor I/O operation failures -X.B errno -Xwill contain the value set by the relevant failed system call, either -X.IR read (2), -X.IR write (2), -Xor -X.IR lseek (2). -X.SH AUTHOR -X.IP "Ozan S. Yigit" (oz@nexus.yorku.ca) -X.SH BUGS -XThe sum of key and value data sizes must not exceed -X.B \s-1PAIRMAX\s0 -X(1008 bytes). -X.LP -XThe sum of the key and value data sizes where several keys hash to the -Xsame value must fit within one bitmap page. -X.LP -XThe -X.B \.pag -Xfile will contain holes, so its apparent size is larger than its contents. -XWhen copied through the filesystem the holes will be filled. -X.LP -XThe contents of -X.B datum -Xvalues returned are in volatile storage. If you want to retain the values -Xpointed to, you must copy them immediately before another call to this package. -X.LP -XThe only safe way for multiple processes to (read and) update a database at -Xthe same time, is to implement a private locking scheme outside this package -Xand open and close the database between lock acquisitions. It is safe for -Xmultiple processes to concurrently access a database read-only. -X.SH APPLICATIONS PORTABILITY -XFor complete source code compatibility with the Berkeley Unix -X.IR ndbm (3) -Xlibrary, the -X.B sdbm.h -Xheader file should be installed in -X.BR /usr/include/ndbm.h . -X.LP -XThe -X.B nullitem -Xdata item, and the -X.BR dbm_prep (\|), -X.BR dbm_hash (\|), -X.BR dbm_rdonly (\|), -X.BR dbm_dirfno (\|), -Xand -X.BR dbm_pagfno (\|) -Xfunctions are unique to this package. -END_OF_FILE -if test 8952 -ne `wc -c <'sdbm.3'`; then - echo shar: \"'sdbm.3'\" unpacked with wrong size! -fi -# end of 'sdbm.3' -fi -if test -f 'sdbm.c' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'sdbm.c'\" -else -echo shar: Extracting \"'sdbm.c'\" \(11029 characters\) -sed "s/^X//" >'sdbm.c' <<'END_OF_FILE' -X/* -X * sdbm - ndbm work-alike hashed database library -X * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978). -X * author: oz@nexus.yorku.ca -X * status: public domain. -X * -X * core routines -X */ -X -X#ifndef lint -Xstatic char rcsid[] = "$Id: sdbm.c,v 1.16 90/12/13 13:01:31 oz Exp $"; -X#endif -X -X#include "sdbm.h" -X#include "tune.h" -X#include "pair.h" -X -X#include <sys/types.h> -X#include <sys/stat.h> -X#ifdef BSD42 -X#include <sys/file.h> -X#else -X#include <fcntl.h> -X#include <memory.h> -X#endif -X#include <errno.h> -X#include <string.h> -X -X#ifdef __STDC__ -X#include <stddef.h> -X#endif -X -X#ifndef NULL -X#define NULL 0 -X#endif -X -X/* -X * externals -X */ -X#ifndef sun -Xextern int errno; -X#endif -X -Xextern char *malloc proto((unsigned int)); -Xextern void free proto((void *)); -Xextern long lseek(); -X -X/* -X * forward -X */ -Xstatic int getdbit proto((DBM *, long)); -Xstatic int setdbit proto((DBM *, long)); -Xstatic int getpage proto((DBM *, long)); -Xstatic datum getnext proto((DBM *)); -Xstatic int makroom proto((DBM *, long, int)); -X -X/* -X * useful macros -X */ -X#define bad(x) ((x).dptr == NULL || (x).dsize <= 0) -X#define exhash(item) dbm_hash((item).dptr, (item).dsize) -X#define ioerr(db) ((db)->flags |= DBM_IOERR) -X -X#define OFF_PAG(off) (long) (off) * PBLKSIZ -X#define OFF_DIR(off) (long) (off) * DBLKSIZ -X -Xstatic long masks[] = { -X 000000000000, 000000000001, 000000000003, 000000000007, -X 000000000017, 000000000037, 000000000077, 000000000177, -X 000000000377, 000000000777, 000000001777, 000000003777, -X 000000007777, 000000017777, 000000037777, 000000077777, -X 000000177777, 000000377777, 000000777777, 000001777777, -X 000003777777, 000007777777, 000017777777, 000037777777, -X 000077777777, 000177777777, 000377777777, 000777777777, -X 001777777777, 003777777777, 007777777777, 017777777777 -X}; -X -Xdatum nullitem = {NULL, 0}; -X -XDBM * -Xdbm_open(file, flags, mode) -Xregister char *file; -Xregister int flags; -Xregister int mode; -X{ -X register DBM *db; -X register char *dirname; -X register char *pagname; -X register int n; -X -X if (file == NULL || !*file) -X return errno = EINVAL, (DBM *) NULL; -X/* -X * need space for two seperate filenames -X */ -X n = strlen(file) * 2 + strlen(DIRFEXT) + strlen(PAGFEXT) + 2; -X -X if ((dirname = malloc((unsigned) n)) == NULL) -X return errno = ENOMEM, (DBM *) NULL; -X/* -X * build the file names -X */ -X dirname = strcat(strcpy(dirname, file), DIRFEXT); -X pagname = strcpy(dirname + strlen(dirname) + 1, file); -X pagname = strcat(pagname, PAGFEXT); -X -X db = dbm_prep(dirname, pagname, flags, mode); -X free((char *) dirname); -X return db; -X} -X -XDBM * -Xdbm_prep(dirname, pagname, flags, mode) -Xchar *dirname; -Xchar *pagname; -Xint flags; -Xint mode; -X{ -X register DBM *db; -X struct stat dstat; -X -X if ((db = (DBM *) malloc(sizeof(DBM))) == NULL) -X return errno = ENOMEM, (DBM *) NULL; -X -X db->flags = 0; -X db->hmask = 0; -X db->blkptr = 0; -X db->keyptr = 0; -X/* -X * adjust user flags so that WRONLY becomes RDWR, -X * as required by this package. Also set our internal -X * flag for RDONLY if needed. -X */ -X if (flags & O_WRONLY) -X flags = (flags & ~O_WRONLY) | O_RDWR; -X -X else if ((flags & 03) == O_RDONLY) -X db->flags = DBM_RDONLY; -X/* -X * open the files in sequence, and stat the dirfile. -X * If we fail anywhere, undo everything, return NULL. -X */ -X if ((db->pagf = open(pagname, flags, mode)) > -1) { -X if ((db->dirf = open(dirname, flags, mode)) > -1) { -X/* -X * need the dirfile size to establish max bit number. -X */ -X if (fstat(db->dirf, &dstat) == 0) { -X/* -X * zero size: either a fresh database, or one with a single, -X * unsplit data page: dirpage is all zeros. -X */ -X db->dirbno = (!dstat.st_size) ? 0 : -1; -X db->pagbno = -1; -X db->maxbno = dstat.st_size * BYTESIZ; -X -X (void) memset(db->pagbuf, 0, PBLKSIZ); -X (void) memset(db->dirbuf, 0, DBLKSIZ); -X /* -X * success -X */ -X return db; -X } -X (void) close(db->dirf); -X } -X (void) close(db->pagf); -X } -X free((char *) db); -X return (DBM *) NULL; -X} -X -Xvoid -Xdbm_close(db) -Xregister DBM *db; -X{ -X if (db == NULL) -X errno = EINVAL; -X else { -X (void) close(db->dirf); -X (void) close(db->pagf); -X free((char *) db); -X } -X} -X -Xdatum -Xdbm_fetch(db, key) -Xregister DBM *db; -Xdatum key; -X{ -X if (db == NULL || bad(key)) -X return errno = EINVAL, nullitem; -X -X if (getpage(db, exhash(key))) -X return getpair(db->pagbuf, key); -X -X return ioerr(db), nullitem; -X} -X -Xint -Xdbm_delete(db, key) -Xregister DBM *db; -Xdatum key; -X{ -X if (db == NULL || bad(key)) -X return errno = EINVAL, -1; -X if (dbm_rdonly(db)) -X return errno = EPERM, -1; -X -X if (getpage(db, exhash(key))) { -X if (!delpair(db->pagbuf, key)) -X return -1; -X/* -X * update the page file -X */ -X if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 -X || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) -X return ioerr(db), -1; -X -X return 0; -X } -X -X return ioerr(db), -1; -X} -X -Xint -Xdbm_store(db, key, val, flags) -Xregister DBM *db; -Xdatum key; -Xdatum val; -Xint flags; -X{ -X int need; -X register long hash; -X -X if (db == NULL || bad(key)) -X return errno = EINVAL, -1; -X if (dbm_rdonly(db)) -X return errno = EPERM, -1; -X -X need = key.dsize + val.dsize; -X/* -X * is the pair too big (or too small) for this database ?? -X */ -X if (need < 0 || need > PAIRMAX) -X return errno = EINVAL, -1; -X -X if (getpage(db, (hash = exhash(key)))) { -X/* -X * if we need to replace, delete the key/data pair -X * first. If it is not there, ignore. -X */ -X if (flags == DBM_REPLACE) -X (void) delpair(db->pagbuf, key); -X#ifdef SEEDUPS -X else if (duppair(db->pagbuf, key)) -X return 1; -X#endif -X/* -X * if we do not have enough room, we have to split. -X */ -X if (!fitpair(db->pagbuf, need)) -X if (!makroom(db, hash, need)) -X return ioerr(db), -1; -X/* -X * we have enough room or split is successful. insert the key, -X * and update the page file. -X */ -X (void) putpair(db->pagbuf, key, val); -X -X if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 -X || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) -X return ioerr(db), -1; -X /* -X * success -X */ -X return 0; -X } -X -X return ioerr(db), -1; -X} -X -X/* -X * makroom - make room by splitting the overfull page -X * this routine will attempt to make room for SPLTMAX times before -X * giving up. -X */ -Xstatic int -Xmakroom(db, hash, need) -Xregister DBM *db; -Xlong hash; -Xint need; -X{ -X long newp; -X char twin[PBLKSIZ]; -X char *pag = db->pagbuf; -X char *new = twin; -X register int smax = SPLTMAX; -X -X do { -X/* -X * split the current page -X */ -X (void) splpage(pag, new, db->hmask + 1); -X/* -X * address of the new page -X */ -X newp = (hash & db->hmask) | (db->hmask + 1); -X -X/* -X * write delay, read avoidence/cache shuffle: -X * select the page for incoming pair: if key is to go to the new page, -X * write out the previous one, and copy the new one over, thus making -X * it the current page. If not, simply write the new page, and we are -X * still looking at the page of interest. current page is not updated -X * here, as dbm_store will do so, after it inserts the incoming pair. -X */ -X if (hash & (db->hmask + 1)) { -X if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 -X || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) -X return 0; -X db->pagbno = newp; -X (void) memcpy(pag, new, PBLKSIZ); -X } -X else if (lseek(db->pagf, OFF_PAG(newp), SEEK_SET) < 0 -X || write(db->pagf, new, PBLKSIZ) < 0) -X return 0; -X -X if (!setdbit(db, db->curbit)) -X return 0; -X/* -X * see if we have enough room now -X */ -X if (fitpair(pag, need)) -X return 1; -X/* -X * try again... update curbit and hmask as getpage would have -X * done. because of our update of the current page, we do not -X * need to read in anything. BUT we have to write the current -X * [deferred] page out, as the window of failure is too great. -X */ -X db->curbit = 2 * db->curbit + -X ((hash & (db->hmask + 1)) ? 2 : 1); -X db->hmask |= db->hmask + 1; -X -X if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 -X || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) -X return 0; -X -X } while (--smax); -X/* -X * if we are here, this is real bad news. After SPLTMAX splits, -X * we still cannot fit the key. say goodnight. -X */ -X#ifdef BADMESS -X (void) write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44); -X#endif -X return 0; -X -X} -X -X/* -X * the following two routines will break if -X * deletions aren't taken into account. (ndbm bug) -X */ -Xdatum -Xdbm_firstkey(db) -Xregister DBM *db; -X{ -X if (db == NULL) -X return errno = EINVAL, nullitem; -X/* -X * start at page 0 -X */ -X if (lseek(db->pagf, OFF_PAG(0), SEEK_SET) < 0 -X || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) -X return ioerr(db), nullitem; -X db->pagbno = 0; -X db->blkptr = 0; -X db->keyptr = 0; -X -X return getnext(db); -X} -X -Xdatum -Xdbm_nextkey(db) -Xregister DBM *db; -X{ -X if (db == NULL) -X return errno = EINVAL, nullitem; -X return getnext(db); -X} -X -X/* -X * all important binary trie traversal -X */ -Xstatic int -Xgetpage(db, hash) -Xregister DBM *db; -Xregister long hash; -X{ -X register int hbit; -X register long dbit; -X register long pagb; -X -X dbit = 0; -X hbit = 0; -X while (dbit < db->maxbno && getdbit(db, dbit)) -X dbit = 2 * dbit + ((hash & (1 << hbit++)) ? 2 : 1); -X -X debug(("dbit: %d...", dbit)); -X -X db->curbit = dbit; -X db->hmask = masks[hbit]; -X -X pagb = hash & db->hmask; -X/* -X * see if the block we need is already in memory. -X * note: this lookaside cache has about 10% hit rate. -X */ -X if (pagb != db->pagbno) { -X/* -X * note: here, we assume a "hole" is read as 0s. -X * if not, must zero pagbuf first. -X */ -X if (lseek(db->pagf, OFF_PAG(pagb), SEEK_SET) < 0 -X || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) -X return 0; -X if (!chkpage(db->pagbuf)) -X return 0; -X db->pagbno = pagb; -X -X debug(("pag read: %d\n", pagb)); -X } -X return 1; -X} -X -Xstatic int -Xgetdbit(db, dbit) -Xregister DBM *db; -Xregister long dbit; -X{ -X register long c; -X register long dirb; -X -X c = dbit / BYTESIZ; -X dirb = c / DBLKSIZ; -X -X if (dirb != db->dirbno) { -X if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 -X || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) -X return 0; -X db->dirbno = dirb; -X -X debug(("dir read: %d\n", dirb)); -X } -X -X return db->dirbuf[c % DBLKSIZ] & (1 << dbit % BYTESIZ); -X} -X -Xstatic int -Xsetdbit(db, dbit) -Xregister DBM *db; -Xregister long dbit; -X{ -X register long c; -X register long dirb; -X -X c = dbit / BYTESIZ; -X dirb = c / DBLKSIZ; -X -X if (dirb != db->dirbno) { -X if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 -X || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) -X return 0; -X db->dirbno = dirb; -X -X debug(("dir read: %d\n", dirb)); -X } -X -X db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); -X -X if (dbit >= db->maxbno) -X db->maxbno += DBLKSIZ * BYTESIZ; -X -X if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 -X || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) -X return 0; -X -X return 1; -X} -X -X/* -X * getnext - get the next key in the page, and if done with -X * the page, try the next page in sequence -X */ -Xstatic datum -Xgetnext(db) -Xregister DBM *db; -X{ -X datum key; -X -X for (;;) { -X db->keyptr++; -X key = getnkey(db->pagbuf, db->keyptr); -X if (key.dptr != NULL) -X return key; -X/* -X * we either run out, or there is nothing on this page.. -X * try the next one... If we lost our position on the -X * file, we will have to seek. -X */ -X db->keyptr = 0; -X if (db->pagbno != db->blkptr++) -X if (lseek(db->pagf, OFF_PAG(db->blkptr), SEEK_SET) < 0) -X break; -X db->pagbno = db->blkptr; -X if (read(db->pagf, db->pagbuf, PBLKSIZ) <= 0) -X break; -X if (!chkpage(db->pagbuf)) -X break; -X } -X -X return ioerr(db), nullitem; -X} -END_OF_FILE -if test 11029 -ne `wc -c <'sdbm.c'`; then - echo shar: \"'sdbm.c'\" unpacked with wrong size! -fi -# end of 'sdbm.c' -fi -if test -f 'sdbm.h' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'sdbm.h'\" -else -echo shar: Extracting \"'sdbm.h'\" \(2174 characters\) -sed "s/^X//" >'sdbm.h' <<'END_OF_FILE' -X/* -X * sdbm - ndbm work-alike hashed database library -X * based on Per-Ake Larson's Dynamic Hashing algorithms. BIT 18 (1978). -X * author: oz@nexus.yorku.ca -X * status: public domain. -X */ -X#define DBLKSIZ 4096 -X#define PBLKSIZ 1024 -X#define PAIRMAX 1008 /* arbitrary on PBLKSIZ-N */ -X#define SPLTMAX 10 /* maximum allowed splits */ -X /* for a single insertion */ -X#define DIRFEXT ".dir" -X#define PAGFEXT ".pag" -X -Xtypedef struct { -X int dirf; /* directory file descriptor */ -X int pagf; /* page file descriptor */ -X int flags; /* status/error flags, see below */ -X long maxbno; /* size of dirfile in bits */ -X long curbit; /* current bit number */ -X long hmask; /* current hash mask */ -X long blkptr; /* current block for nextkey */ -X int keyptr; /* current key for nextkey */ -X long blkno; /* current page to read/write */ -X long pagbno; /* current page in pagbuf */ -X char pagbuf[PBLKSIZ]; /* page file block buffer */ -X long dirbno; /* current block in dirbuf */ -X char dirbuf[DBLKSIZ]; /* directory file block buffer */ -X} DBM; -X -X#define DBM_RDONLY 0x1 /* data base open read-only */ -X#define DBM_IOERR 0x2 /* data base I/O error */ -X -X/* -X * utility macros -X */ -X#define dbm_rdonly(db) ((db)->flags & DBM_RDONLY) -X#define dbm_error(db) ((db)->flags & DBM_IOERR) -X -X#define dbm_clearerr(db) ((db)->flags &= ~DBM_IOERR) /* ouch */ -X -X#define dbm_dirfno(db) ((db)->dirf) -X#define dbm_pagfno(db) ((db)->pagf) -X -Xtypedef struct { -X char *dptr; -X int dsize; -X} datum; -X -Xextern datum nullitem; -X -X#ifdef __STDC__ -X#define proto(p) p -X#else -X#define proto(p) () -X#endif -X -X/* -X * flags to dbm_store -X */ -X#define DBM_INSERT 0 -X#define DBM_REPLACE 1 -X -X/* -X * ndbm interface -X */ -Xextern DBM *dbm_open proto((char *, int, int)); -Xextern void dbm_close proto((DBM *)); -Xextern datum dbm_fetch proto((DBM *, datum)); -Xextern int dbm_delete proto((DBM *, datum)); -Xextern int dbm_store proto((DBM *, datum, datum, int)); -Xextern datum dbm_firstkey proto((DBM *)); -Xextern datum dbm_nextkey proto((DBM *)); -X -X/* -X * other -X */ -Xextern DBM *dbm_prep proto((char *, char *, int, int)); -Xextern long dbm_hash proto((char *, int)); -END_OF_FILE -if test 2174 -ne `wc -c <'sdbm.h'`; then - echo shar: \"'sdbm.h'\" unpacked with wrong size! -fi -# end of 'sdbm.h' -fi -if test -f 'tune.h' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'tune.h'\" -else -echo shar: Extracting \"'tune.h'\" \(665 characters\) -sed "s/^X//" >'tune.h' <<'END_OF_FILE' -X/* -X * sdbm - ndbm work-alike hashed database library -X * tuning and portability constructs [not nearly enough] -X * author: oz@nexus.yorku.ca -X */ -X -X#define BYTESIZ 8 -X -X#ifdef SVID -X#include <unistd.h> -X#endif -X -X#ifdef BSD42 -X#define SEEK_SET L_SET -X#define memset(s,c,n) bzero(s, n) /* only when c is zero */ -X#define memcpy(s1,s2,n) bcopy(s2, s1, n) -X#define memcmp(s1,s2,n) bcmp(s1,s2,n) -X#endif -X -X/* -X * important tuning parms (hah) -X */ -X -X#define SEEDUPS /* always detect duplicates */ -X#define BADMESS /* generate a message for worst case: -X cannot make room after SPLTMAX splits */ -X/* -X * misc -X */ -X#ifdef DEBUG -X#define debug(x) printf x -X#else -X#define debug(x) -X#endif -END_OF_FILE -if test 665 -ne `wc -c <'tune.h'`; then - echo shar: \"'tune.h'\" unpacked with wrong size! -fi -# end of 'tune.h' -fi -if test -f 'util.c' -a "${1}" != "-c" ; then - echo shar: Will not clobber existing file \"'util.c'\" -else -echo shar: Extracting \"'util.c'\" \(767 characters\) -sed "s/^X//" >'util.c' <<'END_OF_FILE' -X#include <stdio.h> -X#ifdef SDBM -X#include "sdbm.h" -X#else -X#include "ndbm.h" -X#endif -X -Xvoid -Xoops(s1, s2) -Xregister char *s1; -Xregister char *s2; -X{ -X extern int errno, sys_nerr; -X extern char *sys_errlist[]; -X extern char *progname; -X -X if (progname) -X fprintf(stderr, "%s: ", progname); -X fprintf(stderr, s1, s2); -X if (errno > 0 && errno < sys_nerr) -X fprintf(stderr, " (%s)", sys_errlist[errno]); -X fprintf(stderr, "\n"); -X exit(1); -X} -X -Xint -Xokpage(pag) -Xchar *pag; -X{ -X register unsigned n; -X register off; -X register short *ino = (short *) pag; -X -X if ((n = ino[0]) > PBLKSIZ / sizeof(short)) -X return 0; -X -X if (!n) -X return 1; -X -X off = PBLKSIZ; -X for (ino++; n; ino += 2) { -X if (ino[0] > off || ino[1] > off || -X ino[1] > ino[0]) -X return 0; -X off = ino[1]; -X n -= 2; -X } -X -X return 1; -X} -END_OF_FILE -if test 767 -ne `wc -c <'util.c'`; then - echo shar: \"'util.c'\" unpacked with wrong size! -fi -# end of 'util.c' -fi -echo shar: End of shell archive. -exit 0 diff --git a/ext/dbm/sdbm/Makefile b/ext/dbm/sdbm/Makefile deleted file mode 100755 index 80b09cd37b..0000000000 --- a/ext/dbm/sdbm/Makefile +++ /dev/null @@ -1,47 +0,0 @@ -# -# This Makefile is for the library part of sdbm. For the -# Full package, see makefile.sdbm. -# -# Makefile for public domain ndbm-clone: sdbm -# DUFF: use duff's device (loop unroll) in parts of the code -# -# -CC = cc -ranlib = /usr/bin/ranlib -TOP = ../../.. -LDFLAGS = -CLDFLAGS = -SMALL = -LARGE = - -# To use an alternate make, set in config.sh. -MAKE = make - -SHELL = /bin/sh -CCCMD = `sh $(shellflags) $(TOP)/cflags $@` - -.c.o: - $(CCCMD) -I$(TOP) -DSDBM -DDUFF $*.c - -LIBOBJS = sdbm.o pair.o hash.o -LIBSRCS = sdbm.c pair.c hash.c -HDRS = tune.h sdbm.h pair.h $(TOP)/config.h - -libsdbm.a: $(LIBOBJS) - ar cr libsdbm.a $(LIBOBJS) - $(ranlib) libsdbm.a - -$(LIBOBJS): $(HDRS) - -lint: - lint -abchx $(LIBSRCS) - -clean: - rm -f *.o *.a mon.out core - -realclean: clean - rm -f dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag - rm -f makefile Makefile - -purge: realclean - diff --git a/ext/dbm/sdbm/libsdbm.a b/ext/dbm/sdbm/libsdbm.a Binary files differdeleted file mode 100644 index baf4b73942..0000000000 --- a/ext/dbm/sdbm/libsdbm.a +++ /dev/null diff --git a/ext/dbm/sdbm/libsdbm_pure_q552_110.a b/ext/dbm/sdbm/libsdbm_pure_q552_110.a Binary files differdeleted file mode 100644 index 3b426e8154..0000000000 --- a/ext/dbm/sdbm/libsdbm_pure_q552_110.a +++ /dev/null diff --git a/ext/dbm/sdbm/makefile b/ext/dbm/sdbm/makefile deleted file mode 100644 index c959c1fab5..0000000000 --- a/ext/dbm/sdbm/makefile +++ /dev/null @@ -1,55 +0,0 @@ -# -# makefile for public domain ndbm-clone: sdbm -# DUFF: use duff's device (loop unroll) in parts of the code -# -CFLAGS = -O -DSDBM -DDUFF -DBSD42 -pic -#LDFLAGS = -p - -OBJS = sdbm.o pair.o hash.o -SRCS = sdbm.c pair.c hash.c dbu.c dba.c dbd.c util.c -HDRS = tune.h sdbm.h pair.h -MISC = README CHANGES COMPARE sdbm.3 dbe.c dbe.1 dbm.c dbm.h biblio \ - readme.ms readme.ps - -all: dbu dba dbd dbe - -dbu: dbu.o sdbm util.o - cc $(LDFLAGS) -o dbu dbu.o util.o libsdbm.a - -dba: dba.o util.o - cc $(LDFLAGS) -o dba dba.o util.o -dbd: dbd.o util.o - cc $(LDFLAGS) -o dbd dbd.o util.o -dbe: dbe.o sdbm - cc $(LDFLAGS) -o dbe dbe.o libsdbm.a - -sdbm: $(OBJS) - ar cr libsdbm.a $(OBJS) - ranlib libsdbm.a -### cp libsdbm.a /usr/lib/libsdbm.a - -dba.o: sdbm.h -dbu.o: sdbm.h -util.o:sdbm.h - -$(OBJS): sdbm.h tune.h pair.h - -# -# dbu using berkelezoid ndbm routines [if you have them] for testing -# -#x-dbu: dbu.o util.o -# cc $(CFLAGS) -o x-dbu dbu.o util.o -lint: - lint -abchx $(SRCS) - -clean: - rm -f *.o mon.out core - -purge: clean - rm -f dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag - -shar: - shar $(MISC) makefile $(SRCS) $(HDRS) >SDBM.SHAR - -readme: - nroff -ms readme.ms | col -b >README diff --git a/ext/dl/dl.c b/ext/dl/dl.c deleted file mode 100644 index d514f81897..0000000000 --- a/ext/dl/dl.c +++ /dev/null @@ -1,54 +0,0 @@ -#include <dlfcn.h> - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -static int -XS_DynamicLoader_bootstrap(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: DynamicLoader::bootstrap(package)"); - } - { - char* package = SvPV(ST(1),na); - void* obj = 0; - int (*bootproc)(); - char tmpbuf[1024]; - char tmpbuf2[128]; - AV *av = GvAVn(incgv); - I32 i; - - for (i = 0; i <= AvFILL(av); i++) { - (void)sprintf(tmpbuf, "%s/auto/%s/%s.so", - SvPVx(*av_fetch(av, i, TRUE), na), package, package); - if (obj = dlopen(tmpbuf,1)) - break; - } - if (!obj) - croak("Can't find loadable object for package %s in @INC", package); - - sprintf(tmpbuf2, "boot_%s", package); - bootproc = (int (*)())dlsym(obj, tmpbuf2); - if (!bootproc) - croak("Shared object %s contains no %s function", tmpbuf, tmpbuf2); - bootproc(); - - ST(0) = sv_mortalcopy(&sv_yes); - } - return ax; -} - -int -boot_DynamicLoader(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("DynamicLoader::bootstrap", 0, XS_DynamicLoader_bootstrap, file); -} diff --git a/ext/dl/dl_hpux.c b/ext/dl/dl_hpux.c deleted file mode 100644 index 57adcc6188..0000000000 --- a/ext/dl/dl_hpux.c +++ /dev/null @@ -1,71 +0,0 @@ -/* -Date: Mon, 25 Apr 94 14:15:30 PDT -From: Jeff Okamoto <okamoto@hpcc101.corp.hp.com> -To: doughera@lafcol.lafayette.edu -Cc: okamoto@hpcc101.corp.hp.com, Jarkko.Hietaniemi@hut.fi, ram@acri.fr, - john@WPI.EDU, k@franz.ww.TU-Berlin.DE, dmm0t@rincewind.mech.virginia.edu, - lwall@netlabs.com -Subject: dl.c.hpux - -This is what I hacked around and came up with for HP-UX. (Or maybe it should -be called dl_hpux.c). Notice the change in suffix from .so to .sl (the -default suffix for HP-UX shared libraries). - -Jeff -*/ -#include <dl.h> - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -static int -XS_DynamicLoader_bootstrap(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: DynamicLoader::bootstrap(package)"); - } - { - char* package = SvPV(ST(1),na); - shl_t obj = NULL; - int (*bootproc)(); - char tmpbuf[1024]; - char tmpbuf2[128]; - AV *av = GvAVn(incgv); - I32 i; - - for (i = 0; i <= AvFILL(av); i++) { - (void)sprintf(tmpbuf, "%s/auto/%s/%s.sl", - SvPVx(*av_fetch(av, i, TRUE), na), package, package); - if (obj = shl_load(tmpbuf, - BIND_IMMEDIATE | BIND_NONFATAL | BIND_NOSTART,0L)) - break; - } - if (obj != (shl_t) NULL) - croak("Can't find loadable object for package %s in @INC", package); - - sprintf(tmpbuf2, "boot_%s", package); - i = shl_findsym(&obj, tmpbuf2, TYPE_PROCEDURE, &bootproc); - if (i == -1) - croak("Shared object %s contains no %s function", tmpbuf, tmpbuf2); - bootproc(); - - ST(0) = sv_mortalcopy(&sv_yes); - } - return ax; -} - -int -boot_DynamicLoader(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("DynamicLoader::bootstrap", 0, XS_DynamicLoader_bootstrap, file); -} - diff --git a/ext/dl/dl_next.c b/ext/dl/dl_next.c deleted file mode 100644 index 66e95121de..0000000000 --- a/ext/dl/dl_next.c +++ /dev/null @@ -1,69 +0,0 @@ -/* dl_next.c - Author: tom@smart.bo.open.de (Thomas Neumann). - Based on dl_sunos.c -*/ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include <mach-o/rld.h> -#include <streams/streams.h> - -static int -XS_DynamicLoader_bootstrap(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: DynamicLoader::bootstrap(package)"); - } - { - char* package = SvPV(ST(1),na); - int rld_success; - NXStream *nxerr = NXOpenFile(fileno(stderr), NX_READONLY); - int (*bootproc)(); - char tmpbuf[1024]; - char tmpbuf2[128]; - AV *av = GvAVn(incgv); - I32 i; - - for (i = 0; i <= AvFILL(av); i++) { - char *p[2]; - p[0] = tmpbuf; - p[1] = 0; - sprintf(tmpbuf, "%s/auto/%s/%s.so", - SvPVx(*av_fetch(av, i, TRUE), na), package, package); - if (rld_success = rld_load(nxerr, (struct mach_header **)0, p, - (const char *)0)) - { - break; - } - } - if (!rld_success) { - NXClose(nxerr); - croak("Can't find loadable object for package %s in @INC", package); - - } - sprintf(tmpbuf2, "_boot_%s", package); - if (!rld_lookup(nxerr, tmpbuf2, (unsigned long *)&bootproc)) { - NXClose(nxerr); - croak("Shared object %s contains no %s function", tmpbuf, tmpbuf2); - } - NXClose(nxerr); - (*bootproc)(); - ST(0) = sv_mortalcopy(&sv_yes); - } - return ax; -} - -int -boot_DynamicLoader(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("DynamicLoader::bootstrap", 0, XS_DynamicLoader_bootstrap, file); -} diff --git a/ext/dl/dl_sunos.c b/ext/dl/dl_sunos.c deleted file mode 100644 index badd66d678..0000000000 --- a/ext/dl/dl_sunos.c +++ /dev/null @@ -1,56 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifdef I_DLFCN -# include <dlfcn.h> -#endif - -static int -XS_DynamicLoader_bootstrap(ix, ax, items) -register int ix; -register int ax; -register int items; -{ - if (items < 1 || items > 1) { - croak("Usage: DynamicLoader::bootstrap(package)"); - } - { - char* package = SvPV(ST(1),na); - void* obj = 0; - int (*bootproc)(); - char tmpbuf[1024]; - char tmpbuf2[128]; - AV *av = GvAVn(incgv); - I32 i; - - for (i = 0; i <= AvFILL(av); i++) { - (void)sprintf(tmpbuf, "%s/auto/%s/%s.so", - SvPVx(*av_fetch(av, i, TRUE), na), package, package); - if (obj = dlopen(tmpbuf,1)) - break; - } - if (!obj) - croak("Can't find loadable object for package %s in @INC", package); - - sprintf(tmpbuf2, "boot_%s", package); - bootproc = (int (*)())dlsym(obj, tmpbuf2); - if (!bootproc) - croak("Shared object %s contains no %s function", tmpbuf, tmpbuf2); - bootproc(); - - ST(0) = sv_mortalcopy(&sv_yes); - } - return ax; -} - -int -boot_DynamicLoader(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - - newXSUB("DynamicLoader::bootstrap", 0, XS_DynamicLoader_bootstrap, file); -} diff --git a/ext/dl/eg/Makefile b/ext/dl/eg/Makefile deleted file mode 100644 index d1ae210730..0000000000 --- a/ext/dl/eg/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -CC = /vol/apps/lucid-3.1/lcc - -all: main test test1 -main: main.c - $(CC) -g -o main main.c -ldl - -test.o: test.c - $(CC) -g -pic -c test.c - -test: test.o - ld -o test -assert pure-text test.o - -test1.o: test1.c - $(CC) -g -pic -c test1.c - -test1: test1.o - ld -o test1 -assert pure-text test1.o - -clean: - /bin/rm -f *.o test test1 main diff --git a/ext/dl/eg/Makefile.att b/ext/dl/eg/Makefile.att deleted file mode 100644 index 435b916f67..0000000000 --- a/ext/dl/eg/Makefile.att +++ /dev/null @@ -1,18 +0,0 @@ -all: main test test1 -main: main.c - cc -g -o main main.c -ldl - -test.o: test.c - cc -g -pic -c test.c - -test: test.o - cc -o test -G test.o - -test1.o: test1.c - cc -g -pic -c test1.c - -test1: test1.o - cc -o test1 -G test1.o - -clean: - /bin/rm -f *.o test test1 main diff --git a/ext/dl/eg/main.c b/ext/dl/eg/main.c deleted file mode 100644 index ac0155453e..0000000000 --- a/ext/dl/eg/main.c +++ /dev/null @@ -1,28 +0,0 @@ -#include <dlfcn.h> -#include <stdio.h> - -main(argc, argv, arge) -int argc; -char **argv; -char **arge; -{ - void *obj; - void (*proc)(); - void *obj1; - void (*proc1)(); - - if (!(obj = dlopen("test", 1))) - fprintf(stderr, "%s\n", dlerror()); - if (!(obj1 = dlopen("test1", 1))) - fprintf(stderr, "%s\n", dlerror()); - proc = (void (*)())dlsym(obj, "test"); - proc1 = (void (*)())dlsym(obj1, "test1"); - proc(); - proc1(); - dlclose(obj); -} - -void print() -{ - printf("got here!\n"); -} diff --git a/ext/dl/eg/test b/ext/dl/eg/test Binary files differdeleted file mode 100755 index 2a8b92570e..0000000000 --- a/ext/dl/eg/test +++ /dev/null diff --git a/ext/dl/eg/test.c b/ext/dl/eg/test.c deleted file mode 100644 index a66db198cf..0000000000 --- a/ext/dl/eg/test.c +++ /dev/null @@ -1,4 +0,0 @@ -test() -{ - print(); -} diff --git a/ext/dl/eg/test1 b/ext/dl/eg/test1 Binary files differdeleted file mode 100755 index e9a37e9e53..0000000000 --- a/ext/dl/eg/test1 +++ /dev/null diff --git a/ext/dl/eg/test1.c b/ext/dl/eg/test1.c deleted file mode 100644 index fc7b1b2cc2..0000000000 --- a/ext/dl/eg/test1.c +++ /dev/null @@ -1,11 +0,0 @@ -#include <dlfcn.h> - -test1() -{ - void *obj; - void (*proc)(); - - obj = dlopen("test", 1); - proc = (void (*)())dlsym(obj, "test"); - proc(); -} diff --git a/ext/man2mus b/ext/man2mus deleted file mode 100644 index a3046784f4..0000000000 --- a/ext/man2mus +++ /dev/null @@ -1,66 +0,0 @@ -#!/usr/bin/perl -while (<>) { - if (/^\.SH SYNOPSIS/) { - $spec = ''; - for ($_ = <>; $_ && !/^\.SH/; $_ = <>) { - s/^\.[IRB][IRB]\s*//; - s/^\.[IRB]\s+//; - next if /^\./; - s/\\f\w//g; - s/\\&//g; - s/^\s+//; - next if /^$/; - next if /^#/; - $spec .= $_; - } - $_ = $spec; - 0 while s/\(([^),;]*)\s*,\s*([^);]*)\)/($1|$2)/g; - s/\(\*([^,;]*)\)\(\)/(*)()$1/g; - s/(\w+)\[\]/*$1/g; - - s/\n/ /g; - s/\s+/ /g; - s/(\w+) \(([^*])/$1($2/g; - s/^ //; - s/ ?; ?/\n/g; - s/\) /)\n/g; - s/ \* / \*/g; - s/\* / \*/g; - - $* = 1; - 0 while s/^((struct )?\w+ )([^\n,]*), ?(.*)/$1$3\n$1$4/g; - $* = 0; - s/\|/,/g; - - @cases = (); - for (reverse split(/\n/,$_)) { - if (/\)$/) { - ($type,$name,$args) = split(/(\w+)\(/); - $type =~ s/ $//; - if ($type =~ /^(\w+) =/) { - $type = $type{$1} if $type{$1}; - } - $type = 'int' if $type eq ''; - @args = grep(/./, split(/[,)]/,$args)); - $case = "CASE $type $name\n"; - foreach $arg (@args) { - $type = $type{$arg} || "int"; - $type =~ s/ //g; - $type .= "\t" if length($type) < 8; - if ($type =~ /\*/) { - $case .= "IO $type $arg\n"; - } - else { - $case .= "I $type $arg\n"; - } - } - $case .= "END\n\n"; - unshift(@cases, $case); - } - else { - $type{$name} = $type if ($type,$name) = /(.*\W)(\w+)$/; - } - } - print @cases; - } -} diff --git a/ext/mus b/ext/mus deleted file mode 100644 index b1675fdc58..0000000000 --- a/ext/mus +++ /dev/null @@ -1,135 +0,0 @@ -#!/usr/bin/perl - -while (<>) { - if (s/^CASE\s+//) { - @fields = split; - $funcname = pop(@fields); - $rettype = "@fields"; - @modes = (); - @types = (); - @names = (); - @outies = (); - @callnames = (); - $pre = "\n"; - $post = ''; - - while (<>) { - last unless /^[IO]+\s/; - @fields = split(' '); - push(@modes, shift(@fields)); - push(@names, pop(@fields)); - push(@types, "@fields"); - } - while (s/^<\s//) { - $pre .= "\t $_"; - $_ = <>; - } - while (s/^>\s//) { - $post .= "\t $_"; - $_ = <>; - } - $items = @names; - $namelist = '$' . join(', $', @names); - $namelist = '' if $namelist eq '$'; - print <<EOF; - case US_$funcname: - if (items != $items) - fatal("Usage: &$funcname($namelist)"); - else { -EOF - if ($rettype eq 'void') { - print <<EOF; - int retval = 1; -EOF - } - else { - print <<EOF; - $rettype retval; -EOF - } - foreach $i (1..@names) { - $mode = $modes[$i-1]; - $type = $types[$i-1]; - $name = $names[$i-1]; - if ($type =~ /^[A-Z]+\*$/) { - $cast = "*($type*)"; - } - else { - $cast = "($type)"; - } - $what = ($type =~ /^(struct\s+\w+|char|[A-Z]+)\s*\*$/ ? "get" : "gnum"); - $type .= "\t" if length($type) < 4; - $cast .= "\t" if length($cast) < 8; - $x = "\t" x (length($name) < 6); - if ($mode =~ /O/) { - if ($what eq 'gnum') { - push(@outies, "\t str_numset(st[$i], (double) $name);\n"); - push(@callnames, "&$name"); - } - else { - push(@outies, "\t str_set(st[$i], (char*) $name);\n"); - push(@callnames, "$name"); - } - } - else { - push(@callnames, $name); - } - if ($mode =~ /I/) { - print <<EOF; - $type $name =$x $cast str_$what(st[$i]); -EOF - } - elsif ($type =~ /char/) { - print <<EOF; - char ${name}[133]; -EOF - } - else { - print <<EOF; - $type $name; -EOF - } - } - $callnames = join(', ', @callnames); - $outies = join("\n",@outies); - if ($rettype eq 'void') { - print <<EOF; -$pre (void)$funcname($callnames); -EOF - } - else { - print <<EOF; -$pre retval = $funcname($callnames); -EOF - } - if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) { - print <<EOF; - str_set(st[0], (char*) retval); -EOF - } - elsif ($rettype =~ /^[A-Z]+\s*\*$/) { - print <<EOF; - str_nset(st[0], (char*) &retval, sizeof retval); -EOF - } - else { - print <<EOF; - str_numset(st[0], (double) retval); -EOF - } - print $outies if $outies; - print $post if $post; - if (/^END/) { - print "\t}\n\treturn sp;\n"; - } - else { - redo; - } - } - elsif (/^END/) { - print "\t}\n\treturn sp;\n"; - } - else { - print; - } -} diff --git a/ext/posix/typemap b/ext/posix/typemap deleted file mode 100644 index e339f10c49..0000000000 --- a/ext/posix/typemap +++ /dev/null @@ -1,11 +0,0 @@ -mode_t T_NV -pid_t T_NV -Uid_t T_NV -Time_t T_NV -Gid_t T_NV -Off_t T_NV -fd T_IV -FILE * T_PTR -FileHandle T_PTROBJ -POSIX::SigSet T_PTROBJ -POSIX::SigAction T_HVOBJ diff --git a/ext/typemap b/ext/typemap index 1d0c9baef3..98493e7c04 100644 --- a/ext/typemap +++ b/ext/typemap @@ -3,24 +3,32 @@ int T_IV unsigned T_IV unsigned int T_IV -long T_NV -unsigned long T_NV +long T_IV +unsigned long T_IV short T_IV unsigned short T_IV char T_CHAR unsigned char T_U_CHAR -char * T_STRING -unsigned char * T_STRING -caddr_t T_STRING +char * T_PV +unsigned char * T_PV +caddr_t T_PV +wchar_t * T_PV +wchar_t T_IV +bool_t T_IV +size_t T_IV +ssize_t T_IV +time_t T_NV unsigned long * T_OPAQUEPTR char ** T_PACKED void * T_PTR +Time_t * T_PV SV * T_SV -SV * T_SVOBJ -AV * T_AVOBJ -HV * T_HVOBJ -CV * T_CVOBJ +SVREF T_SVREF +AV * T_AVREF +HV * T_HVREF +CV * T_CVREF +IV T_IV I32 T_IV I16 T_IV I8 T_IV @@ -28,30 +36,36 @@ U32 T_U_LONG U16 T_U_SHORT U8 T_IV Result T_U_CHAR -Boolean T_U_CHAR +Boolean T_IV double T_DOUBLE SysRet T_SYSRET +SysRetLong T_SYSRET +FILE * T_IN +FileHandle T_PTROBJ +InputStream T_IN +InOutStream T_INOUT +OutputStream T_OUT ############################################################################# INPUT T_SV - $var = $arg; -T_SVOBJ + $var = $arg +T_SVREF if (sv_isa($arg, \"${ntype}\")) - $var = (AV*)SvRV($arg); + $var = (SV*)SvRV($arg); else croak(\"$var is not of type ${ntype}\") -T_AVOBJ +T_AVREF if (sv_isa($arg, \"${ntype}\")) $var = (AV*)SvRV($arg); else croak(\"$var is not of type ${ntype}\") -T_HVOBJ +T_HVREF if (sv_isa($arg, \"${ntype}\")) $var = (HV*)SvRV($arg); else croak(\"$var is not of type ${ntype}\") -T_CVOBJ +T_CVREF if (sv_isa($arg, \"${ntype}\")) $var = (CV*)SvRV($arg); else @@ -84,30 +98,41 @@ T_NV $var = ($type)SvNV($arg) T_DOUBLE $var = (double)SvNV($arg) -T_STRING - $var = SvPV($arg,na) +T_PV + $var = ($type)SvPV($arg,na) T_PTR - $var = ($type)(unsigned long)SvNV($arg) + $var = ($type)SvIV($arg) T_PTRREF if (SvROK($arg)) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV($arg)); + IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } else croak(\"$var is not a reference\") +T_REF_IV_REF + if (sv_isa($arg, \"${type}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *($type *) tmp; + } + else + croak(\"$var is not of type ${ntype}\") +T_REF_IV_PTR + if (sv_isa($arg, \"${type}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = ($type) tmp; + } + else + croak(\"$var is not of type ${ntype}\") T_PTROBJ if (sv_isa($arg, \"${ntype}\")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV($arg)); + IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } else croak(\"$var is not of type ${ntype}\") T_PTRDESC if (sv_isa($arg, \"${ntype}\")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV($arg)); + IV tmp = SvIV((SV*)SvRV($arg)); ${type}_desc = (\U${type}_DESC\E*) tmp; $var = ${type}_desc->ptr; } @@ -115,16 +140,14 @@ T_PTRDESC croak(\"$var is not of type ${ntype}\") T_REFREF if (SvROK($arg)) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV($arg)); + IV tmp = SvIV((SV*)SvRV($arg)); $var = *($type) tmp; } else croak(\"$var is not a reference\") T_REFOBJ if (sv_isa($arg, \"${ntype}\")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV($arg)); + IV tmp = SvIV((SV*)SvRV($arg)); $var = *($type) tmp; } else @@ -145,61 +168,71 @@ T_ARRAY while (items--) { DO_ARRAY_ELEM; } +T_IN + $var = IoIFP(sv_2io($arg)) +T_INOUT + $var = IoIFP(sv_2io($arg)) +T_OUT + $var = IoOFP(sv_2io($arg)) ############################################################################# OUTPUT T_SV $arg = $var; -T_SVOBJ +T_SVREF $arg = newRV((SV*)$var); -T_AVOBJ +T_AVREF $arg = newRV((SV*)$var); -T_HVOBJ +T_HVREF $arg = newRV((SV*)$var); -T_CVOBJ +T_CVREF $arg = newRV((SV*)$var); T_IV - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); T_INT - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); T_SYSRET if ($var != -1) { if ($var == 0) sv_setpvn($arg, "0 but true", 10); else - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); } T_ENUM - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); T_U_INT - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); T_SHORT - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); T_U_SHORT - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); T_LONG - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); T_U_LONG - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); T_CHAR sv_setpvn($arg, (char *)&$var, 1); T_U_CHAR - sv_setiv($arg, (I32)$var); + sv_setiv($arg, (IV)$var); T_FLOAT sv_setnv($arg, (double)$var); T_NV sv_setnv($arg, (double)$var); T_DOUBLE sv_setnv($arg, (double)$var); -T_STRING - sv_setpv($arg, $var); +T_PV + sv_setpv((SV*)$arg, $var); T_PTR - sv_setnv($arg, (double)(unsigned long)$var); + sv_setiv($arg, (IV)$var); T_PTRREF - sv_setptrref($arg, $var); + sv_setref_pv($arg, Nullch, (void*)$var); +T_REF_IV_REF + sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); +T_REF_IV_PTR + sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTROBJ - sv_setptrobj($arg, $var, \"${ntype}\"); + sv_setref_pv($arg, \"${ntype}\", (void*)$var); T_PTRDESC - sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\"); + sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); T_REFREF sv_setrefref($arg, \"${ntype}\", XS_service_$ntype, ($var ? (void*)new $ntype($var) : 0)); @@ -225,3 +258,27 @@ T_ARRAY DO_ARRAY_ELEM } sp += $var.size - 1; +T_IN + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "<&", 2, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &sv_undef; + } +T_INOUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+<&", 3, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &sv_undef; + } +T_OUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+>&", 3, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &sv_undef; + } diff --git a/ext/typemap.oi b/ext/typemap.oi deleted file mode 100644 index fc93718b93..0000000000 --- a/ext/typemap.oi +++ /dev/null @@ -1,99 +0,0 @@ -# -#################################### PARCPLACE OI SECTION -# - -# basic OI types -OI_alignment T_ENUM -OI_bevel_style T_ENUM -OI_bool T_ENUM -OI_charset T_ENUM -OI_char_encode_type T_ENUM -OI_configure_mask T_ENUM -OI_drop_type T_ENUM -OI_ef_char_chk_status T_ENUM -OI_ef_entry_chk_status T_ENUM -OI_ef_mode T_ENUM -OI_enhance T_ENUM -OI_gravity T_ENUM -OI_gauge_ends T_ENUM -OI_gauge_ticks T_ENUM -OI_layout T_INT -OI_menu_cell_type T_ENUM -OI_mnemonic_style T_ENUM -OI_model_type T_ENUM -OI_mt_char_chk_status T_ENUM -OI_mt_entry_chk_status T_ENUM -OI_mt_mode T_ENUM -OI_number T_SHORT -OI_number * T_OPAQUEPTR -OI_orient T_ENUM -OI_pic_type T_ENUM -OI_pic_pixel T_ENUM -OI_psn_type T_ENUM -OI_rm_db T_ENUM -OI_sav_rst_typ T_ENUM -OI_scroll_event T_ENUM -OI_size_track T_ENUM -OI_slider_current T_ENUM -OI_slider_ends T_ENUM -OI_slider_ticks T_ENUM -OI_stat T_ENUM -OI_state T_ENUM -OI_wm_state T_ENUM -PIXEL T_LONG - -# OI classes -OI_abbr_menu * T_PTR -OI_animate_item * T_PTR -OI_app_window * T_PTR -OI_base_text * T_PTR -OI_box * T_PTR -OI_button_menu * T_PTR -OI_command_dialog_box * T_PTR -OI_excl_menu * T_PTR -OI_excl_check_menu * T_PTR -OI_excl_rect_menu * T_PTR -OI_basic_menu * T_PTR -OI_class * T_PTR -OI_connection * T_PTR -OI_ctlr_1d * T_PTR -OI_d_tech * T_PTR -OI_d_tech ** T_OPAQUEPTR -OI_dialog_box * T_PTR -OI_display_1d * T_PTR -OI_entry_field * T_PTR -OI_error_dialog_box * T_PTR -OI_excl_menu * T_PTR -OI_file_dialog_box * T_PTR -OI_gauge * T_PTR -OI_glyph * T_PTR -OI_help * T_PTR -OI_info_dialog_box * T_PTR -OI_menu * T_PTR -OI_menu_cell * T_PTR -OI_menu_cell ** T_OPAQUEPTR -OI_menu_spec * T_PACKED -OI_message_dialog_box * T_PTR -OI_ms_dialog_box * T_PTR -OI_multi_text * T_PTR -OI_panner * T_PTR -OI_pic_spec_mask * T_PTR -OI_pic_spec_mask ** T_OPAQUEPTR -OI_poly_menu * T_PTR -OI_poly_check_menu * T_PTR -OI_poly_rect_menu * T_PTR -OI_prompt_dialog_box * T_PTR -OI_question_dialog_box * T_PTR -OI_scroll_bar * T_PTR -OI_scroll_box * T_PTR -OI_scroll_menu * T_PTR -OI_scroll_text * T_PTR -OI_select_dialog_box * T_PTR -OI_separator * T_PTR -OI_seq_entry_field * T_PTR -OI_slider * T_PTR -OI_static_text * T_PTR -OI_translation_table * T_PTR -OI_warn_dialog_box * T_PTR -OI_work_dialog_box * T_PTR - diff --git a/ext/typemap.xlib b/ext/typemap.xlib deleted file mode 100644 index b04d13048a..0000000000 --- a/ext/typemap.xlib +++ /dev/null @@ -1,97 +0,0 @@ -# -#################################### XLIB SECTION -# - -# basic X types -Atom T_U_LONG -Atom * T_OPAQUEPTR -Bool T_INT -KeyCode T_U_LONG -Status T_INT -Time T_U_LONG -VisualID T_U_LONG -XID T_U_LONG -GC T_PTR -Display * T_PTR -Screen * T_PTR -Visual * T_PTR -XImage * T_PTR -Region T_PTR - -# things that are XIDs -Colormap T_U_LONG -Cursor T_U_LONG -Drawable T_U_LONG -Font T_U_LONG -GContext T_U_LONG -KeySym T_U_LONG -KeySym * T_OPAQUEPTR -Pixmap T_U_LONG -Pixmap * T_OPAQUEPTR -Window T_U_LONG -Window * T_OPAQUEPTR - -# X resource manager types -XrmDatabase T_PTR -XrmQuark T_INT -XrmQuarkList T_OPAQUEPTR -XrmName T_INT -XrmNameList T_OPAQUEPTR -XrmClass T_INT -XrmClassList T_OPAQUEPTR -XrmRepresentation T_INT -XrmString T_STRING -XrmBinding T_ENUM -XrmBindingList T_OPAQUEPTR -XrmOptionKind T_ENUM -XrmSearchList T_OPAQUEPTR - -# context manager types -XContext T_INT - -# Xlib data structures -XArc * T_OPAQUEPTR -XCharStruct T_OPAQUE -XCharStruct * T_OPAQUEPTR -XColor T_OPAQUE -XColor * T_OPAQUEPTR -XComposeStatus * T_OPAQUEPTR -XEvent T_OPAQUE -XEvent * T_OPAQUEPTR -XFontStruct T_OPAQUE -XFontStruct * T_PTR -XGCValues * T_OPAQUEPTR -XIconSize * T_OPAQUEPTR -XKeyboardControl * T_OPAQUEPTR -XKeyboardState T_OPAQUE -XModifierKeymap * T_PTR -XPoint T_OPAQUE -XPoint * T_OPAQUEPTR -XRectangle T_OPAQUE -XRectangle * T_OPAQUEPTR -XSegment * T_OPAQUEPTR -XSetWindowAttributes * T_OPAQUEPTR -XSizeHints T_OPAQUE -XSizeHints * T_OPAQUEPTR -XStandardColormap T_OPAQUE -XStandardColormap * T_OPAQUEPTR -XTimeCoord * T_OPAQUEPTR -XVisualInfo T_OPAQUE -XVisualInfo * T_OPAQUEPTR -XWindowAttributes T_OPAQUE -XWindowAttributes * T_OPAQUEPTR -XWindowChanges * T_OPAQUEPTR -XWMHints * T_OPAQUEPTR - -# these data types must be handled specially -#XrmValue T_OPAQUE -#XrmValue * T_OPAQUEPTR -#XrmOptionDescList T_OPAQUEPTR -#XClassHint T_OPAQUE -#XClassHint * T_OPAQUEPTR -#XHostAddress * T_OPAQUEPTR -#XTextItem * T_OPAQUEPTR -#XTextItem16 * T_OPAQUEPTR -#XTextProperty T_OPAQUE -#XTextProperty * T_OPAQUEPTR - diff --git a/ext/typemap.xpm b/ext/typemap.xpm deleted file mode 100644 index d1312767f5..0000000000 --- a/ext/typemap.xpm +++ /dev/null @@ -1,7 +0,0 @@ -# -#################################### XPM SECTION -# -XpmAttributes * T_PACKED -XpmColorSymbol * T_PACKED -XpmExtension * T_PACKED - diff --git a/ext/util/extliblist b/ext/util/extliblist new file mode 100755 index 0000000000..2b8938fa4d --- /dev/null +++ b/ext/util/extliblist @@ -0,0 +1,151 @@ +case $CONFIG in +'') + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; +esac +: extliblist +: +: Author: Andy Dougherty doughera@lafcol.lafayette.edu +: +: This utility takes a list of libraries in the form +: -llib1 -llib2 -llib3 +: and prints out lines suitable for inclusion in an extension +: Makefile. +: Extra library paths may be included with the form -L/another/path +: this will affect the searches for all subsequent libraries. +: +: It is intended to be "dotted" from within an extension Makefile.SH. +: see ext/POSIX/Makefile.SH for an example. +: Prior to calling this, the variable potential_libs should be set +: to the potential list of libraries +: +: It sets the following +: extralibs = full list of libraries needed for static linking. +: Only those libraries that actually exist are included. +: dynaloadlibs = full path names of those libraries that are needed +: but can be linked in dynamically on this platform. On +: SunOS, for example, this would be .so* libraries, +: but not archive libraries. +: Eventually, this list can be used to write a bootstrap file. +: statloadlibs = list of those libraries which must be statically +: linked into the shared library. On SunOS 4.1.3, +: for example, I have only an archive version of +: -lm, and it must be linked in statically. +: +: This script uses config.sh variables libs, libpth, and so. It is mostly +: taken from the metaconfig libs.U unit. +extralibs='' +dynaloadlibs='' +statloadlibs='' +Llibpth='' +for thislib in `echo "XXX $potential_libs " | $sed 's/ -l/ /g'` ; do + case "$thislib" in + XXX) + : Handle case where potential_libs is empty. + ;; + -L*) + : Handle possible linker path arguments. + newpath=`echo $thislib | $sed 's/^-L//'` + if $test -d $newpath; then + Llibpth="$Llibpth $newpath" + extralibs="$extralibs $thislib" + statloadlibs="$statloadlibs $thislib" + fi + ;; + *) + : Handle possible library arguments. + for thispth in $Llibpth $libpth; do + : Loop over possible wildcards and take the last one. + for fullname in $thispth/lib$thislib.$so.[0-9]* ; do + : + done + if $test -f $fullname; then + break + elif fullname=$thispth/lib$thislib.$so && $test -f $fullname; then + break + elif fullname=$thispth/lib${thislib}_s.a && $test -f $fullname; then + thislib=${thislib}_s + break + elif fullname=$thispth/lib${thislib}.a && $test -f $fullname; then + break + elif fullname=$thispth/Slib${thislib}.a && $test -f $fullname; then + break + else + fullname='' + fi + done + : Now update library lists + case "$fullname" in + '') + : Skip nonexistent files + ;; + *) + : Do not add it into the extralibs if it is already linked in + : with the main perl executable. + case " $libs " in + *" -l$thislib "*|*" -l${thislib}_s "*) ;; + *) extralibs="$extralibs -l$thislib" ;; + esac + : + : For NeXT and DLD, put files into DYNALOADLIBS to be + : converted into a boostrap file. For other systems, + : we will use ld with what I have misnamed STATLOADLIBS + : to assemble the shared object. + case "$dlsrc" in + dl_dld*|dl_next*) + dynaloadlibs="$dynaloadlibs $fullname" ;; + *) + case "$fullname" in + *.a) + statloadlibs="$statloadlibs -l$thislib" + ;; + *) + : For SunOS4, do not add in this shared library + : if it is already linked in the main + : perl executable + case "$osname" in + sunos) + case " $libs " in + *" -l$thislib "*) ;; + *) statloadlibs="$statloadlibs -l$thislib" ;; + esac + ;; + *) + statloadlibs="$statloadlibs -l$thislib" + ;; + esac + ;; + esac + ;; + esac + ;; + esac + ;; + esac +done + +case "$dlsrc" in +dl_next*) + extralibs=`echo " $extralibs "| $sed -e 's/ -lm / /'` ;; +esac + +set X $extralibs +shift +extralibs="$*" + +set X $dynaloadlibs +shift +dynaloadlibs="$*" + +set X $statloadlibs +shift +statloadlibs="$*" + diff --git a/ext/util/make_ext b/ext/util/make_ext new file mode 100644 index 0000000000..fba77c0c9f --- /dev/null +++ b/ext/util/make_ext @@ -0,0 +1,74 @@ +# This script acts as a simple interface for building extensions. +# It primarily used by the perl Makefile: +# +# d_dummy $(dynamic_ext): miniperl preplibrary FORCE +# ext/util/make_ext dynamic $@ +# +# It may be deleted in a later release of perl so try to +# avoid using it for other purposes. + +linktype=$1 +extspec=$2 + +case $CONFIG in +'') + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh generated by Configure"; exit 1 + fi + . $TOP/config.sh + ;; +esac + +if test "X$extspec" = X; then + echo "make_ext: no extension specified" + exit 1; +fi + +# convert old style Name.a into ext/Name/Name.a format +case "$extspec" in +ext/*) ;; +*) extspec=`echo "$extspec" | sed -e 's:\(.*\)\.\(.*\):ext/\1/\1.\2:'` +esac + +# get extension directory path, module name and depth +pname=`echo "$extspec" | sed -e 's:^ext/::' -e 's:/[^/]*$::'` +mname=`echo "$pname" | sed -e 's!/!::!'` +depth=`echo "$pname" | sed -e 's![^/][^/]*!..!g'` + +if test ! -d "ext/$pname"; then + echo " Skipping $extspec (directory does not exist)" + exit 0 # not an error ? +fi + +# check link type and do any preliminaries +case "$linktype" in +static) makeargs='CCCDLFLAGS=' ;; +dynamic) makeargs='' ;; +*) echo "make_ext: unknown link type '$linktype'"; exit 1;; +'') echo "make_ext: no link type specified (eg static or dynamic)"; exit 1;; +esac + +echo "" +echo " Making $mname ($linktype)" + +cd ext/$pname + +if test ! -f Makefile ; then + test -f Makefile.PL && ../$depth/miniperl -I../$depth/lib Makefile.PL +fi +if test ! -f Makefile ; then + test -f Makefile.SH && sh Makefile.SH +fi + +make=${altmake-make} + +$make config + +$make $linktype $makeargs + +exit $? diff --git a/ext/util/mkbootstrap b/ext/util/mkbootstrap new file mode 100644 index 0000000000..6c3a7e10ed --- /dev/null +++ b/ext/util/mkbootstrap @@ -0,0 +1,5 @@ +#!../../miniperl -w -I../../lib + +use ExtUtils::MakeMaker; +&mkbootstrap(join(" ",@ARGV)); +exit; diff --git a/ext/xsubpp b/ext/xsubpp index bb6972008b..1e13118ad5 100755 --- a/ext/xsubpp +++ b/ext/xsubpp @@ -1,11 +1,13 @@ #!./miniperl +'di '; +'ds 00 \"'; +'ig 00 '; # $Header$ -$usage = "Usage: xsubpp [-ansi] [-C++] [-except] [-tm typemap] file.xs\n"; +$usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n"; SWITCH: while ($ARGV[0] =~ s/^-//) { $flag = shift @ARGV; - $ansiflag = 1, next SWITCH if $flag eq 'ansi'; $spat = shift, next SWITCH if $flag eq 's'; $cplusplus = 1, next SWITCH if $flag eq 'C++'; $except = 1, next SWITCH if $flag eq 'except'; @@ -15,6 +17,7 @@ SWITCH: while ($ARGV[0] =~ s/^-//) { @ARGV == 1 or die $usage; chop($pwd = `pwd`); ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)# + or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)# or ($dir, $filename) = ('.', $ARGV[0]); chdir($dir); @@ -43,7 +46,7 @@ foreach $typemap (@tm) { } else { s/\s*$//; -# $input_expr{$_} = ''; + $input_expr{$_} = ''; $current = \$input_expr{$_}; } } @@ -53,7 +56,7 @@ foreach $typemap (@tm) { } else { s/\s*$//; -# $output_expr{$_} = ''; + $output_expr{$_} = ''; $current = \$output_expr{$_}; } } @@ -76,9 +79,9 @@ sub Q { open(F, $filename) || die "cannot open $filename\n"; while (<F>) { - last if ($Module, $foo, $Package, $foo1, $Prefix) = - /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?$/; - print $_; + last if ($Module, $foo, $Package, $foo1, $Prefix) = + /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/; + print $_; } exit 0 if $_ eq ""; $lastline = $_; @@ -88,17 +91,20 @@ sub fetch_para { @line = (); if ($lastline ne "") { if ($lastline =~ - /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?$/) { + /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) { $Module = $1; $foo = $2; $Package = $3; $foo1 = $4; $Prefix = $5; + ($Module_cname = $Module) =~ s/\W/_/g; ($Packid = $Package) =~ s/:/_/g; $Packprefix = $Package; $Packprefix .= "::" if defined $Packprefix && $Packprefix ne ""; while (<F>) { chop; + next if /^#/ && + !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; last if /^\S/; } push(@line, $_) if $_ ne ""; @@ -108,7 +114,8 @@ sub fetch_para { } $lastline = ""; while (<F>) { - next if /^#/ && !/^#(if|ifdef|else|elif|endif|define|undef)\b/; + next if /^#/ && + !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; chop; if (/^\S/ && @line && $line[-1] eq "") { $lastline = $_; @@ -118,8 +125,9 @@ sub fetch_para { push(@line, $_); } } - pop(@line) while @line && $line[-1] eq ""; + pop(@line) while @line && $line[-1] =~ /^\s*$/; } + $PPCODE = grep(/PPCODE:/, @line); scalar @line; } @@ -135,6 +143,10 @@ while (&fetch_para) { # extract return type, function name and arguments $ret_type = shift(@line); + if ($ret_type =~ /^BOOT:/) { + push (@BootCode, @line, "", "") ; + next ; + } if ($ret_type =~ /^static\s+(.*)$/) { $static = 1; $ret_type = $1; @@ -149,10 +161,17 @@ while (&fetch_para) { push(@Func_name, "${Packid}_$func_name"); push(@Func_pname, $pname); @args = split(/\s*,\s*/, $orig_args); - if (defined($class) && !defined($static)) { + if (defined($class)) { + if (defined($static)) { + unshift(@args, "CLASS"); + $orig_args = "CLASS, $orig_args"; + $orig_args =~ s/^CLASS, $/CLASS/; + } + else { unshift(@args, "THIS"); $orig_args = "THIS, $orig_args"; $orig_args =~ s/^THIS, $/THIS/; + } } $orig_args =~ s/"/\\"/g; $min_args = $num_args = @args; @@ -172,7 +191,7 @@ while (&fetch_para) { $defaults{$args[$i]} =~ s/"/\\"/g; } } - if (defined($class) && !defined($static)) { + if (defined($class)) { $func_args = join(", ", @args[1..$#args]); } else { $func_args = join(", ", @args); @@ -180,23 +199,11 @@ while (&fetch_para) { @args_match{@args} = 1..@args; # print function header - if ($ansiflag) { - print Q<<"EOF"; -#static int -#XS_${Packid}_$func_name(int, int ax, int items) -#[[ -EOF - } - else { - print Q<<"EOF"; -#static int -#XS_${Packid}_$func_name(ix, ax, items) -#register int ix; -#register int ax; -#register int items; + print Q<<"EOF"; +#XS(XS_${Packid}_$func_name) #[[ +# dXSARGS; EOF - } if ($elipsis) { $cond = qq(items < $min_args); } @@ -218,6 +225,10 @@ EOF # } EOF + print Q<<"EOF" if $PPCODE; +# SP -= items; +EOF + # Now do a block of some sort. $condnum = 0; @@ -258,6 +269,9 @@ EOF $_ = shift(@line); last if /^\s*NOT_IMPLEMENTED_YET/; last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/; + # Catch common error. Much more error checking required here. + blurt("Error: no tab in $pname argument declaration '$_'\n") + unless (m/\S+\s*\t\s*\S+/); ($var_type, $var_name, $var_init) = /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/; if ($var_name =~ /^&/) { @@ -286,10 +300,17 @@ EOF print "\t$var_name;\n"; } } - if (!$thisdone && defined($class) && !defined($static)) { + if (!$thisdone && defined($class)) { + if (defined($static)) { + print "\tchar *"; + $var_types{"CLASS"} = "char *"; + &generate_init("char *", 1, "CLASS"); + } + else { print "\t$class *"; $var_types{"THIS"} = "$class *"; &generate_init("$class *", 1, "THIS"); + } } # do code @@ -303,14 +324,14 @@ EOF $var_types{"RETVAL"} = $ret_type; } if (/^\s*PPCODE:/) { - print "\tdSP;\n"; print $deferred; while (@line) { $_ = shift(@line); - last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; + die "PPCODE must be last thing" + if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; print "$_\n"; } - print "\tax = sp - stack_base;\n"; + print "\tPUTBACK;\n\treturn;\n"; } elsif (/^\s*CODE:/) { print $deferred; while (@line) { @@ -318,6 +339,10 @@ EOF last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; print "$_\n"; } + } elsif ($func_name eq "DESTROY") { + print $deferred; + print "\n\t"; + print "delete THIS;\n" } else { print $deferred; print "\n\t"; @@ -325,7 +350,12 @@ EOF print "RETVAL = "; } if (defined($static)) { + if ($func_name =~ /^new/) { + $func_name = "$class"; + } + else { print "$class::"; + } } elsif (defined($class)) { print "THIS->"; } @@ -346,7 +376,7 @@ EOF s/^\s+//; ($outarg, $outcode) = split(/\t+/); if ($outcode) { - print "\t$outcode\n"; + print "\t$outcode\n"; } else { die "$outarg not an argument" unless defined($args_match{$outarg}); @@ -383,12 +413,17 @@ EOF unshift(@line, $_); } } + print Q<<EOF if $except; # if (errbuf[0]) # croak(errbuf); EOF + + print Q<<EOF unless $PPCODE; +# XSRETURN(1); +EOF + print Q<<EOF; -# return ax; #]] # EOF @@ -397,24 +432,32 @@ EOF # print initialization routine print qq/extern "C"\n/ if $cplusplus; print Q<<"EOF"; -#int boot_$Module(ix,ax,items) -#int ix; -#int ax; -#int items; +#XS(boot_$Module_cname) #[[ +# dXSARGS; # char* file = __FILE__; # EOF for (@Func_name) { $pname = shift(@Func_pname); - print " newXSUB(\"$pname\", 0, XS_$_, file);\n"; + print " newXS(\"$pname\", XS_$_, file);\n"; +} + +if (@BootCode) +{ + print "\n /* Initialisation Section */\n\n" ; + print grep (s/$/\n/, @BootCode) ; + print " /* End of Initialisation Section */\n\n" ; } + +print " ST(0) = &sv_yes;\n"; +print " XSRETURN(1);\n"; print "}\n"; sub output_init { local($type, $num, $init) = @_; - local($arg) = "ST($num)"; + local($arg) = "ST(" . ($num - 1) . ")"; eval qq/print " $init\\\n"/; } @@ -423,7 +466,7 @@ sub blurt { warn @_; $errors++ } sub generate_init { local($type, $num, $var) = @_; - local($arg) = "ST($num)"; + local($arg) = "ST(" . ($num - 1) . ")"; local($argoff) = $num - 1; local($ntype); local($tk); @@ -443,7 +486,7 @@ sub generate_init { $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]/; + $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; $expr =~ s/DO_ARRAY_ELEM/$subexpr/; } if (defined($defaults{$var})) { @@ -461,7 +504,7 @@ sub generate_init { sub generate_output { local($type, $num, $var) = @_; - local($arg) = "ST($num)"; + local($arg) = "ST(" . ($num - ($num != 0)) . ")"; local($argoff) = $num - 1; local($ntype); @@ -483,18 +526,27 @@ sub generate_output { $subexpr =~ s/\$var/${var}[ix_$var]/g; $subexpr =~ s/\n\t/\n\t\t/g; $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; - eval "print qq\f$expr\f"; + eval "print qq\a$expr\a"; } - elsif ($arg eq 'ST(0)') { + elsif ($var eq 'RETVAL') { if ($expr =~ /^\t\$arg = /) { - eval "print qq\f$expr\f"; + eval "print qq\a$expr\a"; print "\tsv_2mortal(ST(0));\n"; } else { print "\tST(0) = sv_newmortal();\n"; - eval "print qq\f$expr\f"; + eval "print qq\a$expr\a"; } } + elsif ($arg =~ /^ST\(\d+\)$/) { + eval "print qq\a$expr\a"; + } + elsif ($arg =~ /^ST\(\d+\)$/) { + eval "print qq\a$expr\a"; + } + elsif ($arg =~ /^ST\(\d+\)$/) { + eval "print qq\a$expr\a"; + } } } @@ -510,3 +562,55 @@ sub map_type { } exit $errors; + +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00 ; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +'; __END__ ############# From here on it's a standard manual page ############ +.TH XSUBPP 1 "August 9, 1994" +.AT 3 +.SH NAME +xsubpp \- compiler to convert Perl XS code into C code +.SH SYNOPSIS +.B xsubpp [-C++] [-except] [-typemap typemap] file.xs +.SH DESCRIPTION +.I xsubpp +will compile XS code into C code by embedding the constructs necessary to +let C functions manipulate Perl values and creates the glue necessary to let +Perl access those functions. The compiler uses typemaps to determine how +to map C function parameters and variables to Perl values. +.PP +The compiler will search for typemap files called +.I typemap. +It will use the following search path to find default typemaps, with the +rightmost typemap taking precedence. +.br +.nf + ../../../typemap:../../typemap:../typemap:typemap +.fi +.SH OPTIONS +.TP +.B \-C++ +.br +Adds ``extern "C"'' to the C code. +.TP +.B \-except +Adds exception handling stubs to the C code. +.TP +.B \-typemap typemap +Indicates that a user-supplied typemap should take precedence over the +default typemaps. This option may be used multiple times, with the last +typemap having the highest precedence. +.SH ENVIRONMENT +No environment variables are used. +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +perl(1) +.ex diff --git a/ext/xsubpp.bak b/ext/xsubpp.bak deleted file mode 100755 index 0f309e3cd2..0000000000 --- a/ext/xsubpp.bak +++ /dev/null @@ -1,529 +0,0 @@ -#!/usr/bin/perl -# $Header$ - -$usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n"; -die $usage unless (@ARGV >= 2 && @ARGV <= 6); - -SWITCH: while ($ARGV[0] =~ /^-/) { - $flag = shift @ARGV; - $aflag = 1, next SWITCH if $flag =~ /^-a$/; - $spat = $1, next SWITCH if $flag =~ /^-s(.*)$/; - $cflag = 1, next SWITCH if $flag =~ /^-c$/; - $eflag = 1, next SWITCH if $flag =~ /^-e$/; - die $usage; -} - -$typemap = shift @ARGV; -open(TYPEMAP, $typemap) || die "cannot open $typemap\n"; -while (<TYPEMAP>) { - next if /^\s*$/ || /^#/; - chop; - ($typename, $kind) = split(/\t+/, $_, 2); - $type_kind{$typename} = $kind; -} -close(TYPEMAP); - -%input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END')); - -T_INT - $var = (int)SvIVn($arg) -T_ENUM - $var = ($type)SvIVn($arg) -T_U_INT - $var = (unsigned int)SvIVn($arg) -T_SHORT - $var = (short)SvIVn($arg) -T_U_SHORT - $var = (unsigned short)SvIVn($arg) -T_LONG - $var = (long)SvIVn($arg) -T_U_LONG - $var = (unsigned long)SvIVn($arg) -T_CHAR - $var = (char)*SvPVn($arg,na) -T_U_CHAR - $var = (unsigned char)SvIVn($arg) -T_FLOAT - $var = (float)SvNVn($arg) -T_DOUBLE - $var = SvNVn($arg) -T_STRING - $var = SvPVn($arg,na) -T_PTR - $var = ($type)(unsigned long)SvNVn($arg) -T_PTRREF - if (SvTYPE($arg) == SVt_REF) - $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg)); - else - croak(\"$var is not a reference\") -T_PTROBJ - if (sv_isa($arg, \"${ntype}\")) - $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg)); - else - croak(\"$var is not of type ${ntype}\") -T_PTRDESC - if (sv_isa($arg, \"${ntype}\")) { - ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNVn((SV*)SvANY($arg)); - $var = ${type}_desc->ptr; - } - else - croak(\"$var is not of type ${ntype}\") -T_REFREF - if (SvTYPE($arg) == SVt_REF) - $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg)); - else - croak(\"$var is not a reference\") -T_REFOBJ - if (sv_isa($arg, \"${ntype}\")) - $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg)); - else - croak(\"$var is not of type ${ntype}\") -T_OPAQUE - $var NOT IMPLEMENTED -T_OPAQUEPTR - $var = ($type)SvPVn($arg,na) -T_PACKED - $var = XS_unpack_$ntype($arg) -T_PACKEDARRAY - $var = XS_unpack_$ntype($arg) -T_CALLBACK - $var = make_perl_cb_$type($arg) -T_ARRAY - $var = $ntype(items -= $argoff); - U32 ix_$var = $argoff; - while (items--) { - DO_ARRAY_ELEM; - } -T_DATUM - $var.dptr = SvPVn($arg, $var.dsize); -T_GDATUM - UNIMPLEMENTED -T_PLACEHOLDER -T_END - -$* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0; -T_INT - sv_setiv($arg, (I32)$var); -T_ENUM - sv_setiv($arg, (I32)$var); -T_U_INT - sv_setiv($arg, (I32)$var); -T_SHORT - sv_setiv($arg, (I32)$var); -T_U_SHORT - sv_setiv($arg, (I32)$var); -T_LONG - sv_setiv($arg, (I32)$var); -T_U_LONG - sv_setiv($arg, (I32)$var); -T_CHAR - sv_setpvn($arg, (char *)&$var, 1); -T_U_CHAR - sv_setiv($arg, (I32)$var); -T_FLOAT - sv_setnv($arg, (double)$var); -T_DOUBLE - sv_setnv($arg, $var); -T_STRING - sv_setpv($arg, $var); -T_PTR - sv_setnv($arg, (double)(unsigned long)$var); -T_PTRREF - sv_setptrref($arg, $var); -T_PTROBJ - sv_setptrobj($arg, $var, \"${ntype}\"); -T_PTRDESC - sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\"); -T_REFREF - sv_setrefref($arg, \"${ntype}\", XS_service_$ntype, - ($var ? (void*)new $ntype($var) : 0)); -T_REFOBJ - NOT IMPLEMENTED -T_OPAQUE - sv_setpvn($arg, (char *)&$var, sizeof($var)); -T_OPAQUEPTR - sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var); -T_PACKED - XS_pack_$ntype($arg, $var); -T_PACKEDARRAY - XS_pack_$ntype($arg, $var, count_$ntype); -T_DATAUNIT - sv_setpvn($arg, $var.chp(), $var.size()); -T_CALLBACK - sv_setpvn($arg, $var.context.value().chp(), - $var.context.value().size()); -T_ARRAY - ST_EXTEND($var.size); - for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) { - ST(ix_$var) = sv_mortalcopy(&sv_undef); - DO_ARRAY_ELEM - } - sp += $var.size - 1; -T_DATUM - sv_setpvn($arg, $var.dptr, $var.dsize); -T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); -T_END - -$uvfile = shift @ARGV; -open(F, $uvfile) || die "cannot open $uvfile\n"; - -if ($eflag) { - print qq|#include "cfm/basic.h"\n|; -} - -while (<F>) { - last if ($Module, $foo, $Package, $foo1, $Prefix) = - /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/; - print $_; -} -$Pack = $Package; -$Package .= "::" if defined $Package && $Package ne ""; -$/ = ""; - -while (<F>) { - # parse paragraph - chop; - next if /^\s*$/; - next if /^(#.*\n?)+$/; - if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/) { - $Module = $1; - $foo = $2; - $Package = $3; - $Pack = $Package; - $foo1 = $4; - $Prefix = $5; - $Package .= "::" if defined $Package && $Package ne ""; - next; - } - split(/[\t ]*\n/); - - # initialize info arrays - undef(%args_match); - undef(%var_types); - undef(%var_addr); - undef(%defaults); - undef($class); - undef($static); - undef($elipsis); - - # extract return type, function name and arguments - $ret_type = shift(@_); - if ($ret_type =~ /^static\s+(.*)$/) { - $static = 1; - $ret_type = $1; - } - $func_header = shift(@_); - ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/; - if ($func_name =~ /(.*)::(.*)/) { - $class = $1; - $func_name = $2; - } - ($pname = $func_name) =~ s/^($Prefix)?/$Package/; - push(@Func_name, "${Pack}_$func_name"); - push(@Func_pname, $pname); - @args = split(/\s*,\s*/, $orig_args); - if (defined($class) && !defined($static)) { - unshift(@args, "THIS"); - $orig_args = "THIS, $orig_args"; - $orig_args =~ s/^THIS, $/THIS/; - } - $orig_args =~ s/"/\\"/g; - $min_args = $num_args = @args; - foreach $i (0..$num_args-1) { - if ($args[$i] =~ s/\.\.\.//) { - $elipsis = 1; - $min_args--; - if ($args[i] eq '' && $i == $num_args - 1) { - pop(@args); - last; - } - } - if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) { - $min_args--; - $args[$i] = $1; - $defaults{$args[$i]} = $2; - $defaults{$args[$i]} =~ s/"/\\"/g; - } - } - if (defined($class) && !defined($static)) { - $func_args = join(", ", @args[1..$#args]); - } else { - $func_args = join(", ", @args); - } - @args_match{@args} = 1..@args; - - # print function header - print <<"EOF" if $aflag; -static int -XS_${Pack}_$func_name(int, int sp, int items) -EOF - print <<"EOF" if !$aflag; -static int -XS_${Pack}_$func_name(ix, sp, items) -register int ix; -register int sp; -register int items; -EOF - print <<"EOF" if $elipsis; -{ - if (items < $min_args) { - croak("Usage: $pname($orig_args)"); - } -EOF - print <<"EOF" if !$elipsis; -{ - if (items < $min_args || items > $num_args) { - croak("Usage: $pname($orig_args)"); - } -EOF - -# Now do a block of some sort. - -$condnum = 0; -if (!@_) { - @_ = "CLEANUP:"; -} -while (@_) { - if ($_[0] =~ s/^\s*CASE\s*:\s*//) { - $cond = shift(@_); - if ($condnum == 0) { - print " if ($cond)\n"; - } - elsif ($cond ne '') { - print " else if ($cond)\n"; - } - else { - print " else\n"; - } - $condnum++; - } - - print <<"EOF" if $eflag; - TRY { -EOF - print <<"EOF" if !$eflag; - { -EOF - - # do initialization of input variables - $thisdone = 0; - $retvaldone = 0; - $deferred = ""; - while ($_ = shift(@_)) { - last if /^\s*NOT_IMPLEMENTED_YET/; - last if /^\s*(CODE|OUTPUT|CLEANUP|CASE)\s*:/; - ($var_type, $var_name, $var_init) = - /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/; - if ($var_name =~ /^&/) { - $var_name =~ s/^&//; - $var_addr{$var_name} = 1; - } - $thisdone |= $var_name eq "THIS"; - $retvaldone |= $var_name eq "RETVAL"; - $var_types{$var_name} = $var_type; - print "\t" . &map_type($var_type); - $var_num = $args_match{$var_name}; - if ($var_addr{$var_name}) { - $func_args =~ s/\b($var_name)\b/&\1/; - } - if ($var_init !~ /^=\s*NO_INIT\s*$/) { - if ($var_init !~ /^\s*$/) { - &output_init($var_type, $var_num, - "$var_name $var_init"); - } elsif ($var_num) { - # generate initialization code - &generate_init($var_type, $var_num, $var_name); - } else { - print ";\n"; - } - } else { - print "\t$var_name;\n"; - } - } - if (!$thisdone && defined($class) && !defined($static)) { - print "\t$class *"; - $var_types{"THIS"} = "$class *"; - &generate_init("$class *", 1, "THIS"); - } - - # do code - if (/^\s*NOT_IMPLEMENTED_YET/) { - print "\ncroak(\"$pname: not implemented yet\");\n"; - } else { - if ($ret_type ne "void") { - print "\t" . &map_type($ret_type) . "\tRETVAL;\n" - if !$retvaldone; - $args_match{"RETVAL"} = 0; - $var_types{"RETVAL"} = $ret_type; - } - print $deferred; - if (/^\s*CODE:/) { - while ($_ = shift(@_)) { - last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; - print "$_\n"; - } - } else { - print "\n\t"; - if ($ret_type ne "void") { - print "RETVAL = "; - } - if (defined($static)) { - print "$class::"; - } elsif (defined($class)) { - print "THIS->"; - } - if (defined($spat) && $func_name =~ /^($spat)(.*)$/) { - $func_name = $2; - } - print "$func_name($func_args);\n"; - &generate_output($ret_type, 0, "RETVAL") - unless $ret_type eq "void"; - } - } - - # do output variables - if (/^\s*OUTPUT\s*:/) { - while ($_ = shift(@_)) { - last if /^\s*CLEANUP\s*:/; - s/^\s+//; - ($outarg, $outcode) = split(/\t+/); - if ($outcode) { - print "\t$outcode\n"; - } else { - die "$outarg not an argument" - unless defined($args_match{$outarg}); - $var_num = $args_match{$outarg}; - &generate_output($var_types{$outarg}, $var_num, - $outarg); - } - } - } - # do cleanup - if (/^\s*CLEANUP\s*:/) { - while ($_ = shift(@_)) { - last if /^\s*CASE\s*:/; - print "$_\n"; - } - } - # print function trailer - print <<EOF if $eflag; - } - BEGHANDLERS - CATCHALL - croak("%s: %s\\tpropagated", Xname, Xreason); - ENDHANDLERS -EOF - print <<EOF if !$eflag; - } -EOF - if (/^\s*CASE\s*:/) { - unshift(@_, $_); - } -} - print <<EOF; - return sp; -} - -EOF -} - -# print initialization routine -print qq/extern "C"\n/ if $cflag; -print <<"EOF"; -int init_$Module(ix,sp,items) -int ix; -int sp; -int items; -{ - char* file = __FILE__; - -EOF - -for (@Func_name) { - $pname = shift(@Func_pname); - print " newXSUB(\"$pname\", 0, XS_$_, file);\n"; -} -print "}\n"; - -sub output_init { - local($type, $num, $init) = @_; - local($arg) = "ST($num)"; - - eval qq/print " $init\\\n"/; -} - -sub generate_init { - local($type, $num, $var) = @_; - local($arg) = "ST($num)"; - local($argoff) = $num - 1; - local($ntype); - - die "$type not in typemap" if !defined($type_kind{$type}); - ($ntype = $type) =~ s/\s*\*/Ptr/g; - $subtype = $ntype; - $subtype =~ s/Ptr$//; - $subtype =~ s/Array$//; - $expr = $input_expr{$type_kind{$type}}; - if ($expr =~ /DO_ARRAY_ELEM/) { - $subexpr = $input_expr{$type_kind{$subtype}}; - $subexpr =~ s/ntype/subtype/g; - $subexpr =~ s/\$arg/ST(ix_$var)/g; - $subexpr =~ s/\n\t/\n\t\t/g; - $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g; - $subexpr =~ s/\$var/$var[ix_$var - $argoff]/; - $expr =~ s/DO_ARRAY_ELEM/$subexpr/; - } - if (defined($defaults{$var})) { - $expr =~ s/(\t+)/$1 /g; - $expr =~ s/ /\t/g; - eval qq/print "\\t$var;\\n"/; - $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; - } elsif ($expr !~ /^\t\$var =/) { - eval qq/print "\\t$var;\\n"/; - $deferred .= eval qq/"\\n$expr;\\n"/; - } else { - eval qq/print "$expr;\\n"/; - } -} - -sub generate_output { - local($type, $num, $var) = @_; - local($arg) = "ST($num)"; - local($argoff) = $num - 1; - local($ntype); - - if ($type =~ /^array\(([^,]*),(.*)\)/) { - print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; - } else { - die "$type not in typemap" if !defined($type_kind{$type}); - ($ntype = $type) =~ s/\s*\*/Ptr/g; - $ntype =~ s/\(\)//g; - $subtype = $ntype; - $subtype =~ s/Ptr$//; - $subtype =~ s/Array$//; - $expr = $output_expr{$type_kind{$type}}; - if ($expr =~ /DO_ARRAY_ELEM/) { - $subexpr = $output_expr{$type_kind{$subtype}}; - $subexpr =~ s/ntype/subtype/g; - $subexpr =~ s/\$arg/ST(ix_$var)/g; - $subexpr =~ s/\$var/${var}[ix_$var]/g; - $subexpr =~ s/\n\t/\n\t\t/g; - $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; - } - elsif ($arg eq 'ST(0)') { - print "\tST(0) = sv_mortalcopy(&sv_undef);\n"; - } - eval "print qq\f$expr\f"; - } -} - -sub map_type { - local($type) = @_; - - if ($type =~ /^array\(([^,]*),(.*)\)/) { - return "$1 *"; - } else { - return $type; - } -} diff --git a/ext/xvarpp b/ext/xvarpp deleted file mode 100755 index cdb2bd0388..0000000000 --- a/ext/xvarpp +++ /dev/null @@ -1,161 +0,0 @@ -#!/usr/bin/perl -# $Header$ - -$usage = "Usage: xvar [-a] [-c] typemap file.xv\n"; -die $usage unless (@ARGV >= 2 && @ARGV <= 4); - -SWITCH: while ($ARGV[0] =~ /^-/) { - $flag = shift @ARGV; - $aflag = 1, next SWITCH if $flag =~ /^-a$/; - $cflag = 1, next SWITCH if $flag =~ /^-c$/; - die $usage; -} - -$typemap = shift @ARGV; -open(TYPEMAP, $typemap) || die "cannot open $typemap\n"; -while (<TYPEMAP>) { - next if /^\s*$/ || /^#/; - chop; - ($typename, $kind) = split(/\t+/); - $type_kind{$typename} = $kind; -} -close(TYPEMAP); - -$uvfile = shift @ARGV; -open(F, $uvfile) || die "cannot open $uvfile\n"; -#($uvoutfile = $uvfile) =~ s|^.*/([^/]*).us$|\1.c| ; -#print "uvoutfile is $uvoutfile\n"; - -#open(FOUT, ">$uvoutfile") || die "cannot open $uvoutfile\n"; -#select(FOUT); - -while (<F>) { - last if ($Module, $foo, $Package, $foo1, $Prefix) = - /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(\w+))?/; - print $_; -} -$Package .= "::" if defined $Package && $Package ne ""; -print <<EOF; -static struct varinfo varinfo [] = { -EOF - -while (<F>) { - next if /^s*$/ || /^#/; - if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(\w+))?/) { - $Module = $1; - $foo = $2; - $Package = $3; - $foo1 = $4; - $Prefix = $5; - $Package .= "'" if defined $Package && $Package ne ""; - next; - } - chop; - $func = undef; - ($var, $kind, $store, $read) = split(/\t+/); - die "$kind not defined in typemap\n" if !defined($type_kind{$kind}); - $flags = "0"; - if ($store =~ /FUNC=(.*)/) { - $flags .= "|VI_FUNC"; - $func = $1; - } elsif ($store eq "VAR") { - $flags .= "|VI_VARIABLE"; - } elsif ($store ne "VAL") { - die "$var storage class not VAL, VAR or FUNC\n"; - } - if ($read eq "READWRITE") { - $flags .= "|VI_READWRITE"; - } elsif ($read ne "READONLY") { - die "$var access class not READONLY or READWRITE\n"; - } - SIZE: { - $type_kind = $type_kind{$kind}; - $size = 0; - do {$size = "sizeof(int)"; last SIZE; } - if ($type_kind eq "T_INT"); - do {$size = "sizeof($kind)"; last SIZE; } - if ($type_kind eq "T_ENUM"); - do {$size = "sizeof(unsigned int)"; last SIZE; } - if ($type_kind eq "T_U_INT"); - do {$size = "sizeof(short)"; last SIZE; } - if ($type_kind eq "T_SHORT"); - do {$size = "sizeof(unsigned short)"; last SIZE; } - if ($type_kind eq "T_U_SHORT"); - do {$size = "sizeof(long)"; last SIZE; } - if ($type_kind eq "T_LONG"); - do {$size = "sizeof(unsigned long)"; last SIZE; } - if ($type_kind eq "T_U_LONG"); - do {$size = "sizeof(char)"; last SIZE; } - if ($type_kind eq "T_CHAR"); - do {$size = "sizeof(unsigned char)"; last SIZE; } - if ($type_kind eq "T_U_CHAR"); - do {$size = "0"; last SIZE; } - if ($type_kind eq "T_STRING"); - do {$size = "sizeof(char *)"; last SIZE; } - if ($type_kind eq "T_PTR"); - do {$size = "sizeof($kind)"; last SIZE; } - if ($type_kind eq "T_OPAQUE"); - } - ($name = $var) =~ s/^$Prefix//; - print " { \"$Package$name\", $type_kind, $flags, $size, "; - if ($store =~ /FUNC/) { - print "(char *)$func, 0.0 },\n"; - } elsif ($store eq "VAR") { - print "(char *)&$var, 0.0 },\n"; - } elsif ($type_kind eq "T_FLOAT" || $type_kind eq "T_DOUBLE") { - print "0, $var },\n"; - } else { - print "(char *)$var, 0.0 },\n"; - } -} -print <<EOF if $aflag; -}; - -static unsigned long varinfolen = sizeof(varinfo)/sizeof(*varinfo); - -static int UV_val(int ix, SV *sv) -{ - return common_UV_val(varinfo, varinfolen, ix, sv); -} - -static int UV_set(int ix, SV *sv) -{ - return common_UV_set(varinfo, varinfolen, ix, sv); -} -EOF -print <<EOF if !$aflag; -}; - -static unsigned long varinfolen = sizeof(varinfo)/sizeof(*varinfo); - -static int UV_val(ix, sv) -int ix; -SV *sv; -{ - return common_UV_val(varinfo, varinfolen, ix, sv); -} - -static int UV_set(ix, sv) -int ix; -SV *sv; -{ - return common_UV_set(varinfo, varinfolen, ix, sv); -} - -EOF -print qq/extern "C"\n/ if $cflag; -print <<EOF; -void init_$Module() -{ - int i; - struct ufuncs uf; - - uf.uf_set = UV_set; - uf.uf_val = UV_val; - for (i = 0; i < varinfolen; i++) { - uf.uf_index = i; - magicname(varinfo[i].vname, (char *)&uf, sizeof uf); - } -} - -EOF @@ -1,2102 +0,0 @@ -Archive-name: perl-faq/part0 -Version: $Id: faq,v 1.1 92/11/30 05:12:22 tchrist Exp Locker: tchrist $ - -This article contains the table of contents to some of the most -frequently asked questions in comp.lang.perl, a newsgroup devoted to -the Perl programming language. There are two pieces following -this, the general information questions in part1 and the largely -technical opnes in part2. - -They're all good questions, but they come up often enough that -substantial net bandwidth can be saved by looking here first before -asking. Before posting a question, you really should consult the Perl -man page; there's a lot of information packed in there. - -Some questions in this group aren't really about Perl, but rather -about system-specific issues. You might also consult the Most -Frequently Asked Questions list in comp.unix.questions for answers -to this type of question. - -The current version of perl is 4.035 (version 4, patchlevel 35). -There haven't actually been 35 updates to perl4; rather, the context -diffs posted to the net have been broken up into 35 news-digestable -chunks. - -This list is maintained by Tom Christiansen, and is archived on -convex.com [130.168.1.1] in the file pub/perl/info/faq. If you -have any suggested additions or corrections to this article, please -send them to Tom at either <tchrist@convex.com> or <convex!tchrist>. -Special thanks to Larry Wall for initially reviewing this list for -accuracy and especially for writing and releasing Perl in the first place. - - -1.1) What is Perl? -1.2) Is Perl hard to learn? -1.3) Should I program everything in Perl? -1.4) Where can I get Perl over the Internet? -1.5) Where can I get Perl via Email? -1.6) How can I get Perl via UUCP? -1.7) Where can I get more information on Perl? -1.8) Can people who aren't on USENET receive comp.lang.perl as a digest? -1.9) Are archives of comp.lang.perl available? -1.10) How do I get Perl to run on machine FOO? -1.11) Where can I get (info|inter|ora|sql|syb)perl? -1.12) There's an a2p and an s2p; why isn't there a p2c (perl-to-C)? -1.13) Where can I get undump for my machine? -1.14) Where can I get a perl-mode for emacs? -1.15) How can I use Perl interactively? -1.16) Is there a Perl shell? -1.17) Is there a Perl profiler? -1.18) Is there a yacc for Perl? -1.19) How can I use curses with perl? -1.20) How can I use X with Perl? -1.21) What is perl4? What is perl5? -1.22) How does Perl compare with languages like REXX or TCL? -1.23) Is it a Perl program or a Perl script? -1.24) What's the difference between "Perl" and "perl"? -1.25) What companies use or ship Perl? -1.26) Is there commercial, 3rd-party support for Perl? -1.27) Where can I get a list of the JAPH signature quotes? -1.28) Where can I get a list of Larry Wall witticisms? - -2.1) What are all these $@*%<> signs and how do I know when to use them? -2.2) Why don't backticks work as they do in shells? -2.3) How come Perl operators have different precedence than C operators? -2.4) How come my converted awk/sed/sh script runs more slowly in Perl? -2.5) How can I call my system's unique C functions from Perl? -2.6) Where do I get the include files to do ioctl() or syscall()? -2.7) Why doesn't "local($foo) = <FILE>;" work right? -2.8) How can I detect keyboard input without reading it? -2.9) How can I make an array of arrays or other recursive data types? -2.10) How can I quote a variable to use in a regexp? -2.11) Why do setuid Perl scripts complain about kernel problems? -2.12) How do I open a pipe both to and from a command? -2.13) How can I change the first N letters of a string? -2.14) How can I manipulate fixed-record-length files? -2.15) How can I make a file handle local to a subroutine? -2.16) How can I extract just the unique elements of an array? -2.17) How can I call alarm() or usleep() from Perl? -2.18) How can I test whether an array contains a certain element? -2.19) How can I do an atexit() or setjmp()/longjmp() in Perl? -2.20) Why doesn't Perl interpret my octal data octally? -2.21) How do I sort an associative array by value instead of by key? -2.22) How can I capture STDERR from an external command? -2.23) Why doesn't open return an error when a pipe open fails? -2.24) How can I compare two date strings? -2.25) What's the fastest way to code up a given task in perl? -2.26) How can I know how many entries are in an associative array? -2.27) Why can't my perl program read from STDIN after I gave it ^D (EOF) ? -2.28) Do I always/never have to quote my strings or use semicolons? -2.29) How can I translate tildes in a filename? -2.30) How can I convert my shell script to Perl? -2.31) What is variable suicide and how can I prevent it? -2.32) Can I use Perl regular expressions to match balanced text? -2.33) Can I use Perl to run a telnet or ftp session? -2.34) What does "Malformed command links" mean? - - - -1.1) What is Perl? - - A programming language, by Larry Wall <lwall@netlabs.com>. - - Here's the beginning of the description from the man page: - - Perl is an interpreted language optimized for scanning arbitrary text - files, extracting information from those text files, and printing reports - based on that information. It's also a good language for many system - management tasks. The language is intended to be practical (easy to use, - efficient, complete) rather than beautiful (tiny, elegant, minimal). It - combines (in the author's opinion, anyway) some of the best features of C, - sed, awk, and sh, so people familiar with those languages should have - little difficulty with it. (Language historians will also note some - vestiges of csh, Pascal, and even BASIC-PLUS.) Expression syntax - corresponds quite closely to C expression syntax. Unlike most Unix - utilities, Perl does not arbitrarily limit the size of your data--if - you've got the memory, Perl can slurp in your whole file as a single - string. Recursion is of unlimited depth. And the hash tables used by - associative arrays grow as necessary to prevent degraded performance. - Perl uses sophisticated pattern matching techniques to scan large amounts - of data very quickly. Although optimized for scanning text, Perl can also - deal with binary data, and can make dbm files look like associative arrays - (where dbm is available). Setuid Perl scripts are safer than C programs - through a dataflow tracing mechanism which prevents many stupid security - holes. If you have a problem that would ordinarily use sed or awk or sh, - but it exceeds their capabilities or must run a little faster, and you - don't want to write the silly thing in C, then Perl may be for you. There - are also translators to turn your sed and awk scripts into Perl scripts. - - -1.2) Is Perl hard to learn? - - No, Perl is easy to learn for two reasons. - - The first reason is that most of Perl is derived from existing tools - and languages, ones that many people who turn to Perl already have - some familiarity with. These include the C programming language, the - UNIX C library, the UNIX shell, sed, and awk. If you already know - these somewhat, Perl should be very easy for you. - - The second reason that Perl is easy to learn is that you don't have to - know every thing there is to know about it in order to get good use - out of it. In fact, just a very small subset, mostly borrowed from C, - the shell, and sed, will be enough for most tasks. As you feel the - need or desire to use more sophisticated features (such as C - structures or networking), you can learn these as you go. The - learning curve for Perl is not a steep one, especially if you have - the headstart of having a background in UNIX. Rather, its learning - curve is gentle and gradual, but it *is* admittedly rather long. - - If you don't know C or UNIX at all, it'll be a steeper learning curve, - but what you then learn from Perl will carry over into other areas, - like using the C library, UNIX system call, regular expressions, and - associative arrays, just to name a few. To know Perl is to know - UNIX, and vice versa. - - -1.3) Should I program everything in Perl? - - Of course not. You should choose the appropriate tool for the task at - hand. While it's true that the answer to the question "Can I do (some - arbitrary task) in Perl?" is almost always "yes", that doesn't mean - this is necessarily a good thing to do. For many people, Perl serves - as a great replacement for shell programming. For a few people, it - also serves as a replacement for most of what they'd do in C. But - for some things, Perl just isn't the optimal choice, such as tasks - requiring very complex data structures. - - -1.4) Where can I get Perl over the Internet? - - From any comp.sources.misc archive. Initial sources were posted to - Volume 18, Issues 19-54 at patchlevel 3. The Patches 4-10 were posted - to Volume 20, Issues 56-62. You can use the archie server - (see the alt.sources FAQ in news.answers) for ways to find these. - - These machines, at the very least, definitely have it available for - anonymous FTP: - - ftp.uu.net 137.39.1.2 - archive.cis.ohio-state.edu 128.146.8.52 - jpl-devvax.jpl.nasa.gov 128.149.1.143 - ftp.netlabs.com 192.94.48.152 - prep.ai.mit.edu 18.71.0.38 - archive.cs.ruu.nl 131.211.80.5 (Europe) - - - - -1.5) Where can I get Perl via Email? - - If you are in Europe, you might using the following site. (I'm still - looking for a domestic site.) This information thanks to "Henk P. - Penning" <henkp@cs.ruu.nl>: One automated fashion is as follows: - - Email: Send a message to 'mail-server@cs.ruu.nl' containing: - begin - path your_email_address - send help - send PERL/INDEX - end - The path-line may be omitted if your message contains a normal From:-line. - You will receive a help-file and an index of the directory that contains - the Perl stuff. - - If all else fails, mail to Larry usually suffices. - - -1.6) How can I get Perl via UUCP? - - You can get it from the site osu-cis; here is the appropriate info, - thanks to J Greely <jgreely@cis.ohio-state.edu> or <osu-cis!jgreely>. - - E-mail contact: - osu-cis!uucp - Get these two files first: - osu-cis!~/GNU.how-to-get. - osu-cis!~/ls-lR.Z - Current Perl distribution: - osu-cis!~/perl/4.0/kits@10/perl.kitXX.Z (XX=01-37) - How to reach osu-cis via uucp(L.sys/Systems file lines): - # - # Direct Trailblazer - # - osu-cis Any ACU 19200 1-614-292-5112 in:--in:--in: Uanon - # - # Direct V.32 (MNP 4) - # dead, dead, dead...sigh. - # - #osu-cis Any ACU 9600 1-614-292-1153 in:--in:--in: Uanon - # - # Micom port selector, at 1200, 2400, or 9600 bps. - # Replace ##'s below with 12, 24, or 96 (both speed and phone number). - # - osu-cis Any ACU ##00 1-614-292-31## "" \r\c Name? osu-cis nected \c GO \d\r\d\r\d\r in:--in:--in: - Uanon - - Modify as appropriate for your site, of course, to deal with your - local telephone system. There are no limitations concerning the hours - of the day you may call. - - Another possibility is to use UUNET, although they charge you - for it. You have been duly warned. Here's the advert: - - Anonymous Access to UUNET's Source Archives - - 1-900-GOT-SRCS - - UUNET now provides access to its extensive collection of UNIX - related sources to non- subscribers. By calling 1-900-468-7727 - and using the login "uucp" with no password, anyone may uucp any - of UUNET's on line source collection. Callers will be charged 40 - cents per minute. The charges will appear on their next tele- - phone bill. - - The file uunet!/info/help contains instructions. The file - uunet!/index//ls-lR.Z contains a complete list of the files available - and is updated daily. Files ending in Z need to be uncompressed - before being used. The file uunet!~/compress.tar is a tar - archive containing the C sources for the uncompress program. - - This service provides a cost effective way of obtaining - current releases of sources without having to maintain accounts - with UUNET or some other service. All modems connected to the - 900 number are Telebit T2500 modems. These modems support all - standard modem speeds including PEP, V.32 (9600), V.22bis (2400), - Bell 212a (1200), and Bell 103 (300). Using PEP or V.32, a 1.5 - megabyte file such as the GNU C compiler would cost $10 in con- - nect charges. The entire 55 megabyte X Window system V11 R4 - would cost only $370 in connect time. These costs are less than - the official tape distribution fees and they are available now - via modem. - - UUNET Communications Services - 3110 Fairview Park Drive, Suite 570 - Falls Church, VA 22042 - +1 703 876 5050 (voice) - +1 703 876 5059 (fax) - info@uunet.uu.net - - - -1.7) Where can I get more information on Perl? - - We'll cover five areas here: USENET (where you're probably reading - this), publications, the reference guide, examples on the Internet, - and Perl instructional courses. - - A. USENET - - You should definitely read the USENET comp.lang.perl newsgrouor - mailing list for all sorts of discussions regarding the language, - bugs, features, history, humor, and trivia. In this respect, it - functions both as a comp.lang.* style newsgroup and also as a user - group for the language; in fact, there's a mailing list called - ``perl-users'' that is bidirectionally gatewayed to the newsgroup; see - question #38 for details. Larry Wall is a very frequent poster here, - as well as many (if not most) of the other seasoned Perl programmers. - It's the best place for the very latest information on Perl. - - B. PUBLICATIONS - - If you've been dismayed by the ~80-page troffed Perl man page (or is - that man treatise?) you should look to ``the Camel Book'', written by - Larry and Randal L. Schwartz <merlyn@ora.com>, published as a Nutshell - Handbook by O'Reilly & Associates and entitled _Programming Perl_. - Besides serving as a reference guide for Perl, it also contains - tutorial material and is a great source of examples and cookbook - procedures, as well as wit and wisdom, tricks and traps, pranks and - pitfalls. The code examples contained therein are available via - anonymous FTP from ftp.uu.net in - /published/oreilly/nutshell/perl/perl.tar.Z for your retrieval. - Corrections and additions to the book can be found in the Perl man - page right before the BUGS section under the heading ERRATA AND - ADDENDA. - - If you can't find the book in your local technical bookstore, the book - may be ordered directly from O'Reilly by calling 1-800-998-9938 if in - North America and 1-707-829-0515. Autographed copies are available - from TECHbooks by calling 1-503-646-8257 or mailing info@techbook.com. - Cost is ~30$US for the regular version, 40$US for the autographed one. - The book's ISBN is 0-937175-64-1. - - Reasonably substantiated rumor has it that there will be another Perl - book out pretty soon, this one aimed more at beginners. Look for it - from ORA towards the beginning of 93. - - Larry Wall has published a 3-part article on perl in Unix World - (August through October of 1991), and Rob Kolstad also had a 3-parter - in Unix Review (May through July of 1990). Tom Christiansen also has - a brief overview article in the trade newsletter Unix Technology - Advisor from November of 1989. You might also investigate "The Wisdom - of Perl" by Gordon Galligher from SunExpert magazine; April 1991 - Volume 2 Number 4. - - The USENIX LISA (Large Installations Systems Adminstration) Conference - have for several years now included many papers of tools written in - Perl. Old proceedings of these conferences are available; look in - your current issue of ";login:" or send mail to office@usenix.org - for futher information. - - C. INTERNET - - For other examples of Perl scripts, look in the Perl source directory in - the eg subdirectory. You can also find a good deal of them on - tut.cis.ohio-state.edu in the pub/perl/scripts/ subdirectory. - - Another source for examples, currently only for anonymous FTP, is on - convex.com [130.168.1.1]. This contains, amongst other things, - a copy of the newsgroup up through Aug 91, a text retrieval database - for the newsgroup, a rather old and short troff version of Tom Christiansen's - perl tutorial (this was the version presented at Washington DC USENIX), - and quite a few of Tom's scripts. You can look at the INDEX file - in /pub/perl/INDEX for a list of what's in that directory. - - The Convex and Ohio State archives are mirrored on uunet - in /languages/perl/scripts-{convex,osu}. - - D. REFERENCE GUIDE - - A nice reference guide by Johan Vromans <jv@mh.nl> is also available; - It is distributed in LaTeX (source) and PostScript (ready to - print) forms. Obsolete versions may still be available in TeX and troff - forms, although these don't print as nicely. The official kit - includes both LaTeX and PostScript forms, and can be FTP'd from - archive.cs.ruu.nl [131.211.80.5], file /pub/DOC/perlref-4.035.tar.Z. - The reference guide comes with the O'Reilly book in a nice, glossy - card format. - - E. PERL COURSES - - Various technical conferences, including USENIX, SUG, WCSAS, AUUG, - FedUnix, and Europen have been sponsoring tutorials of varying lengths - on Perl at their system administration and general conferences. You - might consider attending one of these. These classes are typically - taught by Tom Christiansen <tchrist@usenix.com>, although both Rob - Kolstad <kolstad@usenix.org> and Randal Schwartz <merlyn@ora.com> also - teach Perl on occasion. Special appearances by Tom, Rob, and/or - Randal may also be negotiated. Classes can run from one day up to a - week ranging over a wide range of subject matter (most are two or - three days), and can include lab time if you want; having lab time - with exercises is generally of great benefit. Send us mail if your - organization is interested in having a Perl class taught at your site. - - -1.8) Can people who aren't on USENET receive comp.lang.perl as a digest? - - "Perl-Users" is the mailing list version of the comp.lang.perl - newsgroup. If you're not lucky enough to be on USENET you can post to - comp.lang.perl by sending to one of the following addresses. Which one - will work best for you depends on which nets your site is hooked into. - Ask your local network guru if you're not certain. - - Internet: PERL-USERS@VIRGINIA.EDU - Perl-Users@UVAARPA.VIRGINIA.EDU - - BitNet: Perl@Virginia - - uucp: ...!uunet!virginia!perl-users - - The Perl-Users list is bidirectionally gatewayed with the USENET - newsgroup comp.lang.perl. This means that VIRGINIA functions as a - reflector. All traffic coming in from the non-USENET side is - immediately posted to the newsgroup. Postings from the USENET side are - periodically digested and mailed out to the Perl-Users mailing list. A - digest is created and distributed at least once per day, more often if - traffic warrants. - - All requests to be added to or deleted from this list, problems, - questions, etc., should be sent to: - - Internet: Perl-Users-Request@Virginia.EDU - Perl-Users-Request@uvaarpa.Virginia.EDU - - BitNet: Perl-Req@Virginia - - uucp: ...!uunet!virginia!perl-users-request - - Coordinator: Marc Rouleau <mer6g@VIRGINIA.EDU> - -1.9) Are archives of comp.lang.perl available? - - Yes, although they're poorly organized. You can get them from - the host betwixt.cs.caltech.edu (131.215.128.4) in the directory - /pub/comp.lang.perl. They are also to uunet in - /languages/perl/comp.lang.perl . It contains these things: - - comp.lang.perl.tar.Z -- the 5M tarchive in MH/news format - archives/ -- the unpacked 5M tarchive - unviewed/ -- new comp.lang.perl messages - - These are currently stored in news- or MH-style format; there are - subdirectories named things like "arrays", "programs", "taint", and - "emacs". Unfortunately, only the first ~1600 or so messages have been - so categorized, and we're now up to almost 15000. Furthermore, even - this categorization was haphazardly done and contains errors. - - A more sophisticated query and retrieval mechanism is desirable. - Preferably one that allows you to retrieve article using a fast-access - indices, keyed on at least author, date, subject, thread (as in "trn") - and probably keywords. Right now, the MH pick command works for this, - but it is very slow to select on 15000 articles. - - If you're serious about this, your best bet is probably to retrieve - the compressed tarchive and play with what you get. Any suggestions - how to better sort this all out are extremely welcome. - - Currently the comp.lang.perl archives on convex.com are nearly a year - behind. That's because I no longer have room to store them there. I - do have them all on-line still, but they are not publicly accessible. - If you have a special request for a query on the old newsgroup - postings, and make nice noises in my direction, I can run the query - and send them to you. Algebraic queries are like "find me anything - about this and that and the other thing but not this or whozits". I - hope to put this in the form of a mailserver. Donated software would - be fine. :-) - - The fast text-retrieval query system for this I'm currently using is - Liam Quin's excellent lqtext system, available from ftp.toronto.edu - in /pub/lq-text* . - - Rumor has it that there are WAIS servers out there for comp.lang.perl - these days, but I haven't used them. - - -1.10) How do I get Perl to run on machine FOO? - - Perl comes with an elaborate auto-configuration script that allows Perl - to be painlessly ported to a wide variety of platforms, including many - non-UNIX ones. Amiga and MS-DOS binaries are available on - jpl-devvax.jpl.nasa.gov [128.149.1.143] for anonymous FTP. Try to bring - Perl up on your machine, and if you have problems, examine the README - file carefully, and if all else fails, post to comp.lang.perl; - probably someone out there has run into your problem and will be able - to help you. - - In particular, since they're so often asked about, here's some information - for the MacIntosh from Matthias Ulrich Neeracher <neeri@iis.ethz.ch>: - - A port of Perl to the Apple Macintosh is available by anonymous - ftp to rascal.ics.utexas.edu from the file - ~ftp/mac/programming/Perl_402_MPW_CPT_bin . - - The file is 1.1M and must be transferred in BINARY mode. Please - be considerate of RASCAL's users during CDT working hours. - (And, no, there is no way to get it by email). - - For European users, the file should soon appear on lth.se. - - To make optimal use of all the features of this port, you - should have MPW, ToolServer, and 5M of memory. There is also a - standalone version included, but it's currently of very limited - usefulness. - - This package contains all of the sources for compilation with - MPW C 3.2 - - And here's some VMS information from Rao V. Akella - <rao@moose.cccs.umn.edu>: (this appears to be an old port) - - You can pick up Perl for VMS (version 3.0.1.1 patchlevel 4) via - anonymous ftp from ftp.pitt.edu [130.49.253.1] in the - software/vms/perl subdirectory (there are two files there: - perl-pl18.bck and perl-pl4.bck). - - There is also a v3.018 on info.rz.uni-ulm.de [134.60.1.125] or - vms.huji.ac.il [128.139.4.3] in /pub/VMS/misc (information courtesy - of Anders Rolff <rolff@scotty.eurokom.ie>). - - And here is a recent version for MS-DOS from Budi Rahard - <rahard@ee.UManitoba.CA>, who says: - - I am collecting MS-DOS Perl(s) in ftp.ee.umanitoba.ca directory - /pub/msdos/perl. Currently I received three versions of Perl v4.019 - and one of 4.010. (Tommy Thorn <tthorn@daimi.aau.dk> and Len Reed - <holos0!lbr@gatech.edu>) - - There is now a 4.035 for 386 [DOS], Hitoshi Doi <doi@jrd.december.com> - port, is available ftp.ee.umanitoba.ca as /pub/msdos/perl/perl386.zoo . - - Please contact the porters directly in case of questions about - these ports. - - -1.11) Where can I get (info|inter|ora|sql|syb)perl? - - Numerous database-oriented extensions to Perl have been written. - These amount to using the usub mechanism (see the usub/ subdirectory - in the distribution tree) to link in a database library, allowing - embedded calls to Informix, Interbase, Oracle, Ingres, and Sybase. - There is currently a project underway, organized by Buzz Moschetti - <buzz@toxicavenger.bear.com>, to create a higher level interface - (DBperl) that will allow you to write your queries in a - database-independent fashion. Meanwhile, here are the authors of the - various extensions: - - What Target DB Who - -------- ----------- ---------------------------------------- - Infoperl Informix Kurt Andersen (kurt@hpsdid.sdd.hp.com) - Interperl Interbase Buzz Moschetti (buzz@fsrg.bear.com) - Oraperl Oracle Kevin Stock (kstock@encore.com) - Sqlperl Ingres Ted Lemon (mellon@ncd.com) - Sybperl Sybase Michael Peppler (mpeppler@itf.ch) - - -1.12) There's an a2p and an s2p; why isn't there a p2c (perl-to-C)? - - Because the Pascal people would be upset that we stole their name. :-) - - The dynamic nature of Perl's do and eval operators (and remember that - constructs like s/$mac_donald/$mac_gregor/eieio count as an eval) would - make this very difficult. To fully support them, you would have to put - the whole Perl interpreter into each compiled version for those scripts - using them. This is what undump does right now, if your machine has it. - If what you're doing will be faster in C than in Perl, maybe it should - have been written in C in the first place. For things that ought to be - written in Perl, the interpreter will be just about as fast, because the - pattern matching routines won't work any faster linked into a C program. - Even in the case of simple Perl programs that don't do any fancy evals, the - major gain would be in compiling the control flow tests, with the rest - still being a maze of twisty, turny subroutine calls. Since these are not - usually the major bottleneck in the program, there's not as much to be - gained via compilation as one might think. - - -1.13) Where can I get undump for my machine? - - The undump program comes from the TeX distribution. If you have TeX, then - you may have a working undump. If you don't, and you can't get one, - *AND* you have a GNU emacs working on your machine that can clone itself, - then you might try taking its unexec() function and compiling Perl with - -DUNEXEC, which will make Perl call unexec() instead of abort(). You'll - have to add unexec.o to the objects line in the Makefile. If you succeed, - post to comp.lang.perl about your experience so others can benefit from it. - - -1.14) Where can I get a perl-mode for emacs? - - In the perl4.0 source directory, you'll find a directory called - "emacs", which contains several files that should help you. - - -1.15) How can I use Perl interactively? - - The easiest way to do this is to run Perl under its debugger. - If you have no program to debug, you can invoke the debugger - on an `empty' program like this: - - perl -de 0 - - (The more positive amongst us prefer "perl -de 1". :-) - - Now you can type in any legal Perl code, and it will be immediately - evaluated. You can also examine the symbol table, get stack - backtraces, check variable Values, and if you want to, set - breakpoints and do the other things you can do in a symbolic debugger. - - -1.16) Is there a Perl shell? - - Not really. Perl is a programming language, not a command - interpreter. There is a very simple one called "perlsh" - included in the Perl source distribution. It just does this: - - $/ = ''; # set paragraph mode - $SHlinesep = "\n"; - while ($SHcmd = <>) { - $/ = $SHlinesep; - eval $SHcmd; print $@ || "\n"; - $SHlinesep = $/; $/ = ''; - } - - Not very interesting, eh? - - Daniel Smith <dansmith@autodesk.com> is working on an interactive Perl - shell called SoftList. It's currently at version 3.0beta. SoftList - 3.0 has tcsh-like command line editing, can let you define a file of - aliases so that you can run chunks of perl or UNIX commands, and so - on. You can send mail to him for further information and availability. - - -1.17) Is there a Perl profiler? - - While there isn't one included with the perl source distribution, - various folks have written packages that allow you to do at least some - sort of profiling. The strategy usually includes modifying the perl - debugger to handle profiling. Authors of these packages include - - Wayne Thompson <me@anywhere.EBay.Sun.COM> - Ray Lischner <lisch@sysserver1.mentor.com> - Kresten Krab Thorup <krab@iesd.auc.dk> - - The original articles by these folks containing their - profilers are available on convex.com in - /pub/perl/information/profiling.shar via anon ftp. - - -1.18) Is there a yacc for Perl? - - Yes!! It's a version of Berkeley yacc that outputs Perl code instead - of C code! You can get this from ftp.sterling.com [192.124.9.1] in - /local/perl-byacc1.8.1.tar.Z, or send the author mail for details. - - -1.19) How can I use curses with perl? - - One way is to build a curseperl binary by linking in your C curses - library as described in the usub subdirectory of the perl sources. - This requires a modicum of work, but it will be reasonably fast - since it's all in C (assuming you consider curses reasonably fast. :-) - Programs written using this method require the modified curseperl, - not vanilla perl, to run. While this is something of a disadvantage, - experience indicates that it's better to use curseperl than to - try to roll your own using termcap directly. - - Another possibility is to use Henk Penning's cterm package, a curses - emulation library written in perl. cterm is actually a separate - program with which you communicate via a pipe. It is available from - archive.cs.ruu.nl [131.211.80.5] via anonymous ftp in the directory - pub/PERL. You may also acquire the package via email in compressed, - uuencoded form by sending a message to mail-server@cs.ruu.nl - containing these lines: - - begin - send PERL/cterm.shar.Z - end - - See the question on retrieving perl via mail for more information on - how to get retrieve other items of interest from the mail server - there. - - -1.20) How can I use X with Perl? - - Right now, you have several choices. You can wait for perl5, use - the WAFE or STDWIN packages, or try to make your own usub bindings. - - Perl5 is anticipated to be released with bindings for X, called - guiperl. An exciting prototype for this, written by Jon Biggar - <jon@netlabs.com>, Larry's *other* brother-in-law and officemate, - is already up and running inside of Netlabs. This program addresses - the same dynamic gui-building problem space as does tcl/tk. - - If you can't wait or don't think that guiperl will do what you want, - a stab at Motif bindings was begun by Theodore C. Law - <TEDLAW@TOROLAB6.VNET.IBM.COM> area. His article about this is - on convex.com in /pub/perl/info/motif for anon ftp. - - STDWIN is a library written by Guido van Rossum <guido@cwi.nl> - (author of the Python programming language) that is portable - between Mac, Dos and X11. One could write a Perl agent to - speak to this STDIN server. - - WAFE is a package that implements a symbolic interface to the Athena - widgets (X11R5). A typical Wafe application consists in our framework - of two parts: the front-end (we call it Wafe for Widget[Athena]front - end) and an application program running typically as separate process. - The application program can be implemented in an arbitrary programming - language and talks to the front-end via stdio. Since Wafe (the - front-end) was developed using the extensible TCL shell (cite John - Ousterhout), an application program can dynamically submit requests to - the front-end to build up the graphical user interface; the - application can even down-load application specific procedures into - the front-end. The distribution contains sample application programs - in Perl, GAWK, Prolog, TCL, and C talking to the same Wafe binary. - Many of the demo applications are implemented in Perl. Wafe 0.9 can - be obtained via anonymous ftp from - ftp.wu-wien.ac.at:pub/src/X11/wafe-0.9.tar.Z - (for people without name server: the ip address is 137.208.3.5) - - -1.21) What is perl4? What is perl5? - - The answer to what is perl4 is nearly anything you might otherwise - program in shell or C. The answer to what is perl5 is basically - Perl: the Next Generation. In fact, it's essentially a complete - rewrite of perl from the bottom up, and back again. - - Larry gave a talk on perl5 at a Bay LISA meeting as well as at the - most recent USENIX LISA conference in Long Beach in which he timorously - admitted that perl5 might possibly be beta released in early 1993. - He enumerated some of the following features. Note that not only have - not all these been implemented yet, the ones further down the list - might well not get done at all. - - a faster, tighter, more flexible interpreter - very easy GUI Perl applications using X bindings ("guiperl") - embeddable Perl code in C code: cc prog.c -lperl - multiple coresident perl interpreters: - perhaps threading and/or coroutines - named argument passing: - some_func( OC => $red, TOF => "\f"); - recursive lists: - [a, b, [c, d], e] has 4 elts, the 3rd being itself a list - typed pointers and generalized indirection: - like @{$aptr} or &{$fptr} or &{ $table[$index] . "func" }(). - merging of list operator and function calling syntax: - split /pat/, $string; - subroutines without &'s: myfunc($arg); - generalization of dbm binding for assoc arrays to handle - any generic fetch/store/open/close/flush package. - (thus allowing both dbm and gdbm at once) - object oriented programming: - STDOUT->flush(1); - give dog $bone; - lexical scoping - dynamic loading of C libraries for systems that can - byte-compiled code for speed and maybe security - - It's tempting to want this stuff soon, since the sooner it comes - out the sooner we can all build really cool applications. But the - longer Larry works on it, the more items from this list will actually - get done, and the more robust the release will be. So let's not - ask him about it too often. - - -1.22) How does Perl compare with languages like REXX or TCL? - - REXX is an interpreted programming language first seen on IBM systems, - and TCL is John Ousterhout's embeddable command language. TCL's most - intriguing feature for many people is the tcl/tk toolset that allows - for interpreted X-based tools. - - To avoid any flamage, if you really want to know the answer to this - question, probably the best thing to do is try to write equivalent - code to do a set of tasks. All three have their own newsgroups in - which you can learn about (but hopefully not argue about) these - languages. - - To find out more about these or other languages, you might also check - out David Muir Sharnoff <muir@tfs.com>'s posting on "Catalog of - compilers, interpreters, and other language tools" which he posts to - comp.lang.misc, comp.sources.d, comp.archives.admin, and the - news.answers newsgroups. It's a comprehensive treatment of many - different languages. (Caveat lector: he considers Perl's syntax - "unappealing".) This list is archived on convex.com in - /pub/perl/info/lang-survey.shar . - - -1.23) Is it a Perl program or a Perl script? - - Certainly. :-) - - Current UNIX parlance holds that anything interpreted - is a script, and anything compiled into native machine - code is a program. However, others hold that a program - is a program is a program: after all, one seldom discusses - scripts written in BASIC or LISP. Larry considers it - a program if it's set in stone and you can't change it, - whereas if you go in and hack on it, then it's a script. - - But doesn't really matter. The terms are generally - interchangeable today. - - -1.24) What's the difference between "Perl" and "perl"? - - 32 :-) [ ord('p') - ord('P') ] - - Larry now uses "Perl" to signify the language proper and "perl" the - implementation of it, i.e. the current interpreter. Hence my quip - that "Nothing but perl can parse Perl." - - On the other hand, the aesthetic value of casewise parallelism - in "awk", "sed", and "perl" as much require the lower-case - version as "C", "Pascal", and "Perl" require the - upper-case version. It's also easier to type "Perl" in - typeset print than to be constantly switching in Courier. :-) - - In other words, it doesn't matter much, especially if all - you're doing is hearing someone talk about the language; - case is hard to distingish aurally. - - -1.25) What companies use or ship Perl? - - At this time, the known list includes at least the following: Convex, - Netlabs, BSDI, Integraph, Dell, and Kubota Pacific, although the - latter is in /usr/contrib only. Many other companies use Perl - internally for purposes of tools development, systems administration, - installation scripts, and test suites. Rumor has it that the large - workstation vendors (the TLA set) are seriously looking into shipping - Perl with their standard systems "soon". - - People with support contracts with their vendors are actively - encouraged to submit enhancement requests that Perl be shipped - as part of their standard system. It would, at the very least, - reduce the FTP load on the Internet. :-) - -1.26) Is there commercial, 3rd-party support for Perl? - - No. Although perl is included in the GNU distribution, at last check, - Cygnus does not offer support for it. However, it's unclear whether - they've ever been offered sufficient financial incentive to do so. - - On the other hand, you do have comp.lang.perl as a totally gratis - support mechanism. As long as you ask "interesting" questions, - you'll probably get plenty of help. :-) - -1.27) Where can I get a list of the JAPH signature quotes? - - These are the "just another perl hacker" signatures that - some people sign their postings with. About 100 of the - of the earlier ones are on convex.com in /pib/perl/info/japh. - -1.28) Where can I get a list of Larry Wall witticisms? - - Over a hundred quips by Larry, from postings of his or source code, - can be found on convex.com in /pub/perl/info/lwall-quotes. - - - - -2.1) What are all these $@*%<> signs and how do I know when to use them? - - Those are type specifiers: $ for scalar values, @ for indexed arrays, - and % for hashed arrays. The * means all types of that symbol name - and are sometimes used like pointers; the <> are used for inputting - a record from a filehandle. See the question on arrays of arrays - for more about Perl pointers. - - Always make sure to use a $ for single values and @ for multiple ones. - Thus element 2 of the @foo array is accessed as $foo[2], not @foo[2], - which is a list of length one (not a scalar), and is a fairly common - novice mistake. Sometimes you can get by with @foo[2], but it's - not really doing what you think it's doing for the reason you think - it's doing it, which means one of these days, you'll shoot yourself - in the foot; ponder for a moment what these will really do: - @foo[0] = `cmd args`; - @foo[2] = <FILE>; - Just always say $foo[2] and you'll be happier. - - This may seem confusing, but try to think of it this way: you use the - character of the type which you *want back*. You could use @foo[1..3] for - a slice of three elements of @foo, or even @foo{A,B,C} for a slice of - of %foo. This is the same as using ($foo[1], $foo[2], $foo[3]) and - ($foo{A}, $foo{B}, $foo{C}) respectively. In fact, you can even use - lists to subscript arrays and pull out more lists, like @foo[@bar] or - @foo{@bar}, where @bar is in both cases presumably a list of subscripts. - - While there are a few places where you don't actually need these type - specifiers, except for files, you should always use them. Note that - <FILE> is NOT the type specifier for files; it's the equivalent of awk's - getline function, that is, it reads a line from the handle FILE. When - doing open, close, and other operations besides the getline function on - files, do NOT use the brackets. - - Beware of saying: - $foo = BAR; - Which wil be interpreted as - $foo = 'BAR'; - and not as - $foo = <BAR>; - If you always quote your strings, you'll avoid this trap. - - Normally, files are manipulated something like this (with appropriate - error checking added if it were production code): - - open (FILE, ">/tmp/foo.$$"); - print FILE "string\n"; - close FILE; - - If instead of a filehandle, you use a normal scalar variable with file - manipulation functions, this is considered an indirect reference to a - filehandle. For example, - - $foo = "TEST01"; - open($foo, "file"); - - After the open, these two while loops are equivalent: - - while (<$foo>) {} - while (<TEST01>) {} - - as are these two statements: - - close $foo; - close TEST01; - - but NOT to this: - - while (<$TEST01>) {} # error - ^ - ^ note spurious dollar sign - - This is another common novice mistake; often it's assumed that - - open($foo, "output.$$"); - - will fill in the value of $foo, which was previously undefined. - This just isn't so -- you must set $foo to be the name of a valid - filehandle before you attempt to open it. - - -2.2) Why don't backticks work as they do in shells? - - Several reason. One is because backticks do not interpolate within - double quotes in Perl as they do in shells. - - Let's look at two common mistakes: - - $foo = "$bar is `wc $file`"; # WRONG - - This should have been: - - $foo = "$bar is " . `wc $file`; - - But you'll have an extra newline you might not expect. This - does not work as expected: - - $back = `pwd`; chdir($somewhere); chdir($back); # WRONG - - Because backticks do not automatically eat trailing or embedded - newlines. The chop() function will remove the last character from - a string. This should have been: - - chop($back = `pwd`); chdir($somewhere); chdir($back); - - You should also be aware that while in the shells, embedding - single quotes will protect variables, in Perl, you'll need - to escape the dollar signs. - - Shell: foo=`cmd 'safe $dollar'` - Perl: $foo=`cmd 'safe \$dollar'`; - - -2.3) How come Perl operators have different precedence than C operators? - - Actually, they don't; all C operators have the same precedence in Perl as - they do in C. The problem is with a class of functions called list - operators, e.g. print, chdir, exec, system, and so on. These are somewhat - bizarre in that they have different precedence depending on whether you - look on the left or right of them. Basically, they gobble up all things - on their right. For example, - - unlink $foo, "bar", @names, "others"; - - will unlink all those file names. A common mistake is to write: - - unlink "a_file" || die "snafu"; - - The problem is that this gets interpreted as - - unlink("a_file" || die "snafu"); - - To avoid this problem, you can always make them look like function calls - or use an extra level of parentheses: - - (unlink "a_file") || die "snafu"; - unlink("a_file") || die "snafu"; - - Sometimes you actually do care about the return value: - - unless ($io_ok = print("some", "list")) { } - - Yes, print() return I/O success. That means - - $io_ok = print(2+4) * 5; - - reutrns 5 times whether printing (2+4) succeeded, and - print(2+4) * 5; - returns the same 5*io_success value and tosses it. - - See the Perl man page's section on Precedence for more gory details, - and be sure to use the -w flag to catch things like this. - - -2.4) How come my converted awk/sed/sh script runs more slowly in Perl? - - The natural way to program in those languages may not make for the fastest - Perl code. Notably, the awk-to-perl translator produces sub-optimal code; - see the a2p man page for tweaks you can make. - - Two of Perl's strongest points are its associative arrays and its regular - expressions. They can dramatically speed up your code when applied - properly. Recasting your code to use them can help alot. - - How complex are your regexps? Deeply nested sub-expressions with {n,m} or - * operators can take a very long time to compute. Don't use ()'s unless - you really need them. Anchor your string to the front if you can. - - Something like this: - next unless /^.*%.*$/; - runs more slowly than the equivalent: - next unless /%/; - - Note that this: - next if /Mon/; - next if /Tue/; - next if /Wed/; - next if /Thu/; - next if /Fri/; - runs faster than this: - next if /Mon/ || /Tue/ || /Wed/ || /Thu/ || /Fri/; - which in turn runs faster than this: - next if /Mon|Tue|Wed|Thu|Fri/; - which runs *much* faster than: - next if /(Mon|Tue|Wed|Thu|Fri)/; - - There's no need to use /^.*foo.*$/ when /foo/ will do. - - Remember that a printf costs more than a simple print. - - Don't split() every line if you don't have to. - - Another thing to look at is your loops. Are you iterating through - indexed arrays rather than just putting everything into a hashed - array? For example, - - @list = ('abc', 'def', 'ghi', 'jkl', 'mno', 'pqr', 'stv'); - - for $i ($[ .. $#list) { - if ($pattern eq $list[$i]) { $found++; } - } - - First of all, it would be faster to use Perl's foreach mechanism - instead of using subscripts: - - foreach $elt (@list) { - if ($pattern eq $elt) { $found++; } - } - - Better yet, this could be sped up dramatically by placing the whole - thing in an associative array like this: - - %list = ('abc', 1, 'def', 1, 'ghi', 1, 'jkl', 1, - 'mno', 1, 'pqr', 1, 'stv', 1 ); - $found += $list{$pattern}; - - (but put the %list assignment outside of your input loop.) - - You should also look at variables in regular expressions, which is - expensive. If the variable to be interpolated doesn't change over the - life of the process, use the /o modifier to tell Perl to compile the - regexp only once, like this: - - for $i (1..100) { - if (/$foo/o) { - &some_func($i); - } - } - - Finally, if you have a bunch of patterns in a list that you'd like to - compare against, instead of doing this: - - @pats = ('_get.*', 'bogus', '_read', '.*exit', '_write'); - foreach $pat (@pats) { - if ( $name =~ /^$pat$/ ) { - &some_func(); - last; - } - } - - If you build your code and then eval it, it will be much faster. - For example: - - @pats = ('_get.*', 'bogus', '_read', '.*exit', '_write'); - $code = <<EOS - while () { - study; -EOS - foreach $pat (@pats) { - $code .= <<EOS - if ( /^$pat\$/ ) { - &some_func(); - next; - } -EOS - } - $code .= "}\n"; - print $code if $debugging; - eval $code; - - - -2.5) How can I call my system's unique C functions from Perl? - - If these are system calls and you have the syscall() function, then - you're probably in luck -- see the next question. For arbitrary - library functions, it's not quite so straight-forward. While you - can't have a C main and link in Perl routines, if you're - determined, you can extend Perl by linking in your own C routines. - See the usub/ subdirectory in the Perl distribution kit for an example - of doing this to build a Perl that understands curses functions. It's - neither particularly easy nor overly-documented, but it is feasible. - - -2.6) Where do I get the include files to do ioctl() or syscall()? - - These are generated from your system's C include files using the h2ph - script (once called makelib) from the Perl source directory. This will - make files containing subroutine definitions, like &SYS_getitimer, which - you can use as arguments to your function. - - You might also look at the h2pl subdirectory in the Perl source for how to - convert these to forms like $SYS_getitimer; there are both advantages and - disadvantages to this. Read the notes in that directory for details. - - In both cases, you may well have to fiddle with it to make these work; it - depends how funny-looking your system's C include files happen to be. - - If you're trying to get at C structures, then you should take a look - at using c2ph, which uses debugger "stab" entries generated by your - BSD or GNU C compiler to produce machine-independent perl definitions - for the data structures. This allows to you avoid hardcoding - structure layouts, types, padding, or sizes, greatly enhancing - portability. c2ph comes with the perl distribution. On an SCO - system, GCC only has COFF debugging support by default, so you'll have - to build GCC 2.1 with DBX_DEBUGGING_INFO defined, and use -gstabs to - get c2ph to work there. - - See the file /pub/perl/info/ch2ph on convex.com via anon ftp - for more traps and tips on this process. - - -2.7) Why doesn't "local($foo) = <FILE>;" work right? - - Well, it does. The thing to remember is that local() provides an array - context, an that the <FILE> syntax in an array context will read all the - lines in a file. To work around this, use: - - local($foo); - $foo = <FILE>; - - You can use the scalar() operator to cast the expression into a scalar - context: - - local($foo) = scalar(<FILE>); - - -2.8) How can I detect keyboard input without reading it? - - You should check out the Frequently Asked Questions list in - comp.unix.* for things like this: the answer is essentially the same. - It's very system dependent. Here's one solution that works on BSD - systems: - - sub key_ready { - local($rin, $nfd); - vec($rin, fileno(STDIN), 1) = 1; - return $nfd = select($rin,undef,undef,0); - } - - A closely related question is how to input a single character from the - keyboard. Again, this is a system dependent operation. The following - code that may or may not help you: - - $BSD = -f '/vmunix'; - if ($BSD) { - system "stty cbreak </dev/tty >/dev/tty 2>&1"; - } - else { - system "stty", 'cbreak', - system "stty", 'eol', "\001"; - } - - $key = getc(STDIN); - - if ($BSD) { - system "stty -cbreak </dev/tty >/dev/tty 2>&1"; - } - else { - system "stty", 'icanon'; - system "stty", 'eol', '^@'; # ascii null - } - print "\n"; - - You could also handle the stty operations yourself for speed if you're - going to be doing a lot of them. This code works to toggle cbreak - and echo modes on a BSD system: - - sub set_cbreak { # &set_cbreak(1) or &set_cbreak(0) - local($on) = $_[0]; - local($sgttyb,@ary); - require 'sys/ioctl.ph'; - $sgttyb_t = 'C4 S' unless $sgttyb_t; # c2ph: &sgttyb'typedef() - - ioctl(STDIN,&TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!"; - - @ary = unpack($sgttyb_t,$sgttyb); - if ($on) { - $ary[4] |= &CBREAK; - $ary[4] &= ~&ECHO; - } else { - $ary[4] &= ~&CBREAK; - $ary[4] |= &ECHO; - } - $sgttyb = pack($sgttyb_t,@ary); - - ioctl(STDIN,&TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!"; - } - - Note that this is one of the few times you actually want to use the - getc() function; it's in general way too expensive to call for normal - I/O. Normally, you just use the <FILE> syntax, or perhaps the read() - or sysread() functions. - - For perspectives on more portable solutions, use anon ftp to retrieve - the file /pub/perl/info/keypress from convex.com. - - -2.9) How can I make an array of arrays or other recursive data types? - - Remember that Perl isn't about nested data structures (actually, - perl0 .. perl4 weren't, but maybe perl5 will be, at least - somewhat). It's about flat ones, so if you're trying to do this, you - may be going about it the wrong way or using the wrong tools. You - might try parallel arrays with common subscripts. - - But if you're bound and determined, you can use the multi-dimensional - array emulation of $a{'x','y','z'}, or you can make an array of names - of arrays and eval it. - - For example, if @name contains a list of names of arrays, you can - get at a the j-th element of the i-th array like so: - - $ary = $name[$i]; - $val = eval "\$$ary[$j]"; - - or in one line - - $val = eval "\$$name[$i][\$j]"; - - You could also use the type-globbing syntax to make an array of *name - values, which will be more efficient than eval. Here @name hold - a list of pointers, which we'll have to dereference through a temporary - variable. - - For example: - - { local(*ary) = $name[$i]; $val = $ary[$j]; } - - In fact, you can use this method to make arbitrarily nested data - structures. You really have to want to do this kind of thing - badly to go this far, however, as it is notationally cumbersome. - - Let's assume you just simply *have* to have an array of arrays of - arrays. What you do is make an array of pointers to arrays of - pointers, where pointers are *name values described above. You - initialize the outermost array normally, and then you build up your - pointers from there. For example: - - @w = ( 'ww' .. 'xx' ); - @x = ( 'xx' .. 'yy' ); - @y = ( 'yy' .. 'zz' ); - @z = ( 'zz' .. 'zzz' ); - - @ww = reverse @w; - @xx = reverse @x; - @yy = reverse @y; - @zz = reverse @z; - - Now make a couple of array of pointers to these: - - @A = ( *w, *x, *y, *z ); - @B = ( *ww, *xx, *yy, *zz ); - - And finally make an array of pointers to these arrays: - - @AAA = ( *A, *B ); - - To access an element, such as AAA[i][j][k], you must do this: - - local(*foo) = $AAA[$i]; - local(*bar) = $foo[$j]; - $answer = $bar[$k]; - - Similar manipulations on associative arrays are also feasible. - - You could take a look at recurse.pl package posted by Felix Lee - <flee@cs.psu.edu>, which lets you simulate vectors and tables (lists and - associative arrays) by using type glob references and some pretty serious - wizardry. - - In C, you're used to creating recursive datatypes for operations - like recursive decent parsing or tree traversal. In Perl, these - algorithms are best implemented using associative arrays. Take an - array called %parent, and build up pointers such that $parent{$person} - is the name of that person's parent. Make sure you remember that - $parent{'adam'} is 'adam'. :-) With a little care, this approach can - be used to implement general graph traversal algorithms as well. - - -2.10) How can I quote a variable to use in a regexp? - - From the manual: - - $pattern =~ s/(\W)/\\$1/g; - - Now you can freely use /$pattern/ without fear of any unexpected - meta-characters in it throwing off the search. If you don't know - whether a pattern is valid or not, enclose it in an eval to avoid - a fatal run-time error. - - -2.11) Why do setuid Perl scripts complain about kernel problems? - - This message: - - YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! - FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP! - - is triggered because setuid scripts are inherently insecure due to a - kernel bug. If your system has fixed this bug, you can compile Perl - so that it knows this. Otherwise, create a setuid C program that just - execs Perl with the full name of the script. - - -2.12) How do I open a pipe both to and from a command? - - In general, this is a dangerous move because you can find yourself in a - deadlock situation. It's better to put one end of the pipe to a file. - For example: - - # first write some_cmd's input into a_file, then - open(CMD, "some_cmd its_args < a_file |"); - while (<CMD>) { - - # or else the other way; run the cmd - open(CMD, "| some_cmd its_args > a_file"); - while ($condition) { - print CMD "some output\n"; - # other code deleted - } - close CMD || warn "cmd exited $?"; - - # now read the file - open(FILE,"a_file"); - while (<FILE>) { - - If you have ptys, you could arrange to run the command on a pty and - avoid the deadlock problem. See the chat2.pl package in the - distributed library for ways to do this. - - At the risk of deadlock, it is theoretically possible to use a - fork, two pipe calls, and an exec to manually set up the two-way - pipe. (BSD system may use socketpair() in place of the two pipes, - but this is not as portable.) The open2 library function distributed - with the current perl release will do this for you. - - It assumes it's going to talk to something like adb, both writing to - it and reading from it. This is presumably safe because you "know" - that commands like adb will read a line at a time and output a line at - a time. Programs like sort that read their entire input stream first, - however, are quite apt to cause deadlock. - - -2.13) How can I change the first N letters of a string? - - Remember that the substr() function produces an lvalue, that is, it may be - assigned to. Therefore, to change the first character to an S, you could - do this: - - substr($var,0,1) = 'S'; - - This assumes that $[ is 0; for a library routine where you can't know $[, - you should use this instead: - - substr($var,$[,1) = 'S'; - - While it would be slower, you could in this case use a substitute: - - $var =~ s/^./S/; - - But this won't work if the string is empty or its first character is a - newline, which "." will never match. So you could use this instead: - - $var =~ s/^[^\0]?/S/; - - To do things like translation of the first part of a string, use substr, - as in: - - substr($var, $[, 10) =~ tr/a-z/A-Z/; - - If you don't know then length of what to translate, something like - this works: - - /^(\S+)/ && substr($_,$[,length($1)) =~ tr/a-z/A-Z/; - - For some things it's convenient to use the /e switch of the - substitute operator: - - s/^(\S+)/($tmp = $1) =~ tr#a-z#A-Z#, $tmp/e - - although in this case, it runs more slowly than does the previous example. - - -2.14) How can I manipulate fixed-record-length files? - - The most efficient way is using pack and unpack. This is faster than - using substr. Here is a sample chunk of code to break up and put back - together again some fixed-format input lines, in this case, from ps. - - # sample input line: - # 15158 p5 T 0:00 perl /mnt/tchrist/scripts/now-what - $ps_t = 'A6 A4 A7 A5 A*'; - open(PS, "ps|"); - $_ = <PS>; print; - while (<PS>) { - ($pid, $tt, $stat, $time, $command) = unpack($ps_t, $_); - for $var ('pid', 'tt', 'stat', 'time', 'command' ) { - print "$var: <", eval "\$$var", ">\n"; - } - print 'line=', pack($ps_t, $pid, $tt, $stat, $time, $command), "\n"; - } - - -2.15) How can I make a file handle local to a subroutine? - - You must use the type-globbing *VAR notation. Here is some code to - cat an include file, calling itself recursively on nested local - include files (i.e. those with #include "file", not #include <file>): - - sub cat_include { - local($name) = @_; - local(*FILE); - local($_); - - warn "<INCLUDING $name>\n"; - if (!open (FILE, $name)) { - warn "can't open $name: $!\n"; - return; - } - while (<FILE>) { - if (/^#\s*include "([^"]*)"/) { - &cat_include($1); - } else { - print; - } - } - close FILE; - } - - -2.16) How can I extract just the unique elements of an array? - - There are several possible ways, depending on whether the - array is ordered and you wish to preserve the ordering. - - a) If @in is sorted, and you want @out to be sorted: - - $prev = 'nonesuch'; - @out = grep($_ ne $prev && (($prev) = $_), @in); - - This is nice in that it doesn't use much extra memory, - simulating uniq's behavior of removing only adjacent - duplicates. - - b) If you don't know whether @in is sorted: - - undef %saw; - @out = grep(!$saw{$_}++, @in); - - c) Like (b), but @in contains only small integers: - - @out = grep(!$saw[$_]++, @in); - - d) A way to do (b) without any loops or greps: - - undef %saw; - @saw{@in} = (); - @out = sort keys %saw; # remove sort if undesired - - e) Like (d), but @in contains only small positive integers: - - undef @ary; - @ary[@in] = @in; - @out = sort @ary; - - -2.17) How can I call alarm() or usleep() from Perl? - - It's available as a built-in as of version 3.038. If you want finer - granularity than 1 second (as usleep() provides) and have itimers and - syscall() on your system, you can use the following. You could also - use select(). - - It takes a floating-point number representing how long to delay until - you get the SIGALRM, and returns a floating- point number representing - how much time was left in the old timer, if any. Note that the C - function uses integers, but this one doesn't mind fractional numbers. - - # alarm; send me a SIGALRM in this many seconds (fractions ok) - # tom christiansen <tchrist@convex.com> - sub alarm { - require 'syscall.ph'; - require 'sys/time.ph'; - - local($ticks) = @_; - local($in_timer,$out_timer); - local($isecs, $iusecs, $secs, $usecs); - - local($itimer_t) = 'L4'; # should be &itimer'typedef() - - $secs = int($ticks); - $usecs = ($ticks - $secs) * 1e6; - - $out_timer = pack($itimer_t,0,0,0,0); - $in_timer = pack($itimer_t,0,0,$secs,$usecs); - - syscall(&SYS_setitimer, &ITIMER_REAL, $in_timer, $out_timer) - && die "alarm: setitimer syscall failed: $!"; - - ($isecs, $iusecs, $secs, $usecs) = unpack($itimer_t,$out_timer); - return $secs + ($usecs/1e6); - } - - -2.18) How can I test whether an array contains a certain element? - - There are several ways to approach this. If you are going to make - this query many times and the values are arbitrary strings, the - fastest way is probably to invert the original array and keep an - associative array lying about whose keys are the first array's values. - - @blues = ('turquoise', 'teal', 'lapis lazuli'); - undef %is_blue; - for (@blues) { $is_blue{$_} = 1; } - - Now you can check whether $is_blue{$some_color}. It might have been - a good idea to keep the blues all in an assoc array in the first place. - - If the values are all small integers, you could use a simple - indexed array. This kind of an array will take up less space: - - @primes = (2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31); - undef @is_tiny_prime; - for (@primes) { $is_tiny_prime[$_] = 1; } - - Now you check whether $is_tiny_prime[$some_number]. - - If the values in question are integers, but instead of strings, - you can save quite a lot of space by using bit strings instead: - - @articles = ( 1..10, 150..2000, 2017 ); - undef $read; - grep (vec($read,$_,1) = 1, @articles); - - Now check whether vec($read,$n,1) is true for some $n. - - -2.19) How can I do an atexit() or setjmp()/longjmp() in Perl? - - Perl's exception-handling mechanism is its eval operator. You - can use eval as setjmp and die as longjmp. Here's an example - of Larry's for timed-out input, which in C is often implemented - using setjmp and longjmp: - - $SIG{ALRM} = TIMEOUT; - sub TIMEOUT { die "restart input\n" } - - do { eval { &realcode } } while $@ =~ /^restart input/; - - sub realcode { - alarm 15; - $ans = <STDIN>; - alarm 0; - } - - Here's an example of Tom's for doing atexit() handling: - - sub atexit { push(@_exit_subs, @_) } - - sub _cleanup { unlink $tmp } - - &atexit('_cleanup'); - - eval <<'End_Of_Eval'; $here = __LINE__; - # as much code here as you want - End_Of_Eval - - $oops = $@; # save error message - - # now call his stuff - for (@_exit_subs) { &$_() } - - $oops && ($oops =~ s/\(eval\) line (\d+)/$0 . - " line " . ($1+$here)/e, die $oops); - - You can register your own routines via the &atexit function now. You - might also want to use the &realcode method of Larry's rather than - embedding all your code in the here-is document. Make sure to leave - via die rather than exit, or write your own &exit routine and call - that instead. In general, it's better for nested routines to exit - via die rather than exit for just this reason. - - Eval is also quite useful for testing for system dependent features, - like symlinks, or using a user-input regexp that might otherwise - blowup on you. - - -2.20) Why doesn't Perl interpret my octal data octally? - - Perl only understands octal and hex numbers as such when they occur - as constants in your program. If they are read in from somewhere - and assigned, then no automatic conversion takes place. You must - explicitly use oct() or hex() if you want this kind of thing to happen. - Actually, oct() knows to interpret both hex and octal numbers, while - hex only converts hexadecimal ones. For example: - - { - print "What mode would you like? "; - $mode = <STDIN>; - $mode = oct($mode); - unless ($mode) { - print "You can't really want mode 0!\n"; - redo; - } - chmod $mode, $file; - } - - Without the octal conversion, a requested mode of 755 would turn - into 01363, yielding bizarre file permissions of --wxrw--wt. - - If you want something that handles decimal, octal and hex input, - you could follow the suggestion in the man page and use: - - $val = oct($val) if $val =~ /^0/; - -2.21) How do I sort an associative array by value instead of by key? - - You have to declare a sort subroutine to do this. Let's assume - you want an ASCII sort on the values of the associative array %ary. - You could do so this way: - - foreach $key (sort by_value keys %ary) { - print $key, '=', $ary{$key}, "\n"; - } - sub by_value { $ary{$a} cmp $ary{$b}; } - - If you wanted a descending numeric sort, you could do this: - - sub by_value { $ary{$b} <=> $ary{$a}; } - - You can also inline your sort function, like this: - - foreach $key ( sort { $x{$b} <=> $a{$a} } keys %ary ) { - print $key, '=', $ary{$key}, "\n"; - } - - If you wanted a function that didn't have the array name hard-wired - into it, you could so this: - - foreach $key (&sort_by_value(*ary)) { - print $key, '=', $ary{$key}, "\n"; - } - sub sort_by_value { - local(*x) = @_; - sub _by_value { $x{$a} cmp $x{$b}; } - sort _by_value keys %x; - } - - If you want neither an alphabetic nor a numeric sort, then you'll - have to code in your own logic instead of relying on the built-in - signed comparison operators "cmp" and "<=>". - - Note that if you're sorting on just a part of the value, such as a - piece you might extract via split, unpack, pattern-matching, or - substr, then rather than performing that operation inside your sort - routine on each call to it, it is significantly more efficient to - build a parallel array of just those portions you're sorting on, sort - the indices of this parallel array, and then to subscript your original - array using the newly sorted indices. This method works on both - regular and associative arrays, since both @ary[@idx] and @ary{@idx} - make sense. See page 245 in the Camel Book on "Sorting an Array by a - Computable Field" for a simple example of this. - - -2.22) How can I capture STDERR from an external command? - - There are three basic ways of running external commands: - - system $cmd; - $output = `$cmd`; - open (PIPE, "cmd |"); - - In the first case, both STDOUT and STDERR will go the same place as - the script's versions of these, unless redirected. You can always put - them where you want them and then read them back when the system - returns. In the second and third cases, you are reading the STDOUT - *only* of your command. If you would like to have merged STDOUT and - STDERR, you can use shell file-descriptor redirection to dup STDERR to - STDOUT: - - $output = `$cmd 2>&1`; - open (PIPE, "cmd 2>&1 |"); - - Another possibility is to run STDERR into a file and read the file - later, as in - - $output = `$cmd 2>some_file`; - open (PIPE, "cmd 2>some_file |"); - - Here's a way to read from both of them and know which descriptor - you got each line from. The trick is to pipe only STDERR through - sed, which then marks each of its lines, and then sends that - back into a merged STDOUT/STDERR stream, from which your Perl program - then reads a line at a time: - - open (CMD, - "3>&1 (cmd args 2>&1 1>&3 3>&- | sed 's/^/STDERR:/' 3>&-) 3>&- |"); - - while (<CMD>) { - if (s/^STDERR://) { - print "line from stderr: ", $_; - } else { - print "line from stdout: ", $_; - } - } - - Be apprised that you *must* use Bourne shell redirection syntax - here, not csh! In fact, you can't even do these things with csh. - For details on how lucky you are that perl's system() and backtick - and pipe opens all use Bourne shell, fetch the file from convex.com - called /pub/csh.whynot -- and you'll be glad that perl's shell - interface is the Bourne shell. - - -2.23) Why doesn't open return an error when a pipe open fails? - - These statements: - - open(TOPIPE, "|bogus_command") || die ... - open(FROMPIPE, "bogus_command|") || die ... - - will not fail just for lack of the bogus_command. They'll only - fail if the fork to run them fails, which is seldom the problem. - - If you're writing to the TOPIPE, you'll get a SIGPIPE if the child - exits prematurely or doesn't run. If you are reading from the - FROMPIPE, you need to check the close() to see what happened. - - If you want an answer sooner than pipe buffering might otherwise - afford you, you can do something like this: - - $kid = open (PIPE, "bogus_command |"); # XXX: check defined($kid) - (kill 0, $kid) || die "bogus_command failed"; - - This works fine if bogus_command doesn't have shell metas in it, but - if it does, the shell may well not have exited before the kill 0. You - could always introduce a delay: - - $kid = open (PIPE, "bogus_command </dev/null |"); - sleep 1; - (kill 0, $kid) || die "bogus_command failed"; - - but this is sometimes undesirable, and in any event does not guarantee - correct behavior. But it seems slightly better than nothing. - - Similar tricks can be played with writable pipes if you don't wish to - catch the SIGPIPE. - - -2.24) How can I compare two date strings? - - If the dates are in an easily parsed, predetermined format, then you - can break them up into their component parts and call &timelocal from - the distributed perl library. If the date strings are in arbitrary - formats, however, it's probably easier to use the getdate program - from the Cnews distribution, since it accepts a wide variety of dates. - Note that in either case the return values you will really be - comparing will be the total time in seconds as return by time(). - - Here's a getdate function for perl that's not very efficient; you - can do better this by sending it many dates at once or modifying - getdate to behave better on a pipe. Beware the hardcoded pathname. - - sub getdate { - local($_) = shift; - - s/-(\d{4})$/+$1/ || s/\+(\d{4})$/-$1/; - # getdate has broken timezone sign reversal! - - $_ = `/usr/local/lib/news/newsbin/getdate '$_'`; - chop; - $_; - } - - Richard Ohnemus <rick@IMD.Sterling.COM> actually has a getdate.y - for use with the Perl yacc. You can get this from ftp.sterling.com - [192.124.9.1] in /local/perl-byacc1.8.1.tar.Z, or send the author - mail for details. - - -2.25) What's the fastest way to code up a given task in perl? - - Because Perl so lends itself to a variety of different approaches - for any given task, a common question is which is the fastest way - to code a given task. Since some approaches can be dramatically - more efficient that others, it's sometimes worth knowing which is - best. Unfortunately, the implementation that first comes to mind, - perhaps as a direct translation from C or the shell, often yields - suboptimal performance. Not all approaches have the same results - across different hardware and software platforms. Furthermore, - legibility must sometimes be sacrificed for speed. - - While an experienced perl programmer can sometimes eye-ball the code - and make an educated guess regarding which way would be fastest, - surprises can still occur. So, in the spirit of perl programming - being an empirical science, the best way to find out which of several - different methods runs the fastest is simply to code them all up and - time them. For example: - - $COUNT = 10_000; $| = 1; - - print "method 1: "; - - ($u, $s) = times; - for ($i = 0; $i < $COUNT; $i++) { - # code for method 1 - } - ($nu, $ns) = times; - printf "%8.4fu %8.4fs\n", ($nu - $u), ($ns - $s); - - print "method 2: "; - - ($u, $s) = times; - for ($i = 0; $i < $COUNT; $i++) { - # code for method 2 - } - ($nu, $ns) = times; - printf "%8.4fu %8.4fs\n", ($nu - $u), ($ns - $s); - - For more specific tips, see the section on Efficiency in the - ``Other Oddments'' chapter at the end of the Camel Book. - - -2.26) How can I know how many entries are in an associative array? - - While the number of elements in a @foobar array is simply @foobar when - used in a scalar, you can't figure out how many elements are in an - associative array in an analagous fashion. That's because %foobar in - a scalar context returns the ratio (as a string) of number of buckets - filled versus the number allocated. For example, scalar(%ENV) might - return "20/32". While perl could in theory keep a count, this would - break down on associative arrays that have been bound to dbm files. - - However, while you can't get a count this way, one thing you *can* use - it for is to determine whether there are any elements whatsoever in - the array, since "if (%table)" is guaranteed to be false if nothing - has ever been stored in it. - - So you either have to keep your own count around and increments - it every time you store a new key in the array, or else do it - on the fly when you really care, perhaps like this: - - $count++ while each %ENV; - - This preceding method will be faster than extracting the - keys into a temporary array to count them. - - As of a very recent patch, you can say - - $count = keys %ENV; - - - -2.27) Why can't my perl program read from STDIN after I gave it ^D (EOF) ? - - Because some stdio's set error and eof flags that need clearing. - - Try keeping around the seekpointer and go there, like this: - $where = tell(LOG); - seek(LOG, $where, 0); - - If that doesn't work, try seeking to a different part of the file and - then back. If that doesn't work, try seeking to a different part of - the file, reading something, and then seeking back. If that doesn't - work, give up on your stdio package and use sysread. You can't call - stdio's clearerr() from Perl, so if you get EINTR from a signal - handler, you're out of luck. Best to just use sysread() from the - start for the tty. - - -2.28) Do I always/never have to quote my strings or use semicolons? - - You don't have to quote strings that can't mean anything else - in the language, like identifiers with any upper-case letters - in them. Therefore, it's fine to do this: - - $SIG{INT} = Timeout_Routine; - or - - @Days = (Sun, Mon, Tue, Wed, Thu, Fri, Sat, Sun); - - but you can't get away with this: - - $foo{while} = until; - - in place of - - $foo{'while'} = 'until'; - - The requirements on semicolons have been increasingly relaxed. You no - longer need one at the end of a block, but stylistically, you're - better to use them if you don't put the curly brace on the same line: - - for (1..10) { print } - - is ok, as is - - @nlist = sort { $a <=> $b } @olist; - - but you probably shouldn't do this: - - for ($i = 0; $i < @a; $i++) { - print "i is $i\n" # <-- oops! - } - - because you might want to add lines later, and anyway, - it looks funny. :-) - - -2.29) How can I translate tildes in a filename? - - Perl doesn't expand tildes -- the shell (ok, some shells) do. - The classic request is to be able to do something like: - - open(FILE, "~/dir1/file1"); - open(FILE, "~tchrist/dir1/file1"); - - which doesn't work. (And you don't know it, because you - did a system call without an "|| die" clause! :-) - - If you *know* you're on a system with the csh, and you *know* - that Larry hasn't internalized file globbing, then you could - get away with - - $filename = <~tchrist/dir1/file1>; - - but that's pretty iffy. - - A better way is to do the translation yourself, as in: - - $filename =~ s#^~(\w+)(/.*)?$#(getpwnam($1))[7].$2#e; - - More robust and efficient versions that checked for error conditions, - handed simple ~/blah notation, and cached lookups are all reasonable - enhancements. - - -2.30) How can I convert my shell script to Perl? - - Larry's standard answer for this is to send your script to me (Tom - Christiansen) with appropriate supplications and offerings. :-( - That's because there's no automatic machine translator. Even if you - were, you wouldn't gain a lot, as most of the external programs would - still get called. It's the same problem as blind translation into C: - you're still apt to be bogged down by exec()s. You have to analize - the dataflow and algorithm and rethink it for optimal speedup. It's - not uncommon to see one, two, or even three orders of magnitude of - speed difference between the brute-force and the recoded approaches. - - -2.31) What is variable suicide and how can I prevent it? - - Variable suicide is a nasty sideeffect of dynamic scoping and - the way variables are passed by reference. If you say - - $x = 17; - &munge($x); - sub munge { - local($x); - local($myvar) = $_[0]; - ... - } - - Then you have just clubbered $_[0]! Why this is occurring - is pretty heavy wizardry: the reference to $x stored in - $_[0] was temporarily occluded by the previous local($x) - statement (which, you're recall, occurs at run-time, not - compile-time). The work around is simple, however: declare - your formal parameters first: - - sub munge { - local($myvar) = $_[0]; - local($x); - ... - } - - That doesn't help you if you're going to be trying to access - @_ directly after the local()s. In this case, careful use - of the package facility is your only recourse. - - Another manifestation of this problem occurs due to the - magical nature of the index variable in a foreach() loop. - - @num = 0 .. 4; - print "num begin @num\n"; - foreach $m (@num) { &ug } - print "num finish @num\n"; - sub ug { - local($m) = 42; - print "m=$m $num[0],$num[1],$num[2],$num[3]\n"; - } - - Which prints out the mysterious: - - num begin 0 1 2 3 4 - m=42 42,1,2,3 - m=42 0,42,2,3 - m=42 0,1,42,3 - m=42 0,1,2,42 - m=42 0,1,2,3 - num finish 0 1 2 3 4 - - What's happening here is that $m is an alias for each - element of @num. Inside &ug, you temporarily change - $m. Well, that means that you've also temporarily - changed whatever $m is an alias to!! The only workaround - is to be careful with global variables, using packages, - and/or just be aware of this potential in foreach() loops. - - -2.32) Can I use Perl regular expressions to match balanced text? - - No, or at least, not by the themselves. - - Regexps just aren't powerful enough. Although Perl's patterns aren't - strictly regular because they do backtracking (the \1 notation), you - still can't do it. You need to employ auxiliary logic. A simple - approach would involve keeping a bit of state around, something - vaguely like this (although we don't handle patterns on the same line): - - while(<>) { - if (/pat1/) { - if ($inpat++ > 0) { warn "already saw pat1" } - redo; - } - if (/pat2/) { - if (--$inpat < 0) { warn "never saw pat1" } - redo; - } - } - - A rather more elaborate subroutine to pull out balanced and possibly - nested single chars, like ` and ', { and }, or ( and ) can be found - on convex.com in /pub/perl/scripts/pull_quotes. - - -2.33) Can I use Perl to run a telnet or ftp session? - - Sure, you can connect directly to them using sockets, or you can run a - session on a pty. In either case, Randal's chat2 package, which is - distributed with the perl source, will come in handly. It address - much the same problem space as Don Libes's expect package does. Two - examples of using managing an ftp session using chat2 can be found on - convex.com in /pub/perl/scripts/ftp-chat2.shar . - - Caveat lector: chat2 is documented only by example, may not run on - System V systems, and is subtly machine dependent both in its ideas - of networking and in pseudottys. - - -2.34) What does "Malformed command links" mean? - - This is a bug in 4.035. While in general it's merely a cosmetic - problem, it often comanifests with a highly undesirable coredumping - problem. Programs known to be affected by the fatal coredump include - plum and pcops. Since perl5 is prety much a total rewrite, we can - count on it being fixed then, but if anyone tracks down the coredump - problem before then, a signifcant portion of the perl world would - rejoice. [Fixed in 4.036--lwall] @@ -1,20 +0,0 @@ -#!./perl - -sub fib -{ - ($_[0] < 2) ? $_[0] : &fib($_[0]-1) + &fib($_[0]-2); -} - -sub myruntime -{ - local(@t) = times; # in seconds - $t[0] + $t[1]; -} - -$x = (shift || 20); -print "Starting fib($x)\n"; -$before = &myruntime; -$y = &fib($x); -$after = &myruntime; -printf("Done. Result $y in %g cpu seconds.\n", $after-$before); - @@ -1,21 +0,0 @@ -#!/usr/bin/perl - -sub fib -{ - local($a) = $_[0]; - ($a < 2) ? $a : &fib($a-1) + &fib($a-2); -} - -sub myruntime -{ - local(@t) = times; # in seconds - $t[0] + $t[1]; -} - -$x = (shift || 20); -print "Starting fib($x)\n"; -$before = &myruntime; -$y = &fib($x); -$after = &myruntime; -printf("Done. Result $y in %g cpu seconds.\n", $after-$before); - @@ -1,5 +0,0 @@ -#!./perl - -require 'dumpvar.pl'; - -&dumpvar("main"); @@ -1,19 +1,10 @@ -/* $RCSfile: form.h,v $$Revision: 4.1 $$Date: 92/08/07 18:20:43 $ +/* form.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: form.h,v $ - * Revision 4.1 92/08/07 18:20:43 lwall - * - * Revision 4.0.1.1 91/06/07 11:08:20 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:19:37 lwall - * 4.0 baseline. - * */ #define FF_END 0 diff --git a/gettest b/gettest deleted file mode 100755 index 565ae82bc6..0000000000 --- a/gettest +++ /dev/null @@ -1,20 +0,0 @@ -#!./perl - - while (($name,$aliases,$addrtype,$length,@addrs) = gethostent) { - print $name,' ',$aliases, - sprintf(" %d.%d.%d.%d\n",unpack('CCCC',$addrs[0])); - last if $i++ > 50; - } - <stdin>; - while (($name,$aliases,$addrtype,$net) = getnetent) { - print "$name $aliases $addrtype ",sprintf("%08lx",$net),"\n"; - } - <stdin>; - while (($name,$aliases,$proto) = getprotoent) { - print "$name $aliases $proto\n"; - } - <stdin>; - while (($name,$aliases,$port,$proto) = getservent) { - print "$name $aliases $port $proto\n"; - } - diff --git a/global.sym b/global.sym index d496c9025b..54b78c2ee0 100644 --- a/global.sym +++ b/global.sym @@ -2,58 +2,115 @@ # Variables +AMG_names No Sv Xpv Yes +abs_amg +add_amg +add_ass_amg additem +amagic_generation an +atan2_amg +autoboot_preamble +band_amg +bool__amg +bor_amg buf bufend bufptr +bxor_amg check coeff compiling +compl_amg comppad comppad_name comppad_name_fill +concat_amg +concat_ass_amg cop_seqmax +cos_amg cryptseen +cryptswitch_add cshlen cshname +curcop curinterp curpad dc +dec_amg di +div_amg +div_ass_amg ds egid +envgv +eq_amg error_count euid evalseq -evstr +exp_amg expect expectterm +fallback_amg fold freq +ge_amg gid +gt_amg hexdigit hints in_my +inc_amg know_next last_lop last_lop_op last_uni +le_amg +lex_state +lex_defer +lex_expect +lex_brackets +lex_formbrack +lex_fakebrack +lex_casemods +lex_dojoin +lex_starts +lex_stuff +lex_repl +lex_op +lex_inpat +lex_inwhat +lex_brackstack +lex_casestack linestr +log_amg +lshift_amg +lshift_ass_amg +lt_amg markstack markstack_max markstack_ptr max_intro_pending min_intro_pending +mod_amg +mod_ass_amg +mult_amg +mult_ass_amg multi_close multi_end multi_open multi_start na +ncmp_amg +nextval +nexttype +nexttoke +ne_amg +neg_amg nexttype nextval no_aelem @@ -68,6 +125,9 @@ no_usym nointrp nomem nomemok +nomethod_amg +not_amg +numer_amg oldbufptr oldoldbufptr op @@ -78,7 +138,11 @@ origalen origenviron padix patleave +pow_amg +pow_ass_amg ppaddr +profiledata +qrt_amg rcsid reall_srchlen regarglen @@ -94,46 +158,67 @@ regmyendp regmyp_size regmystartp regnarrate +regnaughty regnpar regparse regprecomp regprev regsawback -regsawbracket regsize regstartp regtill regxend +repeat_amg +repeat_ass_amg retstack retstack_ix retstack_max rsfp +rshift_amg +rshift_ass_amg savestack savestack_ix savestack_max saw_return +scmp_amg scopestack scopestack_ix scopestack_max scrgv +seq_amg +sge_amg +sgt_amg sig_name +siggv +sighandler simple +sin_amg +sle_amg +slt_amg +sne_amg +stack stack_base stack_max stack_sp statbuf +string_amg sub_generation subline subname +subtr_amg +subtr_ass_amg sv_no sv_undef sv_yes +tainting thisexpr timesbuf tokenbuf uid varies vert +vtbl_amagic +vtbl_amagicelem vtbl_arylen vtbl_bm vtbl_dbline @@ -145,6 +230,7 @@ vtbl_isaelem vtbl_mglob vtbl_pack vtbl_packelem +vtbl_pos vtbl_sig vtbl_sigelem vtbl_substr @@ -187,20 +273,19 @@ av_fill av_len av_make av_pop -av_popnulls av_push av_shift av_store av_undef av_unshift bind_match -block_head +block_end +block_start calllist cando check_uni checkcomma ck_aelem -ck_chop ck_concat ck_eof ck_eval @@ -223,11 +308,11 @@ ck_rvconst ck_select ck_shift ck_sort +ck_spair ck_split ck_subr ck_trunc convert -cpy7bit cpytill croak cv_undef @@ -237,12 +322,12 @@ deb_growlevel debop debstack debstackptrs +deprecate die die_where do_aexec do_chop do_close -do_ctl do_eof do_exec do_execfree @@ -256,6 +341,7 @@ do_open do_pipe do_print do_readline +do_chomp do_seek do_semop do_shmio @@ -278,14 +364,12 @@ fbm_compile fbm_instr fetch_gv fetch_io -fetch_stash fold_constants force_ident force_next force_word free_tmps gen_constant_list -getgimme gp_free gp_ref gv_AVadd @@ -298,13 +382,16 @@ gv_fetchmethod gv_fetchpv gv_fullname gv_init +gv_stashpv +gv_stashsv he_delayfree he_free -hint hoistmust hv_clear hv_delete +hv_exists hv_fetch +hv_stashpv hv_iterinit hv_iterkey hv_iternext @@ -332,11 +419,13 @@ magic_get magic_getarylen magic_getglob magic_getpack +magic_getpos magic_gettaint magic_getuvar magic_len magic_nextpack magic_set +magic_setamagic magic_setarylen magic_setbm magic_setdbline @@ -345,12 +434,15 @@ magic_setglob magic_setisa magic_setmglob magic_setpack +magic_setpos magic_setsig magic_setsubstr magic_settaint magic_setuvar magic_setvec +magic_wipepack magicname +markstack_grow mess mg_clear mg_copy @@ -395,9 +487,11 @@ newLOOPOP newMETHOD newNULLLIST newOP +newPROG newPMOP newPVOP newRANGE +newRV newSLICEOP newSTATEOP newSUB @@ -411,11 +505,11 @@ newSVsv newUNOP newWHILEOP newXSUB +newXS nextargv ninstr no_fh_allowed no_op -nsavestr oopsAV oopsCV oopsHV @@ -478,7 +572,6 @@ pp_delete pp_die pp_divide pp_dofile -pp_done pp_dump pp_each pp_egrent @@ -488,6 +581,7 @@ pp_enter pp_entereval pp_enteriter pp_enterloop +pp_entersub pp_entersubr pp_entertry pp_enterwrite @@ -498,6 +592,7 @@ pp_eq pp_eservent pp_evalonce pp_exec +pp_exists pp_exit pp_exp pp_fcntl @@ -588,7 +683,7 @@ pp_le pp_leave pp_leaveeval pp_leaveloop -pp_leavesubr +pp_leavesub pp_leavetry pp_leavewrite pp_left_shift @@ -602,6 +697,7 @@ pp_log pp_lslice pp_lstat pp_lt +pp_map pp_match pp_method pp_mkdir @@ -631,6 +727,7 @@ pp_padhv pp_padsv pp_pipe_op pp_pop +pp_pos pp_postdec pp_postinc pp_pow @@ -669,6 +766,7 @@ pp_rv2cv pp_rv2gv pp_rv2hv pp_rv2sv +pp_chomp pp_sassign pp_scalar pp_schop @@ -710,6 +808,8 @@ pp_sprotoent pp_spwent pp_sqrt pp_srand +pp_srefgen +pp_schomp pp_sselect pp_sservent pp_ssockopt @@ -765,6 +865,8 @@ regprop repeatcpy rninstr run +savepv +savepvn save_I32 save_aptr save_ary @@ -783,7 +885,6 @@ save_scalar save_sptr save_svref savestack_grow -savestr sawparens scalar scalarkids @@ -807,23 +908,25 @@ scope screaminstr setenv_getix skipspace +stack_grow start_subparse sublex_done sublex_start sv_2bool sv_2cv +sv_2io sv_2iv sv_2mortal sv_2nv sv_2pv sv_backoff +sv_bless sv_catpv sv_catpvn sv_catsv sv_chop sv_clean_all -sv_clean_magic -sv_clean_refs +sv_clean_objs sv_clear sv_cmp sv_dec @@ -849,6 +952,8 @@ sv_setnv sv_setptrobj sv_setpv sv_setpvn +sv_setref_iv +sv_setref_pv sv_setsv sv_unmagic sv_upgrade @@ -862,6 +967,7 @@ wait4pid warn watch whichsig +xiv_arenaroot xiv_root xnv_root xpv_root @@ -1,43 +1,19 @@ -/* $RCSfile: gv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:39 $ +/* gv.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: gv.c,v $ - * Revision 4.1 92/08/07 18:26:39 lwall - * - * Revision 4.0.1.4 92/06/08 15:32:19 lwall - * patch20: fixed confusion between a *var's real name and its effective name - * patch20: the debugger now warns you on lines that can't set a breakpoint - * patch20: the debugger made perl forget the last pattern used by // - * patch20: paragraph mode now skips extra newlines automatically - * patch20: ($<,$>) = ... didn't work on some architectures - * - * Revision 4.0.1.3 91/11/05 18:35:33 lwall - * patch11: length($x) was sometimes wrong for numeric $x - * patch11: perl now issues warning if $SIG{'ALARM'} is referenced - * patch11: *foo = undef coredumped - * patch11: solitary subroutine references no longer trigger typo warnings - * patch11: local(*FILEHANDLE) had a memory leak - * - * Revision 4.0.1.2 91/06/07 11:55:53 lwall - * patch4: new copyright notice - * patch4: added $^P variable to control calling of perldb routines - * patch4: added $^F variable to specify maximum system fd, default 2 - * patch4: $` was busted inside s/// - * patch4: default top-of-form run_format is now FILEHANDLE_TOP - * patch4: length($`), length($&), length($') now optimized to avoid string copy - * patch4: $^D |= 1024 now does syntax tree dump at run-time - * - * Revision 4.0.1.1 91/04/12 09:10:24 lwall - * patch1: Configure now differentiates getgroups() type from getgid() type - * patch1: you may now use "die" and "caller" in a signal handler - * - * Revision 4.0 91/03/20 01:39:41 lwall - * 4.0 baseline. - * + */ + +/* + * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure + * of your inquisitiveness, I shall spend all the rest of my days answering + * you. What more do you want to know?' + * 'The names of all the stars, and of all living things, and the whole + * history of Middle-earth and Over-heaven and of the Sundering Seas,' + * laughed Pippin. */ #include "EXTERN.h" @@ -49,6 +25,8 @@ GV * gv_AVadd(gv) register GV *gv; { + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + croak("Bad symbol for array"); if (!GvAV(gv)) GvAV(gv) = newAV(); return gv; @@ -58,12 +36,25 @@ GV * gv_HVadd(gv) register GV *gv; { + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + croak("Bad symbol for hash"); if (!GvHV(gv)) GvHV(gv) = newHV(); return gv; } GV * +gv_IOadd(gv) +register GV *gv; +{ + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + croak("Bad symbol for filehandle"); + if (!GvIOp(gv)) + GvIOp(gv) = newIO(); + return gv; +} + +GV * gv_fetchfile(name) char *name; { @@ -73,7 +64,7 @@ char *name; sprintf(tmpbuf,"::_<%s", name); gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV); sv_setpv(GvSV(gv), name); - if (*name == '/') + if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm"))) SvMULTI_on(gv); if (perldb) hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); @@ -102,22 +93,47 @@ int multi; GvEGV(gv) = gv; sv_magic((SV*)gv, (SV*)gv, '*', name, len); GvSTASH(gv) = stash; - GvNAME(gv) = nsavestr(name, len); + GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi) SvMULTI_on(gv); } +static void +gv_init_sv(gv, sv_type) +GV* gv; +I32 sv_type; +{ + switch (sv_type) { + case SVt_PVIO: + (void)GvIOn(gv); + break; + case SVt_PVAV: + (void)GvAVn(gv); + break; + case SVt_PVHV: + (void)GvHVn(gv); + break; + } +} + GV * -gv_fetchmeth(stash, name, len) +gv_fetchmeth(stash, name, len, level) HV* stash; char* name; STRLEN len; +I32 level; { AV* av; GV* topgv; GV* gv; GV** gvp; + HV* lastchance; + + if (!stash) + return 0; + if (level > 100) + croak("Recursive inheritance detected"); gvp = (GV**)hv_fetch(stash, name, len, TRUE); @@ -137,14 +153,14 @@ STRLEN len; I32 items = AvFILL(av) + 1; while (items--) { SV* sv = *svp++; - HV* basestash = fetch_stash(sv, FALSE); + HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (dowarn) - warn("Can't locate package %s for @%s'ISA", + warn("Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } - gv = gv_fetchmeth(basestash, name, len); + gv = gv_fetchmeth(basestash, name, len, level + 1); if (gv) { GvCV(topgv) = GvCV(gv); /* cache the CV */ GvCVGEN(topgv) = sub_generation; /* valid for now */ @@ -152,6 +168,17 @@ STRLEN len; } } } + + if (!level) { + if (lastchance = gv_stashpv("UNIVERSAL", FALSE)) { + if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) { + GvCV(topgv) = GvCV(gv); /* cache the CV */ + GvCVGEN(topgv) = sub_generation; /* valid for now */ + return gv; + } + } + } + return 0; } @@ -161,20 +188,78 @@ HV* stash; char* name; { register char *nend; + char *nsplit = 0; + GV* gv; for (nend = name; *nend; nend++) { - if (*nend == ':' || *nend == '\'') { - return gv_fetchpv(name, FALSE, SVt_PVCV); + if (*nend == ':' || *nend == '\'') + nsplit = nend; + } + if (nsplit) { + char ch; + char *origname = name; + name = nsplit + 1; + ch = *nsplit; + if (*nsplit == ':') + --nsplit; + *nsplit = '\0'; + stash = gv_stashpv(origname,TRUE); + *nsplit = ch; + } + gv = gv_fetchmeth(stash, name, nend - name, 0); + if (!gv) { + CV* cv; + + if (strEQ(name,"import") || strEQ(name,"unimport")) + gv = &sv_yes; + else if (strNE(name, "AUTOLOAD")) { + gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0); + if (gv && (cv = GvCV(gv))) { /* One more chance... */ + SV *tmpstr = sv_newmortal(); + sv_catpv(tmpstr,HvNAME(stash)); + sv_catpvn(tmpstr,"::", 2); + sv_catpvn(tmpstr, name, nend - name); + sv_setsv(GvSV(CvGV(cv)), tmpstr); + } } } - return gv_fetchmeth(stash, name, nend - name); + return gv; +} + +HV* +gv_stashpv(name,create) +char *name; +I32 create; +{ + char tmpbuf[1234]; + HV *stash; + GV *tmpgv; + sprintf(tmpbuf,"%.*s::",1200,name); + tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV); + if (!tmpgv) + return 0; + if (!GvHV(tmpgv)) + GvHV(tmpgv) = newHV(); + stash = GvHV(tmpgv); + if (!HvNAME(stash)) + HvNAME(stash) = savepv(name); + return stash; } +HV* +gv_stashsv(sv,create) +SV *sv; +I32 create; +{ + return gv_stashpv(SvPV(sv,na), create); +} + + GV * -gv_fetchpv(nambeg,add,svtype) +gv_fetchpv(nambeg,add,sv_type) char *nambeg; I32 add; -I32 svtype; +I32 sv_type; { register char *name = nambeg; register GV *gv = 0; @@ -191,13 +276,16 @@ I32 svtype; { if (!stash) stash = defstash; + if (!SvREFCNT(stash)) /* symbol table under destruction */ + return Nullgv; len = namend - name; if (len > 0) { - New(601, tmpbuf, len+2, char); - *tmpbuf = '_'; - Copy(name, tmpbuf+1, len, char); - tmpbuf[++len] = '\0'; + New(601, tmpbuf, len+3, char); + Copy(name, tmpbuf, len, char); + tmpbuf[len++] = ':'; + tmpbuf[len++] = ':'; + tmpbuf[len] = '\0'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); Safefree(tmpbuf); if (!gvp || *gvp == (GV*)&sv_undef) @@ -206,6 +294,8 @@ I32 svtype; if (SvTYPE(gv) == SVt_PVGV) SvMULTI_on(gv); + else if (!add) + return Nullgv; else gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); @@ -213,7 +303,7 @@ I32 svtype; stash = GvHV(gv) = newHV(); if (!HvNAME(stash)) - HvNAME(stash) = nsavestr(nambeg, namend - nambeg); + HvNAME(stash) = savepvn(nambeg, namend - nambeg); } if (*namend == ':') @@ -221,9 +311,12 @@ I32 svtype; namend++; name = namend; if (!*name) - return gv ? gv : defgv; + return gv ? gv : *hv_fetch(defstash, "main::", 6, TRUE); } } + len = namend - name; + if (!len) + len = 1; /* No stash in name, so see how we can default */ @@ -256,8 +349,11 @@ I32 svtype; if (global) stash = defstash; else if ((COP*)curcop == &compiling) { - if (!(hints & HINT_STRICT_VARS) || svtype == SVt_PVCV) - stash = curstash; + stash = curstash; + if (add && (hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV) { + if (stash && !hv_fetch(stash,name,len,0)) + stash = 0; + } } else stash = curcop->cop_stash; @@ -268,46 +364,85 @@ I32 svtype; /* By this point we should have a stash and a name */ - if (!stash) - croak("Global symbol \"%s\" requires explicit package name", name); - len = namend - name; - if (!len) - len = 1; + if (!stash) { + if (add) { + warn("Global symbol \"%s\" requires explicit package name", name); + ++error_count; + stash = curstash ? curstash : defstash; /* avoid core dumps */ + } + else + return Nullgv; + } + + if (!SvREFCNT(stash)) /* symbol table under destruction */ + return Nullgv; + gvp = (GV**)hv_fetch(stash,name,len,add); if (!gvp || *gvp == (GV*)&sv_undef) return Nullgv; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { - SvMULTI_on(gv); + if (add) { + SvMULTI_on(gv); + gv_init_sv(gv, sv_type); + } return gv; } /* Adding a new symbol */ + if (add & 4) + warn("Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & 2); + gv_init_sv(gv, sv_type); /* set up magic where warranted */ switch (*name) { + case 'A': + if (strEQ(name, "ARGV")) { + IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; + } + break; + case 'a': case 'b': if (len == 1) SvMULTI_on(gv); break; + case 'E': + if (strnEQ(name, "EXPORT", 6)) + SvMULTI_on(gv); + break; case 'I': if (strEQ(name, "ISA")) { AV* av = GvAVn(gv); SvMULTI_on(gv); - sv_magic((SV*)av, (SV*)gv, 'I', 0, 0); - if (add & 2 && strEQ(nambeg,"Any_DBM_File::ISA") && AvFILL(av) == -1) + sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); + if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1) { - av_push(av, newSVpv("NDBM_File",0)); - av_push(av, newSVpv("DB_File",0)); - av_push(av, newSVpv("GDBM_File",0)); - av_push(av, newSVpv("SDBM_File",0)); - av_push(av, newSVpv("ODBM_File",0)); + 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; +#ifdef OVERLOAD + case 'O': + if (strEQ(name, "OVERLOAD")) { + HV* hv = GvHVn(gv); + SvMULTI_on(gv); + sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0); + } + break; +#endif /* OVERLOAD */ case 'S': if (strEQ(name, "SIG")) { HV *hv; @@ -318,9 +453,9 @@ I32 svtype; /* initialize signal stack */ signalstack = newAV(); - av_store(signalstack, 32, Nullsv); - av_clear(signalstack); AvREAL_off(signalstack); + av_extend(signalstack, 30); + av_fill(signalstack, 0); } break; @@ -329,21 +464,21 @@ I32 svtype; break; ampergv = gv; sawampersand = TRUE; - goto magicalize; + goto ro_magicalize; case '`': if (len > 1) break; leftgv = gv; sawampersand = TRUE; - goto magicalize; + goto ro_magicalize; case '\'': if (len > 1) break; rightgv = gv; sawampersand = TRUE; - goto magicalize; + goto ro_magicalize; case ':': if (len > 1) @@ -351,8 +486,13 @@ I32 svtype; sv_setpv(GvSV(gv),chopset); goto magicalize; - case '!': case '#': + case '*': + if (dowarn && len == 1 && sv_type == SVt_PV) + warn("Use of $%s is deprecated", name); + /* FALL THROUGH */ + case '[': + case '!': case '?': case '^': case '~': @@ -360,8 +500,6 @@ I32 svtype; case '-': case '%': case '.': - case '+': - case '*': case '(': case ')': case '<': @@ -369,9 +507,9 @@ I32 svtype; case ',': case '\\': case '/': - case '[': case '|': case '\004': + case '\010': case '\t': case '\020': case '\024': @@ -381,6 +519,7 @@ I32 svtype; break; goto magicalize; + case '+': case '1': case '2': case '3': @@ -390,6 +529,8 @@ I32 svtype; case '7': case '8': case '9': + ro_magicalize: + SvREADONLY_on(GvSV(gv)); magicalize: sv_magic(GvSV(gv), (SV*)gv, 0, name, len); break; @@ -410,9 +551,7 @@ I32 svtype; SV *sv; sv = GvSV(gv); sv_upgrade(sv, SVt_PVNV); - sv_setpv(sv,rcsid); - SvNVX(sv) = atof(patchlevel); - SvNOK_on(sv); + sv_setpv(sv, patchlevel); } break; } @@ -457,7 +596,7 @@ newIO() GV *iogv; io = (IO*)NEWSV(0,0); - sv_upgrade(io,SVt_PVIO); + sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO); @@ -473,34 +612,39 @@ HV* stash; register I32 i; register GV *gv; HV *hv; + GV *filegv; if (!HvARRAY(stash)) return; - for (i = 0; i <= HvMAX(stash); i++) { + for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) { - if (isALPHA(*entry->hent_key)) { + 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 (SvMULTI(gv)) continue; curcop->cop_line = GvLINE(gv); - curcop->cop_filegv = GvFILEGV(gv); - if (SvMULTI(GvFILEGV(gv))) /* Filename began with slash */ + filegv = GvFILEGV(gv); + curcop->cop_filegv = filegv; + if (filegv && SvMULTI(filegv)) /* Filename began with slash */ continue; - warn("Identifier \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); + warn("Identifier \"%s::%s\" used only once: possible typo", + HvNAME(stash), GvNAME(gv)); } - else if (*entry->hent_key == '_' && - (gv = (GV*)entry->hent_val) && - (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash) - gv_check(hv); /* nested package */ - } } } GV * -newGVgen() +newGVgen(pack) +char *pack; { - (void)sprintf(tokenbuf,"_GEN_%d",gensym++); + (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++); return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV); } @@ -568,3 +712,344 @@ register GV *gv; return GvGP(gv_HVadd(gv))->gp_hv; } #endif /* Microport 2.4 hack */ + +#ifdef OVERLOAD +/* Updates and caches the CV's */ + +bool +Gv_AMupdate(stash) +HV* stash; +{ + GV** gvp; + HV* hv; + GV* gv; + CV* cv; + MAGIC* mg=mg_find((SV*)stash,'c'); + AMT *amtp; + + if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation && + amtp->was_ok_sub == sub_generation) + return HV_AMAGIC(stash)? TRUE: FALSE; + gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); + sv_unmagic((SV*)stash, 'c'); + + DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) ); + + if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) { + int filled=0; + int i; + char *cp; + AMT amt; + SV* sv; + SV** svp; + +/* if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) { + DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash)) +); + return HV_AMAGIC(stash)? TRUE: FALSE; + }*/ + + amt.was_ok_am=amagic_generation; + amt.was_ok_sub=sub_generation; + amt.fallback=AMGfallNO; + + /* Work with "fallback" key, which we assume to be first in AMG_names */ + + if ((cp=((char**)(*AMG_names))[0]) && + (svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { + if (SvTRUE(sv)) amt.fallback=AMGfallYES; + else if (SvOK(sv)) amt.fallback=AMGfallNEVER; + } + + for (i=1;i<NofAMmeth*2;i++) { + cv=0; + + if ( (cp=((char**)(*AMG_names))[i]) ) { + svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE); + if (svp && ((sv = *svp) != (GV*)&sv_undef)) { + switch (SvTYPE(sv)) { + default: + if (!SvROK(sv)) { + if (!SvOK(sv)) break; + gv = gv_fetchmethod(curcop->cop_stash, SvPV(sv, na)); + if (gv) cv = GvCV(gv); + break; + } + cv = (CV*)SvRV(sv); + if (SvTYPE(cv) == SVt_PVCV) + break; + /* FALL THROUGH */ + case SVt_PVHV: + case SVt_PVAV: + die("Not a subroutine reference in %%OVERLOAD"); + return FALSE; + case SVt_PVCV: + cv = (CV*)sv; + break; + case SVt_PVGV: + if (!(cv = GvCV((GV*)sv))) + cv = sv_2cv(sv, &stash, &gv, TRUE); + break; + } + if (cv) filled=1; + else { + die("Method for operation %s not found in package %s during blessing\n", + cp,HvNAME(stash)); + return FALSE; + } + } + } + amt.table[i]=cv; + } + sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt)); + if (filled) { +/* HV_badAMAGIC_off(stash);*/ + HV_AMAGIC_on(stash); + return TRUE; + } + } +/*HV_badAMAGIC_off(stash);*/ + HV_AMAGIC_off(stash); + return FALSE; +} + +/* During call to this subroutine stack can be reallocated. It is + * advised to call SPAGAIN macro in your code after call */ + +SV* +amagic_call(left,right,method,flags) +SV* left; +SV* right; +int method; +int flags; +{ + MAGIC *mg; + CV *cv; + CV **cvp=NULL, **ocvp=NULL; + AMT *amtp, *oamtp; + int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0; + int postpr=0; + HV* stash; + if (!(AMGf_noleft & flags) && SvAMAGIC(left) + && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) + && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table)) + && (assign ? + ((cv = cvp[off=method+1]) + || ( amtp->fallback > AMGfallNEVER && /* fallback to + * usual method */ + (fl = 1, cv = cvp[off=method]))): + (1 && (cv = cvp[off=method])) )) { + lr = -1; /* Call method for left argument */ + } else { + if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { + int logic; + + /* look for substituted methods */ + switch (method) { + case inc_amg: + if ((cv = cvp[off=add_ass_amg]) + || ((cv = cvp[off=add_amg]) && (postpr=1))) { + right = &sv_yes; lr = -1; assign = 1; + } + break; + case dec_amg: + if ((cv = cvp[off=subtr_ass_amg]) + || ((cv = cvp[off=subtr_amg]) && (postpr=1))) { + right = &sv_yes; lr = -1; assign = 1; + } + break; + case bool__amg: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); + break; + case numer_amg: + (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); + break; + case string_amg: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); + break; + case abs_amg: + if ((cvp[off1=lt_amg] || cvp[off1=lt_amg]) + && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { + if (off1==lt_amg) { + SV* lessp = amagic_call(left, + sv_2mortal(newSViv(0)), + lt_amg,AMGf_noright); + logic = SvTRUE(lessp); + } else { + SV* lessp = amagic_call(left, + sv_2mortal(newSViv(0)), + ncmp_amg,AMGf_noright); + logic = (SvNV(lessp) < 0); + } + if (logic) { + if (off==subtr_amg) { + right = left; + left = sv_2mortal(newSViv(0)); + lr = 1; + } + } else { + return left; + } + } + break; + case neg_amg: + if (cv = cvp[off=subtr_amg]) { + right = left; + left = sv_2mortal(newSViv(0)); + lr = 1; + } + break; + default: + goto not_found; + } + if (!cv) goto not_found; + } else if (!(AMGf_noright & flags) && SvAMAGIC(right) + && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) + && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table)) + && (cv = cvp[off=method])) { /* Method for right + * argument found */ + lr=1; + } else if (((ocvp && oamtp->fallback > AMGfallNEVER && (cvp=ocvp)) + || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) + && !(flags & AMGf_unary)) { + /* We look for substitution for + * comparison operations and + * concatendation */ + if (method==concat_amg || method==concat_ass_amg + || method==repeat_amg || method==repeat_ass_amg) { + return NULL; /* Delegate operation to string conversion */ + } + off = -1; + switch (method) { + case lt_amg: + case le_amg: + case gt_amg: + case ge_amg: + case eq_amg: + case ne_amg: + postpr = 1; off=ncmp_amg; break; + case slt_amg: + case sle_amg: + case sgt_amg: + case sge_amg: + case seq_amg: + case sne_amg: + postpr = 1; off=scmp_amg; break; + } + if (off != -1) cv = cvp[off]; + if (!cv) { + goto not_found; + } + } else { + not_found: /* No method found, either report or die */ + if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ + notfound = 1; lr = -1; + } else if (cvp && (cv=cvp[nomethod_amg])) { + notfound = 1; lr = 1; + } else { + char tmpstr[512]; + sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%200s,\n\tright argument %s%200s", + ((char**)AMG_names)[off], + SvAMAGIC(left)? + "in overloaded package ": + "has no overloaded magic", + SvAMAGIC(left)? + HvNAME(SvSTASH(SvRV(left))): + "", + SvAMAGIC(right)? + "in overloaded package ": + "has no overloaded magic", + SvAMAGIC(right)? + HvNAME(SvSTASH(SvRV(right))): + ""); + if (amtp && amtp->fallback >= AMGfallYES) { + DEBUG_o( deb(tmpstr) ); + } else { + die(tmpstr); + } + return NULL; + } + } + } + if (!notfound) { + DEBUG_o( deb("Operation `%s': method for %s argument found in package %s%s\n", + ((char**)AMG_names)[off], + (lr? "right": "left"), + HvNAME(stash), + fl? ",\n\tassignment variant used": "") ); + /* Since we use shallow copy, we need to dublicate the contents, + probably we need also to use user-supplied version of coping? + */ + if (assign || method==inc_amg || method==dec_amg) RvDEEPCP(left); + } + { + dSP; + BINOP myop; + SV* res; + + Zero(&myop, 1, BINOP); + myop.op_last = (OP *) &myop; + myop.op_next = Nullop; + myop.op_flags = OPf_KNOW|OPf_STACKED; + + ENTER; + SAVESPTR(op); + op = (OP *) &myop; + PUTBACK; + pp_pushmark(); + + EXTEND(sp, notfound + 5); + PUSHs(lr>0? right: left); + PUSHs(lr>0? left: right); + PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no)); + if (notfound) { + PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[off],0)) ); + } + PUSHs((SV*)cv); + PUTBACK; + + if (op = pp_entersub()) + run(); + LEAVE; + SPAGAIN; + + res=POPs; + PUTBACK; + + if (notfound) { + /* sv_2mortal(res); */ + return NULL; + } + + if (postpr) { + int ans; + switch (method) { + case le_amg: + case sle_amg: + ans=SvIV(res)<=0; break; + case lt_amg: + case slt_amg: + ans=SvIV(res)<0; break; + case ge_amg: + case sge_amg: + ans=SvIV(res)>=0; break; + case gt_amg: + case sgt_amg: + ans=SvIV(res)>0; break; + case eq_amg: + case seq_amg: + ans=SvIV(res)==0; break; + case ne_amg: + case sne_amg: + ans=SvIV(res)!=0; break; + case inc_amg: + case dec_amg: + SvSetSV(left,res); return res; break; + } + return ans? &sv_yes: &sv_no; + } else { + return res; + } + } +} +#endif /* OVERLOAD */ @@ -1,27 +1,10 @@ -/* $RCSfile: gv.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:42 $ +/* gv.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: gv.h,v $ - * Revision 4.1 92/08/07 18:26:42 lwall - * - * Revision 4.0.1.3 92/06/08 15:33:44 lwall - * patch20: fixed confusion between a *var's real name and its effective name - * patch20: ($<,$>) = ... didn't work on some architectures - * - * Revision 4.0.1.2 91/11/05 18:36:15 lwall - * patch11: length($x) was sometimes wrong for numeric $x - * - * Revision 4.0.1.1 91/06/07 11:56:35 lwall - * patch4: new copyright notice - * patch4: length($`), length($&), length($') now optimized to avoid string copy - * - * Revision 4.0 91/03/20 01:39:49 lwall - * 4.0 baseline. - * */ struct gp { @@ -46,13 +29,11 @@ struct gp { #define GvXPVGV(gv) ((XPVGV*)SvANY(gv)) -#define GvMAGIC(gv) (GvGP(gv)->gp_magic) #define GvSV(gv) (GvGP(gv)->gp_sv) #define GvREFCNT(gv) (GvGP(gv)->gp_refcnt) -#define GvIO(gv) (GvGP(gv)->gp_io) -#define GvIOn(gv) (GvIO(gv) ? \ - GvIO(gv) : \ - (GvIO(gv) = newIO())) +#define GvIO(gv) ((gv) && SvTYPE((SV*)gv) == SVt_PVGV ? GvIOp(gv) : 0) +#define GvIOp(gv) (GvGP(gv)->gp_io) +#define GvIOn(gv) (GvIO(gv) ? GvIOp(gv) : GvIOp(gv_IOadd(gv))) #define GvFORM(gv) (GvGP(gv)->gp_form) #define GvAV(gv) (GvGP(gv)->gp_av) @@ -104,3 +85,9 @@ HV *GvHVn(); #define DM_EGID 0x020 #define DM_DELAY 0x100 +#define GVf_INTRO 0x01 +#define GVf_IMPORTED 0x02 + +#define GV_ADD 0x01 +#define GV_ADDMULTI 0x02 +#define GV_ADDWARN 0x04 @@ -1,253 +0,0 @@ -#!/usr/local/bin/perl -'di'; -'ig00'; - -$perlincl = '/usr/local/lib/perl'; - -chdir '/usr/include' || die "Can't cd /usr/include"; - -@isatype = split(' ',<<END); - char uchar u_char - short ushort u_short - int uint u_int - long ulong u_long - FILE -END - -@isatype{@isatype} = (1) x @isatype; - -@ARGV = ('-') unless @ARGV; - -foreach $file (@ARGV) { - if ($file eq '-') { - open(IN, "-"); - open(OUT, ">-"); - } - else { - ($outfile = $file) =~ s/\.h$/.ph/ || next; - print "$file -> $outfile\n"; - if ($file =~ m|^(.*)/|) { - $dir = $1; - if (!-d "$perlincl/$dir") { - mkdir("$perlincl/$dir",0777); - } - } - open(IN,"$file") || ((warn "Can't open $file: $!\n"),next); - open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n"; - } - while (<IN>) { - chop; - while (/\\$/) { - chop; - $_ .= <IN>; - chop; - } - if (s:/\*:\200:g) { - s:\*/:\201:g; - s/\200[^\201]*\201//g; # delete single line comments - if (s/\200.*//) { # begin multi-line comment? - $_ .= '/*'; - $_ .= <IN>; - redo; - } - } - if (s/^#\s*//) { - if (s/^define\s+(\w+)//) { - $name = $1; - $new = ''; - s/\s+$//; - if (s/^\(([\w,\s]*)\)//) { - $args = $1; - if ($args ne '') { - foreach $arg (split(/,\s*/,$args)) { - $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; - $curargs{$arg} = 1; - } - $args =~ s/\b(\w)/\$$1/g; - $args = "local($args) = \@_;\n$t "; - } - s/^\s+//; - do expr(); - $new =~ s/(["\\])/\\$1/g; - if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; - print OUT $t, - "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n"; - } - else { - print OUT "sub $name {\n ${args}eval \"$new\";\n}\n"; - } - %curargs = (); - } - else { - s/^\s+//; - do expr(); - $new = 1 if $new eq ''; - if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; - print OUT $t,"eval 'sub $name {",$new,";}';\n"; - } - else { - print OUT $t,"sub $name {",$new,";}\n"; - } - } - } - elsif (/^include\s+<(.*)>/) { - ($incl = $1) =~ s/\.h$/.ph/; - print OUT $t,"require '$incl';\n"; - } - elsif (/^ifdef\s+(\w+)/) { - print OUT $t,"if (defined &$1) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^ifndef\s+(\w+)/) { - print OUT $t,"if (!defined &$1) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^if\s+//) { - $new = ''; - do expr(); - print OUT $t,"if ($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^elif\s+//) { - $new = ''; - do expr(); - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}elsif ($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^else/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}else {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^endif/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n"; - } - } - } - print OUT "1;\n"; -} - -sub expr { - while ($_ ne '') { - s/^(\s+)// && do {$new .= ' '; next;}; - s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; - s/^(\d+)// && do {$new .= $1; next;}; - s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; - s/^'((\\"|[^"])*)'// && do { - if ($curargs{$1}) { - $new .= "ord('\$$1')"; - } - else { - $new .= "ord('$1')"; - } - next; - }; - s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { - $new .= '$sizeof'; - next; - }; - s/^([_a-zA-Z]\w*)// && do { - $id = $1; - if ($id eq 'struct') { - s/^\s+(\w+)//; - $id .= ' ' . $1; - $isatype{$id} = 1; - } - elsif ($id eq 'unsigned') { - s/^\s+(\w+)//; - $id .= ' ' . $1; - $isatype{$id} = 1; - } - if ($curargs{$id}) { - $new .= '$' . $id; - } - elsif ($id eq 'defined') { - $new .= 'defined'; - } - elsif (/^\(/) { - s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat - $new .= " &$id"; - } - elsif ($isatype{$id}) { - if ($new =~ /{\s*$/) { - $new .= "'$id'"; - } - elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { - $new =~ s/\(\s*$//; - s/^[\s*]*\)//; - } - else { - $new .= $id; - } - } - else { - $new .= ' &' . $id; - } - next; - }; - s/^(.)// && do {$new .= $1; next;}; - } -} -############################################################################## - - # These next few lines are legal in both Perl and nroff. - -.00; # finish .ig - -'di \" finish diversion--previous line must be blank -.nr nl 0-1 \" fake up transition to first page again -.nr % 0 \" start at page 1 -'; __END__ ############# From here on it's a standard manual page ############ -.TH H2PH 1 "August 8, 1990" -.AT 3 -.SH NAME -h2ph \- convert .h C header files to .ph Perl header files -.SH SYNOPSIS -.B h2ph [headerfiles] -.SH DESCRIPTION -.I h2ph -converts any C header files specified to the corresponding Perl header file -format. -It is most easily run while in /usr/include: -.nf - - cd /usr/include; h2ph * sys/* - -.fi -If run with no arguments, filters standard input to standard output. -.SH ENVIRONMENT -No environment variables are used. -.SH FILES -/usr/include/*.h -.br -/usr/include/sys/*.h -.br -etc. -.SH AUTHOR -Larry Wall -.SH "SEE ALSO" -perl(1) -.SH DIAGNOSTICS -The usual warnings if it can't read or write the files involved. -.SH BUGS -Doesn't construct the %sizeof array for you. -.PP -It doesn't handle all C constructs, but it does attempt to isolate -definitions inside evals so that you can get at the definitions -that it can translate. -.PP -It's only intended as a rough tool. -You may need to dicker with the files produced. -.ex @@ -22,10 +22,11 @@ echo "Extracting h2ph (with variable substitutions)" rm -f h2ph $spitshell >h2ph <<!GROK!THIS! #!$bin/perl -'di'; -'ig00'; +'di '; +'ds 00 \"'; +'ig 00 '; -\$perlincl = '$installprivlib'; +\$perlincl = '$archlibexp'; !GROK!THIS! : In the following dollars and backticks do not need the extra backslash. @@ -231,8 +232,8 @@ sub expr { # These next few lines are legal in both Perl and nroff. -.00; # finish .ig - +.00 ; # finish .ig + 'di \" finish diversion--previous line must be blank .nr nl 0-1 \" fake up transition to first page again .nr % 0 \" start at page 1 diff --git a/h2ph.man b/h2ph.man deleted file mode 100755 index 59caa58c92..0000000000 --- a/h2ph.man +++ /dev/null @@ -1,253 +0,0 @@ -#!/usr/local/bin/perl -'di'; -'ig00'; - -$perlincl = '/usr/local/lib/perl'; - -chdir '/usr/include' || die "Can't cd /usr/include"; - -@isatype = split(' ',<<END); - char uchar u_char - short ushort u_short - int uint u_int - long ulong u_long - FILE -END - -@isatype{@isatype} = (1) x @isatype; - -@ARGV = ('-') unless @ARGV; - -foreach $file (@ARGV) { - if ($file eq '-') { - open(IN, "-"); - open(OUT, ">-"); - } - else { - ($outfile = $file) =~ s/\.h$/.ph/ || next; - print "$file -> $outfile\n"; - if ($file =~ m|^(.*)/|) { - $dir = $1; - if (!-d "$perlincl/$dir") { - mkdir("$perlincl/$dir",0777); - } - } - open(IN,"$file") || ((warn "Can't open $file: $!\n"),next); - open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n"; - } - while (<IN>) { - chop; - while (/\\$/) { - chop; - $_ .= <IN>; - chop; - } - if (s:/\*:\200:g) { - s:\*/:\201:g; - s/\200[^\201]*\201//g; # delete single line comments - if (s/\200.*//) { # begin multi-line comment? - $_ .= '/*'; - $_ .= <IN>; - redo; - } - } - if (s/^#\s*//) { - if (s/^define\s+(\w+)//) { - $name = $1; - $new = ''; - s/\s+$//; - if (s/^\(([\w,\s]*)\)//) { - $args = $1; - if ($args ne '') { - foreach $arg (split(/,\s*/,$args)) { - $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; - $curargs{$arg} = 1; - } - $args =~ s/\b(\w)/\$$1/g; - $args = "local($args) = \@_;\n$t "; - } - s/^\s+//; - do expr(); - $new =~ s/(["\\])/\\$1/g; - if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; - print OUT $t, - "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n"; - } - else { - print OUT "sub $name {\n ${args}eval \"$new\";\n}\n"; - } - %curargs = (); - } - else { - s/^\s+//; - do expr(); - $new = 1 if $new eq ''; - if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; - print OUT $t,"eval 'sub $name {",$new,";}';\n"; - } - else { - print OUT $t,"sub $name {",$new,";}\n"; - } - } - } - elsif (/^include\s+<(.*)>/) { - ($incl = $1) =~ s/\.h$/.ph/; - print OUT $t,"require '$incl';\n"; - } - elsif (/^ifdef\s+(\w+)/) { - print OUT $t,"if (defined &$1) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^ifndef\s+(\w+)/) { - print OUT $t,"if (!defined &$1) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^if\s+//) { - $new = ''; - do expr(); - print OUT $t,"if ($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^elif\s+//) { - $new = ''; - do expr(); - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}elsif ($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^else/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}else {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^endif/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n"; - } - } - } - print OUT "1;\n"; -} - -sub expr { - while ($_ ne '') { - s/^(\s+)// && do {$new .= ' '; next;}; - s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; - s/^(\d+)// && do {$new .= $1; next;}; - s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; - s/^'((\\"|[^"])*)'// && do { - if ($curargs{$1}) { - $new .= "ord('\$$1')"; - } - else { - $new .= "ord('$1')"; - } - next; - }; - s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { - $new .= '$sizeof'; - next; - }; - s/^([_a-zA-Z]\w*)// && do { - $id = $1; - if ($id eq 'struct') { - s/^\s+(\w+)//; - $id .= ' ' . $1; - $isatype{$id} = 1; - } - elsif ($id eq 'unsigned') { - s/^\s+(\w+)//; - $id .= ' ' . $1; - $isatype{$id} = 1; - } - if ($curargs{$id}) { - $new .= '$' . $id; - } - elsif ($id eq 'defined') { - $new .= 'defined'; - } - elsif (/^\(/) { - s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat - $new .= " &$id"; - } - elsif ($isatype{$id}) { - if ($new =~ /{\s*$/) { - $new .= "'$id'"; - } - elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { - $new =~ s/\(\s*$//; - s/^[\s*]*\)//; - } - else { - $new .= $id; - } - } - else { - $new .= ' &' . $id; - } - next; - }; - s/^(.)// && do {$new .= $1; next;}; - } -} -############################################################################## - - # These next few lines are legal in both Perl and nroff. - -.00; # finish .ig - -'di \" finish diversion--previous line must be blank -.nr nl 0-1 \" fake up transition to first page again -.nr % 0 \" start at page 1 -'; __END__ ############# From here on it's a standard manual page ############ -.TH H2PH 1 "August 8, 1990" -.AT 3 -.SH NAME -h2ph \- convert .h C header files to .ph Perl header files -.SH SYNOPSIS -.B h2ph [headerfiles] -.SH DESCRIPTION -.I h2ph -converts any C header files specified to the corresponding Perl header file -format. -It is most easily run while in /usr/include: -.nf - - cd /usr/include; h2ph * sys/* - -.fi -If run with no arguments, filters standard input to standard output. -.SH ENVIRONMENT -No environment variables are used. -.SH FILES -/usr/include/*.h -.br -/usr/include/sys/*.h -.br -etc. -.SH AUTHOR -Larry Wall -.SH "SEE ALSO" -perl(1) -.SH DIAGNOSTICS -The usual warnings if it can't read or write the files involved. -.SH BUGS -Doesn't construct the %sizeof array for you. -.PP -It doesn't handle all C constructs, but it does attempt to isolate -definitions inside evals so that you can get at the definitions -that it can translate. -.PP -It's only intended as a rough tool. -You may need to dicker with the files produced. -.ex @@ -0,0 +1,601 @@ +#!/usr/bin/perl +'di '; +'ds 00 \"'; +'ig 00 '; + +use Getopt::Std; + +$usage='h2xs [-Aachfm] [-n module_name] [headerfile [extra_libraries]] + -a Omit AutoLoad facilities from .pm file. + -c Omit the constant() function from the XS file. + -A Equivalent to -a -c + -f Force creation of the extension even if the C header does not exist. + -m Also create an old-style Makefile.SH + -h help + -n Specify a name to use for the extension. +extra_libraries are any libraries that might be needed for loading + the extension, e.g. -lm would try to link in the math library. +'; + +sub usage{ die "Usage: $usage\n" } + +getopts("fhcaAmn:") || &usage; + +&usage if $opt_h; + +if( @ARGV ){ + $path_h = shift; +} +elsif( ! @ARGV && ! $opt_n ){ + die "Must supply header file or module name\n"; +} + +$extralibs = "@ARGV"; +if( $opt_A ){ + $opt_a = $opt_c = 1; +} +$write_makefile_sh = ($opt_m) ? 1 : 0; + +if( $path_h ){ + $name = $path_h; + if( $path_h =~ s#::#/#g && $opt_n ){ + warn "Nesting of headerfile ignored with -n\n"; + } + $path_h .= ".h" unless $path_h =~ /\.h$/; + $path_h = "/usr/include/$path_h" unless $path_h =~ m#^[./]#; + die "Can't find $path_h\n" if( ! $opt_f && ! -f $path_h ); +} + +$module = $opt_n || do { + $name =~ s/\.h$//; + if( $name !~ /::/ ){ + $name =~ s#^.*/##; + $name = "\u$name"; + } + $name; +}; + +chdir 'ext' if -d 'ext'; + +if( $module =~ /::/ ){ + $nested = 1; + @modparts = split(/::/,$module); + $modfname = $modparts[-1]; + $modpname = join('/',@modparts); +} +else { + $nested = 0; + @modparts = (); + $modfname = $modpname = $module; +} + + +die "Won't overwrite existing ext/$modpname\n" if -e $modpname; +# quick hack, should really loop over @modparts +mkdir($modparts[0], 0777) if $nested; +mkdir($modpname, 0777); +chdir($modpname) || die "Can't chdir ext/$modpname: $!\n"; + +open(XS, ">$modfname.xs") || die "Can't create ext/$modpname/$modfname.xs: $!\n"; +open(PM, ">$modfname.pm") || die "Can't create ext/$modpname/$modfname.pm: $!\n"; + + +if( -r $path_h ){ + 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; + $names{$_}++; + @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/; + @az = 'a' .. 'z' if !@az && /^[a-z]/; + @under = '_' if !@under && /^_/; + } + } + close(CH); + @names = sort keys %names; +} + +$" = "\n\t"; +warn "Writing ext/$modpname/$modfname.pm\n"; + +if( ! $opt_a ){ +print PM <<"END"; +package $module; + +require Exporter; +require AutoLoader; +require DynaLoader; +\@ISA = qw(Exporter AutoLoader DynaLoader); +# Items to export into callers namespace by default +# (move infrequently used names to \@EXPORT_OK below) +\@EXPORT = qw( + @names +); +# Other items we are prepared to export if requested +\@EXPORT_OK = qw( +); + +sub AUTOLOAD { + if (\@_ > 1) { + \$AutoLoader::AUTOLOAD = \$AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + local(\$constname); + (\$constname = \$AUTOLOAD) =~ s/.*:://; + \$val = constant(\$constname, \@_ ? \$_[0] : 0); + if (\$! != 0) { + if (\$! =~ /Invalid/) { + \$AutoLoader::AUTOLOAD = \$AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + (\$pack,\$file,\$line) = caller; + die "Your vendor has not defined $module macro \$constname, used at \$file line \$line.\n"; + } + } + eval "sub \$AUTOLOAD { \$val }"; + goto &\$AUTOLOAD; +} + +bootstrap $module; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +1; +__END__ +END +} +else{ +print PM <<"END"; +package $module; + +require Exporter; +require DynaLoader; +\@ISA = qw(Exporter DynaLoader); +# Items to export into callers namespace by default +\@EXPORT = qw(); +# Other items we are prepared to export if requested +\@EXPORT_OK = qw(); + + +bootstrap $module; + +1; +END +} + +close PM; + +warn "Writing ext/$modpname/$modfname.xs\n"; +print XS <<"END"; +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +END +if( $path_h ){ + my($h) = $path_h; + $h =~ s#^/usr/include/##; +print XS <<"END"; +#include <$h> + +END +} + +if( ! $opt_c ){ +print XS <<"END"; +static int +not_here(s) +char *s; +{ + croak("$module::%s not implemented on this architecture", s); + return -1; +} + +static double +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + switch (*name) { +END + +foreach $letter (@AZ, @az, @under) { + + last if $letter eq 'a' && !@names; + + print XS " case '$letter':\n"; + my($name); + while (substr($names[0],0,1) eq $letter) { + $name = shift(@names); + print XS <<"END"; + if (strEQ(name, "$name")) +#ifdef $name + return $name; +#else + goto not_there; +#endif +END + } + print XS <<"END"; + break; +END +} +print XS <<"END"; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + + +MODULE = $module PACKAGE = $module + +double +constant(name,arg) + char * name + int arg + +END +} +else{ +print XS <<"END"; + +MODULE = $module PACKAGE = $module + +END +} + +close XS; + +{ +warn "Writing ext/$modpname/Makefile.PL\n"; +open(PL, ">Makefile.PL") || die "Can't create ext/$modpname/Makefile.PL: $!\n"; + +# Ideally this should have a #!../.. ... miniperl etc header +print PL <<'END'; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile being created. +END +print PL "&writeMakefile(\n"; +print PL " 'potential_libs' => '$extralibs', # e.g., '-lm' \n"; +print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n"; +print PL " 'DISTNAME' => 'myname',\n"; +print PL " 'VERSION' => '0.1',\n"; +print PL ");\n"; +} + +if ($write_makefile_sh){ +warn "Writing ext/$modpname/Makefile.SH\n"; +open(MF, ">Makefile.SH") || die "Can't create ext/$modpname/Makefile.SH: $!\n"; +print MF <<'END'; +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. + +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find config.sh."; exit 1 +fi + +: Find absolute path name for TOP. This is needed when we cd to TOP +: to run perl on autosplit. +oldpwd=`pwd`; cd $TOP; ABSTOP=`pwd`; cd $oldpwd + +case $CONFIG in +'') + . $TOP/config.sh + ;; +esac + +: Find out directory name. This is also the extension name. +ext=`pwd | $sed -e 's@.*/@@'` + +: This extension might have its own typemap +if test -f typemap; then + exttypemap='typemap' +else + exttypemap='' +fi + +: This extension might need additional libraries. +END +print MF "potential_libs=\"$extralibs\"\n"; +print MF <<'END'; +. $TOP/ext/util/extliblist + +: This extension might need bootstrap support +if test -f ${ext}_BS; then + bootdep=${ext}_BS +else + bootdep='' +fi + +case "$dlsrc" in +dl_aix*) + echo "#!" > $ext.exp + echo "boot_$ext" >> $ext.exp + ;; +esac + +echo "Extracting ext/$ext/Makefile (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >Makefile << !GROK!THIS! +# +# This Makefile is for the $ext extension to perl. +# +CC = $cc +RANLIB = $ranlib +TOP = $TOP +ABSTOP = $ABSTOP +LDFLAGS = $ldflags +CLDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +# To use an alternate make, set \\$altmake in config.sh. +MAKE = ${altmake-make} + +EXT = $ext + +# $ext might have its own typemap +EXTTYPEMAP = $exttypemap + +# $ext might have its own bootstrap support +BOOTDEP = $bootdep +BOOTSTRAP = $ext.bs + +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $lddlflags +CCDLFLAGS = $ccdlflags +CCCDLFLAGS = $cccdlflags +SO = $so + +# $ext might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNLOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $extralibs +DYNALOADLIBS = $dynaloadlibs +STATLOADLIBS = $statloadlibs + +!GROK!THIS! + +$spitshell >>Makefile <<'!NO!SUBS!' + +# Where to put things: +AUTO = $(TOP)/lib/auto +INSTALLBOOT = $(AUTO)/$(EXT)/$(EXT).bs +INSTALLDYNAMIC = $(AUTO)/$(EXT)/$(EXT).$(SO) +INSTALLSTATIC = $(EXT).a +INSTALLPM = $(TOP)/lib/$(EXT).pm + +PERL = $(ABSTOP)/miniperl +XSUBPP = $(TOP)/ext/xsubpp +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(TOP)/cflags $@` + +.c.o: + $(CCCMD) $(CCCDLFLAGS) -I$(TOP) $*.c + +all: dynamic +# Phony target to force checking subdirectories. +FORCE: + +# Target for Dynamic Loading: +dynamic: $(INSTALLDYNAMIC) $(INSTALLPM) $(INSTALLBOOT) + +$(INSTALLDYNAMIC): $(EXT).o + @test -d $(AUTO) || mkdir $(AUTO) + @test -d $(AUTO)/$(EXT) || mkdir $(AUTO)/$(EXT) + ld $(LDDLFLAGS) -o $@ $(EXT).o $(STATLOADLIBS) + +$(BOOTSTRAP): Makefile $(BOOTDEP) + $(PERL) -I$(TOP)/lib $(TOP)/ext/util/mkbootstrap $(DYNALOADLIBS) + touch $(BOOTSTRAP) + +$(INSTALLBOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ + +# Target for Static Loading: +static: $(INSTALLSTATIC) $(INSTALLPM) + +$(INSTALLSTATIC): $(EXT).o + ar cr $@ $(EXT).o + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs + +$(EXT).c: $(EXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags Makefile + $(PERL) $(XSUBPP) $(EXT).xs >tmp + mv tmp $@ + +END +if( ! $opt_a ){ +print MF <<'END'; +$(INSTALLPM): $(EXT).pm + rm -f $@ + cp $(EXT).pm $@ + cd $(TOP); $(PERL) autosplit $(EXT) +END +} +else { +print MF <<'END'; +$(INSTALLPM): $(EXT).pm + cp $(EXT).pm $@ +END +} +print MF <<'END'; + +clean: + rm -f *.o *.a mon.out core $(EXT).c so_locations $(BOOTSTRAP) $(EXT).exp + +realclean: clean + rm -f makefile Makefile + rm -f $(INSTALLPM) $(INSTALLDYNAMIC) $(INSTALLSTATIC) $(INSTALLBOOT) + rm -rf $(AUTO)/$(EXT) + +purge: realclean + +$(EXT).o : $(TOP)/EXTERN.h +$(EXT).o : $(TOP)/perl.h +$(EXT).o : $(TOP)/embed.h +$(EXT).o : $(TOP)/config.h +$(EXT).o : $(TOP)/unixish.h +$(EXT).o : $(TOP)/handy.h +$(EXT).o : $(TOP)/regexp.h +$(EXT).o : $(TOP)/sv.h +$(EXT).o : $(TOP)/util.h +$(EXT).o : $(TOP)/form.h +$(EXT).o : $(TOP)/gv.h +$(EXT).o : $(TOP)/cv.h +$(EXT).o : $(TOP)/opcode.h +$(EXT).o : $(TOP)/op.h +$(EXT).o : $(TOP)/cop.h +$(EXT).o : $(TOP)/av.h +$(EXT).o : $(TOP)/hv.h +$(EXT).o : $(TOP)/mg.h +$(EXT).o : $(TOP)/scope.h +$(EXT).o : $(TOP)/pp.h +$(EXT).o : $(TOP)/proto.h +$(EXT).o : $(TOP)/XSUB.h + +Makefile: Makefile.SH $(TOP)/config.sh ; /bin/sh Makefile.SH +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +!NO!SUBS! +chmod 755 Makefile +$eunicefix Makefile + +END +close MF; +} + +system '/bin/ls > MANIFEST'; + +# this needs fixing +# system '[ -f Makefile.SH ] && sh Makefile.SH'; +# system '[ -f Makefile.PL ] && perl Makefile.PL'; + + +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00 ; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +'; __END__ ############# From here on it's a standard manual page ############ +.TH H2XS 1 "August 9, 1994" +.AT 3 +.SH NAME +h2xs \- convert .h C header files to Perl extensions +.SH SYNOPSIS +.B h2xs [-Aachfm] [-n module_name] [headerfile [extra_libraries]] +.SH DESCRIPTION +.I h2xs +builds a Perl extension from any C header file. The extension will include +functions which can be used to retrieve the value of any #define statement +which was in the C header. +.PP +The +.I module_name +will be used for the name of the extension. If module_name is not supplied +then the name of the header file will be used, with the first character +capitalized. +.PP +If the extension might need extra libraries, they should be included +here. The extension Makefile.SH will take care of checking whether +the libraries actually exist and how they should be loaded. +The extra libraries should be specified in the form -lm -lposix, etc, +just as on the cc command line. By default, the Makefile.SH will +search through the library path determined by Configure. That path +can be augmented by including arguments of the form -L/another/library/path +in the extra-libraries argument. +.SH OPTIONS +.TP +.B \-f +Allows an extension to be created for a header even if that +header is not found in /usr/include. +.TP +.B \-a +Omit AutoLoad(), AUTOLOAD, and autosplit from the .pm and Makefile files. +.TP +.B \-c +Omit constant() from the .xs file. +.TP +.B \-n module_name +Specifies a name to be used for the extension. +.TP +.B \-A +Turns on both -a and -c. +.TP +.B \-m +Causes an old-style Makefile.SH to be created. +.SH EXAMPLES +.nf + + # Default behavior, extension is Rusers + h2xs rpcsvc/rusers + + # Same, but extension is RUSERS + h2xs -n RUSERS rpcsvc/rusers + + # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h> + h2xs rpcsvc::rusers + + # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h> + h2xs -n ONC::RPC rpcsvc/rusers + + # Without AUTOLOAD, AutoLoad, autosplit + h2xs -a rpcsvc/rusers + + # Creates templates for an extension named RPC + h2xs -Afn RPC + + # Extension is ONC::RPC. + h2xs -An ONC::RPC + + # Makefile.SH will look for library -lrpc in + # additional directory /opt/net/lib + h2xs rpcsvc/rusers -L/opt/net/lib -lrpc + +.fi +.SH ENVIRONMENT +No environment variables are used. +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +perl(1) +.SH DIAGNOSTICS +The usual warnings if it can't read or write the files involved. +.ex @@ -1,29 +1,10 @@ -/* $RCSfile: handy.h,v $$Revision: 4.1 $$Date: 92/08/07 18:21:46 $ +/* handy.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: handy.h,v $ - * Revision 4.1 92/08/07 18:21:46 lwall - * - * Revision 4.0.1.4 92/06/08 13:23:17 lwall - * patch20: isascii() may now be supplied by a library routine - * patch20: Perl now distinguishes overlapped copies from non-overlapped - * - * Revision 4.0.1.3 91/11/05 22:54:26 lwall - * patch11: erratum - * - * Revision 4.0.1.2 91/11/05 17:23:38 lwall - * patch11: prepared for ctype implementations that don't define isascii() - * - * Revision 4.0.1.1 91/06/07 11:09:56 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:22:15 lwall - * 4.0 baseline. - * */ #if !defined(__STDC__) @@ -57,23 +38,13 @@ #define TRUE (1) #define FALSE (0) -#ifdef UNICOS -#define I8 char -#define U8 unsigned char -#define I16 short -#define U16 unsigned short -#define I32 int -#define U32 unsigned int - -#else - typedef char I8; typedef unsigned char U8; typedef short I16; typedef unsigned short U16; -#if INTSIZE == 4 +#if BYTEORDER > 0x4321 typedef int I32; typedef unsigned int U32; #else @@ -81,8 +52,6 @@ typedef unsigned short U16; typedef unsigned long U32; #endif -#endif /* UNICOS */ - #define Ctl(ch) (ch & 037) #define strNE(s1,s2) (strcmp(s1,s2)) @@ -100,6 +69,17 @@ typedef unsigned short U16; # endif #endif +#ifdef USE_NEXT_CTYPE +#define isALNUM(c) (NXIsAlpha((unsigned int)c) || NXIsDigit((unsigned int)c) || c == '_') +#define isIDFIRST(c) (NXIsAlpha((unsigned int)c) || c == '_') +#define isALPHA(c) NXIsAlpha((unsigned int)c) +#define isSPACE(c) NXIsSpace((unsigned int)c) +#define isDIGIT(c) NXIsDigit((unsigned int)c) +#define isUPPER(c) NXIsUpper((unsigned int)c) +#define isLOWER(c) NXIsLower((unsigned int)c) +#define toUPPER(c) NXToUpper((unsigned int)c) +#define toLOWER(c) NXToLower((unsigned int)c) +#else /* USE_NEXT_CTYPE */ #if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII)) #define isALNUM(c) (isalpha((unsigned char)(c)) || isdigit((unsigned char)(c)) || c == '_') #define isIDFIRST(c) (isalpha((unsigned char)(c)) || (c) == '_') @@ -108,6 +88,8 @@ typedef unsigned short U16; #define isDIGIT(c) isdigit((unsigned char)(c)) #define isUPPER(c) isupper((unsigned char)(c)) #define isLOWER(c) islower((unsigned char)(c)) +#define toUPPER(c) toupper((unsigned char)(c)) +#define toLOWER(c) tolower((unsigned char)(c)) #else #define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_')) #define isIDFIRST(c) (isascii(c) && (isalpha(c) || (c) == '_')) @@ -116,7 +98,10 @@ typedef unsigned short U16; #define isDIGIT(c) (isascii(c) && isdigit(c)) #define isUPPER(c) (isascii(c) && isupper(c)) #define isLOWER(c) (isascii(c) && islower(c)) +#define toUPPER(c) toupper(c) +#define toLOWER(c) tolower(c) #endif +#endif /* USE_NEXT_CTYPE */ /* Line numbers are unsigned, 16 bits. */ typedef U16 line_t; @@ -129,9 +114,9 @@ typedef U16 line_t; #ifndef lint #ifndef LEAKTEST #ifndef safemalloc -char *safemalloc(); -char *saferealloc(); -void safefree(); +char *safemalloc _((MEM_SIZE)); +char *saferealloc _((char *, MEM_SIZE)); +void safefree _((char *)); #endif #ifndef MSDOS #define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) diff --git a/hints/3b2.sh b/hints/3b2.sh deleted file mode 100644 index 5b67dab8f2..0000000000 --- a/hints/3b2.sh +++ /dev/null @@ -1 +0,0 @@ -optimize='-g' diff --git a/hints/README.hints b/hints/README.hints new file mode 100644 index 0000000000..84503ce8ff --- /dev/null +++ b/hints/README.hints @@ -0,0 +1,57 @@ +These files are used by Configure to set things which Configure either +can't or doesn't guess properly. Most of these hints files are from +perl4. They may or may not work with perl5, but they are probably a +good starting point. + +The following hints files have been tested with at least some version +of perl5 and are probably reasonably close to being correct: + +aix.sh +bsd386.sh +dec_osf.sh +dgux.sh +esix4.sh +freebsd.sh +hpux_9.sh +irix_4.sh +irix_5.sh +isc.sh +linux.sh +netbsd.sh +next_3_2.sh +sco_3.sh +solaris_2.sh +sunos_4_1.sh +svr4.sh +titanos.sh +ultrix_4.sh +unicos.sh +utekv.sh + +The following hints files have not been tested with perl5: + +3b1.sh +altos486.sh +apollo.sh +aux.sh +dnix.sh +dynix.sh +fps.sh +genix.sh +greenhills.sh +i386.sh +isc_2.sh +mips.sh +mpc.sh +ncr_tower.sh +opus.sh +sco_2_3_0.sh +sco_2_3_1.sh +sco_2_3_2.sh +sco_2_3_3.sh +sco_2_3_4.sh +stellar.sh +sunos_4_0.sh +ti1500.sh +unisysdynix.sh +uts.sh diff --git a/hints/aix.sh b/hints/aix.sh new file mode 100644 index 0000000000..81d2a0c91f --- /dev/null +++ b/hints/aix.sh @@ -0,0 +1,20 @@ +d_fchmod=undef +d_setrgid='undef' +d_setruid='undef' +alignbytes=8 + +# Changes for dynamic linking by Wayne Scott (wscott@ichips.intel.com) +# +# Tell perl which symbols to export for dynamic linking. +ccdlflags='-bE:perl.exp' + +# The first 3 options would not be needed if dynamic libs. could be linked +# with the compiler instead of ld. +# -bI:$(TOP)/perl.exp Read the exported symbols from the perl binary +# -bE:$(EXT).exp Export these symbols. This file contains only one +# symbol: boot_$(EXP) can it be auto-generated? +lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(TOP)/perl.exp -bE:$(EXT).exp -e _nostart -lc' + +ccflags='-D_ALL_SOURCE' +# Make setsockopt work correctly. See man page. +# ccflags='-D_BSD=44' diff --git a/hints/aix_rs.sh b/hints/aix_rs.sh deleted file mode 100644 index b2bbb9be7e..0000000000 --- a/hints/aix_rs.sh +++ /dev/null @@ -1,10 +0,0 @@ -d_setregid='undef' -d_setreuid='undef' -d_setrgid='undef' -d_setruid='undef' -d_setegid='undef' -d_seteuid='undef' -memalignbytes=8 -ccflags="$ccflags -D_NO_PROTO" -cppstdin='/lib/cpp -D_AIX -D_IBMR2 -U__STR__' -cppminus='' diff --git a/hints/aix_rt.sh b/hints/aix_rt.sh deleted file mode 100644 index 83bb7a13c7..0000000000 --- a/hints/aix_rt.sh +++ /dev/null @@ -1 +0,0 @@ -ccflags="$ccflags -a -DCRIPPLED_CC" diff --git a/hints/apollo_C6_8.sh b/hints/apollo.sh index 06fe7d73eb..dd06084c3f 100644 --- a/hints/apollo_C6_8.sh +++ b/hints/apollo.sh @@ -1,5 +1,5 @@ optimize='' -ccflags='-DDEBUGGING -A cpu,mathchip -W0,-opt,2' +ccflags='-A cpu,mathchip -W0,-opt,2' cat <<'EOF' Some tests may fail unless you use 'chacl -B'. Also, op/stat diff --git a/hints/apollo_C6_7.sh b/hints/apollo_C6_7.sh deleted file mode 100644 index fd9f44e382..0000000000 --- a/hints/apollo_C6_7.sh +++ /dev/null @@ -1,4 +0,0 @@ -optimize='-opt 2' -cflags='-A nansi cpu,mathchip -O -U__STDC__' -echo "Some tests may fail unless you use 'chacl -B'. Also, op/stat" -echo "test 2 may fail because Apollo doesn't support mtime or ctime." diff --git a/hints/aux.sh b/hints/aux.sh index 0f46f3eb36..b64f3fdf28 100644 --- a/hints/aux.sh +++ b/hints/aux.sh @@ -1,2 +1,3 @@ optimize='-O' ccflags="$ccflags -B/usr/lib/big/ -DPARAM_NEEDS_TYPES" +POSIX_cflags='ccflags="$ccflags -ZP -Du_long=U32"' diff --git a/hints/bsd386.sh b/hints/bsd386.sh new file mode 100644 index 0000000000..8303a18990 --- /dev/null +++ b/hints/bsd386.sh @@ -0,0 +1,34 @@ +# hints file for BSD/386 1.x +# Original by Neil Bowers <neilb@khoros.unm.edu> +# Tue Oct 4 12:01:34 EDT 1994 +# +# filename extension for shared libraries +so='o' + +d_voidsig='define' +sig_name='ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CHLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2 ' +signal_t='void' + +# we don't want to use -lnm, since exp() is busted in there (in 1.1 anyway) +set `echo X "$libswanted "| sed -e 's/ nm / /'` +shift +libswanted="$*" + +# Avoid telldir prototype conflict in pp_sys.c (BSD/386 uses const DIR *) +pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' + +# Avoid problems with HUGE_VAL in POSIX in 1.0's cc. +# Use gcc2 (2.5.8) if available in 1.1. +case "$osvers" in +1.0*) + POSIX_cflags='ccflags="$ccflags -UHUGE_VAL"' + ;; +1.1*) + case "$cc" in + '') cc=gcc2 ;; + esac + ;; +esac + +# BSD/386 has an older <db.h> header file. +DB_File_cflags='ccflags="$ccflags -DDBXS_HASH_TYPE=int -DDBXS_PREFIX_TYPE=int"' diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh new file mode 100644 index 0000000000..1f9d71f5c9 --- /dev/null +++ b/hints/dec_osf.sh @@ -0,0 +1,9 @@ +# hints/dec_osf.sh +optimize="-g" +ccflags="$ccflags -DSTANDARD_C -DDEBUGGING" +# Version 1 has problems with -no_archive if only an archive +# lib is available. +case "$osvers" in +1*) lddlflags='-shared -expect_unresolved "*" -s' ;; +*) lddlflags='-shared -no_archive -expect_unresolved "*" -s' ;; +esac diff --git a/hints/dec_osf1.sh b/hints/dec_osf1.sh deleted file mode 100644 index 07f594e3cf..0000000000 --- a/hints/dec_osf1.sh +++ /dev/null @@ -1,11 +0,0 @@ -d_crypt='undef' # The function is there, but it is empty -d_odbm='undef' # We don't need both odbm and ndbm -gidtype='gid_t' -groupstype='int' -libpth="$libpth /usr/shlib" # Use the shared libraries if possible -libc='/usr/shlib/libc.so' # The archive version is /lib/libc.a -case `uname -m` in - mips|alpha) optimize="$optimize -O2 -Olimit 2900" - ccflags="$ccflags -std1 -D_BSD" ;; - *) ccflags="$ccflags -D_BSD" ;; -esac diff --git a/hints/dec_osf_2_0.sh b/hints/dec_osf_2_0.sh deleted file mode 100644 index 207e56540a..0000000000 --- a/hints/dec_osf_2_0.sh +++ /dev/null @@ -1,13 +0,0 @@ -# hints/dec_osf_2_0.sh -d_odbm='undef' # We don't need both odbm and ndbm -gidtype='gid_t' -groupstype='gid_t' -d_voidshmat='define' -clocktype='time_t' -libpth="$libpth /usr/shlib" # Use the shared libraries if possible -libc='/usr/shlib/libc.so' # The archive version is /lib/libc.a -case `uname -m` in - mips|alpha) optimize="$optimize -g" - ccflags="$ccflags -D_BSD -DSTANDARD_C -DDEBUGGING" ;; - *) ccflags="$ccflags -D_BSD -DSTANDARD_C -DDEBUGGING" ;; -esac diff --git a/hints/dgux.sh b/hints/dgux.sh index d0d115417a..733570b02b 100644 --- a/hints/dgux.sh +++ b/hints/dgux.sh @@ -1,7 +1,26 @@ -cppstdin='/lib/cpp' +# +# hints file for Data General DG/UX +# these hints tweaked for perl5 on an AViiON mc88100, running DG/UX 5.4R2.01 +# + gidtype='gid_t' groupstype='gid_t' -libs='-ldgc' +libswanted="dgc $libswanted" uidtype='uid_t' d_index='define' +ccflags='-D_POSIX_SOURCE -D_DGUX_SOURCE' + +# this hasn't been tried with dynamic loading at all +usedl='false' + +# +# an ugly hack, since the Configure test for "gcc -P -" hangs. +# can't just use 'cppstdin', since our DG has a broken cppstdin :-( +# +cppstdin=`cd ..; pwd`/cppstdin +cpprun=`cd ..; pwd`/cppstdin + +# +# you don't want to use /usr/ucb/cc +# cc='gcc' diff --git a/hints/dynix.sh b/hints/dynix.sh index dca74b4381..51eae905a6 100644 --- a/hints/dynix.sh +++ b/hints/dynix.sh @@ -1,2 +1,2 @@ d_castneg=undef -libswanted=`echo $libswanted | sed -e 's/socket /socket seq inet /'` +libswanted=`echo $libswanted | sed -e 's/socket /socket seq /'` diff --git a/hints/esix4.sh b/hints/esix4.sh new file mode 100644 index 0000000000..6d8f266fd7 --- /dev/null +++ b/hints/esix4.sh @@ -0,0 +1,39 @@ +# hints/esix4.sh +# Original esix4 hint file courtesy of +# Kevin O'Gorman ( kevin@kosman.UUCP, kevin%kosman.uucp@nrc.com ) +# +# Use Configure -Dcc=gcc to use gcc. +case "$cc" in +'') cc='/bin/cc' + test -f $cc || cc='/usr/ccs/bin/cc' + cccdlflags='-Kpic' + ;; +esac +ldflags='-L/usr/ccs/lib -L/usr/ucblib' +test -d /usr/local/man || mansrc='none' +ccflags='-I/usr/include -I/usr/ucbinclude' +libswanted=`echo " $libswanted " | sed -e 's/ malloc / /' ` +d_index='undef' +d_suidsafe=define +lddlflags="-G $ldflags" +usevfork='false' +if test "$osvers" = "3.0"; then + d_gconvert='undef' + grep 'define[ ]*AF_OSI[ ]' /usr/include/sys/socket.h | grep '/\*[^*]*$' >/tmp/esix$$ + if test -s /tmp/esix$$; then + cat <<EOM + +WARNING: You are likely to have problems compiling the Socket extension +unless you fix the unterminated comment for AF_OSI in the file +/usr/include/sys/socket.h. + +EOM + fi + rm -f /tmp/esix$$ +fi +# dlopen routines exist but they don't work with perl. +# The case statement allows experimenters to override hint with +# Configure -D usedl +case "$usedl" in +'') usedl="$undef" ;; +esac diff --git a/hints/fps.sh b/hints/fps.sh index 1132e74b9d..7726790ac0 100644 --- a/hints/fps.sh +++ b/hints/fps.sh @@ -1 +1 @@ -ccflags="$ccflags -J -DBADSWITCH" +ccflags="$ccflags -J" diff --git a/hints/freebsd.sh b/hints/freebsd.sh new file mode 100644 index 0000000000..8a46326c6d --- /dev/null +++ b/hints/freebsd.sh @@ -0,0 +1,28 @@ +# Oringal based on info from +# Carl M. Fongheiser <cmf@ins.infonet.net> +# Date: Thu, 28 Jul 1994 19:17:05 -0500 (CDT) +# +# Additional 1.1.5 defines from +# Ollivier Robert <Ollivier.Robert@keltia.frmug.fr.net> +# Date: Wed, 28 Sep 1994 00:37:46 +0100 (MET) +# +case "$osvers" in +0.*|1.0*) + usedl="$undef" + ;; +*) d_dlopen="$define" + cccdlflags='-DPIC -fpic' + lddlflags='-Bshareable' + malloctype='void *' + groupstype='int' + d_setregid='undef' + d_setreuid='undef' + d_setrgid='undef' + d_setruid='undef' + i_unistd='undef' + ;; +esac +# Avoid telldir prototype conflict in pp_sys.c (FreeBSD uses const DIR *) +pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' +# FreeBSD has an older <db.h> header file. +DB_File_cflags='ccflags="$ccflags -DDBXS_HASH_TYPE=int -DDBXS_PREFIX_TYPE=int"' diff --git a/hints/hp9000_300.sh b/hints/hp9000_300.sh deleted file mode 100644 index 956bf08d07..0000000000 --- a/hints/hp9000_300.sh +++ /dev/null @@ -1,2 +0,0 @@ -optimize='+O1' -ccflags="$ccflags -Wc,-Nw500" diff --git a/hints/hp9000_400.sh b/hints/hp9000_400.sh deleted file mode 100644 index 956bf08d07..0000000000 --- a/hints/hp9000_400.sh +++ /dev/null @@ -1,2 +0,0 @@ -optimize='+O1' -ccflags="$ccflags -Wc,-Nw500" diff --git a/hints/hp9000_700.sh b/hints/hp9000_700.sh deleted file mode 100644 index eee8a4e1a6..0000000000 --- a/hints/hp9000_700.sh +++ /dev/null @@ -1,5 +0,0 @@ -libswanted='ndbm m' -ccflags="$ccflags -Aa -D_POSIX_SOURCE -D_HPUX_SOURCE -DJMPCLOBBER" -optimize='+O1' -d_mymalloc=define -memalignbytes=8 diff --git a/hints/hp9000_800.sh b/hints/hp9000_800.sh deleted file mode 100644 index e1ab9d77f8..0000000000 --- a/hints/hp9000_800.sh +++ /dev/null @@ -1,3 +0,0 @@ -libswanted=`echo $libswanted | sed -e 's/malloc //' -e 's/BSD //` -eval_cflags='optimize=+O1' -teval_cflags=$eval_cflags diff --git a/hints/hpux.sh b/hints/hpux.sh deleted file mode 100644 index 904f9dee60..0000000000 --- a/hints/hpux.sh +++ /dev/null @@ -1,8 +0,0 @@ -echo " " -echo "NOTE: regression test op.read may fail due to an NFS bug in HP/UX." -echo "If so, don't worry about it." -case `(uname -r) 2>/dev/null` in -*3.1*) d_syscall=$undef ;; -*2.1*) libswanted=`echo $libswanted | sed 's/ malloc / /'` ;; -esac -d_index=define diff --git a/hints/hpux_9.sh b/hints/hpux_9.sh new file mode 100644 index 0000000000..8d2556a2b2 --- /dev/null +++ b/hints/hpux_9.sh @@ -0,0 +1,9 @@ +libswanted='ndbm m dld' +ccflags="$ccflags -Aa -D_POSIX_SOURCE -D_HPUX_SOURCE" +# ldflags="-Wl,-E -Wl,-a,shared" # Force all shared? +ldflags="-Wl,-E" +optimize='+O1' +usemymalloc='y' +alignbytes=8 +selecttype='int *' +POSIX_cflags='ccflags="$ccflags -DFLT_MIN=1.17549435E-38"' diff --git a/hints/irix_4.sh b/hints/irix_4.sh new file mode 100644 index 0000000000..57a9031e5c --- /dev/null +++ b/hints/irix_4.sh @@ -0,0 +1,6 @@ +optimize='-O1' +usemymalloc='y' +d_voidsig=define +usevfork=false +d_charsprf=undef +ccflags="-ansiposix -signed" diff --git a/hints/irix_5.sh b/hints/irix_5.sh new file mode 100644 index 0000000000..dcbcfba5d9 --- /dev/null +++ b/hints/irix_5.sh @@ -0,0 +1,10 @@ +# irix_5.sh +i_time='define' +ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000" +lddlflags="-shared" +case "$usedl" in +'') usedl='y' ;; +esac +set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'` +shift +libswanted="$*" diff --git a/hints/isc.sh b/hints/isc.sh new file mode 100644 index 0000000000..7c18380f54 --- /dev/null +++ b/hints/isc.sh @@ -0,0 +1,21 @@ +# isc.sh +# Interactive Unix Versions 3 and 4. +# Compile perl entirely in posix mode. +# Andy Dougherty doughera@lafcol.lafayette.edu +# Wed Oct 5 15:57:37 EDT 1994 +# +# Use Configure -Dcc=gcc to use gcc +# +set `echo X "$libswanted "| sed -e 's/ c / /'` +shift +libswanted="$*" +case "$cc" in +*gcc*) ccflags="$ccflags -posix" + ldflags="$ldflags -posix" + ;; +*) ccflags="$ccflags -Xp -D_POSIX_SOURCE" + ldflags="$ldflags -Xp" + ;; +esac +# Pick up dbm.h in <rpcsvc/dbm.h> +ccflags="$ccflags -I/usr/include/rpcsvc" diff --git a/hints/isc_2.sh b/hints/isc_2.sh new file mode 100644 index 0000000000..95b61ba773 --- /dev/null +++ b/hints/isc_2.sh @@ -0,0 +1,24 @@ +# isc_2.sh +# Interactive Unix Version 2.2 +# Compile perl entirely in posix mode. +# Andy Dougherty doughera@lafcol.lafayette.edu +# Wed Oct 5 15:57:37 EDT 1994 +# +# Use Configure -Dcc=gcc to use gcc +# +set `echo X "$libswanted "| sed -e 's/ c / /'` +shift +libswanted="$*" +case "$cc" in +*gcc*) ccflags="$ccflags -posix" + ldflags="$ldflags -posix" + ;; +*) ccflags="$ccflags -Xp -D_POSIX_SOURCE" + ldflags="$ldflags -Xp" + ;; +esac +# Pick up dbm.h in <rpcsvc/dbm.h> +ccflags="$ccflags -I/usr/include/rpcsvc" +# Compensate for conflicts in <net/errno.h> +doio_cflags='ccflags="$ccflags -DENOTSOCK=103"' +pp_sys_cflags='ccflags="$ccflags -DENOTSOCK=103"' diff --git a/hints/isc_3_2_2.sh b/hints/isc_3_2_2.sh deleted file mode 100644 index 0736d3d303..0000000000 --- a/hints/isc_3_2_2.sh +++ /dev/null @@ -1,7 +0,0 @@ -set `echo $libswanted | sed -e 's/ x / /' -e 's/ PW / /'` -libswanted="$*" -doio_cflags='ccflags="$ccflags -DENOTSOCK=103"' -tdoio_cflags='ccflags="$ccflags -DENOTSOCK=103"' -echo "<net/errno.h> defines error numbers for network calls, but" -echo "the definitions for ENAMETOOLONG and ENOTEMPTY conflict with" -echo "those in <sys/errno.h>. Instead just define ENOTSOCK here." diff --git a/hints/isc_3_2_3.sh b/hints/isc_3_2_3.sh deleted file mode 100644 index 5b99353d1c..0000000000 --- a/hints/isc_3_2_3.sh +++ /dev/null @@ -1,3 +0,0 @@ -set `echo "$libswanted" | sed -e 's/ PW / /' -e 's/ x / /'` -libswanted="$*" -ccflags="$ccflags -DCRIPPLED_CC -DDEBUGGING" diff --git a/hints/linux.sh b/hints/linux.sh new file mode 100644 index 0000000000..7617a886b9 --- /dev/null +++ b/hints/linux.sh @@ -0,0 +1,32 @@ +# Configuration time: Mon May 16 03:41:24 EDT 1994 +# Original version by rsanders +# Additional dlext support by Kenneth Albanowski <kjahds@kjahds.com> +# Target system: linux hrothgar 1.1.12 #9 sat may 14 02:03:23 edt 1994 i486 +bin='/usr/bin' +ccflags='-I/usr/include/bsd' +cppflags=' -I/usr/include/bsd' +d_dosuid='define' +d_voidsig='define' +gidtype='gid_t' +groupstype='gid_t' +malloctype='void *' +nm_opt='' +optimize='-O2' +sig_name='ZERO HUP INT QUIT ILL TRAP IOT UNUSED FPE KILL USR1 SEGV USR2 PIPE ALRM TERM STKFLT CHLD CONT STOP TSTP TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH' +signal_t='void' +uidtype='uid_t' +usemymalloc='n' +yacc='bison -y' +lddlflags='-r' +so='sa' +dlext='o' +## If you are using DLD 3.2.4 which does not support shared libs, +## uncomment the next two lines: +#ldflags="-static" +#so='none' + +cat <<EOM + +You should take a look at hints/linux.sh. There are a couple of lines you +may wish to change near the bottom. +EOM diff --git a/hints/mc6000.sh b/hints/mc6000.sh deleted file mode 100644 index 78c87c8144..0000000000 --- a/hints/mc6000.sh +++ /dev/null @@ -1,5 +0,0 @@ -# defaults for the masscomp (concurrent) 6000 series running RTU 5.0 -cppstdin=/lib/cpp -cmd_cflags='optimize=""' -tcmd_cflags='optimize=""' -d_mymalloc=define diff --git a/hints/mips.sh b/hints/mips.sh index ddb2694658..39cadb4b66 100644 --- a/hints/mips.sh +++ b/hints/mips.sh @@ -1,13 +1,10 @@ -cmd_cflags='optimize="-g"' perl_cflags='optimize="-g"' -tcmd_cflags='optimize="-g"' -tperl_cflags='optimize="-g"' d_volatile=undef d_castneg=undef cc=cc libpth="/usr/lib/cmplrs/cc $libpth" groupstype=int -nm_opts='-B' +nm_opt='-B' case $PATH in *bsd*:/bin:*) cat <<END NOTE: Some people have reported having much better luck with Mips CC than diff --git a/hints/ncr_tower.sh b/hints/ncr_tower.sh index aa517d7964..799ee9375c 100644 --- a/hints/ncr_tower.sh +++ b/hints/ncr_tower.sh @@ -1,8 +1,4 @@ optimize='-O0' ccflags="$ccflags -W2,-Sl,2000" -eval_cflags='large="-W0,-XL"' -teval_cflags=$eval_cflags d_mkdir=$undef usemymalloc='y' -mallocsrc='malloc.c' -mallocobj='malloc.o' diff --git a/hints/netbsd.sh b/hints/netbsd.sh new file mode 100644 index 0000000000..f5f5a74f93 --- /dev/null +++ b/hints/netbsd.sh @@ -0,0 +1,10 @@ +# hints/netbsd.sh +case "$osvers" in +0.9|0.8) + usedl="$undef" + ;; +*) d_dlopen="$define" + cccdlflags='-DPIC -fpic' + lddlflags='-Bforcearchive -Bshareable' + ;; +esac diff --git a/hints/next.sh b/hints/next.sh deleted file mode 100644 index 8a1fe390bd..0000000000 --- a/hints/next.sh +++ /dev/null @@ -1,5 +0,0 @@ -: Just disable defaulting to -fpcc-struct-return, since gcc is native compiler. -nativegcc='define' -groupstype="int" -usemymalloc="n" -libswanted='dbm sys_s' diff --git a/hints/next_3_2.sh b/hints/next_3_2.sh index a77e2ae217..1f86526626 100644 --- a/hints/next_3_2.sh +++ b/hints/next_3_2.sh @@ -1,8 +1,16 @@ -hintfile='next_3_2' -ccflags='-posix -Disascii=NXIsAscii -DDEBUGGING -DHIDEMYMALLOC' +ccflags='-D_POSIX_SOURCE -DUSE_NEXT_CTYPE' ldflags='-u libsys_s' -i_dirent='undef' -groupstype='int' -libs='-ldbm' -optimize='-O' +libswanted='dbm gdbm db' lddlflags='-r' +i_utime='undef' +groupstype='int' +direntrytype='struct direct' +d_strcoll='undef' +# the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails +# with Larry's malloc on NS 3.2 due to broken sbrk() +usemymalloc='n' +d_uname='define' +d_setpgid='define' +d_setsid='define' +d_tcgetpgrp='define' +d_tcsetpgrp='define' diff --git a/hints/osf1.sh b/hints/osf1.sh deleted file mode 100644 index e9be84917a..0000000000 --- a/hints/osf1.sh +++ /dev/null @@ -1,25 +0,0 @@ -ccflags="$ccflags -Olimit 2900" -libswanted=m -tmp=`(uname -a) 2>/dev/null` -case "$tmp" in -OSF1*) - case "$tmp" in - *mips) - d_volatile=define - ;; - *) - cat <<EOFM -You are not supposed to know about that machine... -EOFM - ;; - esac - ;; -esac -#eval_cflags='optimize="-g"' -#teval_cflags='optimize="-g"' -#toke_cflags='optimize="-g"' -#ttoke_cflags='optimize="-g"' -regcomp_cflags='optimize="-g -O0"' -tregcomp_cflags='optimize="-g -O0"' -regexec_cflags='optimize="-g -O0"' -tregexec_cflags='optimize="-g -O0"' diff --git a/hints/sco_2_3_2.sh b/hints/sco_2_3_2.sh index 54540e4aa0..e113a4ec65 100644 --- a/hints/sco_2_3_2.sh +++ b/hints/sco_2_3_2.sh @@ -1,2 +1,2 @@ yacc='/usr/bin/yacc -Sm25000' -libswanted=`echo $libswanted | sed 's/ x / /'` +libswanted=`echo " $libswanted "| sed 's/ x / /'` diff --git a/hints/sco_2_3_4.sh b/hints/sco_2_3_4.sh index 3a1b13c1b6..84f58172b3 100644 --- a/hints/sco_2_3_4.sh +++ b/hints/sco_2_3_4.sh @@ -1,5 +1,5 @@ yacc='/usr/bin/yacc -Sm25000' ccflags="$ccflags -UM_I86" -d_mymalloc=define +usemymalloc='y' echo "NOTE: you may have problems due to a spurious semicolon on the strerror()" echo "macro definition in /usr/include/string.h. If so, delete the semicolon." diff --git a/hints/sco_3.sh b/hints/sco_3.sh index 1bb8fb11a9..a89ffbec6a 100644 --- a/hints/sco_3.sh +++ b/hints/sco_3.sh @@ -1,7 +1,30 @@ -yacc='/usr/bin/yacc -Sm11000' -libswanted=`echo $libswanted | sed 's/ x / /'` -ccflags="$ccflags -U M_XENIX" -cppstdin='/lib/cpp -Di386 -DM_I386 -Dunix -DM_UNIX -DM_INTERNAT -DLAI_TCP' -cppminus='' +# sco_3.sh +# Courtesy of Joel Rosi-Schwartz <joel@ftechne.co.uk> +# To use gcc, do Configure -Dcc=gcc +# +# Try to use libintl.a since it has strcoll and strxfrm +libswanted="intl $libswanted" +# Try to use libdbm.nfs.a since it has dbmclose. +# +if test -f /usr/lib/libdbm.nfs.a ; then + libswanted=`echo "dbm.nfs $libswanted " | sed -e 's/ dbm / /'` +fi +set X $libswanted +shift +libswanted="$*" +# +# We don't want Xenix cross-development libraries +glibpth=`echo $glibpth | sed -e 's! /usr/lib/386 ! !' -e 's! /lib/386 ! !'` +xlibpth='' +# +case "$cc" in +gcc) + ccflags="$ccflags -U M_XENIX" + optimize="$optimize -O2" + ;; +*) + ccflags="$ccflags -W0 -U M_XENIX" + ;; +esac i_varargs=undef -d_rename='undef' +nm_opt='-p' diff --git a/hints/sgi.sh b/hints/sgi.sh deleted file mode 100644 index 4252aaf148..0000000000 --- a/hints/sgi.sh +++ /dev/null @@ -1,12 +0,0 @@ -optimize='-O1' -d_mymalloc=define -mallocsrc='malloc.c' -mallocobj='malloc.o' -d_voidsig=define -d_vfork=undef -d_charsprf=undef -case `(uname -r) 2>/dev/null` in -4*)libswanted=`echo $libswanted | sed 's/c_s \(.*\)/\1 c_s/'` - ccflags="$ccflags -DLANGUAGE_C -DBSD_SIGNALS -cckr -signed" - ;; -esac diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh new file mode 100644 index 0000000000..081213aa96 --- /dev/null +++ b/hints/solaris_2.sh @@ -0,0 +1,33 @@ +usevfork=false +d_suidsafe=define +ccflags="$ccflags" +set `echo $glibpth | sed -e 's@/usr/ucblib@@'` +glibpth="$*" +set `echo " $libswanted " | sed -e 's@ ld @ @' -e 's@ ucb @ @'` +libswanted="$*" + +# Look for architecture name. We want to suggest a useful default +# for archlib and also warn about possible -x486 flags needed. +case "$archname" in +'') + if test -f /usr/bin/arch; then + archname=`/usr/bin/arch` + archname="${archname}-${osname}" + elif test -f /usr/ucb/arch; then + archname=`/usr/ucb/arch` + archname="${archname}-${osname}" + fi + ;; +esac +case "$archname" in +*86*) echo "For an Intel platform you might need to add -x486 to ccflags" >&4;; +*) ;; +esac + +case $PATH in +*/usr/ucb*:/usr/bin:*) cat <<END +NOTE: Some people have reported problems with /usr/ucb/cc. +Remove /usr/ucb from your PATH if you have difficulties. +END +;; +esac diff --git a/hints/solaris_2_0.sh b/hints/solaris_2_0.sh deleted file mode 100644 index 8eae5de276..0000000000 --- a/hints/solaris_2_0.sh +++ /dev/null @@ -1 +0,0 @@ -d_vfork='undef' diff --git a/hints/solaris_2_1.sh b/hints/solaris_2_1.sh deleted file mode 100644 index de405bc24d..0000000000 --- a/hints/solaris_2_1.sh +++ /dev/null @@ -1,4 +0,0 @@ -d_vfork='undef' -d_wait4='undef' -i_dirent='undef' -i_sys_dir='define' diff --git a/hints/solaris_2_2.sh b/hints/solaris_2_2.sh deleted file mode 100644 index 01b9d93342..0000000000 --- a/hints/solaris_2_2.sh +++ /dev/null @@ -1,10 +0,0 @@ -d_vfork='undef' -set `echo $libpth | sed -e 's@/usr/ucblib@@'` -libpth="$*" -case $PATH in -*/usr/ucb*:/usr/bin:*) cat <<END -NOTE: Some people have reported problems with /usr/ucb/cc. -Remove /usr/ucb from your PATH if you have difficulties. -END -;; -esac diff --git a/hints/solaris_2_3.sh b/hints/solaris_2_3.sh deleted file mode 100644 index 01b9d93342..0000000000 --- a/hints/solaris_2_3.sh +++ /dev/null @@ -1,10 +0,0 @@ -d_vfork='undef' -set `echo $libpth | sed -e 's@/usr/ucblib@@'` -libpth="$*" -case $PATH in -*/usr/ucb*:/usr/bin:*) cat <<END -NOTE: Some people have reported problems with /usr/ucb/cc. -Remove /usr/ucb from your PATH if you have difficulties. -END -;; -esac diff --git a/hints/sunos_3_4.sh b/hints/sunos_3_4.sh deleted file mode 100644 index 49b14af1bc..0000000000 --- a/hints/sunos_3_4.sh +++ /dev/null @@ -1,3 +0,0 @@ -usemymalloc=n -mallocsrc='' -mallocobj='' diff --git a/hints/sunos_3_5.sh b/hints/sunos_3_5.sh deleted file mode 100644 index 49b14af1bc..0000000000 --- a/hints/sunos_3_5.sh +++ /dev/null @@ -1,3 +0,0 @@ -usemymalloc=n -mallocsrc='' -mallocobj='' diff --git a/hints/sunos_4_0_1.sh b/hints/sunos_4_0.sh index 99fce3f44b..99fce3f44b 100644 --- a/hints/sunos_4_0_1.sh +++ b/hints/sunos_4_0.sh diff --git a/hints/sunos_4_0_2.sh b/hints/sunos_4_0_2.sh deleted file mode 100644 index 99fce3f44b..0000000000 --- a/hints/sunos_4_0_2.sh +++ /dev/null @@ -1 +0,0 @@ -ccflags="$ccflags -DFPUTS_BOTCH" diff --git a/hints/sunos_4_1.sh b/hints/sunos_4_1.sh new file mode 100644 index 0000000000..070a8e0544 --- /dev/null +++ b/hints/sunos_4_1.sh @@ -0,0 +1,15 @@ +case "$cc" in +*gcc*) usevfork=false ;; +*) usevfork=true ;; +esac +d_tzname='undef' +# check if user is in a bsd or system 5 type environment +if cat -b /dev/null 2>/dev/null +then # bsd + groupstype='int' +else # sys5 + groupstype='gid_t' +fi +# we don't set gidtype because unistd.h says gid_t getgid() but man +# page says int getgid() for bsd. utils.c includes unistd.h :-( + diff --git a/hints/sunos_4_1_2.sh b/hints/sunos_4_1_2.sh deleted file mode 100644 index 9439388774..0000000000 --- a/hints/sunos_4_1_2.sh +++ /dev/null @@ -1 +0,0 @@ -groupstype='int' diff --git a/hints/sunos_4_1_3.sh b/hints/sunos_4_1_3.sh deleted file mode 100644 index 9439388774..0000000000 --- a/hints/sunos_4_1_3.sh +++ /dev/null @@ -1 +0,0 @@ -groupstype='int' diff --git a/hints/svr4.sh b/hints/svr4.sh index eae477e807..c707eb8ccd 100644 --- a/hints/svr4.sh +++ b/hints/svr4.sh @@ -1,6 +1,33 @@ -cc='/bin/cc' -test -f $cc || cc='/usr/ccs/bin/cc' -ldflags='-L/usr/ucblib' -mansrc='/usr/share/man/man1' +# svr4 hints, System V Release 4.x +# Use Configure -Dcc=gcc to use gcc. +case "$cc" in +'') cc='/bin/cc' + test -f $cc || cc='/usr/ccs/bin/cc' + cccdlflags='-Kpic' # Probably needed for dynamic loading + ;; +esac +test -d /usr/local/man || mansrc='none' +# We include support for using libraries in /usr/ucblib, but the setting +# of libswanted excludes some libraries found there. You may want to +# prevent "ucb" from being removed from libswanted and see if perl will +# build on your system. +ldflags='-L/usr/ccs/lib -L/usr/ucblib' ccflags='-I/usr/include -I/usr/ucbinclude' -libswanted=`echo $libswanted | sed 's/ ucb/ c ucb/'` +libswanted=`echo $libswanted | tr ' ' '\012' | egrep -v '^(malloc|ucb)$'` +# -lucb: Defines setreuid() and other routines Perl wants but they don't +# add any/much functionality and often won't ld properly. +# -lmalloc: Anyone know what problems this caused? +if [ "" = "$i_ndbm" -a ! -f /usr/ucblib/libndbm.a ]; then +# UnixWare 1.1 may install /usr/ucbinclude/ndbm.h w/o /usr/ucblib/libndbm.a + i_ndbm="$undef" # so Configure tries to build ext/NDBM_File and ld +fi # can't find dbm_open()! "./Configure -D i_ndbm=define" overrides. +d_index='undef' +d_suidsafe=define # "./Configure -d" can't figure this out +lddlflags="-G $ldflags" # Probably needed for dynamic loading +usevfork='false' +# dlopen routines exist but they don't work with perl. +# The case statement allows experimenters to override hint with +# Configure -D usedl +case "$usedl" in +'') usedl="$undef" ;; +esac diff --git a/hints/ti1500.sh b/hints/ti1500.sh index 3d89250b25..69482d8680 100644 --- a/hints/ti1500.sh +++ b/hints/ti1500.sh @@ -1 +1 @@ -d_mymalloc='undef' +usemymalloc='n' diff --git a/hints/titan.sh b/hints/titan.sh deleted file mode 100644 index 1801e82518..0000000000 --- a/hints/titan.sh +++ /dev/null @@ -1,40 +0,0 @@ -# Hints file (perl 4.019) for Kubota Pacific's Titan 3000 Series Machines. -# Created by: JT McDuffie (jt@kpc.com) 26 DEC 1991 -bin='/usr/local/bin' -installbin='/usr/local/bin' -memalignbytes="8" -byteorder="4321" -cppstdin='/lib/cpp' -cppminus='' -castflags='0' -gid_type='ushort' -groupstype='unsigned short' -intsize='4' -libc='/lib/libc.a' -nm_opts='-eh' -mallocptrtype='void' -mansrc='/usr/man/man1' -installmansrc='/usr/man/man1' -manext='1' -models='none' -optimize='-O' -ccflags="$ccflags -I/usr/include/net -DDEBUGGING" -cppflags="$cppflags -I/usr/include/net -DDEBUGGING" -cc='cc' -libs='-lnsl -ldbm -lPW -lmalloc -lm' -libswanted='net socket nsl nm ndir ndbm dbm PW malloc m x posix ' -scriptdir='/usr/local/bin' -installscr='/usr/local/bin' -stdchar='unsigned char' -uidtype='ushort' -usrinclude='/usr/include' -voidhave='7' -w_localtim='1' -w_s_timevl='1' -w_s_tm='1' -privlib='/usr/local/lib/perl' -installprivlib='/usr/local/lib/perl' -inclwanted='/usr/include /usr/include/net ' -libpth=' /usr/lib /usr/local/lib /lib' -eoPATH='/bin /usr/bin /usr/ucb /usr/local /usr/local/bin /usr/lbin /etc /usr/lib /lib /usr/local/lib ' -pth=' . /bin /usr/bin /usr/ucb /usr/local/bin /usr/X11/bin /usr/lbin /etc /usr/lib /lib /usr/local/lib ' diff --git a/hints/titanos.sh b/hints/titanos.sh new file mode 100644 index 0000000000..b327037c8e --- /dev/null +++ b/hints/titanos.sh @@ -0,0 +1,24 @@ +# Hints file (perl 4.019) for Kubota Pacific's Titan 3000 Series Machines. +# Created by: JT McDuffie (jt@kpc.com) 26 DEC 1991 +# p5ed by: Jarkko Hietaniemi <jhi@hut.fi> Aug 27 1994 +# NOTE: You should run Configure with tcsh (yes, tcsh). +alignbytes="8" +byteorder="4321" +castflags='0' +gidtype='ushort' +groupstype='unsigned short' +intsize='4' +usenm='true' +nm_opt='-eh' +malloctype='void *' +models='none' +ccflags="$ccflags -I/usr/include/net -DDEBUGGING -DSTANDARD_C" +cppflags="$cppflags -I/usr/include/net -DDEBUGGING -DSTANDARD_C" +libs='-lnsl -ldbm -lPW -lmalloc -lm' +stdchar='unsigned char' +static_ext='DynaLoader NDBM_File Socket' +uidtype='ushort' +voidflags='7' +inclwanted='/usr/include /usr/include/net' +libpth='/usr/lib /usr/local/lib /lib' +pth='. /bin /usr/bin /usr/ucb /usr/local/bin /usr/X11/bin /usr/lbin /etc /usr/lib' diff --git a/hints/ultrix_1.sh b/hints/ultrix_1.sh deleted file mode 100644 index 7569e48d57..0000000000 --- a/hints/ultrix_1.sh +++ /dev/null @@ -1 +0,0 @@ -ccflags="$ccflags -DULTRIX_STDIO_BOTCH" diff --git a/hints/ultrix_3.sh b/hints/ultrix_3.sh deleted file mode 100644 index 0df47231f6..0000000000 --- a/hints/ultrix_3.sh +++ /dev/null @@ -1,14 +0,0 @@ -ccflags="$ccflags -DLANGUAGE_C" -tmp="`(uname -a) 2>/dev/null`" -case "$tmp" in -*3.[01]*RISC) d_waitpid=$undef;; -'') d_waitpid=$undef;; -esac -case "$tmp" in -*RISC) - cmd_cflags='optimize="-g"' - perl_cflags='optimize="-g"' - tcmd_cflags='optimize="-g"' - tperl_cflags='optimize="-g"' - ;; -esac diff --git a/hints/ultrix_4.sh b/hints/ultrix_4.sh index 633e904b72..c7a8c2cfa0 100644 --- a/hints/ultrix_4.sh +++ b/hints/ultrix_4.sh @@ -1,4 +1,4 @@ -ccflags="$ccflags -DLANGUAGE_C -Olimit 2900" +optimize=-g tmp=`(uname -a) 2>/dev/null` case "$tmp" in *RISC*) cat <<EOF @@ -12,12 +12,13 @@ EOF ;; esac case "$tmp" in -*4.1*) - eval_cflags='optimize="-g"' - teval_cflags='optimize="-g"' - toke_cflags='optimize="-g"' - ttoke_cflags='optimize="-g"' - ;; -*4.2*) libswanted=`echo $libswanted | sed 's/ malloc / /'` ;; +*4.1*) ccflags="$ccflags -DLANGUAGE_C -Olimit 2900" + ;; +*4.2*) ccflags="$ccflags -DLANGUAGE_C -Olimit 2900" + libswanted=`echo $libswanted | sed 's/ malloc / /'` + ;; +*4.4*) ccflags="$ccflags -std -Olimit 2900" + ranlib='ranlib' + ;; esac - +groupstype='int' diff --git a/hints/cray.sh b/hints/unicos.sh index 2ce956695e..d23cbe3f5e 100644 --- a/hints/cray.sh +++ b/hints/unicos.sh @@ -1,8 +1,8 @@ case `uname -r` in 6.1*) shellflags="-m+65536" ;; esac -ccflags="$ccflags -DUNICOS -h nomessage=118:151:172" -usemymalloc='n' -libswanted='malloc m' +ccflags="$ccflags -DHZ=__hertz" +optimize="-O1" +libswanted=m d_setregid='undef' d_setreuid='undef' diff --git a/hints/utekv.sh b/hints/utekv.sh index 6b2382c0ef..0d30fd66ab 100644 --- a/hints/utekv.sh +++ b/hints/utekv.sh @@ -1,17 +1,14 @@ # XD88/10 UTekV hints by Kaveh Ghazi (ghazi@caip.rutgers.edu) 2/11/92 +# Modified by Andy Dougherty <doughera@lafcol.lafayette.edu> 4 Oct. 1994 -# The -DUTekV is needed because the greenhills compiler does not have any -# UTekV specific definitions and we need one in perl.h -ccflags="$ccflags -X18 -DJMPCLOBBER -DUTekV" +# The -X18 is only if you are using the Greenhills compiler. +ccflags="$ccflags -X18" usemymalloc='y' # /usr/include/rpcsvc is for finding dbm.h inclwanted="$inclwanted /usr/include/rpcsvc" -# dont use the wrapper, use the real thing. -cppstdin=/lib/cpp - echo " " echo "NOTE: You may have to take out makefile dependencies on the files in" echo "/usr/include (i.e. /usr/include/ctype.h) or the make will fail. A" diff --git a/hints/vax.sh b/hints/vax.sh deleted file mode 100644 index ea8f224396..0000000000 --- a/hints/vax.sh +++ /dev/null @@ -1 +0,0 @@ -teval_cflags='case $cc in *gcc);; *) optimize="-O";; esac' @@ -1,35 +1,21 @@ -/* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:21:48 $ +/* hv.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: hash.c,v $ - * Revision 4.1 92/08/07 18:21:48 lwall - * - * Revision 4.0.1.3 92/06/08 13:26:29 lwall - * patch20: removed implicit int declarations on functions - * patch20: delete could cause %array to give too low a count of buckets filled - * patch20: hash tables now split only if the memory is available to do so - * - * Revision 4.0.1.2 91/11/05 17:24:13 lwall - * patch11: saberized perl - * - * Revision 4.0.1.1 91/06/07 11:10:11 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:22:26 lwall - * 4.0 baseline. - * + */ + +/* + * "I sit beside the fire and think of all that I have seen." --Bilbo */ #include "EXTERN.h" #include "perl.h" -static void hsplit(); - -static void hfreeentries(); +static void hsplit _((HV *hv)); +static void hfreeentries _((HV *hv)); SV** hv_fetch(hv,key,klen,lval) @@ -52,10 +38,6 @@ I32 lval; if (mg_find((SV*)hv,'P')) { sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); - if (!lval) { - mg_get(sv); - sv_unmagic(sv,'p'); - } Sv = sv; return &Sv; } @@ -63,7 +45,11 @@ I32 lval; xhv = (XPVHV*)SvANY(hv); if (!xhv->xhv_array) { - if (lval) + 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; @@ -75,7 +61,7 @@ I32 lval; while (i--) hash = hash * 33 + *s++; - entry = ((HE**)xhv->xhv_array)[hash & xhv->xhv_max]; + 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; @@ -85,6 +71,17 @@ I32 lval; 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)) { + char *gotenv; + + gotenv = my_getenv(key); + if (gotenv != NULL) { + sv = newSVpv(gotenv,strlen(gotenv)); + return hv_store(hv,key,klen,sv,hash); + } + } +#endif if (lval) { /* gonna assign to this, so it better be there */ sv = NEWSV(61,0); return hv_store(hv,key,klen,sv,hash); @@ -112,8 +109,14 @@ register U32 hash; xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { mg_copy((SV*)hv, val, key, klen); +#ifndef OVERLOAD if (!xhv->xhv_array) return 0; +#else + if (!xhv->xhv_array && (SvMAGIC(hv)->mg_type != 'A' + || SvMAGIC(hv)->mg_moremagic)) + return 0; +#endif /* OVERLOAD */ } if (!hash) { i = klen; @@ -125,7 +128,7 @@ register U32 hash; if (!xhv->xhv_array) Newz(505, xhv->xhv_array, sizeof(HE**) * (xhv->xhv_max + 1), char); - oentry = &((HE**)xhv->xhv_array)[hash & xhv->xhv_max]; + oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; i = 1; for (entry = *oentry; entry; i=0, entry = entry->hent_next) { @@ -142,7 +145,7 @@ register U32 hash; New(501,entry, 1, HE); entry->hent_klen = klen; - entry->hent_key = nsavestr(key,klen); + entry->hent_key = savepvn(key,klen); entry->hent_val = val; entry->hent_hash = hash; entry->hent_next = *oentry; @@ -177,6 +180,10 @@ U32 klen; if (SvRMAGICAL(hv)) { sv = *hv_fetch(hv, key, klen, TRUE); 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) @@ -187,7 +194,7 @@ U32 klen; while (i--) hash = hash * 33 + *s++; - oentry = &((HE**)xhv->xhv_array)[hash & xhv->xhv_max]; + oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; entry = *oentry; i = 1; for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) { @@ -201,19 +208,70 @@ U32 klen; if (i && !*oentry) xhv->xhv_fill--; sv = sv_mortalcopy(entry->hent_val); - he_free(entry); + if (entry == xhv->xhv_eiter) + entry->hent_klen = -1; + else + he_free(entry); --xhv->xhv_keys; return sv; } return Nullsv; } +bool +hv_exists(hv,key,klen) +HV *hv; +char *key; +U32 klen; +{ + register XPVHV* xhv; + register char *s; + register I32 i; + register I32 hash; + 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, key, klen); + magic_existspack(sv, mg_find(sv, 'p')); + return SvTRUE(sv); + } + } + + xhv = (XPVHV*)SvANY(hv); + 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; + } + return FALSE; +} + static void hsplit(hv) HV *hv; { register XPVHV* xhv = (XPVHV*)SvANY(hv); - I32 oldsize = xhv->xhv_max + 1; + I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */ register I32 newsize = oldsize * 2; register I32 i; register HE **a; @@ -256,9 +314,8 @@ newHV() register HV *hv; register XPVHV* xhv; - Newz(502,hv, 1, HV); - SvREFCNT(hv) = 1; - sv_upgrade(hv, SVt_PVHV); + hv = (HV*)NEWSV(502,0); + sv_upgrade((SV *)hv, SVt_PVHV); xhv = (XPVHV*)SvANY(hv); SvPOK_off(hv); SvNOK_off(hv); @@ -301,32 +358,46 @@ HV *hv; xhv = (XPVHV*)SvANY(hv); hfreeentries(hv); xhv->xhv_fill = 0; + xhv->xhv_keys = 0; if (xhv->xhv_array) (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*)); + + if (SvRMAGICAL(hv)) + mg_clear((SV*)hv); } static void hfreeentries(hv) HV *hv; { - register XPVHV* xhv; + register HE **array; register HE *hent; register HE *ohent = Null(HE*); + I32 riter; + I32 max; if (!hv) return; - xhv = (XPVHV*)SvANY(hv); - if (!xhv->xhv_array) + if (!HvARRAY(hv)) return; - (void)hv_iterinit(hv); - /*SUPPRESS 560*/ - while (hent = hv_iternext(hv)) { /* concise but not very efficient */ - he_free(ohent); - ohent = hent; + + riter = 0; + 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) + break; + hent = array[riter]; + } } - he_free(ohent); - if (SvMAGIC(hv)) - mg_clear((SV*)hv); + (void)hv_iterinit(hv); } void @@ -346,7 +417,10 @@ HV *hv; xhv->xhv_array = 0; xhv->xhv_max = 7; /* it's a normal associative array */ xhv->xhv_fill = 0; - (void)hv_iterinit(hv); /* so each() will start off right */ + xhv->xhv_keys = 0; + + if (SvRMAGICAL(hv)) + mg_clear((SV*)hv); } I32 @@ -354,6 +428,9 @@ hv_iterinit(hv) HV *hv; { register XPVHV* xhv = (XPVHV*)SvANY(hv); + HE *entry = xhv->xhv_eiter; + if (entry && entry->hent_klen < 0) /* was deleted earlier? */ + he_free(entry); xhv->xhv_riter = -1; xhv->xhv_eiter = Null(HE*); return xhv->xhv_fill; @@ -365,25 +442,28 @@ HV *hv; { register XPVHV* xhv; register HE *entry; + HE *oldentry; MAGIC* mg; if (!hv) croak("Bad associative array"); xhv = (XPVHV*)SvANY(hv); - entry = xhv->xhv_eiter; + oldentry = entry = xhv->xhv_eiter; if (SvRMAGICAL(hv) && (mg = mg_find((SV*)hv,'P'))) { SV *key = sv_newmortal(); - if (entry) - sv_setpvn(key, entry->hent_key, entry->hent_klen); - else { - Newz(504,entry, 1, HE); - xhv->xhv_eiter = entry; - } - magic_nextpack(hv,mg,key); + if (entry) { + sv_usepvn(key, entry->hent_key, entry->hent_klen); + entry->hent_key = 0; + } + else { + Newz(504,entry, 1, HE); + xhv->xhv_eiter = entry; + } + magic_nextpack((SV*) hv,mg,key); if (SvOK(key)) { STRLEN len; - entry->hent_key = SvPV(key, len); + entry->hent_key = SvPV_force(key, len); entry->hent_klen = len; SvPOK_off(key); SvPVX(key) = 0; @@ -402,7 +482,7 @@ HV *hv; if (entry) entry = entry->hent_next; if (!entry) { - xhv->xhv_riter++; + ++xhv->xhv_riter; if (xhv->xhv_riter > xhv->xhv_max) { xhv->xhv_riter = -1; break; @@ -411,6 +491,9 @@ HV *hv; } } while (!entry); + if (oldentry && oldentry->hent_klen < 0) /* was deleted earlier? */ + he_free(oldentry); + xhv->xhv_eiter = entry; return entry; } @@ -433,19 +516,30 @@ register HE *entry; if (mg_find((SV*)hv,'P')) { SV* sv = sv_newmortal(); mg_copy((SV*)hv, sv, entry->hent_key, entry->hent_klen); - mg_get(sv); - sv_unmagic(sv,'p'); return sv; } } return entry->hent_val; } +SV * +hv_iternextsv(hv, key, retlen) + HV *hv; + char **key; + I32 *retlen; +{ + HE *he; + if ( (he = hv_iternext(hv)) == NULL) + return NULL; + *key = hv_iterkey(he, retlen); + return hv_iterval(hv, he); +} + void hv_magic(hv, gv, how) HV* hv; GV* gv; -I32 how; +int how; { - sv_magic((SV*)hv, (SV*)gv, how, 0, 0); + sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0); } @@ -1,22 +1,10 @@ -/* $RCSfile: hash.h,v $$Revision: 4.1 $$Date: 92/08/07 18:21:52 $ +/* hv.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: hash.h,v $ - * Revision 4.1 92/08/07 18:21:52 lwall - * - * Revision 4.0.1.2 91/11/05 17:24:31 lwall - * patch11: random cleanup - * - * Revision 4.0.1.1 91/06/07 11:10:33 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:22:38 lwall - * 4.0 baseline. - * */ typedef struct he HE; @@ -33,7 +21,7 @@ struct xpvhv { char * xhv_array; /* pointer to malloced string */ STRLEN xhv_fill; /* how full xhv_array currently is */ STRLEN xhv_max; /* subscript of last element of xhv_array */ - STRLEN xhv_keys; /* how many elements in the array */ + I32 xhv_keys; /* how many elements in the array */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ @@ -53,3 +41,20 @@ struct xpvhv { #define HvEITER(hv) ((XPVHV*) SvANY(hv))->xhv_eiter #define HvPMROOT(hv) ((XPVHV*) SvANY(hv))->xhv_pmroot #define HvNAME(hv) ((XPVHV*) SvANY(hv))->xhv_name + +#ifdef OVERLOAD + +/* Maybe amagical: */ +/* #define HV_AMAGICmb(hv) (SvFLAGS(hv) & (SVpgv_badAM | SVpgv_AM)) */ + +#define HV_AMAGIC(hv) (SvFLAGS(hv) & SVpgv_AM) +#define HV_AMAGIC_on(hv) (SvFLAGS(hv) |= SVpgv_AM) +#define HV_AMAGIC_off(hv) (SvFLAGS(hv) &= ~SVpgv_AM) + +/* +#define HV_AMAGICbad(hv) (SvFLAGS(hv) & SVpgv_badAM) +#define HV_badAMAGIC_on(hv) (SvFLAGS(hv) |= SVpgv_badAM) +#define HV_badAMAGIC_off(hv) (SvFLAGS(hv) &= ~SVpgv_badAM) +*/ + +#endif /* OVERLOAD */ diff --git a/hvdbm.h b/hvdbm.h deleted file mode 100644 index f81492b1df..0000000000 --- a/hvdbm.h +++ /dev/null @@ -1,58 +0,0 @@ -#define DBM_CACHE_MAX 63 /* cache 64 entries for dbm file */ - /* (resident array acts as a write-thru cache)*/ -#ifdef WANT_DBZ -# include <dbz.h> -# define SOME_DBM -# define dbm_fetch(db,dkey) fetch(dkey) -# define dbm_delete(db,dkey) croak("dbz doesn't implement delete") -# define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent) -# define dbm_close(db) dbmclose() -# define dbm_firstkey(db) (croak("dbz doesn't implement traversal"),fetch()) -# define nextkey() (croak("dbz doesn't implement traversal"),fetch()) -# define dbm_nextkey(db) (croak("dbz doesn't implement traversal"),fetch()) -# ifdef I_NDBM -# undef I_NDBM -# endif -# ifndef I_DBM -# define I_DBM -# endif -#else -# ifdef HAS_GDBM -# ifdef I_GDBM -# include <gdbm.h> -# endif -# define SOME_DBM -# ifdef I_NDBM -# undef I_NDBM -# endif -# ifdef I_DBM -# undef I_DBM -# endif -# else -# ifdef I_NDBM -# include <ndbm.h> -# define SOME_DBM -# ifdef I_DBM -# undef I_DBM -# endif -# else -# ifdef I_DBM -# ifdef NULL -# undef NULL /* suppress redefinition message */ -# endif -# include <dbm.h> -# ifdef NULL -# undef NULL -# endif -# define NULL 0 /* silly thing is, we don't even use this... */ -# define SOME_DBM -# define dbm_fetch(db,dkey) fetch(dkey) -# define dbm_delete(db,dkey) delete(dkey) -# define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent) -# define dbm_close(db) dbmclose() -# define dbm_firstkey(db) firstkey() -# endif /* I_DBM */ -# endif /* I_NDBM */ -# endif /* HAS_GDBM */ -#endif /* WANT_DBZ */ - diff --git a/installperl b/installperl index e4e0e44300..4fc145206c 100755 --- a/installperl +++ b/installperl @@ -1,4 +1,7 @@ #!./perl +BEGIN { @INC=('./lib', '../lib') } + +use File::Find; $mainperldir = "/usr/bin"; @@ -10,8 +13,8 @@ while (@ARGV) { umask 022; -@scripts = ('cppstdin', 'h2ph', 'c2ph', 'pstruct', 'x2p/s2p', 'x2p/find2perl'); -@manpages = ('perl.man', 'h2ph.man', 'x2p/a2p.man', 'x2p/s2p.man'); +@scripts = ('cppstdin', 'c2ph', 'pstruct', 'x2p/s2p', 'x2p/find2perl'); +@manpages = (<pod/*.man>, 'x2p/a2p.man', 'x2p/s2p.man'); # Read in the config file. @@ -86,40 +89,31 @@ if ($bdev != $ddev || $bino != $dino) { &chmod(0755, "$installbin/a2p"); } -# Make some enemies in the name of standardization. :-) - -($udev,$uino) = stat($mainperldir); - -if (-w _ && ($udev != $bdev || $uino != $bino) && !$nonono) { - &unlink("$mainperldir/perl"); - eval 'link("$installbin/perl", "$mainperldir/perl")' || - eval 'symlink("$installbin/perl", "$mainperldir/perl")' || - &cmd("cp $installbin/perl $mainperldir"); -} - # Install scripts. -&makedir($installscr); +&makedir($installscript); for (@scripts) { - &cmd("cp $_ $installscr"); - s#.*/##; &chmod(0755, "$installscr/$_"); + if (-f $_) { # cppstdin might not exist on this system. + &cmd("cp $_ $installscript"); + s#.*/##; &chmod(0755, "$installscript/$_"); + } } # Install man pages. -if ($mansrc ne '') { - &makedir($mansrc); +if ($installmansrc ne '') { + &makedir($installmansrc); - ($mdev,$mino) = stat($mansrc); + ($mdev,$mino) = stat($installmansrc); if ($mdev != $ddev || $mino != $dino) { for (@manpages) { ($new = $_) =~ s/man$/$manext/; $new =~ s#.*/##; - print STDERR " Installing $mansrc/$new\n"; + print STDERR " Installing $installmansrc/$new\n"; next if $nonono; open(MI,$_) || warn "Can't open $_: $!\n"; - open(MO,">$mansrc/$new") || warn "Can't install $mansrc/$new: $!\n"; + open(MO,">$installmansrc/$new") || warn "Can't install $installmansrc/$new: $!\n"; print MO ".ds RP Release $release Patchlevel $patchlevel\n"; while (<MI>) { print MO; @@ -132,33 +126,21 @@ if ($mansrc ne '') { # Install library files. +$do_installarchlib = $do_installprivlib = 0; + &makedir($installprivlib); +&makedir($installarchlib); if (chdir "lib") { + ($pdev,$pino) = stat($installarchlib); + ($ldev,$lino) = stat('.'); + $do_installarchlib = ($pdev != $ldev || $pino != $lino); ($pdev,$pino) = stat($installprivlib); ($ldev,$lino) = stat('.'); + $do_installprivlib = ($pdev != $ldev || $pino != $lino); - if ($pdev != $ldev || $pino != $lino) { - # Optimize for quick access. First the auto directory. - system "tar cf - auto | (cd $installprivlib; tar xvf -)"; - # Next the Perl modules. - foreach $file (<*.pm>) { - system "cmp", "-s", $file, "$privlib/$file"; - if ($?) { - &unlink("$installprivlib/$file"); - &cmd("cp $file $installprivlib"); - &chmod(0644, "$installprivlib/$file"); - } - } - # Finally the old library files. - foreach $file (<*.pl>) { - system "cmp", "-s", $file, "$privlib/$file"; - if ($?) { - &unlink("$installprivlib/$file"); - &cmd("cp $file $installprivlib"); - &chmod(0644, "$installprivlib/$file"); - } - } + if ($do_installarchlib || $do_installprivlib) { + find(\&installlib, '.'); } chdir ".." || die "Can't cd back to source directory: $!\n"; } @@ -166,12 +148,82 @@ else { warn "Can't cd to lib to install lib files: $!\n"; } +# Offer to install perl in a "standard" location + +($udev,$uino) = stat($mainperldir); + +$mainperl_is_instperl = 0; + +if (-w _ && ($udev != $bdev || $uino != $bino) && !$nonono) { + # First make sure $mainperldir/perl is not already the same as + # the perl we just installed + if (-x "$mainperldir/perl") { + # Use stat so we detect symbolic links transparently + ($mpdev, $mpino) = stat("$mainperldir/perl"); + ($ipdev, $ipino) = stat("$installbin/perl"); + # Try to be clever about mainperl being a symbolic link + # to binexp/perl if binexp and installbin are different. + $mainperl_is_instperl = + (($mpdev == $ipdev && $mpino == $ipino) || + (($binexp ne $installbin) && + (-l "$mainperldir/perl") && + ((readlink "$mainperldir/perl") eq "$binexp/perl"))); + } + if ((! $mainperl_is_instperl) && + (&yn("Many scripts expect perl to be installed as " . + "$mainperldir/perl.\n" . + "Do you wish to have $mainperldir/perl be the same as\n" . + "$binexp/perl? [y] "))) + { + unlink("$mainperldir/perl"); + eval 'link("$installbin/perl", "$mainperldir/perl")' || + eval 'symlink("$binexp/perl", "$mainperldir/perl")' || + &cmd("cp $installbin/perl $mainperldir"); + $mainperl_is_instperl = 1; + } +} + +# Check to make sure there aren't other perls around in installer's +# path. This is probably UNIX-specific. Check all absolute directories +# in the path except for where public executables are supposed to live. +# Also skip $mainperl if the user opted to have it be a link to the +# installed perl. + +@path = split(/:/, $ENV{"PATH"}); +@otherperls = (); +for (@path) { + next unless m,^/,; + next if ($_ eq $binexp); + # Use &samepath here because some systems have other dirs linked + # to $mainperldir (like SunOS) + next if ($mainperl_is_instperl && &samepath($_, $mainperldir)); + push(@otherperls, "$_/perl") if (-x "$_/perl" && ! -d "$_/perl"); +} +if (@otherperls) { + print STDERR "\nWarning: perl appears in your path in the following " . + "locations beyond where\nwe just installed it:\n"; + for (@otherperls) { + print STDERR " ", $_, "\n"; + } + print STDERR "\n"; +} + print STDERR " Installation complete\n"; exit 0; ############################################################################### +sub yn { + local($prompt) = @_; + local($answer); + local($default) = $prompt =~ m/\[([yn])\]\s*$/i; + print STDERR $prompt; + chop($answer = <STDIN>); + $answer = $default if $answer =~ m/^\s*$/; + ($answer =~ m/^[yY]/); +} + sub unlink { local(@names) = @_; @@ -218,3 +270,46 @@ sub makedir { mkdir($dir, 0777) || warn "Couldn't create $dir: $!\n" unless $nonono; } } + +sub samepath { + local($p1, $p2) = @_; + local($dev1, $ino1, $dev2, $ino2); + + if ($p1 ne p2) { + ($dev1, $ino1) = stat($p1); + ($dev2, $ino2) = stat($p2); + ($dev1 == $dev2 && $ino1 == $ino2); + } + else { + 1; + } +} + +sub installlib { + my $dir = $File::Find::dir; + $dir =~ s#^\.(?![^/])/?##; + + my $name = $_; + $name = "$dir/$name" if $dir ne ''; + + my $installlib = $installprivlib; + if ((substr($dir, 0, 4) eq 'auto') || ($name eq 'Config.pm')) { + $installlib = $installarchlib; + return unless $do_installarchlib; + } else { + return unless $do_installprivlib; + } + + &makedir("$installlib/$dir"); + + if (-f $_) { + system "cmp", "-s", $_, "$installlib/$name"; + if ($?) { + &unlink("$installlib/$name"); + &cmd("cp $_ $installlib/$dir"); + &chmod(0644, "$installlib/$name"); + } + } elsif (-d $_) { + &makedir("$installlib/$name"); + } +} diff --git a/internals b/internals deleted file mode 100644 index fbf686e0c1..0000000000 --- a/internals +++ /dev/null @@ -1,321 +0,0 @@ -Newsgroups: comp.lang.perl -Subject: Re: perl5a4: tie ref restriction? -Summary: -Expires: -References: <2h7b64$aai@jethro.Corp.Sun.COM> -Sender: -Followup-To: -Distribution: world -Organization: NetLabs, Inc. -Keywords: - -In article <2h7b64$aai@jethro.Corp.Sun.COM> Eric.Arnold@Sun.COM writes: -: Darn: -: tie ( @a, TST_tie, "arg1", "arg2" ); -: $a[2]=[1]; -: -: produces: -: -: Can't assign a reference to a magical variable at ./tsttie line 12. -: -: I'm all agog about the "tie" function, but ... if this restriction -: wasn't there, I think I would be able to tie a top level -: reference/variable to my own package, and then automatically tie in all -: subsequently linked vars/references so that I could "tie" any arbitrary thing -: like: -: $r->{key}[el]{key} -: -: to a DBM or other type storage area. -: -: Is the restriction necessary? - -In the current storage scheme, yes, but as I mentioned in the other -article, I can and probably should relax that. That code is some of -the oldest Perl 5 code, and I didn't see some things then that I do -now. - -[I did relax that.] - -Ok, let me explain some things about how values are stored. Consider -this a little design document. - -Internally everything is unified to look like a scalar, regardless of -its type. There's a type-invariant part of every value, and a -type-variant part. When we modify the type of a value, we can do it in -place because all references point to the invariant part. All we do is -swap the variant part for a different part and change that ANY pointer -in the invariant part to point to the new variant. - -The invariant part looks like this: - -struct sv { - void* sv_any; /* pointer to something */ - U32 sv_refcnt; /* how many references to us */ - SVTYPE sv_type; /* what sort of thing pointer points to */ - U8 sv_flags; /* extra flags, some depending on type */ - U8 sv_storage; /* storage class */ - U8 sv_private; /* extra value, depending on type */ -}; - -[The last 4 bytes have been combined into a single U32.] - -This is typedefed to SV. There are other structurally equivalent -types, AV, HV and CV, that are there merely to help gdb know what kind -of pointer sv_any is, and provide a little bit of C type-checking. -Here's a key to Perl naming: - - SV scalar value - AV array value - HV hash value - CV code value - -Additionally I often use names containing - - IV integer value - NV numeric value (double) - PV pointer value - RV reference value - LV lvalue, such as a substr() or vec() being assigned to - BM a string containing a Boyer-Moore compiled pattern - FM a format line program - -You'll notice that in SV there's an sv_type field. This contains one -of the following values, which gives the interpretation of sv_any. - -typedef enum { - SVt_NULL, - SVt_REF, - SVt_IV, - SVt_NV, - SVt_PV, - SVt_PVIV, - SVt_PVNV, - SVt_PVMG, - SVt_PVLV, - SVt_PVAV, - SVt_PVHV, - SVt_PVCV, - SVt_PVGV, - SVt_PVBM, - SVt_PVFM, -} svtype; - -[There is no longer a REF type. There's an RV type that holds a minimal ref -value but other types can also hold an RV. This was to allow magical refs.] - -These are arranged ROUGHLY in order of increasing complexity, though -there are some discontinuities. Many of them indicate that sv_any -points to a struct of a similar name with an X on the front. They can -be classified like this: - - SVt_NULL - The sv_any doesn't point to anything meaningful. - - SVt_REF - The sv_any points to another SV. (This is what we're talking - about changing to work more like IV and NV below.) [And that's what - I did.] - - SVt_IV - SVt_NV - These are a little tricky in order to be efficient in both - memory and time. The sv_any pointer indicates the location of - a solitary integer(double), but not directly. The pointer is - really a pointer to an XPVIV(XPVNV), so that if there's a valid - integer(double) the same code works regardless of the type of - the SV. They have special allocators that guarantee that, even - though sv_any is pointing to a location several words earlier - than the integer(double), it never points to unallocated - memory. This does waste a few allocated integers(doubles) at - the beginning, but it's probably an overall win. - - [SVt_RV probably belongs here.] - SVt_PV - SVt_PVIV - SVt_PVNV - SVt_PVMG - These are pretty ordinary, and each is "derived" from the - previous in the sense that it just adds more data to the - previous structure. -[ Need to add this: - struct xrv { - SV * xrv_rv; /* pointer to another SV */ - }; - - A reference value. In the following structs its space is reserved - as a char* xpv_pv, but if SvROK() is true, xpv_pv is pointing to - another SV, not a string. -] - - struct xpv { - char * xpv_pv; /* pointer to malloced string */ - STRLEN xpv_cur; /* length of xpv_pv as a C string */ - STRLEN xpv_len; /* allocated size */ - }; - - This is your basic string scalar that is never used numerically - or magically. - - struct xpviv { - char * xpv_pv; /* pointer to malloced string */ - STRLEN xpv_cur; /* length of xpv_pv as a C string */ - STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ - }; - - This is a string scalar that has either been used as an - integer, or an integer that has been used in a string - context, or has had the front trimmed off of it, in which - case xiv_iv contains how far xpv_pv has been incremented - from the original allocated value. - - struct xpvnv { - char * xpv_pv; /* pointer to malloced string */ - STRLEN xpv_cur; /* length of xpv_pv as a C string */ - STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ - double xnv_nv; /* numeric value, if any */ - }; - - This is a string or integer scalar that has been used in a - numeric context, or a number that has been used in a string - or integer context. - - struct xpvmg { - char * xpv_pv; /* pointer to malloced string */ - STRLEN xpv_cur; /* length of xpv_pv as a C string */ - STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ - double xnv_nv; /* numeric value, if any */ - MAGIC* xmg_magic; /* linked list of magicalness */ - HV* xmg_stash; /* class package */ - }; - - This is the top of the line for ordinary scalars. This scalar - has been charmed with one or more kinds of magical or object - behavior. In addition it can contain any or all of integer, - double or string. - - SVt_PVLV - SVt_PVAV - SVt_PVHV - SVt_PVCV - SVt_PVGV - SVt_PVBM - SVt_PVFM - These are specialized forms that are never directly visible to - the Perl script. They are independent of each other, and may - not be promoted to any other type. - [Actually, PVBM doesn't belong here, but in the previous section. - saying index($foo,$bar) will in fact turn $bar into a PVBM so that - it can do Boyer-Moore searching.] - -There are several additional data values in the SV structure. The sv_refcnt -gives the number of references to this SV. Some of these references may be -actual Perl language references, but many other are just internal pointers, -from a symbol table, or from the syntax tree, for example. When sv_refcnt -goes to zero, the value can be safely deallocated. Must be, in fact. - -The sv_storage byte is not very well thought out, but tends to indicate -something about where the scalar lives. It's used in allocating -lexical storage, and at runtime contains an 'O' if the value has been -blessed as an object. There may be some conflicts lurking in here, and -I may eventually claim some of the bits for other purposes. [I did, -with a vengeance.] - -The sv_flags are currently as follows. Most of these are set and cleared -by macros to guarantee their consistency, and you should always use the -proper macro rather than accessing them directly. - -[Most of these numbers have changed, and there are some new flags. -And they're all stuffed into a single U32.] - -#define SVf_IOK 1 /* has valid integer value */ -#define SVf_NOK 2 /* has valid numeric value */ -#define SVf_POK 4 /* has valid pointer value */ - These tell whether an integer, double or string value is - immediately available without further consideration. All tainting - and magic (but not objecthood) works by turning off these bits and - forcing a routine to be executed to discover the real value. The - SvIV(), SvNV() and SvPV() macros that fetch values are smart about - all this, and should always be used if possible. Most of the stuff - mentioned below you really don't have to deal with directly. (Values - aren't stored using macros, but using functions sv_setiv(), sv_setnv() - and sv_setpv(), plus variants. You should never have to explicitly - follow the sv_any pointer to any X structure in your code.) - -#define SVf_OOK 8 /* has valid offset value */ - This is only on when SVf_IOK is off, and indicates that the unused - integer storage is holding an offset for the string pointer value - because you've done something like s/^prefix//. - -#define SVf_MAGICAL 16 /* has special methods */ - This indicates not only that sv_type is at least SVt_PVMG, but - also that the linked list of magical behaviors is not empty. - -#define SVf_OK 32 /* has defined value */ - This indicates that the value is defined. Currently it means either - that the type if SVt_REF or that one of SVf_IOK, SVf_NOK, or SVf_POK - is set. - -#define SVf_TEMP 64 /* eventually in sv_private? */ - This indicates that the string is a temporary allocated by one of - the sv_mortal functions, and that any string value may be stolen - from it without copying. (It's important not to steal the value if - the temporary will continue to require the value, however.) - -#define SVf_READONLY 128 /* may not be modified */ - This scalar value may not be modified. Any function that might modify - a scalar should check for this first, and reject the operation when - inappropriate. Currently only the builtin values for sv_undef, sv_yes - and sv_no are marked readonly, but eventually we may provide a language - to set this bit. - -The sv_private byte contains some additional bits that apply across the -board. Really private bits (that depend on the type) are allocated from -128 down. - -#define SVp_IOK 1 /* has valid non-public integer value */ -#define SVp_NOK 2 /* has valid non-public numeric value */ -#define SVp_POK 4 /* has valid non-public pointer value */ - These shadow the bits in sv_flags for tainted variables, indicated that - there really is a valid value available, but you have to set the global - tainted flag if you acces them. - -#define SVp_SCREAM 8 /* has been studied? */ - Indicates that a study was done on this string. A studied string is - magical and automatically unstudies itself when modified. - -#define SVp_TAINTEDDIR 16 /* PATH component is a security risk */ - A special flag for $ENV{PATH} that indicates that, while the value - as a whole may be untainted, some path component names an insecure - directory. - -#define SVpfm_COMPILED 128 - For a format, whether its picture has been "compiled" yet. This - cannot be done until runtime because the user has access to the - internal formline function, and may supply a variable as the - picture. - -#define SVpbm_VALID 128 -#define SVpbm_CASEFOLD 64 -#define SVpbm_TAIL 32 - For a Boyer-Moore pattern, whether the search string has been invalidated - by modification (can happen to $pat between calls to index($string,$pat)), - whether case folding is in force for regexp matching, and whether we're - trying to match something like /foo$/. - -#define SVpgv_MULTI 128 - For a symbol table entry, set when we've decided that this symbol is - probably not a typo. Suspected typos can be reported by -w. - - -Well, that's probably enough for now. As you can see, we could turn -references into something more like an integer or a pointer value. In -fact, I suspect the right thing to do is say that a reference is just -a funny type of string pointer that isn't allocated the same way. -This would let us not only have references to scalars, but might provide -a way to have scalars that point to non-malloced memory. Hmm. I'll -have to think about that s'more. You can think about it too. - -Larry diff --git a/interp.sym b/interp.sym index 6628a3c7a4..ef880908ca 100644 --- a/interp.sym +++ b/interp.sym @@ -10,7 +10,6 @@ allgvs ampergv argvgv argvoutgv -arybase basetime beginav bodytarget @@ -20,7 +19,6 @@ copline curblock curcop curcsv -curoutgv curpm curstash curstname @@ -114,6 +112,7 @@ rs rschar rslen rspara +runlevel sawampersand sawi sawstudy @@ -135,7 +134,7 @@ statusvalue stdingv strchop sv_count -sv_rvcount +sv_objcount sv_root sv_arenaroot tainted diff --git a/keywords.h b/keywords.h index 14aa7322e6..49f4d20944 100644 --- a/keywords.h +++ b/keywords.h @@ -4,42 +4,42 @@ #define KEY___END__ 3 #define KEY_AUTOLOAD 4 #define KEY_BEGIN 5 -#define KEY_DESTROY 6 -#define KEY_END 7 -#define KEY_EQ 8 -#define KEY_GE 9 -#define KEY_GT 10 -#define KEY_LE 11 -#define KEY_LT 12 -#define KEY_NE 13 -#define KEY_abs 14 -#define KEY_accept 15 -#define KEY_alarm 16 -#define KEY_and 17 -#define KEY_atan2 18 -#define KEY_aver 19 +#define KEY_CORE 6 +#define KEY_DESTROY 7 +#define KEY_END 8 +#define KEY_EQ 9 +#define KEY_GE 10 +#define KEY_GT 11 +#define KEY_LE 12 +#define KEY_LT 13 +#define KEY_NE 14 +#define KEY_abs 15 +#define KEY_accept 16 +#define KEY_alarm 17 +#define KEY_and 18 +#define KEY_atan2 19 #define KEY_bind 20 #define KEY_binmode 21 #define KEY_bless 22 #define KEY_caller 23 #define KEY_chdir 24 #define KEY_chmod 25 -#define KEY_chop 26 -#define KEY_chown 27 -#define KEY_chr 28 -#define KEY_chroot 29 -#define KEY_close 30 -#define KEY_closedir 31 -#define KEY_cmp 32 -#define KEY_connect 33 -#define KEY_continue 34 -#define KEY_cos 35 -#define KEY_crypt 36 -#define KEY_dbmclose 37 -#define KEY_dbmopen 38 -#define KEY_defined 39 -#define KEY_delete 40 -#define KEY_deny 41 +#define KEY_chomp 26 +#define KEY_chop 27 +#define KEY_chown 28 +#define KEY_chr 29 +#define KEY_chroot 30 +#define KEY_close 31 +#define KEY_closedir 32 +#define KEY_cmp 33 +#define KEY_connect 34 +#define KEY_continue 35 +#define KEY_cos 36 +#define KEY_crypt 37 +#define KEY_dbmclose 38 +#define KEY_dbmopen 39 +#define KEY_defined 40 +#define KEY_delete 41 #define KEY_die 42 #define KEY_do 43 #define KEY_dump 44 @@ -56,178 +56,186 @@ #define KEY_eq 55 #define KEY_eval 56 #define KEY_exec 57 -#define KEY_exit 58 -#define KEY_exp 59 -#define KEY_fcntl 60 -#define KEY_fileno 61 -#define KEY_flock 62 -#define KEY_for 63 -#define KEY_foreach 64 -#define KEY_fork 65 -#define KEY_format 66 -#define KEY_formline 67 -#define KEY_ge 68 -#define KEY_getc 69 -#define KEY_getgrent 70 -#define KEY_getgrgid 71 -#define KEY_getgrnam 72 -#define KEY_gethostbyaddr 73 -#define KEY_gethostbyname 74 -#define KEY_gethostent 75 -#define KEY_getlogin 76 -#define KEY_getnetbyaddr 77 -#define KEY_getnetbyname 78 -#define KEY_getnetent 79 -#define KEY_getpeername 80 -#define KEY_getpgrp 81 -#define KEY_getppid 82 -#define KEY_getpriority 83 -#define KEY_getprotobyname 84 -#define KEY_getprotobynumber 85 -#define KEY_getprotoent 86 -#define KEY_getpwent 87 -#define KEY_getpwnam 88 -#define KEY_getpwuid 89 -#define KEY_getservbyname 90 -#define KEY_getservbyport 91 -#define KEY_getservent 92 -#define KEY_getsockname 93 -#define KEY_getsockopt 94 -#define KEY_glob 95 -#define KEY_gmtime 96 -#define KEY_goto 97 -#define KEY_grep 98 -#define KEY_gt 99 -#define KEY_hex 100 -#define KEY_if 101 -#define KEY_index 102 -#define KEY_int 103 -#define KEY_ioctl 104 -#define KEY_join 105 -#define KEY_keys 106 -#define KEY_kill 107 -#define KEY_last 108 -#define KEY_lc 109 -#define KEY_lcfirst 110 -#define KEY_le 111 -#define KEY_length 112 -#define KEY_link 113 -#define KEY_listen 114 -#define KEY_local 115 -#define KEY_localtime 116 -#define KEY_log 117 -#define KEY_lstat 118 -#define KEY_lt 119 -#define KEY_m 120 -#define KEY_mkdir 121 -#define KEY_msgctl 122 -#define KEY_msgget 123 -#define KEY_msgrcv 124 -#define KEY_msgsnd 125 -#define KEY_my 126 -#define KEY_ne 127 -#define KEY_next 128 -#define KEY_oct 129 -#define KEY_open 130 -#define KEY_opendir 131 -#define KEY_or 132 -#define KEY_ord 133 -#define KEY_pack 134 -#define KEY_package 135 -#define KEY_pipe 136 -#define KEY_pop 137 -#define KEY_print 138 -#define KEY_printf 139 -#define KEY_push 140 -#define KEY_q 141 -#define KEY_qq 142 -#define KEY_qw 143 -#define KEY_qx 144 -#define KEY_rand 145 -#define KEY_read 146 -#define KEY_readdir 147 -#define KEY_readline 148 -#define KEY_readlink 149 -#define KEY_readpipe 150 -#define KEY_recv 151 -#define KEY_redo 152 -#define KEY_ref 153 -#define KEY_rename 154 -#define KEY_require 155 -#define KEY_reset 156 -#define KEY_return 157 -#define KEY_reverse 158 -#define KEY_rewinddir 159 -#define KEY_rindex 160 -#define KEY_rmdir 161 -#define KEY_s 162 -#define KEY_scalar 163 -#define KEY_seek 164 -#define KEY_seekdir 165 -#define KEY_select 166 -#define KEY_semctl 167 -#define KEY_semget 168 -#define KEY_semop 169 -#define KEY_send 170 -#define KEY_setgrent 171 -#define KEY_sethostent 172 -#define KEY_setnetent 173 -#define KEY_setpgrp 174 -#define KEY_setpriority 175 -#define KEY_setprotoent 176 -#define KEY_setpwent 177 -#define KEY_setservent 178 -#define KEY_setsockopt 179 -#define KEY_shift 180 -#define KEY_shmctl 181 -#define KEY_shmget 182 -#define KEY_shmread 183 -#define KEY_shmwrite 184 -#define KEY_shutdown 185 -#define KEY_sin 186 -#define KEY_sleep 187 -#define KEY_socket 188 -#define KEY_socketpair 189 -#define KEY_sort 190 -#define KEY_splice 191 -#define KEY_split 192 -#define KEY_sprintf 193 -#define KEY_sqrt 194 -#define KEY_srand 195 -#define KEY_stat 196 -#define KEY_study 197 -#define KEY_sub 198 -#define KEY_substr 199 -#define KEY_symlink 200 -#define KEY_syscall 201 -#define KEY_sysread 202 -#define KEY_system 203 -#define KEY_syswrite 204 -#define KEY_tell 205 -#define KEY_telldir 206 -#define KEY_tie 207 -#define KEY_time 208 -#define KEY_times 209 -#define KEY_tr 210 -#define KEY_truncate 211 -#define KEY_uc 212 -#define KEY_ucfirst 213 -#define KEY_umask 214 -#define KEY_undef 215 -#define KEY_unless 216 -#define KEY_unlink 217 -#define KEY_unpack 218 -#define KEY_unshift 219 -#define KEY_untie 220 -#define KEY_until 221 -#define KEY_utime 222 -#define KEY_values 223 -#define KEY_vec 224 -#define KEY_wait 225 -#define KEY_waitpid 226 -#define KEY_wantarray 227 -#define KEY_warn 228 -#define KEY_while 229 -#define KEY_write 230 -#define KEY_x 231 -#define KEY_y 232 +#define KEY_exists 58 +#define KEY_exit 59 +#define KEY_exp 60 +#define KEY_fcntl 61 +#define KEY_fileno 62 +#define KEY_flock 63 +#define KEY_for 64 +#define KEY_foreach 65 +#define KEY_fork 66 +#define KEY_format 67 +#define KEY_formline 68 +#define KEY_ge 69 +#define KEY_getc 70 +#define KEY_getgrent 71 +#define KEY_getgrgid 72 +#define KEY_getgrnam 73 +#define KEY_gethostbyaddr 74 +#define KEY_gethostbyname 75 +#define KEY_gethostent 76 +#define KEY_getlogin 77 +#define KEY_getnetbyaddr 78 +#define KEY_getnetbyname 79 +#define KEY_getnetent 80 +#define KEY_getpeername 81 +#define KEY_getpgrp 82 +#define KEY_getppid 83 +#define KEY_getpriority 84 +#define KEY_getprotobyname 85 +#define KEY_getprotobynumber 86 +#define KEY_getprotoent 87 +#define KEY_getpwent 88 +#define KEY_getpwnam 89 +#define KEY_getpwuid 90 +#define KEY_getservbyname 91 +#define KEY_getservbyport 92 +#define KEY_getservent 93 +#define KEY_getsockname 94 +#define KEY_getsockopt 95 +#define KEY_glob 96 +#define KEY_gmtime 97 +#define KEY_goto 98 +#define KEY_grep 99 +#define KEY_gt 100 +#define KEY_hex 101 +#define KEY_if 102 +#define KEY_index 103 +#define KEY_int 104 +#define KEY_ioctl 105 +#define KEY_join 106 +#define KEY_keys 107 +#define KEY_kill 108 +#define KEY_last 109 +#define KEY_lc 110 +#define KEY_lcfirst 111 +#define KEY_le 112 +#define KEY_length 113 +#define KEY_link 114 +#define KEY_listen 115 +#define KEY_local 116 +#define KEY_localtime 117 +#define KEY_log 118 +#define KEY_lstat 119 +#define KEY_lt 120 +#define KEY_m 121 +#define KEY_map 122 +#define KEY_mkdir 123 +#define KEY_msgctl 124 +#define KEY_msgget 125 +#define KEY_msgrcv 126 +#define KEY_msgsnd 127 +#define KEY_my 128 +#define KEY_ne 129 +#define KEY_next 130 +#define KEY_no 131 +#define KEY_not 132 +#define KEY_oct 133 +#define KEY_open 134 +#define KEY_opendir 135 +#define KEY_or 136 +#define KEY_ord 137 +#define KEY_pack 138 +#define KEY_package 139 +#define KEY_pipe 140 +#define KEY_pop 141 +#define KEY_pos 142 +#define KEY_print 143 +#define KEY_printf 144 +#define KEY_push 145 +#define KEY_q 146 +#define KEY_qq 147 +#define KEY_quotemeta 148 +#define KEY_qw 149 +#define KEY_qx 150 +#define KEY_rand 151 +#define KEY_read 152 +#define KEY_readdir 153 +#define KEY_readline 154 +#define KEY_readlink 155 +#define KEY_readpipe 156 +#define KEY_recv 157 +#define KEY_redo 158 +#define KEY_ref 159 +#define KEY_rename 160 +#define KEY_require 161 +#define KEY_reset 162 +#define KEY_return 163 +#define KEY_reverse 164 +#define KEY_rewinddir 165 +#define KEY_rindex 166 +#define KEY_rmdir 167 +#define KEY_s 168 +#define KEY_scalar 169 +#define KEY_seek 170 +#define KEY_seekdir 171 +#define KEY_select 172 +#define KEY_semctl 173 +#define KEY_semget 174 +#define KEY_semop 175 +#define KEY_send 176 +#define KEY_setgrent 177 +#define KEY_sethostent 178 +#define KEY_setnetent 179 +#define KEY_setpgrp 180 +#define KEY_setpriority 181 +#define KEY_setprotoent 182 +#define KEY_setpwent 183 +#define KEY_setservent 184 +#define KEY_setsockopt 185 +#define KEY_shift 186 +#define KEY_shmctl 187 +#define KEY_shmget 188 +#define KEY_shmread 189 +#define KEY_shmwrite 190 +#define KEY_shutdown 191 +#define KEY_sin 192 +#define KEY_sleep 193 +#define KEY_socket 194 +#define KEY_socketpair 195 +#define KEY_sort 196 +#define KEY_splice 197 +#define KEY_split 198 +#define KEY_sprintf 199 +#define KEY_sqrt 200 +#define KEY_srand 201 +#define KEY_stat 202 +#define KEY_study 203 +#define KEY_sub 204 +#define KEY_substr 205 +#define KEY_symlink 206 +#define KEY_syscall 207 +#define KEY_sysread 208 +#define KEY_system 209 +#define KEY_syswrite 210 +#define KEY_tell 211 +#define KEY_telldir 212 +#define KEY_tie 213 +#define KEY_time 214 +#define KEY_times 215 +#define KEY_tr 216 +#define KEY_truncate 217 +#define KEY_uc 218 +#define KEY_ucfirst 219 +#define KEY_umask 220 +#define KEY_undef 221 +#define KEY_unless 222 +#define KEY_unlink 223 +#define KEY_unpack 224 +#define KEY_unshift 225 +#define KEY_untie 226 +#define KEY_until 227 +#define KEY_use 228 +#define KEY_utime 229 +#define KEY_values 230 +#define KEY_vec 231 +#define KEY_wait 232 +#define KEY_waitpid 233 +#define KEY_wantarray 234 +#define KEY_warn 235 +#define KEY_while 236 +#define KEY_write 237 +#define KEY_x 238 +#define KEY_xor 239 +#define KEY_y 240 diff --git a/keywords.pl b/keywords.pl new file mode 100755 index 0000000000..d3426be313 --- /dev/null +++ b/keywords.pl @@ -0,0 +1,266 @@ +#!/usr/bin/perl + +open(KW, ">keywords.h") || die "Can't create keywords.h: $!\n"; +select KW; + +# Read & print data. + +$keynum = 0; +while (<DATA>) { + chop; + next unless $_; + next if /^#/; + ($keyword) = split; + print &tab(5, "#define KEY_$keyword"), $keynum++, "\n"; +} + +########################################################################### +sub tab { + local($l, $t) = @_; + $t .= "\t" x ($l - (length($t) + 1) / 8); + $t; +} +########################################################################### +__END__ + +NULL +__LINE__ +__FILE__ +__END__ +AUTOLOAD +BEGIN +CORE +DESTROY +END +EQ +GE +GT +LE +LT +NE +abs +accept +alarm +and +atan2 +bind +binmode +bless +caller +chdir +chmod +chomp +chop +chown +chr +chroot +close +closedir +cmp +connect +continue +cos +crypt +dbmclose +dbmopen +defined +delete +die +do +dump +each +else +elsif +endgrent +endhostent +endnetent +endprotoent +endpwent +endservent +eof +eq +eval +exec +exists +exit +exp +fcntl +fileno +flock +for +foreach +fork +format +formline +ge +getc +getgrent +getgrgid +getgrnam +gethostbyaddr +gethostbyname +gethostent +getlogin +getnetbyaddr +getnetbyname +getnetent +getpeername +getpgrp +getppid +getpriority +getprotobyname +getprotobynumber +getprotoent +getpwent +getpwnam +getpwuid +getservbyname +getservbyport +getservent +getsockname +getsockopt +glob +gmtime +goto +grep +gt +hex +if +index +int +ioctl +join +keys +kill +last +lc +lcfirst +le +length +link +listen +local +localtime +log +lstat +lt +m +map +mkdir +msgctl +msgget +msgrcv +msgsnd +my +ne +next +no +not +oct +open +opendir +or +ord +pack +package +pipe +pop +pos +print +printf +push +q +qq +quotemeta +qw +qx +rand +read +readdir +readline +readlink +readpipe +recv +redo +ref +rename +require +reset +return +reverse +rewinddir +rindex +rmdir +s +scalar +seek +seekdir +select +semctl +semget +semop +send +setgrent +sethostent +setnetent +setpgrp +setpriority +setprotoent +setpwent +setservent +setsockopt +shift +shmctl +shmget +shmread +shmwrite +shutdown +sin +sleep +socket +socketpair +sort +splice +split +sprintf +sqrt +srand +stat +study +sub +substr +symlink +syscall +sysread +system +syswrite +tell +telldir +tie +time +times +tr +truncate +uc +ucfirst +umask +undef +unless +unlink +unpack +unshift +untie +until +use +utime +values +vec +wait +waitpid +wantarray +warn +while +write +x +xor +y diff --git a/lib/AnyDBM_File.pm b/lib/AnyDBM_File.pm new file mode 100644 index 0000000000..ff9078652e --- /dev/null +++ b/lib/AnyDBM_File.pm @@ -0,0 +1,9 @@ +package AnyDBM_File; + +@ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; + +eval { require NDBM_File } || +eval { require DB_File } || +eval { require GDBM_File } || +eval { require SDBM_File } || +eval { require ODBM_File }; diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index dba8ca2f5f..3f5eef2375 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -1,13 +1,23 @@ package AutoLoader; +use Carp; AUTOLOAD { my $name = "auto/$AUTOLOAD.al"; $name =~ s#::#/#g; eval {require $name}; if ($@) { - ($p,$f,$l) = caller($AutoLevel); - $@ =~ s/ at .*\n//; - die "$@ at $f line $l\n"; + # The load might just have failed because the filename was too + # long for some old SVR3 systems which treat long names as errors. + # If we can succesfully truncate a long name then it's worth a go. + # There is a slight risk that we could pick up the wrong file here + # but autosplit should have warned about that when splitting. + if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval {require $name}; + } + if ($@){ + $@ =~ s/ at .*\n//; + croak $@; + } } goto &$AUTOLOAD; } diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm new file mode 100644 index 0000000000..dabf43cbb8 --- /dev/null +++ b/lib/AutoSplit.pm @@ -0,0 +1,225 @@ +package AutoSplit; + +require 5.000; +require Exporter; + +use Config; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(&autosplit &autosplit_lib_modules); +@EXPORT_OK = qw($Verbose $Keep); + +# for portability warn about names longer than $maxlen +$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3 +$Verbose = 1; # 0=none, 1=minimal, 2=list .al files +$Keep = 0; +$IndexFile = "autosplit.ix"; # file also serves as timestamp + +$maxflen = 255; +$maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; +$vms = ($Config{'osname'} eq 'VMS'); + +sub autosplit{ + my($file, $autodir) = @_; + autosplit_file($file, $autodir, $Keep, 1, 0); +} + + + +# 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 + + foreach(@modules){ + s#::#/#g; # incase specified as ABC::XYZ + s#^lib/##; # incase specified as lib/*.pm + if ($vms && /[:>\]]/) { # may need to convert VMS-style filespecs + my ($dir,$name) = (/(.*])(.*)/); + $dir =~ s/.*lib[\.\]]//; + $dir =~ s#[\.\]]#/#g; + $_ = $dir . $name; + } + autosplit_file("lib/$_", "lib/auto", $Keep, 1, 1); + } + 0; +} + + +# private functions + +sub autosplit_file{ + my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; + my(@names); + + # where to write output files + $autodir = "lib/auto" unless $autodir; + die "autosplit directory $autodir does not exist" unless -d $autodir; + + # allow just a package name to be used + $filename .= ".pm" unless ($filename =~ m/\.pm$/); + + open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n"; + my($pm_mod_time) = (stat($filename))[9]; + my($autoloader_seen) = 0; + while (<IN>) { + # record last package name seen + $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); + ++$autoloader_seen if m/^\s*use\s+AutoLoader\b/; + ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; + last if /^__END__/; + } + return 0 if ($check_for_autoloader && !$autoloader_seen); + $_ or die "Can't find __END__ in $filename\n"; + + $package or die "Can't find 'package Name;' in $filename\n"; + + my($modpname) = $package; $modpname =~ s#::#/#g; + my($al_idx_file) = "$autodir/$modpname/$IndexFile"; + + die "Package $package does not match filename $filename" + unless ($filename =~ m/$modpname.pm$/ or + $vms && $filename =~ m/$modpname.pm/i); + + if ($check_mod_time){ + my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; + if ($al_ts_time >= $pm_mod_time){ + print "AutoSplit skipped ($al_idx_file newer that $filename)\n" + if ($Verbose >= 2); + return undef; # one undef, not a list + } + } + + my($from) = ($Verbose>=2) ? "$filename => " : ""; + print "AutoSplitting $package ($from$autodir/$modpname)\n" + if $Verbose; + + unless (-d "$autodir/$modpname"){ + local($", @p)="/"; + foreach(split(/\//,"$autodir/$modpname")){ + push(@p, $_); + next if -d "@p"; + mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!"; + } + } + + # We must try to deal with some SVR3 systems with a limit of 14 + # characters for file names. Sadly we *cannot* simply truncate all + # file names to 14 characters on these systems because we *must* + # create filenames which exactly match the names used by AutoLoader.pm. + # This is a problem because some systems silently truncate the file + # names while others treat long file names as an error. + + # We do not yet deal with multiple packages within one file. + # Ideally both of these styles should work. + # + # package NAME; + # __END__ + # sub AAA { ... } + # package NAME::option1; + # sub BBB { ... } + # package NAME::option2; + # sub BBB { ... } + # + # package NAME; + # __END__ + # sub AAA { ... } + # sub NAME::option1::BBB { ... } + # sub NAME::option2::BBB { ... } + # + # For now both of these produce warnings. + + open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning + my(@subnames); + while (<IN>) { + if (/^package ([\w:]+)\s*;/) { + warn "package $1; in AutoSplit section ignored. Not currently supported."; + } + if (/^sub ([\w:]+)/) { + print OUT "1;\n"; + my($subname) = $1; + if ($subname =~ m/::/){ + warn "subs with package names not currently supported in AutoSplit section"; + } + push(@subnames, $subname); + my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); + my($lpath) = "$autodir/$modpname/$lname.al"; + my($spath) = "$autodir/$modpname/$sname.al"; + unless(open(OUT, ">$lpath")){ + open(OUT, ">$spath") or die "Can't create $spath: $!\n"; + push(@names, $sname); + print " writing $spath (with truncated name)\n" + if ($Verbose>=1); + }else{ + push(@names, $lname); + print " writing $lpath\n" if ($Verbose>=2); + } + print OUT "# NOTE: Derived from $filename. ", + "Changes made here will be lost.\n"; + print OUT "package $package;\n\n"; + } + print OUT $_; + } + print OUT "1;\n"; + close(OUT); + close(IN); + + if (!$keep){ # don't keep any obsolete *.al files in the directory + my(%names); + @names{@names} = @names; + opendir(OUTDIR,"$autodir/$modpname"); + foreach(sort readdir(OUTDIR)){ + next unless /\.al$/; + my($subname) = m/(.*)\.al$/; + next if $names{substr($subname,0,$maxflen-3)}; + my($file) = "$autodir/$modpname/$_"; + print " deleting $file\n" if ($Verbose>=2); + unlink $file or carp "Unable to delete $file: $!"; + } + closedir(OUTDIR); + } + + open(TS,">$al_idx_file") or + carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; + print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n"; + print TS map("sub $_ ;\n", @subnames); + close(TS); + + check_unique($package, $Maxlen, 1, @names); + + @names; +} + + +sub check_unique{ + my($module, $maxlen, $warn, @names) = @_; + my(%notuniq) = (); + my(%shorts) = (); + my(@toolong) = grep(length > $maxlen, @names); + + foreach(@toolong){ + my($trunc) = substr($_,0,$maxlen); + $notuniq{$trunc}=1 if $shorts{$trunc}; + $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_; + } + if (%notuniq && $warn){ + print "$module: some names are not unique when truncated to $maxlen characters:\n"; + foreach(keys %notuniq){ + print " $shorts{$_} truncate to $_\n"; + } + } + %notuniq; +} + +1; +__END__ + +# test functions so AutoSplit.pm can be applied to itself: +sub test1{ "test 1\n"; } +sub test2{ "test 2\n"; } +sub test3{ "test 3\n"; } +sub test4{ "test 4\n"; } + + diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm new file mode 100644 index 0000000000..a19caffdc8 --- /dev/null +++ b/lib/Benchmark.pm @@ -0,0 +1,245 @@ +package Benchmark; + +# Purpose: benchmark running times of code. +# +# +# Usage - to time code snippets and print results: +# +# timethis($count, '...code...'); +# +# prints: +# timethis 100: 2 secs ( 0.23 usr 0.10 sys = 0.33 cpu) +# +# +# timethese($count, { +# Name1 => '...code1...', +# Name2 => '...code2...', +# ... }); +# prints: +# Benchmark: timing 100 iterations of Name1, Name2... +# Name1: 2 secs ( 0.50 usr 0.00 sys = 0.50 cpu) +# Name2: 1 secs ( 0.48 usr 0.00 sys = 0.48 cpu) +# +# The default display style will automatically add child process +# values if non-zero. +# +# +# Usage - to time sections of your own code: +# +# use Benchmark; +# $t0 = new Benchmark; +# ... your code here ... +# $t1 = new Benchmark; +# $td = &timediff($t1, $t0); +# print "the code took:",timestr($td),"\n"; +# +# $t = &timeit($count, '...other code...') +# print "$count loops of other code took:",timestr($t),"\n"; +# +# +# Data format: +# The data is stored as a list of values from the time and times +# functions: ($real, $user, $system, $children_user, $children_system) +# in seconds for the whole loop (not divided by the number of rounds). +# +# Internals: +# The timing is done using time(3) and times(3). +# +# Code is executed in the callers package +# +# Enable debugging by: $Benchmark::debug = 1; +# +# The time of the null loop (a loop with the same +# number of rounds but empty loop body) is substracted +# from the time of the real loop. +# +# The null loop times are cached, the key being the +# number of rounds. The caching can be controlled using +# &clearcache($key); &clearallcache; +# &disablecache; &enablecache; +# +# Caveats: +# +# The real time timing is done using time(2) and +# the granularity is therefore only one second. +# +# Short tests may produce negative figures because perl +# can appear to take longer to execute the empty loop +# than a short test: try timethis(100,'1'); +# +# The system time of the null loop might be slightly +# more than the system time of the loop with the actual +# code and therefore the difference might end up being < 0 +# +# More documentation is needed :-( +# Especially for styles and formats. +# +# Authors: Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi> +# Tim Bunce <Tim.Bunce@ig.co.uk> +# +# +# Last updated: Sept 8th 94 by Tim Bunce +# + +use Exporter; +@ISA=(Exporter); +@EXPORT=qw(timeit timethis timethese timediff timestr); +@EXPORT_OK=qw(clearcache clearallcache disablecache enablecache); + +&init; + +sub init { + $debug = 0; + $min_count = 4; + $min_cpu = 0.4; + $defaultfmt = '5.2f'; + $defaultstyle = 'auto'; + # The cache can cause a slight loss of sys time accuracy. If a + # user does many tests (>10) with *very* large counts (>10000) + # or works on a very slow machine the cache may be useful. + &disablecache; + &clearallcache; +} + +sub clearcache { delete $cache{$_[0]}; } +sub clearallcache { %cache = (); } +sub enablecache { $cache = 1; } +sub disablecache { $cache = 0; } + + +# --- Functions to process the 'time' data type + +sub new { my(@t)=(time, times); print "new=@t\n" if $debug; bless \@t; } + +sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } +sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; } +sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; } +sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; } + +sub timediff{ + my($a, $b) = @_; + my(@r); + for($i=0; $i < @$a; ++$i){ + push(@r, $a->[$i] - $b->[$i]); + } + bless \@r; +} + +sub timestr{ + my($tr, $style, $f) = @_; + my(@t) = @$tr; + warn "bad time value" unless @t==5; + my($r, $pu, $ps, $cu, $cs) = @t; + my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); + $f = $defaultfmt unless $f; + # format a time in the required style, other formats may be added here + $style = $defaultstyle unless $style; + $style = ($ct>0) ? 'all' : 'noc' if $style=~/^auto$/; + my($s) = "@t $style"; # default for unknown style + $s=sprintf("%2d secs (%$f usr %$f sys + %$f cusr %$f csys = %$f cpu)", + @t,$t) if $style =~ /^all$/; + $s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)", + $r,$pu,$ps,$pt) if $style =~ /^noc$/; + $s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)", + $r,$cu,$cs,$ct) if $style =~ /^nop$/; + $s; +} +sub timedebug{ + my($msg, $t) = @_; + print STDERR "$msg",timestr($t),"\n" if ($debug); +} + + +# --- Functions implementing low-level support for timing loops + +sub runloop { + my($n, $c) = @_; + my($t0, $t1, $td); # before, after, difference + + # find package of caller so we can execute code there + my ($curpack) = caller(0); + my ($i, $pack)= 0; + while (($pack) = caller(++$i)) { + last if $pack ne $curpack; + } + + my $subcode = "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }"; + my $subref = eval $subcode; + die "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; + print STDERR "runloop $n '$subcode'\n" if ($debug); + + $t0 = &new; + &$subref; + $t1 = &new; + $td = &timediff($t1, $t0); + + timedebug("runloop:",$td); + $td; +} + + +sub timeit { + my($n, $code) = @_; + my($wn, $wc, $wd); + + printf STDERR "timeit $n $code\n" if $debug; + + if ($cache && exists $cache{$n}){ + $wn = $cache{$n}; + }else{ + $wn = &runloop($n, ''); + $cache{$n} = $wn; + } + + $wc = &runloop($n, $code); + + $wd = timediff($wc, $wn); + + timedebug("timeit: ",$wc); + timedebug(" - ",$wn); + timedebug(" = ",$wd); + + $wd; +} + + +# --- Functions implementing high-level time-then-print utilities + +sub timethis{ + my($n, $code, $title, $style) = @_; + my($t) = timeit($n, $code); + local($|) = 1; + $title = "timethis $n" unless $title; + $style = "" unless $style; + printf("%10s: ", $title); + print timestr($t, $style),"\n"; + # A conservative warning to spot very silly tests. + # Don't assume that your benchmark is ok simply because + # you don't get this warning! + print " (warning: too few iterations for a reliable count)\n" + if ( $n < $min_count + || ($t->real < 1 && $n < 1000) + || $t->cpu_a < $min_cpu); + $t; +} + + +sub timethese{ + my($n, $alt, $style) = @_; + die "usage: timethese(count, { 'Name1'=>'code1', ... }\n" + unless ref $alt eq HASH; + my(@all); + my(@names) = sort keys %$alt; + $style = "" unless $style; + print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n"; + foreach(@names){ + $t = timethis($n, $alt->{$_}, $_, $style); + push(@all, $t); + } + # we could produce a summary from @all here + # sum, min, max, avg etc etc + @all; +} + + +1; diff --git a/lib/Carp.pm b/lib/Carp.pm new file mode 100644 index 0000000000..5daba5c289 --- /dev/null +++ b/lib/Carp.pm @@ -0,0 +1,37 @@ +package Carp; + +# This package implements handy routines for modules that wish to throw +# exceptions outside of the current package. + +require Exporter; +@ISA = Exporter; +@EXPORT = qw(confess croak carp); + +sub longmess { + my $error = shift; + my $mess = ""; + my $i = 2; + my ($pack,$file,$line,$sub); + while (($pack,$file,$line,$sub) = caller($i++)) { + $mess .= "\t$sub " if $error eq "called"; + $mess .= "$error at $file line $line\n"; + $error = "called"; + } + $mess || $error; +} + +sub shortmess { + my $error = shift; + my ($curpack) = caller(1); + my $i = 2; + my ($pack,$file,$line,$sub); + while (($pack,$file,$line,$sub) = caller($i++)) { + return "$error at $file line $line\n" if $pack ne $curpack; + } + longmess $error; +} + +sub confess { die longmess @_; } +sub croak { die shortmess @_; } +sub carp { warn shortmess @_; } + diff --git a/lib/Config.pm b/lib/Config.pm deleted file mode 100644 index 20df7e009d..0000000000 --- a/lib/Config.pm +++ /dev/null @@ -1,362 +0,0 @@ -package Config; -require Exporter; -@ISA = (Exporter); -@EXPORT = qw(%Config); - -$] == 5.000 or die sprintf - "Perl lib version (5.000) doesn't match executable version (%.3f)\n", $]; - - -# -# This file was produced by running the Configure script. It holds all the -# definitions figured out by Configure. Should you modify one of these values, -# do not forget to propagate your changes by running "Configure -der". You may -# instead choose to run each of the .SH files by yourself, or "Configure -S". -# - -# Configuration time: Wed May 4 15:10:39 PDT 1994 -# Configured by: lwall -# Target system: sunos scalpel 4.1.3 3 sun4c - -$Config{'extensions'} = ' ext/dbm/NDBM_File.xs ext/dbm/ODBM_File.xs ext/dbm/SDBM_File.xs ext/posix/POSIX.xs'; -$Config{'d_eunice'} = undef; -$Config{'d_xenix'} = undef; -$Config{'eunicefix'} = ':'; -$Config{'Mcc'} = 'Mcc'; -$Config{'awk'} = '/bin/awk'; -$Config{'bash'} = ''; -$Config{'bison'} = '/usr/local/bin/bison'; -$Config{'byacc'} = 'byacc'; -$Config{'cat'} = '/bin/cat'; -$Config{'chgrp'} = ''; -$Config{'chmod'} = ''; -$Config{'chown'} = ''; -$Config{'compress'} = ''; -$Config{'cp'} = '/bin/cp'; -$Config{'cpio'} = ''; -$Config{'cpp'} = '/usr/lib/cpp'; -$Config{'csh'} = '/bin/csh'; -$Config{'date'} = '/bin/date'; -$Config{'echo'} = '/bin/echo'; -$Config{'egrep'} = '/bin/egrep'; -$Config{'emacs'} = ''; -$Config{'expr'} = '/bin/expr'; -$Config{'find'} = '/bin/find'; -$Config{'flex'} = ''; -$Config{'gcc'} = ''; -$Config{'grep'} = '/bin/grep'; -$Config{'inews'} = ''; -$Config{'ksh'} = ''; -$Config{'less'} = ''; -$Config{'line'} = '/bin/line'; -$Config{'lint'} = ''; -$Config{'ln'} = '/bin/ln'; -$Config{'lp'} = ''; -$Config{'lpr'} = ''; -$Config{'ls'} = ''; -$Config{'mail'} = ''; -$Config{'mailx'} = ''; -$Config{'make'} = ''; -$Config{'mkdir'} = '/bin/mkdir'; -$Config{'more'} = ''; -$Config{'mv'} = '/bin/mv'; -$Config{'nroff'} = '/bin/nroff'; -$Config{'perl'} = '/home/netlabs1/lwall/pl/perl'; -$Config{'pg'} = ''; -$Config{'pmake'} = ''; -$Config{'pr'} = ''; -$Config{'rm'} = '/bin/rm'; -$Config{'rmail'} = ''; -$Config{'sed'} = '/bin/sed'; -$Config{'sendmail'} = ''; -$Config{'sh'} = ''; -$Config{'shar'} = ''; -$Config{'sleep'} = ''; -$Config{'smail'} = ''; -$Config{'sort'} = '/bin/sort'; -$Config{'submit'} = ''; -$Config{'tail'} = ''; -$Config{'tar'} = ''; -$Config{'tbl'} = ''; -$Config{'test'} = 'test'; -$Config{'touch'} = '/bin/touch'; -$Config{'tr'} = '/bin/tr'; -$Config{'troff'} = ''; -$Config{'uname'} = '/bin/uname'; -$Config{'uniq'} = '/bin/uniq'; -$Config{'uuname'} = ''; -$Config{'vi'} = ''; -$Config{'zcat'} = ''; -$Config{'hint'} = 'recommended'; -$Config{'myuname'} = 'sunos scalpel 4.1.3 3 sun4c '; -$Config{'osname'} = 'sunos'; -$Config{'osvers'} = '4.1.3'; -$Config{'Author'} = ''; -$Config{'Date'} = '$Date'; -$Config{'Header'} = ''; -$Config{'Id'} = '$Id'; -$Config{'Locker'} = ''; -$Config{'Log'} = '$Log'; -$Config{'RCSfile'} = '$RCSfile'; -$Config{'Revision'} = '$Revision'; -$Config{'Source'} = ''; -$Config{'State'} = ''; -$Config{'afs'} = 'false'; -$Config{'memalignbytes'} = '8'; -$Config{'bin'} = '/usr/local/bin'; -$Config{'binexp'} = '/usr/local/bin'; -$Config{'installbin'} = '/usr/local/bin'; -$Config{'byteorder'} = '4321'; -$Config{'cc'} = 'cc'; -$Config{'gccversion'} = ''; -$Config{'ccflags'} = '-DDEBUGGING'; -$Config{'cppflags'} = ' -DDEBUGGING'; -$Config{'ldflags'} = ''; -$Config{'lkflags'} = ''; -$Config{'optimize'} = '-g'; -$Config{'cf_by'} = 'lwall'; -$Config{'cf_time'} = 'Wed May 4 15:10:39 PDT 1994'; -$Config{'contains'} = 'grep'; -$Config{'cpplast'} = ''; -$Config{'cppminus'} = ''; -$Config{'cpprun'} = '/usr/lib/cpp'; -$Config{'cppstdin'} = '/tmp_mnt/net/vaccine/export/src/local/lwall/perl5/cppstdin'; -$Config{'d_access'} = 'define'; -$Config{'d_bcmp'} = 'define'; -$Config{'d_bcopy'} = 'define'; -$Config{'d_bzero'} = 'define'; -$Config{'d_casti32'} = 'define'; -$Config{'castflags'} = '0'; -$Config{'d_castneg'} = 'define'; -$Config{'d_charsprf'} = 'define'; -$Config{'d_chsize'} = undef; -$Config{'d_const'} = undef; -$Config{'cryptlib'} = ''; -$Config{'d_crypt'} = 'define'; -$Config{'d_csh'} = 'define'; -$Config{'d_dosuid'} = undef; -$Config{'d_dup2'} = 'define'; -$Config{'d_fchmod'} = 'define'; -$Config{'d_fchown'} = 'define'; -$Config{'d_fcntl'} = 'define'; -$Config{'d_flexfnam'} = 'define'; -$Config{'d_flock'} = 'define'; -$Config{'d_getgrps'} = 'define'; -$Config{'d_gethent'} = undef; -$Config{'aphostname'} = ''; -$Config{'d_gethname'} = undef; -$Config{'d_phostname'} = undef; -$Config{'d_uname'} = 'define'; -$Config{'d_getpgrp2'} = undef; -$Config{'d_getpgrp'} = 'define'; -$Config{'d_getprior'} = 'define'; -$Config{'d_htonl'} = 'define'; -$Config{'d_isascii'} = 'define'; -$Config{'d_killpg'} = 'define'; -$Config{'d_link'} = 'define'; -$Config{'d_lstat'} = 'define'; -$Config{'d_memcmp'} = 'define'; -$Config{'d_memcpy'} = 'define'; -$Config{'d_memmove'} = undef; -$Config{'d_memset'} = 'define'; -$Config{'d_mkdir'} = 'define'; -$Config{'d_msg'} = 'define'; -$Config{'d_msgctl'} = 'define'; -$Config{'d_msgget'} = 'define'; -$Config{'d_msgrcv'} = 'define'; -$Config{'d_msgsnd'} = 'define'; -$Config{'d_open3'} = 'define'; -$Config{'d_portable'} = undef; -$Config{'d_readdir'} = 'define'; -$Config{'d_rewinddir'} = 'define'; -$Config{'d_seekdir'} = 'define'; -$Config{'d_telldir'} = 'define'; -$Config{'d_rename'} = 'define'; -$Config{'d_rmdir'} = 'define'; -$Config{'d_safebcpy'} = 'define'; -$Config{'d_safemcpy'} = undef; -$Config{'d_select'} = 'define'; -$Config{'d_sem'} = 'define'; -$Config{'d_semctl'} = 'define'; -$Config{'d_semget'} = 'define'; -$Config{'d_semop'} = 'define'; -$Config{'d_setegid'} = 'define'; -$Config{'d_seteuid'} = 'define'; -$Config{'d_setlocale'} = 'define'; -$Config{'d_setpgid'} = 'define'; -$Config{'d_setpgrp2'} = undef; -$Config{'d_bsdpgrp'} = ''; -$Config{'d_setpgrp'} = 'define'; -$Config{'d_setprior'} = 'define'; -$Config{'d_setregid'} = 'define'; -$Config{'d_setresgid'} = undef; -$Config{'d_setresuid'} = undef; -$Config{'d_setreuid'} = 'define'; -$Config{'d_setrgid'} = 'define'; -$Config{'d_setruid'} = 'define'; -$Config{'d_setsid'} = 'define'; -$Config{'d_shm'} = 'define'; -$Config{'d_shmat'} = 'define'; -$Config{'d_voidshmat'} = undef; -$Config{'d_shmctl'} = 'define'; -$Config{'d_shmdt'} = 'define'; -$Config{'d_shmget'} = 'define'; -$Config{'d_oldsock'} = undef; -$Config{'d_socket'} = 'define'; -$Config{'d_sockpair'} = 'define'; -$Config{'sockethdr'} = ''; -$Config{'socketlib'} = ''; -$Config{'d_statblks'} = 'define'; -$Config{'d_stdstdio'} = 'define'; -$Config{'d_index'} = undef; -$Config{'d_strchr'} = 'define'; -$Config{'d_strctcpy'} = 'define'; -$Config{'d_strerrm'} = 'define'; -$Config{'d_strerror'} = undef; -$Config{'d_sysernlst'} = ''; -$Config{'d_syserrlst'} = 'define'; -$Config{'d_symlink'} = 'define'; -$Config{'d_syscall'} = 'define'; -$Config{'d_system'} = 'define'; -$Config{'d_time'} = 'define'; -$Config{'timetype'} = 'long'; -$Config{'clocktype'} = 'long'; -$Config{'d_times'} = 'define'; -$Config{'d_truncate'} = 'define'; -$Config{'d_usendir'} = undef; -$Config{'i_ndir'} = undef; -$Config{'ndirc'} = ''; -$Config{'ndirlib'} = ''; -$Config{'ndiro'} = ''; -$Config{'d_vfork'} = undef; -$Config{'d_voidsig'} = 'define'; -$Config{'signal_t'} = 'void'; -$Config{'d_volatile'} = undef; -$Config{'d_charvspr'} = 'define'; -$Config{'d_vprintf'} = 'define'; -$Config{'d_wait4'} = 'define'; -$Config{'d_waitpid'} = 'define'; -$Config{'cccdlflags'} = ''; -$Config{'ccdlflags'} = ''; -$Config{'dldir'} = 'ext/dl'; -$Config{'dlobj'} = 'dl_sunos.o'; -$Config{'dlsrc'} = 'dl_sunos.c'; -$Config{'lddlflags'} = ''; -$Config{'shlibsuffix'} = '.so'; -$Config{'usedl'} = 'define'; -$Config{'gidtype'} = 'gid_t'; -$Config{'groupstype'} = 'int'; -$Config{'h_fcntl'} = 'false'; -$Config{'h_sysfile'} = 'true'; -$Config{'i_dbm'} = 'define'; -$Config{'d_dirnamlen'} = undef; -$Config{'i_dirent'} = 'define'; -$Config{'i_dlfcn'} = 'define'; -$Config{'i_fcntl'} = undef; -$Config{'i_gdbm'} = undef; -$Config{'i_grp'} = 'define'; -$Config{'i_memory'} = 'define'; -$Config{'i_ndbm'} = 'define'; -$Config{'i_neterrno'} = undef; -$Config{'i_niin'} = 'define'; -$Config{'i_sysin'} = undef; -$Config{'d_pwage'} = 'define'; -$Config{'d_pwchange'} = undef; -$Config{'d_pwclass'} = undef; -$Config{'d_pwcomment'} = 'define'; -$Config{'d_pwexpire'} = undef; -$Config{'d_pwquota'} = undef; -$Config{'i_pwd'} = 'define'; -$Config{'i_sdbm'} = 'define'; -$Config{'i_stdarg'} = undef; -$Config{'i_stddef'} = 'define'; -$Config{'i_string'} = 'define'; -$Config{'strings'} = '/usr/include/string.h'; -$Config{'i_sysdir'} = 'define'; -$Config{'i_sysfile'} = 'define'; -$Config{'d_voidtty'} = ''; -$Config{'i_bsdioctl'} = ''; -$Config{'i_sysioctl'} = 'define'; -$Config{'i_syssockio'} = ''; -$Config{'i_sysndir'} = undef; -$Config{'i_sysselct'} = undef; -$Config{'i_sgtty'} = undef; -$Config{'i_termio'} = undef; -$Config{'i_termios'} = 'define'; -$Config{'i_systime'} = 'define'; -$Config{'i_systimek'} = undef; -$Config{'i_time'} = undef; -$Config{'timeincl'} = '/usr/include/sys/time.h '; -$Config{'i_unistd'} = 'define'; -$Config{'i_utime'} = 'define'; -$Config{'i_varargs'} = 'define'; -$Config{'i_varhdr'} = 'varargs.h'; -$Config{'i_vfork'} = undef; -$Config{'intsize'} = '4'; -$Config{'lib'} = '/usr/local/lib'; -$Config{'libexp'} = '/usr/local/lib'; -$Config{'libc'} = '/usr/lib/libc.so.1.8.1'; -$Config{'libpth'} = ' /lib /usr/lib /usr/ucblib /usr/local/lib'; -$Config{'plibpth'} = ''; -$Config{'xlibpth'} = '/usr/lib/386 /lib/386'; -$Config{'libs'} = '-ldbm -ldl -lm -lposix'; -$Config{'lns'} = '/bin/ln -s'; -$Config{'lseektype'} = 'off_t'; -$Config{'d_mymalloc'} = 'define'; -$Config{'mallocobj'} = 'malloc.o'; -$Config{'mallocsrc'} = 'malloc.c'; -$Config{'malloctype'} = 'char *'; -$Config{'usemymalloc'} = 'y'; -$Config{'installmansrc'} = '/usr/local/man/man1'; -$Config{'manext'} = '1'; -$Config{'mansrc'} = '/usr/local/man/man1'; -$Config{'mansrcexp'} = '/usr/local/man/man1'; -$Config{'huge'} = ''; -$Config{'large'} = ''; -$Config{'medium'} = ''; -$Config{'models'} = 'none'; -$Config{'small'} = ''; -$Config{'split'} = ''; -$Config{'mydomain'} = ''; -$Config{'myhostname'} = 'scalpel'; -$Config{'phostname'} = 'hostname'; -$Config{'c'} = ''; -$Config{'n'} = '-n'; -$Config{'groupcat'} = ''; -$Config{'hostcat'} = 'ypcat hosts'; -$Config{'passcat'} = ''; -$Config{'orderlib'} = 'false'; -$Config{'ranlib'} = '/usr/bin/ranlib'; -$Config{'package'} = 'perl'; -$Config{'spackage'} = ''; -$Config{'installprivlib'} = '/usr/local/lib/perl'; -$Config{'privlib'} = '/usr/local/lib/perl'; -$Config{'privlibexp'} = '/usr/local/lib/perl'; -$Config{'prototype'} = undef; -$Config{'ptrsize'} = '4'; -$Config{'randbits'} = '31'; -$Config{'installscript'} = '/usr/local/bin'; -$Config{'scriptdir'} = '/usr/local/bin'; -$Config{'scriptdirexp'} = '/usr/local/bin'; -$Config{'sig_name'} = 'ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH LOST USR1 USR2'; -$Config{'sharpbang'} = '#!'; -$Config{'shsharp'} = 'true'; -$Config{'spitshell'} = 'cat'; -$Config{'startsh'} = '#!/bin/sh'; -$Config{'stdchar'} = 'unsigned char'; -$Config{'sysman'} = '/usr/man/man1'; -$Config{'uidtype'} = 'uid_t'; -$Config{'nm_opt'} = ''; -$Config{'runnm'} = 'true'; -$Config{'usenm'} = 'true'; -$Config{'incpath'} = ''; -$Config{'mips'} = ''; -$Config{'mips_type'} = ''; -$Config{'usrinc'} = '/usr/include'; -$Config{'defvoidused'} = '15'; -$Config{'voidflags'} = '15'; -$Config{'yacc'} = 'yacc'; -$Config{'yaccflags'} = ''; -$Config{'PATCHLEVEL'} = 0; -$Config{'CONFIG'} = 'true'; -1; diff --git a/lib/Cwd.pm b/lib/Cwd.pm new file mode 100644 index 0000000000..719d1d2622 --- /dev/null +++ b/lib/Cwd.pm @@ -0,0 +1,161 @@ +package Cwd; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(getcwd fastcwd); +@EXPORT_OK = qw(chdir); + + +# By Brandon S. Allbery +# +# Usage: $cwd = getcwd(); + +sub getcwd +{ + my($dotdots, $cwd, @pst, @cst, $dir, @tst); + + unless (@cst = stat('.')) + { + warn "stat(.): $!"; + return ''; + } + $cwd = ''; + do + { + $dotdots .= '/' if $dotdots; + $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 ($dir = readdir(PARENT)) + { + warn "readdir($dotdots): $!"; + closedir(PARENT); + return ''; + } + unless (@tst = lstat("$dotdots/$dir")) + { + warn "lstat($dotdots/$dir): $!"; + closedir(PARENT); + return ''; + } + } + while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || + $tst[1] != $pst[1]); + } + $cwd = "$dir/$cwd"; + closedir(PARENT); + } while ($dir); + chop($cwd); + $cwd; +} + + + +# By John Bazik +# +# Usage: $cwd = &fastcwd; +# +# This is a faster version of getcwd. It's also more dangerous because +# you might chdir out of a directory that you can't chdir back into. + +sub fastcwd { + my($odev, $oino, $cdev, $cino, $tdev, $tino); + my(@path, $path); + local(*DIR); + + ($cdev, $cino) = stat('.'); + for (;;) { + ($odev, $oino) = ($cdev, $cino); + chdir('..'); + ($cdev, $cino) = stat('.'); + last if $odev == $cdev && $oino == $cino; + opendir(DIR, '.'); + for (;;) { + $_ = readdir(DIR); + next if $_ eq '.'; + next if $_ eq '..'; + + last unless $_; + ($tdev, $tino) = lstat($_); + last unless $tdev != $odev || $tino != $oino; + } + closedir(DIR); + unshift(@path, $_); + } + chdir($path = '/' . join('/', @path)); + $path; +} + + +# keeps track of current working directory in PWD environment var +# +# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ +# +# $Log: pwd.pl,v $ +# +# Usage: +# use Cwd 'chdir'; +# chdir $newdir; + +$chdir_init = 0; + +sub chdir_init{ + if ($ENV{'PWD'}) { + my($dd,$di) = stat('.'); + my($pd,$pi) = stat($ENV{'PWD'}); + if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { + chop($ENV{'PWD'} = `pwd`); + } + } + else { + chop($ENV{'PWD'} = `pwd`); + } + if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { + my($pd,$pi) = stat($2); + my($dd,$di) = stat($1); + if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { + $ENV{'PWD'}="$2$3"; + } + } + $chdir_init = 1; +} + +sub chdir { + my($newdir) = shift; + chdir_init() unless $chdir_init; + return 0 unless (CORE::chdir $newdir); + if ($newdir =~ m#^/#) { + $ENV{'PWD'} = $newdir; + }else{ + my(@curdir) = split(m#/#,$ENV{'PWD'}); + @curdir = '' unless @curdir; + foreach $component (split(m#/#, $newdir)) { + next if $component eq '.'; + pop(@curdir),next if $component eq '..'; + push(@curdir,$component); + } + $ENV{'PWD'} = join('/',@curdir) || '/'; + } +} + +1; + diff --git a/lib/English.pm b/lib/English.pm index 79cceee53c..b203721a52 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -3,6 +3,8 @@ package English; require Exporter; @ISA = (Exporter); +local($^W) = 0; + @EXPORT = qw( *ARG $MATCH @@ -30,6 +32,7 @@ require Exporter; $FORMAT_FORMFEED $CHILD_ERROR $OS_ERROR + $ERRNO $EVAL_ERROR $PROCESS_ID $PID @@ -101,6 +104,7 @@ require Exporter; *CHILD_ERROR = \$? ; *OS_ERROR = \$! ; + *ERRNO = \$! ; *EVAL_ERROR = \$@ ; # Process info. @@ -131,8 +135,8 @@ require Exporter; # Deprecated. - *ARRAY_BASE = \$[ ; - *OFMT = \$# ; - *MULTILINE_MATCHING = \$* ; +# *ARRAY_BASE = \$[ ; +# *OFMT = \$# ; +# *MULTILINE_MATCHING = \$* ; 1; diff --git a/lib/Env.pm b/lib/Env.pm new file mode 100644 index 0000000000..21870903b4 --- /dev/null +++ b/lib/Env.pm @@ -0,0 +1,69 @@ +package Env; + +=head1 NAME + +Env - Perl module that imports environment variables + +=head1 DESCRIPTION + +Perl maintains environment variables in a pseudo-associative-array +named %ENV. For when this access method is inconvenient, the Perl +module C<Env> allows environment variables to be treated as simple +variables. + +The Env::import() function ties environment variables with suitable +names to global Perl variables with the same names. By default it +does so with all existing environment variables (C<keys %ENV>). If +the import function receives arguments, it takes them to be a list of +environment variables to tie; it's okay if they don't yet exist. + +After an environment variable is tied, merely use it like a normal variable. +You may access its value + + @path = split(/:/, $PATH); + +or modify it + + $PATH .= ":."; + +however you'd like. +To remove a tied environment variable from +the environment, assign it the undefined value + + undef $PATH; + +=head1 AUTHOR + +Chip Salzenberg <chip@fin.uucp> + +=cut + +sub import { + my ($callpack) = caller(0); + my $pack = shift; + my @vars = @_ ? @_ : keys(%ENV); + + foreach (@vars) { + tie ${"${callpack}::$_"}, Env, $_ if /^[A-Za-z_]\w*$/; + } +} + +sub TIESCALAR { + bless \($_[1]); +} + +sub FETCH { + my ($self) = @_; + $ENV{$$self}; +} + +sub STORE { + my ($self, $value) = @_; + if (defined($value)) { + $ENV{$$self} = $value; + } else { + delete $ENV{$$self}; + } +} + +1; diff --git a/lib/Exporter.pm b/lib/Exporter.pm index 0b021b3d71..dce6909b18 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -2,9 +2,11 @@ package Exporter; require 5.000; -sub import { - my ($callpack, $callfile, $callline) = caller($ExportLevel); +$ExportLevel = 0; + +sub export { my $pack = shift; + my $callpack = shift; my @imports = @_; *exports = \@{"${pack}::EXPORT"}; if (@imports) { @@ -14,11 +16,14 @@ sub import { if (!%exports) { grep(s/^&//, @exports); @exports{@exports} = (1) x @exports; + foreach $extra (@{"${pack}::EXPORT_OK"}) { + $exports{$extra} = 1; + } } foreach $sym (@imports) { if (!$exports{$sym}) { if ($sym !~ s/^&// || !$exports{$sym}) { - warn "$sym is not exported by the $pack module ", + warn qq["$sym" is not exported by the $pack module ], "at $callfile line $callline\n"; $oops++; next; @@ -43,4 +48,10 @@ sub import { } }; +sub import { + local ($callpack, $callfile, $callline) = caller($ExportLevel); + my $pack = shift; + export $pack, $callpack, @_; +} + 1; diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm new file mode 100644 index 0000000000..563241f1da --- /dev/null +++ b/lib/ExtUtils/MakeMaker.pm @@ -0,0 +1,694 @@ +package ExtUtils::MakeMaker; + +# Authors: Andy Dougherty <doughera@lafcol.lafayette.edu> +# Andreas Koenig <k@franz.ww.TU-Berlin.DE> +# Tim Bunce <Tim.Bunce@ig.co.uk> + +# Last Revision: 12 Oct 1994 + +# This utility is designed to write a Makefile for an extension +# module from a Makefile.PL. It is based on the excellent Makefile.SH +# model provided by Andy Dougherty and the perl5-porters. + +# It splits the task of generating the Makefile into several +# subroutines that can be individually overridden. +# Each subroutine returns the text it wishes to have written to +# the Makefile. + +use Config; +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(writeMakefile mkbootstrap $Verbose); +@EXPORT_OK = qw(%att @recognized_att_keys); + +use strict qw(refs); + +# Setup dummy package: +# MY exists for overriding methods to be defined within +unshift(@MY::ISA, qw(MM)); + +$Verbose = 0; +$Subdirs = 0; # set to 1 to have this .PL run all below +$^W=1; + + +# For most extensions it will do to call +# +# use ExtUtils::MakeMaker +# &writeMakefile("potential_libs" => "-L/usr/alpha -lfoo -lbar"); +# +# from Makefile.PL in the extension directory +# It is also handy to include some of the following attributes: +# +@recognized_att_keys=qw( + TOP INC DISTNAME VERSION DEFINE OBJECT LDTARGET ARMAYBE + BACKUP_LIBS AUTOSPLITMAXLEN LINKTYPE + potential_libs otherldflags perl fullperl + distclean_tarflags + clean_files realclean_files +); + +# +# TOP is the directory above lib/ and ext/ (normally ../..) +# (MakeMaker will normally work this out for itself) +# INC is something like "-I/usr/local/Minerva/include" +# DISTNAME is a name of your choice for distributing the package +# VERSION is your version number +# DEFINE is something like "-DHAVE_UNISTD_H" +# OBJECT defaults to '$(BASEEXT).o', but can be a long string containing +# all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" +# LDTARGET defaults to $(OBJECT) and is used in the ld command +# (some machines need additional switches for bigger projects) +# ARMAYBE defaults to ":", but can be used to run ar before ld +# BACKUP_LIBS is an anonymous array of libraries to be searched for +# until we get at least some output from ext/util/extliblist +# 'potential_libs' => "-lgdbm", +# 'BACKUP_LIBS' => [ "-ldbm -lfoo", "-ldbm.nfs" ] +# AUTOSPLITMAXLEN defaults to 8 and is used when autosplit is done +# (can be set higher on a case-by-case basis) +# defaults to `dynamic', can be set to `static' + +# +# `make distclean' builds $(DISTNAME)-$(VERSION).tar.Z after a clean + +# Be aware, that you can also pass attributes into the %att hash table +# by calling Makefile.PL with an argument of the form TOP=/some/where. + +# If the Makefile generated by default does not fit your purpose, +# you may specify private subroutines in the Makefile.PL as there are: +# +# MY->initialize => sub MY::initialize{ ... } +# MY->post_initialize => sub MY::post_initialize{ ... } +# MY->constants => etc +# MY->dynamic +# etc. (see function writeMakefile, for the current breakpoints) +# +# Each subroutines returns the text it wishes to have written to +# the Makefile. To override a section of the Makefile you can +# either say: sub MY::co { "new literal text" } +# or you can edit the default by saying something like: +# sub MY::co { $_=MM->co; s/old text/new text/; $_ } +# +# If you still need a different solution, try to develop another +# subroutine, that fits your needs and submit the diffs to +# perl5-porters or comp.lang.perl as appropriate. + +sub writeMakefile { + %att = @_; + local($\)="\n"; + + foreach (@ARGV){ + $att{$1}=$2 if m/(.*)=(.*)/; + } + print STDOUT "MakeMaker" if $Verbose; + print STDOUT map(" $_ = '$att{$_}'\n", sort keys %att) if ($Verbose && %att); + + MY->initialize(); + + print STDOUT "Writing ext/$att{FULLEXT}/Makefile (with variable substitutions)"; + + open MAKE, ">Makefile" or die "Unable to open Makefile: $!"; + + MY->mkbootstrap(split(" ", $att{'dynaloadlibs'})); + print MAKE MY->post_initialize; + + print MAKE MY->constants; + print MAKE MY->post_constants; + + print MAKE MY->subdir if $Subdirs; + print MAKE MY->dynamic; + print MAKE MY->force; + print MAKE MY->static; + print MAKE MY->co; + print MAKE MY->c; + print MAKE MY->installpm; + print MAKE MY->clean; + print MAKE MY->realclean; + print MAKE MY->test; + print MAKE MY->install; + print MAKE MY->perldepend; + print MAKE MY->distclean; + print MAKE MY->postamble; + + MY->finish; + + close MAKE; + + 1; +} + + +sub mkbootstrap{ + MY->mkbootstrap(@_) +} + + +sub avoid_typo_warnings{ + local($t) = "$t + $main::writeMakefile + $main::mkbootstrap + $main::Verbose + $DynaLoader::dl_resolve_using + $ExtUtils::MakeMaker::Config + $DynaLoader::Config + "; +} + + +# --- Supply the MakeMaker default methods --- + +package MM; + +use Config; +require Exporter; + +Exporter::import('ExtUtils::MakeMaker', qw(%att @recognized_att_keys)); + +# These attributes cannot be overridden +@other_att_keys=qw(extralibs dynaloadlibs statloadlibs bootdep); + + +sub find_perl{ + my($self, $ver, $names, $dirs, $trace) = @_; + my($name, $dir); + print "Looking for perl $ver by these names: @$names, in these dirs: @$dirs\n" + if ($trace); + foreach $dir (@$dirs){ + foreach $name (@$names){ + print "checking $dir/$name\n" if ($trace >= 2); + next unless -x "$dir/$name"; + print "executing $dir/$name\n" if ($trace); + my($out) = `$dir/$name -e 'require $ver; print "5OK\n" ' 2>&1`; + return "$dir/$name" if $out =~ /5OK/; + } + } + warn "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty +} + + +sub initialize { + # Find out directory name. This is also the extension name. + chop($pwd=`pwd`); + + unless ( $top = $att{TOP} ){ + foreach(qw(../.. ../../.. ../../../..)){ + ($top=$_, last) if -f "$_/config.sh"; + } + die "Can't find config.sh" unless -f "$top/config.sh"; + } + chdir $top or die "Couldn't chdir $top: $!"; + chop($abstop=`pwd`); + chdir $pwd; + + # EXTMODNAME = The perl module name for this extension. + # FULLEXT = Full pathname to extension directory. + # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. + # ROOTEXT = Directory part of FULLEXT. May be empty. + my($p) = $pwd; $p =~ s:^\Q$abstop/ext/\E::; + ($att{EXTMODNAME}=$p) =~ s#/#::#g ; #eg. BSD::Foo::Socket + ($att{FULLEXT} =$p); #eg. BSD/Foo/Socket + ($att{BASEEXT} =$p) =~ s:.*/:: ; #eg. Socket + ($att{ROOTEXT} =$p) =~ s:/?\Q$att{BASEEXT}\E$:: ; #eg. BSD/Foo + + # Find Perl 5. The only contract here is that both 'perl' and 'fullperl' + # will be working versions of perl 5. + $att{'perl'} = MY->find_perl(5.0, [ qw(perl5 perl miniperl) ], + [ $abstop, split(":", $ENV{PATH}) ], 0 ) + unless ($att{'perl'} && -x $att{'perl'}); + + # Define 'fullperl' to be a non-miniperl (used in test: target) + ($att{'fullperl'} = $att{'perl'}) =~ s/miniperl$/perl/ + unless ($att{'fullperl'} && -x $att{'fullperl'}); + + for $key (@recognized_att_keys, @other_att_keys){ + # avoid warnings for uninitialized vars + $att{$key} = "" unless defined $att{$key}; + } + + # compute extralibs, dynaloadlibs and statloadlibs from + # $att{'potential_libs'} + + unless ( &run_extliblist($att{'potential_libs'}) ){ + foreach ( @{$att{'BACKUP_LIBS'} || []} ){ + # Try again. Maybe they have specified some other libraries + last if &run_extliblist($_); + } + } +} + + +sub run_extliblist { + my($potential_libs)=@_; + # Now run ext/util/extliblist to discover what *libs definitions + # are required for the needs of $potential_libs + $ENV{'potential_libs'} = $potential_libs; + $_=`. $abstop/ext/util/extliblist; + echo extralibs=\$extralibs + echo dynaloadlibs=\$dynaloadlibs + echo statloadlibs=\$statloadlibs + echo bootdep=\$bootdep + `; + my(@w); + foreach $line (split "\n", $_){ + chomp $line; + if ($line =~ /(.*)\s*=\s*(.*)$/){ + $att{$1} = $2; + print STDERR " $1 = $2" if $Verbose; + }else{ + push(@w, $line); + } + } + print STDERR "Messages from extliblist:\n", join("\n",@w,'') + if @w ; + join '', @att{qw(extralibs dynaloadlibs statloadlibs)}; +} + + +sub post_initialize{ + ""; +} + + +sub constants { + my(@m); + + $att{BOOTDEP} = (-f "$att{BASEEXT}_BS") ? "$att{BASEEXT}_BS" : ""; + $att{OBJECT} = '$(BASEEXT).o' unless $att{OBJECT}; + $att{LDTARGET} = '$(OBJECT)' unless $att{LDTARGET}; + $att{ARMAYBE} = ":" unless $att{ARMAYBE}; + $att{AUTOSPLITMAXLEN} = 8 unless $att{AUTOSPLITMAXLEN}; + $att{LINKTYPE} = ($Config{'usedl'}) ? 'dynamic' : 'static' + unless $att{LINKTYPE}; + + + push @m, " +# +# This Makefile is for the $att{FULLEXT} extension to perl. +# It was written by Makefile.PL, so don't edit it, edit +# Makefile.PL instead. ANY CHANGES MADE HERE WILL BE LOST! +# + +DISTNAME = $att{DISTNAME} +VERSION = $att{VERSION} + +TOP = $top +ABSTOP = $abstop +PERL = $att{'perl'} +FULLPERL = $att{'fullperl'} +INC = $att{INC} +DEFINE = $att{DEFINE} +OBJECT = $att{OBJECT} +LDTARGET = $att{LDTARGET} +"; + + push @m, " +CC = $Config{'cc'} +LIBC = $Config{'libc'} +LDFLAGS = $Config{'ldflags'} +CLDFLAGS = $Config{'ldflags'} +LINKTYPE = $att{LINKTYPE} +ARMAYBE = $att{ARMAYBE} +RANLIB = $Config{'ranlib'} + +SMALL = $Config{'small'} +LARGE = $Config{'large'} $Config{'split'} +# The following are used to build and install shared libraries for +# dynamic loading. +LDDLFLAGS = $Config{'lddlflags'} +CCDLFLAGS = $Config{'ccdlflags'} +CCCDLFLAGS = $Config{'cccdlflags'} +SO = $Config{'so'} +DLEXT = $Config{'dlext'} +DLSRC = $Config{'dlsrc'} +"; + + push @m, " +# $att{FULLEXT} might need to be linked with some extra libraries. +# EXTRALIBS = full list of libraries needed for static linking. +# Only those libraries that actually exist are included. +# DYNALOADLIBS = list of those libraries that are needed but can be +# linked in dynamically on this platform. On SunOS, for +# example, this would be .so* libraries, but not archive +# libraries. The bootstrap file is installed only if +# this list is not empty. +# STATLOADLIBS = list of those libraries which must be statically +# linked into the shared library. On SunOS 4.1.3, +# for example, I have only an archive version of +# -lm, and it must be linked in statically. +EXTRALIBS = $att{'extralibs'} +DYNALOADLIBS = $att{'dynaloadlibs'} +STATLOADLIBS = $att{'statloadlibs'} + +"; + + push @m, " +# EXTMODNAME = The perl module name for this extension. +# FULLEXT = Full pathname to extension directory. +# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. +# ROOTEXT = Directory part of FULLEXT. May be empty. +EXTMODNAME = $att{EXTMODNAME} +FULLEXT = $att{FULLEXT} +BASEEXT = $att{BASEEXT} +ROOTEXT = $att{ROOTEXT} +# and for backward compatibility and for AIX support (due to change!) +EXT = $att{BASEEXT} + +# $att{FULLEXT} might have its own typemap +EXTTYPEMAP = ".(-f "typemap" ? "typemap" : "")." +# $att{FULLEXT} might have its own bootstrap support +BOOTSTRAP = $att{BASEEXT}.bs +BOOTDEP = $att{BOOTDEP} +"; + + push @m, ' +# Where to put things: +AUTO = $(TOP)/lib/auto +AUTOEXT = $(TOP)/lib/auto/$(FULLEXT) +INST_BOOT = $(AUTOEXT)/$(BASEEXT).bs +INST_DYNAMIC = $(AUTOEXT)/$(BASEEXT).$(DLEXT) +INST_STATIC = $(BASEEXT).a +INST_PM = $(TOP)/lib/$(FULLEXT).pm +'." +# These two are only used by install: targets +INSTALLPRIVLIB = $Config{'installprivlib'} +INSTALLARCHLIB = $Config{'installarchlib'} +"; + + push @m, "\nshellflags = $Config{'shellflags'}" if $Config{'shellflags'}; + + push @m, q{ +# Tools +SHELL = /bin/sh +CCCMD = `sh $(shellflags) $(ABSTOP)/cflags $@` +XSUBPP = $(TOP)/ext/xsubpp +# the following is a portable way to say mkdir -p +MKPATH = $(PERL) -we '$$"="/"; foreach(split(/\//,$$ARGV[0])){ push(@p, $$_); next if -d "@p"; print "mkdir @p\n"; mkdir("@p",0777)||die "mkdir @p: $$!" } exit 0;' +AUTOSPLITLIB = cd $(TOP); \ + $(PERL) -Ilib -e 'use AutoSplit; $$AutoSplit::Maxlen=}.$att{AUTOSPLITMAXLEN}.q{; autosplit_lib_modules(@ARGV) ;' +}; + + push @m, ' + +all :: + +config :: Makefile + @$(MKPATH) $(AUTOEXT) + +install :: + +'; + + join('',@m); +} + + +sub post_constants{ + ""; +} + + +sub subdir { + my(@m); + foreach $MakefilePL (<*/Makefile.PL>){ + ($subdir=$MakefilePL) =~ s:/Makefile\.PL$:: ; + push @m, " +config :: + \@cd $subdir ; \\ + if test ! -f Makefile; then \\ + test -f Makefile.PL && \$(PERL) -I\$(ABSTOP)/lib Makefile.PL TOP=\$(ABSTOP) ; \\ + fi + +all :: + cd $subdir ; \$(MAKE) config + cd $subdir ; \$(MAKE) all +"; + + } + join('',@m); +} + + +sub co { + ' +.c.o: + $(CCCMD) $(CCCDLFLAGS) $(DEFINE) -I$(TOP) $(INC) $*.c +'; +} + + +sub force { + ' +# Phony target to force checking subdirectories. +FORCE: +'; +} + + +sub dynamic { + ' +all:: $(LINKTYPE) + +# Target for Dynamic Loading: +dynamic:: $(INST_DYNAMIC) $(INST_PM) $(INST_BOOT) + +$(INST_DYNAMIC): $(OBJECT) + @$(MKPATH) $(AUTOEXT) + $(ARMAYBE) cr $(EXTMODNAME).a $(OBJECT) + ld $(LDDLFLAGS) -o $@ $(LDTARGET) '.$att{'otherldflags'}.' $(STATLOADLIBS) + +$(BOOTSTRAP): $(BOOTDEP) + $(PERL) -I$(TOP)/lib -e \'use ExtUtils::MakeMaker; &mkbootstrap("$(DYNALOADLIBS)");\' + touch $(BOOTSTRAP) + +$(INST_BOOT): $(BOOTSTRAP) + @test ! -s $(BOOTSTRAP) || cp $(BOOTSTRAP) $@ +'; +} + + +sub static { + ' +# Target for Static Loading: +static:: $(INST_STATIC) $(INST_PM) + +$(INST_STATIC): $(OBJECT) + ar cr $@ $(OBJECT) + $(RANLIB) $@ + echo $(EXTRALIBS) >> $(TOP)/ext.libs +'; +} + + +sub c { + ' +$(BASEEXT).c: $(BASEEXT).xs $(XSUBPP) $(TOP)/ext/typemap $(EXTTYPEMAP) $(TOP)/cflags + $(PERL) $(XSUBPP) $(BASEEXT).xs >tmp + mv tmp $@ +'; +} + + +sub installpm { + ' +$(INST_PM): $(BASEEXT).pm + @$(MKPATH) $(TOP)/lib/$(ROOTEXT) + rm -f $@ + cp $(BASEEXT).pm $@ + @$(AUTOSPLITLIB) $(EXTMODNAME) +'; +} + + +sub clean { + ' +clean:: + rm -f *.o *.a mon.out core $(BASEEXT).c so_locations + rm -f makefile Makefile $(BOOTSTRAP) $(BASEEXT).bso '.$att{'clean_files'}.' +'; +} + + +sub realclean { + ' +realclean:: clean + rm -f $(INST_DYNAMIC) $(INST_STATIC) $(INST_BOOT) + rm -rf $(INST_PM) $(AUTOEXT) '.$att{'realclean_files'}.' + +purge: realclean +'; +} + + +sub test { + ' +test: all + $(FULLPERL) -I$(TOP)/lib -e \'use Test::Harness; runtests @ARGV;\' t/*.t +'; +} + + +sub install { + ' +# used if installperl will not be installing it for you +install:: all + # not yet defined +'; +} + + +sub distclean { + my($tarflags) = $att{'distclean_tarflags'} || 'cvf'; + ' +distclean: clean + rm -f Makefile *~ t/*~ + cd ..; tar '.$tarflags.' "$(DISTNAME)-$(VERSION).tar" $(BASEEXT) + cd ..; compress "$(DISTNAME)-$(VERSION).tar" +'; +} + + +sub perldepend { + ' +$(OBJECT) : Makefile +$(OBJECT) : $(TOP)/EXTERN.h +$(OBJECT) : $(TOP)/INTERN.h +$(OBJECT) : $(TOP)/XSUB.h +$(OBJECT) : $(TOP)/av.h +$(OBJECT) : $(TOP)/cop.h +$(OBJECT) : $(TOP)/cv.h +$(OBJECT) : $(TOP)/dosish.h +$(OBJECT) : $(TOP)/embed.h +$(OBJECT) : $(TOP)/form.h +$(OBJECT) : $(TOP)/gv.h +$(OBJECT) : $(TOP)/handy.h +$(OBJECT) : $(TOP)/hv.h +$(OBJECT) : $(TOP)/keywords.h +$(OBJECT) : $(TOP)/mg.h +$(OBJECT) : $(TOP)/op.h +$(OBJECT) : $(TOP)/opcode.h +$(OBJECT) : $(TOP)/patchlevel.h +$(OBJECT) : $(TOP)/perl.h +$(OBJECT) : $(TOP)/perly.h +$(OBJECT) : $(TOP)/pp.h +$(OBJECT) : $(TOP)/proto.h +$(OBJECT) : $(TOP)/regcomp.h +$(OBJECT) : $(TOP)/regexp.h +$(OBJECT) : $(TOP)/scope.h +$(OBJECT) : $(TOP)/sv.h +$(OBJECT) : $(TOP)/unixish.h +$(OBJECT) : $(TOP)/util.h +$(TOP)/config.h: $(TOP)/config.sh; cd $(TOP); /bin/sh config_h.SH +$(TOP)/embed.h: $(TOP)/config.sh; cd $(TOP); /bin/sh embed_h.SH +$(TOP)/cflags: $(TOP)/config.sh; cd $(TOP); /bin/sh cflags.SH + +Makefile: Makefile.PL + $(PERL) -I$(TOP)/lib Makefile.PL +'; +} + + +sub postamble{ + ""; +} + + +sub finish { + chmod 0644, "Makefile"; + system("$Config{'eunicefix'} Makefile") unless $Config{'eunicefix'} eq ":"; +} + + + +sub mkbootstrap { +# +# mkbootstrap, by: +# +# Andreas Koenig <k@otto.ww.TU-Berlin.DE> +# Tim Bunce <Tim.Bunce@ig.co.uk> +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# +# This perl script attempts to make a bootstrap file for use by this +# system's DynaLoader. It typically gets called from an extension +# Makefile. +# +# There is no .bs file supplied with the extension. Instead a _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 +# @DynaLoader::dl_resolve_using array for the current architecture. +# That will be extended by $dynaloadlibs, which was computed by Andy's +# extliblist script. If this array still is empty, we do nothing, else +# we write a .bs file with an @DynaLoader::dl_resolve_using array, but +# without any `if's, because there is no longer a need to deal with +# special cases. +# +# The _BS file can put some code into the generated .bs file by placing +# it in $bscode. This is a handy 'escape' mechanism that may prove +# useful in complex situations. +# +# If @DynaLoader::dl_resolve_using contains -L* or -l* entries then +# mkbootstrap will automatically add a dl_findfile() call to the +# generated .bs file. +# + my($self, @dynaloadlibs)=@_; + print STDERR " dynaloadlibs=@dynaloadlibs" if $Verbose; + require DynaLoader; # we need DynaLoader, if the *_BS gets interpreted + import DynaLoader; # we don't say `use', so if DynaLoader is not + # yet built MakeMaker works nonetheless except here + + &initialize unless defined $att{'perl'}; + + rename "$att{BASEEXT}.bs", "$att{BASEEXT}.bso"; + + if (-f "$att{BASEEXT}_BS"){ + $_ = "$att{BASEEXT}_BS"; + package DynaLoader; # execute code as if in DynaLoader + local($osname, $dlsrc) = (); # avoid warnings + ($osname, $dlsrc) = @Config{qw(osname dlsrc)}; + $bscode = ""; + unshift @INC, "."; + require $_; + } + + if ($Config{'dlsrc'} =~ /^dl_dld/){ + package DynaLoader; + push(@dl_resolve_using, dl_findfile('-lc')); + } + + my(@all) = (@dynaloadlibs, @DynaLoader::dl_resolve_using); + my($method) = ''; + if (@all){ + open BS, ">$att{BASEEXT}.bs" + or die "Unable to open $att{BASEEXT}.bs: $!"; + print STDOUT "Writing $att{BASEEXT}.bs\n"; + print STDOUT " containing: @all" if $Verbose; + print BS "# $att{BASEEXT} DynaLoader bootstrap file for $Config{'osname'} architecture.\n"; + print BS "# Do not edit this file, changes will be lost.\n"; + print BS "# This file was automatically generated by the\n"; + print BS "# mkbootstrap routine in ExtUtils/MakeMaker.pm.\n"; + print BS "\@DynaLoader::dl_resolve_using = "; + if (" @all" =~ m/ -[lL]/){ + print BS " dl_findfile(qw(\n @all\n ));\n"; + }else{ + print BS " qw(@all);\n"; + } + # write extra code if *_BS says so + print BS $DynaLoader::bscode if $DynaLoader::bscode; + print BS "1;\n"; + close BS; + } + + if ($Config{'dlsrc'} =~ /^dl_aix/){ + open AIX, ">$att{BASEEXT}.exp"; + print AIX "#!\nboot_$att{BASEEXT}\n"; + close AIX; + } +} + +# the following makes AutoSplit happy (bug in perl5b3e) +package ExtUtils::MakeMaker; +1; + +__END__ diff --git a/lib/FOOBAR.pm b/lib/FOOBAR.pm deleted file mode 100644 index 9013b4eb09..0000000000 --- a/lib/FOOBAR.pm +++ /dev/null @@ -1,10 +0,0 @@ -package FOOBAR; - -require Exporter; -@ISA = (Exporter); -@EXPORT = (foo, bar); - -sub foo { print "FOO\n" }; -sub bar { print "BAR\n" }; - -1; diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm new file mode 100644 index 0000000000..9e2e25e889 --- /dev/null +++ b/lib/File/Basename.pm @@ -0,0 +1,138 @@ +package File::Basename; + +require 5.000; +use Config; +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(fileparse set_fileparse_fstype basename dirname); + +# fileparse_set_fstype() - specify OS-based rules used in future +# calls to routines in this package +# +# Currently recognized values: VMS, MSDOS, MacOS +# Any other name uses Unix-style rules + +sub fileparse_set_fstype { + $Fileparse_fstype = $_[0]; +} + +# fileparse() - parse file specification +# +# calling sequence: +# ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist); +# where $filespec is the file specification to be parsed, and +# @excludelist is a list of patterns which should be removed +# from the end of $filename. +# $filename is the part of $filespec after $prefix (i.e. the +# name of the file). The elements of @excludelist +# are compared to $filename, and if an +# $prefix is the path portion $filespec, up to and including +# the end of the last directory name +# $tail any characters removed from $filename because they +# matched an element of @excludelist. +# +# fileparse() first removes the directory specification from $filespec, +# according to the syntax of the OS (code is provided below to handle +# VMS, Unix, MSDOS and MacOS; you can pick the one you want using +# fileparse_set_fstype(), or you can accept the default, which is +# based on the information in the %Config array). 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', and +# $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,$idx); + + if ($fstype =~ /^VMS/i) { + if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation + else { + ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/); + $dirpath = $ENV{'PATH'} unless $dirpath; + } + } + if ($fstype =~ /^MSDOS/i) { + ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/); + $dirpath = '.' unless $dirpath; + } + elsif ($fstype =~ /^MAC/i) { + ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/); + } + else { # default to Unix + ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#); + $dirpath = '.' unless $dirpath; + } + + if (@suffices) { + foreach $suffix (@suffices) { + if ($basename =~ /($suffix)$/) { + $tail = $1 . $tail; + $basename = $`; + } + } + } + + ($basename,$dirpath,$tail); + +} + + +# basename() - returns first element of list returned by fileparse() + +sub basename { + (fileparse(@_))[0]; +} + + +# dirname() - returns device and directory portion of file specification +# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS +# filespecs. This differs from the second element of the list returned +# by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and +# the last directory name if the filespec ends in a '/' or '\'), is lost. + +sub dirname { + my($basename,$dirname) = fileparse($_[0]); + my($fstype) = $Fileparse_fstype; + + if ($fstype =~ /VMS/i) { + if (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; +} + +$Fileparse_fstype = $Config{'osname'}; + +1; diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm new file mode 100644 index 0000000000..d3dfa70084 --- /dev/null +++ b/lib/File/CheckTree.pm @@ -0,0 +1,112 @@ +package File::CheckTree; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(validate); + +# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $ + +# The validate routine takes a single multiline string consisting of +# lines containing a filename plus a file test to try on it. (The +# file test may also be a 'cd', causing subsequent relative filenames +# to be interpreted relative to that directory.) After the file test +# you may put '|| die' to make it a fatal error if the file test fails. +# The default is '|| warn'. The file test may optionally have a ! prepended +# to test for the opposite condition. If you do a cd and then list some +# relative filenames, you may want to indent them slightly for readability. +# If you supply your own "die" or "warn" message, you can use $file to +# interpolate the filename. + +# Filetests may be bunched: -rwx tests for all of -r, -w and -x. +# Only the first failed test of the bunch will produce a warning. + +# The routine returns the number of warnings issued. + +# Usage: +# use File::CheckTree; +# $warnings += validate(' +# /vmunix -e || die +# /boot -e || die +# /bin cd +# csh -ex +# csh !-ug +# sh -ex +# sh !-ug +# /usr -d || warn "What happened to $file?\n" +# '); + +sub validate { + local($file,$test,$warnings,$oldwarnings); + foreach $check (split(/\n/,$_[0])) { + next if $check =~ /^#/; + next if $check =~ /^$/; + ($file,$test) = split(' ',$check,2); + if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { + $testlist = $2; + @testlist = split(//,$testlist); + } + else { + @testlist = ('Z'); + } + $oldwarnings = $warnings; + foreach $one (@testlist) { + $this = $test; + $this =~ s/(-\w\b)/$1 \$file/g; + $this =~ s/-Z/-$one/; + $this .= ' || warn' unless $this =~ /\|\|/; + $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/; + $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; + eval $this; + last if $warnings > $oldwarnings; + } + } + $warnings; +} + +sub valmess { + local($disposition,$this) = @_; + $file = $cwd . '/' . $file unless $file =~ m|^/|; + if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { + $neg = $1; + $tmp = $2; + $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); + $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); + $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); + $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); + $tmp eq 'R' && ($mess = "$file is not readable by you."); + $tmp eq 'W' && ($mess = "$file is not writable by you."); + $tmp eq 'X' && ($mess = "$file is not executable by you."); + $tmp eq 'O' && ($mess = "$file is not owned by you."); + $tmp eq 'e' && ($mess = "$file does not exist."); + $tmp eq 'z' && ($mess = "$file does not have zero size."); + $tmp eq 's' && ($mess = "$file does not have non-zero size."); + $tmp eq 'f' && ($mess = "$file is not a plain file."); + $tmp eq 'd' && ($mess = "$file is not a directory."); + $tmp eq 'l' && ($mess = "$file is not a symbolic link."); + $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); + $tmp eq 'S' && ($mess = "$file is not a socket."); + $tmp eq 'b' && ($mess = "$file is not a block special file."); + $tmp eq 'c' && ($mess = "$file is not a character special file."); + $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); + $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); + $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); + $tmp eq 'T' && ($mess = "$file is not a text file."); + $tmp eq 'B' && ($mess = "$file is not a binary file."); + if ($neg eq '!') { + $mess =~ s/ is not / should not be / || + $mess =~ s/ does not / should not / || + $mess =~ s/ not / /; + } + print stderr $mess,"\n"; + } + else { + $this =~ s/\$file/'$file'/g; + print stderr "Can't do $this.\n"; + } + if ($disposition eq 'die') { exit 1; } + ++$warnings; +} + +1; + diff --git a/lib/File/Find.pm b/lib/File/Find.pm new file mode 100644 index 0000000000..612f14525a --- /dev/null +++ b/lib/File/Find.pm @@ -0,0 +1,224 @@ +package File::Find; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(find finddepth); + +# Usage: +# use File::Find; +# +# find(\&wanted, '/foo','/bar'); +# +# sub wanted { ... } +# where wanted does whatever you want. $dir contains the +# current directory name, and $_ the current filename within +# that directory. $name contains "$dir/$_". You are cd'ed +# to $dir when the function is called. The function may +# set $prune to prune the tree. +# +# This library is primarily for find2perl, which, when fed +# +# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune +# +# spits out something like this +# +# sub wanted { +# /^\.nfs.*$/ && +# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && +# int(-M _) > 7 && +# unlink($_) +# || +# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && +# $dev < 0 && +# ($prune = 1); +# } +# +# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats. + +sub find { + my $wanted = shift; + 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($wanted,$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($wanted,$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($wanted,$name,$nlink); + chdir '..'; + } + --$subcount; + } + } + } + } +} + +# Usage: +# use File::Find; +# +# finddepth(\&wanted, '/foo','/bar'); +# +# sub wanted { ... } +# where wanted does whatever you want. $dir contains the +# current directory name, and $_ the current filename within +# that directory. $name contains "$dir/$_". You are cd'ed +# to $dir when the function is called. The function may +# set $prune to prune the tree. +# +# This library is primarily for find2perl, which, when fed +# +# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune +# +# spits out something like this +# +# sub wanted { +# /^\.nfs.*$/ && +# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && +# int(-M _) > 7 && +# unlink($_) +# || +# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && +# $dev < 0 && +# ($prune = 1); +# } + +sub finddepth { + my $wanted = shift; + 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($wanted,$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 { + my($wanted,$dir,$nlink) = @_; + my($dev,$ino,$mode,$subcount); + my($name); + + # Get the list of files in the current directory. + + opendir(DIR,'.') || warn "Can't open $dir: $!\n"; + my(@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($wanted,$name,$nlink); + chdir '..'; + } + --$subcount; + } + } + &$wanted; + } + } +} + +1; + diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index 2452a15a1f..c45f446667 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -1,12 +1,12 @@ package FileHandle; -BEGIN { - require 5.000; - require English; import English; - require Exporter; -} +# Note that some additional FileHandle methods are defined in POSIX.pm. + +require 5.000; +use English; +use Exporter; -@ISA = (Exporter); +@ISA = qw(Exporter); @EXPORT = qw( print autoflush @@ -21,6 +21,7 @@ BEGIN { format_top_name format_line_break_characters format_formfeed + cacheout ); sub print { @@ -124,4 +125,50 @@ sub format_formfeed { $prev; } + +# --- cacheout functions --- + +# Open in their package. + +sub cacheout_open { + my $pack = caller(1); + open(*{$pack . '::' . $_[0]}, $_[1]); +} + +sub cacheout_close { + my $pack = caller(1); + close(*{$pack . '::' . $_[0]}); +} + +# But only this sub name is visible to them. + +sub cacheout { + ($file) = @_; + if (!$cacheout_maxopen){ + if (open(PARAM,'/usr/include/sys/param.h')) { + local($.); + while (<PARAM>) { + $cacheout_maxopen = $1 - 4 + if /^\s*#\s*define\s+NOFILE\s+(\d+)/; + } + close PARAM; + } + $cacheout_maxopen = 16 unless $cacheout_maxopen; + } + if (!$isopen{$file}) { + if (++$cacheout_numopen > $cacheout_maxopen) { + local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); + splice(@lru, $cacheout_maxopen / 3); + $cacheout_numopen -= @lru; + for (@lru) { &cacheout_close($_); delete $isopen{$_}; } + } + &cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file) + || croak("Can't create $file: $!"); + } + $isopen{$file} = ++$cacheout_seq; +} + +$cacheout_seq = 0; +$cacheout_numopen = 0; + 1; diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm new file mode 100644 index 0000000000..9c66264fdd --- /dev/null +++ b/lib/Getopt/Long.pm @@ -0,0 +1,513 @@ +package Getopt::Long; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(GetOptions); + + +# newgetopt.pl -- new options parsing + +# SCCS Status : @(#)@ newgetopt.pl 1.14 +# Author : Johan Vromans +# Created On : Tue Sep 11 15:00:12 1990 +# Last Modified By: Johan Vromans +# Last Modified On: Sat Feb 12 18:24:02 1994 +# Update Count : 138 +# Status : Okay + +################ 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,1994 by Johan Vromans. +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# If you do not have a copy of the GNU General Public License write to +# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +# MA 02139, USA. + +################ Description ################ +# +# Usage: +# +# require "newgetopt.pl"; +# ...change configuration values, if needed... +# $result = &NGetOpt (...option-descriptions...); +# +# Each description should designate a valid perl identifier, optionally +# followed by an argument specifier. +# +# Values for argument specifiers are: +# +# <none> option does not take an argument +# ! option does not take an argument and may be negated +# =s :s option takes a mandatory (=) or optional (:) string argument +# =i :i option takes a mandatory (=) or optional (:) integer argument +# =f :f option takes a mandatory (=) or optional (:) real number argument +# +# If option "name" is set, it will cause the perl variable $opt_name to +# be set to the specified value. The calling program can use this +# variable to detect whether the option has been set. Options that do +# not take an argument will be set to 1 (one). +# +# Options that take an optional argument will be defined, but set to '' +# if no actual argument has been supplied. +# +# If an "@" sign is appended to the argument specifier, the option is +# treated as an array. Value(s) are not set, but pushed into array +# @opt_name. +# +# Options that do not take a value may have an "!" argument spacifier to +# indicate that they may be negated. E.g. "foo!" will allow -foo (which +# sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0). +# +# The option name may actually be a list of option names, separated by +# '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and +# 'blech' will set $opt_foo instead. +# +# Option names may be abbreviated to uniqueness, depending on +# configuration variable $autoabbrev. +# +# Dashes in option names are allowed (e.g. pcc-struct-return) and will +# be translated to underscores in the corresponding perl variable (e.g. +# $opt_pcc_struct_return). Note that a lone dash "-" is considered an +# option, corresponding perl identifier is $opt_ . +# +# A double dash "--" signals end of the options list. +# +# If the first option of the list consists of non-alphanumeric +# characters only, it is interpreted as a generic option starter. +# Everything starting with one of the characters from the starter will +# be considered an option. +# +# The default values for the option starters are "-" (traditional), "--" +# (POSIX) and "+" (GNU, being phased out). +# +# Options that start with "--" may have an argument appended, separated +# with an "=", e.g. "--foo=bar". +# +# If configuration varaible $getopt_compat is set to a non-zero value, +# options that start with "+" may also include their arguments, +# e.g. "+foo=bar". +# +# A return status of 0 (false) indicates that the function detected +# one or more errors. +# +################ Some examples ################ +# +# If option "one:i" (i.e. takes an optional integer argument), then +# the following situations are handled: +# +# -one -two -> $opt_one = '', -two is next option +# -one -2 -> $opt_one = -2 +# +# Also, assume "foo=s" and "bar:s" : +# +# -bar -xxx -> $opt_bar = '', '-xxx' is next option +# -foo -bar -> $opt_foo = '-bar' +# -foo -- -> $opt_foo = '--' +# +# In GNU or POSIX format, option names and values can be combined: +# +# +foo=blech -> $opt_foo = 'blech' +# --bar= -> $opt_bar = '' +# --bar=-- -> $opt_bar = '--' +# +################ Configuration values ################ +# +# $autoabbrev Allow option names to be abbreviated to uniqueness. +# Default is 1 unless environment variable +# POSIXLY_CORRECT has been set. +# +# $getopt_compat Allow '+' to start options. +# Default is 1 unless environment variable +# POSIXLY_CORRECT has been set. +# +# $option_start Regexp with option starters. +# Default is (--|-) if environment variable +# POSIXLY_CORRECT has been set, (--|-|\+) otherwise. +# +# $order Whether non-options are allowed to be mixed with +# options. +# Default is $REQUIRE_ORDER if environment variable +# POSIXLY_CORRECT has been set, $PERMUTE otherwise. +# +# $ignorecase Ignore case when matching options. Default is 1. +# +# $debug Enable debugging output. Default is 0. + +################ History ################ +# +# 12-Feb-1994 Johan Vromans +# Added "!" for negation. +# Released to the net. +# +# 26-Aug-1992 Johan Vromans +# More POSIX/GNU compliance. +# Lone dash and double-dash are now independent of the option prefix +# that is used. +# Make errors in NGetOpt parameters fatal. +# Allow options to be mixed with arguments. +# Check $ENV{"POSIXLY_CORRECT"} to suppress this. +# Allow --foo=bar and +foo=bar (but not -foo=bar). +# Allow options to be abbreviated to minimum needed for uniqueness. +# (Controlled by configuration variable $autoabbrev.) +# Allow alias names for options (e.g. "foo|bar=s"). +# Allow "-" in option names (e.g. --pcc-struct-return). Dashes are +# translated to "_" to form valid perl identifiers +# (e.g. $opt_pcc_struct_return). +# +# 2-Jun-1992 Johan Vromans +# Do not use //o to allow multiple NGetOpt calls with different delimeters. +# Prevent typeless option from using previous $array state. +# Prevent empty option from being eaten as a (negative) number. +# +# 25-May-1992 Johan Vromans +# Add array options. "foo=s@" will return an array @opt_foo that +# contains all values that were supplied. E.g. "-foo one -foo -two" will +# return @opt_foo = ("one", "-two"); +# Correct bug in handling options that allow for a argument when followed +# by another option. +# +# 4-May-1992 Johan Vromans +# Add $ignorecase to match options in either case. +# Allow '' option. +# +# 19-Mar-1992 Johan Vromans +# Allow require from packages. +# NGetOpt is now defined in the package that requires it. +# @ARGV and $opt_... are taken from the package that calls it. +# Use standard (?) option prefixes: -, -- and +. +# +# 20-Sep-1990 Johan Vromans +# Set options w/o argument to 1. +# Correct the dreadful semicolon/require bug. + +################ Configuration Section ################ + +{ + + # Values for $order. See GNU getopt.c for details. + $REQUIRE_ORDER = 0; + $PERMUTE = 1; + $RETURN_IN_ORDER = 2; + + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $autoabbrev = 0; # no automatic abbrev of options (???) + $getopt_compat = 0; # disallow '+' to start options + $option_start = "(--|-)"; + $order = $REQUIRE_ORDER; + } + else { + $autoabbrev = 1; # automatic abbrev of options + $getopt_compat = 1; # allow '+' to start options + $option_start = "(--|-|\\+)"; + $order = $PERMUTE; + } + + # Other configurable settings. + $debug = 0; # for debugging + $ignorecase = 1; # ignore case when matching options + $argv_end = "--"; # don't change this! +} + +################ Subroutines ################ + +sub GetOptions { + + @optionlist = @_; #'; + + local ($[) = 0; + local ($genprefix) = $option_start; + local ($argend) = $argv_end; + local ($error) = 0; + local ($opt, $optx, $arg, $type, $mand, %opctl); + local ($pkg) = (caller)[0]; + local ($optarg); + local (%aliases); + local (@ret) = (); + + print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug; + + # See if the first element of the optionlist contains option + # starter characters. + if ( $optionlist[0] =~ /^\W+$/ ) { + $genprefix = shift (@optionlist); + # Turn into regexp. + $genprefix =~ s/(\W)/\\$1/g; + $genprefix = "[" . $genprefix . "]"; + } + + # Verify correctness of optionlist. + %opctl = (); + foreach $opt ( @optionlist ) { + $opt =~ tr/A-Z/a-z/ if $ignorecase; + if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) { + die ("Error in option spec: \"", $opt, "\"\n"); + $error++; + next; + } + local ($o, $c, $a) = ($1, $2); + + if ( ! defined $o ) { + $opctl{''} = defined $c ? $c : ''; + } + else { + # Handle alias names + foreach ( split (/\|/, $o)) { + if ( defined $c && $c eq '!' ) { + $opctl{"no$_"} = $c; + $c = ''; + } + $opctl{$_} = defined $c ? $c : ''; + if ( defined $a ) { + # Note alias. + $aliases{$_} = $a; + } + else { + # Set primary name. + $a = $_; + } + } + } + } + @opctl = sort(keys (%opctl)) if $autoabbrev; + + return 0 if $error; + + if ( $debug ) { + local ($arrow, $k, $v); + $arrow = "=> "; + while ( ($k,$v) = each(%opctl) ) { + print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); + $arrow = " "; + } + } + + # Process argument list + + while ( $#ARGV >= 0 ) { + + # >>> See also the continue block <<< + + #### Get next argument #### + + $opt = shift (@ARGV); + print STDERR ("=> option \"", $opt, "\"\n") if $debug; + $arg = undef; + $optarg = undef; + $array = 0; + + #### Determine what we have #### + + # Double dash is option list terminator. + if ( $opt eq $argend ) { + unshift (@ret, @ARGV) if $order == $PERMUTE; + return ($error == 0); + } + elsif ( $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_compat && $+ eq "+")) && + $opt =~ /^([^=]+)=/ ) { + $opt = $1; + $optarg = $'; + print STDERR ("=> option \"", $opt, + "\", optarg = \"$optarg\"\n") + if $debug; + } + + } + # Not an option. Save it if we may permute... + elsif ( $order == $PERMUTE ) { + push (@ret, $opt); + next; + } + # ...otherwise, terminate. + else { + # Push back and exit. + unshift (@ARGV, $opt); + return ($error == 0); + } + + #### Look it up ### + + $opt =~ tr/A-Z/a-z/ if $ignorecase; + + local ($tryopt) = $opt; + if ( $autoabbrev ) { + local ($pat, @hits); + + # Turn option name into pattern. + ($pat = $opt) =~ s/(\W)/\\$1/g; + # Look up in option names. + @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"); + $error++; + next; + } + + # Complete the option name, if appropriate. + if ( @hits == 1 && $hits[0] ne $opt ) { + $tryopt = $hits[0]; + print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") + if $debug; + } + } + + unless ( defined ( $type = $opctl{$tryopt} ) ) { + print STDERR ("Unknown option: ", $opt, "\n"); + $error++; + next; + } + $opt = $tryopt; + print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; + + #### Determine argument status #### + + # If it is an option w/o argument, we're almost finished with it. + if ( $type eq '' || $type eq '!' ) { + if ( defined $optarg ) { + print STDERR ("Option ", $opt, " does not take an argument\n"); + $error++; + } + elsif ( $type eq '' ) { + $arg = 1; # supply explicit value + } + else { + substr ($opt, 0, 2) = ''; # strip NO prefix + $arg = 0; # supply explicit value + } + next; + } + + # Get mandatory status and type info. + ($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"); + $error++; + } + if ( $mand eq ":" ) { + $arg = $type eq "s" ? '' : 0; + } + next; + } + + # Get (possibly optional) argument. + $arg = defined $optarg ? $optarg : shift (@ARGV); + + #### Check if the argument is valid for this option #### + + if ( $type eq "s" ) { # string + # A mandatory string takes anything. + 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 || + $arg =~ /^$genprefix.+/) { + # Push back. + unshift (@ARGV, $arg); + # Supply empty value. + $arg = ''; + } + next; + } + + if ( $type eq "n" || $type eq "i" ) { # numeric/integer + if ( $arg !~ /^-?[0-9]+$/ ) { + if ( defined $optarg || $mand eq "=" ) { + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (number expected)\n"); + $error++; + undef $arg; # don't assign it + } + else { + # Push back. + unshift (@ARGV, $arg); + # Supply default value. + $arg = 0; + } + } + next; + } + + if ( $type eq "f" ) { # fixed real number, int is also ok + if ( $arg !~ /^-?[0-9.]+$/ ) { + if ( defined $optarg || $mand eq "=" ) { + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); + $error++; + undef $arg; # don't assign it + } + else { + # Push back. + unshift (@ARGV, $arg); + # Supply default value. + $arg = 0.0; + } + } + next; + } + + die ("NGetOpt internal error (Can't happen)\n"); + } + + continue { + if ( defined $arg ) { + $opt = $aliases{$opt} if defined $aliases{$opt}; + # Make sure a valid perl identifier results. + $opt =~ s/\W/_/g; + if ( $array ) { + print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n") + if $debug; + eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);"); + } + else { + print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n") + if $debug; + eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;"); + } + } + } + + if ( $order == $PERMUTE && @ret > 0 ) { + unshift (@ARGV, @ret); + } + return ($error == 0); +} + +################ Package return ################ + +1; + + diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm new file mode 100644 index 0000000000..e1de3b531f --- /dev/null +++ b/lib/Getopt/Std.pm @@ -0,0 +1,104 @@ +package Getopt::Std; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(getopt getopts); + +# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ + +# Process single-character switches with switch clustering. Pass one argument +# which is a string containing all switches that take an argument. For each +# switch found, sets $opt_x (where x is the switch name) to the value of the +# argument, or 1 if no argument. Switches which take an argument don't care +# whether there is a space between the switch and the argument. + +# Usage: +# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + +sub getopt { + local($argumentative) = @_; + local($_,$first,$rest); + local $Exporter::ExportLevel; + + while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + if (index($argumentative,$first) >= 0) { + if ($rest ne '') { + shift(@ARGV); + } + else { + shift(@ARGV); + $rest = shift(@ARGV); + } + eval "\$opt_$first = \$rest;"; + push( @EXPORT, "\$opt_$first" ); + } + else { + eval "\$opt_$first = 1;"; + push( @EXPORT, "\$opt_$first" ); + if ($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift(@ARGV); + } + } + } + $Exporter::ExportLevel++; + import Getopt::Std; +} + +# Usage: +# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a +# # side effect. + +sub getopts { + local($argumentative) = @_; + local(@args,$_,$first,$rest); + local($errs) = 0; + local $Exporter::ExportLevel; + + @args = split( / */, $argumentative ); + while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + $pos = index($argumentative,$first); + if($pos >= 0) { + if($args[$pos+1] eq ':') { + shift(@ARGV); + if($rest eq '') { + ++$errs unless @ARGV; + $rest = shift(@ARGV); + } + eval "\$opt_$first = \$rest;"; + push( @EXPORT, "\$opt_$first" ); + } + else { + eval "\$opt_$first = 1"; + push( @EXPORT, "\$opt_$first" ); + if($rest eq '') { + shift(@ARGV); + } + else { + $ARGV[0] = "-$rest"; + } + } + } + else { + print STDERR "Unknown option: $first\n"; + ++$errs; + if($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift(@ARGV); + } + } + } + $Exporter::ExportLevel++; + import Getopt::Std; + $errs == 0; +} + +1; + diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm new file mode 100644 index 0000000000..52c78abe83 --- /dev/null +++ b/lib/I18N/Collate.pm @@ -0,0 +1,97 @@ +package I18N::Collate; + +# Collate.pm +# +# Author: Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi> +# Helsinki University of Technology, Finland +# +# Acks: Guy Decoux <decoux@moulon.inra.fr> understood +# overloading magic much deeper than I and told +# how to cut the size of this code by more than half. +# (my first version did overload all of lt gt eq le ge cmp) +# +# Purpose: compare 8-bit scalar data according to the current locale +# +# Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm() +# +# Exports: setlocale 1) +# collate_xfrm 2) +# +# Overloads: cmp # 3) +# +# Usage: use Collate; +# setlocale(&LC_COLLATE, 'locale-of-your-choice'); # 4) +# $s1 = new Collate "scalar_data_1"; +# $s2 = new Collate "scalar_data_2"; +# +# now you can compare $s1 and $s2: $s1 le $s2 +# to extract the data itself, you need to deref: $$s1 +# +# Notes: +# 1) this uses POSIX::setlocale +# 2) the basic collation conversion is done by strxfrm() which +# terminates at NUL characters being a decent C routine. +# collate_xfrm handles embedded NUL characters gracefully. +# 3) due to cmp and overload magic, lt le eq ge gt work also +# 4) the available locales depend on your operating system; +# try whether "locale -a" shows them or the more direct +# approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls". +# The locale names are probably something like +# 'xx_XX.(ISO)?8859-N'. +# +# Updated: 19940913 1341 GMT +# +# --- + +use POSIX qw(strxfrm LC_COLLATE); + +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(collate_xfrm setlocale LC_COLLATE); +@EXPORT_OK = qw(); + +%OVERLOAD = qw( +fallback 1 +cmp collate_cmp +); + +sub new { my $new = $_[1]; bless \$new } + +sub setlocale { + my ($category, $locale) = @_[0,1]; + + POSIX::setlocale($category, $locale) if (defined $category); + # the current $LOCALE + $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || ''; +} + +sub C { + my $s = ${$_[0]}; + + $C->{$LOCALE}->{$s} = collate_xfrm($s) + unless (defined $C->{$LOCALE}->{$s}); # cache when met + + $C->{$LOCALE}->{$s}; +} + +sub collate_xfrm { + my $s = $_[0]; + my $x = ''; + + for (split(/(\000+)/, $s)) { + $x .= (/^\000/) ? $_ : strxfrm("$_\000"); + } + + $x; +} + +sub collate_cmp { + &C($_[0]) cmp &C($_[1]); +} + +# init $LOCALE + +&I18N::Collate::setlocale(); + +1; # keep require happy diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm new file mode 100644 index 0000000000..c59c7d6897 --- /dev/null +++ b/lib/IPC/Open2.pm @@ -0,0 +1,62 @@ +package IPC::Open2; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(open2); + +# &open2: tom christiansen, <tchrist@convex.com> +# +# usage: $pid = open2('rdr', 'wtr', 'some cmd and args'); +# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); +# +# spawn the given $cmd and connect $rdr for +# reading and $wtr for writing. return pid +# of child, or 0 on failure. +# +# WARNING: this is dangerous, as you may block forever +# unless you are very careful. +# +# $wtr is left unbuffered. +# +# abort program if +# rdr or wtr are null +# pipe or fork or exec fails + +$fh = 'FHOPEN000'; # package static in case called more than once + +sub open2 { + local($kidpid); + local($dad_rdr, $dad_wtr, @cmd) = @_; + + $dad_rdr ne '' || croak "open2: rdr should not be null"; + $dad_wtr ne '' || croak "open2: wtr should not be null"; + + # force unqualified filehandles into callers' package + local($package) = caller; + $dad_rdr =~ s/^[^']+$/$package'$&/; + $dad_wtr =~ s/^[^']+$/$package'$&/; + + local($kid_rdr) = ++$fh; + local($kid_wtr) = ++$fh; + + pipe($dad_rdr, $kid_wtr) || croak "open2: pipe 1 failed: $!"; + pipe($kid_rdr, $dad_wtr) || croak "open2: pipe 2 failed: $!"; + + if (($kidpid = fork) < 0) { + croak "open2: fork failed: $!"; + } elsif ($kidpid == 0) { + close $dad_rdr; close $dad_wtr; + open(STDIN, "<&$kid_rdr"); + open(STDOUT, ">&$kid_wtr"); + warn "execing @cmd\n" if $debug; + exec @cmd; + croak "open2: exec of @cmd failed"; + } + close $kid_rdr; close $kid_wtr; + select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe + $kidpid; +} +1; # so require is happy + diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm new file mode 100644 index 0000000000..3426f19111 --- /dev/null +++ b/lib/IPC/Open3.pm @@ -0,0 +1,113 @@ +package IPC::Open3; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(open3); + +# &open3: Marc Horowitz <marc@mit.edu> +# derived mostly from &open2 by tom christiansen, <tchrist@convex.com> +# +# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ +# +# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); +# +# spawn the given $cmd and connect rdr for +# reading, wtr for writing, and err for errors. +# if err is '', or the same as rdr, then stdout and +# stderr of the child are on the same fh. returns pid +# of child, or 0 on failure. + + +# if wtr begins with '>&', then wtr will be closed in the parent, and +# the child will read from it directly. if rdr or err begins with +# '>&', then the child will send output directly to that fd. In both +# cases, there will be a dup() instead of a pipe() made. + + +# WARNING: this is dangerous, as you may block forever +# unless you are very careful. +# +# $wtr is left unbuffered. +# +# abort program if +# rdr or wtr are null +# pipe or fork or exec fails + +$fh = 'FHOPEN000'; # package static in case called more than once + +sub open3 { + local($kidpid); + local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; + local($dup_wtr, $dup_rdr, $dup_err); + + $dad_wtr || croak "open3: wtr should not be null"; + $dad_rdr || croak "open3: rdr should not be null"; + $dad_err = $dad_rdr if ($dad_err eq ''); + + $dup_wtr = ($dad_wtr =~ s/^\>\&//); + $dup_rdr = ($dad_rdr =~ s/^\>\&//); + $dup_err = ($dad_err =~ s/^\>\&//); + + # force unqualified filehandles into callers' package + local($package) = caller; + $dad_wtr =~ s/^[^']+$/$package'$&/; + $dad_rdr =~ s/^[^']+$/$package'$&/; + $dad_err =~ s/^[^']+$/$package'$&/; + + local($kid_rdr) = ++$fh; + local($kid_wtr) = ++$fh; + local($kid_err) = ++$fh; + + if (!$dup_wtr) { + pipe($kid_rdr, $dad_wtr) || croak "open3: pipe 1 (stdin) failed: $!"; + } + if (!$dup_rdr) { + pipe($dad_rdr, $kid_wtr) || croak "open3: pipe 2 (stdout) failed: $!"; + } + if ($dad_err ne $dad_rdr && !$dup_err) { + pipe($dad_err, $kid_err) || croak "open3: pipe 3 (stderr) failed: $!"; + } + + if (($kidpid = fork) < 0) { + croak "open2: fork failed: $!"; + } elsif ($kidpid == 0) { + if ($dup_wtr) { + open(STDIN, ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); + } else { + close($dad_wtr); + open(STDIN, ">&$kid_rdr"); + } + if ($dup_rdr) { + open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); + } else { + close($dad_rdr); + open(STDOUT, ">&$kid_wtr"); + } + if ($dad_rdr ne $dad_err) { + if ($dup_err) { + open(STDERR, ">&$dad_err") + if (fileno(STDERR) != fileno($dad_err)); + } else { + close($dad_err); + open(STDERR, ">&$kid_err"); + } + } else { + open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); + } + local($")=(" "); + exec @cmd; + croak "open2: exec of @cmd failed"; + } + + close $kid_rdr; close $kid_wtr; close $kid_err; + if ($dup_wtr) { + close($dad_wtr); + } + + select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe + $kidpid; +} +1; # so require is happy + diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm new file mode 100644 index 0000000000..92e701666f --- /dev/null +++ b/lib/Math/BigFloat.pm @@ -0,0 +1,297 @@ +package Math::BigFloat; + +use Math::BigInt; + +use Exporter; # just for use to be happy +@ISA = (Exporter); + +%OVERLOAD = ( + # Anonymous subroutines: +'+' => sub {new BigFloat &fadd}, +'-' => sub {new BigFloat + $_[2]? fsub($_[1],${$_[0]}) : fsub(${$_[0]},$_[1])}, +'<=>' => sub {new BigFloat + $_[2]? fcmp($_[1],${$_[0]}) : fcmp(${$_[0]},$_[1])}, +'cmp' => sub {new BigFloat + $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, +'*' => sub {new BigFloat &fmul}, +'/' => sub {new BigFloat + $_[2]? scalar fdiv($_[1],${$_[0]}) : + scalar fdiv(${$_[0]},$_[1])}, +'neg' => sub {new BigFloat &fneg}, +'abs' => sub {new BigFloat &fabs}, + +qw( +"" stringify +0+ numify) # Order of arguments unsignificant +); + +sub new { + my $foo = fnorm($_[1]); + panic("Not a number initialized to BigFloat") if $foo eq "NaN"; + bless \$foo; +} +sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead + # comparing to direct compilation based on + # stringify +sub stringify { + my $n = ${$_[0]}; + + $n =~ s/^\+//; + $n =~ s/E//; + + $n =~ s/([-+]\d+)$//; + + my $e = $1; + my $ln = length($n); + + if ($e > 0) { + $n .= "0" x $e . '.'; + } elsif (abs($e) < $ln) { + substr($n, $ln + $e, 0) = '.'; + } else { + $n = '.' . ("0" x (abs($e) - $ln)) . $n; + } + + # 1 while $n =~ s/(.*\d)(\d\d\d)/$1,$2/; + + return $n; +} + +# Arbitrary length float math package +# +# by Mark Biggar +# +# number format +# canonical strings have the form /[+-]\d+E[+-]\d+/ +# Input values can have inbedded whitespace +# Error returns +# 'NaN' An input parameter was "Not a Number" or +# divide by zero or sqrt of negative number +# Division is computed to +# max($div_scale,length(dividend)+length(divisor)) +# digits by default. +# Also used for default sqrt scale + +$div_scale = 40; + +# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'. + +$rnd_mode = 'even'; + +sub fadd; sub fsub; sub fmul; sub fdiv; +sub fneg; sub fabs; sub fcmp; +sub fround; sub ffround; +sub fnorm; sub fsqrt; + +# bigfloat routines +# +# fadd(NSTR, NSTR) return NSTR addition +# fsub(NSTR, NSTR) return NSTR subtraction +# fmul(NSTR, NSTR) return NSTR multiplication +# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places +# fneg(NSTR) return NSTR negation +# fabs(NSTR) return NSTR absolute value +# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0 +# fround(NSTR, SCALE) return NSTR round to SCALE digits +# ffround(NSTR, SCALE) return NSTR round at SCALEth place +# fnorm(NSTR) return (NSTR) normalize +# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places + + +# Convert a number to canonical string form. +# Takes something that looks like a number and converts it to +# the form /^[+-]\d+E[+-]\d+$/. +sub fnorm { #(string) return fnum_str + local($_) = @_; + s/\s+//g; # strip white space + if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') { + &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6)); + } else { + 'NaN'; + } +} + +# normalize number -- for internal use +sub norm { #(mantissa, exponent) return fnum_str + local($_, $exp) = @_; + if ($_ eq 'NaN') { + 'NaN'; + } else { + s/^([+-])0+/$1/; # strip leading zeros + if (length($_) == 1) { + '+0E+0'; + } else { + $exp += length($1) if (s/(0+)$//); # strip trailing zeros + sprintf("%sE%+ld", $_, $exp); + } + } +} + +# negation +sub fneg { #(fnum_str) return fnum_str + local($_) = fnorm($_[$[]); + vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign + s/^H/N/; + $_; +} + +# absolute value +sub fabs { #(fnum_str) return fnum_str + local($_) = fnorm($_[$[]); + s/^-/+/; # mash sign + $_; +} + +# multiplication +sub fmul { #(fnum_str, fnum_str) return fnum_str + local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1])); + if ($x eq 'NaN' || $y eq 'NaN') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + local($ym,$ye) = split('E',$y); + &norm(Math::BigInt::bmul($xm,$ym),$xe+$ye); + } +} + +# addition +sub fadd { #(fnum_str, fnum_str) return fnum_str + local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1])); + if ($x eq 'NaN' || $y eq 'NaN') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + local($ym,$ye) = split('E',$y); + ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye); + &norm(Math::BigInt::badd($ym,$xm.('0' x ($xe-$ye))),$ye); + } +} + +# subtraction +sub fsub { #(fnum_str, fnum_str) return fnum_str + fadd($_[$[],fneg($_[$[+1])); +} + +# division +# args are dividend, divisor, scale (optional) +# result has at most max(scale, length(dividend), length(divisor)) digits +sub fdiv #(fnum_str, fnum_str[,scale]) return fnum_str +{ + local($x,$y,$scale) = (fnorm($_[$[]),fnorm($_[$[+1]),$_[$[+2]); + if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + local($ym,$ye) = split('E',$y); + $scale = $div_scale if (!$scale); + $scale = length($xm)-1 if (length($xm)-1 > $scale); + $scale = length($ym)-1 if (length($ym)-1 > $scale); + $scale = $scale + length($ym) - length($xm); + &norm(&round(Math::BigInt::bdiv($xm.('0' x $scale),$ym),$ym), + $xe-$ye-$scale); + } +} + +# round int $q based on fraction $r/$base using $rnd_mode +sub round { #(int_str, int_str, int_str) return int_str + local($q,$r,$base) = @_; + if ($q eq 'NaN' || $r eq 'NaN') { + 'NaN'; + } elsif ($rnd_mode eq 'trunc') { + $q; # just truncate + } else { + local($cmp) = Math::BigInt::bcmp(Math::BigInt::bmul($r,'+2'),$base); + if ( $cmp < 0 || + ($cmp == 0 && + ( $rnd_mode eq 'zero' || + ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) || + ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) || + ($rnd_mode eq 'even' && $q =~ /[24680]$/) || + ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) { + $q; # round down + } else { + Math::BigInt::badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1')); + # round up + } + } +} + +# round the mantissa of $x to $scale digits +sub fround { #(fnum_str, scale) return fnum_str + local($x,$scale) = (fnorm($_[$[]),$_[$[+1]); + if ($x eq 'NaN' || $scale <= 0) { + $x; + } else { + local($xm,$xe) = split('E',$x); + if (length($xm)-1 <= $scale) { + $x; + } else { + &norm(&round(substr($xm,$[,$scale+1), + "+0".substr($xm,$[+$scale+1,1),"+10"), + $xe+length($xm)-$scale-1); + } + } +} + +# round $x at the 10 to the $scale digit place +sub ffround { #(fnum_str, scale) return fnum_str + local($x,$scale) = (fnorm($_[$[]),$_[$[+1]); + if ($x eq 'NaN') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + if ($xe >= $scale) { + $x; + } else { + $xe = length($xm)+$xe-$scale; + if ($xe < 1) { + '+0E+0'; + } elsif ($xe == 1) { + &norm(&round('+0',"+0".substr($xm,$[+1,1),"+10"), $scale); + } else { + &norm(&round(substr($xm,$[,$xe), + "+0".substr($xm,$[+$xe,1),"+10"), $scale); + } + } + } +} + +# compare 2 values returns one of undef, <0, =0, >0 +# returns undef if either or both input value are not numbers +sub fcmp #(fnum_str, fnum_str) return cond_code +{ + local($x, $y) = (fnorm($_[$[]),fnorm($_[$[+1])); + if ($x eq "NaN" || $y eq "NaN") { + undef; + } else { + ord($y) <=> ord($x) + || + ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"), + (($xe <=> $ye) * (substr($x,$[,1).'1') + || Math::BigInt::cmp($xm,$ym)) + ); + } +} + +# square root by Newtons method. +sub fsqrt { #(fnum_str[, scale]) return fnum_str + local($x, $scale) = (fnorm($_[$[]), $_[$[+1]); + if ($x eq 'NaN' || $x =~ /^-/) { + 'NaN'; + } elsif ($x eq '+0E+0') { + '+0E+0'; + } else { + local($xm, $xe) = split('E',$x); + $scale = $div_scale if (!$scale); + $scale = length($xm)-1 if ($scale < length($xm)-1); + local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2)); + while ($gs < 2*$scale) { + $guess = fmul(fadd($guess,fdiv($x,$guess,$gs*2)),".5"); + $gs *= 2; + } + new BigFloat &fround($guess, $scale); + } +} + +1; diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm new file mode 100644 index 0000000000..3e0fc17ff6 --- /dev/null +++ b/lib/Math/BigInt.pm @@ -0,0 +1,347 @@ +package Math::BigInt; + +%OVERLOAD = ( + # Anonymous subroutines: +'+' => sub {new BigInt &badd}, +'-' => sub {new BigInt + $_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])}, +'<=>' => sub {new BigInt + $_[2]? bcmp($_[1],${$_[0]}) : bcmp(${$_[0]},$_[1])}, +'cmp' => sub {new BigInt + $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, +'*' => sub {new BigInt &bmul}, +'/' => sub {new BigInt + $_[2]? scalar bdiv($_[1],${$_[0]}) : + scalar bdiv(${$_[0]},$_[1])}, +'%' => sub {new BigInt + $_[2]? bmod($_[1],${$_[0]}) : bmod(${$_[0]},$_[1])}, +'**' => sub {new BigInt + $_[2]? bpow($_[1],${$_[0]}) : bpow(${$_[0]},$_[1])}, +'neg' => sub {new BigInt &bneg}, +'abs' => sub {new BigInt &babs}, + +qw( +"" stringify +0+ numify) # Order of arguments unsignificant +); + +sub new { + my $foo = bnorm($_[1]); + die "Not a number initialized to BigInt" if $foo eq "NaN"; + bless \$foo; +} +sub stringify { "${$_[0]}" } +sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead + # comparing to direct compilation based on + # stringify + +# arbitrary size integer math package +# +# by Mark Biggar +# +# Canonical Big integer value are strings of the form +# /^[+-]\d+$/ with leading zeros suppressed +# Input values to these routines may be strings of the form +# /^\s*[+-]?[\d\s]+$/. +# Examples: +# '+0' canonical zero value +# ' -123 123 123' canonical value '-123123123' +# '1 23 456 7890' canonical value '+1234567890' +# Output values always always in canonical form +# +# Actual math is done in an internal format consisting of an array +# whose first element is the sign (/^[+-]$/) and whose remaining +# elements are base 100000 digits with the least significant digit first. +# The string 'NaN' is used to represent the result when input arguments +# are not numbers, as well as the result of dividing by zero +# +# routines provided are: +# +# bneg(BINT) return BINT negation +# babs(BINT) return BINT absolute value +# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0) +# badd(BINT,BINT) return BINT addition +# bsub(BINT,BINT) return BINT subtraction +# bmul(BINT,BINT) return BINT multiplication +# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar +# bmod(BINT,BINT) return BINT modulus +# bgcd(BINT,BINT) return BINT greatest common divisor +# bnorm(BINT) return BINT normalization +# + +$zero = 0; + + +# normalize string form of number. Strip leading zeros. Strip any +# white space and add a sign, if missing. +# Strings that are not numbers result the value 'NaN'. + +sub bnorm { #(num_str) return num_str + local($_) = @_; + s/\s+//g; # strip white space + if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number + substr($_,$[,0) = '+' unless $1; # Add missing sign + s/^-0/+0/; + $_; + } else { + 'NaN'; + } +} + +# Convert a number from string format to internal base 100000 format. +# Assumes normalized value as input. +sub internal { #(num_str) return int_num_array + local($d) = @_; + ($is,$il) = (substr($d,$[,1),length($d)-2); + substr($d,$[,1) = ''; + ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d))); +} + +# Convert a number from internal base 100000 format to string format. +# This routine scribbles all over input array. +sub external { #(int_num_array) return num_str + $es = shift; + grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad + &bnorm(join('', $es, reverse(@_))); # reverse concat and normalize +} + +# Negate input value. +sub bneg { #(num_str) return num_str + local($_) = &bnorm(@_); + vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; + s/^H/N/; + $_; +} + +# Returns the absolute value of the input. +sub babs { #(num_str) return num_str + &abs(&bnorm(@_)); +} + +sub abs { # post-normalized abs for internal use + local($_) = @_; + s/^-/+/; + $_; +} + +# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) +sub bcmp { #(num_str, num_str) return cond_code + local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1])); + if ($x eq 'NaN') { + undef; + } elsif ($y eq 'NaN') { + undef; + } else { + &cmp($x,$y); + } +} + +sub cmp { # post-normalized compare for internal use + local($cx, $cy) = @_; + $cx cmp $cy + && + ( + ord($cy) <=> ord($cx) + || + ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx) + ); +} + +sub badd { #(num_str, num_str) return num_str + local(*x, *y); ($x, $y) = (&bnorm($_[$[]),&bnorm($_[$[+1])); + if ($x eq 'NaN') { + 'NaN'; + } elsif ($y eq 'NaN') { + 'NaN'; + } else { + @x = &internal($x); # convert to internal form + @y = &internal($y); + local($sx, $sy) = (shift @x, shift @y); # get signs + if ($sx eq $sy) { + &external($sx, &add(*x, *y)); # if same sign add + } else { + ($x, $y) = (&abs($x),&abs($y)); # make abs + if (&cmp($y,$x) > 0) { + &external($sy, &sub(*y, *x)); + } else { + &external($sx, &sub(*x, *y)); + } + } + } +} + +sub bsub { #(num_str, num_str) return num_str + &badd($_[$[],&bneg($_[$[+1])); +} + +# GCD -- Euclids algorithm Knuth Vol 2 pg 296 +sub bgcd { #(num_str, num_str) return num_str + local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1])); + if ($x eq 'NaN' || $y eq 'NaN') { + 'NaN'; + } else { + ($x, $y) = ($y,&bmod($x,$y)) while $y ne '+0'; + $x; + } +} + +# routine to add two base 1e5 numbers +# stolen from Knuth Vol 2 Algorithm A pg 231 +# there are separate routines to add and sub as per Kunth pg 233 +sub add { #(int_num_array, int_num_array) return int_num_array + local(*x, *y) = @_; + $car = 0; + for $x (@x) { + last unless @y || $car; + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); + } + for $y (@y) { + last unless $car; + $y -= 1e5 if $car = (($y += $car) >= 1e5); + } + (@x, @y, $car); +} + +# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y +sub sub { #(int_num_array, int_num_array) return int_num_array + local(*sx, *sy) = @_; + $bar = 0; + for $sx (@sx) { + last unless @y || $bar; + $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); + } + @sx; +} + +# multiply two numbers -- stolen from Knuth Vol 2 pg 233 +sub bmul { #(num_str, num_str) return num_str + local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1])); + if ($x eq 'NaN') { + 'NaN'; + } elsif ($y eq 'NaN') { + 'NaN'; + } else { + @x = &internal($x); + @y = &internal($y); + &external(&mul(*x,*y)); + } +} + +# multiply two numbers in internal representation +# destroys the arguments, supposes that two arguments are different +sub mul { #(*int_num_array, *int_num_array) return int_num_array + local(*x, *y) = (shift, shift); + local($signr) = (shift @x ne shift @y) ? '-' : '+'; + @prod = (); + for $x (@x) { + ($car, $cty) = (0, $[); + for $y (@y) { + $prod = $x * $y + $prod[$cty] + $car; + $prod[$cty++] = + $prod - ($car = int($prod * 1e-5)) * 1e5; + } + $prod[$cty] += $car if $car; + $x = shift @prod; + } + ($signr, @x, @prod); +} + +# modulus +sub bmod { #(num_str, num_str) return num_str + (&bdiv(@_))[$[+1]; +} + +sub bdiv { #(dividend: num_str, divisor: num_str) return num_str + local (*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1])); + return wantarray ? ('NaN','NaN') : 'NaN' + if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0'); + return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0); + @x = &internal($x); @y = &internal($y); + $srem = $y[$[]; + $sr = (shift @x ne shift @y) ? '-' : '+'; + $car = $bar = $prd = 0; + if (($dd = int(1e5/($y[$#y]+1))) != 1) { + for $x (@x) { + $x = $x * $dd + $car; + $x -= ($car = int($x * 1e-5)) * 1e5; + } + push(@x, $car); $car = 0; + for $y (@y) { + $y = $y * $dd + $car; + $y -= ($car = int($y * 1e-5)) * 1e5; + } + } + else { + push(@x, 0); + } + @q = (); ($v2,$v1) = @y[-2,-1]; + while ($#x > $#y) { + ($u2,$u1,$u0) = @x[-3..-1]; + $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1)); + --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2); + if ($q) { + ($car, $bar) = (0,0); + for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { + $prd = $q * $y[$y] + $car; + $prd -= ($car = int($prd * 1e-5)) * 1e5; + $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0)); + } + if ($x[$#x] < $car + $bar) { + $car = 0; --$q; + for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) { + $x[$x] -= 1e5 + if ($car = (($x[$x] += $y[$y] + $car) > 1e5)); + } + } + } + pop(@x); unshift(@q, $q); + } + if (wantarray) { + @d = (); + if ($dd != 1) { + $car = 0; + for $x (reverse @x) { + $prd = $car * 1e5 + $x; + $car = $prd - ($tmp = int($prd / $dd)) * $dd; + unshift(@d, $tmp); + } + } + else { + @d = @x; + } + (&external($sr, @q), &external($srem, @d, $zero)); + } else { + &external($sr, @q); + } +} + +# compute power of two numbers -- stolen from Knuth Vol 2 pg 233 +sub bpow { #(num_str, num_str) return num_str + local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1])); + if ($x eq 'NaN') { + 'NaN'; + } elsif ($y eq 'NaN') { + 'NaN'; + } elsif ($x eq '+1') { + '+1'; + } elsif ($x eq '-1') { + &bmod($x,2) ? '-1': '+1'; + } elsif ($y =~ /^-/) { + 'NaN'; + } elsif ($x eq '+0' && $y eq '+0') { + 'NaN'; + } else { + @x = &internal($x); + local(@pow2)=@x; + local(@pow)=&internal("+1"); + local($y1,$res,@tmp1,@tmp2)=(1); # need tmp to send to mul + while ($y ne '+0') { + ($y,$res)=&bdiv($y,2); + if ($res ne '+0') {@tmp=@pow2; @pow=&mul(*pow,*tmp);} + if ($y ne '+0') {@tmp=@pow2;@pow2=&mul(*pow2,*tmp);} + } + &external(@pow); + } +} + +1; diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm new file mode 100644 index 0000000000..a5a40b2486 --- /dev/null +++ b/lib/Math/Complex.pm @@ -0,0 +1,136 @@ +# +# Perl5 Package for complex numbers +# +# 1994 by David Nadler +# Coding know-how provided by Tom Christiansen, Tim Bunce, and Larry Wall +# sqrt() added by Tom Christiansen; beware should have two roots, +# but only returns one. (use wantarray?) +# +# +# The functions "Re", "Im", and "arg" are provided. +# "~" is used as the conjugation operator and "abs" is overloaded. +# +# Transcendental functions overloaded: so far only sin, cos, and exp. +# + +package Math::Complex; + +require Exporter; + +@ISA = ('Exporter'); + +# just to make use happy + +%OVERLOAD= ( + '+' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); + bless [ $x1+$x2, $y1+$y2]; + }, + + '-' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); + bless [ $x1-$x2, $y1-$y2]; + }, + + '*' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); + bless [ $x1*$x2-$y1*$y2,$x1*$y2+$x2*$y1]; + }, + + '/' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); + my $q = $x2*$x2+$y2*$y2; + bless [($x1*$x2+$y1*$y2)/$q, ($y1*$x2-$y2*$x1)/$q]; + }, + + 'neg' => sub { my($x,$y) = @{$_[0]}; bless [ -$x, -$y]; + }, + + '~' => sub { my($x,$y) = @{$_[0]}; bless [ $x, -$y]; + }, + + 'abs' => sub { my($x,$y) = @{$_[0]}; sqrt $x*$x+$y*$y; + }, + + 'cos' => sub { my($x,$y) = @{$_[0]}; + my ($ab,$c,$s) = (exp $y, cos $x, sin $x); + my $abr = 1/(2*$ab); $ab /= 2; + bless [ ($abr+$ab)*$c, ($abr-$ab)*$s]; + }, + + 'sin' => sub { my($x,$y) = @{$_[0]}; + my ($ab,$c,$s) = (exp $y, cos $x, sin $x); + my $abr = 1/(2*$ab); $ab /= 2; + bless [ (-$abr-$ab)*$s, ($abr-$ab)*$c]; + }, + + 'exp' => sub { my($x,$y) = @{$_[0]}; + my ($ab,$c,$s) = (exp $x, cos $y, sin $y); + bless [ $ab*$c, $ab*$s ]; + }, + + 'sqrt' => sub { + my($zr,$zi) = @{$_[0]}; + my ($x, $y, $r, $w); + my $c = new Math::Complex (0,0); + if (($zr == 0) && ($zi == 0)) { + # nothing, $c already set + } + else { + $x = abs($zr); + $y = abs($zi); + if ($x >= $y) { + $r = $y/$x; + $w = sqrt($x) * sqrt(0.5*(1.0+sqrt(1.0+$r*$r))); + } + else { + $r = $x/$y; + $w = sqrt($y) * sqrt($y) * sqrt(0.5*($r+sqrt(1.0+$r*$r))); + } + if ( $zr >= 0) { + @$c = ($w, $zi/(2 * $w) ); + } + else { + $c->[1] = ($zi >= 0) ? $w : -$w; + $c->[0] = $zi/(2.0* $c->[1]); + } + } + return $c; + }, + + qw("" stringify) +); + +sub new { + shift; + my @C = @_; + bless \@C; +} + +sub Re { + my($x,$y) = @{$_[0]}; + $x; +} + +sub Im { + my($x,$y) = @{$_[0]}; + $y; +} + +sub arg { + my($x,$y) = @{$_[0]}; + atan2($y,$x); +} + +sub stringify { + my($x,$y) = @{$_[0]}; + my($re,$im); + + $re = $x if ($x); + if ($y == 1) {$im = 'i';} + elsif ($y == -1){$im = '-i';} + elsif ($y) {$im = "${y}i"; } + + local $_ = $re.'+'.$im; + s/\+-/-/; + s/^\+//; + s/[\+-]$//; + $_ = 0 if ($_ eq ''); + return $_; +} diff --git a/lib/NDBM_File.pm b/lib/NDBM_File.pm deleted file mode 100644 index 637001f71c..0000000000 --- a/lib/NDBM_File.pm +++ /dev/null @@ -1,9 +0,0 @@ -package NDBM_File; - -require Exporter; -@ISA = (Exporter, DynamicLoader); -@EXPORT = split(' ', 'new fetch store delete firstkey nextkey error clearerr'); - -bootstrap NDBM_File; - -1; diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm new file mode 100644 index 0000000000..2528f55255 --- /dev/null +++ b/lib/Net/Ping.pm @@ -0,0 +1,64 @@ +package Net::Ping; + +# Authors: karrer@bernina.ethz.ch (Andreas Karrer) +# pmarquess@bfsec.bt.co.uk (Paul Marquess) + +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(ping pingecho); + +use Socket; +use Carp ; + +$tcp_proto = (getprotobyname('tcp'))[2]; +$echo_port = (getservbyname('echo', 'tcp'))[2]; + +sub ping { + croak "ping not implemented yet. Use pingecho()"; +} + + +sub pingecho { + + croak "usage: pingecho host [timeout]" + unless @_ == 1 || @_ == 2 ; + + local ($host, $timeout) = @_; + local (*PINGSOCK); + local ($saddr, $ip); + local ($ret) ; + + # check if $host is alive by connecting to its echo port, within $timeout + # (default 5) seconds. returns 1 if OK, 0 if no answer, 0 if host not found + + $timeout = 5 unless $timeout; + + if ($host =~ /^\s*((\d+\.){3}\d+)\s*$/) + { $ip = pack ('C4', split (/\./, $1)) } + else + { $ip = (gethostbyname($host))[4] } + + return 0 unless $ip; # "no such host" + + $saddr = pack('S n a4 x8', AF_INET, $echo_port, $ip); + $SIG{'ALRM'} = sub { die } ; + alarm($timeout); + + $ret = eval <<'EOM' ; + + return 0 + unless socket(PINGSOCK, PF_INET, SOCK_STREAM, $tcp_proto) ; + + return 0 + unless connect(PINGSOCK, $saddr) ; + + return 1 ; +EOM + + alarm(0); + close(PINGSOCK); + $ret == 1 ? 1 : 0 ; +} + +1; diff --git a/lib/POSIX.pm b/lib/POSIX.pm deleted file mode 100644 index e2ccbccac0..0000000000 --- a/lib/POSIX.pm +++ /dev/null @@ -1,1232 +0,0 @@ -package POSIX; - -require Exporter; -require AutoLoader; -@ISA = (Exporter, AutoLoader, DynamicLoader); - -$H{assert_h} = [qw(assert NDEBUG)]; - -$H{ctype_h} = [qw(isalnum isalpha iscntrl isdigit isgraph islower - isprint ispunct isspace isupper isxdigit tolower toupper)]; - -$H{dirent_h} = [qw(closedir opendir readdir rewinddir)]; - -$H{errno_h} = [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM - EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE - EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK - ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO - EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)]; - -$H{fcntl_h} = [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK - F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK - O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK - O_RDONLY O_RDWR O_TRUNC O_WRONLY - creat fcntl open - SEEK_CUR SEEK_END SEEK_SET - S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID - S_IWGRP S_IWOTH S_IWUSR)]; - -$H{float_h} = [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG - DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP - DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP - FLT_DIG FLT_EPSILON FLT_MANT_DIG - FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP - FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP - FLT_RADIX FLT_ROUNDS - LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG - LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP - LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)]; - -$H{grp_h} = [qw(getgrgid getgrnam)]; - -$H{limits_h} = [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX - INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON - MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX - PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN - SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX - ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX - _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT - _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX - _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX - _POSIX_STREADM_MAX _POSIX_TZNAME_MAX)]; - -$H{locale_h} = [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC - LC_TIME NULL localeconv setlocale)]; - -$H{math_h} = [qw(HUGE_VAL acos asin atan2 atan ceil cos cosh exp - fabs floor fmod frexp ldexp log10 log modf pow sin sinh - sqrt tan tanh)]; - -$H{pwd_h} = [qw(getpwnam getpwuid)]; - -$H{setjmp_h} = [qw(longjmp setjmp siglongjmp sigsetjmp)]; - -$H{signal_h} = [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE - SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV - SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 - SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK - kill raise sigaction signal sigpending sigprocmask - sigsuspend)]; - -$H{stdarg_h} = [qw()]; - -$H{stddef_h} = [qw(NULL offsetof)]; - -$H{stdio_h} = [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid - L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET STREAM_MAX - TMP_MAX stderr stdin stdout _IOFBF _IOLBF _IONBF - clearerr fclose fdopen feof ferror fflush fgetc fgetpos - fgets fileno fopen fprintf fputc fputs fread freopen - fscanf fseek fsetpos ftell fwrite getc getchar gets - perror printf putc putchar puts remove rename rewind - scanf setbuf setvbuf sprintf sscanf tmpfile tmpnam - ungetc vfprintf vprintf vsprintf)]; - -$H{stdlib_h} = [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX - abort abs atexit atof atoi atol bsearch calloc div exit - free getenv labs ldiv malloc mblen mbstowcs mbtowc - qsort rand realloc srand strtod strtol stroul system - wcstombs wctomb)]; - -$H{string_h} = [qw(NULL memchr memcmp memcpy memmove memset strcat - strchr strcmp strcoll strcpy strcspn strerror strlen - strncat strncmp strncpy strpbrk strrchr strspn strstr - strtok strxfrm)]; - -$H{sys_stat_h} = [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG - S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR - chmod fstat mkdir mkfifo stat umask)]; - -$H{sys_times_h} = [qw(times)]; - -$H{sys_types_h} = [qw()]; - -$H{sys_utsname_h} = [qw(uname)]; - -$H{sys_wait_h} = [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED - WNOHANG WSTOPSIG WTERMSIG WUNTRACED wait waitpid)]; - -$H{termios_h} = [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 - B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL - CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK - ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR - INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST - PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION - TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW - TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART - VSTOP VSUSP VTIME - cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain - tcflow tcflush tcgetattr tcsendbreak tcsetattr )]; - -$H{time_h} = [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime - difftime gmtime localtime mktime strftime time tzset tzname)]; - -$H{unistd_h} = [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET - STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK - _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON - _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX - _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED - _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS - _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX - _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL - _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS - _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION - _exit access alarm chdir chown close ctermid cuserid - dup2 dup execl execle execlp execv execve execvp fork - fpathconf getcwd getegid geteuid getgid getgroups - getlogin getpgrp getpid getppid getuid isatty link - lseek pathconf pause pipe read rmdir setgid setpgid - setsid setuid sleep sysconf tcgetpgrp tcsetpgrp ttyname - unlink write)]; - -$H{utime_h} = [qw(utime)]; - -sub expand { - local (@mylist); - foreach $entry (@_) { - if ($H{$entry}) { - push(@mylist, @{$H{$entry}}); - } - else { - push(@mylist, $entry); - } - } - @mylist; -} - -@EXPORT = expand qw(assert_h ctype_h dirent_h errno_h fcntl_h float_h - grp_h limits_h locale_h math_h pwd_h setjmp_h signal_h - stdarg_h stddef_h stdio_h stdlib_h string_h sys_stat_h - sys_times_h sys_types_h sys_utsname_h sys_wait_h - termios_h time_h unistd_h utime_h); - -sub import { - my $this = shift; - my @list = expand @_; - local $Exporter::ExportLevel = 1; - Exporter::import($this,@list); -} - -sub AUTOLOAD { - if ($AUTOLOAD =~ /::(_?[a-z])/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD - } - local $constname = $AUTOLOAD; - $constname =~ s/.*:://; - $val = constant($constname, $_[0]); - if ($! != 0) { - ($pack,$file,$line) = caller; - if ($! =~ /Invalid/) { - die "$constname is not a valid POSIX macro at $file line $line.\n"; - } - else { - die "Your vendor has not defined POSIX macro $constname, used at $file line $line.\n"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -bootstrap POSIX; - -sub usage { - local ($mess, $pack, $file, $line) = @_; - die "Usage: POSIX::$mess at $file line $line\n"; -} - -sub unimpl { - local ($mess, $pack, $file, $line) = @_; - $mess =~ s/xxx//; - die "Unimplemented: POSIX::$mess at $file line $line\n"; -} - -$gensym = "SYM000"; - -sub gensym { - $gensym++; -} - -sub ungensym { - delete $_POSIX{$_[0]}; -} - -1; - -package POSIX::SigAction; - -sub new { - bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3]}; -} -__END__ - -sub assert { - usage "assert(expr)", caller if @_ != 1; - if (!$_[0]) { - local ($pack,$file,$line) = caller; - die "Assertion failed at $file line $line\n"; - } -} - -sub tolower { - usage "tolower(string)", caller if @_ != 1; - lc($_[0]); -} - -sub toupper { - usage "toupper(string)", caller if @_ != 1; - uc($_[0]); -} - -sub closedir { - usage "closedir(dirhandle)", caller if @_ != 1; - closedir($_[0]); - ungensym($_[0]); -} - -sub opendir { - usage "opendir(directory)", caller if @_ != 1; - local($dirhandle) = &gensym; - opendir($dirhandle, $_[0]) - ? $dirhandle - : (ungensym($dirhandle), undef); -} - -sub readdir { - usage "readdir(dirhandle)", caller if @_ != 1; - readdir($_[0]); -} - -sub rewinddir { - usage "rewinddir(dirhandle)", caller if @_ != 1; - rewinddir($_[0]); -} - -sub errno { - usage "errno()", caller if @_ != 0; - $! + 0; -} - -sub creat { - usage "creat(filename, mode)", caller if @_ != 2; - &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[2]); -} - -sub fcntl { - usage "fcntl(filehandle, cmd, arg)", caller if @_ != 3; - fcntl($_[0], $_[1], $_[2]); -} - -sub getgrgid { - usage "getgrgid(gid)", caller if @_ != 1; - getgrgid($_[0]); -} - -sub getgrnam { - usage "getgrnam(name)", caller if @_ != 1; - getgrnam($_[0]); -} - -sub atan2 { - usage "atan2(x,y)", caller if @_ != 2; - atan2($_[0], $_[1]); -} - -sub cos { - usage "cos(x)", caller if @_ != 1; - cos($_[0]); -} - -sub exp { - usage "exp(x)", caller if @_ != 1; - exp($_[0]); -} - -sub fabs { - usage "fabs(x)", caller if @_ != 1; - abs($_[0]); -} - -sub log { - usage "log(x)", caller if @_ != 1; - log($_[0]); -} - -sub pow { - usage "pow(x,exponent)", caller if @_ != 2; - $_[0] ** $_[1]; -} - -sub sin { - usage "sin(x)", caller if @_ != 1; - sin($_[0]); -} - -sub sqrt { - usage "sqrt(x)", caller if @_ != 1; - sqrt($_[0]); -} - -sub tan { - usage "tan(x)", caller if @_ != 1; - tan($_[0]); -} - -sub getpwnam { - usage "getpwnam(name)", caller if @_ != 1; - getpwnam($_[0]); -} - -sub getpwuid { - usage "getpwuid(uid)", caller if @_ != 1; - getpwuid($_[0]); -} - -sub longjmp { - unimpl "longjmp() is C-specific: use die instead", caller; -} - -sub setjmp { - unimpl "setjmp() is C-specific: use eval {} instead", caller; -} - -sub siglongjmp { - unimpl "siglongjmp() is C-specific: use die instead", caller; -} - -sub sigsetjmp { - unimpl "sigsetjmp() is C-specific: use eval {} instead", caller; -} - -sub kill { - usage "kill(pid, sig)", caller if @_ != 2; - kill $_[1], $_[0]; -} - -sub raise { - usage "raise(sig)", caller if @_ != 1; - kill $$, $_[0]; # Is this good enough? -} - -sub offsetof { - unimpl "offsetof() is C-specific, stopped", caller; -} - -sub clearerr { - usage "clearerr(filehandle)", caller if @_ != 1; - seek($_[0], 0, 1); -} - -sub fclose { - unimpl "fclose() is C-specific--use close instead", caller; -} - -sub feof { - usage "feof(filehandle)", caller if @_ != 1; - eof($_[0]); -} - -sub fgetc { - usage "fgetc(filehandle)", caller if @_ != 1; - getc($_[0]); -} - -sub fgetpos { - unimpl "fgetpos(xxx)", caller if @_ != 123; - fgetpos($_[0]); -} - -sub fgets { - usage "fgets(filehandle)", caller if @_ != 1; - local($handle) = @_; - scalar <$handle>; -} - -sub fileno { - usage "fileno(filehandle)", caller if @_ != 1; - fileno($_[0]); -} - -sub fopen { - unimpl "fopen() is C-specific--use open instead", caller; -} - -sub fprintf { - unimpl "fprintf() is C-specific--use printf instead", caller; -} - -sub fputc { - unimpl "fputc() is C-specific--use print instead", caller; -} - -sub fputs { - unimpl "fputs() is C-specific--use print instead", caller; - usage "fputs(string, handle)", caller if @_ != 2; - local($handle) = pop; - print $handle @_; -} - -sub fread { - unimpl "fread() is C-specific--use read instead", caller; - unimpl "fread(xxx)", caller if @_ != 123; - fread($_[0]); -} - -sub freopen { - unimpl "freopen() is C-specific--use open instead", caller; - unimpl "freopen(xxx)", caller if @_ != 123; - freopen($_[0]); -} - -sub fscanf { - unimpl "fscanf() is C-specific--use <> and regular expressions instead", caller; - unimpl "fscanf(xxx)", caller if @_ != 123; - fscanf($_[0]); -} - -sub fseek { - unimpl "fseek() is C-specific--use seek instead", caller; - unimpl "fseek(xxx)", caller if @_ != 123; - fseek($_[0]); -} - -sub fsetpos { - unimpl "fsetpos() is C-specific--use seek instead", caller; - unimpl "fsetpos(xxx)", caller if @_ != 123; - fsetpos($_[0]); -} - -sub ftell { - unimpl "ftell() is C-specific--use tell instead", caller; - unimpl "ftell(xxx)", caller if @_ != 123; - ftell($_[0]); -} - -sub fwrite { - unimpl "fwrite() is C-specific--use print instead", caller; - unimpl "fwrite(xxx)", caller if @_ != 123; - fwrite($_[0]); -} - -sub getc { - usage "getc(handle)", caller if @_ != 1; - getc($_[0]); -} - -sub getchar { - usage "getchar()", caller if @_ != 0; - getc(STDIN); -} - -sub gets { - usage "gets(handle)", caller if @_ != 1; - local($handle) = shift; - scalar <$handle>; -} - -sub perror { - unimpl "perror() is C-specific--print $! instead", caller; - unimpl "perror(xxx)", caller if @_ != 123; - perror($_[0]); -} - -sub printf { - usage "printf(pattern, args...)", caller if @_ < 1; - printf STDOUT @_; -} - -sub putc { - unimpl "putc() is C-specific--use print instead", caller; - unimpl "putc(xxx)", caller if @_ != 123; - putc($_[0]); -} - -sub putchar { - unimpl "putchar() is C-specific--use print instead", caller; - unimpl "putchar(xxx)", caller if @_ != 123; - putchar($_[0]); -} - -sub puts { - unimpl "puts() is C-specific--use print instead", caller; - unimpl "puts(xxx)", caller if @_ != 123; - puts($_[0]); -} - -sub remove { - unimpl "remove(xxx)", caller if @_ != 123; - remove($_[0]); -} - -sub rename { - usage "rename(oldfilename, newfilename)", caller if @_ != 2; - rename($_[0], $_[1]); -} - -sub rewind { - unimpl "rewind(xxx)", caller if @_ != 123; - rewind($_[0]); -} - -sub scanf { - unimpl "scanf(xxx)", caller if @_ != 123; - scanf($_[0]); -} - -sub setbuf { - unimpl "setbuf(xxx)", caller if @_ != 123; - setbuf($_[0]); -} - -sub setvbuf { - unimpl "setvbuf(xxx)", caller if @_ != 123; - setvbuf($_[0]); -} - -sub sprintf { - unimpl "sprintf(xxx)", caller if @_ != 123; - sprintf($_[0]); -} - -sub sscanf { - unimpl "sscanf(xxx)", caller if @_ != 123; - sscanf($_[0]); -} - -sub tmpfile { - unimpl "tmpfile(xxx)", caller if @_ != 123; - tmpfile($_[0]); -} - -sub tmpnam { - unimpl "tmpnam(xxx)", caller if @_ != 123; - tmpnam($_[0]); -} - -sub ungetc { - unimpl "ungetc(xxx)", caller if @_ != 123; - ungetc($_[0]); -} - -sub vfprintf { - unimpl "vfprintf(xxx)", caller if @_ != 123; - vfprintf($_[0]); -} - -sub vprintf { - unimpl "vprintf(xxx)", caller if @_ != 123; - vprintf($_[0]); -} - -sub vsprintf { - unimpl "vsprintf(xxx)", caller if @_ != 123; - vsprintf($_[0]); -} - -sub abort { - unimpl "abort(xxx)", caller if @_ != 123; - abort($_[0]); -} - -sub abs { - usage "abs(x)", caller if @_ != 1; - abs($_[0]); -} - -sub atexit { - unimpl "atexit() is C-specific: use END {} instead", caller; -} - -sub atof { - unimpl "atof() is C-specific, stopped", caller; -} - -sub atoi { - unimpl "atoi() is C-specific, stopped", caller; -} - -sub atol { - unimpl "atol() is C-specific, stopped", caller; -} - -sub bsearch { - unimpl "bsearch(xxx)", caller if @_ != 123; - bsearch($_[0]); -} - -sub calloc { - unimpl "calloc(xxx)", caller if @_ != 123; - calloc($_[0]); -} - -sub div { - unimpl "div(xxx)", caller if @_ != 123; - div($_[0]); -} - -sub exit { - unimpl "exit(xxx)", caller if @_ != 123; - exit($_[0]); -} - -sub free { - unimpl "free(xxx)", caller if @_ != 123; - free($_[0]); -} - -sub getenv { - unimpl "getenv(xxx)", caller if @_ != 123; - getenv($_[0]); -} - -sub labs { - unimpl "labs(xxx)", caller if @_ != 123; - labs($_[0]); -} - -sub ldiv { - unimpl "ldiv(xxx)", caller if @_ != 123; - ldiv($_[0]); -} - -sub malloc { - unimpl "malloc(xxx)", caller if @_ != 123; - malloc($_[0]); -} - -sub mblen { - unimpl "mblen(xxx)", caller if @_ != 123; - mblen($_[0]); -} - -sub mbstowcs { - unimpl "mbstowcs(xxx)", caller if @_ != 123; - mbstowcs($_[0]); -} - -sub mbtowc { - unimpl "mbtowc(xxx)", caller if @_ != 123; - mbtowc($_[0]); -} - -sub qsort { - unimpl "qsort(xxx)", caller if @_ != 123; - qsort($_[0]); -} - -sub rand { - unimpl "rand(xxx)", caller if @_ != 123; - rand($_[0]); -} - -sub realloc { - unimpl "realloc(xxx)", caller if @_ != 123; - realloc($_[0]); -} - -sub srand { - unimpl "srand(xxx)", caller if @_ != 123; - srand($_[0]); -} - -sub strtod { - unimpl "strtod(xxx)", caller if @_ != 123; - strtod($_[0]); -} - -sub strtol { - unimpl "strtol(xxx)", caller if @_ != 123; - strtol($_[0]); -} - -sub stroul { - unimpl "stroul(xxx)", caller if @_ != 123; - stroul($_[0]); -} - -sub system { - usage "system(command)", caller if @_ != 1; - system($_[0]); -} - -sub wcstombs { - unimpl "wcstombs(xxx)", caller if @_ != 123; - wcstombs($_[0]); -} - -sub wctomb { - unimpl "wctomb(xxx)", caller if @_ != 123; - wctomb($_[0]); -} - -sub memchr { - unimpl "memchr(xxx)", caller if @_ != 123; - memchr($_[0]); -} - -sub memcmp { - unimpl "memcmp(xxx)", caller if @_ != 123; - memcmp($_[0]); -} - -sub memcpy { - unimpl "memcpy(xxx)", caller if @_ != 123; - memcpy($_[0]); -} - -sub memmove { - unimpl "memmove(xxx)", caller if @_ != 123; - memmove($_[0]); -} - -sub memset { - unimpl "memset(xxx)", caller if @_ != 123; - memset($_[0]); -} - -sub strcat { - unimpl "strcat(xxx)", caller if @_ != 123; - strcat($_[0]); -} - -sub strchr { - unimpl "strchr(xxx)", caller if @_ != 123; - strchr($_[0]); -} - -sub strcmp { - unimpl "strcmp(xxx)", caller if @_ != 123; - strcmp($_[0]); -} - -sub strcoll { - unimpl "strcoll(xxx)", caller if @_ != 123; - strcoll($_[0]); -} - -sub strcpy { - unimpl "strcpy(xxx)", caller if @_ != 123; - strcpy($_[0]); -} - -sub strcspn { - unimpl "strcspn(xxx)", caller if @_ != 123; - strcspn($_[0]); -} - -sub strerror { - unimpl "strerror(xxx)", caller if @_ != 123; - strerror($_[0]); -} - -sub strlen { - unimpl "strlen(xxx)", caller if @_ != 123; - strlen($_[0]); -} - -sub strncat { - unimpl "strncat(xxx)", caller if @_ != 123; - strncat($_[0]); -} - -sub strncmp { - unimpl "strncmp(xxx)", caller if @_ != 123; - strncmp($_[0]); -} - -sub strncpy { - unimpl "strncpy(xxx)", caller if @_ != 123; - strncpy($_[0]); -} - -sub strpbrk { - unimpl "strpbrk(xxx)", caller if @_ != 123; - strpbrk($_[0]); -} - -sub strrchr { - unimpl "strrchr(xxx)", caller if @_ != 123; - strrchr($_[0]); -} - -sub strspn { - unimpl "strspn(xxx)", caller if @_ != 123; - strspn($_[0]); -} - -sub strstr { - unimpl "strstr(xxx)", caller if @_ != 123; - strstr($_[0]); -} - -sub strtok { - unimpl "strtok(xxx)", caller if @_ != 123; - strtok($_[0]); -} - -sub strxfrm { - unimpl "strxfrm(xxx)", caller if @_ != 123; - strxfrm($_[0]); -} - -sub chmod { - usage "chmod(filename, mode)", caller if @_ != 2; - chmod($_[0], $_[1]); -} - -sub fstat { - usage "fstat(fd)", caller if @_ != 1; - local(*TMP); - open(TMP, "<&$_[0]"); # Gross. - local(@l) = stat(TMP); - close(TMP); - @l; -} - -sub mkdir { - usage "mkdir(directoryname, mode)", caller if @_ != 2; - mkdir($_[0], $_[1]); -} - -sub mkfifo { - unimpl "mkfifo(xxx)", caller if @_ != 123; - mkfifo($_[0]); -} - -sub stat { - usage "stat(filename)", caller if @_ != 1; - stat($_[0]); -} - -sub umask { - usage "umask(mask)", caller if @_ != 1; - umask($_[0]); -} - -sub times { - usage "times()", caller if @_ != 0; - times(); -} - -sub wait { - usage "wait(statusvariable)", caller if @_ != 1; - local $result = wait(); - $_[0] = $?; - $result; -} - -sub waitpid { - usage "waitpid(pid, statusvariable, options)", caller if @_ != 3; - local $result = waitpid($_[0], $_[2]); - $_[1] = $?; - $result; -} - -sub cfgetispeed { - unimpl "cfgetispeed(xxx)", caller if @_ != 123; - cfgetispeed($_[0]); -} - -sub cfgetospeed { - unimpl "cfgetospeed(xxx)", caller if @_ != 123; - cfgetospeed($_[0]); -} - -sub cfsetispeed { - unimpl "cfsetispeed(xxx)", caller if @_ != 123; - cfsetispeed($_[0]); -} - -sub cfsetospeed { - unimpl "cfsetospeed(xxx)", caller if @_ != 123; - cfsetospeed($_[0]); -} - -sub tcdrain { - unimpl "tcdrain(xxx)", caller if @_ != 123; - tcdrain($_[0]); -} - -sub tcflow { - unimpl "tcflow(xxx)", caller if @_ != 123; - tcflow($_[0]); -} - -sub tcflush { - unimpl "tcflush(xxx)", caller if @_ != 123; - tcflush($_[0]); -} - -sub tcgetattr { - unimpl "tcgetattr(xxx)", caller if @_ != 123; - tcgetattr($_[0]); -} - -sub tcsendbreak { - unimpl "tcsendbreak(xxx)", caller if @_ != 123; - tcsendbreak($_[0]); -} - -sub tcsetattr { - unimpl "tcsetattr(xxx)", caller if @_ != 123; - tcsetattr($_[0]); -} - -sub asctime { - unimpl "asctime(xxx)", caller if @_ != 123; - asctime($_[0]); -} - -sub clock { - unimpl "clock(xxx)", caller if @_ != 123; - clock($_[0]); -} - -sub ctime { - unimpl "ctime(xxx)", caller if @_ != 123; - ctime($_[0]); -} - -sub difftime { - unimpl "difftime(xxx)", caller if @_ != 123; - difftime($_[0]); -} - -sub gmtime { - unimpl "gmtime(xxx)", caller if @_ != 123; - gmtime($_[0]); -} - -sub localtime { - unimpl "localtime(xxx)", caller if @_ != 123; - localtime($_[0]); -} - -sub mktime { - unimpl "mktime(xxx)", caller if @_ != 123; - mktime($_[0]); -} - -sub strftime { - unimpl "strftime(xxx)", caller if @_ != 123; - strftime($_[0]); -} - -sub time { - unimpl "time(xxx)", caller if @_ != 123; - time($_[0]); -} - -sub tzset { - unimpl "tzset(xxx)", caller if @_ != 123; - tzset($_[0]); -} - -sub tzname { - unimpl "tzname(xxx)", caller if @_ != 123; - tzname($_[0]); -} - -sub _exit { - unimpl "_exit(xxx)", caller if @_ != 123; - _exit($_[0]); -} - -sub access { - unimpl "access(xxx)", caller if @_ != 123; - access($_[0]); -} - -sub alarm { - unimpl "alarm(xxx)", caller if @_ != 123; - alarm($_[0]); -} - -sub chdir { - unimpl "chdir(xxx)", caller if @_ != 123; - chdir($_[0]); -} - -sub chown { - usage "chown(filename, uid, gid)", caller if @_ != 3; - chown($_[0], $_[1], $_[2]); -} - -sub close { - unimpl "close(xxx)", caller if @_ != 123; - close($_[0]); -} - -sub ctermid { - unimpl "ctermid(xxx)", caller if @_ != 123; - ctermid($_[0]); -} - -sub cuserid { - unimpl "cuserid(xxx)", caller if @_ != 123; - cuserid($_[0]); -} - -sub dup2 { - unimpl "dup2(xxx)", caller if @_ != 123; - dup2($_[0]); -} - -sub dup { - unimpl "dup(xxx)", caller if @_ != 123; - dup($_[0]); -} - -sub execl { - unimpl "execl(xxx)", caller if @_ != 123; - execl($_[0]); -} - -sub execle { - unimpl "execle(xxx)", caller if @_ != 123; - execle($_[0]); -} - -sub execlp { - unimpl "execlp(xxx)", caller if @_ != 123; - execlp($_[0]); -} - -sub execv { - unimpl "execv(xxx)", caller if @_ != 123; - execv($_[0]); -} - -sub execve { - unimpl "execve(xxx)", caller if @_ != 123; - execve($_[0]); -} - -sub execvp { - unimpl "execvp(xxx)", caller if @_ != 123; - execvp($_[0]); -} - -sub fork { - usage "fork()", caller if @_ != 0; - fork; -} - -sub fpathconf { - unimpl "fpathconf(xxx)", caller if @_ != 123; - fpathconf($_[0]); -} - -sub getcwd { - unimpl "getcwd(xxx)", caller if @_ != 123; - getcwd($_[0]); -} - -sub getegid { - usage "getegid()", caller if @_ != 0; - $) + 0; -} - -sub geteuid { - usage "geteuid()", caller if @_ != 0; - $> + 0; -} - -sub getgid { - usage "getgid()", caller if @_ != 0; - $( + 0; -} - -sub getgroups { - usage "getgroups()", caller if @_ != 0; - local(%seen) = (); - grep(!%seen{$_}++, split(' ', $) )); -} - -sub getlogin { - usage "getlogin(xxx)", caller if @_ != 0; - getlogin(); -} - -sub getpgrp { - usage "getpgrp()", caller if @_ != 0; - getpgrp($_[0]); -} - -sub getpid { - usage "getpid()", caller if @_ != 0; - $$; -} - -sub getppid { - usage "getppid()", caller if @_ != 0; - getppid; -} - -sub getuid { - usage "getuid()", caller if @_ != 0; - $<; -} - -sub isatty { - unimpl "isatty(xxx)", caller if @_ != 123; - isatty($_[0]); -} - -sub link { - usage "link(oldfilename, newfilename)", caller if @_ != 2; - link($_[0], $_[1]); -} - -sub lseek { - unimpl "lseek(xxx)", caller if @_ != 123; - lseek($_[0]); -} - -sub pathconf { - unimpl "pathconf(xxx)", caller if @_ != 123; - pathconf($_[0]); -} - -sub pause { - unimpl "pause(xxx)", caller if @_ != 123; - pause($_[0]); -} - -sub pipe { - unimpl "pipe(xxx)", caller if @_ != 123; - pipe($_[0]); -} - -sub read { - unimpl "read(xxx)", caller if @_ != 123; - read($_[0]); -} - -sub rmdir { - usage "rmdir(directoryname)", caller if @_ != 1; - rmdir($_[0]); -} - -sub setgid { - unimpl "setgid(xxx)", caller if @_ != 123; - setgid($_[0]); -} - -sub setpgid { - unimpl "setpgid(xxx)", caller if @_ != 123; - setpgid($_[0]); -} - -sub setsid { - unimpl "setsid(xxx)", caller if @_ != 123; - setsid($_[0]); -} - -sub setuid { - unimpl "setuid(xxx)", caller if @_ != 123; - setuid($_[0]); -} - -sub sleep { - unimpl "sleep(xxx)", caller if @_ != 123; - sleep($_[0]); -} - -sub sysconf { - unimpl "sysconf(xxx)", caller if @_ != 123; - sysconf($_[0]); -} - -sub tcgetpgrp { - unimpl "tcgetpgrp(xxx)", caller if @_ != 123; - tcgetpgrp($_[0]); -} - -sub tcsetpgrp { - unimpl "tcsetpgrp(xxx)", caller if @_ != 123; - tcsetpgrp($_[0]); -} - -sub ttyname { - unimpl "ttyname(xxx)", caller if @_ != 123; - ttyname($_[0]); -} - -sub unlink { - usage "unlink(filename)", caller if @_ != 1; - unlink($_[0]); -} - -sub write { - unimpl "write(xxx)", caller if @_ != 123; - write($_[0]); -} - -sub utime { - usage "utime(filename, atime, mtime)", caller if @_ != 3; - utime($_[1], $_[2], $_[0]); -} - diff --git a/lib/SDBM_File.pm b/lib/SDBM_File.pm deleted file mode 100644 index 544f66f237..0000000000 --- a/lib/SDBM_File.pm +++ /dev/null @@ -1,9 +0,0 @@ -package SDBM_File; - -require Exporter; -@ISA = (Exporter, DynamicLoader); -@EXPORT = qw(new fetch store delete firstkey nextkey error clearerr); - -bootstrap SDBM_File; - -1; diff --git a/lib/Search/Dict.pm b/lib/Search/Dict.pm new file mode 100644 index 0000000000..10aa4ff583 --- /dev/null +++ b/lib/Search/Dict.pm @@ -0,0 +1,52 @@ +package Search::Dict; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(look); + +# Usage: look(*FILEHANDLE,$key,$dict,$fold) + +# Sets file position in FILEHANDLE to be first line greater than or equal +# (stringwise) to $key. Pass flags for dictionary order and case folding. + +sub look { + local(*FH,$key,$dict,$fold) = @_; + local($max,$min,$mid,$_); + local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(FH); + $blksize = 8192 unless $blksize; + $key =~ s/[^\w\s]//g if $dict; + $key =~ tr/A-Z/a-z/ if $fold; + $max = int($size / $blksize); + while ($max - $min > 1) { + $mid = int(($max + $min) / 2); + seek(FH,$mid * $blksize,0); + $_ = <FH> if $mid; # probably a partial line + $_ = <FH>; + chop; + s/[^\w\s]//g if $dict; + tr/A-Z/a-z/ if $fold; + if ($_ lt $key) { + $min = $mid; + } + else { + $max = $mid; + } + } + $min *= $blksize; + seek(FH,$min,0); + <FH> if $min; + while (<FH>) { + chop; + s/[^\w\s]//g if $dict; + y/A-Z/a-z/ if $fold; + last if $_ ge $key; + $min = tell(FH); + } + seek(FH,$min,0); + $min; +} + +1; + diff --git a/lib/Shell.pm b/lib/Shell.pm new file mode 100644 index 0000000000..8098bf2892 --- /dev/null +++ b/lib/Shell.pm @@ -0,0 +1,47 @@ +package Shell; + +sub import { + my $self = shift; + my ($callpack, $callfile, $callline) = caller; + my @EXPORT; + if (@_) { + @EXPORT = @_; + } + else { + @EXPORT = 'AUTOLOAD'; + } + foreach $sym (@EXPORT) { + *{"${callpack}::$sym"} = \&{"Shell::$sym"}; + } +}; + +AUTOLOAD { + my $cmd = $AUTOLOAD; + $cmd =~ s/^.*:://; + eval qq { + sub $AUTOLOAD { + if (\@_ < 2) { + `$cmd \@_`; + } + else { + open(SUBPROC, "-|") + or exec '$cmd', \@_ + or die "Can't exec $cmd: \$!\n"; + if (wantarray) { + my \@ret = <SUBPROC>; + close SUBPROC; # XXX Oughta use a destructor. + \@ret; + } + else { + local(\$/) = undef; + my \$ret = <SUBPROC>; + close SUBPROC; + \$ret; + } + } + } + }; + goto &$AUTOLOAD; +} + +1; diff --git a/lib/Hostname.pm b/lib/Sys/Hostname.pm index f61592eebe..4dd4fe2bdc 100644 --- a/lib/Hostname.pm +++ b/lib/Sys/Hostname.pm @@ -1,30 +1,35 @@ # by David Sundstrom sunds@asictest.sc.ti.com # Texas Instruments -package Hostname; +package Sys::Hostname; +use Carp; require Exporter; -@ISA = (Exporter); -@EXPORT = (hostname); +@ISA = qw(Exporter); +@EXPORT = qw(hostname); # # Try every conceivable way to get hostname. # sub hostname { + # method 1 - we already know it return $host if defined $host; # method 2 - syscall is preferred since it avoids tainting problems eval { - require "syscall.ph"; + { + package main; + require "syscall.ph"; + } $host = "\0" x 65; ## preload scalar - syscall(&SYS_gethostname, $host, 65) == 0; + syscall(&main::SYS_gethostname, $host, 65) == 0; } # method 3 - trusty old hostname command || eval { - $host = `hostname 2>/dev/null`; # bsdish + $host = `(hostname) 2>/dev/null`; # bsdish } # method 4 - sysV uname command (may truncate) @@ -38,7 +43,7 @@ sub hostname { } # bummer - || die "Cannot get host name of local machine\n"; + || Carp::croak "Cannot get host name of local machine"; # remove garbage $host =~ tr/\0\r\n//d; diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm new file mode 100644 index 0000000000..0f7859e226 --- /dev/null +++ b/lib/Sys/Syslog.pm @@ -0,0 +1,195 @@ +package Sys::Syslog; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(openlog closelog setlogmask syslog); + +# +# syslog.pl +# +# $Log: syslog.pl,v $ +# +# tom christiansen <tchrist@convex.com> +# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> +# NOTE: openlog now takes three arguments, just like openlog(3) +# +# call syslog() with a string priority and a list of printf() args +# like syslog(3) +# +# usage: use Syslog; +# +# then (put these all in a script to test function) +# +# openlog($program,'cons,pid','user'); +# syslog('info','this is another test'); +# syslog('mail|warning','this is a better test: %d', time); +# closelog(); +# +# syslog('debug','this is the last test'); +# openlog("$program $$",'ndelay','user'); +# syslog('notice','fooprogram: this is really done'); +# +# $! = 55; +# syslog('info','problem was %m'); # %m == $! in syslog(3) + +$host = 'localhost' unless $host; # set $Syslog::host to change + +require 'syslog.ph'; + +$maskpri = &LOG_UPTO(&LOG_DEBUG); + +sub openlog { + ($ident, $logopt, $facility) = @_; # package vars + $lo_pid = $logopt =~ /\bpid\b/; + $lo_ndelay = $logopt =~ /\bndelay\b/; + $lo_cons = $logopt =~ /\bcons\b/; + $lo_nowait = $logopt =~ /\bnowait\b/; + &connect if $lo_ndelay; +} + +sub closelog { + $facility = $ident = ''; + &disconnect; +} + +sub setlogmask { + local($oldmask) = $maskpri; + $maskpri = shift; + $oldmask; +} + +sub syslog { + local($priority) = shift; + local($mask) = shift; + local($message, $whoami); + local(@words, $num, $numpri, $numfac, $sum); + local($facility) = $facility; # may need to change temporarily. + + croak "syslog: expected both priority and mask" unless $mask && $priority; + + @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". + undef $numpri; + undef $numfac; + foreach (@words) { + $num = &xlate($_); # Translate word to number. + if (/^kern$/ || $num < 0) { + croak "syslog: invalid level/facility: $_"; + } + elsif ($num <= &LOG_PRIMASK) { + croak "syslog: too many levels given: $_" if defined($numpri); + $numpri = $num; + return 0 unless &LOG_MASK($numpri) & $maskpri; + } + else { + croak "syslog: too many facilities given: $_" if defined($numfac); + $facility = $_; + $numfac = $num; + } + } + + croak "syslog: level must be given" unless defined($numpri); + + if (!defined($numfac)) { # Facility not specified in this call. + $facility = 'user' unless $facility; + $numfac = &xlate($facility); + } + + &connect unless $connected; + + $whoami = $ident; + + if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { + $whoami = $1; + $mask = $2; + } + + unless ($whoami) { + ($whoami = getlogin) || + ($whoami = getpwuid($<)) || + ($whoami = 'syslog'); + } + + $whoami .= "[$$]" if $lo_pid; + + $mask =~ s/%m/$!/g; + $mask .= "\n" unless $mask =~ /\n$/; + $message = sprintf ($mask, @_); + + $sum = $numpri + $numfac; + unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { + if ($lo_cons) { + if ($pid = fork) { + unless ($lo_nowait) { + do {$died = wait;} until $died == $pid || $died < 0; + } + } + else { + open(CONS,">/dev/console"); + print CONS "<$facility.$priority>$whoami: $message\r"; + exit if defined $pid; # if fork failed, we're parent + close CONS; + } + } + } +} + +sub xlate { + local($name) = @_; + $name =~ y/a-z/A-Z/; + $name = "LOG_$name" unless $name =~ /^LOG_/; + $name = "syslog'$name"; + eval(&$name) || -1; +} + +sub connect { + $pat = 'S n C4 x8'; + + $af_unix = 1; + $af_inet = 2; + + $stream = 1; + $datagram = 2; + + ($name,$aliases,$proto) = getprotobyname('udp'); + $udp = $proto; + + ($name,$aliase,$port,$proto) = getservbyname('syslog','udp'); + $syslog = $port; + + if (chop($myname = `hostname`)) { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); + croak "Can't lookup $myname" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + else { + @bytes = (0,0,0,0); + } + $this = pack($pat, $af_inet, 0, @bytes); + + if ($host =~ /^\d+\./) { + @bytes = split(/\./,$host); + } + else { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); + croak "Can't lookup $host" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + $that = pack($pat,$af_inet,$syslog,@bytes); + + socket(SYSLOG,$af_inet,$datagram,$udp) || croak "socket: $!"; + bind(SYSLOG,$this) || croak "bind: $!"; + connect(SYSLOG,$that) || croak "connect: $!"; + + local($old) = select(SYSLOG); $| = 1; select($old); + $connected = 1; +} + +sub disconnect { + close SYSLOG; + $connected = 0; +} + +1; + diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm new file mode 100644 index 0000000000..30389bb37c --- /dev/null +++ b/lib/Term/Cap.pm @@ -0,0 +1,174 @@ +package Term::Cap; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(&Tgetent &Tputs &Tgoto $ispeed $ospeed %TC); + +# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $ +# +# Usage: +# require 'ioctl.pl'; +# ioctl(TTY,$TIOCGETP,$foo); +# ($ispeed,$ospeed) = unpack('cc',$foo); +# use Termcap; +# &Tgetent('vt100'); # sets $TC{'cm'}, etc. +# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); +# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); +# +sub Tgetent { + local($TERM) = @_; + local($TERMCAP,$_,$entry,$loop,$field); + + warn "Tgetent: no ospeed set" unless $ospeed; + foreach $key (keys(%TC)) { + delete $TC{$key}; + } + $TERM = $ENV{'TERM'} unless $TERM; + $TERM =~ s/(\W)/\\$1/g; + $TERMCAP = $ENV{'TERMCAP'}; + $TERMCAP = '/etc/termcap' unless $TERMCAP; + if ($TERMCAP !~ m:^/:) { + if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) { + $TERMCAP = '/etc/termcap'; + } + } + if ($TERMCAP =~ m:^/:) { + $entry = ''; + do { + $loop = " + open(TERMCAP,'<$TERMCAP') || croak \"Can't open $TERMCAP\"; + while (<TERMCAP>) { + next if /^#/; + next if /^\t/; + if (/(^|\\|)${TERM}[:\\|]/) { + chop; + while (chop eq '\\\\') { + \$_ .= <TERMCAP>; + chop; + } + \$_ .= ':'; + last; + } + } + close TERMCAP; + \$entry .= \$_; + "; + eval $loop; + } while s/:tc=([^:]+):/:/ && ($TERM = $1); + $TERMCAP = $entry; + } + + foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { + if ($field =~ /^\w\w$/) { + $TC{$field} = 1; + } + elsif ($field =~ /^(\w\w)#(.*)/) { + $TC{$1} = $2 unless defined $TC{$1}; + } + elsif ($field =~ /^(\w\w)=(.*)/) { + $entry = $1; + $_ = $2; + s/\\E/\033/g; + s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; + s/\\n/\n/g; + s/\\r/\r/g; + s/\\t/\t/g; + s/\\b/\b/g; + s/\\f/\f/g; + s/\\\^/\377/g; + s/\^\?/\177/g; + s/\^(.)/pack('c',ord($1) & 31)/eg; + s/\\(.)/$1/g; + s/\377/^/g; + $TC{$entry} = $_ unless defined $TC{$entry}; + } + } + $TC{'pc'} = "\0" unless defined $TC{'pc'}; + $TC{'bc'} = "\b" unless defined $TC{'bc'}; +} + +@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); + +sub Tputs { + local($string,$affcnt,$FH) = @_; + local($ms); + if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { + $ms = $1; + $ms *= $affcnt if $2; + $string = $3; + $decr = $Tputs[$ospeed]; + if ($decr > .1) { + $ms += $decr / 2; + $string .= $TC{'pc'} x ($ms / $decr); + } + } + print $FH $string if $FH; + $string; +} + +sub Tgoto { + local($string) = shift(@_); + local($result) = ''; + local($after) = ''; + local($code,$tmp) = @_; + local(@tmp); + @tmp = ($tmp,$code); + local($online) = 0; + while ($string =~ /^([^%]*)%(.)(.*)/) { + $result .= $1; + $code = $2; + $string = $3; + if ($code eq 'd') { + $result .= sprintf("%d",shift(@tmp)); + } + elsif ($code eq '.') { + $tmp = shift(@tmp); + if ($tmp == 0 || $tmp == 4 || $tmp == 10) { + if ($online) { + ++$tmp, $after .= $TC{'up'} if $TC{'up'}; + } + else { + ++$tmp, $after .= $TC{'bc'}; + } + } + $result .= sprintf("%c",$tmp); + $online = !$online; + } + elsif ($code eq '+') { + $result .= sprintf("%c",shift(@tmp)+ord($string)); + $string = substr($string,1,99); + $online = !$online; + } + elsif ($code eq 'r') { + ($code,$tmp) = @tmp; + @tmp = ($tmp,$code); + $online = !$online; + } + elsif ($code eq '>') { + ($code,$tmp,$string) = unpack("CCa99",$string); + if ($tmp[$[] > $code) { + $tmp[$[] += $tmp; + } + } + elsif ($code eq '2') { + $result .= sprintf("%02d",shift(@tmp)); + $online = !$online; + } + elsif ($code eq '3') { + $result .= sprintf("%03d",shift(@tmp)); + $online = !$online; + } + elsif ($code eq 'i') { + ($code,$tmp) = @tmp; + @tmp = ($code+1,$tmp+1); + } + else { + return "OOPS"; + } + } + $result . $string . $after; +} + +1; diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm new file mode 100644 index 0000000000..10b12a2b5c --- /dev/null +++ b/lib/Term/Complete.pm @@ -0,0 +1,113 @@ +package Term::Complete; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(Complete); + +# +# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 +# +# Author: Wayne Thompson +# +# Description: +# This routine provides word completion. +# (TAB) attempts word completion. +# (^D) prints completion list. +# (These may be changed by setting $Complete::complete, etc.) +# +# Diagnostics: +# Bell when word completion fails. +# +# Dependencies: +# The tty driver is put into raw mode. +# +# Bugs: +# +# Usage: +# $input = complete('prompt_string', \@completion_list); +# or +# $input = complete('prompt_string', @completion_list); +# + +CONFIG: { + $complete = "\004"; + $kill = "\025"; + $erase1 = "\177"; + $erase2 = "\010"; +} + +sub complete { + $prompt = shift; + if (ref $_[0] || $_[0] =~ /^\*/) { + @cmp_lst = sort @{$_[0]}; + } + else { + @cmp_lst = sort(@_); + } + + system('stty raw -echo'); + LOOP: { + print($prompt, $return); + while (($_ = getc(STDIN)) ne "\r") { + CASE: { + # (TAB) attempt completion + $_ eq "\t" && do { + @match = grep(/^$return/, @cmp_lst); + $l = length($test = shift(@match)); + unless ($#match < 0) { + foreach $cmp (@match) { + until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { + $l--; + } + } + print("\a"); + } + print($test = substr($test, $r, $l - $r)); + $r = length($return .= $test); + last CASE; + }; + + # (^D) completion list + $_ eq $complete && do { + print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); + redo LOOP; + }; + + # (^U) kill + $_ eq $kill && do { + if ($r) { + undef($r, $return); + print("\r\n"); + redo LOOP; + } + last CASE; + }; + + # (DEL) || (BS) erase + ($_ eq $erase1 || $_ eq $erase2) && do { + if($r) { + print("\b \b"); + chop($return); + $r--; + } + last CASE; + }; + + # printable char + ord >= 32 && do { + $return .= $_; + $r++; + print; + last CASE; + }; + } + } + } + system('stty -raw echo'); + print("\n"); + $return; +} + +1; + diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm new file mode 100644 index 0000000000..8422f8e4bc --- /dev/null +++ b/lib/Test/Harness.pm @@ -0,0 +1,80 @@ +package Test::Harness; + +use Exporter; +use Benchmark; +@ISA=(Exporter); +@EXPORT= qw(&runtests &test_lib); +@EXPORT_OK= qw($verbose $switches); + +$verbose = 0; +$switches = "-w"; + +sub runtests { + my(@tests) = @_; + local($|) = 1; + my($test,$te,$ok,$next,$max,$totmax, $files,$pct); + my $bad = 0; + my $good = 0; + my $total = @tests; + local($ENV{'PERL5LIB'}) = join(':', @INC); # pass -I flags to children + + my $t_start = new Benchmark; + while ($test = shift(@tests)) { + $te = $test; + chop($te); + print "$te" . '.' x (20 - length($te)); + my $fh = "RESULTS"; + open($fh,"$^X $switches $test|") || (print "can't run. $!\n"); + $ok = 0; + $next = 0; + while (<$fh>) { + if( $verbose ){ + print $_; + } + unless (/^#/) { + if (/^1\.\.([0-9]+)/) { + $max = $1; + $totmax += $max; + $files += 1; + $next = 1; + $ok = 1; + } else { + $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; + if (/^ok (.*)/ && $1 == $next) { + $next = $next + 1; + } + } + } + } + close($fh); # must close to reap child resource values + $next -= 1; + if ($ok && $next == $max) { + print "ok\n"; + $good += 1; + } else { + $next += 1; + print "FAILED on test $next\n"; + $bad += 1; + $_ = $test; + } + } + my $t_total = timediff(new Benchmark, $t_start); + + if ($bad == 0) { + if ($ok) { + print "All tests successful.\n"; + } else { + die "FAILED--no tests were run for some reason.\n"; + } + } else { + $pct = sprintf("%.2f", $good / $total * 100); + if ($bad == 1) { + warn "Failed 1 test, $pct% okay.\n"; + } else { + die "Failed $bad/$total tests, $pct% okay.\n"; + } + } + printf("Files=%d, Tests=%d, %s\n", $files,$totmax, timestr($t_total, 'nop')); +} + +1; diff --git a/lib/Text/Abbrev.pm b/lib/Text/Abbrev.pm new file mode 100644 index 0000000000..77370d37c3 --- /dev/null +++ b/lib/Text/Abbrev.pm @@ -0,0 +1,37 @@ +package Text::Abbrev; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(abbrev); + +# Usage: +# &abbrev(*foo,LIST); +# ... +# $long = $foo{$short}; + +sub abbrev { + local(*domain) = shift; + @cmp = @_; + %domain = (); + foreach $name (@_) { + @extra = split(//,$name); + $abbrev = shift(@extra); + $len = 1; + foreach $cmp (@cmp) { + next if $cmp eq $name; + while (substr($cmp,0,$len) eq $abbrev) { + $abbrev .= shift(@extra); + ++$len; + } + } + $domain{$abbrev} = $name; + while (@extra) { + $abbrev .= shift(@extra); + $domain{$abbrev} = $name; + } + } +} + +1; + diff --git a/lib/quotewords.pl.art b/lib/Text/ParseWords.pm index 65e9f0abc8..89278501d1 100644 --- a/lib/quotewords.pl.art +++ b/lib/Text/ParseWords.pm @@ -1,47 +1,23 @@ -Article 20075 of comp.lang.perl: -Newsgroups: comp.lang.perl -Path: netlabs!news.cerf.net!ihnp4.ucsd.edu!swrinde!sgiblab!rpal.rockwell.com!imagen!pomeranz -From: pomeranz@imagen.com (Hal Pomeranz) -Subject: quotewords.pl [REVISED] -Message-ID: <1994Mar23.071634.23171@aqm.com> -Sender: usenet@aqm.com -Nntp-Posting-Host: imagen -Organization: QMS Inc., Santa Clara -Date: Wed, 23 Mar 1994 07:16:34 GMT -Lines: 132 - - -ARRGH! The version I posted earlier tonight contained an error, so -I've sent out a cancel to chase it down and kill it. Please use this -version dated "23 March 1994". - -quotewords.pl is a generic replacement for shellwords.pl. -"ewords() allows you to specify a delimiter, which may be a -regular expression, and returns a list of words broken on that -delimiter ignoring any instances of the delimiter which may appear -within a quoted string. There's a boolean flag to tell the function -whether or not you want it to strip quotes and backslashes or retain -them. - -I've also included a revised version of &shellwords() (written in -terms of "ewords() of course) which is 99% the same as the -original version. The only difference is that the new version will -not default to using $_ if no arguments are supplied. - -Share and enjoy... - -============================================================================== - Hal Pomeranz pomeranz@sclara.qms.com pomeranz@cs.swarthmore.edu -System/Network Manager "All I can say is that my life is pretty plain. - QMS Santa Clara I like watchin' the puddles gather rain." Blind Melon -============================================================================== - -# quotewords.pl +package Text::ParseWords; + +require 5.000; +require Exporter; +require AutoLoader; +use Carp; + +@ISA = qw(Exporter AutoLoader); +@EXPORT = qw(shellwords quotewords); +@EXPORT_OK = qw(old_shellwords); + +# This code needs updating to use new Perl 5 features (regexp etc). + +# ParseWords.pm # # Usage: -# require 'quotes.pl'; +# use ParseWords; # @words = "ewords($delim, $keep, @lines); # @words = &shellwords(@lines); +# @words = &old_shellwords(@lines); # Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 # Permission to use and distribute under the same terms as Perl. @@ -58,20 +34,27 @@ System/Network Manager "All I can say is that my life is pretty plain. # with each word, otherwise quotes are stripped in the splitting process. # $keep also defines whether unprotected backslashes are retained. # -# A &shellwords() replacement is included to demonstrate the new package. -# This version differs from the original in that it will _NOT_ default -# to using $_ if no arguments are given. I personally find the old behavior -# to be a mis-feature. -package quotewords; +1; +__END__ + + +sub shellwords { + + # A &shellwords() replacement is included to demonstrate the new package. + # This version differs from the original in that it will _NOT_ default + # to using $_ if no arguments are given. I personally find the old behavior + # to be a mis-feature. -sub main'shellwords { local(@lines) = @_; $lines[$#lines] =~ s/\s+$//; - &main'quotewords('\s+', 0, @lines); + "ewords('\s+', 0, @lines); } + +sub quotewords { + # "ewords() works by simply jamming all of @lines into a single # string in $_ and then pulling off words a bit at a time until $_ # is exhausted. @@ -90,7 +73,7 @@ sub main'shellwords { # conditional. The second case handles single quoted strings. In # the third case we've found a quote at the current beginning of $_, # but it didn't match the quoted string regexps in the first two cases, -# so it must be an unbalanced quote and we die with an error (which can +# so it must be an unbalanced quote and we croak with an error (which can # be caught by eval()). # # The next case handles backslashed characters, and the next case is the @@ -102,7 +85,6 @@ sub main'shellwords { # at a time behavior was necessary if the delimiter was going to be a # regexp (love to hear it if you can figure out a better way). -sub main'quotewords { local($delim, $keep, @lines) = @_; local(@words,$snippet,$field,$_); @@ -120,7 +102,7 @@ sub main'quotewords { $snippet = "'$snippet'" if ($keep); } elsif (/^["']/) { - die "Unmatched quote\n"; + croak "Unmatched quote"; } elsif (s/^\\(.)//) { $snippet = $1; @@ -141,6 +123,48 @@ sub main'quotewords { } @words; } -1; +sub old_shellwords { + + # Usage: + # use ParseWords; + # @words = old_shellwords($line); + # or + # @words = old_shellwords(@lines); + + local($_) = join('', @_); + my(@words,$snippet,$field); + + s/^\s+//; + while ($_ ne '') { + $field = ''; + for (;;) { + if (s/^"(([^"\\]|\\.)*)"//) { + ($snippet = $1) =~ s#\\(.)#$1#g; + } + elsif (/^"/) { + croak "Unmatched double quote: $_"; + } + elsif (s/^'(([^'\\]|\\.)*)'//) { + ($snippet = $1) =~ s#\\(.)#$1#g; + } + elsif (/^'/) { + croak "Unmatched single quote: $_"; + } + elsif (s/^\\(.)//) { + $snippet = $1; + } + elsif (s/^([^\s\\'"]+)//) { + $snippet = $1; + } + else { + s/^\s+//; + last; + } + $field .= $snippet; + } + push(@words, $field); + } + @words; +} diff --git a/lib/Text/Soundex.pm b/lib/Text/Soundex.pm new file mode 100644 index 0000000000..655152347c --- /dev/null +++ b/lib/Text/Soundex.pm @@ -0,0 +1,82 @@ +package Text::Soundex; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(&soundex $soundex_nocode); + +# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $ +# +# Implementation of soundex algorithm as described by Knuth in volume +# 3 of The Art of Computer Programming, with ideas stolen from Ian +# Phillips <ian@pipex.net>. +# +# Mike Stok <Mike.Stok@meiko.concord.ma.us>, 2 March 1994. +# +# Knuth's test cases are: +# +# Euler, Ellery -> E460 +# Gauss, Ghosh -> G200 +# Hilbert, Heilbronn -> H416 +# Knuth, Kant -> K530 +# Lloyd, Ladd -> L300 +# Lukasiewicz, Lissajous -> L222 +# +# $Log: soundex.pl,v $ +# Revision 1.2 1994/03/24 00:30:27 mike +# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> +# in the way I handles leasing characters which were different but had +# the same soundex code. This showed up comparing it with Oracle's +# soundex output. +# +# Revision 1.1 1994/03/02 13:01:30 mike +# Initial revision +# +# +############################################################################## + +# $soundex_nocode is used to indicate a string doesn't have a soundex +# code, I like undef other people may want to set it to 'Z000'. + +$soundex_nocode = undef; + +# soundex +# +# usage: +# +# @codes = &soundex (@wordList); +# $code = &soundex ($word); +# +# This strenuously avoids 0 + +sub soundex +{ + local (@s, $f, $fc, $_) = @_; + + foreach (@s) + { + tr/a-z/A-Z/; + tr/A-Z//cd; + + if ($_ eq '') + { + $_ = $soundex_nocode; + } + else + { + ($f) = /^(.)/; + tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/; + ($fc) = /^(.)/; + s/^$fc+//; + tr///cs; + tr/0//d; + $_ = $f . $_ . '000'; + s/^(.{4}).*/$1/; + } + } + + wantarray ? @s : shift @s; +} + +1; + diff --git a/lib/Text/Tabs.pm b/lib/Text/Tabs.pm new file mode 100644 index 0000000000..8ca833f8e8 --- /dev/null +++ b/lib/Text/Tabs.pm @@ -0,0 +1,47 @@ +# +# 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> +# + +package Tabs; + +require Exporter; + +@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; +} + +sub unexpand +{ + my @l = &expand(@_); + my @e; + for $x (@l) { + @e = split(/(.{$tabstop})/,$x); + for $_ (@e) { + s/ +$/\t/; + } + $x = join('',@e); + } + return @l; +} + +1; diff --git a/lib/TieHash.pm b/lib/TieHash.pm new file mode 100644 index 0000000000..0cb4afa20d --- /dev/null +++ b/lib/TieHash.pm @@ -0,0 +1,42 @@ +package TieHash; +use Carp; + +sub new { + my $pack = shift; + $pack->TIEHASH(@_); +} + +# Grandfather "new" + +sub TIEHASH { + my $pack = shift; + if (defined &{"{$pack}::new"}) { + carp "WARNING: calling ${pack}->new since ${pack}->TIEHASH is missing" + if $^W; + $pack->new(@_); + } + else { + croak "$pack doesn't define a TIEHASH method"; + } +} + +sub EXISTS { + my $pack = ref $_[0]; + croak "$pack doesn't define an EXISTS method"; +} + +sub CLEAR { + my $self = shift; + my $key = $self->FIRSTKEY(@_); + my @keys; + + while (defined $key) { + push @keys, $key; + $key = $self->NEXTKEY(@_, $key); + } + foreach $key (@keys) { + $self->DELETE(@_, $key); + } +} + +1; diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm new file mode 100644 index 0000000000..64e62405f7 --- /dev/null +++ b/lib/Time/Local.pm @@ -0,0 +1,105 @@ +package Time::Local; +require 5.000; +require Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(timegm timelocal); + +# timelocal.pl +# +# Usage: +# $time = timelocal($sec,$min,$hours,$mday,$mon,$year); +# $time = timegm($sec,$min,$hours,$mday,$mon,$year); + +# These routines are quite efficient and yet are always guaranteed to agree +# with localtime() and gmtime(). We manage this by caching the start times +# of any months we've seen before. If we know the start time of the month, +# we can always calculate any time within the month. The start times +# themselves are guessed by successive approximation starting at the +# current time, since most dates seen in practice are close to the +# current date. Unlike algorithms that do a binary search (calling gmtime +# once for each bit of the time value, resulting in 32 calls), this algorithm +# calls it at most 6 times, and usually only once or twice. If you hit +# the month cache, of course, it doesn't call it at all. + +# timelocal is implemented using the same cache. We just assume that we're +# translating a GMT time, and then fudge it when we're done for the timezone +# and daylight savings arguments. The timezone is determined by examining +# the result of localtime(0) when the package is initialized. The daylight +# savings offset is currently assumed to be one hour. + +# Both routines return -1 if the integer limit is hit. I.e. for dates +# after the 1st of January, 2038 on most machines. + +@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]; + $time; +} + +sub cheat { + $year = $_[5]; + $month = $_[4]; + croak "Month out of range 0..11 in timelocal.pl" + if $month > 11 || $month < 0; + croak "Day out of range 1..31 in timelocal.pl" + if $_[3] > 31 || $_[3] < 1; + croak "Hour out of range 0..23 in timelocal.pl" + if $_[2] > 23 || $_[2] < 0; + croak "Minute out of range 0..59 in timelocal.pl" + if $_[1] > 59 || $_[1] < 0; + croak "Second out of range 0..59 in timelocal.pl" + if $_[0] > 59 || $_[0] < 0; + $guess = $^T; + @g = gmtime($guess); + $year += $YearFix if $year < $epoch[5]; + $lastguess = ""; + while ($diff = $year - $g[5]) { + $guess += $diff * (363 * $DAYS); + @g = gmtime($guess); + if (($thisguess = "@g") eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $lastguess = $thisguess; + } + while ($diff = $month - $g[4]) { + $guess += $diff * (27 * $DAYS); + @g = gmtime($guess); + if (($thisguess = "@g") eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $lastguess = $thisguess; + } + @gfake = gmtime($guess-1); #still being sceptic + if ("@gfake" eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $g[3]--; + $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; + $cheat{$ym} = $guess; +} + +1; diff --git a/lib/auto/NDBM_File.so b/lib/auto/NDBM_File.so Binary files differdeleted file mode 100755 index af2b0d3476..0000000000 --- a/lib/auto/NDBM_File.so +++ /dev/null diff --git a/lib/auto/NDBM_File/NDBM_File.so b/lib/auto/NDBM_File/NDBM_File.so Binary files differdeleted file mode 100755 index 49c04e6858..0000000000 --- a/lib/auto/NDBM_File/NDBM_File.so +++ /dev/null diff --git a/lib/auto/ODBM_File.so b/lib/auto/ODBM_File.so Binary files differdeleted file mode 100755 index 5044c8a1ab..0000000000 --- a/lib/auto/ODBM_File.so +++ /dev/null diff --git a/lib/auto/ODBM_File/ODBM_File.so b/lib/auto/ODBM_File/ODBM_File.so Binary files differdeleted file mode 100755 index f61231f38e..0000000000 --- a/lib/auto/ODBM_File/ODBM_File.so +++ /dev/null diff --git a/lib/auto/POSIX.so b/lib/auto/POSIX.so Binary files differdeleted file mode 100755 index 7065a09cf1..0000000000 --- a/lib/auto/POSIX.so +++ /dev/null diff --git a/lib/auto/POSIX/POSIX.so b/lib/auto/POSIX/POSIX.so Binary files differdeleted file mode 100755 index 17560bd798..0000000000 --- a/lib/auto/POSIX/POSIX.so +++ /dev/null diff --git a/lib/auto/POSIX/_exit b/lib/auto/POSIX/_exit deleted file mode 100644 index a860527257..0000000000 --- a/lib/auto/POSIX/_exit +++ /dev/null @@ -1,9 +0,0 @@ -package POSIX; - -sub _exit { - unimpl "_exit(xxx)", caller if @_ != 123; - _exit($_[0]); -} - - -1; diff --git a/lib/auto/POSIX/_exit.al b/lib/auto/POSIX/_exit.al deleted file mode 100644 index 7666cebe6e..0000000000 --- a/lib/auto/POSIX/_exit.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub _exit { - unimpl "_exit(xxx)", caller if @_ != 123; - _exit($_[0]); -} - -1; diff --git a/lib/auto/POSIX/abort.al b/lib/auto/POSIX/abort.al deleted file mode 100644 index 58e7ce915b..0000000000 --- a/lib/auto/POSIX/abort.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub abort { - unimpl "abort(xxx)", caller if @_ != 123; - abort($_[0]); -} - -1; diff --git a/lib/auto/POSIX/abs.al b/lib/auto/POSIX/abs.al deleted file mode 100644 index 4a832b40d5..0000000000 --- a/lib/auto/POSIX/abs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub abs { - usage "abs(x)", caller if @_ != 1; - abs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/access.al b/lib/auto/POSIX/access.al deleted file mode 100644 index 89bbfb043a..0000000000 --- a/lib/auto/POSIX/access.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub access { - unimpl "access(xxx)", caller if @_ != 123; - access($_[0]); -} - -1; diff --git a/lib/auto/POSIX/alarm.al b/lib/auto/POSIX/alarm.al deleted file mode 100644 index 183b6d965e..0000000000 --- a/lib/auto/POSIX/alarm.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub alarm { - unimpl "alarm(xxx)", caller if @_ != 123; - alarm($_[0]); -} - -1; diff --git a/lib/auto/POSIX/asctime.al b/lib/auto/POSIX/asctime.al deleted file mode 100644 index 067e0f4211..0000000000 --- a/lib/auto/POSIX/asctime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub asctime { - unimpl "asctime(xxx)", caller if @_ != 123; - asctime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/assert.al b/lib/auto/POSIX/assert.al deleted file mode 100644 index f32a8537ed..0000000000 --- a/lib/auto/POSIX/assert.al +++ /dev/null @@ -1,12 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub assert { - usage "assert(expr)", caller if @_ != 1; - if (!$_[0]) { - local ($pack,$file,$line) = caller; - die "Assertion failed at $file line $line\n"; - } -} - -1; diff --git a/lib/auto/POSIX/atan2.al b/lib/auto/POSIX/atan2.al deleted file mode 100644 index 1b2e23a533..0000000000 --- a/lib/auto/POSIX/atan2.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atan2 { - usage "atan2(x,y)", caller if @_ != 2; - atan2($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/atexit.al b/lib/auto/POSIX/atexit.al deleted file mode 100644 index 054d8da133..0000000000 --- a/lib/auto/POSIX/atexit.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atexit { - unimpl "atexit() is C-specific: use END {} instead", caller; -} - -1; diff --git a/lib/auto/POSIX/atof.al b/lib/auto/POSIX/atof.al deleted file mode 100644 index 0875991941..0000000000 --- a/lib/auto/POSIX/atof.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atof { - unimpl "atof() is C-specific, stopped", caller; -} - -1; diff --git a/lib/auto/POSIX/atoi.al b/lib/auto/POSIX/atoi.al deleted file mode 100644 index 6f18387899..0000000000 --- a/lib/auto/POSIX/atoi.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atoi { - unimpl "atoi() is C-specific, stopped", caller; -} - -1; diff --git a/lib/auto/POSIX/atol.al b/lib/auto/POSIX/atol.al deleted file mode 100644 index 9393d21333..0000000000 --- a/lib/auto/POSIX/atol.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub atol { - unimpl "atol() is C-specific, stopped", caller; -} - -1; diff --git a/lib/auto/POSIX/bsearch.al b/lib/auto/POSIX/bsearch.al deleted file mode 100644 index ed104adf41..0000000000 --- a/lib/auto/POSIX/bsearch.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub bsearch { - unimpl "bsearch(xxx)", caller if @_ != 123; - bsearch($_[0]); -} - -1; diff --git a/lib/auto/POSIX/calloc.al b/lib/auto/POSIX/calloc.al deleted file mode 100644 index d53352385c..0000000000 --- a/lib/auto/POSIX/calloc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub calloc { - unimpl "calloc(xxx)", caller if @_ != 123; - calloc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cfgetispeed.al b/lib/auto/POSIX/cfgetispeed.al deleted file mode 100644 index a95efd6f54..0000000000 --- a/lib/auto/POSIX/cfgetispeed.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cfgetispeed { - unimpl "cfgetispeed(xxx)", caller if @_ != 123; - cfgetispeed($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cfgetospeed.al b/lib/auto/POSIX/cfgetospeed.al deleted file mode 100644 index 69e66ad76c..0000000000 --- a/lib/auto/POSIX/cfgetospeed.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cfgetospeed { - unimpl "cfgetospeed(xxx)", caller if @_ != 123; - cfgetospeed($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cfsetispeed.al b/lib/auto/POSIX/cfsetispeed.al deleted file mode 100644 index cbcc646b1e..0000000000 --- a/lib/auto/POSIX/cfsetispeed.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cfsetispeed { - unimpl "cfsetispeed(xxx)", caller if @_ != 123; - cfsetispeed($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cfsetospeed.al b/lib/auto/POSIX/cfsetospeed.al deleted file mode 100644 index 7dae85c36a..0000000000 --- a/lib/auto/POSIX/cfsetospeed.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cfsetospeed { - unimpl "cfsetospeed(xxx)", caller if @_ != 123; - cfsetospeed($_[0]); -} - -1; diff --git a/lib/auto/POSIX/chdir.al b/lib/auto/POSIX/chdir.al deleted file mode 100644 index 9e1f685dc9..0000000000 --- a/lib/auto/POSIX/chdir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub chdir { - unimpl "chdir(xxx)", caller if @_ != 123; - chdir($_[0]); -} - -1; diff --git a/lib/auto/POSIX/chmod.al b/lib/auto/POSIX/chmod.al deleted file mode 100644 index 24fe4c5ab1..0000000000 --- a/lib/auto/POSIX/chmod.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub chmod { - usage "chmod(filename, mode)", caller if @_ != 2; - chmod($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/chown.al b/lib/auto/POSIX/chown.al deleted file mode 100644 index 127d89861c..0000000000 --- a/lib/auto/POSIX/chown.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub chown { - usage "chown(filename, uid, gid)", caller if @_ != 3; - chown($_[0], $_[1], $_[2]); -} - -1; diff --git a/lib/auto/POSIX/clearerr.al b/lib/auto/POSIX/clearerr.al deleted file mode 100644 index 412f521938..0000000000 --- a/lib/auto/POSIX/clearerr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub clearerr { - usage "clearerr(filehandle)", caller if @_ != 1; - seek($_[0], 0, 1); -} - -1; diff --git a/lib/auto/POSIX/clock.al b/lib/auto/POSIX/clock.al deleted file mode 100644 index 7fae255378..0000000000 --- a/lib/auto/POSIX/clock.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub clock { - unimpl "clock(xxx)", caller if @_ != 123; - clock($_[0]); -} - -1; diff --git a/lib/auto/POSIX/close.al b/lib/auto/POSIX/close.al deleted file mode 100644 index ce471881d0..0000000000 --- a/lib/auto/POSIX/close.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub close { - unimpl "close(xxx)", caller if @_ != 123; - close($_[0]); -} - -1; diff --git a/lib/auto/POSIX/closedir.al b/lib/auto/POSIX/closedir.al deleted file mode 100644 index bb12a2608d..0000000000 --- a/lib/auto/POSIX/closedir.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub closedir { - usage "closedir(dirhandle)", caller if @_ != 1; - closedir($_[0]); - ungensym($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cos.al b/lib/auto/POSIX/cos.al deleted file mode 100644 index 4ea59dfb32..0000000000 --- a/lib/auto/POSIX/cos.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cos { - usage "cos(x)", caller if @_ != 1; - cos($_[0]); -} - -1; diff --git a/lib/auto/POSIX/creat.al b/lib/auto/POSIX/creat.al deleted file mode 100644 index 74656e7dd0..0000000000 --- a/lib/auto/POSIX/creat.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub creat { - usage "creat(filename, mode)", caller if @_ != 2; - &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[2]); -} - -1; diff --git a/lib/auto/POSIX/ctermid.al b/lib/auto/POSIX/ctermid.al deleted file mode 100644 index 37a8f71a14..0000000000 --- a/lib/auto/POSIX/ctermid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ctermid { - unimpl "ctermid(xxx)", caller if @_ != 123; - ctermid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ctime.al b/lib/auto/POSIX/ctime.al deleted file mode 100644 index d12aa4e64c..0000000000 --- a/lib/auto/POSIX/ctime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ctime { - unimpl "ctime(xxx)", caller if @_ != 123; - ctime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/cuserid.al b/lib/auto/POSIX/cuserid.al deleted file mode 100644 index 546c3091fa..0000000000 --- a/lib/auto/POSIX/cuserid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub cuserid { - unimpl "cuserid(xxx)", caller if @_ != 123; - cuserid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/difftime.al b/lib/auto/POSIX/difftime.al deleted file mode 100644 index dd4b3db5db..0000000000 --- a/lib/auto/POSIX/difftime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub difftime { - unimpl "difftime(xxx)", caller if @_ != 123; - difftime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/div.al b/lib/auto/POSIX/div.al deleted file mode 100644 index 0102b32fc9..0000000000 --- a/lib/auto/POSIX/div.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub div { - unimpl "div(xxx)", caller if @_ != 123; - div($_[0]); -} - -1; diff --git a/lib/auto/POSIX/dup.al b/lib/auto/POSIX/dup.al deleted file mode 100644 index 393119e5e0..0000000000 --- a/lib/auto/POSIX/dup.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub dup { - unimpl "dup(xxx)", caller if @_ != 123; - dup($_[0]); -} - -1; diff --git a/lib/auto/POSIX/dup2.al b/lib/auto/POSIX/dup2.al deleted file mode 100644 index c85f16e9d5..0000000000 --- a/lib/auto/POSIX/dup2.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub dup2 { - unimpl "dup2(xxx)", caller if @_ != 123; - dup2($_[0]); -} - -1; diff --git a/lib/auto/POSIX/errno.al b/lib/auto/POSIX/errno.al deleted file mode 100644 index 971b7e8241..0000000000 --- a/lib/auto/POSIX/errno.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub errno { - usage "errno()", caller if @_ != 0; - $! + 0; -} - -1; diff --git a/lib/auto/POSIX/execl.al b/lib/auto/POSIX/execl.al deleted file mode 100644 index c89c6fd8c0..0000000000 --- a/lib/auto/POSIX/execl.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execl { - unimpl "execl(xxx)", caller if @_ != 123; - execl($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execle.al b/lib/auto/POSIX/execle.al deleted file mode 100644 index 530ac768dc..0000000000 --- a/lib/auto/POSIX/execle.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execle { - unimpl "execle(xxx)", caller if @_ != 123; - execle($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execlp.al b/lib/auto/POSIX/execlp.al deleted file mode 100644 index ea78975435..0000000000 --- a/lib/auto/POSIX/execlp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execlp { - unimpl "execlp(xxx)", caller if @_ != 123; - execlp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execv.al b/lib/auto/POSIX/execv.al deleted file mode 100644 index 382ec7dde6..0000000000 --- a/lib/auto/POSIX/execv.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execv { - unimpl "execv(xxx)", caller if @_ != 123; - execv($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execve.al b/lib/auto/POSIX/execve.al deleted file mode 100644 index 9f5790a0f1..0000000000 --- a/lib/auto/POSIX/execve.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execve { - unimpl "execve(xxx)", caller if @_ != 123; - execve($_[0]); -} - -1; diff --git a/lib/auto/POSIX/execvp.al b/lib/auto/POSIX/execvp.al deleted file mode 100644 index 38677d8b7d..0000000000 --- a/lib/auto/POSIX/execvp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub execvp { - unimpl "execvp(xxx)", caller if @_ != 123; - execvp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/exit.al b/lib/auto/POSIX/exit.al deleted file mode 100644 index fc46de2cb8..0000000000 --- a/lib/auto/POSIX/exit.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub exit { - unimpl "exit(xxx)", caller if @_ != 123; - exit($_[0]); -} - -1; diff --git a/lib/auto/POSIX/exp.al b/lib/auto/POSIX/exp.al deleted file mode 100644 index 70683e072f..0000000000 --- a/lib/auto/POSIX/exp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub exp { - usage "exp(x)", caller if @_ != 1; - exp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fabs.al b/lib/auto/POSIX/fabs.al deleted file mode 100644 index 5683d66ca5..0000000000 --- a/lib/auto/POSIX/fabs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fabs { - usage "fabs(x)", caller if @_ != 1; - abs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fclose.al b/lib/auto/POSIX/fclose.al deleted file mode 100644 index 493b964561..0000000000 --- a/lib/auto/POSIX/fclose.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fclose { - unimpl "fclose() is C-specific--use close instead", caller; -} - -1; diff --git a/lib/auto/POSIX/fcntl.al b/lib/auto/POSIX/fcntl.al deleted file mode 100644 index 8108a00fc6..0000000000 --- a/lib/auto/POSIX/fcntl.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fcntl { - usage "fcntl(filehandle, cmd, arg)", caller if @_ != 3; - fcntl($_[0], $_[1], $_[2]); -} - -1; diff --git a/lib/auto/POSIX/fdopen.al b/lib/auto/POSIX/fdopen.al deleted file mode 100644 index 23487cabdc..0000000000 --- a/lib/auto/POSIX/fdopen.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fdopen { - unimpl "fdopen(xxx)", caller if @_ != 123; - fdopen($_[0]); -} - -1; diff --git a/lib/auto/POSIX/feof.al b/lib/auto/POSIX/feof.al deleted file mode 100644 index 895d58b7f0..0000000000 --- a/lib/auto/POSIX/feof.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub feof { - usage "feof(filehandle)", caller if @_ != 1; - eof($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ferror.al b/lib/auto/POSIX/ferror.al deleted file mode 100644 index 0588424f06..0000000000 --- a/lib/auto/POSIX/ferror.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ferror { - unimpl "ferror(xxx)", caller if @_ != 123; - ferror($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fflush.al b/lib/auto/POSIX/fflush.al deleted file mode 100644 index b7b767680c..0000000000 --- a/lib/auto/POSIX/fflush.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fflush { - unimpl "fflush(xxx)", caller if @_ != 123; - fflush($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fgetc.al b/lib/auto/POSIX/fgetc.al deleted file mode 100644 index 41cd70f593..0000000000 --- a/lib/auto/POSIX/fgetc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fgetc { - usage "fgetc(filehandle)", caller if @_ != 1; - getc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fgetpos.al b/lib/auto/POSIX/fgetpos.al deleted file mode 100644 index 679fcd50dd..0000000000 --- a/lib/auto/POSIX/fgetpos.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fgetpos { - unimpl "fgetpos(xxx)", caller if @_ != 123; - fgetpos($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fgets.al b/lib/auto/POSIX/fgets.al deleted file mode 100644 index 7a475b3778..0000000000 --- a/lib/auto/POSIX/fgets.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fgets { - usage "fgets(filehandle)", caller if @_ != 1; - local($handle) = @_; - scalar <$handle>; -} - -1; diff --git a/lib/auto/POSIX/fileno.al b/lib/auto/POSIX/fileno.al deleted file mode 100644 index 62c7c0aff8..0000000000 --- a/lib/auto/POSIX/fileno.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fileno { - usage "fileno(filehandle)", caller if @_ != 1; - fileno($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fopen.al b/lib/auto/POSIX/fopen.al deleted file mode 100644 index f4394ad6cb..0000000000 --- a/lib/auto/POSIX/fopen.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fopen { - unimpl "fopen() is C-specific--use open instead", caller; -} - -1; diff --git a/lib/auto/POSIX/fork.al b/lib/auto/POSIX/fork.al deleted file mode 100644 index 06466157e5..0000000000 --- a/lib/auto/POSIX/fork.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fork { - usage "fork()", caller if @_ != 0; - fork; -} - -1; diff --git a/lib/auto/POSIX/fpathconf.al b/lib/auto/POSIX/fpathconf.al deleted file mode 100644 index 533f906395..0000000000 --- a/lib/auto/POSIX/fpathconf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fpathconf { - unimpl "fpathconf(xxx)", caller if @_ != 123; - fpathconf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fprintf.al b/lib/auto/POSIX/fprintf.al deleted file mode 100644 index b577f9ad35..0000000000 --- a/lib/auto/POSIX/fprintf.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fprintf { - unimpl "fprintf() is C-specific--use printf instead", caller; -} - -1; diff --git a/lib/auto/POSIX/fputc.al b/lib/auto/POSIX/fputc.al deleted file mode 100644 index 0cdf82c5a3..0000000000 --- a/lib/auto/POSIX/fputc.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fputc { - unimpl "fputc() is C-specific--use print instead", caller; -} - -1; diff --git a/lib/auto/POSIX/fputs.al b/lib/auto/POSIX/fputs.al deleted file mode 100644 index 208eea6ba9..0000000000 --- a/lib/auto/POSIX/fputs.al +++ /dev/null @@ -1,11 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fputs { - unimpl "fputs() is C-specific--use print instead", caller; - usage "fputs(string, handle)", caller if @_ != 2; - local($handle) = pop; - print $handle @_; -} - -1; diff --git a/lib/auto/POSIX/fread.al b/lib/auto/POSIX/fread.al deleted file mode 100644 index 5b5c0c5fd7..0000000000 --- a/lib/auto/POSIX/fread.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fread { - unimpl "fread() is C-specific--use read instead", caller; - unimpl "fread(xxx)", caller if @_ != 123; - fread($_[0]); -} - -1; diff --git a/lib/auto/POSIX/free.al b/lib/auto/POSIX/free.al deleted file mode 100644 index 319a76d5a9..0000000000 --- a/lib/auto/POSIX/free.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub free { - unimpl "free(xxx)", caller if @_ != 123; - free($_[0]); -} - -1; diff --git a/lib/auto/POSIX/freopen.al b/lib/auto/POSIX/freopen.al deleted file mode 100644 index ed4eca6d67..0000000000 --- a/lib/auto/POSIX/freopen.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub freopen { - unimpl "freopen() is C-specific--use open instead", caller; - unimpl "freopen(xxx)", caller if @_ != 123; - freopen($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fscanf.al b/lib/auto/POSIX/fscanf.al deleted file mode 100644 index 80a8e61454..0000000000 --- a/lib/auto/POSIX/fscanf.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fscanf { - unimpl "fscanf() is C-specific--use <> and regular expressions instead", caller; - unimpl "fscanf(xxx)", caller if @_ != 123; - fscanf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fseek.al b/lib/auto/POSIX/fseek.al deleted file mode 100644 index 55da72a549..0000000000 --- a/lib/auto/POSIX/fseek.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fseek { - unimpl "fseek() is C-specific--use seek instead", caller; - unimpl "fseek(xxx)", caller if @_ != 123; - fseek($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fsetpos.al b/lib/auto/POSIX/fsetpos.al deleted file mode 100644 index 9b59546e40..0000000000 --- a/lib/auto/POSIX/fsetpos.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fsetpos { - unimpl "fsetpos() is C-specific--use seek instead", caller; - unimpl "fsetpos(xxx)", caller if @_ != 123; - fsetpos($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fstat.al b/lib/auto/POSIX/fstat.al deleted file mode 100644 index 64ac1b6dad..0000000000 --- a/lib/auto/POSIX/fstat.al +++ /dev/null @@ -1,13 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fstat { - usage "fstat(fd)", caller if @_ != 1; - local(*TMP); - open(TMP, "<&$_[0]"); # Gross. - local(@l) = stat(TMP); - close(TMP); - @l; -} - -1; diff --git a/lib/auto/POSIX/ftell.al b/lib/auto/POSIX/ftell.al deleted file mode 100644 index aa922c69b1..0000000000 --- a/lib/auto/POSIX/ftell.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ftell { - unimpl "ftell() is C-specific--use tell instead", caller; - unimpl "ftell(xxx)", caller if @_ != 123; - ftell($_[0]); -} - -1; diff --git a/lib/auto/POSIX/fwrite.al b/lib/auto/POSIX/fwrite.al deleted file mode 100644 index 09d8e7db55..0000000000 --- a/lib/auto/POSIX/fwrite.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub fwrite { - unimpl "fwrite() is C-specific--use print instead", caller; - unimpl "fwrite(xxx)", caller if @_ != 123; - fwrite($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getc.al b/lib/auto/POSIX/getc.al deleted file mode 100644 index 5919395af1..0000000000 --- a/lib/auto/POSIX/getc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getc { - usage "getc(handle)", caller if @_ != 1; - getc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getchar.al b/lib/auto/POSIX/getchar.al deleted file mode 100644 index 08e5111b60..0000000000 --- a/lib/auto/POSIX/getchar.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getchar { - usage "getchar()", caller if @_ != 0; - getc(STDIN); -} - -1; diff --git a/lib/auto/POSIX/getcwd.al b/lib/auto/POSIX/getcwd.al deleted file mode 100644 index 1e1ec7c688..0000000000 --- a/lib/auto/POSIX/getcwd.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getcwd { - unimpl "getcwd(xxx)", caller if @_ != 123; - getcwd($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getegid.al b/lib/auto/POSIX/getegid.al deleted file mode 100644 index 6f3719cc44..0000000000 --- a/lib/auto/POSIX/getegid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getegid { - usage "getegid()", caller if @_ != 0; - $) + 0; -} - -1; diff --git a/lib/auto/POSIX/getenv.al b/lib/auto/POSIX/getenv.al deleted file mode 100644 index 04fc148f23..0000000000 --- a/lib/auto/POSIX/getenv.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getenv { - unimpl "getenv(xxx)", caller if @_ != 123; - getenv($_[0]); -} - -1; diff --git a/lib/auto/POSIX/geteuid.al b/lib/auto/POSIX/geteuid.al deleted file mode 100644 index 74b10ff30f..0000000000 --- a/lib/auto/POSIX/geteuid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub geteuid { - usage "geteuid()", caller if @_ != 0; - $> + 0; -} - -1; diff --git a/lib/auto/POSIX/getgid.al b/lib/auto/POSIX/getgid.al deleted file mode 100644 index a106618fff..0000000000 --- a/lib/auto/POSIX/getgid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getgid { - usage "getgid()", caller if @_ != 0; - $( + 0; -} - -1; diff --git a/lib/auto/POSIX/getgrgid.al b/lib/auto/POSIX/getgrgid.al deleted file mode 100644 index 485ed2b04c..0000000000 --- a/lib/auto/POSIX/getgrgid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getgrgid { - usage "getgrgid(gid)", caller if @_ != 1; - getgrgid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getgrnam.al b/lib/auto/POSIX/getgrnam.al deleted file mode 100644 index 1dcbc69850..0000000000 --- a/lib/auto/POSIX/getgrnam.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getgrnam { - usage "getgrnam(name)", caller if @_ != 1; - getgrnam($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getgroups.al b/lib/auto/POSIX/getgroups.al deleted file mode 100644 index 34ae5e87cd..0000000000 --- a/lib/auto/POSIX/getgroups.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getgroups { - usage "getgroups()", caller if @_ != 0; - local(%seen) = (); - grep(!%seen{$_}++, split(' ', $) )); -} - -1; diff --git a/lib/auto/POSIX/getlogin.al b/lib/auto/POSIX/getlogin.al deleted file mode 100644 index 8f61cb24f2..0000000000 --- a/lib/auto/POSIX/getlogin.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getlogin { - usage "getlogin(xxx)", caller if @_ != 0; - getlogin(); -} - -1; diff --git a/lib/auto/POSIX/getpgrp.al b/lib/auto/POSIX/getpgrp.al deleted file mode 100644 index 0364706e53..0000000000 --- a/lib/auto/POSIX/getpgrp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getpgrp { - usage "getpgrp()", caller if @_ != 0; - getpgrp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getpid.al b/lib/auto/POSIX/getpid.al deleted file mode 100644 index 51deea44db..0000000000 --- a/lib/auto/POSIX/getpid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getpid { - usage "getpid()", caller if @_ != 0; - $$; -} - -1; diff --git a/lib/auto/POSIX/getppid.al b/lib/auto/POSIX/getppid.al deleted file mode 100644 index 95450e95ee..0000000000 --- a/lib/auto/POSIX/getppid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getppid { - usage "getppid()", caller if @_ != 0; - getppid; -} - -1; diff --git a/lib/auto/POSIX/getpwnam.al b/lib/auto/POSIX/getpwnam.al deleted file mode 100644 index d4cbc8d766..0000000000 --- a/lib/auto/POSIX/getpwnam.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getpwnam { - usage "getpwnam(name)", caller if @_ != 1; - getpwnam($_[0]); -} - -1; diff --git a/lib/auto/POSIX/getpwuid.al b/lib/auto/POSIX/getpwuid.al deleted file mode 100644 index cfb1265761..0000000000 --- a/lib/auto/POSIX/getpwuid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getpwuid { - usage "getpwuid(uid)", caller if @_ != 1; - getpwuid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/gets.al b/lib/auto/POSIX/gets.al deleted file mode 100644 index d989692172..0000000000 --- a/lib/auto/POSIX/gets.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub gets { - usage "gets(handle)", caller if @_ != 1; - local($handle) = shift; - scalar <$handle>; -} - -1; diff --git a/lib/auto/POSIX/getuid.al b/lib/auto/POSIX/getuid.al deleted file mode 100644 index 6b97d4889f..0000000000 --- a/lib/auto/POSIX/getuid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub getuid { - usage "getuid()", caller if @_ != 0; - $<; -} - -1; diff --git a/lib/auto/POSIX/gmtime.al b/lib/auto/POSIX/gmtime.al deleted file mode 100644 index 520d2dadc5..0000000000 --- a/lib/auto/POSIX/gmtime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub gmtime { - unimpl "gmtime(xxx)", caller if @_ != 123; - gmtime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/isatty.al b/lib/auto/POSIX/isatty.al deleted file mode 100644 index dfc50f4d63..0000000000 --- a/lib/auto/POSIX/isatty.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub isatty { - unimpl "isatty(xxx)", caller if @_ != 123; - isatty($_[0]); -} - -1; diff --git a/lib/auto/POSIX/kill.al b/lib/auto/POSIX/kill.al deleted file mode 100644 index 138a6d72f4..0000000000 --- a/lib/auto/POSIX/kill.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub kill { - usage "kill(pid, sig)", caller if @_ != 2; - kill $_[1], $_[0]; -} - -1; diff --git a/lib/auto/POSIX/labs.al b/lib/auto/POSIX/labs.al deleted file mode 100644 index 90426e8298..0000000000 --- a/lib/auto/POSIX/labs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub labs { - unimpl "labs(xxx)", caller if @_ != 123; - labs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ldiv.al b/lib/auto/POSIX/ldiv.al deleted file mode 100644 index 788fb3219e..0000000000 --- a/lib/auto/POSIX/ldiv.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ldiv { - unimpl "ldiv(xxx)", caller if @_ != 123; - ldiv($_[0]); -} - -1; diff --git a/lib/auto/POSIX/link.al b/lib/auto/POSIX/link.al deleted file mode 100644 index 662ad9d41e..0000000000 --- a/lib/auto/POSIX/link.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub link { - usage "link(oldfilename, newfilename)", caller if @_ != 2; - link($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/localtime.al b/lib/auto/POSIX/localtime.al deleted file mode 100644 index 5e4d61a940..0000000000 --- a/lib/auto/POSIX/localtime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub localtime { - unimpl "localtime(xxx)", caller if @_ != 123; - localtime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/log.al b/lib/auto/POSIX/log.al deleted file mode 100644 index 2ba36f20cc..0000000000 --- a/lib/auto/POSIX/log.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub log { - usage "log(x)", caller if @_ != 1; - log($_[0]); -} - -1; diff --git a/lib/auto/POSIX/longjmp.al b/lib/auto/POSIX/longjmp.al deleted file mode 100644 index d403d46bc5..0000000000 --- a/lib/auto/POSIX/longjmp.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub longjmp { - unimpl "longjmp() is C-specific: use die instead", caller; -} - -1; diff --git a/lib/auto/POSIX/lseek.al b/lib/auto/POSIX/lseek.al deleted file mode 100644 index ded754a642..0000000000 --- a/lib/auto/POSIX/lseek.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub lseek { - unimpl "lseek(xxx)", caller if @_ != 123; - lseek($_[0]); -} - -1; diff --git a/lib/auto/POSIX/malloc.al b/lib/auto/POSIX/malloc.al deleted file mode 100644 index e860639b0d..0000000000 --- a/lib/auto/POSIX/malloc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub malloc { - unimpl "malloc(xxx)", caller if @_ != 123; - malloc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mblen.al b/lib/auto/POSIX/mblen.al deleted file mode 100644 index 1a7b7f3428..0000000000 --- a/lib/auto/POSIX/mblen.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mblen { - unimpl "mblen(xxx)", caller if @_ != 123; - mblen($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mbstowcs.al b/lib/auto/POSIX/mbstowcs.al deleted file mode 100644 index 8f15fe306e..0000000000 --- a/lib/auto/POSIX/mbstowcs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mbstowcs { - unimpl "mbstowcs(xxx)", caller if @_ != 123; - mbstowcs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mbtowc.al b/lib/auto/POSIX/mbtowc.al deleted file mode 100644 index 695dcb98f4..0000000000 --- a/lib/auto/POSIX/mbtowc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mbtowc { - unimpl "mbtowc(xxx)", caller if @_ != 123; - mbtowc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memchr.al b/lib/auto/POSIX/memchr.al deleted file mode 100644 index 28b0c1255b..0000000000 --- a/lib/auto/POSIX/memchr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memchr { - unimpl "memchr(xxx)", caller if @_ != 123; - memchr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memcmp.al b/lib/auto/POSIX/memcmp.al deleted file mode 100644 index 8406f28ed9..0000000000 --- a/lib/auto/POSIX/memcmp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memcmp { - unimpl "memcmp(xxx)", caller if @_ != 123; - memcmp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memcpy.al b/lib/auto/POSIX/memcpy.al deleted file mode 100644 index eee2dd61fd..0000000000 --- a/lib/auto/POSIX/memcpy.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memcpy { - unimpl "memcpy(xxx)", caller if @_ != 123; - memcpy($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memmove.al b/lib/auto/POSIX/memmove.al deleted file mode 100644 index c926d78fa0..0000000000 --- a/lib/auto/POSIX/memmove.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memmove { - unimpl "memmove(xxx)", caller if @_ != 123; - memmove($_[0]); -} - -1; diff --git a/lib/auto/POSIX/memset.al b/lib/auto/POSIX/memset.al deleted file mode 100644 index 369930e346..0000000000 --- a/lib/auto/POSIX/memset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub memset { - unimpl "memset(xxx)", caller if @_ != 123; - memset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mkdir.al b/lib/auto/POSIX/mkdir.al deleted file mode 100644 index 0b1088271e..0000000000 --- a/lib/auto/POSIX/mkdir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mkdir { - usage "mkdir(directoryname, mode)", caller if @_ != 2; - mkdir($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/mkfifo.al b/lib/auto/POSIX/mkfifo.al deleted file mode 100644 index 8b6ad724f1..0000000000 --- a/lib/auto/POSIX/mkfifo.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mkfifo { - unimpl "mkfifo(xxx)", caller if @_ != 123; - mkfifo($_[0]); -} - -1; diff --git a/lib/auto/POSIX/mktime.al b/lib/auto/POSIX/mktime.al deleted file mode 100644 index df7e3556fd..0000000000 --- a/lib/auto/POSIX/mktime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub mktime { - unimpl "mktime(xxx)", caller if @_ != 123; - mktime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/offsetof.al b/lib/auto/POSIX/offsetof.al deleted file mode 100644 index fb5ecfb819..0000000000 --- a/lib/auto/POSIX/offsetof.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub offsetof { - unimpl "offsetof() is C-specific, stopped", caller; -} - -1; diff --git a/lib/auto/POSIX/opendir.al b/lib/auto/POSIX/opendir.al deleted file mode 100644 index 7c264d4770..0000000000 --- a/lib/auto/POSIX/opendir.al +++ /dev/null @@ -1,12 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub opendir { - usage "opendir(directory)", caller if @_ != 1; - local($dirhandle) = &gensym; - opendir($dirhandle, $_[0]) - ? $dirhandle - : (ungensym($dirhandle), undef); -} - -1; diff --git a/lib/auto/POSIX/pathconf.al b/lib/auto/POSIX/pathconf.al deleted file mode 100644 index 4a66189185..0000000000 --- a/lib/auto/POSIX/pathconf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub pathconf { - unimpl "pathconf(xxx)", caller if @_ != 123; - pathconf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/pause.al b/lib/auto/POSIX/pause.al deleted file mode 100644 index 41fcea6c23..0000000000 --- a/lib/auto/POSIX/pause.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub pause { - unimpl "pause(xxx)", caller if @_ != 123; - pause($_[0]); -} - -1; diff --git a/lib/auto/POSIX/perror.al b/lib/auto/POSIX/perror.al deleted file mode 100644 index 36ae11e4c7..0000000000 --- a/lib/auto/POSIX/perror.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub perror { - unimpl "perror() is C-specific--print $! instead", caller; - unimpl "perror(xxx)", caller if @_ != 123; - perror($_[0]); -} - -1; diff --git a/lib/auto/POSIX/pipe.al b/lib/auto/POSIX/pipe.al deleted file mode 100644 index d65b5ec885..0000000000 --- a/lib/auto/POSIX/pipe.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub pipe { - unimpl "pipe(xxx)", caller if @_ != 123; - pipe($_[0]); -} - -1; diff --git a/lib/auto/POSIX/pow.al b/lib/auto/POSIX/pow.al deleted file mode 100644 index 0893b2260e..0000000000 --- a/lib/auto/POSIX/pow.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub pow { - usage "pow(x,exponent)", caller if @_ != 2; - $_[0] ** $_[1]; -} - -1; diff --git a/lib/auto/POSIX/printf.al b/lib/auto/POSIX/printf.al deleted file mode 100644 index f911780072..0000000000 --- a/lib/auto/POSIX/printf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub printf { - usage "printf(pattern, args...)", caller if @_ < 1; - printf STDOUT @_; -} - -1; diff --git a/lib/auto/POSIX/putc.al b/lib/auto/POSIX/putc.al deleted file mode 100644 index 59eaca87a3..0000000000 --- a/lib/auto/POSIX/putc.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub putc { - unimpl "putc() is C-specific--use print instead", caller; - unimpl "putc(xxx)", caller if @_ != 123; - putc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/putchar.al b/lib/auto/POSIX/putchar.al deleted file mode 100644 index 1d6016c08d..0000000000 --- a/lib/auto/POSIX/putchar.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub putchar { - unimpl "putchar() is C-specific--use print instead", caller; - unimpl "putchar(xxx)", caller if @_ != 123; - putchar($_[0]); -} - -1; diff --git a/lib/auto/POSIX/puts.al b/lib/auto/POSIX/puts.al deleted file mode 100644 index 84d3d8072a..0000000000 --- a/lib/auto/POSIX/puts.al +++ /dev/null @@ -1,10 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub puts { - unimpl "puts() is C-specific--use print instead", caller; - unimpl "puts(xxx)", caller if @_ != 123; - puts($_[0]); -} - -1; diff --git a/lib/auto/POSIX/qsort.al b/lib/auto/POSIX/qsort.al deleted file mode 100644 index 93eb12496c..0000000000 --- a/lib/auto/POSIX/qsort.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub qsort { - unimpl "qsort(xxx)", caller if @_ != 123; - qsort($_[0]); -} - -1; diff --git a/lib/auto/POSIX/raise.al b/lib/auto/POSIX/raise.al deleted file mode 100644 index de43d2a29e..0000000000 --- a/lib/auto/POSIX/raise.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub raise { - usage "raise(sig)", caller if @_ != 1; - kill $$, $_[0]; # Is this good enough? -} - -1; diff --git a/lib/auto/POSIX/rand.al b/lib/auto/POSIX/rand.al deleted file mode 100644 index 08c3a1bfc7..0000000000 --- a/lib/auto/POSIX/rand.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rand { - unimpl "rand(xxx)", caller if @_ != 123; - rand($_[0]); -} - -1; diff --git a/lib/auto/POSIX/read.al b/lib/auto/POSIX/read.al deleted file mode 100644 index 50363afd41..0000000000 --- a/lib/auto/POSIX/read.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub read { - unimpl "read(xxx)", caller if @_ != 123; - read($_[0]); -} - -1; diff --git a/lib/auto/POSIX/readdir.al b/lib/auto/POSIX/readdir.al deleted file mode 100644 index 84792b0c41..0000000000 --- a/lib/auto/POSIX/readdir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub readdir { - usage "readdir(dirhandle)", caller if @_ != 1; - readdir($_[0]); -} - -1; diff --git a/lib/auto/POSIX/realloc.al b/lib/auto/POSIX/realloc.al deleted file mode 100644 index 4899b059c2..0000000000 --- a/lib/auto/POSIX/realloc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub realloc { - unimpl "realloc(xxx)", caller if @_ != 123; - realloc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/remove.al b/lib/auto/POSIX/remove.al deleted file mode 100644 index 83d2b8aa79..0000000000 --- a/lib/auto/POSIX/remove.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub remove { - unimpl "remove(xxx)", caller if @_ != 123; - remove($_[0]); -} - -1; diff --git a/lib/auto/POSIX/rename.al b/lib/auto/POSIX/rename.al deleted file mode 100644 index b657c5a39d..0000000000 --- a/lib/auto/POSIX/rename.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rename { - usage "rename(oldfilename, newfilename)", caller if @_ != 2; - rename($_[0], $_[1]); -} - -1; diff --git a/lib/auto/POSIX/rewind.al b/lib/auto/POSIX/rewind.al deleted file mode 100644 index 0bbcc845a6..0000000000 --- a/lib/auto/POSIX/rewind.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rewind { - unimpl "rewind(xxx)", caller if @_ != 123; - rewind($_[0]); -} - -1; diff --git a/lib/auto/POSIX/rewinddir.al b/lib/auto/POSIX/rewinddir.al deleted file mode 100644 index 610f45818d..0000000000 --- a/lib/auto/POSIX/rewinddir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rewinddir { - usage "rewinddir(dirhandle)", caller if @_ != 1; - rewinddir($_[0]); -} - -1; diff --git a/lib/auto/POSIX/rmdir.al b/lib/auto/POSIX/rmdir.al deleted file mode 100644 index a439aa6f93..0000000000 --- a/lib/auto/POSIX/rmdir.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub rmdir { - usage "rmdir(directoryname)", caller if @_ != 1; - rmdir($_[0]); -} - -1; diff --git a/lib/auto/POSIX/scanf.al b/lib/auto/POSIX/scanf.al deleted file mode 100644 index f15440924d..0000000000 --- a/lib/auto/POSIX/scanf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub scanf { - unimpl "scanf(xxx)", caller if @_ != 123; - scanf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setbuf.al b/lib/auto/POSIX/setbuf.al deleted file mode 100644 index 96f2e976dd..0000000000 --- a/lib/auto/POSIX/setbuf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setbuf { - unimpl "setbuf(xxx)", caller if @_ != 123; - setbuf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setgid.al b/lib/auto/POSIX/setgid.al deleted file mode 100644 index fcbb8b6f79..0000000000 --- a/lib/auto/POSIX/setgid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setgid { - unimpl "setgid(xxx)", caller if @_ != 123; - setgid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setjmp.al b/lib/auto/POSIX/setjmp.al deleted file mode 100644 index 93e614a32e..0000000000 --- a/lib/auto/POSIX/setjmp.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setjmp { - unimpl "setjmp() is C-specific: use eval {} instead", caller; -} - -1; diff --git a/lib/auto/POSIX/setpgid.al b/lib/auto/POSIX/setpgid.al deleted file mode 100644 index 948e79a977..0000000000 --- a/lib/auto/POSIX/setpgid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setpgid { - unimpl "setpgid(xxx)", caller if @_ != 123; - setpgid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setsid.al b/lib/auto/POSIX/setsid.al deleted file mode 100644 index 7edc965f05..0000000000 --- a/lib/auto/POSIX/setsid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setsid { - unimpl "setsid(xxx)", caller if @_ != 123; - setsid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setuid.al b/lib/auto/POSIX/setuid.al deleted file mode 100644 index 02da7d3ab6..0000000000 --- a/lib/auto/POSIX/setuid.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setuid { - unimpl "setuid(xxx)", caller if @_ != 123; - setuid($_[0]); -} - -1; diff --git a/lib/auto/POSIX/setvbuf.al b/lib/auto/POSIX/setvbuf.al deleted file mode 100644 index 5303581077..0000000000 --- a/lib/auto/POSIX/setvbuf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub setvbuf { - unimpl "setvbuf(xxx)", caller if @_ != 123; - setvbuf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigaction.al b/lib/auto/POSIX/sigaction.al deleted file mode 100644 index c2b83002b6..0000000000 --- a/lib/auto/POSIX/sigaction.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigaction { - unimpl "sigaction(xxx)", caller if @_ != 123; - sigaction($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigaddset.al b/lib/auto/POSIX/sigaddset.al deleted file mode 100644 index 9a0ea675f7..0000000000 --- a/lib/auto/POSIX/sigaddset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigaddset { - unimpl "sigaddset(xxx)", caller if @_ != 123; - sigaddset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigdelset.al b/lib/auto/POSIX/sigdelset.al deleted file mode 100644 index c252f9f876..0000000000 --- a/lib/auto/POSIX/sigdelset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigdelset { - unimpl "sigdelset(xxx)", caller if @_ != 123; - sigdelset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigemptyset.al b/lib/auto/POSIX/sigemptyset.al deleted file mode 100644 index f665f624e6..0000000000 --- a/lib/auto/POSIX/sigemptyset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigemptyset { - unimpl "sigemptyset(xxx)", caller if @_ != 123; - sigemptyset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigfillset.al b/lib/auto/POSIX/sigfillset.al deleted file mode 100644 index b685797815..0000000000 --- a/lib/auto/POSIX/sigfillset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigfillset { - unimpl "sigfillset(xxx)", caller if @_ != 123; - sigfillset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigismember.al b/lib/auto/POSIX/sigismember.al deleted file mode 100644 index 67c9d98eb5..0000000000 --- a/lib/auto/POSIX/sigismember.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigismember { - unimpl "sigismember(xxx)", caller if @_ != 123; - sigismember($_[0]); -} - -1; diff --git a/lib/auto/POSIX/siglongjmp.al b/lib/auto/POSIX/siglongjmp.al deleted file mode 100644 index 48ab95ed26..0000000000 --- a/lib/auto/POSIX/siglongjmp.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub siglongjmp { - unimpl "siglongjmp() is C-specific: use die instead", caller; -} - -1; diff --git a/lib/auto/POSIX/signal.al b/lib/auto/POSIX/signal.al deleted file mode 100644 index 2471bd302c..0000000000 --- a/lib/auto/POSIX/signal.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub signal { - unimpl "signal(xxx)", caller if @_ != 123; - signal($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigpending.al b/lib/auto/POSIX/sigpending.al deleted file mode 100644 index bb2c76de5d..0000000000 --- a/lib/auto/POSIX/sigpending.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigpending { - unimpl "sigpending(xxx)", caller if @_ != 123; - sigpending($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigprocmask.al b/lib/auto/POSIX/sigprocmask.al deleted file mode 100644 index a6d42a2d43..0000000000 --- a/lib/auto/POSIX/sigprocmask.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigprocmask { - unimpl "sigprocmask(xxx)", caller if @_ != 123; - sigprocmask($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sigsetjmp.al b/lib/auto/POSIX/sigsetjmp.al deleted file mode 100644 index b737259b1a..0000000000 --- a/lib/auto/POSIX/sigsetjmp.al +++ /dev/null @@ -1,8 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigsetjmp { - unimpl "sigsetjmp() is C-specific: use eval {} instead", caller; -} - -1; diff --git a/lib/auto/POSIX/sigsuspend.al b/lib/auto/POSIX/sigsuspend.al deleted file mode 100644 index 159f1d5aa6..0000000000 --- a/lib/auto/POSIX/sigsuspend.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sigsuspend { - unimpl "sigsuspend(xxx)", caller if @_ != 123; - sigsuspend($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sin.al b/lib/auto/POSIX/sin.al deleted file mode 100644 index 90681ff8d9..0000000000 --- a/lib/auto/POSIX/sin.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sin { - usage "sin(x)", caller if @_ != 1; - sin($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sleep.al b/lib/auto/POSIX/sleep.al deleted file mode 100644 index ac326e8882..0000000000 --- a/lib/auto/POSIX/sleep.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sleep { - unimpl "sleep(xxx)", caller if @_ != 123; - sleep($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sprintf.al b/lib/auto/POSIX/sprintf.al deleted file mode 100644 index 5a61a83dd9..0000000000 --- a/lib/auto/POSIX/sprintf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sprintf { - unimpl "sprintf(xxx)", caller if @_ != 123; - sprintf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sqrt.al b/lib/auto/POSIX/sqrt.al deleted file mode 100644 index f2efe5d76d..0000000000 --- a/lib/auto/POSIX/sqrt.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sqrt { - usage "sqrt(x)", caller if @_ != 1; - sqrt($_[0]); -} - -1; diff --git a/lib/auto/POSIX/srand.al b/lib/auto/POSIX/srand.al deleted file mode 100644 index 563757dcd1..0000000000 --- a/lib/auto/POSIX/srand.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub srand { - unimpl "srand(xxx)", caller if @_ != 123; - srand($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sscanf.al b/lib/auto/POSIX/sscanf.al deleted file mode 100644 index 05701419d7..0000000000 --- a/lib/auto/POSIX/sscanf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sscanf { - unimpl "sscanf(xxx)", caller if @_ != 123; - sscanf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/stat.al b/lib/auto/POSIX/stat.al deleted file mode 100644 index 636607eb33..0000000000 --- a/lib/auto/POSIX/stat.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub stat { - usage "stat(filename)", caller if @_ != 1; - stat($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcat.al b/lib/auto/POSIX/strcat.al deleted file mode 100644 index b80dd70529..0000000000 --- a/lib/auto/POSIX/strcat.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcat { - unimpl "strcat(xxx)", caller if @_ != 123; - strcat($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strchr.al b/lib/auto/POSIX/strchr.al deleted file mode 100644 index 9dbea2e1ec..0000000000 --- a/lib/auto/POSIX/strchr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strchr { - unimpl "strchr(xxx)", caller if @_ != 123; - strchr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcmp.al b/lib/auto/POSIX/strcmp.al deleted file mode 100644 index 72f53043a8..0000000000 --- a/lib/auto/POSIX/strcmp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcmp { - unimpl "strcmp(xxx)", caller if @_ != 123; - strcmp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcoll.al b/lib/auto/POSIX/strcoll.al deleted file mode 100644 index a904097e3f..0000000000 --- a/lib/auto/POSIX/strcoll.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcoll { - unimpl "strcoll(xxx)", caller if @_ != 123; - strcoll($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcpy.al b/lib/auto/POSIX/strcpy.al deleted file mode 100644 index aa3e05d713..0000000000 --- a/lib/auto/POSIX/strcpy.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcpy { - unimpl "strcpy(xxx)", caller if @_ != 123; - strcpy($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strcspn.al b/lib/auto/POSIX/strcspn.al deleted file mode 100644 index 00a5c1a968..0000000000 --- a/lib/auto/POSIX/strcspn.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strcspn { - unimpl "strcspn(xxx)", caller if @_ != 123; - strcspn($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strerror.al b/lib/auto/POSIX/strerror.al deleted file mode 100644 index d4dbd7eeb9..0000000000 --- a/lib/auto/POSIX/strerror.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strerror { - unimpl "strerror(xxx)", caller if @_ != 123; - strerror($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strftime.al b/lib/auto/POSIX/strftime.al deleted file mode 100644 index 578b3245c2..0000000000 --- a/lib/auto/POSIX/strftime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strftime { - unimpl "strftime(xxx)", caller if @_ != 123; - strftime($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strlen.al b/lib/auto/POSIX/strlen.al deleted file mode 100644 index afb3a7e025..0000000000 --- a/lib/auto/POSIX/strlen.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strlen { - unimpl "strlen(xxx)", caller if @_ != 123; - strlen($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strncat.al b/lib/auto/POSIX/strncat.al deleted file mode 100644 index d5694bdddd..0000000000 --- a/lib/auto/POSIX/strncat.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strncat { - unimpl "strncat(xxx)", caller if @_ != 123; - strncat($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strncmp.al b/lib/auto/POSIX/strncmp.al deleted file mode 100644 index d85972c0a2..0000000000 --- a/lib/auto/POSIX/strncmp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strncmp { - unimpl "strncmp(xxx)", caller if @_ != 123; - strncmp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strncpy.al b/lib/auto/POSIX/strncpy.al deleted file mode 100644 index 1ebe12dd5a..0000000000 --- a/lib/auto/POSIX/strncpy.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strncpy { - unimpl "strncpy(xxx)", caller if @_ != 123; - strncpy($_[0]); -} - -1; diff --git a/lib/auto/POSIX/stroul.al b/lib/auto/POSIX/stroul.al deleted file mode 100644 index bbdb71e2ec..0000000000 --- a/lib/auto/POSIX/stroul.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub stroul { - unimpl "stroul(xxx)", caller if @_ != 123; - stroul($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strpbrk.al b/lib/auto/POSIX/strpbrk.al deleted file mode 100644 index ee8bef9a27..0000000000 --- a/lib/auto/POSIX/strpbrk.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strpbrk { - unimpl "strpbrk(xxx)", caller if @_ != 123; - strpbrk($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strrchr.al b/lib/auto/POSIX/strrchr.al deleted file mode 100644 index 175f3265e3..0000000000 --- a/lib/auto/POSIX/strrchr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strrchr { - unimpl "strrchr(xxx)", caller if @_ != 123; - strrchr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strspn.al b/lib/auto/POSIX/strspn.al deleted file mode 100644 index 1856caea4e..0000000000 --- a/lib/auto/POSIX/strspn.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strspn { - unimpl "strspn(xxx)", caller if @_ != 123; - strspn($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strstr.al b/lib/auto/POSIX/strstr.al deleted file mode 100644 index c9ef04aa80..0000000000 --- a/lib/auto/POSIX/strstr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strstr { - unimpl "strstr(xxx)", caller if @_ != 123; - strstr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strtod.al b/lib/auto/POSIX/strtod.al deleted file mode 100644 index 44ada12c08..0000000000 --- a/lib/auto/POSIX/strtod.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strtod { - unimpl "strtod(xxx)", caller if @_ != 123; - strtod($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strtok.al b/lib/auto/POSIX/strtok.al deleted file mode 100644 index 47825149b0..0000000000 --- a/lib/auto/POSIX/strtok.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strtok { - unimpl "strtok(xxx)", caller if @_ != 123; - strtok($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strtol.al b/lib/auto/POSIX/strtol.al deleted file mode 100644 index 4a40dffa0b..0000000000 --- a/lib/auto/POSIX/strtol.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strtol { - unimpl "strtol(xxx)", caller if @_ != 123; - strtol($_[0]); -} - -1; diff --git a/lib/auto/POSIX/strxfrm.al b/lib/auto/POSIX/strxfrm.al deleted file mode 100644 index 9ad22f1efa..0000000000 --- a/lib/auto/POSIX/strxfrm.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub strxfrm { - unimpl "strxfrm(xxx)", caller if @_ != 123; - strxfrm($_[0]); -} - -1; diff --git a/lib/auto/POSIX/sysconf.al b/lib/auto/POSIX/sysconf.al deleted file mode 100644 index 5dfeab8e9d..0000000000 --- a/lib/auto/POSIX/sysconf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub sysconf { - unimpl "sysconf(xxx)", caller if @_ != 123; - sysconf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/system.al b/lib/auto/POSIX/system.al deleted file mode 100644 index c143ca1e23..0000000000 --- a/lib/auto/POSIX/system.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub system { - usage "system(command)", caller if @_ != 1; - system($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tan.al b/lib/auto/POSIX/tan.al deleted file mode 100644 index a86b877f3f..0000000000 --- a/lib/auto/POSIX/tan.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tan { - usage "tan(x)", caller if @_ != 1; - tan($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcdrain.al b/lib/auto/POSIX/tcdrain.al deleted file mode 100644 index 97ea14f0ab..0000000000 --- a/lib/auto/POSIX/tcdrain.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcdrain { - unimpl "tcdrain(xxx)", caller if @_ != 123; - tcdrain($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcflow.al b/lib/auto/POSIX/tcflow.al deleted file mode 100644 index 690587aa46..0000000000 --- a/lib/auto/POSIX/tcflow.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcflow { - unimpl "tcflow(xxx)", caller if @_ != 123; - tcflow($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcflush.al b/lib/auto/POSIX/tcflush.al deleted file mode 100644 index 733ab16425..0000000000 --- a/lib/auto/POSIX/tcflush.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcflush { - unimpl "tcflush(xxx)", caller if @_ != 123; - tcflush($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcgetattr.al b/lib/auto/POSIX/tcgetattr.al deleted file mode 100644 index c8a5e09b6e..0000000000 --- a/lib/auto/POSIX/tcgetattr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcgetattr { - unimpl "tcgetattr(xxx)", caller if @_ != 123; - tcgetattr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcgetpgrp.al b/lib/auto/POSIX/tcgetpgrp.al deleted file mode 100644 index 8b6f884f2b..0000000000 --- a/lib/auto/POSIX/tcgetpgrp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcgetpgrp { - unimpl "tcgetpgrp(xxx)", caller if @_ != 123; - tcgetpgrp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcsendbreak.al b/lib/auto/POSIX/tcsendbreak.al deleted file mode 100644 index e90b7fabd3..0000000000 --- a/lib/auto/POSIX/tcsendbreak.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcsendbreak { - unimpl "tcsendbreak(xxx)", caller if @_ != 123; - tcsendbreak($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcsetattr.al b/lib/auto/POSIX/tcsetattr.al deleted file mode 100644 index 1735cf6862..0000000000 --- a/lib/auto/POSIX/tcsetattr.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcsetattr { - unimpl "tcsetattr(xxx)", caller if @_ != 123; - tcsetattr($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tcsetpgrp.al b/lib/auto/POSIX/tcsetpgrp.al deleted file mode 100644 index 9dcff24b8c..0000000000 --- a/lib/auto/POSIX/tcsetpgrp.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tcsetpgrp { - unimpl "tcsetpgrp(xxx)", caller if @_ != 123; - tcsetpgrp($_[0]); -} - -1; diff --git a/lib/auto/POSIX/time.al b/lib/auto/POSIX/time.al deleted file mode 100644 index d750d24e90..0000000000 --- a/lib/auto/POSIX/time.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub time { - unimpl "time(xxx)", caller if @_ != 123; - time($_[0]); -} - -1; diff --git a/lib/auto/POSIX/times.al b/lib/auto/POSIX/times.al deleted file mode 100644 index d8f588ad63..0000000000 --- a/lib/auto/POSIX/times.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub times { - usage "times()", caller if @_ != 0; - times(); -} - -1; diff --git a/lib/auto/POSIX/tmpfile.al b/lib/auto/POSIX/tmpfile.al deleted file mode 100644 index 7adb01fb9b..0000000000 --- a/lib/auto/POSIX/tmpfile.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tmpfile { - unimpl "tmpfile(xxx)", caller if @_ != 123; - tmpfile($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tmpnam.al b/lib/auto/POSIX/tmpnam.al deleted file mode 100644 index 23e7dfb11b..0000000000 --- a/lib/auto/POSIX/tmpnam.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tmpnam { - unimpl "tmpnam(xxx)", caller if @_ != 123; - tmpnam($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tolower.al b/lib/auto/POSIX/tolower.al deleted file mode 100644 index 8bcbb8494a..0000000000 --- a/lib/auto/POSIX/tolower.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tolower { - usage "tolower(string)", caller if @_ != 1; - lc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/toupper.al b/lib/auto/POSIX/toupper.al deleted file mode 100644 index e8b4c0b4ff..0000000000 --- a/lib/auto/POSIX/toupper.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub toupper { - usage "toupper(string)", caller if @_ != 1; - uc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ttyname.al b/lib/auto/POSIX/ttyname.al deleted file mode 100644 index 60f39dc5f4..0000000000 --- a/lib/auto/POSIX/ttyname.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ttyname { - unimpl "ttyname(xxx)", caller if @_ != 123; - ttyname($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tzname.al b/lib/auto/POSIX/tzname.al deleted file mode 100644 index 86e7019547..0000000000 --- a/lib/auto/POSIX/tzname.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tzname { - unimpl "tzname(xxx)", caller if @_ != 123; - tzname($_[0]); -} - -1; diff --git a/lib/auto/POSIX/tzset.al b/lib/auto/POSIX/tzset.al deleted file mode 100644 index 44b5b0a878..0000000000 --- a/lib/auto/POSIX/tzset.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub tzset { - unimpl "tzset(xxx)", caller if @_ != 123; - tzset($_[0]); -} - -1; diff --git a/lib/auto/POSIX/umask.al b/lib/auto/POSIX/umask.al deleted file mode 100644 index e7c7fc71d3..0000000000 --- a/lib/auto/POSIX/umask.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub umask { - usage "umask(mask)", caller if @_ != 1; - umask($_[0]); -} - -1; diff --git a/lib/auto/POSIX/ungetc.al b/lib/auto/POSIX/ungetc.al deleted file mode 100644 index 76c426e72e..0000000000 --- a/lib/auto/POSIX/ungetc.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub ungetc { - unimpl "ungetc(xxx)", caller if @_ != 123; - ungetc($_[0]); -} - -1; diff --git a/lib/auto/POSIX/unlink.al b/lib/auto/POSIX/unlink.al deleted file mode 100644 index 798ce431d8..0000000000 --- a/lib/auto/POSIX/unlink.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub unlink { - usage "unlink(filename)", caller if @_ != 1; - unlink($_[0]); -} - -1; diff --git a/lib/auto/POSIX/utime.al b/lib/auto/POSIX/utime.al deleted file mode 100644 index fff416df89..0000000000 --- a/lib/auto/POSIX/utime.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub utime { - usage "utime(filename, atime, mtime)", caller if @_ != 3; - utime($_[1], $_[2], $_[0]); -} - -1; diff --git a/lib/auto/POSIX/vfprintf.al b/lib/auto/POSIX/vfprintf.al deleted file mode 100644 index b18f42fd85..0000000000 --- a/lib/auto/POSIX/vfprintf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub vfprintf { - unimpl "vfprintf(xxx)", caller if @_ != 123; - vfprintf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/vprintf.al b/lib/auto/POSIX/vprintf.al deleted file mode 100644 index f295a99906..0000000000 --- a/lib/auto/POSIX/vprintf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub vprintf { - unimpl "vprintf(xxx)", caller if @_ != 123; - vprintf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/vsprintf.al b/lib/auto/POSIX/vsprintf.al deleted file mode 100644 index c8e00c7803..0000000000 --- a/lib/auto/POSIX/vsprintf.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub vsprintf { - unimpl "vsprintf(xxx)", caller if @_ != 123; - vsprintf($_[0]); -} - -1; diff --git a/lib/auto/POSIX/wait.al b/lib/auto/POSIX/wait.al deleted file mode 100644 index 489b1e3b07..0000000000 --- a/lib/auto/POSIX/wait.al +++ /dev/null @@ -1,11 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub wait { - usage "wait(statusvariable)", caller if @_ != 1; - local $result = wait(); - $_[0] = $?; - $result; -} - -1; diff --git a/lib/auto/POSIX/waitpid.al b/lib/auto/POSIX/waitpid.al deleted file mode 100644 index a7706a7243..0000000000 --- a/lib/auto/POSIX/waitpid.al +++ /dev/null @@ -1,11 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub waitpid { - usage "waitpid(pid, statusvariable, options)", caller if @_ != 3; - local $result = waitpid($_[0], $_[2]); - $_[1] = $?; - $result; -} - -1; diff --git a/lib/auto/POSIX/wcstombs.al b/lib/auto/POSIX/wcstombs.al deleted file mode 100644 index 1f8782b9d6..0000000000 --- a/lib/auto/POSIX/wcstombs.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub wcstombs { - unimpl "wcstombs(xxx)", caller if @_ != 123; - wcstombs($_[0]); -} - -1; diff --git a/lib/auto/POSIX/wctomb.al b/lib/auto/POSIX/wctomb.al deleted file mode 100644 index e4ccf87cb9..0000000000 --- a/lib/auto/POSIX/wctomb.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub wctomb { - unimpl "wctomb(xxx)", caller if @_ != 123; - wctomb($_[0]); -} - -1; diff --git a/lib/auto/POSIX/write.al b/lib/auto/POSIX/write.al deleted file mode 100644 index 2306b69a01..0000000000 --- a/lib/auto/POSIX/write.al +++ /dev/null @@ -1,9 +0,0 @@ -# NOTE: Derived from POSIX.pm. Changes made here will be lost. -package POSIX; - -sub write { - unimpl "write(xxx)", caller if @_ != 123; - write($_[0]); -} - -1; diff --git a/lib/auto/README b/lib/auto/README deleted file mode 100644 index b217acc5cd..0000000000 --- a/lib/auto/README +++ /dev/null @@ -1,2 +0,0 @@ -Everything down here is derived from elsewhere. If you modify anything -down here it will someday be overwritten. diff --git a/lib/auto/SDBM_File.so b/lib/auto/SDBM_File.so Binary files differdeleted file mode 100755 index 8414d44a5e..0000000000 --- a/lib/auto/SDBM_File.so +++ /dev/null diff --git a/lib/auto/SDBM_File/SDBM_File.so b/lib/auto/SDBM_File/SDBM_File.so Binary files differdeleted file mode 100755 index 362042ccc0..0000000000 --- a/lib/auto/SDBM_File/SDBM_File.so +++ /dev/null diff --git a/lib/auto/SDBM_File/foo b/lib/auto/SDBM_File/foo Binary files differdeleted file mode 100755 index 193c50caba..0000000000 --- a/lib/auto/SDBM_File/foo +++ /dev/null diff --git a/lib/cacheout.pl b/lib/cacheout.pl index 513c25b6fe..48d594bf82 100644 --- a/lib/cacheout.pl +++ b/lib/cacheout.pl @@ -4,6 +4,12 @@ sub cacheout'open { open($_[0], $_[1]); } +# Close as well + +sub cacheout'close { + close($_[0]); +} + # But only this sub name is visible to them. sub cacheout { @@ -15,7 +21,7 @@ sub cacheout { local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); splice(@lru, $maxopen / 3); $numopen -= @lru; - for (@lru) { close $_; delete $isopen{$_}; } + for (@lru) { &close($_); delete $isopen{$_}; } } &open($file, ($saw{$file}++ ? '>>' : '>') . $file) || die "Can't create $file: $!\n"; diff --git a/lib/chat2.pl b/lib/chat2.pl index 67d0c84069..58674e5a8b 100644 --- a/lib/chat2.pl +++ b/lib/chat2.pl @@ -1,6 +1,6 @@ # chat.pl: chat with a server # Based on: V2.01.alpha.7 91/06/16 -# Randal L. Schwartz (was <merlyn@iwarp.intel.com>) +# Randal L. Schwartz (was <merlyn@stonehenge.com>) # multihome additions by A.Macpherson@bnr.co.uk # allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU> diff --git a/lib/dotsh.pl b/lib/dotsh.pl new file mode 100644 index 0000000000..4db85e742b --- /dev/null +++ b/lib/dotsh.pl @@ -0,0 +1,67 @@ +# +# @(#)dotsh.pl 03/19/94 +# +# Author: Charles Collins +# +# Description: +# This routine takes a shell script and 'dots' it into the current perl +# environment. This makes it possible to use existing system scripts +# to alter environment variables on the fly. +# +# Usage: +# &dotsh ('ShellScript', 'DependentVariable(s)'); +# +# where +# +# 'ShellScript' is the full name of the shell script to be dotted +# +# 'DependentVariable(s)' is an optional list of shell variables in the +# form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is +# dependent upon. These variables MUST be defined using shell syntax. +# +# Example: +# &dotsh ('/tmp/foo', 'arg1'); +# &dotsh ('/tmp/foo'); +# &dotsh ('/tmp/foo arg1 ... argN'); +# +sub dotsh { + local(@sh) = @_; + local($tmp,$key,$shell,*dotsh,$command,$args,$vars) = ''; + $dotsh = shift(@sh); + @dotsh = split (/\s/, $dotsh); + $command = shift (@dotsh); + $args = join (" ", @dotsh); + $vars = join ("\n", @sh); + open (_SH_ENV, "$command") || die "Could not open $dotsh!\n"; + chop($_ = <_SH_ENV>); + $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/); + close (_SH_ENV); + if (!$shell) { + if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/csh$/) { + $shell = "$ENV{'SHELL'} -c"; + } else { + print "SHELL not recognized!\nUsing /bin/sh...\n"; + $shell = "/bin/sh -c"; + } + } + if (length($vars) > 0) { + system "$shell \"$vars;. $command $args; set > /tmp/_sh_env$$\""; + } else { + system "$shell \". $command $args; set > /tmp/_sh_env$$\""; + } + + open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n"; + while (<_SH_ENV>) { + chop; + /=/; + $ENV{$`} = $'; + } + close (_SH_ENV); + system "rm -f /tmp/_sh_env$$"; + + foreach $key (keys(ENV)) { + $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; + } + eval $tmp; +} +1; diff --git a/lib/dotsh.pl.art b/lib/dotsh.pl.art deleted file mode 100644 index 4f0f188e3c..0000000000 --- a/lib/dotsh.pl.art +++ /dev/null @@ -1,154 +0,0 @@ -Article 19995 of comp.lang.perl: -Newsgroups: comp.lang.perl -Path: netlabs!news.cerf.net!mvb.saic.com!MathWorks.Com!europa.eng.gtefsd.com!howland.reston.ans.net!news.ans.net!malgudi.oar.net!chemabs!skf26 -From: skf26@cas.org (Scott Frost) -Subject: HOW TO source shell scripts into Perl -Message-ID: <1994Mar21.191518.11636@chemabs.uucp> -Followup-To: scott.frost@cas.org -Keywords: Shell, Source, Dot -Sender: usenet@chemabs.uucp -Organization: Chemical Abstracts Service -Date: Mon, 21 Mar 1994 19:15:18 GMT -Lines: 139 - -A few days ago I posted a request for information on how to source -a shell script into a perl script. In general, the responses indicated that -it could not be done (although one came pretty close to the actual solution). - -A fellow staff member (who I was posting the request for) wasn't satisfied with -the response and came up with a way. - -Before I indicate how he solved the problem, let me suggest some alternative -methods of resolving this issue, - - 1. Hard code the environment variables directly in your PERL script. This - is easy but unreliable. System administrators could change the - production shell script environment variables and your PERL script would - be hosed. - - 2. Create a shell wrapper that dots the shell script into your current - environment and then invoke your perl script. This approach is easy - to do, fairly full proof, but an affront to serious PERL programmers - who believe PERL is God's gift to man (or at least Larry's :-) ). - -Chuck's solution involves running the script in the appropriate shell -environment, dumping the shell's environment variables to a file, and then -reading the environment variables into PERL's environment. - -It supports ksh, sh, csh, and zsh shells. It'll look at the first line of -the file to be executed to determine the shell to run it under, if not found, -it'll look at the SHELL environment variable. If the shell is not one of the -four listed, it'll warn you and attempt to run the shell script under /bin/sh. - - A typical usage might look like this, - #!/usr/bin/perl - - # Make sure dotsh.pl is placed in your /usr/perl/lib - require "dotsh.pl"; - - print "SHELL_ENV_VAR = $SHELL_ENV_VAR\n" ; - &dotsh('/tmp/foo') ; # script to run - print "SHELL_ENV_VAR = $SHELL_ENV_VAR\n" ; - - /tmp/foo looks like this: - #!/bin/ksh - export SHELL_ENV_VAR="hi mom" - -The actual dotsh.pl script follows (BTW, this is now public domain): -# -# @(#)dotsh.pl 03/19/94 -# -# Author: Charles Collins -# -# Description: -# This routine takes a shell script and 'dots' it into the current perl -# environment. This makes it possible to use existing system scripts -# to alter environment variables on the fly. -# -# Usage: -# &dotsh ('ShellScript', 'DependentVariable(s)'); -# -# where -# -# 'ShellScript' is the full name of the shell script to be dotted -# -# 'DependentVariable(s)' is an optional list of shell variables in the -# form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is -# dependent upon. These variables MUST be defined using shell syntax. -# -# Example: -# &dotsh ('/tmp/foo', 'arg1'); -# &dotsh ('/tmp/foo'); -# &dotsh ('/tmp/foo arg1 ... argN'); -# -sub dotsh { - local(@sh) = @_; - local($tmp,$key,$shell,*dotsh,$command,$args,$vars) = ''; - $dotsh = shift(@sh); - @dotsh = split (/\s/, $dotsh); - $command = shift (@dotsh); - $args = join (" ", @dotsh); - $vars = join ("\n", @sh); - open (_SH_ENV, "$command") || die "Could not open $dotsh!\n"; - chop($_ = <_SH_ENV>); - $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/); - close (_SH_ENV); - if (!$shell) { - if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/csh$/) { - $shell = "$ENV{'SHELL'} -c"; - } else { - print "SHELL not recognized!\nUsing /bin/sh...\n"; - $shell = "/bin/sh -c"; - } - } - if (length($vars) > 0) { - system "$shell \"$vars;. $command $args; set > /tmp/_sh_env$$\""; - } else { - system "$shell \". $command $args; set > /tmp/_sh_env$$\""; - } - - open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n"; - while (<_SH_ENV>) { - chop; - /=/; - $ENV{$`} = $'; - } - close (_SH_ENV); - system "rm -f /tmp/_sh_env$$"; - - foreach $key (keys(ENV)) { - $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; - } - eval $tmp; -} -1; - - - - - - - - - - - - - - - - - - - - - - - - - - --- -Scott K. Frost INET: scott.frost@cas.org - - diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index 03dbbcd8fe..4ebcb5203d 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -3,18 +3,23 @@ package dumpvar; # translate control chars to ^X - Randal Schwartz sub unctrl { local($_) = @_; + return \$_ if ref \$_ eq "GLOB"; s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg; $_; } sub main'dumpvar { ($package,@vars) = @_; - local(*stab) = *{"::_$package"}; + $package .= "::" unless $package =~ /::$/; + *stab = *{"main::"}; + while ($package =~ /(\w+?::)/g){ + *stab = ${stab}{$1}; + } while (($key,$val) = each(%stab)) { { next if @vars && !grep($key eq $_,@vars); local(*entry) = $val; if (defined $entry) { - print "\$$key = '",&unctrl($entry),"'\n"; + print "\$",&unctrl($key)," = '",&unctrl($entry),"'\n"; } if (defined @entry) { print "\@$key = (\n"; @@ -23,7 +28,8 @@ sub main'dumpvar { } print ")\n"; } - if ($key ne "_$package" && $key ne "_DB" && defined %entry) { + if ($key ne "main::" && $key ne "DB::" && defined %entry + && !($package eq "dumpvar" and $key eq "stab")) { print "\%$key = (\n"; foreach $key (sort keys(%entry)) { print " $key\t'",&unctrl($entry{$key}),"'\n"; diff --git a/lib/find.pl b/lib/find.pl index d55cd33122..40e613e97e 100644 --- a/lib/find.pl +++ b/lib/find.pl @@ -39,8 +39,8 @@ sub find { ($dir,$_) = ($topdir,'.'); $name = $topdir; &wanted; - $topdir =~ s,/$,, ; - &finddir($topdir,$topnlink); + ($fixtopdir = $topdir) =~ s,/$,, ; + &finddir($fixtopdir,$topnlink); } else { warn "Can't cd to $topdir: $!\n"; diff --git a/lib/finddepth.pl b/lib/finddepth.pl index 15e4daf561..1fe6a375b6 100644 --- a/lib/finddepth.pl +++ b/lib/finddepth.pl @@ -34,10 +34,10 @@ sub finddepth { || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { - $topdir =~ s,/$,, ; - &finddepthdir($topdir,$topnlink); - ($dir,$_) = ($topdir,'.'); - $name = $topdir; + ($fixtopdir = $topdir) =~ s,/$,, ; + &finddepthdir($fixtopdir,$topnlink); + ($dir,$_) = ($fixtopdir,'.'); + $name = $fixtopdir; &wanted; } else { diff --git a/lib/integer.pm b/lib/integer.pm new file mode 100644 index 0000000000..74039bb962 --- /dev/null +++ b/lib/integer.pm @@ -0,0 +1,11 @@ +package integer; + +sub import { + $^H |= 1; +} + +sub unimport { + $^H &= ~1; +} + +1; diff --git a/lib/less.pm b/lib/less.pm new file mode 100644 index 0000000000..a95484ff76 --- /dev/null +++ b/lib/less.pm @@ -0,0 +1,2 @@ +package less; +1; diff --git a/lib/open3.pl b/lib/open3.pl index 1dbe525f68..7c8b6ae288 100644 --- a/lib/open3.pl +++ b/lib/open3.pl @@ -90,9 +90,8 @@ sub main'open3 { } else { open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); } - exec @cmd; - local($")=(" "); + exec @cmd; die "open2: exec of @cmd failed"; } diff --git a/lib/perldb.pl b/lib/perl5db.pl index 0b50555172..ac03c098fe 100644 --- a/lib/perldb.pl +++ b/lib/perl5db.pl @@ -4,75 +4,34 @@ package DB; # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 # Johan Vromans -- upgrade to 4.0 pl 10 -$header = '$RCSfile: perldb.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:07 $'; +$header = '$RCSfile: perl5db.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:07 $'; # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. # # Perl supplies the values for @line and %sub. It effectively inserts -# a do DB'DB(<linenum>); in front of every place that can +# a &DB'DB(<linenum>); in front of every place that can # have a breakpoint. It also inserts a do 'perldb.pl' before the first line. # # $Log: perldb.pl,v $ -# Revision 4.1 92/08/07 18:24:07 lwall -# -# Revision 4.0.1.3 92/06/08 13:43:57 lwall -# patch20: support for MSDOS folded into perldb.pl -# patch20: perldb couldn't debug file containing '-', such as STDIN designator -# -# Revision 4.0.1.2 91/11/05 17:55:58 lwall -# patch11: perldb.pl modified to run within emacs in perldb-mode -# -# Revision 4.0.1.1 91/06/07 11:17:44 lwall -# patch4: added $^P variable to control calling of perldb routines -# patch4: debugger sometimes listed wrong number of lines for a statement -# -# Revision 4.0 91/03/20 01:25:50 lwall -# 4.0 baseline. -# -# Revision 3.0.1.6 91/01/11 18:08:58 lwall -# patch42: @_ couldn't be accessed from debugger -# -# Revision 3.0.1.5 90/11/10 01:40:26 lwall -# patch38: the debugger wouldn't stop correctly or do action routines -# -# Revision 3.0.1.4 90/10/15 17:40:38 lwall -# patch29: added caller -# patch29: the debugger now understands packages and evals -# patch29: scripts now run at almost full speed under the debugger -# patch29: more variables are settable from debugger -# -# Revision 3.0.1.3 90/08/09 04:00:58 lwall -# patch19: debugger now allows continuation lines -# patch19: debugger can now dump lists of variables -# patch19: debugger can now add aliases easily from prompt -# -# Revision 3.0.1.2 90/03/12 16:39:39 lwall -# patch13: perl -d didn't format stack traces of *foo right -# patch13: perl -d wiped out scalar return values of subroutines -# -# Revision 3.0.1.1 89/10/26 23:14:02 lwall -# patch1: RCS expanded an unintended $Header in lib/perldb.pl -# -# Revision 3.0 89/10/18 15:19:46 lwall -# 3.0 baseline -# -# Revision 2.0 88/06/05 00:09:45 root -# Baseline version 2.0. -# -# + +local($^W) = 0; if (-e "/dev/tty") { $console = "/dev/tty"; $rcfile=".perldb"; } -else { +elsif (-e "con") { $console = "con"; $rcfile="perldb.ini"; } +else { + $console = "sys\$command"; + $rcfile="perldb.ini"; +} open(IN, "<$console") || open(IN, "<&STDIN"); # so we don't dingle stdin -open(OUT,">$console") || open(OUT, "<&STDERR") +open(OUT,">$console") || open(OUT, ">&STDERR") || open(OUT, ">&STDOUT"); # so we don't dongle stdout select(OUT); $| = 1; # for DB::OUT @@ -81,7 +40,7 @@ $| = 1; # for real STDOUT $sub = ''; # Is Perl being run from Emacs? -$emacs = $main::ARGV[$[] eq '-emacs'; +$emacs = $main::ARGV[0] eq '-emacs'; shift(@main::ARGV) if $emacs; $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; @@ -94,7 +53,7 @@ print OUT "\nEnter h for help.\n\n"; sub DB { &save; ($package, $filename, $line) = caller; - $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' . + $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas local(*dbline) = "::_<$filename"; $max = $#dbline; @@ -111,11 +70,20 @@ sub DB { if ($emacs) { print OUT "\032\032$filename:$line:0\n"; } else { - print OUT "$package::" unless $sub =~ /'|::/; - print OUT "$sub($filename:$line):\t",$dbline[$line]; + $prefix = $sub =~ /'|::/ ? "" : "${package}::"; + $prefix .= "$sub($filename:"; + if (length($prefix) > 30) { + print OUT "$prefix$line):\n$line:\t",$dbline[$line]; + $prefix = ""; + $infix = ":\t"; + } + else { + $infix = "):\t"; + print OUT "$prefix$line$infix",$dbline[$line]; + } for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { last if $dbline[$i] =~ /^\s*(}|#|\n)/; - print OUT "$sub($filename:$i):\t",$dbline[$i]; + print OUT "$prefix$i$infix",$dbline[$i]; } } } @@ -222,13 +190,13 @@ command Execute as a perl statement in current package. print OUT "The new f command switches filenames.\n"; next CMD; } - if (!defined $::_main{'_<' . $file}) { - if (($try) = grep(m#^_<.*$file#, keys %::_main)) { + if (!defined $main::{'_<' . $file}) { + if (($try) = grep(m#^_<.*$file#, keys %main::)) { $file = substr($try,2); print "\n$file:\n"; } } - if (!defined $::_main{'_<' . $file}) { + if (!defined $main::{'_<' . $file}) { print OUT "There's no code here anything matching $file.\n"; next CMD; } @@ -320,7 +288,8 @@ command Execute as a perl statement in current package. $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { $subname = $1; $cond = $2 || '1'; - $subname = "$package::" . $subname unless $subname =~ /'|::/; + $subname = "${package}::" . $subname + unless $subname =~ /'|::/; $subname = "main" . $subname if substr($subname,0,1) eq "'"; $subname = "main" . $subname if substr($subname,0,2) eq "::"; ($filename,$i) = split(/:/, $sub{$subname}); @@ -356,10 +325,10 @@ command Execute as a perl statement in current package. } next CMD; }; $cmd =~ /^<\s*(.*)/ && do { - $pre = do action($1); + $pre = action($1); next CMD; }; $cmd =~ /^>\s*(.*)/ && do { - $post = do action($1); + $post = action($1); next CMD; }; $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do { $i = $1; @@ -367,7 +336,7 @@ command Execute as a perl statement in current package. print OUT "Line $i may not have an action.\n"; } else { $dbline{$i} =~ s/\0[^\0]*//; - $dbline{$i} .= "\0" . do action($3); + $dbline{$i} .= "\0" . action($3); } next CMD; }; $cmd =~ /^n$/ && do { @@ -397,16 +366,19 @@ command Execute as a perl statement in current package. $cmd =~ /^T$/ && do { local($p,$f,$l,$s,$h,$a,@a,@sub); for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { - @a = @args; - for (@a) { + @a = (); + for $arg (@args) { + $_ = "$arg"; s/'/\\'/g; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([^\0]*)/'$1'/ + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + push(@a, $_); } $w = $w ? '@ = ' : '$ = '; $a = $h ? '(' . join(', ', @a) . ')' : ''; - push(@sub, "$w&$s$a from file $f line $l\n"); + push(@sub, "$w$s$a from file $f line $l\n"); last if $signal; } for ($i=0; $i <= $#sub; $i++) { @@ -418,7 +390,7 @@ command Execute as a perl statement in current package. $inpat = $1; $inpat =~ s:([^\\])/$:$1:; if ($inpat ne "") { - eval '$inpat =~ m'."\n$inpat\n"; + eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print OUT "$@"; next CMD; @@ -431,7 +403,7 @@ command Execute as a perl statement in current package. ++$start; $start = 1 if ($start > $max); last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { + if ($dbline[$start] =~ m'."\a$pat\a".'i) { if ($emacs) { print OUT "\032\032$filename:$start:0\n"; } else { @@ -446,7 +418,7 @@ command Execute as a perl statement in current package. $inpat = $1; $inpat =~ s:([^\\])\?$:$1:; if ($inpat ne "") { - eval '$inpat =~ m'."\n$inpat\n"; + eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print OUT "$@"; next CMD; @@ -459,7 +431,7 @@ command Execute as a perl statement in current package. --$start; $start = $max if ($start <= 0); last if ($start == $end); - if ($dbline[$start] =~ m'."\n$pat\n".'i) { + if ($dbline[$start] =~ m'."\a$pat\a".'i) { if ($emacs) { print OUT "\032\032$filename:$start:0\n"; } else { @@ -520,12 +492,12 @@ command Execute as a perl statement in current package. $evalarg = $post; &eval; } } - ($@, $!, $[, $,, $/, $\) = @saved; + ($@, $!, $,, $/, $\) = @saved; } sub save { - @saved = ($@, $!, $[, $,, $/, $\); - $[ = 0; $, = ""; $/ = "\n"; $\ = ""; + @saved = ($@, $!, $,, $/, $\, $^W); + $, = ""; $/ = "\n"; $\ = ""; $^W = 0; } # The following takes its argument via $evalarg to preserve current @_ @@ -569,7 +541,8 @@ sub sub { } } -$single = 1; # so it stops on first executable statement +$trace = $signal = $single = 0; # uninitialized warning suppression + @hist = ('?'); $SIG{'INT'} = "DB::catch"; $deep = 100; # warning if stack gets this deep diff --git a/lib/pwd.pl b/lib/pwd.pl index 8e17dd02d2..0cc3d4e96e 100644 --- a/lib/pwd.pl +++ b/lib/pwd.pl @@ -3,20 +3,6 @@ ;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $ ;# ;# $Log: pwd.pl,v $ -;# Revision 4.1 92/08/07 18:24:11 lwall -;# -;# Revision 4.0.1.1 92/06/08 13:45:22 lwall -;# patch20: support added to pwd.pl to strip automounter crud -;# -;# Revision 4.0 91/03/20 01:26:03 lwall -;# 4.0 baseline. -;# -;# Revision 3.0.1.2 91/01/11 18:09:24 lwall -;# patch42: some .pl files were missing their trailing 1; -;# -;# Revision 3.0.1.1 90/08/09 04:01:24 lwall -;# patch19: Initial revision -;# ;# ;# Usage: ;# require "pwd.pl"; diff --git a/lib/shellwords.pl b/lib/shellwords.pl index 5d593daa50..1c45a5a090 100644 --- a/lib/shellwords.pl +++ b/lib/shellwords.pl @@ -17,13 +17,13 @@ sub shellwords { while ($_ ne '') { $field = ''; for (;;) { - if (s/^"(([^"\\]|\\[\\"])*)"//) { + if (s/^"(([^"\\]|\\.)*)"//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^"/) { die "Unmatched double quote: $_\n"; } - elsif (s/^'(([^'\\]|\\[\\'])*)'//) { + elsif (s/^'(([^'\\]|\\.)*)'//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^'/) { diff --git a/lib/sigtrap.pm b/lib/sigtrap.pm new file mode 100644 index 0000000000..72b9cb6044 --- /dev/null +++ b/lib/sigtrap.pm @@ -0,0 +1,47 @@ +package sigtrap; + +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++; + syswrite(STDERR, 'Caught a SIG', 12); + syswrite(STDERR, $_[0], length($_[0])); + syswrite(STDERR, ' at ', 4); + ($pack,$file,$line) = caller; + syswrite(STDERR, $file, length($file)); + syswrite(STDERR, ' line ', 6); + syswrite(STDERR, $line, length($line)); + syswrite(STDERR, "\n", 1); + + # Now go for broke. + for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { + @a = (); + for $arg (@args) { + $_ = "$arg"; + s/'/\\'/g; + s/([^\0]*)/'$1'/ + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + push(@a, $_); + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + $mess = "$w$s$a called from $f line $l\n"; + syswrite(STDERR, $mess, length($mess)); + } + kill 'ABRT', $$; +} + +1; diff --git a/lib/soundex.pl.art b/lib/soundex.pl.art deleted file mode 100644 index 1cc0b9e53c..0000000000 --- a/lib/soundex.pl.art +++ /dev/null @@ -1,285 +0,0 @@ -Article 20106 of comp.lang.perl: -Path: netlabs!news.cerf.net!ihnp4.ucsd.edu!mvb.saic.com!MathWorks.Com!noc.near.net!newshost.meiko.com!not-for-mail -From: mike@meiko.com (Mike Stok) -Newsgroups: comp.lang.perl -Subject: Soundex (again :-) -Date: 23 Mar 1994 19:44:35 -0500 -Organization: Meiko Scientific, Inc., MA -Lines: 272 -Message-ID: <2mqnpj$qk4@hibbert.meiko.com> -NNTP-Posting-Host: hibbert.meiko.com - -Thanks to Rich Pinder <rpinder@hsc.usc.edu> for finding a little bug in my -soundex code I posted a while back. This showed up when he compared it -with the output from Oracle's soundex function, and were caused by leading -characters which were different but shared the same soundex code. - -Here's a fixed shar file... - -Mike - -#!/bin/sh -# This is a shell archive (produced by shar 3.49) -# To extract the files from this archive, save it to a file, remove -# everything above the "!/bin/sh" line above, and type "sh file_name". -# -# made 03/24/1994 00:35 UTC by Mike.Stok@meiko.concord.ma.us -# Source directory /tmp_mnt/develop/sw/misc/mike/soundex -# -# existing files will NOT be overwritten unless -c is specified -# -# This shar contains: -# length mode name -# ------ ---------- ------------------------------------------ -# 1677 -r--r--r-- soundex.pl -# 2408 -r-xr-xr-x soundex.t -# -# ============= soundex.pl ============== -if test -f 'soundex.pl' -a X"$1" != X"-c"; then - echo 'x - skipping soundex.pl (File already exists)' -else -echo 'x - extracting soundex.pl (Text)' -sed 's/^X//' << 'SHAR_EOF' > 'soundex.pl' && -package soundex; -X -;# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $ -;# -;# Implementation of soundex algorithm as described by Knuth in volume -;# 3 of The Art of Computer Programming, with ideas stolen from Ian -;# Phillips <ian@pipex.net>. -;# -;# Mike Stok <Mike.Stok@meiko.concord.ma.us>, 2 March 1994. -;# -;# Knuth's test cases are: -;# -;# Euler, Ellery -> E460 -;# Gauss, Ghosh -> G200 -;# Hilbert, Heilbronn -> H416 -;# Knuth, Kant -> K530 -;# Lloyd, Ladd -> L300 -;# Lukasiewicz, Lissajous -> L222 -;# -;# $Log: soundex.pl,v $ -;# Revision 1.2 1994/03/24 00:30:27 mike -;# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> -;# in the way I handles leasing characters which were different but had -;# the same soundex code. This showed up comparing it with Oracle's -;# soundex output. -;# -;# Revision 1.1 1994/03/02 13:01:30 mike -;# Initial revision -;# -;# -;############################################################################## -X -;# $soundex'noCode is used to indicate a string doesn't have a soundex -;# code, I like undef other people may want to set it to 'Z000'. -X -$noCode = undef; -X -;# main'soundex -;# -;# usage: -;# -;# @codes = &main'soundex (@wordList); -;# $code = &main'soundex ($word); -;# -;# This strenuously avoids $[ -X -sub main'soundex -{ -X local (@s, $f, $fc, $_) = @_; -X -X foreach (@s) -X { -X tr/a-z/A-Z/; -X tr/A-Z//cd; -X -X if ($_ eq '') -X { -X $_ = $noCode; -X } -X else -X { -X ($f) = /^(.)/; -X tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/; -X ($fc) = /^(.)/; -X s/^$fc+//; -X tr///cs; -X tr/0//d; -X $_ = $f . $_ . '000'; -X s/^(.{4}).*/$1/; -X } -X } -X -X wantarray ? @s : shift @s; -} -X -1; -SHAR_EOF -chmod 0444 soundex.pl || -echo 'restore of soundex.pl failed' -Wc_c="`wc -c < 'soundex.pl'`" -test 1677 -eq "$Wc_c" || - echo 'soundex.pl: original size 1677, current size' "$Wc_c" -fi -# ============= soundex.t ============== -if test -f 'soundex.t' -a X"$1" != X"-c"; then - echo 'x - skipping soundex.t (File already exists)' -else -echo 'x - extracting soundex.t (Text)' -sed 's/^X//' << 'SHAR_EOF' > 'soundex.t' && -#!./perl -;# -;# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $ -;# -;# test module for soundex.pl -;# -;# $Log: soundex.t,v $ -;# Revision 1.2 1994/03/24 00:30:27 mike -;# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> -;# in the way I handles leasing characters which were different but had -;# the same soundex code. This showed up comparing it with Oracle's -;# soundex output. -;# -;# Revision 1.1 1994/03/02 13:03:02 mike -;# Initial revision -;# -;# -X -require '../lib/soundex.pl'; -X -$test = 0; -print "1..13\n"; -X -while (<DATA>) -{ -X chop; -X next if /^\s*;?#/; -X next if /^\s*$/; -X -X ++$test; -X $bad = 0; -X -X if (/^eval\s+/) -X { -X ($try = $_) =~ s/^eval\s+//; -X -X eval ($try); -X if ($@) -X { -X $bad++; -X print "not ok $test\n"; -X print "# eval '$try' returned $@"; -X } -X } -X elsif (/^\(/) -X { -X ($in, $out) = split (':'); -X -X $try = "\@expect = $out; \@got = &soundex $in;"; -X eval ($try); -X -X if (@expect != @got) -X { -X $bad++; -X print "not ok $test\n"; -X print "# expected ", scalar @expect, " results, got ", scalar @got, "\n"; -X print "# expected (", join (', ', @expect), -X ") got (", join (', ', @got), ")\n"; -X } -X else -X { -X while (@got) -X { -X $expect = shift @expect; -X $got = shift @got; -X -X if ($expect ne $got) -X { -X $bad++; -X print "not ok $test\n"; -X print "# expected $expect, got $got\n"; -X } -X } -X } -X } -X else -X { -X ($in, $out) = split (':'); -X -X $try = "\$expect = $out; \$got = &soundex ($in);"; -X eval ($try); -X -X if ($expect ne $got) -X { -X $bad++; -X print "not ok $test\n"; -X print "# expected $expect, got $got\n"; -X } -X } -X -X print "ok $test\n" unless $bad; -} -X -__END__ -# -# 1..6 -# -# Knuth's test cases, scalar in, scalar out -# -'Euler':'E460' -'Gauss':'G200' -'Hilbert':'H416' -'Knuth':'K530' -'Lloyd':'L300' -'Lukasiewicz':'L222' -# -# 7..8 -# -# check default bad code -# -'2 + 2 = 4':undef -undef:undef -# -# 9 -# -# check array in, array out -# -('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222') -# -# 10 -# -# check array with explicit undef -# -('Mike', undef, 'Stok'):('M200', undef, 'S320') -# -# 11..12 -# -# check setting $soundex'noCode -# -eval $soundex'noCode = 'Z000'; -('Mike', undef, 'Stok'):('M200', 'Z000', 'S320') -# -# 13 -# -# a subtle difference between me & oracle, spotted by Rich Pinder -# <rpinder@hsc.usc.edu> -# -CZARKOWSKA:C622 -SHAR_EOF -chmod 0555 soundex.t || -echo 'restore of soundex.t failed' -Wc_c="`wc -c < 'soundex.t'`" -test 2408 -eq "$Wc_c" || - echo 'soundex.t: original size 2408, current size' "$Wc_c" -fi -exit 0 - --- -The "usual disclaimers" apply. | Meiko -Mike Stok | 130C Baker Ave. Ext -Mike.Stok@meiko.concord.ma.us | Concord, MA 01742 -Meiko tel: (508) 371 0088 | - - diff --git a/lib/strict.pm b/lib/strict.pm new file mode 100644 index 0000000000..adaf47c720 --- /dev/null +++ b/lib/strict.pm @@ -0,0 +1,23 @@ +package strict; + +sub bits { + my $bits = 0; + foreach $sememe (@_) { + $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; diff --git a/lib/subs.pm b/lib/subs.pm new file mode 100644 index 0000000000..8b5835770f --- /dev/null +++ b/lib/subs.pm @@ -0,0 +1,16 @@ +package subs; + +require 5.000; + +$ExportLevel = 0; + +sub import { + my $callpack = caller; + my $pack = shift; + my @imports = @_; + foreach $sym (@imports) { + *{"${callpack}::$sym"} = \&{"${callpack}::$sym"}; + } +}; + +1; diff --git a/lib/syslog.pl b/lib/syslog.pl index 8e64a0028d..a3b9edf8da 100644 --- a/lib/syslog.pl +++ b/lib/syslog.pl @@ -2,41 +2,7 @@ # syslog.pl # # $Log: syslog.pl,v $ -# Revision 4.1 92/08/07 18:24:15 lwall # -# Revision 4.0.1.1 92/06/08 13:48:05 lwall -# patch20: new warning for ambiguous use of unary operators -# -# Revision 4.0 91/03/20 01:26:24 lwall -# 4.0 baseline. -# -# Revision 3.0.1.4 90/11/10 01:41:11 lwall -# patch38: syslog.pl was referencing an absolute path -# -# Revision 3.0.1.3 90/10/15 17:42:18 lwall -# patch29: various portability fixes -# -# Revision 3.0.1.1 90/08/09 03:57:17 lwall -# patch19: Initial revision -# -# Revision 1.2 90/06/11 18:45:30 18:45:30 root () -# - Changed 'warn' to 'mail|warning' in test call (to give example of -# facility specification, and because 'warn' didn't work on HP-UX). -# - Fixed typo in &openlog ("ncons" should be "cons"). -# - Added (package-global) $maskpri, and &setlogmask. -# - In &syslog: -# - put argument test ahead of &connect (why waste cycles?), -# - allowed facility to be specified in &syslog's first arg (temporarily -# overrides any $facility set in &openlog), just as in syslog(3C), -# - do a return 0 when bit for $numpri not set in log mask (see syslog(3C)), -# - changed $whoami code to use getlogin, getpwuid($<) and 'syslog' -# (in that order) when $ident is null, -# - made PID logging consistent with syslog(3C) and subject to $lo_pid only, -# - fixed typo in "print CONS" statement ($<facility should be <$facility). -# - changed \n to \r in print CONS (\r is useful, $message already has a \n). -# - Changed &xlate to return -1 for an unknown name, instead of croaking. -# -# # tom christiansen <tchrist@convex.com> # modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> # NOTE: openlog now takes three arguments, just like openlog(3) diff --git a/lib/Termcap.pm b/lib/termcap.pl index da4c7ce2bc..e8f108df06 100644 --- a/lib/Termcap.pm +++ b/lib/termcap.pl @@ -1,19 +1,10 @@ -package Termcap; - -require 5.000; -require Exporter; -@ISA = (Exporter); -@EXPORT = qw(&Tgetent $ispeed $ospeed &Tputs %TC &Tgoto); - - -;# Termcap.pm +;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $ ;# ;# Usage: ;# require 'ioctl.pl'; -;# require Termcap; -;# import Termcap; ;# ioctl(TTY,$TIOCGETP,$foo); ;# ($ispeed,$ospeed) = unpack('cc',$foo); +;# require 'termcap.pl'; ;# &Tgetent('vt100'); # sets $TC{'cm'}, etc. ;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); ;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); @@ -23,10 +14,11 @@ sub Tgetent { local($TERMCAP,$_,$entry,$loop,$field); warn "Tgetent: no ospeed set" unless $ospeed; - foreach $key (keys(%TC)) { + foreach $key (keys(TC)) { delete $TC{$key}; } $TERM = $ENV{'TERM'} unless $TERM; + $TERM =~ s/(\W)/\\$1/g; $TERMCAP = $ENV{'TERMCAP'}; $TERMCAP = '/etc/termcap' unless $TERMCAP; if ($TERMCAP !~ m:^/:) { @@ -42,7 +34,7 @@ sub Tgetent { while (<TERMCAP>) { next if /^#/; next if /^\t/; - if (/(^|\\|)$TERM\[:\\|]/) { + if (/(^|\\|)${TERM}[:\\|]/) { chop; while (chop eq '\\\\') { \$_ .= <TERMCAP>; @@ -65,7 +57,7 @@ sub Tgetent { $TC{$field} = 1; } elsif ($field =~ /^(\w\w)#(.*)/) { - $TC{$1} = $2 unless defined $TC{$1}; + $TC{$1} = $2 if $TC{$1} eq ''; } elsif ($field =~ /^(\w\w)=(.*)/) { $entry = $1; @@ -82,11 +74,11 @@ sub Tgetent { s/\^(.)/pack('c',ord($1) & 31)/eg; s/\\(.)/$1/g; s/\377/^/g; - $TC{$entry} = $_ unless defined $TC{$entry}; + $TC{$entry} = $_ if $TC{$entry} eq ''; } } - $TC{'pc'} = "\0" unless defined $TC{'pc'}; - $TC{'bc'} = "\b" unless defined $TC{'bc'}; + $TC{'pc'} = "\0" if $TC{'pc'} eq ''; + $TC{'bc'} = "\b" if $TC{'bc'} eq ''; } @Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); diff --git a/lib/timelocal.pl b/lib/timelocal.pl index c5d8a92920..75f1ac1851 100644 --- a/lib/timelocal.pl +++ b/lib/timelocal.pl @@ -21,6 +21,9 @@ ;# the result of localtime(0) when the package is initialized. The daylight ;# savings offset is currently assumed to be one hour. +;# Both routines return -1 if the integer limit is hit. I.e. for dates +;# after the 1st of January, 2038 on most machines. + CONFIG: { package timelocal; @@ -46,6 +49,7 @@ sub timegm { local($[) = 0; $ym = pack(C2, @_[5,4]); $cheat = $cheat{$ym} || &cheat; + return -1 if $cheat<0; $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; } @@ -54,6 +58,7 @@ sub timelocal { local($[) = 0; $time = &main'timegm + $tzmin*$MIN; + return -1 if $cheat<0; @test = localtime($time); $time -= $HR if $test[2] != $_[2]; $time; @@ -64,17 +69,39 @@ package timelocal; sub cheat { $year = $_[5]; $month = $_[4]; - die "Month out of range 0..11 in ctime.pl\n" if $month > 11; + die "Month out of range 0..11 in timelocal.pl\n" + if $month > 11 || $month < 0; + die "Day out of range 1..31 in timelocal.pl\n" + if $_[3] > 31 || $_[3] < 1; + die "Hour out of range 0..23 in timelocal.pl\n" + if $_[2] > 23 || $_[2] < 0; + die "Minute out of range 0..59 in timelocal.pl\n" + if $_[1] > 59 || $_[1] < 0; + die "Second out of range 0..59 in timelocal.pl\n" + if $_[0] > 59 || $_[0] < 0; $guess = $^T; @g = gmtime($guess); $year += $YearFix if $year < $epoch[5]; + $lastguess = ""; while ($diff = $year - $g[5]) { $guess += $diff * (363 * $DAYS); @g = gmtime($guess); + if (($thisguess = "@g") eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $lastguess = $thisguess; } while ($diff = $month - $g[4]) { $guess += $diff * (27 * $DAYS); @g = gmtime($guess); + if (($thisguess = "@g") eq $lastguess){ + return -1; #date beyond this machine's integer limit + } + $lastguess = $thisguess; + } + @gfake = gmtime($guess-1); #still being sceptic + if ("@gfake" eq $lastguess){ + return -1; #date beyond this machine's integer limit } $g[3]--; $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; diff --git a/main.c b/main.c deleted file mode 100644 index 8cb0a88b08..0000000000 --- a/main.c +++ /dev/null @@ -1,37 +0,0 @@ -#include "INTERN.h" -#include "perl.h" - -main(argc, argv, env) -int argc; -char **argv; -char **env; -{ - int exitstatus; - PerlInterpreter *my_perl; - - my_perl = perl_alloc(); - if (!my_perl) - exit(1); - perl_construct( my_perl ); - - exitstatus = perl_parse( my_perl, argc, argv, env ); - if (exitstatus) - exit( exitstatus ); - - exitstatus = perl_run( my_perl ); - - perl_destruct( my_perl ); - perl_free( my_perl ); - - exit( exitstatus ); -} - -/* Register any extra external extensions */ - -void -perl_init_ext() -{ - char *file = __FILE__; - - boot_DynamicLoader(); -} diff --git a/make.out b/make.out deleted file mode 100644 index c38dafddad..0000000000 --- a/make.out +++ /dev/null @@ -1,9 +0,0 @@ -make: Warning: Both `makefile' and `Makefile' exists -test -f miniperl || make miniperl -./miniperl ext/xsubpp ext/posix/POSIX.xs >tmp -mv tmp POSIX.c -`sh cflags POSIX.o` POSIX.c - CCCMD = cc -c -DDEBUGGING -g -test -d lib/auto/POSIX || mkdir lib/auto/POSIX -ld -o lib/auto/POSIX/POSIX.so POSIX.o -lm -cc -o perl perlmain.o perl.o av.o scope.o op.o doop.o doio.o dump.o hv.o malloc.o mg.o perly.o pp.o regcomp.o regexec.o gv.o sv.o taint.o toke.o util.o deb.o run.o dl_sunos.o -ldbm -ldl -lm -lposix diff --git a/makedepend b/makedepend deleted file mode 100755 index 6aec6dfd50..0000000000 --- a/makedepend +++ /dev/null @@ -1,155 +0,0 @@ -#!/bin/sh -# $RCSfile: makedepend.SH,v 3314Revision: 4.1 3314Date: 92/08/07 18:24:20 $ -# -# $Log: makedepend.SH,v $ -# Revision 4.1 92/08/07 18:24:20 lwall -# -# Revision 4.0.1.4 92/06/08 13:51:24 lwall -# patch20: various and sundry fixes -# -# Revision 4.0.1.3 91/11/05 17:56:33 lwall -# patch11: various portability fixes -# -# Revision 4.0.1.2 91/06/07 15:40:06 lwall -# patch4: fixed cppstdin to run in the right directory -# -# Revision 4.0.1.1 91/06/07 11:20:06 lwall -# patch4: Makefile is no longer self-modifying code under makedepend -# -# Revision 4.0 91/03/20 01:27:04 lwall -# 4.0 baseline. -# -# - -export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0; kill $$) - -cat='/bin/cat' -cppflags=' -DDEBUGGING' -cp='/bin/cp' -cppstdin='/tmp_mnt/net/vaccine/export/src/local/lwall/perl5/cppstdin' -cppminus='' -echo='/bin/echo' -egrep='/bin/egrep' -expr='/bin/expr' -mv='/bin/mv' -rm='/bin/rm' -sed='/bin/sed' -sort='/bin/sort' -test='test' -tr='/bin/tr' -uniq='/bin/uniq' - -PATH="$PATH:." -export PATH - -$cat /dev/null >.deptmp -$rm -f *.c.c c/*.c.c -if test -f Makefile; then - cp Makefile makefile -fi -mf=makefile -if test -f $mf; then - defrule=`<$mf sed -n \ - -e '/^\.c\.o:.*;/{' \ - -e 's/\$\*\.c//' \ - -e 's/^[^;]*;[ ]*//p' \ - -e q \ - -e '}' \ - -e '/^\.c\.o: *$/{' \ - -e N \ - -e 's/\$\*\.c//' \ - -e 's/^.*\n[ ]*//p' \ - -e q \ - -e '}'` -fi -case "$defrule" in -'') defrule='$(CC) -c $(CFLAGS)' ;; -esac - -: Create files in UU directory to avoid problems with long filenames -: on systems with 14 character filename limits so file.c.c and file.c -: might be identical -$test -d UU || mkdir UU - -make clist || ($echo "Searching for .c files..."; \ - $echo *.c | $tr ' ' '\012' | $egrep -v '\*' >.clist) -for file in `$cat .clist`; do -# for file in `cat /dev/null`; do - case "$file" in - *.c) filebase=`basename $file .c` ;; - *.y) filebase=`basename $file .y` ;; - esac - case "$file" in - */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;; - *) finc= ;; - esac - $echo "Finding dependencies for $filebase.o." - ( $echo "#line 1 \"$file\""; \ - $sed -n <$file \ - -e "/^${filebase}_init(/q" \ - -e '/^#line/d' \ - -e '/^#/{' \ - -e 's|/\*.*$||' \ - -e 's|\\$||' \ - -e p \ - -e '}' ) >UU/$file.c - $cppstdin $finc -I/usr/local/include -I. $cppflags $cppminus <UU/$file.c | - $sed \ - -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \ - -e 's/^[ ]*#[ ]*line/#/' \ - -e '/^# *[0-9][0-9]* *[".\/]/!d' \ - -e 's/^.*"\(.*\)".*$/'$filebase'.o: \1/' \ - -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'.o: \1/' \ - -e 's|: \./|: |' \ - -e 's|\.c\.c|.c|' | \ - $uniq | $sort | $uniq >> .deptmp -done - -$sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d' - -make shlist || ($echo "Searching for .SH files..."; \ - $echo *.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist) -if $test -s .deptmp; then - for file in `cat .shlist`; do - $echo `$expr X$file : 'X\(.*\).SH'`: $file config.sh \; \ - /bin/sh $file >> .deptmp - done - $echo "Updating $mf..." - $echo "# If this runs make out of memory, delete /usr/include lines." \ - >> $mf.new - $sed 's|^\(.*\.o:\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \ - >>$mf.new -else - make hlist || ($echo "Searching for .h files..."; \ - $echo *.h | $tr ' ' '\012' | $egrep -v '\*' >.hlist) - $echo "You don't seem to have a proper C preprocessor. Using grep instead." - $egrep '^#include ' `cat .clist` `cat .hlist` >.deptmp - $echo "Updating $mf..." - <.clist $sed -n \ - -e '/\//{' \ - -e 's|^\(.*\)/\(.*\)\.c|\2.o: \1/\2.c; '"$defrule \1/\2.c|p" \ - -e d \ - -e '}' \ - -e 's|^\(.*\)\.c|\1.o: \1.c|p' >> $mf.new - <.hlist $sed -n 's|\(.*/\)\(.*\)|s= \2= \1\2=|p' >.hsed - <.deptmp $sed -n 's|c:#include "\(.*\)".*$|o: \1|p' | \ - $sed 's|^[^;]*/||' | \ - $sed -f .hsed >> $mf.new - <.deptmp $sed -n 's|c:#include <\(.*\)>.*$|o: /usr/include/\1|p' \ - >> $mf.new - <.deptmp $sed -n 's|h:#include "\(.*\)".*$|h: \1|p' | \ - $sed -f .hsed >> $mf.new - <.deptmp $sed -n 's|h:#include <\(.*\)>.*$|h: /usr/include/\1|p' \ - >> $mf.new - for file in `$cat .shlist`; do - $echo `$expr X$file : 'X\(.*\).SH'`: $file 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 -$rm -rf .deptmp UU .shlist .clist .hlist .hsed - diff --git a/makedepend.SH b/makedepend.SH index 01963f873e..296c954045 100755 --- a/makedepend.SH +++ b/makedepend.SH @@ -1,63 +1,42 @@ case $CONFIG in '') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi 2>/dev/null - . ./config.sh - ;; + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; esac +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac echo "Extracting makedepend (with variable substitutions)" rm -f makedepend -$spitshell >makedepend <<!GROK!THIS! -$startsh -# $RCSfile: makedepend.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:24:20 $ +$spitshell >makedepend <<'!NO!SUBS!' +# makedepend.SH # -# $Log: makedepend.SH,v $ -# Revision 4.1 92/08/07 18:24:20 lwall -# -# Revision 4.0.1.4 92/06/08 13:51:24 lwall -# patch20: various and sundry fixes -# -# Revision 4.0.1.3 91/11/05 17:56:33 lwall -# patch11: various portability fixes -# -# Revision 4.0.1.2 91/06/07 15:40:06 lwall -# patch4: fixed cppstdin to run in the right directory -# -# Revision 4.0.1.1 91/06/07 11:20:06 lwall -# patch4: Makefile is no longer self-modifying code under makedepend -# -# Revision 4.0 91/03/20 01:27:04 lwall -# 4.0 baseline. -# -# export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$) -cat='$cat' -cppflags='$cppflags' -cp='$cp' -cppstdin='$cppstdin' -cppminus='$cppminus' -echo='$echo' -egrep='$egrep' -expr='$expr' -mv='$mv' -rm='$rm' -sed='$sed' -sort='$sort' -test='$test' -tr='$tr' -uniq='$uniq' -!GROK!THIS! - -$spitshell >>makedepend <<'!NO!SUBS!' +case $CONFIG in +'') + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; +esac PATH="$PATH:." export PATH @@ -131,7 +110,7 @@ make shlist || ($echo "Searching for .SH files..."; \ $echo *.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist) if $test -s .deptmp; then for file in `cat .shlist`; do - $echo `$expr X$file : 'X\(.*\).SH'`: $file config.sh \; \ + $echo `$expr X$file : 'X\(.*\).SH'`: $file $TOP/config.sh \; \ /bin/sh $file >> .deptmp done $echo "Updating $mf..." @@ -155,14 +134,10 @@ else <.deptmp $sed -n 's|c:#include "\(.*\)".*$|o: \1|p' | \ $sed 's|^[^;]*/||' | \ $sed -f .hsed >> $mf.new - <.deptmp $sed -n 's|c:#include <\(.*\)>.*$|o: /usr/include/\1|p' \ - >> $mf.new <.deptmp $sed -n 's|h:#include "\(.*\)".*$|h: \1|p' | \ $sed -f .hsed >> $mf.new - <.deptmp $sed -n 's|h:#include <\(.*\)>.*$|h: /usr/include/\1|p' \ - >> $mf.new for file in `$cat .shlist`; do - $echo `$expr X$file : 'X\(.*\).SH'`: $file config.sh \; \ + $echo `$expr X$file : 'X\(.*\).SH'`: $file $TOP/config.sh \; \ /bin/sh $file >> $mf.new done fi diff --git a/makedir b/makedir deleted file mode 100755 index 250bdd5fb0..0000000000 --- a/makedir +++ /dev/null @@ -1,58 +0,0 @@ -#!/bin/sh -# $RCSfile: makedir.SH,v 3314Revision: 4.1 3314Date: 92/08/07 18:24:23 $ -# -# $Log: makedir.SH,v $ -# Revision 4.1 92/08/07 18:24:23 lwall -# -# Revision 4.0.1.1 92/06/08 14:24:55 lwall -# patch20: SH files didn't work well with symbolic links -# -# Revision 4.0 91/03/20 01:27:13 lwall -# 4.0 baseline. -# -# - -export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0; kill $$) - -case $# in - 0) - /bin/echo "makedir pathname filenameflag" - exit 1 - ;; -esac - -: guarantee one slash before 1st component -case $1 in - /*) ;; - *) set ./$1 $2 ;; -esac - -: strip last component if it is to be a filename -case X$2 in - X1) set `/bin/echo $1 | /bin/sed 's:\(.*\)/[^/]*$:\1:'` ;; - *) set $1 ;; -esac - -: return reasonable status if nothing to be created -if test -d "$1" ; then - exit 0 -fi - -list='' -while true ; do - case $1 in - */*) - list="$1 $list" - set `echo $1 | /bin/sed 's:\(.*\)/:\1 :'` - ;; - *) - break - ;; - esac -done - -set $list - -for dir do - /bin/mkdir $dir >/dev/null 2>&1 -done diff --git a/makedir.SH b/makedir.SH index 4d055cf450..09908edff2 100755 --- a/makedir.SH +++ b/makedir.SH @@ -16,17 +16,7 @@ echo "Extracting makedir (with variable substitutions)" rm -f makedir $spitshell >makedir <<!GROK!THIS! $startsh -# $RCSfile: makedir.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:24:23 $ -# -# $Log: makedir.SH,v $ -# Revision 4.1 92/08/07 18:24:23 lwall -# -# Revision 4.0.1.1 92/06/08 14:24:55 lwall -# patch20: SH files didn't work well with symbolic links -# -# Revision 4.0 91/03/20 01:27:13 lwall -# 4.0 baseline. -# +# makedir.SH # export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$) diff --git a/makefile b/makefile deleted file mode 100644 index 98bb363faf..0000000000 --- a/makefile +++ /dev/null @@ -1,1523 +0,0 @@ -# .SH,v $Revision: 4.1 $Date: 92/08/07 17:18:08 $ -# 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. -# -# $Log: Makefile.SH,v $ -# Revision 4.1 92/08/07 17:18:08 lwall -# Stage 6 Snapshot -# -# Revision 4.0.1.4 92/06/08 11:40:43 lwall -# patch20: cray didn't give enough memory to /bin/sh -# patch20: various and sundry fixes -# -# Revision 4.0.1.3 91/11/05 15:48:11 lwall -# patch11: saberized perl -# patch11: added support for dbz -# -# Revision 4.0.1.2 91/06/07 10:14:43 lwall -# patch4: cflags now emits entire cc command except for the filename -# patch4: alternate make programs are now semi-supported -# patch4: uperl.o no longer tries to link in libraries prematurely -# patch4: installperl now installs x2p stuff too -# -# Revision 4.0.1.1 91/04/11 17:30:39 lwall -# patch1: C flags are now settable on a per-file basis -# -# Revision 4.0 91/03/20 00:58:54 lwall -# 4.0 baseline. -# -# - -# I now supply perly.c with the kits, so don't remake perly.c without byacc -BYACC = byacc -CC = cc -bin = /usr/local/bin -scriptdir = /usr/local/bin -privlib = /usr/local/lib/perl -mansrc = /usr/local/man/man1 -manext = 1 -LDFLAGS = -CLDFLAGS = - -SMALL = -LARGE = -mallocsrc = malloc.c -mallocobj = malloc.o -dlsrc = dl_sunos.c -dlobj = dl_sunos.o -dldir = ext/dl -LNS = /bin/ln -s -RMS = rm -f -ranlib = /usr/bin/ranlib - -# The following are used to build and install shared libraries for -# dynamic loading. -LDDLFLAGS = -CCDLFLAGS = -CCCDLFLAGS = -SHLIBSUFFIX = .so - -libs = -ldbm -ldl -lm -lposix - -public = perl - -shellflags = - -## To use an alternate make, set in config.sh. -MAKE = make - -CCCMD = `sh $(shellflags) cflags $@` - -private = - -scripts = h2ph - -manpages = perl.man h2ph.man - -util = - -sh = Makefile.SH cflags.SH embed_h.SH makedepend.SH makedir.SH writemain.SH - -h1 = EXTERN.h INTERN.h av.h cop.h config.h embed.h form.h handy.h -h2 = hv.h op.h opcode.h perl.h regcomp.h regexp.h gv.h sv.h util.h - -h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h -h2 = embed.h form.h gv.h handy.h hv.h hvdbm.h keywords.h mg.h op.h -h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h -h4 = regexp.h scope.h sv.h unixish.h util.h -h = $(h1) $(h2) $(h3) $(h4) - -c1 = av.c scope.c op.c doop.c doio.c dump.c hv.c -c2 = $(mallocsrc) mg.c perly.c pp.c regcomp.c regexec.c -c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c - -c = $(c1) $(c2) $(c3) $(dlsrc) miniperlmain.c perlmain.c - -s1 = av.c scope.c op.c doop.c doio.c dump.c hv.c -s2 = $(mallocsrc) mg.c perly.c pp.c regcomp.c regexec.c -s3 = gv.c sv.c taint.c toke.c util.c deb.c run.c perly.c - -saber = $(s1) $(s2) $(s3) $(dlsrc) - -obj1 = av.o scope.o op.o doop.o doio.o dump.o hv.o -obj2 = $(mallocobj) mg.o perly.o pp.o regcomp.o regexec.o -obj3 = gv.o sv.o taint.o toke.o util.o deb.o run.o - -obj = $(obj1) $(obj2) $(obj3) - -lintflags = -hbvxac - -addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 - -# grrr -SHELL = /bin/sh - -.c.o: - $(CCCMD) $*.c - -all: miniperl perl lib/Config.pm - -#all: $(public) $(private) $(util) $(scripts) -# cd x2p; $(MAKE) all -# touch all - -# Phony target to force checking subdirectories. -FORCE: - - -$(dlsrc): $(dldir)/$(dlsrc) - cp $(dldir)/$(dlsrc) $(dlsrc) - -$(dlobj): $(dlsrc) - $(CCCMD) $(dlsrc) - - -# NDBM_File extension -NDBM_File.o: NDBM_File.c - $(CCCMD) $(CCCDLFLAGS) $*.c - -NDBM_File.c: ext/dbm/NDBM_File.xs ext/xsubpp ext/typemap - test -f miniperl || make miniperl - ./miniperl ext/xsubpp ext/dbm/NDBM_File.xs >tmp - mv tmp NDBM_File.c - -lib/auto/NDBM_File/NDBM_File$(SHLIBSUFFIX): NDBM_File.o - test -d lib/auto/NDBM_File || mkdir lib/auto/NDBM_File - ld $(LDDLFLAGS) -o $@ NDBM_File.o - -# ODBM_File extension -ODBM_File.o: ODBM_File.c - $(CCCMD) $(CCCDLFLAGS) $*.c - -ODBM_File.c: ext/dbm/ODBM_File.xs ext/xsubpp ext/typemap - test -f miniperl || make miniperl - ./miniperl ext/xsubpp ext/dbm/ODBM_File.xs >tmp - mv tmp ODBM_File.c - -lib/auto/ODBM_File/ODBM_File$(SHLIBSUFFIX): ODBM_File.o - test -d lib/auto/ODBM_File || mkdir lib/auto/ODBM_File - ld $(LDDLFLAGS) -o $@ ODBM_File.o - -# SDBM_File extension -SDBM_File.o: SDBM_File.c - $(CCCMD) $(CCCDLFLAGS) $*.c - -SDBM_File.c: ext/dbm/SDBM_File.xs ext/xsubpp ext/typemap - test -f miniperl || make miniperl - ./miniperl ext/xsubpp ext/dbm/SDBM_File.xs >tmp - mv tmp SDBM_File.c - -lib/auto/SDBM_File/SDBM_File$(SHLIBSUFFIX): SDBM_File.o ext/dbm/sdbm/libsdbm.a - test -d lib/auto/SDBM_File || mkdir lib/auto/SDBM_File - ld $(LDDLFLAGS) -o $@ SDBM_File.o ext/dbm/sdbm/libsdbm.a - -# POSIX extension -POSIX.o: POSIX.c - $(CCCMD) $(CCCDLFLAGS) $*.c - -POSIX.c: ext/posix/POSIX.xs ext/xsubpp ext/typemap - test -f miniperl || make miniperl - ./miniperl ext/xsubpp ext/posix/POSIX.xs >tmp - mv tmp POSIX.c - -lib/auto/POSIX/POSIX$(SHLIBSUFFIX): POSIX.o - test -d lib/auto/POSIX || mkdir lib/auto/POSIX - ld $(LDDLFLAGS) -o $@ POSIX.o -lm - -# List of extensions (used by writemain) to generate perlmain.c -ext= NDBM_File ODBM_File SDBM_File POSIX -extsrc= NDBM_File.c ODBM_File.c SDBM_File.c POSIX.c -# Extension dependencies. -extdep= lib/auto/NDBM_File/NDBM_File$(SHLIBSUFFIX) lib/auto/ODBM_File/ODBM_File$(SHLIBSUFFIX) lib/auto/SDBM_File/SDBM_File$(SHLIBSUFFIX) lib/auto/POSIX/POSIX$(SHLIBSUFFIX) -# How to include extensions in linking command -extobj= - -ext/dbm/sdbm/libsdbm.a: ext/dbm/sdbm/sdbm.h ext/dbm/sdbm/sdbm.c - cd ext/dbm/sdbm; $(MAKE) -f Makefile libsdbm.a - -# The $& notation tells Sequent machines that it can do a parallel make, -# and is harmless otherwise. - -miniperl: $& miniperlmain.o perl.o $(obj) - $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain.o perl.o $(obj) $(libs) - -perlmain.c: miniperlmain.c - sh writemain $(ext) > perlmain.c - -perlmain.o: perlmain.c - -perl: $& perlmain.o perl.o $(obj) $(dlobj) $(extdep) - $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain.o perl.o $(obj) $(dlobj) $(extobj) $(libs) - -libperl.rlb: libperl.a - $(ranlib) libperl.a - touch libperl.rlb - -libperl.a: $& perl.o $(obj) - ar rcuv libperl.a $(obj) - -# This version, if specified in Configure, does ONLY those scripts which need -# set-id emulation. Suidperl must be setuid root. It contains the "taint" -# checks as well as the special code to validate that the script in question -# has been invoked correctly. - -suidperl: $& sperl.o perlmain.o libperl.rlb - $(CC) $(LARGE) $(CLDFLAGS) sperl.o perlmain.o libperl.a $(libs) -o suidperl - -lib/Config.pm: config.sh miniperl - ./miniperl configpm - -saber: $(saber) - # load $(saber) - # load /lib/libm.a - -sperl.o: perl.c perly.h patchlevel.h $(h) - $(RMS) sperl.c - $(LNS) perl.c sperl.c - $(CCCMD) -DIAMSUID sperl.c - $(RMS) sperl.c - -perly.h: perly.c - @ echo Dummy dependency for dumb parallel make - touch perly.h - -opcode.h: opcode.pl - - perl opcode.pl - -embed.h: embed_h.SH global.sym interp.sym - sh embed_h.SH - -perly.c: - @ echo 'Expect' 80 shift/reduce and 62 reduce/reduce conflicts - $(BYACC) -d perly.y - sh $(shellflags) ./perly.fixer y.tab.c perly.c - mv y.tab.h perly.h - echo 'extern YYSTYPE yylval;' >>perly.h - -perly.o: perly.c perly.h $(h) - $(CCCMD) perly.c - -install: all - ./perl installperl - -clean: - rm -f *.o all perl miniperl - rm -f POSIX.c ?DBM_File.c perlmain.c - rm -f ext/dbm/sdbm/libsdbm.a - cd ext/dbm/sdbm; $(MAKE) -f Makefile clean - cd x2p; $(MAKE) clean - -realclean: clean - cd x2p; $(MAKE) realclean - cd ext/dbm/sdbm; $(MAKE) -f Makefile realclean - rm -f *.orig */*.orig *~ */*~ core $(addedbyconf) h2ph h2ph.man - rm -f Makefile cflags embed_h makedepend makedir writemain - rm -f config.h t/perl makefile makefile.old cflags - rm -rf lib/auto/?DBM_File lib/auto/POSIX - rm -f x2p/Makefile x2p/makefile x2p/makefile.old x2p/cflags - rm -f lib/Config.pm - rm -f c2ph pstruct - -# The following lint has practically everything turned on. Unfortunately, -# you have to wade through a lot of mumbo jumbo that can't be suppressed. -# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message -# for that spot. - -lint: perly.c $(c) - lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz - -depend: makedepend - - test -f perly.h || cp /dev/null perly.h - ./makedepend - - test -s perly.h || /bin/rm -f perly.h - cd x2p; $(MAKE) depend - -test: perl lib/Config.pm - - cd t && chmod +x TEST */*.t - - cd t && (rm -f perl; $(LNS) ../perl perl) && ./perl TEST </dev/tty - -clist: $(c) - echo $(c) | tr ' ' '\012' >.clist - -hlist: $(h) - echo $(h) | tr ' ' '\012' >.hlist - -shlist: $(sh) - echo $(sh) | tr ' ' '\012' >.shlist - -# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE -# If this runs make out of memory, delete /usr/include lines. -av.o: /usr/include/ctype.h -av.o: /usr/include/dirent.h -av.o: /usr/include/errno.h -av.o: /usr/include/machine/param.h -av.o: /usr/include/machine/setjmp.h -av.o: /usr/include/netinet/in.h -av.o: /usr/include/setjmp.h -av.o: /usr/include/stdio.h -av.o: /usr/include/sys/dirent.h -av.o: /usr/include/sys/errno.h -av.o: /usr/include/sys/filio.h -av.o: /usr/include/sys/ioccom.h -av.o: /usr/include/sys/ioctl.h -av.o: /usr/include/sys/param.h -av.o: /usr/include/sys/signal.h -av.o: /usr/include/sys/sockio.h -av.o: /usr/include/sys/stat.h -av.o: /usr/include/sys/stdtypes.h -av.o: /usr/include/sys/sysmacros.h -av.o: /usr/include/sys/time.h -av.o: /usr/include/sys/times.h -av.o: /usr/include/sys/ttold.h -av.o: /usr/include/sys/ttychars.h -av.o: /usr/include/sys/ttycom.h -av.o: /usr/include/sys/ttydev.h -av.o: /usr/include/sys/types.h -av.o: /usr/include/time.h -av.o: /usr/include/varargs.h -av.o: /usr/include/vm/faultcode.h -av.o: EXTERN.h -av.o: av.c -av.o: av.h -av.o: config.h -av.o: cop.h -av.o: cv.h -av.o: embed.h -av.o: form.h -av.o: gv.h -av.o: handy.h -av.o: hv.h -av.o: mg.h -av.o: op.h -av.o: opcode.h -av.o: perl.h -av.o: pp.h -av.o: proto.h -av.o: regexp.h -av.o: scope.h -av.o: sv.h -av.o: unixish.h -av.o: util.h -scope.o: /usr/include/ctype.h -scope.o: /usr/include/dirent.h -scope.o: /usr/include/errno.h -scope.o: /usr/include/machine/param.h -scope.o: /usr/include/machine/setjmp.h -scope.o: /usr/include/netinet/in.h -scope.o: /usr/include/setjmp.h -scope.o: /usr/include/stdio.h -scope.o: /usr/include/sys/dirent.h -scope.o: /usr/include/sys/errno.h -scope.o: /usr/include/sys/filio.h -scope.o: /usr/include/sys/ioccom.h -scope.o: /usr/include/sys/ioctl.h -scope.o: /usr/include/sys/param.h -scope.o: /usr/include/sys/signal.h -scope.o: /usr/include/sys/sockio.h -scope.o: /usr/include/sys/stat.h -scope.o: /usr/include/sys/stdtypes.h -scope.o: /usr/include/sys/sysmacros.h -scope.o: /usr/include/sys/time.h -scope.o: /usr/include/sys/times.h -scope.o: /usr/include/sys/ttold.h -scope.o: /usr/include/sys/ttychars.h -scope.o: /usr/include/sys/ttycom.h -scope.o: /usr/include/sys/ttydev.h -scope.o: /usr/include/sys/types.h -scope.o: /usr/include/time.h -scope.o: /usr/include/varargs.h -scope.o: /usr/include/vm/faultcode.h -scope.o: EXTERN.h -scope.o: av.h -scope.o: config.h -scope.o: cop.h -scope.o: cv.h -scope.o: embed.h -scope.o: form.h -scope.o: gv.h -scope.o: handy.h -scope.o: hv.h -scope.o: mg.h -scope.o: op.h -scope.o: opcode.h -scope.o: perl.h -scope.o: pp.h -scope.o: proto.h -scope.o: regexp.h -scope.o: scope.c -scope.o: scope.h -scope.o: sv.h -scope.o: unixish.h -scope.o: util.h -op.o: /usr/include/ctype.h -op.o: /usr/include/dirent.h -op.o: /usr/include/errno.h -op.o: /usr/include/machine/param.h -op.o: /usr/include/machine/setjmp.h -op.o: /usr/include/netinet/in.h -op.o: /usr/include/setjmp.h -op.o: /usr/include/stdio.h -op.o: /usr/include/sys/dirent.h -op.o: /usr/include/sys/errno.h -op.o: /usr/include/sys/filio.h -op.o: /usr/include/sys/ioccom.h -op.o: /usr/include/sys/ioctl.h -op.o: /usr/include/sys/param.h -op.o: /usr/include/sys/signal.h -op.o: /usr/include/sys/sockio.h -op.o: /usr/include/sys/stat.h -op.o: /usr/include/sys/stdtypes.h -op.o: /usr/include/sys/sysmacros.h -op.o: /usr/include/sys/time.h -op.o: /usr/include/sys/times.h -op.o: /usr/include/sys/ttold.h -op.o: /usr/include/sys/ttychars.h -op.o: /usr/include/sys/ttycom.h -op.o: /usr/include/sys/ttydev.h -op.o: /usr/include/sys/types.h -op.o: /usr/include/time.h -op.o: /usr/include/varargs.h -op.o: /usr/include/vm/faultcode.h -op.o: EXTERN.h -op.o: av.h -op.o: config.h -op.o: cop.h -op.o: cv.h -op.o: embed.h -op.o: form.h -op.o: gv.h -op.o: handy.h -op.o: hv.h -op.o: mg.h -op.o: op.c -op.o: op.h -op.o: opcode.h -op.o: perl.h -op.o: pp.h -op.o: proto.h -op.o: regexp.h -op.o: scope.h -op.o: sv.h -op.o: unixish.h -op.o: util.h -doop.o: /usr/include/ctype.h -doop.o: /usr/include/dirent.h -doop.o: /usr/include/errno.h -doop.o: /usr/include/machine/param.h -doop.o: /usr/include/machine/setjmp.h -doop.o: /usr/include/netinet/in.h -doop.o: /usr/include/setjmp.h -doop.o: /usr/include/stdio.h -doop.o: /usr/include/sys/dirent.h -doop.o: /usr/include/sys/errno.h -doop.o: /usr/include/sys/filio.h -doop.o: /usr/include/sys/ioccom.h -doop.o: /usr/include/sys/ioctl.h -doop.o: /usr/include/sys/param.h -doop.o: /usr/include/sys/signal.h -doop.o: /usr/include/sys/sockio.h -doop.o: /usr/include/sys/stat.h -doop.o: /usr/include/sys/stdtypes.h -doop.o: /usr/include/sys/sysmacros.h -doop.o: /usr/include/sys/time.h -doop.o: /usr/include/sys/times.h -doop.o: /usr/include/sys/ttold.h -doop.o: /usr/include/sys/ttychars.h -doop.o: /usr/include/sys/ttycom.h -doop.o: /usr/include/sys/ttydev.h -doop.o: /usr/include/sys/types.h -doop.o: /usr/include/time.h -doop.o: /usr/include/varargs.h -doop.o: /usr/include/vm/faultcode.h -doop.o: EXTERN.h -doop.o: av.h -doop.o: config.h -doop.o: cop.h -doop.o: cv.h -doop.o: doop.c -doop.o: embed.h -doop.o: form.h -doop.o: gv.h -doop.o: handy.h -doop.o: hv.h -doop.o: mg.h -doop.o: op.h -doop.o: opcode.h -doop.o: perl.h -doop.o: pp.h -doop.o: proto.h -doop.o: regexp.h -doop.o: scope.h -doop.o: sv.h -doop.o: unixish.h -doop.o: util.h -doio.o: /usr/include/ctype.h -doio.o: /usr/include/debug/debug.h -doio.o: /usr/include/dirent.h -doio.o: /usr/include/errno.h -doio.o: /usr/include/machine/mmu.h -doio.o: /usr/include/machine/param.h -doio.o: /usr/include/machine/setjmp.h -doio.o: /usr/include/mon/obpdefs.h -doio.o: /usr/include/mon/openprom.h -doio.o: /usr/include/mon/sunromvec.h -doio.o: /usr/include/netinet/in.h -doio.o: /usr/include/setjmp.h -doio.o: /usr/include/stdio.h -doio.o: /usr/include/sys/dirent.h -doio.o: /usr/include/sys/errno.h -doio.o: /usr/include/sys/fcntlcom.h -doio.o: /usr/include/sys/file.h -doio.o: /usr/include/sys/filio.h -doio.o: /usr/include/sys/ioccom.h -doio.o: /usr/include/sys/ioctl.h -doio.o: /usr/include/sys/ipc.h -doio.o: /usr/include/sys/msg.h -doio.o: /usr/include/sys/param.h -doio.o: /usr/include/sys/sem.h -doio.o: /usr/include/sys/shm.h -doio.o: /usr/include/sys/signal.h -doio.o: /usr/include/sys/sockio.h -doio.o: /usr/include/sys/stat.h -doio.o: /usr/include/sys/stdtypes.h -doio.o: /usr/include/sys/sysmacros.h -doio.o: /usr/include/sys/time.h -doio.o: /usr/include/sys/times.h -doio.o: /usr/include/sys/ttold.h -doio.o: /usr/include/sys/ttychars.h -doio.o: /usr/include/sys/ttycom.h -doio.o: /usr/include/sys/ttydev.h -doio.o: /usr/include/sys/types.h -doio.o: /usr/include/time.h -doio.o: /usr/include/utime.h -doio.o: /usr/include/varargs.h -doio.o: /usr/include/vm/faultcode.h -doio.o: EXTERN.h -doio.o: av.h -doio.o: config.h -doio.o: cop.h -doio.o: cv.h -doio.o: doio.c -doio.o: embed.h -doio.o: form.h -doio.o: gv.h -doio.o: handy.h -doio.o: hv.h -doio.o: mg.h -doio.o: op.h -doio.o: opcode.h -doio.o: perl.h -doio.o: pp.h -doio.o: proto.h -doio.o: regexp.h -doio.o: scope.h -doio.o: sv.h -doio.o: unixish.h -doio.o: util.h -dump.o: /usr/include/ctype.h -dump.o: /usr/include/dirent.h -dump.o: /usr/include/errno.h -dump.o: /usr/include/machine/param.h -dump.o: /usr/include/machine/setjmp.h -dump.o: /usr/include/netinet/in.h -dump.o: /usr/include/setjmp.h -dump.o: /usr/include/stdio.h -dump.o: /usr/include/sys/dirent.h -dump.o: /usr/include/sys/errno.h -dump.o: /usr/include/sys/filio.h -dump.o: /usr/include/sys/ioccom.h -dump.o: /usr/include/sys/ioctl.h -dump.o: /usr/include/sys/param.h -dump.o: /usr/include/sys/signal.h -dump.o: /usr/include/sys/sockio.h -dump.o: /usr/include/sys/stat.h -dump.o: /usr/include/sys/stdtypes.h -dump.o: /usr/include/sys/sysmacros.h -dump.o: /usr/include/sys/time.h -dump.o: /usr/include/sys/times.h -dump.o: /usr/include/sys/ttold.h -dump.o: /usr/include/sys/ttychars.h -dump.o: /usr/include/sys/ttycom.h -dump.o: /usr/include/sys/ttydev.h -dump.o: /usr/include/sys/types.h -dump.o: /usr/include/time.h -dump.o: /usr/include/varargs.h -dump.o: /usr/include/vm/faultcode.h -dump.o: EXTERN.h -dump.o: av.h -dump.o: config.h -dump.o: cop.h -dump.o: cv.h -dump.o: dump.c -dump.o: embed.h -dump.o: form.h -dump.o: gv.h -dump.o: handy.h -dump.o: hv.h -dump.o: mg.h -dump.o: op.h -dump.o: opcode.h -dump.o: perl.h -dump.o: pp.h -dump.o: proto.h -dump.o: regexp.h -dump.o: scope.h -dump.o: sv.h -dump.o: unixish.h -dump.o: util.h -hv.o: /usr/include/ctype.h -hv.o: /usr/include/dirent.h -hv.o: /usr/include/errno.h -hv.o: /usr/include/machine/param.h -hv.o: /usr/include/machine/setjmp.h -hv.o: /usr/include/netinet/in.h -hv.o: /usr/include/setjmp.h -hv.o: /usr/include/stdio.h -hv.o: /usr/include/sys/dirent.h -hv.o: /usr/include/sys/errno.h -hv.o: /usr/include/sys/filio.h -hv.o: /usr/include/sys/ioccom.h -hv.o: /usr/include/sys/ioctl.h -hv.o: /usr/include/sys/param.h -hv.o: /usr/include/sys/signal.h -hv.o: /usr/include/sys/sockio.h -hv.o: /usr/include/sys/stat.h -hv.o: /usr/include/sys/stdtypes.h -hv.o: /usr/include/sys/sysmacros.h -hv.o: /usr/include/sys/time.h -hv.o: /usr/include/sys/times.h -hv.o: /usr/include/sys/ttold.h -hv.o: /usr/include/sys/ttychars.h -hv.o: /usr/include/sys/ttycom.h -hv.o: /usr/include/sys/ttydev.h -hv.o: /usr/include/sys/types.h -hv.o: /usr/include/time.h -hv.o: /usr/include/varargs.h -hv.o: /usr/include/vm/faultcode.h -hv.o: EXTERN.h -hv.o: av.h -hv.o: config.h -hv.o: cop.h -hv.o: cv.h -hv.o: embed.h -hv.o: form.h -hv.o: gv.h -hv.o: handy.h -hv.o: hv.c -hv.o: hv.h -hv.o: mg.h -hv.o: op.h -hv.o: opcode.h -hv.o: perl.h -hv.o: pp.h -hv.o: proto.h -hv.o: regexp.h -hv.o: scope.h -hv.o: sv.h -hv.o: unixish.h -hv.o: util.h -malloc.o: /usr/include/ctype.h -malloc.o: /usr/include/dirent.h -malloc.o: /usr/include/errno.h -malloc.o: /usr/include/machine/param.h -malloc.o: /usr/include/machine/setjmp.h -malloc.o: /usr/include/netinet/in.h -malloc.o: /usr/include/setjmp.h -malloc.o: /usr/include/stdio.h -malloc.o: /usr/include/sys/dirent.h -malloc.o: /usr/include/sys/errno.h -malloc.o: /usr/include/sys/filio.h -malloc.o: /usr/include/sys/ioccom.h -malloc.o: /usr/include/sys/ioctl.h -malloc.o: /usr/include/sys/param.h -malloc.o: /usr/include/sys/signal.h -malloc.o: /usr/include/sys/sockio.h -malloc.o: /usr/include/sys/stat.h -malloc.o: /usr/include/sys/stdtypes.h -malloc.o: /usr/include/sys/sysmacros.h -malloc.o: /usr/include/sys/time.h -malloc.o: /usr/include/sys/times.h -malloc.o: /usr/include/sys/ttold.h -malloc.o: /usr/include/sys/ttychars.h -malloc.o: /usr/include/sys/ttycom.h -malloc.o: /usr/include/sys/ttydev.h -malloc.o: /usr/include/sys/types.h -malloc.o: /usr/include/time.h -malloc.o: /usr/include/varargs.h -malloc.o: /usr/include/vm/faultcode.h -malloc.o: EXTERN.h -malloc.o: av.h -malloc.o: config.h -malloc.o: cop.h -malloc.o: cv.h -malloc.o: embed.h -malloc.o: form.h -malloc.o: gv.h -malloc.o: handy.h -malloc.o: hv.h -malloc.o: malloc.c -malloc.o: mg.h -malloc.o: op.h -malloc.o: opcode.h -malloc.o: perl.h -malloc.o: pp.h -malloc.o: proto.h -malloc.o: regexp.h -malloc.o: scope.h -malloc.o: sv.h -malloc.o: unixish.h -malloc.o: util.h -mg.o: /usr/include/ctype.h -mg.o: /usr/include/dirent.h -mg.o: /usr/include/errno.h -mg.o: /usr/include/machine/param.h -mg.o: /usr/include/machine/setjmp.h -mg.o: /usr/include/netinet/in.h -mg.o: /usr/include/setjmp.h -mg.o: /usr/include/stdio.h -mg.o: /usr/include/sys/dirent.h -mg.o: /usr/include/sys/errno.h -mg.o: /usr/include/sys/filio.h -mg.o: /usr/include/sys/ioccom.h -mg.o: /usr/include/sys/ioctl.h -mg.o: /usr/include/sys/param.h -mg.o: /usr/include/sys/signal.h -mg.o: /usr/include/sys/sockio.h -mg.o: /usr/include/sys/stat.h -mg.o: /usr/include/sys/stdtypes.h -mg.o: /usr/include/sys/sysmacros.h -mg.o: /usr/include/sys/time.h -mg.o: /usr/include/sys/times.h -mg.o: /usr/include/sys/ttold.h -mg.o: /usr/include/sys/ttychars.h -mg.o: /usr/include/sys/ttycom.h -mg.o: /usr/include/sys/ttydev.h -mg.o: /usr/include/sys/types.h -mg.o: /usr/include/time.h -mg.o: /usr/include/varargs.h -mg.o: /usr/include/vm/faultcode.h -mg.o: EXTERN.h -mg.o: av.h -mg.o: config.h -mg.o: cop.h -mg.o: cv.h -mg.o: embed.h -mg.o: form.h -mg.o: gv.h -mg.o: handy.h -mg.o: hv.h -mg.o: mg.c -mg.o: mg.h -mg.o: op.h -mg.o: opcode.h -mg.o: perl.h -mg.o: pp.h -mg.o: proto.h -mg.o: regexp.h -mg.o: scope.h -mg.o: sv.h -mg.o: unixish.h -mg.o: util.h -perly.o: /usr/include/ctype.h -perly.o: /usr/include/dirent.h -perly.o: /usr/include/errno.h -perly.o: /usr/include/machine/param.h -perly.o: /usr/include/machine/setjmp.h -perly.o: /usr/include/netinet/in.h -perly.o: /usr/include/setjmp.h -perly.o: /usr/include/stdio.h -perly.o: /usr/include/sys/dirent.h -perly.o: /usr/include/sys/errno.h -perly.o: /usr/include/sys/filio.h -perly.o: /usr/include/sys/ioccom.h -perly.o: /usr/include/sys/ioctl.h -perly.o: /usr/include/sys/param.h -perly.o: /usr/include/sys/signal.h -perly.o: /usr/include/sys/sockio.h -perly.o: /usr/include/sys/stat.h -perly.o: /usr/include/sys/stdtypes.h -perly.o: /usr/include/sys/sysmacros.h -perly.o: /usr/include/sys/time.h -perly.o: /usr/include/sys/times.h -perly.o: /usr/include/sys/ttold.h -perly.o: /usr/include/sys/ttychars.h -perly.o: /usr/include/sys/ttycom.h -perly.o: /usr/include/sys/ttydev.h -perly.o: /usr/include/sys/types.h -perly.o: /usr/include/time.h -perly.o: /usr/include/varargs.h -perly.o: /usr/include/vm/faultcode.h -perly.o: EXTERN.h -perly.o: av.h -perly.o: config.h -perly.o: cop.h -perly.o: cv.h -perly.o: embed.h -perly.o: form.h -perly.o: gv.h -perly.o: handy.h -perly.o: hv.h -perly.o: mg.h -perly.o: op.h -perly.o: opcode.h -perly.o: perl.h -perly.o: perly.c -perly.o: pp.h -perly.o: proto.h -perly.o: regexp.h -perly.o: scope.h -perly.o: sv.h -perly.o: unixish.h -perly.o: util.h -pp.o: /usr/include/ctype.h -pp.o: /usr/include/dirent.h -pp.o: /usr/include/errno.h -pp.o: /usr/include/grp.h -pp.o: /usr/include/machine/param.h -pp.o: /usr/include/machine/setjmp.h -pp.o: /usr/include/netdb.h -pp.o: /usr/include/netinet/in.h -pp.o: /usr/include/pwd.h -pp.o: /usr/include/setjmp.h -pp.o: /usr/include/stdio.h -pp.o: /usr/include/sys/dirent.h -pp.o: /usr/include/sys/errno.h -pp.o: /usr/include/sys/fcntlcom.h -pp.o: /usr/include/sys/file.h -pp.o: /usr/include/sys/filio.h -pp.o: /usr/include/sys/ioccom.h -pp.o: /usr/include/sys/ioctl.h -pp.o: /usr/include/sys/param.h -pp.o: /usr/include/sys/signal.h -pp.o: /usr/include/sys/socket.h -pp.o: /usr/include/sys/sockio.h -pp.o: /usr/include/sys/stat.h -pp.o: /usr/include/sys/stdtypes.h -pp.o: /usr/include/sys/sysmacros.h -pp.o: /usr/include/sys/time.h -pp.o: /usr/include/sys/times.h -pp.o: /usr/include/sys/ttold.h -pp.o: /usr/include/sys/ttychars.h -pp.o: /usr/include/sys/ttycom.h -pp.o: /usr/include/sys/ttydev.h -pp.o: /usr/include/sys/types.h -pp.o: /usr/include/time.h -pp.o: /usr/include/utime.h -pp.o: /usr/include/varargs.h -pp.o: /usr/include/vm/faultcode.h -pp.o: EXTERN.h -pp.o: av.h -pp.o: config.h -pp.o: cop.h -pp.o: cv.h -pp.o: embed.h -pp.o: form.h -pp.o: gv.h -pp.o: handy.h -pp.o: hv.h -pp.o: mg.h -pp.o: op.h -pp.o: opcode.h -pp.o: perl.h -pp.o: pp.c -pp.o: pp.h -pp.o: proto.h -pp.o: regexp.h -pp.o: scope.h -pp.o: sv.h -pp.o: unixish.h -pp.o: util.h -regcomp.o: /usr/include/ctype.h -regcomp.o: /usr/include/dirent.h -regcomp.o: /usr/include/errno.h -regcomp.o: /usr/include/machine/param.h -regcomp.o: /usr/include/machine/setjmp.h -regcomp.o: /usr/include/netinet/in.h -regcomp.o: /usr/include/setjmp.h -regcomp.o: /usr/include/stdio.h -regcomp.o: /usr/include/sys/dirent.h -regcomp.o: /usr/include/sys/errno.h -regcomp.o: /usr/include/sys/filio.h -regcomp.o: /usr/include/sys/ioccom.h -regcomp.o: /usr/include/sys/ioctl.h -regcomp.o: /usr/include/sys/param.h -regcomp.o: /usr/include/sys/signal.h -regcomp.o: /usr/include/sys/sockio.h -regcomp.o: /usr/include/sys/stat.h -regcomp.o: /usr/include/sys/stdtypes.h -regcomp.o: /usr/include/sys/sysmacros.h -regcomp.o: /usr/include/sys/time.h -regcomp.o: /usr/include/sys/times.h -regcomp.o: /usr/include/sys/ttold.h -regcomp.o: /usr/include/sys/ttychars.h -regcomp.o: /usr/include/sys/ttycom.h -regcomp.o: /usr/include/sys/ttydev.h -regcomp.o: /usr/include/sys/types.h -regcomp.o: /usr/include/time.h -regcomp.o: /usr/include/varargs.h -regcomp.o: /usr/include/vm/faultcode.h -regcomp.o: EXTERN.h -regcomp.o: INTERN.h -regcomp.o: av.h -regcomp.o: config.h -regcomp.o: cop.h -regcomp.o: cv.h -regcomp.o: embed.h -regcomp.o: form.h -regcomp.o: gv.h -regcomp.o: handy.h -regcomp.o: hv.h -regcomp.o: mg.h -regcomp.o: op.h -regcomp.o: opcode.h -regcomp.o: perl.h -regcomp.o: pp.h -regcomp.o: proto.h -regcomp.o: regcomp.c -regcomp.o: regcomp.h -regcomp.o: regexp.h -regcomp.o: scope.h -regcomp.o: sv.h -regcomp.o: unixish.h -regcomp.o: util.h -regexec.o: /usr/include/ctype.h -regexec.o: /usr/include/dirent.h -regexec.o: /usr/include/errno.h -regexec.o: /usr/include/machine/param.h -regexec.o: /usr/include/machine/setjmp.h -regexec.o: /usr/include/netinet/in.h -regexec.o: /usr/include/setjmp.h -regexec.o: /usr/include/stdio.h -regexec.o: /usr/include/sys/dirent.h -regexec.o: /usr/include/sys/errno.h -regexec.o: /usr/include/sys/filio.h -regexec.o: /usr/include/sys/ioccom.h -regexec.o: /usr/include/sys/ioctl.h -regexec.o: /usr/include/sys/param.h -regexec.o: /usr/include/sys/signal.h -regexec.o: /usr/include/sys/sockio.h -regexec.o: /usr/include/sys/stat.h -regexec.o: /usr/include/sys/stdtypes.h -regexec.o: /usr/include/sys/sysmacros.h -regexec.o: /usr/include/sys/time.h -regexec.o: /usr/include/sys/times.h -regexec.o: /usr/include/sys/ttold.h -regexec.o: /usr/include/sys/ttychars.h -regexec.o: /usr/include/sys/ttycom.h -regexec.o: /usr/include/sys/ttydev.h -regexec.o: /usr/include/sys/types.h -regexec.o: /usr/include/time.h -regexec.o: /usr/include/varargs.h -regexec.o: /usr/include/vm/faultcode.h -regexec.o: EXTERN.h -regexec.o: av.h -regexec.o: config.h -regexec.o: cop.h -regexec.o: cv.h -regexec.o: embed.h -regexec.o: form.h -regexec.o: gv.h -regexec.o: handy.h -regexec.o: hv.h -regexec.o: mg.h -regexec.o: op.h -regexec.o: opcode.h -regexec.o: perl.h -regexec.o: pp.h -regexec.o: proto.h -regexec.o: regcomp.h -regexec.o: regexec.c -regexec.o: regexp.h -regexec.o: scope.h -regexec.o: sv.h -regexec.o: unixish.h -regexec.o: util.h -gv.o: /usr/include/ctype.h -gv.o: /usr/include/dirent.h -gv.o: /usr/include/errno.h -gv.o: /usr/include/machine/param.h -gv.o: /usr/include/machine/setjmp.h -gv.o: /usr/include/netinet/in.h -gv.o: /usr/include/setjmp.h -gv.o: /usr/include/stdio.h -gv.o: /usr/include/sys/dirent.h -gv.o: /usr/include/sys/errno.h -gv.o: /usr/include/sys/filio.h -gv.o: /usr/include/sys/ioccom.h -gv.o: /usr/include/sys/ioctl.h -gv.o: /usr/include/sys/param.h -gv.o: /usr/include/sys/signal.h -gv.o: /usr/include/sys/sockio.h -gv.o: /usr/include/sys/stat.h -gv.o: /usr/include/sys/stdtypes.h -gv.o: /usr/include/sys/sysmacros.h -gv.o: /usr/include/sys/time.h -gv.o: /usr/include/sys/times.h -gv.o: /usr/include/sys/ttold.h -gv.o: /usr/include/sys/ttychars.h -gv.o: /usr/include/sys/ttycom.h -gv.o: /usr/include/sys/ttydev.h -gv.o: /usr/include/sys/types.h -gv.o: /usr/include/time.h -gv.o: /usr/include/varargs.h -gv.o: /usr/include/vm/faultcode.h -gv.o: EXTERN.h -gv.o: av.h -gv.o: config.h -gv.o: cop.h -gv.o: cv.h -gv.o: embed.h -gv.o: form.h -gv.o: gv.c -gv.o: gv.h -gv.o: handy.h -gv.o: hv.h -gv.o: mg.h -gv.o: op.h -gv.o: opcode.h -gv.o: perl.h -gv.o: pp.h -gv.o: proto.h -gv.o: regexp.h -gv.o: scope.h -gv.o: sv.h -gv.o: unixish.h -gv.o: util.h -sv.o: /usr/include/ctype.h -sv.o: /usr/include/dirent.h -sv.o: /usr/include/errno.h -sv.o: /usr/include/machine/param.h -sv.o: /usr/include/machine/setjmp.h -sv.o: /usr/include/netinet/in.h -sv.o: /usr/include/setjmp.h -sv.o: /usr/include/stdio.h -sv.o: /usr/include/sys/dirent.h -sv.o: /usr/include/sys/errno.h -sv.o: /usr/include/sys/filio.h -sv.o: /usr/include/sys/ioccom.h -sv.o: /usr/include/sys/ioctl.h -sv.o: /usr/include/sys/param.h -sv.o: /usr/include/sys/signal.h -sv.o: /usr/include/sys/sockio.h -sv.o: /usr/include/sys/stat.h -sv.o: /usr/include/sys/stdtypes.h -sv.o: /usr/include/sys/sysmacros.h -sv.o: /usr/include/sys/time.h -sv.o: /usr/include/sys/times.h -sv.o: /usr/include/sys/ttold.h -sv.o: /usr/include/sys/ttychars.h -sv.o: /usr/include/sys/ttycom.h -sv.o: /usr/include/sys/ttydev.h -sv.o: /usr/include/sys/types.h -sv.o: /usr/include/time.h -sv.o: /usr/include/varargs.h -sv.o: /usr/include/vm/faultcode.h -sv.o: EXTERN.h -sv.o: av.h -sv.o: config.h -sv.o: cop.h -sv.o: cv.h -sv.o: embed.h -sv.o: form.h -sv.o: gv.h -sv.o: handy.h -sv.o: hv.h -sv.o: mg.h -sv.o: op.h -sv.o: opcode.h -sv.o: perl.h -sv.o: perly.h -sv.o: pp.h -sv.o: proto.h -sv.o: regexp.h -sv.o: scope.h -sv.o: sv.c -sv.o: sv.h -sv.o: unixish.h -sv.o: util.h -taint.o: /usr/include/ctype.h -taint.o: /usr/include/dirent.h -taint.o: /usr/include/errno.h -taint.o: /usr/include/machine/param.h -taint.o: /usr/include/machine/setjmp.h -taint.o: /usr/include/netinet/in.h -taint.o: /usr/include/setjmp.h -taint.o: /usr/include/stdio.h -taint.o: /usr/include/sys/dirent.h -taint.o: /usr/include/sys/errno.h -taint.o: /usr/include/sys/filio.h -taint.o: /usr/include/sys/ioccom.h -taint.o: /usr/include/sys/ioctl.h -taint.o: /usr/include/sys/param.h -taint.o: /usr/include/sys/signal.h -taint.o: /usr/include/sys/sockio.h -taint.o: /usr/include/sys/stat.h -taint.o: /usr/include/sys/stdtypes.h -taint.o: /usr/include/sys/sysmacros.h -taint.o: /usr/include/sys/time.h -taint.o: /usr/include/sys/times.h -taint.o: /usr/include/sys/ttold.h -taint.o: /usr/include/sys/ttychars.h -taint.o: /usr/include/sys/ttycom.h -taint.o: /usr/include/sys/ttydev.h -taint.o: /usr/include/sys/types.h -taint.o: /usr/include/time.h -taint.o: /usr/include/varargs.h -taint.o: /usr/include/vm/faultcode.h -taint.o: EXTERN.h -taint.o: av.h -taint.o: config.h -taint.o: cop.h -taint.o: cv.h -taint.o: embed.h -taint.o: form.h -taint.o: gv.h -taint.o: handy.h -taint.o: hv.h -taint.o: mg.h -taint.o: op.h -taint.o: opcode.h -taint.o: perl.h -taint.o: pp.h -taint.o: proto.h -taint.o: regexp.h -taint.o: scope.h -taint.o: sv.h -taint.o: taint.c -taint.o: unixish.h -taint.o: util.h -toke.o: /usr/include/ctype.h -toke.o: /usr/include/dirent.h -toke.o: /usr/include/errno.h -toke.o: /usr/include/machine/param.h -toke.o: /usr/include/machine/setjmp.h -toke.o: /usr/include/netinet/in.h -toke.o: /usr/include/setjmp.h -toke.o: /usr/include/stdio.h -toke.o: /usr/include/sys/dirent.h -toke.o: /usr/include/sys/errno.h -toke.o: /usr/include/sys/fcntlcom.h -toke.o: /usr/include/sys/file.h -toke.o: /usr/include/sys/filio.h -toke.o: /usr/include/sys/ioccom.h -toke.o: /usr/include/sys/ioctl.h -toke.o: /usr/include/sys/param.h -toke.o: /usr/include/sys/signal.h -toke.o: /usr/include/sys/sockio.h -toke.o: /usr/include/sys/stat.h -toke.o: /usr/include/sys/stdtypes.h -toke.o: /usr/include/sys/sysmacros.h -toke.o: /usr/include/sys/time.h -toke.o: /usr/include/sys/times.h -toke.o: /usr/include/sys/ttold.h -toke.o: /usr/include/sys/ttychars.h -toke.o: /usr/include/sys/ttycom.h -toke.o: /usr/include/sys/ttydev.h -toke.o: /usr/include/sys/types.h -toke.o: /usr/include/time.h -toke.o: /usr/include/varargs.h -toke.o: /usr/include/vm/faultcode.h -toke.o: EXTERN.h -toke.o: av.h -toke.o: config.h -toke.o: cop.h -toke.o: cv.h -toke.o: embed.h -toke.o: form.h -toke.o: gv.h -toke.o: handy.h -toke.o: hv.h -toke.o: keywords.h -toke.o: mg.h -toke.o: op.h -toke.o: opcode.h -toke.o: perl.h -toke.o: perly.h -toke.o: pp.h -toke.o: proto.h -toke.o: regexp.h -toke.o: scope.h -toke.o: sv.h -toke.o: toke.c -toke.o: unixish.h -toke.o: util.h -util.o: /usr/include/ctype.h -util.o: /usr/include/dirent.h -util.o: /usr/include/errno.h -util.o: /usr/include/machine/param.h -util.o: /usr/include/machine/setjmp.h -util.o: /usr/include/netinet/in.h -util.o: /usr/include/setjmp.h -util.o: /usr/include/stdio.h -util.o: /usr/include/sys/dirent.h -util.o: /usr/include/sys/errno.h -util.o: /usr/include/sys/fcntlcom.h -util.o: /usr/include/sys/file.h -util.o: /usr/include/sys/filio.h -util.o: /usr/include/sys/ioccom.h -util.o: /usr/include/sys/ioctl.h -util.o: /usr/include/sys/param.h -util.o: /usr/include/sys/signal.h -util.o: /usr/include/sys/sockio.h -util.o: /usr/include/sys/stat.h -util.o: /usr/include/sys/stdtypes.h -util.o: /usr/include/sys/sysmacros.h -util.o: /usr/include/sys/time.h -util.o: /usr/include/sys/times.h -util.o: /usr/include/sys/ttold.h -util.o: /usr/include/sys/ttychars.h -util.o: /usr/include/sys/ttycom.h -util.o: /usr/include/sys/ttydev.h -util.o: /usr/include/sys/types.h -util.o: /usr/include/time.h -util.o: /usr/include/unistd.h -util.o: /usr/include/varargs.h -util.o: /usr/include/vm/faultcode.h -util.o: EXTERN.h -util.o: av.h -util.o: config.h -util.o: cop.h -util.o: cv.h -util.o: embed.h -util.o: form.h -util.o: gv.h -util.o: handy.h -util.o: hv.h -util.o: mg.h -util.o: op.h -util.o: opcode.h -util.o: perl.h -util.o: pp.h -util.o: proto.h -util.o: regexp.h -util.o: scope.h -util.o: sv.h -util.o: unixish.h -util.o: util.c -util.o: util.h -deb.o: /usr/include/ctype.h -deb.o: /usr/include/dirent.h -deb.o: /usr/include/errno.h -deb.o: /usr/include/machine/param.h -deb.o: /usr/include/machine/setjmp.h -deb.o: /usr/include/netinet/in.h -deb.o: /usr/include/setjmp.h -deb.o: /usr/include/stdio.h -deb.o: /usr/include/sys/dirent.h -deb.o: /usr/include/sys/errno.h -deb.o: /usr/include/sys/filio.h -deb.o: /usr/include/sys/ioccom.h -deb.o: /usr/include/sys/ioctl.h -deb.o: /usr/include/sys/param.h -deb.o: /usr/include/sys/signal.h -deb.o: /usr/include/sys/sockio.h -deb.o: /usr/include/sys/stat.h -deb.o: /usr/include/sys/stdtypes.h -deb.o: /usr/include/sys/sysmacros.h -deb.o: /usr/include/sys/time.h -deb.o: /usr/include/sys/times.h -deb.o: /usr/include/sys/ttold.h -deb.o: /usr/include/sys/ttychars.h -deb.o: /usr/include/sys/ttycom.h -deb.o: /usr/include/sys/ttydev.h -deb.o: /usr/include/sys/types.h -deb.o: /usr/include/time.h -deb.o: /usr/include/varargs.h -deb.o: /usr/include/vm/faultcode.h -deb.o: EXTERN.h -deb.o: av.h -deb.o: config.h -deb.o: cop.h -deb.o: cv.h -deb.o: deb.c -deb.o: embed.h -deb.o: form.h -deb.o: gv.h -deb.o: handy.h -deb.o: hv.h -deb.o: mg.h -deb.o: op.h -deb.o: opcode.h -deb.o: perl.h -deb.o: pp.h -deb.o: proto.h -deb.o: regexp.h -deb.o: scope.h -deb.o: sv.h -deb.o: unixish.h -deb.o: util.h -run.o: /usr/include/ctype.h -run.o: /usr/include/dirent.h -run.o: /usr/include/errno.h -run.o: /usr/include/machine/param.h -run.o: /usr/include/machine/setjmp.h -run.o: /usr/include/netinet/in.h -run.o: /usr/include/setjmp.h -run.o: /usr/include/stdio.h -run.o: /usr/include/sys/dirent.h -run.o: /usr/include/sys/errno.h -run.o: /usr/include/sys/filio.h -run.o: /usr/include/sys/ioccom.h -run.o: /usr/include/sys/ioctl.h -run.o: /usr/include/sys/param.h -run.o: /usr/include/sys/signal.h -run.o: /usr/include/sys/sockio.h -run.o: /usr/include/sys/stat.h -run.o: /usr/include/sys/stdtypes.h -run.o: /usr/include/sys/sysmacros.h -run.o: /usr/include/sys/time.h -run.o: /usr/include/sys/times.h -run.o: /usr/include/sys/ttold.h -run.o: /usr/include/sys/ttychars.h -run.o: /usr/include/sys/ttycom.h -run.o: /usr/include/sys/ttydev.h -run.o: /usr/include/sys/types.h -run.o: /usr/include/time.h -run.o: /usr/include/varargs.h -run.o: /usr/include/vm/faultcode.h -run.o: EXTERN.h -run.o: av.h -run.o: config.h -run.o: cop.h -run.o: cv.h -run.o: embed.h -run.o: form.h -run.o: gv.h -run.o: handy.h -run.o: hv.h -run.o: mg.h -run.o: op.h -run.o: opcode.h -run.o: perl.h -run.o: pp.h -run.o: proto.h -run.o: regexp.h -run.o: run.c -run.o: scope.h -run.o: sv.h -run.o: unixish.h -run.o: util.h -dl_sunos.o: /usr/include/ctype.h -dl_sunos.o: /usr/include/dirent.h -dl_sunos.o: /usr/include/dlfcn.h -dl_sunos.o: /usr/include/errno.h -dl_sunos.o: /usr/include/machine/param.h -dl_sunos.o: /usr/include/machine/setjmp.h -dl_sunos.o: /usr/include/netinet/in.h -dl_sunos.o: /usr/include/setjmp.h -dl_sunos.o: /usr/include/stdio.h -dl_sunos.o: /usr/include/sys/dirent.h -dl_sunos.o: /usr/include/sys/errno.h -dl_sunos.o: /usr/include/sys/filio.h -dl_sunos.o: /usr/include/sys/ioccom.h -dl_sunos.o: /usr/include/sys/ioctl.h -dl_sunos.o: /usr/include/sys/param.h -dl_sunos.o: /usr/include/sys/signal.h -dl_sunos.o: /usr/include/sys/sockio.h -dl_sunos.o: /usr/include/sys/stat.h -dl_sunos.o: /usr/include/sys/stdtypes.h -dl_sunos.o: /usr/include/sys/sysmacros.h -dl_sunos.o: /usr/include/sys/time.h -dl_sunos.o: /usr/include/sys/times.h -dl_sunos.o: /usr/include/sys/ttold.h -dl_sunos.o: /usr/include/sys/ttychars.h -dl_sunos.o: /usr/include/sys/ttycom.h -dl_sunos.o: /usr/include/sys/ttydev.h -dl_sunos.o: /usr/include/sys/types.h -dl_sunos.o: /usr/include/time.h -dl_sunos.o: /usr/include/varargs.h -dl_sunos.o: /usr/include/vm/faultcode.h -dl_sunos.o: EXTERN.h -dl_sunos.o: XSUB.h -dl_sunos.o: av.h -dl_sunos.o: config.h -dl_sunos.o: cop.h -dl_sunos.o: cv.h -dl_sunos.o: dl_sunos.c -dl_sunos.o: embed.h -dl_sunos.o: form.h -dl_sunos.o: gv.h -dl_sunos.o: handy.h -dl_sunos.o: hv.h -dl_sunos.o: mg.h -dl_sunos.o: op.h -dl_sunos.o: opcode.h -dl_sunos.o: perl.h -dl_sunos.o: pp.h -dl_sunos.o: proto.h -dl_sunos.o: regexp.h -dl_sunos.o: scope.h -dl_sunos.o: sv.h -dl_sunos.o: unixish.h -dl_sunos.o: util.h -miniperlmain.o: /usr/include/ctype.h -miniperlmain.o: /usr/include/dirent.h -miniperlmain.o: /usr/include/errno.h -miniperlmain.o: /usr/include/machine/param.h -miniperlmain.o: /usr/include/machine/setjmp.h -miniperlmain.o: /usr/include/netinet/in.h -miniperlmain.o: /usr/include/setjmp.h -miniperlmain.o: /usr/include/stdio.h -miniperlmain.o: /usr/include/sys/dirent.h -miniperlmain.o: /usr/include/sys/errno.h -miniperlmain.o: /usr/include/sys/filio.h -miniperlmain.o: /usr/include/sys/ioccom.h -miniperlmain.o: /usr/include/sys/ioctl.h -miniperlmain.o: /usr/include/sys/param.h -miniperlmain.o: /usr/include/sys/signal.h -miniperlmain.o: /usr/include/sys/sockio.h -miniperlmain.o: /usr/include/sys/stat.h -miniperlmain.o: /usr/include/sys/stdtypes.h -miniperlmain.o: /usr/include/sys/sysmacros.h -miniperlmain.o: /usr/include/sys/time.h -miniperlmain.o: /usr/include/sys/times.h -miniperlmain.o: /usr/include/sys/ttold.h -miniperlmain.o: /usr/include/sys/ttychars.h -miniperlmain.o: /usr/include/sys/ttycom.h -miniperlmain.o: /usr/include/sys/ttydev.h -miniperlmain.o: /usr/include/sys/types.h -miniperlmain.o: /usr/include/time.h -miniperlmain.o: /usr/include/varargs.h -miniperlmain.o: /usr/include/vm/faultcode.h -miniperlmain.o: INTERN.h -miniperlmain.o: av.h -miniperlmain.o: config.h -miniperlmain.o: cop.h -miniperlmain.o: cv.h -miniperlmain.o: embed.h -miniperlmain.o: form.h -miniperlmain.o: gv.h -miniperlmain.o: handy.h -miniperlmain.o: hv.h -miniperlmain.o: mg.h -miniperlmain.o: miniperlmain.c -miniperlmain.o: op.h -miniperlmain.o: opcode.h -miniperlmain.o: perl.h -miniperlmain.o: pp.h -miniperlmain.o: proto.h -miniperlmain.o: regexp.h -miniperlmain.o: scope.h -miniperlmain.o: sv.h -miniperlmain.o: unixish.h -miniperlmain.o: util.h -perlmain.o: /usr/include/ctype.h -perlmain.o: /usr/include/dirent.h -perlmain.o: /usr/include/errno.h -perlmain.o: /usr/include/machine/param.h -perlmain.o: /usr/include/machine/setjmp.h -perlmain.o: /usr/include/netinet/in.h -perlmain.o: /usr/include/setjmp.h -perlmain.o: /usr/include/stdio.h -perlmain.o: /usr/include/sys/dirent.h -perlmain.o: /usr/include/sys/errno.h -perlmain.o: /usr/include/sys/filio.h -perlmain.o: /usr/include/sys/ioccom.h -perlmain.o: /usr/include/sys/ioctl.h -perlmain.o: /usr/include/sys/param.h -perlmain.o: /usr/include/sys/signal.h -perlmain.o: /usr/include/sys/sockio.h -perlmain.o: /usr/include/sys/stat.h -perlmain.o: /usr/include/sys/stdtypes.h -perlmain.o: /usr/include/sys/sysmacros.h -perlmain.o: /usr/include/sys/time.h -perlmain.o: /usr/include/sys/times.h -perlmain.o: /usr/include/sys/ttold.h -perlmain.o: /usr/include/sys/ttychars.h -perlmain.o: /usr/include/sys/ttycom.h -perlmain.o: /usr/include/sys/ttydev.h -perlmain.o: /usr/include/sys/types.h -perlmain.o: /usr/include/time.h -perlmain.o: /usr/include/varargs.h -perlmain.o: /usr/include/vm/faultcode.h -perlmain.o: INTERN.h -perlmain.o: av.h -perlmain.o: config.h -perlmain.o: cop.h -perlmain.o: cv.h -perlmain.o: embed.h -perlmain.o: form.h -perlmain.o: gv.h -perlmain.o: handy.h -perlmain.o: hv.h -perlmain.o: mg.h -perlmain.o: op.h -perlmain.o: opcode.h -perlmain.o: perl.h -perlmain.o: perlmain.c -perlmain.o: pp.h -perlmain.o: proto.h -perlmain.o: regexp.h -perlmain.o: scope.h -perlmain.o: sv.h -perlmain.o: unixish.h -perlmain.o: util.h -Makefile: Makefile.SH config.sh ; /bin/sh Makefile.SH -cflags: cflags.SH config.sh ; /bin/sh cflags.SH -embed_h: embed_h.SH config.sh ; /bin/sh embed_h.SH -makedepend: makedepend.SH config.sh ; /bin/sh makedepend.SH -makedir: makedir.SH config.sh ; /bin/sh makedir.SH -writemain: writemain.SH config.sh ; /bin/sh writemain.SH -# WARNING: Put nothing here or make depend will gobble it up! @@ -1,31 +1,8 @@ -/* $RCSfile: malloc.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:25 $ +/* malloc.c * - * $Log: malloc.c,v $ - * Revision 4.1 92/08/07 18:24:25 lwall - * - * Revision 4.0.1.4 92/06/08 14:28:38 lwall - * patch20: removed implicit int declarations on functions - * patch20: hash tables now split only if the memory is available to do so - * patch20: realloc(0, size) now does malloc in case library routines call it - * - * Revision 4.0.1.3 91/11/05 17:57:40 lwall - * patch11: safe malloc code now integrated into Perl's malloc when possible - * - * Revision 4.0.1.2 91/06/07 11:20:45 lwall - * patch4: many, many itty-bitty portability fixes - * - * Revision 4.0.1.1 91/04/11 17:48:31 lwall - * patch1: Configure now figures out malloc ptr type - * - * Revision 4.0 91/03/20 01:28:52 lwall - * 4.0 baseline. - * */ #ifndef lint -/*SUPPRESS 592*/ -static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; - #ifdef DEBUGGING #define RCHECK #endif @@ -44,9 +21,6 @@ static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; #include "EXTERN.h" #include "perl.h" -static int findbucket(); -static int morecore(); - /* I don't much care whether these are defined in sys/types.h--LAW */ #define u_char unsigned char @@ -81,6 +55,12 @@ union overhead { #define ov_rmagic ovu.ovu_rmagic }; +#ifdef debug +static void botch _((char *s)); +#endif +static void morecore _((int bucket)); +static int findbucket _((union overhead *freep, int srchlen)); + #define MAGIC 0xff /* magic # on accounting info */ #define RMAGIC 0x55555555 /* magic # on range info */ #ifdef RCHECK @@ -176,21 +156,15 @@ malloc(nbytes) } #ifdef safemalloc -#if !(defined(I286) || defined(atarist)) - DEBUG_m(fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",p+1,an++,(long)size)); -#else - DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",p+1,an++,(long)size)); -#endif + DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n", + (unsigned long)(p+1),an++,(long)size)); #endif /* safemalloc */ /* remove from linked list */ #ifdef RCHECK if (*((int*)p) & (sizeof(union overhead) - 1)) -#if !(defined(I286) || defined(atarist)) - fprintf(stderr,"Corrupt malloc ptr 0x%x at 0x%x\n",*((int*)p),p); -#else - fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",*((int*)p),p); -#endif + fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n", + (unsigned long)*((int*)p),(unsigned long)p); #endif nextf[bucket] = p->ov_next; p->ov_magic = MAGIC; @@ -214,7 +188,7 @@ malloc(nbytes) /* * Allocate more memory to the indicated bucket. */ -static +static void morecore(bucket) register int bucket; { @@ -288,11 +262,7 @@ free(mp) char *cp = (char*)mp; #ifdef safemalloc -#if !(defined(I286) || defined(atarist)) - DEBUG_m(fprintf(stderr,"0x%x: (%05d) free\n",cp,an++)); -#else - DEBUG_m(fprintf(stderr,"0x%lx: (%05d) free\n",cp,an++)); -#endif + DEBUG_m(fprintf(stderr,"0x%lx: (%05d) free\n",(unsigned long)cp,an++)); #endif /* safemalloc */ if (cp == NULL) @@ -425,17 +395,11 @@ realloc(mp, nbytes) #ifdef safemalloc #ifdef DEBUGGING -# if !(defined(I286) || defined(atarist)) - if (debug & 128) { - fprintf(stderr,"0x%x: (%05d) rfree\n",res,an++); - fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",res,an++,(long)size); - } -# else - if (debug & 128) { - fprintf(stderr,"0x%lx: (%05d) rfree\n",res,an++); - fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",res,an++,(long)size); - } -# endif + if (debug & 128) { + fprintf(stderr,"0x%lx: (%05d) rfree\n",(unsigned long)res,an++); + fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n", + (unsigned long)res,an++,(long)size); + } #endif #endif /* safemalloc */ return ((Malloc_t)res); @@ -1,16 +1,26 @@ -/* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:21:48 $ +/* mg.c * - * Copyright (c) 1993, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: hash.c,v $ + */ + +/* + * "Sam sat on the ground and put his head in his hands. 'I wish I had never + * come here, and I don't want to see no more magic,' he said, and fell silent." */ #include "EXTERN.h" #include "perl.h" +/* Omit -- it causes too much grief on mixed systems. +#ifdef I_UNISTD +# include <unistd.h> +#endif +*/ + void mg_magical(sv) SV* sv; @@ -19,7 +29,7 @@ SV* sv; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl) { - if (vtbl->svt_get) + if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) SvGMAGICAL_on(sv); if (vtbl->svt_set) SvSMAGICAL_on(sv); @@ -34,20 +44,28 @@ mg_get(sv) SV* sv; { MAGIC* mg; - U32 savemagic = SvMAGICAL(sv); + U32 savemagic = SvMAGICAL(sv) | SvREADONLY(sv); + assert(SvGMAGICAL(sv)); SvMAGICAL_off(sv); + SvREADONLY_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; - if (vtbl && vtbl->svt_get) + if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { (*vtbl->svt_get)(sv, mg); + if (mg->mg_flags & MGf_GSKIP) + savemagic = 0; + } } - SvFLAGS(sv) |= savemagic; - assert(SvGMAGICAL(sv)); - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); + if (savemagic) + SvFLAGS(sv) |= savemagic; + else + mg_magical(sv); + if (SvGMAGICAL(sv)) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); return 0; } @@ -65,12 +83,19 @@ SV* sv; for (mg = SvMAGIC(sv); mg; mg = nextmg) { MGVTBL* vtbl = mg->mg_virtual; nextmg = mg->mg_moremagic; /* it may delete itself */ + if (mg->mg_flags & MGf_GSKIP) { + mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ + savemagic = 0; + } if (vtbl && vtbl->svt_set) (*vtbl->svt_set)(sv, mg); } if (SvMAGIC(sv)) { - SvFLAGS(sv) |= savemagic; + if (savemagic) + SvFLAGS(sv) |= savemagic; + else + mg_magical(sv); if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); } @@ -94,6 +119,7 @@ SV* sv; SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv)&(SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + /* omit MGf_GSKIP -- not changed here */ len = (*vtbl->svt_len)(sv, mg); SvFLAGS(sv) |= savemagic; @@ -120,6 +146,8 @@ SV* sv; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; + /* omit GSKIP -- never set here */ + if (vtbl && vtbl->svt_clear) (*vtbl->svt_clear)(sv, mg); } @@ -132,13 +160,9 @@ SV* sv; } MAGIC* -#ifndef STANDARD_C mg_find(sv, type) SV* sv; -char type; -#else -mg_find(SV *sv, char type) -#endif /* STANDARD_C */ +int type; { MAGIC* mg; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { @@ -159,7 +183,7 @@ STRLEN klen; MAGIC* mg; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (isUPPER(mg->mg_type)) { - sv_magic(nsv, mg->mg_obj, tolower(mg->mg_type), key, klen); + sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen); count++; } } @@ -222,6 +246,8 @@ MAGIC *mg; case '+': if (curpm) { paren = curpm->op_pmregexp->lastparen; + if (!paren) + return 0; goto getparen; } break; @@ -278,6 +304,9 @@ MAGIC *mg; case '\006': /* ^F */ sv_setiv(sv,(I32)maxsysfd); break; + case '\010': /* ^H */ + sv_setiv(sv,(I32)hints); + break; case '\t': /* ^I */ if (inplace) sv_setpv(sv, inplace); @@ -300,7 +329,8 @@ MAGIC *mg; getparen: if (curpm->op_pmregexp && paren <= curpm->op_pmregexp->nparens && - (s = curpm->op_pmregexp->startp[paren]) ) { + (s = curpm->op_pmregexp->startp[paren]) && + curpm->op_pmregexp->endp[paren] ) { i = curpm->op_pmregexp->endp[paren] - s; if (i >= 0) sv_setpvn(sv,s,i); @@ -314,7 +344,10 @@ MAGIC *mg; case '+': if (curpm) { paren = curpm->op_pmregexp->lastparen; - goto getparen; + if (paren) + goto getparen; + else + sv_setsv(sv,&sv_undef); } break; case '`': @@ -343,7 +376,7 @@ MAGIC *mg; break; case '.': #ifndef lint - if (last_in_gv && GvIO(last_in_gv)) { + if (GvIO(last_in_gv)) { sv_setiv(sv,(I32)IoLINES(GvIO(last_in_gv))); } #endif @@ -352,7 +385,7 @@ MAGIC *mg; sv_setiv(sv,(I32)statusvalue); break; case '^': - s = IoTOP_NAME(GvIO(defoutgv)); + s = IoTOP_NAME(GvIOp(defoutgv)); if (s) sv_setpv(sv,s); else { @@ -361,20 +394,20 @@ MAGIC *mg; } break; case '~': - s = IoFMT_NAME(GvIO(defoutgv)); + s = IoFMT_NAME(GvIOp(defoutgv)); if (!s) s = GvENAME(defoutgv); sv_setpv(sv,s); break; #ifndef lint case '=': - sv_setiv(sv,(I32)IoPAGE_LEN(GvIO(defoutgv))); + sv_setiv(sv,(I32)IoPAGE_LEN(GvIOp(defoutgv))); break; case '-': - sv_setiv(sv,(I32)IoLINES_LEFT(GvIO(defoutgv))); + sv_setiv(sv,(I32)IoLINES_LEFT(GvIOp(defoutgv))); break; case '%': - sv_setiv(sv,(I32)IoPAGE(GvIO(defoutgv))); + sv_setiv(sv,(I32)IoPAGE(GvIOp(defoutgv))); break; #endif case ':': @@ -382,12 +415,10 @@ MAGIC *mg; case '/': break; case '[': - sv_setiv(sv,(I32)arybase); + sv_setiv(sv,(I32)curcop->cop_arybase); break; case '|': - if (!GvIO(defoutgv)) - GvIO(defoutgv) = newIO(); - sv_setiv(sv, (IoFLAGS(GvIO(defoutgv)) & IOf_FLUSH) != 0 ); + sv_setiv(sv, (IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 ); break; case ',': sv_setpvn(sv,ofs,ofslen); @@ -423,7 +454,7 @@ MAGIC *mg; #define NGROUPS 32 #endif { - GROUPSTYPE gary[NGROUPS]; + Groups_t gary[NGROUPS]; i = getgroups(NGROUPS,gary); while (--i >= 0) { @@ -439,6 +470,7 @@ MAGIC *mg; case '0': break; } + return 0; } int @@ -459,20 +491,30 @@ SV* sv; MAGIC* mg; { register char *s; - U32 i; - s = SvPV(sv,na); + 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 = SvEND(sv); + char *strend = s + len; while (s < strend) { s = cpytill(tokenbuf,s,strend,':',&i); s++; if (*tokenbuf != '/' - || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) ) + || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) ) MgTAINTEDDIR_on(mg); } } @@ -496,10 +538,15 @@ MAGIC* mg; { register char *s; I32 i; - s = SvPV(sv,na); + i = whichsig(mg->mg_ptr); /* ...no, a brick */ if (!i && (dowarn || strEQ(mg->mg_ptr,"ALARM"))) warn("No such signal: SIG%s", mg->mg_ptr); + if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { + (void)signal(i,sighandler); + return 0; + } + s = SvPV_force(sv,na); if (strEQ(s,"IGNORE")) #ifndef lint (void)signal(i,SIG_IGN); @@ -527,49 +574,55 @@ MAGIC* mg; return 0; } +#ifdef OVERLOAD + int -magic_getpack(sv,mg) +magic_setamagic(sv,mg) SV* sv; MAGIC* mg; { - SV* rv = mg->mg_obj; - HV* stash = SvSTASH(SvRV(rv)); - GV* gv = gv_fetchmethod(stash, "fetch"); - dSP; - BINOP myop; + /* HV_badAMAGIC_on(Sv_STASH(sv)); */ + amagic_generation++; - if (!gv || !GvCV(gv)) { - croak("No fetch method for magical variable in package \"%s\"", - HvNAME(stash)); - } - Zero(&myop, 1, BINOP); - myop.op_last = (OP *) &myop; - myop.op_next = Nullop; - myop.op_flags = OPf_STACKED; + return 0; +} +#endif /* OVERLOAD */ - ENTER; - SAVESPTR(op); - op = (OP *) &myop; - PUTBACK; - pp_pushmark(); +static int +magic_methpack(sv,mg,meth) +SV* sv; +MAGIC* mg; +char *meth; +{ + dSP; - EXTEND(sp, 4); - PUSHs(gv); - PUSHs(rv); + ENTER; + SAVETMPS; + PUSHMARK(sp); + EXTEND(sp, 2); + PUSHs(mg->mg_obj); if (mg->mg_ptr) - PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len))); - else if (mg->mg_len >= 0) - PUSHs(sv_mortalcopy(newSViv(mg->mg_len))); + PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len))); + else if (mg->mg_type == 'p') + PUSHs(sv_2mortal(newSViv(mg->mg_len))); PUTBACK; - if (op = pp_entersubr()) - run(); - LEAVE; - SPAGAIN; + if (perl_call_method(meth, G_SCALAR)) + sv_setsv(sv, *stack_sp--); - sv_setsv(sv, POPs); - PUTBACK; + FREETMPS; + LEAVE; + return 0; +} +int +magic_getpack(sv,mg) +SV* sv; +MAGIC* mg; +{ + magic_methpack(sv,mg,"FETCH"); + if (mg->mg_ptr) + mg->mg_flags |= MGf_GSKIP; return 0; } @@ -578,44 +631,19 @@ magic_setpack(sv,mg) SV* sv; MAGIC* mg; { - SV* rv = mg->mg_obj; - HV* stash = SvSTASH(SvRV(rv)); - GV* gv = gv_fetchmethod(stash, "store"); dSP; - BINOP myop; - - if (!gv || !GvCV(gv)) { - croak("No store method for magical variable in package \"%s\"", - HvNAME(stash)); - } - Zero(&myop, 1, BINOP); - myop.op_last = (OP *) &myop; - myop.op_next = Nullop; - myop.op_flags = OPf_STACKED; - - ENTER; - SAVESPTR(op); - op = (OP *) &myop; - PUTBACK; - pp_pushmark(); - EXTEND(sp, 4); - PUSHs(gv); - PUSHs(rv); + PUSHMARK(sp); + EXTEND(sp, 3); + PUSHs(mg->mg_obj); if (mg->mg_ptr) - PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len))); - else if (mg->mg_len >= 0) - PUSHs(sv_mortalcopy(newSViv(mg->mg_len))); + 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); PUTBACK; - if (op = pp_entersubr()) - run(); - LEAVE; - SPAGAIN; - - POPs; - PUTBACK; + perl_call_method("STORE", G_SCALAR|G_DISCARD); return 0; } @@ -625,43 +653,20 @@ magic_clearpack(sv,mg) SV* sv; MAGIC* mg; { - SV* rv = mg->mg_obj; - HV* stash = SvSTASH(SvRV(rv)); - GV* gv = gv_fetchmethod(stash, "delete"); - dSP; - BINOP myop; + return magic_methpack(sv,mg,"DELETE"); +} - if (!gv || !GvCV(gv)) { - croak("No delete method for magical variable in package \"%s\"", - HvNAME(stash)); - } - Zero(&myop, 1, BINOP); - myop.op_last = (OP *) &myop; - myop.op_next = Nullop; - myop.op_flags = OPf_STACKED; +int magic_wipepack(sv,mg) +SV* sv; +MAGIC* mg; +{ + dSP; - ENTER; - SAVESPTR(op); - op = (OP *) &myop; + PUSHMARK(sp); + XPUSHs(mg->mg_obj); PUTBACK; - pp_pushmark(); - EXTEND(sp, 4); - PUSHs(gv); - PUSHs(rv); - if (mg->mg_ptr) - PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len))); - else - PUSHs(sv_mortalcopy(newSViv(mg->mg_len))); - PUTBACK; - - if (op = pp_entersubr()) - run(); - LEAVE; - SPAGAIN; - - sv_setsv(sv, POPs); - PUTBACK; + perl_call_method("CLEAR", G_SCALAR|G_DISCARD); return 0; } @@ -672,46 +677,35 @@ SV* sv; MAGIC* mg; SV* key; { - SV* rv = mg->mg_obj; - HV* stash = SvSTASH(SvRV(rv)); - GV* gv = gv_fetchmethod(stash, SvOK(key) ? "nextkey" : "firstkey"); dSP; - BINOP myop; - - if (!gv || !GvCV(gv)) { - croak("No fetch method for magical variable in package \"%s\"", - HvNAME(stash)); - } - Zero(&myop, 1, BINOP); - myop.op_last = (OP *) &myop; - myop.op_next = Nullop; - myop.op_flags = OPf_STACKED; + char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; ENTER; - SAVESPTR(op); - op = (OP *) &myop; - PUTBACK; - pp_pushmark(); - - EXTEND(sp, 4); - PUSHs(gv); - PUSHs(rv); + SAVETMPS; + PUSHMARK(sp); + EXTEND(sp, 2); + PUSHs(mg->mg_obj); if (SvOK(key)) PUSHs(key); PUTBACK; - if (op = pp_entersubr()) - run(); - LEAVE; - SPAGAIN; - - sv_setsv(key, POPs); - PUTBACK; + if (perl_call_method(meth, G_SCALAR)) + sv_setsv(key, *stack_sp--); + FREETMPS; + LEAVE; return 0; } int +magic_existspack(sv,mg) +SV* sv; +MAGIC* mg; +{ + return magic_methpack(sv,mg,"EXISTS"); +} + +int magic_setdbline(sv,mg) SV* sv; MAGIC* mg; @@ -736,7 +730,7 @@ magic_getarylen(sv,mg) SV* sv; MAGIC* mg; { - sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + arybase); + sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase); return 0; } @@ -745,7 +739,63 @@ magic_setarylen(sv,mg) SV* sv; MAGIC* mg; { - av_fill((AV*)mg->mg_obj, (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) - arybase); + av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase); + return 0; +} + +int +magic_getpos(sv,mg) +SV* sv; +MAGIC* mg; +{ + SV* lsv = LvTARG(sv); + + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { + mg = mg_find(lsv, 'g'); + if (mg && mg->mg_len >= 0) { + sv_setiv(sv, mg->mg_len + curcop->cop_arybase); + return 0; + } + } + (void)SvOK_off(sv); + return 0; +} + +int +magic_setpos(sv,mg) +SV* sv; +MAGIC* mg; +{ + SV* lsv = LvTARG(sv); + SSize_t pos; + STRLEN len; + + mg = 0; + + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) + mg = mg_find(lsv, 'g'); + if (!mg) { + if (!SvOK(sv)) + return 0; + sv_magic(lsv, (SV*)0, 'g', Nullch, 0); + mg = mg_find(lsv, 'g'); + } + else if (!SvOK(sv)) { + mg->mg_len = -1; + return 0; + } + len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv); + + pos = SvIV(sv) - curcop->cop_arybase; + if (pos < 0) { + pos += len; + if (pos < 0) + pos = 0; + } + else if (pos > len) + pos = len; + mg->mg_len = pos; + return 0; } @@ -781,8 +831,8 @@ MAGIC* mg; gv_AVadd(gv); if (!GvHV(gv)) gv_HVadd(gv); - if (!GvIO(gv)) - GvIO(gv) = newIO(); + if (!GvIOp(gv)) + GvIOp(gv) = newIO(); return 0; } @@ -811,8 +861,11 @@ magic_settaint(sv,mg) SV* sv; MAGIC* mg; { - if (!tainted) + if (!tainted) { + if (!SvMAGICAL(sv)) + SvMAGICAL_on(sv); sv_unmagic(sv, 't'); + } return 0; } @@ -830,8 +883,7 @@ magic_setmglob(sv,mg) SV* sv; MAGIC* mg; { - mg->mg_ptr = 0; - mg->mg_len = 0; + mg->mg_len = -1; return 0; } @@ -873,11 +925,14 @@ MAGIC* mg; case '\006': /* ^F */ maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; + case '\010': /* ^H */ + hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + break; case '\t': /* ^I */ if (inplace) Safefree(inplace); if (SvOK(sv)) - inplace = savestr(SvPV(sv,na)); + inplace = savepv(SvPV(sv,na)); else inplace = Nullch; break; @@ -901,35 +956,33 @@ MAGIC* mg; if (localizing) save_sptr((SV**)&last_in_gv); else if (SvOK(sv)) - IoLINES(GvIO(last_in_gv)) = (long)SvIV(sv); + IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv); break; case '^': - Safefree(IoTOP_NAME(GvIO(defoutgv))); - IoTOP_NAME(GvIO(defoutgv)) = s = savestr(SvPV(sv,na)); - IoTOP_GV(GvIO(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); + Safefree(IoTOP_NAME(GvIOp(defoutgv))); + IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na)); + IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); break; case '~': - Safefree(IoFMT_NAME(GvIO(defoutgv))); - IoFMT_NAME(GvIO(defoutgv)) = s = savestr(SvPV(sv,na)); - IoFMT_GV(GvIO(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); + Safefree(IoFMT_NAME(GvIOp(defoutgv))); + IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na)); + IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); break; case '=': - IoPAGE_LEN(GvIO(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); + IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '-': - IoLINES_LEFT(GvIO(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); - if (IoLINES_LEFT(GvIO(defoutgv)) < 0L) - IoLINES_LEFT(GvIO(defoutgv)) = 0L; + IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); + if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L) + IoLINES_LEFT(GvIOp(defoutgv)) = 0L; break; case '%': - IoPAGE(GvIO(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); + IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '|': - if (!GvIO(defoutgv)) - GvIO(defoutgv) = newIO(); - IoFLAGS(GvIO(defoutgv)) &= ~IOf_FLUSH; + IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH; if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) { - IoFLAGS(GvIO(defoutgv)) |= IOf_FLUSH; + IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH; } break; case '*': @@ -937,8 +990,8 @@ MAGIC* mg; multiline = (i != 0); break; case '/': - if (SvPOK(sv)) { - nrs = rs = SvPV(sv,rslen); + if (SvOK(sv)) { + nrs = rs = SvPV_force(sv,rslen); nrslen = rslen; if (rspara = !rslen) { nrs = rs = "\n\n"; @@ -954,20 +1007,20 @@ MAGIC* mg; case '\\': if (ors) Safefree(ors); - ors = savestr(SvPV(sv,orslen)); + ors = savepv(SvPV(sv,orslen)); break; case ',': if (ofs) Safefree(ofs); - ofs = savestr(SvPV(sv, ofslen)); + ofs = savepv(SvPV(sv, ofslen)); break; case '#': if (ofmt) Safefree(ofmt); - ofmt = savestr(SvPV(sv,na)); + ofmt = savepv(SvPV(sv,na)); break; case '[': - arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; case '?': statusvalue = U_S(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); @@ -991,8 +1044,10 @@ MAGIC* mg; #else if (uid == euid) /* special case $< = $> */ (void)setuid(uid); - else + else { + uid = (I32)getuid(); croak("setruid() not implemented"); + } #endif #endif #endif @@ -1016,8 +1071,10 @@ MAGIC* mg; #else if (euid == uid) /* special case $> = $< */ setuid(euid); - else + else { + euid = (I32)geteuid(); croak("seteuid() not implemented"); + } #endif #endif #endif @@ -1075,7 +1132,7 @@ MAGIC* mg; tainting |= (euid != uid || egid != gid); break; case ':': - chopset = SvPV(sv,na); + chopset = SvPV_force(sv,na); break; case '0': if (!origalen) { @@ -1095,7 +1152,7 @@ MAGIC* mg; } origalen = s - origargv[0]; } - s = SvPV(sv,len); + s = SvPV_force(sv,len); i = len; if (i >= origalen) { i = origalen; @@ -1140,36 +1197,34 @@ char *sig; VOIDRET sighandler(sig) -I32 sig; +int sig; { dSP; GV *gv; + HV *st; SV *sv; CV *cv; - CONTEXT *cx; AV *oldstack; - I32 hasargs = 1; - I32 items = 1; - I32 gimme = G_SCALAR; #ifdef OS2 /* or anybody else who requires SIG_ACK */ signal(sig, SIG_ACK); #endif - gv = gv_fetchpv( - SvPVx(*hv_fetch(GvHVn(siggv),sig_name[sig],strlen(sig_name[sig]), - TRUE), na), TRUE, SVt_PVCV); - cv = GvCV(gv); - if (!cv && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) { + cv = sv_2cv(*hv_fetch(GvHVn(siggv),sig_name[sig],strlen(sig_name[sig]), + TRUE), + &st, &gv, TRUE); + if (!cv || !CvROOT(cv) && + *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) { + if (sig_name[sig][1] == 'H') - gv = gv_fetchpv(SvPVx(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE), na), - TRUE, SVt_PVCV); + cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE), + &st, &gv, TRUE); else - gv = gv_fetchpv(SvPVx(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE), na), - TRUE, SVt_PVCV); - cv = GvCV(gv); /* gag */ + cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE), + &st, &gv, TRUE); + /* gag */ } - if (!cv) { + if (!cv || !CvROOT(cv)) { if (dowarn) warn("SIG%s handler \"%s\" not defined.\n", sig_name[sig], GvENAME(gv) ); @@ -1177,34 +1232,19 @@ I32 sig; } oldstack = stack; + if (stack != signalstack) + AvFILL(signalstack) = 0; SWITCHSTACK(stack, signalstack); sv = sv_newmortal(); sv_setpv(sv,sig_name[sig]); + PUSHMARK(sp); PUSHs(sv); - - ENTER; - SAVETMPS; - - push_return(op); - push_return(0); - PUSHBLOCK(cx, CXt_SUB, sp); - PUSHSUB(cx); - cx->blk_sub.savearray = GvAV(defgv); - cx->blk_sub.argarray = av_fake(items, sp); - SAVEFREESV(cx->blk_sub.argarray); - GvAV(defgv) = cx->blk_sub.argarray; - CvDEPTH(cv)++; - if (CvDEPTH(cv) >= 2) { - if (CvDEPTH(cv) == 100 && dowarn) - warn("Deep recursion on subroutine \"%s\"",GvENAME(gv)); - } - op = CvSTART(cv); PUTBACK; - run(); /* Does the LEAVE for us. */ + + perl_call_sv((SV*)cv, G_DISCARD); SWITCHSTACK(signalstack, oldstack); - op = pop_return(); return; } @@ -1,19 +1,18 @@ -/* $RCSfile: arg.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:16 $ +/* mg.h * - * Copyright (c) 1993, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: arg.h,v $ */ struct mgvtbl { - int (*svt_get) P((SV *sv, MAGIC* mg)); - int (*svt_set) P((SV *sv, MAGIC* mg)); - U32 (*svt_len) P((SV *sv, MAGIC* mg)); - int (*svt_clear) P((SV *sv, MAGIC* mg)); - int (*svt_free) P((SV *sv, MAGIC* mg)); + int (*svt_get) _((SV *sv, MAGIC* mg)); + int (*svt_set) _((SV *sv, MAGIC* mg)); + U32 (*svt_len) _((SV *sv, MAGIC* mg)); + int (*svt_clear) _((SV *sv, MAGIC* mg)); + int (*svt_free) _((SV *sv, MAGIC* mg)); }; struct magic { @@ -29,5 +28,6 @@ struct magic { #define MGf_TAINTEDDIR 1 #define MGf_REFCOUNTED 2 +#define MGf_GSKIP 4 #define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR) #define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR) diff --git a/miniperlmain.c b/miniperlmain.c index 0e1b0f990e..44c3d71874 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -1,26 +1,42 @@ +/* + * "The Road goes ever on and on, down from the door where it began." + */ + #include "INTERN.h" #include "perl.h" +static void xs_init _((void)); +static PerlInterpreter *my_perl; + +/* This value may be raised by extensions for testing purposes */ +int perl_destruct_level = 0; /* 0=none, 1=full, 2=full with checks */ + +int main(argc, argv, env) int argc; char **argv; char **env; { int exitstatus; - PerlInterpreter *my_perl; - my_perl = perl_alloc(); - if (!my_perl) - exit(1); - perl_construct( my_perl ); +#ifdef VMS + getredirection(&argc,&argv); +#endif + + if (!do_undump) { + my_perl = perl_alloc(); + if (!my_perl) + exit(1); + perl_construct( my_perl ); + } - exitstatus = perl_parse( my_perl, argc, argv, env ); + exitstatus = perl_parse( my_perl, xs_init, argc, argv, env ); if (exitstatus) exit( exitstatus ); exitstatus = perl_run( my_perl ); - perl_destruct( my_perl ); + perl_destruct( my_perl, perl_destruct_level ); perl_free( my_perl ); exit( exitstatus ); @@ -28,9 +44,8 @@ char **env; /* Register any extra external extensions */ -void -perl_init_ext() +static void +xs_init() { - char *file = __FILE__; /* Do not delete this line--writemain depends on it */ } diff --git a/miniperlmain.x b/miniperlmain.x deleted file mode 100644 index e69de29bb2..0000000000 --- a/miniperlmain.x +++ /dev/null diff --git a/msdos/Changes.dds b/msdos/Changes.dds deleted file mode 100644 index 1eed759cf9..0000000000 --- a/msdos/Changes.dds +++ /dev/null @@ -1,57 +0,0 @@ -These are the changes done by the `patches' file: - -[These patches have been applied, more or less, so I don't supply the -patches file--law] - -Compilation of some portions is done conditional on the definition -of the following symbols: - -BINARY Enables the usage of setmode under MSDOS (added binmode command) -BUGGY_MSC Adds #pragma_function(memset) to avoid internal compiler error -CHOWN Enables chown -CHROOT Enables chroot -FORK Enables fork and changes the compilation of system -GETLOGIN Enables getlogin -GETPPID Enables getppid -GROUP Enables all the group access functions -KILL Enables kill -LINK Enables link -PASSWD Enables all the password access functions -PIPE Enables the pipe function -WAIT Enables the wait function -UMASK Enables the umask function - -S_IFBLK * Enables the block special device check -S_ISGID * Enables the setgid check -S_ISUID * Enables the setuid check -S_ISVTX * Enables the vtx check -unix * Compiles globbing for Unix -MSDOS * Compiles globbing for MS-DOS - Closes stdaux and stdprn on startup - Adds a copyright message for -v - Disables the compilation of my_popen, my_pclose as the - are in a separate file. - -Symbols marked with * are defined in the compilation environment. The -rest should be added to config.h (config.h.SH). All functions when not -supported give a fatal error. - -Added documentation for the binmode function in the manual. - -Fixed the following bugs: - -In eval.c function eval if ioctl or fcntl returned something -other than 0 or -1 the result was a random number as the -double `value' variable wasn't set to `anum'. - -In doio.c function do_exec there were two errors associated with -firing up the shell when the execv fails. First argv was not freed, -secondly an attempt was made to start up the shell with the cmd -string that was now cut to pieces for the execv. Also the maxible -possible length of argv was calculated by (s - cmd). Problem was -that s was not pointing to the end of the string, but to the first -non alpha. - -[These are incorporated in patches 15 and 16--law] - -Diomidis Spinellis, March 1990 diff --git a/msdos/Makefile b/msdos/Makefile deleted file mode 100644 index eeb15e8068..0000000000 --- a/msdos/Makefile +++ /dev/null @@ -1,101 +0,0 @@ -# -# Makefile for compiling Perl under MS-DOS -# -# Needs a Unix compatible make. -# This makefile works for an initial compilation. It does not -# include all dependencies and thus is unsuitable for serious -# development work. But who would do serious development under -# MS-DOS? -# -# By Diomidis Spinellis, March 1990 -# - -# Source files -SRC = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c \ -eval.c form.c hash.c perl.y perly.c regcomp.c regexec.c \ -stab.c str.c toke.c util.c msdos.c popen.c directory.c - -# Object files -OBJ = perl.obj array.obj cmd.obj cons.obj consarg.obj doarg.obj doio.obj \ -dolist.obj dump.obj eval.obj form.obj hash.obj perly.obj regcomp.obj \ -regexec.obj stab.obj str.obj toke.obj util.obj msdos.obj popen.obj \ -directory.obj - -# Files in the MS-DOS distribution -DOSFILES=config.h dir.h director.c glob.c makefile msdos.c popen.c readme.msd \ -changes.dds wishlist.dds patches manifest - -# Yacc flags -YFLAGS=-d - -# Manual pages -MAN=perlman.1 perlman.2 perlman.3 perlman.4 - -CC=cc -# Cflags for the files that break under the optimiser -CPLAIN=-AL -DCRIPPLED_CC -# Cflags for all the rest -CFLAGS=$(CPLAIN) -Ox -# Destination directory for executables -DESTDIR=\usr\bin - -# Deliverables -all: perl.exe perl.1 glob.exe - -perl.exe: $(OBJ) - echo array+cmd+cons+consarg+doarg+doio+dolist+dump+ >perl.arp - echo eval+form+hash+perl+perly+regcomp+regexec+ >>perl.arp - echo stab+str+toke+util+msdos+popen+directory+\lib\setargv >>perl.arp - echo perl.exe >>perl.arp - echo nul >>perl.arp - echo /stack:32767 /NOE >>perl.arp - link @perl.arp - -glob.exe: glob.c - $(CC) glob.c \lib\setargv.obj -link /NOE - -array.obj: array.c -cmd.obj: cmd.c -cons.obj: cons.c perly.h -consarg.obj: consarg.c - $(CC) $(CPLAIN) -c consarg.c -doarg.obj: doarg.c -doio.obj: doio.c -dolist.obj: dolist.c -dump.obj: dump.c -eval.obj: eval.c evalargs.xc -form.obj: form.c -hash.obj: hash.c -perl.obj: perl.y -perly.obj: perly.c -regcomp.obj: regcomp.c -regexec.obj: regexec.c -stab.obj: stab.c -str.obj: str.c -toke.obj: toke.c -util.obj: util.c - $(CC) $(CPLAIN) -c util.c -perly.h: perl.obj - mv ytab.h perly.h -directory.obj: directory.c -popen.obj: popen.c -msdos.obj: msdos.c - -perl.1: $(MAN) - nroff -man $(MAN) >perl.1 - -install: all - exepack perl.exe $(DESTDIR)\perl.exe - exepack glob.exe $(DESTDIR)\glob.exe - -clean: - rm -f *.obj *.exe perl.1 perly.h perl.arp - -tags: - ctags *.c *.h *.xc - -dosperl: - mv $(DOSFILES) ../perl30.new - -doskit: - mv $(DOSFILES) ../msdos diff --git a/msdos/README.msdos b/msdos/README.msdos deleted file mode 100644 index 3a5c38fcae..0000000000 --- a/msdos/README.msdos +++ /dev/null @@ -1,195 +0,0 @@ - Notes on the MS-DOS Perl port - - Diomidis Spinellis - (dds@cc.ic.ac.uk) - -[0. First copy the files in the msdos directory into the parent -directory--law] - -1. Compiling. - - Perl has been compiled under MS-DOS using the Microsoft -C compiler version 5.1. Before compiling install dir.h as -<sys/dir.h>. You will need a Unix-like make program (e.g. -pdmake) and something like yacc (e.g. bison). You could get -away by running yacc and dry running make on a Unix host, -but I haven't tried it. Compilation takes 12 minutes on a -20MHz 386 machine (together with formating the manual), so -you will probably need something to do in the meantime. The -executable is 272k and the top level directory needs 1M for -sources and about the same ammount for the object code and -the executables. - - The makefile will compile glob for you which you will -need to place somewhere in your path so that perl globbing -will work correctly. I have not tried all the tests or the -examples, nor the awk and sed to Perl translators. You are -on your own with them. In the eg directory I have included -an example program that uses ioctl to display the charac- -teristics of the storage devices of the system. - -2. Using MS-DOS Perl - - The MS-DOS version of perl has most of the functional- -ity of the Unix version. Functions that can not be provided -under MS-DOS like sockets, password and host database -access, fork and wait have been ommited and will terminate -with a fatal error. Care has been taken to implement the -rest. In particular directory access, redirection (includ- -ing pipes, but excluding the pipe function), system, ioctl -and sleep have been provided. - -[Files currently can be edited in-place provided you are cre- -ating a backup. However, if the backup coincidentally has -the same name as the original, or if the resulting backup -filename is invalid, then the file will probably be trashed. -For example, don't do - - perl -i~ script makefile - perl -i.bak script file.dat - -because (1) MS-DOS treats "makefile~" and "makefile" as the -same filename, and (2) "file.dat.bak" is an invalid filename. -The files "makefile" and "file.dat" will probably be lost -forever. Moral of the story: Don't use in-place editing -under MS-DOS. --rjc] - -2.1. Interface to the MS-DOS ioctl system call. - - The function code of the ioctl function (the second -argument) is encoded as follows: - -- The lowest nibble of the function code goes to AL. -- The two middle nibbles go to CL. -- The high nibble goes to CH. - - The return code is -1 in the case of an error and if -successful: - -- for functions AL = 00, 09, 0a the value of the register DX -- for functions AL = 02 - 08, 0e the value of the register AX -- for functions AL = 01, 0b - 0f the number 0. - - See the perl manual for instruction on how to distin- -guish between the return value and the success of ioctl. - - Some ioctl functions need a number as the first argu- -ment. Provided that no other files have been opened the -number can be obtained if ioctl is called with -@fdnum[number] as the first argument after executing the -following code: - - @fdnum = ("STDIN", "STDOUT", "STDERR"); - $maxdrives = 15; - for ($i = 3; $i < $maxdrives; $i++) { - open("FD$i", "nul"); - @fdnum[$i - 1] = "FD$i"; - } - -2.2. Binary file access - - Files are opened in text mode by default. This means -that CR LF pairs are translated to LF. If binary access is -needed the `binary' function should be used. There is -currently no way to reverse the effect of the binary func- -tion. If that is needed close and reopen the file. - -2.3. Interpreter startup. - - The effect of the Unix #!/bin/perl interpreter startup -can be obtained under MS-DOS by giving the script a .bat -extension and using the following lines on its begining: - - @REM=(" - @perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 - @end ") if 0 ; - -(Note that you will probably want an absolute path name in -front of %0.bat). - - March 1990 - - Diomidis Spinellis <dds@cc.ic.ac.uk> - Myrsinis 1 - GR-145 62 Kifissia - Greece - --------------------------------------------------------------------------- - - Revisions to the MS-DOS support in Perl 4.0 - Tom Dinger, 18 March 1991 - -The DOS compatibility added to Perl sometime in release 3.x was not -maintained, and Perl as distributed could not be built without changes. - -Both myself and Len Reed more or less "rediscovered" how to get Perl built -and running reliably for MS-DOS, using the Microsoft C compiler. He and I -have communicated, and will be putting together additional patches for the -DOS version of Perl. - -1. Compiling Perl - - For now, I have not supplied a makefile, as there is no standard for - make utilities under DOS. All the files can be compiled with Microsoft - C 5.1, using the switches "-AL -Ox" for Large memory model, maximum - optimization (this turned out a few code generation bugs in MSC 5.1). - The code will also compile with MSC 6.00A, with the optimization - "-Oacegils /Gs" for all files (regcomp.c has special case code to change - the aliasing optimizations). - - Generally, you follow the instructions given above to compile and build - Perl 4.0 for DOS. I used the output of SunOS yacc run on perly.y, - without modification, but I expect both Bison and Berkeley-YACC will work - also. From inspection of the generated code, however, I believe AT&T - derived YACC produces the smallest tables, i.e. uses the least memory. - This is important for a 300K executable file. - -2. Editing in-place. - - You will need the file suffix.c from the os2 subdirectory -- it will - create a backup file with much less danger for DOS. - -3. A "Smarter" chdir() function. - - I have added to the DOS version of Perl 4.0 a replacement chdir() - function. Unlike the "normal" behavior, it is aware of drive letters - at the start of paths for DOS. So for example: - - perl_chdir( "B:" ) changes to the default directory, on drive B: - perl_chdir( "C:\FOO" ) changes to the specified directory, on drive C: - perl_chdir( "\BAR" ) changes to the specified directory on the - current drive. - -4. *.BAT Scripts as Perl scripts - - The strategy described above for turning a Perl script into a *.BAT - script do not work. I have been using the following lines at the - beginning of a Perl *.BAT script: - - @REM=(qq! - @perl -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 - @goto end !) if 0 ; - - and the following at the end of the *.BAT script: - - @REM=(qq! - :end !) if 0 ; - - If you like, with the proper editor you can replace the four '!' - characters with some untypeable character, such as Ctrl-A. This will - allow you to pass any characters, including ".." strings as arguments. - -4. Things to Come - - * Better temporary file handling. - * A real Makefile -- Len Reed has one for Dmake 3.6 - * Swapping code -- swaps most of Perl out of memory (to EMS, XMS or - disk) before running a sub-program or pipe. - * MKS command line support, both into Perl, and to other programs - spawned by Perl. - * Smarter pipe functions, not using COMMAND.COM. - - - Tom Dinger - tdinger@East.Sun.COM - Martch 18, 1991 diff --git a/msdos/Wishlist.dds b/msdos/Wishlist.dds deleted file mode 100644 index d06de117ab..0000000000 --- a/msdos/Wishlist.dds +++ /dev/null @@ -1,17 +0,0 @@ -Perl in general: -Add ftw or find? -Add a parsing mechanism (user specifies parse tree, perl parses). -Arbitrary precision arithmetic. -File calculus (e.g. file1 = file2 + file3, file1 =^ s/foo/bar/g etc.) - -MS-DOS version of Perl: -Add interface to treat dBase files as associative arrays. -Add int86x function. -Handle the C preprocessor. -Provide real pipes by switching the processes. (difficult) -Provide a list of ioctl codes. -Check the ioctl errno handling. -I can't find an easy way in Perl to pass a number as the first argument - to ioctl. This is needed for some functions of ioctl. Either hack - ioctl, or change perl to ioctl interface. Another solution would be - a perl pseudo array containing the filehandles indexed by fd. diff --git a/msdos/chdir.c b/msdos/chdir.c deleted file mode 100644 index b650eb0a90..0000000000 --- a/msdos/chdir.c +++ /dev/null @@ -1,96 +0,0 @@ -/* - * (C) Copyright 1990, 1991 Tom Dinger - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - */ - -/* - * A "DOS-aware" chdir() function, that will change current drive as well. - * - * chdir( "B:" ) -- changes to the default directory, on drive B: - * chdir( "C:\FOO" ) changes to the specified directory, on drive C: - * chdir( "\BAR" ) changes to the specified directory on the current - * drive. - */ - -#include <stdlib.h> -#include <ctype.h> -#include <direct.h> -#include <dos.h> -#include <errno.h> - -#include "config.h" -#ifdef chdir -#undef chdir -#endif - -/* We should have the line: - * - * #define chdir perl_chdir - * - * in some header for perl (I put it in config.h) so that all - * references to chdir() become references to this function. - */ - -/*------------------------------------------------------------------*/ - -#if defined(BUGGY_MSC5) /* only needed for MSC 5.1 */ - -int _chdrive( int drivenum ) -{ -unsigned int ndrives; -unsigned int tmpdrive; - - -_dos_setdrive( drivenum, &ndrives ); - -/* check for illegal drive letter */ -_dos_getdrive( &tmpdrive ); - -return (tmpdrive != drivenum) ? -1 : 0 ; -} - -#endif - -/*-----------------------------------------------------------------*/ - -int perl_chdir( char * path ) -{ -int drive_letter; -unsigned int drivenum; - - -if ( path && *path && (path[1] == ':') ) - { - /* The path starts with a drive letter */ - /* Change current drive */ - drive_letter = *path; - if ( isalpha(drive_letter) ) - { - /* Drive letter legal */ - if ( islower(drive_letter) ) - drive_letter = toupper(drive_letter); - drivenum = drive_letter - 'A' + 1; - - /* Change drive */ - if ( _chdrive( drivenum ) == -1 ) - { - /* Drive change failed -- must be illegal drive letter */ - errno = ENODEV; - return -1; - } - - /* Now see if that's all we do */ - if ( ! path[2] ) - return 0; /* no path after drive -- all done */ - } - /* else drive letter illegal -- fall into "normal" chdir */ - } - -/* Here with some path as well */ -return chdir( path ); - -/* end perl_chdir() */ -} diff --git a/msdos/config.h b/msdos/config.h deleted file mode 100644 index 7131d6338e..0000000000 --- a/msdos/config.h +++ /dev/null @@ -1,938 +0,0 @@ -#ifndef config_h -#define config_h -/* config.h - * - * This file is hand tailored for MS-DOS and MSC 5.1 and 6.00A. - * Tom Dinger, March 1991. - */ - - -/* - * BUGGY_MSC5: - * This symbol is defined if you are the unfortunate owner of the buggy - * Microsoft C compiler version 5.1. It is used as a conditional to - * guard code sections that are known to break this compiler. - * BUGGY_MSC6: - * This symbol is defined if you are the unfortunate owner of the buggy - * Microsoft C compiler version 6.0A. It is used as a conditional to - * guard code sections that are known to break this compiler. - */ -#define BUGGY_MSC5 /**/ -/*#undef BUGGY_MSC6 /**/ - - -/* EUNICE - * This symbol, if defined, indicates that the program is being compiled - * under the EUNICE package under VMS. The program will need to handle - * things like files that don't go away the first time you unlink them, - * due to version numbering. It will also need to compensate for lack - * of a respectable link() command. - */ -/* VMS - * This symbol, if defined, indicates that the program is running under - * VMS. It is currently only set in conjunction with the EUNICE symbol. - */ -/*#undef EUNICE /**/ -/*#undef VMS /**/ - -/* ALIGNBYTES - * This symbol contains the number of bytes required to align a double. - * Usual values are 2, 4, and 8. - */ -#define ALIGNBYTES 4 /**/ - -/* BIN - * This symbol holds the name of the directory in which the user wants - * to keep publicly executable images for the package in question. It - * is most often a local directory such as /usr/local/bin. - */ -#define BIN "/usr/local/bin" /**/ - -/* BYTEORDER - * This symbol contains an encoding of the order of bytes in a long. - * Usual values (in octal) are 01234, 04321, 02143, 03412... - */ -#define BYTEORDER 0x1234 /**/ - -/* 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". - */ -/* 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 "". - */ -/* TODO: doesn't work for MSC -- it's more complicated than this */ -#define CPPSTDIN "cl " -#define CPPMINUS "" - -/* HAS_BCMP - * This symbol, if defined, indicates that the bcmp routine is available - * to compare blocks of memory. If undefined, use memcmp. If that's - * not available, roll your own. - */ -/*#undef HAS_BCMP /**/ - -/* HAS_BCOPY - * This symbol, if defined, indicates that the bcopy routine is available - * to copy blocks of memory. Otherwise you should probably use memcpy(). - * If neither is defined, roll your own. - */ -/* SAFE_BCOPY - * This symbol, if defined, indicates that the bcopy routine is available - * to copy potentially overlapping copy blocks of bcopy. Otherwise you - * should probably use memmove() or memcpy(). If neither is defined, - * roll your own. - */ -/*#undef HAS_BCOPY /**/ -/*#undef SAFE_BCOPY /**/ - -/* HAS_BZERO - * This symbol, if defined, indicates that the bzero routine is available - * to zero blocks of memory. Otherwise you should probably use memset() - * or roll your own. - */ -/*#undef HAS_BZERO /**/ - -/* CASTNEGFLOAT - * This symbol, if defined, indicates that this C compiler knows how to - * cast negative or large floating point 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: - * 1 = couldn't cast < 0 - * 2 = couldn't cast >= 0x80000000 - */ -#define CASTNEGFLOAT /**/ -#define CASTFLAGS 0 /**/ - -/* CHARSPRINTF - * This symbol is defined if this system declares "char *sprintf()" in - * stdio.h. The trend seems to be to declare it as "int sprintf()". It - * is up to the package author to declare sprintf correctly based on the - * symbol. - */ -/*#undef CHARSPRINTF /**/ - -/* HAS_CHSIZE - * This symbol, if defined, indicates that the chsize routine is available - * to truncate files. You might need a -lx to get this routine. - */ -#define HAS_CHSIZE /**/ - -/* HAS_CRYPT - * This symbol, if defined, indicates that the crypt routine is available - * to encrypt passwords and the like. - */ -/*#undef HAS_CRYPT /**/ - -/* CSH - * This symbol, if defined, indicates that the C-shell exists. - * If defined, contains the full pathname of csh. - */ -/*#undef CSH "/usr/bin/csh" /**/ - -/* 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. - */ -/*#undef DOSUID /**/ - -/* HAS_DUP2 - * This symbol, if defined, indicates that the dup2 routine is available - * to dup file descriptors. Otherwise you should use dup(). - */ -#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. - */ -/*#undef HAS_FCNTL /**/ - -/* FLEXFILENAMES - * This symbol, if defined, indicates that the system supports filenames - * longer than 14 characters. - */ -/*#undef FLEXFILENAMES /**/ - -/* HAS_FLOCK - * This symbol, if defined, indicates that the flock() routine is - * available to do file locking. - */ -/*#undef HAS_FLOCK /**/ - -/* 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 /**/ - -/* 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 /**/ - -/* HAS_GETPGRP - * This symbol, if defined, indicates that the getpgrp() routine is - * available to get the current process group. - */ -/*#undef HAS_GETPGRP /**/ - -/* HAS_GETPGRP2 - * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) - * routine is available to get the current process group. - */ -/*#undef HAS_GETPGRP2 /**/ - -/* HAS_GETPRIORITY - * This symbol, if defined, indicates that the getpriority() routine is - * available to get a process's priority. - */ -/*#undef HAS_GETPRIORITY /**/ - -/* HAS_HTONS - * This symbol, if defined, indicates that the htons routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_HTONL - * This symbol, if defined, indicates that the htonl routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_NTOHS - * This symbol, if defined, indicates that the ntohs routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_NTOHL - * This symbol, if defined, indicates that the ntohl routine (and friends) - * are available to do network order byte swapping. - */ -/*#undef HAS_HTONS /**/ -/*#undef HAS_HTONL /**/ -/*#undef HAS_NTOHS /**/ -/*#undef HAS_NTOHL /**/ - -/* index - * This preprocessor symbol is defined, along with rindex, if the system - * uses the strchr and strrchr routines instead. - */ -/* rindex - * This preprocessor symbol is defined, along with index, if the system - * uses the strchr and strrchr routines instead. - */ -#define index strchr /* cultural */ -#define rindex strrchr /* differences? */ - -/* HAS_ISASCII - * This symbol, if defined, indicates that the isascii routine is available - * to test characters for asciiness. - */ -#define HAS_ISASCII /**/ - -/* HAS_KILLPG - * This symbol, if defined, indicates that the killpg routine is available - * to kill process groups. If unavailable, you probably should use kill - * with a negative process number. - */ -/*#undef HAS_KILLPG /**/ - -/* HAS_LSTAT - * This symbol, if defined, indicates that the lstat() routine is - * available to stat symbolic links. - */ -/*#undef HAS_LSTAT /**/ - -/* HAS_MEMCMP - * This symbol, if defined, indicates that the memcmp routine is available - * to compare blocks of memory. If undefined, roll your own. - */ -#define HAS_MEMCMP /**/ - -/* HAS_MEMCPY - * This symbol, if defined, indicates that the memcpy routine is available - * to copy blocks of memory. Otherwise you should probably use bcopy(). - * If neither is defined, roll your own. - */ -/* SAFE_MEMCPY - * This symbol, if defined, indicates that the memcpy routine is available - * to copy potentially overlapping copy blocks of memory. Otherwise you - * should probably use memmove() or bcopy(). If neither is defined, - * roll your own. - */ -#define HAS_MEMCPY /**/ -/*#undef SAFE_MEMCPY /**/ - -/* HAS_MEMMOVE - * This symbol, if defined, indicates that the memmove routine is available - * to move potentially overlapping blocks of memory. Otherwise you - * should use bcopy() or roll your own. - */ -/*#undef HAS_MEMMOVE /**/ - -/* HAS_MEMSET - * This symbol, if defined, indicates that the memset routine is available - * to set a block of memory to a character. If undefined, roll your own. - */ -#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_MSG - * This symbol, if defined, indicates that the entire msg*(2) library is - * supported. - */ -/*#undef HAS_MSG /**/ - -/* HAS_MSGCTL - * This symbol, if defined, indicates that the msgctl() routine is - * available to control message passing. - */ -/*#undef HAS_MSGCTL /**/ - -/* HAS_MSGGET - * This symbol, if defined, indicates that the msgget() routine is - * available to get messages. - */ -/*#undef HAS_MSGGET /**/ - -/* HAS_MSGRCV - * This symbol, if defined, indicates that the msgrcv() routine is - * available to receive messages. - */ -/*#undef HAS_MSGRCV /**/ - -/* HAS_MSGSND - * This symbol, if defined, indicates that the msgsnd() routine is - * available to send messages. - */ -/*#undef HAS_MSGSND /**/ - -/* HAS_NDBM - * This symbol, if defined, indicates that ndbm.h exists and should - * be included. - */ -/*#undef HAS_NDBM /**/ - -/* HAS_ODBM - * This symbol, if defined, indicates that dbm.h exists and should - * be included. - */ -/*#undef HAS_ODBM /**/ - -/* HAS_OPEN3 - * This manifest constant lets the C program know that the three - * argument form of open(2) is available. - */ -#define HAS_OPEN3 /**/ - -/* HAS_READDIR - * This symbol, if defined, indicates that the readdir routine is available - * from the C library to read directories. - */ -#define HAS_READDIR /**/ - -/* 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_REWINDDIR - * This symbol, if defined, indicates that the rewindir routine is - * available to rewind directories. - */ -#define HAS_REWINDDIR /**/ - -/* 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_SEEKDIR - * This symbol, if defined, indicates that the seekdir routine is - * available to seek into directories. - */ -#define HAS_SEEKDIR /**/ - -/* HAS_SELECT - * This symbol, if defined, indicates that the select() subroutine - * exists. - */ -/*#undef HAS_SELECT /**/ - -/* HAS_SEM - * This symbol, if defined, indicates that the entire sem*(2) library is - * supported. - */ -/*#undef HAS_SEM /**/ - -/* HAS_SEMCTL - * This symbol, if defined, indicates that the semctl() routine is - * available to control semaphores. - */ -/*#undef HAS_SEMCTL /**/ - -/* HAS_SEMGET - * This symbol, if defined, indicates that the semget() routine is - * available to get semaphores ids. - */ -/*#undef HAS_SEMGET /**/ - -/* HAS_SEMOP - * This symbol, if defined, indicates that the semop() routine is - * available to perform semaphore operations. - */ -/*#undef HAS_SEMOP /**/ - -/* 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_SETPGRP - * This symbol, if defined, indicates that the setpgrp() routine is - * available to set the current process group. - */ -/*#undef HAS_SETPGRP /**/ - -/* HAS_SETPGRP2 - * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) - * routine is available to set the current process group. - */ -/*#undef HAS_SETPGRP2 /**/ - -/* HAS_SETPRIORITY - * This symbol, if defined, indicates that the setpriority() routine is - * available to set a process's priority. - */ -/*#undef HAS_SETPRIORITY /**/ - -/* HAS_SETREGID - * This symbol, if defined, indicates that the setregid routine is - * available to change the real and effective gid of the current program. - */ -/* HAS_SETRESGID - * This symbol, if defined, indicates that the setresgid routine is - * available to change the real, effective and saved gid of the current - * program. - */ -/*#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 program. - */ -/* HAS_SETRESUID - * This symbol, if defined, indicates that the setresuid routine is - * available to change the real, effective and saved uid of the current - * program. - */ -/*#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_SHM - * This symbol, if defined, indicates that the entire shm*(2) library is - * supported. - */ -/*#undef HAS_SHM /**/ - -/* HAS_SHMAT - * This symbol, if defined, indicates that the shmat() routine is - * available to attach a shared memory segment. - */ -/* VOID_SHMAT - * This symbol, if defined, indicates that the shmat() routine - * returns a pointer of type void*. - */ -/*#undef HAS_SHMAT /**/ - -/*#undef VOIDSHMAT /**/ - -/* HAS_SHMCTL - * This symbol, if defined, indicates that the shmctl() routine is - * available to control a shared memory segment. - */ -/*#undef HAS_SHMCTL /**/ - -/* HAS_SHMDT - * This symbol, if defined, indicates that the shmdt() routine is - * available to detach a shared memory segment. - */ -/*#undef HAS_SHMDT /**/ - -/* HAS_SHMGET - * This symbol, if defined, indicates that the shmget() routine is - * available to get a shared memory segment id. - */ -/*#undef HAS_SHMGET /**/ - -/* 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. - */ -/* OLDSOCKET - * This symbol, if defined, indicates that the 4.1c BSD socket interface - * is supported instead of the 4.2/4.3 BSD socket interface. - */ -/*#undef HAS_SOCKET /**/ - -/*#undef HAS_SOCKETPAIR /**/ - -/*#undef OLDSOCKET /**/ - -/* STATBLOCKS - * This symbol is defined if this system has a stat structure declaring - * st_blksize and st_blocks. - */ -/*#undef STATBLOCKS /**/ - -/* STDSTDIO - * This symbol is defined if this system has a FILE structure declaring - * _ptr and _cnt in stdio.h. - * - * NOTE: [Tom Dinger, 23 February 1991] You also need the _filbuf() - * function, usually referred to by the getc() macro in stdio.h. - */ -#define STDSTDIO /**/ - -/* STRUCTCOPY - * 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 STRUCTCOPY /**/ - -/* HAS_STRERROR - * This symbol, if defined, indicates that the strerror() routine is - * available to translate error numbers to strings. - */ -#define HAS_STRERROR /**/ - -/* HAS_SYMLINK - * This symbol, if defined, indicates that the symlink routine is available - * to create symbolic links. - */ -/*#undef 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_TELLDIR - * This symbol, if defined, indicates that the telldir routine is - * available to tell your location in directories. - */ -#define HAS_TELLDIR /**/ - -/* HAS_TRUNCATE - * This symbol, if defined, indicates that the truncate routine is - * available to truncate files. - */ -/*#undef HAS_TRUNCATE /**/ - -/* HAS_VFORK - * This symbol, if defined, indicates that vfork() exists. - */ -/*#undef HAS_VFORK /**/ - -/* VOIDSIG - * This symbol is defined if this system declares "void (*signal())()" in - * signal.h. The old way was to declare it as "int (*signal())()". It - * is up to the package author to declare things correctly based on the - * symbol. - */ -/* TO_SIGNAL - * This symbol's value is either "void" or "int", corresponding to the - * appropriate return "type" of a signal handler. Thus, one can declare - * a signal handler using "TO_SIGNAL (*handler())()", and define the - * handler using "TO_SIGNAL handler(sig)". - */ -#define VOIDSIG /**/ -#define TO_SIGNAL int /**/ - -/* HASVOLATILE - * This symbol, if defined, indicates that this C compiler knows about - * the volatile declaration. - */ -/*#undef HASVOLATILE /**/ - -/* 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(). - */ -/* CHARVSPRINTF - * 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 /**/ -/*#undef CHARVSPRINTF /**/ - -/* HAS_WAIT4 - * This symbol, if defined, indicates that wait4() exists. - */ -/*#undef HAS_WAIT4 /**/ - -/* HAS_WAITPID - * This symbol, if defined, indicates that waitpid() exists. - */ -/*#undef HAS_WAITPID /**/ - -/* GIDTYPE - * This symbol has a value like gid_t, int, ushort, or whatever type is - * used to declare group ids in the kernel. - */ -#define GIDTYPE int /**/ - -/* GROUPSTYPE - * This symbol has a value like gid_t, int, ushort, or whatever type is - * used in the return value of getgroups(). - */ -#define GROUPSTYPE int /**/ - -/* I_FCNTL - * This manifest constant tells the C program to include <fcntl.h>. - */ -#define I_FCNTL /**/ - -/* I_GDBM - * This symbol, if defined, indicates that gdbm.h exists and should - * be included. - */ -/*#undef I_GDBM /**/ - -/* I_GRP - * This symbol, if defined, indicates to the C program that it should - * include grp.h. - */ -/*#undef I_GRP /**/ - -/* I_NETINET_IN - * This symbol, if defined, indicates to the C program that it should - * include netinet/in.h. - */ -/* I_SYS_IN - * This symbol, if defined, indicates to the C program that it should - * include sys/in.h. - */ -/*#undef I_NETINET_IN /**/ -/*#undef I_SYS_IN /**/ - -/* I_PWD - * This symbol, if defined, indicates to the C program that it should - * include pwd.h. - */ -/* PWQUOTA - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_quota. - */ -/* PWAGE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_age. - */ -/* PWCHANGE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_change. - */ -/* PWCLASS - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_class. - */ -/* PWEXPIRE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_expire. - */ -/* PWCOMMENT - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_comment. - */ -/*#undef I_PWD /**/ -/*#undef PWQUOTA /**/ -/*#undef PWAGE /**/ -/*#undef PWCHANGE /**/ -/*#undef PWCLASS /**/ -/*#undef PWEXPIRE /**/ -/*#undef PWCOMMENT /**/ - -/* I_SYS_FILE - * This manifest constant tells the C program to include <sys/file.h>. - */ -/*#undef I_SYS_FILE /**/ - -/* I_SYSIOCTL - * This symbol, if defined, indicates that sys/ioctl.h exists and should - * be included. - */ -/*#undef I_SYSIOCTL /**/ - -/* I_TIME - * This symbol is defined if the program should include <time.h>. - */ -/* I_SYS_TIME - * This symbol is defined if the program should include <sys/time.h>. - */ -/* SYSTIMEKERNEL - * This symbol is defined if the program should include <sys/time.h> - * with KERNEL defined. - */ -/* I_SYS_SELECT - * This symbol is defined if the program should include <sys/select.h>. - */ -#define I_TIME /**/ -/*#undef I_SYS_TIME /**/ -/*#undef SYSTIMEKERNEL /**/ -/*#undef I_SYS_SELECT /**/ - -/* I_UTIME - * This symbol, if defined, indicates to the C program that it should - * include utime.h. - */ -/*#undef I_UTIME /**/ - -/* I_VARARGS - * This symbol, if defined, indicates to the C program that it should - * include varargs.h. - */ -#define I_VARARGS /**/ - -/* I_VFORK - * This symbol, if defined, indicates to the C program that it should - * include vfork.h. - */ -/*#undef I_VFORK /**/ - -/* INTSIZE - * This symbol contains the size of an int, so that the C preprocessor - * can make decisions based on it. - */ -#define INTSIZE 2 /**/ - -/* I_DIRENT - * This symbol, if defined, indicates that the program should use the - * P1003-style directory routines, and include <dirent.h>. - */ -/* I_SYS_DIR - * This symbol, if defined, indicates that the program should use the - * directory functions by including <sys/dir.h>. - */ -/* I_NDIR - * This symbol, if defined, indicates that the program should include the - * system's version of ndir.h, rather than the one with this package. - */ -/* I_SYS_NDIR - * This symbol, if defined, indicates that the program should include the - * system's version of sys/ndir.h, rather than the one with this package. - */ -/* I_MY_DIR - * This symbol, if defined, indicates that the program should compile - * the ndir.c code provided with the package. - */ -/* 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. - */ -/*#undef I_DIRENT /**/ -#define I_SYS_DIR /**/ -/*#undef I_NDIR /**/ -/*#undef I_SYS_NDIR /**/ -/*#undef I_MY_DIR /**/ -/*#undef DIRNAMLEN /**/ - -/* MYMALLOC - * This symbol, if defined, indicates that we're using our own malloc. - */ -/* MALLOCPTRTYPE - * This symbol defines the kind of ptr returned by malloc and realloc. - */ -#define MYMALLOC /**/ - -#define MALLOCPTRTYPE void /**/ - - -/* RANDBITS - * This symbol contains the number of bits of random number the rand() - * function produces. Usual values are 15, 16, and 31. - */ -#define RANDBITS 31 /**/ - -/* SCRIPTDIR - * This symbol holds the name of the directory in which the user wants - * to keep publicly executable scripts for the package in question. It - * is often a directory that is mounted across diverse architectures. - */ -#define SCRIPTDIR "C:/bin/perl" /**/ - -/* SIG_NAME - * This symbol contains an list of signal names in order. - * - * Note: This list is specific for Microsoft C 5.1 and 6.0, which only - * support SIGINT, SIGFPE, SIGILL, SIGSEGV, and SIGABRT on - * DOS 3.x, but in addition defines SIGTERM, SIGBREAK, SIGUSR1, - * SIGUSR2, and SIGUSR3. - */ -#define SIG_NAME \ - "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE","KILL",\ - "BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","TSTP","CONT",\ - "USR3","BREAK","ABRT" /**/ - -/* 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 /**/ - -/* UIDTYPE - * This symbol has a value like uid_t, int, ushort, or whatever type is - * used to declare user ids in the kernel. - */ -#define UIDTYPE int /**/ - -/* VOIDHAVE - * 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 - * - * The package designer should define VOIDWANT to indicate the requirements - * of the package. This can be done either by #defining VOIDWANT before - * including config.h, or by defining voidwant in Myinit.U. If the level - * of void support necessary is not present, config.h defines void to "int", - * VOID to the empty string, and VOIDP to "char *". - */ -/* void - * This symbol is used for void casts. On implementations which support - * void appropriately, its value is "void". Otherwise, its value maps - * to "int". - */ -/* VOID - * This symbol's value is "void" if the implementation supports void - * appropriately. Otherwise, its value is the empty string. The primary - * use of this symbol is in specifying void parameter lists for function - * prototypes. - */ -/* VOIDP - * This symbol is used for casting generic pointers. On implementations - * which support void appropriately, its value is "void *". Otherwise, - * its value is "char *". - */ -#ifndef VOIDWANT -#define VOIDWANT 1 -#endif -#define VOIDHAVE 1 -#if (VOIDHAVE & VOIDWANT) != VOIDWANT -#define void int /* is void to be avoided? */ -#define VOID -#define VOIDP (char *) -#define M_VOID /* Xenix strikes again */ -#else -#define VOID void -#define VOIDP (void *) -#endif - -/* PRIVLIB - * This symbol contains the name of the private library for this package. - * The library is private in the sense that it needn't be in anyone's - * execution path, but it should be accessible by the world. The program - * should be prepared to do ~ expansion. - */ -#define PRIVLIB "/usr/local/lib/perl" /**/ - -/* - * BINARY: - * This symbol is defined if you run under an operating system that - * distinguishes between binary and text files. If so the function - * setmode will be used to set the file into binary mode. - */ -#define BINARY - -#define S_ISUID 0 -#define S_ISGID 0 - -/* For MSC5.1, toke.c "runs out of heap space" unless CRIPPLED_CC is - * defined. - */ -#if defined(BUGGY_MSC5) || defined(BUGGY_MSC6) -#define CRIPPLED_CC /**/ -#endif - -/* MSC (5.1 and 6.0) doesn't know about S_IFBLK or S_IFIFO -- these are - * normally found in sys/stat.h - */ -#define S_IFBLK (S_IFDIR | S_IFCHR) -#define S_IFIFO 0010000 - -/* Define SUFFIX to get special DOS suffix-replacement code */ -#define SUFFIX /**/ - -/* Add this for the DOS-specific chdir() function */ -#define chdir perl_chdir - -#endif diff --git a/msdos/dir.h b/msdos/dir.h deleted file mode 100644 index d16bc372e0..0000000000 --- a/msdos/dir.h +++ /dev/null @@ -1,63 +0,0 @@ -/* $RCSfile: dir.h,v $$Revision: 4.1 $$Date: 92/08/07 18:24:41 $ - * - * (C) Copyright 1987, 1990 Diomidis Spinellis. - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - * $Log: dir.h,v $ - * Revision 4.1 92/08/07 18:24:41 lwall - * - * Revision 4.0.1.1 91/06/07 11:22:10 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:34:20 lwall - * 4.0 baseline. - * - * Revision 3.0.1.1 90/03/27 16:07:08 lwall - * patch16: MSDOS support - * - * Revision 1.1 90/03/18 20:32:29 dds - * Initial revision - * - * - */ - -/* - * defines the type returned by the directory(3) functions - */ - -#ifndef __DIR_INCLUDED -#define __DIR_INCLUDED - -/*Directory entry size */ -#ifdef DIRSIZ -#undef DIRSIZ -#endif -#define DIRSIZ(rp) (sizeof(struct direct)) - -/* - * Structure of a directory entry - */ -struct direct { - ino_t d_ino; /* inode number (not used by MS-DOS) */ - int d_namlen; /* Name length */ - char d_name[13]; /* file name */ -}; - -struct _dir_struc { /* Structure used by dir operations */ - char *start; /* Starting position */ - char *curr; /* Current position */ - struct direct dirstr; /* Directory structure to return */ -}; - -typedef struct _dir_struc DIR; /* Type returned by dir operations */ - -DIR *cdecl opendir(char *filename); -struct direct *readdir(DIR *dirp); -long telldir(DIR *dirp); -void seekdir(DIR *dirp,long loc); -void rewinddir(DIR *dirp); -void closedir(DIR *dirp); - -#endif /* __DIR_INCLUDED */ diff --git a/msdos/directory.c b/msdos/directory.c deleted file mode 100644 index dd1fb64519..0000000000 --- a/msdos/directory.c +++ /dev/null @@ -1,185 +0,0 @@ -/* $RCSfile: directory.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:42 $ - * - * (C) Copyright 1987, 1988, 1990 Diomidis Spinellis. - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - * $Log: directory.c,v $ - * Revision 4.1 92/08/07 18:24:42 lwall - * - * Revision 4.0.1.1 91/06/07 11:22:24 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:34:24 lwall - * 4.0 baseline. - * - * Revision 3.0.1.1 90/03/27 16:07:37 lwall - * patch16: MSDOS support - * - * Revision 1.3 90/03/16 22:39:40 dds - * Fixed malloc problem. - * - * Revision 1.2 88/07/23 00:08:39 dds - * Added inode non-zero filling. - * - * Revision 1.1 88/07/23 00:03:50 dds - * Initial revision - * - */ - -/* - * UNIX compatible directory access functions - */ - -#include <sys/types.h> -#include <sys/dir.h> -#include <stddef.h> -#include <stdlib.h> -#include <string.h> -#include <dos.h> -#include <ctype.h> - -/* - * File names are converted to lowercase if the - * CONVERT_TO_LOWER_CASE variable is defined. - */ -#define CONVERT_TO_LOWER_CASE - -#define PATHLEN 65 - -#ifndef lint -static char rcsid[] = "$RCSfile: directory.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:42 $"; -#endif - -DIR * -opendir(char *filename) -{ - DIR *p; - char *oldresult, *result; - union REGS srv; - struct SREGS segregs; - register reslen = 0; - char scannamespc[PATHLEN]; - char *scanname = scannamespc; /* To take address we need a pointer */ - - /* - * Structure used by the MS-DOS directory system calls. - */ - struct dir_buff { - char reserved[21]; /* Reserved for MS-DOS */ - unsigned char attribute; /* Attribute */ - unsigned int time; /* Time */ - unsigned int date; /* Date */ - long size; /* Size of file */ - char fn[13]; /* Filename */ - } buffspc, *buff = &buffspc; - - - if (!(p = (DIR *) malloc(sizeof(DIR)))) - return NULL; - - /* Initialize result to use realloc on it */ - if (!(result = malloc(1))) { - free(p); - return NULL; - } - - /* Create the search pattern */ - strcpy(scanname, filename); - if (strchr("/\\", *(scanname + strlen(scanname) - 1)) == NULL) - strcat(scanname, "/*.*"); - else - strcat(scanname, "*.*"); - - segread(&segregs); -#if ( defined(M_I86LM) || defined(M_I86CM) || defined(M_I86HM) ) - segregs.ds = FP_SEG(buff); - srv.x.dx = FP_OFF(buff); -#else - srv.x.dx = (unsigned int) buff; -#endif - srv.h.ah = 0x1a; /* Set DTA to DS:DX */ - intdosx(&srv, &srv, &segregs); - -#if ( defined(M_I86LM) || defined(M_I86CM) || defined(M_I86HM) ) - segregs.ds = FP_SEG(scanname); - srv.x.dx = FP_OFF(scanname); -#else - srv.x.dx = (unsigned int) scanname; -#endif - srv.x.cx = 0xff; /* Search mode */ - - for (srv.h.ah = 0x4e; !intdosx(&srv, &srv, &segregs); srv.h.ah = 0x4f) { - if ((result = (char *) realloc(result, reslen + strlen(buff->fn) + 1)) == - NULL) { - free(p); - free(oldresult); - return NULL; - } - oldresult = result; -#ifdef CONVERT_TO_LOWER_CASE - strcpy(result + reslen, strlwr(buff->fn)); -#else - strcpy(result + reslen, buff->fn); -#endif - reslen += strlen(buff->fn) + 1; - } - - if (!(result = realloc(result, reslen + 1))) { - free(p); - free(oldresult); - return NULL; - } else { - p->start = result; - p->curr = result; - *(result + reslen) = '\0'; - return p; - } -} - - -struct direct * -readdir(DIR *dirp) -{ - char *p; - register len; - static dummy; - - p = dirp->curr; - len = strlen(p); - if (*p) { - dirp->curr += len + 1; - strcpy(dirp->dirstr.d_name, p); - dirp->dirstr.d_namlen = len; - /* To fool programs */ - dirp->dirstr.d_ino = ++dummy; - return &(dirp->dirstr); - } else - return NULL; -} - -long -telldir(DIR *dirp) -{ - return (long) dirp->curr; /* ouch! pointer to long cast */ -} - -void -seekdir(DIR *dirp, long loc) -{ - dirp->curr = (char *) loc; /* ouch! long to pointer cast */ -} - -void -rewinddir(DIR *dirp) -{ - dirp->curr = dirp->start; -} - -void -closedir(DIR *dirp) -{ - free(dirp->start); - free(dirp); -} diff --git a/msdos/eg/crlf.bat b/msdos/eg/crlf.bat deleted file mode 100644 index 24d73661b9..0000000000 --- a/msdos/eg/crlf.bat +++ /dev/null @@ -1,32 +0,0 @@ -@REM=(" -@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 -@end ") if 0 ; - -# Convert all the files in the current directory from unix to MS-DOS -# line ending conventions. -# -# By Diomidis Spinellis -# -open(FILES, 'find . -print |'); -while ($file = <FILES>) { - $file =^ s/[\n\r]//; - if (-f $file) { - if (-B $file) { - print STDERR "Skipping binary file $file\n"; - next; - } - ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, - $blksize, $blocks) = stat($file); - open(IFILE, "$file"); - open(OFILE, ">xl$$"); - while (<IFILE>) { - print OFILE; - } - close(OFILE) || die "close xl$$: $!\n"; - close(IFILE) || die "close $file: $!\n"; - unlink($file) || die "unlink $file: $!\n"; - rename("xl$$", $file) || die "rename(xl$$, $file): $!\n"; - chmod($mode, $file) || die "chmod($mode, $file: $!\n"; - utime($atime, $mtime, $file) || die "utime($atime, $mtime, $file): $!\n"; - } -} diff --git a/msdos/eg/drives.bat b/msdos/eg/drives.bat deleted file mode 100644 index c68306ed8d..0000000000 --- a/msdos/eg/drives.bat +++ /dev/null @@ -1,41 +0,0 @@ -@REM=(" -@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 -@end ") if 0 ; - -# -# Test the ioctl function for MS-DOS. Provide a list of drives and their -# characteristics. -# -# By Diomidis Spinellis. -# - -@fdnum = ("STDIN", "STDOUT", "STDERR"); -$maxdrives = 15; -for ($i = 3; $i < $maxdrives; $i++) { - open("FD$i", "nul"); - @fdnum[$i - 1] = "FD$i"; -} -@mediatype = ( - "320/360 k floppy drive", - "1.2M floppy", - "720K floppy", - "8'' single density floppy", - "8'' double density floppy", - "fixed disk", - "tape drive", - "1.44M floppy", - "other" -); -print "The system has the following drives:\n"; -for ($i = 1; $i < $maxdrives; $i++) { - if ($ret = ioctl(@fdnum[$i], 8, 0)) { - $type = ($ret == 0) ? "removable" : "fixed"; - $ret = ioctl(@fdnum[$i], 9, 0); - $location = ($ret & 0x800) ? "local" : "remote"; - ioctl(@fdnum[$i], 0x860d, $param); - @par = unpack("CCSSSC31S", $param); - $lock = (@par[2] & 2) ? "supporting door lock" : "not supporting door lock"; - printf "%c:$type $location @mediatype[@par[1]] @par[3] cylinders @par[6] - sectors/track $lock\n", ord('A') + $i - 1; - } -} diff --git a/msdos/eg/lf.bat b/msdos/eg/lf.bat deleted file mode 100644 index 9c13eef840..0000000000 --- a/msdos/eg/lf.bat +++ /dev/null @@ -1,33 +0,0 @@ -@REM=(" -@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 -@end ") if 0 ; - -# Convert all the files in the current directory from MS-DOS to unix -# line ending conventions. -# -# By Diomidis Spinellis -# -open(FILES, 'find . -print |'); -while ($file = <FILES>) { - $file =^ s/[\n\r]//; - if (-f $file) { - if (-B $file) { - print STDERR "Skipping binary file $file\n"; - next; - } - ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, - $blksize, $blocks) = stat($file); - open(IFILE, "$file"); - open(OFILE, ">xl$$"); - binmode OFILE || die "binmode xl$$: $!\n"; - while (<IFILE>) { - print OFILE; - } - close(OFILE) || die "close xl$$: $!\n"; - close(IFILE) || die "close $file: $!\n"; - unlink($file) || die "unlink $file: $!\n"; - rename("xl$$", $file) || die "rename(xl$$, $file): $!\n"; - chmod($mode, $file) || die "chmod($mode, $file: $!\n"; - utime($atime, $mtime, $file) || die "utime($atime, $mtime, $file): $!\n"; - } -} diff --git a/msdos/glob.c b/msdos/glob.c deleted file mode 100644 index 19fb2ab7ba..0000000000 --- a/msdos/glob.c +++ /dev/null @@ -1,17 +0,0 @@ -/* - * Globbing for MS-DOS. Relies on the expansion done by the library - * startup code. (dds) - */ - -#include <stdio.h> -#include <string.h> - -main(int argc, char *argv[]) -{ - register i; - - for (i = 1; i < argc; i++) { - fputs(strlwr(argv[i]), stdout); - putchar(0); - } -} diff --git a/msdos/msdos.c b/msdos/msdos.c deleted file mode 100644 index 206cf5a3a1..0000000000 --- a/msdos/msdos.c +++ /dev/null @@ -1,260 +0,0 @@ -/* $RCSfile: msdos.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:49 $ - * - * (C) Copyright 1989, 1990 Diomidis Spinellis. - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - * $Log: msdos.c,v $ - * Revision 4.1 92/08/07 18:24:49 lwall - * - * Revision 4.0.1.1 91/06/07 11:22:37 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:34:46 lwall - * 4.0 baseline. - * - * Revision 3.0.1.1 90/03/27 16:10:41 lwall - * patch16: MSDOS support - * - * Revision 1.1 90/03/18 20:32:01 dds - * Initial revision - * - */ - -/* - * Various Unix compatibility functions for MS-DOS. - */ - -#include "EXTERN.h" -#include "perl.h" - -#include <dos.h> -#include <process.h> - -/* - * Interface to the MS-DOS ioctl system call. - * The function is encoded as follows: - * The lowest nibble of the function code goes to AL - * The two middle nibbles go to CL - * The high nibble goes to CH - * - * The return code is -1 in the case of an error and if successful - * for functions AL = 00, 09, 0a the value of the register DX - * for functions AL = 02 - 08, 0e the value of the register AX - * for functions AL = 01, 0b - 0f the number 0 - * - * Notice that this restricts the ioctl subcodes stored in AL to 00-0f - * In the Ralf Borwn interrupt list 90.1 there are no subcodes above AL=0f - * so we are ok. - * Furthermore CH is also restriced in the same area. Where CH is used as a - * code it always is between 00-0f. In the case where it forms a count - * together with CL we arbitrarily set the highest count limit to 4095. It - * sounds reasonable for an ioctl. - * The other alternative would have been to use the pointer argument to - * point the the values of CX. The problem with this approach is that - * of accessing wild regions when DX is used as a number and not as a - * pointer. - */ -int -ioctl(int handle, unsigned int function, char *data) -{ - union REGS srv; - struct SREGS segregs; - - srv.h.ah = 0x44; - srv.h.al = (unsigned char)(function & 0x0F); - srv.x.bx = handle; - srv.x.cx = function >> 4; - segread(&segregs); -#if ( defined(M_I86LM) || defined(M_I86CM) || defined(M_I86HM) ) - segregs.ds = FP_SEG(data); - srv.x.dx = FP_OFF(data); -#else - srv.x.dx = (unsigned int) data; -#endif - intdosx(&srv, &srv, &segregs); - if (srv.x.cflag & 1) { - switch(srv.x.ax ){ - case 1: - errno = EINVAL; - break; - case 2: - case 3: - errno = ENOENT; - break; - case 4: - errno = EMFILE; - break; - case 5: - errno = EPERM; - break; - case 6: - errno = EBADF; - break; - case 8: - errno = ENOMEM; - break; - case 0xc: - case 0xd: - case 0xf: - errno = EINVAL; - break; - case 0x11: - errno = EXDEV; - break; - case 0x12: - errno = ENFILE; - break; - default: - errno = EZERO; - break; - } - return -1; - } else { - switch (function & 0xf) { - case 0: case 9: case 0xa: - return srv.x.dx; - case 2: case 3: case 4: case 5: - case 6: case 7: case 8: case 0xe: - return srv.x.ax; - case 1: case 0xb: case 0xc: case 0xd: - case 0xf: - default: - return 0; - } - } -} - - -/* - * Sleep function. - */ -void -sleep(unsigned len) -{ - time_t end; - - end = time((time_t *)0) + len; - while (time((time_t *)0) < end) - ; -} - -/* - * Just pretend that everyone is a superuser - */ -#define ROOT_UID 0 -#define ROOT_GID 0 -int -getuid(void) -{ - return ROOT_UID; -} - -int -geteuid(void) -{ - return ROOT_UID; -} - -int -getgid(void) -{ - return ROOT_GID; -} - -int -getegid(void) -{ - return ROOT_GID; -} - -int -setuid(int uid) -{ return (uid==ROOT_UID?0:-1); } - -int -setgid(int gid) -{ return (gid==ROOT_GID?0:-1); } - -/* - * The following code is based on the do_exec and do_aexec functions - * in file doio.c - */ -int -do_aspawn(really,arglast) -STR *really; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register int items = arglast[2] - sp; - register char **a; - char **argv; - char *tmps; - int status; - - if (items) { - New(1101,argv, items+1, char*); - a = argv; - for (st += ++sp; items > 0; items--,st++) { - if (*st) - *a++ = str_get(*st); - else - *a++ = ""; - } - *a = Nullch; - if (really && *(tmps = str_get(really))) - status = spawnvp(P_WAIT,tmps,argv); - else - status = spawnvp(P_WAIT,argv[0],argv); - Safefree(argv); - } - return status; -} - - -int -do_spawn(cmd) -char *cmd; -{ - register char **a; - register char *s; - char **argv; - char flags[10]; - int status; - char *shell, *cmd2; - - /* save an extra exec if possible */ - if ((shell = getenv("COMSPEC")) == 0) - shell = "\\command.com"; - - /* see if there are shell metacharacters in it */ - if (strchr(cmd, '>') || strchr(cmd, '<') || strchr(cmd, '|')) - doshell: - return spawnl(P_WAIT,shell,shell,"/c",cmd,(char*)0); - - New(1102,argv, strlen(cmd) / 2 + 2, char*); - - New(1103,cmd2, strlen(cmd) + 1, char); - strcpy(cmd2, cmd); - a = argv; - for (s = cmd2; *s;) { - while (*s && isspace(*s)) s++; - if (*s) - *(a++) = s; - while (*s && !isspace(*s)) s++; - if (*s) - *s++ = '\0'; - } - *a = Nullch; - if (argv[0]) - if ((status = spawnvp(P_WAIT,argv[0],argv)) == -1) { - Safefree(argv); - Safefree(cmd2); - goto doshell; - } - Safefree(cmd2); - Safefree(argv); - return status; -} diff --git a/msdos/popen.c b/msdos/popen.c deleted file mode 100644 index 0031f5e58a..0000000000 --- a/msdos/popen.c +++ /dev/null @@ -1,186 +0,0 @@ -/* $RCSfile: popen.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:50 $ - * - * (C) Copyright 1988, 1990 Diomidis Spinellis. - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - * $Log: popen.c,v $ - * Revision 4.1 92/08/07 18:24:50 lwall - * - * Revision 4.0.1.1 91/06/07 11:22:52 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:34:50 lwall - * 4.0 baseline. - * - * Revision 3.0.1.2 90/08/09 04:04:42 lwall - * patch19: various MSDOS and OS/2 patches folded in - * - * Revision 3.0.1.1 90/03/27 16:11:57 lwall - * patch16: MSDOS support - * - * Revision 1.1 90/03/18 20:32:20 dds - * Initial revision - * - */ - -/* - * Popen and pclose for MS-DOS - */ - -#include <stdlib.h> -#include <stdio.h> -#include <process.h> - -/* - * Possible actions on an popened file - */ -enum action { - delete, /* Used for "r". Delete the tmp file */ - execute /* Used for "w". Execute the command. */ -}; - -/* - * Linked list of things to do at the end of the program execution. - */ -static struct todo { - FILE *f; /* File we are working on (to fclose) */ - const char *name; /* Name of the file (to unlink) */ - const char *command; /* Command to execute */ - enum action what; /* What to do (execute or delete) */ - struct todo *next; /* Next structure */ -} *todolist; - - -/* Clean up function */ -static int close_pipes(void); - -/* - * Add a file f running the command command on file name to the list - * of actions to be done at the end. The action is specified in what. - * Return -1 on failure, 0 if ok. - */ -static int -add(FILE *f, const char *command, const char *name, enum action what) -{ - struct todo *p; - - if ((p = (struct todo *) malloc(sizeof(struct todo))) == NULL) - return -1; - p->f = f; - p->command = command; - p->name = name; - p->what = what; - p->next = todolist; - todolist = p; - return 0; -} - -FILE * -mypopen(const char *command, const char *t) -{ - char buff[256]; - char *name; - FILE *f; - static init = 0; - - if (!init) - if (onexit(close_pipes) == NULL) - return NULL; - else - init++; - - if ((name = tempnam((char*)NULL, "pp")) == NULL) - return NULL; - - switch (*t) { - case 'r': - sprintf(buff, "%s >%s", command, name); - if (system(buff) || (f = fopen(name, "r")) == NULL) { - free(name); - return NULL; - } - if (add(f, command, name, delete)) { - (void)fclose(f); - (void)unlink(name); - free(name); - return NULL; - } - return f; - case 'w': - if ((f = fopen(name, "w")) == NULL) { - free(name); - return NULL; - } - if (add(f, command, name, execute)) { - (void)fclose(f); - (void)unlink(name); - free(name); - return NULL; - } - return f; - default: - free(name); - return NULL; - } -} - -int -mypclose(FILE *f) -{ - struct todo *p, **prev; - char buff[256]; - const char *name; - int status; - - for (p = todolist, prev = &todolist; p; prev = &(p->next), p = p->next) - if (p->f == f) { - *prev = p->next; - name = p->name; - switch (p->what) { - case delete: - free(p); - if (fclose(f) == EOF) { - (void)unlink(name); - status = EOF; - } else if (unlink(name) < 0) - status = EOF; - else - status = 0; - free((void*)name); - return status; - case execute: - (void)sprintf(buff, "%s <%s", p->command, p->name); - free(p); - if (fclose(f) == EOF) { - (void)unlink(name); - status = EOF; - } else if (system(buff)) { - (void)unlink(name); - status = EOF; - } else if (unlink(name) < 0) - status = EOF; - else - status = 0; - free((void*)name); - return status; - default: - return EOF; - } - } - return EOF; -} - -/* - * Clean up at the end. Called by the onexit handler. - */ -static int -close_pipes(void) -{ - struct todo *p; - - for (p = todolist; p; p = p->next) - (void)mypclose(p->f); - return 0; -} diff --git a/msdos/usage.c b/msdos/usage.c deleted file mode 100644 index 28991679e9..0000000000 --- a/msdos/usage.c +++ /dev/null @@ -1,51 +0,0 @@ -/* usage.c - * - * Show usage message. - */ - -#include <stdio.h> -#include <string.h> - - -usage(char *myname) -{ -char * p; -char * name_p; - -name_p = myname; -if ( p = strrchr(myname,'/') ) - name_p = p+1; /* point after final '/' */ -#ifdef MSDOS -if ( p = strrchr(name_p,'\\') ) - name_p = p+1; /* point after final '\\' */ -if ( p = strrchr(name_p,':') ) - name_p = p+1; /* point after final ':' */ - printf("\nUsage: %s [-acdnpsSvw] [-Dnumber] [-i[extension]] [-Idirectory]" -#else - printf("\nUsage: %s [-acdnpPsSuUvw] [-Dnumber] [-i[extension]] [-Idirectory]" -#endif - "\n [-e \"command\"] [-x[directory]] [filename] [arguments]\n", name_p); - - printf("\n -a autosplit mode with -n or -p" - "\n -c syntaxcheck only" - "\n -d run scripts under debugger" - "\n -n assume 'while (<>) { ...script... }' loop arround your script" - "\n -p assume loop like -n but print line also like sed" -#ifndef MSDOS - "\n -P run script through C preprocessor befor compilation" -#endif - "\n -s enable some switch parsing for switches after script name" - "\n -S look for the script using PATH environment variable"); -#ifndef MSDOS - printf("\n -u dump core after compiling the script" - "\n -U allow unsafe operations"); -#endif - printf("\n -v print version number and patchlevel of perl" - "\n -w turn warnings on for compilation of your script\n" - "\n -Dnumber set debugging flags" - "\n -i[extension] edit <> files in place (make backup if extension supplied)" - "\n -Idirectory specify include directory in conjunction with -P" - "\n -e command one line of script, multiple -e options are allowed" - "\n [filename] can be ommitted, when -e is used" - "\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); -} diff --git a/mv-if-diff b/mv-if-diff new file mode 100644 index 0000000000..1112a10dd3 --- /dev/null +++ b/mv-if-diff @@ -0,0 +1,14 @@ +: mv-if-diff file1 file2 +: move file1 to file2 if file1 and file2 are different. + +if test $# -lt 2 ; then + echo "usage: $0 file1 file2" + echo "move file1 to file2 if file1 and file2 are different." + exit 1 +fi +if cmp $1 $2 >/dev/null 2>&1; then + echo "File $2 not changed." + rm -f tmp +else + mv $1 $2 +fi diff --git a/myconfig b/myconfig new file mode 100755 index 0000000000..be8b40738c --- /dev/null +++ b/myconfig @@ -0,0 +1,41 @@ +#!/bin/sh + +# This script is designed to provide a handy summary of the configuration +# information being used to build perl. This is especially useful if you +# are requesting help from comp.lang.perl on usenet or via mail. + +if test -f config.sh; then TOP=.; +elif test -f ../config.sh; then TOP=..; +elif test -f ../../config.sh; then TOP=../..; +elif test -f ../../../config.sh; then TOP=../../..; +elif test -f ../../../../config.sh; then TOP=../../../..; +else + echo "Can't find the perl config.sh file produced by Configure"; exit 1 +fi +. $TOP/config.sh + +$spitshell <<!GROK!THIS! + +Summary of my $package (patchlevel $PATCHLEVEL) configuration: + Platform: + osname=$osname, osver=$osvers, archname=$archname + uname='$myuname' + hint=$hint + Compiler: + cc='$cc', optimize='$optimize' + cppflags='$cppflags' + ccflags ='$ccflags' + ldflags ='$ldflags' + 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 + Libraries: + so=$so + libpth=$libpth + libs=$libs + libc=$libc + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun + cccdlflags='$cccdlflags', ccdlflags='$ccdlflags', lddlflags='$lddlflags' + +!GROK!THIS! @@ -1 +0,0 @@ -/scalpel/lwall/netperl
\ No newline at end of file diff --git a/objtest b/objtest deleted file mode 100755 index c4e6205bf6..0000000000 --- a/objtest +++ /dev/null @@ -1,21 +0,0 @@ -#!./perl - -package OBJ; - -@ISA = BASEOBJ; - -$main'object = bless {FOO => foo, BAR => bar}; - -package main; - -$object->mymethod("BAR"); - -mymethod $object "FOO"; - -#&mymethod($object, "BAR"); - -sub BASEOBJ'mymethod { - local $ref = shift; - print ref $ref, "\n"; - print $ref->{shift}, "\n"; -} @@ -1,45 +1,31 @@ -/* $RCSfile: cmd.h,v $$Revision: 4.1 $$Date: 92/08/07 17:19:19 $ +/* op.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: cmd.h,v $ + */ + +/* + * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was + * our Mr. Bilbo's first cousin on the mother's side (her mother being the + * youngest of the Old Took's daughters); and Mr. Drogo was his second + * cousin. So Mr. Frodo is his first *and* second cousin, once removed + * either way, as the saying is, if you follow me." --the Gaffer */ #include "EXTERN.h" #include "perl.h" -/* Lowest byte of opargs */ -#define OA_MARK 1 -#define OA_FOLDCONST 2 -#define OA_RETSCALAR 4 -#define OA_TARGET 8 -#define OA_RETINTEGER 16 -#define OA_OTHERINT 32 -#define OA_DANGEROUS 64 - -/* Remaining nybbles of opargs */ -#define OA_SCALAR 1 -#define OA_LIST 2 -#define OA_AVREF 3 -#define OA_HVREF 4 -#define OA_CVREF 5 -#define OA_FILEREF 6 -#define OA_SCALARREF 7 -#define OA_OPTIONAL 8 - -void -cpy7bit(d,s,l) -register char *d; -register char *s; -register I32 l; -{ - while (l--) - *d++ = *s++ & 127; - *d = '\0'; -} +static I32 list_assignment _((OP *op)); +static OP *bad_type _((I32 n, char *t, OP *op, OP *kid)); +static OP *modkids _((OP *op, I32 type)); +static OP *no_fh_allowed _((OP *op)); +static OP *scalarboolean _((OP *op)); +static OP *too_few_arguments _((OP *op)); +static OP *too_many_arguments _((OP *op)); +static void null _((OP* op)); static OP * no_fh_allowed(op) @@ -77,19 +63,42 @@ OP *op; OP *kid; { sprintf(tokenbuf, "Type of arg %d to %s must be %s (not %s)", - n, op_name[op->op_type], t, op_name[kid->op_type]); + (int) n, op_name[op->op_type], t, op_name[kid->op_type]); yyerror(tokenbuf); return op; } +void +assertref(op) +OP *op; +{ + int type = op->op_type; + if (type != OP_AELEM && type != OP_HELEM) { + sprintf(tokenbuf, "Can't use %s as left arg of implicit ->", + op_name[type]); + yyerror(tokenbuf); + if (type == OP_RV2HV || type == OP_ENTERSUB) + warn("(Did you mean $ instead of %c?)\n", + type == OP_RV2HV ? '%' : '&'); + } +} + /* "register" allocation */ PADOFFSET pad_allocmy(name) char *name; { - PADOFFSET off = pad_alloc(OP_PADSV, SVs_PADMY); - SV *sv = NEWSV(0,0); + PADOFFSET off; + SV *sv; + + if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) { + if (!isprint(name[1])) + sprintf(name+1, "^%c", name[1] ^ 64); /* XXX is tokenbuf, really */ + croak("Can't use global %s in \"my\"",name); + } + off = pad_alloc(OP_PADSV, SVs_PADMY); + sv = NEWSV(1102,0); sv_upgrade(sv, SVt_PVNV); sv_setpv(sv, name); av_store(comppad_name, off, sv); @@ -115,7 +124,7 @@ char *name; SV **svp = AvARRAY(comppad_name); register I32 i; register CONTEXT *cx; - bool saweval; + int saweval; AV *curlist; AV *curname; CV *cv; @@ -124,6 +133,7 @@ char *name; /* The one we're looking for is probably just before comppad_name_fill. */ for (off = comppad_name_fill; off > 0; off--) { if ((sv = svp[off]) && + sv != &sv_undef && seq <= SvIVX(sv) && seq > (I32)SvNVX(sv) && strEQ(SvPVX(sv), name)) @@ -137,14 +147,14 @@ char *name; * XXX This will also probably interact badly with eval tree caching. */ - saweval = FALSE; + saweval = 0; for (i = cxstack_ix; i >= 0; i--) { cx = &cxstack[i]; switch (cx->cx_type) { default: break; case CXt_EVAL: - saweval = TRUE; + saweval = i; break; case CXt_SUB: if (!saweval) @@ -152,12 +162,13 @@ char *name; cv = cx->blk_sub.cv; if (debstash && CvSTASH(cv) == debstash) /* ignore DB'* scope */ continue; - seq = cxstack[i+1].blk_oldcop->cop_seq; + seq = cxstack[saweval].blk_oldcop->cop_seq; curlist = CvPADLIST(cv); curname = (AV*)*av_fetch(curlist, 0, FALSE); svp = AvARRAY(curname); for (off = AvFILL(curname); off > 0; off--) { if ((sv = svp[off]) && + sv != &sv_undef && seq <= SvIVX(sv) && seq > (I32)SvNVX(sv) && strEQ(SvPVX(sv), name)) @@ -165,7 +176,7 @@ char *name; PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY); AV *oldpad = (AV*)*av_fetch(curlist, CvDEPTH(cv), FALSE); SV *oldsv = *av_fetch(oldpad, off, TRUE); - SV *sv = NEWSV(0,0); + SV *sv = NEWSV(1103,0); sv_upgrade(sv, SVt_PVNV); sv_setpv(sv, name); av_store(comppad_name, newoff, sv); @@ -179,6 +190,31 @@ char *name; } } + if (!saweval) + return 0; + + /* It's stupid to dup this code. main should be stored in a CV. */ + seq = cxstack[saweval].blk_oldcop->cop_seq; + svp = AvARRAY(padname); + for (off = AvFILL(padname); off > 0; off--) { + if ((sv = svp[off]) && + sv != &sv_undef && + seq <= SvIVX(sv) && + seq > (I32)SvNVX(sv) && + strEQ(SvPVX(sv), name)) + { + PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY); + SV *oldsv = *av_fetch(pad, off, TRUE); + SV *sv = NEWSV(1103,0); + sv_upgrade(sv, SVt_PVNV); + sv_setpv(sv, name); + av_store(comppad_name, newoff, sv); + SvNVX(sv) = (double)curcop->cop_seq; + SvIVX(sv) = 999999999; /* A ref, intro immediately */ + av_store(comppad, newoff, SvREFCNT_inc(oldsv)); + return newoff; + } + } return 0; } @@ -191,13 +227,13 @@ I32 fill; SV *sv; if (min_intro_pending && fill < min_intro_pending) { for (off = max_intro_pending; off >= min_intro_pending; off--) { - if (sv = svp[off]) + if ((sv = svp[off]) && sv != &sv_undef) warn("%s never introduced", SvPVX(sv)); } } /* "Deintroduce" my variables that are leaving with this scope. */ for (off = AvFILL(comppad_name); off > fill; off--) { - if (sv = svp[off]) + if ((sv = svp[off]) && sv != &sv_undef) SvIVX(sv) = cop_seqmax; } } @@ -212,6 +248,8 @@ U32 tmptype; if (AvARRAY(comppad) != curpad) croak("panic: pad_alloc"); + if (pad_reset_pending) + pad_reset(); if (tmptype & SVs_PADMY) { do { sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE); @@ -226,17 +264,17 @@ U32 tmptype; } SvFLAGS(sv) |= tmptype; curpad = AvARRAY(comppad); - DEBUG_X(fprintf(stderr, "Pad alloc %d for %s\n", retval, op_name[optype])); + DEBUG_X(fprintf(stderr, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); return (PADOFFSET)retval; } SV * -#ifndef STANDARD_C +#ifndef CAN_PROTOTYPE pad_sv(po) PADOFFSET po; #else pad_sv(PADOFFSET po) -#endif /* STANDARD_C */ +#endif /* CAN_PROTOTYPE */ { if (!po) croak("panic: pad_sv po"); @@ -245,40 +283,43 @@ pad_sv(PADOFFSET po) } void -#ifndef STANDARD_C +#ifndef CAN_PROTOTYPE pad_free(po) PADOFFSET po; #else pad_free(PADOFFSET po) -#endif /* STANDARD_C */ +#endif /* CAN_PROTOTYPE */ { + if (!curpad) + return; if (AvARRAY(comppad) != curpad) croak("panic: pad_free curpad"); if (!po) croak("panic: pad_free po"); DEBUG_X(fprintf(stderr, "Pad free %d\n", po)); - if (curpad[po]) + if (curpad[po] && curpad[po] != &sv_undef) SvPADTMP_off(curpad[po]); - if (po < padix) + if ((I32)po < padix) padix = po - 1; } void -#ifndef STANDARD_C +#ifndef CAN_PROTOTYPE pad_swipe(po) PADOFFSET po; #else pad_swipe(PADOFFSET po) -#endif /* STANDARD_C */ +#endif /* CAN_PROTOTYPE */ { if (AvARRAY(comppad) != curpad) croak("panic: pad_swipe curpad"); if (!po) croak("panic: pad_swipe po"); DEBUG_X(fprintf(stderr, "Pad swipe %d\n", po)); - curpad[po] = NEWSV(0,0); SvPADTMP_off(curpad[po]); - if (po < padix) + curpad[po] = NEWSV(1107,0); + SvPADTMP_on(curpad[po]); + if ((I32)po < padix) padix = po - 1; } @@ -290,11 +331,12 @@ pad_reset() if (AvARRAY(comppad) != curpad) croak("panic: pad_reset curpad"); DEBUG_X(fprintf(stderr, "Pad reset\n")); - for (po = AvMAX(comppad); po > 0; po--) { - if (curpad[po]) + for (po = AvMAX(comppad); po > padix_floor; po--) { + if (curpad[po] && curpad[po] != &sv_undef) SvPADTMP_off(curpad[po]); } - padix = 0; + padix = padix_floor; + pad_reset_pending = FALSE; } /* Destructor */ @@ -320,9 +362,12 @@ OP *op; case OP_NULL: op->op_targ = 0; /* Was holding old type, if any. */ break; + case OP_ENTEREVAL: + op->op_targ = 0; /* Was holding hints. */ + break; case OP_GVSV: case OP_GV: - SvREFCNT_dec((SV*)cGVOP->op_gv); + SvREFCNT_dec(cGVOP->op_gv); break; case OP_NEXTSTATE: case OP_DBSTATE: @@ -331,6 +376,17 @@ OP *op; case OP_CONST: SvREFCNT_dec(cSVOP->op_sv); break; + case OP_TRANS: + Safefree(cPVOP->op_pv); + break; + case OP_SUBST: + op_free(cPMOP->op_pmreplroot); + /* FALL THROUGH */ + case OP_MATCH: + regfree(cPMOP->op_pmregexp); + break; + default: + break; } if (op->op_targ > 0) @@ -350,17 +406,6 @@ OP* op; op->op_ppaddr = ppaddr[OP_NULL]; } -static void -unlist(op) -OP* op; -{ - OP* kid = cLISTOP->op_first; - assert(kid->op_type == OP_PUSHMARK); - cLISTOP->op_first = kid->op_sibling; - null(kid); - null(op); -} - /* Contextualizers */ #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) @@ -402,13 +447,19 @@ OP *op; return op; } -OP * +static OP * scalarboolean(op) OP *op; { if (dowarn && - op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) - warn("Found = in conditional, should be =="); + op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) { + line_t oldline = curcop->cop_line; + + if (copline != NOLINE) + curcop->cop_line = copline; + warn("Found = in conditional, should be =="); + curcop->cop_line = oldline; + } return scalar(op); } @@ -418,7 +469,8 @@ OP *op; { OP *kid; - if (!op || (op->op_flags & OPf_KNOW)) /* assumes no premature commitment */ + /* assumes no premature commitment */ + if (!op || (op->op_flags & OPf_KNOW) || error_count) return op; op->op_flags &= ~OPf_LIST; @@ -434,6 +486,12 @@ OP *op; for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) scalar(kid); break; + case OP_SPLIT: + if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { + if (!kPMOP->op_pmreplroot) + deprecate("implicit split to @_"); + } + /* FALL THROUGH */ case OP_MATCH: case OP_SUBST: case OP_NULL: @@ -468,7 +526,7 @@ OP *op; char* useless = 0; SV* sv; - if (!op) + if (!op || error_count) return op; if (op->op_flags & OPf_LIST) return op; @@ -492,6 +550,8 @@ OP *op; case OP_AV2ARYLEN: case OP_SV2LEN: case OP_REF: + case OP_REFGEN: + case OP_SREFGEN: case OP_DEFINED: case OP_HEX: case OP_OCT: @@ -551,7 +611,7 @@ OP *op; case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: - if (!(op->op_flags & OPf_INTRO)) + if (!(op->op_private & OPpLVAL_INTRO)) useless = op_name[op->op_type]; break; @@ -559,7 +619,7 @@ OP *op; case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: - if (!(op->op_flags & OPf_INTRO) && + if (!(op->op_private & OPpLVAL_INTRO) && (!op->op_sibling || op->op_sibling->op_type != OP_READLINE)) useless = "a variable"; break; @@ -577,6 +637,7 @@ OP *op; useless = 0; else if (SvPOK(sv)) { if (strnEQ(SvPVX(sv), "di", 2) || + strnEQ(SvPVX(sv), "ds", 2) || strnEQ(SvPVX(sv), "ig", 2)) useless = 0; } @@ -606,20 +667,30 @@ OP *op; for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) scalarvoid(kid); break; + case OP_NULL: + if (op->op_flags & OPf_STACKED) + break; case OP_ENTERTRY: case OP_ENTER: case OP_SCALAR: - case OP_NULL: if (!(op->op_flags & OPf_KIDS)) break; case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: + case OP_LEAVELOOP: + op->op_private |= OPpLEAVE_VOID; case OP_LINESEQ: case OP_LIST: for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) scalarvoid(kid); break; + case OP_SPLIT: + if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { + if (!kPMOP->op_pmreplroot) + deprecate("implicit split to @_"); + } + break; } if (useless && dowarn) warn("Useless use of %s in void context", useless); @@ -644,7 +715,8 @@ OP *op; { OP *kid; - if (!op || (op->op_flags & OPf_KNOW)) /* assumes no premature commitment */ + /* assumes no premature commitment */ + if (!op || (op->op_flags & OPf_KNOW) || error_count) return op; op->op_flags |= (OPf_KNOW | OPf_LIST); @@ -717,7 +789,7 @@ OP *op; return op; } -OP * +static OP * modkids(op, type) OP *op; I32 type; @@ -739,14 +811,31 @@ I32 type; { OP *kid; SV *sv; + char mtype; - if (!op) + if (!op || error_count) return op; switch (op->op_type) { - case OP_ENTERSUBR: - if ((type == OP_UNDEF) && !(op->op_flags & OPf_STACKED)) { - op->op_type = OP_RV2CV; /* entersubr => rv2cv */ + case OP_CONST: + if (!(op->op_flags & (OPf_SPECIAL|OPf_MOD))) + goto nomod; + if (eval_start && eval_start->op_type == OP_CONST) { + compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv); + eval_start = 0; + } + else if (!type) { + SAVEI32(compiling.cop_arybase); + } + else if (type == OP_REFGEN) + goto nomod; + else + croak("That use of $[ is unsupported"); + break; + case OP_ENTERSUB: + if ((type == OP_UNDEF || type == OP_REFGEN) && + !(op->op_flags & OPf_STACKED)) { + op->op_type = OP_RV2CV; /* entersub => rv2cv */ op->op_ppaddr = ppaddr[OP_RV2CV]; assert(cUNOP->op_first->op_type == OP_NULL); null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */ @@ -754,12 +843,41 @@ I32 type; } /* FALL THROUGH */ default: + nomod: + /* grep, foreach, subcalls, refgen */ + if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) + break; sprintf(tokenbuf, "Can't modify %s in %s", op_name[op->op_type], type ? op_name[type] : "local"); yyerror(tokenbuf); return op; + case OP_PREINC: + case OP_PREDEC: + case OP_POW: + case OP_MULTIPLY: + case OP_DIVIDE: + case OP_MODULO: + case OP_REPEAT: + case OP_ADD: + case OP_SUBTRACT: + case OP_CONCAT: + case OP_LEFT_SHIFT: + case OP_RIGHT_SHIFT: + case OP_BIT_AND: + case OP_BIT_XOR: + case OP_BIT_OR: + case OP_I_MULTIPLY: + case OP_I_DIVIDE: + case OP_I_MODULO: + case OP_I_ADD: + case OP_I_SUBTRACT: + if (!(op->op_flags & OPf_STACKED)) + goto nomod; + modcount++; + break; + case OP_COND_EXPR: for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); @@ -768,25 +886,23 @@ I32 type; case OP_RV2AV: case OP_RV2HV: case OP_RV2GV: - op->op_private = (hints & HINT_STRICT_REFS); ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ + case OP_PADAV: + case OP_PADHV: case OP_AASSIGN: case OP_ASLICE: case OP_HSLICE: case OP_NEXTSTATE: case OP_DBSTATE: + case OP_REFGEN: + case OP_CHOMP: modcount = 10000; break; case OP_RV2SV: - op->op_private = (hints & HINT_STRICT_REFS); - if (type == OP_RV2AV || type == OP_RV2HV) - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ case OP_PADSV: - case OP_PADAV: - case OP_PADHV: case OP_UNDEF: case OP_GV: case OP_AV2ARYLEN: @@ -795,54 +911,65 @@ I32 type; modcount++; break; - case OP_REFGEN: - modcount++; - break; - case OP_PUSHMARK: break; - case OP_SUBSTR: + + case OP_POS: + mtype = '.'; + goto makelv; case OP_VEC: + mtype = 'v'; + goto makelv; + case OP_SUBSTR: + mtype = 'x'; + makelv: pad_free(op->op_targ); op->op_targ = pad_alloc(op->op_type, SVs_PADMY); sv = PAD_SV(op->op_targ); sv_upgrade(sv, SVt_PVLV); - sv_magic(sv, 0, op->op_type == OP_VEC ? 'v' : 'x', 0, 0); + sv_magic(sv, Nullsv, mtype, Nullch, 0); curpad[op->op_targ] = sv; - /* FALL THROUGH */ - case OP_NULL: if (op->op_flags & OPf_KIDS) mod(cBINOP->op_first, type); break; + case OP_AELEM: case OP_HELEM: ref(cBINOP->op_first, op->op_type); - op->op_private = (hints & HINT_STRICT_REFS); - if (type == OP_RV2AV || type == OP_RV2HV) - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); + modcount++; break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: + if (op->op_flags & OPf_KIDS) + mod(cLISTOP->op_last, type); + break; + + case OP_NULL: if (!(op->op_flags & OPf_KIDS)) break; - mod(cLISTOP->op_last, type); - break; - + if (op->op_targ != OP_LIST) { + mod(cBINOP->op_first, type); + break; + } + /* FALL THROUGH */ case OP_LIST: for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; } - op->op_flags |= OPf_LVAL; - if (!type) { + op->op_flags |= OPf_MOD; + + if (type == OP_AASSIGN || type == OP_SASSIGN) + op->op_flags |= OPf_SPECIAL|OPf_REF; + else if (!type) { + op->op_private |= OPpLVAL_INTRO; op->op_flags &= ~OPf_SPECIAL; - op->op_flags |= OPf_INTRO; } - else if (type == OP_AASSIGN || type == OP_SASSIGN) - op->op_flags |= OPf_SPECIAL; + else if (type != OP_GREPSTART && type != OP_ENTERSUB) + op->op_flags |= OPf_REF; return op; } @@ -865,16 +992,15 @@ OP *op; I32 type; { OP *kid; - SV *sv; - if (!op) + if (!op || error_count) return op; switch (op->op_type) { - case OP_ENTERSUBR: - if ((type == OP_REFGEN || type == OP_DEFINED) - && !(op->op_flags & (OPf_STACKED|OPf_PARENS))) { - op->op_type = OP_RV2CV; /* entersubr => rv2cv */ + case OP_ENTERSUB: + if ((type == OP_DEFINED) && + !(op->op_flags & OPf_STACKED)) { + op->op_type = OP_RV2CV; /* entersub => rv2cv */ op->op_ppaddr = ppaddr[OP_RV2CV]; assert(cUNOP->op_first->op_type == OP_NULL); null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */ @@ -886,24 +1012,24 @@ I32 type; ref(kid, type); break; case OP_RV2SV: - op->op_private = (hints & HINT_STRICT_REFS); - if (type == OP_RV2AV || type == OP_RV2HV) - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); ref(cUNOP->op_first, op->op_type); + if (type == OP_RV2AV || type == OP_RV2HV) { + op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); + op->op_flags |= OPf_MOD; + } break; case OP_RV2AV: case OP_RV2HV: - op->op_flags |= OPf_LVAL; + op->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: - op->op_private = (hints & HINT_STRICT_REFS); ref(cUNOP->op_first, op->op_type); break; case OP_PADAV: case OP_PADHV: - op->op_flags |= OPf_LVAL; + op->op_flags |= OPf_REF; break; case OP_SCALAR: @@ -915,11 +1041,9 @@ I32 type; case OP_AELEM: case OP_HELEM: ref(cBINOP->op_first, op->op_type); - op->op_private = (hints & HINT_STRICT_REFS); - if (type == OP_RV2AV || type == OP_RV2HV || type == OP_REFGEN) { - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : - type == OP_RV2HV ? OPpDEREF_HV : 0); - op->op_flags |= OPf_LVAL; + if (type == OP_RV2AV || type == OP_RV2HV) { + op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); + op->op_flags |= OPf_MOD; } break; @@ -931,6 +1055,8 @@ I32 type; break; ref(cLISTOP->op_last, type); break; + default: + break; } return scalar(op); @@ -941,10 +1067,9 @@ my(op) OP *op; { OP *kid; - SV *sv; I32 type; - if (!op) + if (!op || error_count) return op; type = op->op_type; @@ -961,7 +1086,8 @@ OP *op; yyerror(tokenbuf); return op; } - op->op_flags |= OPf_LVAL|OPf_INTRO; + op->op_flags |= OPf_MOD; + op->op_private |= OPpLVAL_INTRO; return op; } @@ -989,7 +1115,7 @@ OP *right; if (right->op_type != OP_MATCH) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) - op = newBINOP(OP_NULL, 0, scalar(left), right); + op = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); else op = prepend_elem(right->op_type, scalar(left), right); if (type == OP_NOT) @@ -1016,7 +1142,7 @@ scope(o) OP *o; { if (o) { - if (o->op_flags & OPf_PARENS) { + if (o->op_flags & OPf_PARENS || perldb) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = ppaddr[OP_LEAVE]; @@ -1037,21 +1163,62 @@ OP *o; return o; } -OP * -block_head(o, startp) -OP *o; -OP **startp; +int +block_start() { - if (!o) { - *startp = 0; - return o; + int retval = savestack_ix; + comppad_name_fill = AvFILL(comppad_name); + SAVEINT(min_intro_pending); + SAVEINT(max_intro_pending); + min_intro_pending = 0; + SAVEINT(comppad_name_fill); + SAVEINT(padix_floor); + padix_floor = padix; + pad_reset_pending = FALSE; + SAVEINT(hints); + hints &= ~HINT_BLOCK_SCOPE; + return retval; +} + +OP* +block_end(line, floor, seq) +int line; +int floor; +OP* seq; +{ + int needblockscope = hints & HINT_BLOCK_SCOPE; + OP* retval = scalarseq(seq); + if (copline > (line_t)line) + copline = line; + LEAVE_SCOPE(floor); + pad_reset_pending = FALSE; + if (needblockscope) + hints |= HINT_BLOCK_SCOPE; /* propagate out */ + pad_leavemy(comppad_name_fill); + return retval; +} + +void +newPROG(op) +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); + } + else { + if (!op) { + main_start = 0; + return; + } + main_root = scope(sawparens(scalarvoid(op))); + curcop = &compiling; + main_start = LINKLIST(main_root); + main_root->op_next = 0; + peep(main_start); } - o = scope(sawparens(scalarvoid(o))); - curcop = &compiling; - *startp = LINKLIST(o); - o->op_next = 0; - peep(*startp); - return o; } OP * @@ -1066,7 +1233,7 @@ I32 lex; if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') { char *s; for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ; - if (*s == ';' || *s == '=' && (s[1] == '@' || s[2] == '@')) + if (*s == ';' || *s == '=') warn("Parens missing around \"%s\" list", lex ? "my" : "local"); } } @@ -1096,7 +1263,6 @@ register OP *o; { register OP *curop; I32 type = o->op_type; - SV *sv; if (opargs[type] & OA_RETSCALAR) scalar(o); @@ -1104,15 +1270,19 @@ register OP *o; o->op_targ = pad_alloc(type, SVs_PADTMP); if ((opargs[type] & OA_OTHERINT) && (hints & HINT_INTEGER)) - o->op_ppaddr = ppaddr[++(o->op_type)]; + o->op_ppaddr = ppaddr[type = ++(o->op_type)]; if (!(opargs[type] & OA_FOLDCONST)) goto nope; + if (error_count) + goto nope; /* Don't try to run w/ errors */ + for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { if (curop->op_type != OP_CONST && curop->op_type != OP_LIST && curop->op_type != OP_SCALAR && + curop->op_type != OP_NULL && curop->op_type != OP_PUSHMARK) { goto nope; } @@ -1125,7 +1295,7 @@ register OP *o; if (o->op_targ && *stack_sp == PAD_SV(o->op_targ)) /* grab pad temp? */ pad_swipe(o->op_targ); else if (SvTEMP(*stack_sp)) { /* grab mortal temp? */ - SvREFCNT_inc(*stack_sp); + (void)SvREFCNT_inc(*stack_sp); SvTEMP_off(*stack_sp); } op_free(o); @@ -1139,7 +1309,7 @@ register OP *o; return o; if (!(hints & HINT_INTEGER)) { - if (!(o->op_flags & OPf_KIDS)) + if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS)) return o; for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) { @@ -1152,9 +1322,9 @@ register OP *o; continue; return o; } + o->op_ppaddr = ppaddr[++(o->op_type)]; } - o->op_ppaddr = ppaddr[++(o->op_type)]; return o; } @@ -1163,34 +1333,25 @@ gen_constant_list(o) register OP *o; { register OP *curop; - OP *anonop; - I32 tmpmark; - I32 tmpsp; I32 oldtmps_floor = tmps_floor; - AV *av; - GV *gv; - tmpmark = stack_sp - stack_base; - anonop = newANONLIST(o); - curop = LINKLIST(anonop); - anonop->op_next = 0; - op = curop; + list(o); + if (error_count) + return o; /* Don't attempt to run with errors */ + + op = curop = LINKLIST(o); + o->op_next = 0; + pp_pushmark(); run(); - tmpsp = stack_sp - stack_base; + op = curop; + pp_anonlist(); tmps_floor = oldtmps_floor; - stack_sp = stack_base + tmpmark; o->op_type = OP_RV2AV; o->op_ppaddr = ppaddr[OP_RV2AV]; - o->op_sibling = 0; curop = ((UNOP*)o)->op_first; - ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, newSVsv(stack_sp[1])); + ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*stack_sp--)); op_free(curop); - curop = ((UNOP*)anonop)->op_first; - curop = ((UNOP*)curop)->op_first; - curop->op_sibling = 0; - op_free(anonop); - o->op_next = 0; linklist(o); return list(o); } @@ -1202,7 +1363,7 @@ I32 flags; OP* op; { OP *kid; - OP *last; + OP *last = 0; if (!op || op->op_type != OP_LIST) op = newLISTOP(OP_LIST, 0, op, Nullop); @@ -1242,19 +1403,18 @@ OP* last; if (!last) return first; - if (first->op_type == type) { - if (first->op_flags & OPf_KIDS) - ((LISTOP*)first)->op_last->op_sibling = last; - else { - first->op_flags |= OPf_KIDS; - ((LISTOP*)first)->op_first = last; - } - ((LISTOP*)first)->op_last = last; - ((LISTOP*)first)->op_children++; - return first; - } + if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS) + return newLISTOP(type, 0, first, last); - return newLISTOP(type, 0, first, last); + if (first->op_flags & OPf_KIDS) + ((LISTOP*)first)->op_last->op_sibling = last; + else { + first->op_flags |= OPf_KIDS; + ((LISTOP*)first)->op_first = last; + } + ((LISTOP*)first)->op_last = last; + ((LISTOP*)first)->op_children++; + return first; } OP * @@ -1406,8 +1566,6 @@ OP* first; first = newOP(OP_STUB, 0); if (opargs[type] & OA_MARK) first = force_list(first); - else if (first->op_type == OP_LIST) - unlist(first); Newz(1101, unop, 1, UNOP); unop->op_type = type; @@ -1420,7 +1578,7 @@ OP* first; if (unop->op_next) return (OP*)unop; - return fold_constants(unop); + return fold_constants((OP *) unop); } OP * @@ -1455,7 +1613,7 @@ OP* last; binop->op_last = last = binop->op_first->op_sibling; - return fold_constants(binop); + return fold_constants((OP *)binop); } OP * @@ -1464,7 +1622,6 @@ OP *op; OP *expr; OP *repl; { - PMOP *pm = (PMOP*)op; SV *tstr = ((SVOP*)expr)->op_sv; SV *rstr = ((SVOP*)repl)->op_sv; STRLEN tlen; @@ -1541,7 +1698,7 @@ I32 flags; pmop->op_private = 0; /* link into pm list */ - if (type != OP_TRANS) { + if (type != OP_TRANS && curstash) { pmop->op_pmnext = HvPMROOT(curstash); HvPMROOT(curstash) = pmop; } @@ -1572,10 +1729,12 @@ OP *repl; p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } +#ifdef NOTDEF scan_prefix(pm, p, plen); if (pm->op_pmshort && (pm->op_pmflags & PMf_SCANFIRST)) fbm_compile(pm->op_pmshort, pm->op_pmflags & PMf_FOLD); - pm->op_pmregexp = regcomp(p, p + plen, pm->op_pmflags & PMf_FOLD); +#endif + pm->op_pmregexp = regcomp(p, p + plen, pm); if (strEQ("\\s+", pm->op_pmregexp->precomp)) pm->op_pmflags |= PMf_WHITE; hoistmust(pm); @@ -1757,8 +1916,8 @@ OP *op; STRLEN len; char *name; sv = cSVOP->op_sv; - curstash = fetch_stash(sv,TRUE); name = SvPV(sv, len); + curstash = gv_stashpv(name,TRUE); sv_setpvn(curstname, name, len); op_free(op); } @@ -1771,82 +1930,48 @@ OP *op; } void -hint(aver, id, arg) +utilize(aver, id, arg) int aver; OP *id; OP *arg; { - SV *sv; - U32 bits = 0; - SV **sp = 0; - SV **mark = 0; - - if (arg) { - OP* curop = LINKLIST(arg); - arg->op_next = 0; - op = curop; - run(); - sp = stack_sp; - mark = stack_base + POPMARK; - stack_sp = mark; /* Might as well reset sp now. */ - } - if (id) { - STRLEN len; - char *name; - sv = ((SVOP*)id)->op_sv; - name = SvPV(sv, len); + OP *pack; + OP *meth; + OP *rqop; + OP *imop; - if (strEQ(name, "integer")) - bits = HINT_INTEGER; - else if (strEQ(name, "strict")) { - if (arg) { - while (++mark <= sp) { - if (strEQ(SvPV(*mark,na), "refs")) - bits |= HINT_STRICT_REFS; - else if (strEQ(SvPV(*mark,na), "subs")) - bits |= HINT_STRICT_SUBS; - else if (strEQ(SvPV(*mark,na), "vars")) - bits |= HINT_STRICT_VARS; - } - } - else - bits = HINT_STRICT_REFS|HINT_STRICT_SUBS|HINT_STRICT_VARS; - } + if (id->op_type != OP_CONST) + croak("Module name must be constant"); - if (aver) - hints |= bits; - else - hints &= ~bits; + meth = newSVOP(OP_CONST, 0, + aver + ? newSVpv("import", 6) + : newSVpv("unimport", 8) + ); + + /* Make copy of id so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); + + /* Fake up a require */ + rqop = newUNOP(OP_REQUIRE, 0, id); + + /* Fake up an import/unimport */ + imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(arg)), + newUNOP(OP_METHOD, 0, meth))); + + /* Fake up the BEGIN {}, which does its thing immediately. */ + newSUB(start_subparse(), + newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)), + append_elem(OP_LINESEQ, + newSTATEOP(0, Nullch, rqop), + newSTATEOP(0, Nullch, imop) )); - op_free(id); - } - if (arg) - op_free(arg); copline = NOLINE; expect = XSTATE; } -HV* -fetch_stash(sv,create) -SV *sv; -I32 create; -{ - char tmpbuf[256]; - HV *stash; - GV *tmpgv; - char *name = SvPV(sv, na); - sprintf(tmpbuf,"%s::",name); - tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV); - if (!tmpgv) - return 0; - if (!GvHV(tmpgv)) - GvHV(tmpgv) = newHV(); - stash = GvHV(tmpgv); - if (!HvNAME(stash)) - HvNAME(stash) = savestr(name); - return stash; -} - OP * newSLICEOP(flags, subscript, listval) I32 flags; @@ -1894,20 +2019,41 @@ register OP *op; } OP * -newASSIGNOP(flags, left, right) +newASSIGNOP(flags, left, optype, right) I32 flags; OP *left; +I32 optype; OP *right; { OP *op; + if (optype) { + if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) { + return newLOGOP(optype, 0, + mod(scalar(left), optype), + newUNOP(OP_SASSIGN, 0, scalar(right))); + } + else { + return newBINOP(optype, OPf_STACKED, + mod(scalar(left), optype), scalar(right)); + } + } + if (list_assignment(left)) { modcount = 0; + eval_start = right; /* Grandfathering $[ assignment here. Bletch. */ left = mod(left, OP_AASSIGN); + if (!eval_start) { + op_free(left); + op_free(right); + return Nullop; + } if (right && right->op_type == OP_SPLIT) { if ((op = ((LISTOP*)right)->op_first) && op->op_type == OP_PUSHRE) { PMOP *pm = (PMOP*)op; - if (left->op_type == OP_RV2AV) { + if (left->op_type == OP_RV2AV && + !(left->op_private & OPpLVAL_INTRO) ) + { op = ((UNOP*)left)->op_first; if (op->op_type == OP_GV && !pm->op_pmreplroot) { pm->op_pmreplroot = (OP*)((GVOP*)op)->op_gv; @@ -1929,7 +2075,7 @@ OP *right; list(force_list(right)), list(force_list(left)) ); op->op_private = 0; - if (!(left->op_flags & OPf_INTRO)) { + if (!(left->op_private & OPpLVAL_INTRO)) { static int generation = 0; OP *curop; OP *lastop = op; @@ -1967,9 +2113,15 @@ OP *right; right->op_flags |= OPf_STACKED; return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); } - else + else { + eval_start = right; /* Grandfathering $[ assignment here. Bletch. */ op = newBINOP(OP_SASSIGN, flags, scalar(right), mod(scalar(left), OP_SASSIGN) ); + if (!eval_start) { + op_free(op); + return Nullop; + } + } return op; } @@ -1987,7 +2139,7 @@ OP *op; I32 i; SV *sv; for (i = min_intro_pending; i <= max_intro_pending; i++) { - if (sv = svp[i]) + if ((sv = svp[i]) && sv != &sv_undef) SvIVX(sv) = 999999999; /* Don't know scope end yet. */ } min_intro_pending = 0; @@ -2012,6 +2164,7 @@ OP *op; hints |= HINT_BLOCK_SCOPE; } cop->cop_seq = cop_seqmax++; + cop->cop_arybase = curcop->cop_arybase; if (copline == NOLINE) cop->cop_line = curcop->cop_line; @@ -2026,7 +2179,7 @@ OP *op; SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE); if (svp && *svp != &sv_undef && !SvIOK(*svp)) { SvIVX(*svp) = 1; - SvIOK_on(*svp); + (void)SvIOK_on(*svp); SvSTASH(*svp) = (HV*)cop; } } @@ -2044,6 +2197,9 @@ OP* other; LOGOP *logop; OP *op; + if (type == OP_XOR) /* Not short circuit, but here by precedence. */ + return newBINOP(type, flags, scalar(first), scalar(other)); + scalarboolean(first); /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { @@ -2082,6 +2238,9 @@ OP* other; if (!other) return first; + if (type == OP_ANDASSIGN || type == OP_ORASSIGN) + other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ + Newz(1101, logop, 1, LOGOP); logop->op_type = type; @@ -2215,13 +2374,13 @@ OP *block; OP* listop; OP* op; int once = block && block->op_flags & OPf_SPECIAL && - (block->op_type == OP_ENTERSUBR || block->op_type == OP_NULL); + (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) return block; /* do {} while 0 does once */ else if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) - expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), expr); + expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr); } listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); @@ -2233,7 +2392,9 @@ OP *block; op->op_next = ((LOGOP*)cUNOP->op_first)->op_other; op->op_flags |= flags; - return scope(op); + op = scope(op); + op->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration */ + return op; } OP * @@ -2252,7 +2413,7 @@ OP *cont; OP *condop; if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) - expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), expr); + expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr); if (!block) block = newOP(OP_NULL, 0); @@ -2303,7 +2464,7 @@ OP *cont; } OP * -#ifndef STANDARD_C +#ifndef CAN_PROTOTYPE newFOROP(flags,label,forline,sv,expr,block,cont) I32 flags; char *label; @@ -2314,7 +2475,7 @@ OP*block; OP*cont; #else newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) -#endif /* STANDARD_C */ +#endif /* CAN_PROTOTYPE */ { LOOP *loop; int padoff = 0; @@ -2340,7 +2501,8 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont sv = newGVOP(OP_GV, 0, defgv); } loop = (LOOP*)list(convert(OP_ENTERITER, 0, - append_elem(OP_LIST, force_list(expr), scalar(sv)))); + append_elem(OP_LIST, mod(force_list(expr), OP_GREPSTART), + scalar(sv)))); assert(!loop->op_next); Renew(loop, 1, LOOP); loop->op_targ = padoff; @@ -2355,12 +2517,15 @@ OP* label; { OP *op; if (type != OP_GOTO || label->op_type == OP_CONST) { - op = newPVOP(type, 0, savestr(SvPVx(((SVOP*)label)->op_sv, na))); + op = newPVOP(type, 0, savepv( + label->op_type == OP_CONST + ? SvPVx(((SVOP*)label)->op_sv, na) + : "" )); op_free(label); } else { - if (label->op_type == OP_ENTERSUBR) - label = newUNOP(OP_REFGEN, 0, ref(label, OP_REFGEN)); + if (label->op_type == OP_ENTERSUB) + label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); op = newUNOP(type, OPf_STACKED, label); } hints |= HINT_BLOCK_SCOPE; @@ -2371,53 +2536,50 @@ void cv_undef(cv) CV *cv; { - if (!CvUSERSUB(cv) && CvROOT(cv)) { + if (!CvXSUB(cv) && CvROOT(cv)) { + if (CvDEPTH(cv)) + croak("Can't undef active subroutine"); ENTER; - if (CvPADLIST(cv)) { - SV** svp = av_fetch(CvPADLIST(cv), 0, FALSE); - if (svp) { - SAVESPTR(comppad); - SAVESPTR(curpad); - comppad = (AV*)*svp; /* Need same context we had compiling */ - curpad = AvARRAY(comppad); - } - } + + SAVESPTR(curpad); + curpad = 0; + op_free(CvROOT(cv)); CvROOT(cv) = Nullop; - if (CvDEPTH(cv)) - warn("Deleting active subroutine"); /* XXX */ if (CvPADLIST(cv)) { I32 i = AvFILL(CvPADLIST(cv)); - while (i > 0) { + while (i >= 0) { SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); if (svp) - sv_free(*svp); + SvREFCNT_dec(*svp); } - sv_free(CvPADLIST(cv)); + SvREFCNT_dec((SV*)CvPADLIST(cv)); } SvREFCNT_dec(CvGV(cv)); LEAVE; } } -void +CV * newSUB(floor,op,block) I32 floor; OP *op; OP *block; { register CV *cv; - char *name = SvPVx(cSVOP->op_sv, na); - GV *gv = gv_fetchpv(name,2, SVt_PVCV); + char *name = op ? SvPVx(cSVOP->op_sv, na) : "__ANON__"; + GV *gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PVCV); AV* av; char *s; + I32 ix; - sub_generation++; - if ((cv = GvCV(gv)) && !GvCVGEN(gv)) { - if (CvDEPTH(cv)) - CvDELETED(cv) = TRUE; /* probably an autoloader */ - else { - if (dowarn && CvROOT(cv)) { + if (op) + sub_generation++; + if (cv = GvCV(gv)) { + if (GvCVGEN(gv)) + cv = 0; /* just a cached method */ + else if (CvROOT(cv)) { /* already defined? */ + if (dowarn) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; @@ -2425,45 +2587,54 @@ OP *block; curcop->cop_line = oldline; } SvREFCNT_dec(cv); + cv = 0; } } - Newz(101,cv,1,CV); - sv_upgrade(cv, SVt_PVCV); - SvREFCNT(cv) = 1; + if (cv) { /* must reuse cv if autoloaded */ + assert(SvREFCNT(CvGV(cv)) > 1); + SvREFCNT_dec(CvGV(cv)); + } + else { + cv = (CV*)NEWSV(1104,0); + sv_upgrade((SV *)cv, SVt_PVCV); + } GvCV(gv) = cv; GvCVGEN(gv) = 0; CvFILEGV(cv) = curcop->cop_filegv; CvGV(cv) = SvREFCNT_inc(gv); CvSTASH(cv) = curstash; - av = newAV(); - av_store(av, 0, Nullsv); + if (!block) { + CvROOT(cv) = 0; + op_free(op); + copline = NOLINE; + LEAVE_SCOPE(floor); + return cv; + } + + av = newAV(); /* Will be @_ */ + av_extend(av, 0); av_store(comppad, 0, (SV*)av); - SvOK_on(av); - AvREAL_off(av); + AvFLAGS(av) = AVf_REIFY; + + for (ix = AvFILL(comppad); ix > 0; ix--) { + if (!SvPADMY(curpad[ix])) + SvPADTMP_on(curpad[ix]); + } av = newAV(); AvREAL_off(av); if (AvFILL(comppad_name) < AvFILL(comppad)) av_store(comppad_name, AvFILL(comppad), Nullsv); - av_store(av, 0, (SV*)comppad_name); - av_store(av, 1, (SV*)comppad); + av_store(av, 0, SvREFCNT_inc((SV*)comppad_name)); + av_store(av, 1, SvREFCNT_inc((SV*)comppad)); AvFILL(av) = 1; CvPADLIST(cv) = av; - comppad_name = newAV(); - if (!block) { - CvROOT(cv) = 0; - op_free(op); - copline = NOLINE; - LEAVE_SCOPE(floor); - return; - } - CvROOT(cv) = newUNOP(OP_LEAVESUBR, 0, scalarseq(block)); + CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - CvDELETED(cv) = FALSE; if (s = strrchr(name,':')) s++; else @@ -2502,7 +2673,7 @@ OP *block; SV *sv; SV *tmpstr = sv_newmortal(); - sprintf(buf,"%s:%ld",SvPVX(GvSV(curcop->cop_filegv)), subline); + sprintf(buf,"%s:%ld",SvPVX(GvSV(curcop->cop_filegv)), (long)subline); sv = newSVpv(buf,0); sv_catpv(sv,"-"); sprintf(buf,"%ld",(long)curcop->cop_line); @@ -2513,40 +2684,69 @@ OP *block; op_free(op); copline = NOLINE; LEAVE_SCOPE(floor); + if (!op) + GvCV(gv) = 0; /* Will remember in SVOP instead. */ + return cv; } -void +#ifdef DEPRECATED +CV * newXSUB(name, ix, subaddr, filename) char *name; I32 ix; I32 (*subaddr)(); char *filename; { + CV* cv = newXS(name, (void(*)())subaddr, filename); + CvOLDSTYLE(cv) = TRUE; + CvXSUBANY(cv).any_i32 = ix; + return cv; +} +#endif + +CV * +newXS(name, subaddr, filename) +char *name; +void (*subaddr) _((CV*)); +char *filename; +{ register CV *cv; - GV *gv = gv_fetchpv(name,2, SVt_PVCV); + GV *gv = gv_fetchpv((name ? name : "__ANON__"), GV_ADDMULTI, SVt_PVCV); char *s; - sub_generation++; - if ((cv = GvCV(gv)) && !GvCVGEN(gv)) { - if (dowarn) - warn("Subroutine %s redefined",name); - if (!CvUSERSUB(cv) && CvROOT(cv)) { - op_free(CvROOT(cv)); - CvROOT(cv) = Nullop; + if (name) + sub_generation++; + if (cv = GvCV(gv)) { + if (GvCVGEN(gv)) + cv = 0; /* just a cached method */ + else if (CvROOT(cv)) { /* already defined? */ + if (dowarn) { + line_t oldline = curcop->cop_line; + + curcop->cop_line = copline; + warn("Subroutine %s redefined",name); + curcop->cop_line = oldline; + } + SvREFCNT_dec(cv); + cv = 0; } - Safefree(cv); } - Newz(101,cv,1,CV); - sv_upgrade(cv, SVt_PVCV); - SvREFCNT(cv) = 1; + if (cv) { /* must reuse cv if autoloaded */ + assert(SvREFCNT(CvGV(cv)) > 1); + SvREFCNT_dec(CvGV(cv)); + } + else { + cv = (CV*)NEWSV(1105,0); + sv_upgrade((SV *)cv, SVt_PVCV); + } GvCV(gv) = cv; CvGV(cv) = SvREFCNT_inc(gv); GvCVGEN(gv) = 0; CvFILEGV(cv) = gv_fetchfile(filename); - CvUSERSUB(cv) = subaddr; - CvUSERINDEX(cv) = ix; - CvDELETED(cv) = FALSE; - if (s = strrchr(name,':')) + CvXSUB(cv) = subaddr; + if (!name) + s = "__ANON__"; + else if (s = strrchr(name,':')) s++; else s = name; @@ -2561,6 +2761,9 @@ char *filename; av_unshift(endav, 1); av_store(endav, 0, SvREFCNT_inc(gv)); } + if (!name) + GvCV(gv) = 0; /* Will remember elsewhere instead. */ + return cv; } void @@ -2573,12 +2776,14 @@ OP *block; char *name; GV *gv; AV* av; + I32 ix; if (op) name = SvPVx(cSVOP->op_sv, na); else name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); + SvMULTI_on(gv); if (cv = GvFORM(gv)) { if (dowarn) { line_t oldline = curcop->cop_line; @@ -2589,23 +2794,26 @@ OP *block; } SvREFCNT_dec(cv); } - Newz(101,cv,1,CV); - sv_upgrade(cv, SVt_PVFM); - SvREFCNT(cv) = 1; + cv = (CV*)NEWSV(1106,0); + sv_upgrade((SV *)cv, SVt_PVFM); GvFORM(gv) = cv; CvGV(cv) = SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; + for (ix = AvFILL(comppad); ix > 0; ix--) { + if (!SvPADMY(curpad[ix])) + SvPADTMP_on(curpad[ix]); + } + CvPADLIST(cv) = av = newAV(); AvREAL_off(av); - av_store(av, 1, (SV*)comppad); + av_store(av, 1, SvREFCNT_inc((SV*)comppad)); AvFILL(av) = 1; CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - CvDELETED(cv) = FALSE; FmLINES(cv) = 0; op_free(op); copline = NOLINE; @@ -2636,7 +2844,7 @@ newANONLIST(op) OP* op; { return newUNOP(OP_REFGEN, 0, - ref(list(convert(OP_ANONLIST, 0, op)), OP_REFGEN)); + mod(list(convert(OP_ANONLIST, 0, op)), OP_REFGEN)); } OP * @@ -2644,7 +2852,16 @@ newANONHASH(op) OP* op; { return newUNOP(OP_REFGEN, 0, - ref(list(convert(OP_ANONHASH, 0, op)), OP_REFGEN)); + mod(list(convert(OP_ANONHASH, 0, op)), OP_REFGEN)); +} + +OP * +newANONSUB(floor, block) +I32 floor; +OP *block; +{ + return newUNOP(OP_REFGEN, 0, + newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, block))); } OP * @@ -2708,10 +2925,13 @@ OP *o; } OP * -newGVREF(o) +newGVREF(type,o) +I32 type; OP *o; { - return newUNOP(OP_RV2GV, 0, scalar(o)); + if (type == OP_MAPSTART) + return newUNOP(OP_NULL, 0, o); + return newUNOP(OP_RV2GV, 0, o); } OP * @@ -2766,22 +2986,41 @@ OP *op; } OP * -ck_chop(op) +ck_spair(op) OP *op; { if (op->op_flags & OPf_KIDS) { OP* newop; + OP* kid; op = modkids(ck_fun(op), op->op_type); - if (op->op_private != 1) + kid = cUNOP->op_first; + newop = kUNOP->op_first->op_sibling; + if (newop && + (newop->op_sibling || + !(opargs[newop->op_type] & OA_RETSCALAR) || + newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || + newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { + return op; - newop = cUNOP->op_first->op_sibling; - if (!newop || newop->op_type != OP_RV2SV) - return op; - op_free(cUNOP->op_first); - cUNOP->op_first = newop; + } + op_free(kUNOP->op_first); + kUNOP->op_first = newop; + } + op->op_ppaddr = ppaddr[++op->op_type]; + return ck_fun(op); +} + +OP * +ck_delete(op) +OP *op; +{ + op = ck_fun(op); + if (op->op_flags & OPf_KIDS) { + OP *kid = cUNOP->op_first; + if (kid->op_type != OP_HELEM) + croak("%s argument is not a HASH element", op_name[op->op_type]); + null(kid); } - op->op_type = OP_SCHOP; - op->op_ppaddr = ppaddr[OP_SCHOP]; return op; } @@ -2840,6 +3079,7 @@ OP *op; op_free(op); op = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); } + op->op_targ = (PADOFFSET)hints; return op; } @@ -2874,12 +3114,26 @@ ck_rvconst(op) register OP *op; { SVOP *kid = (SVOP*)cUNOP->op_first; - int iscv = (op->op_type==OP_RV2CV); + int iscv = (op->op_type==OP_RV2CV)*2; + op->op_private = (hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { + GV *gv = 0; kid->op_type = OP_GV; - kid->op_sv = SvREFCNT_inc(gv_fetchpv(SvPVx(kid->op_sv, na), - 1+iscv, iscv ? SVt_PVCV : SVt_PVGV)); + for (gv = 0; !gv; iscv++) { + gv = gv_fetchpv(SvPVx(kid->op_sv, na), + iscv, + iscv + ? SVt_PVCV + : op->op_type == OP_RV2SV + ? SVt_PV + : op->op_type == OP_RV2AV + ? SVt_PVAV + : op->op_type == OP_RV2HV + ? SVt_PVHV + : SVt_PVGV); + } + kid->op_sv = SvREFCNT_inc(gv); } return op; } @@ -2897,14 +3151,14 @@ OP *op; { I32 type = op->op_type; - if (op->op_flags & OPf_SPECIAL) + if (op->op_flags & OPf_REF) return op; if (op->op_flags & OPf_KIDS) { SVOP *kid = (SVOP*)cUNOP->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - OP *newop = newGVOP(type, OPf_SPECIAL, + OP *newop = newGVOP(type, OPf_REF, gv_fetchpv(SvPVx(kid->op_sv, na), TRUE, SVt_PVIO)); op_free(op); return newop; @@ -2913,7 +3167,7 @@ OP *op; else { op_free(op); if (type == OP_FTTTY) - return newGVOP(type, OPf_SPECIAL, gv_fetchpv("main'STDIN", TRUE, + return newGVOP(type, OPf_REF, gv_fetchpv("main'STDIN", TRUE, SVt_PVIO)); else return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); @@ -2929,7 +3183,8 @@ OP *op; OP **tokid; OP *sibl; I32 numargs = 0; - register I32 oa = opargs[op->op_type] >> 8; + int type = op->op_type; + register I32 oa = opargs[type] >> OASHIFT; if (op->op_flags & OPf_STACKED) { if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) @@ -2947,6 +3202,8 @@ OP *op; tokid = &kid->op_sibling; kid = kid->op_sibling; } + if (!kid && opargs[type] & OA_DEFGV) + *tokid = kid = newSVREF(newGVOP(OP_GV, 0, defgv)); while (oa && kid) { numargs++; @@ -2971,7 +3228,7 @@ OP *op; gv_fetchpv(name, TRUE, SVt_PVAV) )); if (dowarn) warn("Array @%s missing the @ in argument %d of %s()", - name, numargs, op_name[op->op_type]); + name, numargs, op_name[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -2979,7 +3236,7 @@ OP *op; } else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) bad_type(numargs, "array", op, kid); - mod(kid, op->op_type); + mod(kid, type); break; case OA_HVREF: if (kid->op_type == OP_CONST && @@ -2989,7 +3246,7 @@ OP *op; gv_fetchpv(name, TRUE, SVt_PVHV) )); if (dowarn) warn("Hash %%%s missing the %% in argument %d of %s()", - name, numargs, op_name[op->op_type]); + name, numargs, op_name[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -2997,11 +3254,11 @@ OP *op; } else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) bad_type(numargs, "hash", op, kid); - mod(kid, op->op_type); + mod(kid, type); break; case OA_CVREF: { - OP *newop = newUNOP(OP_NULL, 0, scalar(kid)); + OP *newop = newUNOP(OP_NULL, 0, kid); kid->op_sibling = 0; linklist(kid); newop->op_next = newop; @@ -3030,7 +3287,7 @@ OP *op; scalar(kid); break; case OA_SCALARREF: - mod(scalar(kid), op->op_type); + mod(scalar(kid), type); break; } oa >>= 4; @@ -3042,6 +3299,11 @@ OP *op; return too_many_arguments(op); listkids(op); } + else if (opargs[type] & OA_DEFGV) { + op_free(op); + return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); + } + if (oa) { while (oa & OA_OPTIONAL) oa >>= 4; @@ -3055,11 +3317,11 @@ OP * ck_glob(op) OP *op; { - GV *gv = newGVgen(); - GvIOn(gv); + GV *gv = newGVgen("main"); + gv_IOadd(gv); append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv)); scalarkids(op); - return op; + return ck_fun(op); } OP * @@ -3068,29 +3330,48 @@ OP *op; { LOGOP *gwop; OP *kid; + OPCODE type = op->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; + op->op_ppaddr = ppaddr[OP_GREPSTART]; + Newz(1101, gwop, 1, LOGOP); + if (op->op_flags & OPf_STACKED) { + OP* k; op = ck_sort(op); + for (k = cLISTOP->op_first->op_sibling->op_next; k; k = k->op_next) { + kid = k; + } + kid->op_next = (OP*)gwop; op->op_flags &= ~OPf_STACKED; } + kid = cLISTOP->op_first->op_sibling; + if (type == OP_MAPWHILE) + list(kid); + else + scalar(kid); op = ck_fun(op); if (error_count) return op; - kid = cLISTOP->op_first->op_sibling; + kid = cLISTOP->op_first->op_sibling; if (kid->op_type != OP_NULL) croak("panic: ck_grep"); kid = kUNOP->op_first; - Newz(1101, gwop, 1, LOGOP); - gwop->op_type = OP_GREPWHILE; - gwop->op_ppaddr = ppaddr[OP_GREPWHILE]; - gwop->op_first = list(op); + gwop->op_type = type; + gwop->op_ppaddr = ppaddr[type]; + gwop->op_first = listkids(op); gwop->op_flags |= OPf_KIDS; gwop->op_private = 1; gwop->op_other = LINKLIST(kid); - gwop->op_targ = pad_alloc(OP_GREPWHILE, SVs_PADTMP); + gwop->op_targ = pad_alloc(type, SVs_PADTMP); kid->op_next = (OP*)gwop; + kid = cLISTOP->op_first->op_sibling; + if (!kid || !kid->op_sibling) + return too_few_arguments(op); + for (kid = kid->op_sibling; kid; kid = kid->op_sibling) + mod(kid, OP_GREPSTART); + return (OP*)gwop; } @@ -3111,7 +3392,7 @@ ck_lengthconst(op) OP *op; { /* XXX length optimization goes here */ - return op; + return ck_fun(op); } OP * @@ -3191,24 +3472,19 @@ OP * ck_require(op) OP *op; { - if (op->op_flags & OPf_KIDS) { /* Shall we fake a BEGIN {}? */ + if (op->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP *kid = (SVOP*)cUNOP->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVX(subname); char *s; - sv_catpvn(kid->op_sv, ".pm", 3); - if (s = strrchr(name,':')) - s++; - else - s = name; - if (strNE(s, "BEGIN")) { - op = newSTATEOP(0, Nullch, op); - newSUB(start_subparse(), - newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)), - op); - return newOP(OP_STUB,0); + for (s = SvPVX(kid->op_sv); *s; s++) { + if (*s == ':' && s[1] == ':') { + *s = '/'; + strcpy(s+1,s+2); /* known to be okay here */ + --SvCUR(kid->op_sv); + } } + sv_catpvn(kid->op_sv, ".pm", 3); } } return ck_fun(op); @@ -3269,7 +3545,6 @@ OP *op; if (kid->op_type == OP_SCOPE) { k = kid->op_next; kid->op_next = 0; - peep(k); } else if (kid->op_type == OP_LEAVE) { null(kid); /* wipe out leave */ @@ -3279,11 +3554,16 @@ OP *op; if (k->op_next == kid) k->op_next = 0; } - peep(kLISTOP->op_first); + k = kLISTOP->op_first; } + peep(k); + kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ null(kid); /* wipe out rv2gv */ - kid->op_next = kid; + if (op->op_type == OP_SORT) + kid->op_next = kid; + else + kid->op_next = k; op->op_flags |= OPf_SPECIAL; } } @@ -3360,6 +3640,8 @@ OP *op; op->op_private = (hints & HINT_STRICT_REFS); if (perldb && curstash != debstash) op->op_private |= OPpDEREF_DB; + while (o = o->op_sibling) + mod(o, OP_ENTERSUB); return op; } @@ -3378,7 +3660,10 @@ OP *op; if (op->op_flags & OPf_KIDS) { SVOP *kid = (SVOP*)cUNOP->op_first; - if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) + if (kid->op_type == OP_NULL) + kid = (SVOP*)kid->op_sibling; + if (kid && + kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) op->op_flags |= OPf_SPECIAL; } return ck_fun(op); @@ -3387,19 +3672,40 @@ OP *op; /* A peephole optimizer. We visit the ops in the order they're to execute. */ void -peep(op) -register OP* op; +peep(o) +register OP* o; { register OP* oldop = 0; - if (!op || op->op_seq) + if (!o || o->op_seq) return; - for (; op; op = op->op_next) { - if (op->op_seq) - return; - switch (op->op_type) { + ENTER; + SAVESPTR(op); + SAVESPTR(curcop); + for (; o; o = o->op_next) { + if (o->op_seq) + break; + op = o; + switch (o->op_type) { + case OP_NEXTSTATE: + case OP_DBSTATE: + curcop = ((COP*)o); /* for warnings */ + break; + + case OP_CONCAT: + case OP_CONST: + case OP_JOIN: + case OP_UC: + case OP_UCFIRST: + case OP_LC: + case OP_LCFIRST: + case OP_QUOTEMETA: + if (o->op_next->op_type == OP_STRINGIFY) + null(o->op_next); + o->op_seq = ++op_seqmax; + break; case OP_STUB: - if ((op->op_flags & (OPf_KNOW|OPf_LIST)) != (OPf_KNOW|OPf_LIST)) { - op->op_seq = ++op_seqmax; + if ((o->op_flags & (OPf_KNOW|OPf_LIST)) != (OPf_KNOW|OPf_LIST)) { + o->op_seq = ++op_seqmax; break; /* Scalar stub must produce undef. List stub is noop */ } /* FALL THROUGH */ @@ -3407,63 +3713,65 @@ register OP* op; case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: - if (oldop) { - oldop->op_next = op->op_next; + if (oldop && o->op_next) { + oldop->op_next = o->op_next; continue; } - op->op_seq = ++op_seqmax; + o->op_seq = ++op_seqmax; break; case OP_GV: - if (op->op_next->op_type == OP_RV2SV) { - if (!(op->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV))) { - null(op->op_next); - op->op_flags |= op->op_next->op_flags & OPf_INTRO; - op->op_next = op->op_next->op_next; - op->op_type = OP_GVSV; - op->op_ppaddr = ppaddr[OP_GVSV]; + if (o->op_next->op_type == OP_RV2SV) { + if (!(o->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV))) { + null(o->op_next); + o->op_private |= o->op_next->op_private & OPpLVAL_INTRO; + o->op_next = o->op_next->op_next; + o->op_type = OP_GVSV; + o->op_ppaddr = ppaddr[OP_GVSV]; } } - else if (op->op_next->op_type == OP_RV2AV) { - OP* pop = op->op_next->op_next; - I32 i; + else if (o->op_next->op_type == OP_RV2AV) { + OP* pop = o->op_next->op_next; + IV i; if (pop->op_type == OP_CONST && + (op = pop->op_next) && pop->op_next->op_type == OP_AELEM && - !(pop->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV)) && - !(pop->op_next->op_flags & OPf_INTRO) && - (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && + !(pop->op_next->op_private & + (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)) && + (i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase) + <= 255 && i >= 0) { - null(op->op_next); + null(o->op_next); null(pop->op_next); null(pop); - op->op_flags &= ~OPf_LVAL; - op->op_flags |= pop->op_next->op_flags & OPf_LVAL; - op->op_next = pop->op_next->op_next; - op->op_type = OP_AELEMFAST; - op->op_ppaddr = ppaddr[OP_AELEMFAST]; - op->op_private = i; - GvAVn((GV*)cSVOP->op_sv); + o->op_flags |= pop->op_next->op_flags & OPf_MOD; + o->op_next = pop->op_next->op_next; + o->op_type = OP_AELEMFAST; + o->op_ppaddr = ppaddr[OP_AELEMFAST]; + o->op_private = (U8)i; + GvAVn((GV*)(((SVOP*)o)->op_sv)); } } - op->op_seq = ++op_seqmax; + o->op_seq = ++op_seqmax; break; + case OP_MAPWHILE: case OP_GREPWHILE: case OP_AND: case OP_OR: - op->op_seq = ++op_seqmax; + o->op_seq = ++op_seqmax; peep(cLOGOP->op_other); break; case OP_COND_EXPR: - op->op_seq = ++op_seqmax; + o->op_seq = ++op_seqmax; peep(cCONDOP->op_true); peep(cCONDOP->op_false); break; case OP_ENTERLOOP: - op->op_seq = ++op_seqmax; + o->op_seq = ++op_seqmax; peep(cLOOP->op_redoop); peep(cLOOP->op_nextop); peep(cLOOP->op_lastop); @@ -3471,14 +3779,29 @@ register OP* op; case OP_MATCH: case OP_SUBST: - op->op_seq = ++op_seqmax; - peep(cPMOP->op_pmreplroot); + o->op_seq = ++op_seqmax; + peep(cPMOP->op_pmreplstart); break; + case OP_EXEC: + o->op_seq = ++op_seqmax; + if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { + if (o->op_next->op_sibling && + o->op_next->op_sibling->op_type != OP_DIE) { + line_t oldline = curcop->cop_line; + + curcop->cop_line = ((COP*)o->op_next)->cop_line; + warn("Statement unlikely to be reached"); + warn("(Maybe you meant system() when you said exec()?)\n"); + curcop->cop_line = oldline; + } + } + break; default: - op->op_seq = ++op_seqmax; + o->op_seq = ++op_seqmax; break; } - oldop = op; + oldop = o; } + LEAVE; } @@ -1,11 +1,10 @@ -/* $RCSfile: arg.h,v $$Revision: 4.1 $$Date: 92/08/07 17:18:16 $ +/* op.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: arg.h,v $ */ /* @@ -39,10 +38,10 @@ typedef U16 PADOFFSET; PADOFFSET op_targ; \ OPCODE op_type; \ U16 op_seq; \ - char op_flags; \ - char op_private; + U8 op_flags; \ + U8 op_private; -#define GIMME (op->op_flags & OPf_KNOW ? op->op_flags & OPf_LIST : cxstack[cxstack_ix].blk_gimme) +#define GIMME (op->op_flags & OPf_KNOW ? op->op_flags & OPf_LIST : cxstack[cxstack_ix].blk_gimme & G_ARRAY) /* Public flags */ #define OPf_LIST 1 /* Do operator in list context. */ @@ -50,45 +49,55 @@ typedef U16 PADOFFSET; #define OPf_KIDS 4 /* There is a firstborn child. */ #define OPf_PARENS 8 /* This operator was parenthesized. */ /* (Or block needs explicit scope entry.) */ -#define OPf_STACKED 16 /* Some arg is arriving on the stack. */ -#define OPf_LVAL 32 /* Certified reference (lvalue). */ -#define OPf_INTRO 64 /* Lvalue must be localized */ +#define OPf_REF 16 /* Certified reference. */ + /* (Return container, not containee). */ +#define OPf_MOD 32 /* Will modify (lvalue). */ +#define OPf_STACKED 64 /* Some arg is arriving on the stack. */ #define OPf_SPECIAL 128 /* Do something weird for this op: */ /* On local LVAL, don't init local value. */ /* On OP_SORT, subroutine is inlined. */ /* On OP_NOT, inversion was implicit. */ - /* On file tests, we fstat filehandle */ + /* On OP_LEAVE, don't restore curpm. */ /* On truncate, we truncate filehandle */ /* On control verbs, we saw no label */ /* On flipflop, we saw ... instead of .. */ /* On UNOPs, saw bare parens, e.g. eof(). */ - /* On OP_ENTERSUBR || OP_NULL, saw a "do". */ + /* On OP_ENTERSUB || OP_NULL, saw a "do". */ -/* Private for OP_ASSIGN */ -#define OPpASSIGN_COMMON 1 /* Left & right have syms in common. */ +/* Private for lvalues */ +#define OPpLVAL_INTRO 128 /* Lvalue must be localized */ + +/* Private for OP_AASSIGN */ +#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */ + +/* Private for OP_SASSIGN */ +#define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */ /* Private for OP_TRANS */ -#define OPpTRANS_SQUASH 1 -#define OPpTRANS_DELETE 2 -#define OPpTRANS_COMPLEMENT 4 +#define OPpTRANS_SQUASH 16 +#define OPpTRANS_DELETE 32 +#define OPpTRANS_COMPLEMENT 64 /* Private for OP_REPEAT */ -#define OPpREPEAT_DOLIST 1 /* List replication. */ +#define OPpREPEAT_DOLIST 64 /* List replication. */ -/* Private for OP_ENTERSUBR, OP_RV2?V, OP_?ELEM */ +/* Private for OP_ENTERSUB, OP_RV2?V, OP_?ELEM */ /* (lower bits carry hints) */ -#define OPpDEREF_DB 32 /* Debug subroutine. */ -#define OPpDEREF_AV 64 /* Want ref to AV. */ -#define OPpDEREF_HV 128 /* Want ref to HV. */ +#define OPpDEREF_DB 16 /* Debug subroutine. */ +#define OPpDEREF_AV 32 /* Want ref to AV. */ +#define OPpDEREF_HV 64 /* Want ref to HV. */ /* Private for OP_CONST */ -#define OPpCONST_BARE 1 /* Was a bare word (filehandle?). */ +#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */ /* Private for OP_FLIP/FLOP */ -#define OPpFLIP_LINENUM 1 /* Range arg potentially a line num. */ +#define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */ /* Private for OP_LIST */ -#define OPpLIST_GUESSED 1 /* Guessed that pushmark was needed. */ +#define OPpLIST_GUESSED 64 /* Guessed that pushmark was needed. */ + +/* Private for OP_LEAVE and friends */ +#define OPpLEAVE_VOID 64 /* No need to copy out values. */ struct op { BASEOP @@ -135,21 +144,26 @@ struct pmop { PMOP * op_pmnext; /* list of all scanpats */ REGEXP * op_pmregexp; /* compiled expression */ SV * op_pmshort; /* for a fast bypass of execute() */ - short op_pmflags; + U16 op_pmflags; char op_pmslen; }; -#define PMf_USED 1 /* pm has been used once already */ -#define PMf_ONCE 2 /* use pattern only once per reset */ -#define PMf_SCANFIRST 4 /* initial constant not anchored */ -#define PMf_ALL 8 /* initial constant is whole pat */ -#define PMf_SKIPWHITE 16 /* skip leading whitespace for split */ -#define PMf_FOLD 32 /* case insensitivity */ -#define PMf_CONST 64 /* subst replacement is constant */ -#define PMf_KEEP 128 /* keep 1st runtime pattern forever */ -#define PMf_GLOBAL 256 /* pattern had a g modifier */ -#define PMf_RUNTIME 512 /* pattern coming in on the stack */ -#define PMf_EVAL 1024 /* evaluating replacement as expr */ -#define PMf_WHITE 2048 /* pattern is \s+ */ + +#define PMf_USED 0x0001 /* pm has been used once already */ +#define PMf_ONCE 0x0002 /* use pattern only once per reset */ +#define PMf_SCANFIRST 0x0004 /* initial constant not anchored */ +#define PMf_ALL 0x0008 /* initial constant is whole pat */ +#define PMf_SKIPWHITE 0x0010 /* skip leading whitespace for split */ +#define PMf_FOLD 0x0020 /* case insensitivity */ +#define PMf_CONST 0x0040 /* subst replacement is constant */ +#define PMf_KEEP 0x0080 /* keep 1st runtime pattern forever */ +#define PMf_GLOBAL 0x0100 /* pattern had a g modifier */ +#define PMf_RUNTIME 0x0200 /* pattern coming in on the stack */ +#define PMf_EVAL 0x0400 /* evaluating replacement as expr */ +#define PMf_WHITE 0x0800 /* pattern is \s+ */ +#define PMf_MULTILINE 0x1000 /* assume multiple lines */ +#define PMf_SINGLELINE 0x2000 /* assume single line */ +#define PMf_UNUSED 0x4000 /* (unused) */ +#define PMf_EXTENDED 0x8000 /* chuck embedded whitespace */ struct svop { BASEOP @@ -210,3 +224,25 @@ struct loop { #define Nullop Null(OP*) +/* Lowest byte of opargs */ +#define OA_MARK 1 +#define OA_FOLDCONST 2 +#define OA_RETSCALAR 4 +#define OA_TARGET 8 +#define OA_RETINTEGER 16 +#define OA_OTHERINT 32 +#define OA_DANGEROUS 64 +#define OA_DEFGV 128 + +#define OASHIFT 8 + +/* Remaining nybbles of opargs */ +#define OA_SCALAR 1 +#define OA_LIST 2 +#define OA_AVREF 3 +#define OA_HVREF 4 +#define OA_CVREF 5 +#define OA_FILEREF 6 +#define OA_SCALARREF 7 +#define OA_OPTIONAL 8 + @@ -5,349 +5,355 @@ typedef enum { OP_PUSHMARK, /* 3 */ OP_WANTARRAY, /* 4 */ OP_CONST, /* 5 */ - OP_INTERP, /* 6 */ - OP_GVSV, /* 7 */ - OP_GV, /* 8 */ - OP_PADSV, /* 9 */ - OP_PADAV, /* 10 */ - OP_PADHV, /* 11 */ - OP_PADANY, /* 12 */ - OP_PUSHRE, /* 13 */ - OP_RV2GV, /* 14 */ - OP_SV2LEN, /* 15 */ - OP_RV2SV, /* 16 */ - OP_AV2ARYLEN, /* 17 */ - OP_RV2CV, /* 18 */ + OP_GVSV, /* 6 */ + OP_GV, /* 7 */ + OP_PADSV, /* 8 */ + OP_PADAV, /* 9 */ + OP_PADHV, /* 10 */ + OP_PADANY, /* 11 */ + OP_PUSHRE, /* 12 */ + OP_RV2GV, /* 13 */ + OP_SV2LEN, /* 14 */ + OP_RV2SV, /* 15 */ + OP_AV2ARYLEN, /* 16 */ + OP_RV2CV, /* 17 */ + OP_ANONCODE, /* 18 */ OP_REFGEN, /* 19 */ - OP_REF, /* 20 */ - OP_BLESS, /* 21 */ - OP_BACKTICK, /* 22 */ - OP_GLOB, /* 23 */ - OP_READLINE, /* 24 */ - OP_RCATLINE, /* 25 */ - OP_REGCMAYBE, /* 26 */ - OP_REGCOMP, /* 27 */ - OP_MATCH, /* 28 */ - OP_SUBST, /* 29 */ - OP_SUBSTCONT, /* 30 */ - OP_TRANS, /* 31 */ - OP_SASSIGN, /* 32 */ - OP_AASSIGN, /* 33 */ - OP_SCHOP, /* 34 */ + OP_SREFGEN, /* 20 */ + OP_REF, /* 21 */ + OP_BLESS, /* 22 */ + OP_BACKTICK, /* 23 */ + OP_GLOB, /* 24 */ + OP_READLINE, /* 25 */ + OP_RCATLINE, /* 26 */ + OP_REGCMAYBE, /* 27 */ + OP_REGCOMP, /* 28 */ + OP_MATCH, /* 29 */ + OP_SUBST, /* 30 */ + OP_SUBSTCONT, /* 31 */ + OP_TRANS, /* 32 */ + OP_SASSIGN, /* 33 */ + OP_AASSIGN, /* 34 */ OP_CHOP, /* 35 */ - OP_DEFINED, /* 36 */ - OP_UNDEF, /* 37 */ - OP_STUDY, /* 38 */ - OP_PREINC, /* 39 */ - OP_I_PREINC, /* 40 */ - OP_PREDEC, /* 41 */ - OP_I_PREDEC, /* 42 */ - OP_POSTINC, /* 43 */ - OP_I_POSTINC, /* 44 */ - OP_POSTDEC, /* 45 */ - OP_I_POSTDEC, /* 46 */ - OP_POW, /* 47 */ - OP_MULTIPLY, /* 48 */ - OP_I_MULTIPLY, /* 49 */ - OP_DIVIDE, /* 50 */ - OP_I_DIVIDE, /* 51 */ - OP_MODULO, /* 52 */ - OP_I_MODULO, /* 53 */ - OP_REPEAT, /* 54 */ - OP_ADD, /* 55 */ - OP_I_ADD, /* 56 */ - OP_SUBTRACT, /* 57 */ - OP_I_SUBTRACT, /* 58 */ - OP_CONCAT, /* 59 */ - OP_LEFT_SHIFT, /* 60 */ - OP_RIGHT_SHIFT, /* 61 */ - OP_LT, /* 62 */ - OP_I_LT, /* 63 */ - OP_GT, /* 64 */ - OP_I_GT, /* 65 */ - OP_LE, /* 66 */ - OP_I_LE, /* 67 */ - OP_GE, /* 68 */ - OP_I_GE, /* 69 */ - OP_EQ, /* 70 */ - OP_I_EQ, /* 71 */ - OP_NE, /* 72 */ - OP_I_NE, /* 73 */ - OP_NCMP, /* 74 */ - OP_I_NCMP, /* 75 */ - OP_SLT, /* 76 */ - OP_SGT, /* 77 */ - OP_SLE, /* 78 */ - OP_SGE, /* 79 */ - OP_SEQ, /* 80 */ - OP_SNE, /* 81 */ - OP_SCMP, /* 82 */ - OP_BIT_AND, /* 83 */ - OP_XOR, /* 84 */ - OP_BIT_OR, /* 85 */ - OP_NEGATE, /* 86 */ - OP_I_NEGATE, /* 87 */ - OP_NOT, /* 88 */ - OP_COMPLEMENT, /* 89 */ - OP_ATAN2, /* 90 */ - OP_SIN, /* 91 */ - OP_COS, /* 92 */ - OP_RAND, /* 93 */ - OP_SRAND, /* 94 */ - OP_EXP, /* 95 */ - OP_LOG, /* 96 */ - OP_SQRT, /* 97 */ - OP_INT, /* 98 */ - OP_HEX, /* 99 */ - OP_OCT, /* 100 */ - OP_ABS, /* 101 */ - OP_LENGTH, /* 102 */ - OP_SUBSTR, /* 103 */ - OP_VEC, /* 104 */ - OP_INDEX, /* 105 */ - OP_RINDEX, /* 106 */ - OP_SPRINTF, /* 107 */ - OP_FORMLINE, /* 108 */ - OP_ORD, /* 109 */ - OP_CHR, /* 110 */ - OP_CRYPT, /* 111 */ - OP_UCFIRST, /* 112 */ - OP_LCFIRST, /* 113 */ - OP_UC, /* 114 */ - OP_LC, /* 115 */ - OP_RV2AV, /* 116 */ - OP_AELEMFAST, /* 117 */ - OP_AELEM, /* 118 */ - OP_ASLICE, /* 119 */ - OP_EACH, /* 120 */ - OP_VALUES, /* 121 */ - OP_KEYS, /* 122 */ - OP_DELETE, /* 123 */ - OP_RV2HV, /* 124 */ - OP_HELEM, /* 125 */ - OP_HSLICE, /* 126 */ - OP_UNPACK, /* 127 */ - OP_PACK, /* 128 */ - OP_SPLIT, /* 129 */ - OP_JOIN, /* 130 */ - OP_LIST, /* 131 */ - OP_LSLICE, /* 132 */ - OP_ANONLIST, /* 133 */ - OP_ANONHASH, /* 134 */ - OP_SPLICE, /* 135 */ - OP_PUSH, /* 136 */ - OP_POP, /* 137 */ - OP_SHIFT, /* 138 */ - OP_UNSHIFT, /* 139 */ - OP_SORT, /* 140 */ - OP_REVERSE, /* 141 */ - OP_GREPSTART, /* 142 */ - OP_GREPWHILE, /* 143 */ - OP_RANGE, /* 144 */ - OP_FLIP, /* 145 */ - OP_FLOP, /* 146 */ - OP_AND, /* 147 */ - OP_OR, /* 148 */ - OP_COND_EXPR, /* 149 */ - OP_ANDASSIGN, /* 150 */ - OP_ORASSIGN, /* 151 */ - OP_METHOD, /* 152 */ - OP_ENTERSUBR, /* 153 */ - OP_LEAVESUBR, /* 154 */ - OP_CALLER, /* 155 */ - OP_WARN, /* 156 */ - OP_DIE, /* 157 */ - OP_RESET, /* 158 */ - OP_LINESEQ, /* 159 */ - OP_NEXTSTATE, /* 160 */ - OP_DBSTATE, /* 161 */ - OP_UNSTACK, /* 162 */ - OP_ENTER, /* 163 */ - OP_LEAVE, /* 164 */ - OP_SCOPE, /* 165 */ - OP_ENTERITER, /* 166 */ - OP_ITER, /* 167 */ - OP_ENTERLOOP, /* 168 */ - OP_LEAVELOOP, /* 169 */ - OP_RETURN, /* 170 */ - OP_LAST, /* 171 */ - OP_NEXT, /* 172 */ - OP_REDO, /* 173 */ - OP_DUMP, /* 174 */ - OP_GOTO, /* 175 */ - OP_EXIT, /* 176 */ - OP_NSWITCH, /* 177 */ - OP_CSWITCH, /* 178 */ - OP_OPEN, /* 179 */ - OP_CLOSE, /* 180 */ - OP_PIPE_OP, /* 181 */ - OP_FILENO, /* 182 */ - OP_UMASK, /* 183 */ - OP_BINMODE, /* 184 */ - OP_TIE, /* 185 */ - OP_UNTIE, /* 186 */ - OP_DBMOPEN, /* 187 */ - OP_DBMCLOSE, /* 188 */ - OP_SSELECT, /* 189 */ - OP_SELECT, /* 190 */ - OP_GETC, /* 191 */ - OP_READ, /* 192 */ - OP_ENTERWRITE, /* 193 */ - OP_LEAVEWRITE, /* 194 */ - OP_PRTF, /* 195 */ - OP_PRINT, /* 196 */ - OP_SYSREAD, /* 197 */ - OP_SYSWRITE, /* 198 */ - OP_SEND, /* 199 */ - OP_RECV, /* 200 */ - OP_EOF, /* 201 */ - OP_TELL, /* 202 */ - OP_SEEK, /* 203 */ - OP_TRUNCATE, /* 204 */ - OP_FCNTL, /* 205 */ - OP_IOCTL, /* 206 */ - OP_FLOCK, /* 207 */ - OP_SOCKET, /* 208 */ - OP_SOCKPAIR, /* 209 */ - OP_BIND, /* 210 */ - OP_CONNECT, /* 211 */ - OP_LISTEN, /* 212 */ - OP_ACCEPT, /* 213 */ - OP_SHUTDOWN, /* 214 */ - OP_GSOCKOPT, /* 215 */ - OP_SSOCKOPT, /* 216 */ - OP_GETSOCKNAME, /* 217 */ - OP_GETPEERNAME, /* 218 */ - OP_LSTAT, /* 219 */ - OP_STAT, /* 220 */ - OP_FTRREAD, /* 221 */ - OP_FTRWRITE, /* 222 */ - OP_FTREXEC, /* 223 */ - OP_FTEREAD, /* 224 */ - OP_FTEWRITE, /* 225 */ - OP_FTEEXEC, /* 226 */ - OP_FTIS, /* 227 */ - OP_FTEOWNED, /* 228 */ - OP_FTROWNED, /* 229 */ - OP_FTZERO, /* 230 */ - OP_FTSIZE, /* 231 */ - OP_FTMTIME, /* 232 */ - OP_FTATIME, /* 233 */ - OP_FTCTIME, /* 234 */ - OP_FTSOCK, /* 235 */ - OP_FTCHR, /* 236 */ - OP_FTBLK, /* 237 */ - OP_FTFILE, /* 238 */ - OP_FTDIR, /* 239 */ - OP_FTPIPE, /* 240 */ - OP_FTLINK, /* 241 */ - OP_FTSUID, /* 242 */ - OP_FTSGID, /* 243 */ - OP_FTSVTX, /* 244 */ - OP_FTTTY, /* 245 */ - OP_FTTEXT, /* 246 */ - OP_FTBINARY, /* 247 */ - OP_CHDIR, /* 248 */ - OP_CHOWN, /* 249 */ - OP_CHROOT, /* 250 */ - OP_UNLINK, /* 251 */ - OP_CHMOD, /* 252 */ - OP_UTIME, /* 253 */ - OP_RENAME, /* 254 */ - OP_LINK, /* 255 */ - OP_SYMLINK, /* 256 */ - OP_READLINK, /* 257 */ - OP_MKDIR, /* 258 */ - OP_RMDIR, /* 259 */ - OP_OPEN_DIR, /* 260 */ - OP_READDIR, /* 261 */ - OP_TELLDIR, /* 262 */ - OP_SEEKDIR, /* 263 */ - OP_REWINDDIR, /* 264 */ - OP_CLOSEDIR, /* 265 */ - OP_FORK, /* 266 */ - OP_WAIT, /* 267 */ - OP_WAITPID, /* 268 */ - OP_SYSTEM, /* 269 */ - OP_EXEC, /* 270 */ - OP_KILL, /* 271 */ - OP_GETPPID, /* 272 */ - OP_GETPGRP, /* 273 */ - OP_SETPGRP, /* 274 */ - OP_GETPRIORITY, /* 275 */ - OP_SETPRIORITY, /* 276 */ - OP_TIME, /* 277 */ - OP_TMS, /* 278 */ - OP_LOCALTIME, /* 279 */ - OP_GMTIME, /* 280 */ - OP_ALARM, /* 281 */ - OP_SLEEP, /* 282 */ - OP_SHMGET, /* 283 */ - OP_SHMCTL, /* 284 */ - OP_SHMREAD, /* 285 */ - OP_SHMWRITE, /* 286 */ - OP_MSGGET, /* 287 */ - OP_MSGCTL, /* 288 */ - OP_MSGSND, /* 289 */ - OP_MSGRCV, /* 290 */ - OP_SEMGET, /* 291 */ - OP_SEMCTL, /* 292 */ - OP_SEMOP, /* 293 */ - OP_REQUIRE, /* 294 */ - OP_DOFILE, /* 295 */ - OP_ENTEREVAL, /* 296 */ - OP_LEAVEEVAL, /* 297 */ - OP_EVALONCE, /* 298 */ - OP_ENTERTRY, /* 299 */ - OP_LEAVETRY, /* 300 */ - OP_GHBYNAME, /* 301 */ - OP_GHBYADDR, /* 302 */ - OP_GHOSTENT, /* 303 */ - OP_GNBYNAME, /* 304 */ - OP_GNBYADDR, /* 305 */ - OP_GNETENT, /* 306 */ - OP_GPBYNAME, /* 307 */ - OP_GPBYNUMBER, /* 308 */ - OP_GPROTOENT, /* 309 */ - OP_GSBYNAME, /* 310 */ - OP_GSBYPORT, /* 311 */ - OP_GSERVENT, /* 312 */ - OP_SHOSTENT, /* 313 */ - OP_SNETENT, /* 314 */ - OP_SPROTOENT, /* 315 */ - OP_SSERVENT, /* 316 */ - OP_EHOSTENT, /* 317 */ - OP_ENETENT, /* 318 */ - OP_EPROTOENT, /* 319 */ - OP_ESERVENT, /* 320 */ - OP_GPWNAM, /* 321 */ - OP_GPWUID, /* 322 */ - OP_GPWENT, /* 323 */ - OP_SPWENT, /* 324 */ - OP_EPWENT, /* 325 */ - OP_GGRNAM, /* 326 */ - OP_GGRGID, /* 327 */ - OP_GGRENT, /* 328 */ - OP_SGRENT, /* 329 */ - OP_EGRENT, /* 330 */ - OP_GETLOGIN, /* 331 */ - OP_SYSCALL, /* 332 */ + OP_SCHOP, /* 36 */ + OP_CHOMP, /* 37 */ + OP_SCHOMP, /* 38 */ + OP_DEFINED, /* 39 */ + OP_UNDEF, /* 40 */ + OP_STUDY, /* 41 */ + OP_POS, /* 42 */ + OP_PREINC, /* 43 */ + OP_I_PREINC, /* 44 */ + OP_PREDEC, /* 45 */ + OP_I_PREDEC, /* 46 */ + OP_POSTINC, /* 47 */ + OP_I_POSTINC, /* 48 */ + OP_POSTDEC, /* 49 */ + OP_I_POSTDEC, /* 50 */ + OP_POW, /* 51 */ + OP_MULTIPLY, /* 52 */ + OP_I_MULTIPLY, /* 53 */ + OP_DIVIDE, /* 54 */ + OP_I_DIVIDE, /* 55 */ + OP_MODULO, /* 56 */ + OP_I_MODULO, /* 57 */ + OP_REPEAT, /* 58 */ + OP_ADD, /* 59 */ + OP_I_ADD, /* 60 */ + OP_SUBTRACT, /* 61 */ + OP_I_SUBTRACT, /* 62 */ + OP_CONCAT, /* 63 */ + OP_STRINGIFY, /* 64 */ + OP_LEFT_SHIFT, /* 65 */ + OP_RIGHT_SHIFT, /* 66 */ + OP_LT, /* 67 */ + OP_I_LT, /* 68 */ + OP_GT, /* 69 */ + OP_I_GT, /* 70 */ + OP_LE, /* 71 */ + OP_I_LE, /* 72 */ + OP_GE, /* 73 */ + OP_I_GE, /* 74 */ + OP_EQ, /* 75 */ + OP_I_EQ, /* 76 */ + OP_NE, /* 77 */ + OP_I_NE, /* 78 */ + OP_NCMP, /* 79 */ + OP_I_NCMP, /* 80 */ + OP_SLT, /* 81 */ + OP_SGT, /* 82 */ + OP_SLE, /* 83 */ + OP_SGE, /* 84 */ + OP_SEQ, /* 85 */ + OP_SNE, /* 86 */ + OP_SCMP, /* 87 */ + OP_BIT_AND, /* 88 */ + OP_BIT_XOR, /* 89 */ + OP_BIT_OR, /* 90 */ + OP_NEGATE, /* 91 */ + OP_I_NEGATE, /* 92 */ + OP_NOT, /* 93 */ + OP_COMPLEMENT, /* 94 */ + OP_ATAN2, /* 95 */ + OP_SIN, /* 96 */ + OP_COS, /* 97 */ + OP_RAND, /* 98 */ + OP_SRAND, /* 99 */ + OP_EXP, /* 100 */ + OP_LOG, /* 101 */ + OP_SQRT, /* 102 */ + OP_INT, /* 103 */ + OP_HEX, /* 104 */ + OP_OCT, /* 105 */ + OP_ABS, /* 106 */ + OP_LENGTH, /* 107 */ + OP_SUBSTR, /* 108 */ + OP_VEC, /* 109 */ + OP_INDEX, /* 110 */ + OP_RINDEX, /* 111 */ + OP_SPRINTF, /* 112 */ + OP_FORMLINE, /* 113 */ + OP_ORD, /* 114 */ + OP_CHR, /* 115 */ + OP_CRYPT, /* 116 */ + OP_UCFIRST, /* 117 */ + OP_LCFIRST, /* 118 */ + OP_UC, /* 119 */ + OP_LC, /* 120 */ + OP_QUOTEMETA, /* 121 */ + OP_RV2AV, /* 122 */ + OP_AELEMFAST, /* 123 */ + OP_AELEM, /* 124 */ + OP_ASLICE, /* 125 */ + OP_EACH, /* 126 */ + OP_VALUES, /* 127 */ + OP_KEYS, /* 128 */ + OP_DELETE, /* 129 */ + OP_EXISTS, /* 130 */ + OP_RV2HV, /* 131 */ + OP_HELEM, /* 132 */ + OP_HSLICE, /* 133 */ + OP_UNPACK, /* 134 */ + OP_PACK, /* 135 */ + OP_SPLIT, /* 136 */ + OP_JOIN, /* 137 */ + OP_LIST, /* 138 */ + OP_LSLICE, /* 139 */ + OP_ANONLIST, /* 140 */ + OP_ANONHASH, /* 141 */ + OP_SPLICE, /* 142 */ + OP_PUSH, /* 143 */ + OP_POP, /* 144 */ + OP_SHIFT, /* 145 */ + OP_UNSHIFT, /* 146 */ + OP_SORT, /* 147 */ + OP_REVERSE, /* 148 */ + OP_GREPSTART, /* 149 */ + OP_GREPWHILE, /* 150 */ + OP_MAPSTART, /* 151 */ + OP_MAPWHILE, /* 152 */ + OP_RANGE, /* 153 */ + OP_FLIP, /* 154 */ + OP_FLOP, /* 155 */ + OP_AND, /* 156 */ + OP_OR, /* 157 */ + OP_XOR, /* 158 */ + OP_COND_EXPR, /* 159 */ + OP_ANDASSIGN, /* 160 */ + OP_ORASSIGN, /* 161 */ + OP_METHOD, /* 162 */ + OP_ENTERSUB, /* 163 */ + OP_LEAVESUB, /* 164 */ + OP_CALLER, /* 165 */ + OP_WARN, /* 166 */ + OP_DIE, /* 167 */ + OP_RESET, /* 168 */ + OP_LINESEQ, /* 169 */ + OP_NEXTSTATE, /* 170 */ + OP_DBSTATE, /* 171 */ + OP_UNSTACK, /* 172 */ + OP_ENTER, /* 173 */ + OP_LEAVE, /* 174 */ + OP_SCOPE, /* 175 */ + OP_ENTERITER, /* 176 */ + OP_ITER, /* 177 */ + OP_ENTERLOOP, /* 178 */ + OP_LEAVELOOP, /* 179 */ + OP_RETURN, /* 180 */ + OP_LAST, /* 181 */ + OP_NEXT, /* 182 */ + OP_REDO, /* 183 */ + OP_DUMP, /* 184 */ + OP_GOTO, /* 185 */ + OP_EXIT, /* 186 */ + OP_OPEN, /* 187 */ + OP_CLOSE, /* 188 */ + OP_PIPE_OP, /* 189 */ + OP_FILENO, /* 190 */ + OP_UMASK, /* 191 */ + OP_BINMODE, /* 192 */ + OP_TIE, /* 193 */ + OP_UNTIE, /* 194 */ + OP_DBMOPEN, /* 195 */ + OP_DBMCLOSE, /* 196 */ + OP_SSELECT, /* 197 */ + OP_SELECT, /* 198 */ + OP_GETC, /* 199 */ + OP_READ, /* 200 */ + OP_ENTERWRITE, /* 201 */ + OP_LEAVEWRITE, /* 202 */ + OP_PRTF, /* 203 */ + OP_PRINT, /* 204 */ + OP_SYSREAD, /* 205 */ + OP_SYSWRITE, /* 206 */ + OP_SEND, /* 207 */ + OP_RECV, /* 208 */ + OP_EOF, /* 209 */ + OP_TELL, /* 210 */ + OP_SEEK, /* 211 */ + OP_TRUNCATE, /* 212 */ + OP_FCNTL, /* 213 */ + OP_IOCTL, /* 214 */ + OP_FLOCK, /* 215 */ + OP_SOCKET, /* 216 */ + OP_SOCKPAIR, /* 217 */ + OP_BIND, /* 218 */ + OP_CONNECT, /* 219 */ + OP_LISTEN, /* 220 */ + OP_ACCEPT, /* 221 */ + OP_SHUTDOWN, /* 222 */ + OP_GSOCKOPT, /* 223 */ + OP_SSOCKOPT, /* 224 */ + OP_GETSOCKNAME, /* 225 */ + OP_GETPEERNAME, /* 226 */ + OP_LSTAT, /* 227 */ + OP_STAT, /* 228 */ + OP_FTRREAD, /* 229 */ + OP_FTRWRITE, /* 230 */ + OP_FTREXEC, /* 231 */ + OP_FTEREAD, /* 232 */ + OP_FTEWRITE, /* 233 */ + OP_FTEEXEC, /* 234 */ + OP_FTIS, /* 235 */ + OP_FTEOWNED, /* 236 */ + OP_FTROWNED, /* 237 */ + OP_FTZERO, /* 238 */ + OP_FTSIZE, /* 239 */ + OP_FTMTIME, /* 240 */ + OP_FTATIME, /* 241 */ + OP_FTCTIME, /* 242 */ + OP_FTSOCK, /* 243 */ + OP_FTCHR, /* 244 */ + OP_FTBLK, /* 245 */ + OP_FTFILE, /* 246 */ + OP_FTDIR, /* 247 */ + OP_FTPIPE, /* 248 */ + OP_FTLINK, /* 249 */ + OP_FTSUID, /* 250 */ + OP_FTSGID, /* 251 */ + OP_FTSVTX, /* 252 */ + OP_FTTTY, /* 253 */ + OP_FTTEXT, /* 254 */ + OP_FTBINARY, /* 255 */ + OP_CHDIR, /* 256 */ + OP_CHOWN, /* 257 */ + OP_CHROOT, /* 258 */ + OP_UNLINK, /* 259 */ + OP_CHMOD, /* 260 */ + OP_UTIME, /* 261 */ + OP_RENAME, /* 262 */ + OP_LINK, /* 263 */ + OP_SYMLINK, /* 264 */ + OP_READLINK, /* 265 */ + OP_MKDIR, /* 266 */ + OP_RMDIR, /* 267 */ + OP_OPEN_DIR, /* 268 */ + OP_READDIR, /* 269 */ + OP_TELLDIR, /* 270 */ + OP_SEEKDIR, /* 271 */ + OP_REWINDDIR, /* 272 */ + OP_CLOSEDIR, /* 273 */ + OP_FORK, /* 274 */ + OP_WAIT, /* 275 */ + OP_WAITPID, /* 276 */ + OP_SYSTEM, /* 277 */ + OP_EXEC, /* 278 */ + OP_KILL, /* 279 */ + OP_GETPPID, /* 280 */ + OP_GETPGRP, /* 281 */ + OP_SETPGRP, /* 282 */ + OP_GETPRIORITY, /* 283 */ + OP_SETPRIORITY, /* 284 */ + OP_TIME, /* 285 */ + OP_TMS, /* 286 */ + OP_LOCALTIME, /* 287 */ + OP_GMTIME, /* 288 */ + OP_ALARM, /* 289 */ + OP_SLEEP, /* 290 */ + OP_SHMGET, /* 291 */ + OP_SHMCTL, /* 292 */ + OP_SHMREAD, /* 293 */ + OP_SHMWRITE, /* 294 */ + OP_MSGGET, /* 295 */ + OP_MSGCTL, /* 296 */ + OP_MSGSND, /* 297 */ + OP_MSGRCV, /* 298 */ + OP_SEMGET, /* 299 */ + OP_SEMCTL, /* 300 */ + OP_SEMOP, /* 301 */ + OP_REQUIRE, /* 302 */ + OP_DOFILE, /* 303 */ + OP_ENTEREVAL, /* 304 */ + OP_LEAVEEVAL, /* 305 */ + OP_ENTERTRY, /* 306 */ + OP_LEAVETRY, /* 307 */ + OP_GHBYNAME, /* 308 */ + OP_GHBYADDR, /* 309 */ + OP_GHOSTENT, /* 310 */ + OP_GNBYNAME, /* 311 */ + OP_GNBYADDR, /* 312 */ + OP_GNETENT, /* 313 */ + OP_GPBYNAME, /* 314 */ + OP_GPBYNUMBER, /* 315 */ + OP_GPROTOENT, /* 316 */ + OP_GSBYNAME, /* 317 */ + OP_GSBYPORT, /* 318 */ + OP_GSERVENT, /* 319 */ + OP_SHOSTENT, /* 320 */ + OP_SNETENT, /* 321 */ + OP_SPROTOENT, /* 322 */ + OP_SSERVENT, /* 323 */ + OP_EHOSTENT, /* 324 */ + OP_ENETENT, /* 325 */ + OP_EPROTOENT, /* 326 */ + OP_ESERVENT, /* 327 */ + OP_GPWNAM, /* 328 */ + OP_GPWUID, /* 329 */ + OP_GPWENT, /* 330 */ + OP_SPWENT, /* 331 */ + OP_EPWENT, /* 332 */ + OP_GGRNAM, /* 333 */ + OP_GGRGID, /* 334 */ + OP_GGRENT, /* 335 */ + OP_SGRENT, /* 336 */ + OP_EGRENT, /* 337 */ + OP_GETLOGIN, /* 338 */ + OP_SYSCALL, /* 339 */ OP_max } opcode; -#define MAXO 333 +#define MAXO 340 #ifndef DOINIT -extern char *op_name[]; +EXT char *op_name[]; #else -char *op_name[] = { +EXT char *op_name[] = { "null operation", "stub", "scalar", "pushmark", "wantarray", "constant item", - "interpreted string", "scalar variable", "glob value", "private variable", @@ -357,10 +363,12 @@ char *op_name[] = { "push regexp", "ref-to-glob cast", "scalar value length", - "ref-to-scalar cast", + "scalar deref", "array length", - "subroutine reference", + "subroutine deref", + "anonymous subroutine", "reference constructor", + "scalar ref constructor", "reference-type operator", "bless", "backticks", @@ -375,11 +383,14 @@ char *op_name[] = { "character translation", "scalar assignment", "list assignment", - "scalar chop", "chop", + "scalar chop", + "safe chop", + "scalar safe chop", "defined operator", "undef operator", "study", + "match position", "preincrement", "integer preincrement", "predecrement", @@ -401,6 +412,7 @@ char *op_name[] = { "subtraction", "integer subtraction", "concatenation", + "string", "left bitshift", "right bitshift", "numeric lt", @@ -415,7 +427,7 @@ char *op_name[] = { "integer eq", "numeric ne", "integer ne", - "spaceship", + "spaceship operator", "integer spaceship", "string lt", "string gt", @@ -424,9 +436,9 @@ char *op_name[] = { "string eq", "string ne", "string comparison", - "bit and", - "xor", - "bit or", + "bitwise and", + "bitwise xor", + "bitwise or", "negate", "integer negate", "not", @@ -457,6 +469,7 @@ char *op_name[] = { "lower case first", "upper case", "lower case", + "quote metachars", "array deref", "known array element", "array element", @@ -465,6 +478,7 @@ char *op_name[] = { "values", "keys", "delete", + "exists operator", "associative array deref", "associative array elem", "associative array slice", @@ -485,11 +499,14 @@ char *op_name[] = { "reverse", "grep", "grep iterator", + "map", + "map iterator", "flipflop", "range (or flip)", "range (or flop)", "logical and", "logical or", + "logical xor", "conditional expression", "logical and assignment", "logical or assignment", @@ -518,8 +535,6 @@ char *op_name[] = { "dump", "goto", "exit", - "numeric switch", - "character switch", "open", "close", "pipe", @@ -639,7 +654,6 @@ char *op_name[] = { "do 'file'", "eval string", "eval exit", - "eval constant string", "eval block", "eval block exit", "gethostbyname", @@ -677,379 +691,386 @@ char *op_name[] = { }; #endif -OP * ck_chop P((OP* op)); -OP * ck_concat P((OP* op)); -OP * ck_eof P((OP* op)); -OP * ck_eval P((OP* op)); -OP * ck_exec P((OP* op)); -OP * ck_formline P((OP* op)); -OP * ck_ftst P((OP* op)); -OP * ck_fun P((OP* op)); -OP * ck_glob P((OP* op)); -OP * ck_grep P((OP* op)); -OP * ck_index P((OP* op)); -OP * ck_lengthconst P((OP* op)); -OP * ck_lfun P((OP* op)); -OP * ck_listiob P((OP* op)); -OP * ck_match P((OP* op)); -OP * ck_null P((OP* op)); -OP * ck_repeat P((OP* op)); -OP * ck_require P((OP* op)); -OP * ck_rfun P((OP* op)); -OP * ck_rvconst P((OP* op)); -OP * ck_select P((OP* op)); -OP * ck_shift P((OP* op)); -OP * ck_sort P((OP* op)); -OP * ck_split P((OP* op)); -OP * ck_subr P((OP* op)); -OP * ck_svconst P((OP* op)); -OP * ck_trunc P((OP* op)); +OP * ck_concat _((OP* op)); +OP * ck_delete _((OP* op)); +OP * ck_eof _((OP* op)); +OP * ck_eval _((OP* op)); +OP * ck_exec _((OP* op)); +OP * ck_formline _((OP* op)); +OP * ck_ftst _((OP* op)); +OP * ck_fun _((OP* op)); +OP * ck_glob _((OP* op)); +OP * ck_grep _((OP* op)); +OP * ck_index _((OP* op)); +OP * ck_lengthconst _((OP* op)); +OP * ck_lfun _((OP* op)); +OP * ck_listiob _((OP* op)); +OP * ck_match _((OP* op)); +OP * ck_null _((OP* op)); +OP * ck_repeat _((OP* op)); +OP * ck_require _((OP* op)); +OP * ck_rfun _((OP* op)); +OP * ck_rvconst _((OP* op)); +OP * ck_select _((OP* op)); +OP * ck_shift _((OP* op)); +OP * ck_sort _((OP* op)); +OP * ck_spair _((OP* op)); +OP * ck_split _((OP* op)); +OP * ck_subr _((OP* op)); +OP * ck_svconst _((OP* op)); +OP * ck_trunc _((OP* op)); -OP * pp_null P((void)); -OP * pp_stub P((void)); -OP * pp_scalar P((void)); -OP * pp_pushmark P((void)); -OP * pp_wantarray P((void)); -OP * pp_const P((void)); -OP * pp_interp P((void)); -OP * pp_gvsv P((void)); -OP * pp_gv P((void)); -OP * pp_padsv P((void)); -OP * pp_padav P((void)); -OP * pp_padhv P((void)); -OP * pp_padany P((void)); -OP * pp_pushre P((void)); -OP * pp_rv2gv P((void)); -OP * pp_sv2len P((void)); -OP * pp_rv2sv P((void)); -OP * pp_av2arylen P((void)); -OP * pp_rv2cv P((void)); -OP * pp_refgen P((void)); -OP * pp_ref P((void)); -OP * pp_bless P((void)); -OP * pp_backtick P((void)); -OP * pp_glob P((void)); -OP * pp_readline P((void)); -OP * pp_rcatline P((void)); -OP * pp_regcmaybe P((void)); -OP * pp_regcomp P((void)); -OP * pp_match P((void)); -OP * pp_subst P((void)); -OP * pp_substcont P((void)); -OP * pp_trans P((void)); -OP * pp_sassign P((void)); -OP * pp_aassign P((void)); -OP * pp_schop P((void)); -OP * pp_chop P((void)); -OP * pp_defined P((void)); -OP * pp_undef P((void)); -OP * pp_study P((void)); -OP * pp_preinc P((void)); -OP * pp_i_preinc P((void)); -OP * pp_predec P((void)); -OP * pp_i_predec P((void)); -OP * pp_postinc P((void)); -OP * pp_i_postinc P((void)); -OP * pp_postdec P((void)); -OP * pp_i_postdec P((void)); -OP * pp_pow P((void)); -OP * pp_multiply P((void)); -OP * pp_i_multiply P((void)); -OP * pp_divide P((void)); -OP * pp_i_divide P((void)); -OP * pp_modulo P((void)); -OP * pp_i_modulo P((void)); -OP * pp_repeat P((void)); -OP * pp_add P((void)); -OP * pp_i_add P((void)); -OP * pp_subtract P((void)); -OP * pp_i_subtract P((void)); -OP * pp_concat P((void)); -OP * pp_left_shift P((void)); -OP * pp_right_shift P((void)); -OP * pp_lt P((void)); -OP * pp_i_lt P((void)); -OP * pp_gt P((void)); -OP * pp_i_gt P((void)); -OP * pp_le P((void)); -OP * pp_i_le P((void)); -OP * pp_ge P((void)); -OP * pp_i_ge P((void)); -OP * pp_eq P((void)); -OP * pp_i_eq P((void)); -OP * pp_ne P((void)); -OP * pp_i_ne P((void)); -OP * pp_ncmp P((void)); -OP * pp_i_ncmp P((void)); -OP * pp_slt P((void)); -OP * pp_sgt P((void)); -OP * pp_sle P((void)); -OP * pp_sge P((void)); -OP * pp_seq P((void)); -OP * pp_sne P((void)); -OP * pp_scmp P((void)); -OP * pp_bit_and P((void)); -OP * pp_xor P((void)); -OP * pp_bit_or P((void)); -OP * pp_negate P((void)); -OP * pp_i_negate P((void)); -OP * pp_not P((void)); -OP * pp_complement P((void)); -OP * pp_atan2 P((void)); -OP * pp_sin P((void)); -OP * pp_cos P((void)); -OP * pp_rand P((void)); -OP * pp_srand P((void)); -OP * pp_exp P((void)); -OP * pp_log P((void)); -OP * pp_sqrt P((void)); -OP * pp_int P((void)); -OP * pp_hex P((void)); -OP * pp_oct P((void)); -OP * pp_abs P((void)); -OP * pp_length P((void)); -OP * pp_substr P((void)); -OP * pp_vec P((void)); -OP * pp_index P((void)); -OP * pp_rindex P((void)); -OP * pp_sprintf P((void)); -OP * pp_formline P((void)); -OP * pp_ord P((void)); -OP * pp_chr P((void)); -OP * pp_crypt P((void)); -OP * pp_ucfirst P((void)); -OP * pp_lcfirst P((void)); -OP * pp_uc P((void)); -OP * pp_lc P((void)); -OP * pp_rv2av P((void)); -OP * pp_aelemfast P((void)); -OP * pp_aelem P((void)); -OP * pp_aslice P((void)); -OP * pp_each P((void)); -OP * pp_values P((void)); -OP * pp_keys P((void)); -OP * pp_delete P((void)); -OP * pp_rv2hv P((void)); -OP * pp_helem P((void)); -OP * pp_hslice P((void)); -OP * pp_unpack P((void)); -OP * pp_pack P((void)); -OP * pp_split P((void)); -OP * pp_join P((void)); -OP * pp_list P((void)); -OP * pp_lslice P((void)); -OP * pp_anonlist P((void)); -OP * pp_anonhash P((void)); -OP * pp_splice P((void)); -OP * pp_push P((void)); -OP * pp_pop P((void)); -OP * pp_shift P((void)); -OP * pp_unshift P((void)); -OP * pp_sort P((void)); -OP * pp_reverse P((void)); -OP * pp_grepstart P((void)); -OP * pp_grepwhile P((void)); -OP * pp_range P((void)); -OP * pp_flip P((void)); -OP * pp_flop P((void)); -OP * pp_and P((void)); -OP * pp_or P((void)); -OP * pp_cond_expr P((void)); -OP * pp_andassign P((void)); -OP * pp_orassign P((void)); -OP * pp_method P((void)); -OP * pp_entersubr P((void)); -OP * pp_leavesubr P((void)); -OP * pp_caller P((void)); -OP * pp_warn P((void)); -OP * pp_die P((void)); -OP * pp_reset P((void)); -OP * pp_lineseq P((void)); -OP * pp_nextstate P((void)); -OP * pp_dbstate P((void)); -OP * pp_unstack P((void)); -OP * pp_enter P((void)); -OP * pp_leave P((void)); -OP * pp_scope P((void)); -OP * pp_enteriter P((void)); -OP * pp_iter P((void)); -OP * pp_enterloop P((void)); -OP * pp_leaveloop P((void)); -OP * pp_return P((void)); -OP * pp_last P((void)); -OP * pp_next P((void)); -OP * pp_redo P((void)); -OP * pp_dump P((void)); -OP * pp_goto P((void)); -OP * pp_exit P((void)); -OP * pp_nswitch P((void)); -OP * pp_cswitch P((void)); -OP * pp_open P((void)); -OP * pp_close P((void)); -OP * pp_pipe_op P((void)); -OP * pp_fileno P((void)); -OP * pp_umask P((void)); -OP * pp_binmode P((void)); -OP * pp_tie P((void)); -OP * pp_untie P((void)); -OP * pp_dbmopen P((void)); -OP * pp_dbmclose P((void)); -OP * pp_sselect P((void)); -OP * pp_select P((void)); -OP * pp_getc P((void)); -OP * pp_read P((void)); -OP * pp_enterwrite P((void)); -OP * pp_leavewrite P((void)); -OP * pp_prtf P((void)); -OP * pp_print P((void)); -OP * pp_sysread P((void)); -OP * pp_syswrite P((void)); -OP * pp_send P((void)); -OP * pp_recv P((void)); -OP * pp_eof P((void)); -OP * pp_tell P((void)); -OP * pp_seek P((void)); -OP * pp_truncate P((void)); -OP * pp_fcntl P((void)); -OP * pp_ioctl P((void)); -OP * pp_flock P((void)); -OP * pp_socket P((void)); -OP * pp_sockpair P((void)); -OP * pp_bind P((void)); -OP * pp_connect P((void)); -OP * pp_listen P((void)); -OP * pp_accept P((void)); -OP * pp_shutdown P((void)); -OP * pp_gsockopt P((void)); -OP * pp_ssockopt P((void)); -OP * pp_getsockname P((void)); -OP * pp_getpeername P((void)); -OP * pp_lstat P((void)); -OP * pp_stat P((void)); -OP * pp_ftrread P((void)); -OP * pp_ftrwrite P((void)); -OP * pp_ftrexec P((void)); -OP * pp_fteread P((void)); -OP * pp_ftewrite P((void)); -OP * pp_fteexec P((void)); -OP * pp_ftis P((void)); -OP * pp_fteowned P((void)); -OP * pp_ftrowned P((void)); -OP * pp_ftzero P((void)); -OP * pp_ftsize P((void)); -OP * pp_ftmtime P((void)); -OP * pp_ftatime P((void)); -OP * pp_ftctime P((void)); -OP * pp_ftsock P((void)); -OP * pp_ftchr P((void)); -OP * pp_ftblk P((void)); -OP * pp_ftfile P((void)); -OP * pp_ftdir P((void)); -OP * pp_ftpipe P((void)); -OP * pp_ftlink P((void)); -OP * pp_ftsuid P((void)); -OP * pp_ftsgid P((void)); -OP * pp_ftsvtx P((void)); -OP * pp_fttty P((void)); -OP * pp_fttext P((void)); -OP * pp_ftbinary P((void)); -OP * pp_chdir P((void)); -OP * pp_chown P((void)); -OP * pp_chroot P((void)); -OP * pp_unlink P((void)); -OP * pp_chmod P((void)); -OP * pp_utime P((void)); -OP * pp_rename P((void)); -OP * pp_link P((void)); -OP * pp_symlink P((void)); -OP * pp_readlink P((void)); -OP * pp_mkdir P((void)); -OP * pp_rmdir P((void)); -OP * pp_open_dir P((void)); -OP * pp_readdir P((void)); -OP * pp_telldir P((void)); -OP * pp_seekdir P((void)); -OP * pp_rewinddir P((void)); -OP * pp_closedir P((void)); -OP * pp_fork P((void)); -OP * pp_wait P((void)); -OP * pp_waitpid P((void)); -OP * pp_system P((void)); -OP * pp_exec P((void)); -OP * pp_kill P((void)); -OP * pp_getppid P((void)); -OP * pp_getpgrp P((void)); -OP * pp_setpgrp P((void)); -OP * pp_getpriority P((void)); -OP * pp_setpriority P((void)); -OP * pp_time P((void)); -OP * pp_tms P((void)); -OP * pp_localtime P((void)); -OP * pp_gmtime P((void)); -OP * pp_alarm P((void)); -OP * pp_sleep P((void)); -OP * pp_shmget P((void)); -OP * pp_shmctl P((void)); -OP * pp_shmread P((void)); -OP * pp_shmwrite P((void)); -OP * pp_msgget P((void)); -OP * pp_msgctl P((void)); -OP * pp_msgsnd P((void)); -OP * pp_msgrcv P((void)); -OP * pp_semget P((void)); -OP * pp_semctl P((void)); -OP * pp_semop P((void)); -OP * pp_require P((void)); -OP * pp_dofile P((void)); -OP * pp_entereval P((void)); -OP * pp_leaveeval P((void)); -OP * pp_evalonce P((void)); -OP * pp_entertry P((void)); -OP * pp_leavetry P((void)); -OP * pp_ghbyname P((void)); -OP * pp_ghbyaddr P((void)); -OP * pp_ghostent P((void)); -OP * pp_gnbyname P((void)); -OP * pp_gnbyaddr P((void)); -OP * pp_gnetent P((void)); -OP * pp_gpbyname P((void)); -OP * pp_gpbynumber P((void)); -OP * pp_gprotoent P((void)); -OP * pp_gsbyname P((void)); -OP * pp_gsbyport P((void)); -OP * pp_gservent P((void)); -OP * pp_shostent P((void)); -OP * pp_snetent P((void)); -OP * pp_sprotoent P((void)); -OP * pp_sservent P((void)); -OP * pp_ehostent P((void)); -OP * pp_enetent P((void)); -OP * pp_eprotoent P((void)); -OP * pp_eservent P((void)); -OP * pp_gpwnam P((void)); -OP * pp_gpwuid P((void)); -OP * pp_gpwent P((void)); -OP * pp_spwent P((void)); -OP * pp_epwent P((void)); -OP * pp_ggrnam P((void)); -OP * pp_ggrgid P((void)); -OP * pp_ggrent P((void)); -OP * pp_sgrent P((void)); -OP * pp_egrent P((void)); -OP * pp_getlogin P((void)); -OP * pp_syscall P((void)); +OP * pp_null _((void)); +OP * pp_stub _((void)); +OP * pp_scalar _((void)); +OP * pp_pushmark _((void)); +OP * pp_wantarray _((void)); +OP * pp_const _((void)); +OP * pp_gvsv _((void)); +OP * pp_gv _((void)); +OP * pp_padsv _((void)); +OP * pp_padav _((void)); +OP * pp_padhv _((void)); +OP * pp_padany _((void)); +OP * pp_pushre _((void)); +OP * pp_rv2gv _((void)); +OP * pp_sv2len _((void)); +OP * pp_rv2sv _((void)); +OP * pp_av2arylen _((void)); +OP * pp_rv2cv _((void)); +OP * pp_anoncode _((void)); +OP * pp_refgen _((void)); +OP * pp_srefgen _((void)); +OP * pp_ref _((void)); +OP * pp_bless _((void)); +OP * pp_backtick _((void)); +OP * pp_glob _((void)); +OP * pp_readline _((void)); +OP * pp_rcatline _((void)); +OP * pp_regcmaybe _((void)); +OP * pp_regcomp _((void)); +OP * pp_match _((void)); +OP * pp_subst _((void)); +OP * pp_substcont _((void)); +OP * pp_trans _((void)); +OP * pp_sassign _((void)); +OP * pp_aassign _((void)); +OP * pp_chop _((void)); +OP * pp_schop _((void)); +OP * pp_chomp _((void)); +OP * pp_schomp _((void)); +OP * pp_defined _((void)); +OP * pp_undef _((void)); +OP * pp_study _((void)); +OP * pp_pos _((void)); +OP * pp_preinc _((void)); +OP * pp_i_preinc _((void)); +OP * pp_predec _((void)); +OP * pp_i_predec _((void)); +OP * pp_postinc _((void)); +OP * pp_i_postinc _((void)); +OP * pp_postdec _((void)); +OP * pp_i_postdec _((void)); +OP * pp_pow _((void)); +OP * pp_multiply _((void)); +OP * pp_i_multiply _((void)); +OP * pp_divide _((void)); +OP * pp_i_divide _((void)); +OP * pp_modulo _((void)); +OP * pp_i_modulo _((void)); +OP * pp_repeat _((void)); +OP * pp_add _((void)); +OP * pp_i_add _((void)); +OP * pp_subtract _((void)); +OP * pp_i_subtract _((void)); +OP * pp_concat _((void)); +OP * pp_stringify _((void)); +OP * pp_left_shift _((void)); +OP * pp_right_shift _((void)); +OP * pp_lt _((void)); +OP * pp_i_lt _((void)); +OP * pp_gt _((void)); +OP * pp_i_gt _((void)); +OP * pp_le _((void)); +OP * pp_i_le _((void)); +OP * pp_ge _((void)); +OP * pp_i_ge _((void)); +OP * pp_eq _((void)); +OP * pp_i_eq _((void)); +OP * pp_ne _((void)); +OP * pp_i_ne _((void)); +OP * pp_ncmp _((void)); +OP * pp_i_ncmp _((void)); +OP * pp_slt _((void)); +OP * pp_sgt _((void)); +OP * pp_sle _((void)); +OP * pp_sge _((void)); +OP * pp_seq _((void)); +OP * pp_sne _((void)); +OP * pp_scmp _((void)); +OP * pp_bit_and _((void)); +OP * pp_bit_xor _((void)); +OP * pp_bit_or _((void)); +OP * pp_negate _((void)); +OP * pp_i_negate _((void)); +OP * pp_not _((void)); +OP * pp_complement _((void)); +OP * pp_atan2 _((void)); +OP * pp_sin _((void)); +OP * pp_cos _((void)); +OP * pp_rand _((void)); +OP * pp_srand _((void)); +OP * pp_exp _((void)); +OP * pp_log _((void)); +OP * pp_sqrt _((void)); +OP * pp_int _((void)); +OP * pp_hex _((void)); +OP * pp_oct _((void)); +OP * pp_abs _((void)); +OP * pp_length _((void)); +OP * pp_substr _((void)); +OP * pp_vec _((void)); +OP * pp_index _((void)); +OP * pp_rindex _((void)); +OP * pp_sprintf _((void)); +OP * pp_formline _((void)); +OP * pp_ord _((void)); +OP * pp_chr _((void)); +OP * pp_crypt _((void)); +OP * pp_ucfirst _((void)); +OP * pp_lcfirst _((void)); +OP * pp_uc _((void)); +OP * pp_lc _((void)); +OP * pp_quotemeta _((void)); +OP * pp_rv2av _((void)); +OP * pp_aelemfast _((void)); +OP * pp_aelem _((void)); +OP * pp_aslice _((void)); +OP * pp_each _((void)); +OP * pp_values _((void)); +OP * pp_keys _((void)); +OP * pp_delete _((void)); +OP * pp_exists _((void)); +OP * pp_rv2hv _((void)); +OP * pp_helem _((void)); +OP * pp_hslice _((void)); +OP * pp_unpack _((void)); +OP * pp_pack _((void)); +OP * pp_split _((void)); +OP * pp_join _((void)); +OP * pp_list _((void)); +OP * pp_lslice _((void)); +OP * pp_anonlist _((void)); +OP * pp_anonhash _((void)); +OP * pp_splice _((void)); +OP * pp_push _((void)); +OP * pp_pop _((void)); +OP * pp_shift _((void)); +OP * pp_unshift _((void)); +OP * pp_sort _((void)); +OP * pp_reverse _((void)); +OP * pp_grepstart _((void)); +OP * pp_grepwhile _((void)); +OP * pp_mapstart _((void)); +OP * pp_mapwhile _((void)); +OP * pp_range _((void)); +OP * pp_flip _((void)); +OP * pp_flop _((void)); +OP * pp_and _((void)); +OP * pp_or _((void)); +OP * pp_xor _((void)); +OP * pp_cond_expr _((void)); +OP * pp_andassign _((void)); +OP * pp_orassign _((void)); +OP * pp_method _((void)); +OP * pp_entersub _((void)); +OP * pp_leavesub _((void)); +OP * pp_caller _((void)); +OP * pp_warn _((void)); +OP * pp_die _((void)); +OP * pp_reset _((void)); +OP * pp_lineseq _((void)); +OP * pp_nextstate _((void)); +OP * pp_dbstate _((void)); +OP * pp_unstack _((void)); +OP * pp_enter _((void)); +OP * pp_leave _((void)); +OP * pp_scope _((void)); +OP * pp_enteriter _((void)); +OP * pp_iter _((void)); +OP * pp_enterloop _((void)); +OP * pp_leaveloop _((void)); +OP * pp_return _((void)); +OP * pp_last _((void)); +OP * pp_next _((void)); +OP * pp_redo _((void)); +OP * pp_dump _((void)); +OP * pp_goto _((void)); +OP * pp_exit _((void)); +OP * pp_open _((void)); +OP * pp_close _((void)); +OP * pp_pipe_op _((void)); +OP * pp_fileno _((void)); +OP * pp_umask _((void)); +OP * pp_binmode _((void)); +OP * pp_tie _((void)); +OP * pp_untie _((void)); +OP * pp_dbmopen _((void)); +OP * pp_dbmclose _((void)); +OP * pp_sselect _((void)); +OP * pp_select _((void)); +OP * pp_getc _((void)); +OP * pp_read _((void)); +OP * pp_enterwrite _((void)); +OP * pp_leavewrite _((void)); +OP * pp_prtf _((void)); +OP * pp_print _((void)); +OP * pp_sysread _((void)); +OP * pp_syswrite _((void)); +OP * pp_send _((void)); +OP * pp_recv _((void)); +OP * pp_eof _((void)); +OP * pp_tell _((void)); +OP * pp_seek _((void)); +OP * pp_truncate _((void)); +OP * pp_fcntl _((void)); +OP * pp_ioctl _((void)); +OP * pp_flock _((void)); +OP * pp_socket _((void)); +OP * pp_sockpair _((void)); +OP * pp_bind _((void)); +OP * pp_connect _((void)); +OP * pp_listen _((void)); +OP * pp_accept _((void)); +OP * pp_shutdown _((void)); +OP * pp_gsockopt _((void)); +OP * pp_ssockopt _((void)); +OP * pp_getsockname _((void)); +OP * pp_getpeername _((void)); +OP * pp_lstat _((void)); +OP * pp_stat _((void)); +OP * pp_ftrread _((void)); +OP * pp_ftrwrite _((void)); +OP * pp_ftrexec _((void)); +OP * pp_fteread _((void)); +OP * pp_ftewrite _((void)); +OP * pp_fteexec _((void)); +OP * pp_ftis _((void)); +OP * pp_fteowned _((void)); +OP * pp_ftrowned _((void)); +OP * pp_ftzero _((void)); +OP * pp_ftsize _((void)); +OP * pp_ftmtime _((void)); +OP * pp_ftatime _((void)); +OP * pp_ftctime _((void)); +OP * pp_ftsock _((void)); +OP * pp_ftchr _((void)); +OP * pp_ftblk _((void)); +OP * pp_ftfile _((void)); +OP * pp_ftdir _((void)); +OP * pp_ftpipe _((void)); +OP * pp_ftlink _((void)); +OP * pp_ftsuid _((void)); +OP * pp_ftsgid _((void)); +OP * pp_ftsvtx _((void)); +OP * pp_fttty _((void)); +OP * pp_fttext _((void)); +OP * pp_ftbinary _((void)); +OP * pp_chdir _((void)); +OP * pp_chown _((void)); +OP * pp_chroot _((void)); +OP * pp_unlink _((void)); +OP * pp_chmod _((void)); +OP * pp_utime _((void)); +OP * pp_rename _((void)); +OP * pp_link _((void)); +OP * pp_symlink _((void)); +OP * pp_readlink _((void)); +OP * pp_mkdir _((void)); +OP * pp_rmdir _((void)); +OP * pp_open_dir _((void)); +OP * pp_readdir _((void)); +OP * pp_telldir _((void)); +OP * pp_seekdir _((void)); +OP * pp_rewinddir _((void)); +OP * pp_closedir _((void)); +OP * pp_fork _((void)); +OP * pp_wait _((void)); +OP * pp_waitpid _((void)); +OP * pp_system _((void)); +OP * pp_exec _((void)); +OP * pp_kill _((void)); +OP * pp_getppid _((void)); +OP * pp_getpgrp _((void)); +OP * pp_setpgrp _((void)); +OP * pp_getpriority _((void)); +OP * pp_setpriority _((void)); +OP * pp_time _((void)); +OP * pp_tms _((void)); +OP * pp_localtime _((void)); +OP * pp_gmtime _((void)); +OP * pp_alarm _((void)); +OP * pp_sleep _((void)); +OP * pp_shmget _((void)); +OP * pp_shmctl _((void)); +OP * pp_shmread _((void)); +OP * pp_shmwrite _((void)); +OP * pp_msgget _((void)); +OP * pp_msgctl _((void)); +OP * pp_msgsnd _((void)); +OP * pp_msgrcv _((void)); +OP * pp_semget _((void)); +OP * pp_semctl _((void)); +OP * pp_semop _((void)); +OP * pp_require _((void)); +OP * pp_dofile _((void)); +OP * pp_entereval _((void)); +OP * pp_leaveeval _((void)); +OP * pp_entertry _((void)); +OP * pp_leavetry _((void)); +OP * pp_ghbyname _((void)); +OP * pp_ghbyaddr _((void)); +OP * pp_ghostent _((void)); +OP * pp_gnbyname _((void)); +OP * pp_gnbyaddr _((void)); +OP * pp_gnetent _((void)); +OP * pp_gpbyname _((void)); +OP * pp_gpbynumber _((void)); +OP * pp_gprotoent _((void)); +OP * pp_gsbyname _((void)); +OP * pp_gsbyport _((void)); +OP * pp_gservent _((void)); +OP * pp_shostent _((void)); +OP * pp_snetent _((void)); +OP * pp_sprotoent _((void)); +OP * pp_sservent _((void)); +OP * pp_ehostent _((void)); +OP * pp_enetent _((void)); +OP * pp_eprotoent _((void)); +OP * pp_eservent _((void)); +OP * pp_gpwnam _((void)); +OP * pp_gpwuid _((void)); +OP * pp_gpwent _((void)); +OP * pp_spwent _((void)); +OP * pp_epwent _((void)); +OP * pp_ggrnam _((void)); +OP * pp_ggrgid _((void)); +OP * pp_ggrent _((void)); +OP * pp_sgrent _((void)); +OP * pp_egrent _((void)); +OP * pp_getlogin _((void)); +OP * pp_syscall _((void)); #ifndef DOINIT -extern OP * (*ppaddr[])(); +EXT OP * (*ppaddr[])(); #else -OP * (*ppaddr[])() = { +EXT OP * (*ppaddr[])() = { pp_null, pp_stub, pp_scalar, pp_pushmark, pp_wantarray, pp_const, - pp_interp, pp_gvsv, pp_gv, pp_padsv, @@ -1062,7 +1083,9 @@ OP * (*ppaddr[])() = { pp_rv2sv, pp_av2arylen, pp_rv2cv, + pp_anoncode, pp_refgen, + pp_srefgen, pp_ref, pp_bless, pp_backtick, @@ -1077,11 +1100,14 @@ OP * (*ppaddr[])() = { pp_trans, pp_sassign, pp_aassign, - pp_schop, pp_chop, + pp_schop, + pp_chomp, + pp_schomp, pp_defined, pp_undef, pp_study, + pp_pos, pp_preinc, pp_i_preinc, pp_predec, @@ -1103,6 +1129,7 @@ OP * (*ppaddr[])() = { pp_subtract, pp_i_subtract, pp_concat, + pp_stringify, pp_left_shift, pp_right_shift, pp_lt, @@ -1127,7 +1154,7 @@ OP * (*ppaddr[])() = { pp_sne, pp_scmp, pp_bit_and, - pp_xor, + pp_bit_xor, pp_bit_or, pp_negate, pp_i_negate, @@ -1159,6 +1186,7 @@ OP * (*ppaddr[])() = { pp_lcfirst, pp_uc, pp_lc, + pp_quotemeta, pp_rv2av, pp_aelemfast, pp_aelem, @@ -1167,6 +1195,7 @@ OP * (*ppaddr[])() = { pp_values, pp_keys, pp_delete, + pp_exists, pp_rv2hv, pp_helem, pp_hslice, @@ -1187,17 +1216,20 @@ OP * (*ppaddr[])() = { pp_reverse, pp_grepstart, pp_grepwhile, + pp_mapstart, + pp_mapwhile, pp_range, pp_flip, pp_flop, pp_and, pp_or, + pp_xor, pp_cond_expr, pp_andassign, pp_orassign, pp_method, - pp_entersubr, - pp_leavesubr, + pp_entersub, + pp_leavesub, pp_caller, pp_warn, pp_die, @@ -1220,8 +1252,6 @@ OP * (*ppaddr[])() = { pp_dump, pp_goto, pp_exit, - pp_nswitch, - pp_cswitch, pp_open, pp_close, pp_pipe_op, @@ -1341,7 +1371,6 @@ OP * (*ppaddr[])() = { pp_dofile, pp_entereval, pp_leaveeval, - pp_evalonce, pp_entertry, pp_leavetry, pp_ghbyname, @@ -1380,16 +1409,15 @@ OP * (*ppaddr[])() = { #endif #ifndef DOINIT -extern OP * (*check[])(); +EXT OP * (*check[])(); #else -OP * (*check[])() = { +EXT OP * (*check[])() = { ck_null, /* null */ ck_null, /* stub */ ck_fun, /* scalar */ ck_null, /* pushmark */ ck_null, /* wantarray */ ck_svconst, /* const */ - ck_null, /* interp */ ck_null, /* gvsv */ ck_null, /* gv */ ck_null, /* padsv */ @@ -1402,7 +1430,9 @@ OP * (*check[])() = { ck_rvconst, /* rv2sv */ ck_null, /* av2arylen */ ck_rvconst, /* rv2cv */ - ck_null, /* refgen */ + ck_null, /* anoncode */ + ck_spair, /* refgen */ + ck_null, /* srefgen */ ck_fun, /* ref */ ck_fun, /* bless */ ck_null, /* backtick */ @@ -1417,11 +1447,14 @@ OP * (*check[])() = { ck_null, /* trans */ ck_null, /* sassign */ ck_null, /* aassign */ + ck_spair, /* chop */ ck_null, /* schop */ - ck_chop, /* chop */ + ck_spair, /* chomp */ + ck_null, /* schomp */ ck_rfun, /* defined */ ck_lfun, /* undef */ ck_fun, /* study */ + ck_lfun, /* pos */ ck_lfun, /* preinc */ ck_lfun, /* i_preinc */ ck_lfun, /* predec */ @@ -1443,6 +1476,7 @@ OP * (*check[])() = { ck_null, /* subtract */ ck_null, /* i_subtract */ ck_concat, /* concat */ + ck_fun, /* stringify */ ck_null, /* left_shift */ ck_null, /* right_shift */ ck_null, /* lt */ @@ -1467,7 +1501,7 @@ OP * (*check[])() = { ck_null, /* sne */ ck_null, /* scmp */ ck_null, /* bit_and */ - ck_null, /* xor */ + ck_null, /* bit_xor */ ck_null, /* bit_or */ ck_null, /* negate */ ck_null, /* i_negate */ @@ -1499,6 +1533,7 @@ OP * (*check[])() = { ck_fun, /* lcfirst */ ck_fun, /* uc */ ck_fun, /* lc */ + ck_fun, /* quotemeta */ ck_rvconst, /* rv2av */ ck_null, /* aelemfast */ ck_null, /* aelem */ @@ -1506,7 +1541,8 @@ OP * (*check[])() = { ck_fun, /* each */ ck_fun, /* values */ ck_fun, /* keys */ - ck_null, /* delete */ + ck_delete, /* delete */ + ck_delete, /* exists */ ck_rvconst, /* rv2hv */ ck_null, /* helem */ ck_null, /* hslice */ @@ -1516,8 +1552,8 @@ OP * (*check[])() = { ck_fun, /* join */ ck_null, /* list */ ck_null, /* lslice */ - ck_null, /* anonlist */ - ck_null, /* anonhash */ + ck_fun, /* anonlist */ + ck_fun, /* anonhash */ ck_fun, /* splice */ ck_fun, /* push */ ck_shift, /* pop */ @@ -1527,17 +1563,20 @@ OP * (*check[])() = { ck_fun, /* reverse */ ck_grep, /* grepstart */ ck_null, /* grepwhile */ + ck_grep, /* mapstart */ + ck_null, /* mapwhile */ ck_null, /* range */ ck_null, /* flip */ ck_null, /* flop */ ck_null, /* and */ ck_null, /* or */ + ck_null, /* xor */ ck_null, /* cond_expr */ ck_null, /* andassign */ ck_null, /* orassign */ ck_null, /* method */ - ck_subr, /* entersubr */ - ck_null, /* leavesubr */ + ck_subr, /* entersub */ + ck_null, /* leavesub */ ck_fun, /* caller */ ck_fun, /* warn */ ck_fun, /* die */ @@ -1560,8 +1599,6 @@ OP * (*check[])() = { ck_null, /* dump */ ck_null, /* goto */ ck_fun, /* exit */ - ck_null, /* nswitch */ - ck_null, /* cswitch */ ck_fun, /* open */ ck_fun, /* close */ ck_fun, /* pipe_op */ @@ -1681,7 +1718,6 @@ OP * (*check[])() = { ck_fun, /* dofile */ ck_eval, /* entereval */ ck_null, /* leaveeval */ - ck_null, /* evalonce */ ck_null, /* entertry */ ck_null, /* leavetry */ ck_fun, /* ghbyname */ @@ -1722,17 +1758,16 @@ OP * (*check[])() = { #ifndef DOINIT EXT U32 opargs[]; #else -U32 opargs[] = { +EXT U32 opargs[] = { 0x00000000, /* null */ 0x00000000, /* stub */ 0x00000104, /* scalar */ 0x00000004, /* pushmark */ 0x00000014, /* wantarray */ 0x00000004, /* const */ - 0x00000000, /* interp */ 0x00000044, /* gvsv */ 0x00000044, /* gv */ - 0x00000000, /* padsv */ + 0x00000004, /* padsv */ 0x00000000, /* padav */ 0x00000000, /* padhv */ 0x00000000, /* padany */ @@ -1742,11 +1777,13 @@ U32 opargs[] = { 0x00000044, /* rv2sv */ 0x00000014, /* av2arylen */ 0x00000040, /* rv2cv */ - 0x0000020e, /* refgen */ - 0x0000090c, /* ref */ + 0x00000000, /* anoncode */ + 0x00000201, /* refgen */ + 0x00000106, /* srefgen */ + 0x0000098c, /* ref */ 0x00009104, /* bless */ 0x00000008, /* backtick */ - 0x00000008, /* glob */ + 0x00001108, /* glob */ 0x00000008, /* readline */ 0x00000008, /* rcatline */ 0x00000104, /* regcmaybe */ @@ -1757,20 +1794,23 @@ U32 opargs[] = { 0x00000114, /* trans */ 0x00000004, /* sassign */ 0x00002208, /* aassign */ - 0x00000008, /* schop */ - 0x00000209, /* chop */ - 0x00000914, /* defined */ + 0x0000020d, /* chop */ + 0x0000098c, /* schop */ + 0x0000020d, /* chomp */ + 0x0000098c, /* schomp */ + 0x00000994, /* defined */ 0x00000904, /* undef */ - 0x0000090c, /* study */ - 0x00000124, /* preinc */ - 0x00000114, /* i_preinc */ - 0x00000124, /* predec */ - 0x00000114, /* i_predec */ - 0x0000012c, /* postinc */ - 0x0000011c, /* i_postinc */ - 0x0000012c, /* postdec */ - 0x0000011c, /* i_postdec */ - 0x0000112e, /* pow */ + 0x0000098c, /* study */ + 0x0000098c, /* pos */ + 0x00000164, /* preinc */ + 0x00000154, /* i_preinc */ + 0x00000164, /* predec */ + 0x00000154, /* i_predec */ + 0x0000016c, /* postinc */ + 0x0000015c, /* i_postinc */ + 0x0000016c, /* postdec */ + 0x0000015c, /* i_postdec */ + 0x0000110e, /* pow */ 0x0000112e, /* multiply */ 0x0000111e, /* i_multiply */ 0x0000112e, /* divide */ @@ -1783,6 +1823,7 @@ U32 opargs[] = { 0x0000112e, /* subtract */ 0x0000111e, /* i_subtract */ 0x0000110e, /* concat */ + 0x0000010e, /* stringify */ 0x0000111e, /* left_shift */ 0x0000111e, /* right_shift */ 0x00001136, /* lt */ @@ -1807,38 +1848,39 @@ U32 opargs[] = { 0x00001116, /* sne */ 0x0000111e, /* scmp */ 0x0000110e, /* bit_and */ - 0x0000110e, /* xor */ + 0x0000110e, /* bit_xor */ 0x0000110e, /* bit_or */ 0x0000012e, /* negate */ 0x0000011e, /* i_negate */ 0x00000116, /* not */ 0x0000010e, /* complement */ 0x0000110e, /* atan2 */ - 0x0000090e, /* sin */ - 0x0000090e, /* cos */ + 0x0000098e, /* sin */ + 0x0000098e, /* cos */ 0x0000090c, /* rand */ 0x00000904, /* srand */ - 0x0000090e, /* exp */ - 0x0000090e, /* log */ - 0x0000090e, /* sqrt */ - 0x0000090e, /* int */ - 0x0000091c, /* hex */ - 0x0000091c, /* oct */ - 0x0000090e, /* abs */ - 0x0000011c, /* length */ + 0x0000098e, /* exp */ + 0x0000098e, /* log */ + 0x0000098e, /* sqrt */ + 0x0000098e, /* int */ + 0x0000099c, /* hex */ + 0x0000099c, /* oct */ + 0x0000098e, /* abs */ + 0x0000099c, /* length */ 0x0009110c, /* substr */ 0x0001111c, /* vec */ 0x0009111c, /* index */ 0x0009111c, /* rindex */ 0x0000210d, /* sprintf */ 0x00002105, /* formline */ - 0x0000091e, /* ord */ - 0x0000090e, /* chr */ + 0x0000099e, /* ord */ + 0x0000098e, /* chr */ 0x0000110e, /* crypt */ - 0x0000010a, /* ucfirst */ - 0x0000010a, /* lcfirst */ - 0x0000010a, /* uc */ - 0x0000010a, /* lc */ + 0x0000010e, /* ucfirst */ + 0x0000010e, /* lcfirst */ + 0x0000010e, /* uc */ + 0x0000010e, /* lc */ + 0x0000010e, /* quotemeta */ 0x00000048, /* rv2av */ 0x00001304, /* aelemfast */ 0x00001304, /* aelem */ @@ -1846,7 +1888,8 @@ U32 opargs[] = { 0x00000408, /* each */ 0x00000408, /* values */ 0x00000408, /* keys */ - 0x00001404, /* delete */ + 0x00000104, /* delete */ + 0x00000114, /* exists */ 0x00000048, /* rv2hv */ 0x00001404, /* helem */ 0x00002401, /* hslice */ @@ -1856,9 +1899,9 @@ U32 opargs[] = { 0x0000210d, /* join */ 0x00000201, /* list */ 0x00022400, /* lslice */ - 0x00000201, /* anonlist */ - 0x00000201, /* anonhash */ - 0x00291301, /* splice */ + 0x00000205, /* anonlist */ + 0x00000205, /* anonhash */ + 0x00299301, /* splice */ 0x0000231d, /* push */ 0x00000304, /* pop */ 0x00000304, /* shift */ @@ -1867,17 +1910,20 @@ U32 opargs[] = { 0x00000209, /* reverse */ 0x00002541, /* grepstart */ 0x00000048, /* grepwhile */ + 0x00002541, /* mapstart */ + 0x00000048, /* mapwhile */ 0x00001100, /* range */ 0x00001100, /* flip */ 0x00000000, /* flop */ 0x00000000, /* and */ 0x00000000, /* or */ + 0x00001106, /* xor */ 0x00000000, /* cond_expr */ 0x00000004, /* andassign */ 0x00000004, /* orassign */ 0x00000040, /* method */ - 0x00000241, /* entersubr */ - 0x00000000, /* leavesubr */ + 0x00000249, /* entersub */ + 0x00000000, /* leavesub */ 0x00000908, /* caller */ 0x0000021d, /* warn */ 0x0000025d, /* die */ @@ -1892,7 +1938,7 @@ U32 opargs[] = { 0x00000040, /* enteriter */ 0x00000000, /* iter */ 0x00000040, /* enterloop */ - 0x00000004, /* leaveloop */ + 0x00000000, /* leaveloop */ 0x00000241, /* return */ 0x00000044, /* last */ 0x00000044, /* next */ @@ -1900,8 +1946,6 @@ U32 opargs[] = { 0x00000044, /* dump */ 0x00000044, /* goto */ 0x00000944, /* exit */ - 0x00000040, /* nswitch */ - 0x00000040, /* cswitch */ 0x0000961c, /* open */ 0x00000e14, /* close */ 0x00006614, /* pipe_op */ @@ -1942,47 +1986,47 @@ U32 opargs[] = { 0x00111614, /* ssockopt */ 0x00000614, /* getsockname */ 0x00000614, /* getpeername */ - 0x00000600, /* lstat */ - 0x00000600, /* stat */ - 0x00000614, /* ftrread */ - 0x00000614, /* ftrwrite */ - 0x00000614, /* ftrexec */ - 0x00000614, /* fteread */ - 0x00000614, /* ftewrite */ - 0x00000614, /* fteexec */ - 0x00000614, /* ftis */ - 0x00000614, /* fteowned */ - 0x00000614, /* ftrowned */ - 0x00000614, /* ftzero */ - 0x0000061c, /* ftsize */ - 0x0000060c, /* ftmtime */ - 0x0000060c, /* ftatime */ - 0x0000060c, /* ftctime */ - 0x00000614, /* ftsock */ - 0x00000614, /* ftchr */ - 0x00000614, /* ftblk */ - 0x00000614, /* ftfile */ - 0x00000614, /* ftdir */ - 0x00000614, /* ftpipe */ - 0x00000614, /* ftlink */ - 0x00000614, /* ftsuid */ - 0x00000614, /* ftsgid */ - 0x00000614, /* ftsvtx */ + 0x00000680, /* lstat */ + 0x00000680, /* stat */ + 0x00000694, /* ftrread */ + 0x00000694, /* ftrwrite */ + 0x00000694, /* ftrexec */ + 0x00000694, /* fteread */ + 0x00000694, /* ftewrite */ + 0x00000694, /* fteexec */ + 0x00000694, /* ftis */ + 0x00000694, /* fteowned */ + 0x00000694, /* ftrowned */ + 0x00000694, /* ftzero */ + 0x0000069c, /* ftsize */ + 0x0000068c, /* ftmtime */ + 0x0000068c, /* ftatime */ + 0x0000068c, /* ftctime */ + 0x00000694, /* ftsock */ + 0x00000694, /* ftchr */ + 0x00000694, /* ftblk */ + 0x00000694, /* ftfile */ + 0x00000694, /* ftdir */ + 0x00000694, /* ftpipe */ + 0x00000694, /* ftlink */ + 0x00000694, /* ftsuid */ + 0x00000694, /* ftsgid */ + 0x00000694, /* ftsvtx */ 0x00000614, /* fttty */ - 0x00000614, /* fttext */ - 0x00000614, /* ftbinary */ + 0x00000694, /* fttext */ + 0x00000694, /* ftbinary */ 0x0000091c, /* chdir */ 0x0000021d, /* chown */ - 0x0000091c, /* chroot */ - 0x0000021d, /* unlink */ + 0x0000099c, /* chroot */ + 0x0000029d, /* unlink */ 0x0000021d, /* chmod */ 0x0000021d, /* utime */ 0x0000111c, /* rename */ 0x0000111c, /* link */ 0x0000111c, /* symlink */ - 0x0000090c, /* readlink */ + 0x0000098c, /* readlink */ 0x0000111c, /* mkdir */ - 0x0000091c, /* rmdir */ + 0x0000099c, /* rmdir */ 0x00001614, /* open_dir */ 0x00000600, /* readdir */ 0x0000060c, /* telldir */ @@ -1997,14 +2041,14 @@ U32 opargs[] = { 0x0000025d, /* kill */ 0x0000001c, /* getppid */ 0x0000091c, /* getpgrp */ - 0x0000111c, /* setpgrp */ + 0x0000991c, /* setpgrp */ 0x0000111c, /* getpriority */ 0x0001111c, /* setpriority */ 0x0000001c, /* time */ 0x00000000, /* tms */ 0x00000908, /* localtime */ 0x00000908, /* gmtime */ - 0x0000091c, /* alarm */ + 0x0000099c, /* alarm */ 0x0000091c, /* sleep */ 0x0001111d, /* shmget */ 0x0001111d, /* shmctl */ @@ -2017,11 +2061,10 @@ U32 opargs[] = { 0x0001111d, /* semget */ 0x0011111d, /* semctl */ 0x0001111d, /* semop */ - 0x00000940, /* require */ + 0x000009c0, /* require */ 0x00000140, /* dofile */ 0x00000140, /* entereval */ 0x00000100, /* leaveeval */ - 0x00000140, /* evalonce */ 0x00000000, /* entertry */ 0x00000000, /* leavetry */ 0x00000100, /* ghbyname */ @@ -2047,14 +2090,14 @@ U32 opargs[] = { 0x00000100, /* gpwnam */ 0x00000100, /* gpwuid */ 0x00000000, /* gpwent */ - 0x0000001c, /* spwent */ - 0x0000001c, /* epwent */ + 0x00000014, /* spwent */ + 0x00000014, /* epwent */ 0x00000100, /* ggrnam */ 0x00000100, /* ggrgid */ 0x00000000, /* ggrent */ - 0x0000001c, /* sgrent */ - 0x0000001c, /* egrent */ + 0x00000014, /* sgrent */ + 0x00000014, /* egrent */ 0x0000000c, /* getlogin */ - 0x0000211c, /* syscall */ + 0x0000211d, /* syscall */ }; #endif @@ -33,9 +33,9 @@ print "\n#define MAXO ", scalar @ops, "\n\n"; print <<END; #ifndef DOINIT -extern char *op_name[]; +EXT char *op_name[]; #else -char *op_name[] = { +EXT char *op_name[] = { END for (@ops) { @@ -51,13 +51,13 @@ END # Emit function declarations. for (sort keys %ckname) { - print "OP *\t", &tab(3,$_),"P((OP* op));\n"; + print "OP *\t", &tab(3,$_),"_((OP* op));\n"; } print "\n"; for (@ops) { - print "OP *\t", &tab(3, "pp_\L$_"), "P((void));\n"; + print "OP *\t", &tab(3, "pp_\L$_"), "_((void));\n"; } # Emit ppcode switch array. @@ -65,9 +65,9 @@ for (@ops) { print <<END; #ifndef DOINIT -extern OP * (*ppaddr[])(); +EXT OP * (*ppaddr[])(); #else -OP * (*ppaddr[])() = { +EXT OP * (*ppaddr[])() = { END for (@ops) { @@ -84,9 +84,9 @@ END print <<END; #ifndef DOINIT -extern OP * (*check[])(); +EXT OP * (*check[])(); #else -OP * (*check[])() = { +EXT OP * (*check[])() = { END for (@ops) { @@ -105,7 +105,7 @@ print <<END; #ifndef DOINIT EXT U32 opargs[]; #else -U32 opargs[] = { +EXT U32 opargs[] = { END %argnum = ( @@ -128,6 +128,7 @@ for (@ops) { $argsum |= 16 if $flags =~ /i/; # always produces integer $argsum |= 32 if $flags =~ /I/; # has corresponding int op $argsum |= 64 if $flags =~ /d/; # danger, unknown side effects + $argsum |= 128 if $flags =~ /u/; # defaults to $_ $mul = 256; for $arg (split(' ',$args{$_})) { $argnum = ($arg =~ s/\?//) ? 8 : 0; @@ -165,11 +166,10 @@ pushmark pushmark ck_null s wantarray wantarray ck_null is const constant item ck_svconst s -interp interpreted string ck_null 0 gvsv scalar variable ck_null ds gv glob value ck_null ds -padsv private variable ck_null 0 +padsv private variable ck_null s padav private array ck_null 0 padhv private hash ck_null 0 padany private something ck_null 0 @@ -180,17 +180,19 @@ pushre push regexp ck_null 0 rv2gv ref-to-glob cast ck_rvconst ds sv2len scalar value length ck_null ist -rv2sv ref-to-scalar cast ck_rvconst ds +rv2sv scalar deref ck_rvconst ds av2arylen array length ck_null is -rv2cv subroutine reference ck_rvconst d -refgen reference constructor ck_null fst L -ref reference-type operator ck_fun st S? +rv2cv subroutine deref ck_rvconst d +anoncode anonymous subroutine ck_null 0 +refgen reference constructor ck_spair m L +srefgen scalar ref constructor ck_null fs S +ref reference-type operator ck_fun stu S? bless bless ck_fun s S S? # Pushy I/O. backtick backticks ck_null t -glob glob ck_glob t +glob glob ck_glob t S S readline <HANDLE> ck_null t rcatline append I/O operator ck_null t @@ -208,24 +210,27 @@ trans character translation ck_null is S sassign scalar assignment ck_null s aassign list assignment ck_null t L L -schop scalar chop ck_null t -chop chop ck_chop mt L -defined defined operator ck_rfun is S? +chop chop ck_spair mts L +schop scalar chop ck_null stu S? +chomp safe chop ck_spair mts L +schomp scalar safe chop ck_null stu S? +defined defined operator ck_rfun isu S? undef undef operator ck_lfun s S? -study study ck_fun st S? - -preinc preincrement ck_lfun Is S -i_preinc integer preincrement ck_lfun is S -predec predecrement ck_lfun Is S -i_predec integer predecrement ck_lfun is S -postinc postincrement ck_lfun Ist S -i_postinc integer postincrement ck_lfun ist S -postdec postdecrement ck_lfun Ist S -i_postdec integer postdecrement ck_lfun ist S +study study ck_fun stu S? +pos match position ck_lfun stu S? + +preinc preincrement ck_lfun dIs S +i_preinc integer preincrement ck_lfun dis S +predec predecrement ck_lfun dIs S +i_predec integer predecrement ck_lfun dis S +postinc postincrement ck_lfun dIst S +i_postinc integer postincrement ck_lfun dist S +postdec postdecrement ck_lfun dIst S +i_postdec integer postdecrement ck_lfun dist S # Ordinary operators. -pow exponentiation ck_null Ifst S S +pow exponentiation ck_null fst S S multiply multiplication ck_null Ifst S S i_multiply integer multiplication ck_null ifst S S @@ -240,6 +245,7 @@ i_add integer addition ck_null ifst S S subtract subtraction ck_null Ifst S S i_subtract integer subtraction ck_null ifst S S concat concatenation ck_concat fst S S +stringify string ck_fun fst S left_shift left bitshift ck_null ifst S S right_shift right bitshift ck_null ifst S S @@ -256,7 +262,7 @@ eq numeric eq ck_null Iifs S S i_eq integer eq ck_null ifs S S ne numeric ne ck_null Iifs S S i_ne integer ne ck_null ifs S S -ncmp spaceship ck_null Iifst S S +ncmp spaceship operator ck_null Iifst S S i_ncmp integer spaceship ck_null ifst S S slt string lt ck_null ifs S S @@ -267,9 +273,9 @@ seq string eq ck_null ifs S S sne string ne ck_null ifs S S scmp string comparison ck_null ifst S S -bit_and bit and ck_null fst S S -xor xor ck_null fst S S -bit_or bit or ck_null fst S S +bit_and bitwise and ck_null fst S S +bit_xor bitwise xor ck_null fst S S +bit_or bitwise or ck_null fst S S negate negate ck_null Ifst S i_negate integer negate ck_null ifst S @@ -279,22 +285,22 @@ complement 1's complement ck_null fst S # High falutin' math. atan2 atan2 ck_fun fst S S -sin sin ck_fun fst S? -cos cos ck_fun fst S? +sin sin ck_fun fstu S? +cos cos ck_fun fstu S? rand rand ck_fun st S? srand srand ck_fun s S? -exp exp ck_fun fst S? -log log ck_fun fst S? -sqrt sqrt ck_fun fst S? +exp exp ck_fun fstu S? +log log ck_fun fstu S? +sqrt sqrt ck_fun fstu S? -int int ck_fun fst S? -hex hex ck_fun ist S? -oct oct ck_fun ist S? -abs abs ck_fun fst S? +int int ck_fun fstu S? +hex hex ck_fun istu S? +oct oct ck_fun istu S? +abs abs ck_fun fstu S? # String stuff. -length length ck_lengthconst ist S +length length ck_lengthconst istu S? substr substr ck_fun st S S S? vec vec ck_fun ist S S S @@ -303,13 +309,14 @@ rindex rindex ck_index ist S S S? sprintf sprintf ck_fun mst S L formline formline ck_formline ms S L -ord ord ck_fun ifst S? -chr chr ck_fun fst S? +ord ord ck_fun ifstu S? +chr chr ck_fun fstu S? crypt crypt ck_fun fst S S -ucfirst upper case first ck_fun ft S -lcfirst lower case first ck_fun ft S -uc upper case ck_fun ft S -lc lower case ck_fun ft S +ucfirst upper case first ck_fun fst S +lcfirst lower case first ck_fun fst S +uc upper case ck_fun fst S +lc lower case ck_fun fst S +quotemeta quote metachars ck_fun fst S # Arrays. @@ -323,7 +330,8 @@ aslice array slice ck_null m A L each each ck_fun t H values values ck_fun t H keys keys ck_fun t H -delete delete ck_null s H S +delete delete ck_delete s S +exists exists operator ck_delete is S rv2hv associative array deref ck_rvconst dt helem associative array elem ck_null s H S hslice associative array slice ck_null m H L @@ -339,10 +347,10 @@ join join ck_fun mst S L list list ck_null m L lslice list slice ck_null 0 H L L -anonlist anonymous list ck_null m L -anonhash anonymous hash ck_null m L +anonlist anonymous list ck_fun ms L +anonhash anonymous hash ck_fun ms L -splice splice ck_fun m A S S? L +splice splice ck_fun m A S? S? L push push ck_fun imst A L pop pop ck_shift s A shift shift ck_shift s A @@ -353,6 +361,9 @@ reverse reverse ck_fun mt L grepstart grep ck_grep dm C L grepwhile grep iterator ck_null dt +mapstart map ck_grep dm C L +mapwhile map iterator ck_null dt + # Range stuff. range flipflop ck_null 0 S S @@ -363,13 +374,14 @@ flop range (or flop) ck_null 0 and logical and ck_null 0 or logical or ck_null 0 +xor logical xor ck_null fs S S cond_expr conditional expression ck_null 0 andassign logical and assignment ck_null s orassign logical or assignment ck_null s method method lookup ck_null d -entersubr subroutine entry ck_subr dm L -leavesubr subroutine exit ck_null 0 +entersub subroutine entry ck_subr dmt L +leavesub subroutine exit ck_null 0 caller caller ck_fun t S? warn warn ck_fun imst L die die ck_fun dimst L @@ -385,7 +397,7 @@ scope block ck_null 0 enteriter foreach loop entry ck_null d iter foreach loop iterator ck_null 0 enterloop loop entry ck_null d -leaveloop loop exit ck_null s +leaveloop loop exit ck_null 0 return return ck_fun dm L last last ck_null ds next next ck_null ds @@ -394,8 +406,8 @@ dump dump ck_null ds goto goto ck_null ds exit exit ck_fun ds S? -nswitch numeric switch ck_null d -cswitch character switch ck_null d +#nswitch numeric switch ck_null d +#cswitch character switch ck_null d # I/O. @@ -457,50 +469,50 @@ getpeername getpeername ck_fun is F # Stat calls. -lstat lstat ck_ftst 0 F -stat stat ck_ftst 0 F -ftrread -R ck_ftst is F -ftrwrite -W ck_ftst is F -ftrexec -X ck_ftst is F -fteread -r ck_ftst is F -ftewrite -w ck_ftst is F -fteexec -x ck_ftst is F -ftis -e ck_ftst is F -fteowned -O ck_ftst is F -ftrowned -o ck_ftst is F -ftzero -z ck_ftst is F -ftsize -s ck_ftst ist F -ftmtime -M ck_ftst st F -ftatime -A ck_ftst st F -ftctime -C ck_ftst st F -ftsock -S ck_ftst is F -ftchr -c ck_ftst is F -ftblk -b ck_ftst is F -ftfile -f ck_ftst is F -ftdir -d ck_ftst is F -ftpipe -p ck_ftst is F -ftlink -l ck_ftst is F -ftsuid -u ck_ftst is F -ftsgid -g ck_ftst is F -ftsvtx -k ck_ftst is F +lstat lstat ck_ftst u F +stat stat ck_ftst u F +ftrread -R ck_ftst isu F +ftrwrite -W ck_ftst isu F +ftrexec -X ck_ftst isu F +fteread -r ck_ftst isu F +ftewrite -w ck_ftst isu F +fteexec -x ck_ftst isu F +ftis -e ck_ftst isu F +fteowned -O ck_ftst isu F +ftrowned -o ck_ftst isu F +ftzero -z ck_ftst isu F +ftsize -s ck_ftst istu F +ftmtime -M ck_ftst stu F +ftatime -A ck_ftst stu F +ftctime -C ck_ftst stu F +ftsock -S ck_ftst isu F +ftchr -c ck_ftst isu F +ftblk -b ck_ftst isu F +ftfile -f ck_ftst isu F +ftdir -d ck_ftst isu F +ftpipe -p ck_ftst isu F +ftlink -l ck_ftst isu F +ftsuid -u ck_ftst isu F +ftsgid -g ck_ftst isu F +ftsvtx -k ck_ftst isu F fttty -t ck_ftst is F -fttext -T ck_ftst is F -ftbinary -B ck_ftst is F +fttext -T ck_ftst isu F +ftbinary -B ck_ftst isu F # File calls. chdir chdir ck_fun ist S? chown chown ck_fun imst L -chroot chroot ck_fun ist S? -unlink unlink ck_fun imst L +chroot chroot ck_fun istu S? +unlink unlink ck_fun imstu L chmod chmod ck_fun imst L utime utime ck_fun imst L rename rename ck_fun ist S S link link ck_fun ist S S symlink symlink ck_fun ist S S -readlink readlink ck_fun st S? +readlink readlink ck_fun stu S? mkdir mkdir ck_fun ist S S -rmdir rmdir ck_fun ist S? +rmdir rmdir ck_fun istu S? # Directory calls. @@ -521,7 +533,7 @@ exec exec ck_exec dimst S? L kill kill ck_fun dimst L getppid getppid ck_null ist getpgrp getpgrp ck_fun ist S? -setpgrp setpgrp ck_fun ist S S +setpgrp setpgrp ck_fun ist S? S? getpriority getpriority ck_fun ist S S setpriority setpriority ck_fun ist S S S @@ -531,7 +543,7 @@ time time ck_null ist tms times ck_null 0 localtime localtime ck_fun t S? gmtime gmtime ck_fun t S? -alarm alarm ck_fun ist S? +alarm alarm ck_fun istu S? sleep sleep ck_fun ist S? # Shared memory. @@ -556,11 +568,11 @@ semop semop ck_fun imst S S S # Eval. -require require ck_require d S? +require require ck_require du S? dofile do 'file' ck_fun d S entereval eval string ck_eval d S leaveeval eval exit ck_null 0 S -evalonce eval constant string ck_null d S +#evalonce eval constant string ck_null d S entertry eval block ck_null 0 leavetry eval block exit ck_null 0 @@ -589,15 +601,15 @@ eservent endservent ck_null is gpwnam getpwnam ck_fun 0 S gpwuid getpwuid ck_fun 0 S gpwent getpwent ck_null 0 -spwent setpwent ck_null ist -epwent endpwent ck_null ist +spwent setpwent ck_null is +epwent endpwent ck_null is ggrnam getgrnam ck_fun 0 S ggrgid getgrgid ck_fun 0 S ggrent getgrent ck_null 0 -sgrent setgrent ck_null ist -egrent endgrent ck_null ist +sgrent setgrent ck_null is +egrent endgrent ck_null is getlogin getlogin ck_null st # Miscellaneous. -syscall syscall ck_fun ist S L +syscall syscall ck_fun imst S L diff --git a/os2/Makefile b/os2/Makefile deleted file mode 100644 index 97d190f5cd..0000000000 --- a/os2/Makefile +++ /dev/null @@ -1,65 +0,0 @@ -# -# Makefile for compiling Perl under OS/2 -# -# Needs Microsoft C 6.00 and NMAKE -# - -EXP = c:\ms\lib\setargv.obj -link /noe - -DEF = os2\perl.def -BAD = os2\perl.bad - -OBJ = array.obj cmd.obj cons.obj consarg.obj doarg.obj doio.obj \ - dolist.obj dump.obj eval.obj form.obj hash.obj perl.obj perly.obj \ - regcomp.obj regexec.obj stab.obj str.obj toke.obj util.obj -OBJO = os2.obj popen.obj suffix.obj director.obj alarm.obj crypt.obj - -LIBS = lgdbm.lib - -YACC=bison -YFLAGS=-d - -CC=cl -nologo -CCL=cl -nologo -B2C2L -B3C3L - -CFLAGS=-W1 -AL -Zep -J -G2s -Olt -Gt 2048 -DDEBUGGING -#CFLAGS=-W1 -AL -Ziep -J -G2 -Od -Gt 2048 -DDEBUGGING - -LDFLAGS=-AL -Lp -F 8000 -#LDFLAGS=-AL -Lp -Zi -Li -F 8000 - -STRIP=bind -nologo -#STRIP=rem - -.c.obj: - $(CC) -c $(CFLAGS) $< - -{os2}.c{}.obj: - $(CC) -c $(CFLAGS) -I. -Ios2 $< - -all: perl.exe perlglob.exe - -perl.exe: $(OBJ) $(OBJO) - $(CC) $(LDFLAGS) $(OBJ) $(OBJO) $(LIBS) os2\perl.def -o $@ $(EXP) - $(STRIP) $@ -n @$(BAD) - -$(OBJ) $(OBJO): config.h -perl.obj str.obj cons.obj toke.obj: perly.h - -config.h: os2\config.h - cp os2\config.h config.h - -perly.c perly.h: perly.y - $(YACC) $(YFLAGS) -o $*.c $*.y - -eval.obj: eval.c - $(CCL) -c $(CFLAGS) $*.c -toke.obj: toke.c - $(CCL) -c $(CFLAGS) $*.c - -perlglob.exe: os2\glob.c os2\director.c - $(CC) -Zep -G2s -Olt -Lp os2\glob.c $(DEF) -o $@ $(EXP) - $(STRIP) $@ -n @$(BAD) - -clean: - -rm perly.c perly.h config.h *.obj >nul diff --git a/os2/README.OS2 b/os2/README.OS2 deleted file mode 100644 index 2cca20cda8..0000000000 --- a/os2/README.OS2 +++ /dev/null @@ -1,434 +0,0 @@ - Notes on the OS/2 Perl port - - Raymond Chen - (rjc@math.princeton.edu) - - Kai Uwe Rommel - (rommel@lan.informatik.tu-muenchen.dbp.de) - --1. Background. - -This port was based on the MS-DOS port by Diomidis Spinellis. - -0. Set-up. - -First copy the files in the os2 directory into the parent -directory. Also install the file msdos/dir.h in your include -directory. - -1. Compiling. - -Perl has been compiled under MS-DOS using the Microsoft C compiler -version 6.0. Before compiling install dir.h as <sys/dir.h>. You will -need a Unix-like make program and something like yacc (e.g. bison). I -just ran yacc on my UNIX box and downloaded the resulting y.tab.[ch] -files. Compilation takes 45 minutes on a 16MHz 386 machine running -no jobs other than the compiler, so you will probably need something to -do in the meantime. Like, say, lunch. (Compilation time does not -include formatting the manual.) If you compile with optimization -turned off, it takes about half as long. - -The executable is 270k (perlsym.exe is 473k; if you compile -without optimization, the sizes are 329K/531K), and the top level -directory needs 800K for sources, 550K for object code, and 800K for the -executables, assuming you want to build both perl.exe and perlsym.exe -with full optimization. - -The makefile will compile glob for you which you will need to place -somewhere in your path so that perl globbing will work correctly. All -the tests were run, although some modifications were necessary because -OS/2 isn't UNIX. The tests that failed failed because of limitations of -the operating system and aren't the fault of the compiler. a2p and s2p -were not tested. - -In the eg directory you will find the syscalls.pl header file, -and a sample program that demonstrates some of the improvements -of the OS/2 version over the MS-DOS version and some of the -system calls. - -2. Using OS/2 Perl - -The OS/2 version of perl has much of the functionality of the Unix -version. Here are some things that don't work: sockets, password -functions, [gs]et[eug]id, dbm functions, fork. - -One thing that doesn't work is "split" with no arguments. Somehow, -yylval.arg is empty ... [[ Wait, sorry, I fixed that. --rjc ]] - -Care has been taken to implement the rest, although the implementation -might not be the best possible. Here are short notes on the tricky -bits: - -2.1. In-place editing. - -Files currently can be edited in-place provided you are creating a -backup. Considerable effort is made to ensure that a reasonable -name for the backup is selected, while still remaining within -the 8.3 contraints of the FAT filesystem. (HPFS users have nothing -to worry about, since HPFS doesn't have the stupid 8.3 rule.) - -The rules for how OS/2 perl combines your filename with the suffix -(the thing passed to "-i") are rather complicated, but the basic -idea is that the "obvious" name is chosen. - -Here are the rules: - -Style 0: Append the suffix exactly as UNIX perl would do it. - If the filesystem likes it, use it. (HPFS will always - swallow it. FAT will rarely accept it.) - -Style 1: If the suffix begins with a '.', change the file extension - to whatever you supplied. If the name matches the original - name, use the fallback method. - -Style 2: If the suffix is a single character, not a '.', try to add the - suffix to the following places, using the first one that works. - [1] Append to extension. - [2] Append to filename, - [3] Replace end of extension, - [4] Replace end of filename. - If the name matches the original name, use the fallback method. - -Style 3: Any other case: Ignore the suffix completely and use the - fallback method. - -Fallback method: Change the extension to ".$$$". If that matches the - original name, then change the extension to ".~~~". - -If filename is more than 1000 characters long, we die a horrible -death. Sorry. - -Examples, assuming style 0 failed. - -suffix = ".bak" (style 1) - foo.bar => foo.bak - foo.bak => foo.$$$ (fallback) - foo.$$$ => foo.~~~ (fallback) - makefile => makefile.bak - -suffix = "~" (style 2) - foo.c => foo.c~ - foo.c~ => foo.c~~ - foo.c~~ => foo~.c~~ - foo~.c~~ => foo~~.c~~ - foo~~~~~.c~~ => foo~~~~~.$$$ (fallback) - - foo.pas => foo~.pas - makefile => makefile.~ - longname.fil => longname.fi~ - longname.fi~ => longnam~.fi~ - longnam~.fi~ => longnam~.$$$ - -2.2. Directory access. - -Are implemented, but in order to support telldir() and seekdir(), -they operate by reading in the entire directory at opendir(), -then handing out pieces of it each time you do a readdir(). - -2.3. Pipes and redirection. - -Pipes and redirection are supported. Although OS/2 does not -terminate programs which try to write to closed pipes, perl will -kill them for you if you do it like this: - - open(I, "long-running-program|"); - ... process a few lines ... - close(I); # discard the rest ... - -The killing works like this: We wait until the child program either -closes its stdout or tries to write to it. If it writes to its stdout, -we kill it. Otherwise, we cwait for it. This is pretty much what UNIX -does by default. - -All pipe commands are given to cmd.exe (or your COMSPEC) for execution as - - CMD /c your-command-line - -so you can go ahead and load it up with any goofy things you want, -like 2>1 redirection, more pipes, && || etc. - -The pipe() function is also supported, so you can go ahead and -make your own funky file descriptor connections before piping off -a process. However, you have to mark the descriptor you are -retaining as NOINHERIT before spawning, else you are in deadlock city. -Unfortunately, there's no way to mark the handle as NOINHERIT yet. -It's on my wish list. - -2.4. Syscall and Ioctl - -IOCtl is not supported because the API is very different from the -UNIX API. Instead, IOCtl is supported as a syscall. Here are -the syscalls I've written so far: - - $OS2_GetVersion = 0; - $OS2_Shutdown = 1; - $OS2_Beep = 2; - $OS2_PhysicalDisk = 3; - $OS2_Config = 4; - $OS2_IOCtl = 5; - $OS2_QCurDisk = 6; - $OS2_SelectDisk = 7; - $OS2_SetMaxFH = 8; - $OS2_Sleep = 9; - $OS2_StartSession = 10; - $OS2_StopSession = 11; - $OS2_SelectSession = 12; - -The arguments you pass are handed off to OS/2 without interpretation, -and the return value is returned straight to you. However, you don't -have to supply arguments for the ones whose descriptions are "must be -zero"; perl will supply the mandatory zeros for you. - -2.5. Binary file access - -Files are opened in text mode by default. This means that CR LF pairs -are translated to LF. If binary access is needed the `binarymode' -function should be used. There is currently no way to reverse the -effect of the binary function. If that is needed close and reopen the -file. - -2.6. Priority - -The getpriority and setpriority functions are implemented, but since -OS/2 priorities are different from UNIX priorities, the arguments aren't -the same. Basically, the arguments you pass are handed directly to -OS/2. The only exception is the last argument to setpriority. To make -it easier to make delta priorities, if the priority class is 0xff, it -is changed to 0. That way, you can write - - setpriority(0,0,-2) - -instead of - - setpriority(0,0,0xfe) - -to decrease the delta by 2. - -2.7. Interpreter startup. - -The effect of the Unix #!/bin/perl interpreter startup can be obtained -under OS/2 by giving the script a .cmd extension and beginning the script -with the line - - extproc C:\binp\perl.exe -S - -You should provide the appropriate path to your executable, and -the -S option is necessary so that perl can find your script. - -2.8. The kill function. - -UNIX and OS/2 have different ideas about the kill function. I've -done a pretty feeble job of taking perl's UNIXish approach and -trying to jam it into the OS/2 way. No doubt you'll find that -your kill()s aren't working. My apologies in advance. - -3. Bug reports. - -I don't normally have access to an OS/2 machine, so if you find -a bug, you can go ahead and tell me about it, but the odds that -I'd be able to fix it are slim. - -4. Wish list. - -4.1. OS/2. - -Make ENOPIPE a fatal error. - -Permit linking of files. (Allegedly, they're working on this.) - -Get a fork. - -Make CMD.EXE pass through the return code of its child. - -4.2 perl. - -Provide a nice way to add new functions to perl without having -to understand the innards of perl. Not being fluent in perl -innards hacking, I added my extra functions via syscall. - -4.3. My port. - -4.3.1. In-place editing. - -Make more idiot-proof. - -Allow in-place editing without backup. (How?) - -4.3.2. Spawning and piping. - -Make popen() cleverer. Currently, it blindly hands everything -off to CMD.EXE. This wastes an exec if the command line didn't -have any shell metacharacters and if the program being run -is not a batch file. - -Clever spawning is carried out by do_spawn. We should try -to make popen() do much of the same sort of preprocessing -as do_spawn does (which means, of course, that we probably -should yank out code to be dished off into a subroutine). - -In do_spawn(), use DosExecPgm instead of spawnl in order to get more -precise reasons why the child terminated (RESULTCODES). - - - July 1990 - - Raymond Chen <rjc@math.princeton.edu> - 1817 Oxford St. Apt 6 - Berkeley, CA 94709-1828 USA - ------------------------ -I picked up the OS/2 port with patches 19-28. When compiling, I found -out that os2.c and director.c were missing. I had to rewrite them because -even the original author of the port (Raymond Chen) did no longer have them. - -I had directory routines laying around, this was no big deal. -I rewrote os2.c, but did not implement the syscall() as described above. -I had not the time and did not really need it. Feel free ... - -Changes to above described port: - -- the small program GLOB is now named PERLGLOB for better ordering in - my /bin directory - -- added help page (well, a graphical user interface would be overkill - but a simple help page should be in every program :-) - -- several cosmetic changes in standard distribution files because of - naming conventions etc., #ifdef'd OS2 - -- syscall() not supported as noted above - -- chdir now recognizes also drive letters and changes also the drive - -- new mypopen(), mypclose() functions and simulation routines for DOS mode, - they are selected automatically in real mode -- the new pclose() does not kill the child, my experience is that this is - not needed. - -- setpriority is now: setpriority(class, pid, val) - see description of DosSetPrty() for class and val meanings -- getpriority is now: getpriority(dummy, pid) - see description of DosGetPrty() - -- kill is now: kill(pid, sig) - where sig can be 0 (kill process) - 1-3 (send process flags A-C, see DosFlagProcess()) - if pid is less than zero, the signal is sent to the whole - process tree originating at -pid. - -The following files are now new with patch >=29: - -readme.os2 this file - -dir.h sys/dir.h -director.c directory routines -os2.c kernel of OS/2 port (see below) -popen.c new popen.c -mktemp.c enhanced mktemp(), uses TMP env. variable, used by popen.c -alarm.c PD implementation for alarm() -alarm.h header for alarm.c - -perl.cs Compiler Shell script for perl itself -perl.def linker definition file for perl -perl.bad names of protect-only API calls for BIND -perlglob.cs Compiler Shell script for perl globbing program -perlglob.def linker definition file for perlglob -a2p.cs Compiler Shell script for a2p (see below) -a2p.def linker definition file for a2p -makefile Makefile, not tested - -perlsh.cmd the converted perlsh -perldb.dif changes required for perldb.pl (change for your needs) -selfrun.cmd sample selfrunning perl script for OS/2 -selfrun.bat sample selfrunning perl script for DOS mode - -Note: I don't use make but my own utility, the Compiler Shell CS. -It was posted in comp.binaries.os2 or you can ask me for the newest -version. The .CS files are the "makefiles" for it. - -Note: MS C 6.00 is required. C 5.1 is not capable of compiling perl, -especially not with -DDEBUGGING - - - August 1990 - - Kai Uwe Rommel - rommel@lan.informatik.tu-muenchen.dbp.de - Zennerstr. 1 - D-8000 Muenchen 70 - - -+ I have verified with patchlevel 37, that the OS/2 port compiles, - after doing two minor changes. HPFS filenames support was also added. - Some bugs were fixed. -+ To compile, - - you need the bison parser generator - - copy config.h from os2 into the main perl directory (important !) - - copy perl.cs and perlglob.cs from the os2 subdir to the main dir - - copy a2p.cs from os2 to x2p - - say "bison -d perl.y" - "ren perl_tab.c perl.c" and - "ren perl_tab.h perly.h" in the main directory - - say "cs perl" and - "cs perlglob" in the main directory - - say "cs a2p" in the x2p subdir -+ If you don't have CS or don't want to use it, you have to - construct a makefile ... -+ If you have GNU gdbm, you can define NDBM in config.h and link with a - large model library of gdbm. -+ I am not sure if I can verify the OS/2 port with each release - from Larry Wall. Therefore, in future releases there may be - changes required to compile perl for OS/2. - October 1990 - Kai Uwe Rommel - rommel@lan.informatik.tu-muenchen.dbp.de - - -Verified patchlevel 40. -Some bugs were fixed. Added alarm() support (using PD implementation). - - - November 1990 - - Kai Uwe Rommel - rommel@lan.informatik.tu-muenchen.dbp.de -Verified perl 4.0 at patchlevel 10 -Changes: -- some minor corrections and updates in various files -- new os2/config.h created from original config.H -- added support for crypt(), PD routine by A.Tanenbaum in new os2/crypt.c -- added support for wait4pid() in os2.c -- fixed/added support for -P option (requires a standard CPP for OS/2) -- os2/mktemp.c deleted, no longer needed -- new Makefile created for MS C 6.00 and it's NMAKE -- with os2/perl.cs, bison has no longer to be called manually -I have successfully run most tests. Diffs are in os2/tests.dif. -Often, only command names, shell expansion etc. have to be changed. -Test that still don't run are Unix-specific ones or fail because -of CR/LF-problems: -- io/argv.t, io/inplace.t, op/exec.t, op/glob.t (minor problems) -- io/fs.t, io/pipe.t op/fork.t, op/magic.t, op/time.t - (under OS/2 not supported features of Unix) -- op/pat.t (bug, not yet fixed) -Remember to remove the HAS_GDBM symbol from os2/config.h or -get GNU gdbm for OS/2. - June 1991 - Kai Uwe Rommel - rommel@lan.informatik.tu-muenchen.dbp.de -Verified perl 4.0 at patchlevel 19 -Minor fixes. Previous fixes at PL10 were not included into distribution. - November 1991 - Kai Uwe Rommel - rommel@informatik.tu-muenchen.dbp.de - - -Verified patchlevel 44. -Only two #ifdefs added to eval.c. Stack size for A2P had to be corrected. -PERLGLOB separated from DOS version because of HPFS support. - -[Note: instead of #ifdef'ing eval.c I fixed it in perl.h--lwall] - - January 1991 - - Kai Uwe Rommel - rommel@lan.informatik.tu-muenchen.dbp.de diff --git a/os2/a2p.cs b/os2/a2p.cs deleted file mode 100644 index 063ec25f46..0000000000 --- a/os2/a2p.cs +++ /dev/null @@ -1,8 +0,0 @@ -(-W1 -Od -Ocgelt a2p.y{a2py.c}) -(-W1 -Od -Ocgelt hash.c str.c util.c walk.c) - -setargv.obj -..\os2\perl.def -a2p.exe - --AL -LB -S0x9000 diff --git a/os2/a2p.def b/os2/a2p.def deleted file mode 100644 index a14bc63f16..0000000000 --- a/os2/a2p.def +++ /dev/null @@ -1 +0,0 @@ -(deprecated) diff --git a/os2/alarm.c b/os2/alarm.c deleted file mode 100644 index 974e2380d8..0000000000 --- a/os2/alarm.c +++ /dev/null @@ -1,149 +0,0 @@ -/* - * This software is Copyright 1989 by Jack Hudler. - * - * Permission is hereby granted to copy, reproduce, redistribute or otherwise - * use this software as long as: there is no monetary profit gained - * specifically from the use or reproduction or this software, it is not - * sold, rented, traded or otherwise marketed, and this copyright notice is - * included prominently in any copy made. - * - * The author make no claims as to the fitness or correctness of this software - * for any use whatsoever, and it is provided as is. Any use of this software - * is at the user's own risk. - * - */ - -/****************************** Module Header ******************************\ -* Module Name: alarm.c -* Created : 11-08-89 -* Author : Jack Hudler [jack@csccat.lonestar.org] -* Copyright : 1988 Jack Hudler. -* Function : Unix like alarm signal simulator. -\***************************************************************************/ - -/* Tested using OS2 1.2 with Microsoft C 5.1 and 6.0. */ - -#define INCL_DOSPROCESS -#define INCL_DOSSIGNALS -#define INCL_DOS -#include <os2.h> - -#include <stdlib.h> -#include <stdio.h> -#include <signal.h> - -#include "alarm.h" - -#define ALARM_STACK 4096 /* This maybe over kill, but the page size is 4K */ - -static PBYTE pbAlarmStack; -static SEL selAlarmStack; -static TID tidAlarm; -static PID pidMain; -static BOOL bAlarmInit=FALSE; -static BOOL bAlarmRunning=FALSE; -static USHORT uTime; - -static VOID FAR alarm_thread ( VOID ) -{ - while(1) - { - if (bAlarmRunning) - { - DosSleep(1000L); - uTime--; - if (uTime==0L) - { - // send signal to the main process.. I could have put raise() here - // however that would require the use of the multithreaded library, - // and it does not contain raise()! - // I tried it with the standard library, this signaled ok, but a - // test printf in the signal would not work and even caused SEGV. - // So I signal the process through OS/2 and then the process - // signals itself. - if (bAlarmRunning) - DosFlagProcess(pidMain,FLGP_PID, PFLG_A,1); - bAlarmRunning=FALSE; - } - } - else - DosSleep(500L); - } -} - -static VOID PASCAL FAR AlarmSignal(USHORT usSigArg,USHORT usSigNum) -{ - /* - * this is not executed from the thread. The thread triggers Process - * flag A which is in the main processes scope, this inturn triggers - * (via the raise) SIGUSR1 which is defined to SIGALRM. - */ - raise(SIGUSR1); -} - -static void alarm_init(void) -{ - PFNSIGHANDLER pfnPrev; - USHORT pfAction; - PIDINFO pid; - - bAlarmInit = TRUE; - - if (!DosAllocSeg( ALARM_STACK, (PSEL) &selAlarmStack, SEG_NONSHARED )) - { - OFFSETOF(pbAlarmStack) = ALARM_STACK - 2; - SELECTOROF(pbAlarmStack) = selAlarmStack; - /* Create the thread */ - if (DosCreateThread( alarm_thread, &tidAlarm, pbAlarmStack )) - { - fprintf(stderr,"Alarm thread failed to start.\n"); - exit(1); - } - /* Setup the signal handler for Process Flag A */ - if (DosSetSigHandler(AlarmSignal,&pfnPrev,&pfAction,SIGA_ACCEPT,SIG_PFLG_A)) - { - fprintf(stderr,"SigHandler Failed to install.\n"); - exit(1); - } - /* Save main process ID, we'll need it for triggering the signal */ - DosGetPID(&pid); - pidMain = pid.pid; - } - else - exit(1); -} - -unsigned alarm(unsigned sec) -{ - if (!bAlarmInit) alarm_init(); - - if (sec) - { - uTime = sec; - bAlarmRunning = TRUE; - } - else - bAlarmRunning = FALSE; - - return 0; -} - -#ifdef TESTING -/* A simple test to see if it works */ -BOOL x; - -void timeout(void) -{ - fprintf(stderr,"ALARM TRIGGERED!!\n"); - DosBeep(1000,500); - x++; -} - -void main(void) -{ - (void) signal(SIGALRM, timeout); - (void) alarm(1L); - printf("ALARM RUNNING!!\n"); - while(!x); -} -#endif diff --git a/os2/alarm.h b/os2/alarm.h deleted file mode 100644 index b5fe69445b..0000000000 --- a/os2/alarm.h +++ /dev/null @@ -1,2 +0,0 @@ -#define SIGALRM SIGUSR1 -unsigned alarm(unsigned); diff --git a/os2/config.h b/os2/config.h deleted file mode 100644 index b37cf5ef5b..0000000000 --- a/os2/config.h +++ /dev/null @@ -1,910 +0,0 @@ -/* manually edited version for OS/2 with MS C 6.00 - check the HAS_?DBM symbols and if you have such a library ... - June 1991, Kai Uwe Rommel */ - -#ifndef config_h -#define config_h -/* config.h - * 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. - */ - -#define OS2 - -/* OS/2 supports some additional things MS-DOS doesn't. - */ -#define S_ISUID 0 -#define S_ISGID 0 - -#define HAS_ALARM -#define HAS_GETPPID -#define HAS_PIPE -#define HAS_KILL -#define HAS_WAIT -#define HAS_UMASK -#define HAS_GDBM - -/* EUNICE - * This symbol, if defined, indicates that the program is being compiled - * under the EUNICE package under VMS. The program will need to handle - * things like files that don't go away the first time you unlink them, - * due to version numbering. It will also need to compensate for lack - * of a respectable link() command. - */ -/* VMS - * This symbol, if defined, indicates that the program is running under - * VMS. It is currently only set in conjunction with the EUNICE symbol. - */ -/*#undef EUNICE /**/ -/*#undef VMS /**/ - -/* ALIGNBYTES - * This symbol contains the number of bytes required to align a double. - * Usual values are 2, 4, and 8. - */ -#define ALIGNBYTES 2 /**/ - -/* BIN - * This symbol holds the name of the directory in which the user wants - * to keep publicly executable images for the package in question. It - * is most often a local directory such as /usr/local/bin. - */ -#define BIN "c:/bin" /**/ - -/* BYTEORDER - * This symbol contains an encoding of the order of bytes in a long. - * Usual values (in octal) are 01234, 04321, 02143, 03412... - */ -#define BYTEORDER 0x1234 /**/ - -/* 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". - */ -/* 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 -P" -#define CPPMINUS "" - -/* HAS_BCMP - * This symbol, if defined, indicates that the bcmp routine is available - * to compare blocks of memory. If undefined, use memcmp. If that's - * not available, roll your own. - */ -/* #define HAS_BCMP /**/ - -/* HAS_BCOPY - * This symbol, if defined, indicates that the bcopy routine is available - * to copy blocks of memory. Otherwise you should probably use memcpy(). - */ -/* #define HAS_BCOPY /**/ - -/* HAS_BZERO - * This symbol, if defined, indicates that the bzero routine is available - * to zero blocks of memory. Otherwise you should probably use memset() - * or roll your own. - */ -/* #define HAS_BZERO /**/ - -/* CASTNEGFLOAT - * This symbol, if defined, indicates that this C compiler knows how to - * cast negative or large floating point 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: - * 1 = couldn't cast < 0 - * 2 = couldn't cast >= 0x80000000 - */ -#define CASTNEGFLOAT /**/ -#define CASTFLAGS 1 /**/ - -/* CHARSPRINTF - * This symbol is defined if this system declares "char *sprintf()" in - * stdio.h. The trend seems to be to declare it as "int sprintf()". It - * is up to the package author to declare sprintf correctly based on the - * symbol. - */ -/* #define CHARSPRINTF /**/ - -/* 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 /**/ - -/* HAS_CRYPT - * This symbol, if defined, indicates that the crypt routine is available - * to encrypt passwords and the like. - */ -#define HAS_CRYPT /**/ - -/* CSH - * This symbol, if defined, indicates that the C-shell exists. - * If defined, contains the full pathname of csh. - */ -/* #define CSH "/bin/csh" /**/ - -/* 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. - */ -/*#undef DOSUID /**/ - -/* HAS_DUP2 - * This symbol, if defined, indicates that the dup2 routine is available - * to dup file descriptors. Otherwise you should use dup(). - */ -#define HAS_DUP2 /**/ - -/* HAS_FCHMOD - * This symbol, if defined, indicates that the fchmod routine is available - * to change mode of opened files. If unavailable, use chmod(). - */ -/* #define HAS_FCHMOD /**/ - -/* HAS_FCHOWN - * This symbol, if defined, indicates that the fchown routine is available - * to change ownership of opened files. If unavailable, use chown(). - */ -/* #define HAS_FCHOWN /**/ - -/* HAS_FCNTL - * This symbol, if defined, indicates to the C program that - * the fcntl() function exists. - */ -/* #define HAS_FCNTL /**/ - -/* FLEXFILENAMES - * This symbol, if defined, indicates that the system supports filenames - * longer than 14 characters. - */ -#define FLEXFILENAMES /**/ - -/* HAS_FLOCK - * This symbol, if defined, indicates that the flock() routine is - * available to do file locking. - */ -/* #define HAS_FLOCK /**/ - -/* HAS_GETGROUPS - * This symbol, if defined, indicates that the getgroups() routine is - * available to get the list of process groups. If unavailable, multiple - * groups are probably not supported. - */ -/* #define HAS_GETGROUPS /**/ - -/* HAS_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 /**/ - -/* 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_GETPRIORITY - * This symbol, if defined, indicates that the getpriority() routine is - * available to get a process's priority. - */ -#define HAS_GETPRIORITY /**/ - -/* HAS_HTONS - * This symbol, if defined, indicates that the htons routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_HTONL - * This symbol, if defined, indicates that the htonl routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_NTOHS - * This symbol, if defined, indicates that the ntohs routine (and friends) - * are available to do network order byte swapping. - */ -/* HAS_NTOHL - * This symbol, if defined, indicates that the ntohl routine (and friends) - * are available to do network order byte swapping. - */ -/* #define HAS_HTONS /**/ -/* #define HAS_HTONL /**/ -/* #define HAS_NTOHS /**/ -/* #define HAS_NTOHL /**/ - -/* index - * This preprocessor symbol is defined, along with rindex, if the system - * uses the strchr and strrchr routines instead. - */ -/* rindex - * This preprocessor symbol is defined, along with index, if the system - * uses the strchr and strrchr routines instead. - */ -#define index strchr /* cultural */ -#define rindex strrchr /* differences? */ - -/* HAS_ISASCII - * This symbol, if defined, indicates that the isascii routine is available - * to test characters for asciiness. - */ -/*#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. - */ -/* #define HAS_KILLPG /**/ - -/* HAS_LSTAT - * This symbol, if defined, indicates that the lstat() routine is - * available to stat symbolic links. - */ -/* #define HAS_LSTAT /**/ - -/* HAS_MEMCMP - * This symbol, if defined, indicates that the memcmp routine is available - * to compare blocks of memory. If undefined, roll your own. - */ -#define HAS_MEMCMP /**/ - -/* HAS_MEMCPY - * This symbol, if defined, indicates that the memcpy routine is available - * to copy blocks of memory. Otherwise you should probably use bcopy(). - * If neither is defined, roll your own. - */ -/* SAFE_MEMCPY - * This symbol, if defined, indicates that the memcpy routine is available - * to copy potentially overlapping copy blocks of memory. Otherwise you - * should probably use memmove() or bcopy(). If neither is defined, - * roll your own. - */ -#define HAS_MEMCPY /**/ -/*#undef SAFE_MEMCPY /**/ - -/* HAS_MEMMOVE - * This symbol, if defined, indicates that the memmove routine is available - * to move potentially overlapping blocks of memory. Otherwise you - * should use bcopy() or roll your own. - */ -/*#undef HAS_MEMMOVE /**/ - -/* HAS_MEMSET - * This symbol, if defined, indicates that the memset routine is available - * to set a block of memory to a character. If undefined, roll your own. - */ -#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_MSG - * This symbol, if defined, indicates that the entire msg*(2) library is - * supported. - */ -/* #define HAS_MSG /**/ - -/* HAS_MSGCTL - * This symbol, if defined, indicates that the msgctl() routine is - * available to control message passing. - */ -/* #define HAS_MSGCTL /**/ - -/* HAS_MSGGET - * This symbol, if defined, indicates that the msgget() routine is - * available to get messages. - */ -/* #define HAS_MSGGET /**/ - -/* HAS_MSGRCV - * This symbol, if defined, indicates that the msgrcv() routine is - * available to receive messages. - */ -/* #define HAS_MSGRCV /**/ - -/* HAS_MSGSND - * This symbol, if defined, indicates that the msgsnd() routine is - * available to send messages. - */ -/* #define HAS_MSGSND /**/ - -/* HAS_NDBM - * This symbol, if defined, indicates that ndbm.h exists and should - * be included. - */ -/* #define HAS_NDBM /**/ - -/* HAS_ODBM - * This symbol, if defined, indicates that dbm.h exists and should - * be included. - */ -/* #define HAS_ODBM /**/ - -/* HAS_OPEN3 - * This manifest constant lets the C program know that the three - * argument form of open(2) is available. - */ -#define HAS_OPEN3 /**/ - -/* HAS_READDIR - * This symbol, if defined, indicates that the readdir routine is available - * from the C library to read directories. - */ -#define HAS_READDIR /**/ - -/* 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_REWINDDIR - * This symbol, if defined, indicates that the rewindir routine is - * available to rewind directories. - */ -#define HAS_REWINDDIR /**/ - -/* 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_SEEKDIR - * This symbol, if defined, indicates that the seekdir routine is - * available to seek into directories. - */ -#define HAS_SEEKDIR /**/ - -/* HAS_SELECT - * This symbol, if defined, indicates that the select() subroutine - * exists. - */ -/* #define HAS_SELECT /**/ - -/* HAS_SEM - * This symbol, if defined, indicates that the entire sem*(2) library is - * supported. - */ -/* #define HAS_SEM /**/ - -/* HAS_SEMCTL - * This symbol, if defined, indicates that the semctl() routine is - * available to control semaphores. - */ -/* #define HAS_SEMCTL /**/ - -/* HAS_SEMGET - * This symbol, if defined, indicates that the semget() routine is - * available to get semaphores ids. - */ -/* #define HAS_SEMGET /**/ - -/* HAS_SEMOP - * This symbol, if defined, indicates that the semop() routine is - * available to perform semaphore operations. - */ -/* #define HAS_SEMOP /**/ - -/* HAS_SETEGID - * This symbol, if defined, indicates that the setegid routine is available - * to change the effective gid of the current program. - */ -/* #define HAS_SETEGID /**/ - -/* HAS_SETEUID - * This symbol, if defined, indicates that the seteuid routine is available - * to change the effective uid of the current program. - */ -/* #define HAS_SETEUID /**/ - -/* HAS_SETPGRP - * This symbol, if defined, indicates that the setpgrp() routine is - * available to set the current process group. - */ -/* #define HAS_SETPGRP /**/ - -/* HAS_SETPGRP2 - * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) - * routine is available to set the current process group. - */ -/*#undef HAS_SETPGRP2 /**/ - -/* HAS_SETPRIORITY - * This symbol, if defined, indicates that the setpriority() routine is - * available to set a process's priority. - */ -#define HAS_SETPRIORITY /**/ - -/* HAS_SETREGID - * This symbol, if defined, indicates that the setregid routine is - * available to change the real and effective gid of the current program. - */ -/* HAS_SETRESGID - * This symbol, if defined, indicates that the setresgid routine is - * available to change the real, effective and saved gid of the current - * program. - */ -/* #define 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 program. - */ -/* HAS_SETRESUID - * This symbol, if defined, indicates that the setresuid routine is - * available to change the real, effective and saved uid of the current - * program. - */ -/* #define 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. - */ -/* #define HAS_SETRGID /**/ - -/* HAS_SETRUID - * This symbol, if defined, indicates that the setruid routine is available - * to change the real uid of the current program. - */ -/* #define HAS_SETRUID /**/ - -/* HAS_SHM - * This symbol, if defined, indicates that the entire shm*(2) library is - * supported. - */ -/* #define HAS_SHM /**/ - -/* HAS_SHMAT - * This symbol, if defined, indicates that the shmat() routine is - * available to attach a shared memory segment. - */ -/* VOID_SHMAT - * This symbol, if defined, indicates that the shmat() routine - * returns a pointer of type void*. - */ -/* #define HAS_SHMAT /**/ - -/*#undef VOIDSHMAT /**/ - -/* HAS_SHMCTL - * This symbol, if defined, indicates that the shmctl() routine is - * available to control a shared memory segment. - */ -/* #define HAS_SHMCTL /**/ - -/* HAS_SHMDT - * This symbol, if defined, indicates that the shmdt() routine is - * available to detach a shared memory segment. - */ -/* #define HAS_SHMDT /**/ - -/* HAS_SHMGET - * This symbol, if defined, indicates that the shmget() routine is - * available to get a shared memory segment id. - */ -/* #define HAS_SHMGET /**/ - -/* 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. - */ -/* OLDSOCKET - * This symbol, if defined, indicates that the 4.1c BSD socket interface - * is supported instead of the 4.2/4.3 BSD socket interface. - */ -/* #define HAS_SOCKET /**/ - -/* #define HAS_SOCKETPAIR /**/ - -/*#undef OLDSOCKET /**/ - -/* STATBLOCKS - * This symbol is defined if this system has a stat structure declaring - * st_blksize and st_blocks. - */ -/* #define STATBLOCKS /**/ - -/* STDSTDIO - * This symbol is defined if this system has a FILE structure declaring - * _ptr and _cnt in stdio.h. - */ -#define STDSTDIO /**/ - -/* STRUCTCOPY - * 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 STRUCTCOPY /**/ - -/* HAS_STRERROR - * This symbol, if defined, indicates that the strerror() routine is - * available to translate error numbers to strings. - */ -/*#undef HAS_STRERROR /**/ - -/* HAS_SYMLINK - * This symbol, if defined, indicates that the symlink routine is available - * to create symbolic links. - */ -/* #define HAS_SYMLINK /**/ - -/* HAS_SYSCALL - * This symbol, if defined, indicates that the syscall routine is available - * to call arbitrary system calls. If undefined, that's tough. - */ -/* #define HAS_SYSCALL /**/ - -/* HAS_TELLDIR - * This symbol, if defined, indicates that the telldir routine is - * available to tell your location in directories. - */ -#define HAS_TELLDIR /**/ - -/* HAS_TRUNCATE - * This symbol, if defined, indicates that the truncate routine is - * available to truncate files. - */ -/* #define HAS_TRUNCATE /**/ - -/* HAS_VFORK - * This symbol, if defined, indicates that vfork() exists. - */ -/* #define HAS_VFORK /**/ - -/* VOIDSIG - * This symbol is defined if this system declares "void (*signal())()" in - * signal.h. The old way was to declare it as "int (*signal())()". It - * is up to the package author to declare things correctly based on the - * symbol. - */ -/* TO_SIGNAL - * This symbol's value is either "void" or "int", corresponding to the - * appropriate return "type" of a signal handler. Thus, one can declare - * a signal handler using "TO_SIGNAL (*handler())()", and define the - * handler using "TO_SIGNAL handler(sig)". - */ -#define VOIDSIG /**/ -#define TO_SIGNAL void /**/ - -/* HASVOLATILE - * This symbol, if defined, indicates that this C compiler knows about - * the volatile declaration. - */ -#define HASVOLATILE /**/ - -/* 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(). - */ -/* CHARVSPRINTF - * 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 CHARVSPRINTF /**/ - -/* HAS_WAIT4 - * This symbol, if defined, indicates that wait4() exists. - */ -/* #define HAS_WAIT4 /**/ - -/* HAS_WAITPID - * This symbol, if defined, indicates that waitpid() exists. - */ -#define HAS_WAITPID /**/ - -/* GIDTYPE - * This symbol has a value like gid_t, int, ushort, or whatever type is - * used to declare group ids in the kernel. - */ -#define GIDTYPE int /**/ - -/* GROUPSTYPE - * This symbol has a value like gid_t, int, ushort, or whatever type is - * used in the return value of getgroups(). - */ -#define GROUPSTYPE int /**/ - -/* I_FCNTL - * This manifest constant tells the C program to include <fcntl.h>. - */ -/*#undef I_FCNTL /**/ - -/* I_GDBM - * This symbol, if defined, indicates that gdbm.h exists and should - * be included. - */ -#define I_GDBM /**/ - -/* I_GRP - * This symbol, if defined, indicates to the C program that it should - * include grp.h. - */ -/* #define I_GRP /**/ - -/* I_NETINET_IN - * This symbol, if defined, indicates to the C program that it should - * include netinet/in.h. - */ -/* I_SYS_IN - * This symbol, if defined, indicates to the C program that it should - * include sys/in.h. - */ -/* #define I_NETINET_IN /**/ -/*#undef I_SYS_IN /**/ - -/* I_PWD - * This symbol, if defined, indicates to the C program that it should - * include pwd.h. - */ -/* PWQUOTA - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_quota. - */ -/* PWAGE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_age. - */ -/* PWCHANGE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_change. - */ -/* PWCLASS - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_class. - */ -/* PWEXPIRE - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_expire. - */ -/* PWCOMMENT - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_comment. - */ -/* #define I_PWD /**/ -/*#undef PWQUOTA /**/ -/* #define PWAGE /**/ -/*#undef PWCHANGE /**/ -/*#undef PWCLASS /**/ -/*#undef PWEXPIRE /**/ -/* #define PWCOMMENT /**/ - -/* I_SYS_FILE - * This manifest constant tells the C program to include <sys/file.h>. - */ -/* #define I_SYS_FILE /**/ - -/* I_SYSIOCTL - * This symbol, if defined, indicates that sys/ioctl.h exists and should - * be included. - */ -/* #define I_SYSIOCTL /**/ - -/* I_TIME - * This symbol is defined if the program should include <time.h>. - */ -/* I_SYS_TIME - * This symbol is defined if the program should include <sys/time.h>. - */ -/* SYSTIMEKERNEL - * This symbol is defined if the program should include <sys/time.h> - * with KERNEL defined. - */ -/* I_SYS_SELECT - * This symbol is defined if the program should include <sys/select.h>. - */ -#define I_TIME /**/ -/* #define I_SYS_TIME /**/ -/*#undef SYSTIMEKERNEL /**/ -/*#undef I_SYS_SELECT /**/ - -/* I_UTIME - * This symbol, if defined, indicates to the C program that it should - * include utime.h. - */ -/* #define I_UTIME /**/ - -/* I_VARARGS - * This symbol, if defined, indicates to the C program that it should - * include varargs.h. - */ -#define I_VARARGS /**/ - -/* I_VFORK - * This symbol, if defined, indicates to the C program that it should - * include vfork.h. - */ -/* #define I_VFORK /**/ - -/* INTSIZE - * This symbol contains the size of an int, so that the C preprocessor - * can make decisions based on it. - */ -#define INTSIZE 2 /**/ - -/* I_DIRENT - * This symbol, if defined, indicates that the program should use the - * P1003-style directory routines, and include <dirent.h>. - */ -/* I_SYS_DIR - * This symbol, if defined, indicates that the program should use the - * directory functions by including <sys/dir.h>. - */ -/* I_NDIR - * This symbol, if defined, indicates that the program should include the - * system's version of ndir.h, rather than the one with this package. - */ -/* I_SYS_NDIR - * This symbol, if defined, indicates that the program should include the - * system's version of sys/ndir.h, rather than the one with this package. - */ -/* I_MY_DIR - * This symbol, if defined, indicates that the program should compile - * the ndir.c code provided with the package. - */ -/* 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. - */ -/* #define I_DIRENT /**/ -#define I_SYS_DIR /**/ -/*#undef I_NDIR /**/ -/*#undef I_SYS_NDIR /**/ -/*#undef I_MY_DIR /**/ -#define DIRNAMLEN /**/ - -/* MYMALLOC - * This symbol, if defined, indicates that we're using our own malloc. - */ -/* MALLOCPTRTYPE - * This symbol defines the kind of ptr returned by malloc and realloc. - */ -#define MYMALLOC /**/ - -#define MALLOCPTRTYPE void /**/ - - -/* 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 keep publicly executable scripts for the package in question. It - * is often a directory that is mounted across diverse architectures. - */ -#define SCRIPTDIR "c:/bin/perl" /**/ - -/* SIG_NAME - * This symbol contains an list of signal names in order. - */ -#define SIG_NAME \ - "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE",\ - /* 0 1 2 3 4 5 6 7 8 */\ - "KILL","BUS","SEGV","SYS","PIPE","UALRM","TERM","ALRM","USR2","CLD",\ - /* 9 10 11 12 13 14 15 16 17 18 */\ - "PWR","USR3","BREAK","ABRT" - /*19 20 21 22 */ - -/* 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 /**/ - -/* UIDTYPE - * This symbol has a value like uid_t, int, ushort, or whatever type is - * used to declare user ids in the kernel. - */ -#define UIDTYPE int /**/ - -/* VOIDHAVE - * 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 - * - * The package designer should define VOIDWANT to indicate the requirements - * of the package. This can be done either by #defining VOIDWANT before - * including config.h, or by defining voidwant in Myinit.U. If the level - * of void support necessary is not present, config.h defines void to "int", - * VOID to the empty string, and VOIDP to "char *". - */ -/* void - * This symbol is used for void casts. On implementations which support - * void appropriately, its value is "void". Otherwise, its value maps - * to "int". - */ -/* VOID - * This symbol's value is "void" if the implementation supports void - * appropriately. Otherwise, its value is the empty string. The primary - * use of this symbol is in specifying void parameter lists for function - * prototypes. - */ -/* VOIDP - * This symbol is used for casting generic pointers. On implementations - * which support void appropriately, its value is "void *". Otherwise, - * its value is "char *". - */ -#ifndef VOIDWANT -#define VOIDWANT 7 -#endif -#define VOIDHAVE 7 -#if (VOIDHAVE & VOIDWANT) != VOIDWANT -#define void int /* is void to be avoided? */ -#define VOID -#define VOIDP (char *) -#define M_VOID /* Xenix strikes again */ -#else -#define VOID void -#define VOIDP (void *) -#endif - -/* PRIVLIB - * This symbol contains the name of the private library for this package. - * The library is private in the sense that it needn't be in anyone's - * execution path, but it should be accessible by the world. The program - * should be prepared to do ~ expansion. - */ -#define PRIVLIB "c:/bin/perl" /**/ - -/* - * BINARY: - * This symbol is defined if you run under an operating system that - * distinguishes between binary and text files. If so the function - * setmode will be used to set the file into binary mode. - */ -#define BINARY - -#endif diff --git a/os2/crypt.c b/os2/crypt.c deleted file mode 100644 index 9f9b562c36..0000000000 --- a/os2/crypt.c +++ /dev/null @@ -1,276 +0,0 @@ -/* From Andy Tanenbaum's book "Computer Networks", - rewritten in C -*/ - -struct block { - unsigned char b_data[64]; -}; - -struct ordering { - unsigned char o_data[64]; -}; - -static struct block key; - -static struct ordering InitialTr = { - 58,50,42,34,26,18,10, 2,60,52,44,36,28,20,12, 4, - 62,54,46,38,30,22,14, 6,64,56,48,40,32,24,16, 8, - 57,49,41,33,25,17, 9, 1,59,51,43,35,27,19,11, 3, - 61,53,45,37,29,21,13, 5,63,55,47,39,31,23,15, 7, -}; - -static struct ordering FinalTr = { - 40, 8,48,16,56,24,64,32,39, 7,47,15,55,23,63,31, - 38, 6,46,14,54,22,62,30,37, 5,45,13,53,21,61,29, - 36, 4,44,12,52,20,60,28,35, 3,43,11,51,19,59,27, - 34, 2,42,10,50,18,58,26,33, 1,41, 9,49,17,57,25, -}; - -static struct ordering swap = { - 33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48, - 49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64, - 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16, - 17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32, -}; - -static struct ordering KeyTr1 = { - 57,49,41,33,25,17, 9, 1,58,50,42,34,26,18, - 10, 2,59,51,43,35,27,19,11, 3,60,52,44,36, - 63,55,47,39,31,23,15, 7,62,54,46,38,30,22, - 14, 6,61,53,45,37,29,21,13, 5,28,20,12, 4, -}; - -static struct ordering KeyTr2 = { - 14,17,11,24, 1, 5, 3,28,15, 6,21,10, - 23,19,12, 4,26, 8,16, 7,27,20,13, 2, - 41,52,31,37,47,55,30,40,51,45,33,48, - 44,49,39,56,34,53,46,42,50,36,29,32, -}; - -static struct ordering etr = { - 32, 1, 2, 3, 4, 5, 4, 5, 6, 7, 8, 9, - 8, 9,10,11,12,13,12,13,14,15,16,17, - 16,17,18,19,20,21,20,21,22,23,24,25, - 24,25,26,27,28,29,28,29,30,31,32, 1, -}; - -static struct ordering ptr = { - 16, 7,20,21,29,12,28,17, 1,15,23,26, 5,18,31,10, - 2, 8,24,14,32,27, 3, 9,19,13,30, 6,22,11, 4,25, -}; - -static unsigned char s_boxes[8][64] = { -{ 14, 4,13, 1, 2,15,11, 8, 3,10, 6,12, 5, 9, 0, 7, - 0,15, 7, 4,14, 2,13, 1,10, 6,12,11, 9, 5, 3, 8, - 4, 1,14, 8,13, 6, 2,11,15,12, 9, 7, 3,10, 5, 0, - 15,12, 8, 2, 4, 9, 1, 7, 5,11, 3,14,10, 0, 6,13, -}, - -{ 15, 1, 8,14, 6,11, 3, 4, 9, 7, 2,13,12, 0, 5,10, - 3,13, 4, 7,15, 2, 8,14,12, 0, 1,10, 6, 9,11, 5, - 0,14, 7,11,10, 4,13, 1, 5, 8,12, 6, 9, 3, 2,15, - 13, 8,10, 1, 3,15, 4, 2,11, 6, 7,12, 0, 5,14, 9, -}, - -{ 10, 0, 9,14, 6, 3,15, 5, 1,13,12, 7,11, 4, 2, 8, - 13, 7, 0, 9, 3, 4, 6,10, 2, 8, 5,14,12,11,15, 1, - 13, 6, 4, 9, 8,15, 3, 0,11, 1, 2,12, 5,10,14, 7, - 1,10,13, 0, 6, 9, 8, 7, 4,15,14, 3,11, 5, 2,12, -}, - -{ 7,13,14, 3, 0, 6, 9,10, 1, 2, 8, 5,11,12, 4,15, - 13, 8,11, 5, 6,15, 0, 3, 4, 7, 2,12, 1,10,14, 9, - 10, 6, 9, 0,12,11, 7,13,15, 1, 3,14, 5, 2, 8, 4, - 3,15, 0, 6,10, 1,13, 8, 9, 4, 5,11,12, 7, 2,14, -}, - -{ 2,12, 4, 1, 7,10,11, 6, 8, 5, 3,15,13, 0,14, 9, - 14,11, 2,12, 4, 7,13, 1, 5, 0,15,10, 3, 9, 8, 6, - 4, 2, 1,11,10,13, 7, 8,15, 9,12, 5, 6, 3, 0,14, - 11, 8,12, 7, 1,14, 2,13, 6,15, 0, 9,10, 4, 5, 3, -}, - -{ 12, 1,10,15, 9, 2, 6, 8, 0,13, 3, 4,14, 7, 5,11, - 10,15, 4, 2, 7,12, 9, 5, 6, 1,13,14, 0,11, 3, 8, - 9,14,15, 5, 2, 8,12, 3, 7, 0, 4,10, 1,13,11, 6, - 4, 3, 2,12, 9, 5,15,10,11,14, 1, 7, 6, 0, 8,13, -}, - -{ 4,11, 2,14,15, 0, 8,13, 3,12, 9, 7, 5,10, 6, 1, - 13, 0,11, 7, 4, 9, 1,10,14, 3, 5,12, 2,15, 8, 6, - 1, 4,11,13,12, 3, 7,14,10,15, 6, 8, 0, 5, 9, 2, - 6,11,13, 8, 1, 4,10, 7, 9, 5, 0,15,14, 2, 3,12, -}, - -{ 13, 2, 8, 4, 6,15,11, 1,10, 9, 3,14, 5, 0,12, 7, - 1,15,13, 8,10, 3, 7, 4,12, 5, 6,11, 0,14, 9, 2, - 7,11, 4, 1, 9,12,14, 2, 0, 6,10,13,15, 3, 5, 8, - 2, 1,14, 7, 4,10, 8,13,15,12, 9, 0, 3, 5, 6,11, -}, -}; - -static int rots[] = { - 1,1,2,2,2,2,2,2,1,2,2,2,2,2,2,1, -}; - -static void transpose(struct block *data, struct ordering *t, int n) -{ - struct block x; - - x = *data; - - while (n-- > 0) { - data->b_data[n] = x.b_data[t->o_data[n] - 1]; - } -} - -static void rotate(struct block *key) -{ - register unsigned char *p = key->b_data; - register unsigned char *ep = &(key->b_data[55]); - int data0 = key->b_data[0], data28 = key->b_data[28]; - - while (p++ < ep) *(p-1) = *p; - key->b_data[27] = (char) data0; - key->b_data[55] = (char) data28; -} - -static struct ordering *EP = &etr; - -static void f(int i, struct block *key, struct block *a, struct block *x) -{ - struct block e, ikey, y; - int k; - register unsigned char *p, *q, *r; - - e = *a; - transpose(&e, EP, 48); - for (k = rots[i]; k; k--) rotate(key); - ikey = *key; - transpose(&ikey, &KeyTr2, 48); - p = &(y.b_data[48]); - q = &(e.b_data[48]); - r = &(ikey.b_data[48]); - while (p > y.b_data) { - *--p = *--q ^ *--r; - } - q = x->b_data; - for (k = 0; k < 8; k++) { - register int xb, r; - - r = *p++ << 5; - r += *p++ << 3; - r += *p++ << 2; - r += *p++ << 1; - r += *p++; - r += *p++ << 4; - - xb = s_boxes[k][r]; - - *q++ = (char) (xb >> 3) & 1; - *q++ = (char) (xb>>2) & 1; - *q++ = (char) (xb>>1) & 1; - *q++ = (char) (xb & 1); - } - transpose(x, &ptr, 32); -} - -void definekey(char *k) -{ - - key = *((struct block *) k); - transpose(&key, &KeyTr1, 56); -} - -void encrypt(char *blck, int edflag) -{ - register struct block *p = (struct block *) blck; - register int i; - - transpose(p, &InitialTr, 64); - for (i = 15; i>= 0; i--) { - int j = edflag ? i : 15 - i; - register int k; - struct block b, x; - - b = *p; - for (k = 31; k >= 0; k--) { - p->b_data[k] = b.b_data[k + 32]; - } - f(j, &key, p, &x); - for (k = 31; k >= 0; k--) { - p->b_data[k+32] = b.b_data[k] ^ x.b_data[k]; - } - } - transpose(p, &swap, 64); - transpose(p, &FinalTr, 64); -} - -char *crypt(char *pw, char *salt) -{ - - char pwb[66]; - static char result[16]; - register char *p = pwb; - struct ordering new_etr; - register int i; - - while (*pw && p < &pwb[64]) { - register int j = 7; - - while (j--) { - *p++ = (*pw >> j) & 01; - } - pw++; - *p++ = 0; - } - while (p < &pwb[64]) *p++ = 0; - - definekey(p = pwb); - - while (p < &pwb[66]) *p++ = 0; - - new_etr = etr; - EP = &new_etr; - for (i = 0; i < 2; i++) { - register char c = *salt++; - register int j; - - result[i] = c; - if ( c > 'Z') c -= 6 + 7 + '.'; /* c was a lower case letter */ - else if ( c > '9') c -= 7 + '.';/* c was upper case letter */ - else c -= '.'; /* c was digit, '.' or '/'. */ - /* now, 0 <= c <= 63 */ - for (j = 0; j < 6; j++) { - if ((c >> j) & 01) { - int t = 6*i + j; - int temp = new_etr.o_data[t]; - new_etr.o_data[t] = new_etr.o_data[t+24]; - new_etr.o_data[t+24] = (char) temp; - } - } - } - - if (result[1] == 0) result[1] = result[0]; - - for (i = 0; i < 25; i++) encrypt(pwb,0); - EP = &etr; - - p = pwb; - pw = result+2; - while (p < &pwb[66]) { - register int c = 0; - register int j = 6; - - while (j--) { - c <<= 1; - c |= *p++; - } - c += '.'; /* becomes >= '.' */ - if (c > '9') c += 7; /* not in [./0-9], becomes upper */ - if (c > 'Z') c += 6; /* not in [A-Z], becomes lower */ - *pw++ = (char) c; - } - *pw = 0; - return result; -} diff --git a/os2/dir.h b/os2/dir.h deleted file mode 100644 index 8ebfae988a..0000000000 --- a/os2/dir.h +++ /dev/null @@ -1,76 +0,0 @@ -/* - * @(#) dir.h 1.4 87/11/06 Public Domain. - * - * A public domain implementation of BSD directory routines for - * MS-DOS. Written by Michael Rendell ({uunet,utai}michael@garfield), - * August 1987 - * - * Enhanced and ported to OS/2 by Kai Uwe Rommel; added scandir() prototype - * December 1989, February 1990 - * Change of MAXPATHLEN for HPFS, October 1990 - */ - - -#define MAXNAMLEN 256 -#define MAXPATHLEN 256 - -#define A_RONLY 0x01 -#define A_HIDDEN 0x02 -#define A_SYSTEM 0x04 -#define A_LABEL 0x08 -#define A_DIR 0x10 -#define A_ARCHIVE 0x20 - - -struct direct -{ - ino_t d_ino; /* a bit of a farce */ - int d_reclen; /* more farce */ - int d_namlen; /* length of d_name */ - char d_name[MAXNAMLEN + 1]; /* null terminated */ - /* nonstandard fields */ - long d_size; /* size in bytes */ - unsigned d_mode; /* DOS or OS/2 file attributes */ - unsigned d_time; - unsigned d_date; -}; - -/* The fields d_size and d_mode are extensions by me (Kai Uwe Rommel). - * The find_first and find_next calls deliver this data without any extra cost. - * If this data is needed, these fields save a lot of extra calls to stat() - * (each stat() again performs a find_first call !). - */ - -struct _dircontents -{ - char *_d_entry; - long _d_size; - unsigned _d_mode, _d_time, _d_date; - struct _dircontents *_d_next; -}; - -typedef struct _dirdesc -{ - int dd_id; /* uniquely identify each open directory */ - long dd_loc; /* where we are in directory entry is this */ - struct _dircontents *dd_contents; /* pointer to contents of dir */ - struct _dircontents *dd_cp; /* pointer to current position */ -} -DIR; - - -extern int attributes; - -extern DIR *opendir(char *); -extern struct direct *readdir(DIR *); -extern void seekdir(DIR *, long); -extern long telldir(DIR *); -extern void closedir(DIR *); -#define rewinddir(dirp) seekdir(dirp, 0L) - -extern int scandir(char *, struct direct ***, - int (*)(struct direct *), - int (*)(struct direct *, struct direct *)); - -extern int getfmode(char *); -extern int setfmode(char *, unsigned); diff --git a/os2/director.c b/os2/director.c deleted file mode 100644 index 3966d3d4bf..0000000000 --- a/os2/director.c +++ /dev/null @@ -1,250 +0,0 @@ -/* - * @(#)dir.c 1.4 87/11/06 Public Domain. - * - * A public domain implementation of BSD directory routines for - * MS-DOS. Written by Michael Rendell ({uunet,utai}michael@garfield), - * August 1897 - * Ported to OS/2 by Kai Uwe Rommel - * December 1989, February 1990 - * Change for HPFS support, October 1990 - */ - -#include <sys/types.h> -#include <sys/stat.h> -#include <sys/dir.h> - -#include <stdlib.h> -#include <stdio.h> -#include <malloc.h> -#include <string.h> -#include <ctype.h> - -#define INCL_NOPM -#include <os2.h> - - -#ifndef PERLGLOB -int attributes = A_DIR | A_HIDDEN; - - -static char *getdirent(char *); -static void free_dircontents(struct _dircontents *); - -static HDIR hdir; -static USHORT count; -static FILEFINDBUF find; -static BOOL lower; - - -DIR *opendir(char *name) -{ - struct stat statb; - DIR *dirp; - char c; - char *s; - struct _dircontents *dp; - char nbuf[MAXPATHLEN + 1]; - - strcpy(nbuf, name); - - if ( ((c = nbuf[strlen(nbuf) - 1]) == '\\' || c == '/') && - (strlen(nbuf) > 1) ) - { - nbuf[strlen(nbuf) - 1] = 0; - - if ( nbuf[strlen(nbuf) - 1] == ':' ) - strcat(nbuf, "\\."); - } - else - if ( nbuf[strlen(nbuf) - 1] == ':' ) - strcat(nbuf, "."); - - if (stat(nbuf, &statb) < 0 || (statb.st_mode & S_IFMT) != S_IFDIR) - return NULL; - - if ( (dirp = malloc(sizeof(DIR))) == NULL ) - return NULL; - - if ( nbuf[strlen(nbuf) - 1] == '.' ) - strcpy(nbuf + strlen(nbuf) - 1, "*.*"); - else - if ( ((c = nbuf[strlen(nbuf) - 1]) == '\\' || c == '/') && - (strlen(nbuf) == 1) ) - strcat(nbuf, "*.*"); - else - strcat(nbuf, "\\*.*"); - - dirp -> dd_loc = 0; - dirp -> dd_contents = dirp -> dd_cp = NULL; - - if ((s = getdirent(nbuf)) == NULL) - return dirp; - - do - { - if (((dp = malloc(sizeof(struct _dircontents))) == NULL) || - ((dp -> _d_entry = malloc(strlen(s) + 1)) == NULL) ) - { - if (dp) - free(dp); - free_dircontents(dirp -> dd_contents); - - return NULL; - } - - if (dirp -> dd_contents) - dirp -> dd_cp = dirp -> dd_cp -> _d_next = dp; - else - dirp -> dd_contents = dirp -> dd_cp = dp; - - strcpy(dp -> _d_entry, s); - dp -> _d_next = NULL; - - dp -> _d_size = find.cbFile; - dp -> _d_mode = find.attrFile; - dp -> _d_time = *(unsigned *) &(find.ftimeLastWrite); - dp -> _d_date = *(unsigned *) &(find.fdateLastWrite); - } - while ((s = getdirent(NULL)) != NULL); - - dirp -> dd_cp = dirp -> dd_contents; - - return dirp; -} - - -void closedir(DIR * dirp) -{ - free_dircontents(dirp -> dd_contents); - free(dirp); -} - - -struct direct *readdir(DIR * dirp) -{ - static struct direct dp; - - if (dirp -> dd_cp == NULL) - return NULL; - - dp.d_namlen = dp.d_reclen = - strlen(strcpy(dp.d_name, dirp -> dd_cp -> _d_entry)); - - dp.d_ino = 0; - - dp.d_size = dirp -> dd_cp -> _d_size; - dp.d_mode = dirp -> dd_cp -> _d_mode; - dp.d_time = dirp -> dd_cp -> _d_time; - dp.d_date = dirp -> dd_cp -> _d_date; - - dirp -> dd_cp = dirp -> dd_cp -> _d_next; - dirp -> dd_loc++; - - return &dp; -} - - -void seekdir(DIR * dirp, long off) -{ - long i = off; - struct _dircontents *dp; - - if (off >= 0) - { - for (dp = dirp -> dd_contents; --i >= 0 && dp; dp = dp -> _d_next); - - dirp -> dd_loc = off - (i + 1); - dirp -> dd_cp = dp; - } -} - - -long telldir(DIR * dirp) -{ - return dirp -> dd_loc; -} - - -static void free_dircontents(struct _dircontents * dp) -{ - struct _dircontents *odp; - - while (dp) - { - if (dp -> _d_entry) - free(dp -> _d_entry); - - dp = (odp = dp) -> _d_next; - free(odp); - } -} - - -static -#endif -int IsFileSystemFAT(char *dir) -{ - USHORT nDrive; - ULONG lMap; - BYTE bData[64], bName[3]; - USHORT cbData; - - if ( _osmode == DOS_MODE ) - return TRUE; - else - { - /* We separate FAT and HPFS file systems here. - * Filenames read from a FAT system are converted to lower case - * while the case of filenames read from a HPFS (and other future - * file systems, like Unix-compatibles) is preserved. - */ - - if ( isalpha(dir[0]) && (dir[1] == ':') ) - nDrive = toupper(dir[0]) - '@'; - else - DosQCurDisk(&nDrive, &lMap); - - bName[0] = (char) (nDrive + '@'); - bName[1] = ':'; - bName[2] = 0; - - cbData = sizeof(bData); - - if ( !DosQFSAttach(bName, 0U, 1U, bData, &cbData, 0L) ) - return !strcmp(bData + (*(USHORT *) (bData + 2) + 7), "FAT"); - else - return FALSE; - - /* End of this ugly code */ - } -} - -#ifndef PERLGLOB -static char *getdirent(char *dir) -{ - int done; - - if (dir != NULL) - { /* get first entry */ - lower = IsFileSystemFAT(dir); - - hdir = HDIR_CREATE; - count = 1; - done = DosFindFirst(dir, &hdir, attributes, - &find, sizeof(find), &count, 0L); - } - else /* get next entry */ - done = DosFindNext(hdir, &find, sizeof(find), &count); - - if ( lower ) - strlwr(find.achName); - - if (done == 0) - return find.achName; - else - { - DosFindClose(hdir); - return NULL; - } -} -#endif diff --git a/os2/eg/alarm.pl b/os2/eg/alarm.pl deleted file mode 100644 index e244df47cc..0000000000 --- a/os2/eg/alarm.pl +++ /dev/null @@ -1,17 +0,0 @@ -sub handler { - local($sig) = @_; - print "Caught a SIG$sig -- shutting down\n"; - exit(0); -} - -$SIG{'ALRM'} = 'handler'; -$SIG{'INT'} = 'handler'; # Ctrl-C pressed -$SIG{'BREAK'} = 'handler'; # Ctrl-Break pressed -$SIG{'TERM'} = 'handler'; # Killed by another process - -print "Starting execution ...\n"; -alarm(10); - -while ( <> ) { -} -print "Normal exit.\n"; diff --git a/os2/eg/os2.pl b/os2/eg/os2.pl deleted file mode 100644 index 411d32712d..0000000000 --- a/os2/eg/os2.pl +++ /dev/null @@ -1,71 +0,0 @@ -extproc C:\binp\misc\perl.exe -S -#!perl - -# os2.pl: Demonstrates the OS/2 system calls and shows off some of the -# features in common with the UNIX version. - -do "syscalls.pl" || die "Cannot load syscalls.pl ($!)"; - -# OS/2 version number. - - $version = " "; syscall($OS2_GetVersion,$version); - ($minor, $major) = unpack("CC", $version); - print "You are using OS/2 version ", int($major/10), - ".", int($minor/10), "\n\n"; - -# Process ID. - print "This process ID is $$ and its parent's ID is ", - getppid(), "\n\n"; - -# Priority. - - printf "Current priority is %x\n", getpriority(0,0); - print "Changing priority by +5\n"; - print "Failed!\n" unless setpriority(0,0,+5); - printf "Priority is now %x\n\n", getpriority(0,0); - -# Beep. - print "Here is an A440.\n\n"; - syscall($OS2_Beep,440,50); - -# Pipes. Unlike MS-DOS, OS/2 supports true asynchronous pipes. - open(ROT13, '|perl -pe y/a-zA-Z/n-za-mN-ZA-M/') || die; - select(ROT13); $|=1; select(STDOUT); - print "Type two lines of stuff, and I'll ROT13 it while you wait.\n". - "If you type fast, you might be able to type both of your\n". - "lines before I get a chance to translate the first line.\n"; - $_ = <STDIN>; print ROT13 $_; - $_ = <STDIN>; print ROT13 $_; - close(ROT13); - print "Thanks.\n\n"; - -# Inspecting the disks. - print "Let's look at the disks you have installed...\n\n"; - - $x = "\0\0"; - syscall($OS2_Config, $x, 2); - print "You have ", unpack("S", $x), " floppy disks,\n"; - - $x = " "; - syscall($OS2_PhysicalDisk, 1, $x, 2, 0, 0); - ($numdisks) = unpack("S", $x); - - print "and $numdisks partitionable disks.\n\n"; - for ($i = 1; $i <= $numdisks; $i++) { - $disk = $i . ":"; - $handle = " "; - syscall($OS2_PhysicalDisk, 2, $handle, 2, $disk, 3); - ($numhandle) = unpack("S", $handle); - $zero = pack("C", 0); - $parmblock = " " x 16; - syscall($OS2_IOCtl, $parmblock, $zero, 0x63, 9, $numhandle); - ($x, $cylinders, $heads, $sect) = unpack("SSSS", $parmblock); - print "Hard drive #$i:\n"; - print " cylinders: $cylinders\n"; - print " heads: $heads\n"; - print " sect/trk: $sect\n"; - syscall($OS2_PhysicalDisk, 3, 0, 0, $handle, 2); - } - -# I won't bother with the other stuff. You get the idea. - diff --git a/os2/eg/syscalls.pl b/os2/eg/syscalls.pl deleted file mode 100644 index 2356f2e478..0000000000 --- a/os2/eg/syscalls.pl +++ /dev/null @@ -1,16 +0,0 @@ -# OS/2 syscall values - -$OS2_GetVersion = 0; -$OS2_Shutdown = 1; -$OS2_Beep = 2; -$OS2_PhysicalDisk = 3; -$OS2_Config = 4; -$OS2_IOCtl = 5; -$OS2_QCurDisk = 6; -$OS2_SelectDisk = 7; -$OS2_SetMaxFH = 8; -$OS2_Sleep = 9; -$OS2_StartSession = 10; -$OS2_StopSession = 11; -$OS2_SelectSession = 12; -1; diff --git a/os2/glob.c b/os2/glob.c deleted file mode 100644 index 75b00848be..0000000000 --- a/os2/glob.c +++ /dev/null @@ -1,21 +0,0 @@ -/* - * Globbing for OS/2. Relies on the expansion done by the library - * startup code. - */ - -#define PERLGLOB -#include "director.c" - -int main(int argc, char **argv) -{ - SHORT i; - USHORT r; - CHAR *f; - - for (i = 1; i < argc; i++) - { - f = IsFileSystemFAT(argv[i]) ? strlwr(argv[i]) : argv[i]; - DosWrite(1, f, strlen(f) + 1, &r); - } - return argc - 1; -} diff --git a/os2/makefile b/os2/makefile deleted file mode 100644 index 9d5fac42b0..0000000000 --- a/os2/makefile +++ /dev/null @@ -1,125 +0,0 @@ -# -# Makefile for compiling Perl under OS/2 -# -# Needs a Unix compatible make. -# This makefile works for an initial compilation. It does not -# include all dependencies and thus is unsuitable for serious -# development work. Hey, I'm just inheriting what Diomidis gave me. -# -# Originally by Diomidis Spinellis, March 1990 -# Adjusted for OS/2 port by Raymond Chen, June 1990 -# - -# Source files -SRC = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c \ -eval.c form.c hash.c perl.y perly.c regcomp.c regexec.c \ -stab.c str.c toke.c util.c os2.c popen.c director.c suffix.c mktemp.c - -# Object files -OBJ = perl.obj array.obj cmd.obj cons.obj consarg.obj doarg.obj doio.obj \ -dolist.obj dump.obj eval.obj form.obj hash.obj perly.obj regcomp.obj \ -regexec.obj stab.obj str.obj toke.obj util.obj os2.obj popen.obj \ -director.obj suffix.obj mktemp.obj - -# Files in the OS/2 distribution -DOSFILES=config.h director.c dir.h makefile os2.c popen.c suffix.c \ -mktemp.c readme.os2 - -# Yacc flags -YFLAGS=-d - -# Manual pages -MAN=perlman.1 perlman.2 perlman.3 perlman.4 - -CC=cl -# CBASE = flags everybody gets -# CPLAIN = flags for modules that give the compiler indigestion -# CFLAGS = flags for milder modules -# PERL = which version of perl to build -# -# For preliminary building: No optimization, DEBUGGING set, symbols included. -#CBASE=-AL -Zi -G2 -Gs -DDEBUGGING -#CPLAIN=$(CBASE) -Od -#CFLAGS=$(CBASE) -Od -#PERL=perlsym.exe - -# For the final build: Optimization on, symbols stripped. -CBASE=-AL -Zi -G2 -Gs -DDEBUGGING -CPLAIN=$(CBASE) -Olt -CFLAGS=$(CBASE) -Oeglt -PERL=perl.exe - -# Destination directory for executables -DESTDIR=\usr\bin - -# Deliverables -# -all: $(PERL) glob.exe - -perl.exe: $(OBJ) perl.arp - link @perl.arp,perl,nul,/stack:32767 /NOE; - exehdr /nologo /newfiles /pmtype:windowcompat perl.exe >nul - -perlsym.exe: $(OBJ) perl.arp - link @perl.arp,perlsym,nul,/stack:32767 /NOE /CODE; - exehdr /nologo /newfiles /pmtype:windowcompat perlsym.exe >nul - -perl.arp: - echo array+cmd+cons+consarg+doarg+doio+dolist+dump+ >perl.arp - echo eval+form+hash+perl+perly+regcomp+regexec+stab+suffix+ >>perl.arp - echo str+toke+util+os2+popen+director+\c600\lib\setargv >>perl.arp - -glob.exe: glob.c - $(CC) glob.c setargv.obj -link /NOE - exehdr /nologo /newfiles /pmtype:windowcompat glob.exe >nul - -array.obj: array.c - $(CC) $(CPLAIN) -c array.c -cmd.obj: cmd.c -cons.obj: cons.c perly.h -consarg.obj: consarg.c -# $(CC) $(CPLAIN) -c consarg.c -doarg.obj: doarg.c -doio.obj: doio.c -dolist.obj: dolist.c -dump.obj: dump.c -eval.obj: eval.c evalargs.xc - $(CC) /B2c2l /B3c3l $(CFLAGS) -c eval.c -form.obj: form.c -hash.obj: hash.c -perl.obj: perl.y -perly.obj: perly.c -regcomp.obj: regcomp.c -regexec.obj: regexec.c -stab.obj: stab.c - $(CC) $(CPLAIN) -c stab.c -str.obj: str.c -suffix.obj: suffix.c -toke.obj: toke.c - $(CC) /B3c3l $(CFLAGS) -c toke.c -util.obj: util.c -# $(CC) $(CPLAIN) -c util.c -perly.h: ytab.h - cp ytab.h perly.h -director.obj: director.c -popen.obj: popen.c -os2.obj: os2.c - -perl.1: $(MAN) - nroff -man $(MAN) >perl.1 - -install: all - exepack perl.exe $(DESTDIR)\perl.exe - exepack glob.exe $(DESTDIR)\glob.exe - -clean: - rm -f *.obj *.exe perl.1 perly.h perl.arp - -tags: - ctags *.c *.h *.xc - -dosperl: - mv $(DOSFILES) ../perl30.new - -doskit: - mv $(DOSFILES) ../os2 diff --git a/os2/mktemp.c b/os2/mktemp.c deleted file mode 100644 index a14bc63f16..0000000000 --- a/os2/mktemp.c +++ /dev/null @@ -1 +0,0 @@ -(deprecated) diff --git a/os2/os2.c b/os2/os2.c deleted file mode 100644 index a0aa0acd1a..0000000000 --- a/os2/os2.c +++ /dev/null @@ -1,298 +0,0 @@ -/* $RCSfile: os2.c,v $$Revision: 4.1 $$Date: 92/08/07 18:25:20 $ - * - * (C) Copyright 1989, 1990 Diomidis Spinellis. - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - * $Log: os2.c,v $ - * Revision 4.1 92/08/07 18:25:20 lwall - * - * Revision 4.0.1.2 92/06/08 14:32:30 lwall - * patch20: new OS/2 support - * - * Revision 4.0.1.1 91/06/07 11:23:06 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:36:21 lwall - * 4.0 baseline. - * - * Revision 3.0.1.2 90/11/10 01:42:38 lwall - * patch38: more msdos/os2 upgrades - * - * Revision 3.0.1.1 90/10/15 17:49:55 lwall - * patch29: Initial revision - * - * Revision 3.0.1.1 90/03/27 16:10:41 lwall - * patch16: MSDOS support - * - * Revision 1.1 90/03/18 20:32:01 dds - * Initial revision - * - */ - -#define INCL_DOS -#define INCL_NOPM -#include <os2.h> - -/* - * Various Unix compatibility functions for OS/2 - */ - -#include <stdio.h> -#include <errno.h> -#include <process.h> - -#include "EXTERN.h" -#include "perl.h" - - -/* dummies */ - -int ioctl(int handle, unsigned int function, char *data) -{ return -1; } - -int userinit() -{ return -1; } - -int syscall() -{ return -1; } - - -/* extended chdir() */ - -int chdir(char *path) -{ - if ( path[0] != 0 && path[1] == ':' ) - if ( DosSelectDisk(toupper(path[0]) - '@') ) - return -1; - - return DosChDir(path, 0L); -} - - -/* priorities */ - -int setpriority(int class, int pid, int val) -{ - int flag = 0; - - if ( pid < 0 ) - { - flag++; - pid = -pid; - } - - return DosSetPrty(flag ? PRTYS_PROCESSTREE : PRTYS_PROCESS, class, val, pid); -} - -int getpriority(int which /* ignored */, int pid) -{ - USHORT val; - - if ( DosGetPrty(PRTYS_PROCESS, &val, pid) ) - return -1; - else - return val; -} - - -/* get parent process id */ - -int getppid(void) -{ - PIDINFO pi; - - DosGetPID(&pi); - return pi.pidParent; -} - - -/* wait for specific pid */ -int wait4pid(int pid, int *status, int flags) -{ - RESULTCODES res; - int endpid, rc; - if ( DosCwait(DCWA_PROCESS, flags ? DCWW_NOWAIT : DCWW_WAIT, - &res, &endpid, pid) ) - return -1; - *status = res.codeResult; - return endpid; -} -/* kill */ - -int kill(int pid, int sig) -{ - int flag = 0; - - if ( pid < 0 ) - { - flag++; - pid = -pid; - } - - switch ( sig & 3 ) - { - - case 0: - DosKillProcess(flag ? DKP_PROCESSTREE : DKP_PROCESS, pid); - break; - - case 1: /* FLAG A */ - DosFlagProcess(pid, flag ? FLGP_SUBTREE : FLGP_PID, PFLG_A, 0); - break; - - case 2: /* FLAG B */ - DosFlagProcess(pid, flag ? FLGP_SUBTREE : FLGP_PID, PFLG_B, 0); - break; - - case 3: /* FLAG C */ - DosFlagProcess(pid, flag ? FLGP_SUBTREE : FLGP_PID, PFLG_C, 0); - break; - - } -} - - -/* Sleep function. */ -void -sleep(unsigned len) -{ - DosSleep(len * 1000L); -} - -/* Just pretend that everyone is a superuser */ - -int setuid() -{ return 0; } - -int setgid() -{ return 0; } - -int getuid(void) -{ return 0; } - -int geteuid(void) -{ return 0; } - -int getgid(void) -{ return 0; } - -int getegid(void) -{ return 0; } - -/* - * The following code is based on the do_exec and do_aexec functions - * in file doio.c - */ -int -do_aspawn(really,arglast) -STR *really; -int *arglast; -{ - register STR **st = stack->ary_array; - register int sp = arglast[1]; - register int items = arglast[2] - sp; - register char **a; - char **argv; - char *tmps; - int status; - - if (items) { - New(1101,argv, items+1, char*); - a = argv; - for (st += ++sp; items > 0; items--,st++) { - if (*st) - *a++ = str_get(*st); - else - *a++ = ""; - } - *a = Nullch; - if (really && *(tmps = str_get(really))) - status = spawnvp(P_WAIT,tmps,argv); - else - status = spawnvp(P_WAIT,argv[0],argv); - Safefree(argv); - } - return status; -} - -char *getenv(char *name); - -int -do_spawn(cmd) -char *cmd; -{ - register char **a; - register char *s; - char **argv; - char flags[10]; - int status; - char *shell, *cmd2; - - /* save an extra exec if possible */ - if ((shell = getenv("COMSPEC")) == 0) - shell = "C:\\OS2\\CMD.EXE"; - - /* see if there are shell metacharacters in it */ - if (strchr(cmd, '>') || strchr(cmd, '<') || strchr(cmd, '|') - || strchr(cmd, '&') || strchr(cmd, '^')) - doshell: - return spawnl(P_WAIT,shell,shell,"/C",cmd,(char*)0); - - New(1102,argv, strlen(cmd) / 2 + 2, char*); - - New(1103,cmd2, strlen(cmd) + 1, char); - strcpy(cmd2, cmd); - a = argv; - for (s = cmd2; *s;) { - while (*s && isspace(*s)) s++; - if (*s) - *(a++) = s; - while (*s && !isspace(*s)) s++; - if (*s) - *s++ = '\0'; - } - *a = Nullch; - if (argv[0]) - if ((status = spawnvp(P_WAIT,argv[0],argv)) == -1) { - Safefree(argv); - Safefree(cmd2); - goto doshell; - } - Safefree(cmd2); - Safefree(argv); - return status; -} - -usage(char *myname) -{ -#ifdef MSDOS - printf("\nUsage: %s [-acdnpPsSvw] [-0[octal]] [-Dnumber] [-i[extension]] [-Idirectory]" -#else - printf("\nUsage: %s [-acdnpPsSuUvw] [-Dnumber] [-i[extension]] [-Idirectory]" -#endif - "\n [-e \"command\"] [-x[directory]] [filename] [arguments]\n", myname); - - printf("\n -a autosplit mode with -n or -p" - "\n -c syntaxcheck only" - "\n -d run scripts under debugger" - "\n -n assume 'while (<>) { ...script... }' loop arround your script" - "\n -p assume loop like -n but print line also like sed" - "\n -P run script through C preprocessor befor compilation" - "\n -s enable some switch parsing for switches after script name" - "\n -S look for the script using PATH environment variable"); -#ifndef MSDOS - printf("\n -u dump core after compiling the script" - "\n -U allow unsafe operations"); -#endif - printf("\n -v print version number and patchlevel of perl" - "\n -w turn warnings on for compilation of your script\n" - "\n -0[octal] specify record separator (0, if no argument)" - "\n -Dnumber set debugging flags (argument is a bit mask)" - "\n -i[extension] edit <> files in place (make backup if extension supplied)" - "\n -Idirectory specify include directory in conjunction with -P" - "\n -e command one line of script, multiple -e options are allowed" - "\n [filename] can be ommitted, when -e is used" - "\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); -} diff --git a/os2/perl.bad b/os2/perl.bad deleted file mode 100644 index 8dd016c513..0000000000 --- a/os2/perl.bad +++ /dev/null @@ -1,8 +0,0 @@ -DOSMAKEPIPE -DOSCWAIT -DOSKILLPROCESS -DOSFLAGPROCESS -DOSSETPRTY -DOSGETPRTY -DOSQFSATTACH -DOSCREATETHREAD diff --git a/os2/perl.cs b/os2/perl.cs deleted file mode 100644 index 000d2c08b4..0000000000 --- a/os2/perl.cs +++ /dev/null @@ -1,21 +0,0 @@ -(-W1 -Od -Olt -DDEBUGGING -Gt2048 -array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c form.c -hash.c perl.c regcomp.c regexec.c stab.c str.c util.c -) -(-W1 -Od -Olt -DDEBUGGING -Gt2048 (-d perly.y)) -(-W1 -Od -Olt -B2C2L -B3C3L -DDEBUGGING eval.c toke.c) -(-W1 -Od -Olt -I. -Ios2 -os2\os2.c os2\popen.c os2\suffix.c -os2\director.c os2\alarm.c os2\crypt.c -) - -; link with this library if you have GNU gdbm for OS/2 -; remember to enable the GDBM symbol in config.h before compiling -llibgdbm.lib - -setargv.obj -os2\perl.def -os2\perl.bad -perl.exe - --AL -LB -S0x8000 diff --git a/os2/perl.def b/os2/perl.def deleted file mode 100644 index 7c0fca0174..0000000000 --- a/os2/perl.def +++ /dev/null @@ -1,2 +0,0 @@ -NAME WINDOWCOMPAT NEWFILES -DESCRIPTION 'PERL 4.0 - for MS-DOS and OS/2' diff --git a/os2/perldb.dif b/os2/perldb.dif deleted file mode 100644 index e69de29bb2..0000000000 --- a/os2/perldb.dif +++ /dev/null diff --git a/os2/perlglob.bad b/os2/perlglob.bad deleted file mode 100644 index a14bc63f16..0000000000 --- a/os2/perlglob.bad +++ /dev/null @@ -1 +0,0 @@ -(deprecated) diff --git a/os2/perlglob.cs b/os2/perlglob.cs deleted file mode 100644 index b5fc1c99b2..0000000000 --- a/os2/perlglob.cs +++ /dev/null @@ -1,9 +0,0 @@ -os2\glob.c - -setargv.obj - -os2\perl.def -os2\perl.bad -perlglob.exe - --AS -LB -S0x1000 diff --git a/os2/perlglob.def b/os2/perlglob.def deleted file mode 100644 index a14bc63f16..0000000000 --- a/os2/perlglob.def +++ /dev/null @@ -1 +0,0 @@ -(deprecated) diff --git a/os2/perlsh.cmd b/os2/perlsh.cmd deleted file mode 100644 index c583af7099..0000000000 --- a/os2/perlsh.cmd +++ /dev/null @@ -1,19 +0,0 @@ -extproc perl -x -#!perl - -# Poor man's perl shell. - -# Simply type two carriage returns every time you want to evaluate. -# Note that it must be a complete perl statement--don't type double -# carriage return in the middle of a loop. - -print "Perl shell\n> "; - -$/ = ''; # set paragraph mode -$SHlinesep = "\n"; - -while ($SHcmd = <>) { - $/ = $SHlinesep; - eval $SHcmd; print $@ || "\n> "; - $SHlinesep = $/; $/ = ''; -} diff --git a/os2/popen.c b/os2/popen.c deleted file mode 100644 index b9522b5671..0000000000 --- a/os2/popen.c +++ /dev/null @@ -1,241 +0,0 @@ -/* added real/protect mode branch at runtime and real mode version - * names changed for perl - * Kai Uwe Rommel - */ - -/* -Several people in the past have asked about having Unix-like pipe -calls in OS/2. The following source file, adapted from 4.3 BSD Unix, -uses a #define to give you a pipe(2) call, and contains function -definitions for popen(3) and pclose(3). Anyone with problems should -send mail to me; they seem to work fine. - -Mark Towfigh -Racal Interlan, Inc. -----------------------------------cut-here------------------------------------ -*/ - -/* - * The following code segment is derived from BSD 4.3 Unix. See - * copyright below. Any bugs, questions, improvements, or problems - * should be sent to Mark Towfigh (towfiq@interlan.interlan.com). - * - * Racal InterLan Inc. - */ - -/* - * Copyright (c) 1980 Regents of the University of California. - * All rights reserved. The Berkeley software License Agreement - * specifies the terms and conditions for redistribution. - */ - -#include <stdio.h> -#include <stdlib.h> -#include <io.h> -#include <string.h> -#include <process.h> -#include <errno.h> - -#define INCL_NOPM -#define INCL_DOS -#include <os2.h> - -static FILE *dos_popen(const char *cmd, const char *flags); -static int dos_pclose(FILE *pipe); - -/* - * emulate Unix pipe(2) call - */ - -#define tst(a,b) (*mode == 'r'? (b) : (a)) -#define READH 0 -#define WRITEH 1 - -static int popen_pid[20]; - -FILE *mypopen(char *cmd, char *mode) -{ - int p[2]; - register myside, hisside, save_stream; - char *shell = getenv("COMPSPEC"); - - if ( shell == NULL ) - shell = "C:\\OS2\\CMD.EXE"; - - if ( _osmode == DOS_MODE ) - return dos_popen(cmd, mode); - - if ( _pipe(p, 4096, 0) ) - return NULL; - - myside = tst(p[WRITEH], p[READH]); - hisside = tst(p[READH], p[WRITEH]); - - /* set up file descriptors for remote function */ - save_stream = dup(tst(0, 1)); /* don't lose stdin/out! */ - if (dup2(hisside, tst(0, 1)) < 0) - { - perror("dup2"); - return NULL; - } - close(hisside); - - /* - * make sure that we can close our side of the pipe, by - * preventing it from being inherited! - */ - - /* set no-inheritance flag */ - DosSetFHandState(myside, OPEN_FLAGS_NOINHERIT); - - /* execute the command: it will inherit our other file descriptors */ - popen_pid[myside] = spawnlp(P_NOWAIT, shell, shell, "/C", cmd, NULL); - - /* now restore our previous file descriptors */ - if (dup2(save_stream, tst(0, 1)) < 0) /* retrieve stdin/out */ - { - perror("dup2"); - return NULL; - } - close(save_stream); - - return fdopen(myside, mode); /* return a FILE pointer */ -} - -int mypclose(FILE *ptr) -{ - register f; - int status; - - if ( _osmode == DOS_MODE ) - return dos_pclose(ptr); - - f = fileno(ptr); - fclose(ptr); - - /* wait for process to terminate */ - cwait(&status, popen_pid[f], WAIT_GRANDCHILD); - - return status; -} - - -int pipe(int *filedes) -{ - int res; - - if ( res = _pipe(filedes, 4096, 0) ) - return res; - - DosSetFHandState(filedes[0], OPEN_FLAGS_NOINHERIT); - DosSetFHandState(filedes[1], OPEN_FLAGS_NOINHERIT); - return 0; -} - - -/* this is the MS-DOS version */ - -typedef enum { unopened = 0, reading, writing } pipemode; - -static struct -{ - char *name; - char *command; - pipemode pmode; -} -pipes[_NFILE]; - -static FILE *dos_popen(const char *command, const char *mode) -{ - FILE *current; - char name[128]; - char *tmp = getenv("TMP"); - int cur; - pipemode curmode; - - /* - ** decide on mode. - */ - if(strchr(mode, 'r') != NULL) - curmode = reading; - else if(strchr(mode, 'w') != NULL) - curmode = writing; - else - return NULL; - - /* - ** get a name to use. - */ - strcpy(name, tmp ? tmp : "\\"); - if ( name[strlen(name) - 1] != '\\' ) - strcat(name, "\\"); - strcat(name, "piXXXXXX"); - mktemp(name); - - /* - ** If we're reading, just call system to get a file filled with - ** output. - */ - if(curmode == reading) - { - char cmd[256]; - sprintf(cmd,"%s > %s", command, name); - system(cmd); - - if((current = fopen(name, mode)) == NULL) - return NULL; - } - else - { - if((current = fopen(name, mode)) == NULL) - return NULL; - } - - cur = fileno(current); - pipes[cur].name = strdup(name); - pipes[cur].command = strdup(command); - pipes[cur].pmode = curmode; - - return current; -} - -static int dos_pclose(FILE * current) -{ - int cur = fileno(current), rval; - char command[256]; - - /* - ** check for an open file. - */ - if(pipes[cur].pmode == unopened) - return -1; - - if(pipes[cur].pmode == reading) - { - /* - ** input pipes are just files we're done with. - */ - rval = fclose(current); - unlink(pipes[cur].name); - } - else - { - /* - ** output pipes are temporary files we have - ** to cram down the throats of programs. - */ - fclose(current); - sprintf(command,"%s < %s", pipes[cur].command, pipes[cur].name); - rval = system(command); - unlink(pipes[cur].name); - } - - /* - ** clean up current pipe. - */ - free(pipes[cur].name); - free(pipes[cur].command); - pipes[cur].pmode = unopened; - - return rval; -} diff --git a/os2/s2p.cmd b/os2/s2p.cmd deleted file mode 100755 index d0a1246186..0000000000 --- a/os2/s2p.cmd +++ /dev/null @@ -1,678 +0,0 @@ -extproc perl -Sx -#!perl - -$bin = 'c:/bin'; - -# $RCSfile: s2p.cmd,v $$Revision: 4.1 $$Date: 92/08/07 18:25:37 $ -# -# $Log: s2p.cmd,v $ -# Revision 4.1 92/08/07 18:25:37 lwall -# -# Revision 4.0 91/03/20 01:37:09 lwall -# 4.0 baseline. -# -# Revision 3.0.1.6 90/10/20 02:21:43 lwall -# patch37: changed some ". config.sh" to ". ./config.sh" -# -# Revision 3.0.1.5 90/10/16 11:32:40 lwall -# patch29: s2p modernized -# -# Revision 3.0.1.4 90/08/09 05:50:43 lwall -# patch19: s2p didn't translate \n right -# -# Revision 3.0.1.3 90/03/01 10:31:21 lwall -# patch9: s2p didn't handle \< and \> -# -# Revision 3.0.1.2 89/11/17 15:51:27 lwall -# patch5: in s2p, line labels without a subsequent statement were done wrong -# patch5: s2p left residue in /tmp -# -# Revision 3.0.1.1 89/11/11 05:08:25 lwall -# patch2: in s2p, + within patterns needed backslashing -# patch2: s2p was printing out some debugging info to the output file -# -# Revision 3.0 89/10/18 15:35:02 lwall -# 3.0 baseline -# -# Revision 2.0.1.1 88/07/11 23:26:23 root -# patch2: s2p didn't put a proper prologue on output script -# -# Revision 2.0 88/06/05 00:15:55 root -# Baseline version 2.0. -# -# - -$indent = 4; -$shiftwidth = 4; -$l = '{'; $r = '}'; - -while ($ARGV[0] =~ /^-/) { - $_ = shift; - last if /^--/; - if (/^-D/) { - $debug++; - open(BODY,'>-'); - next; - } - if (/^-n/) { - $assumen++; - next; - } - if (/^-p/) { - $assumep++; - next; - } - die "I don't recognize this switch: $_\n"; -} - -unless ($debug) { - open(BODY,">sperl$$") || - &Die("Can't open temp file: $!\n"); -} - -if (!$assumen && !$assumep) { - print BODY <<'EOT'; -while ($ARGV[0] =~ /^-/) { - $_ = shift; - last if /^--/; - if (/^-n/) { - $nflag++; - next; - } - die "I don't recognize this switch: $_\\n"; -} - -EOT -} - -print BODY <<'EOT'; - -#ifdef PRINTIT -#ifdef ASSUMEP -$printit++; -#else -$printit++ unless $nflag; -#endif -#endif -LINE: while (<>) { -EOT - -LINE: while (<>) { - - # Wipe out surrounding whitespace. - - s/[ \t]*(.*)\n$/$1/; - - # Perhaps it's a label/comment. - - if (/^:/) { - s/^:[ \t]*//; - $label = &make_label($_); - if ($. == 1) { - $toplabel = $label; - } - $_ = "$label:"; - if ($lastlinewaslabel++) { - $indent += 4; - print BODY &tab, ";\n"; - $indent -= 4; - } - if ($indent >= 2) { - $indent -= 2; - $indmod = 2; - } - next; - } else { - $lastlinewaslabel = ''; - } - - # Look for one or two address clauses - - $addr1 = ''; - $addr2 = ''; - if (s/^([0-9]+)//) { - $addr1 = "$1"; - } - elsif (s/^\$//) { - $addr1 = 'eof()'; - } - elsif (s|^/||) { - $addr1 = &fetchpat('/'); - } - if (s/^,//) { - if (s/^([0-9]+)//) { - $addr2 = "$1"; - } elsif (s/^\$//) { - $addr2 = "eof()"; - } elsif (s|^/||) { - $addr2 = &fetchpat('/'); - } else { - &Die("Invalid second address at line $.\n"); - } - $addr1 .= " .. $addr2"; - } - - # Now we check for metacommands {, }, and ! and worry - # about indentation. - - s/^[ \t]+//; - # a { to keep vi happy - if ($_ eq '}') { - $indent -= 4; - next; - } - if (s/^!//) { - $if = 'unless'; - $else = "$r else $l\n"; - } else { - $if = 'if'; - $else = ''; - } - if (s/^{//) { # a } to keep vi happy - $indmod = 4; - $redo = $_; - $_ = ''; - $rmaybe = ''; - } else { - $rmaybe = "\n$r"; - if ($addr2 || $addr1) { - $space = ' ' x $shiftwidth; - } else { - $space = ''; - } - $_ = &transmogrify(); - } - - # See if we can optimize to modifier form. - - if ($addr1) { - if ($_ !~ /[\n{}]/ && $rmaybe && !$change && - $_ !~ / if / && $_ !~ / unless /) { - s/;$/ $if $addr1;/; - $_ = substr($_,$shiftwidth,1000); - } else { - $_ = "$if ($addr1) $l\n$change$_$rmaybe"; - } - $change = ''; - next LINE; - } -} continue { - @lines = split(/\n/,$_); - for (@lines) { - unless (s/^ *<<--//) { - print BODY &tab; - } - print BODY $_, "\n"; - } - $indent += $indmod; - $indmod = 0; - if ($redo) { - $_ = $redo; - $redo = ''; - redo LINE; - } -} -if ($lastlinewaslabel++) { - $indent += 4; - print BODY &tab, ";\n"; - $indent -= 4; -} - -print BODY "}\n"; -if ($appendseen || $tseen || !$assumen) { - $printit++ if $dseen || (!$assumen && !$assumep); - print BODY <<'EOT'; - -continue { -#ifdef PRINTIT -#ifdef DSEEN -#ifdef ASSUMEP - print if $printit++; -#else - if ($printit) - { print; } - else - { $printit++ unless $nflag; } -#endif -#else - print if $printit; -#endif -#else - print; -#endif -#ifdef TSEEN - $tflag = ''; -#endif -#ifdef APPENDSEEN - if ($atext) { print $atext; $atext = ''; } -#endif -} -EOT -} - -close BODY; - -unless ($debug) { - open(HEAD,">sperl2$$.c") - || &Die("Can't open temp file 2: $!\n"); - print HEAD "#define PRINTIT\n" if ($printit); - print HEAD "#define APPENDSEEN\n" if ($appendseen); - print HEAD "#define TSEEN\n" if ($tseen); - print HEAD "#define DSEEN\n" if ($dseen); - print HEAD "#define ASSUMEN\n" if ($assumen); - print HEAD "#define ASSUMEP\n" if ($assumep); - if ($opens) {print HEAD "$opens\n";} - open(BODY,"sperl$$") - || &Die("Can't reopen temp file: $!\n"); - while (<BODY>) { - print HEAD $_; - } - close HEAD; - - print <<"EOT"; -#!$bin/perl -eval 'exec $bin/perl -S \$0 \$*' - if \$running_under_some_shell; - -EOT - open(BODY,"cc -E sperl2$$.c |") || - &Die("Can't reopen temp file: $!\n"); - while (<BODY>) { - /^# [0-9]/ && next; - /^[ \t]*$/ && next; - s/^<><>//; - print; - } -} - -&Cleanup; -exit; - -sub Cleanup { - unlink "sperl$$", "sperl2$$", "sperl2$$.c"; -} -sub Die { - &Cleanup; - die $_[0]; -} -sub tab { - "\t" x ($indent / 8) . ' ' x ($indent % 8); -} -sub make_filehandle { - local($_) = $_[0]; - local($fname) = $_; - s/[^a-zA-Z]/_/g; - s/^_*//; - substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/; - if (!$seen{$_}) { - $opens .= <<"EOT"; -open($_,'>$fname') || die "Can't create $fname"; -EOT - } - $seen{$_} = $_; -} - -sub make_label { - local($label) = @_; - $label =~ s/[^a-zA-Z0-9]/_/g; - if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } - $label = substr($label,0,8); - - # Could be a reserved word, so capitalize it. - substr($label,0,1) =~ y/a-z/A-Z/ - if $label =~ /^[a-z]/; - - $label; -} - -sub transmogrify { - { # case - if (/^d/) { - $dseen++; - chop($_ = <<'EOT'); -<<--#ifdef PRINTIT -$printit = ''; -<<--#endif -next LINE; -EOT - next; - } - - if (/^n/) { - chop($_ = <<'EOT'); -<<--#ifdef PRINTIT -<<--#ifdef DSEEN -<<--#ifdef ASSUMEP -print if $printit++; -<<--#else -if ($printit) - { print; } -else - { $printit++ unless $nflag; } -<<--#endif -<<--#else -print if $printit; -<<--#endif -<<--#else -print; -<<--#endif -<<--#ifdef APPENDSEEN -if ($atext) {print $atext; $atext = '';} -<<--#endif -$_ = <>; -<<--#ifdef TSEEN -$tflag = ''; -<<--#endif -EOT - next; - } - - if (/^a/) { - $appendseen++; - $command = $space . '$atext .=' . "\n<<--'"; - $lastline = 0; - while (<>) { - s/^[ \t]*//; - s/^[\\]//; - unless (s|\\$||) { $lastline = 1;} - s/'/\\'/g; - s/^([ \t]*\n)/<><>$1/; - $command .= $_; - $command .= '<<--'; - last if $lastline; - } - $_ = $command . "';"; - last; - } - - if (/^[ic]/) { - if (/^c/) { $change = 1; } - $addr1 = '$iter = (' . $addr1 . ')'; - $command = $space . 'if ($iter == 1) { print' - . "\n<<--'"; - $lastline = 0; - while (<>) { - s/^[ \t]*//; - s/^[\\]//; - unless (s/\\$//) { $lastline = 1;} - s/'/\\'/g; - s/^([ \t]*\n)/<><>$1/; - $command .= $_; - $command .= '<<--'; - last if $lastline; - } - $_ = $command . "';}"; - if ($change) { - $dseen++; - $change = "$_\n"; - chop($_ = <<"EOT"); -<<--#ifdef PRINTIT -$space\$printit = ''; -<<--#endif -${space}next LINE; -EOT - } - last; - } - - if (/^s/) { - $delim = substr($_,1,1); - $len = length($_); - $repl = $end = 0; - $inbracket = 0; - for ($i = 2; $i < $len; $i++) { - $c = substr($_,$i,1); - if ($c eq $delim) { - if ($inbracket) { - substr($_, $i, 0) = '\\'; - $i++; - $len++; - } - else { - if ($repl) { - $end = $i; - last; - } else { - $repl = $i; - } - } - } - elsif ($c eq '\\') { - $i++; - if ($i >= $len) { - $_ .= 'n'; - $_ .= <>; - $len = length($_); - $_ = substr($_,0,--$len); - } - elsif (substr($_,$i,1) =~ /^[n]$/) { - ; - } - elsif (!$repl && - substr($_,$i,1) =~ /^[(){}\w]$/) { - $i--; - $len--; - substr($_, $i, 1) = ''; - } - elsif (!$repl && - substr($_,$i,1) =~ /^[<>]$/) { - substr($_,$i,1) = 'b'; - } - } - elsif ($c eq '[' && !$repl) { - $i++ if substr($_,$i,1) eq '^'; - $i++ if substr($_,$i,1) eq ']'; - $inbracket = 1; - } - elsif ($c eq ']') { - $inbracket = 0; - } - elsif (!$repl && index("()+",$c) >= 0) { - substr($_, $i, 0) = '\\'; - $i++; - $len++; - } - } - &Die("Malformed substitution at line $.\n") - unless $end; - $pat = substr($_, 0, $repl + 1); - $repl = substr($_, $repl+1, $end-$repl-1); - $end = substr($_, $end + 1, 1000); - $dol = '$'; - $repl =~ s/\$/\\$/; - $repl =~ s'&'$&'g; - $repl =~ s/[\\]([0-9])/$dol$1/g; - $subst = "$pat$repl$delim"; - $cmd = ''; - while ($end) { - if ($end =~ s/^g//) { - $subst .= 'g'; - next; - } - if ($end =~ s/^p//) { - $cmd .= ' && (print)'; - next; - } - if ($end =~ s/^w[ \t]*//) { - $fh = &make_filehandle($end); - $cmd .= " && (print $fh \$_)"; - $end = ''; - next; - } - &Die("Unrecognized substitution command". - "($end) at line $.\n"); - } - chop ($_ = <<"EOT"); -<<--#ifdef TSEEN -$subst && \$tflag++$cmd; -<<--#else -$subst$cmd; -<<--#endif -EOT - next; - } - - if (/^p/) { - $_ = 'print;'; - next; - } - - if (/^w/) { - s/^w[ \t]*//; - $fh = &make_filehandle($_); - $_ = "print $fh \$_;"; - next; - } - - if (/^r/) { - $appendseen++; - s/^r[ \t]*//; - $file = $_; - $_ = "\$atext .= `cat $file 2>/dev/null`;"; - next; - } - - if (/^P/) { - $_ = 'print $1 if /(^.*\n)/;'; - next; - } - - if (/^D/) { - chop($_ = <<'EOT'); -s/^.*\n//; -redo LINE if $_; -next LINE; -EOT - next; - } - - if (/^N/) { - chop($_ = <<'EOT'); -$_ .= <>; -<<--#ifdef TSEEN -$tflag = ''; -<<--#endif -EOT - next; - } - - if (/^h/) { - $_ = '$hold = $_;'; - next; - } - - if (/^H/) { - $_ = '$hold .= $_ ? $_ : "\n";'; - next; - } - - if (/^g/) { - $_ = '$_ = $hold;'; - next; - } - - if (/^G/) { - $_ = '$_ .= $hold ? $hold : "\n";'; - next; - } - - if (/^x/) { - $_ = '($_, $hold) = ($hold, $_);'; - next; - } - - if (/^b$/) { - $_ = 'next LINE;'; - next; - } - - if (/^b/) { - s/^b[ \t]*//; - $lab = &make_label($_); - if ($lab eq $toplabel) { - $_ = 'redo LINE;'; - } else { - $_ = "goto $lab;"; - } - next; - } - - if (/^t$/) { - $_ = 'next LINE if $tflag;'; - $tseen++; - next; - } - - if (/^t/) { - s/^t[ \t]*//; - $lab = &make_label($_); - $_ = q/if ($tflag) {$tflag = ''; /; - if ($lab eq $toplabel) { - $_ .= 'redo LINE;}'; - } else { - $_ .= "goto $lab;}"; - } - $tseen++; - next; - } - - if (/^=/) { - $_ = 'print "$.\n";'; - next; - } - - if (/^q/) { - chop($_ = <<'EOT'); -close(ARGV); -@ARGV = (); -next LINE; -EOT - next; - } - } continue { - if ($space) { - s/^/$space/; - s/(\n)(.)/$1$space$2/g; - } - last; - } - $_; -} - -sub fetchpat { - local($outer) = @_; - local($addr) = $outer; - local($inbracket); - local($prefix,$delim,$ch); - - # Process pattern one potential delimiter at a time. - - DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) { - $prefix = $1; - $delim = $2; - if ($delim eq '\\') { - s/(.)//; - $ch = $1; - $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/; - $ch = 'b' if $ch =~ /^[<>]$/; - $delim .= $ch; - } - elsif ($delim eq '[') { - $inbracket = 1; - s/^\^// && ($delim .= '^'); - s/^]// && ($delim .= ']'); - } - elsif ($delim eq ']') { - $inbracket = 0; - } - elsif ($inbracket || $delim ne $outer) { - $delim = '\\' . $delim; - } - $addr .= $prefix; - $addr .= $delim; - if ($delim eq $outer && !$inbracket) { - last DELIM; - } - } - $addr; -} diff --git a/os2/selfrun.bat b/os2/selfrun.bat deleted file mode 100755 index 9ec8a2920d..0000000000 --- a/os2/selfrun.bat +++ /dev/null @@ -1,12 +0,0 @@ -@echo off -perl -x %0.bat -goto exit -#!perl - -printf " -This is a self-running perl script for DOS. - -" - -__END__ -:exit diff --git a/os2/selfrun.cmd b/os2/selfrun.cmd deleted file mode 100644 index 471a959005..0000000000 --- a/os2/selfrun.cmd +++ /dev/null @@ -1,7 +0,0 @@ -extproc perl -x -#!perl - -printf " -This is a self-running perl script using the -extproc feature of the OS/2 command processor. -" diff --git a/os2/suffix.c b/os2/suffix.c deleted file mode 100644 index d766da37bc..0000000000 --- a/os2/suffix.c +++ /dev/null @@ -1,147 +0,0 @@ -/* - * Suffix appending for in-place editing under MS-DOS and OS/2. - * - * Here are the rules: - * - * Style 0: Append the suffix exactly as standard perl would do it. - * If the filesystem groks it, use it. (HPFS will always - * grok it. FAT will rarely accept it.) - * - * Style 1: The suffix begins with a '.'. The extension is replaced. - * If the name matches the original name, use the fallback method. - * - * Style 2: The suffix is a single character, not a '.'. Try to add the - * suffix to the following places, using the first one that works. - * [1] Append to extension. - * [2] Append to filename, - * [3] Replace end of extension, - * [4] Replace end of filename. - * If the name matches the original name, use the fallback method. - * - * Style 3: Any other case: Ignore the suffix completely and use the - * fallback method. - * - * Fallback method: Change the extension to ".$$$". If that matches the - * original name, then change the extension to ".~~~". - * - * If filename is more than 1000 characters long, we die a horrible - * death. Sorry. - * - * The filename restriction is a cheat so that we can use buf[] to store - * assorted temporary goo. - * - * Examples, assuming style 0 failed. - * - * suffix = ".bak" (style 1) - * foo.bar => foo.bak - * foo.bak => foo.$$$ (fallback) - * foo.$$$ => foo.~~~ (fallback) - * makefile => makefile.bak - * - * suffix = "~" (style 2) - * foo.c => foo.c~ - * foo.c~ => foo.c~~ - * foo.c~~ => foo~.c~~ - * foo~.c~~ => foo~~.c~~ - * foo~~~~~.c~~ => foo~~~~~.$$$ (fallback) - * - * foo.pas => foo~.pas - * makefile => makefile.~ - * longname.fil => longname.fi~ - * longname.fi~ => longnam~.fi~ - * longnam~.fi~ => longnam~.$$$ - * - */ - -#include "EXTERN.h" -#include "perl.h" -#ifdef OS2 -#define INCL_DOSFILEMGR -#define INCL_DOSERRORS -#include <os2.h> -#endif /* OS2 */ - -static char suffix1[] = ".$$$"; -static char suffix2[] = ".~~~"; - -#define ext (&buf[1000]) - -add_suffix(str,suffix) -register STR *str; -register char *suffix; -{ - int baselen; - int extlen; - char *s, *t, *p; - STRLEN slen; - - if (!(str->str_pok)) (void)str_2ptr(str); - if (str->str_cur > 1000) - fatal("Cannot do inplace edit on long filename (%d characters)", str->str_cur); - -#ifdef OS2 - /* Style 0 */ - slen = str->str_cur; - str_cat(str, suffix); - if (valid_filename(str->str_ptr)) return; - - /* Fooey, style 0 failed. Fix str before continuing. */ - str->str_ptr[str->str_cur = slen] = '\0'; -#endif /* OS2 */ - - slen = strlen(suffix); - t = buf; baselen = 0; s = str->str_ptr; - while ( (*t = *s) && *s != '.') { - baselen++; - if (*s == '\\' || *s == '/') baselen = 0; - s++; t++; - } - p = t; - - t = ext; extlen = 0; - while (*t++ = *s++) extlen++; - if (extlen == 0) { ext[0] = '.'; ext[1] = 0; extlen++; } - - if (*suffix == '.') { /* Style 1 */ - if (strEQ(ext, suffix)) goto fallback; - strcpy(p, suffix); - } else if (suffix[1] == '\0') { /* Style 2 */ - if (extlen < 4) { - ext[extlen] = *suffix; - ext[++extlen] = '\0'; - } else if (baselen < 8) { - *p++ = *suffix; - } else if (ext[3] != *suffix) { - ext[3] = *suffix; - } else if (buf[7] != *suffix) { - buf[7] = *suffix; - } else goto fallback; - strcpy(p, ext); - } else { /* Style 3: Panic */ -fallback: - (void)bcopy(strEQ(ext, suffix1) ? suffix2 : suffix1, p, 4+1); - } - str_set(str, buf); -} - -#ifdef OS2 -int -valid_filename(s) -char *s; -{ - HFILE hf; - USHORT usAction; - - switch(DosOpen(s, &hf, &usAction, 0L, 0, FILE_OPEN, - OPEN_ACCESS_READONLY | OPEN_SHARE_DENYNONE, 0L)) { - case ERROR_INVALID_NAME: - case ERROR_FILENAME_EXCED_RANGE: - return 0; - case NO_ERROR: - DosClose(hf); - /*FALLTHROUGH*/ - default: - return 1; - } -} -#endif /* OS2 */ diff --git a/os2/tests.dif b/os2/tests.dif deleted file mode 100644 index e0ad6fba0c..0000000000 --- a/os2/tests.dif +++ /dev/null @@ -1,589 +0,0 @@ -diff -cbBwr perl-4.019/t/base/term.t new/t/base/term.t -*** perl-4.019/t/base/term.t Wed Mar 20 08:47:14 1991 ---- new/t/base/term.t Sun Jun 16 20:39:50 1991 -*************** -*** 29,35 **** - - # check <> pseudoliteral - -! open(try, "/dev/null") || (die "Can't open /dev/null."); - if (<try> eq '') { - print "ok 5\n"; - } ---- 29,35 ---- - - # check <> pseudoliteral - -! open(try, "nul") || (die "Can't open /dev/null."); - if (<try> eq '') { - print "ok 5\n"; - } -diff -cbBwr perl-4.019/t/cmd/while.t new/t/cmd/while.t -*** perl-4.019/t/cmd/while.t Wed Mar 20 08:46:28 1991 ---- new/t/cmd/while.t Sun Jun 16 20:52:36 1991 -*************** -*** 90,96 **** - if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";} - if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";} - -! `/bin/rm -f Cmd.while.tmp`; - - #$x = 0; - #while (1) { ---- 90,97 ---- - if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";} - if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";} - -! close(fh); -! `del Cmd.while.tmp`; - - #$x = 0; - #while (1) { -diff -cbBwr perl-4.019/t/comp/cpp.t new/t/comp/cpp.t -*** perl-4.019/t/comp/cpp.t Wed Mar 20 08:48:44 1991 ---- new/t/comp/cpp.t Sun Jun 16 20:54:00 1991 -*************** -*** 32,39 **** - print TRY '#define OK "ok 3\n"' . "\n"; - close TRY; - -! $pwd=`pwd`; - $pwd =~ s/\n//; -! $x = `./perl -P Comp.cpp.tmp`; - print $x; - unlink "Comp.cpp.tmp", "Comp.cpp.inc"; ---- 32,39 ---- - print TRY '#define OK "ok 3\n"' . "\n"; - close TRY; - -! $pwd=`cd`; - $pwd =~ s/\n//; -! $x = `perl -P Comp.cpp.tmp`; - print $x; - unlink "Comp.cpp.tmp", "Comp.cpp.inc"; -diff -cbBwr perl-4.019/t/comp/script.t new/t/comp/script.t -*** perl-4.019/t/comp/script.t Wed Mar 20 08:48:50 1991 ---- new/t/comp/script.t Sun Jun 16 21:05:02 1991 -*************** -*** 4,10 **** - - print "1..3\n"; - -! $x = `./perl -e 'print "ok\n";'`; - - if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";} - ---- 4,10 ---- - - print "1..3\n"; - -! $x = `perl -e "print \\\"ok\\n\\\";"`; - - if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";} - -*************** -*** 12,23 **** - print try 'print "ok\n";'; print try "\n"; - close try; - -! $x = `./perl Comp.script`; - - if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";} - -! $x = `./perl <Comp.script`; - - if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";} - -! `/bin/rm -f Comp.script`; ---- 12,23 ---- - print try 'print "ok\n";'; print try "\n"; - close try; - -! $x = `perl Comp.script`; - - if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";} - -! $x = `perl <Comp.script`; - - if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";} - -! `del Comp.script`; -diff -cbBwr perl-4.019/t/io/argv.t new/t/io/argv.t -*** perl-4.019/t/io/argv.t Wed Mar 20 08:48:38 1991 ---- new/t/io/argv.t Sun Jun 16 21:14:14 1991 -*************** -*** 8,26 **** - print try "a line\n"; - close try; - -! $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`; - - if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";} - -! $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`; - - if ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} - -! $x = `echo foo|./perl -e 'while (<>) {print $_;}'`; - - if ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3 :$x:\n";} - -! @ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp'); - while (<>) { - $y .= $. . $_; - if (eof()) { ---- 8,26 ---- - print try "a line\n"; - close try; - -! $x = `perl -e "while (<>) {print \$.,\$_;}" Io.argv.tmp Io.argv.tmp`; - - if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";} - -! $x = `echo foo | perl -e "while (<>) {print $_;}" Io.argv.tmp -`; - - if ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} - -! $x = `echo foo | perl -e "while (<>) {print $_;}"`; - - if ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3 :$x:\n";} - -! @ARGV = ('Io.argv.tmp', 'Io.argv.tmp', 'nul', 'Io.argv.tmp'); - while (<>) { - $y .= $. . $_; - if (eof()) { -*************** -*** 33,36 **** - else - {print "not ok 5\n";} - -! `/bin/rm -f Io.argv.tmp`; ---- 33,36 ---- - else - {print "not ok 5\n";} - -! `del Io.argv.tmp`; -diff -cbBwr perl-4.019/t/io/pipe.t new/t/io/pipe.t -*** perl-4.019/t/io/pipe.t Wed Mar 20 08:48:38 1991 ---- new/t/io/pipe.t Sun Jun 16 21:25:14 1991 -*************** -*** 5,11 **** - $| = 1; - print "1..8\n"; - -! open(PIPE, "|-") || (exec 'tr', '[A-Z]', '[a-z]'); - print PIPE "OK 1\n"; - print PIPE "ok 2\n"; - close PIPE; ---- 5,11 ---- - $| = 1; - print "1..8\n"; - -! open(PIPE, "|-") || (exec 'tr.exe', '[A-Z]', '[a-z]'); - print PIPE "OK 1\n"; - print PIPE "ok 2\n"; - close PIPE; -*************** -*** 18,24 **** - } - else { - print STDOUT "not ok 3\n"; -! exec 'echo', 'not ok 4'; - } - - pipe(READER,WRITER) || die "Can't open pipe"; ---- 18,24 ---- - } - else { - print STDOUT "not ok 3\n"; -! exec 'perlglob', 'not ok 4'; - } - - pipe(READER,WRITER) || die "Can't open pipe"; -diff -cbBwr perl-4.019/t/op/exec.t new/t/op/exec.t -*** perl-4.019/t/op/exec.t Wed Mar 20 08:48:46 1991 ---- new/t/op/exec.t Sun Jun 16 21:39:32 1991 -*************** -*** 7,21 **** - - print "not ok 1\n" if system "echo ok \\1"; # shell interpreted - print "not ok 2\n" if system "echo ok 2"; # split and directly called -! print "not ok 3\n" if system "echo", "ok", "3"; # directly called - -! if (system "true") {print "not ok 4\n";} else {print "ok 4\n";} - -! if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } - print "ok 5\n"; - -! if ((system "lskdfj") == 255 << 8) {print "ok 6\n";} else {print "not ok 6\n";} - - unless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";} - -! exec "echo","ok","8"; ---- 7,21 ---- - - print "not ok 1\n" if system "echo ok \\1"; # shell interpreted - print "not ok 2\n" if system "echo ok 2"; # split and directly called -! print "not ok 3\n" if system "perlglob", "ok", "3", "\n"; # directly called - -! if (system "expr 1 >nul") {print "not ok 4\n";} else {print "ok 4\n";} - -! if ((system "sh -c \"exit 1\"") != 1) { print "not "; } - print "ok 5\n"; - -! if ((system "lskdfj") == 1) {print "ok 6\n";} else {print "not ok 6\n";} - - unless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";} - -! exec "perlglob","ok","8"; -diff -cbBwr perl-4.019/t/op/glob.t new/t/op/glob.t -*** perl-4.019/t/op/glob.t Wed Mar 20 08:48:54 1991 ---- new/t/op/glob.t Sun Jun 16 21:43:26 1991 -*************** -*** 7,13 **** - @ops = <op/*>; - $list = join(' ',@ops); - -! chop($otherway = `echo op/*`); - - print $list eq $otherway ? "ok 1\n" : "not ok 1\n$list\n$otherway\n"; - ---- 7,13 ---- - @ops = <op/*>; - $list = join(' ',@ops); - -! chop($otherway = `perlglob op/*`); - - print $list eq $otherway ? "ok 1\n" : "not ok 1\n$list\n$otherway\n"; - -diff -cbBwr perl-4.019/t/op/goto.t new/t/op/goto.t -*** perl-4.019/t/op/goto.t Wed Mar 20 08:48:46 1991 ---- new/t/op/goto.t Sun Jun 16 21:50:54 1991 -*************** -*** 29,34 **** - print "#2\t:$foo: == 4\n"; - if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} - -! $x = `./perl -e 'goto foo;' 2>&1`; - print "#3\t/label/ in :$x"; - if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} ---- 29,34 ---- - print "#2\t:$foo: == 4\n"; - if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} - -! $x = `perl -e "goto foo;" 2>&1`; - print "#3\t/label/ in :$x"; - if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} -diff -cbBwr perl-4.019/t/op/magic.t new/t/op/magic.t -*** perl-4.019/t/op/magic.t Wed Mar 20 08:48:36 1991 ---- new/t/op/magic.t Sun Jun 16 21:56:14 1991 -*************** -*** 7,13 **** - print "1..5\n"; - - eval '$ENV{"foo"} = "hi there";'; # check that ENV is inited inside eval -! if (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";} - - unlink 'ajslkdfpqjsjfk'; - $! = 0; ---- 7,13 ---- - print "1..5\n"; - - eval '$ENV{"foo"} = "hi there";'; # check that ENV is inited inside eval -! if (`echo %foo%` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";} - - unlink 'ajslkdfpqjsjfk'; - $! = 0; -*************** -*** 17,30 **** - # the next tests are embedded inside system simply because sh spits out - # a newline onto stderr when a child process kills itself with SIGINT. - -! system './perl', - '-e', '$| = 1; # command buffering', - -! '-e', '$SIG{"INT"} = "ok3"; kill 2,$$;', -! '-e', '$SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";', -! '-e', '$SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";', - -! '-e', 'sub ok3 { print "ok 3\n" if pop(@_) eq "INT"; }'; - - @val1 = @ENV{keys(%ENV)}; # can we slice ENV? - @val2 = values(%ENV); ---- 17,30 ---- - # the next tests are embedded inside system simply because sh spits out - # a newline onto stderr when a child process kills itself with SIGINT. - -! system 'perl', - '-e', '$| = 1; # command buffering', - -! '-e', '$SIG{"TERM"} = "ok3"; kill 0,$$;', -! '-e', '$SIG{"TERM"} = "IGNORE"; kill 0,$$; print "ok 4\n";', -! '-e', '$SIG{"TERM"} = "DEFAULT"; kill 0,$$; print "not ok\n";', - -! '-e', 'sub ok3 { print "ok 3\n" if pop(@_) eq "TERM"; }'; - - @val1 = @ENV{keys(%ENV)}; # can we slice ENV? - @val2 = values(%ENV); -diff -cbBwr perl-4.019/t/op/mkdir.t new/t/op/mkdir.t -*** perl-4.019/t/op/mkdir.t Wed Mar 20 08:48:54 1991 ---- new/t/op/mkdir.t Sun Jun 16 22:00:06 1991 -*************** -*** 4,14 **** - - print "1..7\n"; - -! `rm -rf blurfl`; - - print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); - print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); -! print ($! =~ /exist/ ? "ok 3\n" : "not ok 3\n"); - print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); - print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); - print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n"); ---- 4,14 ---- - - print "1..7\n"; - -! `rm -r blurfl`; - - print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); - print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); -! print ($! =~ /denied/ ? "ok 3\n" : "not ok 3\n"); - print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); - print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); - print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n"); -diff -cbBwr perl-4.019/t/op/split.t new/t/op/split.t -*** perl-4.019/t/op/split.t Wed Mar 20 08:48:24 1991 ---- new/t/op/split.t Sun Jun 16 22:04:02 1991 -*************** -*** 47,53 **** - print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; - - # Does assignment to a list imply split to one more field than that? -! $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`; - print $foo =~ /DEBUGGING/ || $foo =~ /num\(3\)/ ? "ok 11\n" : "not ok 11\n"; - - # Can we say how many fields to split to when assigning to a list? ---- 47,53 ---- - print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; - - # Does assignment to a list imply split to one more field than that? -! $foo = `perl -D1024 -e "(\$a,\$b) = split;" 2>&1`; - print $foo =~ /DEBUGGING/ || $foo =~ /num\(3\)/ ? "ok 11\n" : "not ok 11\n"; - - # Can we say how many fields to split to when assigning to a list? -diff -cbBwr perl-4.019/t/op/stat.t new/t/op/stat.t -*** perl-4.019/t/op/stat.t Fri Nov 22 22:04:46 1991 ---- new/t/op/stat.t Fri Nov 22 22:16:40 1991 -*************** -*** 4,12 **** - - print "1..56\n"; - -! chop($cwd = `pwd`); - -! $DEV = `ls -l /dev`; - - unlink "Op.stat.tmp"; - open(FOO, ">Op.stat.tmp"); ---- 4,12 ---- - - print "1..56\n"; - -! chop($cwd = `cd`); - -! $DEV = `ls -l`; - - unlink "Op.stat.tmp"; - open(FOO, ">Op.stat.tmp"); -*************** -*** 23,29 **** - - sleep 2; - -! `rm -f Op.stat.tmp2; ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`; - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('Op.stat.tmp'); ---- 23,29 ---- - - sleep 2; - -! `del Op.stat.tmp2; ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp 2>nul`; - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('Op.stat.tmp'); -*************** -*** 73,80 **** - if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";} - if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";} - -! if (`ls -l perl` =~ /^l.*->/) { -! if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";} - } - else { - print "ok 25\n"; ---- 73,80 ---- - if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";} - if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";} - -! if (`ls -l perl.exe` =~ /^l.*->/) { -! if (-l 'perl.exe') {print "ok 25\n";} else {print "not ok 25\n";} - } - else { - print "ok 25\n"; -*************** -*** 83,89 **** - if (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";} - - if (-e 'Op.stat.tmp') {print "ok 27\n";} else {print "not ok 27\n";} -! `rm -f Op.stat.tmp Op.stat.tmp2`; - if (! -e 'Op.stat.tmp') {print "ok 28\n";} else {print "not ok 28\n";} - - if ($DEV !~ /\nc.* (\S+)\n/) ---- 83,89 ---- - if (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";} - - if (-e 'Op.stat.tmp') {print "ok 27\n";} else {print "not ok 27\n";} -! `del Op.stat.tmp Op.stat.tmp2 2>nul`; - if (! -e 'Op.stat.tmp') {print "ok 28\n";} else {print "not ok 28\n";} - - if ($DEV !~ /\nc.* (\S+)\n/) -*************** -*** 113,119 **** - $cnt = $uid = 0; - - die "Can't run op/stat.t test 35 without pwd working" unless $cwd; -! chdir '/usr/bin' || die "Can't cd to /usr/bin"; - while (defined($_ = <*>)) { - $cnt++; - $uid++ if -u; ---- 113,119 ---- - $cnt = $uid = 0; - - die "Can't run op/stat.t test 35 without pwd working" unless $cwd; -! chdir '../os2' || die "Can't cd to ../os2"; - while (defined($_ = <*>)) { - $cnt++; - $uid++ if -u; -*************** -*** 124,138 **** - # I suppose this is going to fail somewhere... - if ($uid > 0 && $uid < $cnt) {print "ok 35\n";} else {print "not ok 35\n";} - -! unless (open(tty,"/dev/tty")) { -! print STDERR "Can't open /dev/tty--run t/TEST outside of make.\n"; - } - if (-t tty) {print "ok 36\n";} else {print "not ok 36\n";} - if (-c tty) {print "ok 37\n";} else {print "not ok 37\n";} - close(tty); - if (! -t tty) {print "ok 38\n";} else {print "not ok 38\n";} -! open(null,"/dev/null"); -! if (! -t null || -e '/xenix') {print "ok 39\n";} else {print "not ok 39\n";} - close(null); - if (-t) {print "ok 40\n";} else {print "not ok 40\n";} - ---- 124,138 ---- - # I suppose this is going to fail somewhere... - if ($uid > 0 && $uid < $cnt) {print "ok 35\n";} else {print "not ok 35\n";} - -! unless (open(tty,"con")) { -! print STDERR "Can't open con--run t/TEST outside of make.\n"; - } - if (-t tty) {print "ok 36\n";} else {print "not ok 36\n";} - if (-c tty) {print "ok 37\n";} else {print "not ok 37\n";} - close(tty); - if (! -t tty) {print "ok 38\n";} else {print "not ok 38\n";} -! open(null,"nul"); -! if (! -t null || -e 'c:/os2krnl') {print "ok 39\n";} else {print "not ok 39\n";} - close(null); - if (-t) {print "ok 40\n";} else {print "not ok 40\n";} - -*************** -*** 141,148 **** - if (-T 'op/stat.t') {print "ok 41\n";} else {print "not ok 41\n";} - if (! -B 'op/stat.t') {print "ok 42\n";} else {print "not ok 42\n";} - -! if (-B './perl') {print "ok 43\n";} else {print "not ok 43\n";} -! if (! -T './perl') {print "ok 44\n";} else {print "not ok 44\n";} - - open(FOO,'op/stat.t'); - eval { -T FOO; }; ---- 141,148 ---- - if (-T 'op/stat.t') {print "ok 41\n";} else {print "not ok 41\n";} - if (! -B 'op/stat.t') {print "ok 42\n";} else {print "not ok 42\n";} - -! if (-B 'perl.exe') {print "ok 43\n";} else {print "not ok 43\n";} -! if (! -T 'perl.exe') {print "ok 44\n";} else {print "not ok 44\n";} - - open(FOO,'op/stat.t'); - eval { -T FOO; }; -*************** -*** 172,176 **** - } - close(FOO); - -! if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";} -! if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";} ---- 172,176 ---- - } - close(FOO); - -! if (-T 'nul') {print "ok 55\n";} else {print "not ok 55\n";} -! if (-B 'nul') {print "ok 56\n";} else {print "not ok 56\n";} -diff -cbBwr perl-4.019/t/TEST new/t/TEST -*** perl-4.019/t/TEST Tue Jun 11 23:32:06 1991 ---- new/t/TEST Sun Jun 16 20:47:38 1991 -*************** -*** 16,22 **** - - if ($ARGV[0] eq '') { - @ARGV = split(/[ \n]/, -! `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`); - } - - open(CONFIG,"../config.sh"); ---- 16,22 ---- - - if ($ARGV[0] eq '') { - @ARGV = split(/[ \n]/, -! `ls base/*.t comp/*.t cmd/*.t io/*.t op/*.t lib/*.t`); - } - - open(CONFIG,"../config.sh"); -*************** -*** 35,41 **** - chop($te); - print "$te" . '.' x (15 - length($te)); - if ($sharpbang) { -! open(results,"./$test|") || (print "can't run.\n"); - } else { - open(script,"$test") || die "Can't run $test.\n"; - $_ = <script>; ---- 35,41 ---- - chop($te); - print "$te" . '.' x (15 - length($te)); - if ($sharpbang) { -! open(results,"$test|") || (print "can't run.\n"); - } else { - open(script,"$test") || die "Can't run $test.\n"; - $_ = <script>; -*************** -*** 45,51 **** - } else { - $switch = ''; - } -! open(results,"./perl$switch $test|") || (print "can't run.\n"); - } - $ok = 0; - $next = 0; ---- 45,51 ---- - } else { - $switch = ''; - } -! open(results,"perl$switch $test|") || (print "can't run.\n"); - } - $ok = 0; - $next = 0; - diff --git a/pat/env.pat b/pat/env.pat deleted file mode 100644 index 3ba5e69308..0000000000 --- a/pat/env.pat +++ /dev/null @@ -1,22 +0,0 @@ -*** /scalpel/lwall/perl5alpha4/perl.c Fri Jan 14 05:04:50 1994 ---- perl.c Fri Jan 14 23:22:47 1994 -*************** -*** 1303,1309 **** - SvMULTI_on(envgv); - hv = GvHVn(envgv); - hv_clear(hv); -- hv_magic(hv, envgv, 'E'); - if (env != environ) - environ[0] = Nullch; - for (; *env; env++) { ---- 1303,1308 ---- -*************** -*** 1314,1319 **** ---- 1313,1319 ---- - (void)hv_store(hv, *env, s - *env, sv, 0); - *s = '='; - } -+ hv_magic(hv, envgv, 'E'); - } - tainted = 0; - if (tmpgv = gv_fetchpv("$",TRUE)) diff --git a/pat/inherit.pat b/pat/inherit.pat deleted file mode 100644 index 71c41d4107..0000000000 --- a/pat/inherit.pat +++ /dev/null @@ -1,39 +0,0 @@ -*** /scalpel/lwall/perl5alpha4/gv.c Fri Jan 14 04:28:25 1994 ---- gv.c Fri Jan 14 14:05:38 1994 -*************** -*** 133,151 **** - SV** svp = AvARRAY(av); - I32 items = AvFILL(av) + 1; - while (items--) { -- char tmpbuf[512]; - SV* sv = *svp++; -! *tmpbuf = '_'; -! SvUPGRADE(sv, SVt_PV); -! strcpy(tmpbuf+1, SvPV(sv, na)); -! gv = gv_fetchpv(tmpbuf,FALSE); -! if (!gv || !(stash = GvHV(gv))) { - if (dowarn) - warn("Can't locate package %s for @%s'ISA", - SvPVX(sv), HvNAME(stash)); - continue; - } -! gv = gv_fetchmeth(stash, name, len); - if (gv) { - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ ---- 133,147 ---- - SV** svp = AvARRAY(av); - I32 items = AvFILL(av) + 1; - while (items--) { - SV* sv = *svp++; -! HV* basestash = fetch_stash(sv, FALSE); -! if (!basestash) { - if (dowarn) - warn("Can't locate package %s for @%s'ISA", - SvPVX(sv), HvNAME(stash)); - continue; - } -! gv = gv_fetchmeth(basestash, name, len); - if (gv) { - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ @@ -1,31 +0,0 @@ -#!./perl - -sub peekstr { - local ($addr, $len) = @_; - local ($mem) = unpack("P$len", pack("L",$addr+0)); - $mem; -} - -sub unpackmem { - local ($addr, $len, $template) = @_; - local $mem = peekstr($addr, $len); - unpack($template, $mem); -} - -$foo = "stuff"; - -($any, $refcnt, $type, $flags, $storage, $private) = - unpackmem(\$foo, 12, "L2 C4"); - -printf "SV = any %lx refcnt %d type %d flags %x storage '%c' private %x\n", - $any, $refcnt, $type, $flags, $storage, $private; - -if ($type >= 4) { - ($pv, $cur, $len) = unpackmem($any, 12, "L3"); - - printf "XPV = pv %lx cur %d len %d\n", $pv,$cur,$len; - - $string = peekstr($pv, $cur); - - print "String = $string\n" -} @@ -1,64 +1,27 @@ -/* - * Copyright (c) 1991, 1992, 1993, 1994 Larry Wall +/* perl.c + * + * Copyright (c) 1987-1994 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: perl.c,v $ - * Revision 4.1 92/08/07 18:25:50 lwall - * - * Revision 4.0.1.7 92/06/08 14:50:39 lwall - * patch20: PERLLIB now supports multiple directories - * patch20: running taintperl explicitly now does checks even if $< == $> - * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space - * patch20: perl -P now uses location of sed determined by Configure - * patch20: form feed for formats is now specifiable via $^L - * patch20: paragraph mode now skips extra newlines automatically - * patch20: oldeval "1 #comment" didn't work - * patch20: couldn't require . files - * patch20: semantic compilation errors didn't abort execution - * - * Revision 4.0.1.6 91/11/11 16:38:45 lwall - * patch19: default arg for shift was wrong after first subroutine definition - * patch19: op/regexp.t failed from missing arg to bcmp() - * - * Revision 4.0.1.5 91/11/05 18:03:32 lwall - * patch11: random cleanup - * patch11: $0 was being truncated at times - * patch11: cppstdin now installed outside of source directory - * patch11: -P didn't allow use of #elif or #undef - * patch11: prepared for ctype implementations that don't define isascii() - * patch11: added oldeval {} - * patch11: oldeval confused by string containing null - * - * Revision 4.0.1.4 91/06/10 01:23:07 lwall - * patch10: perl -v printed incorrect copyright notice - * - * Revision 4.0.1.3 91/06/07 11:40:18 lwall - * patch4: changed old $^P to $^X - * - * Revision 4.0.1.2 91/06/07 11:26:16 lwall - * patch4: new copyright notice - * patch4: added $^P variable to control calling of perldb routines - * patch4: added $^F variable to specify maximum system fd, default 2 - * patch4: debugger lost track of lines in oldeval - * - * Revision 4.0.1.1 91/04/11 17:49:05 lwall - * patch1: fixed undefined environ problem - * - * Revision 4.0 91/03/20 01:37:44 lwall - * 4.0 baseline. - * */ -/*SUPPRESS 560*/ +/* + * "A ship then new they built for him/of mithril and of elven glass" --Bilbo + */ #include "EXTERN.h" #include "perl.h" -#include "perly.h" #include "patchlevel.h" -char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n"; +/* Omit -- it causes too much grief on mixed systems. +#ifdef I_UNISTD +#include <unistd.h> +#endif +*/ + +char rcsid[] = "perl.c\nPatch level: ###\n"; #ifdef IAMSUID #ifndef DOSUID @@ -72,26 +35,24 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\n #endif #endif -static void incpush(); -static void validate_suid(); -static void find_beginning(); -static void init_main_stash(); -static void open_script(); -static void init_debugger(); -static void init_stacks(); -static void init_lexer(); -static void init_predump_symbols(); -static void init_postdump_symbols(); -static void init_perllib(); +static void find_beginning _((void)); +static void incpush _((char *)); +static void init_debugger _((void)); +static void init_lexer _((void)); +static void init_main_stash _((void)); +static void init_perllib _((void)); +static void init_postdump_symbols _((int, char **, char **)); +static void init_predump_symbols _((void)); +static void init_stacks _((void)); +static void open_script _((char *, bool, SV *)); +static void validate_suid _((char *)); PerlInterpreter * perl_alloc() { PerlInterpreter *sv_interp; - PerlInterpreter junk; curinterp = 0; -/* Zero(&junk, 1, PerlInterpreter); */ New(53, sv_interp, 1, PerlInterpreter); return sv_interp; } @@ -159,11 +120,12 @@ register PerlInterpreter *sv_interp; euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); +#ifdef VMS + uid |= gid << 16; + euid |= egid << 16; +#endif tainting = (euid != uid || egid != gid); - if (s = strchr(rcsid,'#')) { - (void)sprintf(s, "%d\n", PATCHLEVEL); - sprintf(patchlevel,"%3.3s%2.2d", strchr(rcsid,'5'), PATCHLEVEL); - } + sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0)); fdpid = newAV(); /* for remembering popen pids by fd */ pidstatus = newHV();/* for remembering status of dead pids */ @@ -173,59 +135,61 @@ register PerlInterpreter *sv_interp; } void -perl_destruct(sv_interp) +perl_destruct(sv_interp, destruct_level) register PerlInterpreter *sv_interp; +int destruct_level; /* 0=none, 1=full, 2=full with checks */ { I32 last_sv_count; + HV *hv; if (!(curinterp = sv_interp)) return; LEAVE; - FREE_TMPS(); - -#ifndef EMBED - /* The exit() function may do everything that needs doing. */ - if (!sv_rvcount) - return; -#endif - - /* Not so lucky. We must account for everything. First the syntax tree. */ - if (main_root) { - curpad = AvARRAY(comppad); - op_free(main_root); - main_root = 0; + 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) { + /* + * Try to destruct global references. We do this first so that the + * destructors and destructees still exist. Some sv's might remain. + * Non-referenced objects are on their own. + */ + + dirty = TRUE; + sv_clean_objs(); } - /* - * Try to destruct global references. We do this first so that the - * destructors and destructees still exist. This code currently - * will break simple reference loops but may fail on more complicated - * ones. If so, the code below will clean up, but any destructors - * may fail to find what they're looking for. - */ - dirty = TRUE; - if (sv_count != 0) - sv_clean_refs(); - - /* Delete self-reference from main symbol table */ - GvHV(gv_fetchpv("::_main",TRUE, SVt_PVHV)) = 0; - --SvREFCNT(defstash); + if (destruct_level == 0){ - /* Try to destruct main symbol table. May fail on reference loops. */ - SvREFCNT_dec(defstash); + DEBUG_P(debprofdump()); + + /* The exit() function will do everything that needs doing. */ + return; + } + + /* Prepare to destruct main symbol table. */ + hv = defstash; defstash = 0; - - FREE_TMPS(); -#ifdef DEBUGGING - if (scopestack_ix != 0) - warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix); - if (savestack_ix != 0) - warn("Unbalanced saves: %d more saves than restores\n", savestack_ix); - if (tmps_floor != -1) - warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1); - if (cxstack_ix != -1) - warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1); -#endif + SvREFCNT_dec(hv); + + FREETMPS; + if (destruct_level >= 2) { + if (scopestack_ix != 0) + warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix); + if (savestack_ix != 0) + warn("Unbalanced saves: %d more saves than restores\n", savestack_ix); + if (tmps_floor != -1) + warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1); + if (cxstack_ix != -1) + warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1); + } /* Now absolutely destruct everything, somehow or other, loops or no. */ last_sv_count = 0; @@ -235,6 +199,8 @@ register PerlInterpreter *sv_interp; } if (sv_count != 0) warn("Scalars leaked: %d\n", sv_count); + + DEBUG_P(debprofdump()); } void @@ -245,19 +211,22 @@ PerlInterpreter *sv_interp; return; Safefree(sv_interp); } +#ifndef STANDARD_C +char *getenv _((char *)); /* Usually in <stdlib.h> */ +#endif int -perl_parse(sv_interp, argc, argv, env) +perl_parse(sv_interp, xsinit, argc, argv, env) PerlInterpreter *sv_interp; -register int argc; -register char **argv; +void (*xsinit)_((void)); +int argc; +char **argv; char **env; { register SV *sv; register char *s; char *scriptname; - char *getenv(); - bool dosearch = FALSE; + VOL bool dosearch = FALSE; char *validarg = ""; #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW @@ -271,13 +240,26 @@ setuid perl scripts securely.\n"); if (!(curinterp = sv_interp)) return 255; - if (main_root) - op_free(main_root); - main_root = 0; - origargv = argv; origargc = argc; +#ifndef VMS /* VMS doesn't have environ array */ origenviron = environ; +#endif + + if (do_undump) { + + /* Come here if running an undumped a.out. */ + + origfilename = savepv(argv[0]); + do_undump = FALSE; + cxstack_ix = -1; /* start label stack again */ + init_postdump_symbols(argc,argv,env); + return 0; + } + + if (main_root) + op_free(main_root); + main_root = 0; switch (setjmp(top_env)) { case 1: @@ -292,17 +274,6 @@ setuid perl scripts securely.\n"); return 1; } - if (do_undump) { - - /* Come here if running an undumped a.out. */ - - origfilename = savestr(argv[0]); - do_undump = FALSE; - cxstack_ix = -1; /* start label stack again */ - init_postdump_symbols(argc,argv,env); - return 0; - } - sv_setpvn(linestr,"",0); sv = newSVpv("",0); /* first used for -I flags */ SAVEFREESV(sv); @@ -343,7 +314,7 @@ setuid perl scripts securely.\n"); if (euid != uid || egid != gid) croak("No -e allowed in setuid scripts"); if (!e_fp) { - e_tmpname = savestr(TMPPATH); + e_tmpname = savepv(TMPPATH); (void)mktemp(e_tmpname); if (!*e_tmpname) croak("Can't mktemp()"); @@ -363,10 +334,10 @@ setuid perl scripts securely.\n"); sv_catpv(sv,s); sv_catpv(sv," "); if (*++s) { - (void)av_push(GvAVn(incgv),newSVpv(s,0)); + av_push(GvAVn(incgv),newSVpv(s,0)); } else if (argv[1]) { - (void)av_push(GvAVn(incgv),newSVpv(argv[1],0)); + av_push(GvAVn(incgv),newSVpv(argv[1],0)); sv_catpv(sv,argv[1]); argc--,argv++; sv_catpv(sv," "); @@ -386,7 +357,7 @@ setuid perl scripts securely.\n"); doextract = TRUE; s++; if (*s) - cddir = savestr(s); + cddir = savepv(s); break; case '-': argc--,argv++; @@ -422,9 +393,6 @@ setuid perl scripts securely.\n"); if (doextract) find_beginning(); - if (perldb) - init_debugger(); - pad = newAV(); comppad = pad; av_push(comppad, Nullsv); @@ -435,7 +403,8 @@ setuid perl scripts securely.\n"); min_intro_pending = 0; padix = 0; - perl_init_ext(); /* in case linked C routines want magical variables */ + if (xsinit) + (*xsinit)(); /* in case linked C routines want magical variables */ init_predump_symbols(); if (!do_undump) @@ -476,6 +445,10 @@ setuid perl scripts securely.\n"); if (dowarn) gv_check(defstash); + LEAVE; + FREETMPS; + ENTER; + restartop = 0; return 0; } @@ -493,12 +466,12 @@ PerlInterpreter *sv_interp; curstash = defstash; if (endav) calllist(endav); - FREE_TMPS(); + FREETMPS; return(statusvalue); /* my_exit() was called */ case 3: if (!restartop) { fprintf(stderr, "panic: restartop\n"); - FREE_TMPS(); + FREETMPS; return 1; } if (stack != mainstack) { @@ -516,6 +489,8 @@ PerlInterpreter *sv_interp; fprintf(stderr,"%s syntax OK\n", origfilename); my_exit(0); } + if (perldb && DBsingle) + sv_setiv(DBsingle, 1); } /* do it */ @@ -531,84 +506,293 @@ PerlInterpreter *sv_interp; } my_exit(0); + return 0; } void my_exit(status) -int status; +I32 status; { + register CONTEXT *cx; + I32 gimme; + SV **newsp; + statusvalue = (unsigned short)(status & 0xffff); + if (cxstack_ix >= 0) { + if (cxstack_ix > 0) + dounwind(0); + POPBLOCK(cx,curpm); + LEAVE; + } longjmp(top_env, 2); } +SV* +perl_get_sv(name, create) +char* name; +I32 create; +{ + GV* gv = gv_fetchpv(name, create, SVt_PV); + if (gv) + return GvSV(gv); + return Nullsv; +} + +AV* +perl_get_av(name, create) +char* name; +I32 create; +{ + GV* gv = gv_fetchpv(name, create, SVt_PVAV); + if (create) + return GvAVn(gv); + if (gv) + return GvAV(gv); + return Nullav; +} + +HV* +perl_get_hv(name, create) +char* name; +I32 create; +{ + GV* gv = gv_fetchpv(name, create, SVt_PVHV); + if (create) + return GvHVn(gv); + if (gv) + return GvHV(gv); + return Nullhv; +} + +CV* +perl_get_cv(name, create) +char* name; +I32 create; +{ + GV* gv = gv_fetchpv(name, create, SVt_PVCV); + if (create && !GvCV(gv)) + return newSUB(start_subparse(), + newSVOP(OP_CONST, 0, newSVpv(name,0)), + Nullop); + if (gv) + return GvCV(gv); + return Nullcv; +} + /* Be sure to refetch the stack pointer after calling these routines. */ -int -perl_callargv(subname, sp, gimme, argv) +I32 +perl_call_argv(subname, flags, argv) char *subname; -register I32 sp; /* current stack pointer */ -I32 gimme; /* TRUE if called in list context */ -register char **argv; /* null terminated arg list, NULL for no arglist */ +I32 flags; /* See G_* flags in cop.h */ +register char **argv; /* null terminated arg list */ { - register I32 items = 0; - I32 hasargs = (argv != 0); + dSP; - av_store(stack, ++sp, Nullsv); /* reserve spot for sub reference */ - if (hasargs) { + PUSHMARK(sp); + if (argv) { while (*argv) { - av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0))); - items++; + XPUSHs(sv_2mortal(newSVpv(*argv,0))); argv++; } + PUTBACK; } - return perl_callpv(subname, sp, gimme, hasargs, items); + return perl_call_pv(subname, flags); } -int -perl_callpv(subname, sp, gimme, hasargs, numargs) +I32 +perl_call_pv(subname, flags) +char *subname; /* name of the subroutine */ +I32 flags; /* See G_* flags in cop.h */ +{ + return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags); +} + +I32 +perl_call_method(methname, flags) +char *methname; /* name of the subroutine */ +I32 flags; /* See G_* flags in cop.h */ +{ + dSP; + OP myop; + if (!op) + op = &myop; + XPUSHs(sv_2mortal(newSVpv(methname,0))); + PUTBACK; + pp_method(); + return perl_call_sv(*stack_sp--, flags); +} + +/* May be called with any of a CV, a GV, or an SV containing the name. */ +I32 +perl_call_sv(sv, flags) +SV* sv; +I32 flags; /* See G_* flags in cop.h */ +{ + LOGOP myop; /* fake syntax tree node */ + SV** sp = stack_sp; + I32 oldmark = TOPMARK; + I32 retval; + jmp_buf oldtop; + I32 oldscope; + + if (flags & G_DISCARD) { + ENTER; + SAVETMPS; + } + + SAVESPTR(op); + op = (OP*)&myop; + Zero(op, 1, LOGOP); + EXTEND(stack_sp, 1); + *++stack_sp = sv; + oldscope = scopestack_ix; + + if (!(flags & G_NOARGS)) + myop.op_flags = OPf_STACKED; + myop.op_next = Nullop; + myop.op_flags |= OPf_KNOW; + if (flags & G_ARRAY) + myop.op_flags |= OPf_LIST; + + if (flags & G_EVAL) { + Copy(top_env, oldtop, 1, jmp_buf); + + cLOGOP->op_other = op; + markstack_ptr--; + pp_entertry(); + markstack_ptr++; + + restart: + switch (setjmp(top_env)) { + case 0: + break; + case 1: + statusvalue = 255; /* XXX I don't think we use 1 anymore. */ + /* FALL THROUGH */ + case 2: + /* my_exit() was called */ + curstash = defstash; + FREETMPS; + Copy(oldtop, top_env, 1, jmp_buf); + if (statusvalue) + croak("Callback called exit"); + my_exit(statusvalue); + /* NOTREACHED */ + case 3: + if (restartop) { + op = restartop; + restartop = 0; + goto restart; + } + stack_sp = stack_base + oldmark; + if (flags & G_ARRAY) + retval = 0; + else { + retval = 1; + *++stack_sp = &sv_undef; + } + goto cleanup; + } + } + + if (op == (OP*)&myop) + op = pp_entersub(); + if (op) + run(); + retval = stack_sp - (stack_base + oldmark); + if (flags & G_EVAL) + sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + + cleanup: + if (flags & G_EVAL) { + if (scopestack_ix > oldscope) { + op = (OP*)&myop; + pp_leavetry(); + } + Copy(oldtop, top_env, 1, jmp_buf); + } + if (flags & G_DISCARD) { + stack_sp = stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; + } + return retval; +} + +/* Older forms, here grandfathered. */ + +#ifdef DEPRECATED +I32 +perl_callargv(subname, spix, gimme, argv) +char *subname; +register I32 spix; /* current stack pointer index */ +I32 gimme; /* See G_* flags in cop.h */ +register char **argv; /* null terminated arg list, NULL for no arglist */ +{ + stack_sp = stack_base + spix; + return spix + perl_call_argv(subname, gimme, argv); +} + +I32 +perl_callpv(subname, spix, gimme, hasargs, numargs) char *subname; -I32 sp; /* stack pointer after args are pushed */ -I32 gimme; /* TRUE if called in list context */ +I32 spix; /* stack pointer index after args are pushed */ +I32 gimme; /* See G_* flags in cop.h */ I32 hasargs; /* whether to create a @_ array for routine */ I32 numargs; /* how many args are pushed on the stack */ { - return perl_callsv((SV*)gv_fetchpv(subname, TRUE, SVt_PVCV), - sp, gimme, hasargs, numargs); + stack_sp = stack_base + spix; + PUSHMARK(stack_sp - numargs); + return spix - numargs + perl_call_sv((SV*)perl_get_cv(subname, TRUE), + gimme, hasargs, numargs); } -/* May be called with any of a CV, a GV, or an SV containing the name. */ -int -perl_callsv(sv, sp, gimme, hasargs, numargs) +I32 +perl_callsv(sv, spix, gimme, hasargs, numargs) SV* sv; -I32 sp; /* stack pointer after args are pushed */ -I32 gimme; /* TRUE if called in list context */ +I32 spix; /* stack pointer index after args are pushed */ +I32 gimme; /* See G_* flags in cop.h */ I32 hasargs; /* whether to create a @_ array for routine */ I32 numargs; /* how many args are pushed on the stack */ { - BINOP myop; /* fake syntax tree node */ + stack_sp = stack_base + spix; + PUSHMARK(stack_sp - numargs); + return spix - numargs + perl_call_sv(sv, gimme, hasargs, numargs); +} +#endif + +/* Require a module. */ + +void +perl_requirepv(pv) +char* pv; +{ + UNOP myop; /* fake syntax tree node */ + SV* sv; + dSP; ENTER; SAVETMPS; SAVESPTR(op); - stack_base = AvARRAY(stack); - stack_sp = stack_base + sp - numargs - 1; + sv = sv_newmortal(); + sv_setpv(sv, pv); op = (OP*)&myop; - Zero(op, 1, BINOP); - pp_pushmark(); /* doesn't look at op, actually, except to return */ - *++stack_sp = sv; - stack_sp += numargs; + Zero(op, 1, UNOP); + XPUSHs(sv); - if (hasargs) { - myop.op_flags = OPf_STACKED; - myop.op_last = (OP*)&myop; - } + myop.op_type = OP_REQUIRE; myop.op_next = Nullop; + myop.op_private = 1; + myop.op_flags = OPf_KNOW; - if (op = pp_entersubr()) + PUTBACK; + if (op = pp_require()) run(); - FREE_TMPS(); + stack_sp--; + FREETMPS; LEAVE; - return stack_sp - stack_base; } void @@ -643,14 +827,14 @@ char *p; /* First, skip any consecutive separators */ while ( *p == PERLLIB_SEP ) { /* Uncomment the next line for PATH semantics */ - /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */ + /* av_push(GvAVn(incgv), newSVpv(".", 1)); */ p++; } if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { - (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p))); + av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p))); p = s + 1; } else { - (void)av_push(GvAVn(incgv), newSVpv(p, 0)); + av_push(GvAVn(incgv), newSVpv(p, 0)); break; } } @@ -667,7 +851,7 @@ char *s; switch (*s) { case '0': nrschar = scan_oct(s, 4, &numlen); - nrs = nsavestr("\n",1); + nrs = savepvn("\n",1); *nrs = nrschar; if (nrschar > 0377) { nrslen = 0; @@ -681,7 +865,7 @@ char *s; return s + numlen; case 'F': minus_F = TRUE; - splitstr = savestr(s + 1); + splitstr = savepv(s + 1); s += strlen(s); return s; case 'a': @@ -694,7 +878,10 @@ char *s; return s; case 'd': taint_not("-d"); - perldb = TRUE; + if (!perldb) { + perldb = TRUE; + init_debugger(); + } s++; return s; case 'D': @@ -714,14 +901,14 @@ char *s; debug |= 0x80000000; #else warn("Recompile perl with -DDEBUGGING to use -D switch\n"); - for (s++; isDIGIT(*s); s++) ; + for (s++; isALNUM(*s); s++) ; #endif /*SUPPRESS 530*/ return s; case 'i': if (inplace) Safefree(inplace); - inplace = savestr(s+1); + inplace = savepv(s+1); /*SUPPRESS 530*/ for (s = inplace; *s && !isSPACE(*s); s++) ; *s = '\0'; @@ -729,7 +916,7 @@ char *s; case 'I': taint_not("-I"); if (*++s) { - (void)av_push(GvAVn(incgv),newSVpv(s,0)); + av_push(GvAVn(incgv),newSVpv(s,0)); } else croak("No space allowed after -I"); @@ -737,14 +924,16 @@ char *s; case 'l': minus_l = TRUE; s++; + if (ors) + Safefree(ors); if (isDIGIT(*s)) { - ors = savestr("\n"); + ors = savepv("\n"); orslen = 1; *ors = scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { - ors = nsavestr(nrs,nrslen); + ors = savepvn(nrs,nrslen); orslen = nrslen; } return s; @@ -774,9 +963,8 @@ char *s; s++; return s; case 'v': - fputs("\nThis is perl, version 5.0, Alpha 9 (unsupported)\n\n",stdout); - fputs(rcsid,stdout); - fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993, 1994 Larry Wall\n",stdout); + printf("\nThis is perl, version %s\n\n",patchlevel); + fputs("\nCopyright 1987-1994, Larry Wall\n",stdout); #ifdef MSDOS fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", stdout); @@ -799,16 +987,22 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n",st dowarn = TRUE; s++; return s; + case '*': case ' ': if (s[1] == '-') /* Additional switches on #! line. */ return s+2; break; + case '-': case 0: case '\n': case '\t': break; + case 'P': + if (preprocess) + return s+1; + /* FALL THROUGH */ default: - croak("Switch meaningless after -x: -%s",s); + croak("Can't emulate -%.1s on #! line",s); } return Nullch; } @@ -830,7 +1024,7 @@ my_unexec() status = unexec(buf, tokenbuf, &etext, sbrk(0), 0); if (status) fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf); - my_exit(status); + exit(status); #else ABORT(); /* for use with undump */ #endif @@ -842,21 +1036,29 @@ init_main_stash() GV *gv; curstash = defstash = newHV(); curstname = newSVpv("main",4); - GvHV(gv = gv_fetchpv("_main",TRUE, SVt_PVHV)) = (HV*)SvREFCNT_inc(defstash); + GvHV(gv = gv_fetchpv("main::",TRUE, SVt_PVHV)) = + (HV*)SvREFCNT_inc(defstash); SvREADONLY_on(gv); - HvNAME(defstash) = savestr("main"); + HvNAME(defstash) = savepv("main"); incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); SvMULTI_on(incgv); - defgv = gv_fetchpv("_",TRUE, SVt_PV); + defgv = gv_fetchpv("_",TRUE, SVt_PVAV); curstash = defstash; compiling.cop_stash = defstash; + debstash = newHV(); + GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)) = debstash; } +#ifdef CAN_PROTOTYPE +static void +open_script(char *scriptname, bool dosearch, SV *sv) +#else static void open_script(scriptname,dosearch,sv) char *scriptname; bool dosearch; SV *sv; +#endif { char *xfound = Nullch; char *xfailed = Nullch; @@ -892,7 +1094,7 @@ SV *sv; (void)strcat(tokenbuf+len,"/"); (void)strcat(tokenbuf+len,scriptname); DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf)); - if (stat(tokenbuf,&statbuf) < 0) /* not there? */ + if (Stat(tokenbuf,&statbuf) < 0) /* not there? */ continue; if (S_ISREG(statbuf.st_mode) && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) { @@ -900,7 +1102,7 @@ SV *sv; break; } if (!xfailed) - xfailed = savestr(tokenbuf); + xfailed = savepv(tokenbuf); } if (!xfound) croak("Can't execute %s", xfailed ? xfailed : scriptname ); @@ -909,7 +1111,7 @@ SV *sv; scriptname = xfound; } - origfilename = savestr(e_fp ? "-e" : scriptname); + origfilename = savepv(e_fp ? "-e" : scriptname); curcop->cop_filegv = gv_fetchfile(origfilename); if (strEQ(origfilename,"-")) scriptname = ""; @@ -959,7 +1161,6 @@ sed %s -e \"/^[^#]/b\" \ (doextract ? "-e '1,/^#/d\n'" : ""), #endif scriptname, tokenbuf, SvPV(sv, na), CPPMINUS); - DEBUG_P(fprintf(stderr, "%s\n", buf)); doextract = FALSE; #ifdef IAMSUID /* actually, this is caught earlier */ if (euid != uid && !euid) { /* if running suidperl */ @@ -991,7 +1192,7 @@ sed %s -e \"/^[^#]/b\" \ if ((FILE*)rsfp == Nullfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ - if (euid && stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && + if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ @@ -1008,7 +1209,6 @@ static void validate_suid(validarg) char *validarg; { - char *s; /* do we need to emulate setuid on scripts? */ /* This code is for those BSD systems that have setuid #! scripts disabled @@ -1030,7 +1230,9 @@ char *validarg; */ #ifdef DOSUID - if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ + char *s; + + if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ croak("Can't stat script \"%s\"",origfilename); if (statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; @@ -1059,12 +1261,14 @@ char *validarg; if ( #ifdef HAS_SETREUID setreuid(euid,uid) < 0 -#elif HAS_SETRESUID +#else +# if HAS_SETRESUID setresuid(euid,uid,(Uid_t)-1) < 0 +# endif #endif || getuid() != euid || geteuid() != uid) croak("Can't swap uid and euid"); /* really paranoid */ - if (stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) + if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) croak("Permission denied"); /* testing full pathname here */ if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { @@ -1084,8 +1288,10 @@ char *validarg; if ( #ifdef HAS_SETREUID setreuid(uid,euid) < 0 -#elif defined(HAS_SETRESUID) +#else +# if defined(HAS_SETRESUID) setresuid(uid,euid,(Uid_t)-1) < 0 +# endif #endif || getuid() != uid || geteuid() != euid) croak("Can't reswap uid and euid"); @@ -1206,7 +1412,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #else /* !DOSUID */ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW - fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ + Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) @@ -1250,24 +1456,15 @@ init_debugger() { GV* tmpgv; - debstash = newHV(); - GvHV(gv_fetchpv("::_DB",TRUE, SVt_PVHV)) = debstash; curstash = debstash; - dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE, SVt_PVAV)))); - SvMULTI_on(tmpgv); + dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); AvREAL_off(dbargs); - DBgv = gv_fetchpv("DB",TRUE, SVt_PVGV); - SvMULTI_on(DBgv); - DBline = gv_fetchpv("dbline",TRUE, SVt_PVAV); - SvMULTI_on(DBline); - DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE, SVt_PVHV)); - SvMULTI_on(tmpgv); - DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE, SVt_PV))); - SvMULTI_on(tmpgv); - DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE, SVt_PV))); - SvMULTI_on(tmpgv); - DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE, SVt_PV))); - SvMULTI_on(tmpgv); + DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV); + DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV); + DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); + DBsingle = GvSV((tmpgv = gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); + DBtrace = GvSV((tmpgv = gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); + DBsignal = GvSV((tmpgv = gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); curstash = defstash; } @@ -1277,17 +1474,17 @@ init_stacks() stack = newAV(); mainstack = stack; /* remember in case we switch stacks */ AvREAL_off(stack); /* not a real array */ - av_fill(stack,127); av_fill(stack,-1); /* preextend stack */ + av_extend(stack,127); stack_base = AvARRAY(stack); stack_sp = stack_base; stack_max = stack_base + 127; - New(54,markstack,64,int); + New(54,markstack,64,I32); markstack_ptr = markstack; markstack_max = markstack + 64; - New(54,scopestack,32,int); + New(54,scopestack,32,I32); scopestack_ix = 0; scopestack_max = 32; @@ -1313,10 +1510,11 @@ init_stacks() } ) } +static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ static void init_lexer() { - FILE* tmpfp = rsfp; + tmpfp = rsfp; lex_start(linestr); rsfp = tmpfp; @@ -1327,37 +1525,31 @@ static void init_predump_symbols() { GV *tmpgv; + GV *othergv; sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); SvMULTI_on(stdingv); - if (!GvIO(stdingv)) - GvIO(stdingv) = newIO(); - IoIFP(GvIO(stdingv)) = stdin; + IoIFP(GvIOp(stdingv)) = stdin; tmpgv = gv_fetchpv("stdin",TRUE, SVt_PVIO); - GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(stdingv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv)); SvMULTI_on(tmpgv); tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); SvMULTI_on(tmpgv); - if (!GvIO(tmpgv)) - GvIO(tmpgv) = newIO(); - IoOFP(GvIO(tmpgv)) = IoIFP(GvIO(tmpgv)) = stdout; + IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout; defoutgv = tmpgv; tmpgv = gv_fetchpv("stdout",TRUE, SVt_PVIO); - GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(defoutgv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv)); SvMULTI_on(tmpgv); - curoutgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); - SvMULTI_on(curoutgv); - if (!GvIO(curoutgv)) - GvIO(curoutgv) = newIO(); - IoOFP(GvIO(curoutgv)) = IoIFP(GvIO(curoutgv)) = stderr; + othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); + SvMULTI_on(othergv); + IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr; tmpgv = gv_fetchpv("stderr",TRUE, SVt_PVIO); - GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(curoutgv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); SvMULTI_on(tmpgv); - curoutgv = defoutgv; /* switch back to STDOUT */ statname = NEWSV(66,0); /* last filename we did stat on */ } @@ -1412,7 +1604,7 @@ register char **env; (void)gv_AVadd(argvgv); av_clear(GvAVn(argvgv)); for (; argc > 0; argc--,argv++) { - (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0)); + av_push(GvAVn(argvgv),newSVpv(argv[0],0)); } } if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) { @@ -1420,10 +1612,15 @@ register char **env; SvMULTI_on(envgv); hv = GvHVn(envgv); hv_clear(hv); +#ifndef VMS /* VMS doesn't have environ array */ if (env != environ) { environ[0] = Nullch; hv_magic(hv, envgv, 'E'); } +#endif +#ifdef DYNAMIC_ENV_FETCH + HvNAME(hv) = savepv(ENV_HV_NAME); +#endif for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; @@ -1453,11 +1650,15 @@ init_perllib() incpush(getenv("PERLLIB")); } +#ifdef ARCHLIB + incpush(ARCHLIB); +#endif #ifndef PRIVLIB #define PRIVLIB "/usr/local/lib/perl5:/usr/local/lib/perl" #endif incpush(PRIVLIB); - (void)av_push(GvAVn(incgv),newSVpv(".",1)); + + av_push(GvAVn(incgv),newSVpv(".",1)); } void @@ -1465,18 +1666,31 @@ calllist(list) AV* list; { jmp_buf oldtop; - I32 sp = stack_sp - stack_base; + char *mess; + STRLEN len; + line_t oldline = curcop->cop_line; - av_store(stack, ++sp, Nullsv); /* reserve spot for sub reference */ Copy(top_env, oldtop, 1, jmp_buf); while (AvFILL(list) >= 0) { CV *cv = (CV*)av_shift(list); SAVEFREESV(cv); + switch (setjmp(top_env)) { case 0: - perl_callsv((SV*)cv, sp, G_SCALAR, 0, 0); + PUSHMARK(stack_sp); + perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); + mess = SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), len); + if (len) { + Copy(oldtop, top_env, 1, jmp_buf); + curcop = &compiling; + curcop->cop_line = oldline; + if (list == beginav) + croak("%sBEGIN failed--compilation aborted", mess); + else + croak("%sEND failed--cleanup aborted", mess); + } break; case 1: statusvalue = 255; /* XXX I don't think we use 1 anymore. */ @@ -1486,31 +1700,29 @@ AV* list; curstash = defstash; if (endav) calllist(endav); - FREE_TMPS(); + FREETMPS; + Copy(oldtop, top_env, 1, jmp_buf); + curcop = &compiling; + curcop->cop_line = oldline; if (statusvalue) { if (list == beginav) - warn("BEGIN failed--execution aborted"); + croak("BEGIN failed--compilation aborted"); else - warn("END failed--execution aborted"); + croak("END failed--cleanup aborted"); } - Copy(oldtop, top_env, 1, jmp_buf); my_exit(statusvalue); /* NOTREACHED */ return; case 3: if (!restartop) { fprintf(stderr, "panic: restartop\n"); - FREE_TMPS(); + FREETMPS; break; } - if (stack != mainstack) { - dSP; - SWITCHSTACK(stack, mainstack); - } - op = restartop; - restartop = 0; - run(); - break; + Copy(oldtop, top_env, 1, jmp_buf); + curcop = &compiling; + curcop->cop_line = oldline; + longjmp(top_env, 3); } } @@ -1,56 +1,19 @@ -/* $RCSfile: perl.h,v $$Revision: 4.1 $$Date: 92/08/07 18:25:56 $ +/* perl.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1987-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: perl.h,v $ - * Revision 4.1 92/08/07 18:25:56 lwall - * - * Revision 4.0.1.6 92/06/08 14:55:10 lwall - * patch20: added Atari ST portability - * patch20: bcopy() and memcpy() now tested for overlap safety - * patch20: Perl now distinguishes overlapped copies from non-overlapped - * patch20: removed implicit int declarations on functions - * - * Revision 4.0.1.5 91/11/11 16:41:07 lwall - * patch19: uts wrongly defines S_ISDIR() et al - * patch19: too many preprocessors can't expand a macro right in #if - * patch19: added little-endian pack/unpack options - * - * Revision 4.0.1.4 91/11/05 18:06:10 lwall - * patch11: various portability fixes - * patch11: added support for dbz - * patch11: added some support for 64-bit integers - * patch11: hex() didn't understand leading 0x - * - * Revision 4.0.1.3 91/06/10 01:25:10 lwall - * patch10: certain pattern optimizations were botched - * - * Revision 4.0.1.2 91/06/07 11:28:33 lwall - * patch4: new copyright notice - * patch4: made some allowances for "semi-standard" C - * patch4: many, many itty-bitty portability fixes - * - * Revision 4.0.1.1 91/04/11 17:49:51 lwall - * patch1: hopefully straightened out some of the Xenix mess - * - * Revision 4.0 91/03/20 01:37:56 lwall - * 4.0 baseline. - * */ #ifndef H_PERL #define H_PERL 1 +#define OVERLOAD #include "embed.h" #define VOIDUSED 1 -#ifdef __cplusplus -#include "config_c++.h" -#else #include "config.h" -#endif #ifndef BYTEORDER # define BYTEORDER 0x1234 @@ -82,7 +45,7 @@ /* work around some libPW problems */ #ifdef DOINIT -char Error[1]; +EXT char Error[1]; #endif /* define this once if either system, instead of cluttering up the src */ @@ -90,16 +53,10 @@ char Error[1]; #define DOSISH 1 #endif -#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) +#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) # define STANDARD_C 1 #endif -#if defined(STANDARD_C) -# define P(args) args -#else -# define P(args) () -#endif - #if defined(HASVOLATILE) || defined(STANDARD_C) # ifdef __cplusplus # define VOL // to temporarily suppress warnings @@ -132,10 +89,19 @@ char Error[1]; #endif #include <stdio.h> +#ifdef USE_NEXT_CTYPE +#include <appkit/NXCType.h> +#else #include <ctype.h> +#endif + +#ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */ +#undef METHOD +#endif + #include <setjmp.h> -#ifndef MSDOS +#ifdef I_SYS_PARAM # ifdef PARAM_NEEDS_TYPES # include <sys/types.h> # endif @@ -144,24 +110,31 @@ char Error[1]; /* Use all the "standard" definitions? */ -#ifdef STANDARD_C +#if defined(STANDARD_C) && defined(I_STDLIB) # include <stdlib.h> -# ifdef I_STRING -# include <string.h> -# endif -# define MEM_SIZE size_t -#else - typedef unsigned int MEM_SIZE; #endif /* STANDARD_C */ -#if defined(HAS_MEMCMP) && defined(mips) && defined(ultrix) +#define MEM_SIZE Size_t + +#if defined(I_STRING) || defined(__cplusplus) +# include <string.h> +#else +# include <strings.h> +#endif + +#if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr) +#define strchr index +#define strrchr rindex +#endif + +#if defined(mips) && defined(ultrix) && !defined(__STDC__) # undef HAS_MEMCMP #endif #ifdef HAS_MEMCPY # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcpy - extern char * memcpy P((char*, char*, int)); + extern char * memcpy _((char*, char*, int)); # endif # endif #else @@ -177,7 +150,7 @@ char Error[1]; #ifdef HAS_MEMSET # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memset - extern char *memset P((char*, int, int)); + extern char *memset _((char*, int, int)); # endif # endif # define memzero(d,l) memset(d,0,l) @@ -194,7 +167,7 @@ char Error[1]; #ifdef HAS_MEMCMP # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcmp - extern int memcmp P((char*, char*, int)); + extern int memcmp _((char*, char*, int)); # endif # endif #else @@ -234,21 +207,22 @@ char Error[1]; #include <sys/stat.h> -#if defined(uts) || defined(UTekV) +/* The stat macros for Amdahl UTS, Unisoft System V/88 (and derivatives + like UTekV) are broken, sometimes giving false positives. Undefine + them here and let the code below set them to proper values. + + The ghs macro stands for GreenHills Software C-1.8.5 which + is the C compiler for sysV88 and the various derivatives. + This header file bug is corrected in gcc-2.5.8 and later versions. + --Kaveh Ghazi (ghazi@noc.rutgers.edu) 10/3/94. */ + +#if defined(uts) || (defined(m88k) && defined(ghs)) # undef S_ISDIR # undef S_ISCHR # undef S_ISBLK # undef S_ISREG # undef S_ISFIFO # undef S_ISLNK -# define S_ISDIR(P) (((P)&S_IFMT)==S_IFDIR) -# define S_ISCHR(P) (((P)&S_IFMT)==S_IFCHR) -# define S_ISBLK(P) (((P)&S_IFMT)==S_IFBLK) -# define S_ISREG(P) (((P)&S_IFMT)==S_IFREG) -# define S_ISFIFO(P) (((P)&S_IFMT)==S_IFIFO) -# ifdef S_IFLNK -# define S_ISLNK(P) (((P)&S_IFMT)==S_IFLNK) -# endif #endif #ifdef I_TIME @@ -266,7 +240,7 @@ char Error[1]; #endif #ifndef MSDOS -# ifdef HAS_TIMES +# if defined(HAS_TIMES) && defined(I_SYS_TIMES) # include <sys/times.h> # endif #endif @@ -275,6 +249,12 @@ char Error[1]; # undef HAS_STRERROR #endif +#ifndef HAS_MKFIFO +# ifndef mkfifo +# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0)) +# endif +#endif /* !HAS_MKFIFO */ + #include <errno.h> #ifdef HAS_SOCKET # ifdef I_NET_ERRNO @@ -289,7 +269,11 @@ char Error[1]; #endif #ifdef HAS_STRERROR - char *strerror P((int)); +# ifdef VMS + char *strerror _((int,...)); +# else + char *strerror _((int)); +# endif # ifndef Strerror # define Strerror strerror # endif @@ -327,13 +311,15 @@ char Error[1]; # define ntohi ntohl #endif +/* Configure already sets Direntry_t */ #if defined(I_DIRENT) # include <dirent.h> -# define DIRENT dirent +# if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */ +# include <sys/dir.h> +# endif #else # ifdef I_SYS_NDIR # include <sys/ndir.h> -# define DIRENT direct # else # ifdef I_SYS_DIR # ifdef hp9000s500 @@ -341,10 +327,9 @@ char Error[1]; # else # include <sys/dir.h> # endif -# define DIRENT direct # endif # endif -#endif +#endif #ifdef FPUTS_BOTCH /* work around botch in SunOS 4.0.1 and 4.0.2 */ @@ -457,7 +442,7 @@ char Error[1]; # undef ff_next #endif -#if defined(cray) || defined(gould) || defined(i860) +#if defined(cray) || defined(gould) || defined(i860) || defined(pyr) # define SLOPPYDIVIDE #endif @@ -486,7 +471,11 @@ char Error[1]; #ifdef DOSISH # include "dosish.h" #else +# if defined(VMS) +# include "vmsish.h" +# else # include "unixish.h" +# endif #endif #ifndef HAS_PAUSE @@ -551,11 +540,22 @@ typedef struct xpvio XPVIO; typedef struct mgvtbl MGVTBL; typedef union any ANY; +typedef FILE * (*cryptswitch_t) _((FILE *rfp)); + #include "handy.h" + +#ifdef QUAD +typedef quad IV; +#else +typedef long IV; +#endif + union any { void* any_ptr; I32 any_i32; + IV any_iv; long any_long; + void (*any_dptr) _((void*)); }; #include "regexp.h" @@ -578,9 +578,9 @@ union any { #ifndef STANDARD_C # ifdef CHARSPRINTF - char *sprintf P((char *, ...)); + char *sprintf _((char *, const char *, ...)); # else - int sprintf P((char *, ...)); + int sprintf _((char *, const char *, ...)); # endif #endif @@ -643,7 +643,7 @@ union any { #define U_I(what) ((unsigned int)(what)) #define U_L(what) ((U32)(what)) #else -U32 cast_ulong P((double)); +U32 cast_ulong _((double)); #define U_S(what) ((U16)cast_ulong(what)) #define U_I(what) ((unsigned int)cast_ulong(what)) #define U_L(what) (cast_ulong(what)) @@ -651,9 +651,12 @@ U32 cast_ulong P((double)); #ifdef CASTI32 #define I_32(what) ((I32)(what)) +#define I_V(what) ((IV)(what)) #else -I32 cast_i32 P((double)); +I32 cast_i32 _((double)); #define I_32(what) (cast_i32(what)) +IV cast_iv _((double)); +#define I_V(what) (cast_iv(what)) #endif struct Outrec { @@ -666,17 +669,21 @@ struct Outrec { # define MAXSYSFD 2 #endif -#ifndef DOSISH -#define TMPPATH "/tmp/perl-eXXXXXX" -#else +#ifdef DOSISH #define TMPPATH "plXXXXXX" -#endif /* MSDOS */ +#else +#ifdef VMS +#define TMPPATH "/sys$scratch/perl-eXXXXXX" +#else +#define TMPPATH "/tmp/perl-eXXXXXX" +#endif +#endif #ifndef __cplusplus -Uid_t getuid P(()); -Uid_t geteuid P(()); -Gid_t getgid P(()); -Gid_t getegid P(()); +Uid_t getuid _((void)); +Uid_t geteuid _((void)); +Gid_t getgid _((void)); +Gid_t getegid _((void)); #endif #ifdef DEBUGGING @@ -729,14 +736,16 @@ Gid_t getegid P(()); }}) struct ufuncs { - I32 (*uf_val)P((I32, SV*)); - I32 (*uf_set)P((I32, SV*)); - I32 uf_index; + I32 (*uf_val)_((IV, SV*)); + I32 (*uf_set)_((IV, SV*)); + IV uf_index; }; /* Fix these up for __STDC__ */ -char *mktemp P((char*)); -double atof P((const char*)); +#ifndef __cplusplus +char *mktemp _((char*)); +double atof _((const char*)); +#endif #ifndef STANDARD_C /* All of these are in stdlib.h or time.h for ANSI C */ @@ -753,28 +762,34 @@ char *strcpy(), *strcat(); # ifdef __cplusplus extern "C" { # endif - double exp P((double)); - double log P((double)); - double sqrt P((double)); - double modf P((double,double*)); - double sin P((double)); - double cos P((double)); - double atan2 P((double,double)); - double pow P((double,double)); + double exp _((double)); + double fmod _((double,double)); + double log _((double)); + double sqrt _((double)); + double modf _((double,double*)); + double sin _((double)); + double cos _((double)); + double atan2 _((double,double)); + double pow _((double,double)); # ifdef __cplusplus }; # endif #endif +#if !defined(HAS_FMOD) && defined(HAS_DREM) +#define fmod(x,y) drem((x),(y)) +#endif -char *crypt P((const char*, const char*)); -char *getenv P((const char*)); -Off_t lseek P((int,Off_t,int)); -char *getlogin P((void)); +#ifndef __cplusplus +char *crypt _((const char*, const char*)); +char *getenv _((const char*)); +Off_t lseek _((int,Off_t,int)); +char *getlogin _((void)); +#endif #ifdef EUNICE #define UNLINK unlnk -int unlnk P((char*)); +I32 unlnk _((char*)); #else #define UNLINK unlink #endif @@ -797,9 +812,12 @@ int unlnk P((char*)); #define SCAN_REPL 2 #ifdef DEBUGGING -#define PAD_SV(po) pad_sv(po) +# ifndef register +# define register +# endif +# define PAD_SV(po) pad_sv(po) #else -#define PAD_SV(po) curpad[po] +# define PAD_SV(po) curpad[po] #endif /****************/ @@ -807,8 +825,10 @@ int unlnk P((char*)); /****************/ /* global state */ -EXT PerlInterpreter *curinterp; /* currently running interpreter */ +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 */ @@ -821,8 +841,10 @@ EXT U32 evalseq; /* eval sequence number */ EXT U32 sub_generation; /* inc to force methods to be looked up again */ EXT char ** origenviron; EXT U32 origalen; +EXT U32 * profiledata; -EXT I32 ** xiv_root; /* free xiv list--shared by interpreters */ +EXT XPV* xiv_arenaroot; /* list of allocated xiv areas */ +EXT IV ** xiv_root; /* free xiv list--shared by interpreters */ EXT double * xnv_root; /* free xnv list--shared by interpreters */ EXT XRV * xrv_root; /* free xrv list--shared by interpreters */ EXT XPV * xpv_root; /* free xpv list--shared by interpreters */ @@ -878,15 +900,17 @@ EXT char * patleave INIT("\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}"); EXT char * vert INIT("|"); EXT char warn_uninit[] - INIT("Use of uninitialized variable"); + INIT("Use of uninitialized value"); EXT char warn_nosemi[] INIT("Semicolon seems to be missing"); EXT char warn_reserved[] INIT("Unquoted string \"%s\" may clash with future reserved word"); EXT char warn_nl[] INIT("Unsuccessful %s on filename containing newline"); -EXT char no_hardref[] - INIT("Can't use a string as %s ref while \"strict refs\" averred"); +EXT char no_wrongref[] + INIT("Can't use %s ref as %s ref"); +EXT char no_symref[] + INIT("Can't use a string as %s ref while \"strict refs\" in use"); EXT char no_usym[] INIT("Can't use an undefined value as %s reference"); EXT char no_aelem[] @@ -1020,14 +1044,39 @@ EXT char* block_type[]; /*****************************************************************************/ /* XXX This needs to be revisited, since BEGIN makes yacc re-enter... */ +#include "perly.h" + typedef enum { XOPERATOR, XTERM, XREF, XSTATE, - XBLOCK + XBLOCK, + XTERMBLOCK } expectation; +EXT U32 lex_state; /* next token is determined */ +EXT U32 lex_defer; /* state after determined token */ +EXT expectation lex_expect; /* expect after determined token */ +EXT I32 lex_brackets; /* bracket count */ +EXT I32 lex_formbrack; /* bracket count at outer format level */ +EXT I32 lex_fakebrack; /* outer bracket is mere delimiter */ +EXT I32 lex_casemods; /* casemod count */ +EXT I32 lex_dojoin; /* doing an array interpolation */ +EXT I32 lex_starts; /* how many interps done on level */ +EXT SV * lex_stuff; /* runtime pattern from m// or s/// */ +EXT SV * lex_repl; /* runtime replacement from s/// */ +EXT OP * lex_op; /* extra info to pass back on op */ +EXT OP * lex_inpat; /* in pattern $) and $| are special */ +EXT I32 lex_inwhat; /* what kind of quoting are we in */ +EXT char * lex_brackstack; /* what kind of brackets to pop */ +EXT char * lex_casestack; /* what kind of case mods in effect */ + +/* What we know when we're in LEX_KNOWNEXT state. */ +EXT YYSTYPE nextval[5]; /* value of next token, if any */ +EXT I32 nexttype[5]; /* type of next token */ +EXT I32 nexttoke; + EXT FILE * VOL rsfp INIT(Nullfp); EXT SV * linestr; EXT char * bufptr; @@ -1035,6 +1084,7 @@ EXT char * oldbufptr; EXT char * oldoldbufptr; EXT char * bufend; EXT expectation expect INIT(XSTATE); /* how to interpret ambiguous tokens */ +EXT char * autoboot_preamble INIT(Nullch); EXT I32 multi_start; /* 1st line of multi-line string */ EXT I32 multi_end; /* last line of multi-line string */ @@ -1052,9 +1102,10 @@ EXT I32 comppad_name_fill;/* last "introduced" variable offset */ 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 */ +EXT I32 padix_floor; /* how low may inner block reset padix */ +EXT bool pad_reset_pending; /* reset pad on next attempted alloc */ EXT COP compiling; -EXT SV * evstr; /* op_fold_const() temp string cache */ EXT I32 thisexpr; /* name id for nothing_in_common() */ EXT char * last_uni; /* position of last named-unary operator */ EXT char * last_lop; /* position of last list operator */ @@ -1085,21 +1136,18 @@ EXT char * regxend; /* End of input for compile */ EXT I32 regnpar; /* () count. */ EXT char * regcode; /* Code-emit pointer; ®dummy = don't. */ EXT I32 regsize; /* Code size. */ -EXT I32 regfold; /* are we folding? */ -EXT I32 regsawbracket; /* Did we do {d,d} trick? */ +EXT I32 regnaughty; /* How bad is this pattern? */ EXT I32 regsawback; /* Did we see \1, ...? */ EXT char * reginput; /* String-input pointer. */ -EXT char regprev; /* char before regbol, \n if none */ EXT char * regbol; /* Beginning of input, for ^ check. */ EXT char * regeol; /* End of input, for $ check. */ EXT char ** regstartp; /* Pointer to startp array. */ EXT char ** regendp; /* Ditto for endp. */ -EXT char * reglastparen; /* Similarly for lastparen. */ +EXT U32 * reglastparen; /* Similarly for lastparen. */ EXT char * regtill; /* How far we are required to go. */ -EXT I32 regmyp_size; -EXT char ** regmystartp; -EXT char ** regmyendp; +EXT U16 regflags; /* are we folding, multilining? */ +EXT char regprev; /* char before regbol, \n if none */ /***********************************************/ /* Global only to current interpreter instance */ @@ -1153,7 +1201,6 @@ IEXT U32 Iperldb; /* magical thingies */ IEXT Time_t Ibasetime; /* $^T */ -IEXT I32 Iarybase; /* $[ */ IEXT SV * Iformfeed; /* $^L */ IEXT char * Ichopset IINIT(" \n-"); /* $: */ IEXT char * Irs IINIT("\n"); /* $/ */ @@ -1179,7 +1226,6 @@ IEXT GV * Ilast_in_gv; IEXT GV * Idefgv; IEXT GV * Iargvgv; IEXT GV * Idefoutgv; -IEXT GV * Icuroutgv; IEXT GV * Iargvoutgv; /* shortcuts to regexp stuff */ @@ -1218,7 +1264,7 @@ IEXT I32 Itmps_ix IINIT(-1); IEXT I32 Itmps_floor IINIT(-1); IEXT I32 Itmps_max; IEXT I32 Isv_count; /* how many SV* are currently allocated */ -IEXT I32 Isv_rvcount; /* how many RV* are currently allocated */ +IEXT I32 Isv_objcount; /* how many objects are currently allocated */ IEXT SV* Isv_root; /* storage for SVs belonging to interp */ IEXT SV* Isv_arenaroot; /* list of areas for garbage collection */ @@ -1259,6 +1305,7 @@ IEXT CONTEXT * Icxstack; IEXT I32 Icxstack_ix IINIT(-1); IEXT I32 Icxstack_max IINIT(128); IEXT jmp_buf Itop_env; +IEXT I32 Irunlevel; /* stack stuff */ IEXT AV * Istack; /* THE STACK */ @@ -1310,7 +1357,13 @@ struct interpreter { extern "C" { #endif -#ifdef STANDARD_C +#ifdef __cplusplus +# ifndef I_STDARG +# define I_STDARG 1 +# endif +#endif + +#ifdef I_STDARG # include <stdarg.h> #else # ifdef I_VARARGS @@ -1320,6 +1373,14 @@ extern "C" { #include "proto.h" +#ifdef EMBED +#define Perl_sv_setptrobj(rv,ptr,name) Perl_sv_setref_iv(rv,name,(IV)ptr) +#define Perl_sv_setptrref(rv,ptr) Perl_sv_setref_iv(rv,Nullch,(IV)ptr) +#else +#define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,(IV)ptr) +#define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,(IV)ptr) +#endif + #ifdef __cplusplus }; #endif @@ -1338,8 +1399,8 @@ MGVTBL vtbl_envelem = {0, magic_setenv, MGVTBL vtbl_sig = {0, 0, 0, 0, 0}; MGVTBL vtbl_sigelem = {0, magic_setsig, 0, 0, 0}; -MGVTBL vtbl_pack = {0, 0, - 0, 0, 0}; +MGVTBL vtbl_pack = {0, 0, 0, magic_wipepack, + 0}; MGVTBL vtbl_packelem = {magic_getpack, magic_setpack, 0, magic_clearpack, @@ -1364,11 +1425,22 @@ MGVTBL vtbl_substr = {0, magic_setsubstr, 0, 0, 0}; MGVTBL vtbl_vec = {0, magic_setvec, 0, 0, 0}; +MGVTBL vtbl_pos = {magic_getpos, + magic_setpos, + 0, 0, 0}; MGVTBL vtbl_bm = {0, magic_setbm, 0, 0, 0}; MGVTBL vtbl_uvar = {magic_getuvar, magic_setuvar, 0, 0, 0}; + +#ifdef OVERLOAD +MGVTBL vtbl_amagic = {0, magic_setamagic, + 0, 0, 0}; +MGVTBL vtbl_amagicelem = {0, magic_setamagic, + 0, 0, 0}; +#endif /* OVERLOAD */ + #else EXT MGVTBL vtbl_sv; EXT MGVTBL vtbl_env; @@ -1386,8 +1458,96 @@ EXT MGVTBL vtbl_mglob; EXT MGVTBL vtbl_taint; EXT MGVTBL vtbl_substr; EXT MGVTBL vtbl_vec; +EXT MGVTBL vtbl_pos; EXT MGVTBL vtbl_bm; EXT MGVTBL vtbl_uvar; + +#ifdef OVERLOAD +EXT MGVTBL vtbl_amagic; +EXT MGVTBL vtbl_amagicelem; +#endif /* OVERLOAD */ + #endif +#ifdef OVERLOAD +EXT long amagic_generation; + +#define NofAMmeth 27 +#ifdef DOINIT +EXT char * AMG_names[NofAMmeth][2] = { + {"fallback","abs"}, + {"bool", "nomethod"}, + {"\"\"", "0+"}, + {"+","+="}, + {"-","-="}, + {"*", "*="}, + {"/", "/="}, + {"%", "%="}, + {"**", "**="}, + {"<<", "<<="}, + {">>", ">>="}, + {"<", "<="}, + {">", ">="}, + {"==", "!="}, + {"<=>", "cmp"}, + {"lt", "le"}, + {"gt", "ge"}, + {"eq", "ne"}, + {"&", "^"}, + {"|", "neg"}, + {"!", "~"}, + {"++", "--"}, + {"atan2", "cos"}, + {"sin", "exp"}, + {"log", "sqrt"}, + {"x","x="}, + {".",".="} +}; +#else +EXT char * AMG_names[NofAMmeth][2]; +#endif /* def INITAMAGIC */ + +struct am_table { + long was_ok_sub; + long was_ok_am; + CV* table[NofAMmeth*2]; + long fallback; +}; +typedef struct am_table AMT; + +#define AMGfallNEVER 1 +#define AMGfallNO 2 +#define AMGfallYES 3 + +enum { + fallback_amg, abs_amg, + bool__amg, nomethod_amg, + string_amg, numer_amg, + add_amg, add_ass_amg, + subtr_amg, subtr_ass_amg, + mult_amg, mult_ass_amg, + div_amg, div_ass_amg, + mod_amg, mod_ass_amg, + pow_amg, pow_ass_amg, + lshift_amg, lshift_ass_amg, + rshift_amg, rshift_ass_amg, + lt_amg, le_amg, + gt_amg, ge_amg, + eq_amg, ne_amg, + ncmp_amg, scmp_amg, + slt_amg, sle_amg, + sgt_amg, sge_amg, + seq_amg, sne_amg, + band_amg, bxor_amg, + bor_amg, neg_amg, + not_amg, compl_amg, + inc_amg, dec_amg, + atan2_amg, cos_amg, + sin_amg, exp_amg, + log_amg, sqrt_amg, + repeat_amg, repeat_ass_amg, + concat_amg, concat_ass_amg +}; +#endif /* OVERLOAD */ + #endif /* Include guard */ diff --git a/perl.man b/perl.man deleted file mode 100644 index 3bcede859c..0000000000 --- a/perl.man +++ /dev/null @@ -1,6116 +0,0 @@ -.rn '' }` -''' $RCSfile: perl.man,v $$Revision: 4.1 $$Date: 92/08/07 18:25:59 $ -''' -''' $Log: perl.man,v $ -''' Revision 4.1 92/08/07 18:25:59 lwall -''' -''' Revision 4.0.1.6 92/06/08 15:07:29 lwall -''' patch20: documented that numbers may contain underline -''' patch20: clarified that DATA may only be read from main script -''' patch20: relaxed requirement for semicolon at the end of a block -''' patch20: added ... as variant on .. -''' patch20: documented need for 1; at the end of a required file -''' patch20: extended bracket-style quotes to two-arg operators: s()() and tr()() -''' patch20: paragraph mode now skips extra newlines automatically -''' patch20: documented PERLLIB and PERLDB -''' patch20: documented limit on size of regexp -''' -''' Revision 4.0.1.5 91/11/11 16:42:00 lwall -''' patch19: added little-endian pack/unpack options -''' -''' Revision 4.0.1.4 91/11/05 18:11:05 lwall -''' patch11: added sort {} LIST -''' patch11: added eval {} -''' patch11: documented meaning of scalar(%foo) -''' patch11: sprintf() now supports any length of s field -''' -''' Revision 4.0.1.3 91/06/10 01:26:02 lwall -''' patch10: documented some newer features in addenda -''' -''' Revision 4.0.1.2 91/06/07 11:41:23 lwall -''' patch4: added global modifier for pattern matches -''' patch4: default top-of-form format is now FILEHANDLE_TOP -''' patch4: added $^P variable to control calling of perldb routines -''' patch4: added $^F variable to specify maximum system fd, default 2 -''' patch4: changed old $^P to $^X -''' -''' Revision 4.0.1.1 91/04/11 17:50:44 lwall -''' patch1: fixed some typos -''' -''' Revision 4.0 91/03/20 01:38:08 lwall -''' 4.0 baseline. -''' -''' -.de Sh -.br -.ne 5 -.PP -\fB\\$1\fR -.PP -.. -.de Sp -.if t .sp .5v -.if n .sp -.. -.de Ip -.br -.ie \\n(.$>=3 .ne \\$3 -.el .ne 3 -.IP "\\$1" \\$2 -.. -''' -''' Set up \*(-- to give an unbreakable dash; -''' string Tr holds user defined translation string. -''' Bell System Logo is used as a dummy character. -''' -.tr \(*W-|\(bv\*(Tr -.ie n \{\ -.ds -- \(*W- -.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch -.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch -.ds L" "" -.ds R" "" -.ds L' ' -.ds R' ' -'br\} -.el\{\ -.ds -- \(em\| -.tr \*(Tr -.ds L" `` -.ds R" '' -.ds L' ` -.ds R' ' -'br\} -.TH PERL 1 "\*(RP" -.UC -.SH NAME -perl \- Practical Extraction and Report Language -.SH SYNOPSIS -.B perl -[options] filename args -.SH DESCRIPTION -.I Perl -is an interpreted language optimized for scanning arbitrary text files, -extracting information from those text files, and printing reports based -on that information. -It's also a good language for many system management tasks. -The language is intended to be practical (easy to use, efficient, complete) -rather than beautiful (tiny, elegant, minimal). -It combines (in the author's opinion, anyway) some of the best features of C, -\fIsed\fR, \fIawk\fR, and \fIsh\fR, -so people familiar with those languages should have little difficulty with it. -(Language historians will also note some vestiges of \fIcsh\fR, Pascal, and -even BASIC-PLUS.) -Expression syntax corresponds quite closely to C expression syntax. -Unlike most Unix utilities, -.I perl -does not arbitrarily limit the size of your data\*(--if you've got -the memory, -.I perl -can slurp in your whole file as a single string. -Recursion is of unlimited depth. -And the hash tables used by associative arrays grow as necessary to prevent -degraded performance. -.I Perl -uses sophisticated pattern matching techniques to scan large amounts of -data very quickly. -Although optimized for scanning text, -.I perl -can also deal with binary data, and can make dbm files look like associative -arrays (where dbm is available). -Setuid -.I perl -scripts are safer than C programs -through a dataflow tracing mechanism which prevents many stupid security holes. -If you have a problem that would ordinarily use \fIsed\fR -or \fIawk\fR or \fIsh\fR, but it -exceeds their capabilities or must run a little faster, -and you don't want to write the silly thing in C, then -.I perl -may be for you. -There are also translators to turn your -.I sed -and -.I awk -scripts into -.I perl -scripts. -OK, enough hype. -.PP -Upon startup, -.I perl -looks for your script in one of the following places: -.Ip 1. 4 2 -Specified line by line via -.B \-e -switches on the command line. -.Ip 2. 4 2 -Contained in the file specified by the first filename on the command line. -(Note that systems supporting the #! notation invoke interpreters this way.) -.Ip 3. 4 2 -Passed in implicitly via standard input. -This only works if there are no filename arguments\*(--to pass -arguments to a -.I stdin -script you must explicitly specify a \- for the script name. -.PP -After locating your script, -.I perl -compiles it to an internal form. -If the script is syntactically correct, it is executed. If the script -runs off the end without hitting an exit or die operator, an implicit -exit(0) is provided to indicate successful completion. -.Sh "Options" -Note: on first reading this section may not make much sense to you. It's here -at the front for easy reference. -.PP -A single-character option may be combined with the following option, if any. -This is particularly useful when invoking a script using the #! construct which -only allows one argument. Example: -.nf - -.ne 2 - #!/usr/bin/perl \-spi.bak # same as \-s \-p \-i.bak - .\|.\|. - -.fi -Options include: -.TP 5 -.BI \-0 digits -specifies the record separator ($/) as an octal number. -If there are no digits, the null character is the separator. -Other switches may precede or follow the digits. -For example, if you have a version of -.I find -which can print filenames terminated by the null character, you can say this: -.nf - - find . \-name '*.bak' \-print0 | perl \-n0e unlink - -.fi -The special value 00 will cause Perl to slurp files in paragraph mode. -The value 0777 will cause Perl to slurp files whole since there is no -legal character with that value. -.TP 5 -.B \-a -turns on autosplit mode when used with a -.B \-n -or -.BR \-p . -An implicit split command to the @F array -is done as the first thing inside the implicit while loop produced by -the -.B \-n -or -.BR \-p . -.nf - - perl \-ane \'print pop(@F), "\en";\' - -is equivalent to - - while (<>) { - @F = split(\' \'); - print pop(@F), "\en"; - } - -.fi -.TP 5 -.B \-c -causes -.I perl -to check the syntax of the script and then exit without executing it. -.TP 5 -.BI \-d -runs the script under the perl debugger. -See the section on Debugging. -.TP 5 -.BI \-D number -sets debugging flags. -To watch how it executes your script, use -.BR \-D14 . -(This only works if debugging is compiled into your -.IR perl .) -Another nice value is \-D1024, which lists your compiled syntax tree. -And \-D512 displays compiled regular expressions. -.TP 5 -.BI \-e " commandline" -may be used to enter one line of script. -Multiple -.B \-e -commands may be given to build up a multi-line script. -If -.B \-e -is given, -.I perl -will not look for a script filename in the argument list. -.TP 5 -.BI \-i extension -specifies that files processed by the <> construct are to be edited -in-place. -It does this by renaming the input file, opening the output file by the -same name, and selecting that output file as the default for print statements. -The extension, if supplied, is added to the name of the -old file to make a backup copy. -If no extension is supplied, no backup is made. -Saying \*(L"perl \-p \-i.bak \-e "s/foo/bar/;" .\|.\|. \*(R" is the same as using -the script: -.nf - -.ne 2 - #!/usr/bin/perl \-pi.bak - s/foo/bar/; - -which is equivalent to - -.ne 14 - #!/usr/bin/perl - while (<>) { - if ($ARGV ne $oldargv) { - rename($ARGV, $ARGV . \'.bak\'); - open(ARGVOUT, ">$ARGV"); - select(ARGVOUT); - $oldargv = $ARGV; - } - s/foo/bar/; - } - continue { - print; # this prints to original filename - } - select(STDOUT); - -.fi -except that the -.B \-i -form doesn't need to compare $ARGV to $oldargv to know when -the filename has changed. -It does, however, use ARGVOUT for the selected filehandle. -Note that -.I STDOUT -is restored as the default output filehandle after the loop. -.Sp -You can use eof to locate the end of each input file, in case you want -to append to each file, or reset line numbering (see example under eof). -.TP 5 -.BI \-I directory -may be used in conjunction with -.B \-P -to tell the C preprocessor where to look for include files. -By default /usr/include and /usr/lib/perl are searched. -.TP 5 -.BI \-l octnum -enables automatic line-ending processing. It has two effects: -first, it automatically chops the line terminator when used with -.B \-n -or -.B \-p , -and second, it assigns $\e to have the value of -.I octnum -so that any print statements will have that line terminator added back on. If -.I octnum -is omitted, sets $\e to the current value of $/. -For instance, to trim lines to 80 columns: -.nf - - perl -lpe \'substr($_, 80) = ""\' - -.fi -Note that the assignment $\e = $/ is done when the switch is processed, -so the input record separator can be different than the output record -separator if the -.B \-l -switch is followed by a -.B \-0 -switch: -.nf - - gnufind / -print0 | perl -ln0e 'print "found $_" if -p' - -.fi -This sets $\e to newline and then sets $/ to the null character. -.TP 5 -.B \-n -causes -.I perl -to assume the following loop around your script, which makes it iterate -over filename arguments somewhat like \*(L"sed \-n\*(R" or \fIawk\fR: -.nf - -.ne 3 - while (<>) { - .\|.\|. # your script goes here - } - -.fi -Note that the lines are not printed by default. -See -.B \-p -to have lines printed. -Here is an efficient way to delete all files older than a week: -.nf - - find . \-mtime +7 \-print | perl \-nle \'unlink;\' - -.fi -This is faster than using the \-exec switch of find because you don't have to -start a process on every filename found. -.TP 5 -.B \-p -causes -.I perl -to assume the following loop around your script, which makes it iterate -over filename arguments somewhat like \fIsed\fR: -.nf - -.ne 5 - while (<>) { - .\|.\|. # your script goes here - } continue { - print; - } - -.fi -Note that the lines are printed automatically. -To suppress printing use the -.B \-n -switch. -A -.B \-p -overrides a -.B \-n -switch. -.TP 5 -.B \-P -causes your script to be run through the C preprocessor before -compilation by -.IR perl . -(Since both comments and cpp directives begin with the # character, -you should avoid starting comments with any words recognized -by the C preprocessor such as \*(L"if\*(R", \*(L"else\*(R" or \*(L"define\*(R".) -.TP 5 -.B \-s -enables some rudimentary switch parsing for switches on the command line -after the script name but before any filename arguments (or before a \-\|\-). -Any switch found there is removed from @ARGV and sets the corresponding variable in the -.I perl -script. -The following script prints \*(L"true\*(R" if and only if the script is -invoked with a \-xyz switch. -.nf - -.ne 2 - #!/usr/bin/perl \-s - if ($xyz) { print "true\en"; } - -.fi -.TP 5 -.B \-S -makes -.I perl -use the PATH environment variable to search for the script -(unless the name of the script starts with a slash). -Typically this is used to emulate #! startup on machines that don't -support #!, in the following manner: -.nf - - #!/usr/bin/perl - eval "exec /usr/bin/perl \-S $0 $*" - if $running_under_some_shell; - -.fi -The system ignores the first line and feeds the script to /bin/sh, -which proceeds to try to execute the -.I perl -script as a shell script. -The shell executes the second line as a normal shell command, and thus -starts up the -.I perl -interpreter. -On some systems $0 doesn't always contain the full pathname, -so the -.B \-S -tells -.I perl -to search for the script if necessary. -After -.I perl -locates the script, it parses the lines and ignores them because -the variable $running_under_some_shell is never true. -A better construct than $* would be ${1+"$@"}, which handles embedded spaces -and such in the filenames, but doesn't work if the script is being interpreted -by csh. -In order to start up sh rather than csh, some systems may have to replace the -#! line with a line containing just -a colon, which will be politely ignored by perl. -Other systems can't control that, and need a totally devious construct that -will work under any of csh, sh or perl, such as the following: -.nf - -.ne 3 - eval '(exit $?0)' && eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' - & eval 'exec /usr/bin/perl -S $0 $argv:q' - if 0; - -.fi -.TP 5 -.B \-T -forces "taint" checks to be turned on. Ordinarily these checks are done -only when running setuid or setgid. -.TP 5 -.B \-u -causes -.I perl -to dump core after compiling your script. -You can then take this core dump and turn it into an executable file -by using the undump program (not supplied). -This speeds startup at the expense of some disk space (which you can -minimize by stripping the executable). -(Still, a "hello world" executable comes out to about 200K on my machine.) -If you are going to run your executable as a set-id program then you -should probably compile it using taintperl rather than normal perl. -If you want to execute a portion of your script before dumping, use the -dump operator instead. -Note: availability of undump is platform specific and may not be available -for a specific port of perl. -.TP 5 -.B \-U -allows -.I perl -to do unsafe operations. -Currently the only \*(L"unsafe\*(R" operations are the unlinking of directories while -running as superuser, and running setuid programs with fatal taint checks -turned into warnings. -.TP 5 -.B \-v -prints the version and patchlevel of your -.I perl -executable. -.TP 5 -.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 warns you if you use == on values that don't look like numbers, and if -your subroutines recurse more than 100 deep. -.TP 5 -.BI \-x directory -tells -.I perl -that the script is embedded in a message. -Leading garbage will be discarded until the first line that starts -with #! and contains the string "perl". -Any meaningful switches on that line will be applied (but only one -group of switches, as with normal #! processing). -If a directory name is specified, Perl will switch to that directory -before running the script. -The -.B \-x -switch only controls the the disposal of leading garbage. -The script must be terminated with _\|_END_\|_ if there is trailing garbage -to be ignored (the script can process any or all of the trailing garbage -via the DATA filehandle if desired). -.Sh "Data Types and Objects" -.PP -.I Perl -has three data types: scalars, arrays of scalars, and -associative arrays of scalars. -Normal arrays are indexed by number, and associative arrays by string. -.PP -The interpretation of operations and values in perl sometimes -depends on the requirements -of the context around the operation or value. -There are three major contexts: string, numeric and array. -Certain operations return array values -in contexts wanting an array, and scalar values otherwise. -(If this is true of an operation it will be mentioned in the documentation -for that operation.) -Operations which return scalars don't care whether the context is looking -for a string or a number, but -scalar variables and values are interpreted as strings or numbers -as appropriate to the context. -A scalar is interpreted as TRUE in the boolean sense if it is not the null -string or 0. -Booleans returned by operators are 1 for true and 0 or \'\' (the null -string) for false. -.PP -There are actually two varieties of null string: defined and undefined. -Undefined null strings are returned when there is no real value for something, -such as when there was an error, or at end of file, or when you refer -to an uninitialized variable or element of an array. -An undefined null string may become defined the first time you access it, but -prior to that you can use the defined() operator to determine whether the -value is defined or not. -.PP -References to scalar variables always begin with \*(L'$\*(R', even when referring -to a scalar that is part of an array. -Thus: -.nf - -.ne 3 - $days \h'|2i'# a simple scalar variable - $days[28] \h'|2i'# 29th element of array @days - $days{\'Feb\'}\h'|2i'# one value from an associative array - $#days \h'|2i'# last index of array @days - -but entire arrays or array slices are denoted by \*(L'@\*(R': - - @days \h'|2i'# ($days[0], $days[1],\|.\|.\|. $days[n]) - @days[3,4,5]\h'|2i'# same as @days[3.\|.5] - @days{'a','c'}\h'|2i'# same as ($days{'a'},$days{'c'}) - -and entire associative arrays are denoted by \*(L'%\*(R': - - %days \h'|2i'# (key1, val1, key2, val2 .\|.\|.) -.fi -.PP -Any of these eight constructs may serve as an lvalue, -that is, may be assigned to. -(It also turns out that an assignment is itself an lvalue in -certain contexts\*(--see examples under s, tr and chop.) -Assignment to a scalar evaluates the righthand side in a scalar context, -while assignment to an array or array slice evaluates the righthand side -in an array context. -.PP -You may find the length of array @days by evaluating -\*(L"$#days\*(R", as in -.IR csh . -(Actually, it's not the length of the array, it's the subscript of the last element, since there is (ordinarily) a 0th element.) -Assigning to $#days changes the length of the array. -Shortening an array by this method does not actually destroy any values. -Lengthening an array that was previously shortened recovers the values that -were in those elements. -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. -This differs from assigning to $#whatever in that intervening values -are set to null rather than recovered.) -You can truncate an array down to nothing by assigning the null list () to -it. -The following are exactly equivalent -.nf - - @whatever = (); - $#whatever = $[ \- 1; - -.fi -.PP -If you evaluate an array in a scalar context, it returns the length of -the array. -The following is always true: -.nf - - scalar(@whatever) == $#whatever \- $[ + 1; - -.fi -If you evaluate an associative array in a scalar context, it returns -a value which is true if and only if the array contains any elements. -(If there are any elements, the value returned is a string consisting -of the number of used buckets and the number of allocated buckets, separated -by a slash.) -.PP -Multi-dimensional arrays are not directly supported, but see the discussion -of the $; variable later for a means of emulating multiple subscripts with -an associative array. -You could also write a subroutine to turn multiple subscripts into a single -subscript. -.PP -Every data type has its own namespace. -You can, without fear of conflict, use the same name for a scalar variable, -an array, an associative array, a filehandle, a subroutine name, and/or -a label. -Since variable and array references always start with \*(L'$\*(R', \*(L'@\*(R', -or \*(L'%\*(R', the \*(L"reserved\*(R" words aren't in fact reserved -with respect to variable names. -(They ARE reserved with respect to labels and filehandles, however, which -don't have an initial special character. -Hint: you could say open(LOG,\'logfile\') rather than open(log,\'logfile\'). -Using uppercase filehandles also improves readability and protects you -from conflict with future reserved words.) -Case IS significant\*(--\*(L"FOO\*(R", \*(L"Foo\*(R" and \*(L"foo\*(R" are all -different names. -Names which start with a letter may also contain digits and underscores. -Names which do not start with a letter are limited to one character, -e.g. \*(L"$%\*(R" or \*(L"$$\*(R". -(Most of the one character names have a predefined significance to -.IR perl . -More later.) -.PP -Numeric literals are specified in any of the usual floating point or -integer formats: -.nf - -.ne 6 - 12345 - 12345.67 - .23E-10 - 0xffff # hex - 0377 # octal - 4_294_967_296 - -.fi -String literals are delimited by either single or double quotes. -They work much like shell quotes: -double-quoted string literals are subject to backslash and variable -substitution; single-quoted strings are not (except for \e\' and \e\e). -The usual backslash rules apply for making characters such as newline, tab, -etc., as well as some more exotic forms: -.nf - - \et tab - \en newline - \er return - \ef form feed - \eb backspace - \ea alarm (bell) - \ee escape - \e033 octal char - \ex1b hex char - \ec[ control char - \el lowercase next char - \eu uppercase next char - \eL lowercase till \eE - \eU uppercase till \eE - \eE end case modification - -.fi -You can also embed newlines directly in your strings, i.e. they can end on -a different line than they begin. -This is nice, but if you forget your trailing quote, the error will not be -reported until -.I perl -finds another line containing the quote character, which -may be much further on in the script. -Variable substitution inside strings is limited to scalar variables, normal -array values, 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 \*(L"The price is $100.\*(R" -.nf - -.ne 2 - $Price = \'$100\';\h'|3.5i'# not interpreted - print "The price is $Price.\e\|n";\h'|3.5i'# interpreted - -.fi -Note that you can put curly brackets around the identifier to delimit it -from following alphanumerics. -Also note that a single quoted string must be separated from a preceding -word by a space, since single quote is a valid character in an identifier -(see Packages). -.PP -Two special literals are _\|_LINE_\|_ and _\|_FILE_\|_, which represent the current -line number and filename at that point in your program. -They may only be used as separate tokens; they will not be interpolated -into strings. -In addition, the token _\|_END_\|_ may be used to indicate the logical end of the -script before the actual end of file. -Any following text is ignored, but may be read via the DATA filehandle. -(The DATA filehandle may read data only from the main script, but not from -any required file or evaluated string.) -The two control characters ^D and ^Z are synonyms for _\|_END_\|_. -.PP -A word that doesn't have any other interpretation in the grammar will be -treated as if it had single quotes around it. -For this purpose, a word consists only of alphanumeric characters and underline, -and must start with an alphabetic character. -As with filehandles and labels, a bare word that consists entirely of -lowercase letters risks conflict with future reserved words, and if you -use the -.B \-w -switch, Perl will warn you about any such words. -.PP -Array values are interpolated into double-quoted strings by joining all the -elements of the array with the delimiter specified in the $" variable, -space by default. -(Since in versions of perl prior to 3.0 the @ character was not a metacharacter -in double-quoted strings, the interpolation of @array, $array[EXPR], -@array[LIST], $array{EXPR}, or @array{LIST} only happens if array is -referenced elsewhere in the program or is predefined.) -The following are equivalent: -.nf - -.ne 4 - $temp = join($",@ARGV); - system "echo $temp"; - - system "echo @ARGV"; - -.fi -Within search patterns (which also undergo double-quotish substitution) -there is a bad ambiguity: Is /$foo[bar]/ to be -interpreted as /${foo}[bar]/ (where [bar] is a character class for the -regular expression) or as /${foo[bar]}/ (where [bar] is the subscript to -array @foo)? -If @foo doesn't otherwise exist, then it's obviously a character class. -If @foo exists, perl takes a good guess about [bar], and is almost always right. -If it does guess wrong, or if you're just plain paranoid, -you can force the correct interpretation with curly brackets as above. -.PP -A line-oriented form of quoting is based on the shell here-is syntax. -Following a << you specify a string to terminate the quoted material, and all lines -following the current line down to the terminating string are the value -of the item. -The terminating string may be either an identifier (a word), or some -quoted text. -If quoted, the type of quotes you use determines the treatment of the text, -just as in regular quoting. -An unquoted identifier works like double quotes. -There must be no space between the << and the identifier. -(If you put a space it will be treated as a null identifier, which is -valid, and matches the first blank line\*(--see Merry Christmas example below.) -The terminating string must appear by itself (unquoted and with no surrounding -whitespace) on the terminating line. -.nf - - print <<EOF; # same as above -The price is $Price. -EOF - - print <<"EOF"; # same as above -The price is $Price. -EOF - - print << x 10; # null identifier is delimiter -Merry Christmas! - - print <<`EOC`; # execute commands -echo hi there -echo lo there -EOC - - print <<foo, <<bar; # you can stack them -I said foo. -foo -I said bar. -bar - -.fi -Array literals are denoted by separating individual values by commas, and -enclosing the list in parentheses: -.nf - - (LIST) - -.fi -In a context not requiring an array value, the value of the array literal -is the value of the final element, as in the C comma operator. -For example, -.nf - -.ne 4 - @foo = (\'cc\', \'\-E\', $bar); - -assigns the entire array value to array foo, but - - $foo = (\'cc\', \'\-E\', $bar); - -.fi -assigns the value of variable bar to variable foo. -Note that the value of an actual array in a scalar context is the length -of the array; the following assigns to $foo the value 3: -.nf - -.ne 2 - @foo = (\'cc\', \'\-E\', $bar); - $foo = @foo; # $foo gets 3 - -.fi -You may have an optional comma before the closing parenthesis of an -array literal, so that you can say: -.nf - - @foo = ( - 1, - 2, - 3, - ); - -.fi -When a LIST is evaluated, each element of the list is evaluated in -an array context, and the resulting array value is interpolated into LIST -just as if each individual element were a member of LIST. Thus arrays -lose their identity in a LIST\*(--the list - - (@foo,@bar,&SomeSub) - -contains all the elements of @foo followed by all the elements of @bar, -followed by all the elements returned by the subroutine named SomeSub. -.PP -A list value may also be subscripted like a normal array. -Examples: -.nf - - $time = (stat($file))[8]; # stat returns array value - $digit = ('a','b','c','d','e','f')[$digit-10]; - return (pop(@foo),pop(@foo))[0]; - -.fi -.PP -Array lists may be assigned to if and only if each element of the list -is an lvalue: -.nf - - ($a, $b, $c) = (1, 2, 3); - - ($map{\'red\'}, $map{\'blue\'}, $map{\'green\'}) = (0x00f, 0x0f0, 0xf00); - -The final element may be an array or an associative array: - - ($a, $b, @rest) = split; - local($a, $b, %rest) = @_; - -.fi -You can actually put an array anywhere in the list, but the first array -in the list will soak up all the values, and anything after it will get -a null value. -This may be useful in a local(). -.PP -An associative array literal contains pairs of values to be interpreted -as a key and a value: -.nf - -.ne 2 - # same as map assignment above - %map = ('red',0x00f,'blue',0x0f0,'green',0xf00); - -.fi -Array assignment in a scalar context returns the number of elements -produced by the expression on the right side of the assignment: -.nf - - $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2 - -.fi -.PP -There are several other pseudo-literals that you should know about. -If a string is enclosed by backticks (grave accents), it first undergoes -variable substitution just like a double quoted string. -It is then interpreted as a command, and the output of that command -is the value of the pseudo-literal, like in a shell. -In a scalar context, a single string consisting of all the output is -returned. -In an array context, an array of values is returned, one for each line -of output. -(You can set $/ to use a different line terminator.) -The command is executed each time the pseudo-literal is evaluated. -The status value of the command is returned in $? (see Predefined Names -for the interpretation of $?). -Unlike in \f2csh\f1, no translation is done on the return -data\*(--newlines remain newlines. -Unlike in any of the shells, single quotes do not hide variable names -in the command from interpretation. -To pass a $ through to the shell you need to hide it with a backslash. -.PP -Evaluating a filehandle in angle brackets yields the next line -from that file (newline included, so it's never false until EOF, at -which time an undefined value is returned). -Ordinarily you must assign that value to a variable, -but there is one situation where an automatic assignment happens. -If (and only if) the input symbol is the only thing inside the conditional of a -.I while -loop, the value is -automatically assigned to the variable \*(L"$_\*(R". -(This may seem like an odd thing to you, but you'll use the construct -in almost every -.I perl -script you write.) -Anyway, the following lines are equivalent to each other: -.nf - -.ne 5 - while ($_ = <STDIN>) { print; } - while (<STDIN>) { print; } - for (\|;\|<STDIN>;\|) { print; } - print while $_ = <STDIN>; - print while <STDIN>; - -.fi -The filehandles -.IR STDIN , -.I STDOUT -and -.I STDERR -are predefined. -(The filehandles -.IR stdin , -.I stdout -and -.I stderr -will also work except in packages, where they would be interpreted as -local identifiers rather than global.) -Additional filehandles may be created with the -.I open -function. -.PP -If a <FILEHANDLE> is used in a context that is looking for an array, an array -consisting of all the input lines is returned, one line per array element. -It's easy to make a LARGE data space this way, so use with care. -.PP -The null filehandle <> is special and can be used to emulate the behavior of -\fIsed\fR and \fIawk\fR. -Input from <> comes either from standard input, or from each file listed on -the command line. -Here's how it works: the first time <> is evaluated, the ARGV array is checked, -and if it is null, $ARGV[0] is set to \'-\', which when opened gives you standard -input. -The ARGV array is then processed as a list of filenames. -The loop -.nf - -.ne 3 - while (<>) { - .\|.\|. # code for each line - } - -.ne 10 -is equivalent to the following Perl-like pseudo code: - - unshift(@ARGV, \'\-\') \|if \|$#ARGV < $[; - while ($ARGV = shift) { - open(ARGV, $ARGV); - while (<ARGV>) { - .\|.\|. # code for each line - } - } - -.fi -except that it isn't as cumbersome to say, and will actually work. -It really does shift array ARGV and put the current filename into -variable ARGV. -It also uses filehandle ARGV internally\*(--<> is just a synonym for -<ARGV>, which is magical. -(The pseudo code above doesn't work because it treats <ARGV> as non-magical.) -.PP -You can modify @ARGV before the first <> as long as the array ends up -containing the list of filenames you really want. -Line numbers ($.) continue as if the input was one big happy file. -(But see example under eof for how to reset line numbers on each file.) -.PP -.ne 5 -If you want to set @ARGV to your own list of files, go right ahead. -If you want to pass switches into your script, you can -put a loop on the front like this: -.nf - -.ne 10 - while ($_ = $ARGV[0], /\|^\-/\|) { - shift; - last if /\|^\-\|\-$\|/\|; - /\|^\-D\|(.*\|)/ \|&& \|($debug = $1); - /\|^\-v\|/ \|&& \|$verbose++; - .\|.\|. # other switches - } - while (<>) { - .\|.\|. # code for each line - } - -.fi -The <> symbol will return FALSE only once. -If you call it again after this it will assume you are processing another -@ARGV list, and if you haven't set @ARGV, will input from -.IR STDIN . -.PP -If the string inside the angle brackets is a reference to a scalar variable -(e.g. <$foo>), -then that variable contains the name of the filehandle to input from. -.PP -If the string inside angle brackets is not a filehandle, it is interpreted -as a filename pattern to be globbed, and either an array of filenames or the -next filename in the list is returned, depending on context. -One level of $ interpretation is done first, but you can't say <$foo> -because that's an indirect filehandle as explained in the previous -paragraph. -You could insert curly brackets to force interpretation as a -filename glob: <${foo}>. -Example: -.nf - -.ne 3 - while (<*.c>) { - chmod 0644, $_; - } - -is equivalent to - -.ne 5 - open(foo, "echo *.c | tr \-s \' \et\er\ef\' \'\e\e012\e\e012\e\e012\e\e012\'|"); - while (<foo>) { - chop; - chmod 0644, $_; - } - -.fi -In fact, it's currently implemented that way. -(Which means it will not work on filenames with spaces in them unless -you have /bin/csh on your machine.) -Of course, the shortest way to do the above is: -.nf - - chmod 0644, <*.c>; - -.fi -.Sh "Syntax" -.PP -A -.I perl -script consists of a sequence of declarations and commands. -The only things that need to be declared in -.I perl -are report formats and subroutines. -See the sections below for more information on those declarations. -All uninitialized user-created objects are assumed to -start with a null or 0 value until they -are defined by some explicit operation such as assignment. -The sequence of commands is executed just once, unlike in -.I sed -and -.I awk -scripts, where the sequence of commands is executed for each input line. -While this means that you must explicitly loop over the lines of your input file -(or files), it also means you have much more control over which files and which -lines you look at. -(Actually, I'm lying\*(--it is possible to do an implicit loop with either the -.B \-n -or -.B \-p -switch.) -.PP -A declaration can be put anywhere a command can, but has no effect on the -execution of the primary sequence of commands\*(--declarations all take effect -at compile time. -Typically all the declarations are put at the beginning or the end of the script. -.PP -.I Perl -is, for the most part, a free-form language. -(The only exception to this is format declarations, for fairly obvious reasons.) -Comments are indicated by the # character, and extend to the end of the line. -If you attempt to use /* */ C comments, it will be interpreted either as -division or pattern matching, depending on the context. -So don't do that. -.Sh "Compound statements" -In -.IR perl , -a sequence of commands may be treated as one command by enclosing it -in curly brackets. -We will call this a BLOCK. -.PP -The following compound commands may be used to control flow: -.nf - -.ne 4 - if (EXPR) BLOCK - if (EXPR) BLOCK else BLOCK - if (EXPR) BLOCK elsif (EXPR) BLOCK .\|.\|. else BLOCK - LABEL while (EXPR) BLOCK - LABEL while (EXPR) BLOCK continue BLOCK - LABEL for (EXPR; EXPR; EXPR) BLOCK - LABEL foreach VAR (ARRAY) BLOCK - LABEL BLOCK continue BLOCK - -.fi -Note that, unlike C and Pascal, these are defined in terms of BLOCKs, not -statements. -This means that the curly brackets are \fIrequired\fR\*(--no dangling statements allowed. -If you want to write conditionals without curly brackets there are several -other ways to do it. -The following all do the same thing: -.nf - -.ne 5 - if (!open(foo)) { die "Can't open $foo: $!"; } - die "Can't open $foo: $!" unless open(foo); - open(foo) || die "Can't open $foo: $!"; # foo or bust! - open(foo) ? \'hi mom\' : die "Can't open $foo: $!"; - # a bit exotic, that last one - -.fi -.PP -The -.I if -statement is straightforward. -Since BLOCKs are always bounded by curly brackets, there is never any -ambiguity about which -.I if -an -.I else -goes with. -If you use -.I unless -in place of -.IR if , -the sense of the test is reversed. -.PP -The -.I while -statement executes the block as long as the expression is true -(does not evaluate to the null string or 0). -The LABEL is optional, and if present, consists of an identifier followed by -a colon. -The LABEL identifies the loop for the loop control statements -.IR next , -.IR last , -and -.I redo -(see below). -If there is a -.I continue -BLOCK, it is always executed just before -the conditional is about to be evaluated again, similarly to the third part -of a -.I for -loop in C. -Thus it can be used to increment a loop variable, even when the loop has -been continued via the -.I next -statement (similar to the C \*(L"continue\*(R" statement). -.PP -If the word -.I while -is replaced by the word -.IR until , -the sense of the test is reversed, but the conditional is still tested before -the first iteration. -.PP -In either the -.I if -or the -.I while -statement, you may replace \*(L"(EXPR)\*(R" with a BLOCK, and the conditional -is true if the value of the last command in that block is true. -(This feature continues to work in Perl 5 but is deprecated. Please -change any occurrences of "if BLOCK" to "if (do BLOCK)".) -.PP -The -.I for -loop works exactly like the corresponding -.I while -loop: -.nf - -.ne 12 - for ($i = 1; $i < 10; $i++) { - .\|.\|. - } - -is the same as - - $i = 1; - while ($i < 10) { - .\|.\|. - } continue { - $i++; - } -.fi -.PP -The foreach loop iterates over a normal array value and sets the variable -VAR to be each element of the array in turn. -The variable is implicitly local to the loop, and regains its former value -upon exiting the loop. -The \*(L"foreach\*(R" keyword is actually identical to the \*(L"for\*(R" keyword, -so you can use \*(L"foreach\*(R" for readability or \*(L"for\*(R" for brevity. -If VAR is omitted, $_ is set to each value. -If ARRAY is an actual array (as opposed to an expression returning an array -value), you can modify each element of the array -by modifying VAR inside the loop. -Examples: -.nf - -.ne 5 - for (@ary) { s/foo/bar/; } - - foreach $elem (@elements) { - $elem *= 2; - } - -.ne 3 - for ((10,9,8,7,6,5,4,3,2,1,\'BOOM\')) { - print $_, "\en"; sleep(1); - } - - for (1..15) { print "Merry Christmas\en"; } - -.ne 3 - foreach $item (split(/:[\e\e\en:]*/, $ENV{\'TERMCAP\'})) { - print "Item: $item\en"; - } - -.fi -.PP -The BLOCK by itself (labeled or not) is equivalent to a loop that executes -once. -Thus you can use any of the loop control statements in it to leave or -restart the block. -The -.I continue -block is optional. -This construct is particularly nice for doing case structures. -.nf - -.ne 6 - foo: { - if (/^abc/) { $abc = 1; last foo; } - if (/^def/) { $def = 1; last foo; } - if (/^xyz/) { $xyz = 1; last foo; } - $nothing = 1; - } - -.fi -There is no official switch statement in perl, because there -are already several ways to write the equivalent. -In addition to the above, you could write -.nf - -.ne 6 - foo: { - $abc = 1, last foo if /^abc/; - $def = 1, last foo if /^def/; - $xyz = 1, last foo if /^xyz/; - $nothing = 1; - } - -or - -.ne 6 - foo: { - /^abc/ && do { $abc = 1; last foo; }; - /^def/ && do { $def = 1; last foo; }; - /^xyz/ && do { $xyz = 1; last foo; }; - $nothing = 1; - } - -or - -.ne 6 - foo: { - /^abc/ && ($abc = 1, last foo); - /^def/ && ($def = 1, last foo); - /^xyz/ && ($xyz = 1, last foo); - $nothing = 1; - } - -or even - -.ne 8 - if (/^abc/) - { $abc = 1; } - elsif (/^def/) - { $def = 1; } - elsif (/^xyz/) - { $xyz = 1; } - else - {$nothing = 1;} - -.fi -As it happens, these are all optimized internally to a switch structure, -so perl jumps directly to the desired statement, and you needn't worry -about perl executing a lot of unnecessary statements when you have a string -of 50 elsifs, as long as you are testing the same simple scalar variable -using ==, eq, or pattern matching as above. -(If you're curious as to whether the optimizer has done this for a particular -case statement, you can use the \-D1024 switch to list the syntax tree -before execution.) -.Sh "Simple statements" -The only kind of simple statement is an expression evaluated for its side -effects. -Every simple statement must be terminated with a semicolon, unless it is the -final statement in a block, in which case the semicolon is optional. -(Semicolon is still encouraged there if the block takes up more than one line). -.PP -Any simple statement may optionally be followed by a -single modifier, just before the terminating semicolon. -The possible modifiers are: -.nf - -.ne 4 - if EXPR - unless EXPR - while EXPR - until EXPR - -.fi -The -.I if -and -.I unless -modifiers have the expected semantics. -The -.I while -and -.I until -modifiers also have the expected semantics (conditional evaluated first), -except when applied to a do-BLOCK or a do-SUBROUTINE command, -in which case the block executes once before the conditional is evaluated. -This is so that you can write loops like: -.nf - -.ne 4 - do { - $_ = <STDIN>; - .\|.\|. - } until $_ \|eq \|".\|\e\|n"; - -.fi -(See the -.I do -operator below. Note also that the loop control commands described later will -NOT work in this construct, since modifiers don't take loop labels. -Sorry.) -.Sh "Expressions" -Since -.I perl -expressions work almost exactly like C expressions, only the differences -will be mentioned here. -.PP -Here's what -.I perl -has that C doesn't: -.Ip ** 8 2 -The exponentiation operator. -.Ip **= 8 -The exponentiation assignment operator. -.Ip (\|) 8 3 -The null list, used to initialize an array to null. -.Ip . 8 -Concatenation of two strings. -.Ip .= 8 -The concatenation assignment operator. -.Ip eq 8 -String equality (== is numeric equality). -For a mnemonic just think of \*(L"eq\*(R" as a string. -(If you are used to the -.I awk -behavior of using == for either string or numeric equality -based on the current form of the comparands, beware! -You must be explicit here.) -.Ip ne 8 -String inequality (!= is numeric inequality). -.Ip lt 8 -String less than. -.Ip gt 8 -String greater than. -.Ip le 8 -String less than or equal. -.Ip ge 8 -String greater than or equal. -.Ip cmp 8 -String comparison, returning -1, 0, or 1. -.Ip <=> 8 -Numeric comparison, returning -1, 0, or 1. -.Ip =~ 8 2 -Certain operations search or modify the string \*(L"$_\*(R" by default. -This operator makes that kind of operation work on some other string. -The right argument is a search pattern, substitution, or translation. -The left argument is what is supposed to be searched, substituted, or -translated instead of the default \*(L"$_\*(R". -The return value indicates the success of the operation. -(If the right argument is an expression other than a search pattern, -substitution, or translation, it is interpreted as a search pattern -at run time. -This is less efficient than an explicit search, since the pattern must -be compiled every time the expression is evaluated.) -The precedence of this operator is lower than unary minus and autoincrement/decrement, but higher than everything else. -.Ip !~ 8 -Just like =~ except the return value is negated. -.Ip x 8 -The repetition operator. -Returns a string consisting of the left operand repeated the -number of times specified by the right operand. -In an array context, if the left operand is a list in parens, it repeats -the list. -.nf - - print \'\-\' x 80; # print row of dashes - print \'\-\' x80; # illegal, x80 is identifier - - print "\et" x ($tab/8), \' \' x ($tab%8); # tab over - - @ones = (1) x 80; # an array of 80 1's - @ones = (5) x @ones; # set all elements to 5 - -.fi -.Ip x= 8 -The repetition assignment operator. -Only works on scalars. -.Ip .\|. 8 -The range operator, which is really two different operators depending -on the context. -In an array context, returns an array of values counting (by ones) -from the left value to the right value. -This is useful for writing \*(L"for (1..10)\*(R" loops and for doing -slice operations on arrays. -.Sp -In a scalar context, .\|. returns a boolean value. -The operator is bistable, like a flip-flop, and -emulates the line-range (comma) operator of sed, awk, and various editors. -Each .\|. operator maintains its own boolean state. -It is false as long as its left operand is false. -Once the left operand is true, the range operator stays true -until the right operand is true, -AFTER which the range operator becomes false again. -(It doesn't become false till the next time the range operator is evaluated. -It can test the right operand and become false on the -same evaluation it became true (as in awk), but it still returns true once. -If you don't want it to test the right operand till the next -evaluation (as in sed), use three dots (.\|.\|.) instead of two.) -The right operand is not evaluated while the operator is in the \*(L"false\*(R" state, -and the left operand is not evaluated while the operator is in the \*(L"true\*(R" state. -The precedence is a little lower than || and &&. -The value returned is either the null string for false, or a sequence number -(beginning with 1) for true. -The sequence number is reset for each range encountered. -The final sequence number in a range has the string \'E0\' appended to it, which -doesn't affect its numeric value, but gives you something to search for if you -want to exclude the endpoint. -You can exclude the beginning point by waiting for the sequence number to be -greater than 1. -If either operand of scalar .\|. is static, that operand is implicitly compared -to the $. variable, the current line number. -Examples: -.nf - -.ne 6 -As a scalar operator: - if (101 .\|. 200) { print; } # print 2nd hundred lines - - next line if (1 .\|. /^$/); # skip header lines - - s/^/> / if (/^$/ .\|. eof()); # quote body - -.ne 4 -As an array operator: - for (101 .\|. 200) { print; } # print $_ 100 times - - @foo = @foo[$[ .\|. $#foo]; # an expensive no-op - @foo = @foo[$#foo-4 .\|. $#foo]; # slice last 5 items - -.fi -.Ip \-x 8 -A file test. -This unary operator takes one argument, either a filename or a filehandle, -and tests the associated file to see if something is true about it. -If the argument is omitted, tests $_, except for \-t, which tests -.IR STDIN . -It returns 1 for true and \'\' for false, or the undefined value if the -file doesn't exist. -Precedence is higher than logical and relational operators, but lower than -arithmetic operators. -The operator may be any of: -.nf - \-r File is readable by effective uid/gid. - \-w File is writable by effective uid/gid. - \-x File is executable by effective uid/gid. - \-o File is owned by effective uid. - \-R File is readable by real uid/gid. - \-W File is writable by real uid/gid. - \-X File is executable by real uid/gid. - \-O File is owned by real uid. - \-e File exists. - \-z File has zero size. - \-s File has non-zero size (returns size). - \-f File is a plain file. - \-d File is a directory. - \-l File is a symbolic link. - \-p File is a named pipe (FIFO). - \-S File is a socket. - \-b File is a block special file. - \-c File is a character special file. - \-u File has setuid bit set. - \-g File has setgid bit set. - \-k File has sticky bit set. - \-t Filehandle is opened to a tty. - \-T File is a text file. - \-B File is a binary file (opposite of \-T). - \-M Age of file in days when script started. - \-A Same for access time. - \-C Same for inode change time. - -.fi -The interpretation of the file permission operators \-r, \-R, \-w, \-W, \-x and \-X -is based solely on the mode of the file and the uids and gids of the user. -There may be other reasons you can't actually read, write or execute the file. -Also note that, for the superuser, \-r, \-R, \-w and \-W always return 1, and -\-x and \-X return 1 if any execute bit is set in the mode. -Scripts run by the superuser may thus need to do a stat() in order to determine -the actual mode of the file, or temporarily set the uid to something else. -.Sp -Example: -.nf -.ne 7 - - while (<>) { - chop; - next unless \-f $_; # ignore specials - .\|.\|. - } - -.fi -Note that \-s/a/b/ does not do a negated substitution. -Saying \-exp($foo) still works as expected, however\*(--only single letters -following a minus are interpreted as file tests. -.Sp -The \-T and \-B switches work as follows. -The first block or so of the file is examined for odd characters such as -strange control codes or metacharacters. -If too many odd characters (>10%) are found, it's a \-B file, otherwise it's a \-T file. -Also, any file containing null in the first block is considered a binary file. -If \-T or \-B is used on a filehandle, the current stdio buffer is examined -rather than the first block. -Both \-T and \-B return TRUE on a null file, or a file at EOF when testing -a filehandle. -.PP -If any of the file tests (or either stat operator) are given the special -filehandle consisting of a solitary underline, then the stat structure -of the previous file test (or stat operator) is used, saving a system -call. -(This doesn't work with \-t, and you need to remember that lstat and -l -will leave values in the stat structure for the symbolic link, not the -real file.) -Example: -.nf - - print "Can do.\en" if -r $a || -w _ || -x _; - -.ne 9 - stat($filename); - print "Readable\en" if -r _; - print "Writable\en" if -w _; - print "Executable\en" if -x _; - print "Setuid\en" if -u _; - print "Setgid\en" if -g _; - print "Sticky\en" if -k _; - print "Text\en" if -T _; - print "Binary\en" if -B _; - -.fi -.PP -Here is what C has that -.I perl -doesn't: -.Ip "unary &" 12 -Address-of operator. -.Ip "unary *" 12 -Dereference-address operator. -.Ip "(TYPE)" 12 -Type casting operator. -.PP -Like C, -.I perl -does a certain amount of expression evaluation at compile time, whenever -it determines that all of the arguments to an operator are static and have -no side effects. -In particular, string concatenation happens at compile time between literals that don't do variable substitution. -Backslash interpretation also happens at compile time. -You can say -.nf - -.ne 2 - \'Now is the time for all\' . "\|\e\|n" . - \'good men to come to.\' - -.fi -and this all reduces to one string internally. -.PP -The autoincrement operator has a little extra built-in magic to it. -If you increment a variable that is numeric, or that has ever been used in -a numeric context, you get a normal increment. -If, however, the variable has only been used in string contexts since it -was set, and has a value that is not null and matches the -pattern /^[a\-zA\-Z]*[0\-9]*$/, the increment is done -as a string, preserving each character within its range, with carry: -.nf - - print ++($foo = \'99\'); # prints \*(L'100\*(R' - print ++($foo = \'a0\'); # prints \*(L'a1\*(R' - print ++($foo = \'Az\'); # prints \*(L'Ba\*(R' - print ++($foo = \'zz\'); # prints \*(L'aaa\*(R' - -.fi -The autodecrement is not magical. -.PP -The range operator (in an array context) makes use of the magical -autoincrement algorithm if the minimum and maximum are strings. -You can say - - @alphabet = (\'A\' .. \'Z\'); - -to get all the letters of the alphabet, or - - $hexdigit = (0 .. 9, \'a\' .. \'f\')[$num & 15]; - -to get a hexadecimal digit, or - - @z2 = (\'01\' .. \'31\'); print @z2[$mday]; - -to get dates with leading zeros. -(If the final value specified is not in the sequence that the magical increment -would produce, the sequence goes until the next value would be longer than -the final value specified.) -.PP -The || and && operators differ from C's in that, rather than returning 0 or 1, -they return the last value evaluated. -Thus, a portable way to find out the home directory might be: -.nf - - $home = $ENV{'HOME'} || $ENV{'LOGDIR'} || - (getpwuid($<))[7] || die "You're homeless!\en"; - -.fi -As more readable alternatives to && and ||, Perl provides "and" and "or" -operators. The short-circuit behavior is identical. The precedence of -"and" and "or" is much lower, however, so that you can safely use them -after a list operator without the need for parentheses: -.nf - - unlink "alpha", "beta", "gamma" - or gripe(), next LINE; - -.fi -With the old-style operators that would have been written like this: -.nf - - unlink("alpha", "beta", "gamma") - || (gripe(), next LINE); - -.fi -.PP -Along with the literals and variables mentioned earlier, -the operations in the following section can serve as terms in an expression. -Some of these operations take a LIST as an argument. -Such a list can consist of any combination of scalar arguments or array values; -the array values will be included in the list as if each individual element were -interpolated at that point in the list, forming a longer single-dimensional -array value. -Elements of the LIST should be separated by commas. -If an operation is listed both with and without parentheses around its -arguments, it means you can either use it as a unary operator or -as a function call. -To use it as a function call, the next token on the same line must -be a left parenthesis. -(There may be intervening white space.) -Such a function then has highest precedence, as you would expect from -a function. -If any token other than a left parenthesis follows, then it is a -unary operator, with a precedence depending only on whether it is a LIST -operator or not. -LIST operators have lowest precedence. -All other unary operators have a precedence greater than relational operators -but less than arithmetic operators. -See the section on Precedence. -.PP -For operators that can be used in either a scalar or array context, -failure is generally indicated in a scalar context by returning -the undefined value, and in an array context by returning the null list. -Remember though that -THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR. -Each operator decides which sort of scalar it would be most -appropriate to return. -Some operators return the length of the list -that would have been returned in an array context. -Some operators return the first value in the list. -Some operators return the last value in the list. -Some operators return a count of successful operations. -In general, they do what you want, unless you want consistency. -.Ip "/PATTERN/" 8 4 -See m/PATTERN/. -.Ip "?PATTERN?" 8 4 -This is just like the /pattern/ search, except that it matches only once between -calls to the -.I reset -operator. -This is a useful optimization when you only want to see the first occurrence of -something in each file of a set of files, for instance. -Only ?? patterns local to the current package are reset. -.Ip "abs(VALUE)" 8 4 -Returns the absolute value of its argument. -.Ip "accept(NEWSOCKET,GENERICSOCKET)" 8 2 -Does the same thing that the accept system call does. -Returns the packed address if it succeeded, false otherwise. -See example in section on Interprocess Communication. -.Ip "alarm(SECONDS)" 8 4 -.Ip "alarm SECONDS" 8 -Arranges to have a SIGALRM delivered to this process after the specified number -of seconds (minus 1, actually) have elapsed. Thus, alarm(15) will cause -a SIGALRM at some point more than 14 seconds in the future. -Only one timer may be counting at once. Each call disables the previous -timer, and an argument of 0 may be supplied to cancel the previous timer -without starting a new one. -The returned value is the amount of time remaining on the previous timer. -.Ip "atan2(Y,X)" 8 2 -Returns the arctangent of Y/X in the range -.if t \-\(*p to \(*p. -.if n \-PI to PI. -.Ip "bind(SOCKET,NAME)" 8 2 -Does the same thing that the bind system call does. -Returns true if it succeeded, false otherwise. -NAME should be a packed address of the proper type for the socket. -See example in section on Interprocess Communication. -.Ip "binmode(FILEHANDLE)" 8 4 -.Ip "binmode FILEHANDLE" 8 4 -Arranges for the file to be read in \*(L"binary\*(R" mode in operating systems -that distinguish between binary and text files. -Files that are not read in binary mode have CR LF sequences translated -to LF on input and LF translated to CR LF on output. -Binmode has no effect under Unix. -If FILEHANDLE is an expression, the value is taken as the name of -the filehandle. -.Ip "caller(EXPR)" -.Ip "caller" -Returns the context of the current subroutine call: -.nf - - ($package,$filename,$line) = caller; - -.fi -With EXPR, returns some extra information that the debugger uses to print -a stack trace. The value of EXPR indicates how many call frames to go -back before the current one. -.Ip "chdir(EXPR)" 8 2 -.Ip "chdir EXPR" 8 2 -Changes the working directory to EXPR, if possible. -If EXPR is omitted, changes to home directory. -Returns 1 upon success, 0 otherwise. -See example under -.IR die . -.Ip "chmod(LIST)" 8 2 -.Ip "chmod LIST" 8 2 -Changes the permissions of a list of files. -The first element of the list must be the numerical mode. -Returns the number of files successfully changed. -.nf - -.ne 2 - $cnt = chmod 0755, \'foo\', \'bar\'; - chmod 0755, @executables; - -.fi -.Ip "chop(LIST)" 8 7 -.Ip "chop(VARIABLE)" 8 -.Ip "chop VARIABLE" 8 -.Ip "chop" 8 -Chops off the last character of a string and returns the character chopped. -It's used primarily to remove the newline from the end of an input record, -but is much more efficient than s/\en// because it neither scans nor copies -the string. -If VARIABLE is omitted, chops $_. -Example: -.nf - -.ne 5 - while (<>) { - chop; # avoid \en on last field - @array = split(/:/); - .\|.\|. - } - -.fi -You can actually chop anything that's an lvalue, including an assignment: -.nf - - chop($cwd = \`pwd\`); - chop($answer = <STDIN>); - -.fi -If you chop a list, each element is chopped. -Only the value of the last chop is returned. -.Ip "chown(LIST)" 8 2 -.Ip "chown LIST" 8 2 -Changes the owner (and group) of a list of files. -The first two elements of the list must be the NUMERICAL uid and gid, -in that order. -Returns the number of files successfully changed. -.nf - -.ne 2 - $cnt = chown $uid, $gid, \'foo\', \'bar\'; - chown $uid, $gid, @filenames; - -.fi -.ne 23 -Here's an example that looks up non-numeric uids in the passwd file: -.nf - - print "User: "; - $user = <STDIN>; - chop($user); - print "Files: " - $pattern = <STDIN>; - chop($pattern); -.ie t \{\ - open(pass, \'/etc/passwd\') || die "Can't open passwd: $!\en"; -'br\} -.el \{\ - open(pass, \'/etc/passwd\') - || die "Can't open passwd: $!\en"; -'br\} - while (<pass>) { - ($login,$pass,$uid,$gid) = split(/:/); - $uid{$login} = $uid; - $gid{$login} = $gid; - } - @ary = <${pattern}>; # get filenames - if ($uid{$user} eq \'\') { - die "$user not in passwd file"; - } - else { - chown $uid{$user}, $gid{$user}, @ary; - } - -.fi -.Ip "chr(NUMBER)" 8 5 -Returns the character represented by that NUMBER in the character set. -For example, chr(65) is "A". -.Ip "chroot(FILENAME)" 8 5 -.Ip "chroot FILENAME" 8 -Does the same as the system call of that name. -If you don't know what it does, don't worry about it. -If FILENAME is omitted, does chroot to $_. -.Ip "close(FILEHANDLE)" 8 5 -.Ip "close FILEHANDLE" 8 -Closes the file or pipe associated with the file handle, returning true only -if stdio successfully flushes buffers and closes the system file descriptor. -You don't have to close FILEHANDLE if you are immediately going to -do another open on it, since open will close it for you. -(See -.IR open .) -However, an explicit close on an input file resets the line counter ($.), while -the implicit close done by -.I open -does not. -Also, closing a pipe will wait for the process executing on the pipe to complete, -in case you want to look at the output of the pipe afterwards. -Closing a pipe explicitly also puts the status value of the command into $?. -Example: -.nf - -.ne 4 - open(OUTPUT, \'|sort >foo\'); # pipe to sort - .\|.\|. # print stuff to output - close OUTPUT; # wait for sort to finish - open(INPUT, \'foo\'); # get sort's results - -.fi -FILEHANDLE may be an expression whose value gives the real filehandle name. -.Ip "closedir(DIRHANDLE)" 8 5 -.Ip "closedir DIRHANDLE" 8 -Closes a directory opened by opendir(). -.Ip "connect(SOCKET,NAME)" 8 2 -Does the same thing that the connect system call does. -Returns true if it succeeded, false otherwise. -NAME should be a package address of the proper type for the socket. -See example in section on Interprocess Communication. -.Ip "cos(EXPR)" 8 6 -.Ip "cos EXPR" 8 6 -Returns the cosine of EXPR (expressed in radians). -If EXPR is omitted takes cosine of $_. -.Ip "crypt(PLAINTEXT,SALT)" 8 6 -Encrypts a string exactly like the crypt() function in the C library. -Useful for checking the password file for lousy passwords. -Only the guys wearing white hats should do this. -.Ip "dbmclose(ASSOC_ARRAY)" 8 6 -.Ip "dbmclose ASSOC_ARRAY" 8 -[This function has be superseded by the untie() function.] -.Sp -Breaks the binding between a dbm file and an associative array. -The values remaining in the associative array are meaningless unless -you happen to want to know what was in the cache for the dbm file. -This function is only useful if you have ndbm. -.Ip "dbmopen(ASSOC,DBNAME,MODE)" 8 6 -[This function has be superseded by the tie() function.] -.Sp -This binds a dbm or ndbm file to an associative array. -ASSOC is the name of the associative array. -(Unlike normal open, the first argument is NOT a filehandle, even though -it looks like one). -DBNAME is the name of the database (without the .dir or .pag extension). -If the database does not exist, it is created with protection specified -by MODE (as modified by the umask). -If your system only supports the older dbm functions, you may perform only one -dbmopen in your program. -If your system has neither dbm nor ndbm, calling dbmopen produces a fatal -error. -.Sp -Values assigned to the associative array prior to the dbmopen are lost. -A certain number of values from the dbm file are cached in memory. -By default this number is 64, but you can increase it by preallocating -that number of garbage entries in the associative array before the dbmopen. -You can flush the cache if necessary with the reset command. -.Sp -If you don't have write access to the dbm file, you can only read -associative array variables, not set them. -If you want to test whether you can write, either use file tests or -try setting a dummy array entry inside an eval, which will trap the error. -.Sp -Note that functions such as keys() and values() may return huge array values -when used on large dbm files. -You may prefer to use the each() function to iterate over large dbm files. -Example: -.nf - -.ne 6 - # print out history file offsets - dbmopen(%HIST,'/usr/lib/news/history',0666); - while (($key,$val) = each %HIST) { - print $key, ' = ', unpack('L',$val), "\en"; - } - dbmclose(%HIST); - -.fi -.Ip "defined(EXPR)" 8 6 -.Ip "defined EXPR" 8 -Returns a boolean value saying whether the lvalue EXPR has a real value -or not. -Many operations return the undefined value under exceptional conditions, -such as end of file, uninitialized variable, system error and such. -This function allows you to distinguish between an undefined null string -and a defined null string with operations that might return a real null -string, in particular referencing elements of an array. -You may also check to see if arrays or subroutines exist. -Use on predefined variables is not guaranteed to produce intuitive results. -Examples: -.nf - -.ne 7 - print if defined $switch{'D'}; - print "$val\en" while defined($val = pop(@ary)); - die "Can't readlink $sym: $!" - unless defined($value = readlink $sym); - eval '@foo = ()' if defined(@foo); - die "No XYZ package defined" unless defined %_XYZ; - sub foo { defined &$bar ? &$bar(@_) : die "No bar"; } - -.fi -See also undef. -.Ip "delete $ASSOC{KEY}" 8 6 -Deletes the specified value from the specified associative array. -Returns the deleted value, or the undefined value if nothing was deleted. -Deleting from $ENV{} modifies the environment. -Deleting from an array bound to a dbm file deletes the entry from the dbm -file. -.Sp -The following deletes all the values of an associative array: -.nf - -.ne 3 - foreach $key (keys %ARRAY) { - delete $ARRAY{$key}; - } - -.fi -(But it would be faster to use the -.I reset -command. -Saying undef %ARRAY is faster yet.) -.Ip "die(LIST)" 8 -.Ip "die LIST" 8 -Outside of an eval, prints the value of LIST to -.I STDERR -and exits with the current value of $! -(errno). -If $! is 0, exits with the value of ($? >> 8) (\`command\` status). -If ($? >> 8) is 0, exits with 255. -Inside an eval, the error message is stuffed into $@ and the eval is terminated -with the undefined value. -.Sp -Equivalent examples: -.nf - -.ne 3 -.ie t \{\ - die "Can't cd to spool: $!\en" unless chdir \'/usr/spool/news\'; -'br\} -.el \{\ - die "Can't cd to spool: $!\en" - unless chdir \'/usr/spool/news\'; -'br\} - - chdir \'/usr/spool/news\' || die "Can't cd to spool: $!\en" - -.fi -.Sp -If the value of EXPR does not end in a newline, the current script line -number and input line number (if any) are also printed, and a newline is -supplied. -Hint: sometimes appending \*(L", stopped\*(R" to your message will cause it to make -better sense when the string \*(L"at foo line 123\*(R" is appended. -Suppose you are running script \*(L"canasta\*(R". -.nf - -.ne 7 - die "/etc/games is no good"; - die "/etc/games is no good, stopped"; - -produce, respectively - - /etc/games is no good at canasta line 123. - /etc/games is no good, stopped at canasta line 123. - -.fi -See also -.IR exit . -.Ip "do BLOCK" 8 4 -Returns the value of the last command in the sequence of commands indicated -by BLOCK. -When modified by a loop modifier, executes the BLOCK once before testing the -loop condition. -(On other statements the loop modifiers test the conditional first.) -.Ip "do SUBROUTINE (LIST)" 8 3 -Executes a SUBROUTINE declared by a -.I sub -declaration, and returns the value -of the last expression evaluated in SUBROUTINE. -If there is no subroutine by that name, produces a fatal error. -(You may use the \*(L"defined\*(R" operator to determine if a subroutine -exists.) -If you pass arrays as part of LIST you may wish to pass the length -of the array in front of each array. -(See the section on subroutines later on.) -The parentheses are required to avoid confusion with the \*(L"do EXPR\*(R" -form. -.Sp -SUBROUTINE may also be a single scalar variable, in which case -the name of the subroutine to execute is taken from the variable. -.Sp -As an alternate (and preferred) form, -you may call a subroutine by prefixing the name with -an ampersand: &foo(@args). -If you aren't passing any arguments, you don't have to use parentheses. -If you omit the parentheses, no @_ array is passed to the subroutine. -The & form is also used to specify subroutines to the defined and undef -operators: -.nf - - if (defined &$var) { &$var($parm); undef &$var; } - -.fi -.Ip "do EXPR" 8 3 -Uses the value of EXPR as a filename and executes the contents of the file -as a -.I perl -script. -Its primary use is to include subroutines from a -.I perl -subroutine library. -.nf - - do \'stat.pl\'; - -is just like - - eval \`cat stat.pl\`; - -.fi -except that it's more efficient, more concise, keeps track of the current -filename for error messages, and searches all the -.B \-I -libraries if the file -isn't in the current directory (see also the @INC array in Predefined Names). -It's the same, however, in that it does reparse the file every time you -call it, so if you are going to use the file inside a loop you might prefer -to use \-P and #include, at the expense of a little more startup time. -(The main problem with #include is that cpp doesn't grok # comments\*(--a -workaround is to use \*(L";#\*(R" for standalone comments.) -Note that the following are NOT equivalent: -.nf - -.ne 2 - do $foo; # eval a file - do $foo(); # call a subroutine - -.fi -Note that inclusion of library routines is better done with -the \*(L"require\*(R" operator. -.Ip "dump LABEL" 8 6 -This causes an immediate core dump. -Primarily this is so that you can use the undump program to turn your -core dump into an executable binary after having initialized all your -variables at the beginning of the program. -When the new binary is executed it will begin by executing a "goto LABEL" -(with all the restrictions that goto suffers). -Think of it as a goto with an intervening core dump and reincarnation. -If LABEL is omitted, restarts the program from the top. -WARNING: any files opened at the time of the dump will NOT be open any more -when the program is reincarnated, with possible resulting confusion on the part -of perl. -See also \-u. -.Sp -Example: -.nf - -.ne 16 - #!/usr/bin/perl - require 'getopt.pl'; - require 'stat.pl'; - %days = ( - 'Sun',1, - 'Mon',2, - 'Tue',3, - 'Wed',4, - 'Thu',5, - 'Fri',6, - 'Sat',7); - - dump QUICKSTART if $ARGV[0] eq '-d'; - - QUICKSTART: - do Getopt('f'); - -.fi -.Ip "each(ASSOC_ARRAY)" 8 6 -.Ip "each ASSOC_ARRAY" 8 -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 must not modify the array while iterating over it. -There is a single iterator for each associative array, shared by all -each(), keys() and values() function calls in the program. -The following prints out your environment like the printenv program, only -in a different order: -.nf - -.ne 3 - while (($key,$value) = each %ENV) { - print "$key=$value\en"; - } - -.fi -See also keys() and values(). -.Ip "eof(FILEHANDLE)" 8 8 -.Ip "eof()" 8 -.Ip "eof" 8 -Returns 1 if the next read on FILEHANDLE will return end of file, or if -FILEHANDLE is not open. -FILEHANDLE may be an expression whose value gives the real filehandle name. -(Note that this function actually reads a character and then ungetc's it, -so it is not very useful in an interactive context.) -An eof without an argument returns the eof status for the last file read. -Empty parentheses () may be used to indicate the pseudo file formed of the -files listed on the command line, i.e. eof() is reasonable to use inside -a while (<>) loop to detect the end of only the last file. -Use eof(ARGV) or eof without the parentheses to test EACH file in a while (<>) loop. -Examples: -.nf - -.ne 7 - # insert dashes just before last line of last file - while (<>) { - if (eof()) { - print "\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\en"; - } - print; - } - -.ne 7 - # reset line numbering on each input file - while (<>) { - print "$.\et$_"; - if (eof) { # Not eof(). - close(ARGV); - } - } - -.fi -.Ip "eval(EXPR)" 8 6 -.Ip "eval EXPR" 8 6 -.Ip "eval BLOCK" 8 6 -EXPR is parsed and executed as if it were a little -.I perl -program. -It is executed in the context of the current -.I perl -program, so that -any variable settings, subroutine or format definitions remain afterwards. -The value returned is the value of the last expression evaluated, just -as with subroutines. -If there is a syntax error or runtime error, or a die statement is -executed, an undefined value is returned by -eval, and $@ is set to the error message. -If there was no error, $@ is guaranteed to be a null string. -If EXPR is omitted, evaluates $_. -The final semicolon, if any, may be omitted from the expression. -.Sp -Note that, since eval traps otherwise-fatal errors, it is useful for -determining whether a particular feature -(such as dbmopen or symlink) is implemented. -It is also Perl's exception trapping mechanism, where the die operator is -used to raise exceptions. -.Sp -If the code to be executed doesn't vary, you may use -the eval-BLOCK form to trap run-time errors without incurring -the penalty of recompiling each time. -The error, if any, is still returned in $@. -Evaluating a single-quoted string (as EXPR) has the same effect, except that -the eval-EXPR form reports syntax errors at run time via $@, whereas the -eval-BLOCK form reports syntax errors at compile time. The eval-EXPR form -is optimized to eval-BLOCK the first time it succeeds. (Since the replacement -side of a substitution is considered a single-quoted string when you -use the e modifier, the same optimization occurs there.) Examples: -.nf - -.ne 11 - # make divide-by-zero non-fatal - eval { $answer = $a / $b; }; warn $@ if $@; - - # optimized to same thing after first use - eval '$answer = $a / $b'; warn $@ if $@; - - # a compile-time error - eval { $answer = }; - - # a run-time error - eval '$answer ='; # sets $@ - -.fi -.Ip "exec(LIST)" 8 8 -.Ip "exec LIST" 8 6 -If there is more than one argument in LIST, or if LIST is an array with -more than one value, -calls execvp() with the arguments in LIST. -If there is only one scalar argument, the argument is checked for shell metacharacters. -If there are any, the entire argument is passed to \*(L"/bin/sh \-c\*(R" for parsing. -If there are none, the argument is split into words and passed directly to -execvp(), which is more efficient. -Note: exec (and system) do not flush your output buffer, so you may need to -set $| to avoid lost output. -Examples: -.nf - - exec \'/bin/echo\', \'Your arguments are: \', @ARGV; - exec "sort $outfile | uniq"; - -.fi -.Sp -If you don't really want to execute the first argument, but want to lie -to the program you are executing about its own name, you can specify -the program you actually want to run by assigning that to a variable and -putting the name of the variable in front of the LIST without a comma. -(This always forces interpretation of the LIST as a multi-valued list, even -if there is only a single scalar in the list.) -Example: -.nf - -.ne 2 - $shell = '/bin/csh'; - exec $shell '-sh'; # pretend it's a login shell - -.fi -.Ip "exit(EXPR)" 8 6 -.Ip "exit EXPR" 8 -Evaluates EXPR and exits immediately with that value. -Example: -.nf - -.ne 2 - $ans = <STDIN>; - exit 0 \|if \|$ans \|=~ \|/\|^[Xx]\|/\|; - -.fi -See also -.IR die . -If EXPR is omitted, exits with 0 status. -.Ip "exp(EXPR)" 8 3 -.Ip "exp EXPR" 8 -Returns -.I e -to the power of EXPR. -If EXPR is omitted, gives exp($_). -.Ip "fcntl(FILEHANDLE,FUNCTION,SCALAR)" 8 4 -Implements the fcntl(2) function. -You'll probably have to say -.nf - - require "fcntl.ph"; # probably /usr/local/lib/perl/fcntl.ph - -.fi -first to get the correct function definitions. -If fcntl.ph doesn't exist or doesn't have the correct definitions -you'll have to roll -your own, based on your C header files such as <sys/fcntl.h>. -(There is a perl script called h2ph that comes with the perl kit -which may help you in this.) -Argument processing and value return works just like ioctl below. -Note that fcntl will produce a fatal error if used on a machine that doesn't implement -fcntl(2). -.Ip "fileno(FILEHANDLE)" 8 4 -.Ip "fileno FILEHANDLE" 8 4 -Returns the file descriptor for a filehandle. -Useful for constructing bitmaps for select(). -If FILEHANDLE is an expression, the value is taken as the name of -the filehandle. -.Ip "flock(FILEHANDLE,OPERATION)" 8 4 -Calls flock(2) on FILEHANDLE. -See manual page for flock(2) for definition of OPERATION. -Returns true for success, false on failure. -Will produce a fatal error if used on a machine that doesn't implement -flock(2). -Here's a mailbox appender for BSD systems. -.nf - -.ne 20 - $LOCK_SH = 1; - $LOCK_EX = 2; - $LOCK_NB = 4; - $LOCK_UN = 8; - - sub lock { - flock(MBOX,$LOCK_EX); - # and, in case someone appended - # while we were waiting... - seek(MBOX, 0, 2); - } - - sub unlock { - flock(MBOX,$LOCK_UN); - } - - open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}") - || die "Can't open mailbox: $!"; - - do lock(); - print MBOX $msg,"\en\en"; - do unlock(); - -.fi -.Ip "fork" 8 4 -Does a fork() system call. -Returns the child pid to the parent process and 0 to the child process, -or undef if the fork is unsuccessful. -Note: unflushed buffers remain unflushed in both processes, which means -you may need to set $| to avoid duplicate output. -.Ip "getc(FILEHANDLE)" 8 4 -.Ip "getc FILEHANDLE" 8 -.Ip "getc" 8 -Returns the next character from the input file attached to FILEHANDLE, or -a null string at EOF. -If FILEHANDLE is omitted, reads from STDIN. -.Ip "getlogin" 8 3 -Returns the current login from /etc/utmp, if any. -If null, use getpwuid. - - $login = getlogin || (getpwuid($<))[0] || "Somebody"; - -.Ip "getpeername(SOCKET)" 8 3 -Returns the packed sockaddr address of other end of the SOCKET connection. -.nf - -.ne 4 - # An internet sockaddr - $sockaddr = 'S n a4 x8'; - $hersockaddr = getpeername(S); -.ie t \{\ - ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr); -'br\} -.el \{\ - ($family, $port, $heraddr) = - unpack($sockaddr,$hersockaddr); -'br\} - -.fi -.Ip "getpgrp(PID)" 8 4 -.Ip "getpgrp PID" 8 -Returns the current process group for the specified PID, 0 for the current -process. -Will produce a fatal error if used on a machine that doesn't implement -getpgrp(2). -If EXPR is omitted, returns process group of current process. -.Ip "getppid" 8 4 -Returns the process id of the parent process. -.Ip "getpriority(WHICH,WHO)" 8 4 -Returns the current priority for a process, a process group, or a user. -(See getpriority(2).) -Will produce a fatal error if used on a machine that doesn't implement -getpriority(2). -.Ip "getpwnam(NAME)" 8 -.Ip "getgrnam(NAME)" 8 -.Ip "gethostbyname(NAME)" 8 -.Ip "getnetbyname(NAME)" 8 -.Ip "getprotobyname(NAME)" 8 -.Ip "getpwuid(UID)" 8 -.Ip "getgrgid(GID)" 8 -.Ip "getservbyname(NAME,PROTO)" 8 -.Ip "gethostbyaddr(ADDR,ADDRTYPE)" 8 -.Ip "getnetbyaddr(ADDR,ADDRTYPE)" 8 -.Ip "getprotobynumber(NUMBER)" 8 -.Ip "getservbyport(PORT,PROTO)" 8 -.Ip "getpwent" 8 -.Ip "getgrent" 8 -.Ip "gethostent" 8 -.Ip "getnetent" 8 -.Ip "getprotoent" 8 -.Ip "getservent" 8 -.Ip "setpwent" 8 -.Ip "setgrent" 8 -.Ip "sethostent(STAYOPEN)" 8 -.Ip "setnetent(STAYOPEN)" 8 -.Ip "setprotoent(STAYOPEN)" 8 -.Ip "setservent(STAYOPEN)" 8 -.Ip "endpwent" 8 -.Ip "endgrent" 8 -.Ip "endhostent" 8 -.Ip "endnetent" 8 -.Ip "endprotoent" 8 -.Ip "endservent" 8 -These routines perform the same functions as their counterparts in the -system library. -Within an array context, -the return values from the various get routines are as follows: -.nf - - ($name,$passwd,$uid,$gid, - $quota,$comment,$gcos,$dir,$shell) = getpw.\|.\|. - ($name,$passwd,$gid,$members) = getgr.\|.\|. - ($name,$aliases,$addrtype,$length,@addrs) = gethost.\|.\|. - ($name,$aliases,$addrtype,$net) = getnet.\|.\|. - ($name,$aliases,$proto) = getproto.\|.\|. - ($name,$aliases,$port,$proto) = getserv.\|.\|. - -.fi -(If the entry doesn't exist you get a null list.) -.Sp -Within a scalar context, you get the name, unless the function was a -lookup by name, in which case you get the other thing, whatever it is. -(If the entry doesn't exist you get the undefined value.) -For example: -.nf - - $uid = getpwnam - $name = getpwuid - $name = getpwent - $gid = getgrnam - $name = getgrgid - $name = getgrent - etc. - -.fi -The $members value returned by getgr.\|.\|. is a space separated list -of the login names of the members of the group. -.Sp -For the gethost.\|.\|. functions, if the h_errno variable is supported in C, -it will be returned to you via $? if the function call fails. -The @addrs value returned by a successful call is a list of the -raw addresses returned by the corresponding system library call. -In the Internet domain, each address is four bytes long and you can unpack -it by saying something like: -.nf - - ($a,$b,$c,$d) = unpack('C4',$addr[0]); - -.fi -.Ip "getsockname(SOCKET)" 8 3 -Returns the packed sockaddr address of this end of the SOCKET connection. -.nf - -.ne 4 - # An internet sockaddr - $sockaddr = 'S n a4 x8'; - $mysockaddr = getsockname(S); -.ie t \{\ - ($family, $port, $myaddr) = unpack($sockaddr,$mysockaddr); -'br\} -.el \{\ - ($family, $port, $myaddr) = - unpack($sockaddr,$mysockaddr); -'br\} - -.fi -.Ip "getsockopt(SOCKET,LEVEL,OPTNAME)" 8 3 -Returns the socket option requested, or undefined if there is an error. -.Ip "gmtime(EXPR)" 8 4 -.Ip "gmtime EXPR" 8 -Converts a time as returned by the time function to a 9-element array with -the time analyzed for the Greenwich timezone. -Typically used as follows: -.nf - -.ne 3 -.ie t \{\ - ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); -'br\} -.el \{\ - ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = - gmtime(time); -'br\} - -.fi -All array elements are numeric, and come straight out of a struct tm. -In particular this means that $mon has the range 0.\|.11 and $wday has the -range 0.\|.6. -If EXPR is omitted, does gmtime(time). -.Ip "goto LABEL" 8 6 -Finds the statement labeled with LABEL and resumes execution there. -Currently you may only go to statements in the main body of the program -that are not nested inside a do {} construct. -This statement is not implemented very efficiently, and is here only to make -the -.IR sed -to- perl -translator easier. -I may change its semantics at any time, consistent with support for translated -.I sed -scripts. -Use it at your own risk. -Better yet, don't use it at all. -.Ip "grep(EXPR,LIST)" 8 4 -Evaluates EXPR for each element of LIST (locally setting $_ to each element) -and returns the array value consisting of those elements for which the -expression evaluated to true. -In a scalar context, returns the number of times the expression was true. -.nf - - @foo = grep(!/^#/, @bar); # weed out comments - -.fi -Note that, since $_ is a reference into the array value, it can be -used to modify the elements of the array. -While this is useful and supported, it can cause bizarre results if -the LIST is not a named array. -.Ip "hex(EXPR)" 8 4 -.Ip "hex EXPR" 8 -Returns the decimal value of EXPR interpreted as an hex string. -(To interpret strings that might start with 0 or 0x see oct().) -If EXPR is omitted, uses $_. -.Ip "index(STR,SUBSTR,POSITION)" 8 4 -.Ip "index(STR,SUBSTR)" 8 4 -Returns the position of the first occurrence of SUBSTR in STR at or after -POSITION. -If POSITION is omitted, starts searching from the beginning of the string. -The return value is based at 0, or whatever you've -set the $[ variable to. -If the substring is not found, returns one less than the base, ordinarily \-1. -.Ip "int(EXPR)" 8 4 -.Ip "int EXPR" 8 -Returns the integer portion of EXPR. -If EXPR is omitted, uses $_. -.Ip "ioctl(FILEHANDLE,FUNCTION,SCALAR)" 8 4 -Implements the ioctl(2) function. -You'll probably have to say -.nf - - require "ioctl.ph"; # probably /usr/local/lib/perl/ioctl.ph - -.fi -first to get the correct function definitions. -If ioctl.ph doesn't exist or doesn't have the correct definitions -you'll have to roll -your own, based on your C header files such as <sys/ioctl.h>. -(There is a perl script called h2ph that comes with the perl kit -which may help you in this.) -SCALAR will be read and/or written depending on the FUNCTION\*(--a pointer -to the string value of SCALAR will be passed as the third argument of -the actual ioctl call. -(If SCALAR has no string value but does have a numeric value, that value -will be passed rather than a pointer to the string value. -To guarantee this to be true, add a 0 to the scalar before using it.) -The pack() and unpack() functions are useful for manipulating the values -of structures used by ioctl(). -The following example sets the erase character to DEL. -.nf - -.ne 9 - require 'ioctl.ph'; - $sgttyb_t = "ccccs"; # 4 chars and a short - if (ioctl(STDIN,$TIOCGETP,$sgttyb)) { - @ary = unpack($sgttyb_t,$sgttyb); - $ary[2] = 127; - $sgttyb = pack($sgttyb_t,@ary); - ioctl(STDIN,$TIOCSETP,$sgttyb) - || die "Can't ioctl: $!"; - } - -.fi -The return value of ioctl (and fcntl) is as follows: -.nf - -.ne 4 - if OS returns:\h'|3i'perl returns: - -1\h'|3i' undefined value - 0\h'|3i' string "0 but true" - anything else\h'|3i' that number - -.fi -Thus perl returns true on success and false on failure, yet you can still -easily determine the actual value returned by the operating system: -.nf - - ($retval = ioctl(...)) || ($retval = -1); - printf "System returned %d\en", $retval; -.fi -.Ip "join(EXPR,LIST)" 8 8 -.Ip "join(EXPR,ARRAY)" 8 -Joins the separate strings of LIST or ARRAY into a single string with fields -separated by the value of EXPR, and returns the string. -Example: -.nf - -.ie t \{\ - $_ = join(\|\':\', $login,$passwd,$uid,$gid,$gcos,$home,$shell); -'br\} -.el \{\ - $_ = join(\|\':\', - $login,$passwd,$uid,$gid,$gcos,$home,$shell); -'br\} - -.fi -See -.IR split . -.Ip "keys(ASSOC_ARRAY)" 8 6 -.Ip "keys ASSOC_ARRAY" 8 -Returns a normal array consisting of all the keys of the named associative -array. -(In a scalar context, returns the number of keys.) -The keys are returned in an apparently random order, but it is the same order -as either the values() or each() function produces (given that the associative array -has not been modified). -Here is yet another way to print your environment: -.nf - -.ne 5 - @keys = keys %ENV; - @values = values %ENV; - while ($#keys >= 0) { - print pop(@keys), \'=\', pop(@values), "\en"; - } - -or how about sorted by key: - -.ne 3 - foreach $key (sort(keys %ENV)) { - print $key, \'=\', $ENV{$key}, "\en"; - } - -.fi -.Ip "kill(LIST)" 8 8 -.Ip "kill LIST" 8 2 -Sends a signal to a list of processes. -The first element of the list must be the signal to send. -Returns the number of processes successfully signaled. -.nf - - $cnt = kill 1, $child1, $child2; - kill 9, @goners; - -.fi -If the signal is negative, kills process groups instead of processes. -(On System V, a negative \fIprocess\fR number will also kill process groups, -but that's not portable.) -You may use a signal name in quotes. -.Ip "last LABEL" 8 8 -.Ip "last" 8 -The -.I last -command is like the -.I break -statement in C (as used in loops); it immediately exits the loop in question. -If the LABEL is omitted, the command refers to the innermost enclosing loop. -The -.I continue -block, if any, is not executed: -.nf - -.ne 4 - line: while (<STDIN>) { - last line if /\|^$/; # exit when done with header - .\|.\|. - } - -.fi -.Ip "length(EXPR)" 8 4 -.Ip "length EXPR" 8 -Returns the length in characters of the value of EXPR. -If EXPR is omitted, returns length of $_. -.Ip "link(OLDFILE,NEWFILE)" 8 2 -Creates a new filename linked to the old filename. -Returns 1 for success, 0 otherwise. -.Ip "listen(SOCKET,QUEUESIZE)" 8 2 -Does the same thing that the listen system call does. -Returns true if it succeeded, false otherwise. -See example in section on Interprocess Communication. -.Ip "local(LIST)" 8 4 -Declares the listed variables to be local to the enclosing block, -subroutine, eval or \*(L"do\*(R". -All the listed elements must be legal lvalues. -This operator works by saving the current values of those variables in LIST -on a hidden stack and restoring them upon exiting the block, subroutine or eval. -This means that called subroutines can also reference the local variable, -but not the global one. -The LIST may be assigned to if desired, which allows you to initialize -your local variables. -(If no initializer is given for a particular variable, it is created with -an undefined value.) -Commonly this is used to name the parameters to a subroutine. -Examples: -.nf - -.ne 13 - sub RANGEVAL { - local($min, $max, $thunk) = @_; - local($result) = \'\'; - local($i); - - # Presumably $thunk makes reference to $i - - for ($i = $min; $i < $max; $i++) { - $result .= eval $thunk; - } - - $result; - } - -.ne 6 - if ($sw eq \'-v\') { - # init local array with global array - local(@ARGV) = @ARGV; - unshift(@ARGV,\'echo\'); - system @ARGV; - } - # @ARGV restored - -.ne 6 - # temporarily add to digits associative array - if ($base12) { - # (NOTE: not claiming this is efficient!) - local(%digits) = (%digits,'t',10,'e',11); - do parse_num(); - } - -.fi -Note that local() is a run-time command, and so gets executed every time -through a loop, using up more stack storage each time until it's all -released at once when the loop is exited. -.Ip "localtime(EXPR)" 8 4 -.Ip "localtime EXPR" 8 -Converts a time as returned by the time function to a 9-element array with -the time analyzed for the local timezone. -Typically used as follows: -.nf - -.ne 3 -.ie t \{\ - ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); -'br\} -.el \{\ - ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = - localtime(time); -'br\} - -.fi -All array elements are numeric, and come straight out of a struct tm. -In particular this means that $mon has the range 0.\|.11 and $wday has the -range 0.\|.6. -If EXPR is omitted, does localtime(time). -.Ip "log(EXPR)" 8 4 -.Ip "log EXPR" 8 -Returns logarithm (base -.IR e ) -of EXPR. -If EXPR is omitted, returns log of $_. -.Ip "lstat(FILEHANDLE)" 8 6 -.Ip "lstat FILEHANDLE" 8 -.Ip "lstat(EXPR)" 8 -.Ip "lstat SCALARVARIABLE" 8 -Does the same thing as the stat() function, but stats a symbolic link -instead of the file the symbolic link points to. -If symbolic links are unimplemented on your system, a normal stat is done. -.Ip "m/PATTERN/gio" 8 4 -.Ip "/PATTERN/gio" 8 -Searches a string for a pattern match, and returns true (1) or false (\'\'). -If no string is specified via the =~ or !~ operator, -the $_ string is searched. -(The string specified with =~ need not be an lvalue\*(--it may be the result of an expression evaluation, but remember the =~ binds rather tightly.) -See also the section on regular expressions. -.Sp -If / is the delimiter then the initial \*(L'm\*(R' is optional. -With the \*(L'm\*(R' you can use any pair of non-alphanumeric characters -as delimiters. -This is particularly useful for matching Unix path names that contain \*(L'/\*(R'. -If the final delimiter is followed by the optional letter \*(L'i\*(R', the matching is -done in a case-insensitive manner. -PATTERN may contain references to scalar variables, which will be interpolated -(and the pattern recompiled) every time the pattern search is evaluated. -(Note that $) and $| may not be interpolated because they look like end-of-string tests.) -If you want such a pattern to be compiled only once, add an \*(L"o\*(R" after -the trailing delimiter. -This avoids expensive run-time recompilations, and -is useful when the value you are interpolating won't change over the -life of the script. -If the PATTERN evaluates to a null string, the most recent successful -regular expression is used instead. -.Sp -If used in a context that requires an array value, a pattern match returns an -array consisting of the subexpressions matched by the parentheses in the -pattern, -i.e. ($1, $2, $3.\|.\|.). -It does NOT actually set $1, $2, etc. in this case, nor does it set $+, $`, $& -or $'. -If the match fails, a null array is returned. -If the match succeeds, but there were no parentheses, an array value of (1) -is returned. -.Sp -Examples: -.nf - -.ne 4 - open(tty, \'/dev/tty\'); - <tty> \|=~ \|/\|^y\|/i \|&& \|do foo(\|); # do foo if desired - - if (/Version: \|*\|([0\-9.]*\|)\|/\|) { $version = $1; } - - next if m#^/usr/spool/uucp#; - -.ne 5 - # poor man's grep - $arg = shift; - while (<>) { - print if /$arg/o; # compile only once - } - - if (($F1, $F2, $Etc) = ($foo =~ /^(\eS+)\es+(\eS+)\es*(.*)/)) - -.fi -This last example splits $foo into the first two words and the remainder -of the line, and assigns those three fields to $F1, $F2 and $Etc. -The conditional is true if any variables were assigned, i.e. if the pattern -matched. -.Sp -The \*(L"g\*(R" modifier specifies global pattern matching\*(--that is, -matching as many times as possible within the string. How it behaves -depends on the context. In an array context, it returns a list of -all the substrings matched by all the parentheses in the regular expression. -If there are no parentheses, it returns a list of all the matched strings, -as if there were parentheses around the whole pattern. In a scalar context, -it iterates through the string, returning TRUE each time it matches, and -FALSE when it eventually runs out of matches. (In other words, it remembers -where it left off last time and restarts the search at that point.) It -presumes that you have not modified the string since the last match. -Modifying the string between matches may result in undefined behavior. -(You can actually get away with in-place modifications via substr() -that do not change the length of the entire string. In general, however, -you should be using s///g for such modifications.) Examples: -.nf - - # array context - ($one,$five,$fifteen) = (\`uptime\` =~ /(\ed+\e.\ed+)/g); - - # scalar context - $/ = ""; $* = 1; - while ($paragraph = <>) { - while ($paragraph =~ /[a-z][\'")]*[.!?]+[\'")]*\es/g) { - $sentences++; - } - } - print "$sentences\en"; - -.fi -.Ip "mkdir(FILENAME,MODE)" 8 3 -Creates the directory specified by FILENAME, with permissions specified by -MODE (as modified by umask). -If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). -.Ip "msgctl(ID,CMD,ARG)" 8 4 -Calls the System V IPC function msgctl. If CMD is &IPC_STAT, then ARG -must be a variable which will hold the returned msqid_ds structure. -Returns like ioctl: the undefined value for error, "0 but true" for -zero, or the actual return value otherwise. -.Ip "msgget(KEY,FLAGS)" 8 4 -Calls the System V IPC function msgget. Returns the message queue id, -or the undefined value if there is an error. -.Ip "msgsnd(ID,MSG,FLAGS)" 8 4 -Calls the System V IPC function msgsnd to send the message MSG to the -message queue ID. MSG must begin with the long integer message type, -which may be created with pack("L", $type). Returns true if -successful, or false if there is an error. -.Ip "msgrcv(ID,VAR,SIZE,TYPE,FLAGS)" 8 4 -Calls the System V IPC function msgrcv to receive a message from -message queue ID into variable VAR with a maximum message size of -SIZE. Note that if a message is received, the message type will be -the first thing in VAR, and the maximum length of VAR is SIZE plus the -size of the message type. Returns true if successful, or false if -there is an error. -.Ip "next LABEL" 8 8 -.Ip "next" 8 -The -.I next -command is like the -.I continue -statement in C; it starts the next iteration of the loop: -.nf - -.ne 4 - line: while (<STDIN>) { - next line if /\|^#/; # discard comments - .\|.\|. - } - -.fi -Note that if there were a -.I continue -block on the above, it would get executed even on discarded lines. -If the LABEL is omitted, the command refers to the innermost enclosing loop. -.Ip "oct(EXPR)" 8 4 -.Ip "oct EXPR" 8 -Returns the decimal value of EXPR interpreted as an octal string. -(If EXPR happens to start off with 0x, interprets it as a hex string instead.) -The following will handle decimal, octal and hex in the standard notation: -.nf - - $val = oct($val) if $val =~ /^0/; - -.fi -If EXPR is omitted, uses $_. -.Ip "open(FILEHANDLE,EXPR)" 8 8 -.Ip "open(FILEHANDLE)" 8 -.Ip "open FILEHANDLE" 8 -Opens the file whose filename is given by EXPR, and associates it with -FILEHANDLE. -If FILEHANDLE is an expression, its value is used as the name of the -real filehandle wanted. -If EXPR is omitted, the scalar variable of the same name as the FILEHANDLE -contains the filename. -If the filename begins with \*(L"<\*(R" or nothing, the file is opened for -input. -If the filename begins with \*(L">\*(R", the file is opened for output. -If the filename begins with \*(L">>\*(R", the file is opened for appending. -(You can put a \'+\' in front of the \'>\' or \'<\' to indicate that you -want both read and write access to the file.) -If the filename begins with \*(L"|\*(R", the filename is interpreted -as a command to which output is to be piped, and if the filename ends -with a \*(L"|\*(R", the filename is interpreted as command which pipes -input to us. -(You may not have a command that pipes both in and out.) -Opening \'\-\' opens -.I STDIN -and opening \'>\-\' opens -.IR STDOUT . -Open returns non-zero upon success, the undefined value otherwise. -If the open involved a pipe, the return value happens to be the pid -of the subprocess. -Examples: -.nf - -.ne 3 - $article = 100; - open article || die "Can't find article $article: $!\en"; - while (<article>) {\|.\|.\|. - -.ie t \{\ - open(LOG, \'>>/usr/spool/news/twitlog\'\|); # (log is reserved) -'br\} -.el \{\ - open(LOG, \'>>/usr/spool/news/twitlog\'\|); - # (log is reserved) -'br\} - -.ie t \{\ - open(article, "caesar <$article |"\|); # decrypt article -'br\} -.el \{\ - open(article, "caesar <$article |"\|); - # decrypt article -'br\} - -.ie t \{\ - open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process# -'br\} -.el \{\ - open(extract, "|sort >/tmp/Tmp$$"\|); - # $$ is our process# -'br\} - -.ne 7 - # process argument list of files along with any includes - - foreach $file (@ARGV) { - do process($file, \'fh00\'); # no pun intended - } - - sub process { - local($filename, $input) = @_; - $input++; # this is a string increment - unless (open($input, $filename)) { - print STDERR "Can't open $filename: $!\en"; - return; - } -.ie t \{\ - while (<$input>) { # note the use of indirection -'br\} -.el \{\ - while (<$input>) { # note use of indirection -'br\} - if (/^#include "(.*)"/) { - do process($1, $input); - next; - } - .\|.\|. # whatever - } - } - -.fi -You may also, in the Bourne shell tradition, specify an EXPR beginning -with \*(L">&\*(R", in which case the rest of the string -is interpreted as the name of a filehandle -(or file descriptor, if numeric) which is to be duped and opened. -You may use & after >, >>, <, +>, +>> and +<. -The mode you specify should match the mode of the original filehandle. -Here is a script that saves, redirects, and restores -.I STDOUT -and -.IR STDERR : -.nf - -.ne 21 - #!/usr/bin/perl - open(SAVEOUT, ">&STDOUT"); - open(SAVEERR, ">&STDERR"); - - open(STDOUT, ">foo.out") || die "Can't redirect stdout"; - open(STDERR, ">&STDOUT") || die "Can't dup stdout"; - - select(STDERR); $| = 1; # make unbuffered - select(STDOUT); $| = 1; # make unbuffered - - print STDOUT "stdout 1\en"; # this works for - print STDERR "stderr 1\en"; # subprocesses too - - close(STDOUT); - close(STDERR); - - open(STDOUT, ">&SAVEOUT"); - open(STDERR, ">&SAVEERR"); - - print STDOUT "stdout 2\en"; - print STDERR "stderr 2\en"; - -.fi -If you open a pipe on the command \*(L"\-\*(R", i.e. either \*(L"|\-\*(R" or \*(L"\-|\*(R", -then there is an implicit fork done, and the return value of open -is the pid of the child within the parent process, and 0 within the child -process. -(Use defined($pid) to determine if the open was successful.) -The filehandle behaves normally for the parent, but i/o to that -filehandle is piped from/to the -.IR STDOUT / STDIN -of the child process. -In the child process the filehandle isn't opened\*(--i/o happens from/to -the new -.I STDOUT -or -.IR STDIN . -Typically this is used like the normal piped open when you want to exercise -more control over just how the pipe command gets executed, such as when -you are running setuid, and don't want to have to scan shell commands -for metacharacters. -The following pairs are more or less equivalent: -.nf - -.ne 5 - open(FOO, "|tr \'[a\-z]\' \'[A\-Z]\'"); - open(FOO, "|\-") || exec \'tr\', \'[a\-z]\', \'[A\-Z]\'; - - open(FOO, "cat \-n '$file'|"); - open(FOO, "\-|") || exec \'cat\', \'\-n\', $file; - -.fi -Explicitly closing any piped filehandle causes the parent process to wait for the -child to finish, and returns the status value in $?. -Note: on any operation which may do a fork, -unflushed buffers remain unflushed in both -processes, which means you may need to set $| to -avoid duplicate output. -.Sp -The filename that is passed to open will have leading and trailing -whitespace deleted. -In order to open a file with arbitrary weird characters in it, it's necessary -to protect any leading and trailing whitespace thusly: -.nf - -.ne 2 - $file =~ s#^(\es)#./$1#; - open(FOO, "< $file\e0"); - -.fi -.Ip "opendir(DIRHANDLE,EXPR)" 8 3 -Opens a directory named EXPR for processing by readdir(), telldir(), seekdir(), -rewinddir() and closedir(). -Returns true if successful. -DIRHANDLEs have their own namespace separate from FILEHANDLEs. -.Ip "ord(EXPR)" 8 4 -.Ip "ord EXPR" 8 -Returns the numeric ascii value of the first character of EXPR. -If EXPR is omitted, uses $_. -''' Comments on f & d by gnb@melba.bby.oz.au 22/11/89 -.Ip "pack(TEMPLATE,LIST)" 8 4 -Takes an array or list of values and packs it into a binary structure, -returning the string containing the structure. -The TEMPLATE is a sequence of characters that give the order and type -of values, as follows: -.nf - - A An ascii string, will be space padded. - a An ascii string, will be null padded. - c A signed char value. - C An unsigned char value. - s A signed short value. - S An unsigned short value. - i A signed integer value. - I An unsigned integer value. - l A signed long value. - L An unsigned long value. - n A short in \*(L"network\*(R" order. - N A long in \*(L"network\*(R" order. - f A single-precision float in the native format. - d A double-precision float in the native format. - p A pointer to a null-terminated string. - P A pointer to a structure. - v A short in \*(L"VAX\*(R" (little-endian) order. - V A long in \*(L"VAX\*(R" (little-endian) order. - x A null byte. - X Back up a byte. - @ Null fill to absolute position. - u A uuencoded string. - b A bit string (ascending bit order, like vec()). - B A bit string (descending bit order). - h A hex string (low nybble first). - H A hex string (high nybble first). - -.fi -Each letter may optionally be followed by a number which gives a repeat -count. -With all types except "a", "A", "b", "B", "h" and "H", and "P" -the pack function will gobble up that many values -from the LIST. -A * for the repeat count means to use however many items are left. -The "a" and "A" types gobble just one value, but pack it as a string of length -count, -padding with nulls or spaces as necessary. -(When unpacking, "A" strips trailing spaces and nulls, but "a" does not.) -Likewise, the "b" and "B" fields pack a string that many bits long. -The "h" and "H" fields pack a string that many nybbles long. -The "P" packs a pointer to a structure of the size indicated by the length. -Real numbers (floats and doubles) are in the native machine format -only; due to the multiplicity of floating formats around, and the lack -of a standard \*(L"network\*(R" representation, no facility for -interchange has been made. -This means that packed floating point data -written on one machine may not be readable on another - even if both -use IEEE floating point arithmetic (as the endian-ness of the memory -representation is not part of the IEEE spec). -Note that perl uses -doubles internally for all numeric calculation, and converting from -double -> float -> double will lose precision (i.e. unpack("f", -pack("f", $foo)) will not in general equal $foo). -.br -Examples: -.nf - - $foo = pack("cccc",65,66,67,68); - # foo eq "ABCD" - $foo = pack("c4",65,66,67,68); - # same thing - - $foo = pack("ccxxcc",65,66,67,68); - # foo eq "AB\e0\e0CD" - - $foo = pack("s2",1,2); - # "\e1\e0\e2\e0" on little-endian - # "\e0\e1\e0\e2" on big-endian - - $foo = pack("a4","abcd","x","y","z"); - # "abcd" - - $foo = pack("aaaa","abcd","x","y","z"); - # "axyz" - - $foo = pack("a14","abcdefg"); - # "abcdefg\e0\e0\e0\e0\e0\e0\e0" - - $foo = pack("i9pl", gmtime); - # a real struct tm (on my system anyway) - - sub bintodec { - unpack("N", pack("B32", substr("0" x 32 . shift, -32))); - } -.fi -The same template may generally also be used in the unpack function. -.Ip "pipe(READHANDLE,WRITEHANDLE)" 8 3 -Opens a pair of connected pipes like the corresponding system call. -Note that if you set up a loop of piped processes, deadlock can occur -unless you are very careful. -In addition, note that perl's pipes use stdio buffering, so you may need -to set $| to flush your WRITEHANDLE after each command, depending on -the application. -[Requires version 3.0 patchlevel 9.] -.Ip "pop(ARRAY)" 8 -.Ip "pop ARRAY" 8 6 -Pops and returns the last value of the array, shortening the array by 1. -Has the same effect as -.nf - - $tmp = $ARRAY[$#ARRAY\-\|\-]; - -.fi -If there are no elements in the array, returns the undefined value. -.Ip "print(FILEHANDLE LIST)" 8 10 -.Ip "print(LIST)" 8 -.Ip "print FILEHANDLE LIST" 8 -.Ip "print LIST" 8 -.Ip "print" 8 -Prints a string or a comma-separated list of strings. -Returns non-zero if successful. -FILEHANDLE may be a scalar variable name, in which case the variable contains -the name of the filehandle, thus introducing one level of indirection. -(NOTE: If FILEHANDLE is a variable and the next token is a term, it may be -misinterpreted as an operator unless you interpose a + or put parens around -the arguments.) -If FILEHANDLE is omitted, prints by default to standard output (or to the -last selected output channel\*(--see select()). -If LIST is also omitted, prints $_ to -.IR STDOUT . -To set the default output channel to something other than -.I STDOUT -use the select operation. -Note that, because print takes a LIST, anything in the LIST is evaluated -in an array context, and any subroutine that you call will have one or more -of its expressions evaluated in an array context. -Also be careful not to follow the print keyword with a left parenthesis -unless you want the corresponding right parenthesis to terminate the -arguments to the print\*(--interpose a + or put parens around all the arguments. -.Ip "printf(FILEHANDLE LIST)" 8 10 -.Ip "printf(LIST)" 8 -.Ip "printf FILEHANDLE LIST" 8 -.Ip "printf LIST" 8 -Equivalent to a \*(L"print FILEHANDLE sprintf(LIST)\*(R". -.Ip "push(ARRAY,LIST)" 8 7 -Treats ARRAY (@ is optional) as a stack, and pushes the values of LIST -onto the end of ARRAY. -The length of ARRAY increases by the length of LIST. -Has the same effect as -.nf - - for $value (LIST) { - $ARRAY[++$#ARRAY] = $value; - } - -.fi -but is more efficient. Returns the new number of elements in the array. -.Ip "q/STRING/" 8 5 -.Ip "qq/STRING/" 8 -.Ip "qx/STRING/" 8 -These are not really functions, but simply syntactic sugar to let you -avoid putting too many backslashes into quoted strings. -The q operator is a generalized single quote, and the qq operator a -generalized double quote. -The qx operator is a generalized backquote. -Any non-alphanumeric delimiter can be used in place of /, including newline. -If the delimiter is an opening bracket or parenthesis, the final delimiter -will be the corresponding closing bracket or parenthesis. -(Embedded occurrences of the closing bracket need to be backslashed as usual.) -Examples: -.nf - -.ne 5 - $foo = q!I said, "You said, \'She said it.\'"!; - $bar = q(\'This is it.\'); - $today = qx{ date }; - $_ .= qq -*** The previous line contains the naughty word "$&".\en - if /(ibm|apple|awk)/; # :-) - -.fi -.Ip "rand(EXPR)" 8 8 -.Ip "rand EXPR" 8 -.Ip "rand" 8 -Returns a random fractional number between 0 and the value of EXPR. -(EXPR should be positive.) -If EXPR is omitted, returns a value between 0 and 1. -See also srand(). -.Ip "read(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5 -.Ip "read(FILEHANDLE,SCALAR,LENGTH)" 8 5 -Attempts to read LENGTH bytes of data into variable SCALAR from the specified -FILEHANDLE. -Returns the number of bytes actually read, or undef if there was an error. -SCALAR will be grown or shrunk to the length actually read. -An OFFSET may be specified to place the read data at some other place -than the beginning of the string. -This call is actually implemented in terms of stdio's fread call. To get -a true read system call, see sysread. -.Ip "readdir(DIRHANDLE)" 8 3 -.Ip "readdir DIRHANDLE" 8 -Returns the next directory entry for a directory opened by opendir(). -If used in an array context, returns all the rest of the entries in the -directory. -If there are no more entries, returns an undefined value in a scalar context -or a null list in an array context. -.Ip "readlink(EXPR)" 8 6 -.Ip "readlink EXPR" 8 -Returns the value of a symbolic link, if symbolic links are implemented. -If not, gives a fatal error. -If there is some system error, returns the undefined value and sets $! (errno). -If EXPR is omitted, uses $_. -.Ip "recv(SOCKET,SCALAR,LEN,FLAGS)" 8 4 -Receives a message on a socket. -Attempts to receive LENGTH bytes of data into variable SCALAR from the specified -SOCKET filehandle. -Returns the address of the sender, or the undefined value if there's an error. -SCALAR will be grown or shrunk to the length actually read. -Takes the same flags as the system call of the same name. -.Ip "redo LABEL" 8 8 -.Ip "redo" 8 -The -.I redo -command restarts the loop block without evaluating the conditional again. -The -.I continue -block, if any, is not executed. -If the LABEL is omitted, the command refers to the innermost enclosing loop. -This command is normally used by programs that want to lie to themselves -about what was just input: -.nf - -.ne 16 - # a simpleminded Pascal comment stripper - # (warning: assumes no { or } in strings) - line: while (<STDIN>) { - while (s|\|({.*}.*\|){.*}|$1 \||) {} - s|{.*}| \||; - if (s|{.*| \||) { - $front = $_; - while (<STDIN>) { - if (\|/\|}/\|) { # end of comment? - s|^|$front{|; - redo line; - } - } - } - print; - } - -.fi -.Ip "rename(OLDNAME,NEWNAME)" 8 2 -Changes the name of a file. -Returns 1 for success, 0 otherwise. -Will not work across filesystem boundaries. -.Ip "require(EXPR)" 8 6 -.Ip "require EXPR" 8 -.Ip "require" 8 -Includes the library file specified by EXPR, or by $_ if EXPR is not supplied. -Has semantics similar to the following subroutine: -.nf - - sub require { - local($filename) = @_; - return 1 if $INC{$filename}; - local($realfilename,$result); - ITER: { - foreach $prefix (@INC) { - $realfilename = "$prefix/$filename"; - if (-f $realfilename) { - $result = do $realfilename; - last ITER; - } - } - die "Can't find $filename in \e@INC"; - } - die $@ if $@; - die "$filename did not return true value" unless $result; - $INC{$filename} = $realfilename; - $result; - } - -.fi -Note that the file will not be included twice under the same specified name. -The file must return true as the last statement to indicate successful -execution of any initialization code, so it's customary to end -such a file with \*(L"1;\*(R" unless you're sure it'll return true otherwise. -.Ip "reset(EXPR)" 8 6 -.Ip "reset EXPR" 8 -.Ip "reset" 8 -Generally used in a -.I continue -block at the end of a loop to clear variables and reset ?? searches -so that they work again. -The expression is interpreted as a list of single characters (hyphens allowed -for ranges). -All variables and arrays beginning with one of those letters are reset to -their pristine state. -If the expression is omitted, one-match searches (?pattern?) are reset to -match again. -Only resets variables or searches in the current package. -Always returns 1. -Examples: -.nf - -.ne 3 - reset \'X\'; \h'|2i'# reset all X variables - reset \'a\-z\';\h'|2i'# reset lower case variables - reset; \h'|2i'# just reset ?? searches - -.fi -Note: resetting \*(L"A\-Z\*(R" is not recommended since you'll wipe out your ARGV and ENV -arrays. -.Sp -The use of reset on dbm associative arrays does not change the dbm file. -(It does, however, flush any entries cached by perl, which may be useful if -you are sharing the dbm file. -Then again, maybe not.) -.Ip "return LIST" 8 3 -Returns from a subroutine or eval with the value specified. -(Note that in the absence of a return a subroutine will automatically return -the value of the last expression evaluated.) -.Ip "reverse(LIST)" 8 4 -.Ip "reverse LIST" 8 -In an array context, returns an array value consisting of the elements -of LIST in the opposite order. -In a scalar context, returns a string value consisting of the bytes of -the first element of LIST in the opposite order. -.Ip "rewinddir(DIRHANDLE)" 8 5 -.Ip "rewinddir DIRHANDLE" 8 -Sets the current position to the beginning of the directory for the readdir() routine on DIRHANDLE. -.Ip "rindex(STR,SUBSTR,POSITION)" 8 6 -.Ip "rindex(STR,SUBSTR)" 8 4 -Works just like index except that it -returns the position of the LAST occurrence of SUBSTR in STR. -If POSITION is specified, returns the last occurrence at or before that -position. -.Ip "rmdir(FILENAME)" 8 4 -.Ip "rmdir FILENAME" 8 -Deletes the directory specified by FILENAME if it is empty. -If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). -If FILENAME is omitted, uses $_. -.Ip "s/PATTERN/REPLACEMENT/gieo" 8 3 -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). -The \*(L"g\*(R" is optional, and if present, indicates that all occurrences -of the pattern are to be replaced. -The \*(L"i\*(R" is also optional, and if present, indicates that matching -is to be done in a case-insensitive manner. -The \*(L"e\*(R" is likewise optional, and if present, indicates that -the replacement string is to be evaluated as an expression rather than just -as a double-quoted string. -Any non-alphanumeric delimiter may replace the slashes; -if single quotes are used, no -interpretation is done on the replacement string (the 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. -s(foo)(bar) or s<foo>/bar/. -If no string is specified via the =~ or !~ operator, -the $_ string is searched and modified. -(The string specified with =~ must be a scalar variable, an array element, -or an assignment to one of those, i.e. an lvalue.) -If the pattern contains a $ that looks like a variable rather than an -end-of-string test, the variable will be interpolated into the pattern at -run-time. -If you only want the pattern compiled once the first time the variable is -interpolated, add an \*(L"o\*(R" at the end. -If the PATTERN evaluates to a null string, the most recent successful -regular expression is used instead. -See also the section on regular expressions. -Examples: -.nf - - s/\|\e\|bgreen\e\|b/mauve/g; # don't change wintergreen - - $path \|=~ \|s|\|/usr/bin|\|/usr/local/bin|; - - s/Login: $foo/Login: $bar/; # run-time pattern - - ($foo = $bar) =~ s/bar/foo/; - - $_ = \'abc123xyz\'; - s/\ed+/$&*2/e; # yields \*(L'abc246xyz\*(R' - s/\ed+/sprintf("%5d",$&)/e; # yields \*(L'abc 246xyz\*(R' - s/\ew/$& x 2/eg; # yields \*(L'aabbcc 224466xxyyzz\*(R' - - s/\|([^ \|]*\|) *\|([^ \|]*\|)\|/\|$2 $1/; # reverse 1st two fields - -.fi -(Note the use of $ instead of \|\e\| in the last example. See section -on regular expressions.) -.Ip "scalar(EXPR)" 8 3 -Forces EXPR to be interpreted in a scalar context and returns the value -of EXPR. -.Ip "seek(FILEHANDLE,POSITION,WHENCE)" 8 3 -Randomly positions the file pointer for FILEHANDLE, just like the fseek() -call of stdio. -FILEHANDLE may be an expression whose value gives the name of the filehandle. -Returns 1 upon success, 0 otherwise. -.Ip "seekdir(DIRHANDLE,POS)" 8 3 -Sets the current position for the readdir() routine on DIRHANDLE. -POS must be a value returned by telldir(). -Has the same caveats about possible directory compaction as the corresponding -system library routine. -.Ip "select(FILEHANDLE)" 8 3 -.Ip "select" 8 3 -Returns the currently selected filehandle. -Sets the current default filehandle for output, if FILEHANDLE is supplied. -This has two effects: first, a -.I write -or a -.I print -without a filehandle will default to this FILEHANDLE. -Second, references to variables related to output will refer to this output -channel. -For example, if you have to set the top of form format for more than -one output channel, you might do the following: -.nf - -.ne 4 - select(REPORT1); - $^ = \'report1_top\'; - select(REPORT2); - $^ = \'report2_top\'; - -.fi -FILEHANDLE may be an expression whose value gives the name of the actual filehandle. -Thus: -.nf - - $oldfh = select(STDERR); $| = 1; select($oldfh); - -.fi -.Ip "select(RBITS,WBITS,EBITS,TIMEOUT)" 8 3 -This calls the select system call with the bitmasks specified, which can -be constructed using fileno() and vec(), along these lines: -.nf - - $rin = $win = $ein = ''; - vec($rin,fileno(STDIN),1) = 1; - vec($win,fileno(STDOUT),1) = 1; - $ein = $rin | $win; - -.fi -If you want to select on many filehandles you might wish to write a subroutine: -.nf - - sub fhbits { - local(@fhlist) = split(' ',$_[0]); - local($bits); - for (@fhlist) { - vec($bits,fileno($_),1) = 1; - } - $bits; - } - $rin = &fhbits('STDIN TTY SOCK'); - -.fi -The usual idiom is: -.nf - - ($nfound,$timeleft) = - select($rout=$rin, $wout=$win, $eout=$ein, $timeout); - -or to block until something becomes ready: - -.ie t \{\ - $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef); -'br\} -.el \{\ - $nfound = select($rout=$rin, $wout=$win, - $eout=$ein, undef); -'br\} - -.fi -Any of the bitmasks can also be undef. -The timeout, if specified, is in seconds, which may be fractional. -NOTE: not all implementations are capable of returning the $timeleft. -If not, they always return $timeleft equal to the supplied $timeout. -.Ip "semctl(ID,SEMNUM,CMD,ARG)" 8 4 -Calls the System V IPC function semctl. If CMD is &IPC_STAT or -&GETALL, then ARG must be a variable which will hold the returned -semid_ds structure or semaphore value array. Returns like ioctl: the -undefined value for error, "0 but true" for zero, or the actual return -value otherwise. -.Ip "semget(KEY,NSEMS,FLAGS)" 8 4 -Calls the System V IPC function semget. Returns the semaphore id, or -the undefined value if there is an error. -.Ip "semop(KEY,OPSTRING)" 8 4 -Calls the System V IPC function semop to perform semaphore operations -such as signaling and waiting. OPSTRING must be a packed array of -semop structures. Each semop structure can be generated with -\&'pack("sss", $semnum, $semop, $semflag)'. The number of semaphore -operations is implied by the length of OPSTRING. Returns true if -successful, or false if there is an error. As an example, the -following code waits on semaphore $semnum of semaphore id $semid: -.nf - - $semop = pack("sss", $semnum, -1, 0); - die "Semaphore trouble: $!\en" unless semop($semid, $semop); - -.fi -To signal the semaphore, replace "-1" with "1". -.Ip "send(SOCKET,MSG,FLAGS,TO)" 8 4 -.Ip "send(SOCKET,MSG,FLAGS)" 8 -Sends a message on a socket. -Takes the same flags as the system call of the same name. -On unconnected sockets you must specify a destination to send TO. -Returns the number of characters sent, or the undefined value if -there is an error. -.Ip "setpgrp(PID,PGRP)" 8 4 -Sets the current process group for the specified PID, 0 for the current -process. -Will produce a fatal error if used on a machine that doesn't implement -setpgrp(2). -.Ip "setpriority(WHICH,WHO,PRIORITY)" 8 4 -Sets the current priority for a process, a process group, or a user. -(See setpriority(2).) -Will produce a fatal error if used on a machine that doesn't implement -setpriority(2). -.Ip "setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)" 8 3 -Sets the socket option requested. -Returns undefined if there is an error. -OPTVAL may be specified as undef if you don't want to pass an argument. -.Ip "shift(ARRAY)" 8 6 -.Ip "shift ARRAY" 8 -.Ip "shift" 8 -Shifts the first value of the array off and returns it, -shortening the array by 1 and moving everything down. -If there are no elements in the array, returns the undefined value. -If ARRAY is omitted, shifts the @ARGV array in the main program, and the @_ -array in subroutines. -(This is determined lexically.) -See also unshift(), push() and pop(). -Shift() and unshift() do the same thing to the left end of an array that push() -and pop() do to the right end. -.Ip "shmctl(ID,CMD,ARG)" 8 4 -Calls the System V IPC function shmctl. If CMD is &IPC_STAT, then ARG -must be a variable which will hold the returned shmid_ds structure. -Returns like ioctl: the undefined value for error, "0 but true" for -zero, or the actual return value otherwise. -.Ip "shmget(KEY,SIZE,FLAGS)" 8 4 -Calls the System V IPC function shmget. Returns the shared memory -segment id, or the undefined value if there is an error. -.Ip "shmread(ID,VAR,POS,SIZE)" 8 4 -.Ip "shmwrite(ID,STRING,POS,SIZE)" 8 -Reads or writes the System V shared memory segment ID starting at -position POS for size SIZE by attaching to it, copying in/out, and -detaching from it. When reading, VAR must be a variable which -will hold the data read. When writing, if STRING is too long, -only SIZE bytes are used; if STRING is too short, nulls are -written to fill out SIZE bytes. Return true if successful, or -false if there is an error. -.Ip "shutdown(SOCKET,HOW)" 8 3 -Shuts down a socket connection in the manner indicated by HOW, which has -the same interpretation as in the system call of the same name. -.Ip "sin(EXPR)" 8 4 -.Ip "sin EXPR" 8 -Returns the sine of EXPR (expressed in radians). -If EXPR is omitted, returns sine of $_. -.Ip "sleep(EXPR)" 8 6 -.Ip "sleep EXPR" 8 -.Ip "sleep" 8 -Causes the script to sleep for EXPR seconds, or forever if no EXPR. -May be interrupted by sending the process a SIGALRM. -Returns the number of seconds actually slept. -You probably cannot mix alarm() and sleep() calls, since sleep() is -often implemented using alarm(). -.Ip "socket(SOCKET,DOMAIN,TYPE,PROTOCOL)" 8 3 -Opens a socket of the specified kind and attaches it to filehandle SOCKET. -DOMAIN, TYPE and PROTOCOL are specified the same as for the system call -of the same name. -You may need to run h2ph on sys/socket.h to get the proper values handy -in a perl library file. -Return true if successful. -See the example in the section on Interprocess Communication. -.Ip "socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)" 8 3 -Creates an unnamed pair of sockets in the specified domain, of the specified -type. -DOMAIN, TYPE and PROTOCOL are specified the same as for the system call -of the same name. -If unimplemented, yields a fatal error. -Return true if successful. -.Ip "sort(SUBROUTINE LIST)" 8 9 -.Ip "sort(LIST)" 8 -.Ip "sort SUBROUTINE LIST" 8 -.Ip "sort BLOCK LIST" 8 -.Ip "sort LIST" 8 -Sorts the LIST and returns the sorted array value. -Nonexistent values of arrays are stripped out. -If SUBROUTINE or BLOCK is omitted, sorts in standard string comparison order. -If SUBROUTINE is specified, gives the name of a subroutine that returns -an integer less than, equal to, or greater than 0, -depending on how the elements of the array are to be ordered. -(The <=> and cmp operators are extremely useful in such routines.) -SUBROUTINE may be a scalar variable name, in which case the value provides -the name of the subroutine to use. -In place of a SUBROUTINE name, you can provide a BLOCK as an anonymous, -in-line sort subroutine. -.Sp -In the interests of efficiency the normal calling code for subroutines -is bypassed, with the following effects: the subroutine may not be a recursive -subroutine, and the two elements to be compared are passed into the subroutine -not via @_ but as $a and $b (see example below). -They are passed by reference so don't modify $a and $b. -.Sp -Examples: -.nf - -.ne 2 - # sort lexically - @articles = sort @files; - -.ne 2 - # same thing, but with explicit sort routine - @articles = sort {$a cmp $b} @files; - -.ne 2 - # same thing in reversed order - @articles = sort {$b cmp $a} @files; - -.ne 2 - # sort numerically ascending - @articles = sort {$a <=> $b} @files; - -.ne 2 - # sort numerically descending - @articles = sort {$b <=> $a} @files; - -.ne 5 - # sort using explicit subroutine name - sub byage { - $age{$a} <=> $age{$b}; # presuming integers - } - @sortedclass = sort byage @class; - -.ne 9 - sub reverse { $b cmp $a; } - @harry = (\'dog\',\'cat\',\'x\',\'Cain\',\'Abel\'); - @george = (\'gone\',\'chased\',\'yz\',\'Punished\',\'Axed\'); - print sort @harry; - # prints AbelCaincatdogx - print sort reverse @harry; - # prints xdogcatCainAbel - print sort @george, \'to\', @harry; - # prints AbelAxedCainPunishedcatchaseddoggonetoxyz - -.fi -.Ip "splice(ARRAY,OFFSET,LENGTH,LIST)" 8 8 -.Ip "splice(ARRAY,OFFSET,LENGTH)" 8 -.Ip "splice(ARRAY,OFFSET)" 8 -Removes the elements designated by OFFSET and LENGTH from an array, and -replaces them with the elements of LIST, if any. -Returns the elements removed from the array. -The array grows or shrinks as necessary. -If LENGTH is omitted, removes everything from OFFSET onward. -The following equivalencies hold (assuming $[ == 0): -.nf - - push(@a,$x,$y)\h'|3.5i'splice(@a,$#a+1,0,$x,$y) - pop(@a)\h'|3.5i'splice(@a,-1) - shift(@a)\h'|3.5i'splice(@a,0,1) - unshift(@a,$x,$y)\h'|3.5i'splice(@a,0,0,$x,$y) - $a[$x] = $y\h'|3.5i'splice(@a,$x,1,$y); - -Example, assuming array lengths are passed before arrays: - - sub aeq { # compare two array values - local(@a) = splice(@_,0,shift); - local(@b) = splice(@_,0,shift); - return 0 unless @a == @b; # same len? - while (@a) { - return 0 if pop(@a) ne pop(@b); - } - return 1; - } - if (&aeq($len,@foo[1..$len],0+@bar,@bar)) { ... } - -.fi -.Ip "split(/PATTERN/,EXPR,LIMIT)" 8 8 -.Ip "split(/PATTERN/,EXPR)" 8 8 -.Ip "split(/PATTERN/)" 8 -.Ip "split" 8 -Splits a string into an array of strings, and returns it. -(If not in an array context, returns the number of fields found and splits -into the @_ array. -(In an array context, you can force the split into @_ -by using ?? as the pattern delimiters, but it still returns the array value.)) -If EXPR is omitted, splits the $_ string. -If PATTERN is also omitted, splits on whitespace (/[\ \et\en]+/). -Anything matching PATTERN is taken to be a delimiter separating the fields. -(Note that the delimiter may be longer than one character.) -If LIMIT is specified, splits into no more than that many fields (though it -may split into fewer). -If LIMIT is unspecified, trailing null fields are stripped (which -potential users of pop() would do well to remember). -A pattern matching the null string (not to be confused with a null pattern //, -which is just one member of the set of patterns matching a null string) -will split the value of EXPR into separate characters at each point it -matches that way. -For example: -.nf - - print join(\':\', split(/ */, \'hi there\')); - -.fi -produces the output \*(L'h:i:t:h:e:r:e\*(R'. -.Sp -The LIMIT parameter can be used to partially split a line -.nf - - ($login, $passwd, $remainder) = split(\|/\|:\|/\|, $_, 3); - -.fi -(When assigning to a list, if LIMIT is omitted, perl supplies a LIMIT one -larger than the number of variables in the list, to avoid unnecessary work. -For the list above LIMIT would have been 4 by default. -In time critical applications it behooves you not to split into -more fields than you really need.) -.Sp -If the PATTERN contains parentheses, additional array elements are created -from each matching substring in the delimiter. -.Sp - split(/([,-])/,"1-10,20"); -.Sp -produces the array value -.Sp - (1,'-',10,',',20) -.Sp -The pattern /PATTERN/ may be replaced with an expression to specify patterns -that vary at runtime. -(To do runtime compilation only once, use /$variable/o.) -As a special case, specifying a space (\'\ \') will split on white space -just as split with no arguments does, but leading white space does NOT -produce a null first field. -Thus, split(\'\ \') can be used to emulate -.IR awk 's -default behavior, whereas -split(/\ /) will give you as many null initial fields as there are -leading spaces. -.Sp -Example: -.nf - -.ne 5 - open(passwd, \'/etc/passwd\'); - while (<passwd>) { -.ie t \{\ - ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(\|/\|:\|/\|); -'br\} -.el \{\ - ($login, $passwd, $uid, $gid, $gcos, $home, $shell) - = split(\|/\|:\|/\|); -'br\} - .\|.\|. - } - -.fi -(Note that $shell above will still have a newline on it. See chop().) -See also -.IR join . -.Ip "sprintf(FORMAT,LIST)" 8 4 -Returns a string formatted by the usual printf conventions. -The * character is not supported. -.Ip "sqrt(EXPR)" 8 4 -.Ip "sqrt EXPR" 8 -Return the square root of EXPR. -If EXPR is omitted, returns square root of $_. -.Ip "srand(EXPR)" 8 4 -.Ip "srand EXPR" 8 -Sets the random number seed for the -.I rand -operator. -If EXPR is omitted, does srand(time). -.Ip "stat(FILEHANDLE)" 8 8 -.Ip "stat FILEHANDLE" 8 -.Ip "stat(EXPR)" 8 -.Ip "stat SCALARVARIABLE" 8 -Returns a 13-element array giving the statistics for a file, either the file -opened via FILEHANDLE, or named by EXPR. -Returns a null list if the stat fails. -Typically used as follows: -.nf - -.ne 3 - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) - = stat($filename); - -.fi -If stat is passed the special filehandle consisting of an underline, -no stat is done, but the current contents of the stat structure from -the last stat or filetest are returned. -Example: -.nf - -.ne 3 - if (-x $file && (($d) = stat(_)) && $d < 0) { - print "$file is executable NFS file\en"; - } - -.fi -(This only works on machines for which the device number is negative under NFS.) -.Ip "study(SCALAR)" 8 6 -.Ip "study SCALAR" 8 -.Ip "study" -Takes extra time to study SCALAR ($_ if unspecified) in anticipation of -doing many pattern matches on the string before it is next modified. -This may or may not save time, depending on the nature and number of patterns -you are searching on, and on the distribution of character frequencies in -the string to be searched\*(--you probably want to compare runtimes with and -without it to see which runs faster. -Those loops which scan for many short constant strings (including the constant -parts of more complex patterns) will benefit most. -You may have only one study active at a time\*(--if you study a different -scalar the first is \*(L"unstudied\*(R". -(The way study works is this: a linked list of every character in the string -to be searched is made, so we know, for example, where all the \*(L'k\*(R' characters -are. -From each search string, the rarest character is selected, based on some -static frequency tables constructed from some C programs and English text. -Only those places that contain this \*(L"rarest\*(R" character are examined.) -.Sp -For example, here is a loop which inserts index producing entries before any line -containing a certain pattern: -.nf - -.ne 8 - while (<>) { - study; - print ".IX foo\en" if /\ebfoo\eb/; - print ".IX bar\en" if /\ebbar\eb/; - print ".IX blurfl\en" if /\ebblurfl\eb/; - .\|.\|. - print; - } - -.fi -In searching for /\ebfoo\eb/, only those locations in $_ that contain \*(L'f\*(R' -will be looked at, because \*(L'f\*(R' is rarer than \*(L'o\*(R'. -In general, this is a big win except in pathological cases. -The only question is whether it saves you more time than it took to build -the linked list in the first place. -.Sp -Note that if you have to look for strings that you don't know till runtime, -you can build an entire loop as a string and eval that to avoid recompiling -all your patterns all the time. -Together with undefining $/ to input entire files as one record, this can -be very fast, often faster than specialized programs like fgrep. -The following scans a list of files (@files) -for a list of words (@words), and prints out the names of those files that -contain a match: -.nf - -.ne 12 - $search = \'while (<>) { study;\'; - foreach $word (@words) { - $search .= "++\e$seen{\e$ARGV} if /\e\eb$word\e\eb/;\en"; - } - $search .= "}"; - @ARGV = @files; - undef $/; - eval $search; # this screams - $/ = "\en"; # put back to normal input delim - foreach $file (sort keys(%seen)) { - print $file, "\en"; - } - -.fi -.Ip "substr(EXPR,OFFSET,LEN)" 8 2 -.Ip "substr(EXPR,OFFSET)" 8 2 -Extracts a substring out of EXPR and returns it. -First character is at offset 0, or whatever you've set $[ to. -If OFFSET is negative, starts that far from the end of the string. -If LEN is omitted, returns everything to the end of the string. -You can use the substr() function as an lvalue, in which case EXPR must -be an lvalue. -If you assign something shorter than LEN, the string will shrink, and -if you assign something longer than LEN, the string will grow to accommodate it. -To keep the string the same length you may need to pad or chop your value using -sprintf(). -.Ip "symlink(OLDFILE,NEWFILE)" 8 2 -Creates a new filename symbolically linked to the old filename. -Returns 1 for success, 0 otherwise. -On systems that don't support symbolic links, produces a fatal error at -run time. -To check for that, use eval: -.nf - - $symlink_exists = (eval \'symlink("","");\', $@ eq \'\'); - -.fi -.Ip "syscall(LIST)" 8 6 -.Ip "syscall LIST" 8 -Calls the system call specified as the first element of the list, passing -the remaining elements as arguments to the system call. -If unimplemented, produces a fatal error. -The arguments are interpreted as follows: if a given argument is numeric, -the argument is passed as an int. -If not, the pointer to the string value is passed. -You are responsible to make sure a string is pre-extended long enough -to receive any result that might be written into a string. -If your integer arguments are not literals and have never been interpreted -in a numeric context, you may need to add 0 to them to force them to look -like numbers. -.nf - - require 'syscall.ph'; # may need to run h2ph - syscall(&SYS_write, fileno(STDOUT), "hi there\en", 9); - -.fi -.Ip "sysread(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5 -.Ip "sysread(FILEHANDLE,SCALAR,LENGTH)" 8 5 -Attempts to read LENGTH bytes of data into variable SCALAR from the specified -FILEHANDLE, using the system call read(2). -It bypasses stdio, so mixing this with other kinds of reads may cause -confusion. -Returns the number of bytes actually read, or undef if there was an error. -SCALAR will be grown or shrunk to the length actually read. -An OFFSET may be specified to place the read data at some other place -than the beginning of the string. -.Ip "system(LIST)" 8 6 -.Ip "system LIST" 8 -Does exactly the same thing as \*(L"exec LIST\*(R" except that a fork -is done first, and the parent process waits for the child process to complete. -Note that argument processing varies depending on the number of arguments. -The return value is the exit status of the program as returned by the wait() -call. -To get the actual exit value divide by 256. -See also -.IR exec . -.Ip "syswrite(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5 -.Ip "syswrite(FILEHANDLE,SCALAR,LENGTH)" 8 5 -Attempts to write LENGTH bytes of data from variable SCALAR to the specified -FILEHANDLE, using the system call write(2). -It bypasses stdio, so mixing this with prints may cause -confusion. -Returns the number of bytes actually written, or undef if there was an error. -An OFFSET may be specified to place the read data at some other place -than the beginning of the string. -.Ip "tell(FILEHANDLE)" 8 6 -.Ip "tell FILEHANDLE" 8 6 -.Ip "tell" 8 -Returns the current file position for FILEHANDLE. -FILEHANDLE may be an expression whose value gives the name of the actual -filehandle. -If FILEHANDLE is omitted, assumes the file last read. -.Ip "telldir(DIRHANDLE)" 8 5 -.Ip "telldir DIRHANDLE" 8 -Returns the current position of the readdir() routines on DIRHANDLE. -Value may be given to seekdir() to access a particular location in -a directory. -Has the same caveats about possible directory compaction as the corresponding -system library routine. -.Ip "tie VARIABLE,PACKAGENAME,LIST" 8 6 -This function binds a variable to a package that will provide the -implementation for the variable. -VARIABLE is the name of the variable to be enchanted. -PACKAGENAME is the name of a package implementing objects of correct type. -Any additional arguments are passed to the "new" method of the package. -Typically these are arguments such as might be passed to the dbm_open() -function of C. -.Sp -Note that functions such as keys() and values() may return huge array values -when used on large dbm files. -You may prefer to use the each() function to iterate over large dbm files. -Example: -.nf - -.ne 6 - # print out history file offsets - tie(%HIST, NDBM_File, '/usr/lib/news/history', 1, 0); - while (($key,$val) = each %HIST) { - print $key, ' = ', unpack('L',$val), "\en"; - } - untie(%HIST); - -.fi -A package implementing an associative array should have the following methods: -.nf - -.ne 7 - new objectname, LIST - DESTROY this - fetch this, key - store this, key, value - delete this, key - firstkey this - nextkey this, lastkey - -.fi -A package implementing an ordinary array should have the following methods: -.nf - -.ne 7 - new objectname, LIST - DESTROY this - fetch this, key - store this, key, value - [others TBD] - -.fi -A package implementing a scalar should have the following methods: -.nf - -.ne 4 - new objectname, LIST - DESTROY this - fetch this, - store this, value - -.fi -.Ip "time" 8 4 -Returns the number of non-leap seconds since 00:00:00 UTC, January 1, 1970. -Suitable for feeding to gmtime() and localtime(). -.Ip "times" 8 4 -Returns a four-element array giving the user and system times, in seconds, for this -process and the children of this process. -.Sp - ($user,$system,$cuser,$csystem) = times; -.Sp -.Ip "tr/SEARCHLIST/REPLACEMENTLIST/cds" 8 5 -.Ip "y/SEARCHLIST/REPLACEMENTLIST/cds" 8 -Translates all occurrences of the characters found in the search list with -the corresponding character in the replacement list. -It returns the number of characters replaced or deleted. -If no string is specified via the =~ or !~ operator, -the $_ string is translated. -(The string specified with =~ must be a scalar variable, an array element, -or an assignment to one of those, i.e. an lvalue.) -For -.I sed -devotees, -.I y -is provided as a synonym for -.IR tr . -If the SEARCHLIST is delimited by bracketing quotes, the REPLACEMENTLIST -has its own pair of quotes, which may or may not be bracketing quotes, e.g. -tr[A-Z][a-z] or tr(+-*/)/ABCD/. -.Sp -If the c modifier is specified, the SEARCHLIST character set is complemented. -If the d modifier is specified, any characters specified by SEARCHLIST that -are not found in REPLACEMENTLIST are deleted. -(Note that this is slightly more flexible than the behavior of some -.I tr -programs, which delete anything they find in the SEARCHLIST, period.) -If the s modifier is specified, sequences of characters that were translated -to the same character are squashed down to 1 instance of the character. -.Sp -If the d modifier was used, the REPLACEMENTLIST is always interpreted exactly -as specified. -Otherwise, if the REPLACEMENTLIST is shorter than the SEARCHLIST, -the final character is replicated till it is long enough. -If the REPLACEMENTLIST is null, the SEARCHLIST is replicated. -This latter is useful for counting characters in a class, or for squashing -character sequences in a class. -.Sp -Examples: -.nf - - $ARGV[1] \|=~ \|y/A\-Z/a\-z/; \h'|3i'# canonicalize to lower case - - $cnt = tr/*/*/; \h'|3i'# count the stars in $_ - - $cnt = tr/0\-9//; \h'|3i'# count the digits in $_ - - tr/a\-zA\-Z//s; \h'|3i'# bookkeeper \-> bokeper - - ($HOST = $host) =~ tr/a\-z/A\-Z/; - - y/a\-zA\-Z/ /cs; \h'|3i'# change non-alphas to single space - - tr/\e200\-\e377/\e0\-\e177/;\h'|3i'# delete 8th bit - -.fi -.Ip "truncate(FILEHANDLE,LENGTH)" 8 4 -.Ip "truncate(EXPR,LENGTH)" 8 -Truncates the file opened on FILEHANDLE, or named by EXPR, to the specified -length. -Produces a fatal error if truncate isn't implemented on your system. -.Ip "umask(EXPR)" 8 4 -.Ip "umask EXPR" 8 -.Ip "umask" 8 -Sets the umask for the process and returns the old one. -If EXPR is omitted, merely returns current umask. -.Ip "undef(EXPR)" 8 6 -.Ip "undef EXPR" 8 -.Ip "undef" 8 -Undefines the value of EXPR, which must be an lvalue. -Use only on a scalar value, an entire array, or a subroutine name (using &). -(Undef will probably not do what you expect on most predefined variables or -dbm array values.) -Always returns the undefined value. -You can omit the EXPR, in which case nothing is undefined, but you still -get an undefined value that you could, for instance, return from a subroutine. -Examples: -.nf - -.ne 6 - undef $foo; - undef $bar{'blurfl'}; - undef @ary; - undef %assoc; - undef &mysub; - return (wantarray ? () : undef) if $they_blew_it; - -.fi -.Ip "unlink(LIST)" 8 4 -.Ip "unlink LIST" 8 -Deletes a list of files. -Returns the number of files successfully deleted. -.nf - -.ne 2 - $cnt = unlink \'a\', \'b\', \'c\'; - unlink @goners; - unlink <*.bak>; - -.fi -Note: unlink will not delete directories unless you are superuser and the -.B \-U -flag is supplied to -.IR perl . -Even if these conditions are met, be warned that unlinking a directory -can inflict damage on your filesystem. -Use rmdir instead. -.Ip "unpack(TEMPLATE,EXPR)" 8 4 -Unpack does the reverse of pack: it takes a string representing -a structure and expands it out into an array value, returning the array -value. -(In a scalar context, it merely returns the first value produced.) -The TEMPLATE has the same format as in the pack function. -Here's a subroutine that does substring: -.nf - -.ne 4 - sub substr { - local($what,$where,$howmuch) = @_; - unpack("x$where a$howmuch", $what); - } - -.ne 3 -and then there's - - sub ord { unpack("c",$_[0]); } - -.fi -In addition, you may prefix a field with a %<number> to indicate that -you want a <number>-bit checksum of the items instead of the items themselves. -Default is a 16-bit checksum. -For example, the following computes the same number as the System V sum program: -.nf - -.ne 4 - while (<>) { - $checksum += unpack("%16C*", $_); - } - $checksum %= 65536; - -.fi -The following efficiently counts the number of set bits in a bit vector: -.nf - - $setbits = unpack("%32b*", $selectmask); - -.fi -.Ip "untie VARIABLE" 8 6 -Breaks the binding between a variable and a package. (See tie.) -.Ip "unshift(ARRAY,LIST)" 8 4 -Does the opposite of a -.IR shift . -Or the opposite of a -.IR push , -depending on how you look at it. -Prepends list to the front of the array, and returns the new number of elements -in the array. -.nf - - unshift(ARGV, \'\-e\') unless $ARGV[0] =~ /^\-/; - -.fi -Note the LIST is prepended whole, not one element at a time, so the prepended -elements stay in the same order. Use reverse to do the reverse. -.Ip "utime(LIST)" 8 2 -.Ip "utime LIST" 8 2 -Changes the access and modification times on each file of a list of files. -The first two elements of the list must be the NUMERICAL access and -modification times, in that order. -Returns the number of files successfully changed. -The inode modification time of each file is set to the current time. -Example of a \*(L"touch\*(R" command: -.nf - -.ne 3 - #!/usr/bin/perl - $now = time; - utime $now, $now, @ARGV; - -.fi -.Ip "values(ASSOC_ARRAY)" 8 6 -.Ip "values ASSOC_ARRAY" 8 -Returns a normal array consisting of all the values of the named associative -array. -(In a scalar context, returns the number of values.) -The values are returned in an apparently random order, but it is the same order -as either the keys() or each() function would produce on the same array. -See also keys() and each(). -.Ip "vec(EXPR,OFFSET,BITS)" 8 2 -Treats a string as a vector of unsigned integers, and returns the value -of the bitfield specified. -May also be assigned to. -BITS must be a power of two from 1 to 32. -.Sp -Vectors created with vec() can also be manipulated with the logical operators -|, & and ^, -which will assume a bit vector operation is desired when both operands are -strings. -This interpretation is not enabled unless there is at least one vec() in -your program, to protect older programs. -.Sp -To transform a bit vector into a string or array of 0's and 1's, use these: -.nf - - $bits = unpack("b*", $vector); - @bits = split(//, unpack("b*", $vector)); - -.fi -If you know the exact length in bits, it can be used in place of the *. -.Ip "wait" 8 6 -Waits for a child process to terminate and returns the pid of the deceased -process, or -1 if there are no child processes. -The status is returned in $?. -.Ip "waitpid(PID,FLAGS)" 8 6 -Waits for a particular child process to terminate and returns the pid of the deceased -process, or -1 if there is no such child process. -The status is returned in $?. -If you say -.nf - - require "sys/wait.h"; - .\|.\|. - waitpid(-1,&WNOHANG); - -.fi -then you can do a non-blocking wait for any process. Non-blocking wait -is only available on machines supporting either the -.I waitpid (2) -or -.I wait4 (2) -system calls. -However, waiting for a particular pid with FLAGS of 0 is implemented -everywhere. (Perl emulates the system call by remembering the status -values of processes that have exited but have not been harvested by the -Perl script yet.) -.Ip "wantarray" 8 4 -Returns true if the context of the currently executing subroutine -is looking for an array value. -Returns false if the context is looking for a scalar. -.nf - - return wantarray ? () : undef; - -.fi -.Ip "warn(LIST)" 8 4 -.Ip "warn LIST" 8 -Produces a message on STDERR just like \*(L"die\*(R", but doesn't exit. -.Ip "write(FILEHANDLE)" 8 6 -.Ip "write(EXPR)" 8 -.Ip "write" 8 -Writes a formatted record (possibly multi-line) to the specified file, -using the format associated with that file. -By default the format for a file is the one having the same name is the -filehandle, but the format for the current output channel (see -.IR select ) -may be set explicitly -by assigning the name of the format to the $~ variable. -.Sp -Top of form processing is handled automatically: -if there is insufficient room on the current page for the formatted -record, the page is advanced by writing a form feed, -a special top-of-page format is used -to format the new page header, and then the record is written. -By default the top-of-page format is the name of the filehandle with -\*(L"_TOP\*(R" appended, but it may be dynamically set to the -format of your choice by assigning the name to the $^ variable while -the filehandle is selected. -The number of lines remaining on the current page is in variable $-, which -can be set to 0 to force a new page. -.Sp -If FILEHANDLE is unspecified, output goes to the current default output channel, -which starts out as -.I STDOUT -but may be changed by the -.I select -operator. -If the FILEHANDLE is an EXPR, then the expression is evaluated and the -resulting string is used to look up the name of the FILEHANDLE at run time. -For more on formats, see the section on formats later on. -.Sp -Note that write is NOT the opposite of read. -.Sh "Precedence" -.I Perl -operators have the following associativity and precedence: -.nf - -nonassoc\h'|1i'print printf exec system sort reverse -\h'1.5i'chmod chown kill unlink utime die return -left\h'|1i', -right\h'|1i'= += \-= *= etc. -right\h'|1i'?: -nonassoc\h'|1i'.\|. -left\h'|1i'|| -left\h'|1i'&& -left\h'|1i'| ^ -left\h'|1i'& -nonassoc\h'|1i'== != <=> eq ne cmp -nonassoc\h'|1i'< > <= >= lt gt le ge -nonassoc\h'|1i'chdir exit eval reset sleep rand umask -nonassoc\h'|1i'\-r \-w \-x etc. -left\h'|1i'<< >> -left\h'|1i'+ \- . -left\h'|1i'* / % x -left\h'|1i'=~ !~ -right\h'|1i'! ~ and unary minus -right\h'|1i'** -nonassoc\h'|1i'++ \-\|\- -left\h'|1i'\*(L'(\*(R' - -.fi -As mentioned earlier, if any list operator (print, etc.) or -any unary operator (chdir, etc.) -is followed by a left parenthesis as the next token on the same line, -the operator and arguments within parentheses are taken to -be of highest precedence, just like a normal function call. -Examples: -.nf - - chdir $foo || die;\h'|3i'# (chdir $foo) || die - chdir($foo) || die;\h'|3i'# (chdir $foo) || die - chdir ($foo) || die;\h'|3i'# (chdir $foo) || die - chdir +($foo) || die;\h'|3i'# (chdir $foo) || die - -but, because * is higher precedence than ||: - - chdir $foo * 20;\h'|3i'# chdir ($foo * 20) - chdir($foo) * 20;\h'|3i'# (chdir $foo) * 20 - chdir ($foo) * 20;\h'|3i'# (chdir $foo) * 20 - chdir +($foo) * 20;\h'|3i'# chdir ($foo * 20) - - rand 10 * 20;\h'|3i'# rand (10 * 20) - rand(10) * 20;\h'|3i'# (rand 10) * 20 - rand (10) * 20;\h'|3i'# (rand 10) * 20 - rand +(10) * 20;\h'|3i'# rand (10 * 20) - -.fi -In the absence of parentheses, -the precedence of list operators such as print, sort or chmod is -either very high or very low depending on whether you look at the left -side of operator or the right side of it. -For example, in -.nf - - @ary = (1, 3, sort 4, 2); - print @ary; # prints 1324 - -.fi -the commas on the right of the sort are evaluated before the sort, but -the commas on the left are evaluated after. -In other words, list operators tend to gobble up all the arguments that -follow them, and then act like a simple term with regard to the preceding -expression. -Note that you have to be careful with parens: -.nf - -.ne 3 - # These evaluate exit before doing the print: - print($foo, exit); # Obviously not what you want. - print $foo, exit; # Nor is this. - -.ne 4 - # These do the print before evaluating exit: - (print $foo), exit; # This is what you want. - print($foo), exit; # Or this. - print ($foo), exit; # Or even this. - -Also note that - - print ($foo & 255) + 1, "\en"; - -.fi -probably doesn't do what you expect at first glance. -.Sh "Subroutines" -A subroutine may be declared as follows: -.nf - - sub NAME BLOCK - -.fi -.PP -Any arguments passed to the routine come in as array @_, -that is ($_[0], $_[1], .\|.\|.). -The array @_ is a local array, but its values are references to the -actual scalar parameters. -The return value of the subroutine is the value of the last expression -evaluated, and can be either an array value or a scalar value. -Alternately, a return statement may be used to specify the returned value and -exit the subroutine. -To create local variables see the -.I local -operator. -.PP -A subroutine is called using the -.I do -operator or the & operator. -.nf - -.ne 12 -Example: - - sub MAX { - local($max) = pop(@_); - foreach $foo (@_) { - $max = $foo \|if \|$max < $foo; - } - $max; - } - - .\|.\|. - $bestday = &MAX($mon,$tue,$wed,$thu,$fri); - -.ne 21 -Example: - - # get a line, combining continuation lines - # that start with whitespace - sub get_line { - $thisline = $lookahead; - line: while ($lookahead = <STDIN>) { - if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) { - $thisline \|.= \|$lookahead; - } - else { - last line; - } - } - $thisline; - } - - $lookahead = <STDIN>; # get first line - while ($_ = do get_line(\|)) { - .\|.\|. - } - -.fi -.nf -.ne 6 -Use array assignment to a local list to name your formal arguments: - - sub maybeset { - local($key, $value) = @_; - $foo{$key} = $value unless $foo{$key}; - } - -.fi -This also has the effect of turning call-by-reference into call-by-value, -since the assignment copies the values. -.Sp -Subroutines may be called recursively. -If a subroutine is called using the & form, the argument list is optional. -If omitted, no @_ array is set up for the subroutine; the @_ array at the -time of the call is visible to subroutine instead. -.nf - - do foo(1,2,3); # pass three arguments - &foo(1,2,3); # the same - - do foo(); # pass a null list - &foo(); # the same - &foo; # pass no arguments\*(--more efficient - -.fi -.Sh "Passing By Reference" -Sometimes you don't want to pass the value of an array to a subroutine but -rather the name of it, so that the subroutine can modify the global copy -of it rather than working with a local copy. -In perl you can refer to all the objects of a particular name by prefixing -the name with a star: *foo. -When evaluated, it produces a scalar value that represents all the objects -of that name, including any filehandle, format or subroutine. -When assigned to within a local() operation, it causes the name mentioned -to refer to whatever * value was assigned to it. -Example: -.nf - - sub doubleary { - local(*someary) = @_; - foreach $elem (@someary) { - $elem *= 2; - } - } - do doubleary(*foo); - do doubleary(*bar); - -.fi -Assignment to *name is currently recommended only inside a local(). -You can actually assign to *name anywhere, but the previous referent of -*name may be stranded forever. -This may or may not bother you. -.Sp -Note that scalars are already passed by reference, so you can modify scalar -arguments without using this mechanism by referring explicitly to the $_[nnn] -in question. -You can modify all the elements of an array by passing all the elements -as scalars, but you have to use the * mechanism to push, pop or change the -size of an array. -The * mechanism will probably be more efficient in any case. -.Sp -Since a *name value contains unprintable binary data, if it is used as -an argument in a print, or as a %s argument in a printf or sprintf, it -then has the value '*name', just so it prints out pretty. -.Sp -Even if you don't want to modify an array, this mechanism is useful for -passing multiple arrays in a single LIST, since normally the LIST mechanism -will merge all the array values so that you can't extract out the -individual arrays. -.Sh "Regular Expressions" -The patterns used in pattern matching are regular expressions such as -those supplied in the Version 8 regexp routines. -(In fact, the routines are derived from Henry Spencer's freely redistributable -reimplementation of the V8 routines.) -In addition, \ew matches an alphanumeric character (including \*(L"_\*(R") and \eW a nonalphanumeric. -Word boundaries may be matched by \eb, and non-boundaries by \eB. -A whitespace character is matched by \es, non-whitespace by \eS. -A numeric character is matched by \ed, non-numeric by \eD. -You may use \ew, \es and \ed within character classes. -Also, \en, \er, \ef, \et and \eNNN have their normal interpretations. -Within character classes \eb represents backspace rather than a word boundary. -Alternatives may be separated by |. -The bracketing construct \|(\ .\|.\|.\ \|) may also be used, in which case \e<digit> -matches the digit'th substring. -(Outside of the pattern, always use $ instead of \e in front of the digit. -The scope of $<digit> (and $\`, $& and $\') -extends to the end of the enclosing BLOCK or eval string, or to -the next pattern match with subexpressions. -The \e<digit> notation sometimes works outside the current pattern, but should -not be relied upon.) -You may have as many parentheses as you wish. If you have more than 9 -substrings, the variables $10, $11, ... refer to the corresponding -substring. Within the pattern, \e10, \e11, -etc. refer back to substrings if there have been at least that many left parens -before the backreference. Otherwise (for backward compatibilty) \e10 -is the same as \e010, a backspace, -and \e11 the same as \e011, a tab. -And so on. -(\e1 through \e9 are always backreferences.) -.PP -$+ returns whatever the last bracket match matched. -$& returns the entire matched string. -($0 used to return the same thing, but not any more.) -$\` returns everything before the matched string. -$\' returns everything after the matched string. -Examples: -.nf - - s/\|^\|([^ \|]*\|) \|*([^ \|]*\|)\|/\|$2 $1\|/; # swap first two words - -.ne 5 - if (/\|Time: \|(.\|.\|):\|(.\|.\|):\|(.\|.\|)\|/\|) { - $hours = $1; - $minutes = $2; - $seconds = $3; - } - -.fi -By default, the ^ character is only guaranteed to match at the beginning -of the string, -the $ character only at the end (or before the newline at the end) -and -.I perl -does certain optimizations with the assumption that the string contains -only one line. -The behavior of ^ and $ on embedded newlines will be inconsistent. -You may, however, wish to treat a string as a multi-line buffer, such that -the ^ will match after any newline within the string, and $ will match -before any newline. -At the cost of a little more overhead, you can do this by setting the variable -$* to 1. -Setting it back to 0 makes -.I perl -revert to its old behavior. -.PP -To facilitate multi-line substitutions, the . character never matches a newline -(even when $* is 0). -In particular, the following leaves a newline on the $_ string: -.nf - - $_ = <STDIN>; - s/.*(some_string).*/$1/; - -If the newline is unwanted, try one of - - s/.*(some_string).*\en/$1/; - s/.*(some_string)[^\e000]*/$1/; - s/.*(some_string)(.|\en)*/$1/; - chop; s/.*(some_string).*/$1/; - /(some_string)/ && ($_ = $1); - -.fi -Any item of a regular expression may be followed with digits in curly brackets -of the form {n,m}, where n gives the minimum number of times to match the item -and m gives the maximum. -The form {n} is equivalent to {n,n} and matches exactly n times. -The form {n,} matches n or more times. -(If a curly bracket occurs in any other context, it is treated as a regular -character.) -The * modifier is equivalent to {0,}, the + modifier to {1,} and the ? modifier -to {0,1}. -There is no limit to the size of n or m, but large numbers will chew up -more memory. -.Sp -You will note that all backslashed metacharacters in -.I perl -are alphanumeric, -such as \eb, \ew, \en. -Unlike some other regular expression languages, there are no backslashed -symbols that aren't alphanumeric. -So anything that looks like \e\e, \e(, \e), \e<, \e>, \e{, or \e} is always -interpreted as a literal character, not a metacharacter. -This makes it simple to quote a string that you want to use for a pattern -but that you are afraid might contain metacharacters. -Simply quote all the non-alphanumeric characters: -.nf - - $pattern =~ s/(\eW)/\e\e$1/g; - -.fi -.Sh "Formats" -Output record formats for use with the -.I write -operator may declared as follows: -.nf - -.ne 3 - format NAME = - FORMLIST - . - -.fi -If name is omitted, format \*(L"STDOUT\*(R" is defined. -FORMLIST consists of a sequence of lines, each of which may be of one of three -types: -.Ip 1. 4 -A comment. -.Ip 2. 4 -A \*(L"picture\*(R" line giving the format for one output line. -.Ip 3. 4 -An argument line supplying values to plug into a picture line. -.PP -Picture lines are printed exactly as they look, except for certain fields -that substitute values into the line. -Each picture field starts with either @ or ^. -The @ field (not to be confused with the array marker @) is the normal -case; ^ fields are used -to do rudimentary multi-line text block filling. -The length of the field is supplied by padding out the field -with multiple <, >, or | characters to specify, respectively, left justification, -right justification, or centering. -As an alternate form of right justification, -you may also use # characters (with an optional .) to specify a numeric field. -(Use of ^ instead of @ causes the field to be blanked if undefined.) -If any of the values supplied for these fields contains a newline, only -the text up to the newline is printed. -The special field @* can be used for printing multi-line values. -It should appear by itself on a line. -.PP -The values are specified on the following line, in the same order as -the picture fields. -The values should be separated by commas. -.PP -Picture fields that begin with ^ rather than @ are treated specially. -The value supplied must be a scalar variable name which contains a text -string. -.I Perl -puts as much text as it can into the field, and then chops off the front -of the string so that the next time the variable is referenced, -more of the text can be printed. -Normally you would use a sequence of fields in a vertical stack to print -out a block of text. -If you like, you can end the final field with .\|.\|., which will appear in the -output if the text was too long to appear in its entirety. -You can change which characters are legal to break on by changing the -variable $: to a list of the desired characters. -.PP -Since use of ^ fields can produce variable length records if the text to be -formatted is short, you can suppress blank lines by putting the tilde (~) -character anywhere in the line. -(Normally you should put it in the front if possible, for visibility.) -The tilde will be translated to a space upon output. -If you put a second tilde contiguous to the first, the line will be repeated -until all the fields on the line are exhausted. -(If you use a field of the @ variety, the expression you supply had better -not give the same value every time forever!) -.PP -Examples: -.nf -.lg 0 -.cs R 25 -.ft C - -.ne 10 -# a report on the /etc/passwd file -format STDOUT_TOP = -\& Passwd File -Name Login Office Uid Gid Home ------------------------------------------------------------------- -\&. -format STDOUT = -@<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<< -$name, $login, $office,$uid,$gid, $home -\&. - -.ne 29 -# a report from a bug report form -format STDOUT_TOP = -\& Bug Reports -@<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>> -$system, $%, $date ------------------------------------------------------------------- -\&. -format STDOUT = -Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $subject -Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $index, $description -Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $priority, $date, $description -From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $from, $description -Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $programmer, $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<... -\& $description -\&. - -.ft R -.cs R -.lg -.fi -It is possible to intermix prints with writes on the same output channel, -but you'll have to handle $\- (lines left on the page) yourself. -.PP -If you are printing lots of fields that are usually blank, you should consider -using the reset operator between records. -Not only is it more efficient, but it can prevent the bug of adding another -field and forgetting to zero it. -.Sh "Interprocess Communication" -The IPC facilities of perl are built on the Berkeley socket mechanism. -If you don't have sockets, you can ignore this section. -The calls have the same names as the corresponding system calls, -but the arguments tend to differ, for two reasons. -First, perl file handles work differently than C file descriptors. -Second, perl already knows the length of its strings, so you don't need -to pass that information. -Here is a sample client (untested): -.nf - - ($them,$port) = @ARGV; - $port = 2345 unless $port; - $them = 'localhost' unless $them; - - $SIG{'INT'} = 'dokill'; - sub dokill { kill 9,$child if $child; } - - require 'sys/socket.ph'; - - $sockaddr = 'S n a4 x8'; - chop($hostname = `hostname`); - - ($name, $aliases, $proto) = getprotobyname('tcp'); - ($name, $aliases, $port) = getservbyname($port, 'tcp') - unless $port =~ /^\ed+$/; -.ie t \{\ - ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname); -'br\} -.el \{\ - ($name, $aliases, $type, $len, $thisaddr) = - gethostbyname($hostname); -'br\} - ($name, $aliases, $type, $len, $thataddr) = gethostbyname($them); - - $this = pack($sockaddr, &AF_INET, 0, $thisaddr); - $that = pack($sockaddr, &AF_INET, $port, $thataddr); - - socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; - bind(S, $this) || die "bind: $!"; - connect(S, $that) || die "connect: $!"; - - select(S); $| = 1; select(stdout); - - if ($child = fork) { - while (<>) { - print S; - } - sleep 3; - do dokill(); - } - else { - while (<S>) { - print; - } - } - -.fi -And here's a server: -.nf - - ($port) = @ARGV; - $port = 2345 unless $port; - - require 'sys/socket.ph'; - - $sockaddr = 'S n a4 x8'; - - ($name, $aliases, $proto) = getprotobyname('tcp'); - ($name, $aliases, $port) = getservbyname($port, 'tcp') - unless $port =~ /^\ed+$/; - - $this = pack($sockaddr, &AF_INET, $port, "\e0\e0\e0\e0"); - - select(NS); $| = 1; select(stdout); - - socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; - bind(S, $this) || die "bind: $!"; - listen(S, 5) || die "connect: $!"; - - select(S); $| = 1; select(stdout); - - for (;;) { - print "Listening again\en"; - ($addr = accept(NS,S)) || die $!; - print "accept ok\en"; - - ($af,$port,$inetaddr) = unpack($sockaddr,$addr); - @inetaddr = unpack('C4',$inetaddr); - print "$af $port @inetaddr\en"; - - while (<NS>) { - print; - print NS; - } - } - -.fi -.Sh "Predefined Names" -The following names have special meaning to -.IR perl . -I could have used alphabetic symbols for some of these, but I didn't want -to take the chance that someone would say reset \*(L"a\-zA\-Z\*(R" and wipe them all -out. -You'll just have to suffer along with these silly symbols. -Most of them have reasonable mnemonics, or analogues in one of the shells. -.Ip $_ 8 -The default input and pattern-searching space. -The following pairs are equivalent: -.nf - -.ne 2 - while (<>) {\|.\|.\|. # only equivalent in while! - while ($_ = <>) {\|.\|.\|. - -.ne 2 - /\|^Subject:/ - $_ \|=~ \|/\|^Subject:/ - -.ne 2 - y/a\-z/A\-Z/ - $_ =~ y/a\-z/A\-Z/ - -.ne 2 - chop - chop($_) - -.fi -(Mnemonic: underline is understood in certain operations.) -.Ip $. 8 -The current input line number of the last filehandle that was read. -Readonly. -Remember that only an explicit close on the filehandle resets the line number. -Since <> never does an explicit close, line numbers increase across ARGV files -(but see examples under eof). -(Mnemonic: many programs use . to mean the current line number.) -.Ip $/ 8 -The input record separator, newline by default. -Works like -.IR awk 's -RS variable, including treating blank lines as delimiters -if set to the null string. -You may set it to a multicharacter string to match a multi-character -delimiter. -Note that setting it to "\en\en" means something slightly different -than setting it to "", if the file contains consecutive blank lines. -Setting it to "" will treat two or more consecutive blank lines as a single -blank line. -Setting it to "\en\en" will blindly assume that the next input character -belongs to the next paragraph, even if it's a newline. -(Mnemonic: / is used to delimit line boundaries when quoting poetry.) -.Ip $, 8 -The output field separator for the print operator. -Ordinarily the print operator simply prints out the comma separated fields -you specify. -In order to get behavior more like -.IR awk , -set this variable as you would set -.IR awk 's -OFS variable to specify what is printed between fields. -(Mnemonic: what is printed when there is a , in your print statement.) -.Ip $"" 8 -This is like $, except that it applies to array values interpolated into -a double-quoted string (or similar interpreted string). -Default is a space. -(Mnemonic: obvious, I think.) -.Ip $\e 8 -The output record separator for the print operator. -Ordinarily the print operator simply prints out the comma separated fields -you specify, with no trailing newline or record separator assumed. -In order to get behavior more like -.IR awk , -set this variable as you would set -.IR awk 's -ORS variable to specify what is printed at the end of the print. -(Mnemonic: you set $\e instead of adding \en at the end of the print. -Also, it's just like /, but it's what you get \*(L"back\*(R" from -.IR perl .) -.Ip $# 8 -The output format for printed numbers. -This variable is a half-hearted attempt to emulate -.IR awk 's -OFMT variable. -There are times, however, when -.I awk -and -.I perl -have differing notions of what -is in fact numeric. -Also, the initial value is %.20g rather than %.6g, so you need to set $# -explicitly to get -.IR awk 's -value. -(Mnemonic: # is the number sign.) -.Ip $% 8 -The current page number of the currently selected output channel. -(Mnemonic: % is page number in nroff.) -.Ip $= 8 -The current page length (printable lines) of the currently selected output -channel. -Default is 60. -(Mnemonic: = has horizontal lines.) -.Ip $\- 8 -The number of lines left on the page of the currently selected output channel. -(Mnemonic: lines_on_page \- lines_printed.) -.Ip $~ 8 -The name of the current report format for the currently selected output -channel. -Default is name of the filehandle. -(Mnemonic: brother to $^.) -.Ip $^ 8 -The name of the current top-of-page format for the currently selected output -channel. -Default is name of the filehandle with \*(L"_TOP\*(R" appended. -(Mnemonic: points to top of page.) -.Ip $| 8 -If set to nonzero, forces a flush after every write or print on the currently -selected output channel. -Default is 0. -Note that -.I 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 -.I perl -script under rsh and want to see the -output as it's happening. -(Mnemonic: when you want your pipes to be piping hot.) -.Ip $$ 8 -The process number of the -.I perl -running this script. -(Mnemonic: same as shells.) -.Ip $? 8 -The status returned by the last pipe close, backtick (\`\`) command or -.I system -operator. -Note that this is the status word returned by the wait() system -call, so the exit value of the subprocess is actually ($? >> 8). -$? & 255 gives which signal, if any, the process died from, and whether -there was a core dump. -(Mnemonic: similar to sh and ksh.) -.Ip $& 8 4 -The string matched by the last successful pattern match -(not counting any matches hidden -within a BLOCK or eval enclosed by the current BLOCK). -(Mnemonic: like & in some editors.) -.Ip $\` 8 4 -The string preceding whatever was matched by the last successful pattern match -(not counting any matches hidden within a BLOCK or eval enclosed by the current -BLOCK). -(Mnemonic: \` often precedes a quoted string.) -.Ip $\' 8 4 -The string following whatever was matched by the last successful pattern match -(not counting any matches hidden within a BLOCK or eval enclosed by the current -BLOCK). -(Mnemonic: \' often follows a quoted string.) -Example: -.nf - -.ne 3 - $_ = \'abcdefghi\'; - /def/; - print "$\`:$&:$\'\en"; # prints abc:def:ghi - -.fi -.Ip $+ 8 4 -The last bracket matched by the last search pattern. -This is useful if you don't know which of a set of alternative patterns -matched. -For example: -.nf - - /Version: \|(.*\|)|Revision: \|(.*\|)\|/ \|&& \|($rev = $+); - -.fi -(Mnemonic: be positive and forward looking.) -.Ip $* 8 2 -Set to 1 to do multiline matching within a string, 0 to tell -.I perl -that it can assume that strings contain a single line, for the purpose -of optimizing pattern matches. -Pattern matches on strings containing multiple newlines can produce confusing -results when $* is 0. -Default is 0. -(Mnemonic: * matches multiple things.) -Note that this variable only influences the interpretation of ^ and $. -A literal newline can be searched for even when $* == 0. -.Ip $0 8 -Contains the name of the file containing the -.I perl -script being executed. -Assigning to $0 modifies the argument area that the ps(1) program sees. -(Mnemonic: same as sh and ksh.) -.Ip $<digit> 8 -Contains the subpattern from the corresponding set of parentheses in the last -pattern matched, not counting patterns matched in nested blocks that have -been exited already. -(Mnemonic: like \edigit.) -.Ip $[ 8 2 -The index of the first element in an array, and of the first character in -a substring. -Default is 0, but you could set it to 1 to make -.I perl -behave more like -.I awk -(or Fortran) -when subscripting and when evaluating the index() and substr() functions. -(Mnemonic: [ begins subscripts.) -.Ip $] 8 2 -The string printed out when you say \*(L"perl -v\*(R". -It can be used to determine at the beginning of a script whether the perl -interpreter executing the script is in the right range of versions. -If used in a numeric context, returns the version + patchlevel / 1000. -Example: -.nf - -.ne 8 - # see if getc is available - ($version,$patchlevel) = - $] =~ /(\ed+\e.\ed+).*\enPatch level: (\ed+)/; - print STDERR "(No filename completion available.)\en" - if $version * 1000 + $patchlevel < 2016; - -or, used numerically, - - warn "No checksumming!\en" if $] < 3.019; - -.fi -(Mnemonic: Is this version of perl in the right bracket?) -.Ip $; 8 2 -The subscript separator for multi-dimensional array emulation. -If you refer to an associative array element as -.nf - $foo{$a,$b,$c} - -it really means - - $foo{join($;, $a, $b, $c)} - -But don't put - - @foo{$a,$b,$c} # a slice\*(--note the @ - -which means - - ($foo{$a},$foo{$b},$foo{$c}) - -.fi -Default is "\e034", the same as SUBSEP in -.IR awk . -Note that if your keys contain binary data there might not be any safe -value for $;. -(Mnemonic: comma (the syntactic subscript separator) is a semi-semicolon. -Yeah, I know, it's pretty lame, but $, is already taken for something more -important.) -.Ip $! 8 2 -If used in a numeric context, yields the current value of errno, with all the -usual caveats. -(This means that you shouldn't depend on the value of $! to be anything -in particular unless you've gotten a specific error return indicating a -system error.) -If used in a string context, yields the corresponding system error string. -You can assign to $! in order to set errno -if, for instance, you want $! to return the string for error n, or you want -to set the exit value for the die operator. -(Mnemonic: What just went bang?) -.Ip $@ 8 2 -The perl syntax error message from the last eval command. -If null, the last eval parsed and executed correctly (although the operations -you invoked may have failed in the normal fashion). -(Mnemonic: Where was the syntax error \*(L"at\*(R"?) -.Ip $< 8 2 -The real uid of this process. -(Mnemonic: it's the uid you came FROM, if you're running setuid.) -.Ip $> 8 2 -The effective uid of this process. -Example: -.nf - -.ne 2 - $< = $>; # set real uid to the effective uid - ($<,$>) = ($>,$<); # swap real and effective uid - -.fi -(Mnemonic: it's the uid you went TO, if you're running setuid.) -Note: $< and $> can only be swapped on machines supporting setreuid(). -.Ip $( 8 2 -The real gid of this process. -If you are on a machine that supports membership in multiple groups -simultaneously, gives a space separated list of groups you are in. -The first number is the one returned by getgid(), and the subsequent ones -by getgroups(), one of which may be the same as the first number. -(Mnemonic: parentheses are used to GROUP things. -The real gid is the group you LEFT, if you're running setgid.) -.Ip $) 8 2 -The effective gid of this process. -If you are on a machine that supports membership in multiple groups -simultaneously, gives a space separated list of groups you are in. -The first number is the one returned by getegid(), and the subsequent ones -by getgroups(), one of which may be the same as the first number. -(Mnemonic: parentheses are used to GROUP things. -The effective gid is the group that's RIGHT for you, if you're running setgid.) -.Sp -Note: $<, $>, $( and $) can only be set on machines that support the -corresponding set[re][ug]id() routine. -$( and $) can only be swapped on machines supporting setregid(). -.Ip $: 8 2 -The current set of characters after which a string may be broken to -fill continuation fields (starting with ^) in a format. -Default is "\ \en-", to break on whitespace or hyphens. -(Mnemonic: a \*(L"colon\*(R" in poetry is a part of a line.) -.Ip $^A 8 2 -The current value of the write accumulator for format lines. -.Ip $^D 8 2 -The current value of the debugging flags. -(Mnemonic: value of -.B \-D -switch.) -.Ip $^F 8 2 -The maximum system file descriptor, ordinarily 2. System file descriptors -are passed to subprocesses, while higher file descriptors are not. -During an open, system file descriptors are preserved even if the open -fails. Ordinary file descriptors are closed before the open is attempted. -.Ip $^I 8 2 -The current value of the inplace-edit extension. -Use undef to disable inplace editing. -(Mnemonic: value of -.B \-i -switch.) -.Ip $^L 8 2 -What formats output to perform a formfeed. Default is \ef. -.Ip $^P 8 2 -The internal flag that the debugger clears so that it doesn't -debug itself. You could conceivable disable debugging yourself -by clearing it. -.Ip $^T 8 2 -The time at which the script began running, in seconds since the epoch. -The values returned by the -.B \-M , -.B \-A -and -.B \-C -filetests are based on this value. -.Ip $^W 8 2 -The current value of the warning switch. -(Mnemonic: related to the -.B \-w -switch.) -.Ip $^X 8 2 -The name that Perl itself was executed as, from argv[0]. -.Ip $ARGV 8 3 -contains the name of the current file when reading from <>. -.Ip @ARGV 8 3 -The array ARGV contains the command line arguments intended for the script. -Note that $#ARGV is the generally number of arguments minus one, since -$ARGV[0] is the first argument, NOT the command name. -See $0 for the command name. -.Ip @INC 8 3 -The array INC contains the list of places to look for -.I perl -scripts to be -evaluated by the \*(L"do EXPR\*(R" command or the \*(L"require\*(R" command. -It initially consists of the arguments to any -.B \-I -command line switches, followed -by the default -.I perl -library, probably \*(L"/usr/local/lib/perl\*(R", -followed by \*(L".\*(R", to represent the current directory. -.Ip %INC 8 3 -The associative array INC contains entries for each filename that has -been included via \*(L"do\*(R" or \*(L"require\*(R". -The key is the filename you specified, and the value is the location of -the file actually found. -The \*(L"require\*(R" command uses this array to determine whether -a given file has already been included. -.Ip $ENV{expr} 8 2 -The associative array ENV contains your current environment. -Setting a value in ENV changes the environment for child processes. -.Ip $SIG{expr} 8 2 -The associative array SIG is used to set signal handlers for various signals. -Example: -.nf - -.ne 12 - sub handler { # 1st argument is signal name - local($sig) = @_; - print "Caught a SIG$sig\-\|\-shutting down\en"; - close(LOG); - exit(0); - } - - $SIG{\'INT\'} = \'handler\'; - $SIG{\'QUIT\'} = \'handler\'; - .\|.\|. - $SIG{\'INT\'} = \'DEFAULT\'; # restore default action - $SIG{\'QUIT\'} = \'IGNORE\'; # ignore SIGQUIT - -.fi -The SIG array only contains values for the signals actually set within -the perl script. -.Sh "Packages" -Perl provides a mechanism for alternate namespaces to protect packages from -stomping on each others variables. -By default, a perl script starts compiling into the package known as \*(L"main\*(R". -By use of the -.I package -declaration, you can switch namespaces. -The scope of the package declaration is from the declaration itself to the end -of the enclosing block (the same scope as the local() operator). -Typically it would be the first declaration in a file to be included by -the \*(L"require\*(R" operator. -You can switch into a package in more than one place; it merely influences -which symbol table is used by the compiler for the rest of that block. -You can refer to variables and filehandles in other packages by prefixing -the identifier with the package name and a single quote. -If the package name is null, the \*(L"main\*(R" package as assumed. -.PP -Only identifiers starting with letters are stored in the packages symbol -table. -All other symbols are kept in package \*(L"main\*(R". -In addition, the identifiers STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV, INC -and SIG are forced to be in package \*(L"main\*(R", even when used for -other purposes than their built-in one. -Note also that, if you have a package called \*(L"m\*(R", \*(L"s\*(R" -or \*(L"y\*(R", the you can't use the qualified form of an identifier since it -will be interpreted instead as a pattern match, a substitution -or a translation. -.PP -Eval'ed strings are compiled in the package in which the eval was compiled -in. -(Assignments to $SIG{}, however, assume the signal handler specified is in the -main package. -Qualify the signal handler name if you wish to have a signal handler in -a package.) -For an example, examine perldb.pl in the perl library. -It initially switches to the DB package so that the debugger doesn't interfere -with variables in the script you are trying to debug. -At various points, however, it temporarily switches back to the main package -to evaluate various expressions in the context of the main package. -.PP -The symbol table for a package happens to be stored in the associative array -of that name prepended with an underscore. -The value in each entry of the associative array is -what you are referring to when you use the *name notation. -In fact, the following have the same effect (in package main, anyway), -though the first is more -efficient because it does the symbol table lookups at compile time: -.nf - -.ne 2 - local(*foo) = *bar; - local($_main{'foo'}) = $_main{'bar'}; - -.fi -You can use this to print out all the variables in a package, for instance. -Here is dumpvar.pl from the perl library: -.nf -.ne 11 - package dumpvar; - - sub main'dumpvar { - \& ($package) = @_; - \& local(*stab) = eval("*_$package"); - \& while (($key,$val) = each(%stab)) { - \& { - \& local(*entry) = $val; - \& if (defined $entry) { - \& print "\e$$key = '$entry'\en"; - \& } -.ne 7 - \& if (defined @entry) { - \& print "\e@$key = (\en"; - \& foreach $num ($[ .. $#entry) { - \& print " $num\et'",$entry[$num],"'\en"; - \& } - \& print ")\en"; - \& } -.ne 10 - \& if ($key ne "_$package" && defined %entry) { - \& print "\e%$key = (\en"; - \& foreach $key (sort keys(%entry)) { - \& print " $key\et'",$entry{$key},"'\en"; - \& } - \& print ")\en"; - \& } - \& } - \& } - } - -.fi -Note that, even though the subroutine is compiled in package dumpvar, the -name of the subroutine is qualified so that its name is inserted into package -\*(L"main\*(R". -.Sh "Style" -Each programmer will, of course, have his or her own preferences in regards -to formatting, but there are some general guidelines that will make your -programs easier to read. -.Ip 1. 4 4 -Just because you CAN do something a particular way doesn't mean that -you SHOULD do it that way. -.I Perl -is designed to give you several ways to do anything, so consider picking -the most readable one. -For instance - - open(FOO,$foo) || die "Can't open $foo: $!"; - -is better than - - die "Can't open $foo: $!" unless open(FOO,$foo); - -because the second way hides the main point of the statement in a -modifier. -On the other hand - - print "Starting analysis\en" if $verbose; - -is better than - - $verbose && print "Starting analysis\en"; - -since the main point isn't whether the user typed -v or not. -.Sp -Similarly, just because an operator lets you assume default arguments -doesn't mean that you have to make use of the defaults. -The defaults are there for lazy systems programmers writing one-shot -programs. -If you want your program to be readable, consider supplying the argument. -.Sp -Along the same lines, just because you -.I can -omit parentheses in many places doesn't mean that you ought to: -.nf - - return print reverse sort num values array; - return print(reverse(sort num (values(%array)))); - -.fi -When in doubt, parenthesize. -At the very least it will let some poor schmuck bounce on the % key in vi. -.Sp -Even if you aren't in doubt, consider the mental welfare of the person who -has to maintain the code after you, and who will probably put parens in -the wrong place. -.Ip 2. 4 4 -Don't go through silly contortions to exit a loop at the top or the -bottom, when -.I perl -provides the "last" operator so you can exit in the middle. -Just outdent it a little to make it more visible: -.nf - -.ne 7 - line: - for (;;) { - statements; - last line if $foo; - next line if /^#/; - statements; - } - -.fi -.Ip 3. 4 4 -Don't be afraid to use loop labels\*(--they're there to enhance readability as -well as to allow multi-level loop breaks. -See last example. -.Ip 4. 4 4 -For portability, when using features that may not be implemented on every -machine, test the construct in an eval to see if it fails. -If you know what version or patchlevel a particular feature was implemented, -you can test $] to see if it will be there. -.Ip 5. 4 4 -Choose mnemonic identifiers. -.Ip 6. 4 4 -Be consistent. -.Sh "Debugging" -If you invoke -.I perl -with a -.B \-d -switch, your script will be run under a debugging monitor. -It will halt before the first executable statement and ask you for a -command, such as: -.Ip "h" 12 4 -Prints out a help message. -.Ip "T" 12 4 -Stack trace. -.Ip "s" 12 4 -Single step. -Executes until it reaches the beginning of another statement. -.Ip "n" 12 4 -Next. -Executes over subroutine calls, until it reaches the beginning of the -next statement. -.Ip "f" 12 4 -Finish. -Executes statements until it has finished the current subroutine. -.Ip "c" 12 4 -Continue. -Executes until the next breakpoint is reached. -.Ip "c line" 12 4 -Continue to the specified line. -Inserts a one-time-only breakpoint at the specified line. -.Ip "<CR>" 12 4 -Repeat last n or s. -.Ip "l min+incr" 12 4 -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. -.Ip "l min-max" 12 4 -List lines in the indicated range. -.Ip "l line" 12 4 -List just the indicated line. -.Ip "l" 12 4 -List next window. -.Ip "-" 12 4 -List previous window. -.Ip "w line" 12 4 -List window around line. -.Ip "l subname" 12 4 -List subroutine. -If it's a long subroutine it just lists the beginning. -Use \*(L"l\*(R" to list more. -.Ip "/pattern/" 12 4 -Regular expression search forward for pattern; the final / is optional. -.Ip "?pattern?" 12 4 -Regular expression search backward for pattern; the final ? is optional. -.Ip "L" 12 4 -List lines that have breakpoints or actions. -.Ip "S" 12 4 -Lists the names of all subroutines. -.Ip "t" 12 4 -Toggle trace mode on or off. -.Ip "b line condition" 12 4 -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. -.Ip "b subname condition" 12 4 -Set breakpoint at first executable line of subroutine. -.Ip "d line" 12 4 -Delete breakpoint. -If line is omitted, deletes the breakpoint on the -line that is about to be executed. -.Ip "D" 12 4 -Delete all breakpoints. -.Ip "a line command" 12 4 -Set an action for line. -A multi-line command may be entered by backslashing the newlines. -.Ip "A" 12 4 -Delete all line actions. -.Ip "< command" 12 4 -Set an action to happen before every debugger prompt. -A multi-line command may be entered by backslashing the newlines. -.Ip "> command" 12 4 -Set an action to happen after the prompt when you've just given a command -to return to executing the script. -A multi-line command may be entered by backslashing the newlines. -.Ip "V package" 12 4 -List all variables in package. -Default is main package. -.Ip "! number" 12 4 -Redo a debugging command. -If number is omitted, redoes the previous command. -.Ip "! -number" 12 4 -Redo the command that was that many commands ago. -.Ip "H -number" 12 4 -Display last n commands. -Only commands longer than one character are listed. -If number is omitted, lists them all. -.Ip "q or ^D" 12 4 -Quit. -.Ip "command" 12 4 -Execute command as a perl statement. -A missing semicolon will be supplied. -.Ip "p expr" 12 4 -Same as \*(L"print DB'OUT expr\*(R". -The DB'OUT filehandle is opened to /dev/tty, regardless of where STDOUT -may be redirected to. -.PP -If you want to modify the debugger, copy perldb.pl from the perl library -to your current directory and modify it as necessary. -(You'll also have to put -I. on your command line.) -You can do some customization by setting up a .perldb file which contains -initialization code. -For instance, you could make aliases like these: -.nf - - $DB'alias{'len'} = 's/^len(.*)/p length($1)/'; - $DB'alias{'stop'} = 's/^stop (at|in)/b/'; - $DB'alias{'.'} = - 's/^\e./p "\e$DB\e'sub(\e$DB\e'line):\et",\e$DB\e'line[\e$DB\e'line]/'; - -.fi -.Sh "Setuid Scripts" -.I 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, -.I perl -uses a more conventional evaluation scheme with fewer hidden \*(L"gotchas\*(R". -Additionally, since the language has more built-in functionality, it -has to rely less upon external (and possibly untrustworthy) programs to -accomplish its purposes. -.PP -In an unpatched 4.2 or 4.3bsd kernel, setuid scripts are intrinsically -insecure, but this kernel feature can be disabled. -If it is, -.I perl -can emulate the setuid and setgid mechanism when it notices the otherwise -useless setuid/gid bits on perl scripts. -If the kernel feature isn't disabled, -.I 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. -.PP -When perl is executing a setuid script, it 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 -\*(L"tainted\*(R", 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: -.nf - -.ne 5 - $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 - -.ne 4 - system "echo $foo"; # Insecure - system "/bin/echo", $foo; # Secure (doesn't use sh) - system "echo $bar"; # Insecure - system "echo $abc"; # Insecure until PATH set - -.ne 5 - $ENV{\'PATH\'} = \'/bin:/usr/bin\'; - $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\'; - - $path = $ENV{\'PATH\'}; # Not tainted - system "echo $abc"; # Is secure now! - -.ne 5 - 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 - -.ne 3 - exec "echo $foo"; # Insecure - exec "echo", $foo; # Secure (doesn't use sh) - exec "sh", \'-c\', $foo; # Considered secure, alas - -.fi -The taintedness is associated with each scalar value, so some elements -of an array can be tainted, and others not. -.PP -If you try to do something insecure, you will get a fatal error saying -something like \*(L"Insecure dependency\*(R" or \*(L"Insecure PATH\*(R". -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\*(--\c -.I perl -presumes that if you reference a substring using $1, $2, etc, you knew -what you were doing when you wrote the pattern: -.nf - - $ARGV[0] =~ /^\-P(\ew+)$/; - $printer = $1; # Not tainted - -.fi -This is fairly secure since \ew+ doesn't match shell metacharacters. -Use of .+ would have been insecure, but -.I perl -doesn't check for that, so you must be careful with your patterns. -This is the ONLY mechanism for untainting user supplied filenames if you -want to do file operations on them (unless you make $> equal to $<). -.PP -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 $> = $<. -.I 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. -.SH ENVIRONMENT -.Ip HOME 12 4 -Used if chdir has no argument. -.Ip LOGDIR 12 4 -Used if chdir has no argument and HOME is not set. -.Ip PATH 12 4 -Used in executing subprocesses, and in finding the script if \-S -is used. -.Ip PERLLIB 12 4 -A colon-separated list of directories in which to look for Perl library -files before looking in the standard library and the current directory. -.Ip PERLDB 12 4 -The command used to get the debugger code. If unset, uses -.br - - require 'perldb.pl' - -.PP -Apart from these, -.I perl -uses no other environment variables, except to make them available -to the script being executed, and to child processes. -However, scripts running setuid would do well to execute the following lines -before doing anything else, just to keep people honest: -.nf - -.ne 3 - $ENV{\'PATH\'} = \'/bin:/usr/bin\'; # or whatever you need - $ENV{\'SHELL\'} = \'/bin/sh\' if $ENV{\'SHELL\'} ne \'\'; - $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\'; - -.fi -.SH AUTHOR -Larry Wall <lwall@netlabs.com> -.br -MS-DOS port by Diomidis Spinellis <dds@cc.ic.ac.uk> -.SH FILES -/tmp/perl\-eXXXXXX temporary file for -.B \-e -commands. -.SH SEE ALSO -a2p awk to perl translator -.br -s2p sed to perl translator -.SH DIAGNOSTICS -Compilation errors will tell you the line number of the error, with an -indication of the next token or token type that was to be examined. -(In the case of a script passed to -.I perl -via -.B \-e -switches, each -.B \-e -is counted as one line.) -.PP -Setuid scripts have additional constraints that can produce error messages -such as \*(L"Insecure dependency\*(R". -See the section on setuid scripts. -.SH TRAPS -Accustomed -.IR awk -users should take special note of the following: -.Ip * 4 2 -Semicolons are required after all simple statements in -.I perl -(except at the end of a block). -Newline is not a statement delimiter. -.Ip * 4 2 -Curly brackets are required on ifs and whiles. -.Ip * 4 2 -Variables begin with $ or @ in -.IR perl . -.Ip * 4 2 -Arrays index from 0 unless you set $[. -Likewise string positions in substr() and index(). -.Ip * 4 2 -You have to decide whether your array has numeric or string indices. -.Ip * 4 2 -Associative array values do not spring into existence upon mere reference. -.Ip * 4 2 -You have to decide whether you want to use string or numeric comparisons. -.Ip * 4 2 -Reading an input line does not split it for you. You get to split it yourself -to an array. -And the -.I split -operator has different arguments. -.Ip * 4 2 -The current input line is normally in $_, not $0. -It generally does not have the newline stripped. -($0 is the name of the program executed.) -.Ip * 4 2 -$<digit> does not refer to fields\*(--it refers to substrings matched by the last -match pattern. -.Ip * 4 2 -The -.I print -statement does not add field and record separators unless you set -$, and $\e. -.Ip * 4 2 -You must open your files before you print to them. -.Ip * 4 2 -The range operator is \*(L".\|.\*(R", not comma. -(The comma operator works as in C.) -.Ip * 4 2 -The match operator is \*(L"=~\*(R", not \*(L"~\*(R". -(\*(L"~\*(R" is the one's complement operator, as in C.) -.Ip * 4 2 -The exponentiation operator is \*(L"**\*(R", not \*(L"^\*(R". -(\*(L"^\*(R" is the XOR operator, as in C.) -.Ip * 4 2 -The concatenation operator is \*(L".\*(R", not the null string. -(Using the null string would render \*(L"/pat/ /pat/\*(R" unparsable, -since the third slash would be interpreted as a division operator\*(--the -tokener is in fact slightly context sensitive for operators like /, ?, and <. -And in fact, . itself can be the beginning of a number.) -.Ip * 4 2 -.IR Next , -.I exit -and -.I continue -work differently. -.Ip * 4 2 -The following variables work differently -.nf - - Awk \h'|2.5i'Perl - ARGC \h'|2.5i'$#ARGV - ARGV[0] \h'|2.5i'$0 - FILENAME\h'|2.5i'$ARGV - FNR \h'|2.5i'$. \- something - FS \h'|2.5i'(whatever you like) - NF \h'|2.5i'$#Fld, or some such - NR \h'|2.5i'$. - OFMT \h'|2.5i'$# - OFS \h'|2.5i'$, - ORS \h'|2.5i'$\e - RLENGTH \h'|2.5i'length($&) - RS \h'|2.5i'$/ - RSTART \h'|2.5i'length($\`) - SUBSEP \h'|2.5i'$; - -.fi -.Ip * 4 2 -When in doubt, run the -.I awk -construct through a2p and see what it gives you. -.PP -Cerebral C programmers should take note of the following: -.Ip * 4 2 -Curly brackets are required on ifs and whiles. -.Ip * 4 2 -You should use \*(L"elsif\*(R" rather than \*(L"else if\*(R" -.Ip * 4 2 -.I Break -and -.I continue -become -.I last -and -.IR next , -respectively. -.Ip * 4 2 -There's no switch statement. -.Ip * 4 2 -Variables begin with $ or @ in -.IR perl . -.Ip * 4 2 -Printf does not implement *. -.Ip * 4 2 -Comments begin with #, not /*. -.Ip * 4 2 -You can't take the address of anything. -.Ip * 4 2 -ARGV must be capitalized. -.Ip * 4 2 -The \*(L"system\*(R" calls link, unlink, rename, etc. return nonzero for success, not 0. -.Ip * 4 2 -Signal handlers deal with signal names, not numbers. -.PP -Seasoned -.I sed -programmers should take note of the following: -.Ip * 4 2 -Backreferences in substitutions use $ rather than \e. -.Ip * 4 2 -The pattern matching metacharacters (, ), and | do not have backslashes in front. -.Ip * 4 2 -The range operator is .\|. rather than comma. -.PP -Sharp shell programmers should take note of the following: -.Ip * 4 2 -The backtick operator does variable interpretation without regard to the -presence of single quotes in the command. -.Ip * 4 2 -The backtick operator does no translation of the return value, unlike csh. -.Ip * 4 2 -Shells (especially csh) do several levels of substitution on each command line. -.I Perl -does substitution only in certain constructs such as double quotes, -backticks, angle brackets and search patterns. -.Ip * 4 2 -Shells interpret scripts a little bit at a time. -.I Perl -compiles the whole program before executing it. -.Ip * 4 2 -The arguments are available via @ARGV, not $1, $2, etc. -.Ip * 4 2 -The environment is not automatically made available as variables. -.SH ERRATA\0AND\0ADDENDA -The Perl book, -.I Programming\0Perl , -has the following omissions and goofs. -.PP -On page 5, the examples which read -.nf - - eval "/usr/bin/perl - -should read - - eval "exec /usr/bin/perl - -.fi -.PP -On page 195, the equivalent to the System V sum program only works for -very small files. To do larger files, use -.nf - - undef $/; - $checksum = unpack("%32C*",<>) % 65535; - -.fi -.PP -The descriptions of alarm and sleep refer to signal SIGALARM. These -should refer to SIGALRM. -.PP -The -.B \-0 -switch to set the initial value of $/ was added to Perl after the book -went to press. -.PP -The -.B \-l -switch now does automatic line ending processing. -.PP -The qx// construct is now a synonym for backticks. -.PP -$0 may now be assigned to set the argument displayed by -.I ps (1). -.PP -The new @###.## format was omitted accidentally from the description -on formats. -.PP -It wasn't known at press time that s///ee caused multiple evaluations of -the replacement expression. This is to be construed as a feature. -.PP -(LIST) x $count now does array replication. -.PP -There is now no limit on the number of parentheses in a regular expression. -.PP -In double-quote context, more escapes are supported: \ee, \ea, \ex1b, \ec[, -\el, \eL, \eu, \eU, \eE. The latter five control up/lower case translation. -.PP -The -.B $/ -variable may now be set to a multi-character delimiter. -.PP -There is now a g modifier on ordinary pattern matching that causes it -to iterate through a string finding multiple matches. -.PP -All of the $^X variables are new except for $^T. -.PP -The default top-of-form format for FILEHANDLE is now FILEHANDLE_TOP rather -than top. -.PP -The eval {} and sort {} constructs were added in version 4.018. -.PP -The v and V (little-endian) template options for pack and unpack were -added in 4.019. -.SH BUGS -.PP -.I Perl -is at the mercy of your machine's definitions of various operations -such as type casting, atof() and sprintf(). -.PP -If your stdio requires an seek or eof between reads and writes on a particular -stream, so does -.IR perl . -(This doesn't apply to sysread() and syswrite().) -.PP -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 \-S. -A regular expression may not compile to more than 32767 bytes internally. -.PP -.I Perl -actually stands for Pathologically Eclectic Rubbish Lister, but don't tell -anyone I said that. -.rn }` '' diff --git a/perl_exp.SH b/perl_exp.SH new file mode 100644 index 0000000000..f67b165821 --- /dev/null +++ b/perl_exp.SH @@ -0,0 +1,33 @@ +#!/bin/sh + +# Create the export list for perl. +# Needed by AIX to do dynamic linking. + +# This simple program relys on 'global.sym' being up to date +# with all of the global symbols that a dynamicly link library +# might want to access. + +echo "Extracting perl.exp" + +echo "#!" > perl.exp + +sed -n "/^[A-Za-z]/ p" global.sym >> perl.exp + +cat <<END >> perl.exp +perl_init_ext +perl_alloc +perl_construct +perl_destruct +perl_free +perl_parse +perl_run +perl_get_sv +perl_get_av +perl_get_hv +perl_get_cv +perl_call_argv +perl_call_pv +perl_call_method +perl_call_sv +perl_requirepv +END diff --git a/perlmain.c b/perlmain.c deleted file mode 100644 index d3ff323a73..0000000000 --- a/perlmain.c +++ /dev/null @@ -1,38 +0,0 @@ -#include "INTERN.h" -#include "perl.h" - -main(argc, argv, env) -int argc; -char **argv; -char **env; -{ - int exitstatus; - PerlInterpreter *my_perl; - - my_perl = perl_alloc(); - if (!my_perl) - exit(1); - perl_construct( my_perl ); - - exitstatus = perl_parse( my_perl, argc, argv, env ); - if (exitstatus) - exit( exitstatus ); - - exitstatus = perl_run( my_perl ); - - perl_destruct( my_perl ); - perl_free( my_perl ); - - exit( exitstatus ); -} - -/* Register any extra external extensions */ - -void -perl_init_ext() -{ - char *file = __FILE__; - /* Do not delete this line--writemain depends on it */ - boot_DynamicLoader(); - -} diff --git a/perlmain.x b/perlmain.x deleted file mode 100644 index 9839490a3b..0000000000 --- a/perlmain.x +++ /dev/null @@ -1,3 +0,0 @@ -POSIX -NDBM_File -ODBM_File @@ -2,1394 +2,1100 @@ static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; #endif #define YYBYACC 1 -#line 39 "perly.y" +#line 17 "perly.y" #include "EXTERN.h" #include "perl.h" -/*SUPPRESS 530*/ -/*SUPPRESS 593*/ -/*SUPPRESS 595*/ +static void +dep() +{ + deprecate("\"do\" to call subroutines"); +} -#line 50 "perly.y" -typedef union { - I32 ival; - char *pval; - OP *opval; - GV *gvval; -} YYSTYPE; -#line 21 "y.tab.c" -#define WORD 257 -#define METHOD 258 -#define THING 259 -#define PMFUNC 260 -#define PRIVATEREF 261 -#define LABEL 262 -#define FORMAT 263 -#define SUB 264 -#define PACKAGE 265 -#define HINT 266 -#define WHILE 267 -#define UNTIL 268 -#define IF 269 -#define UNLESS 270 -#define ELSE 271 -#define ELSIF 272 -#define CONTINUE 273 -#define FOR 274 -#define LOOPEX 275 -#define DOTDOT 276 -#define FUNC0 277 -#define FUNC1 278 -#define FUNC 279 -#define RELOP 280 -#define EQOP 281 -#define MULOP 282 -#define ADDOP 283 -#define DOLSHARP 284 -#define DO 285 -#define LOCAL 286 -#define DELETE 287 -#define HASHBRACK 288 -#define NOAMP 289 -#define OROP 290 -#define ANDOP 291 -#define LSTOP 292 -#define OROR 293 -#define ANDAND 294 -#define BITOROP 295 -#define BITANDOP 296 -#define UNIOP 297 -#define SHIFTOP 298 -#define MATCHOP 299 -#define UMINUS 300 -#define REFGEN 301 -#define POWOP 302 -#define PREINC 303 -#define PREDEC 304 -#define POSTINC 305 -#define POSTDEC 306 -#define ARROW 307 #define YYERRCODE 256 short yylhs[] = { -1, - 30, 0, 7, 3, 8, 8, 8, 9, 9, 9, - 9, 23, 23, 23, 23, 23, 23, 13, 13, 13, - 11, 11, 11, 11, 29, 29, 10, 10, 10, 10, - 10, 10, 10, 10, 12, 12, 26, 26, 28, 28, - 1, 1, 1, 1, 2, 2, 31, 31, 32, 32, - 33, 33, 14, 14, 27, 27, 27, 27, 27, 27, - 27, 27, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 24, 24, 22, 17, 18, - 19, 20, 21, 25, 25, 25, 25, 4, 4, 5, - 5, 6, 6, + 30, 0, 5, 3, 6, 6, 6, 7, 7, 7, + 7, 21, 21, 21, 21, 21, 21, 11, 11, 11, + 9, 9, 9, 9, 29, 29, 8, 8, 8, 8, + 8, 8, 8, 8, 10, 10, 25, 25, 28, 28, + 1, 1, 1, 1, 2, 2, 31, 31, 4, 32, + 32, 33, 13, 13, 13, 13, 12, 12, 12, 26, + 26, 26, 26, 26, 26, 26, 27, 27, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 22, 22, + 23, 23, 23, 20, 15, 16, 17, 18, 19, 24, + 24, 24, 24, }; short yylen[] = { 2, 0, 2, 4, 0, 0, 2, 2, 2, 1, 2, 3, 1, 1, 3, 3, 3, 3, 0, 2, 6, 6, 6, 4, 4, 0, 2, 7, 7, 5, 5, 8, 7, 10, 3, 0, 1, 0, 1, 0, 1, - 1, 1, 1, 1, 3, 2, 3, 3, 3, 2, - 3, 4, 3, 1, 3, 5, 4, 6, 6, 3, - 2, 4, 3, 4, 4, 4, 4, 4, 4, 4, - 4, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 5, 3, 1, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 3, 2, 3, - 2, 3, 3, 1, 1, 4, 5, 4, 1, 1, - 1, 5, 6, 5, 6, 5, 4, 5, 6, 8, - 1, 1, 3, 4, 3, 4, 2, 2, 4, 5, - 4, 5, 1, 2, 1, 2, 2, 1, 3, 3, - 4, 4, 6, 1, 1, 0, 1, 2, 2, 2, - 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, - 1, 3, 2, + 1, 1, 1, 1, 4, 3, 4, 4, 0, 3, + 2, 4, 3, 3, 2, 1, 2, 3, 1, 3, + 5, 6, 3, 5, 2, 4, 1, 1, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 5, 3, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 3, 2, 3, 2, 4, 3, 3, 1, + 1, 4, 5, 4, 1, 1, 1, 5, 6, 5, + 6, 5, 4, 5, 1, 1, 3, 4, 3, 2, + 2, 4, 5, 4, 5, 1, 2, 1, 2, 2, + 1, 3, 3, 4, 4, 6, 1, 1, 0, 1, + 0, 1, 2, 2, 2, 2, 2, 2, 2, 1, + 1, 1, 1, }; short yydefred[] = { 1, - 0, 5, 0, 40, 0, 0, 0, 0, 6, 41, - 7, 9, 0, 42, 43, 44, 4, 0, 46, 0, - 0, 50, 0, 12, 0, 0, 121, 0, 157, 0, + 0, 5, 0, 40, 49, 49, 0, 0, 6, 41, + 7, 9, 0, 42, 43, 44, 0, 0, 0, 51, + 0, 12, 4, 137, 0, 0, 115, 0, 49, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 10, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 8, 0, 0, 0, 0, 0, 109, 111, - 105, 0, 0, 0, 145, 5, 45, 48, 47, 49, - 51, 156, 0, 154, 155, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 152, 0, 128, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 61, 0, 136, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 101, 0, 148, 149, - 150, 151, 153, 0, 34, 0, 0, 0, 0, 0, + 0, 0, 8, 0, 0, 0, 0, 0, 105, 107, + 101, 0, 0, 138, 0, 46, 0, 50, 0, 0, + 5, 150, 153, 152, 151, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 93, 94, 0, - 0, 0, 0, 0, 0, 0, 11, 0, 0, 52, - 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 36, 0, 139, 140, 0, 0, 0, - 0, 0, 0, 0, 103, 0, 0, 102, 125, 0, - 55, 0, 159, 0, 0, 0, 161, 100, 26, 0, + 0, 0, 0, 148, 0, 121, 0, 0, 0, 0, + 0, 0, 55, 0, 0, 65, 0, 129, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 96, 0, + 144, 145, 146, 147, 149, 0, 34, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, + 89, 0, 0, 0, 0, 0, 0, 0, 11, 45, + 48, 47, 52, 0, 63, 0, 0, 99, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 36, + 0, 132, 133, 0, 0, 0, 0, 0, 0, 98, + 0, 119, 0, 0, 0, 95, 26, 0, 0, 0, + 0, 0, 0, 53, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 123, 0, 0, - 0, 3, 142, 0, 0, 29, 0, 30, 0, 0, - 0, 23, 0, 24, 0, 0, 0, 141, 62, 0, - 129, 0, 131, 0, 0, 0, 0, 163, 126, 0, - 158, 0, 160, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 108, 0, 106, 0, - 117, 124, 0, 57, 0, 0, 0, 0, 19, 0, - 0, 0, 0, 0, 56, 130, 132, 0, 0, 162, - 116, 0, 0, 114, 0, 0, 107, 112, 118, 0, - 143, 27, 28, 21, 0, 22, 0, 32, 0, 0, - 119, 115, 113, 59, 58, 0, 0, 31, 0, 0, - 0, 120, 20, 33, + 67, 0, 68, 0, 0, 0, 0, 0, 0, 117, + 0, 3, 0, 135, 0, 0, 29, 0, 30, 0, + 0, 0, 23, 0, 24, 0, 0, 0, 134, 143, + 66, 0, 122, 0, 124, 0, 97, 0, 0, 0, + 0, 0, 0, 0, 104, 0, 102, 0, 113, 118, + 64, 0, 0, 0, 0, 19, 0, 0, 0, 0, + 0, 61, 123, 125, 112, 0, 110, 0, 0, 103, + 0, 108, 114, 136, 27, 28, 21, 0, 22, 0, + 32, 0, 111, 109, 62, 0, 0, 31, 0, 0, + 20, 33, }; short yydgoto[] = { 1, - 9, 10, 76, 205, 208, 198, 82, 3, 11, 12, - 63, 182, 262, 113, 65, 66, 67, 68, 69, 70, - 71, 72, 184, 114, 74, 174, 75, 13, 135, 2, + 9, 10, 81, 17, 84, 3, 11, 12, 63, 188, + 253, 64, 195, 66, 67, 68, 69, 70, 71, 72, + 190, 80, 196, 86, 180, 74, 234, 13, 137, 2, 14, 15, 16, }; short yysindex[] = { 0, - 0, 0, 74, 0, -120, -227, -57, -209, 0, 0, - 0, 0, 893, 0, 0, 0, 0, -67, 0, -52, - 52, 0, 993, 0, 0, -4, 0, 25, 0, -31, - -23, -19, -11, 77, 2687, 76, 106, 113, -4, 2786, - 2687, 87, 1043, -132, 2687, 2687, 2687, 2687, 2687, 2687, - 2687, 1100, 0, 2687, 2687, 1222, -4, -4, -4, -4, - -4, -116, 0, -21, 1549, -87, -69, -40, 0, 0, - 0, 145, 115, -121, 0, 0, 0, 0, 0, 0, - 0, 0, -1, 0, 0, 2687, 2687, 2687, -67, 2687, - -67, 2687, -67, 2687, -67, 1329, 150, 1549, 151, 1394, - 2687, 0, 164, 0, 324, -29, 324, 170, 88, 102, - 11, 2687, 190, 0, 442, 0, 324, -87, -87, -87, - -86, -86, 149, -2, -87, -87, 0, -30, 0, 0, - 0, 0, 0, -67, 0, 2687, 2687, 2687, 2687, 2687, - 2687, 2687, 2687, 1451, 1501, 2687, 2687, 2687, 2687, 1598, - 1680, 1774, 1870, 1964, 2687, 2043, 2687, 0, 0, -85, - 2687, 2687, 2687, 2687, 2687, 2143, 0, -248, -49, 0, - 0, 1273, 190, 195, -116, 143, -116, 181, -12, 182, - -12, 192, 36, 0, 2687, 0, 0, 191, 222, 442, - 2242, 2315, 141, 2687, 0, 2415, 142, 0, 0, 442, - 0, 2687, 0, 2514, 177, 2587, 0, 0, 0, 190, - 190, 190, 190, 18, 660, 324, -131, 2687, -181, 2687, - -230, 829, 18, 18, 1915, 2687, 710, 2687, 455, 2687, - 46, 2687, 276, 2687, -127, -28, 2687, -28, 71, 2687, - 237, 2687, -26, 122, -20, 134, 2, 0, -2, 247, - 2687, 0, 0, 2687, -67, 0, -67, 0, -67, -67, - 249, 0, -67, 0, 2687, -67, -2, 0, 0, 252, - 0, -2, 0, -2, 2687, 135, 171, 0, 0, 6, - 0, 2687, 0, 18, 18, 2687, 18, 18, 18, 18, - 18, 18, 183, 136, 2687, 15, 0, 185, 0, 193, - 0, 0, 2687, 0, 290, -116, -116, -12, 0, 2687, - -12, 236, -116, -67, 0, 0, 0, 153, 194, 0, - 0, 17, 392, 0, 200, 261, 0, 0, 0, 274, - 0, 0, 0, 0, 197, 0, 1329, 0, -116, 205, - 0, 0, 0, 0, 0, -67, 291, 0, 292, -12, - -67, 0, 0, 0, + 0, 0, -109, 0, 0, 0, -47, -221, 0, 0, + 0, 0, 585, 0, 0, 0, -106, -207, 3, 0, + 2059, 0, 0, 0, 94, 94, 0, 27, 0, -21, + -13, -12, -10, 11, 2059, 31, 34, 38, 94, 1787, + 2059, 961, -173, 1853, 1029, 1960, 2059, 2059, 2059, 2059, + 2059, 1140, 0, 2059, 2059, 1237, 94, 94, 94, 94, + 94, -187, 0, 50, 232, 3898, -65, -59, 0, 0, + 0, 60, 56, 0, -20, 0, -26, 0, 50, 57, + 0, 0, 0, 0, 0, 2059, 78, 2059, -20, 1853, + -20, 1853, -20, 1853, -20, 1853, -20, 1305, 79, 3898, + 80, 1416, 909, 0, 83, 0, 927, -19, 927, -5, + -54, 2059, 0, 0, -65, 0, 2059, 0, 927, 450, + 450, 450, -83, -83, 40, -41, 450, 450, 0, -90, + 0, 0, 0, 0, 0, -20, 0, 2059, 1853, 1853, + 1853, 1853, 1853, 1853, 1853, 2059, 2059, 2059, 2059, 2059, + 2059, 2059, 2059, 2059, 2059, 2059, 2059, 2059, 2059, 0, + 0, -22, 1853, 1853, 1853, 1853, 1853, 1512, 0, 0, + 0, 0, 0, -102, 0, 1853, 1351, 0, -210, 84, + -187, -39, -187, -17, -167, 35, -167, 70, 365, 0, + 1853, 0, 0, 44, 5, 91, 1853, 1581, 1688, 0, + 9, 0, 50, 1853, 48, 0, 0, 3898, -210, -210, + -210, -210, -155, 0, -48, 746, 927, 1382, 338, 1360, + 3898, 469, 797, 1069, 1103, 1180, 1455, 450, 450, 1853, + 0, 1853, 0, 100, -87, -44, -84, 76, -77, 0, + 46, 0, 108, 0, 2059, -20, 0, -20, 0, -20, + -20, 106, 0, -20, 0, 1853, -20, 58, 0, 0, + 0, 81, 0, 87, 0, 111, 0, -73, 1853, 28, + 2059, 122, -68, 1853, 0, 43, 0, 47, 0, 0, + 0, 2945, -187, -187, -167, 0, 1853, -167, 101, -187, + -20, 0, 0, 0, 0, -62, 0, 4048, 49, 0, + 132, 0, 0, 0, 0, 0, 0, 116, 0, 1305, + 0, -187, 0, 0, 0, -20, 134, 0, -167, -20, + 0, 0, }; short yyrindex[] = { 0, - 0, 0, 505, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 105, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 121, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 2263, 1892, 0, 0, 0, 0, + 0, 0, 0, 0, 2761, 2803, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 557, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 3333, 2837, 0, 0, 0, 0, - 0, 0, 0, 0, 3423, 3589, 0, 0, 0, 0, + 0, 1, 0, 697, 4, 153, 2869, 2912, 0, 0, + 0, 2151, 0, 0, 0, 0, 0, 0, 2309, 0, + 0, 0, 0, 0, 0, 2351, 0, 0, 0, 141, + 0, 0, 0, 0, 0, 0, 0, 124, 0, 2544, + 0, 0, 143, 0, 2212, 0, 3721, 2869, 3753, 0, + 0, 2351, 0, 435, 526, 0, 0, 0, 3786, 3215, + 3255, 3311, 3062, 3174, 2413, 0, 3347, 3390, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 2610, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 105, 0, 23, 16, 4876, 618, 3639, 0, 0, - 0, 2892, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 3423, 0, 294, 0, 0, - 0, 0, 0, 0, 0, 284, 0, 969, 0, 0, - 306, 0, 2936, 0, 1830, 3682, 2474, 0, 0, 0, - 0, 3423, 2991, 0, 4707, 0, 4051, 4923, 4973, 5009, - 5045, 5092, 3152, 0, 5139, 5187, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 857, 0, 143, 0, 0, 7, 0, + 1, 0, 1, 0, 53, 0, 53, 0, 126, 0, + 0, 0, 0, 0, 145, 0, 0, 0, 0, 0, + 0, 0, 2460, 0, 2719, 0, 0, 2586, 14, 16, + 18, 20, -37, 0, 0, 1443, 3822, 1763, 390, 3649, + 2845, 0, 4045, 4002, 3970, 3865, 3685, 3504, 3606, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 943, 0, - 0, 0, 61, 0, 165, 0, 165, 0, 233, 0, - 233, 0, 293, 0, 0, 0, 0, 0, 0, 306, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 4707, - 0, 0, 0, 0, 3207, 0, 0, 0, 0, 65, - 73, 81, 85, 2218, 4507, 4093, 4134, 0, 3723, 0, - 3769, -25, 3057, 4364, 0, 0, 4466, 0, 4456, 0, - 4415, 0, 4176, 0, 4010, 3250, 0, 3291, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 3423, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 295, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 128, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 4519, 4565, 0, 4570, 4621, 4758, 4787, - 4806, 4857, 0, 0, 306, 0, 0, 0, 0, 0, - 0, 0, 306, 0, 0, 165, 165, 233, 0, 0, - 233, 0, 165, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 4514, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 308, 0, 165, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 233, - 0, 0, 0, 0, + 0, 0, 0, 143, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 1, 53, 0, 0, 53, 0, 1, + 0, 0, 0, 0, 0, 0, 0, 311, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 147, + 0, 1, 0, 0, 0, 0, 0, 0, 53, 0, + 0, 0, }; short yygindex[] = { 0, - 0, 0, 0, -171, 0, 0, -5, 279, 0, 0, - 0, 13, -180, -3, 5357, 586, 585, 0, 0, 0, - 0, 0, 344, 362, 359, 95, 0, 0, -130, 0, + 0, 0, 0, 23, 209, 109, 0, 0, 0, -121, + -152, -3, 345, 4241, 878, 0, 0, 0, 0, 0, + 178, -32, -166, 494, -64, 0, 0, 0, -113, 0, 0, 0, 0, }; -#define YYTABLESIZE 5643 -short yytable[] = { 19, - 264, 22, 17, 161, 161, 242, 78, 62, 88, 64, - 192, 266, 77, 206, 79, 84, 90, 140, 84, 83, - 92, 163, 140, 140, 89, 91, 93, 95, 94, 20, - 250, 58, 84, 84, 104, 157, 157, 240, 203, 111, - 116, 204, 140, 251, 256, 140, 258, 23, 124, 140, - 165, 144, 128, 162, 196, 17, 54, 170, 140, 54, - 140, 163, 207, 13, 87, 84, 297, 84, 155, 197, - 17, 156, 299, 54, 54, 252, 203, 302, 148, 204, - 149, 13, 164, 175, 173, 177, 176, 179, 178, 181, - 180, 17, 183, 162, 301, 314, 188, 84, 321, 17, - 316, 38, 317, 17, 25, 16, 54, 327, 54, 342, - 80, 17, 58, 17, 140, 99, 96, 155, 17, 38, - 156, 14, 58, 16, 112, 15, 108, 334, 209, 293, - 336, 17, 210, 211, 212, 213, 18, 25, 54, 14, - 25, 25, 25, 15, 25, 100, 25, 25, 142, 25, - 144, 145, 101, 239, 144, 145, 134, 243, 244, 245, - 246, 247, 249, 25, 25, 140, 154, 155, 25, 353, - 156, 155, 241, 167, 156, 332, 333, 140, 140, 140, - 298, 267, 338, 257, 166, 168, 140, 272, 274, 185, - 276, 186, 300, 319, 325, 25, 140, 25, 280, 21, - 25, 25, 25, 191, 25, 58, 25, 25, 348, 25, - 194, 340, 4, 5, 6, 7, 8, 158, 159, 160, - 160, 259, 263, 25, 140, 140, 195, 25, 25, 25, - 25, 268, 18, 140, 140, 255, 294, 346, 296, 202, - 140, 84, 84, 84, 84, 136, 137, 138, 139, 306, - 265, 307, 84, 308, 309, 25, 29, 311, 260, 261, - 313, 173, 269, 275, 84, 18, 278, 282, 18, 18, - 18, 318, 18, 156, 18, 18, 295, 18, 322, 84, - 84, 84, 54, 54, 54, 54, 303, 25, 310, 25, - 25, 18, 315, 141, 337, 320, 18, 142, 143, 144, - 145, 344, 136, 137, 138, 139, 335, 324, 339, 328, - 150, 151, 152, 153, 345, 154, 155, 329, 341, 156, - 54, 54, 54, 18, 343, 142, 143, 144, 145, 349, - 331, 351, 352, 64, 37, 4, 5, 6, 7, 8, - 350, 153, 35, 154, 155, 354, 146, 156, 35, 347, - 148, 13, 149, 37, 169, 18, 73, 18, 18, 312, - 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, - 25, 25, 25, 25, 25, 0, 0, 0, 25, 25, - 0, 25, 25, 25, 86, 0, 0, 0, 25, 25, - 25, 25, 25, 25, 0, 0, 25, 102, 0, 0, - 0, 25, 0, 115, 0, 25, 0, 25, 25, 0, - 0, 156, 0, 0, 0, 129, 130, 131, 132, 133, - 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, - 25, 25, 25, 25, 25, 0, 0, 0, 25, 25, - 0, 25, 25, 25, 0, 0, 0, 171, 25, 25, - 25, 25, 25, 25, 149, 0, 25, 0, 0, 190, - 0, 25, 189, 0, 0, 25, 0, 25, 25, 0, - 200, 0, 0, 199, 47, 0, 201, 58, 60, 57, - 0, 52, 0, 61, 55, 0, 54, 0, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 0, 2, 59, 18, 18, 0, 18, - 18, 18, 0, 0, 0, 0, 18, 18, 18, 18, - 18, 18, 0, 0, 18, 0, 0, 0, 0, 18, - 0, 0, 56, 18, 0, 18, 18, 39, 0, 0, - 39, 39, 39, 0, 39, 0, 39, 39, 0, 39, - 0, 270, 0, 0, 0, 142, 143, 144, 145, 0, - 0, 279, 0, 39, 17, 141, 0, 48, 39, 142, - 143, 144, 145, 154, 155, 0, 0, 156, 0, 146, - 147, 0, 150, 151, 152, 153, 0, 154, 155, 154, - 0, 156, 154, 154, 154, 39, 154, 144, 154, 154, - 144, 154, 0, 0, 0, 144, 145, 0, 0, 0, - 85, 0, 304, 0, 144, 144, 0, 144, 97, 144, - 154, 154, 155, 85, 106, 156, 109, 39, 0, 0, - 39, 0, 118, 119, 120, 121, 122, 0, 0, 125, - 126, 85, 85, 85, 85, 85, 0, 144, 0, 144, - 155, 0, 0, 155, 155, 155, 326, 155, 104, 155, - 155, 104, 155, 0, 330, 0, 0, 141, 0, 0, - 0, 142, 143, 144, 145, 104, 104, 0, 104, 144, - 104, 155, 154, 0, 150, 151, 152, 153, 0, 154, - 155, 0, 193, 156, 0, 0, 0, 0, 25, 26, - 27, 28, 29, 0, 0, 0, 0, 0, 0, 0, - 104, 0, 0, 0, 0, 0, 35, 0, 36, 37, - 38, 0, 0, 0, 0, 39, 40, 41, 42, 43, - 44, 0, 0, 45, 142, 143, 144, 145, 46, 0, - 0, 0, 49, 155, 50, 51, 0, 0, 168, 152, - 153, 0, 154, 155, 0, 0, 156, 0, 0, 0, - 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, - 0, 39, 39, 39, 39, 0, 0, 0, 39, 39, - 0, 39, 39, 39, 0, 0, 0, 0, 39, 39, - 39, 39, 39, 39, 0, 0, 39, 0, 0, 0, - 0, 39, 0, 0, 0, 39, 0, 39, 39, 0, - 0, 0, 0, 154, 154, 154, 154, 154, 0, 0, - 0, 0, 0, 144, 144, 144, 144, 0, 0, 0, - 0, 154, 144, 154, 154, 154, 144, 144, 144, 144, - 154, 154, 154, 154, 154, 154, 144, 144, 154, 144, - 144, 144, 144, 154, 144, 144, 0, 154, 144, 154, - 154, 144, 144, 144, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 155, 155, 155, 155, 155, 0, - 0, 0, 0, 0, 104, 104, 104, 104, 0, 148, - 0, 149, 155, 104, 155, 155, 155, 104, 104, 104, - 104, 155, 155, 155, 155, 155, 155, 104, 104, 155, - 104, 104, 104, 104, 155, 104, 104, 0, 155, 104, - 155, 155, 104, 104, 104, 47, 0, 0, 58, 60, - 57, 0, 52, 0, 61, 55, 0, 54, 0, 142, - 143, 144, 145, 0, 0, 0, 0, 0, 0, 0, - 0, 53, 150, 151, 152, 153, 59, 154, 155, 0, - 0, 156, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 39, 0, 0, 39, 39, - 39, 0, 39, 56, 39, 39, 0, 39, 0, 142, - 143, 144, 145, 0, 0, 0, 0, 0, 0, 0, - 0, 39, 0, 151, 152, 153, 39, 154, 155, 134, - 0, 156, 134, 0, 0, 17, 0, 0, 48, 0, - 0, 0, 0, 0, 0, 47, 134, 134, 58, 60, - 57, 0, 52, 39, 61, 55, 0, 54, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 81, 0, 0, 0, 0, 59, 0, 0, 134, - 0, 134, 0, 0, 0, 39, 0, 0, 39, 0, - 0, 0, 0, 0, 0, 47, 0, 0, 58, 60, - 57, 0, 52, 56, 61, 55, 0, 54, 0, 0, - 0, 134, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 110, 0, 0, 141, 0, 59, 0, 142, 143, - 144, 145, 0, 0, 0, 17, 0, 0, 48, 147, - 0, 150, 151, 152, 153, 0, 154, 155, 0, 0, - 156, 0, 47, 56, 0, 58, 60, 57, 0, 52, - 123, 61, 55, 0, 54, 0, 0, 0, 24, 25, - 26, 27, 28, 29, 0, 0, 0, 0, 0, 30, - 31, 32, 33, 59, 0, 17, 34, 35, 48, 36, - 37, 38, 0, 0, 0, 0, 39, 40, 41, 42, - 43, 44, 0, 0, 45, 0, 0, 0, 0, 46, - 56, 0, 0, 49, 0, 50, 51, 0, 39, 39, - 39, 39, 39, 39, 0, 0, 0, 0, 0, 39, - 39, 39, 39, 0, 0, 0, 39, 39, 0, 39, - 39, 39, 17, 0, 0, 48, 39, 39, 39, 39, - 39, 39, 0, 0, 39, 134, 134, 134, 134, 39, - 0, 0, 0, 39, 0, 39, 39, 0, 0, 25, - 26, 27, 28, 29, 47, 0, 0, 58, 60, 57, - 0, 52, 0, 61, 55, 0, 54, 35, 0, 36, - 37, 38, 0, 134, 134, 134, 39, 40, 41, 42, - 43, 44, 0, 0, 45, 59, 0, 0, 0, 46, - 0, 0, 0, 49, 0, 50, 51, 0, 0, 25, - 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, - 0, 0, 56, 253, 127, 0, 254, 35, 0, 36, +#define YYTABLESIZE 4512 +short yytable[] = { 205, + 25, 248, 206, 54, 201, 275, 54, 163, 277, 243, + 270, 20, 116, 58, 276, 279, 23, 79, 90, 295, + 199, 54, 242, 250, 300, 165, 92, 94, 18, 96, + 313, 167, 171, 25, 255, 21, 25, 25, 25, 145, + 25, 79, 25, 25, 13, 25, 58, 38, 260, 77, + 98, 89, 18, 175, 16, 54, 17, 164, 14, 25, + 15, 78, 13, 166, 25, 38, 88, 247, 232, 249, + 101, 165, 16, 102, 17, 254, 14, 103, 15, 202, + 143, 144, 79, 112, 259, 18, 280, 136, 18, 18, + 18, 25, 18, 138, 18, 18, 23, 18, 291, 168, + 230, 23, 23, 164, 2, 251, 252, 301, 79, 23, + 23, 18, 23, 203, 169, 173, 18, 176, 191, 200, + 192, 292, 198, 25, 246, 25, 25, 293, 256, 58, + 204, 261, 307, 267, 278, 309, 144, 39, 269, 274, + 39, 39, 39, 18, 39, 287, 39, 39, 281, 39, + 75, 294, 297, 4, 5, 6, 316, 7, 8, 310, + 4, 5, 6, 39, 7, 8, 321, 302, 39, 305, + 306, 303, 315, 314, 320, 18, 311, 18, 18, 139, + 299, 37, 35, 141, 13, 142, 37, 35, 317, 174, + 73, 289, 0, 59, 0, 39, 59, 0, 318, 0, + 143, 144, 0, 143, 144, 0, 143, 144, 0, 19, + 59, 59, 0, 143, 144, 0, 23, 143, 144, 0, + 0, 62, 143, 144, 0, 76, 162, 39, 143, 144, + 39, 54, 54, 54, 54, 231, 143, 144, 91, 93, + 95, 97, 143, 144, 0, 59, 143, 144, 106, 143, + 144, 143, 144, 54, 118, 0, 25, 25, 25, 25, + 25, 25, 0, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 143, 144, 0, 25, 25, 0, 25, + 25, 25, 0, 170, 0, 172, 25, 25, 25, 25, + 25, 0, 0, 25, 25, 143, 144, 178, 0, 181, + 25, 183, 0, 185, 25, 187, 25, 25, 18, 18, + 18, 18, 18, 18, 0, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 143, 144, 0, 18, 18, + 0, 18, 18, 18, 143, 144, 143, 144, 18, 18, + 18, 18, 18, 0, 207, 18, 18, 0, 143, 144, + 82, 81, 18, 0, 81, 83, 18, 65, 18, 18, + 39, 39, 39, 39, 39, 39, 143, 144, 81, 81, + 39, 143, 144, 39, 39, 39, 39, 143, 144, 0, + 39, 39, 0, 39, 39, 39, 111, 0, 113, 0, + 39, 39, 39, 39, 39, 0, 126, 39, 39, 0, + 130, 143, 144, 81, 39, 257, 143, 144, 39, 0, + 39, 39, 143, 144, 0, 0, 0, 0, 0, 0, + 0, 59, 59, 59, 59, 0, 0, 0, 163, 0, + 71, 0, 0, 71, 179, 0, 182, 0, 184, 0, + 186, 0, 189, 59, 59, 0, 194, 71, 71, 0, + 0, 0, 71, 0, 283, 0, 284, 0, 285, 286, + 145, 0, 288, 0, 0, 290, 0, 150, 0, 0, + 150, 150, 150, 0, 150, 137, 150, 150, 137, 150, + 0, 0, 71, 209, 210, 211, 212, 213, 214, 215, + 0, 0, 137, 137, 0, 0, 0, 137, 150, 312, + 139, 140, 141, 142, 0, 0, 0, 235, 236, 237, + 238, 239, 241, 0, 0, 0, 0, 0, 0, 87, + 0, 0, 143, 144, 319, 137, 271, 137, 322, 0, + 0, 152, 104, 0, 0, 258, 0, 0, 117, 0, + 163, 262, 264, 266, 0, 0, 0, 0, 268, 0, + 131, 132, 133, 134, 135, 0, 0, 137, 151, 163, + 150, 151, 151, 151, 0, 151, 100, 151, 151, 100, + 151, 0, 145, 0, 272, 0, 273, 0, 0, 81, + 81, 81, 81, 100, 100, 0, 0, 0, 100, 151, + 0, 145, 0, 0, 0, 0, 197, 0, 0, 0, + 179, 81, 81, 0, 0, 81, 0, 0, 0, 0, + 0, 0, 0, 296, 0, 0, 0, 47, 100, 0, + 58, 60, 57, 0, 52, 0, 61, 55, 0, 54, + 0, 308, 0, 139, 140, 141, 142, 0, 0, 158, + 0, 0, 159, 53, 0, 160, 161, 162, 59, 0, + 0, 151, 0, 0, 65, 143, 144, 0, 71, 71, + 71, 71, 0, 0, 0, 0, 0, 71, 0, 0, + 0, 71, 71, 71, 71, 56, 0, 0, 0, 0, + 71, 71, 0, 0, 71, 71, 71, 71, 71, 0, + 71, 150, 150, 150, 150, 150, 0, 0, 0, 0, + 150, 0, 0, 137, 137, 137, 137, 23, 0, 0, + 48, 150, 137, 150, 150, 150, 137, 137, 137, 137, + 150, 150, 150, 150, 150, 137, 137, 150, 150, 137, + 137, 137, 137, 137, 150, 137, 137, 56, 150, 137, + 150, 150, 137, 137, 137, 0, 146, 0, 0, 0, + 147, 148, 149, 150, 159, 56, 0, 160, 161, 162, + 0, 0, 0, 151, 153, 154, 155, 156, 0, 157, + 158, 0, 0, 159, 0, 0, 160, 161, 162, 0, + 0, 0, 151, 151, 151, 151, 151, 0, 0, 56, + 0, 151, 0, 0, 100, 100, 100, 100, 0, 0, + 0, 0, 151, 100, 151, 151, 151, 100, 100, 100, + 100, 151, 151, 151, 151, 151, 100, 100, 151, 151, + 100, 100, 100, 100, 100, 151, 100, 100, 0, 151, + 100, 151, 151, 100, 100, 100, 163, 0, 0, 0, + 22, 24, 25, 26, 27, 28, 0, 0, 0, 0, + 29, 0, 0, 30, 31, 32, 33, 0, 0, 0, + 34, 35, 0, 36, 37, 38, 0, 0, 145, 0, + 39, 40, 41, 42, 43, 0, 0, 44, 45, 0, + 0, 0, 0, 0, 46, 0, 0, 163, 49, 39, + 50, 51, 39, 39, 39, 0, 39, 0, 39, 39, + 0, 39, 85, 85, 0, 0, 0, 0, 0, 0, + 0, 99, 0, 0, 0, 39, 85, 108, 0, 145, + 39, 0, 115, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 85, 85, 85, 85, 85, 0, + 0, 47, 0, 0, 58, 60, 57, 39, 52, 0, + 61, 55, 0, 54, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 56, 56, 56, 56, 0, + 0, 0, 59, 0, 0, 0, 0, 0, 0, 39, + 115, 0, 39, 0, 0, 0, 0, 56, 56, 0, + 0, 0, 0, 47, 0, 0, 58, 60, 57, 56, + 52, 0, 61, 55, 0, 54, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 163, 0, 110, + 0, 0, 0, 0, 59, 0, 0, 147, 148, 149, + 150, 23, 0, 0, 48, 0, 0, 0, 0, 233, + 0, 153, 154, 155, 156, 0, 157, 158, 0, 145, + 159, 56, 0, 160, 161, 162, 0, 0, 0, 0, + 0, 47, 0, 0, 58, 60, 57, 0, 52, 0, + 61, 55, 0, 54, 0, 0, 0, 0, 147, 148, + 149, 150, 0, 0, 0, 0, 48, 0, 0, 0, + 0, 0, 59, 154, 155, 156, 0, 157, 158, 0, + 0, 159, 0, 0, 160, 161, 162, 0, 0, 0, + 0, 0, 39, 39, 39, 39, 39, 39, 0, 56, + 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, 23, 0, 0, 48, 0, 39, 0, 0, 163, + 39, 0, 39, 39, 0, 114, 25, 26, 27, 28, + 83, 0, 47, 0, 29, 58, 60, 57, 0, 52, + 125, 61, 55, 0, 54, 35, 0, 36, 37, 38, + 0, 145, 0, 163, 39, 40, 41, 42, 43, 0, + 0, 44, 45, 59, 0, 0, 0, 0, 46, 0, + 149, 150, 49, 0, 50, 51, 0, 24, 25, 26, + 27, 28, 0, 0, 0, 145, 29, 157, 158, 0, + 56, 159, 0, 0, 160, 161, 162, 35, 0, 36, 37, 38, 0, 0, 0, 0, 39, 40, 41, 42, - 43, 44, 0, 148, 45, 149, 0, 0, 0, 46, - 0, 0, 0, 49, 17, 50, 51, 48, 0, 0, - 0, 0, 0, 0, 0, 0, 25, 26, 27, 28, - 29, 47, 0, 0, 58, 60, 57, 0, 52, 0, - 61, 55, 0, 54, 35, 0, 36, 37, 38, 0, - 0, 0, 0, 39, 40, 41, 42, 43, 44, 0, - 0, 45, 59, 0, 0, 0, 46, 0, 0, 0, - 49, 0, 50, 51, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 56, - 0, 0, 0, 0, 0, 0, 47, 0, 0, 58, - 60, 57, 0, 52, 187, 61, 55, 0, 54, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 17, 0, 0, 48, 0, 0, 59, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 25, 26, - 27, 28, 29, 47, 56, 0, 58, 60, 57, 0, - 52, 0, 61, 55, 0, 54, 35, 0, 36, 37, + 43, 0, 0, 44, 45, 0, 0, 0, 0, 0, + 46, 0, 0, 0, 49, 48, 50, 51, 0, 47, + 163, 0, 58, 60, 57, 0, 52, 0, 61, 55, + 0, 54, 0, 0, 0, 114, 25, 26, 27, 28, + 83, 0, 0, 0, 29, 0, 0, 0, 0, 0, + 59, 0, 145, 0, 0, 35, 0, 36, 37, 38, + 0, 0, 0, 0, 39, 40, 41, 42, 43, 0, + 0, 0, 45, 0, 0, 0, 0, 56, 46, 129, + 0, 0, 49, 0, 50, 51, 0, 47, 0, 0, + 58, 60, 57, 0, 52, 0, 61, 55, 0, 54, + 147, 148, 149, 150, 0, 0, 0, 0, 0, 0, + 0, 0, 48, 0, 0, 0, 155, 156, 59, 157, + 158, 0, 0, 159, 0, 0, 160, 161, 162, 0, + 0, 0, 0, 0, 147, 148, 149, 150, 0, 0, + 0, 244, 0, 0, 245, 56, 24, 25, 26, 27, + 28, 156, 0, 157, 158, 29, 0, 159, 0, 0, + 160, 161, 162, 152, 0, 0, 35, 0, 36, 37, 38, 0, 0, 0, 0, 39, 40, 41, 42, 43, - 44, 218, 0, 45, 59, 0, 17, 0, 46, 48, - 0, 0, 49, 0, 50, 51, 0, 0, 0, 0, - 0, 0, 0, 47, 0, 0, 58, 60, 57, 0, - 52, 56, 61, 55, 0, 54, 0, 0, 141, 0, - 0, 0, 142, 143, 144, 145, 0, 0, 0, 0, - 0, 220, 146, 147, 59, 150, 151, 152, 153, 0, - 154, 155, 0, 17, 156, 0, 48, 0, 0, 0, - 0, 0, 0, 0, 24, 25, 26, 27, 28, 29, - 0, 56, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 35, 0, 36, 37, 38, 0, 148, - 0, 149, 39, 40, 41, 42, 43, 44, 0, 0, - 45, 0, 0, 17, 0, 46, 48, 0, 0, 49, - 47, 50, 51, 58, 60, 57, 0, 52, 0, 61, - 55, 0, 54, 0, 0, 0, 0, 0, 0, 0, - 25, 26, 27, 28, 29, 0, 0, 0, 226, 0, - 0, 59, 0, 0, 0, 0, 0, 0, 35, 0, - 36, 37, 38, 0, 0, 0, 0, 39, 40, 41, - 42, 43, 44, 0, 0, 45, 0, 0, 56, 0, - 46, 0, 0, 0, 49, 0, 50, 51, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 25, 26, 27, - 28, 29, 47, 0, 0, 58, 60, 57, 0, 52, - 17, 61, 55, 48, 54, 35, 0, 36, 37, 38, - 0, 0, 0, 0, 39, 40, 41, 42, 43, 44, - 228, 0, 45, 59, 0, 0, 0, 46, 0, 0, - 0, 49, 0, 50, 51, 0, 0, 25, 26, 27, - 28, 29, 0, 0, 0, 0, 0, 0, 0, 0, - 56, 0, 0, 0, 0, 35, 0, 36, 37, 38, - 0, 0, 0, 0, 39, 40, 41, 42, 43, 44, - 0, 0, 45, 0, 0, 0, 0, 46, 0, 0, - 0, 49, 17, 50, 51, 48, 47, 0, 0, 58, - 60, 57, 0, 52, 0, 61, 55, 0, 54, 0, - 0, 0, 0, 0, 141, 0, 0, 0, 142, 143, - 144, 145, 0, 0, 230, 0, 0, 59, 146, 147, - 0, 150, 151, 152, 153, 0, 154, 155, 0, 0, - 156, 0, 0, 0, 25, 26, 27, 28, 29, 0, - 0, 0, 0, 0, 56, 0, 0, 0, 0, 0, - 127, 0, 35, 127, 36, 37, 38, 0, 0, 0, - 0, 39, 40, 41, 42, 43, 44, 127, 127, 45, - 127, 0, 127, 0, 46, 0, 17, 0, 49, 48, - 50, 51, 47, 0, 0, 58, 60, 57, 0, 52, - 0, 61, 55, 0, 54, 0, 0, 0, 0, 0, - 127, 0, 127, 0, 0, 0, 0, 0, 0, 0, - 232, 0, 0, 59, 0, 0, 25, 26, 27, 28, - 29, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 127, 0, 35, 0, 36, 37, 38, 0, - 56, 0, 0, 39, 40, 41, 42, 43, 44, 0, - 0, 45, 286, 0, 0, 148, 46, 149, 0, 0, - 49, 0, 50, 51, 0, 0, 0, 0, 0, 0, - 0, 0, 17, 0, 0, 48, 47, 0, 0, 58, - 60, 57, 0, 52, 0, 61, 55, 0, 54, 0, + 48, 0, 44, 45, 0, 0, 0, 0, 0, 46, + 0, 163, 0, 49, 0, 50, 51, 0, 47, 0, + 163, 58, 60, 57, 0, 52, 193, 61, 55, 0, + 54, 147, 148, 149, 150, 0, 0, 0, 0, 0, + 0, 0, 163, 145, 0, 0, 0, 0, 0, 59, + 157, 158, 145, 78, 159, 0, 78, 160, 161, 162, + 0, 0, 0, 24, 25, 26, 27, 28, 0, 0, + 78, 78, 29, 0, 145, 78, 56, 0, 0, 0, + 0, 0, 0, 35, 0, 36, 37, 38, 0, 0, + 0, 0, 39, 40, 41, 42, 43, 0, 0, 44, + 45, 0, 0, 0, 0, 78, 46, 0, 0, 0, + 49, 48, 50, 51, 47, 163, 0, 58, 60, 57, + 0, 52, 240, 61, 55, 0, 54, 0, 0, 0, + 22, 24, 25, 26, 27, 28, 0, 0, 0, 0, + 29, 0, 0, 0, 0, 59, 0, 145, 0, 0, + 0, 35, 0, 36, 37, 38, 0, 0, 0, 0, + 39, 40, 41, 42, 43, 0, 0, 44, 45, 0, + 0, 0, 56, 0, 46, 0, 0, 0, 49, 0, + 50, 51, 0, 47, 0, 0, 58, 60, 57, 0, + 52, 263, 61, 55, 0, 54, 0, 0, 146, 0, + 0, 0, 147, 148, 149, 150, 0, 48, 0, 0, + 0, 0, 0, 149, 59, 151, 153, 154, 155, 156, + 0, 157, 158, 0, 0, 159, 0, 0, 160, 161, + 162, 158, 0, 147, 159, 149, 150, 160, 161, 162, + 0, 56, 24, 25, 26, 27, 28, 0, 0, 0, + 0, 29, 157, 158, 0, 0, 159, 0, 0, 160, + 161, 162, 35, 0, 36, 37, 38, 0, 0, 0, + 0, 39, 40, 41, 42, 43, 48, 0, 44, 45, + 0, 78, 78, 78, 78, 46, 0, 0, 0, 49, + 47, 50, 51, 58, 60, 57, 0, 52, 265, 61, + 55, 0, 54, 78, 78, 0, 0, 78, 149, 150, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 234, 0, 0, 59, 0, 0, - 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, + 0, 59, 0, 0, 0, 0, 158, 0, 0, 159, + 0, 0, 160, 161, 162, 0, 0, 0, 24, 25, + 26, 27, 28, 0, 0, 0, 0, 29, 56, 0, 0, 0, 0, 0, 0, 0, 0, 0, 35, 0, - 36, 37, 38, 0, 56, 0, 0, 39, 40, 41, - 42, 43, 44, 0, 0, 45, 0, 0, 0, 0, - 46, 0, 0, 0, 49, 47, 50, 51, 58, 60, - 57, 0, 52, 0, 61, 55, 17, 54, 0, 48, - 0, 0, 0, 0, 0, 0, 127, 127, 127, 127, - 0, 0, 0, 237, 0, 127, 59, 0, 0, 127, - 127, 0, 0, 0, 0, 0, 0, 0, 0, 127, - 127, 0, 127, 127, 127, 127, 25, 26, 27, 28, - 29, 0, 0, 56, 127, 127, 127, 0, 0, 0, - 0, 0, 0, 0, 35, 0, 36, 37, 38, 0, - 0, 0, 0, 39, 40, 41, 42, 43, 44, 0, - 0, 45, 0, 0, 0, 17, 46, 0, 48, 0, - 49, 0, 50, 51, 0, 47, 0, 0, 58, 60, - 57, 0, 52, 248, 61, 55, 0, 54, 0, 0, - 141, 0, 0, 0, 142, 143, 144, 145, 0, 0, - 0, 0, 0, 0, 146, 147, 59, 150, 151, 152, - 153, 0, 154, 155, 0, 0, 156, 0, 0, 0, - 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, - 0, 0, 0, 56, 0, 0, 0, 0, 35, 0, 36, 37, 38, 0, 0, 0, 0, 39, 40, 41, - 42, 43, 44, 0, 0, 45, 0, 0, 53, 0, - 46, 53, 0, 0, 49, 17, 50, 51, 48, 0, - 0, 0, 0, 0, 47, 53, 53, 58, 60, 57, - 0, 52, 271, 61, 55, 0, 54, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 25, - 26, 27, 28, 29, 0, 59, 0, 0, 53, 0, - 53, 0, 0, 0, 0, 0, 0, 35, 0, 36, + 42, 43, 0, 75, 44, 45, 75, 0, 0, 0, + 0, 46, 0, 48, 0, 49, 0, 50, 51, 47, + 75, 75, 58, 60, 57, 75, 52, 0, 61, 55, + 0, 54, 0, 0, 0, 0, 0, 24, 25, 26, + 27, 28, 0, 0, 0, 0, 29, 0, 0, 0, + 59, 0, 0, 0, 0, 75, 0, 35, 0, 36, 37, 38, 0, 0, 0, 0, 39, 40, 41, 42, - 43, 44, 56, 0, 45, 0, 0, 0, 0, 46, - 53, 0, 0, 49, 0, 50, 51, 47, 0, 0, - 58, 60, 57, 0, 52, 273, 61, 55, 0, 54, - 0, 0, 0, 0, 17, 0, 0, 48, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 59, 0, + 43, 0, 0, 44, 45, 0, 0, 56, 0, 0, + 46, 0, 0, 0, 49, 47, 50, 51, 58, 60, + 57, 0, 52, 0, 61, 55, 0, 54, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, + 0, 0, 48, 0, 0, 0, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 25, - 26, 27, 28, 29, 0, 56, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 35, 0, 36, - 37, 38, 0, 0, 0, 0, 39, 40, 41, 42, - 43, 44, 0, 0, 45, 0, 0, 17, 0, 46, - 48, 0, 0, 49, 0, 50, 51, 47, 0, 0, - 58, 60, 57, 0, 52, 0, 61, 55, 0, 54, + 0, 0, 131, 0, 0, 131, 0, 0, 0, 0, + 0, 0, 0, 56, 24, 25, 26, 27, 28, 131, + 131, 0, 0, 29, 131, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 35, 0, 36, 37, 38, 0, + 0, 0, 0, 39, 40, 41, 42, 43, 48, 0, + 44, 45, 131, 0, 131, 0, 0, 46, 0, 0, + 0, 49, 47, 50, 51, 58, 60, 57, 0, 52, + 0, 61, 55, 0, 54, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 131, 0, 0, 0, 0, 0, + 0, 0, 0, 59, 0, 0, 0, 0, 0, 0, + 0, 75, 75, 75, 75, 0, 0, 0, 0, 0, + 75, 0, 0, 105, 25, 26, 27, 28, 0, 0, + 56, 0, 29, 75, 75, 0, 0, 75, 75, 75, + 75, 75, 0, 35, 0, 36, 37, 38, 0, 0, + 0, 0, 39, 40, 41, 42, 43, 0, 0, 0, + 45, 0, 23, 0, 0, 48, 46, 0, 0, 0, + 49, 47, 50, 51, 58, 60, 57, 0, 52, 0, + 61, 55, 0, 54, 0, 0, 0, 0, 0, 24, + 25, 26, 27, 28, 0, 0, 0, 0, 29, 0, + 0, 0, 59, 0, 0, 0, 0, 0, 0, 35, + 0, 36, 37, 38, 0, 0, 0, 0, 39, 40, + 41, 42, 43, 0, 0, 44, 45, 0, 0, 56, + 0, 0, 46, 0, 0, 0, 49, 0, 50, 51, + 131, 131, 131, 131, 0, 0, 0, 0, 0, 131, + 0, 0, 0, 131, 131, 131, 131, 0, 0, 0, + 0, 0, 131, 131, 48, 0, 131, 131, 131, 131, + 131, 116, 131, 131, 116, 0, 131, 0, 0, 131, + 131, 131, 0, 0, 0, 0, 0, 0, 116, 116, + 0, 0, 0, 116, 0, 0, 24, 25, 26, 27, + 28, 0, 0, 0, 0, 29, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 35, 0, 36, 37, + 38, 116, 0, 116, 0, 39, 40, 41, 42, 43, + 0, 0, 137, 45, 0, 137, 0, 0, 0, 46, + 0, 0, 0, 49, 0, 50, 51, 0, 0, 137, + 137, 0, 0, 116, 137, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 277, 0, 0, 0, 0, 59, 0, - 0, 0, 0, 0, 53, 53, 53, 53, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 25, 26, - 27, 28, 29, 0, 0, 56, 0, 53, 53, 0, - 0, 0, 0, 0, 97, 0, 35, 97, 36, 37, - 38, 0, 53, 53, 53, 39, 40, 41, 42, 43, - 44, 97, 97, 45, 97, 0, 97, 17, 46, 0, - 48, 0, 49, 0, 50, 51, 47, 0, 0, 58, - 60, 57, 0, 52, 281, 61, 55, 0, 54, 0, - 0, 0, 0, 0, 97, 0, 97, 0, 0, 0, - 0, 25, 26, 27, 28, 29, 0, 59, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 35, - 0, 36, 37, 38, 0, 0, 97, 0, 39, 40, - 41, 42, 43, 44, 56, 0, 45, 0, 0, 0, - 0, 46, 0, 0, 0, 49, 0, 50, 51, 47, - 0, 0, 58, 60, 57, 0, 52, 0, 61, 55, - 0, 54, 0, 0, 0, 0, 17, 0, 0, 48, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 137, 126, 137, 0, 126, 0, 0, 0, + 0, 0, 0, 0, 0, 24, 25, 26, 27, 28, + 126, 126, 0, 0, 29, 126, 0, 0, 0, 0, + 0, 0, 0, 0, 137, 35, 0, 36, 37, 38, + 0, 0, 0, 0, 39, 40, 41, 42, 43, 140, + 0, 0, 45, 0, 0, 126, 0, 0, 46, 0, + 0, 0, 49, 0, 50, 51, 140, 140, 0, 0, + 0, 140, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 126, 0, 0, 0, 0, + 0, 139, 0, 0, 139, 0, 0, 0, 0, 140, + 0, 140, 0, 0, 0, 0, 0, 0, 139, 139, + 0, 0, 0, 139, 0, 0, 0, 0, 0, 116, + 116, 116, 116, 0, 0, 0, 0, 0, 116, 0, + 0, 140, 116, 116, 116, 116, 0, 0, 0, 0, + 0, 116, 116, 139, 0, 116, 116, 116, 116, 116, + 0, 116, 116, 94, 0, 116, 94, 0, 116, 116, + 116, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 94, 94, 0, 139, 0, 94, 0, 0, 0, 0, + 137, 137, 137, 137, 0, 0, 0, 0, 0, 137, + 0, 0, 0, 137, 137, 137, 137, 0, 0, 0, + 60, 0, 137, 137, 0, 94, 137, 137, 137, 137, + 137, 0, 137, 137, 0, 0, 137, 60, 60, 137, + 137, 137, 60, 0, 0, 0, 0, 0, 0, 0, + 0, 126, 126, 126, 126, 94, 0, 0, 0, 0, + 126, 0, 0, 0, 126, 126, 126, 126, 0, 0, + 60, 0, 60, 126, 126, 0, 0, 126, 126, 126, + 126, 126, 0, 126, 126, 0, 0, 126, 0, 0, + 126, 126, 126, 0, 0, 0, 0, 140, 140, 140, + 140, 0, 60, 0, 127, 0, 140, 127, 0, 0, + 140, 140, 140, 140, 0, 0, 0, 0, 0, 140, + 140, 127, 127, 140, 140, 140, 140, 140, 0, 140, + 140, 0, 0, 140, 0, 0, 140, 140, 140, 139, + 139, 139, 139, 0, 0, 0, 58, 0, 139, 58, + 0, 0, 139, 139, 139, 139, 127, 0, 0, 0, + 0, 139, 139, 58, 58, 139, 139, 139, 139, 139, + 57, 139, 139, 57, 0, 139, 0, 0, 139, 139, + 139, 0, 0, 0, 0, 0, 0, 57, 57, 0, + 0, 0, 57, 0, 0, 0, 0, 0, 58, 0, + 0, 94, 94, 94, 94, 0, 0, 0, 0, 0, + 94, 0, 0, 0, 94, 94, 94, 94, 0, 0, + 0, 0, 57, 94, 94, 0, 0, 94, 94, 94, + 94, 94, 0, 94, 94, 0, 0, 94, 0, 0, + 94, 94, 94, 0, 0, 0, 0, 0, 60, 60, + 60, 60, 57, 0, 0, 0, 0, 60, 0, 0, + 0, 60, 60, 60, 60, 0, 0, 0, 0, 0, + 60, 60, 0, 0, 60, 60, 60, 60, 60, 93, + 60, 60, 93, 0, 60, 0, 0, 60, 60, 60, + 0, 0, 0, 0, 0, 0, 93, 93, 0, 0, + 0, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 25, 26, 27, 28, 29, 0, 56, 0, 283, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 35, - 0, 36, 37, 38, 0, 0, 0, 0, 39, 40, - 41, 42, 43, 44, 0, 0, 45, 0, 0, 17, - 0, 46, 48, 0, 0, 49, 0, 50, 51, 47, - 0, 0, 58, 60, 57, 0, 52, 0, 61, 55, - 0, 54, 0, 0, 0, 0, 0, 0, 0, 0, - 97, 97, 97, 97, 0, 0, 0, 0, 0, 97, - 59, 0, 0, 97, 97, 0, 0, 0, 0, 0, - 0, 0, 0, 97, 97, 0, 97, 97, 97, 97, - 25, 26, 27, 28, 29, 0, 0, 56, 97, 97, - 97, 0, 0, 0, 0, 0, 0, 0, 35, 0, - 36, 37, 38, 0, 0, 0, 0, 39, 40, 41, - 42, 43, 44, 0, 0, 45, 0, 0, 0, 17, - 46, 0, 48, 0, 49, 0, 50, 51, 47, 0, - 0, 58, 60, 57, 0, 52, 0, 61, 55, 0, - 54, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 25, 26, 27, 28, 29, 0, 59, + 0, 139, 0, 0, 139, 0, 0, 0, 0, 0, + 0, 93, 127, 127, 127, 127, 0, 0, 139, 139, + 0, 0, 0, 139, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 127, 127, 0, 0, 0, 0, + 0, 93, 0, 128, 0, 0, 128, 0, 0, 0, + 0, 0, 0, 139, 58, 58, 58, 58, 0, 0, + 128, 128, 0, 0, 0, 128, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 58, 58, 57, 57, + 57, 57, 0, 0, 0, 69, 0, 57, 69, 0, + 0, 57, 57, 57, 57, 128, 0, 0, 0, 0, + 57, 57, 69, 69, 57, 57, 57, 57, 57, 100, + 57, 57, 100, 0, 57, 0, 0, 57, 57, 57, + 0, 0, 0, 0, 0, 0, 100, 100, 0, 0, + 0, 100, 0, 0, 0, 0, 0, 69, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 35, 0, 36, 37, 38, 0, 0, 0, 0, - 39, 40, 41, 42, 43, 44, 56, 138, 45, 0, - 138, 0, 0, 46, 0, 0, 0, 49, 0, 50, - 51, 0, 0, 0, 138, 138, 0, 138, 0, 138, - 0, 0, 0, 0, 0, 0, 0, 0, 17, 0, - 0, 48, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 138, 0, 138, - 0, 0, 122, 0, 0, 122, 0, 0, 0, 0, - 0, 0, 0, 25, 26, 27, 28, 29, 0, 122, - 122, 0, 122, 0, 122, 0, 0, 0, 0, 138, - 0, 35, 0, 36, 37, 38, 0, 0, 0, 0, - 39, 40, 41, 42, 43, 44, 144, 0, 45, 144, - 0, 0, 122, 46, 122, 0, 0, 49, 0, 50, - 51, 0, 0, 144, 144, 0, 144, 0, 144, 0, + 0, 0, 106, 0, 0, 106, 0, 0, 0, 0, + 0, 100, 0, 0, 0, 0, 0, 0, 0, 106, + 106, 0, 0, 0, 106, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 304, 0, 93, 93, 93, + 93, 0, 0, 0, 0, 0, 93, 0, 0, 0, + 93, 93, 93, 93, 106, 0, 0, 152, 0, 93, + 93, 0, 0, 93, 93, 93, 93, 93, 0, 93, + 93, 0, 0, 93, 0, 0, 93, 93, 93, 139, + 139, 139, 139, 0, 0, 163, 0, 0, 139, 0, + 0, 0, 139, 139, 139, 139, 0, 0, 0, 0, + 0, 139, 139, 0, 0, 139, 139, 139, 139, 139, + 0, 139, 139, 0, 0, 139, 0, 145, 139, 139, + 139, 128, 128, 128, 128, 0, 0, 0, 0, 0, + 128, 0, 0, 0, 128, 128, 128, 128, 0, 0, + 0, 0, 0, 128, 128, 0, 0, 128, 128, 128, + 128, 128, 90, 128, 128, 90, 0, 128, 0, 0, + 128, 128, 128, 69, 69, 69, 69, 0, 0, 90, + 90, 0, 0, 0, 90, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 69, 69, 100, 100, 100, + 100, 0, 0, 0, 0, 0, 100, 0, 0, 0, + 100, 100, 100, 100, 90, 0, 0, 0, 0, 100, + 100, 0, 0, 100, 100, 100, 100, 100, 0, 100, + 100, 0, 0, 100, 0, 0, 100, 100, 100, 0, + 106, 106, 106, 106, 0, 0, 0, 0, 0, 106, + 0, 0, 0, 106, 106, 106, 106, 0, 0, 0, + 0, 0, 106, 106, 0, 0, 106, 106, 106, 106, + 106, 0, 106, 106, 91, 0, 106, 91, 0, 106, + 106, 106, 146, 0, 0, 0, 147, 148, 149, 150, + 0, 91, 91, 0, 0, 0, 91, 0, 0, 151, + 153, 154, 155, 156, 0, 157, 158, 0, 0, 159, + 0, 0, 160, 161, 162, 85, 0, 0, 85, 0, + 0, 0, 0, 0, 0, 0, 91, 0, 0, 0, + 0, 0, 85, 85, 0, 0, 0, 85, 0, 0, + 0, 0, 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, 85, 0, 0, + 0, 0, 86, 86, 0, 0, 0, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 122, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 144, 0, 144, 0, - 0, 147, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 103, 26, 27, 28, 29, 0, 147, 147, - 0, 147, 0, 147, 0, 0, 0, 0, 144, 0, - 35, 0, 36, 37, 38, 0, 0, 0, 0, 39, - 40, 41, 42, 43, 44, 0, 0, 45, 0, 0, - 0, 147, 46, 147, 0, 0, 49, 0, 50, 51, + 90, 90, 90, 90, 0, 0, 0, 0, 0, 90, + 0, 0, 0, 90, 90, 90, 90, 86, 0, 0, + 0, 87, 90, 90, 87, 0, 90, 90, 90, 90, + 90, 0, 90, 90, 0, 0, 90, 0, 87, 87, + 0, 0, 0, 87, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 83, 0, 0, - 83, 0, 0, 138, 138, 138, 138, 0, 0, 0, - 0, 0, 138, 147, 83, 83, 138, 138, 138, 138, - 0, 0, 0, 0, 0, 0, 138, 138, 0, 138, - 138, 138, 138, 0, 138, 138, 0, 0, 138, 0, - 0, 138, 138, 138, 0, 0, 0, 83, 0, 83, - 0, 0, 0, 0, 0, 0, 0, 0, 122, 122, - 122, 122, 0, 0, 0, 0, 0, 122, 0, 0, - 0, 122, 122, 122, 122, 0, 0, 0, 0, 83, - 0, 122, 122, 0, 122, 122, 122, 122, 0, 122, - 122, 0, 99, 122, 0, 99, 122, 122, 122, 0, - 0, 0, 144, 144, 144, 144, 0, 0, 0, 99, - 99, 144, 99, 0, 99, 144, 144, 144, 144, 0, - 0, 0, 0, 0, 0, 144, 144, 0, 144, 144, - 144, 144, 0, 144, 144, 0, 0, 144, 0, 0, - 144, 144, 144, 0, 99, 0, 0, 98, 0, 0, - 98, 0, 0, 0, 0, 0, 0, 147, 147, 147, - 147, 0, 0, 0, 98, 98, 147, 98, 0, 98, - 147, 147, 147, 147, 99, 0, 0, 0, 0, 0, - 147, 147, 0, 147, 147, 147, 147, 0, 147, 147, - 86, 0, 147, 86, 0, 147, 147, 147, 0, 98, - 0, 0, 0, 0, 0, 0, 0, 86, 86, 0, - 86, 0, 86, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 83, 83, 83, 83, 0, 0, 98, - 0, 72, 0, 0, 72, 0, 0, 0, 0, 0, - 86, 0, 86, 0, 0, 0, 83, 83, 72, 72, - 0, 72, 0, 72, 0, 0, 0, 0, 0, 0, - 0, 83, 83, 83, 0, 0, 0, 0, 0, 0, - 0, 0, 86, 133, 0, 0, 133, 0, 0, 0, - 0, 72, 0, 72, 0, 0, 0, 0, 0, 0, - 133, 133, 0, 133, 0, 133, 0, 0, 0, 0, + 83, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 87, 83, 83, 0, 0, 0, 83, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 72, 0, 0, 0, 0, 99, 99, - 99, 99, 0, 0, 0, 133, 0, 99, 0, 0, - 0, 99, 99, 99, 99, 0, 0, 0, 0, 0, - 0, 99, 99, 0, 99, 99, 99, 99, 0, 99, - 99, 0, 0, 99, 0, 0, 99, 99, 99, 0, - 0, 0, 0, 146, 0, 0, 146, 0, 0, 0, - 0, 0, 0, 98, 98, 98, 98, 0, 0, 0, - 146, 146, 98, 146, 0, 146, 98, 98, 98, 98, - 0, 0, 0, 0, 0, 0, 98, 98, 0, 98, - 98, 98, 98, 0, 98, 98, 0, 0, 98, 0, - 0, 98, 98, 98, 0, 146, 86, 86, 86, 86, - 0, 0, 0, 0, 0, 86, 0, 0, 0, 86, - 86, 86, 86, 0, 0, 0, 0, 0, 0, 86, - 86, 0, 86, 86, 86, 86, 0, 86, 86, 0, - 0, 0, 0, 0, 86, 86, 86, 72, 72, 72, - 72, 0, 0, 0, 0, 0, 72, 0, 0, 0, - 72, 72, 72, 72, 0, 0, 0, 0, 0, 0, - 72, 72, 0, 72, 72, 72, 72, 0, 72, 72, - 0, 0, 0, 0, 0, 72, 72, 72, 0, 133, - 133, 133, 133, 0, 0, 0, 0, 0, 133, 0, - 0, 0, 133, 133, 133, 133, 0, 0, 0, 0, - 0, 0, 133, 133, 0, 133, 133, 133, 133, 135, - 133, 133, 135, 0, 133, 0, 0, 133, 133, 133, - 0, 0, 0, 0, 0, 0, 135, 135, 0, 135, - 0, 135, 0, 0, 0, 0, 0, 0, 0, 0, + 84, 0, 0, 84, 0, 0, 0, 0, 0, 83, + 0, 0, 91, 91, 91, 91, 0, 84, 84, 0, + 0, 91, 84, 0, 0, 91, 91, 91, 91, 0, + 0, 0, 0, 0, 91, 91, 0, 0, 91, 91, + 91, 91, 91, 0, 91, 91, 0, 0, 91, 0, + 0, 0, 84, 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, 0, + 0, 0, 0, 86, 86, 86, 86, 0, 0, 0, + 0, 0, 86, 0, 0, 0, 86, 86, 86, 86, + 0, 0, 0, 0, 82, 86, 86, 82, 0, 86, + 86, 86, 86, 86, 0, 86, 86, 0, 0, 0, + 0, 82, 82, 0, 0, 0, 82, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 87, + 87, 87, 87, 0, 0, 0, 0, 0, 87, 0, + 0, 0, 87, 87, 87, 87, 82, 0, 0, 0, + 0, 87, 87, 0, 0, 87, 87, 87, 87, 87, + 0, 87, 87, 0, 0, 83, 83, 83, 83, 0, + 0, 0, 0, 0, 83, 0, 0, 0, 83, 83, + 83, 83, 0, 0, 0, 0, 0, 83, 83, 0, + 0, 83, 83, 83, 83, 83, 70, 83, 83, 70, + 0, 0, 0, 0, 0, 0, 0, 0, 84, 84, + 84, 84, 0, 70, 70, 0, 0, 84, 70, 0, + 0, 84, 84, 84, 84, 0, 0, 0, 0, 0, + 84, 84, 0, 0, 84, 84, 84, 84, 84, 72, + 84, 84, 72, 0, 0, 0, 0, 0, 70, 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, 0, 0, 0, 0, 0, 0, 0, 0, 110, - 0, 135, 110, 0, 0, 0, 0, 0, 0, 146, - 146, 146, 146, 0, 0, 0, 110, 110, 146, 110, - 0, 110, 146, 146, 146, 146, 0, 0, 0, 0, - 0, 0, 146, 146, 0, 146, 146, 146, 146, 0, - 146, 146, 104, 0, 146, 104, 0, 146, 146, 146, - 0, 110, 0, 0, 0, 0, 0, 0, 0, 104, - 104, 0, 104, 0, 104, 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, 0, 73, 0, 0, 73, 0, 0, 0, - 0, 0, 0, 0, 104, 0, 0, 0, 0, 0, - 73, 73, 0, 73, 0, 73, 0, 0, 0, 0, + 0, 120, 0, 0, 120, 0, 0, 0, 0, 0, + 0, 0, 82, 82, 82, 82, 0, 73, 120, 120, + 0, 82, 0, 120, 0, 82, 82, 82, 82, 0, + 0, 0, 0, 92, 82, 82, 92, 0, 82, 82, + 82, 82, 82, 0, 82, 82, 0, 0, 0, 0, + 92, 92, 0, 120, 0, 92, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 130, 0, 0, 130, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 74, - 0, 0, 74, 73, 0, 73, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 74, 74, 0, 74, - 0, 74, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 73, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 135, 135, 135, 135, 74, - 0, 74, 0, 0, 135, 0, 0, 0, 135, 135, - 135, 135, 0, 0, 0, 0, 0, 0, 135, 135, - 0, 135, 135, 135, 135, 0, 135, 135, 0, 0, - 135, 74, 0, 135, 135, 135, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 110, 110, 110, 110, 0, - 0, 0, 0, 0, 110, 0, 0, 0, 110, 110, - 110, 110, 0, 0, 0, 0, 0, 0, 110, 110, - 0, 110, 110, 110, 110, 0, 110, 110, 0, 0, - 110, 0, 0, 110, 110, 110, 0, 0, 104, 104, - 104, 104, 0, 0, 0, 0, 0, 104, 0, 0, - 0, 104, 104, 104, 104, 0, 0, 0, 0, 0, - 0, 104, 104, 0, 104, 104, 104, 104, 0, 104, - 104, 0, 0, 104, 0, 0, 104, 104, 104, 73, - 73, 73, 73, 0, 0, 0, 0, 0, 73, 0, - 0, 0, 73, 73, 73, 73, 0, 0, 0, 0, - 0, 0, 73, 73, 0, 73, 73, 73, 73, 0, - 73, 0, 0, 0, 0, 0, 0, 73, 73, 73, - 0, 0, 0, 0, 0, 74, 74, 74, 74, 0, - 0, 0, 0, 0, 74, 0, 0, 0, 74, 74, - 75, 74, 0, 75, 0, 0, 0, 0, 74, 74, - 0, 74, 74, 74, 74, 0, 74, 75, 75, 0, - 75, 0, 75, 74, 74, 74, 0, 0, 0, 0, + 0, 0, 0, 130, 130, 92, 0, 0, 130, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 137, 0, 0, 137, 0, 0, 0, 0, 0, - 75, 0, 75, 0, 0, 0, 0, 0, 137, 137, - 0, 137, 0, 137, 0, 0, 0, 0, 0, 0, + 0, 0, 74, 0, 0, 74, 0, 0, 0, 0, + 0, 0, 0, 0, 70, 70, 70, 70, 130, 74, + 74, 0, 0, 70, 74, 0, 0, 70, 70, 70, + 70, 0, 0, 0, 0, 0, 70, 70, 0, 0, + 70, 70, 70, 70, 70, 76, 70, 70, 76, 0, + 0, 0, 0, 0, 74, 0, 0, 72, 72, 72, + 72, 0, 76, 76, 0, 0, 72, 76, 0, 0, + 72, 72, 0, 72, 0, 0, 0, 0, 0, 72, + 72, 0, 0, 72, 72, 72, 72, 72, 0, 72, + 0, 0, 0, 73, 73, 73, 73, 76, 0, 0, + 152, 0, 73, 0, 0, 0, 73, 73, 0, 0, + 0, 0, 0, 0, 0, 73, 73, 0, 0, 73, + 73, 73, 73, 73, 0, 73, 0, 0, 163, 120, + 120, 120, 120, 0, 0, 0, 0, 0, 120, 0, + 0, 0, 120, 120, 0, 0, 0, 0, 0, 0, + 77, 120, 120, 77, 0, 120, 120, 120, 120, 120, + 145, 92, 92, 92, 92, 0, 0, 77, 77, 0, + 92, 0, 77, 0, 92, 92, 0, 0, 0, 0, + 0, 0, 79, 92, 92, 79, 0, 92, 92, 92, + 92, 92, 0, 0, 130, 130, 130, 130, 0, 79, + 79, 0, 77, 130, 79, 0, 0, 130, 130, 0, + 0, 0, 0, 0, 0, 0, 130, 130, 0, 0, + 130, 130, 130, 130, 130, 80, 0, 0, 80, 0, + 74, 74, 74, 74, 79, 0, 0, 0, 0, 74, + 0, 0, 80, 80, 74, 0, 0, 80, 0, 0, + 152, 0, 74, 74, 0, 0, 74, 74, 74, 74, + 74, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 76, 76, 76, 76, 80, 163, 0, + 0, 0, 76, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 76, 76, 0, 0, 76, + 76, 76, 76, 76, 0, 0, 0, 0, 0, 0, + 145, 0, 0, 0, 0, 146, 0, 0, 0, 147, + 148, 149, 150, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 151, 153, 154, 155, 156, 0, 157, 158, + 0, 0, 159, 0, 0, 160, 161, 162, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 75, 76, 0, 0, 76, 0, 0, 0, - 0, 137, 0, 137, 0, 0, 0, 0, 0, 0, - 76, 76, 0, 76, 0, 76, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 137, 77, 0, 0, 77, 0, 0, - 0, 0, 0, 76, 0, 76, 0, 0, 0, 0, - 0, 77, 77, 0, 77, 0, 77, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 77, 77, + 77, 77, 0, 0, 0, 0, 0, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 76, 78, 0, 0, 78, - 0, 0, 0, 0, 77, 0, 77, 0, 0, 0, - 0, 0, 0, 78, 78, 0, 78, 0, 78, 0, + 77, 77, 0, 0, 77, 77, 77, 77, 0, 0, + 79, 79, 79, 79, 0, 100, 0, 0, 0, 79, + 107, 109, 0, 0, 0, 0, 119, 120, 121, 122, + 123, 124, 79, 79, 127, 128, 79, 79, 79, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 77, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 78, 0, 78, 0, - 0, 0, 0, 0, 0, 0, 75, 75, 75, 75, - 0, 0, 0, 0, 0, 75, 0, 0, 0, 75, - 75, 0, 0, 0, 0, 0, 0, 0, 78, 75, - 75, 0, 75, 75, 75, 75, 0, 75, 0, 0, - 0, 0, 0, 0, 75, 75, 75, 137, 137, 137, - 137, 0, 0, 0, 0, 0, 137, 0, 0, 0, - 137, 137, 0, 0, 0, 0, 0, 0, 0, 0, - 137, 137, 0, 137, 137, 137, 137, 0, 0, 0, - 0, 0, 0, 0, 0, 137, 137, 137, 0, 76, - 76, 76, 76, 0, 0, 0, 0, 0, 76, 0, - 0, 0, 0, 76, 0, 0, 0, 0, 0, 0, - 0, 0, 76, 76, 0, 76, 76, 76, 76, 0, - 0, 0, 0, 0, 0, 0, 0, 76, 76, 76, - 77, 77, 77, 77, 63, 0, 0, 63, 0, 77, + 0, 0, 0, 80, 80, 80, 80, 0, 0, 0, + 0, 0, 80, 0, 0, 146, 0, 0, 177, 147, + 148, 149, 150, 0, 0, 80, 80, 0, 0, 80, + 80, 0, 0, 153, 154, 155, 156, 0, 157, 158, + 0, 0, 159, 0, 0, 160, 161, 162, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 208, 0, + 0, 0, 0, 0, 0, 0, 216, 217, 218, 219, + 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 63, 63, 77, 77, 0, 77, 77, 77, 77, - 0, 0, 0, 0, 0, 0, 0, 0, 77, 77, - 77, 0, 78, 78, 78, 78, 0, 0, 0, 0, - 0, 78, 0, 0, 63, 79, 63, 0, 79, 0, - 0, 0, 0, 0, 0, 78, 78, 0, 78, 78, - 78, 78, 79, 79, 0, 79, 0, 79, 0, 0, - 78, 78, 78, 0, 0, 0, 63, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 81, 0, 0, 81, - 0, 0, 0, 0, 0, 79, 82, 79, 0, 82, - 0, 0, 0, 81, 81, 0, 81, 0, 81, 0, - 0, 0, 0, 82, 82, 0, 82, 0, 82, 0, - 0, 0, 0, 0, 0, 0, 0, 79, 0, 0, - 0, 0, 0, 0, 0, 0, 81, 80, 81, 0, - 80, 0, 0, 0, 85, 0, 82, 85, 82, 65, - 0, 0, 65, 0, 80, 80, 0, 80, 0, 80, - 0, 85, 85, 0, 85, 0, 65, 65, 81, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 82, 0, - 0, 0, 0, 0, 0, 0, 0, 80, 0, 80, - 0, 0, 0, 0, 85, 66, 85, 0, 66, 65, - 71, 65, 0, 71, 0, 0, 0, 0, 0, 0, - 0, 0, 66, 66, 0, 0, 0, 71, 71, 80, - 63, 63, 63, 63, 0, 0, 85, 0, 0, 0, - 0, 65, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 63, 63, 66, 0, 66, 0, 0, - 71, 70, 71, 0, 70, 0, 0, 0, 63, 63, - 63, 0, 0, 0, 0, 0, 0, 0, 70, 70, - 0, 79, 79, 79, 79, 0, 0, 66, 0, 0, - 79, 0, 71, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 79, 79, 0, 79, 79, 79, - 0, 70, 0, 70, 0, 0, 0, 0, 0, 79, - 79, 79, 81, 81, 81, 81, 0, 0, 0, 0, - 0, 81, 82, 82, 82, 82, 0, 0, 0, 0, - 0, 82, 0, 70, 0, 81, 81, 146, 81, 81, - 146, 0, 0, 0, 0, 82, 82, 0, 82, 0, - 81, 81, 81, 0, 146, 146, 0, 146, 0, 146, - 82, 82, 82, 80, 80, 80, 80, 0, 0, 0, - 85, 85, 85, 85, 0, 65, 65, 65, 65, 0, - 0, 0, 0, 0, 0, 0, 80, 80, 69, 146, - 0, 69, 0, 85, 85, 0, 0, 0, 65, 65, - 0, 80, 80, 80, 0, 69, 69, 0, 85, 85, - 85, 0, 0, 65, 65, 65, 0, 68, 0, 0, - 68, 66, 66, 66, 66, 0, 71, 71, 71, 71, - 0, 0, 0, 0, 68, 68, 67, 0, 69, 67, - 69, 0, 0, 0, 66, 66, 0, 0, 0, 71, - 71, 0, 0, 67, 67, 0, 0, 0, 0, 66, - 66, 66, 0, 0, 71, 71, 71, 68, 0, 68, - 69, 0, 0, 0, 0, 0, 0, 70, 70, 70, - 70, 0, 0, 0, 0, 0, 67, 64, 67, 0, - 64, 0, 0, 0, 0, 0, 0, 0, 0, 68, - 70, 70, 0, 0, 64, 64, 87, 0, 0, 87, - 0, 0, 0, 0, 0, 70, 70, 70, 67, 0, - 0, 0, 0, 87, 87, 0, 87, 0, 87, 0, - 0, 0, 0, 0, 0, 0, 0, 64, 0, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 90, 0, 0, 90, 0, 87, 0, - 0, 0, 0, 146, 146, 146, 146, 0, 0, 64, - 90, 90, 146, 90, 0, 90, 146, 146, 146, 146, - 0, 0, 0, 0, 0, 0, 146, 146, 0, 146, - 146, 146, 146, 0, 146, 146, 0, 0, 146, 0, - 0, 146, 146, 91, 0, 90, 91, 0, 0, 0, - 0, 0, 0, 0, 69, 69, 69, 69, 0, 0, - 91, 91, 0, 91, 0, 91, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 69, 69, 92, - 0, 0, 92, 68, 68, 68, 68, 0, 0, 0, - 0, 0, 69, 69, 69, 91, 92, 92, 0, 92, - 0, 92, 67, 67, 67, 67, 68, 68, 0, 0, - 0, 0, 0, 0, 0, 95, 0, 0, 95, 0, - 0, 68, 68, 68, 0, 67, 67, 0, 0, 0, - 0, 92, 95, 95, 0, 95, 0, 95, 0, 0, - 67, 67, 67, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 64, 64, 64, 64, 0, 0, 0, - 0, 0, 96, 0, 0, 96, 0, 95, 0, 0, - 0, 0, 87, 87, 87, 87, 64, 64, 0, 96, - 96, 87, 96, 0, 96, 87, 87, 87, 87, 0, - 0, 64, 64, 64, 0, 87, 87, 0, 87, 87, - 87, 87, 0, 87, 87, 0, 0, 87, 0, 88, - 0, 0, 88, 0, 96, 0, 0, 0, 0, 90, - 90, 90, 90, 0, 0, 0, 88, 88, 90, 88, - 0, 88, 90, 90, 90, 90, 0, 0, 0, 0, - 0, 0, 90, 90, 0, 90, 90, 90, 90, 0, - 90, 90, 0, 0, 90, 0, 0, 89, 0, 0, - 89, 88, 0, 0, 0, 0, 0, 0, 0, 91, - 91, 91, 91, 0, 89, 89, 0, 89, 91, 89, - 0, 0, 91, 91, 91, 91, 0, 0, 0, 0, - 0, 0, 91, 91, 0, 91, 91, 91, 91, 0, - 91, 91, 0, 0, 91, 92, 92, 92, 92, 89, - 0, 0, 0, 0, 92, 0, 0, 0, 92, 92, - 92, 92, 0, 0, 0, 0, 0, 0, 92, 92, - 0, 92, 92, 92, 92, 0, 92, 92, 0, 0, - 92, 95, 95, 95, 95, 0, 0, 0, 0, 0, - 95, 0, 0, 0, 95, 95, 95, 95, 0, 0, - 0, 0, 0, 0, 95, 95, 0, 95, 95, 95, - 95, 0, 95, 95, 0, 0, 95, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 96, 96, - 96, 96, 0, 0, 0, 0, 0, 96, 0, 0, - 0, 96, 96, 96, 96, 0, 0, 0, 0, 0, - 0, 96, 96, 0, 96, 96, 96, 96, 0, 96, - 96, 98, 0, 96, 0, 0, 105, 107, 0, 0, - 0, 0, 117, 0, 0, 88, 88, 88, 88, 0, - 0, 0, 0, 0, 88, 0, 0, 0, 88, 88, - 88, 88, 0, 0, 0, 0, 0, 0, 88, 88, - 0, 88, 88, 88, 88, 0, 88, 88, 0, 0, - 88, 0, 0, 172, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 89, 89, 89, 89, 0, 0, 0, - 0, 0, 89, 0, 0, 0, 89, 89, 89, 89, - 0, 0, 0, 0, 0, 0, 89, 89, 0, 89, - 89, 89, 89, 0, 89, 89, 0, 0, 89, 0, - 0, 0, 0, 0, 0, 0, 214, 215, 216, 217, - 219, 221, 222, 223, 224, 225, 227, 229, 231, 233, - 235, 236, 238, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 214, 0, 0, 0, 0, 0, 0, 0, - 214, 0, 214, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 284, 0, 285, 0, 0, 0, - 0, 0, 287, 0, 288, 0, 289, 0, 290, 0, - 291, 0, 0, 292, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 305, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 323, + 0, 0, 0, 0, 0, 282, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 298, }; -short yycheck[] = { 5, - 181, 59, 123, 91, 91, 91, 59, 13, 40, 13, - 40, 183, 18, 44, 20, 41, 40, 44, 44, 23, - 40, 91, 44, 44, 30, 31, 32, 33, 40, 257, - 279, 36, 58, 59, 40, 123, 123, 123, 41, 43, - 46, 44, 44, 292, 175, 44, 177, 257, 52, 44, - 91, 282, 56, 123, 44, 123, 41, 59, 44, 44, - 44, 91, 93, 41, 40, 91, 93, 93, 299, 59, - 123, 302, 93, 58, 59, 125, 41, 249, 61, 44, - 63, 59, 123, 89, 88, 91, 90, 93, 92, 95, - 94, 123, 96, 123, 93, 267, 100, 123, 93, 123, - 272, 41, 274, 123, 0, 41, 91, 93, 93, 93, - 59, 123, 36, 41, 44, 40, 40, 299, 123, 59, - 302, 41, 36, 59, 257, 41, 40, 308, 134, 59, - 311, 59, 136, 137, 138, 139, 257, 33, 123, 59, - 36, 37, 38, 59, 40, 40, 42, 43, 280, 45, - 282, 283, 40, 157, 282, 283, 273, 161, 162, 163, - 164, 165, 166, 59, 0, 44, 298, 299, 64, 350, - 302, 299, 258, 59, 302, 306, 307, 44, 44, 44, - 59, 185, 313, 41, 40, 307, 44, 191, 192, 40, - 194, 41, 59, 59, 59, 91, 44, 33, 202, 257, - 36, 37, 38, 40, 40, 36, 42, 43, 339, 45, - 123, 59, 262, 263, 264, 265, 266, 305, 306, 307, - 307, 41, 41, 59, 44, 44, 125, 123, 64, 125, - 126, 41, 0, 44, 44, 41, 240, 41, 242, 91, - 44, 267, 268, 269, 270, 267, 268, 269, 270, 255, - 59, 257, 257, 259, 260, 91, 261, 263, 271, 272, - 266, 265, 41, 123, 290, 33, 125, 91, 36, 37, - 38, 275, 40, 302, 42, 43, 40, 45, 282, 305, - 306, 307, 267, 268, 269, 270, 40, 123, 40, 125, - 126, 59, 41, 276, 59, 125, 64, 280, 281, 282, - 283, 41, 267, 268, 269, 270, 310, 125, 314, 125, - 293, 294, 295, 296, 41, 298, 299, 125, 125, 302, - 305, 306, 307, 91, 125, 280, 281, 282, 283, 125, - 41, 41, 41, 337, 41, 262, 263, 264, 265, 266, - 346, 296, 59, 298, 299, 351, 41, 302, 41, 337, - 61, 59, 63, 59, 76, 123, 13, 125, 126, 265, - 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, - 266, 267, 268, 269, 270, -1, -1, -1, 274, 275, - -1, 277, 278, 279, 26, -1, -1, -1, 284, 285, - 286, 287, 288, 289, -1, -1, 292, 39, -1, -1, - -1, 297, -1, 45, -1, 301, -1, 303, 304, -1, - -1, 307, -1, -1, -1, 57, 58, 59, 60, 61, - 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, - 266, 267, 268, 269, 270, -1, -1, -1, 274, 275, - -1, 277, 278, 279, -1, -1, -1, 86, 284, 285, - 286, 287, 288, 289, 63, -1, 292, -1, -1, 101, - -1, 297, 101, -1, -1, 301, -1, 303, 304, -1, - 112, -1, -1, 112, 33, -1, 115, 36, 37, 38, - -1, 40, -1, 42, 43, -1, 45, -1, 256, 257, - 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, - 268, 269, 270, -1, 0, 64, 274, 275, -1, 277, - 278, 279, -1, -1, -1, -1, 284, 285, 286, 287, - 288, 289, -1, -1, 292, -1, -1, -1, -1, 297, - -1, -1, 91, 301, -1, 303, 304, 33, -1, -1, +short yycheck[] = { 41, + 0, 41, 93, 41, 59, 93, 44, 91, 93, 176, + 59, 59, 45, 36, 59, 93, 123, 21, 40, 93, + 40, 59, 125, 41, 93, 91, 40, 40, 6, 40, + 93, 91, 59, 33, 187, 257, 36, 37, 38, 123, + 40, 45, 42, 43, 41, 45, 36, 41, 44, 257, + 40, 29, 0, 86, 41, 93, 41, 123, 41, 59, + 41, 59, 59, 123, 64, 59, 40, 181, 91, 183, + 40, 91, 59, 40, 59, 41, 59, 40, 59, 112, + 291, 292, 86, 257, 41, 33, 41, 275, 36, 37, + 38, 91, 40, 44, 42, 43, 123, 45, 41, 40, + 123, 123, 123, 123, 0, 273, 274, 274, 112, 123, + 123, 59, 123, 117, 59, 59, 64, 40, 40, 125, + 41, 41, 40, 123, 41, 125, 126, 41, 59, 36, + 91, 41, 285, 125, 59, 288, 292, 33, 91, 40, + 36, 37, 38, 91, 40, 40, 42, 43, 41, 45, + 257, 41, 125, 263, 264, 265, 41, 267, 268, 59, + 263, 264, 265, 59, 267, 268, 319, 125, 64, 283, + 284, 125, 41, 125, 41, 123, 290, 125, 126, 59, + 59, 41, 59, 41, 59, 41, 59, 41, 310, 81, + 13, 256, -1, 41, -1, 91, 44, -1, 312, -1, + 291, 292, -1, 291, 292, -1, 291, 292, -1, 257, + 58, 59, -1, 291, 292, -1, 123, 291, 292, -1, + -1, 13, 291, 292, -1, 17, 310, 123, 291, 292, + 126, 269, 270, 271, 272, 258, 291, 292, 30, 31, + 32, 33, 291, 292, -1, 93, 291, 292, 40, 291, + 292, 291, 292, 291, 46, -1, 256, 257, 258, 259, + 260, 261, -1, 263, 264, 265, 266, 267, 268, 269, + 270, 271, 272, 291, 292, -1, 276, 277, -1, 279, + 280, 281, -1, 75, -1, 77, 286, 287, 288, 289, + 290, -1, -1, 293, 294, 291, 292, 89, -1, 91, + 300, 93, -1, 95, 304, 97, 306, 307, 256, 257, + 258, 259, 260, 261, -1, 263, 264, 265, 266, 267, + 268, 269, 270, 271, 272, 291, 292, -1, 276, 277, + -1, 279, 280, 281, 291, 292, 291, 292, 286, 287, + 288, 289, 290, -1, 136, 293, 294, -1, 291, 292, + 257, 41, 300, -1, 44, 262, 304, 13, 306, 307, + 256, 257, 258, 259, 260, 261, 291, 292, 58, 59, + 266, 291, 292, 269, 270, 271, 272, 291, 292, -1, + 276, 277, -1, 279, 280, 281, 42, -1, 44, -1, + 286, 287, 288, 289, 290, -1, 52, 293, 294, -1, + 56, 291, 292, 93, 300, 41, 291, 292, 304, -1, + 306, 307, 291, 292, -1, -1, -1, -1, -1, -1, + -1, 269, 270, 271, 272, -1, -1, -1, 91, -1, + 41, -1, -1, 44, 90, -1, 92, -1, 94, -1, + 96, -1, 98, 291, 292, -1, 102, 58, 59, -1, + -1, -1, 63, -1, 246, -1, 248, -1, 250, 251, + 123, -1, 254, -1, -1, 257, -1, 33, -1, -1, + 36, 37, 38, -1, 40, 41, 42, 43, 44, 45, + -1, -1, 93, 139, 140, 141, 142, 143, 144, 145, + -1, -1, 58, 59, -1, -1, -1, 63, 64, 291, + 269, 270, 271, 272, -1, -1, -1, 163, 164, 165, + 166, 167, 168, -1, -1, -1, -1, -1, -1, 26, + -1, -1, 291, 292, 316, 91, 58, 93, 320, -1, + -1, 63, 39, -1, -1, 191, -1, -1, 45, -1, + 91, 197, 198, 199, -1, -1, -1, -1, 204, -1, + 57, 58, 59, 60, 61, -1, -1, 123, 33, 91, + 126, 36, 37, 38, -1, 40, 41, 42, 43, 44, + 45, -1, 123, -1, 230, -1, 232, -1, -1, 269, + 270, 271, 272, 58, 59, -1, -1, -1, 63, 64, + -1, 123, -1, -1, -1, -1, 103, -1, -1, -1, + 256, 291, 292, -1, -1, 295, -1, -1, -1, -1, + -1, -1, -1, 269, -1, -1, -1, 33, 93, -1, 36, 37, 38, -1, 40, -1, 42, 43, -1, 45, - -1, 190, -1, -1, -1, 280, 281, 282, 283, -1, - -1, 200, -1, 59, 123, 276, -1, 126, 64, 280, - 281, 282, 283, 298, 299, -1, -1, 302, -1, 290, - 291, -1, 293, 294, 295, 296, -1, 298, 299, 33, - -1, 302, 36, 37, 38, 91, 40, 41, 42, 43, - 44, 45, -1, -1, -1, 282, 283, -1, -1, -1, - 26, -1, 251, -1, 58, 59, -1, 61, 34, 63, - 64, 298, 299, 39, 40, 302, 42, 123, -1, -1, - 126, -1, 47, 48, 49, 50, 51, -1, -1, 54, - 55, 57, 58, 59, 60, 61, -1, 91, -1, 93, - 33, -1, -1, 36, 37, 38, 295, 40, 41, 42, - 43, 44, 45, -1, 303, -1, -1, 276, -1, -1, - -1, 280, 281, 282, 283, 58, 59, -1, 61, 123, - 63, 64, 126, -1, 293, 294, 295, 296, -1, 298, - 299, -1, 108, 302, -1, -1, -1, -1, 257, 258, - 259, 260, 261, -1, -1, -1, -1, -1, -1, -1, - 93, -1, -1, -1, -1, -1, 275, -1, 277, 278, - 279, -1, -1, -1, -1, 284, 285, 286, 287, 288, - 289, -1, -1, 292, 280, 281, 282, 283, 297, -1, - -1, -1, 301, 126, 303, 304, -1, -1, 307, 295, - 296, -1, 298, 299, -1, -1, 302, -1, -1, -1, + -1, 287, -1, 269, 270, 271, 272, -1, -1, 302, + -1, -1, 305, 59, -1, 308, 309, 310, 64, -1, + -1, 126, -1, -1, 310, 291, 292, -1, 269, 270, + 271, 272, -1, -1, -1, -1, -1, 278, -1, -1, + -1, 282, 283, 284, 285, 91, -1, -1, -1, -1, + 291, 292, -1, -1, 295, 296, 297, 298, 299, -1, + 301, 257, 258, 259, 260, 261, -1, -1, -1, -1, + 266, -1, -1, 269, 270, 271, 272, 123, -1, -1, + 126, 277, 278, 279, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 41, 304, 305, + 306, 307, 308, 309, 310, -1, 278, -1, -1, -1, + 282, 283, 284, 285, 305, 59, -1, 308, 309, 310, + -1, -1, -1, 295, 296, 297, 298, 299, -1, 301, + 302, -1, -1, 305, -1, -1, 308, 309, 310, -1, + -1, -1, 257, 258, 259, 260, 261, -1, -1, 93, + -1, 266, -1, -1, 269, 270, 271, 272, -1, -1, + -1, -1, 277, 278, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 297, 298, 299, 300, 301, 302, -1, 304, + 305, 306, 307, 308, 309, 310, 91, -1, -1, -1, 256, 257, 258, 259, 260, 261, -1, -1, -1, -1, - -1, 267, 268, 269, 270, -1, -1, -1, 274, 275, - -1, 277, 278, 279, -1, -1, -1, -1, 284, 285, - 286, 287, 288, 289, -1, -1, 292, -1, -1, -1, - -1, 297, -1, -1, -1, 301, -1, 303, 304, -1, + 266, -1, -1, 269, 270, 271, 272, -1, -1, -1, + 276, 277, -1, 279, 280, 281, -1, -1, 123, -1, + 286, 287, 288, 289, 290, -1, -1, 293, 294, -1, + -1, -1, -1, -1, 300, -1, -1, 91, 304, 33, + 306, 307, 36, 37, 38, -1, 40, -1, 42, 43, + -1, 45, 25, 26, -1, -1, -1, -1, -1, -1, + -1, 34, -1, -1, -1, 59, 39, 40, -1, 123, + 64, -1, 45, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 57, 58, 59, 60, 61, -1, + -1, 33, -1, -1, 36, 37, 38, 91, 40, -1, + 42, 43, -1, 45, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 269, 270, 271, 272, -1, + -1, -1, 64, -1, -1, -1, -1, -1, -1, 123, + 103, -1, 126, -1, -1, -1, -1, 291, 292, -1, + -1, -1, -1, 33, -1, -1, 36, 37, 38, 91, + 40, -1, 42, 43, -1, 45, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 91, -1, 59, + -1, -1, -1, -1, 64, -1, -1, 282, 283, 284, + 285, 123, -1, -1, 126, -1, -1, -1, -1, 162, + -1, 296, 297, 298, 299, -1, 301, 302, -1, 123, + 305, 91, -1, 308, 309, 310, -1, -1, -1, -1, + -1, 33, -1, -1, 36, 37, 38, -1, 40, -1, + 42, 43, -1, 45, -1, -1, -1, -1, 282, 283, + 284, 285, -1, -1, -1, -1, 126, -1, -1, -1, + -1, -1, 64, 297, 298, 299, -1, 301, 302, -1, + -1, 305, -1, -1, 308, 309, 310, -1, -1, -1, + -1, -1, 256, 257, 258, 259, 260, 261, -1, 91, + -1, -1, 266, -1, -1, 269, 270, 271, 272, -1, + -1, -1, 276, 277, -1, 279, 280, 281, -1, -1, + -1, -1, 286, 287, 288, 289, 290, -1, -1, 293, + 294, 123, -1, -1, 126, -1, 300, -1, -1, 91, + 304, -1, 306, 307, -1, 257, 258, 259, 260, 261, + 262, -1, 33, -1, 266, 36, 37, 38, -1, 40, + 41, 42, 43, -1, 45, 277, -1, 279, 280, 281, + -1, 123, -1, 91, 286, 287, 288, 289, 290, -1, + -1, 293, 294, 64, -1, -1, -1, -1, 300, -1, + 284, 285, 304, -1, 306, 307, -1, 257, 258, 259, + 260, 261, -1, -1, -1, 123, 266, 301, 302, -1, + 91, 305, -1, -1, 308, 309, 310, 277, -1, 279, + 280, 281, -1, -1, -1, -1, 286, 287, 288, 289, + 290, -1, -1, 293, 294, -1, -1, -1, -1, -1, + 300, -1, -1, -1, 304, 126, 306, 307, -1, 33, + 91, -1, 36, 37, 38, -1, 40, -1, 42, 43, + -1, 45, -1, -1, -1, 257, 258, 259, 260, 261, + 262, -1, -1, -1, 266, -1, -1, -1, -1, -1, + 64, -1, 123, -1, -1, 277, -1, 279, 280, 281, + -1, -1, -1, -1, 286, 287, 288, 289, 290, -1, + -1, -1, 294, -1, -1, -1, -1, 91, 300, 93, + -1, -1, 304, -1, 306, 307, -1, 33, -1, -1, + 36, 37, 38, -1, 40, -1, 42, 43, -1, 45, + 282, 283, 284, 285, -1, -1, -1, -1, -1, -1, + -1, -1, 126, -1, -1, -1, 298, 299, 64, 301, + 302, -1, -1, 305, -1, -1, 308, 309, 310, -1, + -1, -1, -1, -1, 282, 283, 284, 285, -1, -1, + -1, 41, -1, -1, 44, 91, 257, 258, 259, 260, + 261, 299, -1, 301, 302, 266, -1, 305, -1, -1, + 308, 309, 310, 63, -1, -1, 277, -1, 279, 280, + 281, -1, -1, -1, -1, 286, 287, 288, 289, 290, + 126, -1, 293, 294, -1, -1, -1, -1, -1, 300, + -1, 91, -1, 304, -1, 306, 307, -1, 33, -1, + 91, 36, 37, 38, -1, 40, 41, 42, 43, -1, + 45, 282, 283, 284, 285, -1, -1, -1, -1, -1, + -1, -1, 91, 123, -1, -1, -1, -1, -1, 64, + 301, 302, 123, 41, 305, -1, 44, 308, 309, 310, -1, -1, -1, 257, 258, 259, 260, 261, -1, -1, - -1, -1, -1, 267, 268, 269, 270, -1, -1, -1, - -1, 275, 276, 277, 278, 279, 280, 281, 282, 283, - 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, - 294, 295, 296, 297, 298, 299, -1, 301, 302, 303, - 304, 305, 306, 307, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 257, 258, 259, 260, 261, -1, - -1, -1, -1, -1, 267, 268, 269, 270, -1, 61, - -1, 63, 275, 276, 277, 278, 279, 280, 281, 282, - 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, - 293, 294, 295, 296, 297, 298, 299, -1, 301, 302, - 303, 304, 305, 306, 307, 33, -1, -1, 36, 37, - 38, -1, 40, -1, 42, 43, -1, 45, -1, 280, - 281, 282, 283, -1, -1, -1, -1, -1, -1, -1, - -1, 59, 293, 294, 295, 296, 64, 298, 299, -1, - -1, 302, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 33, -1, -1, 36, 37, - 38, -1, 40, 91, 42, 43, -1, 45, -1, 280, - 281, 282, 283, -1, -1, -1, -1, -1, -1, -1, - -1, 59, -1, 294, 295, 296, 64, 298, 299, 41, - -1, 302, 44, -1, -1, 123, -1, -1, 126, -1, - -1, -1, -1, -1, -1, 33, 58, 59, 36, 37, - 38, -1, 40, 91, 42, 43, -1, 45, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 59, -1, -1, -1, -1, 64, -1, -1, 91, - -1, 93, -1, -1, -1, 123, -1, -1, 126, -1, - -1, -1, -1, -1, -1, 33, -1, -1, 36, 37, - 38, -1, 40, 91, 42, 43, -1, 45, -1, -1, - -1, 123, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 59, -1, -1, 276, -1, 64, -1, 280, 281, - 282, 283, -1, -1, -1, 123, -1, -1, 126, 291, - -1, 293, 294, 295, 296, -1, 298, 299, -1, -1, - 302, -1, 33, 91, -1, 36, 37, 38, -1, 40, - 41, 42, 43, -1, 45, -1, -1, -1, 256, 257, - 258, 259, 260, 261, -1, -1, -1, -1, -1, 267, - 268, 269, 270, 64, -1, 123, 274, 275, 126, 277, - 278, 279, -1, -1, -1, -1, 284, 285, 286, 287, - 288, 289, -1, -1, 292, -1, -1, -1, -1, 297, - 91, -1, -1, 301, -1, 303, 304, -1, 256, 257, - 258, 259, 260, 261, -1, -1, -1, -1, -1, 267, - 268, 269, 270, -1, -1, -1, 274, 275, -1, 277, - 278, 279, 123, -1, -1, 126, 284, 285, 286, 287, - 288, 289, -1, -1, 292, 267, 268, 269, 270, 297, - -1, -1, -1, 301, -1, 303, 304, -1, -1, 257, - 258, 259, 260, 261, 33, -1, -1, 36, 37, 38, - -1, 40, -1, 42, 43, -1, 45, 275, -1, 277, - 278, 279, -1, 305, 306, 307, 284, 285, 286, 287, - 288, 289, -1, -1, 292, 64, -1, -1, -1, 297, - -1, -1, -1, 301, -1, 303, 304, -1, -1, 257, - 258, 259, 260, 261, -1, -1, -1, -1, -1, -1, - -1, -1, 91, 41, 93, -1, 44, 275, -1, 277, - 278, 279, -1, -1, -1, -1, 284, 285, 286, 287, - 288, 289, -1, 61, 292, 63, -1, -1, -1, 297, - -1, -1, -1, 301, 123, 303, 304, 126, -1, -1, - -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, - 261, 33, -1, -1, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, 275, -1, 277, 278, 279, -1, - -1, -1, -1, 284, 285, 286, 287, 288, 289, -1, - -1, 292, 64, -1, -1, -1, 297, -1, -1, -1, - 301, -1, 303, 304, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 91, - -1, -1, -1, -1, -1, -1, 33, -1, -1, 36, - 37, 38, -1, 40, 41, 42, 43, -1, 45, -1, + 58, 59, 266, -1, 123, 63, 91, -1, -1, -1, + -1, -1, -1, 277, -1, 279, 280, 281, -1, -1, + -1, -1, 286, 287, 288, 289, 290, -1, -1, 293, + 294, -1, -1, -1, -1, 93, 300, -1, -1, -1, + 304, 126, 306, 307, 33, 91, -1, 36, 37, 38, + -1, 40, 41, 42, 43, -1, 45, -1, -1, -1, + 256, 257, 258, 259, 260, 261, -1, -1, -1, -1, + 266, -1, -1, -1, -1, 64, -1, 123, -1, -1, + -1, 277, -1, 279, 280, 281, -1, -1, -1, -1, + 286, 287, 288, 289, 290, -1, -1, 293, 294, -1, + -1, -1, 91, -1, 300, -1, -1, -1, 304, -1, + 306, 307, -1, 33, -1, -1, 36, 37, 38, -1, + 40, 41, 42, 43, -1, 45, -1, -1, 278, -1, + -1, -1, 282, 283, 284, 285, -1, 126, -1, -1, + -1, -1, -1, 284, 64, 295, 296, 297, 298, 299, + -1, 301, 302, -1, -1, 305, -1, -1, 308, 309, + 310, 302, -1, 282, 305, 284, 285, 308, 309, 310, + -1, 91, 257, 258, 259, 260, 261, -1, -1, -1, + -1, 266, 301, 302, -1, -1, 305, -1, -1, 308, + 309, 310, 277, -1, 279, 280, 281, -1, -1, -1, + -1, 286, 287, 288, 289, 290, 126, -1, 293, 294, + -1, 269, 270, 271, 272, 300, -1, -1, -1, 304, + 33, 306, 307, 36, 37, 38, -1, 40, 41, 42, + 43, -1, 45, 291, 292, -1, -1, 295, 284, 285, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 123, -1, -1, 126, -1, -1, 64, -1, -1, + -1, 64, -1, -1, -1, -1, 302, -1, -1, 305, + -1, -1, 308, 309, 310, -1, -1, -1, 257, 258, + 259, 260, 261, -1, -1, -1, -1, 266, 91, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 277, -1, + 279, 280, 281, -1, -1, -1, -1, 286, 287, 288, + 289, 290, -1, 41, 293, 294, 44, -1, -1, -1, + -1, 300, -1, 126, -1, 304, -1, 306, 307, 33, + 58, 59, 36, 37, 38, 63, 40, -1, 42, 43, + -1, 45, -1, -1, -1, -1, -1, 257, 258, 259, + 260, 261, -1, -1, -1, -1, 266, -1, -1, -1, + 64, -1, -1, -1, -1, 93, -1, 277, -1, 279, + 280, 281, -1, -1, -1, -1, 286, 287, 288, 289, + 290, -1, -1, 293, 294, -1, -1, 91, -1, -1, + 300, -1, -1, -1, 304, 33, 306, 307, 36, 37, + 38, -1, 40, -1, 42, 43, -1, 45, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 123, + -1, -1, 126, -1, -1, -1, 64, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, - 259, 260, 261, 33, 91, -1, 36, 37, 38, -1, - 40, -1, 42, 43, -1, 45, 275, -1, 277, 278, - 279, -1, -1, -1, -1, 284, 285, 286, 287, 288, - 289, 61, -1, 292, 64, -1, 123, -1, 297, 126, - -1, -1, 301, -1, 303, 304, -1, -1, -1, -1, - -1, -1, -1, 33, -1, -1, 36, 37, 38, -1, - 40, 91, 42, 43, -1, 45, -1, -1, 276, -1, - -1, -1, 280, 281, 282, 283, -1, -1, -1, -1, - -1, 61, 290, 291, 64, 293, 294, 295, 296, -1, - 298, 299, -1, 123, 302, -1, 126, -1, -1, -1, - -1, -1, -1, -1, 256, 257, 258, 259, 260, 261, - -1, 91, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 275, -1, 277, 278, 279, -1, 61, - -1, 63, 284, 285, 286, 287, 288, 289, -1, -1, - 292, -1, -1, 123, -1, 297, 126, -1, -1, 301, - 33, 303, 304, 36, 37, 38, -1, 40, -1, 42, - 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, - 257, 258, 259, 260, 261, -1, -1, -1, 61, -1, - -1, 64, -1, -1, -1, -1, -1, -1, 275, -1, - 277, 278, 279, -1, -1, -1, -1, 284, 285, 286, - 287, 288, 289, -1, -1, 292, -1, -1, 91, -1, - 297, -1, -1, -1, 301, -1, 303, 304, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, - 260, 261, 33, -1, -1, 36, 37, 38, -1, 40, - 123, 42, 43, 126, 45, 275, -1, 277, 278, 279, - -1, -1, -1, -1, 284, 285, 286, 287, 288, 289, - 61, -1, 292, 64, -1, -1, -1, 297, -1, -1, - -1, 301, -1, 303, 304, -1, -1, 257, 258, 259, - 260, 261, -1, -1, -1, -1, -1, -1, -1, -1, - 91, -1, -1, -1, -1, 275, -1, 277, 278, 279, - -1, -1, -1, -1, 284, 285, 286, 287, 288, 289, - -1, -1, 292, -1, -1, -1, -1, 297, -1, -1, - -1, 301, 123, 303, 304, 126, 33, -1, -1, 36, - 37, 38, -1, 40, -1, 42, 43, -1, 45, -1, - -1, -1, -1, -1, 276, -1, -1, -1, 280, 281, - 282, 283, -1, -1, 61, -1, -1, 64, 290, 291, - -1, 293, 294, 295, 296, -1, 298, 299, -1, -1, - 302, -1, -1, -1, 257, 258, 259, 260, 261, -1, - -1, -1, -1, -1, 91, -1, -1, -1, -1, -1, - 41, -1, 275, 44, 277, 278, 279, -1, -1, -1, - -1, 284, 285, 286, 287, 288, 289, 58, 59, 292, - 61, -1, 63, -1, 297, -1, 123, -1, 301, 126, - 303, 304, 33, -1, -1, 36, 37, 38, -1, 40, + -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, + -1, -1, -1, 91, 257, 258, 259, 260, 261, 58, + 59, -1, -1, 266, 63, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 277, -1, 279, 280, 281, -1, + -1, -1, -1, 286, 287, 288, 289, 290, 126, -1, + 293, 294, 91, -1, 93, -1, -1, 300, -1, -1, + -1, 304, 33, 306, 307, 36, 37, 38, -1, 40, -1, 42, 43, -1, 45, -1, -1, -1, -1, -1, - 91, -1, 93, -1, -1, -1, -1, -1, -1, -1, - 61, -1, -1, 64, -1, -1, 257, 258, 259, 260, - 261, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 123, -1, 275, -1, 277, 278, 279, -1, - 91, -1, -1, 284, 285, 286, 287, 288, 289, -1, - -1, 292, 58, -1, -1, 61, 297, 63, -1, -1, - 301, -1, 303, 304, -1, -1, -1, -1, -1, -1, - -1, -1, 123, -1, -1, 126, 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, 61, -1, -1, 64, -1, -1, - 257, 258, 259, 260, 261, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 275, -1, - 277, 278, 279, -1, 91, -1, -1, 284, 285, 286, - 287, 288, 289, -1, -1, 292, -1, -1, -1, -1, - 297, -1, -1, -1, 301, 33, 303, 304, 36, 37, - 38, -1, 40, -1, 42, 43, 123, 45, -1, 126, - -1, -1, -1, -1, -1, -1, 267, 268, 269, 270, - -1, -1, -1, 61, -1, 276, 64, -1, -1, 280, - 281, -1, -1, -1, -1, -1, -1, -1, -1, 290, - 291, -1, 293, 294, 295, 296, 257, 258, 259, 260, - 261, -1, -1, 91, 305, 306, 307, -1, -1, -1, - -1, -1, -1, -1, 275, -1, 277, 278, 279, -1, - -1, -1, -1, 284, 285, 286, 287, 288, 289, -1, - -1, 292, -1, -1, -1, 123, 297, -1, 126, -1, - 301, -1, 303, 304, -1, 33, -1, -1, 36, 37, - 38, -1, 40, 41, 42, 43, -1, 45, -1, -1, - 276, -1, -1, -1, 280, 281, 282, 283, -1, -1, - -1, -1, -1, -1, 290, 291, 64, 293, 294, 295, - 296, -1, 298, 299, -1, -1, 302, -1, -1, -1, - 257, 258, 259, 260, 261, -1, -1, -1, -1, -1, - -1, -1, -1, 91, -1, -1, -1, -1, 275, -1, - 277, 278, 279, -1, -1, -1, -1, 284, 285, 286, - 287, 288, 289, -1, -1, 292, -1, -1, 41, -1, - 297, 44, -1, -1, 301, 123, 303, 304, 126, -1, - -1, -1, -1, -1, 33, 58, 59, 36, 37, 38, - -1, 40, 41, 42, 43, -1, 45, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, - 258, 259, 260, 261, -1, 64, -1, -1, 91, -1, - 93, -1, -1, -1, -1, -1, -1, 275, -1, 277, - 278, 279, -1, -1, -1, -1, 284, 285, 286, 287, - 288, 289, 91, -1, 292, -1, -1, -1, -1, 297, - 123, -1, -1, 301, -1, 303, 304, 33, -1, -1, - 36, 37, 38, -1, 40, 41, 42, 43, -1, 45, - -1, -1, -1, -1, 123, -1, -1, 126, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 64, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, - 258, 259, 260, 261, -1, 91, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 275, -1, 277, - 278, 279, -1, -1, -1, -1, 284, 285, 286, 287, - 288, 289, -1, -1, 292, -1, -1, 123, -1, 297, - 126, -1, -1, 301, -1, 303, 304, 33, -1, -1, - 36, 37, 38, -1, 40, -1, 42, 43, -1, 45, + -1, -1, -1, -1, 123, -1, -1, -1, -1, -1, + -1, -1, -1, 64, -1, -1, -1, -1, -1, -1, + -1, 269, 270, 271, 272, -1, -1, -1, -1, -1, + 278, -1, -1, 257, 258, 259, 260, 261, -1, -1, + 91, -1, 266, 291, 292, -1, -1, 295, 296, 297, + 298, 299, -1, 277, -1, 279, 280, 281, -1, -1, + -1, -1, 286, 287, 288, 289, 290, -1, -1, -1, + 294, -1, 123, -1, -1, 126, 300, -1, -1, -1, + 304, 33, 306, 307, 36, 37, 38, -1, 40, -1, + 42, 43, -1, 45, -1, -1, -1, -1, -1, 257, + 258, 259, 260, 261, -1, -1, -1, -1, 266, -1, + -1, -1, 64, -1, -1, -1, -1, -1, -1, 277, + -1, 279, 280, 281, -1, -1, -1, -1, 286, 287, + 288, 289, 290, -1, -1, 293, 294, -1, -1, 91, + -1, -1, 300, -1, -1, -1, 304, -1, 306, 307, + 269, 270, 271, 272, -1, -1, -1, -1, -1, 278, + -1, -1, -1, 282, 283, 284, 285, -1, -1, -1, + -1, -1, 291, 292, 126, -1, 295, 296, 297, 298, + 299, 41, 301, 302, 44, -1, 305, -1, -1, 308, + 309, 310, -1, -1, -1, -1, -1, -1, 58, 59, + -1, -1, -1, 63, -1, -1, 257, 258, 259, 260, + 261, -1, -1, -1, -1, 266, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 277, -1, 279, 280, + 281, 91, -1, 93, -1, 286, 287, 288, 289, 290, + -1, -1, 41, 294, -1, 44, -1, -1, -1, 300, + -1, -1, -1, 304, -1, 306, 307, -1, -1, 58, + 59, -1, -1, 123, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 59, -1, -1, -1, -1, 64, -1, - -1, -1, -1, -1, 267, 268, 269, 270, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, - 259, 260, 261, -1, -1, 91, -1, 290, 291, -1, - -1, -1, -1, -1, 41, -1, 275, 44, 277, 278, - 279, -1, 305, 306, 307, 284, 285, 286, 287, 288, - 289, 58, 59, 292, 61, -1, 63, 123, 297, -1, - 126, -1, 301, -1, 303, 304, 33, -1, -1, 36, - 37, 38, -1, 40, 41, 42, 43, -1, 45, -1, - -1, -1, -1, -1, 91, -1, 93, -1, -1, -1, - -1, 257, 258, 259, 260, 261, -1, 64, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 275, - -1, 277, 278, 279, -1, -1, 123, -1, 284, 285, - 286, 287, 288, 289, 91, -1, 292, -1, -1, -1, - -1, 297, -1, -1, -1, 301, -1, 303, 304, 33, - -1, -1, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, -1, -1, -1, 123, -1, -1, 126, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 64, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 91, 41, 93, -1, 44, -1, -1, -1, + -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, + 58, 59, -1, -1, 266, 63, -1, -1, -1, -1, + -1, -1, -1, -1, 123, 277, -1, 279, 280, 281, + -1, -1, -1, -1, 286, 287, 288, 289, 290, 41, + -1, -1, 294, -1, -1, 93, -1, -1, 300, -1, + -1, -1, 304, -1, 306, 307, 58, 59, -1, -1, + -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 123, -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, 269, + 270, 271, 272, -1, -1, -1, -1, -1, 278, -1, + -1, 123, 282, 283, 284, 285, -1, -1, -1, -1, + -1, 291, 292, 93, -1, 295, 296, 297, 298, 299, + -1, 301, 302, 41, -1, 305, 44, -1, 308, 309, + 310, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 58, 59, -1, 123, -1, 63, -1, -1, -1, -1, + 269, 270, 271, 272, -1, -1, -1, -1, -1, 278, + -1, -1, -1, 282, 283, 284, 285, -1, -1, -1, + 41, -1, 291, 292, -1, 93, 295, 296, 297, 298, + 299, -1, 301, 302, -1, -1, 305, 58, 59, 308, + 309, 310, 63, -1, -1, -1, -1, -1, -1, -1, + -1, 269, 270, 271, 272, 123, -1, -1, -1, -1, + 278, -1, -1, -1, 282, 283, 284, 285, -1, -1, + 91, -1, 93, 291, 292, -1, -1, 295, 296, 297, + 298, 299, -1, 301, 302, -1, -1, 305, -1, -1, + 308, 309, 310, -1, -1, -1, -1, 269, 270, 271, + 272, -1, 123, -1, 41, -1, 278, 44, -1, -1, + 282, 283, 284, 285, -1, -1, -1, -1, -1, 291, + 292, 58, 59, 295, 296, 297, 298, 299, -1, 301, + 302, -1, -1, 305, -1, -1, 308, 309, 310, 269, + 270, 271, 272, -1, -1, -1, 41, -1, 278, 44, + -1, -1, 282, 283, 284, 285, 93, -1, -1, -1, + -1, 291, 292, 58, 59, 295, 296, 297, 298, 299, + 41, 301, 302, 44, -1, 305, -1, -1, 308, 309, + 310, -1, -1, -1, -1, -1, -1, 58, 59, -1, + -1, -1, 63, -1, -1, -1, -1, -1, 93, -1, + -1, 269, 270, 271, 272, -1, -1, -1, -1, -1, + 278, -1, -1, -1, 282, 283, 284, 285, -1, -1, + -1, -1, 93, 291, 292, -1, -1, 295, 296, 297, + 298, 299, -1, 301, 302, -1, -1, 305, -1, -1, + 308, 309, 310, -1, -1, -1, -1, -1, 269, 270, + 271, 272, 123, -1, -1, -1, -1, 278, -1, -1, + -1, 282, 283, 284, 285, -1, -1, -1, -1, -1, + 291, 292, -1, -1, 295, 296, 297, 298, 299, 41, + 301, 302, 44, -1, 305, -1, -1, 308, 309, 310, + -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, 257, 258, 259, 260, 261, -1, 91, -1, 93, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 275, - -1, 277, 278, 279, -1, -1, -1, -1, 284, 285, - 286, 287, 288, 289, -1, -1, 292, -1, -1, 123, - -1, 297, 126, -1, -1, 301, -1, 303, 304, 33, - -1, -1, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, - 267, 268, 269, 270, -1, -1, -1, -1, -1, 276, - 64, -1, -1, 280, 281, -1, -1, -1, -1, -1, - -1, -1, -1, 290, 291, -1, 293, 294, 295, 296, - 257, 258, 259, 260, 261, -1, -1, 91, 305, 306, - 307, -1, -1, -1, -1, -1, -1, -1, 275, -1, - 277, 278, 279, -1, -1, -1, -1, 284, 285, 286, - 287, 288, 289, -1, -1, 292, -1, -1, -1, 123, - 297, -1, 126, -1, 301, -1, 303, 304, 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, 257, 258, 259, 260, 261, -1, 64, + -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, + -1, 93, 269, 270, 271, 272, -1, -1, 58, 59, + -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 291, 292, -1, -1, -1, -1, + -1, 123, -1, 41, -1, -1, 44, -1, -1, -1, + -1, -1, -1, 93, 269, 270, 271, 272, -1, -1, + 58, 59, -1, -1, -1, 63, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 291, 292, 269, 270, + 271, 272, -1, -1, -1, 41, -1, 278, 44, -1, + -1, 282, 283, 284, 285, 93, -1, -1, -1, -1, + 291, 292, 58, 59, 295, 296, 297, 298, 299, 41, + 301, 302, 44, -1, 305, -1, -1, 308, 309, 310, + -1, -1, -1, -1, -1, -1, 58, 59, -1, -1, + -1, 63, -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 275, -1, 277, 278, 279, -1, -1, -1, -1, - 284, 285, 286, 287, 288, 289, 91, 41, 292, -1, - 44, -1, -1, 297, -1, -1, -1, 301, -1, 303, - 304, -1, -1, -1, 58, 59, -1, 61, -1, 63, - -1, -1, -1, -1, -1, -1, -1, -1, 123, -1, - -1, 126, -1, -1, -1, -1, -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, -1, 257, 258, 259, 260, 261, -1, 58, - 59, -1, 61, -1, 63, -1, -1, -1, -1, 123, - -1, 275, -1, 277, 278, 279, -1, -1, -1, -1, - 284, 285, 286, 287, 288, 289, 41, -1, 292, 44, - -1, -1, 91, 297, 93, -1, -1, 301, -1, 303, - 304, -1, -1, 58, 59, -1, 61, -1, 63, -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, 41, -1, 269, 270, 271, + 272, -1, -1, -1, -1, -1, 278, -1, -1, -1, + 282, 283, 284, 285, 93, -1, -1, 63, -1, 291, + 292, -1, -1, 295, 296, 297, 298, 299, -1, 301, + 302, -1, -1, 305, -1, -1, 308, 309, 310, 269, + 270, 271, 272, -1, -1, 91, -1, -1, 278, -1, + -1, -1, 282, 283, 284, 285, -1, -1, -1, -1, + -1, 291, 292, -1, -1, 295, 296, 297, 298, 299, + -1, 301, 302, -1, -1, 305, -1, 123, 308, 309, + 310, 269, 270, 271, 272, -1, -1, -1, -1, -1, + 278, -1, -1, -1, 282, 283, 284, 285, -1, -1, + -1, -1, -1, 291, 292, -1, -1, 295, 296, 297, + 298, 299, 41, 301, 302, 44, -1, 305, -1, -1, + 308, 309, 310, 269, 270, 271, 272, -1, -1, 58, + 59, -1, -1, -1, 63, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 291, 292, 269, 270, 271, + 272, -1, -1, -1, -1, -1, 278, -1, -1, -1, + 282, 283, 284, 285, 93, -1, -1, -1, -1, 291, + 292, -1, -1, 295, 296, 297, 298, 299, -1, 301, + 302, -1, -1, 305, -1, -1, 308, 309, 310, -1, + 269, 270, 271, 272, -1, -1, -1, -1, -1, 278, + -1, -1, -1, 282, 283, 284, 285, -1, -1, -1, + -1, -1, 291, 292, -1, -1, 295, 296, 297, 298, + 299, -1, 301, 302, 41, -1, 305, 44, -1, 308, + 309, 310, 278, -1, -1, -1, 282, 283, 284, 285, + -1, 58, 59, -1, -1, -1, 63, -1, -1, 295, + 296, 297, 298, 299, -1, 301, 302, -1, -1, 305, + -1, -1, 308, 309, 310, 41, -1, -1, 44, -1, + -1, -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, -1, -1, -1, 123, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 91, -1, 93, -1, - -1, 41, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 257, 258, 259, 260, 261, -1, 58, 59, - -1, 61, -1, 63, -1, -1, -1, -1, 123, -1, - 275, -1, 277, 278, 279, -1, -1, -1, -1, 284, - 285, 286, 287, 288, 289, -1, -1, 292, -1, -1, - -1, 91, 297, 93, -1, -1, 301, -1, 303, 304, + -1, -1, -1, -1, -1, 41, -1, -1, 44, -1, + -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, + -1, -1, 58, 59, -1, -1, -1, 63, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 269, 270, 271, 272, -1, -1, -1, -1, -1, 278, + -1, -1, -1, 282, 283, 284, 285, 93, -1, -1, + -1, 41, 291, 292, 44, -1, 295, 296, 297, 298, + 299, -1, 301, 302, -1, -1, 305, -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, 267, 268, 269, 270, -1, -1, -1, - -1, -1, 276, 123, 58, 59, 280, 281, 282, 283, - -1, -1, -1, -1, -1, -1, 290, 291, -1, 293, - 294, 295, 296, -1, 298, 299, -1, -1, 302, -1, - -1, 305, 306, 307, -1, -1, -1, 91, -1, 93, - -1, -1, -1, -1, -1, -1, -1, -1, 267, 268, - 269, 270, -1, -1, -1, -1, -1, 276, -1, -1, - -1, 280, 281, 282, 283, -1, -1, -1, -1, 123, - -1, 290, 291, -1, 293, 294, 295, 296, -1, 298, - 299, -1, 41, 302, -1, 44, 305, 306, 307, -1, - -1, -1, 267, 268, 269, 270, -1, -1, -1, 58, - 59, 276, 61, -1, 63, 280, 281, 282, 283, -1, - -1, -1, -1, -1, -1, 290, 291, -1, 293, 294, - 295, 296, -1, 298, 299, -1, -1, 302, -1, -1, - 305, 306, 307, -1, 93, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, -1, 267, 268, 269, - 270, -1, -1, -1, 58, 59, 276, 61, -1, 63, - 280, 281, 282, 283, 123, -1, -1, -1, -1, -1, - 290, 291, -1, 293, 294, 295, 296, -1, 298, 299, - 41, -1, 302, 44, -1, 305, 306, 307, -1, 93, - -1, -1, -1, -1, -1, -1, -1, 58, 59, -1, - 61, -1, 63, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 267, 268, 269, 270, -1, -1, 123, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - 91, -1, 93, -1, -1, -1, 290, 291, 58, 59, - -1, 61, -1, 63, -1, -1, -1, -1, -1, -1, - -1, 305, 306, 307, -1, -1, -1, -1, -1, -1, - -1, -1, 123, 41, -1, -1, 44, -1, -1, -1, - -1, 91, -1, 93, -1, -1, -1, -1, -1, -1, - 58, 59, -1, 61, -1, 63, -1, -1, -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, 123, -1, -1, -1, -1, 267, 268, - 269, 270, -1, -1, -1, 93, -1, 276, -1, -1, - -1, 280, 281, 282, 283, -1, -1, -1, -1, -1, - -1, 290, 291, -1, 293, 294, 295, 296, -1, 298, - 299, -1, -1, 302, -1, -1, 305, 306, 307, -1, - -1, -1, -1, 41, -1, -1, 44, -1, -1, -1, - -1, -1, -1, 267, 268, 269, 270, -1, -1, -1, - 58, 59, 276, 61, -1, 63, 280, 281, 282, 283, - -1, -1, -1, -1, -1, -1, 290, 291, -1, 293, - 294, 295, 296, -1, 298, 299, -1, -1, 302, -1, - -1, 305, 306, 307, -1, 93, 267, 268, 269, 270, - -1, -1, -1, -1, -1, 276, -1, -1, -1, 280, - 281, 282, 283, -1, -1, -1, -1, -1, -1, 290, - 291, -1, 293, 294, 295, 296, -1, 298, 299, -1, - -1, -1, -1, -1, 305, 306, 307, 267, 268, 269, - 270, -1, -1, -1, -1, -1, 276, -1, -1, -1, - 280, 281, 282, 283, -1, -1, -1, -1, -1, -1, - 290, 291, -1, 293, 294, 295, 296, -1, 298, 299, - -1, -1, -1, -1, -1, 305, 306, 307, -1, 267, - 268, 269, 270, -1, -1, -1, -1, -1, 276, -1, - -1, -1, 280, 281, 282, 283, -1, -1, -1, -1, - -1, -1, 290, 291, -1, 293, 294, 295, 296, 41, - 298, 299, 44, -1, 302, -1, -1, 305, 306, 307, - -1, -1, -1, -1, -1, -1, 58, 59, -1, 61, + 41, -1, -1, 44, -1, -1, -1, -1, -1, 93, + -1, -1, 269, 270, 271, 272, -1, 58, 59, -1, + -1, 278, 63, -1, -1, 282, 283, 284, 285, -1, + -1, -1, -1, -1, 291, 292, -1, -1, 295, 296, + 297, 298, 299, -1, 301, 302, -1, -1, 305, -1, + -1, -1, 93, 269, 270, 271, 272, -1, -1, -1, + -1, -1, 278, -1, -1, -1, 282, 283, 284, 285, + -1, -1, -1, -1, -1, 291, 292, -1, -1, 295, + 296, 297, 298, 299, -1, 301, 302, -1, -1, -1, + -1, -1, -1, 269, 270, 271, 272, -1, -1, -1, + -1, -1, 278, -1, -1, -1, 282, 283, 284, 285, + -1, -1, -1, -1, 41, 291, 292, 44, -1, 295, + 296, 297, 298, 299, -1, 301, 302, -1, -1, -1, + -1, 58, 59, -1, -1, -1, 63, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 269, + 270, 271, 272, -1, -1, -1, -1, -1, 278, -1, + -1, -1, 282, 283, 284, 285, 93, -1, -1, -1, + -1, 291, 292, -1, -1, 295, 296, 297, 298, 299, + -1, 301, 302, -1, -1, 269, 270, 271, 272, -1, + -1, -1, -1, -1, 278, -1, -1, -1, 282, 283, + 284, 285, -1, -1, -1, -1, -1, 291, 292, -1, + -1, 295, 296, 297, 298, 299, 41, 301, 302, 44, + -1, -1, -1, -1, -1, -1, -1, -1, 269, 270, + 271, 272, -1, 58, 59, -1, -1, 278, 63, -1, + -1, 282, 283, 284, 285, -1, -1, -1, -1, -1, + 291, 292, -1, -1, 295, 296, 297, 298, 299, 41, + 301, 302, 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, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, 93, 44, -1, -1, -1, -1, -1, -1, 267, - 268, 269, 270, -1, -1, -1, 58, 59, 276, 61, - -1, 63, 280, 281, 282, 283, -1, -1, -1, -1, - -1, -1, 290, 291, -1, 293, 294, 295, 296, -1, - 298, 299, 41, -1, 302, 44, -1, 305, 306, 307, - -1, 93, -1, -1, -1, -1, -1, -1, -1, 58, - 59, -1, 61, -1, 63, -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, 41, -1, -1, 44, -1, -1, -1, - -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, - 58, 59, -1, 61, -1, 63, -1, -1, -1, -1, + -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, + -1, -1, 269, 270, 271, 272, -1, 93, 58, 59, + -1, 278, -1, 63, -1, 282, 283, 284, 285, -1, + -1, -1, -1, 41, 291, 292, 44, -1, 295, 296, + 297, 298, 299, -1, 301, 302, -1, -1, -1, -1, + 58, 59, -1, 93, -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, -1, -1, -1, -1, -1, -1, 41, - -1, -1, 44, 91, -1, 93, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 58, 59, -1, 61, - -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 123, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 267, 268, 269, 270, 91, - -1, 93, -1, -1, 276, -1, -1, -1, 280, 281, - 282, 283, -1, -1, -1, -1, -1, -1, 290, 291, - -1, 293, 294, 295, 296, -1, 298, 299, -1, -1, - 302, 123, -1, 305, 306, 307, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 267, 268, 269, 270, -1, - -1, -1, -1, -1, 276, -1, -1, -1, 280, 281, - 282, 283, -1, -1, -1, -1, -1, -1, 290, 291, - -1, 293, 294, 295, 296, -1, 298, 299, -1, -1, - 302, -1, -1, 305, 306, 307, -1, -1, 267, 268, - 269, 270, -1, -1, -1, -1, -1, 276, -1, -1, - -1, 280, 281, 282, 283, -1, -1, -1, -1, -1, - -1, 290, 291, -1, 293, 294, 295, 296, -1, 298, - 299, -1, -1, 302, -1, -1, 305, 306, 307, 267, - 268, 269, 270, -1, -1, -1, -1, -1, 276, -1, - -1, -1, 280, 281, 282, 283, -1, -1, -1, -1, - -1, -1, 290, 291, -1, 293, 294, 295, 296, -1, - 298, -1, -1, -1, -1, -1, -1, 305, 306, 307, - -1, -1, -1, -1, -1, 267, 268, 269, 270, -1, - -1, -1, -1, -1, 276, -1, -1, -1, 280, 281, - 41, 283, -1, 44, -1, -1, -1, -1, 290, 291, - -1, 293, 294, 295, 296, -1, 298, 58, 59, -1, - 61, -1, 63, 305, 306, 307, -1, -1, -1, -1, + -1, -1, -1, 58, 59, 93, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - 91, -1, 93, -1, -1, -1, -1, -1, 58, 59, - -1, 61, -1, 63, -1, -1, -1, -1, -1, -1, + -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, + -1, -1, -1, -1, 269, 270, 271, 272, 93, 58, + 59, -1, -1, 278, 63, -1, -1, 282, 283, 284, + 285, -1, -1, -1, -1, -1, 291, 292, -1, -1, + 295, 296, 297, 298, 299, 41, 301, 302, 44, -1, + -1, -1, -1, -1, 93, -1, -1, 269, 270, 271, + 272, -1, 58, 59, -1, -1, 278, 63, -1, -1, + 282, 283, -1, 285, -1, -1, -1, -1, -1, 291, + 292, -1, -1, 295, 296, 297, 298, 299, -1, 301, + -1, -1, -1, 269, 270, 271, 272, 93, -1, -1, + 63, -1, 278, -1, -1, -1, 282, 283, -1, -1, + -1, -1, -1, -1, -1, 291, 292, -1, -1, 295, + 296, 297, 298, 299, -1, 301, -1, -1, 91, 269, + 270, 271, 272, -1, -1, -1, -1, -1, 278, -1, + -1, -1, 282, 283, -1, -1, -1, -1, -1, -1, + 41, 291, 292, 44, -1, 295, 296, 297, 298, 299, + 123, 269, 270, 271, 272, -1, -1, 58, 59, -1, + 278, -1, 63, -1, 282, 283, -1, -1, -1, -1, + -1, -1, 41, 291, 292, 44, -1, 295, 296, 297, + 298, 299, -1, -1, 269, 270, 271, 272, -1, 58, + 59, -1, 93, 278, 63, -1, -1, 282, 283, -1, + -1, -1, -1, -1, -1, -1, 291, 292, -1, -1, + 295, 296, 297, 298, 299, 41, -1, -1, 44, -1, + 269, 270, 271, 272, 93, -1, -1, -1, -1, 278, + -1, -1, 58, 59, 283, -1, -1, 63, -1, -1, + 63, -1, 291, 292, -1, -1, 295, 296, 297, 298, + 299, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 269, 270, 271, 272, 93, 91, -1, + -1, -1, 278, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 291, 292, -1, -1, 295, + 296, 297, 298, 299, -1, -1, -1, -1, -1, -1, + 123, -1, -1, -1, -1, 278, -1, -1, -1, 282, + 283, 284, 285, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 295, 296, 297, 298, 299, -1, 301, 302, + -1, -1, 305, -1, -1, 308, 309, 310, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 123, 41, -1, -1, 44, -1, -1, -1, - -1, 91, -1, 93, -1, -1, -1, -1, -1, -1, - 58, 59, -1, 61, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 123, 41, -1, -1, 44, -1, -1, - -1, -1, -1, 91, -1, 93, -1, -1, -1, -1, - -1, 58, 59, -1, 61, -1, 63, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 269, 270, + 271, 272, -1, -1, -1, -1, -1, 278, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 123, 41, -1, -1, 44, - -1, -1, -1, -1, 91, -1, 93, -1, -1, -1, - -1, -1, -1, 58, 59, -1, 61, -1, 63, -1, + 291, 292, -1, -1, 295, 296, 297, 298, -1, -1, + 269, 270, 271, 272, -1, 35, -1, -1, -1, 278, + 40, 41, -1, -1, -1, -1, 46, 47, 48, 49, + 50, 51, 291, 292, 54, 55, 295, 296, 297, -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, 91, -1, 93, -1, - -1, -1, -1, -1, -1, -1, 267, 268, 269, 270, - -1, -1, -1, -1, -1, 276, -1, -1, -1, 280, - 281, -1, -1, -1, -1, -1, -1, -1, 123, 290, - 291, -1, 293, 294, 295, 296, -1, 298, -1, -1, - -1, -1, -1, -1, 305, 306, 307, 267, 268, 269, - 270, -1, -1, -1, -1, -1, 276, -1, -1, -1, - 280, 281, -1, -1, -1, -1, -1, -1, -1, -1, - 290, 291, -1, 293, 294, 295, 296, -1, -1, -1, - -1, -1, -1, -1, -1, 305, 306, 307, -1, 267, - 268, 269, 270, -1, -1, -1, -1, -1, 276, -1, - -1, -1, -1, 281, -1, -1, -1, -1, -1, -1, - -1, -1, 290, 291, -1, 293, 294, 295, 296, -1, - -1, -1, -1, -1, -1, -1, -1, 305, 306, 307, - 267, 268, 269, 270, 41, -1, -1, 44, -1, 276, + -1, -1, -1, 269, 270, 271, 272, -1, -1, -1, + -1, -1, 278, -1, -1, 278, -1, -1, 88, 282, + 283, 284, 285, -1, -1, 291, 292, -1, -1, 295, + 296, -1, -1, 296, 297, 298, 299, -1, 301, 302, + -1, -1, 305, -1, -1, 308, 309, 310, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 58, 59, 290, 291, -1, 293, 294, 295, 296, - -1, -1, -1, -1, -1, -1, -1, -1, 305, 306, - 307, -1, 267, 268, 269, 270, -1, -1, -1, -1, - -1, 276, -1, -1, 91, 41, 93, -1, 44, -1, - -1, -1, -1, -1, -1, 290, 291, -1, 293, 294, - 295, 296, 58, 59, -1, 61, -1, 63, -1, -1, - 305, 306, 307, -1, -1, -1, 123, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 41, -1, -1, 44, - -1, -1, -1, -1, -1, 91, 41, 93, -1, 44, - -1, -1, -1, 58, 59, -1, 61, -1, 63, -1, - -1, -1, -1, 58, 59, -1, 61, -1, 63, -1, - -1, -1, -1, -1, -1, -1, -1, 123, -1, -1, - -1, -1, -1, -1, -1, -1, 91, 41, 93, -1, - 44, -1, -1, -1, 41, -1, 91, 44, 93, 41, - -1, -1, 44, -1, 58, 59, -1, 61, -1, 63, - -1, 58, 59, -1, 61, -1, 58, 59, 123, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 123, -1, - -1, -1, -1, -1, -1, -1, -1, 91, -1, 93, - -1, -1, -1, -1, 91, 41, 93, -1, 44, 91, - 41, 93, -1, 44, -1, -1, -1, -1, -1, -1, - -1, -1, 58, 59, -1, -1, -1, 58, 59, 123, - 267, 268, 269, 270, -1, -1, 123, -1, -1, -1, - -1, 123, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 290, 291, 91, -1, 93, -1, -1, - 91, 41, 93, -1, 44, -1, -1, -1, 305, 306, - 307, -1, -1, -1, -1, -1, -1, -1, 58, 59, - -1, 267, 268, 269, 270, -1, -1, 123, -1, -1, - 276, -1, 123, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 290, 291, -1, 293, 294, 295, - -1, 91, -1, 93, -1, -1, -1, -1, -1, 305, - 306, 307, 267, 268, 269, 270, -1, -1, -1, -1, - -1, 276, 267, 268, 269, 270, -1, -1, -1, -1, - -1, 276, -1, 123, -1, 290, 291, 41, 293, 294, - 44, -1, -1, -1, -1, 290, 291, -1, 293, -1, - 305, 306, 307, -1, 58, 59, -1, 61, -1, 63, - 305, 306, 307, 267, 268, 269, 270, -1, -1, -1, - 267, 268, 269, 270, -1, 267, 268, 269, 270, -1, - -1, -1, -1, -1, -1, -1, 290, 291, 41, 93, - -1, 44, -1, 290, 291, -1, -1, -1, 290, 291, - -1, 305, 306, 307, -1, 58, 59, -1, 305, 306, - 307, -1, -1, 305, 306, 307, -1, 41, -1, -1, - 44, 267, 268, 269, 270, -1, 267, 268, 269, 270, - -1, -1, -1, -1, 58, 59, 41, -1, 91, 44, - 93, -1, -1, -1, 290, 291, -1, -1, -1, 290, - 291, -1, -1, 58, 59, -1, -1, -1, -1, 305, - 306, 307, -1, -1, 305, 306, 307, 91, -1, 93, - 123, -1, -1, -1, -1, -1, -1, 267, 268, 269, - 270, -1, -1, -1, -1, -1, 91, 41, 93, -1, - 44, -1, -1, -1, -1, -1, -1, -1, -1, 123, - 290, 291, -1, -1, 58, 59, 41, -1, -1, 44, - -1, -1, -1, -1, -1, 305, 306, 307, 123, -1, - -1, -1, -1, 58, 59, -1, 61, -1, 63, -1, - -1, -1, -1, -1, -1, -1, -1, 91, -1, 93, + -1, -1, -1, -1, -1, -1, -1, -1, 138, -1, + -1, -1, -1, -1, -1, -1, 146, 147, 148, 149, + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 41, -1, -1, 44, -1, 93, -1, - -1, -1, -1, 267, 268, 269, 270, -1, -1, 123, - 58, 59, 276, 61, -1, 63, 280, 281, 282, 283, - -1, -1, -1, -1, -1, -1, 290, 291, -1, 293, - 294, 295, 296, -1, 298, 299, -1, -1, 302, -1, - -1, 305, 306, 41, -1, 93, 44, -1, -1, -1, - -1, -1, -1, -1, 267, 268, 269, 270, -1, -1, - 58, 59, -1, 61, -1, 63, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 290, 291, 41, - -1, -1, 44, 267, 268, 269, 270, -1, -1, -1, - -1, -1, 305, 306, 307, 93, 58, 59, -1, 61, - -1, 63, 267, 268, 269, 270, 290, 291, -1, -1, - -1, -1, -1, -1, -1, 41, -1, -1, 44, -1, - -1, 305, 306, 307, -1, 290, 291, -1, -1, -1, - -1, 93, 58, 59, -1, 61, -1, 63, -1, -1, - 305, 306, 307, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 267, 268, 269, 270, -1, -1, -1, - -1, -1, 41, -1, -1, 44, -1, 93, -1, -1, - -1, -1, 267, 268, 269, 270, 290, 291, -1, 58, - 59, 276, 61, -1, 63, 280, 281, 282, 283, -1, - -1, 305, 306, 307, -1, 290, 291, -1, 293, 294, - 295, 296, -1, 298, 299, -1, -1, 302, -1, 41, - -1, -1, 44, -1, 93, -1, -1, -1, -1, 267, - 268, 269, 270, -1, -1, -1, 58, 59, 276, 61, - -1, 63, 280, 281, 282, 283, -1, -1, -1, -1, - -1, -1, 290, 291, -1, 293, 294, 295, 296, -1, - 298, 299, -1, -1, 302, -1, -1, 41, -1, -1, - 44, 93, -1, -1, -1, -1, -1, -1, -1, 267, - 268, 269, 270, -1, 58, 59, -1, 61, 276, 63, - -1, -1, 280, 281, 282, 283, -1, -1, -1, -1, - -1, -1, 290, 291, -1, 293, 294, 295, 296, -1, - 298, 299, -1, -1, 302, 267, 268, 269, 270, 93, - -1, -1, -1, -1, 276, -1, -1, -1, 280, 281, - 282, 283, -1, -1, -1, -1, -1, -1, 290, 291, - -1, 293, 294, 295, 296, -1, 298, 299, -1, -1, - 302, 267, 268, 269, 270, -1, -1, -1, -1, -1, - 276, -1, -1, -1, 280, 281, 282, 283, -1, -1, - -1, -1, -1, -1, 290, 291, -1, 293, 294, 295, - 296, -1, 298, 299, -1, -1, 302, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 267, 268, - 269, 270, -1, -1, -1, -1, -1, 276, -1, -1, - -1, 280, 281, 282, 283, -1, -1, -1, -1, -1, - -1, 290, 291, -1, 293, 294, 295, 296, -1, 298, - 299, 35, -1, 302, -1, -1, 40, 41, -1, -1, - -1, -1, 46, -1, -1, 267, 268, 269, 270, -1, - -1, -1, -1, -1, 276, -1, -1, -1, 280, 281, - 282, 283, -1, -1, -1, -1, -1, -1, 290, 291, - -1, 293, 294, 295, 296, -1, 298, 299, -1, -1, - 302, -1, -1, 87, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 267, 268, 269, 270, -1, -1, -1, - -1, -1, 276, -1, -1, -1, 280, 281, 282, 283, - -1, -1, -1, -1, -1, -1, 290, 291, -1, 293, - 294, 295, 296, -1, 298, 299, -1, -1, 302, -1, - -1, -1, -1, -1, -1, -1, 140, 141, 142, 143, - 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, - 154, 155, 156, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 196, -1, -1, -1, -1, -1, -1, -1, - 204, -1, 206, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 218, -1, 220, -1, -1, -1, - -1, -1, 226, -1, 228, -1, 230, -1, 232, -1, - 234, -1, -1, 237, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 254, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 286, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 245, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 271, }; #define YYFINAL 1 #ifndef YYDEBUG #define YYDEBUG 0 #endif -#define YYMAXTOKEN 307 +#define YYMAXTOKEN 310 #if YYDEBUG char *yyname[] = { "end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, "'!'",0,0,"'$'","'%'","'&'",0,"'('","')'","'*'","'+'","','","'-'",0,0,0,0,0,0,0, -0,0,0,0,0,"':'","';'",0,"'='",0,"'?'","'@'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,"'['",0,"']'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,"'{'",0,"'}'","'~'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,"':'","';'",0,0,0,"'?'","'@'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,"'['",0,"']'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,"'{'",0,"'}'","'~'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"WORD","METHOD","THING", -"PMFUNC","PRIVATEREF","LABEL","FORMAT","SUB","PACKAGE","HINT","WHILE","UNTIL", -"IF","UNLESS","ELSE","ELSIF","CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0","FUNC1", -"FUNC","RELOP","EQOP","MULOP","ADDOP","DOLSHARP","DO","LOCAL","DELETE", -"HASHBRACK","NOAMP","OROP","ANDOP","LSTOP","OROR","ANDAND","BITOROP","BITANDOP", -"UNIOP","SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP","PREINC","PREDEC", -"POSTINC","POSTDEC","ARROW", +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"WORD","METHOD","FUNCMETH","THING", +"PMFUNC","PRIVATEREF","LABEL","FORMAT","SUB","ANONSUB","PACKAGE","USE","WHILE", +"UNTIL","IF","UNLESS","ELSE","ELSIF","CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0", +"FUNC1","FUNC","RELOP","EQOP","MULOP","ADDOP","DOLSHARP","DO","LOCAL", +"HASHBRACK","NOAMP","OROP","ANDOP","NOTOP","LSTOP","ASSIGNOP","OROR","ANDAND", +"BITOROP","BITANDOP","UNIOP","SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP", +"PREINC","PREDEC","POSTINC","POSTDEC","ARROW", }; char *yyrule[] = { "$accept : prog", @@ -1423,8 +1129,8 @@ char *yyrule[] = { "loop : label UNTIL '(' expr ')' block cont", "loop : label WHILE block block cont", "loop : label UNTIL block block cont", -"loop : label FOR scalar '(' expr crp block cont", -"loop : label FOR '(' expr crp block cont", +"loop : label FOR scalar '(' expr ')' block cont", +"loop : label FOR '(' expr ')' block cont", "loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' block", "loop : label block cont", "nexpr :", @@ -1436,50 +1142,45 @@ char *yyrule[] = { "decl : format", "decl : subrout", "decl : package", -"decl : hint", -"format : FORMAT WORD block", -"format : FORMAT block", -"subrout : SUB WORD block", -"subrout : SUB WORD ';'", +"decl : use", +"format : FORMAT startsub WORD block", +"format : FORMAT startsub block", +"subrout : SUB startsub WORD block", +"subrout : SUB startsub WORD ';'", +"startsub :", "package : PACKAGE WORD ';'", "package : PACKAGE ';'", -"hint : HINT WORD ';'", -"hint : HINT WORD expr ';'", -"expr : expr ',' sexpr", -"expr : sexpr", -"listop : LSTOP indirob listexpr", -"listop : FUNC '(' indirob listexpr ')'", -"listop : indirob ARROW LSTOP listexpr", -"listop : indirob ARROW FUNC '(' listexpr ')'", -"listop : term ARROW METHOD '(' listexpr ')'", +"use : USE WORD listexpr ';'", +"expr : expr ANDOP expr", +"expr : expr OROP expr", +"expr : NOTOP expr", +"expr : argexpr", +"argexpr : argexpr ','", +"argexpr : argexpr ',' term", +"argexpr : term", +"listop : LSTOP indirob argexpr", +"listop : FUNC '(' indirob expr ')'", +"listop : term ARROW method '(' listexprcom ')'", "listop : METHOD indirob listexpr", +"listop : FUNCMETH indirob '(' listexprcom ')'", "listop : LSTOP listexpr", -"listop : FUNC '(' listexpr ')'", -"sexpr : sexpr '=' sexpr", -"sexpr : sexpr POWOP '=' sexpr", -"sexpr : sexpr MULOP '=' sexpr", -"sexpr : sexpr ADDOP '=' sexpr", -"sexpr : sexpr SHIFTOP '=' sexpr", -"sexpr : sexpr BITANDOP '=' sexpr", -"sexpr : sexpr BITOROP '=' sexpr", -"sexpr : sexpr ANDAND '=' sexpr", -"sexpr : sexpr OROR '=' sexpr", -"sexpr : sexpr POWOP sexpr", -"sexpr : sexpr MULOP sexpr", -"sexpr : sexpr ADDOP sexpr", -"sexpr : sexpr SHIFTOP sexpr", -"sexpr : sexpr RELOP sexpr", -"sexpr : sexpr EQOP sexpr", -"sexpr : sexpr BITANDOP sexpr", -"sexpr : sexpr BITOROP sexpr", -"sexpr : sexpr DOTDOT sexpr", -"sexpr : sexpr ANDAND sexpr", -"sexpr : sexpr OROR sexpr", -"sexpr : sexpr ANDOP sexpr", -"sexpr : sexpr OROP sexpr", -"sexpr : sexpr '?' sexpr ':' sexpr", -"sexpr : sexpr MATCHOP sexpr", -"sexpr : term", +"listop : FUNC '(' listexprcom ')'", +"method : METHOD", +"method : scalar", +"term : term ASSIGNOP term", +"term : term POWOP term", +"term : term MULOP term", +"term : term ADDOP term", +"term : term SHIFTOP term", +"term : term RELOP term", +"term : term EQOP term", +"term : term BITANDOP term", +"term : term BITOROP term", +"term : term DOTDOT term", +"term : term ANDAND term", +"term : term OROR term", +"term : term '?' term ':' term", +"term : term MATCHOP term", "term : '-' term", "term : '+' term", "term : '!' term", @@ -1489,13 +1190,14 @@ char *yyrule[] = { "term : term POSTDEC", "term : PREINC term", "term : PREDEC term", -"term : LOCAL sexpr", -"term : '(' expr crp", +"term : LOCAL term", +"term : '(' expr ')'", "term : '(' ')'", -"term : '[' expr crb", +"term : '[' expr ']'", "term : '[' ']'", -"term : HASHBRACK expr crhb", +"term : HASHBRACK expr ';' '}'", "term : HASHBRACK ';' '}'", +"term : ANONSUB startsub block", "term : scalar", "term : star", "term : scalar '[' expr ']'", @@ -1507,39 +1209,39 @@ char *yyrule[] = { "term : scalar '{' expr ';' '}'", "term : term ARROW '{' expr ';' '}'", "term : term '{' expr ';' '}'", -"term : '(' expr crp '[' expr ']'", +"term : '(' expr ')' '[' expr ']'", "term : '(' ')' '[' expr ']'", "term : ary '[' expr ']'", "term : ary '{' expr ';' '}'", -"term : DELETE scalar '{' expr ';' '}'", -"term : DELETE '(' scalar '{' expr ';' '}' ')'", "term : THING", "term : amper", "term : amper '(' ')'", -"term : amper '(' expr crp", +"term : amper '(' expr ')'", "term : NOAMP WORD listexpr", -"term : NOAMP WORD indirob listexpr", -"term : DO sexpr", +"term : DO term", "term : DO block", "term : DO WORD '(' ')'", -"term : DO WORD '(' expr crp", +"term : DO WORD '(' expr ')'", "term : DO scalar '(' ')'", -"term : DO scalar '(' expr crp", +"term : DO scalar '(' expr ')'", "term : LOOPEX", -"term : LOOPEX sexpr", +"term : LOOPEX term", "term : UNIOP", "term : UNIOP block", -"term : UNIOP sexpr", +"term : UNIOP term", "term : FUNC0", "term : FUNC0 '(' ')'", "term : FUNC1 '(' ')'", "term : FUNC1 '(' expr ')'", -"term : PMFUNC '(' sexpr ')'", -"term : PMFUNC '(' sexpr ',' sexpr ')'", +"term : PMFUNC '(' term ')'", +"term : PMFUNC '(' term ',' term ')'", "term : WORD", "term : listop", "listexpr :", -"listexpr : expr", +"listexpr : argexpr", +"listexprcom :", +"listexprcom : expr", +"listexprcom : expr ','", "amper : '&' indirob", "scalar : '$' indirob", "ary : '@' indirob", @@ -1550,12 +1252,6 @@ char *yyrule[] = { "indirob : scalar", "indirob : block", "indirob : PRIVATEREF", -"crp : ',' ')'", -"crp : ')'", -"crb : ',' ']'", -"crb : ']'", -"crhb : ',' ';' '}'", -"crhb : ';' '}'", }; #endif #define yyclearin (yychar=(-1)) @@ -1578,12 +1274,40 @@ int yyerrflag; int yychar; YYSTYPE yyval; YYSTYPE yylval; -#line 621 "perly.y" +#line 546 "perly.y" /* PROGRAM */ -#line 1589 "y.tab.c" +#line 1347 "y.tab.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab + +struct ysv { + short* yyss; + YYSTYPE* yyvs; + int oldyydebug; + int oldyynerrs; + int oldyyerrflag; + int oldyychar; + YYSTYPE oldyyval; + YYSTYPE oldyylval; +}; + +void +yydestruct(ptr) +void* ptr; +{ + struct ysv* ysave = (struct ysv*)ptr; + if (ysave->yyss) Safefree(ysave->yyss); + if (ysave->yyvs) Safefree(ysave->yyvs); + yydebug = ysave->oldyydebug; + yynerrs = ysave->oldyynerrs; + yyerrflag = ysave->oldyyerrflag; + yychar = ysave->oldyychar; + yyval = ysave->oldyyval; + yylval = ysave->oldyylval; + Safefree(ysave); +} + int yyparse() { @@ -1593,18 +1317,22 @@ yyparse() short* yyss; YYSTYPE* yyvs; unsigned yystacksize = YYSTACKSIZE; - int oldyydebug = yydebug; - int oldyynerrs = yynerrs; - int oldyyerrflag = yyerrflag; - int oldyychar = yychar; - YYSTYPE oldyyval = yyval; - YYSTYPE oldyylval = yylval; int retval = 0; - #if YYDEBUG register char *yys; extern char *getenv(); +#endif + + struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); + SAVEDESTRUCTOR(yydestruct, ysave); + ysave->oldyydebug = yydebug; + ysave->oldyynerrs = yynerrs; + ysave->oldyyerrflag = yyerrflag; + ysave->oldyychar = yychar; + ysave->oldyyval = yyval; + ysave->oldyylval = yylval; +#if YYDEBUG if (yys = getenv("YYDEBUG")) { yyn = *yys; @@ -1620,8 +1348,8 @@ yyparse() /* ** Initialize private stacks (yyparse may be called from an action) */ - yyss = (short*)malloc(yystacksize*sizeof(short)); - yyvs = (YYSTYPE*)malloc(yystacksize*sizeof(YYSTYPE)); + ysave->yyss = yyss = (short*)safemalloc(yystacksize*sizeof(short)); + ysave->yyvs = yyvs = (YYSTYPE*)safemalloc(yystacksize*sizeof(YYSTYPE)); if (!yyvs || !yyss) goto yyoverflow; @@ -1662,8 +1390,10 @@ yyloop: int yyps_index = (yyssp - yyss); int yypv_index = (yyvsp - yyvs); yystacksize += YYSTACKSIZE; - yyvs = (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); - yyss = (short*)realloc((char*)yyss,yystacksize * sizeof(short)); + ysave->yyvs = yyvs = + (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); + ysave->yyss = yyss = + (short*)realloc((char*)yyss,yystacksize * sizeof(short)); if (!yyvs || !yyss) goto yyoverflow; yyssp = yyss + yyps_index; @@ -1716,9 +1446,9 @@ yyinrecovery: int yyps_index = (yyssp - yyss); int yypv_index = (yyvsp - yyvs); yystacksize += YYSTACKSIZE; - yyvs = (YYSTYPE*)realloc((char*)yyvs, + ysave->yyvs = yyvs = (YYSTYPE*)realloc((char*)yyvs, yystacksize * sizeof(YYSTYPE)); - yyss = (short*)realloc((char*)yyss, + ysave->yyss = yyss = (short*)realloc((char*)yyss, yystacksize * sizeof(short)); if (!yyvs || !yyss) goto yyoverflow; @@ -1771,7 +1501,7 @@ yyreduce: switch (yyn) { case 1: -#line 103 "perly.y" +#line 84 "perly.y" { #if defined(YYDEBUG) && defined(DEBUGGING) yydebug = (debug & 1); @@ -1780,59 +1510,38 @@ case 1: } break; case 2: -#line 110 "perly.y" -{ if (in_eval) { - eval_root = newUNOP(OP_LEAVEEVAL, 0, yyvsp[0].opval); - eval_start = linklist(eval_root); - eval_root->op_next = 0; - peep(eval_start); - } - else - main_root = block_head(yyvsp[0].opval, &main_start); - } +#line 91 "perly.y" +{ newPROG(yyvsp[0].opval); } break; case 3: -#line 122 "perly.y" -{ int needblockscope = hints & HINT_BLOCK_SCOPE; - yyval.opval = scalarseq(yyvsp[-1].opval); - if (copline > (line_t)yyvsp[-3].ival) - copline = yyvsp[-3].ival; - LEAVE_SCOPE(yyvsp[-2].ival); - if (needblockscope) - hints |= HINT_BLOCK_SCOPE; /* propagate out */ - pad_leavemy(comppad_name_fill); } +#line 95 "perly.y" +{ yyval.opval = block_end(yyvsp[-3].ival,yyvsp[-2].ival,yyvsp[-1].opval); } break; case 4: -#line 133 "perly.y" -{ yyval.ival = savestack_ix; - comppad_name_fill = AvFILL(comppad_name); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); - min_intro_pending = 0; - SAVEINT(comppad_name_fill); - SAVEINT(hints); - hints &= ~HINT_BLOCK_SCOPE; } +#line 99 "perly.y" +{ yyval.ival = block_start(); } break; case 5: -#line 144 "perly.y" +#line 103 "perly.y" { yyval.opval = Nullop; } break; case 6: -#line 146 "perly.y" +#line 105 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 7: -#line 148 "perly.y" +#line 107 "perly.y" { yyval.opval = append_list(OP_LINESEQ, - (LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval); pad_reset(); + (LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval); + pad_reset_pending = TRUE; if (yyvsp[-1].opval && yyvsp[0].opval) hints |= HINT_BLOCK_SCOPE; } break; case 8: -#line 154 "perly.y" +#line 114 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } break; case 10: -#line 157 "perly.y" +#line 117 "perly.y" { if (yyvsp[-1].pval != Nullch) { yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); } @@ -1843,117 +1552,119 @@ case 10: expect = XSTATE; } break; case 11: -#line 166 "perly.y" +#line 126 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); expect = XSTATE; } break; case 12: -#line 171 "perly.y" +#line 131 "perly.y" { yyval.opval = Nullop; } break; case 13: -#line 173 "perly.y" +#line 133 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 14: -#line 175 "perly.y" +#line 135 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 15: -#line 177 "perly.y" +#line 137 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } break; case 16: -#line 179 "perly.y" +#line 139 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } break; case 17: -#line 181 "perly.y" +#line 141 "perly.y" { yyval.opval = newLOOPOP(OPf_PARENS, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);} break; case 18: -#line 185 "perly.y" +#line 145 "perly.y" { yyval.opval = Nullop; } break; case 19: -#line 187 "perly.y" +#line 147 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 20: -#line 189 "perly.y" +#line 149 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newSTATEOP(0, 0, newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); } break; case 21: -#line 195 "perly.y" +#line 155 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); } break; case 22: -#line 198 "perly.y" +#line 158 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newCONDOP(0, invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); } break; case 23: -#line 202 "perly.y" +#line 162 "perly.y" { copline = yyvsp[-3].ival; + deprecate("if BLOCK BLOCK"); yyval.opval = newCONDOP(0, scope(yyvsp[-2].opval), scope(yyvsp[-1].opval), yyvsp[0].opval); } break; case 24: -#line 205 "perly.y" +#line 166 "perly.y" { copline = yyvsp[-3].ival; + deprecate("unless BLOCK BLOCK"); yyval.opval = newCONDOP(0, invert(scalar(scope(yyvsp[-2].opval))), scope(yyvsp[-1].opval), yyvsp[0].opval); } break; case 25: -#line 211 "perly.y" +#line 173 "perly.y" { yyval.opval = Nullop; } break; case 26: -#line 213 "perly.y" +#line 175 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 27: -#line 217 "perly.y" +#line 179 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newSTATEOP(0, yyvsp[-6].pval, newWHILEOP(0, 1, (LOOP*)Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) ); } break; case 28: -#line 222 "perly.y" +#line 184 "perly.y" { copline = yyvsp[-5].ival; yyval.opval = newSTATEOP(0, yyvsp[-6].pval, newWHILEOP(0, 1, (LOOP*)Nullop, invert(scalar(yyvsp[-3].opval)), yyvsp[-1].opval, yyvsp[0].opval) ); } break; case 29: -#line 227 "perly.y" +#line 189 "perly.y" { copline = yyvsp[-3].ival; yyval.opval = newSTATEOP(0, yyvsp[-4].pval, newWHILEOP(0, 1, (LOOP*)Nullop, scope(yyvsp[-2].opval), yyvsp[-1].opval, yyvsp[0].opval) ); } break; case 30: -#line 232 "perly.y" +#line 194 "perly.y" { copline = yyvsp[-3].ival; yyval.opval = newSTATEOP(0, yyvsp[-4].pval, newWHILEOP(0, 1, (LOOP*)Nullop, invert(scalar(scope(yyvsp[-2].opval))), yyvsp[-1].opval, yyvsp[0].opval)); } break; case 31: -#line 237 "perly.y" +#line 199 "perly.y" { yyval.opval = newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, mod(yyvsp[-5].opval, OP_ENTERLOOP), yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 32: -#line 240 "perly.y" +#line 202 "perly.y" { yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } break; case 33: -#line 243 "perly.y" +#line 205 "perly.y" { copline = yyvsp[-8].ival; yyval.opval = append_elem(OP_LINESEQ, newSTATEOP(0, yyvsp[-9].pval, scalar(yyvsp[-6].opval)), @@ -1962,569 +1673,504 @@ case 33: scalar(yyvsp[-4].opval), yyvsp[0].opval, scalar(yyvsp[-2].opval)) )); } break; case 34: -#line 250 "perly.y" +#line 212 "perly.y" { yyval.opval = newSTATEOP(0, yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } break; case 35: -#line 256 "perly.y" +#line 218 "perly.y" { yyval.opval = Nullop; } break; case 37: -#line 261 "perly.y" +#line 223 "perly.y" { (void)scan_num("1"); yyval.opval = yylval.opval; } break; case 39: -#line 266 "perly.y" +#line 228 "perly.y" { yyval.pval = Nullch; } break; case 41: -#line 271 "perly.y" +#line 233 "perly.y" { yyval.ival = 0; } break; case 42: -#line 273 "perly.y" +#line 235 "perly.y" { yyval.ival = 0; } break; case 43: -#line 275 "perly.y" +#line 237 "perly.y" { yyval.ival = 0; } break; case 44: -#line 277 "perly.y" +#line 239 "perly.y" { yyval.ival = 0; } break; case 45: -#line 281 "perly.y" +#line 243 "perly.y" { newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 46: -#line 283 "perly.y" +#line 245 "perly.y" { newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); } break; case 47: -#line 287 "perly.y" +#line 249 "perly.y" { newSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 48: -#line 289 "perly.y" +#line 251 "perly.y" { newSUB(yyvsp[-2].ival, yyvsp[-1].opval, Nullop); expect = XSTATE; } break; case 49: -#line 293 "perly.y" -{ package(yyvsp[-1].opval); } +#line 255 "perly.y" +{ yyval.ival = start_subparse(); } break; case 50: -#line 295 "perly.y" -{ package(Nullop); } +#line 259 "perly.y" +{ package(yyvsp[-1].opval); } break; case 51: -#line 299 "perly.y" -{ hint(yyvsp[-2].ival, yyvsp[-1].opval, Nullop); } +#line 261 "perly.y" +{ package(Nullop); } break; case 52: -#line 301 "perly.y" -{ hint(yyvsp[-3].ival, yyvsp[-2].opval, list(force_list(yyvsp[-1].opval))); } +#line 265 "perly.y" +{ utilize(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval); } break; case 53: -#line 305 "perly.y" -{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } +#line 269 "perly.y" +{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 55: -#line 310 "perly.y" -{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yyvsp[-1].opval), yyvsp[0].opval) ); } +case 54: +#line 271 "perly.y" +{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; -case 56: -#line 313 "perly.y" -{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yyvsp[-2].opval), yyvsp[-1].opval) ); } +case 55: +#line 273 "perly.y" +{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 57: -#line 316 "perly.y" -{ yyval.opval = convert(yyvsp[-1].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yyvsp[-3].opval), yyvsp[0].opval) ); } +#line 278 "perly.y" +{ yyval.opval = yyvsp[-1].opval; } break; case 58: -#line 319 "perly.y" -{ yyval.opval = convert(yyvsp[-3].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yyvsp[-5].opval), yyvsp[-1].opval) ); } -break; -case 59: -#line 322 "perly.y" -{ yyval.opval = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, - newMETHOD(yyvsp[-5].opval,yyvsp[-3].opval), list(yyvsp[-1].opval))); } +#line 280 "perly.y" +{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; case 60: -#line 326 "perly.y" -{ yyval.opval = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, - newMETHOD(yyvsp[-1].opval,yyvsp[-2].opval), list(yyvsp[0].opval))); } +#line 285 "perly.y" +{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, + prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); } break; case 61: -#line 330 "perly.y" -{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } +#line 288 "perly.y" +{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, + prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); } break; case 62: -#line 332 "perly.y" -{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } +#line 291 "perly.y" +{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, yyvsp[-5].opval, list(yyvsp[-1].opval)), + newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } break; case 63: -#line 336 "perly.y" -{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[0].opval); } +#line 296 "perly.y" +{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, yyvsp[-1].opval, list(yyvsp[0].opval)), + newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); } break; case 64: -#line 338 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - mod(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } +#line 301 "perly.y" +{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, yyvsp[-3].opval, list(yyvsp[-1].opval)), + newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); } break; case 65: -#line 341 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - mod(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } +#line 306 "perly.y" +{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 66: -#line 344 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - mod(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval));} -break; -case 67: -#line 347 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - mod(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } -break; -case 68: -#line 350 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - mod(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } +#line 308 "perly.y" +{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 69: -#line 353 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - mod(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } +#line 316 "perly.y" +{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; case 70: -#line 356 "perly.y" -{ yyval.opval = newLOGOP(OP_ANDASSIGN, 0, - mod(scalar(yyvsp[-3].opval), OP_ANDASSIGN), - newUNOP(OP_SASSIGN, 0, scalar(yyvsp[0].opval))); } +#line 318 "perly.y" +{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 71: -#line 360 "perly.y" -{ yyval.opval = newLOGOP(OP_ORASSIGN, 0, - mod(scalar(yyvsp[-3].opval), OP_ORASSIGN), - newUNOP(OP_SASSIGN, 0, scalar(yyvsp[0].opval))); } +#line 320 "perly.y" +{ if (yyvsp[-1].ival != OP_REPEAT) + scalar(yyvsp[-2].opval); + yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } break; case 72: -#line 366 "perly.y" +#line 324 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 73: -#line 368 "perly.y" -{ if (yyvsp[-1].ival != OP_REPEAT) - scalar(yyvsp[-2].opval); - yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } +#line 326 "perly.y" +{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 74: -#line 372 "perly.y" +#line 328 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 75: -#line 374 "perly.y" +#line 330 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 76: -#line 376 "perly.y" +#line 332 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 77: -#line 378 "perly.y" +#line 334 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 78: -#line 380 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } +#line 336 "perly.y" +{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; case 79: -#line 382 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } +#line 338 "perly.y" +{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 80: -#line 384 "perly.y" -{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} +#line 340 "perly.y" +{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 81: -#line 386 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } +#line 342 "perly.y" +{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; case 82: -#line 388 "perly.y" -{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } +#line 344 "perly.y" +{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; case 83: -#line 390 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } +#line 347 "perly.y" +{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; case 84: -#line 392 "perly.y" -{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } +#line 349 "perly.y" +{ yyval.opval = yyvsp[0].opval; } break; case 85: -#line 394 "perly.y" -{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } +#line 351 "perly.y" +{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 86: -#line 396 "perly.y" -{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } +#line 353 "perly.y" +{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; case 87: -#line 398 "perly.y" -{ yyval.opval = yyvsp[0].opval; } +#line 355 "perly.y" +{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; case 88: -#line 402 "perly.y" -{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } -break; -case 89: -#line 404 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 90: -#line 406 "perly.y" -{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } -break; -case 91: -#line 408 "perly.y" -{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} -break; -case 92: -#line 410 "perly.y" -{ yyval.opval = newUNOP(OP_REFGEN, 0, ref(yyvsp[0].opval,OP_REFGEN)); } -break; -case 93: -#line 412 "perly.y" +#line 357 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; -case 94: -#line 415 "perly.y" +case 89: +#line 360 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; -case 95: -#line 418 "perly.y" +case 90: +#line 363 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; -case 96: -#line 421 "perly.y" +case 91: +#line 366 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; -case 97: -#line 424 "perly.y" +case 92: +#line 369 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; -case 98: -#line 426 "perly.y" +case 93: +#line 371 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; -case 99: -#line 428 "perly.y" +case 94: +#line 373 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; -case 100: -#line 430 "perly.y" +case 95: +#line 375 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; -case 101: -#line 432 "perly.y" +case 96: +#line 377 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; -case 102: -#line 434 "perly.y" -{ yyval.opval = newANONHASH(yyvsp[-1].opval); } +case 97: +#line 379 "perly.y" +{ yyval.opval = newANONHASH(yyvsp[-2].opval); } break; -case 103: -#line 436 "perly.y" +case 98: +#line 381 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; -case 104: -#line 438 "perly.y" +case 99: +#line 383 "perly.y" +{ yyval.opval = newANONSUB(yyvsp[-1].ival, yyvsp[0].opval); } +break; +case 100: +#line 385 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 105: -#line 440 "perly.y" +case 101: +#line 387 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 106: -#line 442 "perly.y" +case 102: +#line 389 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; -case 107: -#line 444 "perly.y" +case 103: +#line 391 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; -case 108: -#line 448 "perly.y" -{ yyval.opval = newBINOP(OP_AELEM, 0, +case 104: +#line 395 "perly.y" +{ assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; -case 109: -#line 452 "perly.y" +case 105: +#line 399 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 110: -#line 454 "perly.y" +case 106: +#line 401 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 111: -#line 456 "perly.y" +case 107: +#line 403 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; -case 112: -#line 458 "perly.y" +case 108: +#line 405 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 113: -#line 461 "perly.y" +case 109: +#line 408 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 114: -#line 466 "perly.y" -{ yyval.opval = newBINOP(OP_HELEM, 0, +case 110: +#line 413 "perly.y" +{ assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; -case 115: -#line 471 "perly.y" +case 111: +#line 418 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; -case 116: -#line 473 "perly.y" +case 112: +#line 420 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; -case 117: -#line 475 "perly.y" +case 113: +#line 422 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), - list( newLISTOP(OP_ASLICE, 0, list(yyvsp[-1].opval), - ref(yyvsp[-3].opval, OP_ASLICE)))); } + ref(yyvsp[-3].opval, OP_ASLICE))); } break; -case 118: -#line 482 "perly.y" +case 114: +#line 428 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), - list( newLISTOP(OP_HSLICE, 0, list(yyvsp[-2].opval), - ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)))); + ref(oopsHV(yyvsp[-4].opval), OP_HSLICE))); expect = XOPERATOR; } break; +case 115: +#line 435 "perly.y" +{ yyval.opval = yyvsp[0].opval; } +break; +case 116: +#line 437 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, 0, + scalar(yyvsp[0].opval)); } +break; +case 117: +#line 440 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } +break; +case 118: +#line 442 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, + list(append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval)))); } +break; case 119: -#line 490 "perly.y" -{ yyval.opval = newBINOP(OP_DELETE, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); - expect = XOPERATOR; } +#line 445 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, + list(append_elem(OP_LIST, + yyvsp[0].opval, newCVREF(scalar(yyvsp[-1].opval))))); } break; case 120: -#line 493 "perly.y" -{ yyval.opval = newBINOP(OP_DELETE, 0, oopsHV(yyvsp[-5].opval), jmaybe(yyvsp[-3].opval)); - expect = XOPERATOR; } +#line 449 "perly.y" +{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; case 121: -#line 496 "perly.y" -{ yyval.opval = yyvsp[0].opval; } +#line 451 "perly.y" +{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 122: -#line 498 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, 0, - scalar(yyvsp[0].opval)); } +#line 453 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, + list(prepend_elem(OP_LIST, + scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop))); dep();} break; case 123: -#line 501 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_STACKED, scalar(yyvsp[-2].opval)); } +#line 457 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, + list(append_elem(OP_LIST, + yyvsp[-1].opval, + scalar(newCVREF(scalar(yyvsp[-3].opval)))))); dep();} break; case 124: -#line 503 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_STACKED, - list(prepend_elem(OP_LIST, scalar(yyvsp[-3].opval), yyvsp[-1].opval))); } +#line 462 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, + list(prepend_elem(OP_LIST, + scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop))); dep();} break; case 125: -#line 506 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_STACKED, +#line 466 "perly.y" +{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, list(prepend_elem(OP_LIST, - newCVREF(scalar(yyvsp[-1].opval)), yyvsp[0].opval))); } + yyvsp[-1].opval, + scalar(newCVREF(scalar(yyvsp[-3].opval)))))); dep();} break; case 126: -#line 510 "perly.y" -{ yyval.opval = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, - newMETHOD(yyvsp[-1].opval,yyvsp[-2].opval), list(yyvsp[0].opval))); } +#line 471 "perly.y" +{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); + hints |= HINT_BLOCK_SCOPE; } break; case 127: -#line 514 "perly.y" -{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } +#line 474 "perly.y" +{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 128: -#line 516 "perly.y" -{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } +#line 476 "perly.y" +{ yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 129: -#line 518 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop))); } +#line 478 "perly.y" +{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 130: -#line 522 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-3].opval))), - yyvsp[-1].opval))); } +#line 480 "perly.y" +{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 131: -#line 527 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop)));} +#line 482 "perly.y" +{ yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 132: -#line 531 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-3].opval))), - yyvsp[-1].opval))); } +#line 484 "perly.y" +{ yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 133: -#line 536 "perly.y" -{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); - hints |= HINT_BLOCK_SCOPE; } +#line 486 "perly.y" +{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 134: -#line 539 "perly.y" -{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } +#line 488 "perly.y" +{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 135: -#line 541 "perly.y" -{ yyval.opval = newOP(yyvsp[0].ival, 0); } +#line 490 "perly.y" +{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 136: -#line 543 "perly.y" -{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } -break; -case 137: -#line 545 "perly.y" -{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } -break; -case 138: -#line 547 "perly.y" -{ yyval.opval = newOP(yyvsp[0].ival, 0); } +#line 492 "perly.y" +{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 139: -#line 549 "perly.y" -{ yyval.opval = newOP(yyvsp[-2].ival, 0); } +#line 498 "perly.y" +{ yyval.opval = Nullop; } break; case 140: -#line 551 "perly.y" -{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } +#line 500 "perly.y" +{ yyval.opval = yyvsp[0].opval; } break; case 141: -#line 553 "perly.y" -{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } +#line 504 "perly.y" +{ yyval.opval = Nullop; } break; case 142: -#line 555 "perly.y" -{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } +#line 506 "perly.y" +{ yyval.opval = yyvsp[0].opval; } break; case 143: -#line 557 "perly.y" -{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } -break; -case 146: -#line 563 "perly.y" -{ yyval.opval = Nullop; } -break; -case 147: -#line 565 "perly.y" -{ yyval.opval = yyvsp[0].opval; } +#line 508 "perly.y" +{ yyval.opval = yyvsp[-1].opval; } break; -case 148: -#line 569 "perly.y" +case 144: +#line 512 "perly.y" { yyval.opval = newCVREF(yyvsp[0].opval); } break; -case 149: -#line 573 "perly.y" +case 145: +#line 516 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; -case 150: -#line 577 "perly.y" +case 146: +#line 520 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 151: -#line 581 "perly.y" +case 147: +#line 524 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; -case 152: -#line 585 "perly.y" +case 148: +#line 528 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; -case 153: -#line 589 "perly.y" -{ yyval.opval = newGVREF(yyvsp[0].opval); } +case 149: +#line 532 "perly.y" +{ yyval.opval = newGVREF(0,yyvsp[0].opval); } break; -case 154: -#line 593 "perly.y" +case 150: +#line 536 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 155: -#line 595 "perly.y" +case 151: +#line 538 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; -case 156: -#line 597 "perly.y" -{ yyval.opval = scalar(scope(yyvsp[0].opval)); } +case 152: +#line 540 "perly.y" +{ yyval.opval = scope(yyvsp[0].opval); } break; -case 157: -#line 600 "perly.y" +case 153: +#line 543 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -case 158: -#line 604 "perly.y" -{ yyval.ival = 1; } -break; -case 159: -#line 606 "perly.y" -{ yyval.ival = 0; } -break; -case 160: -#line 610 "perly.y" -{ yyval.ival = 1; } -break; -case 161: -#line 612 "perly.y" -{ yyval.ival = 0; } -break; -case 162: -#line 616 "perly.y" -{ yyval.ival = 1; } -break; -case 163: -#line 618 "perly.y" -{ yyval.ival = 0; } -break; -#line 2483 "y.tab.c" +#line 2157 "y.tab.c" } yyssp -= yym; yystate = *yyssp; @@ -2578,8 +2224,10 @@ break; int yyps_index = (yyssp - yyss); int yypv_index = (yyvsp - yyvs); yystacksize += YYSTACKSIZE; - yyvs = (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); - yyss = (short*)realloc((char*)yyss,yystacksize * sizeof(short)); + ysave->yyvs = yyvs = + (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); + ysave->yyss = yyss = + (short*)realloc((char*)yyss,yystacksize * sizeof(short)); if (!yyvs || !yyss) goto yyoverflow; yyssp = yyss + yyps_index; @@ -2593,13 +2241,5 @@ yyoverflow: yyabort: retval = 1; yyaccept: - if (yyss) free(yyss); - if (yyvs) free(yyvs); - yydebug = oldyydebug; - yynerrs = oldyynerrs; - yyerrflag = oldyyerrflag; - yychar = oldyychar; - yyval = oldyyval; - yylval = oldyylval; return retval; } diff --git a/perly.c.byacc b/perly.c.byacc deleted file mode 100644 index e78ca0d59a..0000000000 --- a/perly.c.byacc +++ /dev/null @@ -1,2295 +0,0 @@ -#ifndef lint -static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; -#endif -#define YYBYACC 1 -#line 39 "perly.y" -#include "EXTERN.h" -#include "perl.h" - -/*SUPPRESS 530*/ -/*SUPPRESS 593*/ -/*SUPPRESS 595*/ - -#line 50 "perly.y" -typedef union { - I32 ival; - char *pval; - OP *opval; - GV *gvval; -} YYSTYPE; -#line 21 "y.tab.c" -#define WORD 257 -#define METHOD 258 -#define THING 259 -#define PMFUNC 260 -#define PRIVATEREF 261 -#define LABEL 262 -#define FORMAT 263 -#define SUB 264 -#define PACKAGE 265 -#define WHILE 266 -#define UNTIL 267 -#define IF 268 -#define UNLESS 269 -#define ELSE 270 -#define ELSIF 271 -#define CONTINUE 272 -#define FOR 273 -#define LOOPEX 274 -#define DOTDOT 275 -#define FUNC0 276 -#define FUNC1 277 -#define FUNC 278 -#define RELOP 279 -#define EQOP 280 -#define MULOP 281 -#define ADDOP 282 -#define DOLSHARP 283 -#define DO 284 -#define LOCAL 285 -#define DELETE 286 -#define HASHBRACK 287 -#define LSTOP 288 -#define OROR 289 -#define ANDAND 290 -#define BITOROP 291 -#define BITANDOP 292 -#define UNIOP 293 -#define SHIFTOP 294 -#define MATCHOP 295 -#define ARROW 296 -#define UMINUS 297 -#define REFGEN 298 -#define POWOP 299 -#define PREINC 300 -#define PREDEC 301 -#define POSTINC 302 -#define POSTDEC 303 -#define YYERRCODE 256 -short yylhs[] = { -1, - 30, 0, 7, 3, 8, 8, 8, 9, 9, 9, - 9, 23, 23, 23, 23, 23, 23, 13, 13, 13, - 11, 11, 11, 11, 29, 29, 10, 10, 10, 10, - 10, 10, 10, 10, 12, 12, 26, 26, 28, 28, - 1, 1, 1, 2, 2, 31, 32, 32, 14, 14, - 27, 27, 27, 27, 27, 27, 27, 27, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 24, 24, 22, 17, 18, - 19, 20, 21, 25, 25, 25, 25, 4, 4, 5, - 5, 6, 6, -}; -short yylen[] = { 2, - 0, 2, 4, 0, 0, 2, 2, 2, 1, 2, - 3, 1, 1, 3, 3, 3, 3, 0, 2, 6, - 6, 6, 4, 4, 0, 2, 7, 7, 5, 5, - 8, 7, 10, 3, 0, 1, 0, 1, 0, 1, - 1, 1, 1, 3, 2, 3, 3, 2, 3, 1, - 3, 5, 4, 6, 6, 3, 2, 4, 3, 4, - 4, 4, 4, 4, 4, 4, 4, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 5, 3, - 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 3, 2, 3, 2, 3, 3, 1, 1, 4, - 5, 1, 1, 1, 5, 6, 6, 5, 4, 5, - 6, 8, 1, 1, 3, 4, 2, 2, 4, 5, - 4, 5, 1, 2, 1, 2, 2, 1, 3, 3, - 4, 4, 6, 1, 1, 0, 1, 2, 2, 2, - 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, - 1, 3, 2, -}; -short yydefred[] = { 1, - 0, 5, 0, 40, 0, 0, 0, 6, 41, 7, - 9, 0, 42, 43, 4, 0, 45, 0, 0, 48, - 12, 0, 0, 113, 0, 147, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 10, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 8, 0, - 0, 0, 0, 0, 102, 104, 99, 0, 0, 0, - 135, 5, 44, 46, 47, 144, 146, 145, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 124, 0, 0, 0, 142, 0, 118, 0, 0, 0, - 0, 0, 0, 0, 0, 57, 0, 126, 0, 0, - 0, 0, 89, 90, 0, 0, 0, 0, 95, 0, - 138, 139, 140, 141, 143, 0, 34, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 87, 88, 0, - 0, 0, 0, 0, 11, 0, 0, 56, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 36, 0, 129, 130, 0, 0, 0, 0, 0, 0, - 0, 97, 0, 0, 96, 51, 0, 149, 0, 0, - 0, 151, 94, 26, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 115, 0, - 0, 0, 3, 132, 0, 0, 29, 0, 30, 0, - 0, 0, 23, 0, 24, 0, 0, 0, 131, 58, - 0, 119, 0, 121, 0, 0, 0, 0, 153, 0, - 148, 0, 150, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 100, 0, 109, 116, - 0, 53, 0, 0, 0, 0, 19, 0, 0, 0, - 0, 0, 52, 120, 122, 0, 0, 152, 108, 0, - 0, 0, 0, 101, 105, 110, 0, 133, 27, 28, - 21, 0, 22, 0, 32, 0, 0, 111, 107, 106, - 55, 54, 0, 0, 31, 0, 0, 0, 112, 20, - 33, -}; -short yydgoto[] = { 1, - 8, 9, 72, 190, 193, 185, 77, 3, 10, 11, - 59, 169, 243, 105, 61, 62, 63, 64, 65, 66, - 67, 68, 171, 106, 70, 161, 71, 12, 127, 2, - 13, 14, -}; -short yysindex[] = { 0, - 0, 0, -17, 0, -120, -239, -58, 0, 0, 0, - 0, 620, 0, 0, 0, -93, 0, -93, -21, 0, - 0, 0, -20, 0, 7, 0, -30, -28, -26, -23, - -9, -172, 23, 86, 143, -20, 2759, 2804, 24, 886, - 2804, 2804, 2804, 2804, 2804, 2804, 2804, 931, 0, 2804, - 2804, 997, -20, -20, -20, -20, -20, -96, 0, 94, - 3685, -73, -82, -71, 0, 0, 0, 149, 139, -92, - 0, 0, 0, 0, 0, 0, 0, 0, 2804, 2804, - 2804, -93, 2804, -93, 2804, -93, 2804, -93, 1197, 171, - 0, 185, 1263, 2804, 0, 180, 0, -94, -32, -94, - 192, 111, 119, 80, 188, 0, 1308, 0, -94, -100, - -100, -100, 0, 0, 165, 108, -100, -100, 0, -39, - 0, 0, 0, 0, 0, -93, 0, 2804, 2804, 2804, - 2804, 2804, 2804, 2804, 2804, 1368, 1574, 2804, 2804, 1634, - 1679, 1745, 1948, 2011, 2804, 2056, -87, 0, 0, 2804, - 2804, 2804, 2804, 2119, 0, -216, -119, 0, 4405, 188, - 219, -96, 210, -96, 214, -3, 225, -3, 220, 84, - 0, 2804, 0, 0, 234, 239, 1308, 2322, 2385, 172, - 2804, 0, 2430, 169, 0, 0, 2804, 0, 2493, 197, - 2696, 0, 0, 0, 188, 188, 188, 188, 3685, 699, - -94, 295, 2804, -194, 2804, -225, 3685, 4320, 2804, 269, - 2804, 330, 2804, 393, 2804, 230, 2804, -253, 1, 2804, - 1, 2804, 261, 2804, 107, -11, 115, -4, 0, 108, - 263, 2804, 0, 0, 2804, -93, 0, -93, 0, -93, - -93, 270, 0, -93, 0, 2804, -93, 108, 0, 0, - 273, 0, 108, 0, 108, 2804, 133, 190, 0, 5, - 0, 2804, 0, 3685, 3685, 2804, 3685, 3685, 3685, 3685, - 3685, 3685, 134, 2804, 6, 196, 0, 199, 0, 0, - 2804, 0, 3169, -96, -96, -3, 0, 2804, -3, 266, - -96, -93, 0, 0, 0, 136, 201, 0, 0, 29, - -18, 216, 281, 0, 0, 0, 301, 0, 0, 0, - 0, 249, 0, 1197, 0, -96, 218, 0, 0, 0, - 0, 0, -93, 305, 0, 324, -3, -93, 0, 0, - 0, -}; -short yyrindex[] = { 0, - 0, 0, 449, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 494, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 17, 2840, 0, 0, 0, 0, 0, 0, 0, - 2878, 2946, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 71, 0, -15, - 375, 4354, 555, 2990, 0, 0, 0, 3035, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 2878, 0, - 325, 0, 0, 0, 0, 0, 0, 0, 309, 0, - 0, 0, 0, 329, 0, 3138, 0, 3762, 3203, 3800, - 0, 0, 0, 0, 3329, 0, 3394, 0, 3839, 4095, - 4163, 4203, 0, 0, 3250, 0, 4256, 4295, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 826, 0, 0, -2, - 0, 127, 0, 127, 0, 179, 0, 179, 0, 314, - 0, 0, 0, 0, 0, 0, 329, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 3291, - 0, 0, 0, 0, 77, 88, 99, 109, 1460, 899, - 3900, 1092, 0, 3585, 0, 3646, 1901, 0, 0, 2217, - 0, 1469, 0, 3910, 0, 1840, 0, 3719, 3463, 0, - 3506, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 2878, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 315, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 2398, 2591, 0, 3097, 3107, 3547, 3991, - 4002, 4041, 0, 329, 0, 0, 0, 0, 0, 0, - 329, 0, 0, 127, 127, 179, 0, 0, 179, 0, - 127, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 365, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 334, 0, 127, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 179, 0, 0, 0, - 0, -}; -short yygindex[] = { 0, - 0, 0, 0, -136, 0, 0, -5, 304, 0, 0, - 0, 63, -166, 3, 4588, 163, 465, 0, 0, 0, - 0, 0, 366, 8, 12, 135, 0, 0, -143, 0, - 0, 0, -}; -#define YYTABLESIZE 4854 -short yytable[] = { 17, - 20, 245, 15, 224, 191, 233, 58, 179, 151, 81, - 73, 83, 74, 85, 60, 54, 87, 18, 237, 153, - 239, 82, 84, 86, 88, 13, 54, 136, 137, 15, - 89, 97, 132, 247, 79, 222, 108, 75, 38, 132, - 150, 145, 104, 13, 139, 146, 80, 95, 132, 132, - 116, 152, 107, 192, 120, 136, 38, 123, 151, 54, - 123, 231, 92, 101, 121, 122, 123, 124, 125, 145, - 25, 232, 132, 146, 123, 123, 162, 123, 164, 123, - 166, 277, 168, 160, 91, 163, 158, 165, 279, 167, - 150, 170, 15, 280, 15, 175, 15, 299, 304, 15, - 145, 176, 15, 25, 146, 177, 25, 25, 25, 123, - 25, 292, 25, 25, 186, 25, 294, 16, 295, 311, - 194, 319, 313, 183, 188, 93, 25, 189, 17, 25, - 195, 196, 197, 198, 25, 16, 16, 132, 184, 14, - 309, 310, 4, 5, 6, 7, 17, 315, 188, 15, - 132, 189, 225, 226, 227, 228, 230, 14, 132, 25, - 330, 25, 25, 25, 25, 276, 25, 15, 25, 25, - 223, 25, 325, 278, 248, 126, 132, 132, 18, 132, - 253, 255, 94, 257, 251, 25, 136, 137, 154, 260, - 25, 297, 302, 25, 317, 25, 25, 155, 19, 144, - 145, 148, 149, 156, 146, 110, 111, 112, 113, 114, - 172, 18, 117, 118, 18, 18, 18, 25, 18, 178, - 18, 18, 147, 18, 273, 173, 275, 54, 148, 149, - 284, 132, 285, 181, 286, 287, 76, 18, 289, 282, - 26, 291, 18, 182, 4, 5, 6, 7, 160, 25, - 238, 25, 25, 132, 240, 187, 133, 132, 296, 236, - 134, 135, 136, 137, 300, 244, 241, 242, 132, 18, - 140, 141, 142, 143, 249, 144, 145, 132, 246, 250, - 146, 303, 123, 123, 123, 123, 316, 262, 307, 323, - 312, 123, 132, 259, 256, 123, 123, 123, 123, 146, - 274, 18, 281, 18, 18, 123, 123, 123, 123, 288, - 123, 123, 123, 293, 298, 123, 60, 327, 123, 123, - 305, 321, 331, 306, 314, 318, 25, 25, 25, 25, - 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, - 320, 322, 326, 25, 25, 328, 25, 25, 25, 128, - 129, 130, 131, 25, 25, 25, 25, 25, 25, 128, - 129, 130, 131, 25, 329, 37, 146, 35, 25, 136, - 25, 25, 13, 37, 35, 157, 324, 69, 0, 0, - 290, 0, 25, 25, 25, 25, 25, 25, 25, 25, - 25, 25, 25, 25, 25, 25, 0, 0, 0, 25, - 25, 0, 25, 25, 25, 79, 0, 0, 79, 25, - 25, 25, 25, 25, 25, 50, 0, 0, 50, 25, - 0, 0, 79, 79, 25, 79, 25, 25, 0, 0, - 0, 0, 50, 50, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 2, 0, - 0, 18, 18, 0, 18, 18, 18, 79, 0, 0, - 0, 18, 18, 18, 18, 18, 18, 50, 0, 0, - 0, 18, 0, 0, 0, 0, 18, 0, 18, 18, - 0, 39, 0, 0, 39, 39, 39, 78, 39, 0, - 39, 39, 0, 39, 0, 90, 0, 0, 0, 0, - 78, 99, 0, 102, 0, 0, 0, 39, 134, 135, - 136, 137, 39, 0, 0, 0, 0, 78, 78, 78, - 78, 78, 0, 144, 145, 0, 144, 0, 146, 144, - 144, 144, 0, 144, 134, 144, 144, 134, 144, 39, - 0, 0, 0, 0, 0, 0, 0, 134, 135, 136, - 137, 134, 134, 0, 134, 0, 134, 144, 141, 142, - 143, 0, 144, 145, 0, 180, 0, 146, 0, 0, - 0, 39, 0, 134, 39, 136, 137, 0, 0, 0, - 0, 0, 0, 0, 144, 0, 134, 145, 144, 145, - 145, 145, 145, 146, 145, 98, 145, 145, 98, 145, - 0, 0, 0, 0, 0, 0, 0, 0, 134, 135, - 136, 137, 98, 98, 0, 98, 144, 98, 145, 144, - 142, 143, 0, 144, 145, 0, 0, 0, 146, 0, - 79, 79, 79, 79, 0, 0, 0, 0, 0, 0, - 50, 50, 50, 50, 0, 0, 0, 98, 0, 0, - 0, 0, 43, 0, 0, 54, 56, 53, 0, 48, - 79, 57, 51, 0, 50, 0, 79, 79, 0, 0, - 50, 134, 135, 136, 137, 0, 50, 50, 49, 0, - 145, 0, 0, 55, 143, 0, 144, 145, 0, 0, - 0, 146, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, - 52, 0, 0, 0, 39, 39, 39, 39, 0, 0, - 0, 39, 39, 0, 39, 39, 39, 0, 0, 0, - 0, 39, 39, 39, 39, 39, 39, 0, 0, 0, - 0, 39, 15, 0, 0, 44, 39, 0, 39, 39, - 144, 144, 144, 144, 144, 0, 0, 0, 0, 134, - 134, 134, 134, 0, 0, 0, 0, 144, 134, 144, - 144, 144, 134, 134, 134, 134, 144, 144, 144, 144, - 144, 144, 134, 134, 134, 134, 144, 134, 134, 134, - 0, 144, 134, 144, 144, 134, 134, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 145, 145, 145, 145, 145, 0, 0, 0, 0, - 98, 98, 98, 98, 0, 0, 0, 0, 145, 98, - 145, 145, 145, 98, 98, 98, 98, 145, 145, 145, - 145, 145, 145, 98, 98, 98, 98, 145, 98, 98, - 98, 0, 145, 98, 145, 145, 98, 98, 39, 0, - 0, 39, 39, 39, 0, 39, 0, 39, 39, 0, - 39, 0, 0, 0, 0, 21, 22, 23, 24, 25, - 26, 0, 0, 0, 39, 27, 28, 29, 30, 39, - 0, 0, 31, 32, 0, 33, 34, 35, 0, 0, - 0, 0, 36, 37, 38, 39, 40, 41, 0, 0, - 0, 0, 42, 0, 0, 0, 39, 45, 43, 46, - 47, 54, 56, 53, 0, 48, 0, 57, 51, 0, - 50, 0, 0, 0, 0, 0, 0, 0, 0, 76, - 0, 0, 76, 0, 103, 0, 0, 0, 39, 55, - 0, 39, 0, 0, 0, 0, 76, 76, 0, 76, - 0, 76, 0, 43, 0, 0, 54, 56, 53, 0, - 48, 115, 57, 51, 0, 50, 52, 134, 135, 136, - 137, 0, 0, 0, 0, 0, 0, 140, 141, 142, - 143, 76, 144, 145, 55, 0, 0, 146, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 0, - 0, 44, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 52, 0, 0, 0, 0, 0, 0, 0, 43, - 0, 0, 54, 56, 53, 0, 48, 0, 57, 51, - 0, 50, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 0, 0, 44, 0, 0, 0, - 55, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 39, 39, 39, 39, 39, 39, 52, 0, 119, - 0, 39, 39, 39, 39, 0, 0, 0, 39, 39, - 0, 39, 39, 39, 0, 0, 0, 0, 39, 39, - 39, 39, 39, 39, 0, 0, 0, 0, 39, 15, - 0, 0, 44, 39, 0, 39, 39, 0, 0, 0, - 0, 0, 73, 0, 0, 73, 0, 0, 0, 0, - 0, 0, 22, 23, 24, 25, 26, 0, 0, 73, - 73, 0, 73, 0, 73, 0, 0, 0, 0, 32, - 0, 33, 34, 35, 76, 76, 76, 76, 36, 37, - 38, 39, 40, 41, 0, 0, 0, 0, 42, 0, - 0, 0, 0, 45, 73, 46, 47, 22, 23, 24, - 25, 26, 0, 0, 76, 0, 0, 0, 0, 0, - 76, 76, 0, 0, 32, 0, 33, 34, 35, 0, - 0, 0, 0, 36, 37, 38, 39, 40, 41, 0, - 0, 0, 0, 42, 0, 0, 0, 0, 45, 43, - 46, 47, 54, 56, 53, 0, 48, 0, 57, 51, - 0, 50, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 22, 23, 24, 25, 26, 0, 0, - 55, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 32, 0, 33, 34, 35, 0, 0, 0, 0, 36, - 37, 38, 39, 40, 41, 0, 0, 52, 0, 42, - 0, 0, 0, 0, 45, 43, 46, 47, 54, 56, - 53, 0, 48, 174, 57, 51, 0, 50, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, - 0, 0, 44, 0, 0, 0, 55, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 43, 0, 0, 54, 56, 53, 0, 48, 0, 57, - 51, 0, 50, 52, 0, 0, 0, 73, 73, 73, - 73, 0, 0, 0, 0, 0, 73, 0, 0, 0, - 0, 55, 0, 0, 0, 0, 0, 0, 0, 0, - 73, 73, 73, 73, 0, 15, 0, 73, 44, 0, - 0, 0, 0, 73, 73, 0, 0, 0, 52, 0, - 43, 0, 0, 54, 56, 53, 0, 48, 0, 57, - 51, 0, 50, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 203, 0, - 15, 55, 0, 44, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 21, 22, 23, 24, 25, 26, 52, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 32, 0, 33, 34, 35, 0, 0, 0, 0, 36, - 37, 38, 39, 40, 41, 0, 0, 0, 0, 42, - 15, 0, 0, 44, 45, 0, 46, 47, 0, 0, - 49, 0, 0, 49, 0, 0, 0, 0, 0, 77, - 0, 0, 77, 0, 0, 0, 0, 49, 49, 22, - 23, 24, 25, 26, 0, 0, 77, 77, 0, 77, - 0, 77, 0, 0, 0, 0, 32, 0, 33, 34, - 35, 0, 0, 0, 0, 36, 37, 38, 39, 40, - 41, 0, 49, 0, 0, 42, 0, 0, 0, 0, - 45, 77, 46, 47, 22, 23, 24, 25, 26, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 32, 0, 33, 34, 35, 0, 0, 0, 0, - 36, 37, 38, 39, 40, 41, 0, 0, 0, 0, - 42, 0, 0, 156, 0, 45, 43, 46, 47, 54, - 56, 53, 0, 48, 0, 57, 51, 0, 50, 0, - 0, 0, 0, 0, 22, 23, 24, 25, 26, 0, - 0, 0, 0, 0, 205, 0, 0, 55, 0, 0, - 0, 32, 0, 33, 34, 35, 0, 0, 0, 0, - 36, 37, 38, 39, 40, 41, 0, 0, 0, 0, - 42, 0, 0, 0, 52, 45, 43, 46, 47, 54, - 56, 53, 0, 48, 0, 57, 51, 0, 50, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 209, 0, 15, 55, 0, 44, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 43, 0, 0, 54, 56, 53, 0, 48, 0, - 57, 51, 0, 50, 52, 49, 49, 49, 49, 0, - 0, 0, 0, 0, 77, 77, 77, 77, 0, 211, - 0, 0, 55, 77, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 49, 15, 77, 77, 44, - 0, 49, 49, 0, 77, 0, 0, 0, 0, 52, - 77, 77, 0, 0, 0, 0, 0, 43, 0, 0, - 54, 56, 53, 0, 48, 0, 57, 51, 0, 50, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 15, 0, 0, 44, 213, 0, 0, 55, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 22, 23, 24, 25, 26, 52, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 32, 0, 33, - 34, 35, 0, 0, 0, 0, 36, 37, 38, 39, - 40, 41, 0, 0, 0, 0, 42, 15, 0, 0, - 44, 45, 0, 46, 47, 0, 0, 0, 0, 0, - 74, 0, 0, 74, 0, 0, 0, 0, 0, 0, - 22, 23, 24, 25, 26, 0, 0, 74, 74, 0, - 74, 0, 74, 0, 0, 0, 0, 32, 0, 33, - 34, 35, 0, 0, 0, 0, 36, 37, 38, 39, - 40, 41, 0, 0, 0, 0, 42, 0, 0, 0, - 0, 45, 74, 46, 47, 22, 23, 24, 25, 26, - 0, 59, 0, 0, 59, 0, 0, 0, 0, 0, - 0, 0, 32, 0, 33, 34, 35, 0, 59, 59, - 0, 36, 37, 38, 39, 40, 41, 0, 0, 0, - 0, 42, 0, 0, 0, 0, 45, 0, 46, 47, - 43, 0, 0, 54, 56, 53, 0, 48, 0, 57, - 51, 0, 50, 59, 0, 0, 0, 0, 0, 0, - 0, 22, 23, 24, 25, 26, 0, 0, 215, 0, - 0, 55, 0, 0, 0, 0, 0, 0, 32, 0, - 33, 34, 35, 0, 0, 0, 0, 36, 37, 38, - 39, 40, 41, 0, 0, 0, 0, 42, 52, 0, - 0, 0, 45, 43, 46, 47, 54, 56, 53, 0, - 48, 0, 57, 51, 0, 50, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 15, 217, 0, 44, 55, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 43, 0, - 0, 54, 56, 53, 0, 48, 0, 57, 51, 0, - 50, 52, 0, 0, 0, 74, 74, 74, 74, 0, - 0, 0, 0, 0, 74, 0, 220, 0, 0, 55, - 0, 0, 0, 0, 0, 0, 0, 0, 74, 74, - 74, 74, 0, 15, 0, 74, 44, 0, 0, 0, - 0, 74, 74, 0, 0, 0, 52, 0, 0, 0, - 0, 43, 0, 0, 54, 56, 53, 0, 48, 229, - 57, 51, 0, 50, 0, 0, 59, 59, 59, 59, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 0, - 0, 44, 55, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 59, 0, 0, 0, - 0, 0, 59, 59, 22, 23, 24, 25, 26, 52, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 32, 0, 33, 34, 35, 0, 0, 0, 0, - 36, 37, 38, 39, 40, 41, 0, 0, 0, 0, - 42, 15, 0, 0, 44, 45, 0, 46, 47, 0, - 0, 0, 0, 0, 0, 0, 0, 78, 0, 0, - 78, 0, 0, 0, 0, 0, 0, 22, 23, 24, - 25, 26, 0, 0, 78, 78, 0, 78, 0, 78, - 0, 0, 0, 0, 32, 0, 33, 34, 35, 0, - 0, 0, 0, 36, 37, 38, 39, 40, 41, 0, - 0, 0, 0, 42, 0, 0, 0, 0, 45, 78, - 46, 47, 22, 23, 24, 25, 26, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 32, - 0, 33, 34, 35, 0, 0, 0, 0, 36, 37, - 38, 39, 40, 41, 0, 0, 0, 0, 42, 0, - 0, 0, 0, 45, 43, 46, 47, 54, 56, 53, - 0, 48, 252, 57, 51, 0, 50, 0, 0, 0, - 0, 0, 0, 0, 0, 22, 23, 24, 25, 26, - 0, 0, 0, 0, 0, 55, 0, 0, 0, 0, - 0, 0, 32, 0, 33, 34, 35, 0, 0, 0, - 0, 36, 37, 38, 39, 40, 41, 0, 0, 0, - 0, 42, 52, 0, 0, 0, 45, 43, 46, 47, - 54, 56, 53, 0, 48, 254, 57, 51, 0, 50, - 0, 0, 0, 0, 0, 0, 0, 0, 61, 0, - 0, 61, 0, 0, 15, 0, 0, 44, 55, 0, - 0, 0, 0, 0, 0, 61, 61, 0, 0, 0, - 0, 0, 43, 0, 0, 54, 56, 53, 0, 48, - 0, 57, 51, 0, 50, 52, 0, 0, 0, 0, - 0, 0, 78, 78, 78, 78, 0, 0, 258, 0, - 61, 78, 0, 55, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 78, 0, 15, 0, 0, - 44, 0, 78, 0, 0, 0, 0, 0, 78, 78, - 52, 0, 0, 0, 0, 43, 0, 0, 54, 56, - 53, 0, 48, 261, 57, 51, 0, 50, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 15, 0, 0, 44, 55, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 22, 23, - 24, 25, 26, 52, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 32, 0, 33, 34, 35, - 0, 0, 0, 0, 36, 37, 38, 39, 40, 41, - 0, 0, 0, 0, 42, 15, 0, 0, 44, 45, - 0, 46, 47, 0, 0, 0, 0, 0, 0, 0, - 0, 62, 0, 0, 62, 0, 0, 0, 0, 0, - 0, 22, 23, 24, 25, 26, 0, 0, 62, 62, - 0, 0, 0, 0, 0, 0, 0, 0, 32, 0, - 33, 34, 35, 61, 61, 61, 61, 36, 37, 38, - 39, 40, 41, 0, 0, 0, 0, 42, 0, 0, - 0, 0, 45, 62, 46, 47, 22, 23, 24, 25, - 26, 0, 0, 61, 0, 0, 0, 0, 0, 61, - 61, 0, 0, 32, 0, 33, 34, 35, 0, 0, - 0, 0, 36, 37, 38, 39, 40, 41, 0, 0, - 0, 0, 42, 0, 0, 0, 0, 45, 43, 46, - 47, 54, 56, 53, 0, 48, 0, 57, 51, 0, - 50, 0, 0, 0, 0, 0, 0, 0, 0, 22, - 23, 24, 25, 26, 0, 0, 0, 0, 0, 55, - 0, 0, 0, 0, 0, 0, 32, 0, 33, 34, - 35, 0, 0, 0, 0, 36, 37, 38, 39, 40, - 41, 0, 0, 0, 0, 42, 52, 0, 263, 0, - 45, 43, 46, 47, 54, 56, 53, 0, 48, 0, - 57, 51, 0, 50, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 15, 0, - 0, 44, 55, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 43, 0, 0, 54, - 56, 53, 0, 48, 0, 57, 51, 0, 50, 52, - 0, 0, 0, 0, 0, 0, 62, 62, 62, 62, - 0, 0, 0, 0, 0, 0, 0, 55, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 128, 15, 0, 128, 44, 0, 62, 0, 0, 0, - 0, 0, 62, 62, 52, 0, 0, 128, 128, 0, - 128, 0, 128, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 136, 0, - 0, 136, 0, 0, 0, 0, 15, 0, 0, 44, - 0, 0, 128, 0, 0, 136, 136, 0, 136, 0, - 136, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 22, 23, 24, 25, 26, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 32, - 136, 33, 34, 35, 0, 0, 0, 0, 36, 37, - 38, 39, 40, 41, 0, 0, 125, 0, 42, 125, - 0, 0, 0, 45, 0, 46, 47, 0, 0, 0, - 0, 0, 0, 125, 125, 0, 125, 0, 125, 0, - 0, 0, 0, 0, 0, 96, 23, 24, 25, 26, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 103, 0, 32, 103, 33, 34, 35, 0, 125, 0, - 0, 36, 37, 38, 39, 40, 41, 103, 103, 0, - 103, 42, 103, 0, 0, 0, 45, 0, 46, 47, - 22, 23, 24, 25, 26, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 114, 0, 32, 114, 33, - 34, 35, 103, 0, 0, 0, 36, 37, 38, 39, - 40, 41, 114, 114, 0, 114, 42, 114, 0, 0, - 0, 45, 0, 46, 47, 128, 128, 128, 128, 0, - 0, 0, 0, 0, 128, 0, 0, 0, 128, 128, - 128, 128, 0, 0, 0, 0, 0, 114, 128, 128, - 128, 128, 0, 128, 128, 128, 0, 67, 128, 0, - 67, 128, 128, 136, 136, 136, 136, 66, 0, 0, - 66, 0, 136, 0, 67, 67, 136, 136, 136, 136, - 0, 0, 0, 0, 66, 66, 136, 136, 136, 136, - 0, 136, 136, 136, 0, 0, 136, 0, 134, 136, - 136, 134, 0, 0, 0, 0, 0, 0, 0, 67, - 0, 0, 0, 0, 0, 134, 134, 0, 134, 66, - 134, 0, 0, 0, 0, 0, 0, 0, 0, 308, - 0, 125, 125, 125, 125, 0, 0, 0, 0, 0, - 125, 0, 0, 0, 125, 125, 125, 125, 0, 138, - 134, 139, 0, 0, 125, 125, 125, 125, 0, 125, - 125, 125, 0, 98, 125, 0, 98, 125, 125, 0, - 0, 0, 0, 0, 0, 103, 103, 103, 103, 0, - 98, 98, 0, 98, 103, 98, 0, 0, 103, 103, - 103, 103, 0, 0, 0, 0, 0, 0, 103, 103, - 103, 103, 0, 103, 103, 103, 0, 0, 103, 0, - 93, 103, 103, 93, 0, 98, 0, 0, 0, 0, - 114, 114, 114, 114, 0, 0, 0, 93, 93, 114, - 93, 0, 93, 114, 114, 114, 114, 0, 0, 0, - 0, 0, 0, 114, 114, 114, 114, 0, 114, 114, - 114, 92, 0, 114, 92, 0, 114, 114, 0, 0, - 0, 0, 93, 0, 0, 0, 0, 0, 92, 92, - 0, 92, 0, 92, 0, 0, 0, 0, 0, 0, - 0, 0, 67, 67, 67, 67, 0, 0, 0, 137, - 0, 0, 66, 66, 66, 66, 0, 0, 0, 0, - 0, 0, 0, 92, 0, 0, 137, 137, 0, 137, - 0, 137, 67, 0, 0, 0, 0, 0, 67, 67, - 0, 0, 66, 134, 134, 134, 134, 0, 66, 66, - 0, 0, 134, 0, 0, 0, 134, 134, 134, 134, - 0, 137, 0, 0, 0, 0, 134, 134, 134, 134, - 0, 134, 134, 134, 136, 0, 134, 136, 0, 134, - 134, 0, 0, 133, 0, 0, 0, 134, 135, 136, - 137, 136, 136, 0, 136, 0, 136, 140, 141, 142, - 143, 0, 144, 145, 0, 0, 0, 146, 98, 98, - 98, 98, 0, 0, 0, 0, 0, 98, 0, 0, - 0, 98, 98, 98, 98, 0, 136, 0, 0, 0, - 0, 98, 98, 98, 98, 0, 98, 98, 98, 0, - 0, 98, 0, 80, 98, 98, 80, 0, 0, 0, - 0, 0, 0, 0, 0, 93, 93, 93, 93, 0, - 80, 80, 0, 80, 93, 80, 0, 0, 93, 93, - 93, 93, 0, 0, 0, 0, 0, 0, 93, 93, - 93, 93, 0, 93, 93, 93, 68, 0, 93, 68, - 0, 93, 93, 0, 0, 80, 92, 92, 92, 92, - 0, 0, 0, 68, 68, 92, 68, 0, 68, 92, - 92, 92, 92, 0, 0, 0, 0, 0, 0, 92, - 92, 92, 92, 0, 92, 92, 92, 65, 0, 92, - 65, 0, 92, 92, 137, 137, 137, 137, 68, 0, - 0, 0, 0, 137, 65, 65, 0, 137, 137, 137, - 137, 0, 0, 0, 0, 0, 0, 137, 137, 137, - 137, 0, 137, 137, 137, 69, 0, 137, 69, 0, - 137, 137, 0, 0, 0, 0, 0, 0, 0, 65, - 0, 0, 69, 69, 0, 69, 0, 69, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 136, - 136, 136, 136, 0, 0, 0, 0, 0, 136, 0, - 0, 0, 136, 136, 136, 136, 0, 69, 0, 0, - 0, 0, 136, 136, 136, 136, 70, 136, 136, 70, - 0, 0, 136, 0, 0, 136, 136, 0, 0, 0, - 0, 0, 0, 70, 70, 0, 70, 0, 70, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 80, 80, - 80, 80, 0, 0, 0, 0, 0, 80, 70, 0, - 0, 80, 80, 80, 80, 138, 0, 139, 0, 0, - 0, 80, 80, 80, 80, 0, 80, 80, 80, 71, - 0, 0, 71, 0, 80, 80, 0, 0, 0, 0, - 0, 68, 68, 68, 68, 0, 71, 71, 0, 71, - 68, 71, 0, 0, 68, 68, 68, 68, 0, 0, - 0, 0, 0, 0, 68, 68, 68, 68, 0, 68, - 68, 68, 117, 0, 0, 117, 0, 68, 68, 0, - 0, 71, 65, 65, 65, 65, 0, 0, 0, 117, - 117, 0, 117, 0, 117, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 91, 0, 65, 91, 0, 0, 0, 0, 65, 65, - 69, 69, 69, 69, 117, 0, 0, 91, 91, 69, - 91, 0, 91, 69, 69, 69, 69, 0, 0, 0, - 0, 0, 0, 69, 69, 69, 69, 0, 69, 127, - 69, 0, 127, 0, 0, 0, 69, 69, 0, 0, - 0, 0, 91, 0, 0, 0, 127, 127, 0, 127, - 0, 127, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 70, 70, 70, 70, 0, 0, 0, 0, 0, - 70, 0, 0, 0, 70, 70, 0, 70, 0, 0, - 0, 127, 0, 0, 70, 70, 70, 70, 0, 70, - 72, 70, 0, 72, 0, 0, 0, 70, 70, 0, - 75, 0, 0, 75, 0, 0, 0, 72, 72, 133, - 72, 0, 72, 134, 135, 136, 137, 75, 75, 0, - 75, 0, 75, 140, 141, 142, 143, 0, 144, 145, - 0, 0, 0, 146, 71, 71, 71, 71, 0, 0, - 0, 0, 72, 71, 0, 0, 0, 71, 71, 0, - 0, 0, 75, 0, 0, 0, 0, 71, 71, 71, - 71, 0, 71, 0, 71, 0, 0, 0, 0, 0, - 71, 71, 0, 0, 0, 0, 0, 117, 117, 117, - 117, 64, 0, 0, 64, 0, 117, 0, 0, 0, - 117, 117, 63, 0, 0, 63, 0, 0, 64, 64, - 117, 117, 117, 117, 0, 0, 0, 117, 0, 63, - 63, 0, 0, 117, 117, 91, 91, 91, 91, 0, - 0, 0, 0, 0, 91, 0, 0, 0, 91, 91, - 0, 60, 0, 64, 60, 0, 0, 0, 91, 91, - 91, 91, 0, 0, 63, 91, 0, 0, 60, 60, - 0, 91, 91, 0, 127, 127, 127, 127, 0, 0, - 0, 0, 0, 127, 0, 0, 0, 127, 127, 0, - 0, 0, 0, 0, 0, 0, 0, 127, 127, 127, - 127, 0, 0, 60, 127, 84, 0, 0, 84, 0, - 127, 127, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 84, 84, 0, 84, 0, 84, 0, 0, - 0, 0, 0, 0, 0, 72, 72, 72, 72, 0, - 0, 0, 0, 0, 72, 75, 75, 75, 75, 72, - 0, 0, 0, 0, 75, 0, 0, 84, 72, 72, - 72, 72, 0, 0, 0, 72, 0, 0, 75, 75, - 75, 72, 72, 85, 0, 75, 85, 0, 0, 0, - 0, 75, 75, 0, 0, 0, 0, 0, 0, 0, - 85, 85, 0, 85, 0, 85, 0, 0, 0, 0, - 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, 85, 64, 64, 64, 64, - 86, 86, 0, 86, 0, 86, 0, 63, 63, 63, - 63, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 64, 0, 0, 0, - 0, 0, 64, 64, 0, 86, 82, 63, 0, 82, - 0, 0, 0, 63, 63, 0, 60, 60, 60, 60, - 0, 0, 0, 82, 82, 0, 82, 0, 82, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 83, 60, 0, 83, 0, - 0, 0, 60, 60, 0, 0, 0, 0, 82, 0, - 0, 0, 83, 83, 0, 83, 0, 83, 0, 0, - 84, 84, 84, 84, 0, 0, 0, 0, 0, 84, - 0, 0, 0, 84, 84, 84, 84, 266, 0, 0, - 138, 0, 139, 84, 84, 84, 84, 83, 84, 84, - 84, 0, 0, 84, 81, 0, 0, 81, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 81, 81, 0, 81, 0, 81, 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, 234, 81, 0, 235, 0, - 0, 85, 85, 85, 85, 0, 85, 85, 85, 0, - 0, 85, 0, 0, 0, 138, 0, 139, 86, 86, - 86, 86, 0, 0, 0, 0, 0, 86, 0, 0, - 0, 86, 86, 86, 86, 0, 0, 0, 0, 0, - 0, 86, 86, 86, 86, 0, 86, 86, 86, 0, - 0, 86, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 82, 82, 82, 82, 0, 0, 0, 0, 0, - 82, 0, 0, 0, 82, 82, 82, 82, 0, 0, - 0, 0, 0, 0, 82, 82, 82, 82, 0, 82, - 82, 82, 0, 0, 82, 0, 0, 0, 0, 0, - 83, 83, 83, 83, 0, 0, 0, 0, 0, 83, - 0, 0, 0, 83, 83, 83, 83, 0, 0, 0, - 0, 0, 0, 83, 83, 83, 83, 0, 83, 83, - 83, 0, 0, 83, 133, 0, 0, 0, 134, 135, - 136, 137, 0, 0, 0, 0, 0, 0, 140, 141, - 142, 143, 0, 144, 145, 0, 0, 0, 146, 81, - 81, 81, 81, 0, 98, 100, 0, 0, 81, 109, - 0, 0, 81, 81, 81, 81, 0, 0, 0, 0, - 0, 0, 81, 81, 81, 81, 0, 81, 81, 0, - 0, 0, 81, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 159, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 133, - 0, 0, 0, 134, 135, 136, 137, 0, 0, 0, - 0, 0, 0, 140, 141, 142, 143, 0, 144, 145, - 0, 0, 0, 146, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 199, - 200, 201, 202, 204, 206, 207, 208, 210, 212, 214, - 216, 218, 219, 221, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 199, 0, 0, 0, 0, 0, 199, 0, 199, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 264, 0, 265, 0, 0, 0, 267, 0, 268, 0, - 269, 0, 270, 0, 271, 0, 0, 272, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 283, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 301, -}; -short yycheck[] = { 5, - 59, 168, 123, 91, 44, 125, 12, 40, 91, 40, - 16, 40, 18, 40, 12, 36, 40, 257, 162, 91, - 164, 27, 28, 29, 30, 41, 36, 281, 282, 123, - 40, 37, 44, 170, 23, 123, 42, 59, 41, 44, - 123, 295, 40, 59, 63, 299, 40, 36, 44, 44, - 48, 123, 41, 93, 52, 281, 59, 41, 91, 36, - 44, 278, 40, 40, 53, 54, 55, 56, 57, 295, - 0, 288, 44, 299, 58, 59, 82, 61, 84, 63, - 86, 93, 88, 81, 257, 83, 79, 85, 93, 87, - 123, 89, 123, 230, 123, 93, 123, 93, 93, 123, - 295, 94, 123, 33, 299, 94, 36, 37, 38, 93, - 40, 248, 42, 43, 107, 45, 253, 41, 255, 286, - 126, 93, 289, 44, 41, 40, 0, 44, 41, 59, - 128, 129, 130, 131, 64, 59, 257, 44, 59, 41, - 284, 285, 262, 263, 264, 265, 59, 291, 41, 41, - 44, 44, 150, 151, 152, 153, 154, 59, 44, 33, - 327, 91, 36, 37, 38, 59, 40, 59, 42, 43, - 258, 45, 316, 59, 172, 272, 44, 44, 0, 44, - 178, 179, 40, 181, 177, 59, 281, 282, 40, 187, - 64, 59, 59, 123, 59, 125, 126, 59, 257, 294, - 295, 302, 303, 296, 299, 43, 44, 45, 46, 47, - 40, 33, 50, 51, 36, 37, 38, 91, 40, 40, - 42, 43, 296, 45, 222, 41, 224, 36, 302, 303, - 236, 44, 238, 123, 240, 241, 257, 59, 244, 232, - 261, 247, 64, 125, 262, 263, 264, 265, 246, 123, - 41, 125, 126, 44, 41, 91, 275, 44, 256, 41, - 279, 280, 281, 282, 262, 41, 270, 271, 44, 91, - 289, 290, 291, 292, 41, 294, 295, 44, 59, 41, - 299, 274, 266, 267, 268, 269, 292, 91, 281, 41, - 288, 275, 44, 125, 123, 279, 280, 281, 282, 299, - 40, 123, 40, 125, 126, 289, 290, 291, 292, 40, - 294, 295, 296, 41, 125, 299, 314, 323, 302, 303, - 125, 41, 328, 125, 59, 125, 256, 257, 258, 259, - 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, - 125, 41, 125, 273, 274, 41, 276, 277, 278, 266, - 267, 268, 269, 283, 284, 285, 286, 287, 288, 266, - 267, 268, 269, 293, 41, 41, 296, 59, 298, 41, - 300, 301, 59, 59, 41, 72, 314, 12, -1, -1, - 246, -1, 256, 257, 258, 259, 260, 261, 262, 263, - 264, 265, 266, 267, 268, 269, -1, -1, -1, 273, - 274, -1, 276, 277, 278, 41, -1, -1, 44, 283, - 284, 285, 286, 287, 288, 41, -1, -1, 44, 293, - -1, -1, 58, 59, 298, 61, 300, 301, -1, -1, - -1, -1, 58, 59, 256, 257, 258, 259, 260, 261, - 262, 263, 264, 265, 266, 267, 268, 269, 0, -1, - -1, 273, 274, -1, 276, 277, 278, 93, -1, -1, - -1, 283, 284, 285, 286, 287, 288, 93, -1, -1, - -1, 293, -1, -1, -1, -1, 298, -1, 300, 301, - -1, 33, -1, -1, 36, 37, 38, 23, 40, -1, - 42, 43, -1, 45, -1, 31, -1, -1, -1, -1, - 36, 37, -1, 39, -1, -1, -1, 59, 279, 280, - 281, 282, 64, -1, -1, -1, -1, 53, 54, 55, - 56, 57, -1, 294, 295, -1, 33, -1, 299, 36, - 37, 38, -1, 40, 41, 42, 43, 44, 45, 91, - -1, -1, -1, -1, -1, -1, -1, 279, 280, 281, - 282, 58, 59, -1, 61, -1, 63, 64, 290, 291, - 292, -1, 294, 295, -1, 101, -1, 299, -1, -1, - -1, 123, -1, 279, 126, 281, 282, -1, -1, -1, - -1, -1, -1, -1, 91, -1, 93, 33, 294, 295, - 36, 37, 38, 299, 40, 41, 42, 43, 44, 45, - -1, -1, -1, -1, -1, -1, -1, -1, 279, 280, - 281, 282, 58, 59, -1, 61, 123, 63, 64, 126, - 291, 292, -1, 294, 295, -1, -1, -1, 299, -1, - 266, 267, 268, 269, -1, -1, -1, -1, -1, -1, - 266, 267, 268, 269, -1, -1, -1, 93, -1, -1, - -1, -1, 33, -1, -1, 36, 37, 38, -1, 40, - 296, 42, 43, -1, 45, -1, 302, 303, -1, -1, - 296, 279, 280, 281, 282, -1, 302, 303, 59, -1, - 126, -1, -1, 64, 292, -1, 294, 295, -1, -1, - -1, 299, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 256, 257, 258, 259, 260, 261, - 91, -1, -1, -1, 266, 267, 268, 269, -1, -1, - -1, 273, 274, -1, 276, 277, 278, -1, -1, -1, - -1, 283, 284, 285, 286, 287, 288, -1, -1, -1, - -1, 293, 123, -1, -1, 126, 298, -1, 300, 301, - 257, 258, 259, 260, 261, -1, -1, -1, -1, 266, - 267, 268, 269, -1, -1, -1, -1, 274, 275, 276, - 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, - 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, - -1, 298, 299, 300, 301, 302, 303, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 257, 258, 259, 260, 261, -1, -1, -1, -1, - 266, 267, 268, 269, -1, -1, -1, -1, 274, 275, - 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, - 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, - 296, -1, 298, 299, 300, 301, 302, 303, 33, -1, - -1, 36, 37, 38, -1, 40, -1, 42, 43, -1, - 45, -1, -1, -1, -1, 256, 257, 258, 259, 260, - 261, -1, -1, -1, 59, 266, 267, 268, 269, 64, - -1, -1, 273, 274, -1, 276, 277, 278, -1, -1, - -1, -1, 283, 284, 285, 286, 287, 288, -1, -1, - -1, -1, 293, -1, -1, -1, 91, 298, 33, 300, - 301, 36, 37, 38, -1, 40, -1, 42, 43, -1, - 45, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, -1, 44, -1, 59, -1, -1, -1, 123, 64, - -1, 126, -1, -1, -1, -1, 58, 59, -1, 61, - -1, 63, -1, 33, -1, -1, 36, 37, 38, -1, - 40, 41, 42, 43, -1, 45, 91, 279, 280, 281, - 282, -1, -1, -1, -1, -1, -1, 289, 290, 291, - 292, 93, 294, 295, 64, -1, -1, 299, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 123, -1, - -1, 126, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 91, -1, -1, -1, -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, 123, -1, -1, 126, -1, -1, -1, - 64, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 256, 257, 258, 259, 260, 261, 91, -1, 93, - -1, 266, 267, 268, 269, -1, -1, -1, 273, 274, - -1, 276, 277, 278, -1, -1, -1, -1, 283, 284, - 285, 286, 287, 288, -1, -1, -1, -1, 293, 123, - -1, -1, 126, 298, -1, 300, 301, -1, -1, -1, - -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, - -1, -1, 257, 258, 259, 260, 261, -1, -1, 58, - 59, -1, 61, -1, 63, -1, -1, -1, -1, 274, - -1, 276, 277, 278, 266, 267, 268, 269, 283, 284, - 285, 286, 287, 288, -1, -1, -1, -1, 293, -1, - -1, -1, -1, 298, 93, 300, 301, 257, 258, 259, - 260, 261, -1, -1, 296, -1, -1, -1, -1, -1, - 302, 303, -1, -1, 274, -1, 276, 277, 278, -1, - -1, -1, -1, 283, 284, 285, 286, 287, 288, -1, - -1, -1, -1, 293, -1, -1, -1, -1, 298, 33, - 300, 301, 36, 37, 38, -1, 40, -1, 42, 43, - -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 257, 258, 259, 260, 261, -1, -1, - 64, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 274, -1, 276, 277, 278, -1, -1, -1, -1, 283, - 284, 285, 286, 287, 288, -1, -1, 91, -1, 293, - -1, -1, -1, -1, 298, 33, 300, 301, 36, 37, - 38, -1, 40, 41, 42, 43, -1, 45, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 123, - -1, -1, 126, -1, -1, -1, 64, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 33, -1, -1, 36, 37, 38, -1, 40, -1, 42, - 43, -1, 45, 91, -1, -1, -1, 266, 267, 268, - 269, -1, -1, -1, -1, -1, 275, -1, -1, -1, - -1, 64, -1, -1, -1, -1, -1, -1, -1, -1, - 289, 290, 291, 292, -1, 123, -1, 296, 126, -1, - -1, -1, -1, 302, 303, -1, -1, -1, 91, -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, 61, -1, - 123, 64, -1, 126, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 256, 257, 258, 259, 260, 261, 91, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 274, -1, 276, 277, 278, -1, -1, -1, -1, 283, - 284, 285, 286, 287, 288, -1, -1, -1, -1, 293, - 123, -1, -1, 126, 298, -1, 300, 301, -1, -1, - 41, -1, -1, 44, -1, -1, -1, -1, -1, 41, - -1, -1, 44, -1, -1, -1, -1, 58, 59, 257, - 258, 259, 260, 261, -1, -1, 58, 59, -1, 61, - -1, 63, -1, -1, -1, -1, 274, -1, 276, 277, - 278, -1, -1, -1, -1, 283, 284, 285, 286, 287, - 288, -1, 93, -1, -1, 293, -1, -1, -1, -1, - 298, 93, 300, 301, 257, 258, 259, 260, 261, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 274, -1, 276, 277, 278, -1, -1, -1, -1, - 283, 284, 285, 286, 287, 288, -1, -1, -1, -1, - 293, -1, -1, 296, -1, 298, 33, 300, 301, 36, - 37, 38, -1, 40, -1, 42, 43, -1, 45, -1, - -1, -1, -1, -1, 257, 258, 259, 260, 261, -1, - -1, -1, -1, -1, 61, -1, -1, 64, -1, -1, - -1, 274, -1, 276, 277, 278, -1, -1, -1, -1, - 283, 284, 285, 286, 287, 288, -1, -1, -1, -1, - 293, -1, -1, -1, 91, 298, 33, 300, 301, 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, 61, -1, 123, 64, -1, 126, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 33, -1, -1, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, 91, 266, 267, 268, 269, -1, - -1, -1, -1, -1, 266, 267, 268, 269, -1, 61, - -1, -1, 64, 275, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 296, 123, 289, 290, 126, - -1, 302, 303, -1, 296, -1, -1, -1, -1, 91, - 302, 303, -1, -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, 123, -1, -1, 126, 61, -1, -1, 64, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 257, 258, 259, 260, 261, 91, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 274, -1, 276, - 277, 278, -1, -1, -1, -1, 283, 284, 285, 286, - 287, 288, -1, -1, -1, -1, 293, 123, -1, -1, - 126, 298, -1, 300, 301, -1, -1, -1, -1, -1, - 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, - 257, 258, 259, 260, 261, -1, -1, 58, 59, -1, - 61, -1, 63, -1, -1, -1, -1, 274, -1, 276, - 277, 278, -1, -1, -1, -1, 283, 284, 285, 286, - 287, 288, -1, -1, -1, -1, 293, -1, -1, -1, - -1, 298, 93, 300, 301, 257, 258, 259, 260, 261, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - -1, -1, 274, -1, 276, 277, 278, -1, 58, 59, - -1, 283, 284, 285, 286, 287, 288, -1, -1, -1, - -1, 293, -1, -1, -1, -1, 298, -1, 300, 301, - 33, -1, -1, 36, 37, 38, -1, 40, -1, 42, - 43, -1, 45, 93, -1, -1, -1, -1, -1, -1, - -1, 257, 258, 259, 260, 261, -1, -1, 61, -1, - -1, 64, -1, -1, -1, -1, -1, -1, 274, -1, - 276, 277, 278, -1, -1, -1, -1, 283, 284, 285, - 286, 287, 288, -1, -1, -1, -1, 293, 91, -1, - -1, -1, 298, 33, 300, 301, 36, 37, 38, -1, - 40, -1, 42, 43, -1, 45, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 123, 61, -1, 126, 64, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, - -1, 36, 37, 38, -1, 40, -1, 42, 43, -1, - 45, 91, -1, -1, -1, 266, 267, 268, 269, -1, - -1, -1, -1, -1, 275, -1, 61, -1, -1, 64, - -1, -1, -1, -1, -1, -1, -1, -1, 289, 290, - 291, 292, -1, 123, -1, 296, 126, -1, -1, -1, - -1, 302, 303, -1, -1, -1, 91, -1, -1, -1, - -1, 33, -1, -1, 36, 37, 38, -1, 40, 41, - 42, 43, -1, 45, -1, -1, 266, 267, 268, 269, - -1, -1, -1, -1, -1, -1, -1, -1, 123, -1, - -1, 126, 64, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 296, -1, -1, -1, - -1, -1, 302, 303, 257, 258, 259, 260, 261, 91, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 274, -1, 276, 277, 278, -1, -1, -1, -1, - 283, 284, 285, 286, 287, 288, -1, -1, -1, -1, - 293, 123, -1, -1, 126, 298, -1, 300, 301, -1, - -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, - 44, -1, -1, -1, -1, -1, -1, 257, 258, 259, - 260, 261, -1, -1, 58, 59, -1, 61, -1, 63, - -1, -1, -1, -1, 274, -1, 276, 277, 278, -1, - -1, -1, -1, 283, 284, 285, 286, 287, 288, -1, - -1, -1, -1, 293, -1, -1, -1, -1, 298, 93, - 300, 301, 257, 258, 259, 260, 261, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 274, - -1, 276, 277, 278, -1, -1, -1, -1, 283, 284, - 285, 286, 287, 288, -1, -1, -1, -1, 293, -1, - -1, -1, -1, 298, 33, 300, 301, 36, 37, 38, - -1, 40, 41, 42, 43, -1, 45, -1, -1, -1, - -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, - -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, - -1, -1, 274, -1, 276, 277, 278, -1, -1, -1, - -1, 283, 284, 285, 286, 287, 288, -1, -1, -1, - -1, 293, 91, -1, -1, -1, 298, 33, 300, 301, - 36, 37, 38, -1, 40, 41, 42, 43, -1, 45, - -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, - -1, 44, -1, -1, 123, -1, -1, 126, 64, -1, - -1, -1, -1, -1, -1, 58, 59, -1, -1, -1, - -1, -1, 33, -1, -1, 36, 37, 38, -1, 40, - -1, 42, 43, -1, 45, 91, -1, -1, -1, -1, - -1, -1, 266, 267, 268, 269, -1, -1, 59, -1, - 93, 275, -1, 64, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 289, -1, 123, -1, -1, - 126, -1, 296, -1, -1, -1, -1, -1, 302, 303, - 91, -1, -1, -1, -1, 33, -1, -1, 36, 37, - 38, -1, 40, 41, 42, 43, -1, 45, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 123, -1, -1, 126, 64, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, - 259, 260, 261, 91, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 274, -1, 276, 277, 278, - -1, -1, -1, -1, 283, 284, 285, 286, 287, 288, - -1, -1, -1, -1, 293, 123, -1, -1, 126, 298, - -1, 300, 301, -1, -1, -1, -1, -1, -1, -1, - -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, - -1, 257, 258, 259, 260, 261, -1, -1, 58, 59, - -1, -1, -1, -1, -1, -1, -1, -1, 274, -1, - 276, 277, 278, 266, 267, 268, 269, 283, 284, 285, - 286, 287, 288, -1, -1, -1, -1, 293, -1, -1, - -1, -1, 298, 93, 300, 301, 257, 258, 259, 260, - 261, -1, -1, 296, -1, -1, -1, -1, -1, 302, - 303, -1, -1, 274, -1, 276, 277, 278, -1, -1, - -1, -1, 283, 284, 285, 286, 287, 288, -1, -1, - -1, -1, 293, -1, -1, -1, -1, 298, 33, 300, - 301, 36, 37, 38, -1, 40, -1, 42, 43, -1, - 45, -1, -1, -1, -1, -1, -1, -1, -1, 257, - 258, 259, 260, 261, -1, -1, -1, -1, -1, 64, - -1, -1, -1, -1, -1, -1, 274, -1, 276, 277, - 278, -1, -1, -1, -1, 283, 284, 285, 286, 287, - 288, -1, -1, -1, -1, 293, 91, -1, 93, -1, - 298, 33, 300, 301, 36, 37, 38, -1, 40, -1, - 42, 43, -1, 45, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 123, -1, - -1, 126, 64, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 33, -1, -1, 36, - 37, 38, -1, 40, -1, 42, 43, -1, 45, 91, - -1, -1, -1, -1, -1, -1, 266, 267, 268, 269, - -1, -1, -1, -1, -1, -1, -1, 64, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 41, 123, -1, 44, 126, -1, 296, -1, -1, -1, - -1, -1, 302, 303, 91, -1, -1, 58, 59, -1, - 61, -1, 63, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, - -1, 44, -1, -1, -1, -1, 123, -1, -1, 126, - -1, -1, 93, -1, -1, 58, 59, -1, 61, -1, - 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 257, 258, 259, 260, 261, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 274, - 93, 276, 277, 278, -1, -1, -1, -1, 283, 284, - 285, 286, 287, 288, -1, -1, 41, -1, 293, 44, - -1, -1, -1, 298, -1, 300, 301, -1, -1, -1, - -1, -1, -1, 58, 59, -1, 61, -1, 63, -1, - -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 41, -1, 274, 44, 276, 277, 278, -1, 93, -1, - -1, 283, 284, 285, 286, 287, 288, 58, 59, -1, - 61, 293, 63, -1, -1, -1, 298, -1, 300, 301, - 257, 258, 259, 260, 261, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 41, -1, 274, 44, 276, - 277, 278, 93, -1, -1, -1, 283, 284, 285, 286, - 287, 288, 58, 59, -1, 61, 293, 63, -1, -1, - -1, 298, -1, 300, 301, 266, 267, 268, 269, -1, - -1, -1, -1, -1, 275, -1, -1, -1, 279, 280, - 281, 282, -1, -1, -1, -1, -1, 93, 289, 290, - 291, 292, -1, 294, 295, 296, -1, 41, 299, -1, - 44, 302, 303, 266, 267, 268, 269, 41, -1, -1, - 44, -1, 275, -1, 58, 59, 279, 280, 281, 282, - -1, -1, -1, -1, 58, 59, 289, 290, 291, 292, - -1, 294, 295, 296, -1, -1, 299, -1, 41, 302, - 303, 44, -1, -1, -1, -1, -1, -1, -1, 93, - -1, -1, -1, -1, -1, 58, 59, -1, 61, 93, - 63, -1, -1, -1, -1, -1, -1, -1, -1, 41, - -1, 266, 267, 268, 269, -1, -1, -1, -1, -1, - 275, -1, -1, -1, 279, 280, 281, 282, -1, 61, - 93, 63, -1, -1, 289, 290, 291, 292, -1, 294, - 295, 296, -1, 41, 299, -1, 44, 302, 303, -1, - -1, -1, -1, -1, -1, 266, 267, 268, 269, -1, - 58, 59, -1, 61, 275, 63, -1, -1, 279, 280, - 281, 282, -1, -1, -1, -1, -1, -1, 289, 290, - 291, 292, -1, 294, 295, 296, -1, -1, 299, -1, - 41, 302, 303, 44, -1, 93, -1, -1, -1, -1, - 266, 267, 268, 269, -1, -1, -1, 58, 59, 275, - 61, -1, 63, 279, 280, 281, 282, -1, -1, -1, - -1, -1, -1, 289, 290, 291, 292, -1, 294, 295, - 296, 41, -1, 299, 44, -1, 302, 303, -1, -1, - -1, -1, 93, -1, -1, -1, -1, -1, 58, 59, - -1, 61, -1, 63, -1, -1, -1, -1, -1, -1, - -1, -1, 266, 267, 268, 269, -1, -1, -1, 41, - -1, -1, 266, 267, 268, 269, -1, -1, -1, -1, - -1, -1, -1, 93, -1, -1, 58, 59, -1, 61, - -1, 63, 296, -1, -1, -1, -1, -1, 302, 303, - -1, -1, 296, 266, 267, 268, 269, -1, 302, 303, - -1, -1, 275, -1, -1, -1, 279, 280, 281, 282, - -1, 93, -1, -1, -1, -1, 289, 290, 291, 292, - -1, 294, 295, 296, 41, -1, 299, 44, -1, 302, - 303, -1, -1, 275, -1, -1, -1, 279, 280, 281, - 282, 58, 59, -1, 61, -1, 63, 289, 290, 291, - 292, -1, 294, 295, -1, -1, -1, 299, 266, 267, - 268, 269, -1, -1, -1, -1, -1, 275, -1, -1, - -1, 279, 280, 281, 282, -1, 93, -1, -1, -1, - -1, 289, 290, 291, 292, -1, 294, 295, 296, -1, - -1, 299, -1, 41, 302, 303, 44, -1, -1, -1, - -1, -1, -1, -1, -1, 266, 267, 268, 269, -1, - 58, 59, -1, 61, 275, 63, -1, -1, 279, 280, - 281, 282, -1, -1, -1, -1, -1, -1, 289, 290, - 291, 292, -1, 294, 295, 296, 41, -1, 299, 44, - -1, 302, 303, -1, -1, 93, 266, 267, 268, 269, - -1, -1, -1, 58, 59, 275, 61, -1, 63, 279, - 280, 281, 282, -1, -1, -1, -1, -1, -1, 289, - 290, 291, 292, -1, 294, 295, 296, 41, -1, 299, - 44, -1, 302, 303, 266, 267, 268, 269, 93, -1, - -1, -1, -1, 275, 58, 59, -1, 279, 280, 281, - 282, -1, -1, -1, -1, -1, -1, 289, 290, 291, - 292, -1, 294, 295, 296, 41, -1, 299, 44, -1, - 302, 303, -1, -1, -1, -1, -1, -1, -1, 93, - -1, -1, 58, 59, -1, 61, -1, 63, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 266, - 267, 268, 269, -1, -1, -1, -1, -1, 275, -1, - -1, -1, 279, 280, 281, 282, -1, 93, -1, -1, - -1, -1, 289, 290, 291, 292, 41, 294, 295, 44, - -1, -1, 299, -1, -1, 302, 303, -1, -1, -1, - -1, -1, -1, 58, 59, -1, 61, -1, 63, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 266, 267, - 268, 269, -1, -1, -1, -1, -1, 275, 93, -1, - -1, 279, 280, 281, 282, 61, -1, 63, -1, -1, - -1, 289, 290, 291, 292, -1, 294, 295, 296, 41, - -1, -1, 44, -1, 302, 303, -1, -1, -1, -1, - -1, 266, 267, 268, 269, -1, 58, 59, -1, 61, - 275, 63, -1, -1, 279, 280, 281, 282, -1, -1, - -1, -1, -1, -1, 289, 290, 291, 292, -1, 294, - 295, 296, 41, -1, -1, 44, -1, 302, 303, -1, - -1, 93, 266, 267, 268, 269, -1, -1, -1, 58, - 59, -1, 61, -1, 63, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 41, -1, 296, 44, -1, -1, -1, -1, 302, 303, - 266, 267, 268, 269, 93, -1, -1, 58, 59, 275, - 61, -1, 63, 279, 280, 281, 282, -1, -1, -1, - -1, -1, -1, 289, 290, 291, 292, -1, 294, 41, - 296, -1, 44, -1, -1, -1, 302, 303, -1, -1, - -1, -1, 93, -1, -1, -1, 58, 59, -1, 61, - -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 266, 267, 268, 269, -1, -1, -1, -1, -1, - 275, -1, -1, -1, 279, 280, -1, 282, -1, -1, - -1, 93, -1, -1, 289, 290, 291, 292, -1, 294, - 41, 296, -1, 44, -1, -1, -1, 302, 303, -1, - 41, -1, -1, 44, -1, -1, -1, 58, 59, 275, - 61, -1, 63, 279, 280, 281, 282, 58, 59, -1, - 61, -1, 63, 289, 290, 291, 292, -1, 294, 295, - -1, -1, -1, 299, 266, 267, 268, 269, -1, -1, - -1, -1, 93, 275, -1, -1, -1, 279, 280, -1, - -1, -1, 93, -1, -1, -1, -1, 289, 290, 291, - 292, -1, 294, -1, 296, -1, -1, -1, -1, -1, - 302, 303, -1, -1, -1, -1, -1, 266, 267, 268, - 269, 41, -1, -1, 44, -1, 275, -1, -1, -1, - 279, 280, 41, -1, -1, 44, -1, -1, 58, 59, - 289, 290, 291, 292, -1, -1, -1, 296, -1, 58, - 59, -1, -1, 302, 303, 266, 267, 268, 269, -1, - -1, -1, -1, -1, 275, -1, -1, -1, 279, 280, - -1, 41, -1, 93, 44, -1, -1, -1, 289, 290, - 291, 292, -1, -1, 93, 296, -1, -1, 58, 59, - -1, 302, 303, -1, 266, 267, 268, 269, -1, -1, - -1, -1, -1, 275, -1, -1, -1, 279, 280, -1, - -1, -1, -1, -1, -1, -1, -1, 289, 290, 291, - 292, -1, -1, 93, 296, 41, -1, -1, 44, -1, - 302, 303, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 58, 59, -1, 61, -1, 63, -1, -1, - -1, -1, -1, -1, -1, 266, 267, 268, 269, -1, - -1, -1, -1, -1, 275, 266, 267, 268, 269, 280, - -1, -1, -1, -1, 275, -1, -1, 93, 289, 290, - 291, 292, -1, -1, -1, 296, -1, -1, 289, 290, - 291, 302, 303, 41, -1, 296, 44, -1, -1, -1, - -1, 302, 303, -1, -1, -1, -1, -1, -1, -1, - 58, 59, -1, 61, -1, 63, -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, -1, -1, -1, -1, 93, 266, 267, 268, 269, - 58, 59, -1, 61, -1, 63, -1, 266, 267, 268, - 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 296, -1, -1, -1, - -1, -1, 302, 303, -1, 93, 41, 296, -1, 44, - -1, -1, -1, 302, 303, -1, 266, 267, 268, 269, - -1, -1, -1, 58, 59, -1, 61, -1, 63, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 41, 296, -1, 44, -1, - -1, -1, 302, 303, -1, -1, -1, -1, 93, -1, - -1, -1, 58, 59, -1, 61, -1, 63, -1, -1, - 266, 267, 268, 269, -1, -1, -1, -1, -1, 275, - -1, -1, -1, 279, 280, 281, 282, 58, -1, -1, - 61, -1, 63, 289, 290, 291, 292, 93, 294, 295, - 296, -1, -1, 299, 41, -1, -1, 44, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 58, 59, -1, 61, -1, 63, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 266, 267, - 268, 269, -1, -1, -1, -1, -1, 275, -1, -1, - -1, 279, 280, 281, 282, 41, 93, -1, 44, -1, - -1, 289, 290, 291, 292, -1, 294, 295, 296, -1, - -1, 299, -1, -1, -1, 61, -1, 63, 266, 267, - 268, 269, -1, -1, -1, -1, -1, 275, -1, -1, - -1, 279, 280, 281, 282, -1, -1, -1, -1, -1, - -1, 289, 290, 291, 292, -1, 294, 295, 296, -1, - -1, 299, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 266, 267, 268, 269, -1, -1, -1, -1, -1, - 275, -1, -1, -1, 279, 280, 281, 282, -1, -1, - -1, -1, -1, -1, 289, 290, 291, 292, -1, 294, - 295, 296, -1, -1, 299, -1, -1, -1, -1, -1, - 266, 267, 268, 269, -1, -1, -1, -1, -1, 275, - -1, -1, -1, 279, 280, 281, 282, -1, -1, -1, - -1, -1, -1, 289, 290, 291, 292, -1, 294, 295, - 296, -1, -1, 299, 275, -1, -1, -1, 279, 280, - 281, 282, -1, -1, -1, -1, -1, -1, 289, 290, - 291, 292, -1, 294, 295, -1, -1, -1, 299, 266, - 267, 268, 269, -1, 37, 38, -1, -1, 275, 42, - -1, -1, 279, 280, 281, 282, -1, -1, -1, -1, - -1, -1, 289, 290, 291, 292, -1, 294, 295, -1, - -1, -1, 299, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 80, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 275, - -1, -1, -1, 279, 280, 281, 282, -1, -1, -1, - -1, -1, -1, 289, 290, 291, 292, -1, 294, 295, - -1, -1, -1, 299, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 132, - 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, - 143, 144, 145, 146, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 183, -1, -1, -1, -1, -1, 189, -1, 191, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 203, -1, 205, -1, -1, -1, 209, -1, 211, -1, - 213, -1, 215, -1, 217, -1, -1, 220, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 235, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 266, -}; -#define YYFINAL 1 -#ifndef YYDEBUG -#define YYDEBUG 0 -#endif -#define YYMAXTOKEN 303 -#if YYDEBUG -char *yyname[] = { -"end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, -"'!'",0,0,"'$'","'%'","'&'",0,"'('","')'","'*'","'+'","','","'-'",0,0,0,0,0,0,0, -0,0,0,0,0,"':'","';'",0,"'='",0,"'?'","'@'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,"'['",0,"']'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,"'{'",0,"'}'","'~'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"WORD","METHOD","THING", -"PMFUNC","PRIVATEREF","LABEL","FORMAT","SUB","PACKAGE","WHILE","UNTIL","IF", -"UNLESS","ELSE","ELSIF","CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0","FUNC1", -"FUNC","RELOP","EQOP","MULOP","ADDOP","DOLSHARP","DO","LOCAL","DELETE", -"HASHBRACK","LSTOP","OROR","ANDAND","BITOROP","BITANDOP","UNIOP","SHIFTOP", -"MATCHOP","ARROW","UMINUS","REFGEN","POWOP","PREINC","PREDEC","POSTINC", -"POSTDEC", -}; -char *yyrule[] = { -"$accept : prog", -"$$1 :", -"prog : $$1 lineseq", -"block : '{' remember lineseq '}'", -"remember :", -"lineseq :", -"lineseq : lineseq decl", -"lineseq : lineseq line", -"line : label cond", -"line : loop", -"line : label ';'", -"line : label sideff ';'", -"sideff : error", -"sideff : expr", -"sideff : expr IF expr", -"sideff : expr UNLESS expr", -"sideff : expr WHILE expr", -"sideff : expr UNTIL expr", -"else :", -"else : ELSE block", -"else : ELSIF '(' expr ')' block else", -"cond : IF '(' expr ')' block else", -"cond : UNLESS '(' expr ')' block else", -"cond : IF block block else", -"cond : UNLESS block block else", -"cont :", -"cont : CONTINUE block", -"loop : label WHILE '(' texpr ')' block cont", -"loop : label UNTIL '(' expr ')' block cont", -"loop : label WHILE block block cont", -"loop : label UNTIL block block cont", -"loop : label FOR scalar '(' expr crp block cont", -"loop : label FOR '(' expr crp block cont", -"loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' block", -"loop : label block cont", -"nexpr :", -"nexpr : sideff", -"texpr :", -"texpr : expr", -"label :", -"label : LABEL", -"decl : format", -"decl : subrout", -"decl : package", -"format : FORMAT WORD block", -"format : FORMAT block", -"subrout : SUB WORD block", -"package : PACKAGE WORD ';'", -"package : PACKAGE ';'", -"expr : expr ',' sexpr", -"expr : sexpr", -"listop : LSTOP indirob listexpr", -"listop : FUNC '(' indirob listexpr ')'", -"listop : indirob ARROW LSTOP listexpr", -"listop : indirob ARROW FUNC '(' listexpr ')'", -"listop : term ARROW METHOD '(' listexpr ')'", -"listop : METHOD indirob listexpr", -"listop : LSTOP listexpr", -"listop : FUNC '(' listexpr ')'", -"sexpr : sexpr '=' sexpr", -"sexpr : sexpr POWOP '=' sexpr", -"sexpr : sexpr MULOP '=' sexpr", -"sexpr : sexpr ADDOP '=' sexpr", -"sexpr : sexpr SHIFTOP '=' sexpr", -"sexpr : sexpr BITANDOP '=' sexpr", -"sexpr : sexpr BITOROP '=' sexpr", -"sexpr : sexpr ANDAND '=' sexpr", -"sexpr : sexpr OROR '=' sexpr", -"sexpr : sexpr POWOP sexpr", -"sexpr : sexpr MULOP sexpr", -"sexpr : sexpr ADDOP sexpr", -"sexpr : sexpr SHIFTOP sexpr", -"sexpr : sexpr RELOP sexpr", -"sexpr : sexpr EQOP sexpr", -"sexpr : sexpr BITANDOP sexpr", -"sexpr : sexpr BITOROP sexpr", -"sexpr : sexpr DOTDOT sexpr", -"sexpr : sexpr ANDAND sexpr", -"sexpr : sexpr OROR sexpr", -"sexpr : sexpr '?' sexpr ':' sexpr", -"sexpr : sexpr MATCHOP sexpr", -"sexpr : term", -"term : '-' term", -"term : '+' term", -"term : '!' term", -"term : '~' term", -"term : REFGEN term", -"term : term POSTINC", -"term : term POSTDEC", -"term : PREINC term", -"term : PREDEC term", -"term : LOCAL sexpr", -"term : '(' expr crp", -"term : '(' ')'", -"term : '[' expr crb", -"term : '[' ']'", -"term : HASHBRACK expr crhb", -"term : HASHBRACK ';' '}'", -"term : scalar", -"term : star", -"term : scalar '[' expr ']'", -"term : term ARROW '[' expr ']'", -"term : hsh", -"term : ary", -"term : arylen", -"term : scalar '{' expr ';' '}'", -"term : term ARROW '{' expr ';' '}'", -"term : '(' expr crp '[' expr ']'", -"term : '(' ')' '[' expr ']'", -"term : ary '[' expr ']'", -"term : ary '{' expr ';' '}'", -"term : DELETE scalar '{' expr ';' '}'", -"term : DELETE '(' scalar '{' expr ';' '}' ')'", -"term : THING", -"term : amper", -"term : amper '(' ')'", -"term : amper '(' expr crp", -"term : DO sexpr", -"term : DO block", -"term : DO WORD '(' ')'", -"term : DO WORD '(' expr crp", -"term : DO scalar '(' ')'", -"term : DO scalar '(' expr crp", -"term : LOOPEX", -"term : LOOPEX WORD", -"term : UNIOP", -"term : UNIOP block", -"term : UNIOP sexpr", -"term : FUNC0", -"term : FUNC0 '(' ')'", -"term : FUNC1 '(' ')'", -"term : FUNC1 '(' expr ')'", -"term : PMFUNC '(' sexpr ')'", -"term : PMFUNC '(' sexpr ',' sexpr ')'", -"term : WORD", -"term : listop", -"listexpr :", -"listexpr : expr", -"amper : '&' indirob", -"scalar : '$' indirob", -"ary : '@' indirob", -"hsh : '%' indirob", -"arylen : DOLSHARP indirob", -"star : '*' indirob", -"indirob : WORD", -"indirob : scalar", -"indirob : block", -"indirob : PRIVATEREF", -"crp : ',' ')'", -"crp : ')'", -"crb : ',' ']'", -"crb : ']'", -"crhb : ',' ';' '}'", -"crhb : ';' '}'", -}; -#endif -#define yyclearin (yychar=(-1)) -#define yyerrok (yyerrflag=0) -#ifdef YYSTACKSIZE -#ifndef YYMAXDEPTH -#define YYMAXDEPTH YYSTACKSIZE -#endif -#else -#ifdef YYMAXDEPTH -#define YYSTACKSIZE YYMAXDEPTH -#else -#define YYSTACKSIZE 500 -#define YYMAXDEPTH 500 -#endif -#endif -int yydebug; -int yynerrs; -int yyerrflag; -int yychar; -short *yyssp; -YYSTYPE *yyvsp; -YYSTYPE yyval; -YYSTYPE yylval; -short yyss[YYSTACKSIZE]; -YYSTYPE yyvs[YYSTACKSIZE]; -#define yystacksize YYSTACKSIZE -#line 573 "perly.y" - /* PROGRAM */ -#line 1409 "y.tab.c" -#define YYABORT goto yyabort -#define YYACCEPT goto yyaccept -#define YYERROR goto yyerrlab -int -yyparse() -{ - register int yym, yyn, yystate; -#if YYDEBUG - register char *yys; - extern char *getenv(); - - if (yys = getenv("YYDEBUG")) - { - yyn = *yys; - if (yyn >= '0' && yyn <= '9') - yydebug = yyn - '0'; - } -#endif - - yynerrs = 0; - yyerrflag = 0; - yychar = (-1); - - yyssp = yyss; - yyvsp = yyvs; - *yyssp = yystate = 0; - -yyloop: - if (yyn = yydefred[yystate]) goto yyreduce; - if (yychar < 0) - { - if ((yychar = yylex()) < 0) yychar = 0; -#if YYDEBUG - if (yydebug) - { - yys = 0; - if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; - if (!yys) yys = "illegal-symbol"; - printf("yydebug: state %d, reading %d (%s)\n", yystate, - yychar, yys); - } -#endif - } - if ((yyn = yysindex[yystate]) && (yyn += yychar) >= 0 && - yyn <= YYTABLESIZE && yycheck[yyn] == yychar) - { -#if YYDEBUG - if (yydebug) - printf("yydebug: state %d, shifting to state %d\n", - yystate, yytable[yyn]); -#endif - if (yyssp >= yyss + yystacksize - 1) - { - goto yyoverflow; - } - *++yyssp = yystate = yytable[yyn]; - *++yyvsp = yylval; - yychar = (-1); - if (yyerrflag > 0) --yyerrflag; - goto yyloop; - } - if ((yyn = yyrindex[yystate]) && (yyn += yychar) >= 0 && - yyn <= YYTABLESIZE && yycheck[yyn] == yychar) - { - yyn = yytable[yyn]; - goto yyreduce; - } - if (yyerrflag) goto yyinrecovery; -#ifdef lint - goto yynewerror; -#endif -yynewerror: - yyerror("syntax error"); -#ifdef lint - goto yyerrlab; -#endif -yyerrlab: - ++yynerrs; -yyinrecovery: - if (yyerrflag < 3) - { - yyerrflag = 3; - for (;;) - { - if ((yyn = yysindex[*yyssp]) && (yyn += YYERRCODE) >= 0 && - yyn <= YYTABLESIZE && yycheck[yyn] == YYERRCODE) - { -#if YYDEBUG - if (yydebug) - printf("yydebug: state %d, error recovery shifting\ - to state %d\n", *yyssp, yytable[yyn]); -#endif - if (yyssp >= yyss + yystacksize - 1) - { - goto yyoverflow; - } - *++yyssp = yystate = yytable[yyn]; - *++yyvsp = yylval; - goto yyloop; - } - else - { -#if YYDEBUG - if (yydebug) - printf("yydebug: error recovery discarding state %d\n", - *yyssp); -#endif - if (yyssp <= yyss) goto yyabort; - --yyssp; - --yyvsp; - } - } - } - else - { - if (yychar == 0) goto yyabort; -#if YYDEBUG - if (yydebug) - { - yys = 0; - if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; - if (!yys) yys = "illegal-symbol"; - printf("yydebug: state %d, error recovery discards token %d (%s)\n", - yystate, yychar, yys); - } -#endif - yychar = (-1); - goto yyloop; - } -yyreduce: -#if YYDEBUG - if (yydebug) - printf("yydebug: state %d, reducing by rule %d (%s)\n", - yystate, yyn, yyrule[yyn]); -#endif - yym = yylen[yyn]; - yyval = yyvsp[1-yym]; - switch (yyn) - { -case 1: -#line 100 "perly.y" -{ -#if defined(YYDEBUG) && defined(DEBUGGING) - yydebug = (debug & 1); -#endif - expect = XBLOCK; - } -break; -case 2: -#line 107 "perly.y" -{ if (in_eval) { - eval_root = newUNOP(OP_LEAVEEVAL, 0, yyvsp[0].opval); - eval_start = linklist(eval_root); - eval_root->op_next = 0; - peep(eval_start); - } - else - main_root = block_head(yyvsp[0].opval, &main_start); - } -break; -case 3: -#line 119 "perly.y" -{ yyval.opval = scalarseq(yyvsp[-1].opval); - if (copline > (line_t)yyvsp[-3].ival) - copline = yyvsp[-3].ival; - leave_scope(yyvsp[-2].ival); - pad_leavemy(comppadnamefill); - expect = XBLOCK; } -break; -case 4: -#line 128 "perly.y" -{ yyval.ival = savestack_ix; SAVEINT(comppadnamefill); } -break; -case 5: -#line 132 "perly.y" -{ yyval.opval = Nullop; } -break; -case 6: -#line 134 "perly.y" -{ yyval.opval = yyvsp[-1].opval; } -break; -case 7: -#line 136 "perly.y" -{ yyval.opval = append_list(OP_LINESEQ, yyvsp[-1].opval, yyvsp[0].opval); pad_reset(); } -break; -case 8: -#line 140 "perly.y" -{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); } -break; -case 10: -#line 143 "perly.y" -{ if (yyvsp[-1].pval != Nullch) { - yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0)); - } - else { - yyval.opval = Nullop; - copline = NOLINE; - } - expect = XBLOCK; } -break; -case 11: -#line 152 "perly.y" -{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval); - expect = XBLOCK; } -break; -case 12: -#line 157 "perly.y" -{ yyval.opval = Nullop; } -break; -case 13: -#line 159 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 14: -#line 161 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); } -break; -case 15: -#line 163 "perly.y" -{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); } -break; -case 16: -#line 165 "perly.y" -{ yyval.opval = newLOOPOP(0, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); } -break; -case 17: -#line 167 "perly.y" -{ yyval.opval = newLOOPOP(0, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);} -break; -case 18: -#line 171 "perly.y" -{ yyval.opval = Nullop; } -break; -case 19: -#line 173 "perly.y" -{ yyval.opval = scope(yyvsp[0].opval); } -break; -case 20: -#line 175 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); } -break; -case 21: -#line 180 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); } -break; -case 22: -#line 183 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newCONDOP(0, - invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); } -break; -case 23: -#line 187 "perly.y" -{ copline = yyvsp[-3].ival; - yyval.opval = newCONDOP(0, scope(yyvsp[-2].opval), scope(yyvsp[-1].opval), yyvsp[0].opval); } -break; -case 24: -#line 190 "perly.y" -{ copline = yyvsp[-3].ival; - yyval.opval = newCONDOP(0, invert(scalar(scope(yyvsp[-2].opval))), - scope(yyvsp[-1].opval), yyvsp[0].opval); } -break; -case 25: -#line 196 "perly.y" -{ yyval.opval = Nullop; } -break; -case 26: -#line 198 "perly.y" -{ yyval.opval = scope(yyvsp[0].opval); } -break; -case 27: -#line 202 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newSTATEOP(0, yyvsp[-6].pval, - newWHILEOP(0, 1, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) ); } -break; -case 28: -#line 206 "perly.y" -{ copline = yyvsp[-5].ival; - yyval.opval = newSTATEOP(0, yyvsp[-6].pval, - newWHILEOP(0, 1, Nullop, - invert(scalar(yyvsp[-3].opval)), yyvsp[-1].opval, yyvsp[0].opval) ); } -break; -case 29: -#line 211 "perly.y" -{ copline = yyvsp[-3].ival; - yyval.opval = newSTATEOP(0, yyvsp[-4].pval, - newWHILEOP(0, 1, Nullop, - scope(yyvsp[-2].opval), yyvsp[-1].opval, yyvsp[0].opval) ); } -break; -case 30: -#line 216 "perly.y" -{ copline = yyvsp[-3].ival; - yyval.opval = newSTATEOP(0, yyvsp[-4].pval, - newWHILEOP(0, 1, Nullop, - invert(scalar(scope(yyvsp[-2].opval))), yyvsp[-1].opval, yyvsp[0].opval)); } -break; -case 31: -#line 221 "perly.y" -{ yyval.opval = newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, ref(yyvsp[-5].opval, OP_ENTERLOOP), - yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } -break; -case 32: -#line 224 "perly.y" -{ yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); } -break; -case 33: -#line 227 "perly.y" -{ copline = yyvsp[-8].ival; - yyval.opval = append_elem(OP_LINESEQ, - newSTATEOP(0, yyvsp[-9].pval, scalar(yyvsp[-6].opval)), - newSTATEOP(0, yyvsp[-9].pval, - newWHILEOP(0, 1, Nullop, - scalar(yyvsp[-4].opval), yyvsp[0].opval, scalar(yyvsp[-2].opval)) )); } -break; -case 34: -#line 234 "perly.y" -{ yyval.opval = newSTATEOP(0, - yyvsp[-2].pval, newWHILEOP(0, 1, Nullop, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); } -break; -case 35: -#line 239 "perly.y" -{ yyval.opval = Nullop; } -break; -case 37: -#line 244 "perly.y" -{ (void)scan_num("1"); yyval.opval = yylval.opval; } -break; -case 39: -#line 249 "perly.y" -{ yyval.pval = Nullch; } -break; -case 41: -#line 254 "perly.y" -{ yyval.ival = 0; } -break; -case 42: -#line 256 "perly.y" -{ yyval.ival = 0; } -break; -case 43: -#line 258 "perly.y" -{ yyval.ival = 0; } -break; -case 44: -#line 262 "perly.y" -{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } -break; -case 45: -#line 264 "perly.y" -{ newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); } -break; -case 46: -#line 268 "perly.y" -{ newSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } -break; -case 47: -#line 272 "perly.y" -{ package(yyvsp[-1].opval); } -break; -case 48: -#line 274 "perly.y" -{ package(Nullop); } -break; -case 49: -#line 278 "perly.y" -{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } -break; -case 51: -#line 283 "perly.y" -{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yyvsp[-1].opval), yyvsp[0].opval) ); } -break; -case 52: -#line 286 "perly.y" -{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yyvsp[-2].opval), yyvsp[-1].opval) ); } -break; -case 53: -#line 289 "perly.y" -{ yyval.opval = convert(yyvsp[-1].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yyvsp[-3].opval), yyvsp[0].opval) ); } -break; -case 54: -#line 292 "perly.y" -{ yyval.opval = convert(yyvsp[-3].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yyvsp[-5].opval), yyvsp[-1].opval) ); } -break; -case 55: -#line 295 "perly.y" -{ yyval.opval = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, newMETHOD(yyvsp[-5].opval,yyvsp[-3].opval), yyvsp[-1].opval)); } -break; -case 56: -#line 298 "perly.y" -{ yyval.opval = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, newMETHOD(yyvsp[-1].opval,yyvsp[-2].opval), yyvsp[0].opval)); } -break; -case 57: -#line 301 "perly.y" -{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } -break; -case 58: -#line 303 "perly.y" -{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } -break; -case 59: -#line 307 "perly.y" -{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[0].opval); } -break; -case 60: -#line 309 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - ref(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } -break; -case 61: -#line 312 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - ref(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } -break; -case 62: -#line 315 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - ref(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval));} -break; -case 63: -#line 318 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - ref(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } -break; -case 64: -#line 321 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - ref(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } -break; -case 65: -#line 324 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-2].ival, OPf_STACKED, - ref(scalar(yyvsp[-3].opval), yyvsp[-2].ival), scalar(yyvsp[0].opval)); } -break; -case 66: -#line 327 "perly.y" -{ yyval.opval = newLOGOP(OP_ANDASSIGN, 0, - ref(scalar(yyvsp[-3].opval), OP_ANDASSIGN), - newUNOP(OP_SASSIGN, 0, scalar(yyvsp[0].opval))); } -break; -case 67: -#line 331 "perly.y" -{ yyval.opval = newLOGOP(OP_ORASSIGN, 0, - ref(scalar(yyvsp[-3].opval), OP_ORASSIGN), - newUNOP(OP_SASSIGN, 0, scalar(yyvsp[0].opval))); } -break; -case 68: -#line 337 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } -break; -case 69: -#line 339 "perly.y" -{ if (yyvsp[-1].ival != OP_REPEAT) - scalar(yyvsp[-2].opval); - yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } -break; -case 70: -#line 343 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } -break; -case 71: -#line 345 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } -break; -case 72: -#line 347 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } -break; -case 73: -#line 349 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } -break; -case 74: -#line 351 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } -break; -case 75: -#line 353 "perly.y" -{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } -break; -case 76: -#line 355 "perly.y" -{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} -break; -case 77: -#line 357 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } -break; -case 78: -#line 359 "perly.y" -{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } -break; -case 79: -#line 361 "perly.y" -{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } -break; -case 80: -#line 363 "perly.y" -{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } -break; -case 81: -#line 365 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 82: -#line 369 "perly.y" -{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } -break; -case 83: -#line 371 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 84: -#line 373 "perly.y" -{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } -break; -case 85: -#line 375 "perly.y" -{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} -break; -case 86: -#line 377 "perly.y" -{ yyval.opval = newUNOP(OP_REFGEN, 0, ref(yyvsp[0].opval, OP_REFGEN)); } -break; -case 87: -#line 379 "perly.y" -{ yyval.opval = newUNOP(OP_POSTINC, 0, - ref(scalar(yyvsp[-1].opval), OP_POSTINC)); } -break; -case 88: -#line 382 "perly.y" -{ yyval.opval = newUNOP(OP_POSTDEC, 0, - ref(scalar(yyvsp[-1].opval), OP_POSTDEC)); } -break; -case 89: -#line 385 "perly.y" -{ yyval.opval = newUNOP(OP_PREINC, 0, - ref(scalar(yyvsp[0].opval), OP_PREINC)); } -break; -case 90: -#line 388 "perly.y" -{ yyval.opval = newUNOP(OP_PREDEC, 0, - ref(scalar(yyvsp[0].opval), OP_PREDEC)); } -break; -case 91: -#line 391 "perly.y" -{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } -break; -case 92: -#line 393 "perly.y" -{ yyval.opval = sawparens(yyvsp[-1].opval); } -break; -case 93: -#line 395 "perly.y" -{ yyval.opval = newNULLLIST(); } -break; -case 94: -#line 397 "perly.y" -{ yyval.opval = newANONLIST(yyvsp[-1].opval); } -break; -case 95: -#line 399 "perly.y" -{ yyval.opval = newANONLIST(Nullop); } -break; -case 96: -#line 401 "perly.y" -{ yyval.opval = newANONHASH(yyvsp[-1].opval); } -break; -case 97: -#line 403 "perly.y" -{ yyval.opval = newANONHASH(Nullop); } -break; -case 98: -#line 405 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 99: -#line 407 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 100: -#line 409 "perly.y" -{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } -break; -case 101: -#line 411 "perly.y" -{ yyval.opval = newBINOP(OP_AELEM, 0, - scalar(ref(newAVREF(yyvsp[-4].opval),OP_RV2AV)), - scalar(yyvsp[-1].opval));} -break; -case 102: -#line 415 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 103: -#line 417 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 104: -#line 419 "perly.y" -{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} -break; -case 105: -#line 421 "perly.y" -{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); - expect = XOPERATOR; } -break; -case 106: -#line 424 "perly.y" -{ yyval.opval = newBINOP(OP_HELEM, 0, - scalar(ref(newHVREF(yyvsp[-5].opval),OP_RV2HV)), - jmaybe(yyvsp[-2].opval)); - expect = XOPERATOR; } -break; -case 107: -#line 429 "perly.y" -{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } -break; -case 108: -#line 431 "perly.y" -{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } -break; -case 109: -#line 433 "perly.y" -{ yyval.opval = prepend_elem(OP_ASLICE, - newOP(OP_PUSHMARK, 0), - list( - newLISTOP(OP_ASLICE, 0, - list(yyvsp[-1].opval), - ref(yyvsp[-3].opval, OP_ASLICE)))); } -break; -case 110: -#line 440 "perly.y" -{ yyval.opval = prepend_elem(OP_HSLICE, - newOP(OP_PUSHMARK, 0), - list( - newLISTOP(OP_HSLICE, 0, - list(yyvsp[-2].opval), - ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)))); - expect = XOPERATOR; } -break; -case 111: -#line 448 "perly.y" -{ yyval.opval = newBINOP(OP_DELETE, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); - expect = XOPERATOR; } -break; -case 112: -#line 451 "perly.y" -{ yyval.opval = newBINOP(OP_DELETE, 0, oopsHV(yyvsp[-5].opval), jmaybe(yyvsp[-3].opval)); - expect = XOPERATOR; } -break; -case 113: -#line 454 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 114: -#line 456 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, 0, - scalar(yyvsp[0].opval)); } -break; -case 115: -#line 459 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_STACKED, scalar(yyvsp[-2].opval)); } -break; -case 116: -#line 461 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_STACKED, - list(prepend_elem(OP_LIST, scalar(yyvsp[-3].opval), yyvsp[-1].opval))); } -break; -case 117: -#line 464 "perly.y" -{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); - allgvs = TRUE;} -break; -case 118: -#line 467 "perly.y" -{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } -break; -case 119: -#line 469 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-2].opval))), newNULLLIST()))); } -break; -case 120: -#line 473 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-3].opval))), - yyvsp[-1].opval))); } -break; -case 121: -#line 478 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-2].opval))), newNULLLIST())));} -break; -case 122: -#line 482 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yyvsp[-3].opval))), - yyvsp[-1].opval))); } -break; -case 123: -#line 487 "perly.y" -{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); } -break; -case 124: -#line 489 "perly.y" -{ yyval.opval = newPVOP(yyvsp[-1].ival, 0, - savestr(SvPVnx(((SVOP*)yyvsp[0].opval)->op_sv))); - op_free(yyvsp[0].opval); } -break; -case 125: -#line 493 "perly.y" -{ yyval.opval = newOP(yyvsp[0].ival, 0); } -break; -case 126: -#line 495 "perly.y" -{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } -break; -case 127: -#line 497 "perly.y" -{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } -break; -case 128: -#line 499 "perly.y" -{ yyval.opval = newOP(yyvsp[0].ival, 0); } -break; -case 129: -#line 501 "perly.y" -{ yyval.opval = newOP(yyvsp[-2].ival, 0); } -break; -case 130: -#line 503 "perly.y" -{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } -break; -case 131: -#line 505 "perly.y" -{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } -break; -case 132: -#line 507 "perly.y" -{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } -break; -case 133: -#line 509 "perly.y" -{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } -break; -case 136: -#line 515 "perly.y" -{ yyval.opval = newNULLLIST(); } -break; -case 137: -#line 517 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 138: -#line 521 "perly.y" -{ yyval.opval = newCVREF(yyvsp[0].opval); } -break; -case 139: -#line 525 "perly.y" -{ yyval.opval = newSVREF(yyvsp[0].opval); } -break; -case 140: -#line 529 "perly.y" -{ yyval.opval = newAVREF(yyvsp[0].opval); } -break; -case 141: -#line 533 "perly.y" -{ yyval.opval = newHVREF(yyvsp[0].opval); } -break; -case 142: -#line 537 "perly.y" -{ yyval.opval = newAVREF(yyvsp[0].opval); } -break; -case 143: -#line 541 "perly.y" -{ yyval.opval = newGVREF(yyvsp[0].opval); } -break; -case 144: -#line 545 "perly.y" -{ yyval.opval = scalar(yyvsp[0].opval); } -break; -case 145: -#line 547 "perly.y" -{ yyval.opval = scalar(yyvsp[0].opval); } -break; -case 146: -#line 549 "perly.y" -{ yyval.opval = scalar(scope(yyvsp[0].opval)); } -break; -case 147: -#line 552 "perly.y" -{ yyval.opval = yyvsp[0].opval; } -break; -case 148: -#line 556 "perly.y" -{ yyval.ival = 1; } -break; -case 149: -#line 558 "perly.y" -{ yyval.ival = 0; } -break; -case 150: -#line 562 "perly.y" -{ yyval.ival = 1; } -break; -case 151: -#line 564 "perly.y" -{ yyval.ival = 0; } -break; -case 152: -#line 568 "perly.y" -{ yyval.ival = 1; } -break; -case 153: -#line 570 "perly.y" -{ yyval.ival = 0; } -break; -#line 2240 "y.tab.c" - } - yyssp -= yym; - yystate = *yyssp; - yyvsp -= yym; - yym = yylhs[yyn]; - if (yystate == 0 && yym == 0) - { -#if YYDEBUG - if (yydebug) - printf("yydebug: after reduction, shifting from state 0 to\ - state %d\n", YYFINAL); -#endif - yystate = YYFINAL; - *++yyssp = YYFINAL; - *++yyvsp = yyval; - if (yychar < 0) - { - if ((yychar = yylex()) < 0) yychar = 0; -#if YYDEBUG - if (yydebug) - { - yys = 0; - if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; - if (!yys) yys = "illegal-symbol"; - printf("yydebug: state %d, reading %d (%s)\n", - YYFINAL, yychar, yys); - } -#endif - } - if (yychar == 0) goto yyaccept; - goto yyloop; - } - if ((yyn = yygindex[yym]) && (yyn += yystate) >= 0 && - yyn <= YYTABLESIZE && yycheck[yyn] == yystate) - yystate = yytable[yyn]; - else - yystate = yydgoto[yym]; -#if YYDEBUG - if (yydebug) - printf("yydebug: after reduction, shifting from state %d \ -to state %d\n", *yyssp, yystate); -#endif - if (yyssp >= yyss + yystacksize - 1) - { - goto yyoverflow; - } - *++yyssp = yystate; - *++yyvsp = yyval; - goto yyloop; -yyoverflow: - yyerror("yacc stack overflow"); -yyabort: - return (1); -yyaccept: - return (0); -} diff --git a/perly.c.diff b/perly.c.diff index c8d6f10b50..a6e9389306 100644 --- a/perly.c.diff +++ b/perly.c.diff @@ -1,7 +1,78 @@ -*** perly.c.orig Mon Feb 14 14:24:43 1994 ---- perly.c Mon Feb 14 14:24:44 1994 +*** perly.c.orig Thu Sep 15 11:18:35 1994 +--- perly.c Thu Sep 15 11:19:31 1994 *************** -*** 1591,1603 **** +*** 12,79 **** + deprecate("\"do\" to call subroutines"); + } + +- #line 30 "perly.y" +- typedef union { +- I32 ival; +- char *pval; +- OP *opval; +- GV *gvval; +- } YYSTYPE; +- #line 23 "y.tab.c" +- #define WORD 257 +- #define METHOD 258 +- #define FUNCMETH 259 +- #define THING 260 +- #define PMFUNC 261 +- #define PRIVATEREF 262 +- #define LABEL 263 +- #define FORMAT 264 +- #define SUB 265 +- #define ANONSUB 266 +- #define PACKAGE 267 +- #define USE 268 +- #define WHILE 269 +- #define UNTIL 270 +- #define IF 271 +- #define UNLESS 272 +- #define ELSE 273 +- #define ELSIF 274 +- #define CONTINUE 275 +- #define FOR 276 +- #define LOOPEX 277 +- #define DOTDOT 278 +- #define FUNC0 279 +- #define FUNC1 280 +- #define FUNC 281 +- #define RELOP 282 +- #define EQOP 283 +- #define MULOP 284 +- #define ADDOP 285 +- #define DOLSHARP 286 +- #define DO 287 +- #define LOCAL 288 +- #define HASHBRACK 289 +- #define NOAMP 290 +- #define OROP 291 +- #define ANDOP 292 +- #define NOTOP 293 +- #define LSTOP 294 +- #define ASSIGNOP 295 +- #define OROR 296 +- #define ANDAND 297 +- #define BITOROP 298 +- #define BITANDOP 299 +- #define UNIOP 300 +- #define SHIFTOP 301 +- #define MATCHOP 302 +- #define UMINUS 303 +- #define REFGEN 304 +- #define POWOP 305 +- #define PREINC 306 +- #define PREDEC 307 +- #define POSTINC 308 +- #define POSTDEC 309 +- #define ARROW 310 + #define YYERRCODE 256 + short yylhs[] = { -1, + 30, 0, 5, 3, 6, 6, 6, 7, 7, 7, +--- 12,17 ---- +*************** +*** 1334,1346 **** int yynerrs; int yyerrflag; int yychar; @@ -12,13 +83,45 @@ - short yyss[YYSTACKSIZE]; - YYSTYPE yyvs[YYSTACKSIZE]; - #define yystacksize YYSTACKSIZE - #line 611 "perly.y" + #line 544 "perly.y" /* PROGRAM */ - #line 1604 "y.tab.c" ---- 1591,1598 ---- + #line 1347 "y.tab.c" +--- 1272,1279 ---- *************** -*** 1608,1613 **** ---- 1603,1621 ---- +*** 1347,1360 **** +--- 1280,1338 ---- + #define YYABORT goto yyabort + #define YYACCEPT goto yyaccept + #define YYERROR goto yyerrlab ++ ++ struct ysv { ++ short* yyss; ++ YYSTYPE* yyvs; ++ int oldyydebug; ++ int oldyynerrs; ++ int oldyyerrflag; ++ int oldyychar; ++ YYSTYPE oldyyval; ++ YYSTYPE oldyylval; ++ }; ++ ++ void ++ yydestruct(ptr) ++ void* ptr; ++ { ++ struct ysv* ysave = (struct ysv*)ptr; ++ if (ysave->yyss) Safefree(ysave->yyss); ++ if (ysave->yyvs) Safefree(ysave->yyvs); ++ yydebug = ysave->oldyydebug; ++ yynerrs = ysave->oldyynerrs; ++ yyerrflag = ysave->oldyyerrflag; ++ yychar = ysave->oldyychar; ++ yyval = ysave->oldyyval; ++ yylval = ysave->oldyylval; ++ Safefree(ysave); ++ } ++ + int yyparse() { register int yym, yyn, yystate; @@ -27,28 +130,36 @@ + short* yyss; + YYSTYPE* yyvs; + unsigned yystacksize = YYSTACKSIZE; -+ int oldyydebug = yydebug; -+ int oldyynerrs = yynerrs; -+ int oldyyerrflag = yyerrflag; -+ int oldyychar = yychar; -+ YYSTYPE oldyyval = yyval; -+ YYSTYPE oldyylval = yylval; + int retval = 0; -+ #if YYDEBUG register char *yys; extern char *getenv(); ++ #endif + ++ struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); ++ SAVEDESTRUCTOR(yydestruct, ysave); ++ ysave->oldyydebug = yydebug; ++ ysave->oldyynerrs = yynerrs; ++ ysave->oldyyerrflag = yyerrflag; ++ ysave->oldyychar = yychar; ++ ysave->oldyyval = yyval; ++ ysave->oldyylval = yylval; ++ ++ #if YYDEBUG + if (yys = getenv("YYDEBUG")) + { + yyn = *yys; *************** -*** 1624,1629 **** ---- 1632,1645 ---- +*** 1367,1372 **** +--- 1345,1358 ---- yyerrflag = 0; yychar = (-1); + /* + ** Initialize private stacks (yyparse may be called from an action) + */ -+ yyss = (short*)malloc(yystacksize*sizeof(short)); -+ yyvs = (YYSTYPE*)malloc(yystacksize*sizeof(YYSTYPE)); ++ ysave->yyss = yyss = (short*)safemalloc(yystacksize*sizeof(short)); ++ ysave->yyvs = yyvs = (YYSTYPE*)safemalloc(yystacksize*sizeof(YYSTYPE)); + if (!yyvs || !yyss) + goto yyoverflow; + @@ -56,7 +167,7 @@ yyvsp = yyvs; *yyssp = yystate = 0; *************** -*** 1639,1645 **** +*** 1382,1388 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -64,7 +175,7 @@ yychar, yys); } #endif ---- 1655,1661 ---- +--- 1368,1374 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -73,7 +184,7 @@ } #endif *************** -*** 1649,1660 **** +*** 1392,1403 **** { #if YYDEBUG if (yydebug) @@ -86,7 +197,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1665,1688 ---- +--- 1378,1403 ---- { #if YYDEBUG if (yydebug) @@ -102,8 +213,10 @@ ! int yyps_index = (yyssp - yyss); ! int yypv_index = (yyvsp - yyvs); ! yystacksize += YYSTACKSIZE; -! yyvs = (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); -! yyss = (short*)realloc((char*)yyss,yystacksize * sizeof(short)); +! ysave->yyvs = yyvs = +! (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); +! ysave->yyss = yyss = +! (short*)realloc((char*)yyss,yystacksize * sizeof(short)); ! if (!yyvs || !yyss) ! goto yyoverflow; ! yyssp = yyss + yyps_index; @@ -112,7 +225,7 @@ *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; *************** -*** 1690,1701 **** +*** 1433,1444 **** { #if YYDEBUG if (yydebug) @@ -125,7 +238,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1718,1744 ---- +--- 1433,1459 ---- { #if YYDEBUG if (yydebug) @@ -142,9 +255,9 @@ ! int yyps_index = (yyssp - yyss); ! int yypv_index = (yyvsp - yyvs); ! yystacksize += YYSTACKSIZE; -! yyvs = (YYSTYPE*)realloc((char*)yyvs, +! ysave->yyvs = yyvs = (YYSTYPE*)realloc((char*)yyvs, ! yystacksize * sizeof(YYSTYPE)); -! yyss = (short*)realloc((char*)yyss, +! ysave->yyss = yyss = (short*)realloc((char*)yyss, ! yystacksize * sizeof(short)); ! if (!yyvs || !yyss) ! goto yyoverflow; @@ -154,7 +267,7 @@ *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; *************** -*** 1705,1712 **** +*** 1448,1455 **** { #if YYDEBUG if (yydebug) @@ -163,7 +276,7 @@ #endif if (yyssp <= yyss) goto yyabort; --yyssp; ---- 1748,1756 ---- +--- 1463,1471 ---- { #if YYDEBUG if (yydebug) @@ -174,7 +287,7 @@ if (yyssp <= yyss) goto yyabort; --yyssp; *************** -*** 1723,1730 **** +*** 1466,1473 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -183,7 +296,7 @@ } #endif yychar = (-1); ---- 1767,1775 ---- +--- 1482,1490 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -194,7 +307,7 @@ #endif yychar = (-1); *************** -*** 1733,1739 **** +*** 1476,1482 **** yyreduce: #if YYDEBUG if (yydebug) @@ -202,7 +315,7 @@ yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; ---- 1778,1784 ---- +--- 1493,1499 ---- yyreduce: #if YYDEBUG if (yydebug) @@ -211,7 +324,7 @@ #endif yym = yylen[yyn]; *************** -*** 2490,2497 **** +*** 2161,2168 **** { #if YYDEBUG if (yydebug) @@ -220,7 +333,7 @@ #endif yystate = YYFINAL; *++yyssp = YYFINAL; ---- 2535,2543 ---- +--- 2178,2186 ---- { #if YYDEBUG if (yydebug) @@ -231,7 +344,7 @@ yystate = YYFINAL; *++yyssp = YYFINAL; *************** -*** 2505,2511 **** +*** 2176,2182 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -239,7 +352,7 @@ YYFINAL, yychar, yys); } #endif ---- 2551,2557 ---- +--- 2194,2200 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -248,7 +361,7 @@ } #endif *************** -*** 2520,2539 **** +*** 2191,2210 **** yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) @@ -269,7 +382,7 @@ yyaccept: ! return (0); } ---- 2566,2606 ---- +--- 2209,2243 ---- yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) @@ -286,8 +399,10 @@ ! int yyps_index = (yyssp - yyss); ! int yypv_index = (yyvsp - yyvs); ! yystacksize += YYSTACKSIZE; -! yyvs = (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); -! yyss = (short*)realloc((char*)yyss,yystacksize * sizeof(short)); +! ysave->yyvs = yyvs = +! (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE)); +! ysave->yyss = yyss = +! (short*)realloc((char*)yyss,yystacksize * sizeof(short)); ! if (!yyvs || !yyss) ! goto yyoverflow; ! yyssp = yyss + yyps_index; @@ -301,13 +416,5 @@ yyabort: ! retval = 1; yyaccept: -! if (yyss) free(yyss); -! if (yyvs) free(yyvs); -! yydebug = oldyydebug; -! yynerrs = oldyynerrs; -! yyerrflag = oldyyerrflag; -! yychar = oldyychar; -! yyval = oldyyval; -! yylval = oldyylval; ! return retval; } diff --git a/perly.c.yacc b/perly.c.yacc deleted file mode 100644 index f1f410ac5f..0000000000 --- a/perly.c.yacc +++ /dev/null @@ -1,1767 +0,0 @@ -extern char *malloc(), *realloc(); - -# line 39 "perly.y" -#include "EXTERN.h" -#include "perl.h" - -/*SUPPRESS 530*/ -/*SUPPRESS 593*/ -/*SUPPRESS 595*/ - - -# line 50 "perly.y" -typedef union { - I32 ival; - char *pval; - OP *opval; - GV *gvval; -} YYSTYPE; -# define WORD 257 -# define METHOD 258 -# define THING 259 -# define PMFUNC 260 -# define PRIVATEREF 261 -# define LABEL 262 -# define FORMAT 263 -# define SUB 264 -# define PACKAGE 265 -# define WHILE 266 -# define UNTIL 267 -# define IF 268 -# define UNLESS 269 -# define ELSE 270 -# define ELSIF 271 -# define CONTINUE 272 -# define FOR 273 -# define LOOPEX 274 -# define DOTDOT 275 -# define FUNC0 276 -# define FUNC1 277 -# define FUNC 278 -# define RELOP 279 -# define EQOP 280 -# define MULOP 281 -# define ADDOP 282 -# define DOLSHARP 283 -# define DO 284 -# define LOCAL 285 -# define DELETE 286 -# define HASHBRACK 287 -# define LSTOP 288 -# define OROR 289 -# define ANDAND 290 -# define BITOROP 291 -# define BITANDOP 292 -# define UNIOP 293 -# define SHIFTOP 294 -# define MATCHOP 295 -# define ARROW 296 -# define UMINUS 297 -# define REFGEN 298 -# define POWOP 299 -# define PREINC 300 -# define PREDEC 301 -# define POSTINC 302 -# define POSTDEC 303 -#define yyclearin yychar = -1 -#define yyerrok yyerrflag = 0 -extern int yychar; -extern int yyerrflag; -#ifndef YYMAXDEPTH -#define YYMAXDEPTH 150 -#endif -YYSTYPE yylval, yyval; -# define YYERRCODE 256 - -# line 573 "perly.y" - /* PROGRAM */ -int yyexca[] ={ --1, 1, - 0, -1, - -2, 0, --1, 3, - 0, 2, - -2, 39, --1, 21, - 296, 146, - -2, 25, --1, 40, - 41, 98, - 266, 98, - 267, 98, - 268, 98, - 269, 98, - 275, 98, - 279, 98, - 280, 98, - 281, 98, - 282, 98, - 44, 98, - 61, 98, - 63, 98, - 58, 98, - 289, 98, - 290, 98, - 291, 98, - 292, 98, - 294, 98, - 295, 98, - 296, 98, - 299, 98, - 302, 98, - 303, 98, - 59, 98, - 93, 98, - -2, 145, --1, 54, - 41, 134, - 266, 134, - 267, 134, - 268, 134, - 269, 134, - 275, 134, - 279, 134, - 280, 134, - 281, 134, - 282, 134, - 44, 134, - 61, 134, - 63, 134, - 58, 134, - 289, 134, - 290, 134, - 291, 134, - 292, 134, - 294, 134, - 295, 134, - 296, 134, - 299, 134, - 302, 134, - 303, 134, - 59, 134, - 93, 134, - -2, 144, --1, 78, - 59, 35, - -2, 0, --1, 114, - 302, 0, - 303, 0, - -2, 89, --1, 115, - 302, 0, - 303, 0, - -2, 90, --1, 194, - 279, 0, - -2, 72, --1, 195, - 280, 0, - -2, 73, --1, 196, - 275, 0, - -2, 76, --1, 312, - 41, 35, - -2, 0, - }; -# define YYNPROD 154 -# define YYLAST 2319 -int yyact[]={ - - 109, 106, 107, 164, 92, 104, 231, 105, 150, 92, - 21, 241, 68, 106, 107, 152, 230, 80, 25, 74, - 76, 242, 243, 82, 84, 56, 26, 93, 94, 326, - 31, 319, 134, 56, 58, 61, 69, 37, 157, 57, - 30, 104, 29, 317, 300, 92, 117, 119, 121, 131, - 246, 135, 299, 93, 94, 93, 16, 298, 79, 125, - 264, 59, 14, 11, 12, 13, 95, 104, 154, 104, - 155, 92, 212, 92, 71, 159, 123, 161, 83, 81, - 75, 166, 158, 168, 160, 170, 26, 163, 38, 270, - 167, 126, 169, 200, 171, 172, 173, 174, 217, 260, - 73, 205, 222, 312, 239, 156, 31, 89, 124, 56, - 58, 61, 26, 37, 89, 57, 30, 3, 29, 89, - 26, 89, 89, 32, 72, 201, 89, 329, 100, 101, - 93, 94, 213, 214, 215, 216, 327, 59, 220, 100, - 101, 93, 94, 95, 104, 322, 89, 225, 92, 99, - 98, 97, 96, 123, 95, 104, 318, 316, 306, 92, - 67, 26, 26, 26, 38, 89, 280, 233, 297, 31, - 294, 237, 56, 58, 61, 267, 37, 290, 57, 30, - 320, 29, 245, 26, 223, 124, 89, 14, 11, 12, - 13, 100, 101, 93, 94, 265, 26, 282, 256, 32, - 59, 301, 98, 97, 96, 221, 95, 104, 176, 257, - 258, 92, 206, 100, 261, 93, 94, 89, 234, 162, - 236, 151, 100, 101, 93, 94, 269, 38, 95, 104, - 273, 275, 295, 92, 283, 96, 284, 95, 104, 286, - 139, 288, 92, 289, 204, 291, 141, 202, 158, 138, - 66, 137, 89, 24, 54, 65, 46, 53, 66, 26, - 199, 208, 32, 18, 19, 22, 23, 268, 129, 296, - 20, 49, 70, 51, 52, 63, 149, 89, 287, 302, - 60, 48, 36, 45, 39, 62, 310, 209, 325, 56, - 50, 89, 266, 203, 8, 33, 7, 34, 35, 314, - 313, 204, 211, 315, 202, 276, 244, 56, 89, 89, - 31, 128, 2, 56, 58, 61, 324, 37, 274, 57, - 30, 25, 29, 9, 240, 165, 328, 89, 330, 24, - 54, 65, 46, 53, 66, 17, 87, 88, 85, 86, - 331, 59, 308, 309, 56, 311, 55, 49, 78, 51, - 52, 63, 235, 47, 41, 89, 60, 48, 36, 45, - 39, 62, 44, 42, 43, 15, 50, 10, 38, 323, - 5, 33, 210, 34, 35, 31, 207, 90, 56, 58, - 61, 6, 37, 272, 57, 30, 4, 29, 1, 100, - 101, 93, 94, 54, 65, 46, 53, 66, 0, 0, - 26, 97, 96, 32, 95, 104, 59, 0, 0, 92, - 49, 0, 51, 52, 63, 0, 0, 0, 28, 60, - 48, 36, 45, 39, 62, 227, 0, 0, 229, 50, - 232, 0, 152, 38, 33, 31, 34, 35, 56, 58, - 61, 0, 37, 0, 57, 30, 0, 29, 108, 110, - 111, 112, 113, 114, 115, 0, 0, 238, 64, 0, - 0, 263, 0, 0, 0, 26, 59, 0, 32, 87, - 88, 85, 86, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 31, 38, 0, 56, 58, 61, 0, 37, - 0, 57, 30, 0, 29, 279, 0, 281, 0, 0, - 0, 0, 0, 0, 271, 140, 143, 144, 145, 146, - 147, 148, 0, 59, 153, 26, 0, 0, 32, 0, - 0, 285, 0, 293, 54, 65, 46, 53, 66, 0, - 0, 0, 0, 0, 0, 0, 277, 0, 0, 278, - 38, 49, 262, 51, 52, 63, 0, 0, 0, 307, - 60, 48, 36, 45, 39, 62, 91, 303, 103, 304, - 50, 0, 0, 0, 0, 33, 0, 34, 35, 0, - 0, 0, 26, 0, 0, 32, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 54, - 65, 46, 53, 66, 0, 0, 0, 0, 0, 0, - 228, 0, 0, 0, 0, 0, 49, 0, 51, 52, - 63, 0, 0, 0, 0, 60, 48, 36, 45, 39, - 62, 0, 0, 0, 0, 50, 0, 0, 0, 0, - 33, 31, 34, 35, 56, 58, 61, 40, 37, 259, - 57, 30, 0, 29, 0, 0, 0, 0, 0, 54, - 65, 46, 53, 66, 0, 0, 0, 0, 77, 0, - 0, 0, 59, 0, 0, 0, 49, 0, 51, 52, - 63, 0, 0, 0, 0, 60, 48, 36, 45, 39, - 62, 0, 0, 127, 0, 50, 133, 0, 0, 38, - 33, 0, 34, 35, 142, 142, 142, 142, 142, 142, - 0, 0, 0, 142, 0, 0, 54, 65, 46, 53, - 66, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 26, 0, 49, 32, 51, 52, 63, 0, 103, - 0, 0, 60, 48, 36, 45, 39, 62, 0, 0, - 0, 0, 50, 0, 0, 0, 0, 33, 31, 34, - 35, 56, 58, 61, 0, 37, 224, 57, 30, 0, - 29, 0, 0, 0, 0, 0, 218, 0, 0, 0, - 102, 0, 0, 0, 100, 101, 93, 94, 0, 59, - 0, 0, 0, 0, 99, 98, 97, 96, 0, 95, - 104, 0, 0, 0, 92, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 31, 0, 38, 56, 58, 61, - 0, 37, 219, 57, 30, 0, 29, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 59, 0, 0, 26, 0, - 0, 32, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 54, 65, 46, 53, 66, - 0, 31, 38, 0, 56, 58, 61, 0, 37, 0, - 57, 30, 49, 29, 51, 52, 63, 0, 0, 0, - 0, 60, 48, 36, 45, 39, 62, 0, 0, 192, - 0, 50, 59, 0, 26, 0, 33, 32, 34, 35, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, - 0, 31, 0, 0, 56, 58, 61, 0, 37, 0, - 57, 30, 0, 29, 0, 0, 0, 0, 0, 0, - 0, 102, 0, 0, 321, 100, 101, 93, 94, 190, - 0, 26, 59, 0, 32, 99, 98, 97, 96, 0, - 95, 104, 0, 0, 91, 92, 103, 0, 0, 0, - 0, 0, 54, 65, 46, 53, 66, 0, 0, 38, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 49, - 0, 51, 52, 63, 0, 0, 0, 0, 60, 48, - 36, 45, 39, 62, 0, 0, 0, 255, 50, 0, - 91, 26, 103, 33, 32, 34, 35, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 54, 65, - 46, 53, 66, 0, 31, 0, 0, 56, 58, 61, - 0, 37, 0, 57, 30, 49, 29, 51, 52, 63, - 0, 0, 0, 0, 60, 48, 36, 45, 39, 62, - 0, 0, 188, 0, 50, 59, 0, 0, 0, 33, - 0, 34, 35, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 54, 65, 46, 53, 66, - 0, 0, 38, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 49, 0, 51, 52, 63, 91, 0, 103, - 0, 60, 48, 36, 45, 39, 62, 0, 0, 0, - 0, 50, 0, 0, 26, 0, 33, 32, 34, 35, - 0, 0, 31, 0, 0, 56, 58, 61, 0, 37, - 0, 57, 30, 0, 29, 54, 65, 46, 53, 66, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 186, 0, 49, 59, 51, 52, 63, 0, 0, 0, - 0, 60, 48, 36, 45, 39, 62, 0, 102, 0, - 0, 50, 100, 101, 93, 94, 33, 0, 34, 35, - 38, 0, 99, 98, 97, 96, 0, 95, 104, 0, - 0, 0, 92, 0, 0, 31, 0, 0, 56, 58, - 61, 0, 37, 0, 57, 30, 0, 29, 0, 0, - 0, 0, 26, 0, 102, 32, 0, 0, 100, 101, - 93, 94, 0, 184, 0, 0, 59, 0, 99, 98, - 97, 96, 0, 95, 104, 0, 0, 0, 92, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 54, 65, - 46, 53, 66, 38, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 49, 0, 51, 52, 63, - 0, 0, 0, 0, 60, 48, 36, 45, 39, 62, - 0, 0, 0, 0, 50, 26, 0, 0, 32, 33, - 0, 34, 35, 31, 0, 0, 56, 58, 61, 0, - 37, 0, 57, 30, 0, 29, 0, 0, 0, 0, - 0, 102, 0, 0, 0, 100, 101, 93, 94, 0, - 0, 182, 0, 0, 59, 99, 98, 97, 96, 0, - 95, 104, 0, 0, 0, 92, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 54, 65, 46, 53, - 66, 38, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 49, 0, 51, 52, 63, 0, 0, - 0, 0, 60, 48, 36, 45, 39, 62, 0, 0, - 0, 0, 50, 26, 0, 0, 32, 33, 0, 34, - 35, 0, 0, 0, 0, 0, 31, 0, 0, 56, - 58, 61, 0, 37, 0, 57, 30, 0, 29, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 54, - 65, 46, 53, 66, 180, 0, 0, 59, 0, 0, - 0, 0, 0, 0, 0, 0, 49, 0, 51, 52, - 63, 0, 0, 0, 0, 60, 48, 36, 45, 39, - 62, 0, 0, 0, 38, 50, 0, 0, 0, 0, - 33, 0, 34, 35, 31, 0, 0, 56, 58, 61, - 0, 37, 0, 57, 30, 0, 29, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 26, 0, 0, 32, - 0, 0, 178, 0, 0, 59, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 54, 65, 46, - 53, 66, 38, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 49, 0, 51, 52, 63, 0, - 0, 0, 0, 60, 48, 36, 45, 39, 62, 0, - 0, 0, 0, 50, 26, 0, 0, 32, 33, 0, - 34, 35, 0, 0, 0, 0, 0, 31, 0, 0, - 56, 58, 61, 0, 37, 0, 57, 30, 0, 29, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 122, 0, 0, 0, 0, 59, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 54, 65, 46, 53, 66, 38, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 49, 0, 51, - 52, 63, 0, 0, 0, 0, 60, 48, 36, 45, - 39, 62, 0, 0, 0, 0, 50, 26, 0, 0, - 32, 33, 31, 34, 35, 56, 58, 61, 0, 37, - 0, 57, 30, 0, 29, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 54, 65, - 46, 53, 66, 59, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 49, 0, 51, 52, 63, - 0, 0, 0, 0, 60, 48, 36, 45, 39, 62, - 38, 0, 120, 0, 50, 0, 0, 0, 0, 33, - 0, 34, 35, 0, 0, 0, 0, 0, 31, 0, - 0, 56, 58, 61, 0, 37, 118, 57, 30, 0, - 29, 0, 26, 0, 0, 32, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 59, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 54, 65, 46, 53, 66, 38, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 49, 0, - 51, 52, 63, 0, 0, 0, 0, 60, 48, 36, - 45, 39, 62, 0, 0, 0, 0, 50, 26, 0, - 0, 32, 33, 31, 34, 35, 56, 58, 61, 0, - 37, 0, 57, 30, 0, 29, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 59, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 54, 65, 46, 53, - 66, 38, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 49, 0, 51, 52, 63, 0, 0, - 0, 0, 60, 48, 36, 45, 39, 62, 0, 0, - 0, 0, 50, 26, 0, 0, 32, 33, 31, 34, - 35, 56, 58, 61, 0, 37, 0, 57, 30, 0, - 29, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 59, - 0, 0, 54, 65, 46, 53, 66, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 49, - 0, 51, 52, 63, 0, 0, 38, 0, 60, 48, - 36, 45, 39, 62, 0, 0, 0, 0, 50, 0, - 0, 0, 0, 33, 0, 34, 35, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 26, 27, - 0, 32, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 116, 54, 65, 46, - 53, 66, 0, 0, 0, 0, 0, 0, 130, 0, - 136, 0, 0, 0, 49, 0, 51, 52, 63, 0, - 0, 0, 0, 60, 48, 36, 45, 39, 62, 0, - 0, 0, 0, 50, 0, 0, 0, 0, 33, 0, - 34, 35, 0, 0, 0, 0, 0, 0, 0, 175, - 0, 177, 179, 181, 183, 185, 187, 189, 191, 193, - 194, 195, 196, 197, 198, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 132, 65, 46, 53, 66, 0, 0, 226, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 49, - 0, 51, 52, 63, 0, 0, 0, 0, 60, 48, - 36, 45, 39, 62, 0, 0, 0, 0, 50, 0, - 0, 0, 0, 33, 0, 34, 35, 0, 247, 0, - 248, 0, 249, 0, 250, 0, 251, 0, 252, 0, - 253, 0, 254, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 175, 0, 0, 0, 175, 0, 0, 175, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 292, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 305 }; -int yypact[]={ - - -1000, -1000, -1000, -200, -1000, -1000, -1000, -1000, -1000, -3, - -1000, -97, -221, 15, -1000, -1000, -1000, 65, 60, 40, - 308, -255, 39, 38, -1000, 70, -1000, 1056, -289, 1820, - 1820, 1820, 1820, 1820, 1820, 1820, 1820, 1725, 1649, 1554, - -15, -1000, -1000, -32, -1000, 271, -1000, 228, 1915, -225, - 1820, 211, 209, 200, -1000, -1000, -11, -11, -11, -11, - -11, -11, 1820, 181, -281, -11, -1000, -37, -1000, -37, - 46, -1000, -1000, 1820, -37, 1820, -37, 179, 73, -1000, - -37, 1820, -37, 1820, -37, 1820, 1820, 1820, 1820, 1820, - -1000, 1820, 1451, 1383, 1280, 1182, 1109, 1011, 898, 838, - 1820, 1820, 1820, 1820, 1820, 2, -1000, -1000, -301, -1000, - -301, -301, -301, -301, -1000, -1000, -228, 260, 10, 168, - -1000, 243, -53, 1820, 1820, 1820, 1820, -25, 253, 781, - -228, -1000, 165, 62, -1000, -1000, -228, 143, 725, 1820, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, 136, -1000, - 78, 1820, -272, 1820, -1000, -1000, -1000, 126, 78, -255, - 311, -255, 1820, 203, 45, -1000, -1000, 283, -249, 265, - -249, 78, 78, 78, 78, 1056, -75, 1056, 1820, -295, - 1820, -290, 1820, -226, 1820, -254, 1820, -151, 1820, -57, - 1820, 110, 1820, -88, -228, -66, -140, 959, -295, 158, - 1820, 1820, 608, 8, -1000, 1820, 459, -1000, -1000, 402, - -1000, -65, -1000, 102, 233, 82, 208, 1820, -34, -1000, - 260, 342, 277, -1000, -1000, 264, 505, -1000, 136, 125, - 1820, 157, -1000, -37, -1000, -37, -1000, 260, -37, 1820, - -37, -1000, -37, 137, -37, -1000, -1000, 1056, 1056, 1056, - 1056, 1056, 1056, 1056, 1056, 1820, 1820, 77, 173, -1000, - 1820, 75, -1000, -68, -1000, -1000, -73, -1000, -81, 142, - 1820, -1000, -1000, 260, -1000, 260, -1000, -1000, 1820, 117, - -1000, -1000, 1820, -255, -255, -37, -255, 44, -249, -1000, - 1820, -249, 676, 116, -1000, -82, 63, -1000, -1000, -1000, - -1000, -94, 121, -1000, -1000, 913, -1000, 104, -1000, -1000, - -255, -1000, 73, -1000, 247, -1000, -1000, -1000, -1000, -1000, - -96, -1000, -1000, -1000, 95, -37, 86, -37, -249, -1000, - -1000, -1000 }; -int yypgo[]={ - - 0, 388, 386, 381, 377, 293, 376, 372, 0, 117, - 370, 367, 365, 3, 11, 8, 2039, 418, 647, 364, - 363, 362, 354, 353, 325, 276, 458, 38, 346, 323, - 58, 312, 296, 294 }; -int yyr1[]={ - - 0, 31, 1, 8, 4, 9, 9, 9, 10, 10, - 10, 10, 24, 24, 24, 24, 24, 24, 14, 14, - 14, 12, 12, 12, 12, 30, 30, 11, 11, 11, - 11, 11, 11, 11, 11, 13, 13, 27, 27, 29, - 29, 2, 2, 2, 3, 3, 32, 33, 33, 15, - 15, 28, 28, 28, 28, 28, 28, 28, 28, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 25, 25, 23, 18, - 19, 20, 21, 22, 26, 26, 26, 26, 5, 5, - 6, 6, 7, 7 }; -int yyr2[]={ - - 0, 1, 5, 9, 1, 1, 5, 5, 5, 2, - 5, 7, 3, 3, 7, 7, 7, 7, 1, 5, - 13, 13, 13, 9, 9, 1, 5, 15, 15, 11, - 11, 17, 15, 21, 7, 1, 2, 1, 2, 1, - 2, 3, 3, 3, 7, 5, 7, 7, 5, 7, - 2, 7, 11, 9, 13, 13, 7, 5, 9, 7, - 9, 9, 9, 9, 9, 9, 9, 9, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 11, - 7, 3, 5, 5, 5, 5, 5, 5, 5, 5, - 5, 5, 7, 5, 7, 5, 7, 7, 3, 3, - 9, 11, 3, 3, 3, 11, 13, 13, 11, 9, - 11, 13, 17, 3, 3, 7, 9, 5, 5, 9, - 11, 9, 11, 3, 5, 3, 5, 5, 3, 7, - 7, 9, 9, 13, 2, 2, 1, 3, 5, 5, - 5, 5, 5, 5, 3, 3, 3, 3, 5, 3, - 5, 3, 7, 5 }; -int yychk[]={ - - -1000, -1, -31, -9, -2, -10, -3, -32, -33, -29, - -11, 263, 264, 265, 262, -12, 59, -24, 266, 267, - 273, -8, 268, 269, 256, -15, 123, -16, -17, 45, - 43, 33, 126, 298, 300, 301, 285, 40, 91, 287, - -18, -22, -20, -19, -21, 286, 259, -23, 284, 274, - 293, 276, 277, 260, 257, -28, 36, 42, 37, 64, - 283, 38, 288, 278, -26, 258, 261, 257, -8, 257, - 257, 59, 59, 40, -8, 40, -8, -18, 40, -30, - 272, 40, -8, 40, -8, 268, 269, 266, 267, 44, - -4, 61, 299, 281, 282, 294, 292, 291, 290, 289, - 279, 280, 275, 63, 295, 296, 302, 303, -17, -8, - -17, -17, -17, -17, -17, -17, -16, -15, 41, -15, - 93, -15, 59, 91, 123, 91, 123, -18, 40, 40, - -16, -8, 257, -18, 257, -8, -16, 40, 40, 40, - -26, 257, -18, -26, -26, -26, -26, -26, -26, -25, - -15, 40, 296, -26, -8, -8, 59, -27, -15, -8, - -15, -8, 40, -15, -13, -24, -8, -15, -8, -15, - -8, -15, -15, -15, -15, -16, -9, -16, 61, -16, - 61, -16, 61, -16, 61, -16, 61, -16, 61, -16, - 61, -16, 61, -16, -16, -16, -16, -16, -16, 258, - 91, 123, 44, -5, 41, 91, 44, -6, 93, 44, - -7, 59, 125, -15, -15, -15, -15, 123, -18, 41, - -15, 40, 40, 41, 41, -15, -16, -25, -26, -25, - 288, 278, -25, 41, -30, 41, -30, -15, -5, 59, - 41, -14, 270, 271, 41, -14, 125, -16, -16, -16, - -16, -16, -16, -16, -16, 58, 40, -15, -15, 41, - 91, -15, 93, 59, 125, 93, 59, 93, 59, -15, - 123, -5, 41, -15, 41, -15, 41, 41, 44, -25, - 41, -25, 40, -8, -8, -5, -8, -27, -8, -8, - 40, -8, -16, -25, 93, 59, -15, 93, 125, 125, - 125, 59, -15, -5, -5, -16, 41, -25, -30, -30, - -8, -30, 59, -14, -15, -14, 41, 125, 93, 125, - 59, 41, 41, -30, -13, 41, 125, 41, -8, 41, - -8, -14 }; -int yydef[]={ - - 1, -2, 5, -2, 6, 7, 41, 42, 43, 0, - 9, 0, 0, 0, 40, 8, 10, 0, 0, 0, - 0, -2, 0, 0, 12, 13, 4, 50, 81, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - -2, 99, 102, 103, 104, 0, 113, 114, 0, 123, - 125, 128, 0, 0, -2, 135, 0, 0, 0, 0, - 0, 0, 136, 0, 0, 0, 147, 0, 45, 0, - 0, 48, 11, 37, 0, 0, 0, 0, -2, 34, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 87, 88, 82, 146, - 83, 84, 85, 86, -2, -2, 91, 0, 93, 0, - 95, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 117, 118, 134, 98, 124, 126, 127, 0, 0, 0, - 139, 144, 145, 143, 141, 140, 142, 138, 136, 57, - 137, 136, 0, 136, 44, 46, 47, 0, 38, 25, - 0, 25, 0, 13, 0, 36, 26, 0, 18, 0, - 18, 14, 15, 16, 17, 49, 39, 59, 0, 68, - 0, 69, 0, 70, 0, 71, 0, 74, 0, 75, - 0, 77, 0, 78, -2, -2, -2, 0, 80, 0, - 0, 0, 0, 92, 149, 0, 0, 94, 151, 0, - 96, 0, 97, 0, 0, 0, 0, 0, 0, 115, - 0, 0, 0, 129, 130, 0, 0, 51, 136, 0, - 136, 0, 56, 0, 29, 0, 30, 0, 0, 37, - 0, 23, 0, 0, 0, 24, 3, 60, 61, 62, - 63, 64, 65, 66, 67, 0, 136, 0, 0, 148, - 0, 0, 150, 0, 153, 100, 0, 109, 0, 0, - 0, 116, 119, 0, 121, 0, 131, 132, 0, 0, - 58, 53, 136, 25, 25, 0, 25, 0, 18, 19, - 0, 18, 79, 0, 101, 0, 0, 108, 152, 105, - 110, 0, 0, 120, 122, 0, 52, 0, 27, 28, - 25, 32, -2, 21, 0, 22, 55, 106, 107, 111, - 0, 133, 54, 31, 0, 0, 0, 0, 18, 112, - 33, 20 }; -typedef struct { char *t_name; int t_val; } yytoktype; -#ifndef YYDEBUG -# define YYDEBUG 0 /* don't allow debugging */ -#endif - -#if YYDEBUG - -yytoktype yytoks[] = -{ - "{", 123, - ")", 41, - "WORD", 257, - "METHOD", 258, - "THING", 259, - "PMFUNC", 260, - "PRIVATEREF", 261, - "LABEL", 262, - "FORMAT", 263, - "SUB", 264, - "PACKAGE", 265, - "WHILE", 266, - "UNTIL", 267, - "IF", 268, - "UNLESS", 269, - "ELSE", 270, - "ELSIF", 271, - "CONTINUE", 272, - "FOR", 273, - "LOOPEX", 274, - "DOTDOT", 275, - "FUNC0", 276, - "FUNC1", 277, - "FUNC", 278, - "RELOP", 279, - "EQOP", 280, - "MULOP", 281, - "ADDOP", 282, - "DOLSHARP", 283, - "DO", 284, - "LOCAL", 285, - "DELETE", 286, - "HASHBRACK", 287, - "LSTOP", 288, - ",", 44, - "=", 61, - "?", 63, - ":", 58, - "OROR", 289, - "ANDAND", 290, - "BITOROP", 291, - "BITANDOP", 292, - "UNIOP", 293, - "SHIFTOP", 294, - "MATCHOP", 295, - "ARROW", 296, - "!", 33, - "~", 126, - "UMINUS", 297, - "REFGEN", 298, - "POWOP", 299, - "PREINC", 300, - "PREDEC", 301, - "POSTINC", 302, - "POSTDEC", 303, - "(", 40, - "-unknown-", -1 /* ends search */ -}; - -char * yyreds[] = -{ - "-no such reduction-", - "prog : /* empty */", - "prog : lineseq", - "block : '{' remember lineseq '}'", - "remember : /* empty */", - "lineseq : /* empty */", - "lineseq : lineseq decl", - "lineseq : lineseq line", - "line : label cond", - "line : loop", - "line : label ';'", - "line : label sideff ';'", - "sideff : error", - "sideff : expr", - "sideff : expr IF expr", - "sideff : expr UNLESS expr", - "sideff : expr WHILE expr", - "sideff : expr UNTIL expr", - "else : /* empty */", - "else : ELSE block", - "else : ELSIF '(' expr ')' block else", - "cond : IF '(' expr ')' block else", - "cond : UNLESS '(' expr ')' block else", - "cond : IF block block else", - "cond : UNLESS block block else", - "cont : /* empty */", - "cont : CONTINUE block", - "loop : label WHILE '(' texpr ')' block cont", - "loop : label UNTIL '(' expr ')' block cont", - "loop : label WHILE block block cont", - "loop : label UNTIL block block cont", - "loop : label FOR scalar '(' expr crp block cont", - "loop : label FOR '(' expr crp block cont", - "loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' block", - "loop : label block cont", - "nexpr : /* empty */", - "nexpr : sideff", - "texpr : /* empty */", - "texpr : expr", - "label : /* empty */", - "label : LABEL", - "decl : format", - "decl : subrout", - "decl : package", - "format : FORMAT WORD block", - "format : FORMAT block", - "subrout : SUB WORD block", - "package : PACKAGE WORD ';'", - "package : PACKAGE ';'", - "expr : expr ',' sexpr", - "expr : sexpr", - "listop : LSTOP indirob listexpr", - "listop : FUNC '(' indirob listexpr ')'", - "listop : indirob ARROW LSTOP listexpr", - "listop : indirob ARROW FUNC '(' listexpr ')'", - "listop : term ARROW METHOD '(' listexpr ')'", - "listop : METHOD indirob listexpr", - "listop : LSTOP listexpr", - "listop : FUNC '(' listexpr ')'", - "sexpr : sexpr '=' sexpr", - "sexpr : sexpr POWOP '=' sexpr", - "sexpr : sexpr MULOP '=' sexpr", - "sexpr : sexpr ADDOP '=' sexpr", - "sexpr : sexpr SHIFTOP '=' sexpr", - "sexpr : sexpr BITANDOP '=' sexpr", - "sexpr : sexpr BITOROP '=' sexpr", - "sexpr : sexpr ANDAND '=' sexpr", - "sexpr : sexpr OROR '=' sexpr", - "sexpr : sexpr POWOP sexpr", - "sexpr : sexpr MULOP sexpr", - "sexpr : sexpr ADDOP sexpr", - "sexpr : sexpr SHIFTOP sexpr", - "sexpr : sexpr RELOP sexpr", - "sexpr : sexpr EQOP sexpr", - "sexpr : sexpr BITANDOP sexpr", - "sexpr : sexpr BITOROP sexpr", - "sexpr : sexpr DOTDOT sexpr", - "sexpr : sexpr ANDAND sexpr", - "sexpr : sexpr OROR sexpr", - "sexpr : sexpr '?' sexpr ':' sexpr", - "sexpr : sexpr MATCHOP sexpr", - "sexpr : term", - "term : '-' term", - "term : '+' term", - "term : '!' term", - "term : '~' term", - "term : REFGEN term", - "term : term POSTINC", - "term : term POSTDEC", - "term : PREINC term", - "term : PREDEC term", - "term : LOCAL sexpr", - "term : '(' expr crp", - "term : '(' ')'", - "term : '[' expr crb", - "term : '[' ']'", - "term : HASHBRACK expr crhb", - "term : HASHBRACK ';' '}'", - "term : scalar", - "term : star", - "term : scalar '[' expr ']'", - "term : term ARROW '[' expr ']'", - "term : hsh", - "term : ary", - "term : arylen", - "term : scalar '{' expr ';' '}'", - "term : term ARROW '{' expr ';' '}'", - "term : '(' expr crp '[' expr ']'", - "term : '(' ')' '[' expr ']'", - "term : ary '[' expr ']'", - "term : ary '{' expr ';' '}'", - "term : DELETE scalar '{' expr ';' '}'", - "term : DELETE '(' scalar '{' expr ';' '}' ')'", - "term : THING", - "term : amper", - "term : amper '(' ')'", - "term : amper '(' expr crp", - "term : DO sexpr", - "term : DO block", - "term : DO WORD '(' ')'", - "term : DO WORD '(' expr crp", - "term : DO scalar '(' ')'", - "term : DO scalar '(' expr crp", - "term : LOOPEX", - "term : LOOPEX WORD", - "term : UNIOP", - "term : UNIOP block", - "term : UNIOP sexpr", - "term : FUNC0", - "term : FUNC0 '(' ')'", - "term : FUNC1 '(' ')'", - "term : FUNC1 '(' expr ')'", - "term : PMFUNC '(' sexpr ')'", - "term : PMFUNC '(' sexpr ',' sexpr ')'", - "term : WORD", - "term : listop", - "listexpr : /* empty */", - "listexpr : expr", - "amper : '&' indirob", - "scalar : '$' indirob", - "ary : '@' indirob", - "hsh : '%' indirob", - "arylen : DOLSHARP indirob", - "star : '*' indirob", - "indirob : WORD", - "indirob : scalar", - "indirob : block", - "indirob : PRIVATEREF", - "crp : ',' ')'", - "crp : ')'", - "crb : ',' ']'", - "crb : ']'", - "crhb : ',' ';' '}'", - "crhb : ';' '}'", -}; -#endif /* YYDEBUG */ -#line 1 "/usr/lib/yaccpar" -/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */ - -/* -** Skeleton parser driver for yacc output -*/ - -/* -** yacc user known macros and defines -*/ -#define YYERROR goto yyerrlab -#define YYACCEPT { free(yys); free(yyv); return(0); } -#define YYABORT { free(yys); free(yyv); return(1); } -#define YYBACKUP( newtoken, newvalue )\ -{\ - if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\ - {\ - yyerror( "syntax error - cannot backup" );\ - goto yyerrlab;\ - }\ - yychar = newtoken;\ - yystate = *yyps;\ - yylval = newvalue;\ - goto yynewstate;\ -} -#define YYRECOVERING() (!!yyerrflag) -#ifndef YYDEBUG -# define YYDEBUG 1 /* make debugging available */ -#endif - -/* -** user known globals -*/ -int yydebug; /* set to 1 to get debugging */ - -/* -** driver internal defines -*/ -#define YYFLAG (-1000) - -/* -** static variables used by the parser -*/ -static YYSTYPE *yyv; /* value stack */ -static int *yys; /* state stack */ - -static YYSTYPE *yypv; /* top of value stack */ -static int *yyps; /* top of state stack */ - -static int yystate; /* current state */ -static int yytmp; /* extra var (lasts between blocks) */ - -int yynerrs; /* number of errors */ - -int yyerrflag; /* error recovery flag */ -int yychar; /* current input token number */ - - -/* -** yyparse - return 0 if worked, 1 if syntax error not recovered from -*/ -int -yyparse() -{ - register YYSTYPE *yypvt; /* top of value stack for $vars */ - unsigned yymaxdepth = YYMAXDEPTH; - - /* - ** Initialize externals - yyparse may be called more than once - */ - yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE)); - yys = (int*)malloc(yymaxdepth*sizeof(int)); - if (!yyv || !yys) - { - yyerror( "out of memory" ); - return(1); - } - yypv = &yyv[-1]; - yyps = &yys[-1]; - yystate = 0; - yytmp = 0; - yynerrs = 0; - yyerrflag = 0; - yychar = -1; - - goto yystack; - { - register YYSTYPE *yy_pv; /* top of value stack */ - register int *yy_ps; /* top of state stack */ - register int yy_state; /* current state */ - register int yy_n; /* internal state number info */ - - /* - ** get globals into registers. - ** branch to here only if YYBACKUP was called. - */ - yynewstate: - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - goto yy_newstate; - - /* - ** get globals into registers. - ** either we just started, or we just finished a reduction - */ - yystack: - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - - /* - ** top of for (;;) loop while no reductions done - */ - yy_stack: - /* - ** put a state and value onto the stacks - */ -#if YYDEBUG - /* - ** if debugging, look up token value in list of value vs. - ** name pairs. 0 and negative (-1) are special values. - ** Note: linear search is used since time is not a real - ** consideration while debugging. - */ - if ( yydebug ) - { - register int yy_i; - - (void)printf( "State %d, token ", yy_state ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif /* YYDEBUG */ - if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */ - { - /* - ** reallocate and recover. Note that pointers - ** have to be reset, or bad things will happen - */ - int yyps_index = (yy_ps - yys); - int yypv_index = (yy_pv - yyv); - int yypvt_index = (yypvt - yyv); - yymaxdepth += YYMAXDEPTH; - yyv = (YYSTYPE*)realloc((char*)yyv, - yymaxdepth * sizeof(YYSTYPE)); - yys = (int*)realloc((char*)yys, - yymaxdepth * sizeof(int)); - if (!yyv || !yys) - { - yyerror( "yacc stack overflow" ); - return(1); - } - yy_ps = yys + yyps_index; - yy_pv = yyv + yypv_index; - yypvt = yyv + yypvt_index; - } - *yy_ps = yy_state; - *++yy_pv = yyval; - - /* - ** we have a new state - find out what to do - */ - yy_newstate: - if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG ) - goto yydefault; /* simple state */ -#if YYDEBUG - /* - ** if debugging, need to mark whether new token grabbed - */ - yytmp = yychar < 0; -#endif - if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) - yychar = 0; /* reached EOF */ -#if YYDEBUG - if ( yydebug && yytmp ) - { - register int yy_i; - - (void)printf( " *** Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif /* YYDEBUG */ - if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) ) - goto yydefault; - if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/ - { - yychar = -1; - yyval = yylval; - yy_state = yy_n; - if ( yyerrflag > 0 ) - yyerrflag--; - goto yy_stack; - } - - yydefault: - if ( ( yy_n = yydef[ yy_state ] ) == -2 ) - { -#if YYDEBUG - yytmp = yychar < 0; -#endif - if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) - yychar = 0; /* reached EOF */ -#if YYDEBUG - if ( yydebug && yytmp ) - { - register int yy_i; - - (void)printf( " *** Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; - yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val - == yychar ) - { - break; - } - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif /* YYDEBUG */ - /* - ** look through exception table - */ - { - register int *yyxi = yyexca; - - while ( ( *yyxi != -1 ) || - ( yyxi[1] != yy_state ) ) - { - yyxi += 2; - } - while ( ( *(yyxi += 2) >= 0 ) && - ( *yyxi != yychar ) ) - ; - if ( ( yy_n = yyxi[1] ) < 0 ) - YYACCEPT; - } - } - - /* - ** check for syntax error - */ - if ( yy_n == 0 ) /* have an error */ - { - /* no worry about speed here! */ - switch ( yyerrflag ) - { - case 0: /* new error */ - yyerror( "syntax error" ); - goto skip_init; - yyerrlab: - /* - ** get globals into registers. - ** we have a user generated syntax type error - */ - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - yynerrs++; - skip_init: - case 1: - case 2: /* incompletely recovered error */ - /* try again... */ - yyerrflag = 3; - /* - ** find state where "error" is a legal - ** shift action - */ - while ( yy_ps >= yys ) - { - yy_n = yypact[ *yy_ps ] + YYERRCODE; - if ( yy_n >= 0 && yy_n < YYLAST && - yychk[yyact[yy_n]] == YYERRCODE) { - /* - ** simulate shift of "error" - */ - yy_state = yyact[ yy_n ]; - goto yy_stack; - } - /* - ** current state has no shift on - ** "error", pop stack - */ -#if YYDEBUG -# define _POP_ "Error recovery pops state %d, uncovers state %d\n" - if ( yydebug ) - (void)printf( _POP_, *yy_ps, - yy_ps[-1] ); -# undef _POP_ -#endif - yy_ps--; - yy_pv--; - } - /* - ** there is no state on stack with "error" as - ** a valid shift. give up. - */ - YYABORT; - case 3: /* no shift yet; eat a token */ -#if YYDEBUG - /* - ** if debugging, look up token in list of - ** pairs. 0 and negative shouldn't occur, - ** but since timing doesn't matter when - ** debugging, it doesn't hurt to leave the - ** tests here. - */ - if ( yydebug ) - { - register int yy_i; - - (void)printf( "Error recovery discards " ); - if ( yychar == 0 ) - (void)printf( "token end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "token -none-\n" ); - else - { - for ( yy_i = 0; - yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val - == yychar ) - { - break; - } - } - (void)printf( "token %s\n", - yytoks[yy_i].t_name ); - } - } -#endif /* YYDEBUG */ - if ( yychar == 0 ) /* reached EOF. quit */ - YYABORT; - yychar = -1; - goto yy_newstate; - } - }/* end if ( yy_n == 0 ) */ - /* - ** reduction by production yy_n - ** put stack tops, etc. so things right after switch - */ -#if YYDEBUG - /* - ** if debugging, print the string that is the user's - ** specification of the reduction which is just about - ** to be done. - */ - if ( yydebug ) - (void)printf( "Reduce by (%d) \"%s\"\n", - yy_n, yyreds[ yy_n ] ); -#endif - yytmp = yy_n; /* value to switch over */ - yypvt = yy_pv; /* $vars top of value stack */ - /* - ** Look in goto table for next state - ** Sorry about using yy_state here as temporary - ** register variable, but why not, if it works... - ** If yyr2[ yy_n ] doesn't have the low order bit - ** set, then there is no action to be done for - ** this reduction. So, no saving & unsaving of - ** registers done. The only difference between the - ** code just after the if and the body of the if is - ** the goto yy_stack in the body. This way the test - ** can be made before the choice of what to do is needed. - */ - { - /* length of production doubled with extra bit */ - register int yy_len = yyr2[ yy_n ]; - - if ( !( yy_len & 01 ) ) - { - yy_len >>= 1; - yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ - yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + - *( yy_ps -= yy_len ) + 1; - if ( yy_state >= YYLAST || - yychk[ yy_state = - yyact[ yy_state ] ] != -yy_n ) - { - yy_state = yyact[ yypgo[ yy_n ] ]; - } - goto yy_stack; - } - yy_len >>= 1; - yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ - yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + - *( yy_ps -= yy_len ) + 1; - if ( yy_state >= YYLAST || - yychk[ yy_state = yyact[ yy_state ] ] != -yy_n ) - { - yy_state = yyact[ yypgo[ yy_n ] ]; - } - } - /* save until reenter driver code */ - yystate = yy_state; - yyps = yy_ps; - yypv = yy_pv; - } - /* - ** code supplied by user is placed in this switch - */ - switch( yytmp ) - { - -case 1: -# line 100 "perly.y" -{ -#if defined(YYDEBUG) && defined(DEBUGGING) - yydebug = (debug & 1); -#endif - expect = XBLOCK; - } break; -case 2: -# line 107 "perly.y" -{ if (in_eval) { - eval_root = newUNOP(OP_LEAVEEVAL, 0, yypvt[-0].opval); - eval_start = linklist(eval_root); - eval_root->op_next = 0; - peep(eval_start); - } - else - main_root = block_head(yypvt[-0].opval, &main_start); - } break; -case 3: -# line 119 "perly.y" -{ yyval.opval = scalarseq(yypvt[-1].opval); - if (copline > (line_t)yypvt[-3].ival) - copline = yypvt[-3].ival; - leave_scope(yypvt[-2].ival); - pad_leavemy(comppadnamefill); - expect = XBLOCK; } break; -case 4: -# line 128 "perly.y" -{ yyval.ival = savestack_ix; SAVEINT(comppadnamefill); } break; -case 5: -# line 132 "perly.y" -{ yyval.opval = Nullop; } break; -case 6: -# line 134 "perly.y" -{ yyval.opval = yypvt[-1].opval; } break; -case 7: -# line 136 "perly.y" -{ yyval.opval = append_list(OP_LINESEQ, yypvt[-1].opval, yypvt[-0].opval); pad_reset(); } break; -case 8: -# line 140 "perly.y" -{ yyval.opval = newSTATEOP(0, yypvt[-1].pval, yypvt[-0].opval); } break; -case 10: -# line 143 "perly.y" -{ if (yypvt[-1].pval != Nullch) { - yyval.opval = newSTATEOP(0, yypvt[-1].pval, newOP(OP_NULL, 0)); - } - else { - yyval.opval = Nullop; - copline = NOLINE; - } - expect = XBLOCK; } break; -case 11: -# line 152 "perly.y" -{ yyval.opval = newSTATEOP(0, yypvt[-2].pval, yypvt[-1].opval); - expect = XBLOCK; } break; -case 12: -# line 157 "perly.y" -{ yyval.opval = Nullop; } break; -case 13: -# line 159 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 14: -# line 161 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yypvt[-0].opval, yypvt[-2].opval); } break; -case 15: -# line 163 "perly.y" -{ yyval.opval = newLOGOP(OP_OR, 0, yypvt[-0].opval, yypvt[-2].opval); } break; -case 16: -# line 165 "perly.y" -{ yyval.opval = newLOOPOP(0, 1, scalar(yypvt[-0].opval), yypvt[-2].opval); } break; -case 17: -# line 167 "perly.y" -{ yyval.opval = newLOOPOP(0, 1, invert(scalar(yypvt[-0].opval)), yypvt[-2].opval);} break; -case 18: -# line 171 "perly.y" -{ yyval.opval = Nullop; } break; -case 19: -# line 173 "perly.y" -{ yyval.opval = scope(yypvt[-0].opval); } break; -case 20: -# line 175 "perly.y" -{ copline = yypvt[-5].ival; - yyval.opval = newCONDOP(0, yypvt[-3].opval, scope(yypvt[-1].opval), yypvt[-0].opval); } break; -case 21: -# line 180 "perly.y" -{ copline = yypvt[-5].ival; - yyval.opval = newCONDOP(0, yypvt[-3].opval, scope(yypvt[-1].opval), yypvt[-0].opval); } break; -case 22: -# line 183 "perly.y" -{ copline = yypvt[-5].ival; - yyval.opval = newCONDOP(0, - invert(scalar(yypvt[-3].opval)), scope(yypvt[-1].opval), yypvt[-0].opval); } break; -case 23: -# line 187 "perly.y" -{ copline = yypvt[-3].ival; - yyval.opval = newCONDOP(0, scope(yypvt[-2].opval), scope(yypvt[-1].opval), yypvt[-0].opval); } break; -case 24: -# line 190 "perly.y" -{ copline = yypvt[-3].ival; - yyval.opval = newCONDOP(0, invert(scalar(scope(yypvt[-2].opval))), - scope(yypvt[-1].opval), yypvt[-0].opval); } break; -case 25: -# line 196 "perly.y" -{ yyval.opval = Nullop; } break; -case 26: -# line 198 "perly.y" -{ yyval.opval = scope(yypvt[-0].opval); } break; -case 27: -# line 202 "perly.y" -{ copline = yypvt[-5].ival; - yyval.opval = newSTATEOP(0, yypvt[-6].pval, - newWHILEOP(0, 1, Nullop, yypvt[-3].opval, yypvt[-1].opval, yypvt[-0].opval) ); } break; -case 28: -# line 206 "perly.y" -{ copline = yypvt[-5].ival; - yyval.opval = newSTATEOP(0, yypvt[-6].pval, - newWHILEOP(0, 1, Nullop, - invert(scalar(yypvt[-3].opval)), yypvt[-1].opval, yypvt[-0].opval) ); } break; -case 29: -# line 211 "perly.y" -{ copline = yypvt[-3].ival; - yyval.opval = newSTATEOP(0, yypvt[-4].pval, - newWHILEOP(0, 1, Nullop, - scope(yypvt[-2].opval), yypvt[-1].opval, yypvt[-0].opval) ); } break; -case 30: -# line 216 "perly.y" -{ copline = yypvt[-3].ival; - yyval.opval = newSTATEOP(0, yypvt[-4].pval, - newWHILEOP(0, 1, Nullop, - invert(scalar(scope(yypvt[-2].opval))), yypvt[-1].opval, yypvt[-0].opval)); } break; -case 31: -# line 221 "perly.y" -{ yyval.opval = newFOROP(0, yypvt[-7].pval, yypvt[-6].ival, ref(yypvt[-5].opval, OP_ENTERLOOP), - yypvt[-3].opval, yypvt[-1].opval, yypvt[-0].opval); } break; -case 32: -# line 224 "perly.y" -{ yyval.opval = newFOROP(0, yypvt[-6].pval, yypvt[-5].ival, Nullop, yypvt[-3].opval, yypvt[-1].opval, yypvt[-0].opval); } break; -case 33: -# line 227 "perly.y" -{ copline = yypvt[-8].ival; - yyval.opval = append_elem(OP_LINESEQ, - newSTATEOP(0, yypvt[-9].pval, scalar(yypvt[-6].opval)), - newSTATEOP(0, yypvt[-9].pval, - newWHILEOP(0, 1, Nullop, - scalar(yypvt[-4].opval), yypvt[-0].opval, scalar(yypvt[-2].opval)) )); } break; -case 34: -# line 234 "perly.y" -{ yyval.opval = newSTATEOP(0, - yypvt[-2].pval, newWHILEOP(0, 1, Nullop, Nullop, yypvt[-1].opval, yypvt[-0].opval)); } break; -case 35: -# line 239 "perly.y" -{ yyval.opval = Nullop; } break; -case 37: -# line 244 "perly.y" -{ (void)scan_num("1"); yyval.opval = yylval.opval; } break; -case 39: -# line 249 "perly.y" -{ yyval.pval = Nullch; } break; -case 41: -# line 254 "perly.y" -{ yyval.ival = 0; } break; -case 42: -# line 256 "perly.y" -{ yyval.ival = 0; } break; -case 43: -# line 258 "perly.y" -{ yyval.ival = 0; } break; -case 44: -# line 262 "perly.y" -{ newFORM(yypvt[-2].ival, yypvt[-1].opval, yypvt[-0].opval); } break; -case 45: -# line 264 "perly.y" -{ newFORM(yypvt[-1].ival, Nullop, yypvt[-0].opval); } break; -case 46: -# line 268 "perly.y" -{ newSUB(yypvt[-2].ival, yypvt[-1].opval, yypvt[-0].opval); } break; -case 47: -# line 272 "perly.y" -{ package(yypvt[-1].opval); } break; -case 48: -# line 274 "perly.y" -{ package(Nullop); } break; -case 49: -# line 278 "perly.y" -{ yyval.opval = append_elem(OP_LIST, yypvt[-2].opval, yypvt[-0].opval); } break; -case 51: -# line 283 "perly.y" -{ yyval.opval = convert(yypvt[-2].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yypvt[-1].opval), yypvt[-0].opval) ); } break; -case 52: -# line 286 "perly.y" -{ yyval.opval = convert(yypvt[-4].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yypvt[-2].opval), yypvt[-1].opval) ); } break; -case 53: -# line 289 "perly.y" -{ yyval.opval = convert(yypvt[-1].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yypvt[-3].opval), yypvt[-0].opval) ); } break; -case 54: -# line 292 "perly.y" -{ yyval.opval = convert(yypvt[-3].ival, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF(yypvt[-5].opval), yypvt[-1].opval) ); } break; -case 55: -# line 295 "perly.y" -{ yyval.opval = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, newMETHOD(yypvt[-5].opval,yypvt[-3].opval), yypvt[-1].opval)); } break; -case 56: -# line 298 "perly.y" -{ yyval.opval = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, newMETHOD(yypvt[-1].opval,yypvt[-2].opval), yypvt[-0].opval)); } break; -case 57: -# line 301 "perly.y" -{ yyval.opval = convert(yypvt[-1].ival, 0, yypvt[-0].opval); } break; -case 58: -# line 303 "perly.y" -{ yyval.opval = convert(yypvt[-3].ival, 0, yypvt[-1].opval); } break; -case 59: -# line 307 "perly.y" -{ yyval.opval = newASSIGNOP(OPf_STACKED, yypvt[-2].opval, yypvt[-0].opval); } break; -case 60: -# line 309 "perly.y" -{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED, - ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break; -case 61: -# line 312 "perly.y" -{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED, - ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break; -case 62: -# line 315 "perly.y" -{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED, - ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval));} break; -case 63: -# line 318 "perly.y" -{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED, - ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break; -case 64: -# line 321 "perly.y" -{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED, - ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break; -case 65: -# line 324 "perly.y" -{ yyval.opval = newBINOP(yypvt[-2].ival, OPf_STACKED, - ref(scalar(yypvt[-3].opval), yypvt[-2].ival), scalar(yypvt[-0].opval)); } break; -case 66: -# line 327 "perly.y" -{ yyval.opval = newLOGOP(OP_ANDASSIGN, 0, - ref(scalar(yypvt[-3].opval), OP_ANDASSIGN), - newUNOP(OP_SASSIGN, 0, scalar(yypvt[-0].opval))); } break; -case 67: -# line 331 "perly.y" -{ yyval.opval = newLOGOP(OP_ORASSIGN, 0, - ref(scalar(yypvt[-3].opval), OP_ORASSIGN), - newUNOP(OP_SASSIGN, 0, scalar(yypvt[-0].opval))); } break; -case 68: -# line 337 "perly.y" -{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break; -case 69: -# line 339 "perly.y" -{ if (yypvt[-1].ival != OP_REPEAT) - scalar(yypvt[-2].opval); - yyval.opval = newBINOP(yypvt[-1].ival, 0, yypvt[-2].opval, scalar(yypvt[-0].opval)); } break; -case 70: -# line 343 "perly.y" -{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break; -case 71: -# line 345 "perly.y" -{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break; -case 72: -# line 347 "perly.y" -{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break; -case 73: -# line 349 "perly.y" -{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break; -case 74: -# line 351 "perly.y" -{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break; -case 75: -# line 353 "perly.y" -{ yyval.opval = newBINOP(yypvt[-1].ival, 0, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval)); } break; -case 76: -# line 355 "perly.y" -{ yyval.opval = newRANGE(yypvt[-1].ival, scalar(yypvt[-2].opval), scalar(yypvt[-0].opval));} break; -case 77: -# line 357 "perly.y" -{ yyval.opval = newLOGOP(OP_AND, 0, yypvt[-2].opval, yypvt[-0].opval); } break; -case 78: -# line 359 "perly.y" -{ yyval.opval = newLOGOP(OP_OR, 0, yypvt[-2].opval, yypvt[-0].opval); } break; -case 79: -# line 361 "perly.y" -{ yyval.opval = newCONDOP(0, yypvt[-4].opval, yypvt[-2].opval, yypvt[-0].opval); } break; -case 80: -# line 363 "perly.y" -{ yyval.opval = bind_match(yypvt[-1].ival, yypvt[-2].opval, yypvt[-0].opval); } break; -case 81: -# line 365 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 82: -# line 369 "perly.y" -{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yypvt[-0].opval)); } break; -case 83: -# line 371 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 84: -# line 373 "perly.y" -{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yypvt[-0].opval)); } break; -case 85: -# line 375 "perly.y" -{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yypvt[-0].opval));} break; -case 86: -# line 377 "perly.y" -{ yyval.opval = newUNOP(OP_REFGEN, 0, ref(yypvt[-0].opval, OP_REFGEN)); } break; -case 87: -# line 379 "perly.y" -{ yyval.opval = newUNOP(OP_POSTINC, 0, - ref(scalar(yypvt[-1].opval), OP_POSTINC)); } break; -case 88: -# line 382 "perly.y" -{ yyval.opval = newUNOP(OP_POSTDEC, 0, - ref(scalar(yypvt[-1].opval), OP_POSTDEC)); } break; -case 89: -# line 385 "perly.y" -{ yyval.opval = newUNOP(OP_PREINC, 0, - ref(scalar(yypvt[-0].opval), OP_PREINC)); } break; -case 90: -# line 388 "perly.y" -{ yyval.opval = newUNOP(OP_PREDEC, 0, - ref(scalar(yypvt[-0].opval), OP_PREDEC)); } break; -case 91: -# line 391 "perly.y" -{ yyval.opval = localize(yypvt[-0].opval,yypvt[-1].ival); } break; -case 92: -# line 393 "perly.y" -{ yyval.opval = sawparens(yypvt[-1].opval); } break; -case 93: -# line 395 "perly.y" -{ yyval.opval = newNULLLIST(); } break; -case 94: -# line 397 "perly.y" -{ yyval.opval = newANONLIST(yypvt[-1].opval); } break; -case 95: -# line 399 "perly.y" -{ yyval.opval = newANONLIST(Nullop); } break; -case 96: -# line 401 "perly.y" -{ yyval.opval = newANONHASH(yypvt[-1].opval); } break; -case 97: -# line 403 "perly.y" -{ yyval.opval = newANONHASH(Nullop); } break; -case 98: -# line 405 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 99: -# line 407 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 100: -# line 409 "perly.y" -{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yypvt[-3].opval), scalar(yypvt[-1].opval)); } break; -case 101: -# line 411 "perly.y" -{ yyval.opval = newBINOP(OP_AELEM, 0, - scalar(ref(newAVREF(yypvt[-4].opval),OP_RV2AV)), - scalar(yypvt[-1].opval));} break; -case 102: -# line 415 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 103: -# line 417 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 104: -# line 419 "perly.y" -{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yypvt[-0].opval, OP_AV2ARYLEN));} break; -case 105: -# line 421 "perly.y" -{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yypvt[-4].opval), jmaybe(yypvt[-2].opval)); - expect = XOPERATOR; } break; -case 106: -# line 424 "perly.y" -{ yyval.opval = newBINOP(OP_HELEM, 0, - scalar(ref(newHVREF(yypvt[-5].opval),OP_RV2HV)), - jmaybe(yypvt[-2].opval)); - expect = XOPERATOR; } break; -case 107: -# line 429 "perly.y" -{ yyval.opval = newSLICEOP(0, yypvt[-1].opval, yypvt[-4].opval); } break; -case 108: -# line 431 "perly.y" -{ yyval.opval = newSLICEOP(0, yypvt[-1].opval, Nullop); } break; -case 109: -# line 433 "perly.y" -{ yyval.opval = prepend_elem(OP_ASLICE, - newOP(OP_PUSHMARK, 0), - list( - newLISTOP(OP_ASLICE, 0, - list(yypvt[-1].opval), - ref(yypvt[-3].opval, OP_ASLICE)))); } break; -case 110: -# line 440 "perly.y" -{ yyval.opval = prepend_elem(OP_HSLICE, - newOP(OP_PUSHMARK, 0), - list( - newLISTOP(OP_HSLICE, 0, - list(yypvt[-2].opval), - ref(oopsHV(yypvt[-4].opval), OP_HSLICE)))); - expect = XOPERATOR; } break; -case 111: -# line 448 "perly.y" -{ yyval.opval = newBINOP(OP_DELETE, 0, oopsHV(yypvt[-4].opval), jmaybe(yypvt[-2].opval)); - expect = XOPERATOR; } break; -case 112: -# line 451 "perly.y" -{ yyval.opval = newBINOP(OP_DELETE, 0, oopsHV(yypvt[-5].opval), jmaybe(yypvt[-3].opval)); - expect = XOPERATOR; } break; -case 113: -# line 454 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 114: -# line 456 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, 0, - scalar(yypvt[-0].opval)); } break; -case 115: -# line 459 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_STACKED, scalar(yypvt[-2].opval)); } break; -case 116: -# line 461 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_STACKED, - list(prepend_elem(OP_LIST, scalar(yypvt[-3].opval), yypvt[-1].opval))); } break; -case 117: -# line 464 "perly.y" -{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yypvt[-0].opval)); - allgvs = TRUE;} break; -case 118: -# line 467 "perly.y" -{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yypvt[-0].opval)); } break; -case 119: -# line 469 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yypvt[-2].opval))), newNULLLIST()))); } break; -case 120: -# line 473 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yypvt[-3].opval))), - yypvt[-1].opval))); } break; -case 121: -# line 478 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yypvt[-2].opval))), newNULLLIST())));} break; -case 122: -# line 482 "perly.y" -{ yyval.opval = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar(yypvt[-3].opval))), - yypvt[-1].opval))); } break; -case 123: -# line 487 "perly.y" -{ yyval.opval = newOP(yypvt[-0].ival, OPf_SPECIAL); } break; -case 124: -# line 489 "perly.y" -{ yyval.opval = newPVOP(yypvt[-1].ival, 0, - savestr(SvPVnx(((SVOP*)yypvt[-0].opval)->op_sv))); - op_free(yypvt[-0].opval); } break; -case 125: -# line 493 "perly.y" -{ yyval.opval = newOP(yypvt[-0].ival, 0); } break; -case 126: -# line 495 "perly.y" -{ yyval.opval = newUNOP(yypvt[-1].ival, 0, yypvt[-0].opval); } break; -case 127: -# line 497 "perly.y" -{ yyval.opval = newUNOP(yypvt[-1].ival, 0, yypvt[-0].opval); } break; -case 128: -# line 499 "perly.y" -{ yyval.opval = newOP(yypvt[-0].ival, 0); } break; -case 129: -# line 501 "perly.y" -{ yyval.opval = newOP(yypvt[-2].ival, 0); } break; -case 130: -# line 503 "perly.y" -{ yyval.opval = newOP(yypvt[-2].ival, OPf_SPECIAL); } break; -case 131: -# line 505 "perly.y" -{ yyval.opval = newUNOP(yypvt[-3].ival, 0, yypvt[-1].opval); } break; -case 132: -# line 507 "perly.y" -{ yyval.opval = pmruntime(yypvt[-3].opval, yypvt[-1].opval, Nullop); } break; -case 133: -# line 509 "perly.y" -{ yyval.opval = pmruntime(yypvt[-5].opval, yypvt[-3].opval, yypvt[-1].opval); } break; -case 136: -# line 515 "perly.y" -{ yyval.opval = newNULLLIST(); } break; -case 137: -# line 517 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 138: -# line 521 "perly.y" -{ yyval.opval = newCVREF(yypvt[-0].opval); } break; -case 139: -# line 525 "perly.y" -{ yyval.opval = newSVREF(yypvt[-0].opval); } break; -case 140: -# line 529 "perly.y" -{ yyval.opval = newAVREF(yypvt[-0].opval); } break; -case 141: -# line 533 "perly.y" -{ yyval.opval = newHVREF(yypvt[-0].opval); } break; -case 142: -# line 537 "perly.y" -{ yyval.opval = newAVREF(yypvt[-0].opval); } break; -case 143: -# line 541 "perly.y" -{ yyval.opval = newGVREF(yypvt[-0].opval); } break; -case 144: -# line 545 "perly.y" -{ yyval.opval = scalar(yypvt[-0].opval); } break; -case 145: -# line 547 "perly.y" -{ yyval.opval = scalar(yypvt[-0].opval); } break; -case 146: -# line 549 "perly.y" -{ yyval.opval = scalar(scope(yypvt[-0].opval)); } break; -case 147: -# line 552 "perly.y" -{ yyval.opval = yypvt[-0].opval; } break; -case 148: -# line 556 "perly.y" -{ yyval.ival = 1; } break; -case 149: -# line 558 "perly.y" -{ yyval.ival = 0; } break; -case 150: -# line 562 "perly.y" -{ yyval.ival = 1; } break; -case 151: -# line 564 "perly.y" -{ yyval.ival = 0; } break; -case 152: -# line 568 "perly.y" -{ yyval.ival = 1; } break; -case 153: -# line 570 "perly.y" -{ yyval.ival = 0; } break; - } - goto yystack; /* reset registers in driver code */ -} diff --git a/perly.fixer b/perly.fixer index 8dc533efc1..98296a72fd 100755 --- a/perly.fixer +++ b/perly.fixer @@ -1,5 +1,13 @@ #!/bin/sh +# Fix up yacc output to allow dynamic allocation. Since perly.c +# is now provided with the perl source, this should not be necessary. +# +# However, if the user wishes to use byacc, or wishes to try another +# compiler compiler (e.g. bison or yacc), this script will get run. +# +# Currently, only byacc version 1.8 is supported. +# # Hacks to make it work with Interactive's SysVr3 Version 2.2 # doughera@lafvax.lafayette.edu (Andy Dougherty) 3/23/91 # @@ -10,22 +18,41 @@ input=$1 output=$2 tmp=/tmp/f$$ -if test -f perly.c.diff; then +if grep 'yaccpar 1.8 (Berkeley)' $input >/dev/null 2>&1; then cp $input $output - patch -F3 <perly.c.diff - rm -rf $input + if test -f perly.c.diff; then + patch -F3 $output <perly.c.diff + rm -rf $input + fi exit +elif grep 'yaccpar 1.9 (Berkeley)' $input >/dev/null 2>&1; then + if test -f perly.c.dif9; then + patch -F3 $output <perly.c.dif9 + rm -rf $input + exit 0 + else + echo "Diffs from byacc-1.9 are not available." + echo "If you wish to proceed anyway, do" + echo "cp $input $output" + echo "cp y.tab.h perly.h" + echo "and re-run make. Otherwise, I will use the old perly.c" + touch perly.c + # Exit with error status to stop make. + exit 1 + fi fi plan="unknown" +# Below, we check for various yaccpar outputs. + # Test for BSD 4.3 version. # Also tests for the SunOS 4.0.2 version egrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\]; short[ ]*yys\[ *YYMAXDEPTH *\] *; yyps *= *&yys\[ *-1 *\]; yypv *= *&yyv\[ *-1 *\]; -if *\( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp +if *\( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp 2>/dev/null set `wc -l $tmp` if test "$1" = "5"; then @@ -33,12 +60,12 @@ if test "$1" = "5"; then fi if test "$plan" = "unknown"; then - # Test for ISC 2.2 version. + # Test for ISC 2.2 version (probably generic SysVr3). egrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\]; int[ ]*yys\[ *YYMAXDEPTH *\] *; yyps *= *&yys\[ *-1 *\]; yypv *= *&yyv\[ *-1 *\]; -if *\( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp +if *\( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp 2>/dev/null set `wc -l $tmp` if test "$1" = "5"; then @@ -67,8 +94,8 @@ short *maxyyps; /yypv *= *&yyv\[ *-1 *\];/c\ \ if (!yyv) {\ -\ yyv = (YYSTYPE*) malloc(yymaxdepth * sizeof(YYSTYPE));\ -\ yys = (short*) malloc(yymaxdepth * sizeof(short));\ +\ yyv = (YYSTYPE*) safemalloc(yymaxdepth * sizeof(YYSTYPE));\ +\ yys = (short*) safemalloc(yymaxdepth * sizeof(short));\ \ if ( !yyv || !yys ) {\ \ yyerror( "out of memory" );\ \ return(1);\ @@ -128,8 +155,8 @@ int *maxyyps; /yypv *= *&yyv\[ *-1 *\];/c\ \ if (!yyv) {\ -\ yyv = (YYSTYPE*) malloc(yymaxdepth * sizeof(YYSTYPE));\ -\ yys = (int*) malloc(yymaxdepth * sizeof(int));\ +\ yyv = (YYSTYPE*) safemalloc(yymaxdepth * sizeof(YYSTYPE));\ +\ yys = (int*) safemalloc(yymaxdepth * sizeof(int));\ \ maxyyps = &yys[yymaxdepth];\ \ }\ \ yyps = &yys[-1];\ @@ -1,54 +1,57 @@ #define WORD 257 #define METHOD 258 -#define THING 259 -#define PMFUNC 260 -#define PRIVATEREF 261 -#define LABEL 262 -#define FORMAT 263 -#define SUB 264 -#define PACKAGE 265 -#define HINT 266 -#define WHILE 267 -#define UNTIL 268 -#define IF 269 -#define UNLESS 270 -#define ELSE 271 -#define ELSIF 272 -#define CONTINUE 273 -#define FOR 274 -#define LOOPEX 275 -#define DOTDOT 276 -#define FUNC0 277 -#define FUNC1 278 -#define FUNC 279 -#define RELOP 280 -#define EQOP 281 -#define MULOP 282 -#define ADDOP 283 -#define DOLSHARP 284 -#define DO 285 -#define LOCAL 286 -#define DELETE 287 -#define HASHBRACK 288 -#define NOAMP 289 -#define OROP 290 -#define ANDOP 291 -#define LSTOP 292 -#define OROR 293 -#define ANDAND 294 -#define BITOROP 295 -#define BITANDOP 296 -#define UNIOP 297 -#define SHIFTOP 298 -#define MATCHOP 299 -#define UMINUS 300 -#define REFGEN 301 -#define POWOP 302 -#define PREINC 303 -#define PREDEC 304 -#define POSTINC 305 -#define POSTDEC 306 -#define ARROW 307 +#define FUNCMETH 259 +#define THING 260 +#define PMFUNC 261 +#define PRIVATEREF 262 +#define LABEL 263 +#define FORMAT 264 +#define SUB 265 +#define ANONSUB 266 +#define PACKAGE 267 +#define USE 268 +#define WHILE 269 +#define UNTIL 270 +#define IF 271 +#define UNLESS 272 +#define ELSE 273 +#define ELSIF 274 +#define CONTINUE 275 +#define FOR 276 +#define LOOPEX 277 +#define DOTDOT 278 +#define FUNC0 279 +#define FUNC1 280 +#define FUNC 281 +#define RELOP 282 +#define EQOP 283 +#define MULOP 284 +#define ADDOP 285 +#define DOLSHARP 286 +#define DO 287 +#define LOCAL 288 +#define HASHBRACK 289 +#define NOAMP 290 +#define OROP 291 +#define ANDOP 292 +#define NOTOP 293 +#define LSTOP 294 +#define ASSIGNOP 295 +#define OROR 296 +#define ANDAND 297 +#define BITOROP 298 +#define BITANDOP 299 +#define UNIOP 300 +#define SHIFTOP 301 +#define MATCHOP 302 +#define UMINUS 303 +#define REFGEN 304 +#define POWOP 305 +#define PREINC 306 +#define PREDEC 307 +#define POSTINC 308 +#define POSTDEC 309 +#define ARROW 310 typedef union { I32 ival; char *pval; @@ -1,47 +1,26 @@ -/* $RCSfile: perly.y,v $$Revision: 4.1 $$Date: 92/08/07 18:26:16 $ +/* perly.y * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: perly.y,v $ - * Revision 4.1 92/08/07 18:26:16 lwall - * - * Revision 4.0.1.5 92/06/11 21:12:50 lwall - * patch34: expectterm incorrectly set to indicate start of program or block - * - * Revision 4.0.1.4 92/06/08 17:33:25 lwall - * patch20: one of the backdoors to expectterm was on the wrong reduction - * - * Revision 4.0.1.3 92/06/08 15:18:16 lwall - * patch20: an expression may now start with a bareword - * patch20: relaxed requirement for semicolon at the end of a block - * patch20: added ... as variant on .. - * patch20: fixed double debug break in foreach with implicit array assignment - * patch20: if {block} {block} didn't work any more - * patch20: deleted some minor memory leaks - * - * Revision 4.0.1.2 91/11/05 18:17:38 lwall - * patch11: extra comma at end of list is now allowed in more places (Hi, Felix!) - * patch11: once-thru blocks didn't display right in the debugger - * patch11: debugger got confused over nested subroutine definitions - * - * Revision 4.0.1.1 91/06/07 11:42:34 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:38:40 lwall - * 4.0 baseline. - * + */ + +/* + * 'I see,' laughed Strider. 'I look foul and feel fair. Is that it? + * All that is gold does not glitter, not all those that wander are lost.' */ %{ #include "EXTERN.h" #include "perl.h" -/*SUPPRESS 530*/ -/*SUPPRESS 593*/ -/*SUPPRESS 595*/ +static void +dep() +{ + deprecate("\"do\" to call subroutines"); +} %} @@ -56,28 +35,29 @@ %token <ival> '{' ')' -%token <opval> WORD METHOD THING PMFUNC PRIVATEREF +%token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF %token <pval> LABEL -%token <ival> FORMAT SUB PACKAGE HINT +%token <ival> FORMAT SUB ANONSUB PACKAGE USE %token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR %token <ival> LOOPEX DOTDOT %token <ival> FUNC0 FUNC1 FUNC %token <ival> RELOP EQOP MULOP ADDOP -%token <ival> DOLSHARP DO LOCAL DELETE HASHBRACK NOAMP +%token <ival> DOLSHARP DO LOCAL HASHBRACK NOAMP -%type <ival> prog decl format remember crp crb crhb -%type <opval> block lineseq line loop cond nexpr else -%type <opval> expr sexpr term scalar ary hsh arylen star amper sideff -%type <opval> listexpr indirob -%type <opval> texpr listop +%type <ival> prog decl format remember startsub +%type <opval> block lineseq line loop cond nexpr else argexpr +%type <opval> expr term scalar ary hsh arylen star amper sideff +%type <opval> listexpr listexprcom indirob +%type <opval> texpr listop method %type <pval> label %type <opval> cont -%left OROP +%left <ival> OROP %left ANDOP +%left NOTOP %nonassoc <ival> LSTOP %left ',' -%right '=' +%right <ival> ASSIGNOP %right '?' ':' %nonassoc DOTDOT %left OROR @@ -107,37 +87,15 @@ prog : /* NULL */ expect = XSTATE; } /*CONTINUED*/ lineseq - { if (in_eval) { - eval_root = newUNOP(OP_LEAVEEVAL, 0, $2); - eval_start = linklist(eval_root); - eval_root->op_next = 0; - peep(eval_start); - } - else - main_root = block_head($2, &main_start); - } + { newPROG($2); } ; block : '{' remember lineseq '}' - { int needblockscope = hints & HINT_BLOCK_SCOPE; - $$ = scalarseq($3); - if (copline > (line_t)$1) - copline = $1; - LEAVE_SCOPE($2); - if (needblockscope) - hints |= HINT_BLOCK_SCOPE; /* propagate out */ - pad_leavemy(comppad_name_fill); } - ; - -remember: /* NULL */ /* in case they push a package name */ - { $$ = savestack_ix; - comppad_name_fill = AvFILL(comppad_name); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); - min_intro_pending = 0; - SAVEINT(comppad_name_fill); - SAVEINT(hints); - hints &= ~HINT_BLOCK_SCOPE; } + { $$ = block_end($1,$2,$3); } + ; + +remember: /* NULL */ /* start a lexical scope */ + { $$ = block_start(); } ; lineseq : /* NULL */ @@ -146,7 +104,8 @@ lineseq : /* NULL */ { $$ = $1; } | lineseq line { $$ = append_list(OP_LINESEQ, - (LISTOP*)$1, (LISTOP*)$2); pad_reset(); + (LISTOP*)$1, (LISTOP*)$2); + pad_reset_pending = TRUE; if ($1 && $2) hints |= HINT_BLOCK_SCOPE; } ; @@ -200,9 +159,11 @@ cond : IF '(' expr ')' block else invert(scalar($3)), scope($5), $6); } | IF block block else { copline = $1; + deprecate("if BLOCK BLOCK"); $$ = newCONDOP(0, scope($2), scope($3), $4); } | UNLESS block block else { copline = $1; + deprecate("unless BLOCK BLOCK"); $$ = newCONDOP(0, invert(scalar(scope($2))), scope($3), $4); } ; @@ -233,10 +194,10 @@ loop : label WHILE '(' texpr ')' block cont $$ = newSTATEOP(0, $1, newWHILEOP(0, 1, (LOOP*)Nullop, invert(scalar(scope($3))), $4, $5)); } - | label FOR scalar '(' expr crp block cont + | label FOR scalar '(' expr ')' block cont { $$ = newFOROP(0, $1, $2, mod($3, OP_ENTERLOOP), $5, $7, $8); } - | label FOR '(' expr crp block cont + | label FOR '(' expr ')' block cont { $$ = newFOROP(0, $1, $2, Nullop, $4, $6, $7); } | label FOR '(' nexpr ';' texpr ';' nexpr ')' block /* basically fake up an initialize-while lineseq */ @@ -273,20 +234,24 @@ decl : format { $$ = 0; } | package { $$ = 0; } - | hint + | use { $$ = 0; } ; -format : FORMAT WORD block - { newFORM($1, $2, $3); } - | FORMAT block - { newFORM($1, Nullop, $2); } +format : FORMAT startsub WORD block + { newFORM($2, $3, $4); } + | FORMAT startsub block + { newFORM($2, Nullop, $3); } ; -subrout : SUB WORD block - { newSUB($1, $2, $3); } - | SUB WORD ';' - { newSUB($1, $2, Nullop); expect = XSTATE; } +subrout : SUB startsub WORD block + { newSUB($2, $3, $4); } + | SUB startsub WORD ';' + { newSUB($2, $3, Nullop); expect = XSTATE; } + ; + +startsub: /* NULL */ /* start a subroutine scope */ + { $$ = start_subparse(); } ; package : PACKAGE WORD ';' @@ -295,110 +260,89 @@ package : PACKAGE WORD ';' { package(Nullop); } ; -hint : HINT WORD ';' - { hint($1, $2, Nullop); } - | HINT WORD expr ';' - { hint($1, $2, list(force_list($3))); } +use : USE WORD listexpr ';' + { utilize($1, $2, $3); } ; -expr : expr ',' sexpr +expr : expr ANDOP expr + { $$ = newLOGOP(OP_AND, 0, $1, $3); } + | expr OROP expr + { $$ = newLOGOP($2, 0, $1, $3); } + | NOTOP expr + { $$ = newUNOP(OP_NOT, 0, scalar($2)); } + | argexpr + ; + +argexpr : argexpr ',' + { $$ = $1; } + | argexpr ',' term { $$ = append_elem(OP_LIST, $1, $3); } - | sexpr + | term ; -listop : LSTOP indirob listexpr +listop : LSTOP indirob argexpr { $$ = convert($1, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF($2), $3) ); } - | FUNC '(' indirob listexpr ')' + prepend_elem(OP_LIST, newGVREF($1,$2), $3) ); } + | FUNC '(' indirob expr ')' { $$ = convert($1, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF($3), $4) ); } - | indirob ARROW LSTOP listexpr - { $$ = convert($3, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF($1), $4) ); } - | indirob ARROW FUNC '(' listexpr ')' - { $$ = convert($3, OPf_STACKED, - prepend_elem(OP_LIST, newGVREF($1), $5) ); } - | term ARROW METHOD '(' listexpr ')' - { $$ = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, - newMETHOD($1,$3), list($5))); } + prepend_elem(OP_LIST, newGVREF($1,$3), $4) ); } + | term ARROW method '(' listexprcom ')' + { $$ = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, $1, list($5)), + newUNOP(OP_METHOD, 0, $3))); } | METHOD indirob listexpr - { $$ = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, - newMETHOD($2,$1), list($3))); } + { $$ = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, $2, list($3)), + newUNOP(OP_METHOD, 0, $1))); } + | FUNCMETH indirob '(' listexprcom ')' + { $$ = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, $2, list($4)), + newUNOP(OP_METHOD, 0, $1))); } | LSTOP listexpr { $$ = convert($1, 0, $2); } - | FUNC '(' listexpr ')' + | FUNC '(' listexprcom ')' { $$ = convert($1, 0, $3); } ; -sexpr : sexpr '=' sexpr - { $$ = newASSIGNOP(OPf_STACKED, $1, $3); } - | sexpr POWOP '=' sexpr - { $$ = newBINOP($2, OPf_STACKED, - mod(scalar($1), $2), scalar($4)); } - | sexpr MULOP '=' sexpr - { $$ = newBINOP($2, OPf_STACKED, - mod(scalar($1), $2), scalar($4)); } - | sexpr ADDOP '=' sexpr - { $$ = newBINOP($2, OPf_STACKED, - mod(scalar($1), $2), scalar($4));} - | sexpr SHIFTOP '=' sexpr - { $$ = newBINOP($2, OPf_STACKED, - mod(scalar($1), $2), scalar($4)); } - | sexpr BITANDOP '=' sexpr - { $$ = newBINOP($2, OPf_STACKED, - mod(scalar($1), $2), scalar($4)); } - | sexpr BITOROP '=' sexpr - { $$ = newBINOP($2, OPf_STACKED, - mod(scalar($1), $2), scalar($4)); } - | sexpr ANDAND '=' sexpr - { $$ = newLOGOP(OP_ANDASSIGN, 0, - mod(scalar($1), OP_ANDASSIGN), - newUNOP(OP_SASSIGN, 0, scalar($4))); } - | sexpr OROR '=' sexpr - { $$ = newLOGOP(OP_ORASSIGN, 0, - mod(scalar($1), OP_ORASSIGN), - newUNOP(OP_SASSIGN, 0, scalar($4))); } - - - | sexpr POWOP sexpr +method : METHOD + | scalar + ; + +term : term ASSIGNOP term + { $$ = newASSIGNOP(OPf_STACKED, $1, $2, $3); } + | term POWOP term { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | sexpr MULOP sexpr + | term MULOP term { if ($2 != OP_REPEAT) scalar($1); $$ = newBINOP($2, 0, $1, scalar($3)); } - | sexpr ADDOP sexpr + | term ADDOP term { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | sexpr SHIFTOP sexpr + | term SHIFTOP term { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | sexpr RELOP sexpr + | term RELOP term { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | sexpr EQOP sexpr + | term EQOP term { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | sexpr BITANDOP sexpr + | term BITANDOP term { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | sexpr BITOROP sexpr + | term BITOROP term { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | sexpr DOTDOT sexpr + | term DOTDOT term { $$ = newRANGE($2, scalar($1), scalar($3));} - | sexpr ANDAND sexpr - { $$ = newLOGOP(OP_AND, 0, $1, $3); } - | sexpr OROR sexpr - { $$ = newLOGOP(OP_OR, 0, $1, $3); } - | sexpr ANDOP sexpr + | term ANDAND term { $$ = newLOGOP(OP_AND, 0, $1, $3); } - | sexpr OROP sexpr + | term OROR term { $$ = newLOGOP(OP_OR, 0, $1, $3); } - | sexpr '?' sexpr ':' sexpr + | term '?' term ':' term { $$ = newCONDOP(0, $1, $3, $5); } - | sexpr MATCHOP sexpr + | term MATCHOP term { $$ = bind_match($2, $1, $3); } - | term - { $$ = $1; } - ; -term : '-' term %prec UMINUS + | '-' term %prec UMINUS { $$ = newUNOP(OP_NEGATE, 0, scalar($2)); } | '+' term %prec UMINUS { $$ = $2; } @@ -407,7 +351,7 @@ term : '-' term %prec UMINUS | '~' term { $$ = newUNOP(OP_COMPLEMENT, 0, scalar($2));} | REFGEN term - { $$ = newUNOP(OP_REFGEN, 0, ref($2,OP_REFGEN)); } + { $$ = newUNOP(OP_REFGEN, 0, mod($2,OP_REFGEN)); } | term POSTINC { $$ = newUNOP(OP_POSTINC, 0, mod(scalar($1), OP_POSTINC)); } @@ -420,20 +364,22 @@ term : '-' term %prec UMINUS | PREDEC term { $$ = newUNOP(OP_PREDEC, 0, mod(scalar($2), OP_PREDEC)); } - | LOCAL sexpr %prec UNIOP + | LOCAL term %prec UNIOP { $$ = localize($2,$1); } - | '(' expr crp + | '(' expr ')' { $$ = sawparens($2); } | '(' ')' { $$ = sawparens(newNULLLIST()); } - | '[' expr crb %prec '(' + | '[' expr ']' %prec '(' { $$ = newANONLIST($2); } | '[' ']' %prec '(' { $$ = newANONLIST(Nullop); } - | HASHBRACK expr crhb %prec '(' + | HASHBRACK expr ';' '}' %prec '(' { $$ = newANONHASH($2); } | HASHBRACK ';' '}' %prec '(' { $$ = newANONHASH(Nullop); } + | ANONSUB startsub block %prec '(' + { $$ = newANONSUB($2, $3); } | scalar %prec '(' { $$ = $1; } | star %prec '(' @@ -445,7 +391,7 @@ term : '-' term %prec UMINUS ref(newAVREF($1),OP_RV2AV), scalar($4));} | term '[' expr ']' %prec '(' - { $$ = newBINOP(OP_AELEM, 0, + { assertref($1); $$ = newBINOP(OP_AELEM, 0, ref(newAVREF($1),OP_RV2AV), scalar($3));} | hsh %prec '(' @@ -463,85 +409,73 @@ term : '-' term %prec UMINUS jmaybe($4)); expect = XOPERATOR; } | term '{' expr ';' '}' %prec '(' - { $$ = newBINOP(OP_HELEM, 0, + { assertref($1); $$ = newBINOP(OP_HELEM, 0, ref(newHVREF($1),OP_RV2HV), jmaybe($3)); expect = XOPERATOR; } - | '(' expr crp '[' expr ']' %prec '(' + | '(' expr ')' '[' expr ']' %prec '(' { $$ = newSLICEOP(0, $5, $2); } | '(' ')' '[' expr ']' %prec '(' { $$ = newSLICEOP(0, $4, Nullop); } | ary '[' expr ']' %prec '(' { $$ = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), - list( newLISTOP(OP_ASLICE, 0, list($3), - ref($1, OP_ASLICE)))); } + ref($1, OP_ASLICE))); } | ary '{' expr ';' '}' %prec '(' { $$ = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), - list( newLISTOP(OP_HSLICE, 0, list($3), - ref(oopsHV($1), OP_HSLICE)))); - expect = XOPERATOR; } - | DELETE scalar '{' expr ';' '}' %prec '(' - { $$ = newBINOP(OP_DELETE, 0, oopsHV($2), jmaybe($4)); - expect = XOPERATOR; } - | DELETE '(' scalar '{' expr ';' '}' ')' %prec '(' - { $$ = newBINOP(OP_DELETE, 0, oopsHV($3), jmaybe($5)); + ref(oopsHV($1), OP_HSLICE))); expect = XOPERATOR; } | THING %prec '(' { $$ = $1; } | amper - { $$ = newUNOP(OP_ENTERSUBR, 0, + { $$ = newUNOP(OP_ENTERSUB, 0, scalar($1)); } | amper '(' ')' - { $$ = newUNOP(OP_ENTERSUBR, OPf_STACKED, scalar($1)); } - | amper '(' expr crp - { $$ = newUNOP(OP_ENTERSUBR, OPf_STACKED, - list(prepend_elem(OP_LIST, scalar($1), $3))); } + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); } + | amper '(' expr ')' + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, + list(append_elem(OP_LIST, $3, scalar($1)))); } | NOAMP WORD listexpr - { $$ = newUNOP(OP_ENTERSUBR, OPf_STACKED, - list(prepend_elem(OP_LIST, - newCVREF(scalar($2)), $3))); } - | NOAMP WORD indirob listexpr - { $$ = convert(OP_ENTERSUBR, OPf_STACKED|OPf_SPECIAL, - prepend_elem(OP_LIST, - newMETHOD($3,$2), list($4))); } - | DO sexpr %prec UNIOP + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, + list(append_elem(OP_LIST, + $3, newCVREF(scalar($2))))); } + | DO term %prec UNIOP { $$ = newUNOP(OP_DOFILE, 0, scalar($2)); } | DO block %prec '(' { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); } | DO WORD '(' ')' - { $$ = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, + { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar($2))), Nullop))); } - | DO WORD '(' expr crp - { $$ = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, - list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar($2))), - $4))); } + scalar(newCVREF(scalar($2))), Nullop))); dep();} + | DO WORD '(' expr ')' + { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, + list(append_elem(OP_LIST, + $4, + scalar(newCVREF(scalar($2)))))); dep();} | DO scalar '(' ')' - { $$ = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, + { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar($2))), Nullop)));} - | DO scalar '(' expr crp - { $$ = newUNOP(OP_ENTERSUBR, OPf_SPECIAL|OPf_STACKED, + scalar(newCVREF(scalar($2))), Nullop))); dep();} + | DO scalar '(' expr ')' + { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, list(prepend_elem(OP_LIST, - scalar(newCVREF(scalar($2))), - $4))); } + $4, + scalar(newCVREF(scalar($2)))))); dep();} | LOOPEX { $$ = newOP($1, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } - | LOOPEX sexpr + | LOOPEX term { $$ = newLOOPEX($1,$2); } | UNIOP { $$ = newOP($1, 0); } | UNIOP block { $$ = newUNOP($1, 0, $2); } - | UNIOP sexpr + | UNIOP term { $$ = newUNOP($1, 0, $2); } | FUNC0 { $$ = newOP($1, 0); } @@ -551,9 +485,9 @@ term : '-' term %prec UMINUS { $$ = newOP($1, OPf_SPECIAL); } | FUNC1 '(' expr ')' { $$ = newUNOP($1, 0, $3); } - | PMFUNC '(' sexpr ')' + | PMFUNC '(' term ')' { $$ = pmruntime($1, $3, Nullop); } - | PMFUNC '(' sexpr ',' sexpr ')' + | PMFUNC '(' term ',' term ')' { $$ = pmruntime($1, $3, $5); } | WORD | listop @@ -561,8 +495,16 @@ term : '-' term %prec UMINUS listexpr: /* NULL */ { $$ = Nullop; } + | argexpr + { $$ = $1; } + ; + +listexprcom: /* NULL */ + { $$ = Nullop; } | expr { $$ = $1; } + | expr ',' + { $$ = $1; } ; amper : '&' indirob @@ -586,7 +528,7 @@ arylen : DOLSHARP indirob ; star : '*' indirob - { $$ = newGVREF($2); } + { $$ = newGVREF(0,$2); } ; indirob : WORD @@ -594,28 +536,10 @@ indirob : WORD | scalar { $$ = scalar($1); } | block - { $$ = scalar(scope($1)); } + { $$ = scope($1); } | PRIVATEREF { $$ = $1; } ; -crp : ',' ')' - { $$ = 1; } - | ')' - { $$ = 0; } - ; - -crb : ',' ']' - { $$ = 1; } - | ']' - { $$ = 0; } - ; - -crhb : ',' ';' '}' - { $$ = 1; } - | ';' '}' - { $$ = 0; } - ; - %% /* PROGRAM */ @@ -0,0 +1,321 @@ +#!/usr/bin/perl + +while (<DATA>) { + chop; + $keyword{$_} = 1; +} + +undef $/; +$* = 1; +while (<>) { + $newname = $ARGV; + $newname =~ s/\.pl$/.pm/ || next; + $newname =~ s#(.*/)?(\w+)#$1\u$2#; + if (-f $newname) { + warn "Won't overwrite existing $newname\n"; + next; + } + $oldpack = $2; + $newpack = "\u$2"; + @export = (); + print "$oldpack => $newpack\n" if $verbose; + + s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig; + if (/sub\s+main'/) { + @export = m/sub\s+main'(\w+)/g; + s/(sub\s+)main'(\w+)/$1$2/g; + } + else { + @export = m/sub\s+([A-Za-z]\w*)/g; + } + @export_ok = grep($keyword{$_}, @export); + @export = grep(!$keyword{$_}, @export); + @export{@export} = (1) x @export; + s/(^\s*);#/$1#/g; + s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/; + s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig; + s/([\$\@%&*])'(\w+)/&xlate($1,"",$2)/eg; + s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3)/eg; + if (!/\$\[\s*\)?\s*=\s*[^0\s]/) { + s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g; + s/\$\[\s*\+\s*//g; + s/\s*\+\s*\$\[//g; + s/\$\[/0/g; + } + s/open\s+(\w+)/open($1)/g; + + if (s/\bdie\b/croak/g) { + $carp = "use Carp;\n"; + s/croak "([^"]*)\\n"/croak "$1"/g; + } + else { + $carp = ""; + } + if (@export_ok) { + $export_ok = "\@EXPORT_OK = qw(@export_ok);\n"; + } + else { + $export_ok = ""; + } + + open(PM, ">$newname") || warn "Can't create $newname: $!\n"; + print PM <<"END"; +package $newpack; +require 5.000; +require Exporter; +$carp +\@ISA = qw(Exporter); +\@EXPORT = qw(@export); +$export_ok +$_ +END +} + +sub xlate { + local($prefix, $pack, $ident) = @_; + if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) { + "${pack}'$ident"; + } + elsif ($pack eq "" || $pack eq "main") { + if ($export{$ident}) { + "$prefix$ident"; + } + else { + "$prefix${pack}::$ident"; + } + } + elsif ($pack eq $oldpack) { + "$prefix${newpack}::$ident"; + } + else { + "$prefix${pack}::$ident"; + } +} +__END__ +AUTOLOAD +BEGIN +CORE +DESTROY +END +abs +accept +alarm +and +atan2 +bind +binmode +bless +caller +chdir +chmod +chop +chown +chr +chroot +close +closedir +cmp +connect +continue +cos +crypt +dbmclose +dbmopen +defined +delete +die +do +dump +each +else +elsif +endgrent +endhostent +endnetent +endprotoent +endpwent +endservent +eof +eq +eval +exec +exit +exp +fcntl +fileno +flock +for +foreach +fork +format +formline +ge +getc +getgrent +getgrgid +getgrnam +gethostbyaddr +gethostbyname +gethostent +getlogin +getnetbyaddr +getnetbyname +getnetent +getpeername +getpgrp +getppid +getpriority +getprotobyname +getprotobynumber +getprotoent +getpwent +getpwnam +getpwuid +getservbyname +getservbyport +getservent +getsockname +getsockopt +glob +gmtime +goto +grep +gt +hex +if +index +int +ioctl +join +keys +kill +last +lc +lcfirst +le +length +link +listen +local +localtime +log +lstat +lt +m +mkdir +msgctl +msgget +msgrcv +msgsnd +my +ne +next +no +not +oct +open +opendir +or +ord +pack +package +pipe +pop +print +printf +push +q +qq +quotemeta +qw +qx +rand +read +readdir +readline +readlink +readpipe +recv +redo +ref +rename +require +reset +return +reverse +rewinddir +rindex +rmdir +s +scalar +seek +seekdir +select +semctl +semget +semop +send +setgrent +sethostent +setnetent +setpgrp +setpriority +setprotoent +setpwent +setservent +setsockopt +shift +shmctl +shmget +shmread +shmwrite +shutdown +sin +sleep +socket +socketpair +sort +splice +split +sprintf +sqrt +srand +stat +study +sub +substr +symlink +syscall +sysread +system +syswrite +tell +telldir +tie +time +times +tr +truncate +uc +ucfirst +umask +undef +unless +unlink +unpack +unshift +untie +until +use +utime +values +vec +wait +waitpid +wantarray +warn +while +write +x +xor +y diff --git a/pod/Makefile b/pod/Makefile new file mode 100644 index 0000000000..d96fd7da3e --- /dev/null +++ b/pod/Makefile @@ -0,0 +1,106 @@ +all: man + +POD = \ + perl.pod \ + perlapi.pod \ + perlbook.pod \ + perlbot.pod \ + perlcall.pod \ + perldata.pod \ + perldebug.pod \ + perldiag.pod \ + perlembed.pod \ + perlform.pod \ + perlfunc.pod \ + perlguts.pod \ + perlipc.pod \ + perlmod.pod \ + perlobj.pod \ + perlop.pod \ + perlovl.pod \ + perlpod.pod \ + perlre.pod \ + perlref.pod \ + perlrun.pod \ + perlsec.pod \ + perlstyle.pod \ + perlsub.pod \ + perlsyn.pod \ + perltrap.pod \ + perlvar.pod + +MAN = \ + perl.man \ + perlapi.man \ + perlbook.man \ + perlbot.man \ + perlcall.man \ + perldata.man \ + perldebug.man \ + perldiag.man \ + perlembed.man \ + perlform.man \ + perlfunc.man \ + perlguts.man \ + perlipc.man \ + perlmod.man \ + perlobj.man \ + perlop.man \ + perlovl.man \ + perlpod.man \ + perlre.man \ + perlref.man \ + perlrun.man \ + perlsec.man \ + perlstyle.man \ + perlsub.man \ + perlsyn.man \ + perltrap.man \ + perlvar.man + +HTML = \ + perl.html \ + perlapi.html \ + perlbook.html \ + perlbot.html \ + perlcall.html \ + perldata.html \ + perldebug.html \ + perldiag.html \ + perlembed.html \ + perlform.html \ + perlfunc.html \ + perlguts.html \ + perlipc.html \ + perlmod.html \ + perlobj.html \ + perlop.html \ + perlovl.html \ + perlpod.html \ + perlre.html \ + perlref.html \ + perlrun.html \ + perlsec.html \ + perlstyle.html \ + perlsub.html \ + perlsyn.html \ + perltrap.html \ + perlvar.html + +man: $(MAN) + +html: $(HTML) + +.SUFFIXES: .pod .man + +.pod.man: + ../miniperl pod2man $*.pod >$*.man + +.SUFFIXES: .pod .html + +.pod.html: + ../miniperl pod2html $*.pod >$*.html + +clean: + rm -f $(MAN) $(HTML) + diff --git a/pod/modpods/Abbrev.pod b/pod/modpods/Abbrev.pod new file mode 100644 index 0000000000..85ec88ef85 --- /dev/null +++ b/pod/modpods/Abbrev.pod @@ -0,0 +1,19 @@ +=head1 NAME + +abbrev - create an abbreviation table from a list + +=head1 SYNOPSIS + + use Abbrev; + abbrev *HASH, LIST + + +=head1 DESCRIPTION + +Stores all unambiguous truncations of each element of LIST +as keys key in the associative array indicated by C<*hash>. +The values are the original list elements. + +=head1 EXAMPLE + + abbrev(*hash,qw("list edit send abort gripe")); diff --git a/pod/modpods/AnyDBMFile.pod b/pod/modpods/AnyDBMFile.pod new file mode 100644 index 0000000000..7b579ca34c --- /dev/null +++ b/pod/modpods/AnyDBMFile.pod @@ -0,0 +1,73 @@ +=head1 NAME + +AnyDBM_File - provide framework for multiple DBMs + +NDBM_File, ODBM_File, SDBM_File, GDBM_File - various DBM implementations + +=head1 SYNOPSIS + + use AnyDBM_File; + +=head1 DESCRIPTION + +This module is a "pure virtual base class"--it has nothing of us its own. +It's just there to inherit from one of the various DBM packages. It +prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See +L<DB_File>), GDBM, SDBM (which is always there -- it comes with Perl), and +finally ODBM. This way old programs that used to use NDBM via dbmopen() can still +do so, but new ones can reorder @ISA: + + @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File); + +This makes it trivial to copy database formats: + + use POSIX; use NDBM_File; use DB_File; + tie %newhash, DB_File, $new_filename, O_CREAT|O_RDWR; + tie %oldhash, NDBM_File, $old_filename, 1, 0; + %newhash = %oldhash; + +=head2 DBM Comparisons + +Here's a partial table of features the different packages offer: + + odbm ndbm sdbm gdbm bsd-db + ---- ---- ---- ---- ------ + Linkage comes w/ perl yes yes yes yes yes + Src comes w/ perl no no yes no no + Comes w/ many unix os yes yes[0] no no no + Builds ok on !unix ? ? yes yes ? + Code Size ? ? small big big + Database Size ? ? small big? ok[1] + Speed ? ? slow ok fast + FTPable no no yes yes yes + Easy to build N/A N/A yes yes ok[2] + Size limits 1k 4k 1k[3] none none + Byte-order independent no no no no yes + Licensing restrictions ? ? no yes no + + +=over 4 + +=item [0] + +on mixed universe machines, may be in the bsd compat library, +which is often shunned. + +=item [1] + +Can be trimmed if you compile for one access method. + +=item [2] + +See L<DB_File>. +Requires symbolic links. + +=item [3] + +By default, but can be redefined. + +=back + +=head1 SEE ALSO + +dbm(3), ndbm(3), DB_File(3) diff --git a/pod/modpods/AutoLoader.pod b/pod/modpods/AutoLoader.pod new file mode 100644 index 0000000000..203f951e39 --- /dev/null +++ b/pod/modpods/AutoLoader.pod @@ -0,0 +1,16 @@ +=head1 NAME + +AutoLoader - load functions only on demand + +=head1 SYNOPSIS + + package FOOBAR; + use Exporter; + use AutoLoader; + @ISA = (Exporter, AutoLoader); + +=head1 DESCRIPTION + +This module tells its users that functions in the FOOBAR package are to be +autoloaded from F<auto/$AUTOLOAD.al>. See L<perlsub/"Autoloading">. + diff --git a/pod/modpods/AutoSplit.pod b/pod/modpods/AutoSplit.pod new file mode 100644 index 0000000000..86df8c018b --- /dev/null +++ b/pod/modpods/AutoSplit.pod @@ -0,0 +1,11 @@ +=head1 NAME + +AutoSplit - split a package for autoloading + +=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. + diff --git a/pod/modpods/Basename.pod b/pod/modpods/Basename.pod new file mode 100644 index 0000000000..11cb15ee77 --- /dev/null +++ b/pod/modpods/Basename.pod @@ -0,0 +1,108 @@ +=head1 NAME + +Basename - parse file specifications + +fileparse - split a pathname into pieces + +basename - extract just the filename from a path + +dirname - extract just the directory from a path + +=head1 SYNOPSIS + + use File::Basename; + + ($name,$path,$suffix) = fileparse($fullname,@suffixlist) + fileparse_set_fstype($os_string); + $basename = basename($fullname,@suffixlist); + $dirname = dirname($fullname); + + ($name,$path,$suffix) = fileparse("lib/File/Basename.pm",".pm"); + fileparse_set_fstype("VMS"); + $basename = basename("lib/File/Basename.pm",".pm"); + $dirname = dirname("lib/File/Basename.pm"); + +=head1 DESCRIPTION + +These routines allow you to parse file specifications into useful +pieces according using the syntax of different operating systems. + +=over 4 + +=item fileparse_set_fstype + +You select the syntax via the routine fileparse_set_fstype(). +If the argument passed to it contains one of the substrings +"VMS", "MSDOS", or "MacOS", the file specification syntax of that +operating system is used in future calls to fileparse(), +basename(), and dirname(). If it contains none of these +substrings, UNIX syntax is used. This pattern matching is +case-insensitive. If you've selected VMS syntax, and the file +specification you pass to one of these routines contains a "/", +they assume you are using UNIX emulation and apply the UNIX syntax +rules instead, for that function call only. + +If you haven't called fileparse_set_fstype(), the syntax is chosen +by examining the "osname" entry from the C<Config> package +according to these rules. + +=item fileparse + +The fileparse() routine divides a file specification into three +parts: a leading B<path>, a file B<name>, and a B<suffix>. The +B<path> contains everything up to and including the last directory +separator in the input file specification. The remainder of the input +file specification is then divided into B<name> and B<suffix> based on +the optional patterns you specify in C<@suffixlist>. Each element of +this list is interpreted as a regular expression, and is matched +against the end of B<name>. If this succeeds, the matching portion of +B<name> is removed and prepended to B<suffix>. By proper use of +C<@suffixlist>, you can remove file types or versions for examination. + +You are guaranteed that if you concatenate B<path>, B<name>, and +B<suffix> together in that order, the result will be identical to the +input file specification. + +=back + +=head1 EXAMPLES + +Using UNIX file syntax: + + ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', + '\.book\d+'); + +would yield + + $base eq 'draft' + $path eq '/virgil/aeneid', + $tail eq '.book7' + +Similarly, using VMS syntax: + + ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh', + '\..*'); + +would yield + + $name eq 'Rhetoric' + $dir eq 'Doc_Root:[Help]' + $type eq '.Rnh' + +=item C<basename> + +The basename() routine returns the first element of the list produced +by calling fileparse() with the same arguments. It is provided for +compatibility with the UNIX shell command basename(1). + +=item C<dirname> + +The dirname() routine returns the directory portion of the input file +specification. When using VMS or MacOS syntax, this is identical to the +second element of the list produced by calling fileparse() with the same +input file specification. When using UNIX or MSDOS syntax, the return +value conforms to the behavior of the UNIX shell command dirname(1). This +is usually the same as the behavior of fileparse(), but differs in some +cases. For example, for the input file specification F<lib/>, fileparse() +considers the directory name to be F<lib/>, while dirname() considers the +directory name to be F<.>). diff --git a/pod/modpods/Benchmark.pod b/pod/modpods/Benchmark.pod new file mode 100644 index 0000000000..bdb3f05700 --- /dev/null +++ b/pod/modpods/Benchmark.pod @@ -0,0 +1,159 @@ +=head1 NAME + +Benchmark - benchmark running times of code + +timethis - run a chunk of code several times + +timethese - run several chunks of code several times + +timeit - run a chunk of code and see how long it goes + +=head1 SYNOPSYS + + timethis ($count, "code"); + + timethese($count, { + 'Name1' => '...code1...', + 'Name2' => '...code2...', + }); + + $t = timeit($count, '...other code...') + print "$count loops of other code took:",timestr($t),"\n"; + +=head1 DESCRIPTION + +The Benchmark module encapsulates a number of routines to help you +figure out how long it takes to execute some code. + +=head2 Methods + +=over 10 + +=item new + +Returns the current time. Example: + + use Benchmark; + $t0 = new Benchmark; + # ... your code here ... + $t1 = new Benchmark; + $td = timediff($t1, $t0); + print "the code took:",timestr($dt),"\n"; + +=item debug + +Enables or disable debugging by setting the C<$Benchmark::Debug> flag: + + debug Benchmark 1; + $t = timeit(10, ' 5 ** $Global '); + debug Benchmark 0; + +=back + +=head2 Standard Exports + +The following routines will be exported into your namespace +if you use the Benchmark module: + +=over 10 + +=item timeit(COUNT, CODE) + +Arguments: COUNT is the number of time to run the loop, and +the second is the code to run. CODE may be a string containing the code, +a reference to the function to run, or a reference to a hash containing +keys which are names and values which are more CODE specs. + +Side-effects: prints out noise to standard out. + +Returns: a Benchmark object. + +=item timethis + +=item timethese + +=item timediff + +=item timestr + +=back + +=head2 Optional Exports + +The following routines will be exported into your namespace +if you specifically ask that they be imported: + +=over 10 + +clearcache + +clearallcache + +disablecache + +enablecache + +=back + +=head1 NOTES + +The data is stored as a list of values from the time and times +functions: + + ($real, $user, $system, $children_user, $children_system) + +in seconds for the whole loop (not divided by the number of rounds). + +The timing is done using time(3) and times(3). + +Code is executed in the caller's package. + +Enable debugging by: + + $Benchmark::debug = 1; + +The time of the null loop (a loop with the same +number of rounds but empty loop body) is subtracted +from the time of the real loop. + +The null loop times are cached, the key being the +number of rounds. The caching can be controlled using +calls like these: + + clearcache($key); + clearallcache(); + + disablecache(); + enablecache(); + +=head1 INHERITANCE + +Benchmark inherits from no other class, except of course +for Exporter. + +=head1 CAVEATS + +The real time timing is done using time(2) and +the granularity is therefore only one second. + +Short tests may produce negative figures because perl +can appear to take longer to execute the empty loop +than a short test; try: + + timethis(100,'1'); + +The system time of the null loop might be slightly +more than the system time of the loop with the actual +code and therefore the difference might end up being < 0. + +More documentation is needed :-( especially for styles and formats. + +=head1 AUTHORS + +Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi>, +Tim Bunce <Tim.Bunce@ig.co.uk> + +=head1 MODIFICATION HISTORY + +September 8th, 1994; by Tim Bunce. + diff --git a/pod/modpods/Carp.pod b/pod/modpods/Carp.pod new file mode 100644 index 0000000000..b5439779ac --- /dev/null +++ b/pod/modpods/Carp.pod @@ -0,0 +1,22 @@ +=head1 NAME + +carp - warn of errors (from perspective of caller) + +croak - die of errors (from perspective of caller) + +confess - die of errors with stack backtrace + +=head1 SYNOPSIS + + use Carp; + croak "We're outta here!"; + +=head1 DESCRIPTION + +The Carp routines are useful in your own modules because +they act like die() or warn(), but report where the error +was in the code they were called from. Thus if you have a +routine Foo() that has a carp() in it, then the carp() +will report the error as occurring where Foo() was called, +not where carp() was called. + diff --git a/pod/modpods/CheckTree.pod b/pod/modpods/CheckTree.pod new file mode 100644 index 0000000000..cc06eeeda3 --- /dev/null +++ b/pod/modpods/CheckTree.pod @@ -0,0 +1,37 @@ +=head1 NAME + +validate - run many filetest checks on a tree + +=head1 SYNOPSIS + + use File::CheckTree; + + $warnings += validate( q{ + /vmunix -e || die + /boot -e || die + /bin cd + csh -ex + csh !-ug + sh -ex + sh !-ug + /usr -d || warn "What happened to $file?\n" + }); + +=head1 DESCRIPTION + +The validate() routine takes a single multiline string consisting of +lines containing a filename plus a file test to try on it. (The +file test may also be a "cd", causing subsequent relative filenames +to be interpreted relative to that directory.) After the file test +you may put C<|| die> to make it a fatal error if the file test fails. +The default is C<|| warn>. The file test may optionally have a "!' prepended +to test for the opposite condition. If you do a cd and then list some +relative filenames, you may want to indent them slightly for readability. +If you supply your own die() or warn() message, you can use $file to +interpolate the filename. + +Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>. +Only the first failed test of the bunch will produce a warning. + +The routine returns the number of warnings issued. + diff --git a/pod/modpods/Collate.pod b/pod/modpods/Collate.pod new file mode 100644 index 0000000000..852fd1f4bd --- /dev/null +++ b/pod/modpods/Collate.pod @@ -0,0 +1,31 @@ +=head1 NAME + +Collate - compare 8-bit scalar data according to the current locale + +=head1 SYNOPSIS + + use Collate; + setlocale(LC_COLLATE, 'locale-of-your-choice'); + $s1 = new Collate "scalar_data_1"; + $s2 = new Collate "scalar_data_2"; + +=head1 DESCRIPTION + +This module provides you with objects that will collate +according to your national character set, providing the +POSIX setlocale() function should be supported on your system. + +You can compare $s1 and $s2 above with + + $s1 le $s2 + +to extract the data itself, you'll need a dereference: $$s1 + +This uses POSIX::setlocale The basic collation conversion is done by +strxfrm() which terminates at NUL characters being a decent C routine. +collate_xfrm() handles embedded NUL characters gracefully. Due to C<cmp> +and overload magic, C<lt>, C<le>, C<eq>, C<ge>, and C<gt> work also. The +available locales depend on your operating system; try whether C<locale +-a> shows them or the more direct approach C<ls /usr/lib/nls/loc> or C<ls +/usr/lib/nls>. The locale names are probably something like +"xx_XX.(ISO)?8859-N". diff --git a/pod/modpods/Config.pod b/pod/modpods/Config.pod new file mode 100644 index 0000000000..141fb67393 --- /dev/null +++ b/pod/modpods/Config.pod @@ -0,0 +1,40 @@ +=head1 NAME + +Config - access Perl configuration option + +=head1 SYNOPSIS + + use Config; + if ($Config{'cc'} =~ /gcc/) { + print "built by gcc\n"; + } + +=head1 DESCRIPTION + +The Config module contains everything that was available to the +C<Configure> program at Perl build time. Shell variables from +F<config.sh> are stored in the readonly-variable C<%Config>, indexed by +their names. + +=head1 EXAMPLE + +Here's a more sophisticated example of using %Config: + + use Config; + + defined $Config{sig_name} || die "No sigs?"; + foreach $name (split(' ', $Config{sig_name})) { + $signo{$name} = $i; + $signame[$i] = $name; + $i++; + } + + print "signal #17 = $signame[17]\n"; + if ($signo{ALRM}) { + print "SIGALRM is $signo{ALRM}\n"; + } + +=head1 NOTE + +This module contains a good example of how to make a variable +readonly to those outside of it. diff --git a/pod/modpods/Cwd.pod b/pod/modpods/Cwd.pod new file mode 100644 index 0000000000..ac4e24f74d --- /dev/null +++ b/pod/modpods/Cwd.pod @@ -0,0 +1,26 @@ +=head1 NAME + +getcwd - get pathname of current working directory + +=head1 SYNOPSIS + + require Cwd; + $dir = Cwd::getcwd()' + + use Cwd; + $dir = getcwd()' + + use Cwd 'chdir'; + chdir "/tmp"; + print $ENV{'PWD'}; + +=head1 DESCRIPTION + +The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions +in Perl. If you ask to override your chdir() built-in function, then your +PWD environment variable will be kept up to date. (See +L<perlsub/Overriding builtin functions>.) + +The fastgetcwd() function looks the same as getcwd(), but runs faster. +It's also more dangerous because you might conceivably chdir() out of a +directory that you can't chdir() back into. diff --git a/pod/modpods/DB_File.pod b/pod/modpods/DB_File.pod new file mode 100644 index 0000000000..919743b7ca --- /dev/null +++ b/pod/modpods/DB_File.pod @@ -0,0 +1,319 @@ +=head1 NAME + +DB_File - Perl5 access to Berkeley DB + +=head1 SYNOPSIS + + use DB_File ; + + [$X =] tie %hash, DB_File, $filename [, $flags, $mode, $DB_HASH] ; + [$X =] tie %hash, DB_File, $filename, $flags, $mode, $DB_BTREE ; + [$X =] tie @array, DB_File, $filename, $flags, $mode, $DB_RECNO ; + + $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 ; + +=head1 DESCRIPTION + +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. + +Berkeley DB is a C library which provides a consistent interface to a number of +database formats. +B<DB_File> provides an interface to all three of the database types currently +supported by Berkeley DB. + +The file types are: + +=over 5 + +=item 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 other packages mentioned. + +A default hashing algorithm, which will be adequate for most applications, +is built into Berkeley DB. +If you do need to use your own hashing algorithm it is possible to write your +own in Perl and have B<DB_File> use it instead. + +=item 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 and DB_BTREE. +In this case the key will consist of a record (line) number. + +=back + +=head2 How does DB_File interface to Berkeley DB? + +B<DB_File> allows access to Berkeley DB files using the tie() mechanism +in Perl 5 (for full details, see L<perlfunc/tie()>). +This facility allows B<DB_File> to access Berkeley DB files using +either an associative array (for DB_HASH & DB_BTREE file types) or an +ordinary array (for the DB_RECNO file type). + +In addition to the tie() interface, it is also possible to 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(). + + DB* + dbopen (const char * file, int flags, int mode, + DBTYPE type, const void * openinfo) + +The parameter C<type> is an enumeration which specifies which of the 3 +interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used. +Depending on which of these is actually chosen, the final parameter, +I<openinfo> points to a data structure which allows tailoring of the +specific interface method. + +This interface is handled +slightly differently in B<DB_File>. Here is an equivalent call using +B<DB_File>. + + tie %array, DB_File, $filename, $flags, $mode, $DB_HASH ; + +The C<filename>, C<flags> and C<mode> parameters are the direct equivalent +of their dbopen() counterparts. The final parameter $DB_HASH +performs the function of both the C<type> and C<openinfo> +parameters in dbopen(). + +In the example above $DB_HASH is actually a 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 + +Berkeley DB allows the creation of in-memory databases by using NULL (that is, a +C<(char *)0 in C) in +place of the filename. +B<DB_File> uses C<undef> instead of NULL to provide this functionality. + + +=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 + +=head1 EXAMPLES + +It is always a lot easier to understand something when you see a real example. +So here are a few. + +=head2 Using HASH + + use DB_File ; + use Fcntl ; + + tie %h, DB_File, "hashed", O_RDWR|O_CREAT, 0640, $DB_HASH ; + + # 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. + + mouse + Smith + Wall + + +=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 ; + + + +=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. + +=head1 BUGS + +Some older versions of Berkeley DB had problems with fixed length records +using the RECNO file format. The newest version at the time of writing +was 1.85 - this seems to have fixed the problems with RECNO. + +I am sure there are bugs in the code. If you do find any, or can suggest any +enhancements, I would welcome your comments. + +=head1 AVAILABILITY + +Berkeley DB is available via the hold C<ftp.cs.berkeley.edu> in the +directory C</ucb/4bsd/db.tar.gz>. It is I<not> under the GPL. + +=head1 SEE ALSO + +L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> + +Berkeley DB is available from F<ftp.cs.berkeley.edu> in the directory F</ucb/4bsd>. + +=head1 AUTHOR + +The DB_File interface was written by +Paul Marquess <pmarquess@bfsec.bt.co.uk>. +Questions about the DB system itself may be addressed to +Keith Bostic <bostic@cs.berkeley.edu>. diff --git a/pod/modpods/Dynaloader.pod b/pod/modpods/Dynaloader.pod new file mode 100644 index 0000000000..9810dad205 --- /dev/null +++ b/pod/modpods/Dynaloader.pod @@ -0,0 +1,316 @@ +=head1 NAME + +DynaLoader - Dynamically load C libraries into Perl code + +dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl_undef_symbols(), dl_install_xsub(), boostrap() - routines used by DynaLoader modules + +=head1 SYNOPSIS + + require DynaLoader; + push (@ISA, 'DynaLoader'); + + +=head1 DESCRIPTION + +This specification defines a standard generic interface to the dynamic +linking mechanisms available on many platforms. Its primary purpose is +to implement automatic dynamic loading of Perl modules. + +The DynaLoader is designed to be a very simple high-level +interface that is sufficiently general to cover the requirements +of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. + +It is also hoped that the interface will cover the needs of OS/2, +NT etc and allow pseudo-dynamic linking (using C<ld -A> at runtime). + +This document serves as both a specification for anyone wishing to +implement the DynaLoader for a new platform and as a guide for +anyone wishing to use the DynaLoader directly in an application. + +It must be stressed that the DynaLoader, by itself, is practically +useless for accessing non-Perl libraries because it provides almost no +Perl-to-C 'glue'. There is, for example, no mechanism for calling a C +library function or supplying arguments. It is anticipated that any +glue that may be developed in the future will be implemented in a +separate dynamically loaded module. + +DynaLoader Interface Summary + + @dl_library_path + @dl_resolve_using + @dl_require_symbols + $dl_debug + Implemented in: + bootstrap($modulename) Perl + @filepaths = dl_findfile(@names) Perl + + $libref = dl_load_file($filename) C + $symref = dl_find_symbol($libref, $symbol) C + @symbols = dl_undef_symbols() C + dl_install_xsub($name, $symref [, $filename]) C + $message = dl_error C + +=over 4 + +=item @dl_library_path + +The standard/default list of directories in which dl_findfile() will +search for libraries etc. Directories are searched in order: +$dl_library_path[0], [1], ... etc + +@dl_library_path is initialised to hold the list of 'normal' directories +(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}.). This should +ensure portability across a wide range of platforms. + +@dl_library_path should also be initialised with any other directories +that can be determined from the environment at runtime (such as +LD_LIBRARY_PATH for SunOS). + +After initialisation @dl_library_path can be manipulated by an +application using push and unshift before calling dl_findfile(). +Unshift can be used to add directories to the front of the search order +either to save search time or to override libraries with the same name +in the 'normal' directories. + +The load function that dl_load_file() calls may require an absolute +pathname. The dl_findfile() function and @dl_library_path can be +used to search for and return the absolute pathname for the +library/object that you wish to load. + +=item @dl_resolve_using + +A list of additional libraries or other shared objects which can be +used to resolve any undefined symbols that might be generated by a +later call to load_file(). + +This is only required on some platforms which do not handle dependent +libraries automatically. For example the Socket Perl extension library +(F<auto/Socket/Socket.so>) contains references to many socket functions +which need to be resolved when it's loaded. Most platforms will +automatically know where to find the 'dependent' library (e.g., +F</usr/lib/libsocket.so>). A few platforms need to to be told the location +of the dependent library explicitly. Use @dl_resolve_using for this. + +Example usage: + + @dl_resolve_using = dl_findfile('-lsocket'); + +=item @dl_require_symbols + +A list of one or more symbol names that are in the library/object file +to be dynamically loaded. This is only required on some platforms. + +=item dl_error() + +Syntax: + + $message = dl_error(); + +Error message text from the last failed DynaLoader function. Note +that, similar to errno in unix, a successful function call does not +reset this message. + +Implementations should detect the error as soon as it occurs in any of +the other functions and save the corresponding message for later +retrieval. This will avoid problems on some platforms (such as SunOS) +where the error message is very temporary (e.g., dlerror()). + +=item $dl_debug + +Internal debugging messages are enabled when $dl_debug is set true. +Currently setting $dl_debug only affects the Perl side of the +DynaLoader. These messages should help an application developer to +resolve any DynaLoader usage problems. + +$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined. + +For the DynaLoader developer/porter there is a similar debugging +variable added to the C code (see dlutils.c) and enabled if Perl was +built with the B<-DDEBUGGING> flag. This can also be set via the +PERL_DL_DEBUG environment variable. Set to 1 for minimal information or +higher for more. + +=item dl_findfile() + +Syntax: + + @filepaths = dl_findfile(@names) + +Determine the full paths (including file suffix) of one or more +loadable files given their generic names and optionally one or more +directories. Searches directories in @dl_library_path by default and +returns an empty list if no files were found. + +Names can be specified in a variety of platform independent forms. Any +names in the form B<-lname> are converted into F<libname.*>, where F<.*> is +an appropriate suffix for the platform. + +If a name does not already have a suitable prefix and/or suffix then +the corresponding file will be searched for by trying combinations of +prefix and suffix appropriate to the platform: "$name.o", "lib$name.*" +and "$name". + +If any directories are included in @names they are searched before +@dl_library_path. Directories may be specified as B<-Ldir>. Any other names +are treated as filenames to be searched for. + +Using arguments of the form C<-Ldir> and C<-lname> is recommended. + +Example: + + @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); + + +=item dl_expandspec() + +Syntax: + + $filepath = dl_expandspec($spec) + +Some unusual systems, such as VMS, require special filename handling in +order to deal with symbolic names for files (i.e., VMS's Logical Names). + +To support these systems a dl_expandspec() function can be implemented +either in the F<dl_*.xs> file or code can be added to the autoloadable +dl_expandspec(0 function in F<DynaLoader.pm). See F<DynaLoader.pm> for more +information. + +=item dl_load_file() + +Syntax: + + $libref = dl_load_file($filename) + +Dynamically load $filename, which must be the path to a shared object +or library. An opaque 'library reference' is returned as a handle for +the loaded object. Returns undef on error. + +(On systems that provide a handle for the loaded object such as SunOS +and HPUX, $libref will be that handle. On other systems $libref will +typically be $filename or a pointer to a buffer containing $filename. +The application should not examine or alter $libref in any way.) + +This is function that does the real work. It should use the current +values of @dl_require_symbols and @dl_resolve_using if required. + + SunOS: dlopen($filename) + HP-UX: shl_load($filename) + Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) + NeXT: rld_load($filename, @dl_resolve_using) + VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) + + +=item dl_find_symbol() + +Syntax: + + $symref = dl_find_symbol($libref, $symbol) + +Return the address of the symbol $symbol or C<undef> if not found. If the +target system has separate functions to search for symbols of different +types then dl_find_symbol() should search for function symbols first and +then other types. + +The exact manner in which the address is returned in $symref is not +currently defined. The only initial requirement is that $symref can +be passed to, and understood by, dl_install_xsub(). + + SunOS: dlsym($libref, $symbol) + HP-UX: shl_findsym($libref, $symbol) + Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) + NeXT: rld_lookup("_$symbol") + VMS: lib$find_image_symbol($libref,$symbol) + + +=item dl_undef_symbols() + +Example + + @symbols = dl_undef_symbols() + +Return a list of symbol names which remain undefined after load_file(). +Returns C<()> if not known. Don't worry if your platform does not provide +a mechanism for this. Most do not need it and hence do not provide it. + + +=item dl_install_xsub() + +Syntax: + + dl_install_xsub($perl_name, $symref [, $filename]) + +Create a new Perl external subroutine named $perl_name using $symref as +a pointer to the function which implements the routine. This is simply +a direct call to newXSUB(). Returns a reference to the installed +function. + +The $filename parameter is used by Perl to identify the source file for +the function if required by die(), caller() or the debugger. If +$filename is not defined then "DynaLoader" will be used. + + +=item boostrap() + +Syntax: + +bootstrap($module) + +This is the normal entry point for automatic dynamic loading in Perl. + +It performs the following actions: + +=over 8 + +=item * + +locates an auto/$module directory by searching @INC + +=item * + +uses dl_findfile() to determine the filename to load + +=item * + +sets @dl_require_symbols to C<("boot_$module")> + +=item * + +executes an F<auto/$module/$module.bs> file if it exists +(typically used to add to @dl_resolve_using any files which +are required to load the module on the current platform) + +=item * + +calls dl_load_file() to load the file + +=item * + +calls dl_undef_symbols() and warns if any symbols are undefined + +=item * + +calls dl_find_symbol() for "boot_$module" + +=item * + +calls dl_install_xsub() to install it as "${module}::bootstrap" + +=item * + +calls &{"${module}::bootstrap"} to bootstrap the module + +=back + +=back + + +=head1 AUTHOR + +This interface is based on the work and comments of (in no particular +order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno +Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, and others. + +Larry Wall designed the elegant inherited bootstrap mechanism and +implemented the first Perl 5 dynamic loader using it. + +Tim Bunce, 11 August 1994. diff --git a/pod/modpods/English.pod b/pod/modpods/English.pod new file mode 100644 index 0000000000..d6b26beaf2 --- /dev/null +++ b/pod/modpods/English.pod @@ -0,0 +1,24 @@ +=head1 NAME + +English - use nice English (or awk) names for ugly punctuation variables + +=head1 SYNOPSIS + + use English; + ... + if ($ERRNO =~ /denied/) { ... } + +=head1 DESCRIPTION + +This module provides aliases for the built-in variables whose +names no one seems to like to read. Variables with side-effects +which get triggered just by accessing them (like $0) will still +be affected. + +For those variables that have an B<awk> version, both long +and short English alternatives are provided. For example, +the C<$/> variable can be referred to either $RS or +$INPUT_RECORD_SEPARATOR if you are using the English module. + +See L<perlvar> for a complete list of these. + diff --git a/pod/modpods/Env.pod b/pod/modpods/Env.pod new file mode 100644 index 0000000000..44344998bd --- /dev/null +++ b/pod/modpods/Env.pod @@ -0,0 +1,31 @@ +=head1 NAME + +Env - Perl module that imports environment variables + +=head1 DESCRIPTION + +Perl maintains environment variables in a pseudo-associative-array +named %ENV. For when this access method is inconvenient, the Perl +module C<Env> allows environment variables to be treated as simple +variables. + +The Env::import() function ties environment variables with suitable +names to global Perl variables with the same names. By default it +does so with all existing environment variables (C<keys %ENV>). If +the import function receives arguments, it takes them to be a list of +environment variables to tie; it's okay if they don't yet exist. + +After an environment variable is tied, merely use it like a normal variable. +You may access its value + + @path = split(/:/, $PATH); + +or modify it + + $PATH .= ":."; + +however you'd like. +To remove a tied environment variable from +the environment, assign it the undefined value + + undef $PATH; diff --git a/pod/modpods/Exporter.pod b/pod/modpods/Exporter.pod new file mode 100644 index 0000000000..03e6a1c92d --- /dev/null +++ b/pod/modpods/Exporter.pod @@ -0,0 +1,60 @@ +=head1 NAME + +Exporter - module to control namespace manipulations + +import - import functions into callers namespace + +=head1 SYNOPSYS + + package WhatEver; + require Exporter; + @ISA = (Exporter); + @EXPORT = qw(func1, $foo, %tabs); + @EXPORT_OK = qw(sin cos); + ... + use Whatever; + use WhatEver 'sin'; + +=head1 DESCRIPTION + +The Exporter module is used by well-behaved Perl modules to +control what they will export into their user's namespace. +The WhatEver module above has placed in its export list +the function C<func1()>, the scalar C<$foo>, and the +hash C<%tabs>. When someone decides to +C<use WhatEver>, they get those identifier grafted +onto their own namespace. That means the user of +package whatever can use the function func1() instead +of fully qualifying it as WhatEver::func1(). + +You should be careful of such namespace pollution. +Of course, the user of the WhatEver module is free to +use a C<require> instead of a C<use>, which will +preserve the sanctity of their namespace. + +In particular, you almost certainly shouldn't +automatically export functions whose names are +already used in the language. For this reason, +the @EXPORT_OK list contains those function which +may be selectively imported, as the sin() function +was above. +See L<perlsub/Overriding builtin functions>. + +You can't import names that aren't in either the @EXPORT +or the @EXPORT_OK list. + +Remember that these two constructs are identical: + + use WhatEver; + + BEGIN { + require WhatEver; + import Module; + } + +The import() function above is not predefined in the +language. Rather, it's a method in the Exporter module. +A sneaky library writer could conceivably have an import() +method that behaved differently from the standard one, but +that's not very friendly. + diff --git a/pod/modpods/Fcntl.pod b/pod/modpods/Fcntl.pod new file mode 100644 index 0000000000..165153e475 --- /dev/null +++ b/pod/modpods/Fcntl.pod @@ -0,0 +1,20 @@ +=head1 NAME + +Fcntl - load the C Fcntl.h defines + +=head1 SYNOPSIS + + use Fcntl; + +=head1 DESCRIPTION + +This module is just a translation of the C F<fnctl.h> file. +Unlike the old mechanism of requiring a translated F<fnctl.ph> +file, this uses the B<h2xs> program (see the Perl source distribution) +and your native C compiler. This means that it has a +far more likely chance of getting the numbers right. + +=head1 NOTE + +Only C<#define> symbols get translated; you must still correctly +pack up your own arguments to pass as args for locking functions, etc. diff --git a/pod/modpods/FileHandle.pod b/pod/modpods/FileHandle.pod new file mode 100644 index 0000000000..d595617973 --- /dev/null +++ b/pod/modpods/FileHandle.pod @@ -0,0 +1,46 @@ +=head1 NAME + +FileHandle - supply object methods for filehandles + +cacheout - keep more files open than the system permits + +=head1 SYNOPSIS + + use FileHandle; + autoflush STDOUT 1; + + cacheout($path); + print $path @data; + +=head1 DESCRIPTION + +See L<perlvar> for complete descriptions of each of the following supported C<FileHandle> +methods: + + print + 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 + +The cacheout() function will make sure that there's a filehandle +open for writing available as the pathname you give it. It automatically +closes and re-opens files if you exceed your system file descriptor maximum. + +=head1 BUGS + +F<sys/param.h> lies with its C<NOFILE> define on some systems, +so you may have to set $cacheout::maxopen yourself. + +Due to backwards compatibility, all filehandles resemble objects +of class C<FileHandle>, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C<FileHandle> and inherit those methods. diff --git a/pod/modpods/Find.pod b/pod/modpods/Find.pod new file mode 100644 index 0000000000..81b46a9879 --- /dev/null +++ b/pod/modpods/Find.pod @@ -0,0 +1,44 @@ +=head1 NAME + +find - traverse a file tree + +=head1 SYNOPSYS + + use File::Find; + find(\&wanted, '/foo','/bar'); + sub wanted { ... } + +=head1 DESCRIPTION + +The wanted() function does whatever verificationsyou want. $dir contains +the current directory name, and $_ the current filename within that +directory. $name contains C<"$dir/$_">. You are chdir()'d to $dir when +the function is called. The function may set $prune to prune the tree. + +This library is primarily for the C<find2perl> tool, which when fed, + + find2perl / -name .nfs\* -mtime +7 \ + -exec rm -f {} \; -o -fstype nfs -prune + +produces something like: + + sub wanted { + /^\.nfs.*$/ && + (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && + int(-M _) > 7 && + unlink($_) + || + ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && + $dev < 0 && + ($prune = 1); + } + +Set the variable $dont_use_nlink if you're using AFS, since AFS cheats. + +Here's another interesting wanted function. It will find all symlinks +that don't resolve: + + sub wanted { + -l && !-e && print "bogus link: $name\n"; + } + diff --git a/pod/modpods/Finddepth.pod b/pod/modpods/Finddepth.pod new file mode 100644 index 0000000000..022ddaf9f4 --- /dev/null +++ b/pod/modpods/Finddepth.pod @@ -0,0 +1,16 @@ +=head1 NAME + +finddepth - traverse a directory structure depth-first + +=head1 SYNOPSYS + + use File::Finddepth; + finddepth(\&wanted, '/foo','/bar'); + sub wanted { ... } + +=head2 DESCRIPTION + +This is just like C<File::Find>, except that it does a depthfirst +search uses finddepth() rather than find(), and performs a +depth-first search. + diff --git a/pod/modpods/GetOptions.pod b/pod/modpods/GetOptions.pod new file mode 100644 index 0000000000..ca64639968 --- /dev/null +++ b/pod/modpods/GetOptions.pod @@ -0,0 +1,137 @@ +=head1 NAME + +Getopt::Long, GetOptions - extended getopt processing + +=head1 SYNOPSIS + + use Getopt::Long; + $result = GetOptions (...option-descriptions...); + +=head1 DESCRIPTION + +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. + +Each description should designate a valid Perl identifier, optionally +followed by an argument specifier. + +Values for argument specifiers are: + + <none> option does not take an argument + ! option does not take an argument and may be negated + =s :s option takes a mandatory (=) or optional (:) string argument + =i :i option takes a mandatory (=) or optional (:) integer argument + =f :f option takes a mandatory (=) or optional (:) real number argument + +If option "name" is set, it will cause the Perl variable $opt_name to +be set to the specified value. The calling program can use this +variable to detect whether the option has been set. Options that do +not take an argument will be set to 1 (one). + +Options that take an optional argument will be defined, but set to '' +if no actual argument has been supplied. + +If an "@" sign is appended to the argument specifier, the option is +treated as an array. Value(s) are not set, but pushed into array +@opt_name. + +Options that do not take a value may have an "!" argument spacifier to +indicate that they may be negated. E.g. "foo!" will allow B<-foo> (which +sets $opt_foo to 1) and B<-nofoo> (which will set $opt_foo to 0). + +The option name may actually be a list of option names, separated by +'|'s, e.g. B<"foo|bar|blech=s". In this example, options 'bar' and +'blech' will set $opt_foo instead. + +Option names may be abbreviated to uniqueness, depending on +configuration variable $autoabbrev. + +Dashes in option names are allowed (e.g. pcc-struct-return) and will +be translated to underscores in the corresponding Perl variable (e.g. +$opt_pcc_struct_return). Note that a lone dash "-" is considered an +option, corresponding Perl identifier is $opt_ . + +A double dash "--" signals end of the options list. + +If the first option of the list consists of non-alphanumeric +characters only, it is interpreted as a generic option starter. +Everything starting with one of the characters from the starter will +be considered an option. + +The default values for the option starters are "-" (traditional), "--" +(POSIX) and "+" (GNU, being phased out). + +Options that start with "--" may have an argument appended, separated +with an "=", e.g. "--foo=bar". + +If configuration varaible $getopt_compat is set to a non-zero value, +options that start with "+" may also include their arguments, +e.g. "+foo=bar". + +A return status of 0 (false) indicates that the function detected +one or more errors. + +=head1 EXAMPLES + +If option "one:i" (i.e. takes an optional integer argument), then +the following situations are handled: + + -one -two -> $opt_one = '', -two is next option + -one -2 -> $opt_one = -2 + +Also, assume "foo=s" and "bar:s" : + + -bar -xxx -> $opt_bar = '', '-xxx' is next option + -foo -bar -> $opt_foo = '-bar' + -foo -- -> $opt_foo = '--' + +In GNU or POSIX format, option names and values can be combined: + + +foo=blech -> $opt_foo = 'blech' + --bar= -> $opt_bar = '' + --bar=-- -> $opt_bar = '--' + +=over 12 + +=item $autoabbrev + +Allow option names to be abbreviated to uniqueness. +Default is 1 unless environment variable +POSIXLY_CORRECT has been set. + +=item $getopt_compat + +Allow '+' to start options. +Default is 1 unless environment variable +POSIXLY_CORRECT has been set. + +=item $option_start + +Regexp with option starters. +Default is (--|-) if environment variable +POSIXLY_CORRECT has been set, (--|-|\+) otherwise. + +=item $order + +Whether non-options are allowed to be mixed with +options. +Default is $REQUIRE_ORDER if environment variable +POSIXLY_CORRECT has been set, $PERMUTE otherwise. + +=item $ignorecase + +Ignore case when matching options. Default is 1. + +=item $debug + +Enable debugging output. Default is 0. + +=back + +=head1 NOTE + +Does not yet use the Exporter--or even packages!! +Thus, it's not a real module. + diff --git a/pod/modpods/Getopt.pod b/pod/modpods/Getopt.pod new file mode 100644 index 0000000000..2f607257ba --- /dev/null +++ b/pod/modpods/Getopt.pod @@ -0,0 +1,152 @@ +=head1 NAME + +getopt - Process single-character switches with switch clustering + +getopts - Process single-character switches with switch clustering + +GetOptions - extended getopt processing + +=head1 SYNOPSIS + + use Getopt::Std; + getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + getopts('oif:'); # likewise, but all of them + + use Getopt::Long; + $result = GetOptions (...option-descriptions...); + +=head1 DESCRIPTION + +The getopt() functions processes single-character switches with switch +clustering. Pass one argument which is a string containing all switches +that take an argument. For each switch found, sets $opt_x (where x is the +switch name) to the value of the argument, or 1 if no argument. Switches +which take an argument don't care whether there is a space between the +switch and the argument. + +The Getopt::Long module implements an extended getopt function called +GetOptions(). 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. + +Each description should designate a valid Perl identifier, optionally +followed by an argument specifier. + +Values for argument specifiers are: + + <none> option does not take an argument + ! option does not take an argument and may be negated + =s :s option takes a mandatory (=) or optional (:) string argument + =i :i option takes a mandatory (=) or optional (:) integer argument + =f :f option takes a mandatory (=) or optional (:) real number argument + +If option "name" is set, it will cause the Perl variable $opt_name to +be set to the specified value. The calling program can use this +variable to detect whether the option has been set. Options that do +not take an argument will be set to 1 (one). + +Options that take an optional argument will be defined, but set to '' +if no actual argument has been supplied. + +If an "@" sign is appended to the argument specifier, the option is +treated as an array. Value(s) are not set, but pushed into array +@opt_name. + +Options that do not take a value may have an "!" argument specifier to +indicate that they may be negated. E.g. "foo!" will allow B<-foo> (which +sets $opt_foo to 1) and B<-nofoo> (which will set $opt_foo to 0). + +The option name may actually be a list of option names, separated by +'|'s, e.g. B<"foo|bar|blech=s". In this example, options 'bar' and +'blech' will set $opt_foo instead. + +Option names may be abbreviated to uniqueness, depending on +configuration variable $autoabbrev. + +Dashes in option names are allowed (e.g. pcc-struct-return) and will +be translated to underscores in the corresponding Perl variable (e.g. +$opt_pcc_struct_return). Note that a lone dash "-" is considered an +option, corresponding Perl identifier is $opt_ . + +A double dash "--" signals end of the options list. + +If the first option of the list consists of non-alphanumeric +characters only, it is interpreted as a generic option starter. +Everything starting with one of the characters from the starter will +be considered an option. + +The default values for the option starters are "-" (traditional), "--" +(POSIX) and "+" (GNU, being phased out). + +Options that start with "--" may have an argument appended, separated +with an "=", e.g. "--foo=bar". + +If configuration variable $getopt_compat is set to a non-zero value, +options that start with "+" may also include their arguments, +e.g. "+foo=bar". + +A return status of 0 (false) indicates that the function detected +one or more errors. + +=head1 EXAMPLES + +If option "one:i" (i.e. takes an optional integer argument), then +the following situations are handled: + + -one -two -> $opt_one = '', -two is next option + -one -2 -> $opt_one = -2 + +Also, assume "foo=s" and "bar:s" : + + -bar -xxx -> $opt_bar = '', '-xxx' is next option + -foo -bar -> $opt_foo = '-bar' + -foo -- -> $opt_foo = '--' + +In GNU or POSIX format, option names and values can be combined: + + +foo=blech -> $opt_foo = 'blech' + --bar= -> $opt_bar = '' + --bar=-- -> $opt_bar = '--' + +=over 12 + +=item $autoabbrev + +Allow option names to be abbreviated to uniqueness. +Default is 1 unless environment variable +POSIXLY_CORRECT has been set. + +=item $getopt_compat + +Allow '+' to start options. +Default is 1 unless environment variable +POSIXLY_CORRECT has been set. + +=item $option_start + +Regexp with option starters. +Default is (--|-) if environment variable +POSIXLY_CORRECT has been set, (--|-|\+) otherwise. + +=item $order + +Whether non-options are allowed to be mixed with +options. +Default is $REQUIRE_ORDER if environment variable +POSIXLY_CORRECT has been set, $PERMUTE otherwise. + +=item $ignorecase + +Ignore case when matching options. Default is 1. + +=item $debug + +Enable debugging output. Default is 0. + +=back + +=head1 NOTE + +Does not yet use the Exporter--or even packages!! +Thus, it's not a real module. + diff --git a/pod/modpods/MakeMaker.pod b/pod/modpods/MakeMaker.pod new file mode 100644 index 0000000000..4db758fb20 --- /dev/null +++ b/pod/modpods/MakeMaker.pod @@ -0,0 +1,24 @@ +=head1 NAME + +MakeMaker - generate a Makefile for Perl extension + +=head1 SYNOPSIS + + use ExtUtils::MakeMaker; + +=head1 DESCRIPTION + +This utility is designed to write a Makefile for an extension module from +a Makefile.PL. It splits the task of generating the Makefile into several +subroutines that can be individually overridden. Each subroutines returns +the text it wishes to have written to the Makefile. + +The best way to learn to use this is to look at how some of the +extensions are generated, such as Socket. + +=head1 AUTHOR + +Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, +Andreas Koenig <F<k@franz.ww.TU-Berlin.DE>>, +and +Tim Bunce <F<Tim.Bunce@ig.co.uk>>. diff --git a/pod/modpods/Open2.pod b/pod/modpods/Open2.pod new file mode 100644 index 0000000000..19f0369cfd --- /dev/null +++ b/pod/modpods/Open2.pod @@ -0,0 +1,33 @@ +=head1 NAME + +IPC::Open2, open2 - open a process for both reading and writing + +=head1 SYNOPSIS + + use IPC::Open2; + $pid = open2('rdr', 'wtr', 'some cmd and args'); + # or + $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); + +=head1 DESCRIPTION + +The open2() function spawns the given $cmd and connects $rdr for +reading and $wtr for writing. It's what you think should work +when you try + + open(HANDLE, "|cmd args"); + +open2() returns the process ID of the child process. It doesn't return on +failure: it just raises an exception matching C</^open2:/>. + +=head1 WARNING + +It will not create these file handles for you. You have to do this yourself. +So don't pass it empty variables expecting them to get filled in for you. + +Additionally, this is very dangerous as you may block forever. +It assumes it's going to talk to something like B<bc>, both writing to +it and reading from it. This is presumably safe because you "know" +that commands like B<bc> will read a line at a time and output a line at +a time. Programs like B<sort> that read their entire input stream first, +however, are quite apt to cause deadlock. See L<open3> for an alternative. diff --git a/pod/modpods/Open3.pod b/pod/modpods/Open3.pod new file mode 100644 index 0000000000..690d8ffdfb --- /dev/null +++ b/pod/modpods/Open3.pod @@ -0,0 +1,23 @@ +=head1 NAME + +IPC::Open3, open3 - open a process for reading, writing, and error handling + +=head1 SYNOPSIS + + $pid = open3('WTRFH', 'RDRFH', 'ERRFH' + 'some cmd and args', 'optarg', ...); + +=head1 DESCRIPTION + +Extremely similar to open2(), open3() spawns the given $cmd and +connects RDRFH for reading, WTRFH for writing, and ERRFH for errors. If +ERRFH is '', or the same as RDRFH, then STDOUT and STDERR of the child are +on the same file handle. + +If WTRFH begins with ">&", then WTRFH will be closed in the parent, and +the child will read from it directly. if RDRFH or ERRFH begins with +">&", then the child will send output directly to that file handle. In both +cases, there will be a dup(2) instead of a pipe(2) made. + +All caveats from open2() continue to apply. See L<open2> for details. + diff --git a/pod/modpods/POSIX.pod b/pod/modpods/POSIX.pod new file mode 100644 index 0000000000..30539ad36f --- /dev/null +++ b/pod/modpods/POSIX.pod @@ -0,0 +1,53 @@ +=head1 NAME + +POSIX - Perl interface to IEEE 1003.1 namespace + +=head1 SYNOPSIS + + use POSIX; + use POSIX 'strftime'; + +=head1 DESCRIPTION + +The POSIX module permits you to access all (or nearly all) the standard +POSIX 1003.1 identifiers. Things which are C<#defines> in C, like EINTR +or O_NDELAY, are automatically exported into your namespace. All +functions are only exported if you ask for them explicitly. Most likely +people will prefer to use the fully-qualified function names. + +To get a list of all the possible identifiers available to you--and +their semantics--you should pick up a 1003.1 spec, or look in the +F<POSIX.pm> module. + +=head1 EXAMPLES + + printf "EENTR is %d\n", EINTR; + + POSIX::setsid(0); + + $fd = POSIX::open($path, O_CREAT|O_EXCL|O_WRONLY, 0644); + # note: that's a filedescriptor, *NOT* a filehandle + +=head1 NOTE + +The POSIX module is probably the most complex Perl module supplied with +the standard distribution. It incorporates autoloading, namespace games, +and dynamic loading of code that's in Perl, C, or both. It's a great +source of wisdom. + +=head1 CAVEATS + +A few functions are not implemented because they are C specific. If you +attempt to call these, they will print a message telling you that they +aren't implemented because they're, supplying the Perl equivalent if one +exists. For example, trying to access the setjmp() call will elicit the +message "setjmp() is C-specific: use eval {} instead". + +Furthermore, some evil vendors will claim 1003.1 compliance, but in fact +are not so: they will not pass the PCTS (POSIX Compliance Test Suites). +For example, one vendor may not define EDEADLK, or the semantics of the +errno values set by open(2) might not be quite right. Perl does not +attempt to verify POSIX compliance. That means you can currently +successfully say "use POSIX", and then later in your program you find +that your vendor has been lax and there's no usable ICANON macro after +all. This could be construed to be a bug. diff --git a/pod/modpods/Ping.pod b/pod/modpods/Ping.pod new file mode 100644 index 0000000000..01bc25c64f --- /dev/null +++ b/pod/modpods/Ping.pod @@ -0,0 +1,37 @@ +=head1 NAME + +Net::Ping, pingecho - check a host for upness + +=head1 SYNOPSIS + + use Net::Ping; + print "'jimmy' is alive and kicking\n" if pingecho('jimmy', 10) ; + +=head1 DESCRIPTION + +This module contains routines to test for the reachability of remote hosts. +Currently the only routine implemented is pingecho(). + +pingecho() uses a TCP echo (I<NOT> an ICMP one) to determine if the +remote host is reachable. This is usually adequate to tell that a remote +host is available to rsh(1), ftp(1), or telnet(1) onto. + +=head2 Parameters + +=over 5 + +=item hostname + +The remote host to check, specified either as a hostname or as an IP address. + +=item timeout + +The timeout in seconds. If not specified it will default to 5 seconds. + +=back + +=head1 WARNING + +pingecho() uses alarm to implement the timeout, so don't set another alarm +while you are using it. + diff --git a/pod/modpods/Socket.pod b/pod/modpods/Socket.pod new file mode 100644 index 0000000000..7dfab25b26 --- /dev/null +++ b/pod/modpods/Socket.pod @@ -0,0 +1,23 @@ +=head1 NAME + +Socket - load the C socket.h defines + +=head1 SYNOPSIS + + use Socket; + + $proto = (getprotobyname('udp'))[2]; + socket(Socket_Handle, PF_INET, SOCK_DGRAM, $proto); + +=head1 DESCRIPTION + +This module is just a translation of the C F<socket.h> file. +Unlike the old mechanism of requiring a translated F<socket.ph> +file, this uses the B<h2xs> program (see the Perl source distribution) +and your native C compiler. This means that it has a +far more likely chance of getting the numbers right. + +=head1 NOTE + +Only C<#define> symbols get translated; you must still correctly +pack up your own arguments to pass to bind(), etc. diff --git a/pod/modpods/integer.pod b/pod/modpods/integer.pod new file mode 100644 index 0000000000..d459bca385 --- /dev/null +++ b/pod/modpods/integer.pod @@ -0,0 +1,18 @@ +=head1 NAME + +integer - Perl pragma to compute arithmetic in integer instead of double + +=head1 SYNOPSIS + + use integer; + $x = 10/3; + # $x is now 3, not 3.33333333333333333 + +=head1 DESCRIPTION + +This tells the compiler that it's okay to use integer operations +from here to the end of the enclosing BLOCK. On many machines, +this doesn't matter a great deal for most computations, but on those +without floating point hardware, it can make a big difference. + +See L<perlmod/Pragmatic Modules>. diff --git a/pod/modpods/less.pod b/pod/modpods/less.pod new file mode 100644 index 0000000000..bccc5341d1 --- /dev/null +++ b/pod/modpods/less.pod @@ -0,0 +1,13 @@ +=head1 NAME + +less - Perl pragma to request less of something from the compiler + +=head1 DESCRIPTION + +Currently unimplemented, this may someday be a compiler directive +to make certain trade-off, such as perhaps + + use less 'memory'; + use less 'CPU'; + use less 'fat'; + diff --git a/pod/modpods/sigtrap.pod b/pod/modpods/sigtrap.pod new file mode 100644 index 0000000000..ecc35421cc --- /dev/null +++ b/pod/modpods/sigtrap.pod @@ -0,0 +1,19 @@ +=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>. diff --git a/pod/modpods/strict.pod b/pod/modpods/strict.pod new file mode 100644 index 0000000000..e994ed2bc5 --- /dev/null +++ b/pod/modpods/strict.pod @@ -0,0 +1,65 @@ +=head1 NAME + +strict - Perl pragma to restrict unsafe constructs + +=head1 SYNOPSIS + + use strict; + + use strict "vars"; + use strict "refs"; + use strict "subs"; + + use strict; + no strict "vars"; + +=head1 DESCRIPTION + +If no import list is supplied, all possible restrictions are assumed. +(This 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", or "refs". + +=over 6 + +=item C<strict refs> + +This generates a runtime error if you +use symbolic references (see L<perlref>). + + use strict 'refs'; + $ref = \$foo; + print $$ref; # ok + $ref = "foo"; + print $$ref; # runtime error; normally ok + +=item C<strict vars> + +This generates a compile-time error if you access a variable that wasn't +localized via C<my()> or wasn't fully qualified. Because this is to avoid +variable suicide problems and subtle dynamic scoping issues, a merely +local() variable isn't good enough. See L<perlfunc/my> and +L<perlfunc/local>. + + use strict 'vars'; + $X::foo = 1; # ok, fully qualified + my $foo = 10; # ok, my() var + local $foo = 9; # blows up + +The local() generated a compile-time error because you just touched a global +name without fully qualifying it. + +=item C<strict subs> + +This disables the poetry optimization, +generating a compile-time error if you +try to use a bareword identifiers that's not a subroutine. + + use strict 'subs'; + $SIG{PIPE} = Plumber; # blows up + $SIG{"PIPE"} = "Plumber"; # just fine + +=back + +See L<perlmod/Pragmatic Modules>. + diff --git a/pod/modpods/subs.pod b/pod/modpods/subs.pod new file mode 100644 index 0000000000..b54b6754ce --- /dev/null +++ b/pod/modpods/subs.pod @@ -0,0 +1,16 @@ +=head1 NAME + +subs - Perl pragma to predeclare sub names + +=head1 SYNOPSIS + + use subs qw(frob); + frob 3..10; + +=head1 DESCRIPTION + +This will predeclare all the subroutine whose names are +in the list, allowing you to use them without parentheses +even before they're declared. + +See L<perlmod/Pragmatic Modules> and L<strict/subs>. diff --git a/pod/perl.pod b/pod/perl.pod new file mode 100644 index 0000000000..9306d5c9c7 --- /dev/null +++ b/pod/perl.pod @@ -0,0 +1,271 @@ +=head1 NAME + +perl - Practical Extraction and Report Language + +=head1 SYNOPSIS + +For ease of access, the Perl manual has been split up into a number +of sections: + + perl Perl overview (this section) + perldata Perl data structures + perlsyn Perl syntax + perlop Perl operators and precedence + perlre Perl regular expressions + perlrun Perl execution and options + perlfunc Perl builtin functions + perlvar Perl predefined variables + perlsub Perl subroutines + perlmod Perl modules + perlref Perl references and nested data structures + perlobj Perl objects + perlbot Perl OO tricks and examples + perldebug Perl debugging + perldiag Perl diagnostic messages + perlform Perl formats + perlipc Perl interprocess communication + perlsec Perl security + perltrap Perl traps for the unwary + perlstyle Perl style guide + perlapi Perl application programming interface + perlguts Perl internal functions for those doing extensions + perlcall Perl calling conventions from C + perlovl Perl overloading semantics + perlbook Perl book information + +(If you're intending to read these straight through for the first time, +the suggested order will tend to reduce the number of forward references.) + +If something strange has gone wrong with your program and you're not +sure where you should look for help, try the B<-w> switch first. It +will often point out exactly where the trouble is. + +=head1 DESCRIPTION + +Perl is an interpreted language optimized for scanning arbitrary +text files, extracting information from those text files, and printing +reports based on that information. It's also a good language for many +system management tasks. The language is intended to be practical +(easy to use, efficient, complete) rather than beautiful (tiny, +elegant, minimal). It combines (in the author's opinion, anyway) some +of the best features of C, B<sed>, B<awk>, and B<sh>, so people +familiar with those languages should have little difficulty with it. +(Language historians will also note some vestiges of B<csh>, Pascal, +and even BASIC-PLUS.) Expression syntax corresponds quite closely to C +expression syntax. Unlike most Unix utilities, Perl does not +arbitrarily limit the size of your data--if you've got the memory, +Perl can slurp in your whole file as a single string. Recursion is +of unlimited depth. And the hash tables used by associative arrays +grow as necessary to prevent degraded performance. Perl uses +sophisticated pattern matching techniques to scan large amounts of data +very quickly. Although optimized for scanning text, Perl can also +deal with binary data, and can make dbm files look like associative +arrays (where dbm is available). Setuid Perl scripts are safer than +C programs through a dataflow tracing mechanism which prevents many +stupid security holes. If you have a problem that would ordinarily use +B<sed> or B<awk> or B<sh>, but it exceeds their capabilities or must +run a little faster, and you don't want to write the silly thing in C, +then Perl may be for you. There are also translators to turn your +B<sed> and B<awk> scripts into Perl scripts. + +But wait, there's more... + +Perl version 5 is nearly a complete rewrite, and provides +the following additional benefits: + +=over 5 + +=item * Many usability enhancements + +It is now possible to write much more readable Perl code (even within +regular expressions). Formerly cryptic variable names can be replaced +by mnemonic identifiers. Error messages are more informative, and the +optional warnings will catch many of the mistakes a novice might make. +This cannot be stressed enough. Whenever you get mysterious behavior, +try the B<-w> switch!!! Whenever you don't get mysterious behavior, +try using B<-w> anyway. + +=item * Simplified grammar + +The new yacc grammar is one half the size of the old one. Many of the +arbitrary grammar rules have been regularized. The number of reserved +words has been cut by 2/3. Despite this, nearly all old Perl scripts +will continue to work unchanged. + +=item * Lexical scoping + +Perl variables may now be declared within a lexical scope, like "auto" +variables in C. Not only is this more efficient, but it contributes +to better privacy for "programming in the large". + +=item * Arbitrarily nested data structures + +Any scalar value, including any array element, may now contain a +reference to any other variable or subroutine. You can easily create +anonymous variables and subroutines. Perl manages your reference +counts for you. + +=item * Modularity and reusability + +The Perl library is now defined in terms of modules which can be easily +shared among various packages. A package may choose to import all or a +portion of a module's published interface. Pragmas (that is, compiler +directives) are defined and used by the same mechanism. + +=item * Object-oriented programming + +A package can function as a class. Dynamic multiple inheritance and +virtual methods are supported in a straightforward manner and with very +little new syntax. Filehandles may now be treated as objects. + +=item * Embeddible and Extensible + +Perl may now be embedded easily in your C or C++ application, and can +either call or be called by your routines through a documented +interface. The XS preprocessor is provided to make it easy to glue +your C or C++ routines into Perl. Dynamic loading of modules is +supported. + +=item * POSIX compliant + +A major new module is the POSIX module, which provides access to all +available POSIX routines and definitions, via object classes where +appropriate. + +=item * Package constructors and destructors + +The new BEGIN and END blocks provide means to capture control as +a package is being compiled, and after the program exits. As a +degenerate case they work just like awk's BEGIN and END when you +use the B<-p> or B<-n> switches. + +=item * Multiple simultaneous DBM implementations + +A Perl program may now access DBM, NDBM, SDBM, GDBM, and Berkeley DB +files from the same script simultaneously. In fact, the old dbmopen +interface has been generalized to allow any variable to be tied +to an object class which defines its access methods. + +=item * Subroutine definitions may now be autoloaded + +In fact, the AUTOLOAD mechanism also allows you to define any arbitrary +semantics for undefined subroutine calls. It's not just for autoloading. + +=item * Regular expression enhancements + +You can now specify non-greedy quantifiers. You can now do grouping +without creating a backreference. You can now write regular expressions +with embedded whitespace and comments for readability. A consistent +extensibility mechanism has been added that is upwardly compatible with +all old regular expressions. + +=back + +Ok, that's I<definitely> enough hype. + +=head1 ENVIRONMENT + +=over 12 + +=item HOME + +Used if chdir has no argument. + +=item LOGDIR + +Used if chdir has no argument and HOME is not set. + +=item PATH + +Used in executing subprocesses, and in finding the script if B<-S> is +used. + +=item PERL5LIB + +A colon-separated list of directories in which to look for Perl library +files before looking in the standard library and the current +directory. If PERL5LIB is not defined, PERLLIB is used. + +=item PERL5DB + +The command used to get the debugger code. If unset, uses + + BEGIN { require 'perl5db.pl' } + +=item PERLLIB + +A colon-separated list of directories in which to look for Perl library +files before looking in the standard library and the current +directory. If PERL5LIB is defined, PERLLIB is not used. + + +=back + +Apart from these, Perl uses no other environment variables, except +to make them available to the script being executed, and to child +processes. However, scripts running setuid would do well to execute +the following lines before doing anything else, just to keep people +honest: + + $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need + $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'}; + $ENV{'IFS'} = '' if defined $ENV{'IFS'}; + +=head1 AUTHOR + +Larry Wall <F<lwall@netlabs.com.>, with the help of oodles of other folks. + +=head1 FILES + + "/tmp/perl-e$$" temporary file for -e commands + "@INC" locations of perl 5 libraries + +=head1 SEE ALSO + + a2p awk to perl translator + s2p sed to perl translator + +=head1 DIAGNOSTICS + +The B<-w> switch produces some lovely diagnostics. + +See L<perldiag> for explanations of all Perl's diagnostics. + +Compilation errors will tell you the line number of the error, with an +indication of the next token or token type that was to be examined. +(In the case of a script passed to Perl via B<-e> switches, each +B<-e> is counted as one line.) + +Setuid scripts have additional constraints that can produce error +messages such as "Insecure dependency". See L<perlsec>. + +Did we mention that you should definitely consider using the B<-w> +switch? + +=head1 BUGS + +The B<-w> switch is not mandatory. + +Perl is at the mercy of your machine's definitions of various +operations such as type casting, atof() and sprintf(). + +If your stdio requires an seek or eof between reads and writes on a +particular stream, so does Perl. (This doesn't apply to sysread() +and syswrite().) + +While none of the built-in data types have any arbitrary size limits +(apart from memory size), there are still a few arbitrary limits: a +given 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. + +Perl actually stands for Pathologically Eclectic Rubbish Lister, but +don't tell anyone I said that. + +=head1 NOTES + +The Perl motto is "There's more than one way to do it." Divining +how many more is left as an exercise to the reader. + +The three principle virtues of a programmer are Laziness, +Impatience, and Hubris. See the Camel Book for why. diff --git a/pod/perlapi.pod b/pod/perlapi.pod new file mode 100644 index 0000000000..f76d877f9b --- /dev/null +++ b/pod/perlapi.pod @@ -0,0 +1,951 @@ +=head1 NAME + +perlapi - Perl 5 application programming interface for C extensions + +=head1 DESCRIPTION + +=head2 Introduction + +XS is a language used to create an extension interface +between Perl and some C library which one wishes to use with +Perl. The XS interface is combined with the library to +create a new library which can be linked to Perl. An B<XSUB> +is a function in the XS language and is the core component +of the Perl application interface. + +The XS compiler is called B<xsubpp>. This compiler will embed +the constructs necessary to let an XSUB, which is really a C +function in disguise, manipulate Perl values and creates the +glue necessary to let Perl access the XSUB. The compiler +uses B<typemaps> to determine how to map C function parameters +and variables to Perl values. The default typemap handles +many common C types. A supplement typemap must be created +to handle special structures and types for the library being +linked. + +Many of the examples which follow will concentrate on creating an +interface between Perl and the ONC+RPC bind library functions. +Specifically, the rpcb_gettime() function will be used to demonstrate many +features of the XS language. This function has two parameters; the first +is an input parameter and the second is an output parameter. The function +also returns a status value. + + bool_t rpcb_gettime(const char *host, time_t *timep); + +From C this function will be called with the following +statements. + + #include <rpc/rpc.h> + bool_t status; + time_t timep; + status = rpcb_gettime( "localhost", &timep ); + +If an XSUB is created to offer a direct translation between this function +and Perl, then this XSUB will be used from Perl with the following code. +The $status and $timep variables will contain the output of the function. + + use RPC; + $status = rpcb_gettime( "localhost", $timep ); + +The following XS file shows an XS subroutine, or XSUB, which +demonstrates one possible interface to the rpcb_gettime() +function. This XSUB represents a direct translation between +C and Perl and so preserves the interface even from Perl. +This XSUB will be invoked from Perl with the usage shown +above. Note that the first three #include statements, for +C<EXTERN.h>, C<perl.h>, and C<XSUB.h>, will always be present at the +beginning of an XS file. This approach and others will be +expanded later in this document. + + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + #include <rpc/rpc.h> + + MODULE = RPC PACKAGE = RPC + + bool_t + rpcb_gettime(host,timep) + char * host + time_t &timep + OUTPUT: + timep + +Any extension to Perl, including those containing XSUBs, +should have a Perl module to serve as the bootstrap which +pulls the extension into Perl. This module will export the +extension's functions and variables to the Perl program and +will cause the extension's XSUBs to be linked into Perl. +The following module will be used for most of the examples +in this document and should be used from Perl with the C<use> +command as shown earlier. Perl modules are explained in +more detail later in this document. + + package RPC; + + require Exporter; + require DynaLoader; + @ISA = qw(Exporter DynaLoader); + @EXPORT = qw( rpcb_gettime ); + + bootstrap RPC; + 1; + +Throughout this document a variety of interfaces to the rpcb_gettime() +XSUB will be explored. The XSUBs will take their parameters in different +orders or will take different numbers of parameters. In each case the +XSUB is an abstraction between Perl and the real C rpcb_gettime() +function, and the XSUB must always ensure that the real rpcb_gettime() +function is called with the correct parameters. This abstraction will +allow the programmer to create a more Perl-like interface to the C +function. + +=head2 The Anatomy of an XSUB + +The following XSUB allows a Perl program to access a C library function called sin(). The XSUB will imitate the C +function which takes a single argument and returns a single +value. + + double + sin(x) + double<tab>x + +The compiler expects a tab between the parameter name and its type, and +any or no whitespace before the type. When using C pointers the +indirection operator C<*> should be considered part of the type and the +address operator C<&> should be considered part of the variable, as is +demonstrated in the rpcb_gettime() function above. See the section on +typemaps for more about handling qualifiers and unary operators in C +types. + +The parameter list of a function must not have whitespace +after the open-parenthesis or before the close-parenthesis. + + INCORRECT CORRECT + + double double + sin( x ) sin(x) + double x double x + +The function name and the return type must be placed on +separate lines. + + INCORRECT CORRECT + + double sin(x) double + double x sin(x) + double x + +=head2 The Argument Stack + +The argument stack is used to store the values which are +sent as parameters to the XSUB and to store the XSUB's +return value. In reality all Perl functions keep their +values on this stack at the same time, each limited to its +own range of positions on the stack. In this document the +first position on that stack which belongs to the active +function will be referred to as position 0 for that function. + +XSUBs refer to their stack arguments with the macro B<ST(x)>, where I<x> refers +to a position in this XSUB's part of the stack. Position 0 for that +function would be known to the XSUB as ST(0). The XSUB's incoming +parameters and outgoing return values always begin at ST(0). For many +simple cases the B<xsubpp> compiler will generate the code necessary to +handle the argument stack by embedding code fragments found in the +typemaps. In more complex cases the programmer must supply the code. + +=head2 The RETVAL Variable + +The RETVAL variable is a magic variable which always matches +the return type of the C library function. The B<xsubpp> compiler will +supply this variable in each XSUB and by default will use it to hold the +return value of the C library function being called. In simple cases the +value of RETVAL will be placed in ST(0) of the argument stack where it can +be received by Perl as the return value of the XSUB. + +If the XSUB has a return type of C<void> then the compiler will +not supply a RETVAL variable for that function. When using +the PPCODE: directive the RETVAL variable may not be needed. + +=head2 The MODULE Keyword + +The MODULE keyword is used to start the XS code and to +specify the package of the functions which are being +defined. All text preceding the first MODULE keyword is +considered C code and is passed through to the output +untouched. Every XS module will have a bootstrap function +which is used to hook the XSUBs into Perl. The package name +of this bootstrap function will match the value of the last +MODULE statement in the XS source files. The value of +MODULE should always remain constant within the same XS +file, though this is not required. + +The following example will start the XS code and will place +all functions in a package named RPC. + + MODULE = RPC + +=head2 The PACKAGE Keyword + +When functions within an XS source file must be separated into packages +the PACKAGE keyword should be used. This keyword is used with the MODULE +keyword and must follow immediately after it when used. + + MODULE = RPC PACKAGE = RPC + + [ XS code in package RPC ] + + MODULE = RPC PACKAGE = RPCB + + [ XS code in package RPCB ] + + MODULE = RPC PACKAGE = RPC + + [ XS code in package RPC ] + +Although this keyword is optional and in some cases provides redundant +information it should always be used. This keyword will ensure that the +XSUBs appear in the desired package. + +=head2 The PREFIX Keyword + +The PREFIX keyword designates prefixes which should be +removed from the Perl function names. If the C function is +C<rpcb_gettime()> and the PREFIX value is C<rpcb_> then Perl will +see this function as C<gettime()>. + +This keyword should follow the PACKAGE keyword when used. +If PACKAGE is not used then PREFIX should follow the MODULE +keyword. + + MODULE = RPC PREFIX = rpc_ + + MODULE = RPC PACKAGE = RPCB PREFIX = rpcb_ + +=head2 The OUTPUT: Keyword + +The OUTPUT: keyword indicates that certain function parameters should be +updated (new values made visible to Perl) when the XSUB terminates or that +certain values should be returned to the calling Perl function. For +simple functions, such as the sin() function above, the RETVAL variable is +automatically designated as an output value. In more complex functions +the B<xsubpp> compiler will need help to determine which variables are output +variables. + +This keyword will normally be used to complement the CODE: keyword. +The RETVAL variable is not recognized as an output variable when the +CODE: keyword is present. The OUTPUT: keyword is used in this +situation to tell the compiler that RETVAL really is an output +variable. + +The OUTPUT: keyword can also be used to indicate that function parameters +are output variables. This may be necessary when a parameter has been +modified within the function and the programmer would like the update to +be seen by Perl. If function parameters are listed under OUTPUT: along +with the RETVAL variable then the RETVAL variable must be the last one +listed. + + bool_t + rpcb_gettime(host,timep) + char * host + time_t &timep + OUTPUT: + timep + +The OUTPUT: keyword will also allow an output parameter to +be mapped to a matching piece of code rather than to a +typemap. + + bool_t + rpcb_gettime(host,timep) + char * host + time_t &timep + OUTPUT: + timep<tab>sv_setnv(ST(1), (double)timep); + +=head2 The CODE: Keyword + +This keyword is used in more complicated XSUBs which require +special handling for the C function. The RETVAL variable is +available but will not be returned unless it is specified +under the OUTPUT: keyword. + +The following XSUB is for a C function which requires special handling of +its parameters. The Perl usage is given first. + + $status = rpcb_gettime( "localhost", $timep ); + +The XSUB follows. + + bool_t rpcb_gettime(host,timep) + char * host + time_t timep + CODE: + RETVAL = rpcb_gettime( host, &timep ); + OUTPUT: + timep + RETVAL + +In many of the examples shown here the CODE: block (and +other blocks) will often be contained within braces ( C<{> and +C<}> ). This protects the CODE: block from complex INPUT +typemaps and ensures the resulting C code is legal. + +=head2 The NO_INIT Keyword + +The NO_INIT keyword is used to indicate that a function +parameter is being used only as an output value. The B<xsubpp> +compiler will normally generate code to read the values of +all function parameters from the argument stack and assign +them to C variables upon entry to the function. NO_INIT +will tell the compiler that some parameters will be used for +output rather than for input and that they will be handled +before the function terminates. + +The following example shows a variation of the rpcb_gettime() function. +This function uses the timep variable only as an output variable and does +not care about its initial contents. + + bool_t + rpcb_gettime(host,timep) + char * host + time_t &timep = NO_INIT + OUTPUT: + timep + +=head2 Initializing Function Parameters + +Function parameters are normally initialized with their +values from the argument stack. The typemaps contain the +code segments which are used to transfer the Perl values to +the C parameters. The programmer, however, is allowed to +override the typemaps and supply alternate initialization +code. + +The following code demonstrates how to supply initialization code for +function parameters. The initialization code is eval'd by the compiler +before it is added to the output so anything which should be interpreted +literally, such as double quotes, must be protected with backslashes. + + bool_t + rpcb_gettime(host,timep) + char * host = (char *)SvPV(ST(0),na); + time_t &timep = 0; + OUTPUT: + timep + +This should not be used to supply default values for parameters. One +would normally use this when a function parameter must be processed by +another library function before it can be used. Default parameters are +covered in the next section. + +=head2 Default Parameter Values + +Default values can be specified for function parameters by +placing an assignment statement in the parameter list. The +default value may be a number or a string. Defaults should +always be used on the right-most parameters only. + +To allow the XSUB for rpcb_gettime() to have a default host +value the parameters to the XSUB could be rearranged. The +XSUB will then call the real rpcb_gettime() function with +the parameters in the correct order. Perl will call this +XSUB with either of the following statements. + + $status = rpcb_gettime( $timep, $host ); + + $status = rpcb_gettime( $timep ); + +The XSUB will look like the code which follows. A CODE: +block is used to call the real rpcb_gettime() function with +the parameters in the correct order for that function. + + bool_t + rpcb_gettime(timep,host="localhost") + char * host + time_t timep = NO_INIT + CODE: + RETVAL = rpcb_gettime( host, &timep ); + OUTPUT: + timep + RETVAL + +=head2 Variable-length Parameter Lists + +XSUBs can have variable-length parameter lists by specifying an ellipsis +C<(...)> in the parameter list. This use of the ellipsis is similar to that +found in ANSI C. The programmer is able to determine the number of +arguments passed to the XSUB by examining the C<items> variable which the +B<xsubpp> compiler supplies for all XSUBs. By using this mechanism one can +create an XSUB which accepts a list of parameters of unknown length. + +The I<host> parameter for the rpcb_gettime() XSUB can be +optional so the ellipsis can be used to indicate that the +XSUB will take a variable number of parameters. Perl should +be able to call this XSUB with either of the following statments. + + $status = rpcb_gettime( $timep, $host ); + + $status = rpcb_gettime( $timep ); + +The XS code, with ellipsis, follows. + + bool_t + rpcb_gettime(timep, ...) + time_t timep = NO_INIT + CODE: + { + char *host = "localhost"; + + if( items > 1 ) + host = (char *)SvPV(ST(1), na); + RETVAL = rpcb_gettime( host, &timep ); + } + OUTPUT: + timep + RETVAL + +=head2 The PPCODE: Keyword + +The PPCODE: keyword is an alternate form of the CODE: keyword and is used +to tell the B<xsubpp> compiler that the programmer is supplying the code to +control the argument stack for the XSUBs return values. Occassionally one +will want an XSUB to return a list of values rather than a single value. +In these cases one must use PPCODE: and then explicitly push the list of +values on the stack. The PPCODE: and CODE: keywords are not used +together within the same XSUB. + +The following XSUB will call the C rpcb_gettime() function +and will return its two output values, timep and status, to +Perl as a single list. + + void rpcb_gettime(host) + char * host + PPCODE: + { + time_t timep; + bool_t status; + status = rpcb_gettime( host, &timep ); + EXTEND(sp, 2); + PUSHs(sv_2mortal(newSVnv(status))); + PUSHs(sv_2mortal(newSVnv(timep))); + } + +Notice that the programmer must supply the C code necessary +to have the real rpcb_gettime() function called and to have +the return values properly placed on the argument stack. + +The C<void> return type for this function tells the B<xsubpp> compiler that +the RETVAL variable is not needed or used and that it should not be created. +In most scenarios the void return type should be used with the PPCODE: +directive. + +The EXTEND() macro is used to make room on the argument +stack for 2 return values. The PPCODE: directive causes the +B<xsubpp> compiler to create a stack pointer called C<sp>, and it +is this pointer which is being used in the EXTEND() macro. +The values are then pushed onto the stack with the PUSHs() +macro. + +Now the rpcb_gettime() function can be used from Perl with +the following statement. + + ($status, $timep) = rpcb_gettime("localhost"); + +=head2 Returning Undef And Empty Lists + +Occassionally the programmer will want to simply return +C<undef> or an empty list if a function fails rather than a +separate status value. The rpcb_gettime() function offers +just this situation. If the function succeeds we would like +to have it return the time and if it fails we would like to +have undef returned. In the following Perl code the value +of $timep will either be undef or it will be a valid time. + + $timep = rpcb_gettime( "localhost" ); + +The following XSUB uses the C<void> return type to disable the generation of +the RETVAL variable and uses a CODE: block to indicate to the compiler +that the programmer has supplied all the necessary code. The +sv_newmortal() call will initialize the return value to undef, making that +the default return value. + + void + rpcb_gettime(host) + char * host + CODE: + { + time_t timep; + bool_t x; + ST(0) = sv_newmortal(); + if( rpcb_gettime( host, &timep ) ) + sv_setnv( ST(0), (double)timep); + } + +The next example demonstrates how one would place an explicit undef in the +return value, should the need arise. + + void + rpcb_gettime(host) + char * host + CODE: + { + time_t timep; + bool_t x; + ST(0) = sv_newmortal(); + if( rpcb_gettime( host, &timep ) ){ + sv_setnv( ST(0), (double)timep); + } + else{ + ST(0) = &sv_undef; + } + } + +To return an empty list one must use a PPCODE: block and +then not push return values on the stack. + + void + rpcb_gettime(host) + char * host + PPCODE: + { + time_t timep; + if( rpcb_gettime( host, &timep ) ) + PUSHs(sv_2mortal(newSVnv(timep))); + else{ + /* Nothing pushed on stack, so an empty */ + /* list is implicitly returned. */ + } + } + +=head2 The CLEANUP: Keyword + +This keyword can be used when an XSUB requires special cleanup procedures +before it terminates. When the CLEANUP: keyword is used it must follow +any CODE:, PPCODE:, or OUTPUT: blocks which are present in the XSUB. The +code specified for the cleanup block will be added as the last statements +in the XSUB. + +=head2 The BOOT: Keyword + +The BOOT: keyword is used to add code to the extension's bootstrap +function. The bootstrap function is generated by the B<xsubpp> compiler and +normally holds the statements necessary to register any XSUBs with Perl. +With the BOOT: keyword the programmer can tell the compiler to add extra +statements to the bootstrap function. + +This keyword may be used any time after the first MODULE keyword and should +appear on a line by itself. The first blank line after the keyword will +terminate the code block. + + BOOT: + # The following message will be printed when the + # bootstrap function executes. + printf("Hello from the bootstrap!\n"); + +=head2 Inserting Comments and C Preprocessor Directives + +Comments and C preprocessor directives are allowed within +CODE:, PPCODE:, BOOT:, and CLEANUP: blocks. 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<#> at the beginning of the line. Care +should be taken to avoid making the comment look like a C +preprocessor directive, lest it be interpreted as such. + +=head2 Using XS With C++ + +If a function is defined as a C++ method then it will assume +its first argument is an object pointer. The object pointer +will be stored in a variable called THIS. The object should +have been created by C++ with the new() function and should +be blessed by Perl with the sv_setptrobj() macro. The +blessing of the object by Perl can be handled by the +T_PTROBJ typemap. + +If the method is defined as static it will call the C++ +function using the class::method() syntax. If the method is not static +the function will be called using the THIS->method() syntax. + +=head2 Perl Variables + +The following demonstrates how the Perl variable $host can +be accessed from an XSUB. The function B<perl_get_sv()> is +used to obtain a pointer to the variable, known as an B<SV> +(Scalar Variable) internally. The package name C<RPC> will be +added to the name of the variable so perl_get_sv() will know +in which package $host can be found. If the package name is +not supplied then perl_get_sv() will search package C<main> for +the variable. The macro B<SvPVX()> is then used to dereference +the SV to obtain a C<char*> pointer to its contents. + + void + rpcb_gettime() + PPCODE: + { + char *host; + SV *hostsv; + time_t timep; + + hostsv = perl_get_sv( "RPC::host", FALSE ); + if( hostsv != NULL ){ + host = SvPVX( hostsv ); + if( rpcb_gettime( host, &timep ) ) + PUSHs(sv_2mortal(newSVnv(timep))); + } + } + +This Perl code can be used to call that XSUB. + + $RPC::host = "localhost"; + $timep = rpcb_gettime(); + +In the above example the SV contained a C C<char*> but a Perl +scalar variable may also contain numbers and references. If +the SV is expected to have a C C<int> then the macro B<SvIVX()> +should be used to dereference the SV. When the SV contains +a C double then B<SvNVX()> should be used. + +The macro B<SvRV()> can be used to dereference an SV when it is a Perl +reference. The result will be another SV which points to the actual Perl +variable. This can then be dereferenced with SvPVX(), SvNVX(), or +SvIVX(). The following XSUB will use SvRV(). + + void rpcb_gettime() + PPCODE: + { + char *host; + SV *rv; + SV *hostsv; + time_t timep; + + rv = perl_get_sv( "RPC::host", FALSE ); + if( rv != NULL ){ + hostsv = SvRV( rv ); + host = SvPVX( hostsv ); + if( rpcb_gettime( host, &timep ) ) + PUSHs(sv_2mortal(newSVnv(timep))); + } + } + +This Perl code will create a variable $RPC::host which is a +reference to $MY::host. The variable $MY::host contains the +hostname which will be used. + + $MY::host = "localhost"; + $RPC::host = \$MY::host; + $timep = rpcb_gettime(); + +The second argument to perl_get_sv() will normally be B<FALSE> +as shown in the above examples. An argument of B<TRUE> will +cause variables to be created if they do not already exist. +One should not use TRUE unless steps are taken to deal with +a possibly empty SV. + +XSUBs may use B<perl_get_av()>, B<perl_get_hv()>, and B<perl_get_cv()> to +access Perl arrays, hashes, and code values. + +=head2 Interface Stategy + +When designing an interface between Perl and a C library a straight +translation from C to XS is often sufficient. The interface will often be +very C-like and occasionally nonintuitive, especially when the C function +modifies one of its parameters. In cases where the programmer wishes to +create a more Perl-like interface the following strategy may help to +identify the more critical parts of the interface. + +Identify the C functions which modify their parameters. The XSUBs for +these functions may be able to return lists to Perl, or may be +candidates to return undef or an empty list in case of failure. + +Identify which values are used only by the C and XSUB functions +themselves. If Perl does not need to access the contents of the value +then it may not be necessary to provide a translation for that value +from C to Perl. + +Identify the pointers in the C function parameter lists and return +values. Some pointers can be handled in XS with the & unary operator on +the variable name while others will require the use of the * operator on +the type name. In general it is easier to work with the & operator. + +Identify the structures used by the C functions. In many +cases it may be helpful to use the T_PTROBJ typemap for +these structures so they can be manipulated by Perl as +blessed objects. + +=head2 The Perl Module + +The Perl module is the link between the extension library, +which was generated from XS code, and the Perl interpreter. +The module is used to tell Perl what the extension library +contains. The name and package of the module should match +the name of the library. + +The following is a Perl module for an extension containing +some ONC+ RPC bind library functions. + + package RPC; + + require Exporter; + require DynaLoader; + @ISA = qw(Exporter DynaLoader); + @EXPORT = qw( rpcb_gettime rpcb_getmaps rpcb_getaddr + rpcb_rmtcall rpcb_set rpcb_unset ); + + bootstrap RPC; + 1; + +The RPC extension contains the functions found in the +@EXPORT list. By using the C<Exporter> module the RPC module +can make these function names visible to the rest of the +Perl program. The C<DynaLoader> module will allow the RPC +module to bootstrap the extension library. To load this +extension and make the functions available, the following +Perl statement should be used. + + use RPC; + +For more information about the DynaLoader consult its documentation in the +ext/DynaLoader directory in the Perl source. + +=head2 Perl Objects And C Structures + +When dealing with C structures one should select either +B<T_PTROBJ> or B<T_PTRREF> for the XS type. Both types are +designed to handle pointers to complex objects. The +T_PTRREF type will allow the Perl object to be unblessed +while the T_PTROBJ type requires that the object be blessed. +By using T_PTROBJ one can achieve a form of type-checking +since the XSUB will attempt to verify that the Perl object +is of the expected type. + +The following XS code shows the getnetconfigent() function which is used +with ONC TIRPC. The getnetconfigent() function will return a pointer to a +C structure and has the C prototype shown below. The example will +demonstrate how the C pointer will become a Perl reference. Perl will +consider this reference to be a pointer to a blessed object and will +attempt to call a destructor for the object. A destructor will be +provided in the XS source to free the memory used by getnetconfigent(). +Destructors in XS can be created by specifying an XSUB function whose name +ends with the word B<DESTROY>. XS destructors can be used to free memory +which may have been malloc'd by another XSUB. + + struct netconfig *getnetconfigent(const char *netid); + +A C<typedef> will be created for C<struct netconfig>. The Perl +object will be blessed in a class matching the name of the C +type, with the tag C<Ptr> appended, and the name should not +have embedded spaces if it will be a Perl package name. The +destructor will be placed in a class corresponding to the +class of the object and the PREFIX keyword will be used to +trim the name to the word DESTROY as Perl will expect. + + typedef struct netconfig Netconfig; + + MODULE = RPC PACKAGE = RPC + + Netconfig * + getnetconfigent(netid) + char * netid + + MODULE = RPC PACKAGE = NetconfigPtr PREFIX = rpcb_ + + void + rpcb_DESTROY(netconf) + Netconfig * netconf + CODE: + printf("Now in NetconfigPtr::DESTROY\n"); + free( netconf ); + +This example requires the following typemap entry. Consult the typemap +section for more information about adding new typemaps for an extension. + + TYPEMAP + Netconfig * T_PTROBJ + +This example will be used with the following Perl statements. + + use RPC; + $netconf = getnetconfigent("udp"); + +When Perl destroys the object referenced by $netconf it will send the +object to the supplied XSUB DESTROY function. Perl cannot determine, and +does not care, that this object is a C struct and not a Perl object. In +this sense, there is no difference between the object created by the +getnetconfigent() XSUB and an object created by a normal Perl subroutine. + +=head2 C Headers and Perl + +The B<h2xs> compiler is designed to convert C header files in +/usr/include into Perl extensions. This compiler will +create a directory under the C<ext> directory of the Perl +source and will populate it with a Makefile, a Perl Module, +an XS source file, and a MANIFEST file. + +The following command will create an extension called C<Rusers> +from the <rpcsvc/rusers.h> header. + + h2xs rpcsvc/rusers + +When the Rusers extension has been compiled and installed +Perl can use it to retrieve any C<#define> statements which +were in the C header. + + use Rusers; + print "RPC program number for rusers service: "; + print &RUSERSPROG, "\n"; + +=head2 Creating A New Extension + +The B<h2xs> compiler can generate template source files and +Makefiles. These templates offer a suitable starting point +for most extensions. The following example demonstrates how +one might use B<h2xs> to create an extension containing the RPC +functions in this document. + +The extension will not use autoloaded functions and will not define +constants, so the B<-A> option will be given to B<h2xs>. When run from the +Perl source directory, the B<h2xs> compiler will create the directory +ext/RPC and will populate it with files called RPC.xs, RPC.pm, Makefile.PL, +and MANIFEST. The XS code for the RPC functions should be added to the +RPC.xs file. The @EXPORT list in RPC.pm should be updated to include the +functions from RPC.xs. + + h2xs -An RPC + +To compile the extension for dynamic loading the following +command should be executed from the ext/RPC directory. + + make dynamic + +If the extension will be statically linked into the Perl +binary then the makefile (use C<makefile>, not C<Makefile>) in the +Perl source directory should be edited to add C<ext/RPC/RPC.a> +to the C<static_ext> variable. Before making this change Perl +should have already been built. After the makefile has been +updated the following command should be executed from the +Perl source directory. + + make + +Perl's B<Configure> script can also be used to add extensions. The extension +should be placed in the C<ext> directory under the Perl source before Perl +has been built and prior to running Configure. When Configure is run it +will find the extension along with the other extensions in the C<ext> +directory and will add it to the list of extensions to be built. When make +is run the extension will be built along with the other extensions. + +Configure recognizes extensions if they have an XS source +file which matches the name of the extension directory. If +the extension directory includes a MANIFEST file Configure +will search that file for any B<.SH> files and extract them +after it extracts all the other .SH files listed in the main +MANIFEST. The main Perl Makefile will then run B<make> in the +extension's directory if it finds an XS file matching the +name of the extension's directory. + +=head2 The Typemap + +The typemap is a collection of code fragments which are used by the B<xsubpp> +compiler to map C function parameters and values to Perl values. The +typemap file may consist of three sections labeled C<TYPEMAP>, C<INPUT>, and +C<OUTPUT>. The INPUT section tells the compiler how to translate Perl values +into variables of certain C types. The OUTPUT section tells the compiler +how to translate the values from certain C types into values Perl can +understand. The TYPEMAP section tells the compiler which of the INPUT and +OUTPUT code fragments should be used to map a given C type to a Perl value. +Each of the sections of the typemap must be preceded by one of the TYPEMAP, +INPUT, or OUTPUT keywords. + +The default typemap in the C<ext> directory of the Perl source contains many +useful types which can be used by Perl extensions. Some extensions define +additional typemaps which they keep in their own directory. These +additional typemaps may reference INPUT and OUTPUT maps in the main +typemap. The B<xsubpp> compiler will allow the extension's own typemap to +override any mappings which are in the default typemap. + +Most extensions which require a custom typemap will need only the TYPEMAP +section of the typemap file. The custom typemap used in the +getnetconfigent() example shown earlier demonstrates what may be the typical +use of extension typemaps. That typemap is used to equate a C structure +with the T_PTROBJ typemap. The typemap used by getnetconfigent() is shown +here. Note that the C type is separated from the XS type with a tab and +that the C unary operator C<*> is considered to be a part of the C type name. + + TYPEMAP + Netconfig *<tab>T_PTROBJ + +=head1 EXAMPLES + +File C<RPC.xs>: Interface to some ONC+ RPC bind library functions. + + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + + #include <rpc/rpc.h> + + typedef struct netconfig Netconfig; + + MODULE = RPC PACKAGE = RPC + + void + rpcb_gettime(host="localhost") + char * host + CODE: + { + time_t timep; + ST(0) = sv_newmortal(); + if( rpcb_gettime( host, &timep ) ) + sv_setnv( ST(0), (double)timep ); + } + + Netconfig * + getnetconfigent(netid="udp") + char * netid + + MODULE = RPC PACKAGE = NetconfigPtr PREFIX = rpcb_ + + void + rpcb_DESTROY(netconf) + Netconfig * netconf + CODE: + printf("NetconfigPtr::DESTROY\n"); + free( netconf ); + +File C<typemap>: Custom typemap for RPC.xs. + + TYPEMAP + Netconfig * T_PTROBJ + +File C<RPC.pm>: Perl module for the RPC extension. + + package RPC; + + require Exporter; + require DynaLoader; + @ISA = qw(Exporter DynaLoader); + @EXPORT = qw(rpcb_gettime getnetconfigent); + + bootstrap RPC; + 1; + +File C<rpctest.pl>: Perl test program for the RPC extension. + + use RPC; + + $netconf = getnetconfigent(); + $a = rpcb_gettime(); + print "time = $a\n"; + print "netconf = $netconf\n"; + + $netconf = getnetconfigent("tcp"); + $a = rpcb_gettime("poplar"); + print "time = $a\n"; + print "netconf = $netconf\n"; + + +=head1 AUTHOR + +Dean Roehrich <roehrich@cray.com> +September 27, 1994 diff --git a/pod/perlbook.pod b/pod/perlbook.pod new file mode 100644 index 0000000000..441c43aabf --- /dev/null +++ b/pod/perlbook.pod @@ -0,0 +1,20 @@ +=head1 NAME + +perlbook - Perl book information + +=head1 DESCRIPTION + +You can order Perl books from O'Reilly & Associates, 1-800-998-9938. +Local/overseas is 1-707-829-0515. If you can locate an O'Reilly order +form, you can also fax to 1-707-829-0104. I<Programming Perl> is a +reference work that covers nearly all of Perl (version 4, alas), while +I<Learning Perl> is a tutorial that covers the most frequently used subset +of the language. + + Programming Perl (the Camel Book): + ISBN 0-937175-64-1 (English) + ISBN 4-89052-384-7 (Japanese) + + Learning Perl (the Llama Book): + ISBN 1-56592-042-2 (English) + diff --git a/pod/perlbot.pod b/pod/perlbot.pod new file mode 100644 index 0000000000..3df273be7d --- /dev/null +++ b/pod/perlbot.pod @@ -0,0 +1,367 @@ +=head1 NAME + +perlbot - Bag'o Object Tricks For Perl5 (the BOT) + +=head1 INTRODUCTION + +The following collection of tricks and hints is intended to whet curious +appetites about such things as the use of instance variables and the +mechanics of object and class relationships. The reader is encouraged to +consult relevant textbooks for discussion of Object Oriented definitions and +methodology. This is not intended as a comprehensive guide to Perl5's +object oriented features, nor should it be construed as a style guide. + +The Perl motto still holds: There's more than one way to do it. + +=head1 INSTANCE VARIABLES + +An anonymous array or anonymous hash can be used to hold instance +variables. Named parameters are also demonstrated. + + package Foo; + + sub new { + my $type = shift; + my %params = @_; + my $self = {}; + $self->{'High'} = $params{'High'}; + $self->{'Low'} = $params{'Low'}; + bless $self; + } + + + package Bar; + + sub new { + my $type = shift; + my %params = @_; + my $self = []; + $self->[0] = $params{'Left'}; + $self->[1] = $params{'Right'}; + bless $self; + } + + package main; + + $a = new Foo ( 'High' => 42, 'Low' => 11 ); + print "High=$a->{'High'}\n"; + print "Low=$a->{'Low'}\n"; + + $b = new Bar ( 'Left' => 78, 'Right' => 40 ); + print "Left=$b->[0]\n"; + print "Right=$b->[1]\n"; + + +=head1 SCALAR INSTANCE VARIABLES + +An anonymous scalar can be used when only one instance variable is needed. + + package Foo; + + sub new { + my $type = shift; + my $self; + $self = shift; + bless \$self; + } + + package main; + + $a = new Foo 42; + print "a=$$a\n"; + + +=head1 INSTANCE VARIABLE INHERITANCE + +This example demonstrates how one might inherit instance variables from a +superclass for inclusion in the new class. This requires calling the +superclass's constructor and adding one's own instance variables to the new +object. + + package Bar; + + sub new { + my $self = {}; + $self->{'buz'} = 42; + bless $self; + } + + package Foo; + @ISA = qw( Bar ); + + sub new { + my $self = new Bar; + $self->{'biz'} = 11; + bless $self; + } + + package main; + + $a = new Foo; + print "buz = ", $a->{'buz'}, "\n"; + print "biz = ", $a->{'biz'}, "\n"; + + + +=head1 OBJECT RELATIONSHIPS + +The following demonstrates how one might implement "containing" and "using" +relationships between objects. + + package Bar; + + sub new { + my $self = {}; + $self->{'buz'} = 42; + bless $self; + } + + package Foo; + + sub new { + my $self = {}; + $self->{'Bar'} = new Bar (); + $self->{'biz'} = 11; + bless $self; + } + + package main; + + $a = new Foo; + print "buz = ", $a->{'Bar'}->{'buz'}, "\n"; + print "biz = ", $a->{'biz'}, "\n"; + + + +=head1 OVERRIDING SUPERCLASS METHODS + +The following example demonstrates how one might override a superclass +method and then call the method after it has been overridden. The +Foo::Inherit class allows the programmer to call an overridden superclass +method without actually knowing where that method is defined. + + + package Buz; + sub goo { print "here's the goo\n" } + + package Bar; @ISA = qw( Buz ); + sub google { print "google here\n" } + + package Baz; + sub mumble { print "mumbling\n" } + + package Foo; + @ISA = qw( Bar Baz ); + @Foo::Inherit::ISA = @ISA; # Access to overridden methods. + + sub new { bless [] } + sub grr { print "grumble\n" } + sub goo { + my $self = shift; + $self->Foo::Inherit::goo(); + } + sub mumble { + my $self = shift; + $self->Foo::Inherit::mumble(); + } + sub google { + my $self = shift; + $self->Foo::Inherit::google(); + } + + package main; + + $foo = new Foo; + $foo->mumble; + $foo->grr; + $foo->goo; + $foo->google; + + +=head1 USING RELATIONSHIP WITH SDBM + +This example demonstrates an interface for the SDBM class. This creates a +"using" relationship between the SDBM class and the new class Mydbm. + + use SDBM_File; + use POSIX; + + package Mydbm; + + sub TIEHASH { + my $self = shift; + my $ref = SDBM_File->new(@_); + bless {'dbm' => $ref}; + } + sub FETCH { + my $self = shift; + my $ref = $self->{'dbm'}; + $ref->FETCH(@_); + } + sub STORE { + my $self = shift; + if (defined $_[0]){ + my $ref = $self->{'dbm'}; + $ref->STORE(@_); + } else { + die "Cannot STORE an undefined key in Mydbm\n"; + } + } + + package main; + + tie %foo, Mydbm, "Sdbm", O_RDWR|O_CREAT, 0640; + $foo{'bar'} = 123; + print "foo-bar = $foo{'bar'}\n"; + + tie %bar, Mydbm, "Sdbm2", O_RDWR|O_CREAT, 0640; + $bar{'Cathy'} = 456; + print "bar-Cathy = $bar{'Cathy'}\n"; + +=head1 THINKING OF CODE REUSE + +One strength of Object-Oriented languages is the ease with which old code +can use new code. The following examples will demonstrate first how one can +hinder code reuse and then how one can promote code reuse. + +This first example illustrates a class which uses a fully-qualified method +call to access the "private" method BAZ(). The second example will show +that it is impossible to override the BAZ() method. + + package FOO; + + sub new { bless {} } + sub bar { + my $self = shift; + $self->FOO::private::BAZ; + } + + package FOO::private; + + sub BAZ { + print "in BAZ\n"; + } + + package main; + + $a = FOO->new; + $a->bar; + +Now we try to override the BAZ() method. We would like FOO::bar() to call +GOOP::BAZ(), but this cannot happen since FOO::bar() explicitly calls +FOO::private::BAZ(). + + package FOO; + + sub new { bless {} } + sub bar { + my $self = shift; + $self->FOO::private::BAZ; + } + + package FOO::private; + + sub BAZ { + print "in BAZ\n"; + } + + package GOOP; + @ISA = qw( FOO ); + sub new { bless {} } + + sub BAZ { + print "in GOOP::BAZ\n"; + } + + package main; + + $a = GOOP->new; + $a->bar; + +To create reusable code we must modify class FOO, flattening class +FOO::private. The next example shows a reusable class FOO which allows the +method GOOP::BAZ() to be used in place of FOO::BAZ(). + + package FOO; + + sub new { bless {} } + sub bar { + my $self = shift; + $self->BAZ; + } + + sub BAZ { + print "in BAZ\n"; + } + + package GOOP; + @ISA = qw( FOO ); + + sub new { bless {} } + sub BAZ { + print "in GOOP::BAZ\n"; + } + + package main; + + $a = GOOP->new; + $a->bar; + +=head1 CLASS CONTEXT AND THE OBJECT + +Use the object to solve package and class context problems. Everything a +method needs should be available via the object or should be passed as a +parameter to the method. + +A class will sometimes have static or global data to be used by the +methods. A subclass may want to override that data and replace it with new +data. When this happens the superclass may not know how to find the new +copy of the data. + +This problem can be solved by using the object to define the context of the +method. Let the method look in the object for a reference to the data. The +alternative is to force the method to go hunting for the data ("Is it in my +class, or in a subclass? Which subclass?"), and this can be inconvenient +and will lead to hackery. It is better to just let the object tell the +method where that data is located. + + package Bar; + + %fizzle = ( 'Password' => 'XYZZY' ); + + sub new { + my $self = {}; + $self->{'fizzle'} = \%fizzle; + bless $self; + } + + sub enter { + my $self = shift; + + # Don't try to guess if we should use %Bar::fizzle + # or %Foo::fizzle. The object already knows which + # we should use, so just ask it. + # + my $fizzle = $self->{'fizzle'}; + + print "The word is ", $fizzle->{'Password'}, "\n"; + } + + package Foo; + @ISA = qw( Bar ); + + %fizzle = ( 'Password' => 'Rumple' ); + + sub new { + my $self = Bar->new; + $self->{'fizzle'} = \%fizzle; + bless $self; + } + + package main; + + $a = Bar->new; + $b = Foo->new; + $a->enter; + $b->enter; + diff --git a/pod/perlcall.pod b/pod/perlcall.pod new file mode 100644 index 0000000000..d81ee4a9ec --- /dev/null +++ b/pod/perlcall.pod @@ -0,0 +1,838 @@ +=head1 NAME + +perlcall - Perl calling conventions from C + +=head1 DESCRIPTION + +B<WARNING : This document is still under construction. +There are bound to be a number of inaccuracies, so tread very carefully for now.> + +The purpose of this document is to show you how to write I<callbacks>, +i.e. how to call Perl from C. The main +focus is on how to interface back to Perl from a bit of C code that has itself +been run by Perl, i.e. the 'main' program is a Perl script; you are using it +to execute +a section of code written in C; that bit of C code wants you to do something +with a particular event, so you want a Perl sub to be executed whenever it +happens. + +Examples where this is necessary include + +=over 5 + +=item * + +You have created an XSUB interface to an application's C API. + +A fairly common feature in applications is to allow you to define a C +function that will get called whenever something nasty occurs. +What we would like is for a Perl sub to be called instead. + +=item * + +The classic example of where callbacks are used is in an event driven program +like for X-windows. +In this case your register functions to be called whenever a specific events +occur, e.g. a mouse button is pressed. + +=back + +Although the techniques described are applicable to embedding Perl +in a C program, this is not the primary goal of this document. For details +on embedding Perl in C refer to L<perlembed> (currently unwritten). + +Before you launch yourself head first into the rest of this document, it would +be a good idea to have read the following two documents - L<perlapi> and L<perlguts>. + +This stuff is easier to explain using examples. But first here are a few +definitions anyway. + +=head2 Definitions + +Perl has a number of C functions which allow you to call Perl subs. They are + + I32 perl_call_sv(SV* sv, I32 flags) ; + I32 perl_call_pv(char *subname, I32 flags) ; + I32 perl_call_method(char *methname, I32 flags) ; + I32 perl_call_argv(char *subname, I32 flags, register char **argv) ; + +The key function is I<perl_call_sv>. All the other functions make use of +I<perl_call_sv> to do what they do. + +I<perl_call_sv> takes two parameters, the first is an SV*. This allows you to +specify the Perl sub to be called either as a C string (which has first been +converted to an SV) or a reference to a +sub. Example 7, shows you how you can make use of I<perl_call_sv>. +The second parameter, C<flags>, is a general purpose option command. +This parameter is common to all the I<perl_call_*> functions. +It is discussed in the next section. + +The function, I<perl_call_pv>, is similar as I<perl_call_sv> except it +expects it's first parameter has to be a C char* which identifies the Perl +sub you want to call, e.g. C<perl_call_pv("fred", 0)>. + +The function I<perl_call_method> expects its first argument to contain a +blessed reference to a class. Using that reference it looks up and calls C<methname> +from that class. See example 9. + +I<perl_call_argv> calls the Perl sub specified by the C<subname> parameter. +It also takes the usual C<flags> parameter. +The final parameter, C<argv>, consists of a +list of C strings to be sent to the Perl sub. See example 8. + +All the functions return a number. This is a count of the number of items +returned by the Perl sub on the stack. + +As a general rule you should I<always> check the return value from these +functions. +Even if you are only expecting a particular number of values to be returned +from the Perl sub, there is nothing to stop someone from doing something +unexpected - don't say you havn't been warned. + +=head2 Flag Values + +The C<flags> parameter in all the I<perl_call_*> functions consists of any +combination of the symbols defined below, OR'ed together. + +=over 5 + +=item G_SCALAR + +Calls the Perl sub in a scalar context. + +Whatever the Perl sub actually returns, we only want a scalar. If the perl sub +does return a scalar, the return value from the I<perl_call_*> function +will be 1 or 0. If 1, then the value actually returned by the Perl sub will +be contained +on the top of the stack. +If 0, then the sub has probably called I<die> or you have +used the G_DISCARD flag. + +If the Perl sub returns a list, the I<perl_call_*> function will still +only return 1 or 0. If 1, then the number of elements in the list +will be stored on top of the stack. +The actual values of the list will not be accessable. + + +G_SCALAR is the default flag setting for all the functions. + +=item G_ARRAY + +Calls the Perl sub in a list context. + +The return code from the I<perl_call_*> functions will indicate how +many elements of the stack are used to store the array. + +=item G_DISCARD + +If you are not interested in the values returned by the Perl sub then setting +this flag will make Perl get rid of them automatically for you. This will take +precedence to either G_SCALAR or G_ARRAY. + +If you do +not set this flag then you may need to explicitly get rid of temporary values. +See example 3 for details. + +=item G_NOARGS + +If you are not passing any parameters to the Perl sub, you can save a bit of +time by setting this flag. It has the effect of of not creating the C<@_> array +for the Perl sub. + +A point worth noting is that if this flag is specified the Perl sub called can +still access an C<@_> array from a previous Perl sub. +This functionality can be illustrated with the perl code below + + sub fred + { print "@_\n" } + + sub joe + { &fred } + + &joe(1,2,3) ; + +This will print + + 1 2 3 + +What has happened is that C<fred> accesses the C<@_> array which belongs to C<joe>. + +=item G_EVAL + +If the Perl sub you are calling has the ability to terminate +abnormally, e.g. by calling I<die> or by not actually existing, and +you want to catch this type of event, specify this flag setting. It will put +an I<eval { }> around the sub call. + +Whenever control returns from the I<perl_call_*> function you need to +check the C<$@> variable as you would in a normal Perl script. +See example 6 for details of how to do this. + + +=back + + +=head1 EXAMPLES + +Enough of the definition talk, let's have a few examples. + +Perl provides many macros to assist in accessing the Perl stack. +These macros should always be used when interfacing to Perl internals. +Hopefully this should make the code less vulnerable to changes made to +Perl in the future. + +Another point worth noting is that in the first series of examples I have +only made use of the I<perl_call_pv> function. +This has only been done to ease you into the +topic. Wherever possible, if the choice is between using I<perl_call_pv> +and I<perl_call_sv>, I would always try to use I<perl_call_sv>. + +The code for these examples is stored in the file F<perlcall.tar>. +(Once this document settles down, all the example code will be available in the file). + +=head2 Example1: No Parameters, Nothing returned + +This first trivial example will call a Perl sub, I<PrintUID>, to print +out the UID of the process. + + sub PrintUID + { + print "UID is $<\n" ; + } + +and here is the C to call it + + void + call_PrintUID() + { + dSP ; + + PUSHMARK(sp) ; + perl_call_pv("PrintUID", G_DISCARD|G_NOARGS) ; + } + +Simple, eh. + +A few points to note about this example. + +=over 5 + +=item 1. + +We aren't passing any parameters to I<PrintUID> so G_NOARGS +can be specified. + +=item 2. + +Ignore C<dSP> and C<PUSHMARK(sp)> for now. They will be discussed in the next +example. + +=item 3. + +We aren't interested in anything returned from I<PrintUID>, so +G_DISCARD is specified. Even if I<PrintUID> was changed to actually +return some value(s), having specified G_DISCARD will mean that they +will be wiped by the time control returns from I<perl_call_pv>. + +=item 4. + +Because we specified G_DISCARD, it is not necessary to check +the value returned from I<perl_call_sv>. It will always be 0. + +=item 5. + +As I<perl_call_pv> is being used, the Perl sub is specified as a C string. + +=back + +=head2 Example 2: Passing Parameters + +Now let's make a slightly more complex example. This time we want +to call a Perl sub +which will take 2 parameters - a string (C<$s>) and an integer (C<$n>). +The sub will simply print the first C<$n> characters of the string. + +So the Perl sub would look like this + + sub LeftString + { + my($s, $n) = @_ ; + print substr($s, 0, $n), "\n" ; + } + +The C function required to call I<LeftString> would look like this. + + static void + call_LeftString(a, b) + char * a ; + int b ; + { + dSP ; + + PUSHMARK(sp) ; + XPUSHs(sv_2mortal(newSVpv(a, 0))); + XPUSHs(sv_2mortal(newSViv(b))); + PUTBACK ; + + perl_call_pv("LeftString", G_DISCARD); + } + + +Here are a few notes on the C function I<call_LeftString>. + +=over 5 + +=item 1. + +The only flag specified this time is G_DISCARD. As we are passing 2 +parameters to the Perl sub this time, we have not specified G_NOARGS. + +=item 2. + +Parameters are passed to the Perl sub using the Perl stack. +This is the purpose of the code beginning with the line C<dSP> and ending +with the line C<PUTBACK>. + + +=item 3. + +If you are going to put something onto the Perl stack, you need to know +where to put it. This is the purpose of the macro C<dSP> - +it declares and initialises a local copy of the Perl stack pointer. + +All the other macros which will be used in this example require you to +have used this macro. + +If you are calling a Perl sub directly from an XSUB function, it is +not necessary to explicitly use the C<dSP> macro - it will be declared for you. + +=item 4. + +Any parameters to be pushed onto the stack should be bracketed by the +C<PUSHMARK> and C<PUTBACK> macros. +The purpose of these two macros, in this context, is to automatically count +the number of parameters you are pushing. Then whenever Perl is creating +the C<@_> array for the sub, it knows how big to make it. + +The C<PUSHMARK> macro tells Perl to make a mental note of the current stack +pointer. Even if you aren't passing any parameters (like in Example 1) you must +still call the C<PUSHMARK> macro before you can call any of +the I<perl_call_*> functions - Perl still needs to know that there are +no parameters. + +The C<PUTBACK> macro sets the global copy of the stack pointer to be the +same as our local copy. If we didn't do this I<perl_call_pv> wouldn't +know where the two parameters we pushed were - remember that up to now +all the stack pointer manipulation we have done is with our local copy, +I<not> the global copy. + +=item 5. + +Next, we come to XPUSHs. This is where the parameters actually get +pushed onto the stack. In this case we are pushing a string and an integer. + +See the section I<XSUB's AND THE ARGUMENT STACK> in L<perlguts> for +details on how the XPUSH macros work. + +=item 6. + +Finally, I<LeftString> can now be called via the I<perl_call_pv> function. + +=back + +=head2 Example 3: Returning a Scalar + +Now for an example of dealing with the values returned from a Perl sub. + +Here is a Perl sub, I<Adder>, which takes 2 integer parameters and simply +returns their sum. + + sub Adder + { + my($a, $b) = @_ ; + $a + $b ; + } + +As we are now concerned with the return value from I<Adder>, the C function +is now a bit more complex. + + static void + call_Adder(a, b) + int a ; + int b ; + { + dSP ; + int count ; + + ENTER ; + SAVETMPS; + + PUSHMARK(sp) ; + XPUSHs(sv_2mortal(newSViv(a))); + XPUSHs(sv_2mortal(newSViv(b))); + PUTBACK ; + + count = perl_call_pv("Adder", G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak("Big trouble\n") ; + + printf ("The sum of %d and %d is %d\n", a, b, POPi) ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + } + + +Points to note this time are + +=over 5 + +=item 1. + +The only flag specified this time was G_SCALAR. That means the @_ array +will be created and that the value returned by I<Adder> will still +exist after the call to I<perl_call_pv>. + + + +=item 2. + +Because we are interested in what is returned from I<Adder> we cannot specify +G_DISCARD. This means that we will have to tidy up the Perl stack and dispose +of any temporary values ourselves. This is the purpose of + + ENTER ; + SAVETMPS ; + +at the start of the function, and + + FREETMPS ; + LEAVE ; + +at the end. The C<ENTER>/C<SAVETMPS> pair creates a boundary for any +temporaries we create. +This means that the temporaries we get rid of will be limited to those which +were created after these calls. + +The C<FREETMPS>/C<LEAVE> pair will get rid of any values returned by the Perl +sub, plus it will also dump the mortal SV's we created. +Having C<ENTER>/C<SAVETMPS> at the beginning +of the code makes sure that no other mortals are destroyed. + +=item 3. + +The purpose of the macro C<SPAGAIN> is to refresh the local copy of the +stack pointer. This is necessary because it is possible that the memory +allocated to the Perl stack has been re-allocated whilst in the I<perl_call_pv> +call. + +If you are making use of the Perl stack pointer in your code you must always +refresh the your local copy using SPAGAIN whenever you make use of +of the I<perl_call_*> functions or any other Perl internal function. + +=item 4. + +Although only a single value was expected to be returned from I<Adder>, it is +still good practice to check the return code from I<perl_call_pv> anyway. + +Expecting a single value is not quite the same as knowing that there will +be one. If someone modified I<Adder> to return a list and we didn't check +for that possibility and take appropriate action the Perl stack would end +up in an inconsistant state. That is something you I<really> don't want +to ever happen. + +=item 5. + +The C<POPi> macro is used here to pop the return value from the stack. In this +case we wanted an integer, so C<POPi> was used. + + +Here is the complete list of POP macros available, along with the types they +return. + + POPs SV + POPp pointer + POPn double + POPi integer + POPl long + +=item 6. + +The final C<PUTBACK> is used to leave the Perl stack in a consistant state +before exiting the function. This is +necessary because when we popped the return value from the stack with C<POPi> it +only updated our local copy of the stack pointer. Remember, C<PUTBACK> sets the +global stack pointer to be the same as our local copy. + +=back + + +=head2 Example 4: Returning a list of values + +Now, let's extend the previous example to return both the sum of the parameters +and the difference. + +Here is the Perl sub + + sub AddSubtract + { + my($a, $b) = @_ ; + ($a+$b, $a-$b) ; + } + + +and this is the C function + + static void + call_AddSubtract(a, b) + int a ; + int b ; + { + dSP ; + int count ; + + ENTER ; + SAVETMPS; + + PUSHMARK(sp) ; + XPUSHs(sv_2mortal(newSViv(a))); + XPUSHs(sv_2mortal(newSViv(b))); + PUTBACK ; + + count = perl_call_pv("AddSubtract", G_ARRAY); + + SPAGAIN ; + + if (count != 2) + croak("Big trouble\n") ; + + printf ("%d - %d = %d\n", a, b, POPi) ; + printf ("%d + %d = %d\n", a, b, POPi) ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + } + + +Notes + +=over 5 + +=item 1. + +We wanted array context, so we used G_ARRAY. + +=item 2. + +Not surprisingly there are 2 POPi's this time because we were retrieving 2 +values from the stack. The main point to note is that they came off the stack in +reverse order. + +=back + +=head2 Example 5: Returning Data from Perl via the parameter list + +It is also possible to return values directly via the parameter list - +whether it is actually desirable to do it is another matter entirely. + +The Perl sub, I<Inc>, below takes 2 parameters and increments each. + + sub Inc + { + ++ $_[0] ; + ++ $_[1] ; + } + +and here is a C function to call it. + + static void + call_Inc(a, b) + int a ; + int b ; + { + dSP ; + int count ; + SV * sva ; + SV * svb ; + + ENTER ; + SAVETMPS; + + sva = sv_2mortal(newSViv(a)) ; + svb = sv_2mortal(newSViv(b)) ; + + PUSHMARK(sp) ; + XPUSHs(sva); + XPUSHs(svb); + PUTBACK ; + + count = perl_call_pv("Inc", G_DISCARD); + + if (count != 0) + croak ("call_Inc : expected 0 return value from 'Inc', got %d\n", count) ; + + printf ("%d + 1 = %d\n", a, SvIV(sva)) ; + printf ("%d + 1 = %d\n", b, SvIV(svb)) ; + + FREETMPS ; + LEAVE ; + } + + + +To be able to access the two parameters that were pushed onto the stack +after they return from I<perl_call_pv> it is necessary to make a note of +their addresses - thus the two variables C<sva> and C<svb>. + +The reason this is necessary is that +the area of the Perl stack which held them +will very likely have been overwritten by something else by the time control +returns from I<perl_call_pv>. + + + + +=head2 Example 6: Using G_EVAL + +Now an example using G_EVAL. Below is a Perl sub which computes the +difference of its 2 parameters. If this would result in a negative result, +the sub calls I<die>. + + + sub Subtract + { + my ($a, $b) = @_ ; + + die "death can be fatal\n" if $a < $b ; + + $a - $b ; + } + +and some C to call it + + static void + call_Subtract(a, b) + int a ; + int b ; + { + dSP ; + int count ; + SV * sv ; + + ENTER ; + SAVETMPS; + + PUSHMARK(sp) ; + XPUSHs(sv_2mortal(newSViv(a))); + XPUSHs(sv_2mortal(newSViv(b))); + PUTBACK ; + + count = perl_call_pv("Subtract", G_EVAL|G_SCALAR); + + /* Check the eval first */ + sv = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); + if (SvTRUE(sv)) + printf ("Uh oh - %s\n", SvPV(sv, na)) ; + + SPAGAIN ; + + if (count != 1) + croak ("call_Subtract : expected 1 return value from 'Subtract', got %d\n", count) ; + + + printf ("%d - %d = %d\n", a, b, POPi) ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + } + +If I<call_Subtract> is called thus + + call_Subtract(4, 5) + +the following will be printed + + Uh oh - death can be fatal + +Notes + +=over 5 + +=item 1. + +We want to be able to catch the I<die> so we have used the G_EVAL flag. +Not specifying this flag would mean that the program would terminate. + +=item 2. + +The code + + sv = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); + if (SvTRUE(sv)) + printf ("Uh oh - %s\n", SvPVx(sv, na)) ; + +is the equivalent of this bit of Perl + + print "Uh oh - $@\n" if $@ ; + + + +=back + + +=head2 Example 7: Using perl_call_sv + +In all the previous examples I have 'hard-wried' the name of the Perl sub to +be called from C. +Sometimes though, it is necessary to be able to specify the name +of the Perl sub from within the Perl script. + +Consider the Perl code below + + sub fred + { + print "Hello there\n" ; + } + + CallSub("fred") ; + + +here is a snippet of XSUB which defines I<CallSub>. + + void + CallSub(name) + char * name + CODE: + PUSHMARK(sp) ; + perl_call_pv(name, G_DISCARD|G_NOARGS) ; + +That is fine as far as it goes. The thing is, it only allows the Perl sub to be +specified as a string. +For perl 4 this was adequate, but Perl 5 allows references to +subs and anonymous subs. This is where I<perl_call_sv> is useful. + +The code below for I<CallSub> is identical to the previous time except that the +C<name> parameter is now defined as an SV* and we use I<perl_call_sv> instead of +I<perl_call_pv>. + + void + CallSub(name) + SV* name + CODE: + PUSHMARK(sp) ; + perl_call_sv(name, G_DISCARD|G_NOARGS) ; + +As we are using an SV to call I<fred> the following can all be used + + CallSub("fred") ; + Callsub(\&fred) ; + $ref = \&fred ; + CallSub($ref) ; + CallSub( sub { print "Hello there\n" } ) ; + +As you can see, I<perl_call_sv> gives you greater flexibility in how you +can specify the Perl sub. + +=head2 Example 8: Using perl_call_argv + +Here is a Perl sub which prints whatever parameters are passed to it. + + sub PrintList + { + my(@list) = @_ ; + + foreach (@list) { print "$_\n" } + } + +and here is an example of I<perl_call_argv> which will call I<PrintList>. + + call_PrintList + { + dSP ; + char * words[] = {"alpha", "beta", "gamma", "delta", NULL } ; + + perl_call_argv("PrintList", words, G_DISCARD) ; + } + +Note that it is not necessary to call C<PUSHMARK> in this instance. This is +because I<perl_call_argv> will do it for you. + +=head2 Example 9: Using perl_call_method + +[This section is under construction] + +Consider the following Perl code + + { + package Mine ; + + sub new { bless [@_] } + sub Display { print $_[0][1], "\n" } + } + + $a = new Mine ('red', 'green', 'blue') ; + call_Display($a, 'Display') ; + +The method C<Display> just prints out the first element of the list. +Here is a XSUB implementation of I<call_Display>. + + void + call_Display(ref, method) + SV * ref + char * method + CODE: + PUSHMARK(sp); + XPUSHs(ref); + PUTBACK; + + perl_call_method(method, G_DISCARD) ; + + + + +=head2 Strategies for storing Context Information + +[This section is under construction] + +One of the trickiest problems to overcome when designing a callback interface +is figuring +out how to store the mapping between the C callback functions and the +Perl equivalent. + +Consider the following example. + +=head2 Alternate Stack Manipulation + +[This section is under construction] + +Although I have only made use of the POP* macros to access values returned +from Perl subs, it is also possible to bypass these macros and read the +stack directly. + +The code below is example 4 recoded to + +=head1 SEE ALSO + +L<perlapi>, L<perlguts>, L<perlembed> + +=head1 AUTHOR + +Paul Marquess <pmarquess@bfsec.bt.co.uk> + +Special thanks to the following people who assisted in the creation of the +document. + +Jeff Okamoto, Tim Bunce. + +=head1 DATE + +Version 0.4, 17th October 1994 + + diff --git a/pod/perldata.pod b/pod/perldata.pod new file mode 100644 index 0000000000..6b4f7a4053 --- /dev/null +++ b/pod/perldata.pod @@ -0,0 +1,408 @@ +=head1 NAME + +perldata - Perl data structures + +=head1 DESCRIPTION + +=head2 Variable names + +Perl has three data structures: scalars, arrays of scalars, and +associative arrays of scalars, known as "hashes". Normal arrays are +indexed by number, starting with 0. (Negative subscripts count from +the end.) Hash arrays are indexed by string. + +Scalar values are always named with '$', even when referring to a scalar +that is part of an array. It works like the English word "the". Thus +we have: + + $days # the simple scalar value "days" + $days[28] # the 29th element of array @days + $days{'Feb'} # the 'Feb' value from hash %days + $#days # the last index of array @days + +but entire arrays or array slices are denoted by '@', which works much like +the word "these" or "those": + + @days # ($days[0], $days[1],... $days[n]) + @days[3,4,5] # same as @days[3..5] + @days{'a','c'} # same as ($days{'a'},$days{'c'}) + +and entire hashes are denoted by '%': + + %days # (key1, val1, key2, val2 ...) + +In addition, subroutines are named with an initial '&', though this is +optional when it's otherwise unambiguous (just as "do" is often +redundant in English). Symbol table entries can be named with an +initial '*', but you don't really care about that yet. + +Every variable type has its own namespace. You can, without fear of +conflict, use the same name for a scalar variable, an array, or a hash +(or, for that matter, a filehandle, a subroutine name, or a label). +This means that $foo and @foo are two different variables. It also +means that $foo[1] is a part of @foo, not a part of $foo. This may +seem a bit weird, but that's okay, because it is weird. + +Since variable and array references always start with '$', '@', or '%', +the "reserved" words aren't in fact reserved with respect to variable +names. (They ARE reserved with respect to labels and filehandles, +however, which don't have an initial special character. You can't have +a filehandle named "log", for instance. Hint: you could say +C<open(LOG,'logfile')> rather than C<open(log,'logfile')>. Using uppercase +filehandles also improves readability and protects you from conflict +with future reserved words.) Case I<IS> significant--"FOO", "Foo" and +"foo" are all different names. Names that start with a letter or +underscore may also contain digits and underscores. + +It is possible to replace such an alphanumeric name with an expression +that returns a reference to an object of that type. For a description +of this, see L<perlref>. + +Names that start with a digit may only contain more digits. Names +which do not start with a letter, underscore, or digit are limited to +one character, e.g. "$%" or "$$". (Most of these one character names +have a predefined significance to Perl. For instance, $$ is the +current process id.) + +=head2 Context + +The interpretation of operations and values in Perl sometimes depends +on the requirements of the context around the operation or value. +There are two major contexts: scalar and list. Certain operations +return list values in contexts wanting a list, and scalar values +otherwise. (If this is true of an operation it will be mentioned in +the documentation for that operation.) In other words, Perl overloads +certain operations based on whether the expected return value is +singular or plural. (Some words in English work this way, like "fish" +and "sheep".) + +In a reciprocal fashion, an operation provides either a scalar or a +list context to each of its arguments. For example, if you say + + int( <STDIN> ) + +the integer operation provides a scalar context for the <STDIN> +operator, which responds by reading one line from STDIN and passing it +back to the integer operation, which will then find the integer value +of that line and return that. If, on the other hand, you say + + sort( <STDIN> ) + +then the sort operation provides a list context for <STDIN>, which +will proceed to read every line available up to the end of file, and +pass that list of lines back to the sort routine, which will then +sort those lines and return them as a list to whatever the context +of the sort was. + +Assignment is a little bit special in that it uses its left argument to +determine the context for the right argument. Assignment to a scalar +evaluates the righthand side in a scalar context, while assignment to +an array or array slice evaluates the righthand side in a list +context. Assignment to a list also evaluates the righthand side in a +list context. + +User defined subroutines may choose to care whether they are being +called in a scalar or list context, but most subroutines do not +need to care, because scalars are automatically interpolated into +lists. See L<perlfunc/wantarray>. + +=head2 Scalar values + +Scalar variables may contain various kinds of singular data, such as +numbers, strings and references. In general, conversion from one form +to another is transparent. (A scalar may not contain multiple values, +but may contain a reference to an array or hash containing multiple +values.) Because of the automatic conversion of scalars, operations and +functions that return scalars don't need to care (and, in fact, can't +care) whether the context is looking for a string or a number. + +A scalar value is interpreted as TRUE in the Boolean sense if it is not +the null string or the number 0 (or its string equivalent, "0"). The +Boolean context is just a special kind of scalar context. + +There are actually two varieties of null scalars: defined and +undefined. Undefined null scalars are returned when there is no real +value for something, such as when there was an error, or at end of +file, or when you refer to an uninitialized variable or element of an +array. An undefined null scalar may become defined the first time you +use it as if it were defined, but prior to that you can use the +defined() operator to determine whether the value is defined or not. + +The length of an array is a scalar value. You may find the length of +array @days by evaluating C<$#days>, as in B<csh>. (Actually, it's not +the length of the array, it's the subscript of the last element, since +there is (ordinarily) a 0th element.) Assigning to C<$#days> changes the +length of the array. Shortening an array by this method destroys +intervening values. Lengthening an array that was previously shortened +I<NO LONGER> recovers the values that were in those elements. (It used to +in Perl 4, but we had to break this make to make sure destructors were +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.) +You can truncate an array down to nothing by assigning the null list () +to it. The following are equivalent: + + @whatever = (); + $#whatever = $[ - 1; + +If you evaluate a named array in a scalar context, it returns the length of +the array. (Note that this is not true of lists, which return the +last value, like the C comma operator.) The following is always true: + + scalar(@whatever) == $#whatever - $[ + 1; + +Version 5 of Perl changed the semantics of $[: files that don't set +the value of $[ no longer need to worry about whether another +file changed its value. (In other words, use of $[ is deprecated.) +So in general you can just assume that + + scalar(@whatever) == $#whatever + 1; + +If you evaluate a hash in a scalar context, it returns a value which is +true if and only if the hash contains any key/value pairs. (If there +are any key/value pairs, the value returned is a string consisting of +the number of used buckets and the number of allocated buckets, separated +by a slash. This is pretty much only useful to find out whether Perl's +(compiled in) hashing algorithm is performing poorly on your data set. +For example, you stick 10,000 things in a hash, but evaluating %HASH in +scalar context reveals "1/16", which means only one out of sixteen buckets +has been touched, and presumably contains all 10,000 of your items. This +isn't supposed to happen.) + +=head2 Scalar value constructors + +Numeric literals are specified in any of the customary floating point or +integer formats: + + + 12345 + 12345.67 + .23E-10 + 0xffff # hex + 0377 # octal + 4_294_967_296 # underline for legibility + +String literals are delimited by either single or double quotes. They +work much like shell quotes: double-quoted string literals are subject +to backslash and variable substitution; single-quoted strings are not +(except for "C<\'>" and "C<\\>"). The usual Unix backslash rules apply for making +characters such as newline, tab, etc., as well as some more exotic +forms. See L<perlop/qq> for a list. + +You can also embed newlines directly in your strings, i.e. they can end +on a different line than they begin. This is nice, but if you forget +your trailing quote, the error will not be reported until Perl finds +another line containing the quote character, which may be much further +on in the script. Variable substitution inside strings is limited to +scalar variables, arrays, and array slices. (In other words, +identifiers beginning with $ or @, followed by an optional bracketed +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. Also note that a +single-quoted string must be separated from a preceding word by a +space, since single quote is a valid (though discouraged) character in +an identifier (see L<perlmod/Packages>). + +Two special literals are __LINE__ and __FILE__, which represent the +current line number and filename at that point in your program. They +may only be used as separate tokens; they will not be interpolated into +strings. In addition, the token __END__ may be used to indicate the +logical end of the script before the actual end of file. Any following +text is ignored, but may be read via the DATA filehandle. (The DATA +filehandle may read data only from the main script, but not from any +required file or evaluated string.) The two control characters ^D and +^Z are synonyms for __END__. + +A word that doesn't have any other interpretation in the grammar will +be treated as if it were a quoted string. These are known as +"barewords". As with filehandles and labels, a bareword that consists +entirely of lowercase letters risks conflict with future reserved +words, and if you use the B<-w> switch, Perl will warn you about any +such words. Some people may wish to outlaw barewords entirely. If you +say + + use strict 'subs'; + +then any bareword that would NOT be interpreted as a subroutine call +produces a compile-time error instead. The restriction lasts to the +end of the enclosing block. An inner block may countermand this +by saying C<no strict 'subs'>. + +Array variables are interpolated into double-quoted strings by joining all +the elements of the array with the delimiter specified in the C<$"> +variable, space by default. The following are equivalent: + + $temp = join($",@ARGV); + system "echo $temp"; + + system "echo @ARGV"; + +Within search patterns (which also undergo double-quotish substitution) +there is a bad ambiguity: Is C</$foo[bar]/> to be interpreted as +C</${foo}[bar]/> (where C<[bar]> is a character class for the regular +expression) or as C</${foo[bar]}/> (where C<[bar]> is the subscript to array +@foo)? If @foo doesn't otherwise exist, then it's obviously a +character class. If @foo exists, Perl takes a good guess about C<[bar]>, +and is almost always right. If it does guess wrong, or if you're just +plain paranoid, you can force the correct interpretation with curly +brackets as above. + +A line-oriented form of quoting is based on the shell "here-doc" syntax. +Following a C<E<lt>E<lt>> you specify a string to terminate the quoted material, +and all lines following the current line down to the terminating string +are the value of the item. The terminating string may be either an +identifier (a word), or some quoted text. If quoted, the type of +quotes you use determines the treatment of the text, just as in regular +quoting. An unquoted identifier works like double quotes. There must +be no space between the C<E<lt>E<lt>> and the identifier. (If you put a space it +will be treated as a null identifier, which is valid, and matches the +first blank line--see the Merry Christmas example below.) The terminating +string must appear by itself (unquoted and with no surrounding +whitespace) on the terminating line. + + print <<EOF; # same as above + The price is $Price. + EOF + + print <<"EOF"; # same as above + The price is $Price. + EOF + + print << x 10; # Legal but discouraged. Use <<"". + Merry Christmas! + + print <<`EOC`; # execute commands + echo hi there + echo lo there + EOC + + print <<"foo", <<"bar"; # you can stack them + I said foo. + foo + I said bar. + bar + + myfunc(<<"THIS", 23, <<'THAT''); + Here's a line + or two. + THIS + and here another. + THAT + +Just don't forget that you have to put a semicolon on the end +to finish the statement, as Perl doesn't know you're not going to +try to do this: + + print <<ABC + 179231 + ABC + + 20; + + +=head2 List value constructors + +List values are denoted by separating individual values by commas +(and enclosing the list in parentheses where precedence requires it): + + (LIST) + +In a context not requiring an list value, the value of the list +literal is the value of the final element, as with the C comma operator. +For example, + + @foo = ('cc', '-E', $bar); + +assigns the entire list value to array foo, but + + $foo = ('cc', '-E', $bar); + +assigns the value of variable bar to variable foo. Note that the value +of an actual array in a scalar context is the length of the array; the +following assigns to $foo the value 3: + + @foo = ('cc', '-E', $bar); + $foo = @foo; # $foo gets 3 + +You may have an optional comma before the closing parenthesis of an +list literal, so that you can say: + + @foo = ( + 1, + 2, + 3, + ); + +LISTs do automatic interpolation of sublists. That is, when a LIST is +evaluated, each element of the list is evaluated in a list context, and +the resulting list value is interpolated into LIST just as if each +individual element were a member of LIST. Thus arrays lose their +identity in a LIST--the list + + (@foo,@bar,&SomeSub) + +contains all the elements of @foo followed by all the elements of @bar, +followed by all the elements returned by the subroutine named SomeSub. +To make a list reference that does I<NOT> interpolate, see L<perlref>. + +The null list is represented by (). Interpolating it in a list +has no effect. Thus ((),(),()) is equivalent to (). Similarly, +interpolating an array with no elements is the same as if no +array had been interpolated at that point. + +A list value may also be subscripted like a normal array. You must +put the list in parentheses to avoid ambiguity. Examples: + + # Stat returns list value. + $time = (stat($file))[8]; + + # Find a hex digit. + $hexdigit = ('a','b','c','d','e','f')[$digit-10]; + + # A "reverse comma operator". + return (pop(@foo),pop(@foo))[0]; + +Lists may be assigned to if and only if each element of the list +is legal to assign to: + + ($a, $b, $c) = (1, 2, 3); + + ($map{'red'}, $map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00); + +The final element may be an array or a hash: + + ($a, $b, @rest) = split; + local($a, $b, %rest) = @_; + +You can actually put an array anywhere in the list, but the first array +in the list will soak up all the values, and anything after it will get +a null value. This may be useful in a local() or my(). + +A hash literal contains pairs of values to be interpreted +as a key and a value: + + # same as map assignment above + %map = ('red',0x00f,'blue',0x0f0,'green',0xf00); + +It is often more readable to use the C<=E<gt>> operator between key/value pairs +(the C<=E<gt>> operator is actually nothing more than a more visually +distinctive synonym for a comma): + + %map = ( + 'red' => 0x00f, + 'blue' => 0x0f0, + 'green' => 0xf00, + ); + +Array assignment in a scalar context returns the number of elements +produced by the expression on the right side of the assignment: + + $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2 + +This is very handy when you want to do a list assignment in a Boolean +context, since most list functions return a null list when finished, +which when assigned produces a 0, which is interpreted as FALSE. diff --git a/pod/perldebug.pod b/pod/perldebug.pod new file mode 100644 index 0000000000..17fe25926f --- /dev/null +++ b/pod/perldebug.pod @@ -0,0 +1,249 @@ +=head1 NAME + +perldebug - Perl debugging + +=head1 DESCRIPTION + +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 + +Set an action to happen before every debugger prompt. A multiline +command may be entered by backslashing the newlines. + +=item > command + +Set an action to happen after the prompt when you've just given a +command to return to executing the script. A multiline command may be +entered by backslashing the newlines. + +=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 + +Display last n commands. Only commands longer than one character are +listed. If number is omitted, lists them all. + +=item q or ^D + +Quit. ("quit" doesn't work for this.) + +=item command + +Execute command as a Perl statement. A missing semicolon will be +supplied. + +=item p expr + +Same as C<print DB::OUT expr>. The DB::OUT filehandle is opened to +/dev/tty, regardless of where STDOUT may be redirected to. + +=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 + +You did try the B<-w> switch, didn't you? + +=head1 BUGS + +If your program exit()s or die()s, so does the debugger. + +There's no builtin way to restart the debugger without exiting and coming back +into it. You could use an alias like this: + + $DB::alias{'rerun'} = 'exec "perl -d $DB::filename"'; + +But you'd lose any pending breakpoint information, and that might not +be the right path, etc. diff --git a/pod/perldiag.pod b/pod/perldiag.pod new file mode 100644 index 0000000000..43b0f3f5b8 --- /dev/null +++ b/pod/perldiag.pod @@ -0,0 +1,2002 @@ +=head1 NAME + +perldiag - various Perl diagnostics + +=head1 DESCRIPTION + +These messages are classified as follows (listed in increasing order of +desperation): + + (W) A warning (optional). + (D) A deprecation (optional). + (S) A severe warning (mandatory). + (F) A fatal error (trappable). + (P) An internal error you should never see (trappable). + (X) A very fatal error (non-trappable). + +Optional warnings are enabled by using the B<-w> switch. Trappable +errors may be trapped using the eval operator. See L<perlfunc/eval>. + +Some of these messages are generic. Spots that vary are denoted with a %s, +just as in a printf format. Note that some message start with a %s! +The symbols C<"%-?@> sort before the letters, while C<[> and C<\> sort after. + +=over 4 + +=item "my" variable %s can't be in a package + +(F) Lexically scoped variables aren't in a package, so it doesn't make sense +to try to declare one with a package qualifier on the front. Use local() +if you want to localize a package variable. + +=item "no" not allowed in expression + +(F) The "no" keyword is recognized and executed at compile time, and returns +no useful value. See L<perlmod>. + +=item "use" not allowed in expression + +(F) The "use" keyword is recognized and executed at compile time, and returns +no useful value. See L<perlmod>. + +=item % may only be used in unpack + +(F) You can't pack a string by supplying a checksum, since the +checksumming process loses information, and you can't go the other +way. See L<perlfunc/unpack>. + +=item %s (...) interpreted as function + +(W) You've run afoul of the rule that says that any list operator followed +by parentheses turns into a function, with all the list operators arguments +found inside the parens. See L<perlop/Terms and List Operators (Leftward)>. + +=item %s argument is not a HASH element + +(F) The argument to delete() or exists() must be a hash element, such as + + $foo{$bar} + $ref->[12]->{"susie"} + +=item %s did not return a true value + +(F) A required (or used) file must return a true value to indicate that +it compiled correctly and ran its initialization code correctly. It's +traditional to end such a file with a "1;", though any true value would +do. See L<perlfunc/require>. + +=item %s found where operator expected + +(S) The Perl lexer knows whether to expect a term or an operator. If it +sees what it knows to be a term when it was expecting to see an operator, +it gives you this warning. Usually it indicates that an operator or +delimiter was omitted, such as a semicolon. + +=item %s had compilation errors. + +(F) The final summary message when a C<perl -c> fails. + +=item %s has too many errors. + +(F) The parser has given up trying to parse the program after 10 errors. +Further error messages would likely be uninformative. + +=item %s matches null string many times + +(W) The pattern you've specified would be an infinite loop if the +regular expression engine didn't specifically check for that. See L<perlre>. + +=item %s never introduced + +(S) The symbol in question was declared but somehow went out of scope +before it could possibly have been used. + +=item %s syntax OK + +(F) The final summary message when a C<perl -c> succeeds. + +=item B<-P> not allowed for setuid/setgid script + +(F) The script would have to be opened by the C preprocessor by name, +which provides a race condition that breaks security. + +=item C<-T> and C<-B> not implemented on filehandles + +(F) Perl can't peek at the stdio buffer of filehandles when it doesn't +know about your kind of stdio. You'll have to use a filename instead. + +=item ?+* follows nothing in regexp + +(F) You started a regular expression with a quantifier. Backslash it +if you meant it literally. See L<perlre>. + +=item @ outside of string + +(F) You had a pack template that specified an absolution position outside +the string being unpacked. See L<perlfunc/pack>. + +=item accept() on closed fd + +(W) You tried to do an accept on a closed socket. Did you forget to check +the return value of your socket() call? See L<perlfunc/accept>. + +=item Allocation too large: %lx + +(F) You can't allocate more than 64K on an MSDOS machine. + +=item Arg too short for msgsnd + +(F) msgsnd() requires a string at least as long as sizeof(long). + +=item Args must match #! line + +(F) The setuid emulator requires that the arguments Perl was invoked +with match the arguments specified on the #! line. + +=item Argument "%s" isn't numeric + +(W) The indicated string was fed as an argument to an operator that +expected a numeric value instead. If you're fortunate the message +will identify which operator was so unfortunate. + +=item Array @%s missing the @ in argument %d of %s() + +(D) Really old Perl let you omit the @ on array names in some spots. This +is now heavily deprecated. + +=item assertion botched: %s + +(P) The malloc package that comes with Perl had an internal failure. + +=item Assertion failed: file "%s" + +(P) A general assertion failed. The file in question must be examined. + +=item Assignment to both a list and a scalar + +(F) If you assign to a conditional operator, the 2nd and 3rd arguments +must either both be scalars or both be lists. Otherwise Perl won't +know which context to supply to the right side. + +=item Attempt to free non-arena SV: 0x%lx + +(P) All SV objects are supposed to be allocated from arenas that will +be garbage collected on exit. An SV was discovered to be outside any +of those arenas. + +=item Attempt to free temp prematurely + +(W) Mortalized values are supposed to be freed by the free_tmps() +routine. This indicates that something else is freeing the SV before +the free_tmps() routine gets a chance, which means that the free_tmps() +routine will be freeing an unreferenced scalar when it does try to free +it. + +=item Attempt to free unreferenced glob pointers + +(P) The reference counts got screwed up on symbol aliases. + +=item Attempt to free unreferenced scalar + +(W) Perl went to decrement the reference count of a scalar to see if it +would go to 0, and discovered that it had already gone to 0 earlier, +and should have been freed, and in fact, probably was freed. This +could indicate that SvREFCNT_dec() was called too many times, or that +SvREFCNT_inc() was called too few times, or that the SV was mortalized +when it shouldn't have been, or that memory has been corrupted. + +=item 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 *)>. + +=item Bad associative array + +(P) One of the internal hash routines was passed a null HV pointer. + +=item Bad filehandle: %s + +(F) A symbol was passed to something wanting a filehandle, but the symbol +has no filehandle associated with it. Perhaps you didn't do an open(), or +did it in another package. + +=item Bad free() ignored + +(S) An internal routine called free() on something that had never been +malloc()ed in the first place. + +=item Bad name after %s:: + +(F) You started to name a symbol by using a package prefix, and then didn't +finish the symbol. In particular, you can't interpolate outside of quotes, +so + + $var = 'myvar'; + $sym = mypack::$var; + +is not the same as + + $var = 'myvar'; + $sym = "mypack::$var"; + +=item Bad symbol for array + +(P) An internal request asked to add an array entry to something that +wasn't a symbol table entry. + +=item Bad symbol for filehandle + +(P) An internal request asked to add a filehandle entry to something that +wasn't a symbol table entry. + +=item Bad symbol for hash + +(P) An internal request asked to add a hash entry to something that +wasn't a symbol table entry. + +=item BEGIN failed--compilation aborted + +(F) An untrapped exception was raised while executing a BEGIN subroutine. +Compilation stops immediately and the interpreter is exited. + +=item bind() on closed fd + +(W) You tried to do a bind on a closed socket. Did you forget to check +the return value of your socket() call? See L<perlfunc/bind>. + +=item Callback called exit + +(F) A subroutine invoked from an external package via perl_call_sv() +exited by calling exit. + +=item Can't "last" outside a block + +(F) A "last" statement was executed to break out of the current block, +except that there's this itty bitty problem called there isn't a +current block. Note that an "if" or "else" block doesn't count as a +"loopish" block. You can usually double the curlies to get the same +effect though, since the inner curlies will be considered a block +that loops once. See L<perlfunc/last>. + +=item Can't "next" outside a block + +(F) A "next" statement was executed to reiterate the current block, but +there isn't a current block. Note that an "if" or "else" block doesn't +count as a "loopish" block. You can usually double the curlies to get +the same effect though, since the inner curlies will be considered a block +that loops once. See L<perlfunc/last>. + +=item Can't "redo" outside a block + +(F) A "redo" statement was executed to restart the current block, but +there isn't a current block. Note that an "if" or "else" block doesn't +count as a "loopish" block. You can usually double the curlies to get +the same effect though, since the inner curlies will be considered a block +that loops once. See L<perlfunc/last>. + +=item Can't bless non-reference value + +(F) Only hard references may be blessed. This is how Perl "enforces" +encapsulation of objects. See L<perlobj>. + +=item Can't break at that line + +(S) A warning intended for while running within the debugger, indicating +the line number specified wasn't the location of a statement that could +be stopped at. + +=item Can't call method "%s" in empty package "%s" + +(F) You called a method correctly, and it correctly indicated a package +functioning as a class, but that package doesn't have ANYTHING defined +in it, let alone methods. See L<perlobj>. + +=item Can't call method "%s" on unblessed reference + +(F) A method call must know what package it's supposed to run in. It +ordinarily finds this out from the object reference you supply, but +you didn't supply an object reference in this case. A reference isn't +an object reference until it has been blessed. See L<perlobj>. + +=item Can't call method "%s" without a package or object reference + +(F) You used the syntax of a method call, but the slot filled by the +object reference or package name contains an expression that returns +neither an object reference nor a package name. (Perhaps it's null?) +Something like this will reproduce the error: + + $BADREF = undef; + process $BADREF 1,2,3; + $BADREF->process(1,2,3); + +=item Can't chdir to %s + +(F) You called C<perl -x/foo/bar>, but C</foo/bar> is not a directory +that you can chdir to, possibly because it doesn't exist. + +=item Can't coerce %s to integer in %s + +(F) Certain types of SVs, in particular real symbol table entries +(type GLOB), can't be forced to stop being what they are. So you can't +say things like: + + *foo += 1; + +You CAN say + + $foo = *foo; + $foo += 1; + +but then $foo no longer contains a glob. + +=item Can't coerce %s to number in %s + +(F) Certain types of SVs, in particular real symbol table entries +(type GLOB), can't be forced to stop being what they are. + +=item Can't coerce %s to string in %s + +(F) Certain types of SVs, in particular real symbol table entries +(type GLOB), can't be forced to stop being what they are. + +=item Can't create pipe mailbox + +(F) An error peculiar to VMS. + +=item Can't declare %s in my + +(F) Only scalar, array and hash variables may be declared as lexical variables. +They must have ordinary identifiers as names. + +=item Can't do inplace edit on %s: %s + +(S) The creation of the new file failed for the indicated reason. + +=item Can't do inplace edit without backup + +(F) You're on a system such as MSDOS that gets confused if you try reading +from a deleted (but still opened) file. You have to say B<-i>C<.bak>, or some +such. + +=item Can't do inplace edit: %s > 14 characters + +(S) There isn't enough room in the filename to make a backup name for the file. + +=item Can't do inplace edit: %s is not a regular file + +(S) You tried to use the B<-i> switch on a special file, such as a file in +/dev, or a FIFO. The file was ignored. + +=item Can't do setegid! + +(P) The setegid() call failed for some reason in the setuid emulator +of suidperl. + +=item Can't do seteuid! + +(P) The setuid emulator of suidperl failed for some reason. + +=item Can't do setuid + +(F) This typically means that ordinary perl tried to exec suidperl to +do setuid emulation, but couldn't exec it. It looks for a name of the +form sperl5.000 in the same directory that the perl executable resides +under the name perl5.000, typically /usr/local/bin on Unix machines. +If the file is there, check the execute permissions. If it isn't, ask +your sysadmin why he and/or she removed it. + +=item Can't do waitpid with flags + +(F) This machine doesn't have either waitpid() or wait4(), so only waitpid() +without flags is emulated. + +=item Can't do {n,m} with n > m + +(F) Minima must be less than or equal to maxima. If you really want +your regexp to match something 0 times, just put {0}. See L<perlre>. + +=item Can't emulate -%s on #! line + +(F) The #! line specifies a switch that doesn't make sense at this point. +For example, it'd be kind of silly to put a B<-x> on the #! line. + +=item Can't exec "%s": %s + +(W) An system(), exec() or piped open call could not execute the named +program for the indicated reason. Typical reasons include: the permissions +were wrong on the file, the file wasn't found in C<$ENV{PATH}>, the +executable in question was compiled for another architecture, or the +#! line in a script points to an interpreter that can't be run for +similar reasons. (Or maybe your system doesn't support #! at all.) + +=item Can't exec %s + +(F) Perl was trying to execute the indicated program for you because that's +what the #! line said. If that's not what you wanted, you may need to +mention "perl" on the #! line somewhere. + +=item Can't execute %s + +(F) You used the B<-S> switch, but the script to execute could not be found +in the PATH, or at least not with the correct permissions. + +=item Can't find label %s + +(F) You said to goto a label that isn't mentioned anywhere that it's possible +for us to go to. See L<perlfunc/goto>. + +=item Can't find string terminator %s anywhere before EOF + +(F) Perl strings can stretch over multiple lines. This message means that +the closing delimiter was omitted. Since bracketed quotes count nesting +levels, the following is missing its final parenthesis: + + print q(The character '(' starts a side comment.) + +=item Can't fork + +(F) A fatal error occurred while trying to fork while opening a pipeline. + +=item Can't get pipe mailbox device name + +(F) An error peculiar to VMS. + +=item Can't get SYSGEN parameter value for MAXBUF + +(F) An error peculiar to VMS. + +=item Can't goto subroutine outside a subroutine + +(F) The deeply magical "goto subroutine" call can only replace one subroutine +call for another. It can't manufacture one out of whole cloth. In general +you should only be calling it out of an AUTOLOAD routine anyway. See +L<perlfunc/goto>. + +=item Can't locate %s in @INC + +(F) You said to do (or require, or use) a file that couldn't be found +in any of the libraries mentioned in @INC. Perhaps you need to set +the PERL5LIB environment variable to say where the extra library is, +or maybe the script needs to add the library name to @INC. Or maybe +you just misspelled the name of the file. See L<perlfunc/require>. + +=item Can't locate object method "%s" via package "%s" + +(F) You called a method correctly, and it correctly indicated a package +functioning as a class, but that package doesn't define that particular +method, nor does any of it's base classes. See L<perlobj>. + +=item Can't locate package %s for @%s::ISA + +(W) The @ISA array contained the name of another package that doesn't seem +to exist. + +=item Can't mktemp() + +(F) The mktemp() routine failed for some reason while trying to process +a B<-e> switch. Maybe your /tmp partition is full, or clobbered. + +=item Can't modify %s in %s + +(F) You aren't allowed to assign to the item indicated, or otherwise try to +change it, such as with an autoincrement. + +=item Can't modify non-existent substring + +(P) The internal routine that does assignment to a substr() was handed +a NULL. + +=item Can't msgrcv to readonly var + +(F) The target of a msgrcv must be modifiable in order to be used as a receive +buffer. + +=item Can't open %s: %s + +(S) An inplace edit couldn't open the original file for the indicated reason. +Usually this is because you don't have read permission for the file. + +=item Can't open bidirectional pipe + +(W) You tried to say C<open(CMD, "|cmd|")>, which is not supported. You can +try any of several modules in the Perl library to do this, such as +"open2.pl". Alternately, direct the pipe's output to a file using ">", +and then read it in under a different file handle. + +=item Can't open perl script "%s": %s + +(F) The script you specified can't be opened for the indicated reason. + +=item Can't rename %s to %s: %s, skipping file + +(S) The rename done by the B<-i> switch failed for some reason, probably because +you don't have write permission to the directory. + +=item Can't reswap uid and euid + +(P) The setreuid() call failed for some reason in the setuid emulator +of suidperl. + +=item Can't return outside a subroutine + +(F) The return statement was executed in mainline code, that is, where +there was no subroutine call to return out of. See L<perlsub>. + +=item Can't stat script "%s" + +(P) For some reason you can't fstat() the script even though you have +it open already. Bizarre. + +=item Can't swap uid and euid + +(P) The setreuid() call failed for some reason in the setuid emulator +of suidperl. + +=item Can't take log of %g + +(F) Logarithms are only defined on positive real numbers. + +=item Can't take sqrt of %g + +(F) For ordinary real numbers, you can't take the square root of a +negative number. There's a Complex package available for Perl, though, +if you really want to do that. + +=item Can't undef active subroutine + +(F) You can't undefine a routine that's currently running. You can, +however, redefine it while it's running, and you can even undef the +redefined subroutine while the old routine is running. Go figure. + +=item Can't unshift + +(F) You tried to unshift an "unreal" array that can't be unshifted, such +as the main Perl stack. + +=item Can't upgrade that kind of scalar + +(P) The internal sv_upgrade routine adds "members" to an SV, making +it into a more specialized kind of SV. The top several SV types are +so specialized, however, that they cannot be interconverted. This +message indicates that such a conversion was attempted. + +=item Can't upgrade to undef + +(P) The undefined SV is the bottom of the totem pole, in the scheme +of upgradability. Upgrading to undef indicates an error in the +code calling sv_upgrade. + +=item Can't use %s as left arg of an implicit -> + +(F) The compiler tried to interpret a bracketed expression as a subscript +to an array reference. But to the left of the brackets was an expression +that didn't end in an arrow (->), or look like a subscripted expression. +Only subscripted expressions with multiple subscripts are allowed to omit +the intervening arrow. + +=item Can't use %s for loop variable + +(F) Only a simple scalar variable may be used as a loop variable on a foreach. + +=item Can't use %s ref as %s ref + +(F) You've mixed up your reference types. You have to dereference a +reference of the type needed. You can use the ref() function to +test the type of the reference, if need be. + +=item Can't use a string as %s ref while "strict refs" in use + +(F) Only hard references are allowed by "strict refs". Symbolic references +are disallowed. See L<perlref>. + +=item Can't use an undefined value as %s reference + +(F) A value used as either a hard reference or a symbolic reference must +be a defined value. This helps to 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 +not allowed, because the magic can only be tied to one location (namely +the global variable) and it would be incredibly confusing to have +variables in your program that looked like magical variables but +weren't. + +=item Can't write to temp file for B<-e>: %s + +(F) The write routine failed for some reason while trying to process +a B<-e> switch. Maybe your /tmp partition is full, or clobbered. + +=item Can't x= to readonly value + +(F) You tried to repeat a constant value (often the undefined value) with +an assignment operator, which implies modifying the value itself. +Perhaps you need to copy the value to a temporary, and repeat that. + +=item Cannot open temporary file + +(F) The create routine failed for some reaon while trying to process +a B<-e> switch. Maybe your /tmp partition is full, or clobbered. + +=item chmod: mode argument is missing initial 0 + +(W) A novice will sometimes say + + chmod 777, $filename + +not realizing that 777 will be interpreted as a decimal number, equivalent +to 01411. Octal constants are introduced with a leading 0 in Perl, as in C. + +=item Close on unopened file <%s> + +(W) You tried to close a filehandle that was never opened. + +=item connect() on closed fd + +(W) You tried to do a connect on a closed socket. Did you forget to check +the return value of your socket() call? See L<perlfunc/connect>. + +=item Corrupt malloc ptr 0x%lx at 0x%lx + +(P) The malloc package that comes with Perl had an internal failure. + +=item corrupted regexp pointers + +(P) The regular expression engine got confused by what the regular +expression compiler gave it. + +=item corrupted regexp program + +(P) The regular expression engine got passed a regexp program without +a valid magic number. + +=item Deep recursion on subroutine "%s" + +(W) This subroutine has called itself (directly or indirectly) 100 +times than it has returned. This probably indicates an infinite +recursion, unless you're writing strange benchmark programs, in which +case it indicates something else. + +=item Did you mean $ instead of %? + +(W) You probably said %hash{$key} when you meant $hash{$key}. + +=item Don't know how to handle magic of type '%s' + +(P) The internal handling of magical variables has been cursed. + +=item do_study: out of memory + +(P) This should have been caught by safemalloc() instead. + +=item Duplicate free() ignored + +(S) An internal routine called free() on something that had already +been freed. + +=item END failed--cleanup aborted + +(F) An untrapped exception was raised while executing an END subroutine. +The interpreter is immediately exited. + +=item Execution of %s aborted due to compilation errors. + +(F) The final summary message when a Perl compilation fails. + +=item Exiting eval via %s + +(W) You are exiting an eval by unconventional means, such as a +a goto, or a loop control statement. + +=item Exiting subroutine via %s + +(W) You are exiting a subroutine by unconventional means, such as a +a goto, or a loop control statement. + +=item Exiting substitution via %s + +(W) You are exiting a substitution by unconventional means, such as a +a return, a goto, or a loop control statement. + +=item Fatal $PUTMSG error: %d + +(F) An error peculiar to VMS. + +=item fcntl is not implemented + +(F) Your machine apparently doesn't implement fcntl(). What is this, a +PDP-11 or something? + +=item Filehandle %s never opened + +(W) An I/O operation was attempted on a filehandle that was never initialized. +You need to do an open() or a socket() call, or call a constructor from +the FileHandle package. + +=item Filehandle %s opened only for input + +(W) You tried to write on a read-only filehandle. If you +intended it to be a read-write filehandle, you needed to open it with +"+<" or "+>" or "+>>" instead of with "<" or nothing. If you only +intended to write the file, use ">" or ">>". See L<perlfunc/open>. + +=item Filehandle only opened for input + +(W) You tried to write on a read-only filehandle. If you +intended it to be a read-write filehandle, you needed to open it with +"+<" or "+>" or "+>>" instead of with "<" or nothing. If you only +intended to write the file, use ">" or ">>". See L<perlfunc/open>. + +=item Final $ should be \$ or $name + +(F) You must now decide whether the final $ in a string was meant to be +a literal dollar sign, or was meant to introduce a variable name +that happens to be missing. So you have to put either the backslash or +the name. + +=item Final @ should be \@ or @name + +(F) You must now decide whether the final @ in a string was meant to be +a literal "at" sign, or was meant to introduce a variable name +that happens to be missing. So you have to put either the backslash or +the name. + +=item Format %s redefined + +(W) You redefined a format. To suppress this warning, say + + { + local $^W = 0; + eval "format NAME =..."; + } + +=item Format not terminated + +(F) A format must be terminated by a line with a solitary dot. Perl got +to the end of your file without finding such a line. + +=item Found = in conditional, should be == + +(W) You said + + if ($foo = 123) + +when you meant + + if ($foo == 123) + +(or something like that). + +=item gdbm store returned %d, errno %d, key "%s" + +(S) A warning from the GDBM_File extension that a store failed. + +=item gethostent not implemented + +(F) Your C library apparently doesn't implement gethostent(), probably +because if it did, it'd feel morally obligated to return every hostname +on the Internet. + +=item get{sock,peer}name() on closed fd + +(W) You tried to get a socket or peer socket name on a closed socket. +Did you forget to check the return value of your socket() call? + +=item Glob not terminated + +(F) The lexer saw a left angle bracket in a place where it was expecting +a term, so it's looking for the corresponding right angle bracket, and not +finding it. Chances are you left some needed parentheses out earlier in +the line, and you really meant a "less than". + +=item Global symbol "%s" requires explicit package name + +(F) You've said "use strict vars", which indicates that all variables must +either be lexically scoped (using "my"), or explicitly qualified to +say which package the global variable is in (using "::"). + +=item goto must have label + +(F) Unlike with "next" or "last", you're not allowed to goto an +unspecified destination. See L<perlfunc/goto>. + +=item Had to create %s unexpectedly + +(S) A routine asked for a symbol from a symbol table that ought to have +existed already, but for some reason it didn't, and had to be created on +an emergency basis to prevent a core dump. + +=item Hash %%s missing the % in argument %d of %s() + +(D) Really old Perl let you omit the % on hash names in some spots. This +is now heavily deprecated. + +=item Identifier "%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 + +(F) You tried to divide a number by 0. Either something was wrong in your +logic, or you need to put a conditional in to guard against meaningless input. + +=item Illegal modulus zero + +(F) You tried to divide a number by 0 to get the remainder. Most numbers +don't take to this kindly. + +=item Illegal octal digit + +(F) You used an 8 or 9 in a octal number. + +=item Insecure dependency in %s + +(F) You tried to do something that the tainting mechanism didn't like. +The tainting mechanism is turned on when you're running setuid or setgid, +or when you specify B<-T> to turn it on explicitly. The tainting mechanism +labels all data that's derived directly or indirectly from the user, +who is considered to be unworthy of your trust. If any such data is +used in a "dangerous" operation, you get this error. See L<perlsec> +for more information. + +=item Insecure directory in %s + +(F) You can't use system(), exec(), or a piped open in a setuid or setgid +script if $ENV{PATH} contains a directory that is writable by the world. +See L<perlsec>. + +=item Insecure PATH + +(F) You can't use system(), exec(), or a piped open in a setuid or +setgid script if $ENV{PATH} is derived from data supplied (or +potentially supplied) by the user. The script must set the path to a +known value, using trustworthy data. See L<perlsec>. + +=item internal disaster in regexp + +(P) Something went badly wrong in the regular expression parser. + +=item internal urp in regexp at /%s/ + +(P) Something went badly awry in the regular expression parser. + +=item invalid [] range in regexp + +(F) The range specified in a character class had a minimum character +greater than the maximum character. See L<perlre>. + +=item ioctl is not implemented + +(F) Your machine apparently doesn't implement ioctl(), which is pretty +strange for a machine that supports C. + +=item junk on end of regexp + +(P) The regular expression parser is confused. + +=item Label not found for "last %s" + +(F) You named a loop to break out of, but you're not currently in a +loop of that name, not even if you count where you were called from. +See L<perlfunc/last>. + +=item Label not found for "next %s" + +(F) You named a loop to continue, but you're not currently in a loop of +that name, not even if you count where you were called from. See +L<perlfunc/last>. + +=item Label not found for "redo %s" + +(F) You named a loop to restart, but you're not currently in a loop of +that name, not even if you count where you were called from. See +L<perlfunc/last>. + +=item listen() on closed fd + +(W) You tried to do a listen on a closed socket. Did you forget to check +the return value of your socket() call? See L<perlfunc/listen>. + +=item Literal @%s now requires backslash + +(F) It used to be that Perl would try to guess whether you wanted an +array interpolated or a literal @. It did this when the string was +first used at runtime. Now strings are parsed at compile time, and +ambiguous instances of @ must be disambiguated, either by putting a +backslash to indicate a literal, or by declaring (or using) the array +within the program before the string (lexically). (Someday it will simply +assume that an unbackslashed @ interpolates an array.) + +=item Method for operation %s not found in package %s during blessing + +(F) An attempt was made to specify an entry in an overloading table that +doesn't somehow point to a valid method. See L<perlovl>. + +=item Might be a runaway multi-line %s string starting on line %d + +(S) An advisory indicating that the previous error may have been caused +by a missing delimiter on a string or pattern, because it eventually +ended earlier on the current line. + +=item Misplaced _ in number + +(W) An underline in a decimal constant wasn't on a 3-digit boundary. + +=item Missing $ on loop variable + +(F) Apparently you've been programming in csh too much. Variables are always +mentioned with the $ in Perl, unlike in the shells, where it can vary from +one line to the next. + +=item Missing comma after first argument to %s function + +(F) While certain functions allow you to specify a filehandle or an +"indirect object" before the argument list, this ain't one of them. + +=item Missing right bracket + +(F) The lexer counted more opening curly brackets (braces) than closing ones. +As a general rule, you'll find it's missing near the place you were last +editing. + +=item Missing semicolon on previous line? + +(S) This is an educated guess made in conjunction with the message "%s +found where operator expected". Don't automatically put a semicolon on +the previous line just because you saw this message. + +=item Modification of a read-only value attempted + +(F) You tried, directly or indirectly, to change the value of a +constant. You didn't, of course, try "2 = 1", since the compiler +catches that. But an easy way to do the same thing is: + + sub mod { $_[0] = 1 } + mod(2); + +Another way is to assign to a substr() that's off the end of the string. + +=item Modification of non-creatable array value attempted, subscript %d + +(F) You tried to make an array value spring into existence, and the +subscript was probably negative, even counting from end of the array +backwards. + +=item Modification of non-creatable hash value attempted, subscript "%s" + +(F) You tried to make a hash value spring into existence, and it couldn't +be created for some peculiar reason. + +=item Module name must be constant + +(F) Only a bare module name is allowed as the first argument to a "use". + +=item msg%s not implemented + +(F) You don't have System V message IPC on your system. + +=item Multidimensional syntax %s not supported + +(W) Multidimensional arrays aren't written like $foo[1,2,3]. They're written +like $foo[1][2][3], as in C. + +=item Negative length + +(F) You tried to do a read/write/send/recv operation with a buffer length +that is less than 0. This is difficult to imagine. + +=item nested *?+ in regexp + +(F) You can't quantify a quantifier without intervening parens. So +things like ** or +* or ?* are illegal. + +Note, however, that the minimal matching quantifiers, *?, +? and ?? appear +to be nested quantifiers, but aren't. See L<perlre>. + +=item No #! line + +(F) The setuid emulator requires that scripts have a well-formed #! line +even on machines that don't support the #! construct. + +=item No %s allowed while running setuid + +(F) Certain operations are deemed to be too insecure for a setuid or setgid +script to even be allowed to attempt. Generally speaking there will be +another way to do what you want that is, if not secure, at least securable. +See L<perlsec>. + +=item No B<-e> allowed in setuid scripts + +(F) A setuid script can't be specified by the user. + +=item No comma allowed after %s + +(F) A list operator that has a filehandle or "indirect object" is not +allowed to have a comma between that and the following arguments. +Otherwise it'd be just another one of the arguments. + +=item No DB::DB routine defined + +(F) The currently executing code was compiled with the B<-d> switch, +but for some reason the perl5db.pl file (or some facsimile thereof) +didn't define a routine to be called at the beginning of each +statement. Which is odd, because the file should have been required +automatically, and should have blown up the require if it didn't parse +right. + +=item No dbm on this machine + +(P) This is counted as an internal error, because every machine should +supply dbm nowadays, since Perl comes with SDBM. See L<SDBM_File>. + +=item No DBsub routine + +(F) The currently executing code was compiled with the B<-d> switch, +but for some reason the perl5db.pl file (or some facsimile thereof) +didn't define a DB::sub routine to be called at the beginning of each +ordinary subroutine call. + +=item No Perl script found in input + +(F) You called C<perl -x>, but no line was found in the file beginning +with #! and containing the word "perl". + +=item No setregid available + +(F) Configure didn't find anything resembling the setregid() call for +your system. + +=item No setreuid available + +(F) Configure didn't find anything resembling the setreuid() call for +your system. + +=item No space allowed after B<-I> + +(F) The argument to B<-I> must follow the B<-I> immediately with no +intervening space. + +=item No such signal: SIG%s + +(W) You specified a signal name as a subscript to %SIG that was not recognized. +Say C<kill -l> in your shell to see the valid signal names on your system. + +=item Not a CODE reference + +(F) Perl was trying to evaluate a reference to a code value (that is, a +subroutine), but found a reference to something else instead. You can +use the ref() function to find out what kind of ref it really was. +See also L<perlref>. + +=item Not a format reference + +(F) I'm not sure how you managed to generate a reference to an anonymous +format, but this indicates you did, and that it didn't exist. + +=item Not a GLOB reference + +(F) Perl was trying to evaluate a reference to a "type glob" (that is, +a symbol table entry that looks like C<*foo>), but found a reference to +something else instead. You can use the ref() function to find out +what kind of ref it really was. See L<perlref>. + +=item Not a HASH reference + +(F) Perl was trying to evaluate a reference to a hash value, but +found a reference to something else instead. You can use the ref() +function to find out what kind of ref it really was. See L<perlref>. + +=item Not a perl script + +(F) The setuid emulator requires that scripts have a well-formed #! line +even on machines that don't support the #! construct. The line must +mention perl. + +=item Not a SCALAR reference + +(F) Perl was trying to evaluate a reference to a scalar value, but +found a reference to something else instead. You can use the ref() +function to find out what kind of ref it really was. See L<perlref>. + +=item Not a subroutine reference + +(F) Perl was trying to evaluate a reference to a code value (that is, a +subroutine), but found a reference to something else instead. You can +use the ref() function to find out what kind of ref it really was. +See also L<perlref>. + +=item Not a subroutine reference in %OVERLOAD + +(F) An attempt was made to specify an entry in an overloading table that +doesn't somehow point to a valid subroutine. See L<perlovl>. + +=item Not an ARRAY reference + +(F) Perl was trying to evaluate a reference to an array value, but +found a reference to something else instead. You can use the ref() +function to find out what kind of ref it really was. See L<perlref>. + +=item Not enough arguments for %s + +(F) The function requires more arguments than you specified. + +=item Not enough format arguments + +(W) A format specified more picture fields than the next line supplied. +See L<perlform>. + +=item Null filename used + +(F) You can't require the null filename, especially since on many machines +that means the current directory! See L<perlfunc/require>. + +=item NULL OP IN RUN + +(P) Some internal routine called run() with a null opcode pointer. + +=item Null realloc + +(P) An attempt was made to realloc NULL. + +=item NULL regexp argument + +(P) The internal pattern matching routines blew it bigtime. + +=item NULL regexp parameter + +(P) The internal pattern matching routines are out of their gourd. + +=item Odd number of elements in hash list + +(S) You specified an odd number of elements to a hash list, which is odd, +since hash lists come in key/value pairs. + +=item oops: oopsAV + +(S) An internal warning that the grammar is screwed up. + +=item oops: oopsHV + +(S) An internal warning that the grammar is screwed up. + +=item Operation `%s' %s: no method found, + +(F) An attempt was made to use an entry in an overloading table that +somehow no longer points to a valid method. See L<perlovl>. + +=item Out of memory for yacc stack + +(F) The yacc parser wanted to grow its stack so it could continue parsing, +but realloc() wouldn't give it more memory, virtual or otherwise. + +=item Out of memory! + +(X) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. + +=item page overflow + +(W) A single call to write() produced more lines than can fit on a page. +See L<perlform>. + +=item panic: ck_grep + +(P) Failed an internal consistency check trying to compile a grep. + +=item panic: ck_split + +(P) Failed an internal consistency check trying to compile a split. + +=item panic: corrupt saved stack index + +(P) The savestack was requested to restore more localized values than there +are in the savestack. + +=item panic: die %s + +(P) We popped the context stack to an eval context, and then discovered +it wasn't an eval context. + +=item panic: do_match + +(P) The internal pp_match() routine was called with invalid operational data. + +=item panic: do_split + +(P) Something terrible went wrong in setting up for the split. + +=item panic: do_subst + +(P) The internal pp_subst() routine was called with invalid operational data. + +=item panic: do_trans + +(P) The internal do_trans() routine was called with invalid operational data. + +=item panic: goto + +(P) We popped the context stack to a context with the specified label, +and then discovered it wasn't a context we know how to do a goto in. + +=item panic: INTERPCASEMOD + +(P) The lexer got into a bad state at a case modifier. + +=item panic: INTERPCONCAT + +(P) The lexer got into a bad state parsing a string with brackets. + +=item panic: last + +(P) We popped the context stack to a block context, and then discovered +it wasn't a block context. + +=item panic: leave_scope clearsv + +(P) A writable lexical variable became readonly somehow within the scope. + +=item panic: leave_scope inconsistency + +(P) The savestack probably got out of sync. At least, there was an +invalid enum on the top of it. + +=item panic: malloc + +(P) Something requested a negative number of bytes of malloc. + +=item panic: mapstart + +(P) The compiler is screwed up with respect to the map() function. + +=item panic: null array + +(P) One of the internal array routines was passed a null AV pointer. + +=item panic: pad_alloc + +(P) The compiler got confused about which scratch pad it was allocating +and freeing temporaries and lexicals from. + +=item panic: pad_free curpad + +(P) The compiler got confused about which scratch pad it was allocating +and freeing temporaries and lexicals from. + +=item panic: pad_free po + +(P) An invalid scratch pad offset was detected internally. + +=item panic: pad_reset curpad + +(P) The compiler got confused about which scratch pad it was allocating +and freeing temporaries and lexicals from. + +=item panic: pad_sv po + +(P) An invalid scratch pad offset was detected internally. + +=item panic: pad_swipe curpad + +(P) The compiler got confused about which scratch pad it was allocating +and freeing temporaries and lexicals from. + +=item panic: pad_swipe po + +(P) An invalid scratch pad offset was detected internally. + +=item panic: pp_iter + +(P) The foreach iterator got called in a non-loop context frame. + +=item panic: realloc + +(P) Something requested a negative number of bytes of realloc. + +=item panic: restartop + +(P) Some internal routine requested a goto (or something like it), and +didn't supply the destination. + +=item panic: return + +(P) We popped the context stack to a subroutine or eval context, and +then discovered it wasn't a subroutine or eval context. + +=item panic: scan_num + +(P) scan_num() got called on something that wasn't a number. + +=item panic: sv_insert + +(P) The sv_insert() routine was told to remove more string than there +was string. + +=item panic: top_env + +(P) The compiler attempted to do a goto, or something weird like that. + +=item panic: yylex + +(P) The lexer got into a bad state while processing a case modifier. + +=item Parens missing around "%s" list + +(W) You said something like + + my $foo, $bar = @_; + +when you meant + + my ($foo, $bar) = @_; + +Remember that "my" and "local" bind closer than comma. + +=item Perl %3.3f required--this is only version %s, stopped + +(F) The module in question uses features of a version of Perl more recent +than the currently running version. How long has it been since you upgraded, +anyway? See L<perlfunc/require>. + +=item Permission denied + +(F) The setuid emulator in suidperl decided you were up to no good. + +=item POSIX getpgrp can't take an argument + +(F) Your C compiler uses POSIX getpgrp(), which takes no argument, unlike +the BSD version, which takes a pid. + +=item Possible memory corruption: %s overflowed 3rd argument + +(F) An ioctl() or fcntl() returned more than Perl was bargaining for. +Perl guesses a reasonable buffer size, but puts a sentinel byte at the +end of the buffer just in case. This sentinel byte got clobbered, and +Perl assumes that memory is now corrupted. See L<perlfunc/ioctl>. + +=item Precedence problem: open %s should be open(%s) + +(S) The old irregular construct + + open FOO || die; + +is now misinterpreted as + + open(FOO || die); + +because of the strict regularization of Perl 5's grammar into unary and +list operators. (The old open was a little of both.) You must put +parens around the filehandle, or use the new "or" operator instead of "||". + +=item print on closed filehandle %s + +(W) The filehandle you're printing on got itself closed sometime before now. +Check your logic flow. + +=item printf on closed filehandle %s + +(W) The filehandle you're writing to got itself closed sometime before now. +Check your logic flow. + +=item Probable precedence problem on %s + +(W) The compiler found a bare word where it expected a conditional, +which often indicates that an || or && was parsed as part of the +last argument of the previous construct, for example: + + open FOO || die; + +=item Read on closed filehandle <%s> + +(W) The filehandle you're reading from got itself closed sometime before now. +Check your logic flow. + +=item Reallocation too large: %lx + +(F) You can't allocate more than 64K on an MSDOS machine. + +=item Recompile perl with B<-D>DEBUGGING to use B<-D> switch + +(F) You can't use the B<-D> option unless the code to produce the +desired output is compiled into Perl, which entails some overhead, +which is why it's currently left out of your copy. + +=item Recursive inheritance detected + +(F) More than 100 levels of inheritance were used. Probably indicates +an unintended loop in your inheritance hierarchy. + +=item Reference miscount in sv_replace() + +(W) The internal sv_replace() function was handed a new SV with a +reference count of other than 1. + +=item regexp memory corruption + +(P) The regular expression engine got confused by what the regular +expression compiler gave it. + +=item regexp out of space + +(P) A "can't happen" error, because safemalloc() should have caught it earlier. + +=item regexp too big + +(F) The current implementation of regular 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 +way to do it with multiple statements. See L<perlre>. + +=item Reversed %s= operator + +(W) You wrote your assignment operator backwards. The = must always +comes last, to avoid ambiguity with subsequent unary operators. + +=item Runaway format + +(F) Your format contained the ~~ repeat-until-blank sequence, but it +produced 200 lines at once, and the 200th line looked exactly like the +199th line. Apparently you didn't arrange for the arguments to exhaust +themselves, either by using ^ instead of @ (for scalar variables), or by +shifting or popping (for array variables). See L<perlform>. + +=item Scalar value @%s[%s] better written as $%s[%s] + +(W) You've used an array slice (indicated by @) to select a single value of +an array. Generally it's better to ask for a scalar value (indicated by $). +The difference is that $foo[&bar] always behaves like a scalar, both when +assigning to it and when evaluating its argument, while @foo[&bar] behaves +like a list when you assign to it, and provides a list context to its +subscript, which can do weird things if you're only expecting one subscript. + +=item Script is not setuid/setgid in suidperl + +(F) Oddly, the suidperl program was invoked on a script with its setuid +or setgid bit set. This doesn't make much sense. + +=item Search pattern not terminated + +(F) The lexer couldn't find the final delimiter of a // or m{} +construct. Remember that bracketing delimiters count nesting level. + +=item seek() on unopened file + +(W) You tried to use the seek() function on a filehandle that was either +never opened or has been closed since. + +=item select not implemented + +(F) This machine doesn't implement the select() system call. + +=item sem%s not implemented + +(F) You don't have System V semaphore IPC on your system. + +=item semi-panic: attempt to dup freed string + +(S) The internal newSVsv() routine was called to duplicate a scalar +that had previously been marked as free. + +=item Semicolon seems to be missing + +(W) A nearby syntax error was probably caused by a missing semicolon, +or possibly some other missing operator, such as a comma. + +=item Send on closed socket + +(W) The filehandle you're sending to got itself closed sometime before now. +Check your logic flow. + +=item Sequence (?#... not terminated + +(F) A regular expression comment must be terminated by a closing +parenthesis. Embedded parens aren't allowed. See L<perlre>. + +=item Sequence (?%s...) not implemented + +(F) A proposed regular expression extension has the character reserved +but has not yet been written. See L<perlre>. + +=item Sequence (?%s...) not recognized + +(F) You used a regular expression extension that doesn't make sense. +See L<perlre>. + +=item setegid() not implemented + +(F) You tried to assign to $), and your operating system doesn't support +the setegid() system call (or equivalent), or at least Configure didn't +think so. + +=item seteuid() not implemented + +(F) You tried to assign to $>, and your operating system doesn't support +the seteuid() system call (or equivalent), or at least Configure didn't +think so. + +=item setrgid() not implemented + +(F) You tried to assign to $(, and your operating system doesn't support +the setrgid() system call (or equivalent), or at least Configure didn't +think so. + +=item setruid() not implemented + +(F) You tried to assign to $<, and your operating system doesn't support +the setruid() system call (or equivalent), or at least Configure didn't +think so. + +=item Setuid/gid script is writable by world + +(F) The setuid emulator won't run a script that is writable by the world, +because the world might have written on it already. + +=item shm%s not implemented + +(F) You don't have System V shared memory IPC on your system. + +=item shutdown() on closed fd + +(W) You tried to do a shutdown on a closed socket. Seems a bit superfluous. + +=item SIG%s handler "%s" not defined. + +(W) The signal handler named in %SIG doesn't, in fact, exist. Perhaps you +put it into the wrong package? + +=item sort is now a reserved word + +(F) An ancient error message that almost nobody ever runs into anymore. +But before sort was a keyword, people sometimes used it as a filehandle. + +=item Sort subroutine didn't return a numeric value + +(F) A sort comparison routine must return a number. You probably blew +it by not using C<E<lt>=E<gt> or C<cmp>, or by not using them correctly. +See L<perlfunc/sort>. + +=item Sort subroutine didn't return single value + +(F) A sort comparison subroutine may not return a list value with more +or less than one element. See L<perlfunc/sort>. + +=item Split loop + +(P) The split was looping infinitely. (Obviously, a split shouldn't iterate +more times than there are characters of input, which is what happened.) +See L<perlfunc/split>. + +=item Stat on unopened file <%s> + +(W) You tried to use the stat() function (or an equivalent file test) +on a filehandle that was either never opened or has been closed since. + +=item Statement unlikely to be reached + +(W) You did an exec() with some statement after it other than a die(). +This is almost always an error, because exec() never returns unless +there was a failure. You probably wanted to use system() instead, +which does return. To suppress this warning, put the exec() in a block +by itself. + +=item Subroutine %s redefined + +(W) You redefined a subroutine. To suppress this warning, say + + { + local $^W = 0; + eval "sub name { ... }"; + } + +=item Substitution loop + +(P) The substitution was looping infinitely. (Obviously, a +substitution shouldn't iterate more times than there are characters of +input, which is what happened.) See the discussion of substitution in +L<perlop/"Quote and Quotelike Operators">. + +=item Substitution pattern not terminated + +(F) The lexer couldn't find the interior delimiter of a s/// or s{}{} +construct. Remember that bracketing delimiters count nesting level. + +=item Substitution replacement not terminated + +(F) The lexer couldn't find the final delimiter of a s/// or s{}{} +construct. Remember that bracketing delimiters count nesting level. + +=item substr outside of string + +(W) You tried to reference a substr() that pointed outside of a string. +That is, the absolute value of the offset was larger than the length of +the string. See L<perlfunc/substr>. + +=item suidperl is no longer needed since... + +(F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but a +version of the setuid emulator somehow got run anyway. + +=item syntax error + +(F) Probably means you had a syntax error. Common reasons include: + + A keyword is misspelled. + A semicolon is missing. + A comma is missing. + An opening or closing parenthesis is missing. + An opening or closing brace is missing. + A closing quote is missing. + +Often there will be another error message associated with the syntax +error giving more information. (Sometimes it helps to turn on B<-w>.) +The error message itself often tells you where it was in the line when +it decided to give up. Sometimes the actual error is several tokens +before this, since Perl is good at understanding random input. +Occasionally the line number may be misleading, and once in a blue moon +the only way to figure out what's triggering the error is to call +C<perl -c> repeatedly, chopping away half the program each time to see +if the error went away. Sort of the cybernetic version of S<20 questions>. + +=item System V IPC is not implemented on this machine + +(F) You tried to do something with a function beginning with "sem", "shm" +or "msg". See L<perlfunc/semctl>, for example. + +=item Syswrite on closed filehandle + +(W) The filehandle you're writing to got itself closed sometime before now. +Check your logic flow. + +=item tell() on unopened file + +(W) You tried to use the tell() function on a filehandle that was either +never opened or has been closed since. + +=item Test on unopened file <%s> + +(W) You tried to invoke a file test operator on a filehandle that isn't +open. Check your logic. See also L<perlfunc/-X>. + +=item That use of $[ is unsupported + +(F) Assignment to $[ is now strictly circumscribed, and interpreted as +a compiler directive. You may only say one of + + $[ = 0; + $[ = 1; + ... + local $[ = 0; + local $[ = 1; + ... + +This is to prevent the problem of one module changing the array base +out from under another module inadvertently. See L<perlvar/$[>. + +=item The %s function is unimplemented + +The function indicated isn't implemented on this architecture, according +to the probings of Configure. + +=item The crypt() function is unimplemented due to excessive paranoia. + +(F) Configure couldn't find the crypt() function on your machine, +probably because your vendor didn't supply it, probably because they +think the U.S. Govermnment thinks it's a secret, or at least that they +will continue to pretend that it is. And if you quote me on that, I +will deny it. + +=item The stat preceding C<-l _> wasn't an lstat + +(F) It makes no sense to test the current stat buffer for symbolic linkhood +if the last stat that wrote to the stat buffer already went past +the symlink to get to the real file. Use an actual filename instead. + +=item times not implemented + +(F) Your version of the C library apparently doesn't do times(). I suspect +you're not running on Unix. + +=item Too few args to syscall + +(F) There has to be at least one argument to syscall() to specify the +system call to call, silly dilly. + +=item Too many args to syscall + +(F) Perl only supports a maximum of 14 args to syscall(). + +=item Too many arguments for %s + +(F) The function requires fewer arguments than you specified. + +=item trailing \ in regexp + +(F) The regular expression ends with an unbackslashed backslash. Backslash +it. See L<perlre>. + +=item Translation pattern not terminated + +(F) The lexer couldn't find the interior delimiter of a tr/// or tr[][] +construct. + +=item Translation replacement not terminated + +(F) The lexer couldn't find the final delimiter of a tr/// or tr[][] +construct. + +=item truncate not implemented + +(F) Your machine doesn't implement a file truncation mechanism that +Configure knows about. + +=item Type of arg %d to %s must be %s (not %s) + +(F) This function requires the argument in that position to be of a +certain type. Arrays must be @NAME or @{EXPR}. Hashes must be +%NAME or %{EXPR}. No implicit dereferencing is allowed--use the +{EXPR} forms as an explicit dereference. See L<perlref>. + +=item umask: argument is missing initial 0 + +(W) A umask of 222 is incorrect. It should be 0222, since octal literals +always start with 0 in Perl, as in C. + +=item Unbalanced context: %d more PUSHes than POPs + +(W) The exit code detected an internal inconsistency in how many execution +contexts were entered and left. + +=item Unbalanced saves: %d more saves than restores + +(W) The exit code detected an internal inconsistency in how many +values were temporarily localized. + +=item Unbalanced scopes: %d more ENTERs than LEAVEs + +(W) The exit code detected an internal inconsistency in how many blocks +were entered and left. + +=item Unbalanced tmps: %d more allocs than frees + +(W) The exit code detected an internal inconsistency in how many mortal +scalars were allocated and freed. + +=item Undefined format "%s" called + +(F) The format indicated doesn't seem to exist. Perhaps it's really in +another package? See L<perlform>. + +=item Undefined sort subroutine "%s" called + +(F) The sort comparison routine specified doesn't seem to exist. Perhaps +it's in a different package? See L<perlfunc/sort>. + +=item Undefined subroutine &%s called + +(F) The subroutine indicated hasn't been defined, or if it was, it +has since been undefined. + +=item Undefined subroutine called + +(F) The anonymous subroutine you're trying to call hasn't been defined, +or if it was, it has since been undefined. + +=item Undefined subroutine in sort + +(F) The sort comparison routine specified is declared but doesn't seem to +have been defined yet. See L<perlfunc/sort>. + +=item unexec of %s into %s failed! + +(F) The unexec() routine failed for some reason. See your local FSF +representative, who probably put it there in the first place. + +=item Unknown BYTEORDER + +(F) There are no byteswapping functions for a machine with this byte order. + +=item unmatched () in regexp + +(F) Unbackslashed parentheses must always be balanced in regular +expressions. If you're a vi user, the % key is valuable for finding +the matching paren. See L<perlre>. + +=item Unmatched right bracket + +(F) The lexer counted more closing curly brackets (braces) than opening +ones, so you're probably missing an opening bracket. As a general +rule, you'll find the missing one (so to speak) near the place you were +last editing. + +=item unmatched [] in regexp + +(F) The brackets around a character class must match. If you wish to +include a closing bracket in a character class, backslash it or put it first. +See L<perlre>. + +=item Unquoted string "%s" may clash with future reserved word + +(W) You used a bare word that might someday be claimed as a reserved word. +It's best to put such a word in quotes, or capitalize it somehow, or insert +an underbar into it. You might also declare it as a subroutine. + +=item Unrecognized character \%03o ignored + +(S) A garbage character was found in the input, and ignored, in case it's +a weird control character on an EBCDIC machine, or some such. + +=item Unrecognized signal name "%s" + +(F) You specified a signal name to the kill() function that was not recognized. +Say C<kill -l> in your shell to see the valid signal names on your system. + +=item Unrecognized switch: -%s + +(F) You specified an illegal option to Perl. Don't do that. +(If you think you didn't do that, check the #! line to see if it's +supplying the bad switch on your behalf.) + +=item Unsuccessful %s on filename containing newline + +(W) A file operation was attempted on a filename, and that operation +failed, PROBABLY because the filename contained a newline, PROBABLY +because you forgot to chop() or chomp() it off. See L<perlfunc/chop>. + +=item Unsupported directory function "%s" called + +(F) Your machine doesn't support opendir() and readdir(). + +=item Unsupported function %s + +(F) This machines doesn't implement the indicated function, apparently. +At least, Configure doesn't think so. + +=item Unsupported socket function "%s" called + +(F) Your machine doesn't support the Berkeley socket mechanism, or at +least that's what Configure thought. + +=item Unterminated <> operator + +(F) The lexer saw a left angle bracket in a place where it was expecting +a term, so it's looking for the corresponding right angle bracket, and not +finding it. Chances are you left some needed parentheses out earlier in +the line, and you really meant a "less than". + +=item Use of $# is deprecated + +(D) This was an ill-advised attempt to emulate a poorly defined awk feature. +Use an explicit printf() or sprintf() instead. + +=item Use of $* is deprecated + +(D) This variable magically turned on multiline pattern matching, both for +you and for any luckless subroutine that you happen to call. You should +use the new C<//m> and C<//s> modifiers now to do that without the dangerous +action-at-a-distance effects of C<$*>. + +=item Use of %s is deprecated + +(D) The construct indicated is no longer recommended for use, generally +because there's a better way to do it, and also because the old way has +bad side effects. + +=item Use of implicit split to @_ is deprecated + +(D) It makes a lot of work for the compiler when you clobber a +subroutine's argument list, so it's better if you assign the results of +a split() explicitly to an array (or list). + +=item Use of uninitialized value + +(W) An undefined value was used as if it were already defined. It was +interpreted as a "" or a 0, but maybe it was a mistake. To suppress this +warning assign an initial value to your variables. + +=item Useless use of %s in void context + +(W) You did something without a side effect in a context that does nothing +with the return value, such as a statement that doesn't return a value +from a block, or the left side of a scalar comma operator. Very often +this points not to stupidity on your part, but a failure of Perl to parse +your program the way you thought it would. For example, you'd get this +if you mixed up your C precedence with Python precedence and said + + $one, $two = 1, 2; + +when you meant to say + + ($one, $two) = (1, 2); + +=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 + +(S) You wrote a unary operator followed by something that looks like a +binary operator that could also have been interpreted as a term or +unary operator. For instance, if you know that the rand function +has a default argument of 1.0, and you write + + rand + 5; + +you may THINK you wrote the same thing as + + rand() + 5; + +but in actual fact, you got + + rand(+5); + +So put in parens to say what you really mean. + +=item Write on closed filehandle + +(W) The filehandle you're writing to got itself closed sometime before now. +Check your logic flow. + +=item X outside of string + +(F) You had a pack template that specified a relative position before +the beginning of the string being unpacked. See L<perlfunc/pack>. + +=item x outside of string + +(F) You had a pack template that specified a relative position after +the end of the string being unpacked. See L<perlfunc/pack>. + +=item Xsub "%s" called in sort + +(F) The use of an external subroutine as a sort comparison is not yet supported. + +=item Xsub called in sort + +(F) The use of an external subroutine as a sort comparison is not yet supported. + +=item You can't use C<-l> on a filehandle + +(F) A filehandle represents an opened file, and when you opened the file it +already went past any symlink you are presumably trying to look for. +Use a filename instead. + +=item YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! + +(F) And you probably never will, since you probably don't have the +sources to your kernel, and your vendor probably doesn't give a rip +about what you want. Your best bet is to use the wrapsuid script in +the eg directory to put a setuid C wrapper around your script. + +=item You need to quote "%s" + +(W) You assigned a bareword as a signal handler name. Unfortunately, you +already have a subroutine of that name declared, which means that Perl 5 +will try to call the subroutine when the assignment is executed, which is +probably not what you want. (If it IS what you want, put an & in front.) + +=item [gs]etsockopt() on closed fd + +(W) You tried to get or set a socket option on a closed socket. +Did you forget to check the return value of your socket() call? +See L<perlfunc/getsockopt>. + +=item \1 better written as $1 + +(W) Outside of patterns, backreferences live on as variables. The use +of backslashes is grandfathered on the righthand side of a +substitution, but stylistically it's better to use the variable form +because other Perl programmers will expect it, and it works better +if there are more than 9 backreferences. + +=back + diff --git a/pod/perlembed.pod b/pod/perlembed.pod new file mode 100644 index 0000000000..5ac5a9e0c6 --- /dev/null +++ b/pod/perlembed.pod @@ -0,0 +1,7 @@ +=head1 NAME + +perlembed - how to embed perl in your C or C++ app + +=head1 DESCRIPTION + +Look at perlmain.c, and do something like that. diff --git a/pod/perlform.pod b/pod/perlform.pod new file mode 100644 index 0000000000..38d7153e8b --- /dev/null +++ b/pod/perlform.pod @@ -0,0 +1,314 @@ +=head1 NAME + +perlform - Perl formats + +=head1 DESCRIPTION + +Perl has a mechanism to help you generate simple reports and charts. To +facilitate this, Perl helps you lay out your output page in your code in a +fashion that's close to how it will look when it's printed. It can keep +track of things like how many lines on a page, what page you're, when to +print page headers, etc. The keywords used are borrowed from FORTRAN: +format() to declare and write() to execute; see their entries in +L<manfunc>. Fortunately, the layout is much more legible, more like +BASIC's PRINT USING statement. Think of it as a poor man's nroff(1). + +Formats, like packages and subroutines, are declared rather than executed, +so they may occur at any point in your program. (Usually it's best to +keep them all together though.) They have their own namespace apart from +all the other "types" in Perl. This means that if you have a function +named "Foo", it is not the same thing as having a format named "Foo". +However, the default name for the format associated with a given +filehandle is the same as the name of the filehandle. Thus, the default +format for STDOUT is name "STDOUT", and the default format for filehandle +TEMP is name "TEMP". They just look the same. They aren't. + +Output record formats are declared as follows: + + format NAME = + FORMLIST + . + +If name is omitted, format "STDOUT" is defined. FORMLIST consists of a +sequence of lines, each of which may be of one of three types: + +=over 4 + +=item 1. + +A comment, indicated by putting a '#' in the first column. + +=item 2. + +A "picture" line giving the format for one output line. + +=item 3. + +An argument line supplying values to plug into the previous picture line. + +=back + +Picture lines are printed exactly as they look, except for certain fields +that substitute values into the line. Each field in a picture line starts +with either "@" (at) or "^" (caret). These lines do not undergo any kind +of variable interpolation. The at field (not to be confused with the array +marker @) is the normal kind of field; the other kind, caret fields, are used +to do rudimentary multi-line text block filling. The length of the field +is supplied by padding out the field with multiple "<", ">", or "|" +characters to specify, respectively, left justification, right +justification, or centering. If the variable would exceed the width +specified, it is truncated. + +As an alternate form of right justification, you may also use "#" +characters (with an optional ".") to specify a numeric field. This way +you can line up the decimal points. If any value supplied for these +fields contains a newline, only the text up to the newline is printed. +Finally, the special field "@*" can be used for printing multi-line, +non-truncated values; it should appear by itself on a line. + +The values are specified on the following line in the same order as +the picture fields. The expressions providing the values should be +separated by commas. The expressions are all evaluated in a list context +before the line is processed, so a single list expression could produce +multiple list elements. The expressions may be spread out to more than +one line if enclosed in braces. If so, the opening brace must be the first +token on the first line. + +Picture fields that begin with ^ rather than @ are treated specially. +With a # field, the field is blanked out if the value is undefined. For +other field types, the caret enables a kind of fill mode. Instead of an +arbitrary expression, the value supplied must be a scalar variable name +that contains a text string. Perl puts as much text as it can into the +field, and then chops off the front of the string so that the next time +the variable is referenced, more of the text can be printed. (Yes, this +means that the variable itself is altered during execution of the write() +call, and is not returned.) Normally you would use a sequence of fields +in a vertical stack to print out a block of text. You might wish to end +the final field with the text "...", which will appear in the output if +the text was too long to appear in its entirety. You can change which +characters are legal to break on by changing the variable C<$:> (that's +$FORMAT_LINE_BREAK_CHARACTERS if you're using the English module) to a +list of the desired characters. + +Since use of caret fields can produce variable length records. If the text +to be formatted is short, you can suppress blank lines by putting a +"~" (tilde) character anywhere in the line. The tilde will be translated +to a space upon output. If you put a second tilde contiguous to the +first, the line will be repeated until all the fields on the line are +exhausted. (If you use a field of the at variety, the expression you +supply had better not give the same value every time forever!) + +Top-of-form processing is by default handled by a format with the +same name as the current filehandle with "_TOP" concatenated to it. +It's triggered at the top of each page. See <perlfunc/write()>. + +Examples: + + # a report on the /etc/passwd file + format STDOUT_TOP = + Passwd File + Name Login Office Uid Gid Home + ------------------------------------------------------------------ + . + format STDOUT = + @<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<< + $name, $login, $office,$uid,$gid, $home + . + + + # a report from a bug report form + format STDOUT_TOP = + Bug Reports + @<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>> + $system, $%, $date + ------------------------------------------------------------------ + . + format STDOUT = + Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $subject + Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $index, $description + Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $priority, $date, $description + From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $from, $description + Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $programmer, $description + ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $description + ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $description + ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $description + ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $description + ~ ^<<<<<<<<<<<<<<<<<<<<<<<... + $description + . + +It is possible to intermix print()s with write()s on the same output +channel, but you'll have to handle $- ($FORMAT_LINES_LEFT) +yourself. + +=head2 Format Variables + +The current format name is stored in the variable C<$~> ($FORMAT_NAME), +and the current top of form format name is in C<$^> ($FORMAT_TOP_NAME). +The current output page number is stored in C<$%> ($FORMAT_PAGE_NUMBER), +and the number of lines on the page is in C<$=> ($FORMAT_LINES_PER_PAGE). +Whether to autoflush output on this handle is stored in $<$|> +($OUTPUT_AUTOFLUSH). The string output before each top of page (except +the first) is stored in C<$^L> ($FORMAT_FORMFEED). These variables are +set on a per-filehandle basis, so you'll need to select() into a different +one to affect them: + + select((select(OUTF), + $~ = "My_Other_Format", + $^ = "My_Top_Format" + )[0]); + +Pretty ugly, eh? It's a common idiom though, so don't be too surprised +when you see it. You can at least use a temporary variable to hold +the previous filehandle: (this is a much better approach in general, +because not only does legibility improve, you now have intermediary +stage in the expression to single-step the debugger through): + + $ofh = select(OUTF); + $~ = "My_Other_Format"; + $^ = "My_Top_Format"; + select($ofh); + +If you use the English module, you can even read the variable names: + + use English; + $ofh = select(OUTF); + $FORMAT_NAME = "My_Other_Format"; + $FORMAT_TOP_NAME = "My_Top_Format"; + select($ofh); + +But you still have those funny select()s. So just use the FileHandle +module. Now, you can access these special variables using lower-case +method names instead: + + use FileHandle; + format_name OUTF "My_Other_Format"; + format_top_name OUTF "My_Top_Format"; + +Much better! + +=head1 NOTES + +Since the values line may contain arbitrary expression (for at fields, +not caret fields), you can farm out any more sophisticated processing +to other functions, like sprintf() or one of your own. For example: + + format Ident = + @<<<<<<<<<<<<<<< + &commify($n) + . + +To get a real at or caret into the field, do this: + + format Ident = + I have an @ here. + "@" + . + +To center a whole line of text, do something like this: + + format Ident = + @||||||||||||||||||||||||||||||||||||||||||||||| + "Some text line" + . + +There is no builtin way to say "float this to the right hand side +of the page, however wide it is." You have to specify where it goes. +The truly desperate can generate their own format on the fly, based +on the current number of columns, and then eval() it: + + $format = "format STDOUT = \n"; + . '^' . '<' x $cols . "\n"; + . '$entry' . "\n"; + . "\t^" . "<" x ($cols-8) . "~~\n"; + . '$entry' . "\n"; + . ".\n"; + print $format if $Debugging; + eval $format; + die $@ if $@; + +Which would generate a format looking something like this: + + format STDOUT = + ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $entry + ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~ + $entry + . + +Here's a little program that's somewhat like fmt(1): + + format = + ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ + $_ + + . + + $/ = ''; + while (<>) { + s/\s*\n\s*/ /g; + write; + } + +=head2 Footers + +While $FORMAT_TOP_NAME contains the name of the current header format, +there is no corresponding mechanism to automatically do the same thing +for a footer. Not knowing how big a format is going to be until you +evaluate it is one of the major problems. It's on the TODO list. + +Here's one strategy: If you have a fixed-size footer, you can get footers +by checking $FORMAT_LINES_LEFT before each write() and print the footer +yourself if necessary. + +Here's another strategy; open a pipe to yourself, using C<open(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 + +For low-level access to the formatting mechanism. you may use formline() +and access C<$^A> (the $ACCUMULATOR variable) directly. + +For example: + + $str = formline <<'END', 1,2,3; + @<<< @||| @>>> + END + + print "Wow, I just stored `$^A' in the accumulator!\n"; + +Or to make an swrite() subroutine which is to write() what sprintf() +is to printf(), do this: + + use English; + use Carp; + sub swrite { + croak "usage: swrite PICTURE ARGS" unless @ARG; + local($ACCUMULATOR); + formline(@ARG); + return $ACCUMULATOR; + } + + $string = swrite(<<'END', 1, 2, 3); + Check me out + @<<< @||| @>>> + END + print $string; + +=head1 WARNING + +During the execution of a format, only global variables are visible, +or dynamically-scoped ones declared with local(). Lexically scoped +variables declared with my() are I<NOT> available, as they are not +considered to reside in the same lexical scope as the format. diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod new file mode 100644 index 0000000000..d5aa3aa0b3 --- /dev/null +++ b/pod/perlfunc.pod @@ -0,0 +1,2896 @@ +=head1 NAME + +perlfunc - Perl builtin functions + +=head1 DESCRIPTION + +The functions in this section can serve as terms in an expression. +They fall into two major categories: list operators and named unary +operators. These differ in their precedence relationship with a +following comma. (See the precedence table in L<perlop>.) List +operators take more than one argument, while unary operators can never +take more than one argument. Thus, a comma terminates the argument of +a unary operator, but merely separates the arguments of a list +operator. A unary operator generally provides a scalar context to its +argument, while a list operator may provide either scalar and list +contexts for its arguments. If it does both, the scalar arguments will +be first, and the list argument will follow. (Note that there can only +ever be one list argument.) For instance, splice() has three scalar +arguments followed by a list. + +In the syntax descriptions that follow, list operators that expect a +list (and provide list context for the elements of the list) are shown +with LIST as an argument. Such a list may consist of any combination +of scalar arguments or list values; the list values will be included +in the list as if each individual element were interpolated at that +point in the list, forming a longer single-dimensional list value. +Elements of the LIST should be separated by commas. + +Any function in the list below may be used either with or without +parentheses around its arguments. (The syntax descriptions omit the +parens.) If you use the parens, the simple (but occasionally +surprising) rule is this: It I<LOOKS> like a function, therefore it I<IS> a +function, and precedence doesn't matter. Otherwise it's a list +operator or unary operator, and precedence does matter. And whitespace +between the function and left parenthesis doesn't count--so you need to +be careful sometimes: + + print 1+2+3; # Prints 6. + print(1+2) + 3; # Prints 3. + print (1+2)+3; # Also prints 3! + print +(1+2)+3; # Prints 6. + print ((1+2)+3); # Prints 6. + +If you run Perl with the B<-w> switch it can warn you about this. For +example, the third line above produces: + + print (...) interpreted as function at - line 1. + Useless use of integer addition in void context at - line 1. + +For functions that can be used in either a scalar or list context, +non-abortive failure is generally indicated in a scalar context by +returning the undefined value, and in a list context by returning the +null list. + +Remember the following rule: + +=over 5 + +=item * + +I<THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR!> + +=back + +Each operator and function decides which sort of value it would be most +appropriate to return in a scalar context. Some operators return the +length of the list that would have been returned in a list context. Some +operators return the first value in the list. Some operators return the +last value in the list. Some operators return a count of successful +operations. In general, they do what you want, unless you want +consistency. + +=over 8 + +=item -X FILEHANDLE + +=item -X EXPR + +=item -X + +A file test, where X is one of the letters listed below. This unary +operator takes one argument, either a filename or a filehandle, and +tests the associated file to see if something is true about it. If the +argument is omitted, tests $_, except for C<-t>, which tests STDIN. +Unless otherwise documented, it returns C<1> for TRUE and C<''> for FALSE, or +the undefined value if the file doesn't exist. Despite the funny +names, precedence is the same as any other named unary operator, and +the argument may be parenthesized like any other unary operator. The +operator may be any of: + + -r File is readable by effective uid/gid. + -w File is writable by effective uid/gid. + -x File is executable by effective uid/gid. + -o File is owned by effective uid. + + -R File is readable by real uid/gid. + -W File is writable by real uid/gid. + -X File is executable by real uid/gid. + -O File is owned by real uid. + + -e File exists. + -z File has zero size. + -s File has non-zero size (returns size). + + -f File is a plain file. + -d File is a directory. + -l File is a symbolic link. + -p File is a named pipe (FIFO). + -S File is a socket. + -b File is a block special file. + -c File is a character special file. + -t Filehandle is opened to a tty. + + -u File has setuid bit set. + -g File has setgid bit set. + -k File has sticky bit set. + + -T File is a text file. + -B File is a binary file (opposite of -T). + + -M Age of file in days when script started. + -A Same for access time. + -C Same for inode change time. + +The interpretation of the file permission operators C<-r>, C<-R>, C<-w>, +C<-W>, C<-x> and C<-X> is based solely on the mode of the file and the +uids and gids of the user. There may be other reasons you can't actually +read, write or execute the file. Also note that, for the superuser, +C<-r>, C<-R>, C<-w> and C<-W> always return 1, and C<-x> and C<-X> return +1 if any execute bit is set in the mode. Scripts run by the superuser may +thus need to do a stat() in order to determine the actual mode of the +file, or temporarily set the uid to something else. + +Example: + + while (<>) { + chop; + next unless -f $_; # ignore specials + ... + } + +Note that C<-s/a/b/> does not do a negated substitution. Saying +C<-exp($foo)> still works as expected, however--only single letters +following a minus are interpreted as file tests. + +The C<-T> and C<-B> switches work as follows. The first block or so of the +file is examined for odd characters such as strange control codes or +characters with the high bit set. If too many odd characters (>30%) +are found, it's a C<-B> file, otherwise it's a C<-T> file. Also, any file +containing null in the first block is considered a binary file. If C<-T> +or C<-B> is used on a filehandle, the current stdio buffer is examined +rather than the first block. Both C<-T> and C<-B> return TRUE on a null +file, or a file at EOF when testing a filehandle. + +If any of the file tests (or either the stat() or lstat() operators) are given the +special filehandle consisting of a solitary underline, then the stat +structure of the previous file test (or stat operator) is used, saving +a system call. (This doesn't work with C<-t>, and you need to remember +that lstat() and C<-l> will leave values in the stat structure for the +symbolic link, not the real file.) Example: + + print "Can do.\n" if -r $a || -w _ || -x _; + + stat($filename); + print "Readable\n" if -r _; + print "Writable\n" if -w _; + print "Executable\n" if -x _; + print "Setuid\n" if -u _; + print "Setgid\n" if -g _; + print "Sticky\n" if -k _; + print "Text\n" if -T _; + print "Binary\n" if -B _; + +=item abs VALUE + +Returns the absolute value of its argument. + +=item accept NEWSOCKET,GENERICSOCKET + +Accepts an incoming socket connect, just as the accept(2) system call +does. Returns the packed address if it succeeded, FALSE otherwise. +See example in L<perlipc>. + +=item alarm SECONDS + +Arranges to have a SIGALRM delivered to this process after the +specified number of seconds have elapsed. (On some machines, +unfortunately, the elapsed time may be up to one second less than you +specified because of how seconds are counted.) Only one timer may be +counting at once. Each call disables the previous timer, and an +argument of 0 may be supplied to cancel the previous timer without +starting a new one. The returned value is the amount of time remaining +on the previous timer. + +For sleeps of finer granularity than one second, you may use Perl's +syscall() interface to access setitimer(2) if your system supports it, +or else see L</select()> below. + +=item atan2 Y,X + +Returns the arctangent of Y/X in the range -PI to PI. + +=item bind SOCKET,NAME + +Binds a network address to a socket, just as the bind system call +does. Returns TRUE if it succeeded, FALSE otherwise. NAME should be a +packed address of the appropriate type for the socket. See example in +L<perlipc>. + +=item binmode FILEHANDLE + +Arranges for the file to be read or written in "binary" mode in +operating systems that distinguish between binary and text files. +Files that are not in binary mode have CR LF sequences translated to LF +on input and LF translated to CR LF on output. Binmode has no effect +under Unix; in DOS, it may be imperative. If FILEHANDLE is an expression, +the value is taken as the name of the filehandle. + +=item bless REF,PACKAGE + +=item bless REF + +This function tells the referenced object (passed as REF) that it is now +an object in PACKAGE--or the current package if no PACKAGE is specified, +which is the usual case. It returns the reference for convenience, since +a bless() is often the last thing in a constructor. See L<perlobj> for +more about the blessing (and blessings) of objects. + +=item caller EXPR + +=item caller + +Returns the context of the current subroutine call. In a scalar context, +returns TRUE if there is a caller, that is, if we're in a subroutine or +eval() or require(), and FALSE otherwise. In a list context, returns + + ($package,$filename,$line) = caller; + +With EXPR, it returns some extra information that the debugger uses to +print a stack trace. The value of EXPR indicates how many call frames +to go back before the current one. + +=item chdir EXPR + +Changes the working directory to EXPR, if possible. If EXPR is +omitted, changes to home directory. Returns TRUE upon success, FALSE +otherwise. See example under die(). + +=item chmod LIST + +Changes the permissions of a list of files. The first element of the +list must be the numerical mode. Returns the number of files +successfully changed. + + $cnt = chmod 0755, 'foo', 'bar'; + chmod 0755, @executables; + +=item chomp VARIABLE + +=item chomp LIST + +=item chomp + +This is a slightly safer version of chop (see below). It removes any +line ending that corresponds to the current value of C<$/> (also known as +$INPUT_RECORD_SEPARATOR in the C<English> module). It returns the number +of characters removed. It's often used to remove the newline from the +end of an input record when you're worried that the final record may be +missing its newline. When in paragraph mode (C<$/ = "">), it removes all +trailing newlines from the string. If VARIABLE is omitted, it chomps +$_. Example: + + while (<>) { + chomp; # avoid \n on last field + @array = split(/:/); + ... + } + +You can actually chomp anything that's an lvalue, including an assignment: + + chomp($cwd = `pwd`); + chomp($answer = <STDIN>); + +If you chomp a list, each element is chomped, and the total number of +characters removed is returned. + +=item chop VARIABLE + +=item chop LIST + +=item chop + +Chops off the last character of a string and returns the character +chopped. It's used primarily to remove the newline from the end of an +input record, but is much more efficient than C<s/\n//> because it neither +scans nor copies the string. If VARIABLE is omitted, chops $_. +Example: + + while (<>) { + chop; # avoid \n on last field + @array = split(/:/); + ... + } + +You can actually chop anything that's an lvalue, including an assignment: + + chop($cwd = `pwd`); + chop($answer = <STDIN>); + +If you chop a list, each element is chopped. Only the value of the +last chop is returned. + +=item chown LIST + +Changes the owner (and group) of a list of files. The first two +elements of the list must be the I<NUMERICAL> uid and gid, in that order. +Returns the number of files successfully changed. + + $cnt = chown $uid, $gid, 'foo', 'bar'; + chown $uid, $gid, @filenames; + +Here's an example that looks up non-numeric uids in the passwd file: + + print "User: "; + chop($user = <STDIN>); + print "Files: " + chop($pattern = <STDIN>); + + ($login,$pass,$uid,$gid) = getpwnam($user) + or die "$user not in passwd file"; + + @ary = <${pattern}>; # expand filenames + chown $uid, $gid, @ary; + +=item chr NUMBER + +Returns the character represented by that NUMBER in the character set. +For example, C<chr(65)> is "A" in ASCII. + +=item chroot FILENAME + +Does the same as the system call of that name. If you don't know what +it does, don't worry about it. If FILENAME is omitted, does chroot to +$_. + +=item close FILEHANDLE + +Closes the file or pipe associated with the file handle, returning TRUE +only if stdio successfully flushes buffers and closes the system file +descriptor. You don't have to close FILEHANDLE if you are immediately +going to do another open on it, since open will close it for you. (See +open().) However, an explicit close on an input file resets the line +counter ($.), while the implicit close done by open() does not. Also, +closing a pipe will wait for the process executing on the pipe to +complete, in case you want to look at the output of the pipe +afterwards. Closing a pipe explicitly also puts the status value of +the command into C<$?>. Example: + + open(OUTPUT, '|sort >foo'); # pipe to sort + ... # print stuff to output + close OUTPUT; # wait for sort to finish + open(INPUT, 'foo'); # get sort's results + +FILEHANDLE may be an expression whose value gives the real filehandle name. + +=item closedir DIRHANDLE + +Closes a directory opened by opendir(). + +=item connect SOCKET,NAME + +Attempts to connect to a remote socket, just as the connect system call +does. Returns TRUE if it succeeded, FALSE otherwise. NAME should be a +package address of the appropriate type for the socket. See example in +L<perlipc>. + +=item cos EXPR + +Returns the cosine of EXPR (expressed in radians). If EXPR is omitted +takes cosine of $_. + +=item crypt PLAINTEXT,SALT + +Encrypts a string exactly like the crypt(3) function in the C library. +Useful for checking the password file for lousy passwords, amongst +other things. Only the guys wearing white hats should do this. + +Here's an example that makes sure that whoever runs this program knows +their own password: + + $pwd = (getpwuid($<))[1]; + $salt = substr($pwd, 0, 2); + + system "stty -echo"; + print "Password: "; + chop($word = <STDIN>); + print "\n"; + system "stty echo"; + + if (crypt($word, $salt) ne $pwd) { + die "Sorry...\n"; + } else { + print "ok\n"; + } + +Of course, typing in your own password to whoever asks you +for it is unwise at best. + +=item dbmclose ASSOC_ARRAY + +[This function has been superseded by the untie() function.] + +Breaks the binding between a DBM file and an associative array. + +=item dbmopen ASSOC,DBNAME,MODE + +[This function has been superseded by the tie() function.] + +This binds a dbm(3) or ndbm(3) file to an associative array. ASSOC is the +name of the associative array. (Unlike normal open, the first argument +is I<NOT> a filehandle, even though it looks like one). DBNAME is the +name of the database (without the F<.dir> or F<.pag> extension). If the +database does not exist, it is created with protection specified by +MODE (as modified by the umask()). If your system only supports the +older DBM functions, you may perform only one dbmopen() in your program. +If your system has neither DBM nor ndbm, calling dbmopen() produces a +fatal error. + +If you don't have write access to the DBM file, you can only read +associative array variables, not set them. If you want to test whether +you can write, either use file tests or try setting a dummy array entry +inside an eval(), which will trap the error. + +Note that functions such as keys() and values() may return huge array +values when used on large DBM files. You may prefer to use the each() +function to iterate over large DBM files. Example: + + # print out history file offsets + dbmopen(%HIST,'/usr/lib/news/history',0666); + while (($key,$val) = each %HIST) { + print $key, ' = ', unpack('L',$val), "\n"; + } + dbmclose(%HIST); + +=item defined EXPR + +Returns a boolean value saying whether the lvalue EXPR has a real value +or not. Many operations return the undefined value under exceptional +conditions, such as end of file, uninitialized variable, system error +and such. This function allows you to distinguish between an undefined +null scalar and a defined null scalar with operations that might return +a real null string, such as referencing elements of an array. You may +also check to see if arrays or subroutines exist. Use of defined on +predefined variables is not guaranteed to produce intuitive results. + +When used on a hash array element, it tells you whether the value +is defined, not whether the key exists in the hash. Use exists() for that. + +Examples: + + print if defined $switch{'D'}; + print "$val\n" while defined($val = pop(@ary)); + die "Can't readlink $sym: $!" + unless defined($value = readlink $sym); + eval '@foo = ()' if defined(@foo); + die "No XYZ package defined" unless defined %_XYZ; + sub foo { defined &$bar ? &$bar(@_) : die "No bar"; } + +See also undef(). + +=item delete EXPR + +Deletes the specified value from its hash array. Returns the deleted +value, or the undefined value if nothing was deleted. Deleting from +C<$ENV{}> modifies the environment. Deleting from an array tied to a DBM +file deletes the entry from the DBM file. (But deleting from a tie()d +hash doesn't necessarily return anything.) + +The following deletes all the values of an associative array: + + foreach $key (keys %ARRAY) { + delete $ARRAY{$key}; + } + +(But it would be faster to use the undef() command.) Note that the +EXPR can be arbitrarily complicated as long as the final operation is +a hash key lookup: + + delete $ref->[$x][$y]{$key}; + +=item die LIST + +Outside of an eval(), prints the value of LIST to C<STDERR> and exits with +the current value of $! (errno). If $! is 0, exits with the value of +C<($? E<gt>E<gt> 8)> (`command` status). If C<($? E<gt>E<gt> 8)> is 0, +exits with 255. Inside an eval(), the error message is stuffed into C<$@>. +and the eval() is terminated with the undefined value. + +Equivalent examples: + + die "Can't cd to spool: $!\n" unless chdir '/usr/spool/news'; + chdir '/usr/spool/news' or die "Can't cd to spool: $!\n" + +If the value of EXPR does not end in a newline, the current script line +number and input line number (if any) are also printed, and a newline +is supplied. Hint: sometimes appending ", stopped" to your message +will cause it to make better sense when the string "at foo line 123" is +appended. Suppose you are running script "canasta". + + die "/etc/games is no good"; + die "/etc/games is no good, stopped"; + +produce, respectively + + /etc/games is no good at canasta line 123. + /etc/games is no good, stopped at canasta line 123. + +See also exit() and warn(). + +=item do BLOCK + +Not really a function. Returns the value of the last command in the +sequence of commands indicated by BLOCK. When modified by a loop +modifier, executes the BLOCK once before testing the loop condition. +(On other statements the loop modifiers test the conditional first.) + +=item do SUBROUTINE(LIST) + +A deprecated form of subroutine call. See L<perlsub>. + +=item do EXPR + +Uses the value of EXPR as a filename and executes the contents of the +file as a Perl script. Its primary use is to include subroutines +from a Perl subroutine library. + + do 'stat.pl'; + +is just like + + eval `cat stat.pl`; + +except that it's more efficient, more concise, keeps track of the +current filename for error messages, and searches all the B<-I> +libraries if the file isn't in the current directory (see also the @INC +array in L<perlvar/Predefined Names>). It's the same, however, in that it does +reparse the file every time you call it, so you probably don't want to +do this inside a loop. + +Note that inclusion of library modules is better done with the +use() and require() operators. + +=item dump LABEL + +This causes an immediate core dump. Primarily this is so that you can +use the B<undump> program to turn your core dump into an executable binary +after having initialized all your variables at the beginning of the +program. When the new binary is executed it will begin by executing a +C<goto LABEL> (with all the restrictions that C<goto> suffers). Think of +it as a goto with an intervening core dump and reincarnation. If LABEL +is omitted, restarts the program from the top. WARNING: any files +opened at the time of the dump will NOT be open any more when the +program is reincarnated, with possible resulting confusion on the part +of Perl. See also B<-u> option in L<perlrun>. + +Example: + + #!/usr/bin/perl + require 'getopt.pl'; + require 'stat.pl'; + %days = ( + 'Sun' => 1, + 'Mon' => 2, + 'Tue' => 3, + 'Wed' => 4, + 'Thu' => 5, + 'Fri' => 6, + 'Sat' => 7, + ); + + dump QUICKSTART if $ARGV[0] eq '-d'; + + QUICKSTART: + Getopt('f'); + +=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 +associative array, shared by all each(), keys() and values() function +calls in the program. The following prints out your environment like +the printenv(1) program, only in a different order: + + while (($key,$value) = each %ENV) { + print "$key=$value\n"; + } + +See also keys() and values(). + +=item eof FILEHANDLE + +=item eof + +Returns 1 if the next read on FILEHANDLE will return end of file, or if +FILEHANDLE is not open. FILEHANDLE may be an expression whose value +gives the real filehandle name. (Note that this function actually +reads a character and then ungetc()s it, so it is not very useful in an +interactive context.) An C<eof> without an argument returns the eof status +for the last file read. Empty parentheses () may be used to indicate +the pseudo file formed of the files listed on the command line, i.e. +C<eof()> is reasonable to use inside a while (<>) loop to detect the end +of only the last file. Use C<eof(ARGV)> or eof without the parentheses to +test I<EACH> file in a while (<>) loop. Examples: + + # insert dashes just before last line of last file + while (<>) { + if (eof()) { + print "--------------\n"; + } + print; + } + + # reset line numbering on each input file + while (<>) { + print "$.\t$_"; + if (eof) { # Not eof(). + close(ARGV); + } + } + +Practical hint: you almost never need to use C<eof> in Perl, because the +input operators return undef when they run out of data. + +=item eval EXPR + +=item eval BLOCK + +EXPR is parsed and executed as if it were a little Perl program. It +is executed in the context of the current Perl program, so that any +variable settings, subroutine or format definitions remain afterwards. +The value returned is the value of the last expression evaluated, or a +return statement may be used, just as with subroutines. + +If there is a syntax error or runtime error, or a die() statement is +executed, an undefined value is returned by eval(), and C<$@> is set to the +error message. If there was no error, C<$@> is guaranteed to be a null +string. If EXPR is omitted, evaluates $_. The final semicolon, if +any, may be omitted from the expression. + +Note that, since eval() traps otherwise-fatal errors, it is useful for +determining whether a particular feature (such as dbmopen() or symlink()) +is implemented. It is also Perl's exception trapping mechanism, where +the die operator is used to raise exceptions. + +If the code to be executed doesn't vary, you may use the eval-BLOCK +form to trap run-time errors without incurring the penalty of +recompiling each time. The error, if any, is still returned in C<$@>. +Examples: + + # make divide-by-zero non-fatal + eval { $answer = $a / $b; }; warn $@ if $@; + + # same thing, but less efficient + eval '$answer = $a / $b'; warn $@ if $@; + + # a compile-time error + eval { $answer = }; + + # a run-time error + eval '$answer ='; # sets $@ + +With an eval(), you should be especially careful to remember what's +being looked at when: + + eval $x; # CASE 1 + eval "$x"; # CASE 2 + + eval '$x'; # CASE 3 + eval { $x }; # CASE 4 + + eval "\$$x++" # CASE 5 + $$x++; # CASE 6 + +Cases 1 and 2 above behave identically: they run the code contained in the +variable $x. (Although case 2 has misleading double quotes making the +reader wonder what else might be happening (nothing is).) Cases 3 and 4 +likewise behave in the same way: they run the code <$x>, which does +nothing at all. (Case 4 is preferred for purely visual reasons.) Case 5 +is a place where normally you I<WOULD> like to use double quotes, except +that in particular situation, you can just use symbolic references +instead, as in case 6. + +=item exec LIST + +The exec() function executes a system command I<AND NEVER RETURNS>. Use +the system() function if you want it to return. + +If there is more than one argument in LIST, or if LIST is an array with +more than one value, calls execvp(3) with the arguments in LIST. If +there is only one scalar argument, the argument is checked for shell +metacharacters. If there are any, the entire argument is passed to +C</bin/sh -c> for parsing. If there are none, the argument is split +into words and passed directly to execvp(), which is more efficient. +Note: exec() (and system(0) do not flush your output buffer, so you may +need to set C<$|> to avoid lost output. Examples: + + exec '/bin/echo', 'Your arguments are: ', @ARGV; + exec "sort $outfile | uniq"; + +If you don't really want to execute the first argument, but want to lie +to the program you are executing about its own name, you can specify +the program you actually want to run as an "indirect object" (without a +comma) in front of the LIST. (This always forces interpretation of the +LIST as a multi-valued list, even if there is only a single scalar in +the list.) Example: + + $shell = '/bin/csh'; + exec $shell '-sh'; # pretend it's a login shell + +or, more directly, + + exec {'/bin/csh'} '-sh'; # pretend it's a login shell + +=item exists EXPR + +Returns TRUE if the specified hash key exists in its hash array, even +if the corresponding value is undefined. + + print "Exists\n" if exists $array{$key}; + print "Defined\n" if defined $array{$key}; + print "True\n" if $array{$key}; + +A hash element can only be TRUE if it's defined, and defined if +it exists, but the reverse doesn't necessarily hold true. + +Note that the EXPR can be arbitrarily complicated as long as the final +operation is a hash key lookup: + + if (exists $ref->[$x][$y]{$key}) { ... } + +=item exit EXPR + +Evaluates EXPR and exits immediately with that value. (Actually, it +calls any defined C<END> routines first, but the C<END> routines may not +abort the exit. Likewise any object destructors that need to be called +are called before exit.) Example: + + $ans = <STDIN>; + exit 0 if $ans =~ /^[Xx]/; + +See also die(). If EXPR is omitted, exits with 0 status. + +=item exp EXPR + +Returns I<e> (the natural logarithm base) to the power of EXPR. +If EXPR is omitted, gives C<exp($_)>. + +=item fcntl FILEHANDLE,FUNCTION,SCALAR + +Implements the fcntl(2) function. You'll probably have to say + + use Fcntl; + +first to get the correct function definitions. Argument processing and +value return works just like ioctl() below. Note that fcntl() will produce +a fatal error if used on a machine that doesn't implement fcntl(2). +For example: + + use Fcntl; + fcntl($filehandle, F_GETLK, $packed_return_buffer); + +=item fileno FILEHANDLE + +Returns the file descriptor for a filehandle. This is useful for +constructing bitmaps for select(). If FILEHANDLE is an expression, the +value is taken as the name of the filehandle. + +=item flock FILEHANDLE,OPERATION + +Calls flock(2) on FILEHANDLE. See L<flock(2)> for +definition of OPERATION. Returns TRUE for success, FALSE on failure. +Will produce a fatal error if used on a machine that doesn't implement +flock(2). Here's a mailbox appender for BSD systems. + + $LOCK_SH = 1; + $LOCK_EX = 2; + $LOCK_NB = 4; + $LOCK_UN = 8; + + sub lock { + flock(MBOX,$LOCK_EX); + # and, in case someone appended + # while we were waiting... + seek(MBOX, 0, 2); + } + + sub unlock { + flock(MBOX,$LOCK_UN); + } + + open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}") + or die "Can't open mailbox: $!"; + + lock(); + print MBOX $msg,"\n\n"; + unlock(); + +Note that flock() can't lock things over the network. You need to do +locking with fcntl() for that. + +=item fork + +Does a fork(2) system call. Returns the child pid to the parent process +and 0 to the child process, or undef if the fork is unsuccessful. +Note: unflushed buffers remain unflushed in both processes, which means +you may need to set C<$|> ($AUTOFLUSH in English) or call the +autoflush() FileHandle method to avoid duplicate output. + +If you fork() without ever waiting on your children, you will accumulate +zombies: + + $SIG{'CHLD'} = sub { wait }; + +There's also the double-fork trick (error checking on +fork() returns omitted); + + unless ($pid = fork) { + unless (fork) { + exec "what you really wanna do"; + die "no exec"; + # ... or ... + some_perl_code_here; + exit 0; + } + exit 0; + } + waitpid($pid,0); + + +=item formline PICTURE, LIST + +This is an internal function used by formats, though you may call it +too. It formats (see L<perlform>) a list of values according to the +contents of PICTURE, placing the output into the format output +accumulator, C<$^A>. Eventually, when a write() is done, the contents of +C<$^A> are written to some filehandle, but you could also read C<$^A> +yourself and then set C<$^A> back to "". Note that a format typically +does one formline() per line of form, but the formline() function itself +doesn't care how many newlines are embedded in the PICTURE. Be careful +if you put double quotes around the picture, since an "C<@>" character may +be taken to mean the beginning of an array name. formline() always +returns TRUE. + +=item getc FILEHANDLE + +=item getc + +Returns the next character from the input file attached to FILEHANDLE, +or a null string at end of file. If FILEHANDLE is omitted, reads from STDIN. + +=item getlogin + +Returns the current login from F</etc/utmp>, if any. If null, use +getpwuid(). + + $login = getlogin || (getpwuid($<))[0] || "Kilroy"; + +=item getpeername SOCKET + +Returns the packed sockaddr address of other end of the SOCKET connection. + + # An internet sockaddr + $sockaddr = 'S n a4 x8'; + $hersockaddr = getpeername(S); + ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr); + +=item getpgrp PID + +Returns the current process group for the specified PID, 0 for the +current process. Will produce a fatal error if used on a machine that +doesn't implement getpgrp(2). If PID is omitted, returns process +group of current process. + +=item getppid + +Returns the process id of the parent process. + +=item getpriority WHICH,WHO + +Returns the current priority for a process, a process group, or a +user. (See L<getpriority(2)>.) Will produce a fatal error if used on a +machine that doesn't implement getpriority(2). + +=item getpwnam NAME + +=item getgrnam NAME + +=item gethostbyname NAME + +=item getnetbyname NAME + +=item getprotobyname NAME + +=item getpwuid UID + +=item getgrgid GID + +=item getservbyname NAME,PROTO + +=item gethostbyaddr ADDR,ADDRTYPE + +=item getnetbyaddr ADDR,ADDRTYPE + +=item getprotobynumber NUMBER + +=item getservbyport PORT,PROTO + +=item getpwent + +=item getgrent + +=item gethostent + +=item getnetent + +=item getprotoent + +=item getservent + +=item setpwent + +=item setgrent + +=item sethostent STAYOPEN + +=item setnetent STAYOPEN + +=item setprotoent STAYOPEN + +=item setservent STAYOPEN + +=item endpwent + +=item endgrent + +=item endhostent + +=item endnetent + +=item endprotoent + +=item endservent + +These routines perform the same functions as their counterparts in the +system library. Within a list context, the return values from the +various get routines are as follows: + + ($name,$passwd,$uid,$gid, + $quota,$comment,$gcos,$dir,$shell) = getpw* + ($name,$passwd,$gid,$members) = getgr* + ($name,$aliases,$addrtype,$length,@addrs) = gethost* + ($name,$aliases,$addrtype,$net) = getnet* + ($name,$aliases,$proto) = getproto* + ($name,$aliases,$port,$proto) = getserv* + +(If the entry doesn't exist you get a null list.) + +Within a scalar context, you get the name, unless the function was a +lookup by name, in which case you get the other thing, whatever it is. +(If the entry doesn't exist you get the undefined value.) For example: + + $uid = getpwnam + $name = getpwuid + $name = getpwent + $gid = getgrnam + $name = getgrgid + $name = getgrent + etc. + +The $members value returned by I<getgr*()> is a space separated list of +the login names of the members of the group. + +For the I<gethost*()> functions, if the C<h_errno> variable is supported in +C, it will be returned to you via C<$?> if the function call fails. The +@addrs value returned by a successful call is a list of the raw +addresses returned by the corresponding system library call. In the +Internet domain, each address is four bytes long and you can unpack it +by saying something like: + + ($a,$b,$c,$d) = unpack('C4',$addr[0]); + +=item getsockname SOCKET + +Returns the packed sockaddr address of this end of the SOCKET connection. + + # An internet sockaddr + $sockaddr = 'S n a4 x8'; + $mysockaddr = getsockname(S); + ($family, $port, $myaddr) = + unpack($sockaddr,$mysockaddr); + +=item getsockopt SOCKET,LEVEL,OPTNAME + +Returns the socket option requested, or undefined if there is an error. + +=item glob EXPR + +Returns the value of EXPR with filename expansions such as a shell +would do. This is the internal function implementing the <*.*> +operator. + +=item gmtime EXPR + +Converts a time as returned by the time function to a 9-element array +with the time analyzed for the Greenwich timezone. Typically used as +follows: + + + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = + gmtime(time); + +All array elements are numeric, and come straight out of a struct tm. +In particular this means that $mon has the range 0..11 and $wday has +the range 0..6. If EXPR is omitted, does C<gmtime(time())>. + +=item goto LABEL + +=item goto &NAME + +The goto-LABEL form finds the statement labeled with LABEL and resumes +execution there. It may not be used to go into any construct that +requires initialization, such as a subroutine or a foreach loop. It +also can't be used to go into a construct that is optimized away. It +can be used to go almost anywhere else within the dynamic scope, +including out of subroutines, but it's usually better to use some other +construct such as last or die. The author of Perl has never felt the +need to use this form of goto (in Perl, that is--C is another matter). + +The goto-&NAME form is highly magical, and substitutes a call to the +named subroutine for the currently running subroutine. This is used by +AUTOLOAD subroutines that wish to load another subroutine and then +pretend that the other subroutine had been called in the first place +(except that any modifications to @_ in the current subroutine are +propagated to the other subroutine.) After the goto, not even caller() +will be able to tell that this routine was called first. + +=item grep BLOCK LIST + +=item grep EXPR,LIST + +Evaluates the BLOCK or EXPR for each element of LIST (locally setting +$_ to each element) and returns the list value consisting of those +elements for which the expression evaluated to TRUE. In a scalar +context, returns the number of times the expression was TRUE. + + @foo = grep(!/^#/, @bar); # weed out comments + +or equivalently, + + @foo = grep {!/^#/} @bar; # weed out comments + +Note that, since $_ is a reference into the list value, it can be used +to modify the elements of the array. While this is useful and +supported, it can cause bizarre results if the LIST is not a named +array. + +=item hex EXPR + +Returns the decimal value of EXPR interpreted as an hex string. (To +interpret strings that might start with 0 or 0x see oct().) If EXPR is +omitted, uses $_. + +=item import + +There is no built-in import() function. It is merely an ordinary +method subroutine defined (or inherited) by modules that wish to export +names to another module. The use() function calls the import() method +for the package used. See also L</use> below and L<perlmod>. + +=item index STR,SUBSTR,POSITION + +=item index STR,SUBSTR + +Returns the position of the first occurrence of SUBSTR in STR at or +after POSITION. If POSITION is omitted, starts searching from the +beginning of the string. The return value is based at 0, or whatever +you've set the $[ variable to. If the substring is not found, returns +one less than the base, ordinarily -1. + +=item int EXPR + +Returns the integer portion of EXPR. If EXPR is omitted, uses $_. + +=item ioctl FILEHANDLE,FUNCTION,SCALAR + +Implements the ioctl(2) function. You'll probably have to say + + require "ioctl.ph"; # probably /usr/local/lib/perl/ioctl.ph + +first to get the correct function definitions. If ioctl.ph doesn't +exist or doesn't have the correct definitions you'll have to roll your +own, based on your C header files such as <sys/ioctl.h>. (There is a +Perl script called B<h2ph> that comes with the Perl kit which may help you +in this.) SCALAR will be read and/or written depending on the +FUNCTION--a pointer to the string value of SCALAR will be passed as the +third argument of the actual ioctl call. (If SCALAR has no string +value but does have a numeric value, that value will be passed rather +than a pointer to the string value. To guarantee this to be TRUE, add +a 0 to the scalar before using it.) The pack() and unpack() functions +are useful for manipulating the values of structures used by ioctl(). +The following example sets the erase character to DEL. + + require 'ioctl.ph'; + $sgttyb_t = "ccccs"; # 4 chars and a short + if (ioctl(STDIN,$TIOCGETP,$sgttyb)) { + @ary = unpack($sgttyb_t,$sgttyb); + $ary[2] = 127; + $sgttyb = pack($sgttyb_t,@ary); + ioctl(STDIN,$TIOCSETP,$sgttyb) + || die "Can't ioctl: $!"; + } + +The return value of ioctl (and fcntl) is as follows: + + if OS returns: then Perl returns: + -1 undefined value + 0 string "0 but true" + anything else that number + +Thus Perl returns TRUE on success and FALSE on failure, yet you can +still easily determine the actual value returned by the operating +system: + + ($retval = ioctl(...)) || ($retval = -1); + printf "System returned %d\n", $retval; + +=item join EXPR,LIST + +Joins the separate strings of LIST or ARRAY into a single string with +fields separated by the value of EXPR, and returns the string. +Example: + + $_ = join(':', $login,$passwd,$uid,$gid,$gcos,$home,$shell); + +See L<perlfunc/split>. + +=item keys ASSOC_ARRAY + +Returns a normal array consisting of all the keys of the named +associative array. (In a scalar context, returns the number of keys.) +The keys are returned in an apparently random order, but it is the same +order as either the values() or each() function produces (given that +the associative array has not been modified). Here is yet another way +to print your environment: + + @keys = keys %ENV; + @values = values %ENV; + while ($#keys >= 0) { + print pop(@keys), '=', pop(@values), "\n"; + } + +or how about sorted by key: + + foreach $key (sort(keys %ENV)) { + print $key, '=', $ENV{$key}, "\n"; + } + +=item kill LIST + +Sends a signal to a list of processes. The first element of the list +must be the signal to send. Returns the number of processes +successfully signaled. + + $cnt = kill 1, $child1, $child2; + kill 9, @goners; + +Unlike in the shell, in Perl +if the I<SIGNAL> is negative, it kills process groups instead of processes. +(On System V, a negative I<PROCESS> number will also kill process +groups, but that's not portable.) That means you usually want to use +positive not negative signals. You may also use a signal name in quotes. + +=item last LABEL + +=item last + +The C<last> command is like the C<break> statement in C (as used in +loops); it immediately exits the loop in question. If the LABEL is +omitted, the command refers to the innermost enclosing loop. The +C<continue> block, if any, is not executed: + + line: while (<STDIN>) { + last line if /^$/; # exit when done with header + ... + } + +=item lc EXPR + +Returns an lowercased version of EXPR. This is the internal function +implementing the \L escape in double-quoted strings. + +=item lcfirst EXPR + +Returns the value of EXPR with the first character lowercased. This is +the internal function implementing the \l escape in double-quoted strings. + +=item length EXPR + +Returns the length in characters of the value of EXPR. If EXPR is +omitted, returns length of $_. + +=item link OLDFILE,NEWFILE + +Creates a new filename linked to the old filename. Returns 1 for +success, 0 otherwise. + +=item listen SOCKET,QUEUESIZE + +Does the same thing that the listen system call does. Returns TRUE if +it succeeded, FALSE otherwise. See example in L<perlipc>. + +=item local EXPR + +In general, you should be using "my" instead of "local", because it's +faster and safer. Format variables have to use "local" though, as +do any other variables whose local value must be visible to called +subroutines. This is known as dynamic scoping. Lexical scoping is +done with "my", which works more like C's auto declarations. + +A local modifies the listed variables to be local to the enclosing block, +subroutine, eval or "do". If more than one value is listed, the list +must be placed in parens. All the listed elements must be legal +lvalues. This operator works by saving the current values of those +variables in LIST on a hidden stack and restoring them upon exiting the +block, subroutine or eval. This means that called subroutines can also +reference the local variable, but not the global one. The LIST may be +assigned to if desired, which allows you to initialize your local +variables. (If no initializer is given for a particular variable, it +is created with an undefined value.) Commonly this is used to name the +parameters to a subroutine. Examples: + + sub RANGEVAL { + local($min, $max, $thunk) = @_; + local $result = ''; + local $i; + + # Presumably $thunk makes reference to $i + + for ($i = $min; $i < $max; $i++) { + $result .= eval $thunk; + } + + $result; + } + + + if ($sw eq '-v') { + # init local array with global array + local @ARGV = @ARGV; + unshift(@ARGV,'echo'); + system @ARGV; + } + # @ARGV restored + + + # temporarily add to digits associative array + if ($base12) { + # (NOTE: not claiming this is efficient!) + local(%digits) = (%digits,'t',10,'e',11); + parse_num(); + } + +Note that local() is a run-time command, and so gets executed every +time through a loop. In Perl 4 it used up more stack storage each +time until the loop was exited. Perl 5 reclaims the space each time +through, but it's still more efficient to declare your variables +outside the loop. + +When you assign to a localized EXPR, the local doesn't change whether +EXPR is viewed as a scalar or an array. So + + local($foo) = <STDIN>; + local @FOO = <STDIN>; + +both supply a list context to the righthand side, while + + local $foo = <STDIN>; + +supplies a scalar context. + +=item localtime EXPR + +Converts a time as returned by the time function to a 9-element array +with the time analyzed for the local timezone. Typically used as +follows: + + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = + localtime(time); + +All array elements are numeric, and come straight out of a struct tm. +In particular this means that $mon has the range 0..11 and $wday has +the range 0..6. If EXPR is omitted, does localtime(time). + +In a scalar context, prints out the ctime(3) value: + + $now_string = localtime; # e.g. "Thu Oct 13 04:54:34 1994" + +See also L<perlmod/timelocal> and the strftime(3) function available +via the POSIX modulie. + +=item log EXPR + +Returns logarithm (base I<e>) of EXPR. If EXPR is omitted, returns log +of $_. + +=item lstat FILEHANDLE + +=item lstat EXPR + +Does the same thing as the stat() function, but stats a symbolic link +instead of the file the symbolic link points to. If symbolic links are +unimplemented on your system, a normal stat() is done. + +=item m// + +The match operator. See L<perlop>. + +=item map BLOCK LIST + +=item map EXPR,LIST + +Evaluates the BLOCK or EXPR for each element of LIST (locally setting $_ to each +element) and returns the list value composed of the results of each such +evaluation. Evaluates BLOCK or EXPR in a list context, so each element of LIST +may produce zero, one, or more elements in the returned value. + + @chars = map(chr, @nums); + +translates a list of numbers to the corresponding characters. And + + %hash = map {&key($_), $_} @array; + +is just a funny way to write + + %hash = (); + foreach $_ (@array) { + $hash{&key($_)} = $_; + } + +=item mkdir FILENAME,MODE + +Creates the directory specified by FILENAME, with permissions specified +by MODE (as modified by umask). If it succeeds it returns 1, otherwise +it returns 0 and sets $! (errno). + +=item msgctl ID,CMD,ARG + +Calls the System V IPC function msgctl. If CMD is &IPC_STAT, then ARG +must be a variable which will hold the returned msqid_ds structure. +Returns like ioctl: the undefined value for error, "0 but true" for +zero, or the actual return value otherwise. + +=item msgget KEY,FLAGS + +Calls the System V IPC function msgget. Returns the message queue id, +or the undefined value if there is an error. + +=item msgsnd ID,MSG,FLAGS + +Calls the System V IPC function msgsnd to send the message MSG to the +message queue ID. MSG must begin with the long integer message type, +which may be created with C<pack("L", $type)>. Returns TRUE if +successful, or FALSE if there is an error. + +=item msgrcv ID,VAR,SIZE,TYPE,FLAGS + +Calls the System V IPC function msgrcv to receive a message from +message queue ID into variable VAR with a maximum message size of +SIZE. Note that if a message is received, the message type will be the +first thing in VAR, and the maximum length of VAR is SIZE plus the size +of the message type. Returns TRUE if successful, or FALSE if there is +an error. + +=item my EXPR + +A "my" declares the listed variables to be local (lexically) to the +enclosing block, subroutine, eval or "do". If more than one value is +listed, the list must be placed in parens. All the listed elements +must be legal lvalues. Only alphanumeric identifiers may be lexically +scoped--magical builtins like $/ must be localized with "local" +instead. In particular, you're not allowed to say + + my $_; # Illegal. + +Unlike the "local" declaration, variables declared with "my" +are totally hidden from the outside world, including any called +subroutines (even if it's the same subroutine--every call gets its own +copy). + +(An eval(), however, can see the lexical variables of the scope it is +being evaluated in so long as the names aren't hidden by declarations within +the eval() itself. See L<perlref>.) + +The EXPR may be assigned to if desired, which allows you to initialize +your variables. (If no initializer is given for a particular +variable, it is created with an undefined value.) Commonly this is +used to name the parameters to a subroutine. Examples: + + sub RANGEVAL { + my($min, $max, $thunk) = @_; + my $result = ''; + my $i; + + # Presumably $thunk makes reference to $i + + for ($i = $min; $i < $max; $i++) { + $result .= eval $thunk; + } + + $result; + } + + + if ($sw eq '-v') { + # init my array with global array + my @ARGV = @ARGV; + unshift(@ARGV,'echo'); + system @ARGV; + } + # Outer @ARGV again visible + +When you assign to the EXPR, the "my" doesn't change whether +EXPR is viewed as a scalar or an array. So + + my($foo) = <STDIN>; + my @FOO = <STDIN>; + +both supply a list context to the righthand side, while + + my $foo = <STDIN>; + +supplies a scalar context. + +Some users may wish to encourage the use of lexically scoped variables. +As an aid to catching implicit references to package variables, +if you say + + use strict 'vars'; + +then any variable reference from there to the end of the enclosing +block must either refer to a lexical variable, or must be fully +qualified with the package name. A compilation error results +otherwise. An inner block may countermand this with S<"no strict 'vars'">. + +=item next LABEL + +=item next + +The C<next> command is like the C<continue> statement in C; it starts +the next iteration of the loop: + + line: while (<STDIN>) { + next line if /^#/; # discard comments + ... + } + +Note that if there were a C<continue> block on the above, it would get +executed even on discarded lines. If the LABEL is omitted, the command +refers to the innermost enclosing loop. + +=item no Module LIST + +See the "use" function, which "no" is the opposite of. + +=item oct EXPR + +Returns the decimal value of EXPR interpreted as an octal string. (If +EXPR happens to start off with 0x, interprets it as a hex string +instead.) The following will handle decimal, octal, and hex in the +standard Perl or C notation: + + $val = oct($val) if $val =~ /^0/; + +If EXPR is omitted, uses $_. + +=item open FILEHANDLE,EXPR + +=item open FILEHANDLE + +Opens the file whose filename is given by EXPR, and associates it with +FILEHANDLE. If FILEHANDLE is an expression, its value is used as the +name of the real filehandle wanted. If EXPR is omitted, the scalar +variable of the same name as the FILEHANDLE contains the filename. If +the filename begins with "<" or nothing, the file is opened for input. +If the filename begins with ">", the file is opened for output. If the +filename begins with ">>", the file is opened for appending. (You can +put a '+' in front of the '>' or '<' to indicate that you want both +read and write access to the file.) If the filename begins with "|", +the filename is interpreted as a command to which output is to be +piped, and if the filename ends with a "|", the filename is interpreted +as command which pipes input to us. (You may not have a command that +pipes both in and out.) Opening '-' opens STDIN and opening '>-' +opens STDOUT. Open returns non-zero upon success, the undefined +value otherwise. If the open involved a pipe, the return value happens +to be the pid of the subprocess. Examples: + + $ARTICLE = 100; + open ARTICLE or die "Can't find article $ARTICLE: $!\n"; + while (<ARTICLE>) {... + + open(LOG, '>>/usr/spool/news/twitlog'); # (log is reserved) + + open(article, "caesar <$article |"); # decrypt article + + open(extract, "|sort >/tmp/Tmp$$"); # $$ is our process id + + # process argument list of files along with any includes + + foreach $file (@ARGV) { + process($file, 'fh00'); + } + + sub process { + local($filename, $input) = @_; + $input++; # this is a string increment + unless (open($input, $filename)) { + print STDERR "Can't open $filename: $!\n"; + return; + } + + while (<$input>) { # note use of indirection + if (/^#include "(.*)"/) { + process($1, $input); + next; + } + ... # whatever + } + } + +You may also, in the Bourne shell tradition, specify an EXPR beginning +with ">&", in which case the rest of the string is interpreted as the +name of a filehandle (or file descriptor, if numeric) which is to be +duped and opened. You may use & after >, >>, <, +>, +>> and +<. The +mode you specify should match the mode of the original filehandle. +Here is a script that saves, redirects, and restores STDOUT and +STDERR: + + #!/usr/bin/perl + open(SAVEOUT, ">&STDOUT"); + open(SAVEERR, ">&STDERR"); + + open(STDOUT, ">foo.out") || die "Can't redirect stdout"; + open(STDERR, ">&STDOUT") || die "Can't dup stdout"; + + select(STDERR); $| = 1; # make unbuffered + select(STDOUT); $| = 1; # make unbuffered + + print STDOUT "stdout 1\n"; # this works for + print STDERR "stderr 1\n"; # subprocesses too + + close(STDOUT); + close(STDERR); + + open(STDOUT, ">&SAVEOUT"); + open(STDERR, ">&SAVEERR"); + + print STDOUT "stdout 2\n"; + print STDERR "stderr 2\n"; + + +If you specify "<&=N", where N is a number, then Perl will do an +equivalent of C's fdopen() of that file descriptor. For example: + + open(FILEHANDLE, "<&=$fd") + +If you open a pipe on the command "-", i.e. either "|-" or "-|", then +there is an implicit fork done, and the return value of open is the pid +of the child within the parent process, and 0 within the child +process. (Use defined($pid) to determine whether the open was successful.) +The filehandle behaves normally for the parent, but i/o to that +filehandle is piped from/to the STDOUT/STDIN of the child process. +In the child process the filehandle isn't opened--i/o happens from/to +the new STDOUT or STDIN. Typically this is used like the normal +piped open when you want to exercise more control over just how the +pipe command gets executed, such as when you are running setuid, and +don't want to have to scan shell commands for metacharacters. The +following pairs are more or less equivalent: + + open(FOO, "|tr '[a-z]' '[A-Z]'"); + open(FOO, "|-") || exec 'tr', '[a-z]', '[A-Z]'; + + open(FOO, "cat -n '$file'|"); + open(FOO, "-|") || exec 'cat', '-n', $file; + +Explicitly closing any piped filehandle causes the parent process to +wait for the child to finish, and returns the status value in $?. +Note: on any operation which may do a fork, unflushed buffers remain +unflushed in both processes, which means you may need to set $| to +avoid duplicate output. + +The filename that is passed to open will have leading and trailing +whitespace deleted. In order to open a file with arbitrary weird +characters in it, it's necessary to protect any leading and trailing +whitespace thusly: + + $file =~ s#^(\s)#./$1#; + open(FOO, "< $file\0"); + +=item opendir DIRHANDLE,EXPR + +Opens a directory named EXPR for processing by readdir(), telldir(), +seekdir(), rewinddir() and closedir(). Returns TRUE if successful. +DIRHANDLEs have their own namespace separate from FILEHANDLEs. + +=item ord EXPR + +Returns the numeric ascii value of the first character of EXPR. If +EXPR is omitted, uses $_. + +=item pack TEMPLATE,LIST + +Takes an array or list of values and packs it into a binary structure, +returning the string containing the structure. The TEMPLATE is a +sequence of characters that give the order and type of values, as +follows: + + A An ascii string, will be space padded. + a An ascii string, will be null padded. + b A bit string (ascending bit order, like vec()). + B A bit string (descending bit order). + h A hex string (low nybble first). + H A hex string (high nybble first). + + c A signed char value. + C An unsigned char value. + s A signed short value. + S An unsigned short value. + i A signed integer value. + I An unsigned integer value. + l A signed long value. + L An unsigned long value. + + n A short in "network" order. + N A long in "network" order. + v A short in "VAX" (little-endian) order. + V A long in "VAX" (little-endian) order. + + f A single-precision float in the native format. + d A double-precision float in the native format. + + p A pointer to a null-terminated string. + P A pointer to a structure (fixed-length string). + + u A uuencoded string. + + x A null byte. + X Back up a byte. + @ Null fill to absolute position. + +Each letter may optionally be followed by a number which gives a repeat +count. With all types except "a", "A", "b", "B", "h" and "H", and "P" the +pack function will gobble up that many values from the LIST. A * for the +repeat count means to use however many items are left. The "a" and "A" +types gobble just one value, but pack it as a string of length count, +padding with nulls or spaces as necessary. (When unpacking, "A" strips +trailing spaces and nulls, but "a" does not.) Likewise, the "b" and "B" +fields pack a string that many bits long. The "h" and "H" fields pack a +string that many nybbles long. The "P" packs a pointer to a structure of +the size indicated by the length. Real numbers (floats and doubles) are +in the native machine format only; due to the multiplicity of floating +formats around, and the lack of a standard "network" representation, no +facility for interchange has been made. This means that packed floating +point data written on one machine may not be readable on another - even if +both use IEEE floating point arithmetic (as the endian-ness of the memory +representation is not part of the IEEE spec). Note that Perl uses doubles +internally for all numeric calculation, and converting from double into +float and thence back to double again will lose precision (i.e. +C<unpack("f", pack("f", $foo)>) will not in general equal $foo). + +Examples: + + $foo = pack("cccc",65,66,67,68); + # foo eq "ABCD" + $foo = pack("c4",65,66,67,68); + # same thing + + $foo = pack("ccxxcc",65,66,67,68); + # foo eq "AB\0\0CD" + + $foo = pack("s2",1,2); + # "\1\0\2\0" on little-endian + # "\0\1\0\2" on big-endian + + $foo = pack("a4","abcd","x","y","z"); + # "abcd" + + $foo = pack("aaaa","abcd","x","y","z"); + # "axyz" + + $foo = pack("a14","abcdefg"); + # "abcdefg\0\0\0\0\0\0\0" + + $foo = pack("i9pl", gmtime); + # a real struct tm (on my system anyway) + + sub bintodec { + unpack("N", pack("B32", substr("0" x 32 . shift, -32))); + } + +The same template may generally also be used in the unpack function. + +=item pipe READHANDLE,WRITEHANDLE + +Opens a pair of connected pipes like the corresponding system call. +Note that if you set up a loop of piped processes, deadlock can occur +unless you are very careful. In addition, note that Perl's pipes use +stdio buffering, so you may need to set $| to flush your WRITEHANDLE +after each command, depending on the application. + +=item pop ARRAY + +Pops and returns the last value of the array, shortening the array by +1. Has a similar effect to + + $tmp = $ARRAY[$#ARRAY--]; + +If there are no elements in the array, returns the undefined value. + +=item pos SCALAR + +Returns the offset of where the last m//g search left off for the variable +in question. May be modified to change that offset. + +=item print FILEHANDLE LIST + +=item print LIST + +=item print + +Prints a string or a comma-separated list of strings. Returns non-zero +if successful. FILEHANDLE may be a scalar variable name, in which case +the variable contains the name of the filehandle, thus introducing one +level of indirection. (NOTE: If FILEHANDLE is a variable and the next +token is a term, it may be misinterpreted as an operator unless you +interpose a + or put parens around the arguments.) If FILEHANDLE is +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 +subroutine that you call will have one or more of its expressions +evaluated in a list context. Also be careful not to follow the print +keyword with a left parenthesis unless you want the corresponding right +parenthesis to terminate the arguments to the print--interpose a + or +put parens around all the arguments. + +=item printf FILEHANDLE LIST + +=item printf LIST + +Equivalent to a "print FILEHANDLE sprintf(LIST)". The first argument +of the list will be interpreted as the printf format. + +=item push ARRAY,LIST + +Treats ARRAY as a stack, and pushes the values of LIST +onto the end of ARRAY. The length of ARRAY increases by the length of +LIST. Has the same effect as + + for $value (LIST) { + $ARRAY[++$#ARRAY] = $value; + } + +but is more efficient. Returns the new number of elements in the array. + +=item q/STRING/ + +=item qq/STRING/ + +=item qx/STRING/ + +=item qw/STRING/ + +Generalized quotes. See L<perlop>. + +=item quotemeta EXPR + +Returns the value of EXPR with with all regular expression +metacharacters backslashed. This is the internal function implementing +the \Q escape in double-quoted strings. + +=item rand EXPR + +=item rand + +Returns a random fractional number between 0 and the value of EXPR. +(EXPR should be positive.) If EXPR is omitted, returns a value between +0 and 1. This function produces repeatable sequences unless srand() +is invoked. See also srand(). + +(Note: if your rand function consistently returns numbers that are too +large or too small, then your version of Perl was probably compiled +with the wrong number of RANDBITS. As a workaround, you can usually +multiply EXPR by the correct power of 2 to get the range you want. +This will make your script unportable, however. It's better to recompile +if you can.) + +=item read FILEHANDLE,SCALAR,LENGTH,OFFSET + +=item read FILEHANDLE,SCALAR,LENGTH + +Attempts to read LENGTH bytes of data into variable SCALAR from the +specified FILEHANDLE. Returns the number of bytes actually read, or +undef if there was an error. SCALAR will be grown or shrunk to the +length actually read. An OFFSET may be specified to place the read +data at some other place than the beginning of the string. This call +is actually implemented in terms of stdio's fread call. To get a true +read system call, see sysread(). + +=item readdir DIRHANDLE + +Returns the next directory entry for a directory opened by opendir(). +If used in a list context, returns all the rest of the entries in the +directory. If there are no more entries, returns an undefined value in +a scalar context or a null list in a list context. + +=item readlink EXPR + +Returns the value of a symbolic link, if symbolic links are +implemented. If not, gives a fatal error. If there is some system +error, returns the undefined value and sets $! (errno). If EXPR is +omitted, uses $_. + +=item recv SOCKET,SCALAR,LEN,FLAGS + +Receives a message on a socket. Attempts to receive LENGTH bytes of +data into variable SCALAR from the specified SOCKET filehandle. +Actually does a C recvfrom(), so that it can returns the address of the +sender. Returns the undefined value if there's an error. SCALAR will +be grown or shrunk to the length actually read. Takes the same flags +as the system call of the same name. + +=item redo LABEL + +=item redo + +The C<redo> command restarts the loop block without evaluating the +conditional again. The C<continue> block, if any, is not executed. If +the LABEL is omitted, the command refers to the innermost enclosing +loop. This command is normally used by programs that want to lie to +themselves about what was just input: + + # a simpleminded Pascal comment stripper + # (warning: assumes no { or } in strings) + line: while (<STDIN>) { + while (s|({.*}.*){.*}|$1 |) {} + s|{.*}| |; + if (s|{.*| |) { + $front = $_; + while (<STDIN>) { + if (/}/) { # end of comment? + s|^|$front{|; + redo line; + } + } + } + print; + } + +=item ref EXPR + +Returns a TRUE value if EXPR is a reference, FALSE otherwise. The value +returned depends on the type of thing the reference is a reference to. +Builtin types include: + + REF + SCALAR + ARRAY + HASH + CODE + GLOB + +If the referenced object has been blessed into a package, then that package +name is returned instead. You can think of ref() as a typeof() operator. + + if (ref($r) eq "HASH") { + print "r is a reference to an associative array.\n"; + } + if (!ref ($r) { + print "r is not a reference at all.\n"; + } + +See also L<perlref>. + +=item rename OLDNAME,NEWNAME + +Changes the name of a file. Returns 1 for success, 0 otherwise. Will +not work across filesystem boundaries. + +=item require EXPR + +=item require + +Demands some semantics specified by EXPR, or by $_ if EXPR is not +supplied. If EXPR is numeric, demands that the current version of Perl +($] or $PERL_VERSION) be equal or greater than EXPR. + +Otherwise, demands that a library file be included if it hasn't already +been included. The file is included via the do-FILE mechanism, which is +essentially just a variety of eval(). Has semantics similar to the following +subroutine: + + sub require { + local($filename) = @_; + return 1 if $INC{$filename}; + local($realfilename,$result); + ITER: { + foreach $prefix (@INC) { + $realfilename = "$prefix/$filename"; + if (-f $realfilename) { + $result = do $realfilename; + last ITER; + } + } + die "Can't find $filename in \@INC"; + } + die $@ if $@; + die "$filename did not return true value" unless $result; + $INC{$filename} = $realfilename; + $result; + } + +Note that the file will not be included twice under the same specified +name. The file must return TRUE as the last statement to indicate +successful execution of any initialization code, so it's customary to +end such a file with "1;" unless you're sure it'll return TRUE +otherwise. But it's better just to put the "C<1;>", in case you add more +statements. + +If EXPR is a bare word, the require assumes a "F<.pm>" extension for you, +to make it easy to load standard modules. This form of loading of +modules does not risk altering your namespace. + +For a yet more powerful import facility, see the L</use()> below, and +also L<perlmod>. + +=item reset EXPR + +=item reset + +Generally used in a C<continue> block at the end of a loop to clear +variables and reset ?? searches so that they work again. The +expression is interpreted as a list of single characters (hyphens +allowed for ranges). All variables and arrays beginning with one of +those letters are reset to their pristine state. If the expression is +omitted, one-match searches (?pattern?) are reset to match again. Only +resets variables or searches in the current package. Always returns +1. Examples: + + reset 'X'; # reset all X variables + reset 'a-z'; # reset lower case variables + reset; # just reset ?? searches + +Resetting "A-Z" is not recommended since you'll wipe out your +ARGV and ENV arrays. Only resets package variables--lexical variables +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 + +Returns from a subroutine or eval with the value specified. (Note that +in the absence of a return a subroutine or eval will automatically +return the value of the last expression evaluated.) + +=item reverse LIST + +In a list context, returns a list value consisting of the elements +of LIST in the opposite order. In a scalar context, returns a string +value consisting of the bytes of the first element of LIST in the +opposite order. + +=item rewinddir DIRHANDLE + +Sets the current position to the beginning of the directory for the +readdir() routine on DIRHANDLE. + +=item rindex STR,SUBSTR,POSITION + +=item rindex STR,SUBSTR + +Works just like index except that it returns the position of the LAST +occurrence of SUBSTR in STR. If POSITION is specified, returns the +last occurrence at or before that position. + +=item rmdir FILENAME + +Deletes the directory specified by FILENAME if it is empty. If it +succeeds it returns 1, otherwise it returns 0 and sets $! (errno). If +FILENAME is omitted, uses $_. + +=item s/// + +The substitution operator. See L<perlop>. + +=item scalar EXPR + +Forces EXPR to be interpreted in a scalar context and returns the value +of EXPR. + +=item seek FILEHANDLE,POSITION,WHENCE + +Randomly positions the file pointer for FILEHANDLE, just like the fseek() +call of stdio. FILEHANDLE may be an expression whose value gives the name +of the filehandle. The values for WHENCE are 0 to set the file pointer to +POSITION, 1 to set the it to current plus POSITION, and 2 to set it to EOF +plus offset. You may use the values SEEK_SET, SEEK_CUR, and SEEK_END for +this is usin the POSIX module. Returns 1 upon success, 0 otherwise. + +=item seekdir DIRHANDLE,POS + +Sets the current position for the readdir() routine on DIRHANDLE. POS +must be a value returned by telldir(). Has the same caveats about +possible directory compaction as the corresponding system library +routine. + +=item select FILEHANDLE + +=item select + +Returns the currently selected filehandle. Sets the current default +filehandle for output, if FILEHANDLE is supplied. This has two +effects: first, a C<write> or a C<print> without a filehandle will +default to this FILEHANDLE. Second, references to variables related to +output will refer to this output channel. For example, if you have to +set the top of form format for more than one output channel, you might +do the following: + + select(REPORT1); + $^ = 'report1_top'; + select(REPORT2); + $^ = 'report2_top'; + +FILEHANDLE may be an expression whose value gives the name of the +actual filehandle. Thus: + + $oldfh = select(STDERR); $| = 1; select($oldfh); + +With Perl 5, filehandles are objects with methods, and the last example +is preferably written + + use FileHandle; + STDERR->autoflush(1); + +=item select RBITS,WBITS,EBITS,TIMEOUT + +This calls the select system(2) call with the bitmasks specified, which +can be constructed using fileno() and vec(), along these lines: + + $rin = $win = $ein = ''; + vec($rin,fileno(STDIN),1) = 1; + vec($win,fileno(STDOUT),1) = 1; + $ein = $rin | $win; + +If you want to select on many filehandles you might wish to write a +subroutine: + + sub fhbits { + local(@fhlist) = split(' ',$_[0]); + local($bits); + for (@fhlist) { + vec($bits,fileno($_),1) = 1; + } + $bits; + } + $rin = &fhbits('STDIN TTY SOCK'); + +The usual idiom is: + + ($nfound,$timeleft) = + select($rout=$rin, $wout=$win, $eout=$ein, $timeout); + +or to block until something becomes ready: + + $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef); + +Any of the bitmasks can also be undef. The timeout, if specified, is +in seconds, which may be fractional. Note: not all implementations are +capable of returning the $timeleft. If not, they always return +$timeleft equal to the supplied $timeout. + +You can effect a 250 microsecond sleep this way: + + select(undef, undef, undef, 0.25); + + +=item semctl ID,SEMNUM,CMD,ARG + +Calls the System V IPC function semctl. If CMD is &IPC_STAT or +&GETALL, then ARG must be a variable which will hold the returned +semid_ds structure or semaphore value array. Returns like ioctl: the +undefined value for error, "0 but true" for zero, or the actual return +value otherwise. + +=item semget KEY,NSEMS,FLAGS + +Calls the System V IPC function semget. Returns the semaphore id, or +the undefined value if there is an error. + +=item semop KEY,OPSTRING + +Calls the System V IPC function semop to perform semaphore operations +such as signaling and waiting. OPSTRING must be a packed array of +semop structures. Each semop structure can be generated with +C<pack("sss", $semnum, $semop, $semflag)>. The number of semaphore +operations is implied by the length of OPSTRING. Returns TRUE if +successful, or FALSE if there is an error. As an example, the +following code waits on semaphore $semnum of semaphore id $semid: + + $semop = pack("sss", $semnum, -1, 0); + die "Semaphore trouble: $!\n" unless semop($semid, $semop); + +To signal the semaphore, replace "-1" with "1". + +=item send SOCKET,MSG,FLAGS,TO + +=item send SOCKET,MSG,FLAGS + +Sends a message on a socket. Takes the same flags as the system call +of the same name. On unconnected sockets you must specify a +destination to send TO, in which case it does a C sendto(). Returns +the number of characters sent, or the undefined value if there is an +error. + +=item setpgrp PID,PGRP + +Sets the current process group for the specified PID, 0 for the current +process. Will produce a fatal error if used on a machine that doesn't +implement setpgrp(2). + +=item setpriority WHICH,WHO,PRIORITY + +Sets the current priority for a process, a process group, or a user. +(See Lsetpriority(2)>.) Will produce a fatal error if used on a machine +that doesn't implement setpriority(2). + +=item setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL + +Sets the socket option requested. Returns undefined if there is an +error. OPTVAL may be specified as undef if you don't want to pass an +argument. + +=item shift ARRAY + +=item shift + +Shifts the first value of the array off and returns it, shortening the +array by 1 and moving everything down. If there are no elements in the +array, returns the undefined value. If ARRAY is omitted, shifts the +@ARGV array in the main program, and the @_ array in subroutines. +(This is determined lexically.) See also unshift(), push(), and pop(). +Shift() and unshift() do the same thing to the left end of an array +that push() and pop() do to the right end. + +=item shmctl ID,CMD,ARG + +Calls the System V IPC function shmctl. If CMD is &IPC_STAT, then ARG +must be a variable which will hold the returned shmid_ds structure. +Returns like ioctl: the undefined value for error, "0 but true" for +zero, or the actual return value otherwise. + +=item shmget KEY,SIZE,FLAGS + +Calls the System V IPC function shmget. Returns the shared memory +segment id, or the undefined value if there is an error. + +=item shmread ID,VAR,POS,SIZE + +=item shmwrite ID,STRING,POS,SIZE + +Reads or writes the System V shared memory segment ID starting at +position POS for size SIZE by attaching to it, copying in/out, and +detaching from it. When reading, VAR must be a variable which will +hold the data read. When writing, if STRING is too long, only SIZE +bytes are used; if STRING is too short, nulls are written to fill out +SIZE bytes. Return TRUE if successful, or FALSE if there is an error. + +=item shutdown SOCKET,HOW + +Shuts down a socket connection in the manner indicated by HOW, which +has the same interpretation as in the system call of the same name. + +=item sin EXPR + +Returns the sine of EXPR (expressed in radians). If EXPR is omitted, +returns sine of $_. + +=item sleep EXPR + +=item sleep + +Causes the script to sleep for EXPR seconds, or forever if no EXPR. +May be interrupted by sending the process a SIGALRM. Returns the +number of seconds actually slept. You probably cannot mix alarm() and +sleep() calls, since sleep() is often implemented using alarm(). + +On some older systems, it may sleep up to a full second less than what +you requested, depending on how it counts seconds. Most modern systems +always sleep the full amount. + +=item socket SOCKET,DOMAIN,TYPE,PROTOCOL + +Opens a socket of the specified kind and attaches it to filehandle +SOCKET. DOMAIN, TYPE and PROTOCOL are specified the same as for the +system call of the same name. You should "use Socket;" first to get +the proper definitions imported. See the example in L<perlipc>. + +=item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL + +Creates an unnamed pair of sockets in the specified domain, of the +specified type. DOMAIN, TYPE and PROTOCOL are specified the same as +for the system call of the same name. If unimplemented, yields a fatal +error. Returns TRUE if successful. + +=item sort SUBNAME LIST + +=item sort BLOCK LIST + +=item sort LIST + +Sorts the LIST and returns the sorted list value. Nonexistent values +of arrays are stripped out. If SUBNAME or BLOCK is omitted, sorts +in standard string comparison order. If SUBNAME is specified, it +gives the name of a subroutine that returns an integer less than, equal +to, or greater than 0, depending on how the elements of the array are +to be ordered. (The <=> and cmp operators are extremely useful in such +routines.) SUBNAME may be a scalar variable name, in which case the +value provides the name of the subroutine to use. In place of a +SUBNAME, you can provide a BLOCK as an anonymous, in-line sort +subroutine. + +In the interests of efficiency the normal calling code for subroutines +is bypassed, with the following effects: the subroutine may not be a +recursive subroutine, and the two elements to be compared are passed +into the subroutine not via @_ but as $a and $b (see example below). +They are passed by reference, so don't modify $a and $b. + +Examples: + + # sort lexically + @articles = sort @files; + + # same thing, but with explicit sort routine + @articles = sort {$a cmp $b} @files; + + # same thing in reversed order + @articles = sort {$b cmp $a} @files; + + # sort numerically ascending + @articles = sort {$a <=> $b} @files; + + # sort numerically descending + @articles = sort {$b <=> $a} @files; + + # sort using explicit subroutine name + sub byage { + $age{$a} <=> $age{$b}; # presuming integers + } + @sortedclass = sort byage @class; + + sub backwards { $b cmp $a; } + @harry = ('dog','cat','x','Cain','Abel'); + @george = ('gone','chased','yz','Punished','Axed'); + print sort @harry; + # prints AbelCaincatdogx + print sort backwards @harry; + # prints xdogcatCainAbel + print sort @george, 'to', @harry; + # prints AbelAxedCainPunishedcatchaseddoggonetoxyz + +=item splice ARRAY,OFFSET,LENGTH,LIST + +=item splice ARRAY,OFFSET,LENGTH + +=item splice ARRAY,OFFSET + +Removes the elements designated by OFFSET and LENGTH from an array, and +replaces them with the elements of LIST, if any. Returns the elements +removed from the array. The array grows or shrinks as necessary. If +LENGTH is omitted, removes everything from OFFSET onward. The +following equivalencies hold (assuming $[ == 0): + + push(@a,$x,$y) splice(@a,$#a+1,0,$x,$y) + pop(@a) splice(@a,-1) + shift(@a) splice(@a,0,1) + unshift(@a,$x,$y) splice(@a,0,0,$x,$y) + $a[$x] = $y splice(@a,$x,1,$y); + +Example, assuming array lengths are passed before arrays: + + sub aeq { # compare two list values + local(@a) = splice(@_,0,shift); + local(@b) = splice(@_,0,shift); + return 0 unless @a == @b; # same len? + while (@a) { + return 0 if pop(@a) ne pop(@b); + } + return 1; + } + if (&aeq($len,@foo[1..$len],0+@bar,@bar)) { ... } + +=item split /PATTERN/,EXPR,LIMIT + +=item split /PATTERN/,EXPR + +=item split /PATTERN/ + +=item split + +Splits a string into an array of strings, and returns it. + +If not in a list context, returns the number of fields found and splits into +the @_ array. (In a list context, you can force the split into @_ by +using C<??> as the pattern delimiters, but it still returns the array +value.) The use of implicit split to @_ is deprecated, however. + +If EXPR is omitted, splits the $_ string. If PATTERN is also omitted, +splits on whitespace (C</[ \t\n]+/>). Anything matching PATTERN is taken +to be a delimiter separating the fields. (Note that the delimiter may +be longer than one character.) If LIMIT is specified and is not +negative, splits into no more than that many fields (though it may +split into fewer). If LIMIT is unspecified, trailing null fields are +stripped (which potential users of pop() would do well to remember). +If LIMIT is negative, it is treated as if an arbitrarily large LIMIT +had been specified. + +A pattern matching the null string (not to be confused with +a null pattern C<//., which is just one member of the set of patterns +matching a null string) will split the value of EXPR into separate +characters at each point it matches that way. For example: + + print join(':', split(/ */, 'hi there')); + +produces the output 'h:i:t:h:e:r:e'. + +The LIMIT parameter can be used to partially split a line + + ($login, $passwd, $remainder) = split(/:/, $_, 3); + +When assigning to a list, if LIMIT is omitted, Perl supplies a LIMIT +one larger than the number of variables in the list, to avoid +unnecessary work. For the list above LIMIT would have been 4 by +default. In time critical applications it behooves you not to split +into more fields than you really need. + +If the PATTERN contains parentheses, additional array elements are +created from each matching substring in the delimiter. + + split(/([,-])/, "1-10,20"); + +produces the list value + + (1, '-', 10, ',', 20) + +The pattern C</PATTERN/> may be replaced with an expression to specify +patterns that vary at runtime. (To do runtime compilation only once, +use C</$variable/o>.) As a special case, specifying a space S<(' ')> will +split on white space just as split with no arguments does, but leading +white space does I<NOT> produce a null first field. Thus, split(' ') can +be used to emulate B<awk>'s default behavior, whereas C<split(/ /)> will +give you as many null initial fields as there are leading spaces. + +Example: + + open(passwd, '/etc/passwd'); + while (<passwd>) { + ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(/:/); + ... + } + +(Note that $shell above will still have a newline on it. See L</chop>, +L</chomp>, and L</join>.) + +=item sprintf FORMAT,LIST + +Returns a string formatted by the usual printf conventions of the C +language. (The * character for an indirectly specified length is not +supported, but you can get the same effect by interpolating a variable +into the pattern.) + +=item sqrt EXPR + +Return the square root of EXPR. If EXPR is omitted, returns square +root of $_. + +=item srand EXPR + +Sets the random number seed for the C<rand> operator. If EXPR is +omitted, does C<srand(time)>. 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 comp.security.unix. + +=item stat FILEHANDLE + +=item stat EXPR + +Returns a 13-element array giving the status info for a file, either the +file opened via FILEHANDLE, or named by EXPR. Returns a null list if +the stat fails. Typically used as follows: + + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) + = stat($filename); + +If stat is passed the special filehandle consisting of an underline, no +stat is done, but the current contents of the stat structure from the +last stat or filetest are returned. Example: + + if (-x $file && (($d) = stat(_)) && $d < 0) { + print "$file is executable NFS file\n"; + } + +(This only works on machines for which the device number is negative under NFS.) + +=item study SCALAR + +=item study + +Takes extra time to study SCALAR ($_ if unspecified) in anticipation of +doing many pattern matches on the string before it is next modified. +This may or may not save time, depending on the nature and number of +patterns you are searching on, and on the distribution of character +frequencies in the string to be searched--you probably want to compare +runtimes with and without it to see which runs faster. Those loops +which scan for many short constant strings (including the constant +parts of more complex patterns) will benefit most. You may have only +one study active at a time--if you study a different scalar the first +is "unstudied". (The way study works is this: a linked list of every +character in the string to be searched is made, so we know, for +example, where all the 'k' characters are. From each search string, +the rarest character is selected, based on some static frequency tables +constructed from some C programs and English text. Only those places +that contain this "rarest" character are examined.) + +For example, here is a loop which inserts index producing entries +before any line containing a certain pattern: + + while (<>) { + study; + print ".IX foo\n" if /\bfoo\b/; + print ".IX bar\n" if /\bbar\b/; + print ".IX blurfl\n" if /\bblurfl\b/; + ... + print; + } + +In searching for /\bfoo\b/, only those locations in $_ that contain "f" +will be looked at, because "f" is rarer than "o". In general, this is +a big win except in pathological cases. The only question is whether +it saves you more time than it took to build the linked list in the +first place. + +Note that if you have to look for strings that you don't know till +runtime, you can build an entire loop as a string and eval that to +avoid recompiling all your patterns all the time. Together with +undefining $/ to input entire files as one record, this can be very +fast, often faster than specialized programs like fgrep(1). The following +scans a list of files (@files) for a list of words (@words), and prints +out the names of those files that contain a match: + + $search = 'while (<>) { study;'; + foreach $word (@words) { + $search .= "++\$seen{\$ARGV} if /\\b$word\\b/;\n"; + } + $search .= "}"; + @ARGV = @files; + undef $/; + eval $search; # this screams + $/ = "\n"; # put back to normal input delim + foreach $file (sort keys(%seen)) { + print $file, "\n"; + } + +=item substr EXPR,OFFSET,LEN + +=item substr EXPR,OFFSET + +Extracts a substring out of EXPR and returns it. First character is at +offset 0, or whatever you've set $[ to. If OFFSET is negative, starts +that far from the end of the string. If LEN is omitted, returns +everything to the end of the string. You can use the substr() function +as an lvalue, in which case EXPR must be an lvalue. If you assign +something shorter than LEN, the string will shrink, and if you assign +something longer than LEN, the string will grow to accommodate it. To +keep the string the same length you may need to pad or chop your value +using sprintf(). + +=item symlink OLDFILE,NEWFILE + +Creates a new filename symbolically linked to the old filename. +Returns 1 for success, 0 otherwise. On systems that don't support +symbolic links, produces a fatal error at run time. To check for that, +use eval: + + $symlink_exists = (eval 'symlink("","");', $@ eq ''); + +=item syscall LIST + +Calls the system call specified as the first element of the list, +passing the remaining elements as arguments to the system call. If +unimplemented, produces a fatal error. The arguments are interpreted +as follows: if a given argument is numeric, the argument is passed as +an int. If not, the pointer to the string value is passed. You are +responsible to make sure a string is pre-extended long enough to +receive any result that might be written into a string. If your +integer arguments are not literals and have never been interpreted in a +numeric context, you may need to add 0 to them to force them to look +like numbers. + + require 'syscall.ph'; # may need to run h2ph + syscall(&SYS_write, fileno(STDOUT), "hi there\n", 9); + +Note that Perl only supports passing of up to 14 arguments to your system call, +which in practice should usually suffice. + +=item sysread FILEHANDLE,SCALAR,LENGTH,OFFSET + +=item sysread FILEHANDLE,SCALAR,LENGTH + +Attempts to read LENGTH bytes of data into variable SCALAR from the +specified FILEHANDLE, using the system call read(2). It bypasses +stdio, so mixing this with other kinds of reads may cause confusion. +Returns the number of bytes actually read, or undef if there was an +error. SCALAR will be grown or shrunk to the length actually read. An +OFFSET may be specified to place the read data at some other place than +the beginning of the string. + +=item system LIST + +Does exactly the same thing as "exec LIST" except that a fork is done +first, and the parent process waits for the child process to complete. +Note that argument processing varies depending on the number of +arguments. The return value is the exit status of the program as +returned by the wait() call. To get the actual exit value divide by +256. See also L</exec>. + +=item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET + +=item syswrite FILEHANDLE,SCALAR,LENGTH + +Attempts to write LENGTH bytes of data from variable SCALAR to the +specified FILEHANDLE, using the system call write(2). It bypasses +stdio, so mixing this with prints may cause confusion. Returns the +number of bytes actually written, or undef if there was an error. An +OFFSET may be specified to place the read data at some other place than +the beginning of the string. + +=item tell FILEHANDLE + +=item tell + +Returns the current file position for FILEHANDLE. FILEHANDLE may be an +expression whose value gives the name of the actual filehandle. If +FILEHANDLE is omitted, assumes the file last read. + +=item telldir DIRHANDLE + +Returns the current position of the readdir() routines on DIRHANDLE. +Value may be given to seekdir() to access a particular location in a +directory. Has the same caveats about possible directory compaction as +the corresponding system library routine. + +=item tie VARIABLE,PACKAGENAME,LIST + +This function binds a variable to a package that will provide the +implementation for the variable. VARIABLE is the name of the variable +to be enchanted. PACKAGENAME is the name of a package implementing +objects of correct type. Any additional arguments are passed to the +"new" method of the package. Typically these are arguments such as +might be passed to the dbm_open() function of C. + +Note that functions such as keys() and values() may return huge array +values when used on large DBM files. You may prefer to use the each() +function to iterate over large DBM files. Example: + + # print out history file offsets + tie(%HIST, NDBM_File, '/usr/lib/news/history', 1, 0); + while (($key,$val) = each %HIST) { + print $key, ' = ', unpack('L',$val), "\n"; + } + untie(%HIST); + +A package implementing an associative array should have the following +methods: + + TIEHASH objectname, LIST + DESTROY this + FETCH this, key + STORE this, key, value + DELETE this, key + EXISTS this, key + FIRSTKEY this + NEXTKEY this, lastkey + +A package implementing an ordinary array should have the following methods: + + TIEARRAY objectname, LIST + DESTROY this + FETCH this, key + STORE this, key, value + [others TBD] + +A package implementing a scalar should have the following methods: + + TIESCALAR objectname, LIST + DESTROY this + FETCH this, + STORE this, value + +=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 + +Returns a four-element array giving the user and system times, in +seconds, for this process and the children of this process. + + ($user,$system,$cuser,$csystem) = times; + +=item tr/// + +The translation operator. See L<perlop>. + +=item truncate FILEHANDLE,LENGTH + +=item truncate EXPR,LENGTH + +Truncates the file opened on FILEHANDLE, or named by EXPR, to the +specified length. Produces a fatal error if truncate isn't implemented +on your system. + +=item uc EXPR + +Returns an uppercased version of EXPR. This is the internal function +implementing the \U escape in double-quoted strings. + +=item ucfirst EXPR + +Returns the value of EXPR with the first character uppercased. This is +the internal function implementing the \u escape in double-quoted strings. + +=item umask EXPR + +=item umask + +Sets the umask for the process and returns the old one. If EXPR is +omitted, merely returns current umask. + +=item undef EXPR + +=item undef + +Undefines the value of EXPR, which must be an lvalue. Use only on a +scalar value, an entire array, or a subroutine name (using "&"). (Using undef() +will probably not do what you expect on most predefined variables or +DBM list values, so don't do that.) Always returns the undefined value. You can omit +the EXPR, in which case nothing is undefined, but you still get an +undefined value that you could, for instance, return from a +subroutine. Examples: + + undef $foo; + undef $bar{'blurfl'}; + undef @ary; + undef %assoc; + undef &mysub; + return (wantarray ? () : undef) if $they_blew_it; + +=item unlink LIST + +Deletes a list of files. Returns the number of files successfully +deleted. + + $cnt = unlink 'a', 'b', 'c'; + unlink @goners; + unlink <*.bak>; + +Note: unlink will not delete directories unless you are superuser and +the B<-U> flag is supplied to Perl. Even if these conditions are +met, be warned that unlinking a directory can inflict damage on your +filesystem. Use rmdir instead. + +=item unpack TEMPLATE,EXPR + +Unpack does the reverse of pack: it takes a string representing a +structure and expands it out into a list value, returning the array +value. (In a scalar context, it merely returns the first value +produced.) The TEMPLATE has the same format as in the pack function. +Here's a subroutine that does substring: + + sub substr { + local($what,$where,$howmuch) = @_; + unpack("x$where a$howmuch", $what); + } + +and then there's + + sub ordinal { unpack("c",$_[0]); } # same as ord() + +In addition, you may prefix a field with a %<number> to indicate that +you want a <number>-bit checksum of the items instead of the items +themselves. Default is a 16-bit checksum. For example, the following +computes the same number as the System V sum program: + + while (<>) { + $checksum += unpack("%16C*", $_); + } + $checksum %= 65536; + +The following efficiently counts the number of set bits in a bit vector: + + $setbits = unpack("%32b*", $selectmask); + +=item untie VARIABLE + +Breaks the binding between a variable and a package. (See tie().) + +=item unshift ARRAY,LIST + +Does the opposite of a C<shift>. Or the opposite of a C<push>, +depending on how you look at it. Prepends list to the front of the +array, and returns the new number of elements in the array. + + unshift(ARGV, '-e') unless $ARGV[0] =~ /^-/; + +Note the LIST is prepended whole, not one element at a time, so the +prepended elements stay in the same order. Use reverse to do the +reverse. + +=item use Module LIST + +=item use Module + +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; } + +If you don't want your namespace altered, use require instead. + +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 +call into the "Module" package to tell the module to import the list of +features back into the current package. The module can implement its +import method any way it likes, though most modules just choose to +derive their import method via inheritance from the Exporter class that +is defined in the Exporter module. + +Because this is a wide-open interface, pragmas (compiler directives) +are also implemented this way. Currently implemented pragmas are: + + use integer; + use sigtrap qw(SEGV BUS); + use strict qw(subs vars refs); + use subs qw(afunc blurfl); + +These pseudomodules import semantics into the current block scope, unlike +ordinary modules, which import symbols into the current package (which are +effective through the end of the file). + +There's a corresponding "no" command that unimports meanings imported +by use. + + no integer; + no strict 'refs'; + +See L<perlmod> for a list of standard modules and pragmas. + +=item utime LIST + +Changes the access and modification times on each file of a list of +files. The first two elements of the list must be the NUMERICAL access +and modification times, in that order. Returns the number of files +successfully changed. The inode modification time of each file is set +to the current time. Example of a "touch" command: + + #!/usr/bin/perl + $now = time; + utime $now, $now, @ARGV; + +=item values ASSOC_ARRAY + +Returns a normal array consisting of all the values of the named +associative array. (In a scalar context, returns the number of +values.) The values are returned in an apparently random order, but it +is the same order as either the keys() or each() function would produce +on the same array. See also keys() and each(). + +=item vec EXPR,OFFSET,BITS + +Treats a string as a vector of unsigned integers, and returns the value +of the bitfield specified. May also be assigned to. BITS must be a +power of two from 1 to 32. + +Vectors created with vec() can also be manipulated with the logical +operators |, & and ^, which will assume a bit vector operation is +desired when both operands are strings. + +To transform a bit vector into a string or array of 0's and 1's, use these: + + $bits = unpack("b*", $vector); + @bits = split(//, unpack("b*", $vector)); + +If you know the exact length in bits, it can be used in place of the *. + +=item wait + +Waits for a child process to terminate and returns the pid of the +deceased process, or -1 if there are no child processes. The status is +returned in $?. + +=item waitpid PID,FLAGS + +Waits for a particular child process to terminate and returns the pid +of the deceased process, or -1 if there is no such child process. The +status is returned in $?. If you say + + use POSIX "wait_h"; + ... + waitpid(-1,&WNOHANG); + +then you can do a non-blocking wait for any process. Non-blocking wait +is only available on machines supporting either the waitpid(2) or +wait4(2) system calls. However, waiting for a particular pid with +FLAGS of 0 is implemented everywhere. (Perl emulates the system call +by remembering the status values of processes that have exited but have +not been harvested by the Perl script yet.) + +=item wantarray + +Returns TRUE if the context of the currently executing subroutine is +looking for a list value. Returns FALSE if the context is looking +for a scalar. + + return wantarray ? () : undef; + +=item warn LIST + +Produces a message on STDERR just like die(), but doesn't exit or +throw an exception. + +=item write FILEHANDLE + +=item write EXPR + +=item write + +Writes a formatted record (possibly multi-line) to the specified file, +using the format associated with that file. By default the format for +a file is the one having the same name is the filehandle, but the +format for the current output channel (see the select() function) may be set +explicitly by assigning the name of the format to the $~ variable. + +Top of form processing is handled automatically: if there is +insufficient room on the current page for the formatted record, the +page is advanced by writing a form feed, a special top-of-page format +is used to format the new page header, and then the record is written. +By default the top-of-page format is the name of the filehandle with +"_TOP" appended, but it may be dynamically set to the format of your +choice by assigning the name to the $^ variable while the filehandle is +selected. The number of lines remaining on the current page is in +variable $-, which can be set to 0 to force a new page. + +If FILEHANDLE is unspecified, output goes to the current default output +channel, which starts out as STDOUT but may be changed by the +C<select> operator. If the FILEHANDLE is an EXPR, then the expression +is evaluated and the resulting string is used to look up the name of +the FILEHANDLE at run time. For more on formats, see L<perlform>. + +Note that write is I<NOT> the opposite of read. Unfortunately. + +=item y/// + +The translation operator. See L<perlop/tr///>. + +=back diff --git a/pod/perlguts.pod b/pod/perlguts.pod new file mode 100644 index 0000000000..a08ac95340 --- /dev/null +++ b/pod/perlguts.pod @@ -0,0 +1,521 @@ +=head1 NAME + +perlguts - Perl's Internal Functions + +=head1 DESCRIPTION + +This document attempts to describe some of the internal functions of the +Perl executable. It is far from complete and probably contains many errors. +Please refer any questions or comments to the author below. + +=head1 Datatypes + +Perl has three typedefs that handle Perl's three main data types: + + SV Scalar Value + AV Array Value + HV Hash Value + +Each typedef has specific routines that manipulate the various data type. + +=head2 What is an "IV"? + +Perl uses a special typedef IV which is large enough to hold either an +integer or a pointer. + +Perl also uses a special typedef I32 which will always be a 32-bit integer. + +=head2 Working with SV's + +An SV can be created and loaded with one command. There are four types of +values that can be loaded: an integer value (IV), a double (NV), a string, +(PV), and another scalar (SV). + +The four routines are: + + SV* newSViv(IV); + SV* newSVnv(double); + SV* newSVpv(char*, int); + SV* newSVsv(SV*); + +To change the value of an *already-existing* scalar, there are five routines: + + void sv_setiv(SV*, IV); + void sv_setnv(SV*, double); + void sv_setpvn(SV*, char*, int) + void sv_setpv(SV*, char*); + void sv_setsv(SV*, SV*); + +Notice that you can choose to specify the length of the string to be +assigned by using C<sv_setpvn>, or allow Perl to calculate the length by +using C<sv_setpv>. Be warned, though, that C<sv_setpv> determines the +string's length by using C<strlen>, which depends on the string terminating +with a NUL character. + +To access the actual value that an SV points to, you can use the macros: + + SvIV(SV*) + SvNV(SV*) + SvPV(SV*, STRLEN len) + +which will automatically coerce the actual scalar type into an IV, double, +or string. + +In the C<SvPV> macro, the length of the string returned is placed into the +variable C<len> (this is a macro, so you do I<not> use C<&len>). If you do not +care what the length of the data is, use the global variable C<na>. Remember, +however, that Perl allows arbitrary strings of data that may both contain +NUL's and not be terminated by a NUL. + +If you simply want to know if the scalar value is TRUE, you can use: + + SvTRUE(SV*) + +Although Perl will automatically grow strings for you, if you need to force +Perl to allocate more memory for your SV, you can use the macro + + SvGROW(SV*, STRLEN newlen) + +which will determine if more memory needs to be allocated. If so, it will +call the function C<sv_grow>. Note that C<SvGROW> can only increase, not +decrease, the allocated memory of an SV. + +If you have an SV and want to know what kind of data Perl thinks is stored +in it, you can use the following macros to check the type of SV you have. + + SvIOK(SV*) + SvNOK(SV*) + SvPOK(SV*) + +You can get and set the current length of the string stored in an SV with +the following macros: + + SvCUR(SV*) + SvCUR_set(SV*, I32 val) + +But note that these are valid only if C<SvPOK()> is true. + +If you know the name of a scalar variable, you can get a pointer to its SV +by using the following: + + SV* perl_get_sv("varname", FALSE); + +This returns NULL if the variable does not exist. + +If you want to know if this variable (or any other SV) is actually defined, +you can call: + + SvOK(SV*) + +The scalar C<undef> value is stored in an SV instance called C<sv_undef>. Its +address can be used whenever an C<SV*> is needed. + +There are also the two values C<sv_yes> and C<sv_no>, which contain Boolean +TRUE and FALSE values, respectively. Like C<sv_undef>, their addresses can +be used whenever an C<SV*> is needed. + +Do not be fooled into thinking that C<(SV *) 0> is the same as C<&sv_undef>. +Take this code: + + SV* sv = (SV*) 0; + if (I-am-to-return-a-real-value) { + sv = sv_2mortal(newSViv(42)); + } + sv_setsv(ST(0), sv); + +This code tries to return a new SV (which contains the value 42) if it should +return a real value, or undef otherwise. Instead it has returned a null +pointer which, somewhere down the line, will cause a segmentation violation, +or just weird results. Change the zero to C<&sv_undef> in the first line and +all will be well. + +To free an SV that you've created, call C<SvREFCNT_dec(SV*)>. Normally this +call is not necessary. See the section on B<MORTALITY>. + +=head2 Private and Public Values + +Recall that the usual method of determining the type of scalar you have is +to use C<Sv[INP]OK> macros. Since a scalar can be both a number and a string, +usually these macros will always return TRUE and calling the C<Sv[INP]V> +macros will do the appropriate conversion of string to integer/double or +integer/double to string. + +If you I<really> need to know if you have an integer, double, or string +pointer in an SV, you can use the following three macros instead: + + SvIOKp(SV*) + SvNOKp(SV*) + SvPOKp(SV*) + +These will tell you if you truly have an integer, double, or string pointer +stored in your SV. + +In general, though, it's best to just use the C<Sv[INP]V> macros. + +=head2 Working with AV's + +There are two ways to create and load an AV. The first method just creates +an empty AV: + + AV* newAV(); + +The second method both creates the AV and initially populates it with SV's: + + AV* av_make(I32 num, SV **ptr); + +The second argument points to an array containing C<num> C<SV*>'s. + +Once the AV has been created, the following operations are possible on AV's: + + void av_push(AV*, SV*); + SV* av_pop(AV*); + SV* av_shift(AV*); + void av_unshift(AV*, I32 num); + +These should be familiar operations, with the exception of C<av_unshift>. +This routine adds C<num> elements at the front of the array with the C<undef> +value. You must then use C<av_store> (described below) to assign values +to these new elements. + +Here are some other functions: + + I32 av_len(AV*); /* Returns length of array */ + + SV** av_fetch(AV*, I32 key, I32 lval); + /* Fetches value at key offset, but it seems to + set the value to lval if lval is non-zero */ + SV** av_store(AV*, I32 key, SV* val); + /* Stores val at offset key */ + + void av_clear(AV*); + /* Clear out all elements, but leave the array */ + void av_undef(AV*); + /* Undefines the array, removing all elements */ + +If you know the name of an array variable, you can get a pointer to its AV +by using the following: + + AV* perl_get_av("varname", FALSE); + +This returns NULL if the variable does not exist. + +=head2 Working with HV's + +To create an HV, you use the following routine: + + HV* newHV(); + +Once the HV has been created, the following operations are possible on HV's: + + SV** hv_store(HV*, char* key, U32 klen, SV* val, U32 hash); + SV** hv_fetch(HV*, char* key, U32 klen, I32 lval); + +The C<klen> parameter is the length of the key being passed in. The C<val> +argument contains the SV pointer to the scalar being stored, and C<hash> is +the pre-computed hash value (zero if you want C<hv_store> to calculate it +for you). The C<lval> parameter indicates whether this fetch is actually a +part of a store operation. + +Remember that C<hv_store> and C<hv_fetch> return C<SV**>'s and not just +C<SV*>. In order to access the scalar value, you must first dereference +the return value. However, you should check to make sure that the return +value is not NULL before dereferencing it. + +These two functions check if a hash table entry exists, and deletes it. + + bool hv_exists(HV*, char* key, U32 klen); + SV* hv_delete(HV*, char* key, U32 klen); + +And more miscellaneous functions: + + void hv_clear(HV*); + /* Clears all entries in hash table */ + void hv_undef(HV*); + /* Undefines the hash table */ + + I32 hv_iterinit(HV*); + /* Prepares starting point to traverse hash table */ + HE* hv_iternext(HV*); + /* Get the next entry, and return a pointer to a + structure that has both the key and value */ + char* hv_iterkey(HE* entry, I32* retlen); + /* Get the key from an HE structure and also return + the length of the key string */ + SV* hv_iterval(HV*, HE* entry); + /* Return a SV pointer to the value of the HE + structure */ + +If you know the name of a hash variable, you can get a pointer to its HV +by using the following: + + HV* perl_get_hv("varname", FALSE); + +This returns NULL if the variable does not exist. + +The hash algorithm, for those who are interested, is: + + i = klen; + hash = 0; + s = key; + while (i--) + hash = hash * 33 + *s++; + +=head2 References + +References are a special type of scalar that point to other scalar types +(including references). To treat an AV or HV as a scalar, it is simply +a matter of casting an AV or HV to an SV. + +To create a reference, use the following command: + + SV* newRV((SV*) pointer); + +Once you have a reference, you can use the following macro with a cast to +the appropriate typedef (SV, AV, HV): + + SvRV(SV*) + +then call the appropriate routines, casting the returned C<SV*> to either an +C<AV*> or C<HV*>. + +To determine, after dereferencing a reference, if you still have a reference, +you can use the following macro: + + SvROK(SV*) + +=head1 XSUB'S and the Argument Stack + +The XSUB mechanism is a simple way for Perl programs to access C subroutines. +An XSUB routine will have a stack that contains the arguments from the Perl +program, and a way to map from the Perl data structures to a C equivalent. + +The stack arguments are accessible through the C<ST(n)> macro, which returns +the C<n>'th stack argument. Argument 0 is the first argument passed in the +Perl subroutine call. These arguments are C<SV*>, and can be used anywhere +an C<SV*> is used. + +Most of the time, output from the C routine can be handled through use of +the RETVAL and OUTPUT directives. However, there are some cases where the +argument stack is not already long enough to handle all the return values. +An example is the POSIX tzname() call, which takes no arguments, but returns +two, the local timezone's standard and summer time abbreviations. + +To handle this situation, the PPCODE directive is used and the stack is +extended using the macro: + + EXTEND(sp, num); + +where C<sp> is the stack pointer, and C<num> is the number of elements the +stack should be extended by. + +Now that there is room on the stack, values can be pushed on it using the +macros to push IV's, doubles, strings, and SV pointers respectively: + + PUSHi(IV) + PUSHn(double) + PUSHp(char*, I32) + PUSHs(SV*) + +And now the Perl program calling C<tzname>, the two values will be assigned +as in: + + ($standard_abbrev, $summer_abbrev) = POSIX::tzname; + +An alternate (and possibly simpler) method to pushing values on the stack is +to use the macros: + + XPUSHi(IV) + XPUSHn(double) + XPUSHp(char*, I32) + XPUSHs(SV*) + +These macros automatically adjust the stack for you, if needed. + +=head1 Mortality + +In Perl, values are normally "immortal" -- that is, they are not freed unless +explicitly done so (via the Perl C<undef> call or other routines in Perl +itself). + +In the above example with C<tzname>, we needed to create two new SV's to push +onto the argument stack, that being the two strings. However, we don't want +these new SV's to stick around forever because they will eventually be +copied into the SV's that hold the two scalar variables. + +An SV (or AV or HV) that is "mortal" acts in all ways as a normal "immortal" +SV, AV, or HV, but is only valid in the "current context". When the Perl +interpreter leaves the current context, the mortal SV, AV, or HV is +automatically freed. Generally the "current context" means a single +Perl statement. + +To create a mortal variable, use the functions: + + SV* sv_newmortal() + SV* sv_2mortal(SV*) + SV* sv_mortalcopy(SV*) + +The first call creates a mortal SV, the second converts an existing SV to +a mortal SV, the third creates a mortal copy of an existing SV. + +The mortal routines are not just for SV's -- AV's and HV's can be made mortal +by passing their address (and casting them to C<SV*>) to the C<sv_2mortal> or +C<sv_mortalcopy> routines. + +=head1 Creating New Variables + +To create a new Perl variable, which can be accessed from your Perl script, +use the following routines, depending on the variable type. + + SV* perl_get_sv("varname", TRUE); + AV* perl_get_av("varname", TRUE); + HV* perl_get_hv("varname", TRUE); + +Notice the use of TRUE as the second parameter. The new variable can now +be set, using the routines appropriate to the data type. + +=head1 Stashes and Objects + +A stash is a hash table (associative array) that contains all of the +different objects that are contained within a package. Each key of the +hash table is a symbol name (shared by all the different types of +objects that have the same name), and each value in the hash table is +called a GV (for Glob Value). The GV in turn contains references to +the various objects of that name, including (but not limited to) the +following: + + Scalar Value + Array Value + Hash Value + File Handle + Directory Handle + Format + Subroutine + +Perl stores various stashes in a GV structure (for global variable) but +represents them with an HV structure. + +To get the HV pointer for a particular package, use the function: + + HV* gv_stashpv(char* name, I32 create) + HV* gv_stashsv(SV*, I32 create) + +The first function takes a literal string, the second uses the string stored +in the SV. + +The name that C<gv_stash*v> wants is the name of the package whose symbol table +you want. The default package is called C<main>. If you have multiply nested +packages, it is legal to pass their names to C<gv_stash*v>, separated by +C<::> as in the Perl language itself. + +Alternately, if you have an SV that is a blessed reference, you can find +out the stash pointer by using: + + HV* SvSTASH(SvRV(SV*)); + +then use the following to get the package name itself: + + char* HvNAME(HV* stash); + +If you need to return a blessed value to your Perl script, you can use the +following function: + + SV* sv_bless(SV*, HV* stash) + +where the first argument, an C<SV*>, must be a reference, and the second +argument is a stash. The returned C<SV*> can now be used in the same way +as any other SV. + +=head1 Magic + +[This section under construction] + +=head1 Double-Typed SV's + +Scalar variables normally contain only one type of value, an integer, +double, pointer, or reference. Perl will automatically convert the +actual scalar data from the stored type into the requested type. + +Some scalar variables contain more than one type of scalar data. For +example, the variable C<$!> contains either the numeric value of C<errno> +or its string equivalent from C<sys_errlist[]>. + +To force multiple data values into an SV, you must do two things: use the +C<sv_set*v> routines to add the additional scalar type, then set a flag +so that Perl will believe it contains more than one type of data. The +four macros to set the flags are: + + SvIOK_on + SvNOK_on + SvPOK_on + SvROK_on + +The particular macro you must use depends on which C<sv_set*v> routine +you called first. This is because every C<sv_set*v> routine turns on +only the bit for the particular type of data being set, and turns off +all the rest. + +For example, to create a new Perl variable called "dberror" that contains +both the numeric and descriptive string error values, you could use the +following code: + + extern int dberror; + extern char *dberror_list; + + SV* sv = perl_get_sv("dberror", TRUE); + sv_setiv(sv, (IV) dberror); + sv_setpv(sv, dberror_list[dberror]); + SvIOK_on(sv); + +If the order of C<sv_setiv> and C<sv_setpv> had been reversed, then the +macro C<SvPOK_on> would need to be called instead of C<SvIOK_on>. + +=head1 Calling Perl Routines from within C Programs + +There are four routines that can be used to call a Perl subroutine from +within a C program. These four are: + + I32 perl_call_sv(SV*, I32); + I32 perl_call_pv(char*, I32); + I32 perl_call_method(char*, I32); + I32 perl_call_argv(char*, I32, register char**); + +The routine most often used should be C<perl_call_sv>. The C<SV*> argument +contains either the name of the Perl subroutine to be called, or a reference +to the subroutine. The second argument tells the appropriate routine what, +if any, variables are being returned by the Perl subroutine. + +All four routines return the number of arguments that the subroutine returned +on the Perl stack. + +When using these four routines, the programmer must manipulate the Perl stack. +These include the following macros and functions: + + dSP + PUSHMARK() + PUTBACK + SPAGAIN + ENTER + SAVETMPS + FREETMPS + LEAVE + XPUSH*() + +For more information, consult L<perlcall>. + +=head1 Memory Allocation + +[This section under construction] + +=head1 AUTHOR + +Jeff Okamoto <okamoto@corp.hp.com> + +With lots of help and suggestions from Dean Roehrich, Malcolm Beattie, +Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, and Neil +Bowers. + +=head1 DATE + +Version 12: 1994/10/16 + + diff --git a/pod/perlipc.pod b/pod/perlipc.pod new file mode 100644 index 0000000000..a2f3f8b16d --- /dev/null +++ b/pod/perlipc.pod @@ -0,0 +1,168 @@ +=head1 NAME + +perlipc - Perl interprocess communication + +=head1 DESCRIPTION + +The IPC facilities of Perl are built on the Berkeley socket mechanism. +If you don't have sockets, you can ignore this section. The calls have +the same names as the corresponding system calls, but the arguments +tend to differ, for two reasons. First, Perl file handles work +differently than C file descriptors. Second, Perl already knows the +length of its strings, so you don't need to pass that information. + +=head2 Client/Server Communication + +Here's a sample TCP client. + + ($them,$port) = @ARGV; + $port = 2345 unless $port; + $them = 'localhost' unless $them; + + $SIG{'INT'} = 'dokill'; + sub dokill { kill 9,$child if $child; } + + use Socket; + + $sockaddr = 'S n a4 x8'; + chop($hostname = `hostname`); + + ($name, $aliases, $proto) = getprotobyname('tcp'); + ($name, $aliases, $port) = getservbyname($port, 'tcp') + unless $port =~ /^\d+$/; + ($name, $aliases, $type, $len, $thisaddr) = + gethostbyname($hostname); + ($name, $aliases, $type, $len, $thataddr) = gethostbyname($them); + + $this = pack($sockaddr, &AF_INET, 0, $thisaddr); + $that = pack($sockaddr, &AF_INET, $port, $thataddr); + + socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; + bind(S, $this) || die "bind: $!"; + connect(S, $that) || die "connect: $!"; + + select(S); $| = 1; select(stdout); + + if ($child = fork) { + while (<>) { + print S; + } + sleep 3; + do dokill(); + } + else { + while (<S>) { + print; + } + } + +And here's a server: + + ($port) = @ARGV; + $port = 2345 unless $port; + + use Socket; + + $sockaddr = 'S n a4 x8'; + + ($name, $aliases, $proto) = getprotobyname('tcp'); + ($name, $aliases, $port) = getservbyname($port, 'tcp') + unless $port =~ /^\d+$/; + + $this = pack($sockaddr, &AF_INET, $port, "\0\0\0\0"); + + select(NS); $| = 1; select(stdout); + + socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; + bind(S, $this) || die "bind: $!"; + listen(S, 5) || die "connect: $!"; + + select(S); $| = 1; select(stdout); + + for (;;) { + print "Listening again\n"; + ($addr = accept(NS,S)) || die $!; + print "accept ok\n"; + + ($af,$port,$inetaddr) = unpack($sockaddr,$addr); + @inetaddr = unpack('C4',$inetaddr); + print "$af $port @inetaddr\n"; + + while (<NS>) { + print; + print NS; + } + } + +=head2 SysV IPC + +Here's a small example showing shared memory usage: + + $IPC_PRIVATE = 0; + $IPC_RMID = 0; + $size = 2000; + $key = shmget($IPC_PRIVATE, $size , 0777 ); + die if !defined($key); + + $message = "Message #1"; + shmwrite($key, $message, 0, 60 ) || die "$!"; + shmread($key,$buff,0,60) || die "$!"; + + print $buff,"\n"; + + print "deleting $key\n"; + shmctl($key ,$IPC_RMID, 0) || die "$!"; + +Here's an example of a semaphore: + + $IPC_KEY = 1234; + $IPC_RMID = 0; + $IPC_CREATE = 0001000; + $key = semget($IPC_KEY, $nsems , 0666 | $IPC_CREATE ); + 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 + + $IPC_KEY = 1234; + $key = semget($IPC_KEY, 0 , 0 ); + die if !defined($key); + + $semnum = 0; + $semflag = 0; + + # 'take' semaphore + # wait for semaphore to be zero + $semop = 0; + $opstring1 = pack("sss", $semnum, $semop, $semflag); + + # Increment the semaphore count + $semop = 1; + $opstring2 = pack("sss", $semnum, $semop, $semflag); + $opstring = $opstring1 . $opstring2; + + semop($key,$opstring) || die "$!"; + +Put this code in a separate file to be run in more that one process +Call this file F<give>: + + #'give' the semaphore + # run this in the original process and you will see + # that the second process continues + + $IPC_KEY = 1234; + $key = semget($IPC_KEY, 0, 0); + die if !defined($key); + + $semnum = 0; + $semflag = 0; + + # Decrement the semaphore count + $semop = -1; + $opstring = pack("sss", $semnum, $semop, $semflag); + + semop($key,$opstring) || die "$!"; + diff --git a/pod/perlmod.pod b/pod/perlmod.pod new file mode 100644 index 0000000000..d804b1e4ed --- /dev/null +++ b/pod/perlmod.pod @@ -0,0 +1,472 @@ +=head1 NAME + +perlmod - Perl modules (packages) + +=head1 DESCRIPTION + +=head2 Packages + +Perl provides a mechanism for alternate namespaces to protect packages +from stomping on each others variables. By default, a Perl script starts +compiling into the package known as C<main>. You can switch namespaces +using the C<package> declaration. The scope of the package declaration is +from the declaration itself to the end of the enclosing block (the same +scope as the local() operator). Typically it would be the first +declaration in a file to be included by the C<require> operator. You can +switch into a package in more than one place; it merely influences which +symbol table is used by the compiler for the rest of that block. You can +refer to variables and filehandles in other packages by prefixing the +identifier with the package name and a double colon: +C<$Package::Variable>. If the package name is null, the C<main> package +as assumed. That is, C<$::sail> is equivalent to C<$main::sail>. + +(The old package delimiter was a single quote, but double colon +is now the preferred delimiter, in part because it's more readable +to humans, and in part because it's more readable to B<emacs> macros. +It also makes C++ programmers feel like they know what's going on.) + +Packages may be nested inside other packages: C<$OUTER::INNER::var>. This +implies nothing about the order of name lookups, however. All symbols +are either local to the current package, or must be fully qualified +from the outer package name down. For instance, there is nowhere +within package C<OUTER> that C<$INNER::var> refers to C<$OUTER::INNER::var>. +It would treat package C<INNER> as a totally separate global package. + +Only identifiers starting with letters (or underscore) are stored in a +package's symbol table. All other symbols are kept in package C<main>. +In addition, the identifiers STDIN, STDOUT, STDERR, C<ARGV>, +ARGVOUT, ENV, INC and SIG are forced to be in package C<main>, +even when used for other purposes than their built-in one. Note also +that, if you have a package called C<m>, C<s> or C<y>, then you can't use +the qualified form of an identifier since it will be interpreted instead +as a pattern match, a substitution, or a translation. + +(Variables beginning with underscore used to be forced into package +main, but we decided it was more useful for package writers to be able +to use leading underscore to indicate private variables and method names.) + +Eval()ed strings are compiled in the package in which the eval() was +compiled. (Assignments to C<$SIG{}>, however, assume the signal +handler specified is in the C<main. package. Qualify the signal handler +name if you wish to have a signal handler in a package.) For an +example, examine F<perldb.pl> in the Perl library. It initially switches +to the C<DB> package so that the debugger doesn't interfere with variables +in the script you are trying to debug. At various points, however, it +temporarily switches back to the C<main> package to evaluate various +expressions in the context of the C<main> package (or wherever you came +from). See L<perldebug>. + +=head2 Symbol Tables + +The symbol table for a package happens to be stored in the associative +array of that name appended with two colons. The main symbol table's +name is thus C<%main::>, or C<%::> for short. Likewise the nested package +mentioned earlier is named C<%OUTER::INNER::>. + +The value in each entry of the associative array is what you are +referring to when you use the C<*name> notation. In fact, the following +have the same effect, though the first is more efficient because it +does the symbol table lookups at compile time: + + local(*main::foo) = *main::bar; local($main::{'foo'}) = + $main::{'bar'}; + +You can use this to print out all the variables in a package, for +instance. Here is F<dumpvar.pl> from the Perl library: + + package dumpvar; + sub main::dumpvar { + ($package) = @_; + local(*stab) = eval("*${package}::"); + while (($key,$val) = each(%stab)) { + local(*entry) = $val; + if (defined $entry) { + print "\$$key = '$entry'\n"; + } + + if (defined @entry) { + print "\@$key = (\n"; + foreach $num ($[ .. $#entry) { + print " $num\t'",$entry[$num],"'\n"; + } + print ")\n"; + } + + if ($key ne "${package}::" && defined %entry) { + print "\%$key = (\n"; + foreach $key (sort keys(%entry)) { + print " $key\t'",$entry{$key},"'\n"; + } + print ")\n"; + } + } + } + +Note that even though the subroutine is compiled in package C<dumpvar>, +the name of the subroutine is qualified so that its name is inserted +into package C<main>. + +Assignment to a symbol table entry performs an aliasing operation, +i.e., + + *dick = *richard; + +causes variables, subroutines and filehandles 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: + + *dick = \$richard; + +makes $richard and $dick the same variable, but leaves +@richard and @dick as separate arrays. Tricky, eh? + +=head2 Package Constructors and Destructors + +There are two special subroutine definitions that function as package +constructors and destructors. These are the C<BEGIN> and C<END> +routines. The C<sub> is optional for these routines. + +A C<BEGIN> subroutine is executed as soon as possible, that is, the +moment it is completely defined, even before the rest of the containing +file is parsed. You may have multiple C<BEGIN> blocks within a +file--they will execute in order of definition. Because a C<BEGIN> +block executes immediately, it can pull in definitions of subroutines +and such from other files in time to be visible to the rest of the +file. + +An C<END> subroutine is executed as late as possible, that is, when the +interpreter is being exited, even if it is exiting as a result of a +die() function. (But not if it's is being blown out of the water by a +signal--you have to trap that yourself (if you can).) You may have +multiple C<END> blocks within a file--they wil execute in reverse +order of definition; that is: last in, first out (LIFO). + +Note that when you use the B<-n> and B<-p> switches to Perl, C<BEGIN> +and C<END> work just as they do in B<awk>, as a degenerate case. + +=head2 Perl Classes + +There is no special class syntax in Perl 5, but a package may function +as a class if it provides subroutines that function as methods. Such a +package may also derive some of its methods from another class package +by listing the other package name in its @ISA array. For more on +this, see L<perlobj>. + +=head2 Perl Modules + +In Perl 5, the notion of packages has been extended into the notion of +modules. A module is a package that is defined in a library file of +the same name, and is designed to be reusable. It may do this by +providing a mechanism for exporting some of its symbols into the symbol +table of any package using it. Or it may function as a class +definition and make its semantics available implicitly through method +calls on the class and its objects, without explicit exportation of any +symbols. Or it can do a little of both. + +Perl modules are included by saying + + use Module; + +or + + use Module LIST; + +This is exactly equivalent to + + BEGIN { require "Module.pm"; import Module; } + +or + + BEGIN { require "Module.pm"; import Module LIST; } + +All Perl module files have the extension F<.pm>. C<use> assumes this so +that you don't have to spell out "F<Module.pm>" in quotes. This also +helps to differentiate new modules from old F<.pl> and F<.ph> files. +Module names are also capitalized unless they're functioning as pragmas, +"Pragmas" are in effect compiler directives, and are sometimes called +"pragmatic modules" (or even "pragmata" if you're a classicist). + +Because the C<use> statement implies a C<BEGIN> block, the importation +of semantics happens at the moment the C<use> statement is compiled, +before the rest of the file is compiled. This is how it is able +to function as a pragma mechanism, and also how modules are able to +declare subroutines that are then visible as list operators for +the rest of the current file. This will not work if you use C<require> +instead of C<use>. Therefore, if you're planning on the module altering +your namespace, use C<use>; otherwise, use C<require>. Otherwise you +can get into this problem: + + require Cwd; # make Cwd:: accessible + $here = Cwd::getcwd(); + + use Cwd; # import names from Cwd:: + $here = getcwd(); + + require Cwd; # make Cwd:: accessible + $here = getcwd(); # oops! no main::getcwd() + +Perl packages may be nested inside other package names, so we can have +package names containing C<::>. But if we used that package name +directly as a filename it would makes for unwieldy or impossible +filenames on some systems. Therefore, if a module's name is, say, +C<Text::Soundex>, then its definition is actually found in the library +file F<Text/Soundex.pm>. + +Perl modules always have a F<.pm> file, but there may also be dynamically +linked executables or autoloaded subroutine definitions associated with +the module. If so, these will be entirely transparent to the user of +the module. It is the responsibility of the F<.pm> file to load (or +arrange to autoload) any additional functionality. The POSIX module +happens to do both dynamic loading and autoloading, but the user can +just say C<use POSIX> to get it all. + +For more information on writing extension modules, see L<perlapi> +and L<perlguts>. + +=head1 NOTE + +Perl does not enforce private and public parts of its modules as you may +have been used to in other languages like C++, Ada, or Modula-17. Perl +doesn't have an infatuation with enforced privacy. It would prefer +that you stayed out of its living room because you weren't invited, not +because it has a shotgun. + +The module and its user have a contract, part of which is common law, +and part of which is "written". Part of the common law contract is +that a module doesn't pollute any namespace it wasn't asked to. The +written contract for the module (AKA documentation) may make other +provisions. But then you know when you C<use RedefineTheWorld> that +you're redefining the world and willing to take the consequences. + +=head1 THE PERL MODULE LIBRARY + +A number of modules are included the the Perl distribution. These are +described below, and all end in F<.pm>. You may also discover files in +the library directory that end in either F<.pl> or F<.ph>. These are old +libaries supplied so that old programs that use them still run. The +F<.pl> files will all eventually be converted into standard modules, and +the F<.ph> files made by B<h2ph> will probably end up as extension modules +made by B<h2xs>. (Some F<.ph> values may already be available through the +POSIX module.) The B<pl2pm> file in the distribution may help in your +conversion, but it's just a mechanical process, so is far from bullet proof. + +=head2 Pragmatic Modules + +They work somewhat like pragmas in that they tend to affect the compilation of +your program, and thus will usually only work well when used within a +C<use>, or C<no>. These are locally scoped, so if an inner BLOCK +may countermand any of these by saying + + no integer; + no strict 'refs'; + +which lasts until the end of that BLOCK. + +The following programs are defined (and have their own documentation). + +=over 12 + +=item C<integer> + +Perl pragma to compute arithmetic in integer instead of double + +=item C<less> + +Perl pragma to request less of something from the compiler + +=item C<sigtrap> + +Perl pragma to enable stack backtrace on unexpected signals + +=item C<strict> + +Perl pragma to restrict unsafe constructs + +=item C<subs> + +Perl pragma to predeclare sub names + +=back + +=head2 Standard Modules + +The following modules are all expacted to behave in a well-defined +manner with respect to namespace pollution because they use the +Exporter module. +See their own documentation for details. + +=over 12 + +=item C<Abbrev> + +create an abbreviation table from a list + +=item C<AnyDBM_File> + +provide framework for multiple DBMs + +=item C<AutoLoader> + +load functions only on demand + +=item C<AutoSplit> + +split a package for autoloading + +=item C<Basename> + +parse file anme and path from a specification + +=item C<Benchmark> + +benchmark running times of code + +=item C<Carp> + +warn or die of errors (from perspective of caller) + +=item C<CheckTree> + +run many filetest checks on a tree + +=item C<Collate> + +compare 8-bit scalar data according to the current locale + +=item C<Config> + +access Perl configuration option + +=item C<Cwd> + +get pathname of current working directory + +=item C<DynaLoader> + +Dynamically load C libraries into Perl code + +=item C<English> + +use nice English (or B<awk>) names for ugly punctuation variables + +=item C<Env> + +Perl module that imports environment variables + +=item C<Exporter> + +module to control namespace manipulations + +=item C<Fcntl> + +load the C Fcntl.h defines + +=item C<FileHandle> + +supply object methods for filehandles + +=item C<Find> + +traverse a file tree + +=item C<Finddepth> + +traverse a directory structure depth-first + +=item C<Getopt> + +basic and extended getopt(3) processing + +=item C<MakeMaker> + +generate a Makefile for Perl extension + +=item C<Open2> + +open a process for both reading and writing + +=item C<Open3> + +open a process for reading, writing, and error handling + +=item C<POSIX> + +Perl interface to IEEE 1003.1 namespace + +=item C<Ping> + +check a host for upness + +=item C<Socket> + +load the C socket.h defines + +=back + +=head2 Extension Modules + +Extension modules are written in C (or a mix of Perl and C) and get +dynamically loaded into Perl if and when you need them. Supported +extension modules include the Socket, Fcntl, and POSIX modules. + +The following are popular C extension modules, which while available at +Perl 5.0 release time, do not come not bundled (at least, not completely) +due to their size, volatility, or simply lack of time for adequate testing +and configuration across the multitude of platforms on which Perl was +beta-tested. You are encouraged to look for them in archie(1L), the Perl +FAQ or Meta-FAQ, the WWW page, and even their authors before randomly +posting asking for their present condition and disposition. There's no +guarantee that the names or addresses below have not changed since printing, +and in fact, they probably have! + +=over 12 + +=item C<Curses> + +Written by William Setzer <F<William_Setzer@ncsu.edu>>, while not +included with the standard distribution, this extension module ports to +most systems. FTP from your nearest Perl archive site, or try + + ftp://ftp.ncsu.edu/pub/math/wsetzer/cursperl5??.tar.gz + +It is currently in alpha test, so the name and ftp location may +change. + + +=item C<DBI> + +This is the portable database interface written by +<F<Tim.Bunce@ig.co.uk>>. This supersedes the many perl4 ports for +database extensions. The official archive for DBperl extensions is +F<ftp.demon.co.uk:/pub/perl/db>. This archive contains copies of perl4 +ports for Ingres, Oracle, Sybase, Informix, Unify, Postgres, and +Interbase, as well as rdb and shql and other non-SQL systems. + +=item C<DB_File> + +Fastest and most restriction-free of the DBM bindings, this extension module +uses the popular Berkeley DB to tie() into your hashes. This has a +standardly-distributed man page and dynamic loading extension module, but +you'll have to fetch the Berkeley code yourself. See L<DB_File> for +where. + +=item C<Sx> + +This extension module is a front to the Athena and Xlib libraries for Perl +GUI progamming, originally written by by Dominic Giampaolo +<F<dbg@sgi.com>>, then and rewritten for Sx by FrE<eacute>dE<eacute>ric +Chauveau <F<fmc@pasteur.fr>>. It's available for FTP from + + ftp.pasteur.fr:/pub/Perl/Sx.tar.gz + +=item C<Tk> + +This extension module is an object-oriented Perl5 binding to the popular +tcl/tk X11 package. However, you need know no TCL to use it! +It was written by Malcolm Beattie <F<mbeattie@sable.ox.ac.uk>>. +If you are unable to locate it using archie(1L) or a similar +tool, you may try retrieving it from F</private/Tk-october.tar.gz> +from Malcolm's machine listed above. + +=back diff --git a/pod/perlobj.pod b/pod/perlobj.pod new file mode 100644 index 0000000000..e4f34ba48d --- /dev/null +++ b/pod/perlobj.pod @@ -0,0 +1,251 @@ +=head1 NAME + +perlobj - Perl objects + +=head1 DESCRIPTION + +First of all, you need to understand what references are in Perl. See +L<perlref> for that. + +Here are three very simple definitions that you should find reassuring. + +=over 4 + +=item 1. + +An object is simply a reference that happens to know which class it +belongs to. + +=item 2. + +A class is simply a package that happens to provide methods to deal +with object references. + +=item 3. + +A method is simply a subroutine that expects an object reference (or +a package name, for static methods) as the first argument. + +=back + +We'll cover these points now in more depth. + +=head2 An Object is Simply a Reference + +Unlike say C++, Perl doesn't provide any special syntax for +constructors. A constructor is merely a subroutine that returns a +reference that has been "blessed" into a class, generally the +class that the subroutine is defined in. Here is a typical +constructor: + + package Critter; + sub new { bless {} } + +The C<{}> constructs a reference to an anonymous hash containing no +key/value pairs. The bless() takes that reference and tells the object +it references that it's now a Critter, and returns the reference. +This is for convenience, since the referenced object itself knows that +it has been blessed, and its reference to it could have been returned +directly, like this: + + sub new { + my $self = {}; + bless $self; + return $self; + } + +In fact, you often see such a thing in more complicated constructors +that wish to call methods in the class as part of the construction: + + sub new { + my $self = {} + bless $self; + $self->initialize(); + $self; + } + +Within the class package, the methods will typically deal with the +reference as an ordinary reference. Outside the class package, +the reference is generally treated as an opaque value that may +only be accessed through the class's methods. + +A constructor may rebless a referenced object currently belonging to +another class, but then the new class is responsible for all cleanup +later. The previous blessing is forgotten, as an object may only +belong to one class at a time. (Although of course it's free to +inherit methods from many classes.) + +A clarification: Perl objects are blessed. References are not. Objects +know which package they belong to. References do not. The bless() +function simply uses the reference in order to find the object. Consider +the following example: + + $a = {}; + $b = $a; + bless $a, BLAH; + print "\$b is a ", ref($b), "\n"; + +This reports $b as being a BLAH, so obviously bless() +operated on the object and not on the reference. + +=head2 A Class is Simply a Package + +Unlike say C++, Perl doesn't provide any special syntax for class +definitions. You just use a package as a class by putting method +definitions into the class. + +There is a special array within each package called @ISA which says +where else to look for a method if you can't find it in the current +package. This is how Perl implements inheritance. Each element of the +@ISA array is just the name of another package that happens to be a +class package. The classes are searched (depth first) for missing +methods in the order that they occur in @ISA. The classes accessible +through @ISA are known as base classes of the current class. + +If a missing method is found in one of the base classes, it is cached +in the current class for efficiency. Changing @ISA or defining new +subroutines invalidates the cache and causes Perl to do the lookup again. + +If a method isn't found, but an AUTOLOAD routine is found, then +that is called on behalf of the missing method. + +If neither a method nor an AUTOLOAD routine is found in @ISA, then one +last try is made for the method (or an AUTOLOAD routine) in a class +called UNIVERSAL. If that doesn't work, Perl finally gives up and +complains. + +Perl classes only do method inheritance. Data inheritance is left +up to the class itself. By and large, this is not a problem in Perl, +because most classes model the attributes of their object using +an anonymous hash, which serves as its own little namespace to be +carved up by the various classes that might want to do something +with the object. + +=head2 A Method is Simply a Subroutine + +Unlike say C++, Perl doesn't provide any special syntax for method +definition. (It does provide a little syntax for method invocation +though. More on that later.) A method expects its first argument +to be the object or package it is being invoked on. There are just two +types of methods, which we'll call static and virtual, in honor of +the two C++ method types they most closely resemble. + +A static method expects a class name as the first argument. It +provides functionality for the class as a whole, not for any individual +object belonging to the class. Constructors are typically static +methods. Many static methods simply ignore their first argument, since +they already know what package they're in, and don't care what package +they were invoked via. (These aren't necessarily the same, since +static methods follow the inheritance tree just like ordinary virtual +methods.) Another typical use for static methods is to look up an +object by name: + + sub find { + my ($class, $name) = @_; + $objtable{$name}; + } + +A virtual method expects an object reference as its first argument. +Typically it shifts the first argument into a "self" or "this" variable, +and then uses that as an ordinary reference. + + sub display { + my $self = shift; + my @keys = @_ ? @_ : sort keys %$self; + foreach $key (@keys) { + print "\t$key => $self->{$key}\n"; + } + } + +=head2 Method Invocation + +There are two ways to invoke a method, one of which you're already +familiar with, and the other of which will look familiar. Perl 4 +already had an "indirect object" syntax that you use when you say + + print STDERR "help!!!\n"; + +This same syntax can be used to call either static or virtual methods. +We'll use the two methods defined above, the static method to lookup +an object reference and the virtual method to print out its attributes. + + $fred = find Critter "Fred"; + display $fred 'Height', 'Weight'; + +These could be combined into one statement by using a BLOCK in the +indirect object slot: + + display {find Critter "Fred"} 'Height', 'Weight'; + +For C++ fans, there's also a syntax using -> notation that does exactly +the same thing. The parentheses are required if there are any arguments. + + $fred = Critter->find("Fred"); + $fred->display('Height', 'Weight'); + +or in one statement, + + Critter->find("Fred")->display('Height', 'Weight'); + +There are times when one syntax is more readable, and times when the +other syntax is more readable. The indirect object syntax is less +cluttered, but it has the same ambiguity as ordinary list operators. +Indirect object method calls are parsed using the same rule as list +operators: "If it looks like a function, it is a function". (Presuming +for the moment that you think two words in a row can look like a +function name. C++ programmers seem to think so with some regularity, +especially when the first word is "new".) Thus, the parens of + + new Critter ('Barney', 1.5, 70) + +are assumed to surround ALL the arguments of the method call, regardless +of what comes after. Saying + + new Critter ('Bam' x 2), 1.4, 45 + +would be equivalent to + + Critter->new('Bam' x 2), 1.4, 45 + +which is unlikely to do what you want. + +There are times when you wish to specify which class's method to use. +In this case, you can call your method as an ordinary subroutine +call, being sure to pass the requisite first argument explicitly: + + $fred = MyCritter::find("Critter", "Fred"); + MyCritter::display($fred, 'Height', 'Weight'); + +Note however, that this does not do any inheritance. If you merely +wish to specify that Perl should I<START> looking for a method in a +particular package, use an ordinary method call, but qualify the method +name with the package like this: + + $fred = Critter->MyCritter::find("Fred"); + $fred->MyCritter::display('Height', 'Weight'); + +=head2 Destructors + +When the last reference to an object goes away, the object is +automatically destroyed. (This may even be after you exit, if you've +stored references in global variables.) If you want to capture control +just before the object is freed, you may define a DESTROY method in +your class. It will automatically be called at the appropriate moment, +and you can do any extra cleanup you need to do. + +Perl doesn't do nested destruction for you. If your constructor +reblessed a reference from one of your base classes, your DESTROY may +need to call DESTROY for any base classes that need it. But this only +applies to reblessed objects--an object reference that is merely +I<CONTAINED> in the current object will be freed and destroyed +automatically when the current object is freed. + +=head2 Summary + +That's about all there is to it. Now you just need to go off and buy a +book about object-oriented design methodology, and bang your forehead +with it for the next six months or so. + +=head1 SEE ALSO + +You should also check out L<perlbot> for other object tricks, traps, and tips. diff --git a/pod/perlop.pod b/pod/perlop.pod new file mode 100644 index 0000000000..d33ce931c2 --- /dev/null +++ b/pod/perlop.pod @@ -0,0 +1,1062 @@ +=head1 NAME + +perlop - Perl operators and precedence + +=head1 SYNOPSIS + +Perl operators have the following associativity and precedence, +listed from highest precedence to lowest. Note that all operators +borrowed from C keep the same precedence relationship with each other, +even where C's precedence is slightly screwy. (This makes learning +Perl easier for C folks.) + + left terms and list operators (leftward) + left -> + nonassoc ++ -- + right ** + right ! ~ \ and unary + and - + left =~ !~ + left * / % x + left + - . + left << >> + nonassoc named unary operators + nonassoc < > <= >= lt gt le ge + nonassoc == != <=> eq ne cmp + left & + left | ^ + left && + left || + nonassoc .. + right ?: + right = += -= *= etc. + left , => + nonassoc list operators (rightward) + left not + left and + left or xor + +In the following sections, these operators are covered in precedence order. + +=head1 DESCRIPTIONS + +=head2 Terms and List Operators (Leftward) + +Any TERM is of highest precedence of Perl. These includes variables, +quote and quotelike operators, any expression in parentheses, +and any function whose arguments are parenthesized. Actually, there +aren't really functions in this sense, just list operators and unary +operators behaving as functions because you put parentheses around +the arguments. These are all documented in L<perlfunc>. + +If any list operator (print(), etc.) or any unary operator (chdir(), etc.) +is followed by a left parenthesis as the next token, the operator and +arguments within parentheses are taken to be of highest precedence, +just like a normal function call. + +In the absence of parentheses, the precedence of list operators such as +C<print>, C<sort>, or C<chmod> is either very high or very low depending on +whether you look at the left side of operator or the right side of it. +For example, in + + @ary = (1, 3, sort 4, 2); + print @ary; # prints 1324 + +the commas on the right of the sort are evaluated before the sort, but +the commas on the left are evaluated after. In other words, list +operators tend to gobble up all the arguments that follow them, and +then act like a simple TERM with regard to the preceding expression. +Note that you have to be careful with parens: + + # These evaluate exit before doing the print: + print($foo, exit); # Obviously not what you want. + print $foo, exit; # Nor is this. + + # These do the print before evaluating exit: + (print $foo), exit; # This is what you want. + print($foo), exit; # Or this. + print ($foo), exit; # Or even this. + +Also note that + + print ($foo & 255) + 1, "\n"; + +probably doesn't do what you expect at first glance. See +L<Named Unary Operators> for more discussion of this. + +Also parsed as terms are the C<do {}> and C<eval {}> constructs, as +well as subroutine and method calls, and the anonymous +constructors C<[]> and C<{}>. + +See also L<Quote and Quotelike Operators> toward the end of this section, +as well as L<I/O Operators>. + +=head2 The Arrow Operator + +Just as in C and C++, "C<-E<gt>>" is an infix dereference operator. If the +right side is either a C<[...]> or C<{...}> subscript, then the left side +must be either a hard or symbolic reference to an array or hash (or +a location capable of holding a hard reference, if it's an lvalue (assignable)). +See L<perlref>. + +Otherwise, the right side is a method name or a simple scalar variable +containing the method name, and the left side must either be an object +(a blessed reference) or a class name (that is, a package name). +See L<perlobj>. + +=head2 Autoincrement and Autodecrement + +"++" and "--" work as in C. That is, if placed before a variable, they +increment or decrement the variable before returning the value, and if +placed after, increment or decrement the variable after returning the value. + +The autoincrement operator has a little extra built-in magic to it. If +you increment a variable that is numeric, or that has ever been used in +a numeric context, you get a normal increment. If, however, the +variable has only been used in string contexts since it was set, and +has a value that is not null and matches the pattern +C</^[a-zA-Z]*[0-9]*$/>, the increment is done as a string, preserving each +character within its range, with carry: + + print ++($foo = '99'); # prints '100' + print ++($foo = 'a0'); # prints 'a1' + print ++($foo = 'Az'); # prints 'Ba' + print ++($foo = 'zz'); # prints 'aaa' + +The autodecrement operator is not magical. + +=head2 Exponentiation + +Binary "**" is the exponentiation operator. Note that it binds even more +tightly than unary minus, so -2**4 is -(2**4), not (-2)**4. + +=head2 Symbolic Unary Operators + +Unary "!" performs logical negation, i.e. "not". See also C<not> for a lower +precedence version of this. + +Unary "-" performs arithmetic negation if the operand is numeric. If +the operand is an identifier, a string consisting of a minus sign +concatenated with the identifier is returned. Otherwise, if the string +starts with a plus or minus, a string starting with the opposite sign +is returned. One effect of these rules is that C<-bareword> is equivalent +to C<"-bareword">. + +Unary "~" performs bitwise negation, i.e. 1's complement. + +Unary "+" has no effect whatsoever, even on strings. It is useful +syntactically for separating a function name from a parenthesized expression +that would otherwise be interpreted as the complete list of function +arguments. (See examples above under L<List Operators>.) + +Unary "\" creates a reference to whatever follows it. See L<perlref>. +Do not confuse this behavior with the behavior of backslash within a +string, although both forms do convey the notion of protecting the next +thing from interpretation. + +=head2 Binding Operators + +Binary "=~" binds an expression to a pattern match. +Certain operations search or modify the string $_ by default. This +operator makes that kind of operation work on some other string. The +right argument is a search pattern, substitution, or translation. The +left argument is what is supposed to be searched, substituted, or +translated instead of the default $_. The return value indicates the +success of the operation. (If the right argument is an expression +rather than a search pattern, substitution, or translation, it is +interpreted as a search pattern at run time. This is less efficient +than an explicit search, since the pattern must be compiled every time +the expression is evaluated--unless you've used C</o>.) + +Binary "!~" is just like "=~" except the return value is negated in +the logical sense. + +=head2 Multiplicative Operators + +Binary "*" multiplies two numbers. + +Binary "/" divides two numbers. + +Binary "%" computes the modulus of the two numbers. + +Binary "x" is the repetition operator. In a scalar context, it +returns a string consisting of the left operand repeated the number of +times specified by the right operand. In a list context, if the left +operand is a list in parens, it repeats the list. + + print '-' x 80; # print row of dashes + + print "\t" x ($tab/8), ' ' x ($tab%8); # tab over + + @ones = (1) x 80; # a list of 80 1's + @ones = (5) x @ones; # set all elements to 5 + + +=head2 Additive Operators + +Binary "+" returns the sum of two numbers. + +Binary "-" returns the difference of two numbers. + +Binary "." concatenates two strings. + +=head2 Shift Operators + +Binary "<<" returns the value of its left argument shifted left by the +number of bits specified by the right argument. Arguments should be +integers. + +Binary ">>" returns the value of its left argument shifted right by the +number of bits specified by the right argument. Arguments should be +integers. + +=head2 Named Unary Operators + +The various named unary operators are treated as functions with one +argument, with optional parentheses. These include the filetest +operators, like C<-f>, C<-M>, etc. See L<perlfunc>. + +If any list operator (print(), etc.) or any unary operator (chdir(), etc.) +is followed by a left parenthesis as the next token, the operator and +arguments within parentheses are taken to be of highest precedence, +just like a normal function call. Examples: + + chdir $foo || die; # (chdir $foo) || die + chdir($foo) || die; # (chdir $foo) || die + chdir ($foo) || die; # (chdir $foo) || die + chdir +($foo) || die; # (chdir $foo) || die + +but, because * is higher precedence than ||: + + chdir $foo * 20; # chdir ($foo * 20) + chdir($foo) * 20; # (chdir $foo) * 20 + chdir ($foo) * 20; # (chdir $foo) * 20 + chdir +($foo) * 20; # chdir ($foo * 20) + + rand 10 * 20; # rand (10 * 20) + rand(10) * 20; # (rand 10) * 20 + rand (10) * 20; # (rand 10) * 20 + rand +(10) * 20; # rand (10 * 20) + +See also L<"List Operators">. + +=head2 Relational Operators + +Binary "<" returns true if the left argument is numerically less than +the right argument. + +Binary ">" returns true if the left argument is numerically greater +than the right argument. + +Binary "<=" returns true if the left argument is numerically less than +or equal to the right argument. + +Binary ">=" returns true if the left argument is numerically greater +than or equal to the right argument. + +Binary "lt" returns true if the left argument is stringwise less than +the right argument. + +Binary "gt" returns true if the left argument is stringwise greater +than the right argument. + +Binary "le" returns true if the left argument is stringwise less than +or equal to the right argument. + +Binary "ge" returns true if the left argument is stringwise greater +than or equal to the right argument. + +=head2 Equality Operators + +Binary "==" returns true if the left argument is numerically equal to +the right argument. + +Binary "!=" returns true if the left argument is numerically not equal +to the right argument. + +Binary "<=>" returns -1, 0, or 1 depending on whether the left argument is numerically +less than, equal to, or greater than the right argument. + +Binary "eq" returns true if the left argument is stringwise equal to +the right argument. + +Binary "ne" returns true if the left argument is stringwise not equal +to the right argument. + +Binary "cmp" returns -1, 0, or 1 depending on whether the left argument is stringwise +less than, equal to, or greater than the right argument. + +=head2 Bitwise And + +Binary "&" returns its operators ANDed together bit by bit. + +=head2 Bitwise Or and Exclusive Or + +Binary "|" returns its operators ORed together bit by bit. + +Binary "^" returns its operators XORed together bit by bit. + +=head2 C-style Logical And + +Binary "&&" performs a short-circuit logical AND operation. That is, +if the left operand is false, the right operand is not even evaluated. +Scalar or list context propagates down to the right operand if it +is evaluated. + +=head2 C-style Logical Or + +Binary "||" performs a short-circuit logical OR operation. That is, +if the left operand is true, the right operand is not even evaluated. +Scalar or list context propagates down to the right operand if it +is evaluated. + +The C<||> and C<&&> operators differ from C's in that, rather than returning +0 or 1, they return the last value evaluated. Thus, a reasonably portable +way to find out the home directory (assuming it's not "0") might be: + + $home = $ENV{'HOME'} || $ENV{'LOGDIR'} || + (getpwuid($<))[7] || die "You're homeless!\n"; + +As more readable alternatives to C<&&> and C<||>, Perl provides "and" and +"or" operators (see below). The short-circuit behavior is identical. The +precedence of "and" and "or" is much lower, however, so that you can +safely use them after a list operator without the need for +parentheses: + + unlink "alpha", "beta", "gamma" + or gripe(), next LINE; + +With the C-style operators that would have been written like this: + + unlink("alpha", "beta", "gamma") + || (gripe(), next LINE); + +=head2 Range Operator + +Binary ".." is the range operator, which is really two different +operators depending on the context. In a list context, it returns an +array of values counting (by ones) from the left value to the right +value. This is useful for writing C<for (1..10)> loops and for doing +slice operations on arrays. Be aware that under the current implementation, +a temporary array is created, so you'll burn a lot of memory if you +write something like this: + + for (1 .. 1_000_000) { + # code + } + +In a scalar context, ".." returns a boolean value. The operator is +bistable, like a flip-flop, and emulates the line-range (comma) operator +of B<sed>, B<awk>, and various editors. Each ".." operator maintains its +own boolean state. It is false as long as its left operand is false. +Once the left operand is true, the range operator stays true until the +right operand is true, I<AFTER> which the range operator becomes false +again. (It doesn't become false till the next time the range operator is +evaluated. It can test the right operand and become false on the same +evaluation it became true (as in B<awk>), but it still returns true once. +If you don't want it to test the right operand till the next evaluation +(as in B<sed>), use three dots ("...") instead of two.) The right +operand is not evaluated while the operator is in the "false" state, and +the left operand is not evaluated while the operator is in the "true" +state. The precedence is a little lower than || and &&. The value +returned is either the null string for false, or a sequence number +(beginning with 1) for true. The sequence number is reset for each range +encountered. The final sequence number in a range has the string "E0" +appended to it, which doesn't affect its numeric value, but gives you +something to search for if you want to exclude the endpoint. You can +exclude the beginning point by waiting for the sequence number to be +greater than 1. If either operand of scalar ".." is a numeric literal, +that operand is implicitly compared to the C<$.> variable, the current +line number. Examples: + +As a scalar operator: + + if (101 .. 200) { print; } # print 2nd hundred lines + next line if (1 .. /^$/); # skip header lines + s/^/> / if (/^$/ .. eof()); # quote body + +As a list operator: + + for (101 .. 200) { print; } # print $_ 100 times + @foo = @foo[$[ .. $#foo]; # an expensive no-op + @foo = @foo[$#foo-4 .. $#foo]; # slice last 5 items + +The range operator (in a list context) makes use of the magical +autoincrement algorithm if the operaands are strings. You +can say + + @alphabet = ('A' .. 'Z'); + +to get all the letters of the alphabet, or + + $hexdigit = (0 .. 9, 'a' .. 'f')[$num & 15]; + +to get a hexadecimal digit, or + + @z2 = ('01' .. '31'); print $z2[$mday]; + +to get dates with leading zeros. If the final value specified is not +in the sequence that the magical increment would produce, the sequence +goes until the next value would be longer than the final value +specified. + +=head2 Conditional Operator + +Ternary "?:" is the conditional operator, just as in C. It works much +like an if-then-else. If the argument before the ? is true, the +argument before the : is returned, otherwise the argument after the : +is returned. Scalar or list context propagates downward into the 2nd +or 3rd argument, whichever is selected. The operator may be assigned +to if both the 2nd and 3rd arguments are legal lvalues (meaning that you +can assign to them): + + ($a_or_b ? $a : $b) = $c; + +Note that this is not guaranteed to contribute to the readability of +your program. + +=head2 Assigment Operators + +"=" is the ordinary assignment operator. + +Assignment operators work as in C. That is, + + $a += 2; + +is equivalent to + + $a = $a + 2; + +although without duplicating any side effects that dereferencing the lvalue +might trigger, such as from tie(). Other assignment operators work similarly. +The following are recognized: + + **= += *= &= <<= &&= + -= /= |= >>= ||= + .= %= ^= + x= + +Note that while these are grouped by family, they all have the precedence +of assignment. + +Unlike in C, the assignment operator produces a valid lvalue. Modifying +an assignment is equivalent to doing the assignment and then modifying +the variable that was assigned to. This is useful for modifying +a copy of something, like this: + + ($tmp = $global) =~ tr [A-Z] [a-z]; + +Likewise, + + ($a += 2) *= 3; + +is equivalent to + + $a += 2; + $a *= 3; + +=head2 + +Binary "," is the comma operator. In a scalar context it evaluates +its left argument, throws that value away, then evaluates its right +argument and returns that value. This is just like C's comma operator. + +In a list context, it's just the list argument separator, and inserts +both its arguments into the list. + +=head2 List Operators (Rightward) + +On the right side of a list operator, it has very low precedence, +such that it controls all comma-separated expressions found there. +The only operators with lower precedence are the logical operators +"and", "or", and "not", which may be used to evaluate calls to list +operators without the need for extra parentheses: + + open HANDLE, "filename" + or die "Can't open: $!\n"; + +See also discussion of list operators in L<List Operators (Leftward)>. + +=head2 Logical Not + +Unary "not" returns the logical negation of the expression to its right. +It's the equivalent of "!" except for the very low precedence. + +=head2 Logical And + +Binary "and" returns the logical conjunction of the two surrounding +expressions. It's equivalent to && except for the very low +precedence. This means that it short-circuits: i.e. the right +expression is evaluated only if the left expression is true. + +=head2 Logical or and Exclusive Or + +Binary "or" returns the logical disjunction of the two surrounding +expressions. It's equivalent to || except for the very low +precedence. This means that it short-circuits: i.e. the right +expression is evaluated only if the left expression is false. + +Binary "xor" returns the exclusive-OR of the two surrounding expressions. +It cannot short circuit, of course. + +=head2 C Operators Missing From Perl + +Here is what C has that Perl doesn't: + +=over 8 + +=item unary & + +Address-of operator. (But see the "\" operator for taking a reference.) + +=item unary * + +Dereference-address operator. (Perl's prefix dereferencing +operators are typed: $, @, %, and &.) + +=item (TYPE) + +Type casting operator. + +=back + +=head2 Quote and Quotelike Operators + +While we usually think of quotes as literal values, in Perl they +function as operators, providing various kinds of interpolating and +pattern matching capabilities. Perl provides customary quote characters +for these behaviors, but also provides a way for you to choose your +quote character for any of them. In the following table, a C<{}> represents +any pair of delimiters you choose. Non-bracketing delimiters use +the same character fore and aft, but the 4 sorts of brackets +(round, angle, square, curly) will all nest. + + Customary Generic Meaning Interpolates + '' q{} Literal no + "" qq{} Literal yes + `` qx{} Command yes + qw{} Word list no + // m{} Pattern match yes + s{}{} Substitution yes + tr{}{} Translation no + +For constructs that do interpolation, variables beginning with "C<$> or "C<@>" +are interpolated, as are the following sequences: + + \t tab + \n newline + \r return + \f form feed + \v vertical tab, whatever that is + \b backspace + \a alarm (bell) + \e escape + \033 octal char + \x1b hex char + \c[ control char + \l lowercase next char + \u uppercase next char + \L lowercase till \E + \U uppercase till \E + \E end case modification + \Q quote regexp metacharacters till \E + +Patterns are subject to an additional level of interpretation as a +regular expression. This is done as a second pass, after variables are +interpolated, so that regular expressions may be incorporated into the +pattern from the variables. If this is not what you want, use C<\Q> to +interpolate a variable literally. + +Apart from the above, there are no multiple levels of interpolation. In +particular, contrary to the expectations of shell programmers, backquotes +do I<NOT> interpolate within double quotes, nor do single quotes impede +evaluation of variables when used within double quotes. + +=over 8 + +=item ?PATTERN? + +This is just like the C</pattern/> search, except that it matches only +once between calls to the reset() operator. This is a useful +optimization when you only want to see the first occurrence of +something in each file of a set of files, for instance. Only C<??> +patterns local to the current package are reset. + +This usage is vaguely deprecated, and may be removed in some future +version of Perl. + +=item m/PATTERN/gimosx + +=item /PATTERN/gimosx + +Searches a string for a pattern match, and in a scalar context returns +true (1) or false (''). If no string is specified via the C<=~> or +C<!~> operator, the $_ string is searched. (The string specified with +C<=~> need not be an lvalue--it may be the result of an expression +evaluation, but remember the C<=~> binds rather tightly.) See also +L<perlre>. + +Options are: + + g Match globally, i.e. find all occurrences. + i Do case-insensitive pattern matching. + m Treat string as multiple lines. + o Only compile pattern once. + s Treat string as single line. + x Use extended regular expressions. + +If "/" is the delimiter then the initial C<m> is optional. With the C<m> +you can use any pair of non-alphanumeric, non-whitespace characters as +delimiters. This is particularly useful for matching Unix path names +that contain "/", to avoid LTS (leaning toothpick syndrome). + +PATTERN may contain variables, which will be interpolated (and the +pattern recompiled) every time the pattern search is evaluated. (Note +that C<$)> and C<$|> might not be interpolated because they look like +end-of-string tests.) If you want such a pattern to be compiled only +once, add a C</o> after the trailing delimiter. This avoids expensive +run-time recompilations, and is useful when the value you are +interpolating won't change over the life of the script. However, mentioning +C</o> constitutes a promise that you won't change the variables in the pattern. +If you change them, Perl won't even notice. + +If the PATTERN evaluates to a null string, the most recently executed +(and successfully compiled) regular expression is used instead. + +If used in a context that requires a list value, a pattern match returns a +list consisting of the subexpressions matched by the parentheses in the +pattern, i.e. ($1, $2, $3...). (Note that here $1 etc. are also set, and +that this differs from Perl 4's behavior.) If the match fails, a null +array is returned. If the match succeeds, but there were no parentheses, +a list value of (1) is returned. + +Examples: + + open(TTY, '/dev/tty'); + <TTY> =~ /^y/i && foo(); # do foo if desired + + if (/Version: *([0-9.]*)/) { $version = $1; } + + next if m#^/usr/spool/uucp#; + + # poor man's grep + $arg = shift; + while (<>) { + print if /$arg/o; # compile only once + } + + if (($F1, $F2, $Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) + +This last example splits $foo into the first two words and the +remainder of the line, and assigns those three fields to $F1, $F2 and +$Etc. The conditional is true if any variables were assigned, i.e. if +the pattern matched. + +The C</g> modifier specifies global pattern matching--that is, matching +as many times as possible within the string. How it behaves depends on +the context. In a list context, it returns a list of all the +substrings matched by all the parentheses in the regular expression. +If there are no parentheses, it returns a list of all the matched +strings, as if there were parentheses around the whole pattern. + +In a scalar context, C<m//g> iterates through the string, returning TRUE +each time it matches, and FALSE when it eventually runs out of +matches. (In other words, it remembers where it left off last time and +restarts the search at that point. You can actually find the current +match position of a string using the pos() function--see L<perlfunc>.) +If you modify the string in any way, the match position is reset to the +beginning. Examples: + + # list context + ($one,$five,$fifteen) = (`uptime` =~ /(\d+\.\d+)/g); + + # scalar context + $/ = ""; $* = 1; # $* deprecated in Perl 5 + while ($paragraph = <>) { + while ($paragraph =~ /[a-z]['")]*[.!?]+['")]*\s/g) { + $sentences++; + } + } + print "$sentences\n"; + +=item q/STRING/ + +=item C<'STRING'> + +A single-quoted, literal string. Backslashes are ignored, unless +followed by the delimiter or another backslash, in which case the +delimiter or backslash is interpolated. + + $foo = q!I said, "You said, 'She said it.'"!; + $bar = q('This is it.'); + +=item qq/STRING/ + +=item "STRING" + +A double-quoted, interpolated string. + + $_ .= qq + (*** The previous line contains the naughty word "$1".\n) + if /(tcl|rexx|python)/; # :-) + +=item qx/STRING/ + +=item `STRING` + +A string which is interpolated and then executed as a system command. +The collected standard output of the command is returned. In scalar +context, it comes back as a single (potentially multi-line) string. +In list context, returns a list of lines (however you've defined lines +with $/ or $INPUT_RECORD_SEPARATOR). + + $today = qx{ date }; + +See L<I/O Operators> for more discussion. + +=item qw/STRING/ + +Returns a list of the words extracted out of STRING, using embedded +whitespace as the word delimiters. It is exactly equivalent to + + split(' ', q/STRING/); + +Some frequently seen examples: + + use POSIX qw( setlocale localeconv ) + @EXPORT = qw( foo bar baz ); + +=item s/PATTERN/REPLACEMENT/egimosx + +Searches a string for a pattern, and if found, replaces that pattern +with the replacement text and returns the number of substitutions +made. Otherwise it returns false (0). + +If no string is specified via the C<=~> or C<!~> operator, the C<$_> +variable is searched and modified. (The string specified with C<=~> must +be a scalar variable, an array element, a hash element, or an assignment +to one of those, i.e. an lvalue.) + +If the delimiter chosen is single quote, no variable interpolation is +done on either the PATTERN or the REPLACEMENT. Otherwise, if the +PATTERN contains a $ that looks like a variable rather than an +end-of-string test, the variable will be interpolated into the pattern +at run-time. If you only want the pattern compiled once the first time +the variable is interpolated, use the C</o> option. If the pattern +evaluates to a null string, the most recently executed (and successfully compiled) regular +expression is used instead. See L<perlre> for further explanation on these. + +Options are: + + e Evaluate the right side as an expression. + g Replace globally, i.e. all occurrences. + i Do case-insensitive pattern matching. + m Treat string as multiple lines. + o Only compile pattern once. + s Treat string as single line. + x Use extended regular expressions. + +Any non-alphanumeric, non-whitespace delimiter may replace the +slashes. If single quotes are used, no interpretation is done on the +replacement string (the C</e> modifier overrides this, however). If +backquotes are used, the replacement string is a command to execute +whose output will be used as the actual replacement text. If the +PATTERN is delimited by bracketing quotes, the REPLACEMENT has its own +pair of quotes, which may or may not be bracketing quotes, e.g. +C<s(foo)(bar)> or C<sE<lt>fooE<gt>/bar/>. A C</e> will cause the +replacement portion to be interpreter as a full-fledged Perl expression +and eval()ed right then and there. It is, however, syntax checked at +compile-time. + +Examples: + + s/\bgreen\b/mauve/g; # don't change wintergreen + + $path =~ s|/usr/bin|/usr/local/bin|; + + s/Login: $foo/Login: $bar/; # run-time pattern + + ($foo = $bar) =~ s/this/that/; + + $count = ($paragraph =~ s/Mister\b/Mr./g); + + $_ = 'abc123xyz'; + s/\d+/$&*2/e; # yields 'abc246xyz' + s/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz' + s/\w/$& x 2/eg; # yields 'aabbcc 224466xxyyzz' + + s/%(.)/$percent{$1}/g; # change percent escapes; no /e + s/%(.)/$percent{$1} || $&/ge; # expr now, so /e + s/^=(\w+)/&pod($1)/ge; # use function call + + # /e's can even nest; this will expand + # simple embedded variables in $_ + s/(\$\w+)/$1/eeg; + + # Delete C comments. + $program =~ s { + /\* (?# Match the opening delimiter.) + .*? (?# Match a minimal number of characters.) + \*/ (?# Match the closing delimiter.) + } []gsx; + + s/^\s*(.*?)\s*$/$1/; # trim white space + + s/([^ ]*) *([^ ]*)/$2 $1/; # reverse 1st two fields + +Note the use of $ instead of \ in the last example. Unlike +B<sed>, we only use the \<I<digit>> form in the left hand side. +Anywhere else it's $<I<digit>>. + +Occasionally, you can't just use a C</g> to get all the changes +to occur. Here are two common cases: + + # put commas in the right places in an integer + 1 while s/(.*\d)(\d\d\d)/$1,$2/g; # perl4 + 1 while s/(\d)(\d\d\d)(?!\d)/$1,$2/g; # perl5 + + # expand tabs to 8-column spacing + 1 while s/\t+/' ' x (length($&)*8 - length($`)%8)/e; + + +=item tr/SEARCHLIST/REPLACEMENTLIST/cds + +=item y/SEARCHLIST/REPLACEMENTLIST/cds + +Translates all occurrences of the characters found in the search list +with the corresponding character in the replacement list. It returns +the number of characters replaced or deleted. If no string is +specified via the =~ or !~ operator, the $_ string is translated. (The +string specified with =~ must be a scalar variable, an array element, +or an assignment to one of those, i.e. an lvalue.) For B<sed> devotees, +C<y> is provided as a synonym for C<tr>. If the SEARCHLIST is +delimited by bracketing quotes, the REPLACEMENTLIST has its own pair of +quotes, which may or may not be bracketing quotes, e.g. C<tr[A-Z][a-z]> +or C<tr(+-*/)/ABCD/>. + +Options: + + c Complement the SEARCHLIST. + d Delete found but unreplaced characters. + s Squash duplicate replaced characters. + +If the C</c> modifier is specified, the SEARCHLIST character set is +complemented. If the C</d> modifier is specified, any characters specified +by SEARCHLIST not found in REPLACEMENTLIST are deleted. (Note +that this is slightly more flexible than the behavior of some B<tr> +programs, which delete anything they find in the SEARCHLIST, period.) +If the C</s> modifier is specified, sequences of characters that were +translated to the same character are squashed down to a single instance of the +character. + +If the C</d> modifier is used, the REPLACEMENTLIST is always interpreted +exactly as specified. Otherwise, if the REPLACEMENTLIST is shorter +than the SEARCHLIST, the final character is replicated till it is long +enough. If the REPLACEMENTLIST is null, the SEARCHLIST is replicated. +This latter is useful for counting characters in a class or for +squashing character sequences in a class. + +Examples: + + $ARGV[1] =~ tr/A-Z/a-z/; # canonicalize to lower case + + $cnt = tr/*/*/; # count the stars in $_ + + $cnt = $sky =~ tr/*/*/; # count the stars in $sky + + $cnt = tr/0-9//; # count the digits in $_ + + tr/a-zA-Z//s; # bookkeeper -> bokeper + + ($HOST = $host) =~ tr/a-z/A-Z/; + + tr/a-zA-Z/ /cs; # change non-alphas to single space + + tr [\200-\377] + [\000-\177]; # delete 8th bit + +Note that because the translation table is built at compile time, neither +the SEARCHLIST nor the REPLACEMENTLIST are subjected to double quote +interpolation. That means that if you want to use variables, you must use +an eval(): + + eval "tr/$oldlist/$newlist/"; + die $@ if $@; + + eval "tr/$oldlist/$newlist/, 1" or die $@; + +=back + +=head2 I/O Operators + +There are several I/O operators you should know about. +A string is enclosed by backticks (grave accents) first undergoes +variable substitution just like a double quoted string. It is then +interpreted as a command, and the output of that command is the value +of the pseudo-literal, like in a shell. In a scalar context, a single +string consisting of all the output is returned. In a list context, +a list of values is returned, one for each line of output. (You can +set C<$/> to use a different line terminator.) The command is executed +each time the pseudo-literal is evaluated. The status value of the +command is returned in C<$?> (see L<perlvar> for the interpretation +of C<$?>). Unlike in B<csh>, no translation is done on the return +data--newlines remain newlines. Unlike in any of the shells, single +quotes do not hide variable names in the command from interpretation. +To pass a $ through to the shell you need to hide it with a backslash. +The generalized form of backticks is C<qx//>. + +Evaluating a filehandle in angle brackets yields the next line from +that file (newline included, so it's never false until end of file, at which +time an undefined value is returned). Ordinarily you must assign that +value to a variable, but there is one situation where an automatic +assignment happens. I<If and ONLY if> the input symbol is the only +thing inside the conditional of a C<while> loop, the value is +automatically assigned to the variable C<$_>. (This may seem like an +odd thing to you, but you'll use the construct in almost every Perl +script you write.) Anyway, the following lines are equivalent to each +other: + + while ($_ = <STDIN>) { print; } + while (<STDIN>) { print; } + for (;<STDIN>;) { print; } + print while $_ = <STDIN>; + print while <STDIN>; + +The filehandles STDIN, STDOUT and STDERR are predefined. (The +filehandles C<stdin>, C<stdout> and C<stderr> will also work except in +packages, where they would be interpreted as local identifiers rather +than global.) Additional filehandles may be created with the open() +function. + +If a <FILEHANDLE> is used in a context that is looking for a list, a +list consisting of all the input lines is returned, one line per list +element. It's easy to make a I<LARGE> data space this way, so use with +care. + +The null filehandle <> is special and can be used to emulate the +behavior of B<sed> and B<awk>. Input from <> comes either from +standard input, or from each file listed on the command line. Here's +how it works: the first time <> is evaluated, the @ARGV array is +checked, and if it is null, C<$ARGV[0]> is set to "-", which when opened +gives you standard input. The @ARGV array is then processed as a list +of filenames. The loop + + while (<>) { + ... # code for each line + } + +is equivalent to the following Perl-like pseudo code: + + unshift(@ARGV, '-') if $#ARGV < $[; + while ($ARGV = shift) { + open(ARGV, $ARGV); + while (<ARGV>) { + ... # code for each line + } + } + +except that it isn't so cumbersome to say, and will actually work. It +really does shift array @ARGV and put the current filename into variable +$ARGV. It also uses filehandle I<ARGV> internally--<> is just a synonym +for <ARGV>, which is magical. (The pseudo code above doesn't work +because it treats <ARGV> as non-magical.) + +You can modify @ARGV before the first <> as long as the array ends up +containing the list of filenames you really want. Line numbers (C<$.>) +continue as if the input were one big happy file. (But see example +under eof() for how to reset line numbers on each file.) + +If you want to set @ARGV to your own list of files, go right ahead. If +you want to pass switches into your script, you can use one of the +Getopts modules or put a loop on the front like this: + + while ($_ = $ARGV[0], /^-/) { + shift; + last if /^--$/; + if (/^-D(.*)/) { $debug = $1 } + if (/^-v/) { $verbose++ } + ... # other switches + } + while (<>) { + ... # code for each line + } + +The <> symbol will return FALSE only once. If you call it again after +this it will assume you are processing another @ARGV list, and if you +haven't set @ARGV, will input from STDIN. + +If the string inside the angle brackets is a reference to a scalar +variable (e.g. <$foo>), then that variable contains the name of the +filehandle to input from. + +If the string inside angle brackets is not a filehandle, it is +interpreted as a filename pattern to be globbed, and either a list of +filenames or the next filename in the list is returned, depending on +context. One level of $ interpretation is done first, but you can't +say C<E<lt>$fooE<gt>> because that's an indirect filehandle as explained in the +previous paragraph. You could insert curly brackets to force +interpretation as a filename glob: C<E<lt>${foo}E<gt>>. (Alternately, you can +call the internal function directly as C<glob($foo)>, which is probably +the right way to have done it in the first place.) Example: + + while (<*.c>) { + chmod 0644, $_; + } + +is equivalent to + + open(FOO, "echo *.c | tr -s ' \t\r\f' '\\012\\012\\012\\012'|"); + while (<FOO>) { + chop; + chmod 0644, $_; + } + +In fact, it's currently implemented that way. (Which means it will not +work on filenames with spaces in them unless you have csh(1) on your +machine.) Of course, the shortest way to do the above is: + + chmod 0644, <*.c>; + +Because globbing invokes a shell, it's often faster to call readdir() yourself +and just do your own grep() on the filenames. Furthermore, due to its current +implementation of using a shell, the glob() routine may get "Arg list too +long" errors (unless you've installed tcsh(1L) as F</bin/csh>). + +=head2 Constant Folding + +Like C, Perl does a certain amount of expression evaluation at +compile time, whenever it determines that all of the arguments to an +operator are static and have no side effects. In particular, string +concatenation happens at compile time between literals that don't do +variable substitution. Backslash interpretation also happens at +compile time. You can say + + 'Now is the time for all' . "\n" . + 'good men to come to.' + +and this all reduces to one string internally. Likewise, if +you say + + foreach $file (@filenames) { + if (-s $file > 5 + 100 * 2**16) { ... } + } + +the compiler will pre-compute the number that +expression represents so that the interpreter +won't have to. + + +=head2 Integer arithmetic + +By default Perl assumes that it must do most of its arithmetic in +floating point. But by saying + + use integer; + +you may tell the compiler that it's okay to use integer operations +from here to the end of the enclosing BLOCK. An inner BLOCK may +countermand this by saying + + no integer; + +which lasts until the end of that BLOCK. + diff --git a/pod/perlovl.pod b/pod/perlovl.pod new file mode 100644 index 0000000000..db00f4dbf1 --- /dev/null +++ b/pod/perlovl.pod @@ -0,0 +1,363 @@ +=head1 NAME + +perlovl - perl overloading semantics + +=head1 SYNOPSIS + + package SomeThing; + + %OVERLOAD = ( + '+' => \&myadd, + '-' => \&mysub, + # etc + ); + ... + + package main; + $a = new SomeThing 57; + $b=5+$a; + +=head1 CAVEAT SCRIPTOR + +Overloading of operators is a subject not to be taken lightly. +Neither its precise implementation, syntax, nor semantics are +100% endorsed by Larry Wall. So any of these may be changed +at some point in the future. + +=head1 DESCRIPTION + +=head2 Declaration of overloaded functions + + package Number; + %OVERLOAD = ( + "+" => \&add, + "*=" => "muas" + ); + +declares function Number::add() for addition, and method muas() in +the "class" C<Number> (or one of its base classes) +for the assignment form C<*=> of multiplication. Legal values of this +hash array are values legal inside C<&{ ... }> call, so the name of a +subroutine, a reference to a subroutine, or an anonymous subroutine +will all work. + +The subroutine C<$OVERLOAD{"+"}> will be called to execute C<$a+$b> if $a +is a reference to an object blessed into the package C<Number>, or $a is +not an object from a package with defined mathemagic addition, but $b is a +reference to a C<Number>. It can be called also in other situations, like +C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical +methods refer to methods triggered by an overloaded mathematical +operator.) + +=head2 Calling Conventions for Binary Operations + +The functions in C<values %OVERLOAD> are called with three (in one +particular case with four, see L<Last Resort>) arguments. If the +corresponding operation is binary, then the first two arguments are the +two arguments of the operation. However, due to general object calling +conventions, the first argument should be always an object in the package, +so in the situation of C<7+$a>, the order of arguments is interchanged. +Most probably it does not matter for implementation of the addition +method, but whether the arguments are reversed is vital for the +subtraction method. The subroutine can query this information by +examining the third argument, which can take three different values: + +=over 7 + +=item FALSE + +the order of arguments is as in the current operation. + +=item TRUE + +the arguments are reversed. + +=item C<undef> + +the current operation is an assignment variant (as in +C<$a+=7>), but the usual function is called instead. This additional +information can be used to generate some optimizations. + +=back + +=head2 Calling Conventions for Unary Operations + +Unary operation are considered binary operations with the second +argument being C<undef>. Thus C<$OVERLOAD{"++"}> is called with +arguments C<($a,undef,'')> when $a++ is executed. + +=head2 Overloadable Operations + +The following keys of %OVERLOAD are recognized: + +=over 5 + +=item * I<Arithmetic operations> + + "+", "+=", "-", "-=", "*", "*=", "/", "/=", "%", "%=", + "**", "**=", "<<", "<<=", ">>", ">>=", "x", "x=", ".", ".=", + +For these operations a substituted non-assignment variant can be called if +the assignment variant is not available. Methods for operations "C<+>", +"C<->", "C<+=>", and "C<-=>" can be called to automatically generate +increment and decrement methods. The operations "C<->" can be used to +autogenerate missing methods for unary minus or C<abs>. + +=item * I<Comparison operations> + + "<", "<=", ">", ">=", "==", "!=", "<=>", + "lt", "le", "gt", "ge", "eq", "ne", "cmp", + +If the corresponding "spaceship" variant is available, it can be +used to substitute for the missing operation. During C<sort>ing +arrays, C<cmp> is used to compare values subject to %OVERLOAD. + +=item * I<Bit operations> + + "&", "^", "|", "neg", "!", "~", + +"C<neg>" stands for unary minus. If the method for C<neg> is not +specified, it can be autogenerated using on the method for subtraction. + +=item * I<Increment and decrement> + + "++", "--", + +If undefined, addition and subtraction methods can be +used instead. These operations are called both in prefix and +postfix form. + +=item * I<Transcendental functions> + + "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", + +If C<abs> is unavailable, it can be autogenerated using methods +for "<" or "<=>" combined with either unary minus or subtraction. + +=item * I<Boolean, string and numeric conversion> + + "bool", "\"\"", "0+", + +If one or two of these operations are unavailable, the remaining ones can +be used instead. C<bool> is used in the flow control operators +(like C<while>) and for the ternary "C<?:>" operation. These functions can +return any arbitrary Perl value. If the corresponding operation for this value +is overloaded too, that operation will be called again with this value. + +=item * I<Special> + + "nomethod", "fallback", "=", + +see L<SPECIAL KEYS OF %OVERLOAD>. + +=back + +See L<"Fallback"> for an explanation of when a missing method can be autogenerated. + +=head1 SPECIAL KEYS OF %OVERLOAD + +Three keys are recognized by Perl that are not covered by the above +description. + +=head2 Last Resort + +C<$OVERLOAD{"nomethod"}> is a reference to a function of four parameters. +If defined, it is called when the overloading mechanism cannot find a +method for some operation. The first three arguments of this function +coincide with arguments for the corresponding method if it were found, the +fourth argument is the key of %OVERLOAD corresponding to the missing +method. If several methods are tried, the last one is used. Say, C<1-$a> +can be equivalent to + + &{ $Pack::OVERLOAD{"nomethod"} }($a,1,1,"-"). + +If some operation cannot be resolved, and there is no +C<$OVERLOAD{"nomethod"}>, then an exception will be raised +via die() -- unless C<$OVERLOAD{"fallback"}> is true. + +=head2 Fallback + +C<$OVERLOAD{"fallback"}> governs what to do if a method for a particular +operation is not found. Three different cases are possible depending on +value of C<$OVERLOAD{"fallback"}>: + +=over 16 + +=item * C<undef> + +Perl tries to use a +substituted method (see L<MAGIC AUTOGENERATION>). If this fails, it +then tries to calls C<$OVERLOAD{"nomethod"}>; if missing, an exception +will be raised. + +=item * TRUE + +The same as for the C<undef> value, but no exception is raised. Instead, +it silently reverts to what it would have done were there no %OVERLOAD is +present. + +=item * defined, but FALSE + +No autogeneration is tried. Perl tries to call +C<$OVERLOAD{"nomethod"}>, and if this is missing, raises an exception. + +=back + +=head2 Copy Constructor + +C<$OVERLOAD{"="}> is a reference to a function with three arguments, +i.e., it looks like a usual value of %OVERLOAD. What is special about +this subroutine is that it should not return a blessed reference into +a package (as most other methods are expected to), but rather a freshly made +copy of its dereferenced argument (see L<"BUGS">, though). This operation +is called in the situations when a mutator is applied to a reference +that shares its object with some other reference, such as + + $a=$b; + $a++; + +To make this change to $a and not to change $b, a freshly made copy of +C<$$a> is made, and $a is assigned a reference to this object. This +operation is executed during C<$a++>, (so before this C<$$a> coincides +with C<$$b>), and only if C<++> is expressed via C<$OPERATOR{'++'}> or +C<$OPERATOR{'+='}>. Note that if this operation is expressed via 'C<+>', +i.e., as + + $a=$b; + $a=$a+1; + +then C<$$a> and C<$$b> do not appear as lvalues. + +If the copy constructor is required during execution of some mutator, but +C<$OPERATOR{'='}> is missing, it can be autogenerated as a string +copy if an object of +the package is a plain scalar. + +=head1 MAGIC AUTOGENERATION + +If a method for an operation is not found, and C<$OVERLOAD{"fallback"}> is +TRUE or undefined, Perl tries to to autogenerate a substitute method for +the missing operation based on defined operations. Autogenerated method +substitutions are possible for the following operations: + +=over 16 + +=item I<Assignment forms of arithmetic operations> + +C<$a=+$b> can use the C<$OVERLOAD{"+"}> method if C<$OVERLOAD{"+="}> +is not defined. + +=item I<Conversion operations> + +String, numeric, and boolean conversion are calculated in terms of one +another if not all of them are defined. + +=item I<Increment and decrement> + +The C<++$a> operation can be expressed in terms of C<$a+=1> or C<$a+1>, +and C<$a--> in terms of C<$a-=1> and C<$a-1>. + +=item C<abs($a)> + +can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>). + +=item I<Unary minus> + +can be expressed in terms of subtraction. + +=item I<Concatenation> + +can be expressed in terms of string conversion. + +=item I<Comparison operations> + +can be expressed in terms of its "spaceship" counterpart: either +C<E<lt>=E<gt>> or C<cmp>: + + <, >, <=, >=, ==, != in terms of <=> + lt, gt, le, ge, eq, ne in terms of cmp + +=item I<Copy operator> + +can be expressed in terms of assignment to the dereferenced value, if this +value is scalar but not a reference. + +=back + +=head1 WARNING + +The restriction for the comparison operation is that even if, for example, +`C<cmp>' should return a blessed reference, the autogenerated `C<lt>' +function will produce only a standard logical value based on the +numerical value of the result of `C<cmp>'. In particular, a working +numeric conversion is needed in this case (possibly expressed in terms of +other conversions). + +Similarly, C<.=> and C<x=> operators lose their mathemagical properties +if the string conversion substitution is applied. + +When you chop() a mathemagical object, it becomes promoted to a string +first, and its mathemagical qualities is lost. The same can happen with other +operations as well. + +=head1 IMPLEMENTATION + +The table of methods for all operations is cached as a magic for the +symbol table hash of the package. It is rechecked for changes of +%OVERLOAD and @ISA only during C<bless>ing; so if it is changed +dynamically, you'll need an additional fake C<bless>ing to update the +table. + +(Every SVish thing has a magic queue, and a magic is an entry in that queue. +This is how a single variable may participate in multiple forms of magic +simultaneously. For instance, environment variables regularly have two +forms at once: their %ENV magic and their taint magic.) + +If an object belongs to a package with %OVERLOAD, it carries a special +flag. Thus the only speed penalty during arithmetic operations without +overload is the check of this flag. + +In fact, if no %OVERLOAD is ever accessed, there is almost no overhead for +overloadable operations, so most programs should not suffer measurable +performance penalties. Considerable effort was made minimize overhead +when %OVERLOAD is accessed and the current operation is overloadable but +the arguments in question do not belong to packages with %OVERLOAD. When +in doubt, test your speed with %OVERLOAD and without it. So far there +have been no reports of substantial speed degradation if Perl is compiled +with optimization turned on. + +There is no size penalty for data if there is no %OVERLOAD. + +The copying like C<$a=$b> is shallow; however, a one-level-deep +copying is +carried out before any operation that can imply an assignment to the +object $b (or $a) refers to, like C<$b++>. You can override this +behavior by defining your copy constructor (see L<"Copy Constructor">). + +It is expected that arguments to methods that are not explicitly supposed +to be changed are constant (but this is not enforced). + +=head1 AUTHOR + +Ilya Zakharevich <F<ilya@math.mps.ohio-state.edu>>. + +=head1 DIAGNOSTICS + +When Perl is run with the B<-Do> switch or its equivalent, overloading +induces diagnostic messages. + +=head1 BUGS + +Because it's used for overloading, the per-package associative array +%OVERLOAD now has a special meaning in Perl. + +Although the copy constructor is specially designed to make overloading +operations with references to an array simpler, as it now works it's +useless for this because a subroutine cannot return an array in the same +way as it returns a scalar (from the point of view of Perl +internals). Expect a change of interface for the copy constructor. + +As shipped, %OVERLOAD is not inherited via the @ISA tree. A patch for +this is available from the author. + +This document is confusing. diff --git a/pod/perlpod.pod b/pod/perlpod.pod new file mode 100644 index 0000000000..46693f1793 --- /dev/null +++ b/pod/perlpod.pod @@ -0,0 +1,81 @@ +=head1 NAME + +pod - plain old documentation + +=head1 DESCRIPTION + +A pod-to-whatever translator reads a pod file paragraph by paragraph, +and translates it to the appropriate output format. There are +three kinds of paragraphs: + +=over 4 + +=item * + +A verbatim paragraph, distinguished by being indented (that is, +it starts with space or tab). It should be reproduced exactly, +with tabs assumed to be on 8-column boundaries. There are no +special formatting escapes, so you can't italicize or anything +like that. A \ means \, and nothing else. + +=item * + +A command. All command paragraphs start with "=", followed by an +identifier, followed by arbitrary text that the command can +use however it pleases. Currently recognized commands are + + =head1 heading + =head2 heading + =item text + =over N + =back + +=item * + +An ordinary block of text. It will be filled, and maybe even +justified. Certain interior sequences are recognized both +here and in commands: + + I<text> italicize text, used for emphasis or variables + B<text> embolden text, used for switches and programs + S<text> text contains non-breaking spaces + C<code> literal code + L<name> A link (cross reference) to name + L<name> manpage + L<name/ident> item in manpage + L<name/"sec"> section in other manpage + L<"sec"> section in this manpage + (the quotes are optional) + F<file> Used for filenames + Z<> A zero-width character + +That's it. The intent is simplicity, not power. I wanted paragraphs +to look like paragraphs (block format), so that they stand out +visually, and so that I could run them through fmt easily to reformat +them (that's F7 in my version of B<vi>). I wanted the translator (and not +me) to worry about whether " or ' is a left quote or a right quote +within filled text, and I wanted it to leave the quotes alone dammit in +verbatim mode, so I could slurp in a working program, shift it over 4 +spaces, and have it print out, er, verbatim. And presumably in a +constant width font. + +In particular, you can leave things like this verbatim in your text: + + Perl + FILEHANDLE + $variable + function() + manpage(3r) + +Doubtless a few other commands or sequences will need to be added along +the way, but I've gotten along surprisingly well with just these. + +Note that I'm not at all claiming this to be sufficient for producing a +book. I'm just trying to make an idiot-proof common source for nroff, +TeX, and other markup languages, as used for online documentation. +Both B<pod2html> and B<pod2man> translators exist. + +=head1 Author + +Larry Wall + diff --git a/pod/perlre.pod b/pod/perlre.pod new file mode 100644 index 0000000000..1324642f71 --- /dev/null +++ b/pod/perlre.pod @@ -0,0 +1,315 @@ +=head1 NAME + +perlre - Perl regular expressions + +=head1 DESCRIPTION + +For a description of how to use regular expressions in matching +operations, see C<m//> and C<s///> in L<perlop>. The matching operations can +have various modifiers, some of which relate to the interpretation of +the regular expression inside. These are: + + i Do case-insensitive pattern matching. + m Treat string as multiple lines. + s Treat string as single line. + x Use extended regular expressions. + +These are usually written as "the C</x> modifier", even though the delimiter +in question might not actually be a slash. In fact, any of these +modifiers may also be embedded within the regular expression itself using +the new C<(?...)> construct. See below. + +The C</x> modifier itself needs a little more explanation. It tells the +regular expression parser to ignore whitespace that is not backslashed +or within a character class. You can use this to break up your regular +expression into (slightly) more readable parts. Together with the +capability of embedding comments described later, this goes a long +way towards making Perl 5 a readable language. See the C comment +deletion code in L<perlop>. + +=head2 Regular Expressions + +The patterns used in pattern matching are regular expressions such as +those supplied in the Version 8 regexp routines. (In fact, the +routines are derived (distantly) from Henry Spencer's freely +redistributable reimplementation of the V8 routines.) +See L<Version 8 Regular Expressions> for details. + +In particular the following metacharacters have their standard I<egrep>-ish +meanings: + + \ Quote the next metacharacter + ^ Match the beginning of the line + . Match any character (except newline) + $ Match the end of the line + | Alternation + () Grouping + [] Character class + +By default, the "^" character is guaranteed to match only at the +beginning of the string, the "$" character only at the end (or before the +newline at the end) and Perl does certain optimizations with the +assumption that the string contains only one line. Embedded newlines +will not be matched by "^" or "$". You may, however, wish to treat a +string as a multi-line buffer, such that the "^" will match after any +newline within the string, and "$" will match before any newline. At the +cost of a little more overhead, you can do this by using the /m modifier +on the pattern match operator. (Older programs did this by setting C<$*>, +but this practice is deprecated in Perl 5.) + +To facilitate multi-line substitutions, the "." character never matches a +newline unless you use the C</s> modifier, which tells Perl to pretend +the string is a single line--even if it isn't. The C</s> modifier also +overrides the setting of C<$*>, in case you have some (badly behaved) older +code that sets it in another module. + +The following standard quantifiers are recognized: + + * Match 0 or more times + + Match 1 or more times + ? Match 1 or 0 times + {n} Match exactly n times + {n,} Match at least n times + {n,m} Match at least n but not more than m times + +(If a curly bracket occurs in any other context, it is treated +as a regular character.) The "*" modifier is equivalent to C<{0,}>, the "+" +modifier to C<{1,}>, and the "?" modifier to C<{0,1}>. There is no limit to the +size of n or m, but large numbers will chew up more memory. + +By default, a quantified subpattern is "greedy", that is, it will match as +many times as possible without causing the rest pattern not to match. The +standard quantifiers are all "greedy", in that they match as many +occurrences as possible (given a particular starting location) without +causing the pattern to fail. If you want it to match the minimum number +of times possible, follow the quantifier with a "?" after any of them. +Note that the meanings don't change, just the "gravity": + + *? Match 0 or more times + +? Match 1 or more times + ?? Match 0 or 1 time + {n}? Match exactly n times + {n,}? Match at least n times + {n,m}? Match at least n but not more than m times + +Since patterns are processed as double quoted strings, the following +also work: + + \t tab + \n newline + \r return + \f form feed + \v vertical tab, whatever that is + \a alarm (bell) + \e escape + \033 octal char + \x1b hex char + \c[ control char + \l lowercase next char + \u uppercase next char + \L lowercase till \E + \U uppercase till \E + \E end case modification + \Q quote regexp metacharacters till \E + +In addition, Perl defines the following: + + \w Match a "word" character (alphanumeric plus "_") + \W Match a non-word character + \s Match a whitespace character + \S Match a non-whitespace character + \d Match a digit character + \D Match a non-digit character + +Note that C<\w> matches a single alphanumeric character, not a whole +word. To match a word you'd need to say C<\w+>. You may use C<\w>, C<\W>, C<\s>, +C<\S>, C<\d> and C<\D> within character classes (though not as either end of a +range). + +Perl defines the following zero-width assertions: + + \b Match a word boundary + \B Match a non-(word boundary) + \A Match only at beginning of string + \Z Match only at end of string + \G Match only where previous m//g left off + +A word boundary (C<\b>) is defined as a spot between two characters that +has a C<\w> on one side of it and and a C<\W> on the other side of it (in +either order), counting the imaginary characters off the beginning and +end of the string as matching a C<\W>. (Within character classes C<\b> +represents backspace rather than a word boundary.) The C<\A> and C<\Z> are +just like "^" and "$" except that they won't match multiple times when the +C</m> modifier is used, while "^" and "$" will match at every internal line +boundary. + +When the bracketing construct C<( ... )> is used, \<digit> matches the +digit'th substring. (Outside of the pattern, always use "$" instead of +"\" in front of the digit. The scope of $<digit> (and C<$`>, C<$&>, and C<$')> +extends to the end of the enclosing BLOCK or eval string, or to the +next pattern match with subexpressions. +If you want to +use parentheses to delimit subpattern (e.g. a set of alternatives) without +saving it as a subpattern, follow the ( with a ?. +The \<digit> notation +sometimes works outside the current pattern, but should not be relied +upon.) You may have as many parentheses as you wish. If you have more +than 9 substrings, the variables $10, $11, ... refer to the +corresponding substring. Within the pattern, \10, \11, etc. refer back +to substrings if there have been at least that many left parens before +the backreference. Otherwise (for backward compatibilty) \10 is the +same as \010, a backspace, and \11 the same as \011, a tab. And so +on. (\1 through \9 are always backreferences.) + +C<$+> returns whatever the last bracket match matched. C<$&> returns the +entire matched string. ($0 used to return the same thing, but not any +more.) C<$`> returns everything before the matched string. C<$'> returns +everything after the matched string. Examples: + + s/^([^ ]*) *([^ ]*)/$2 $1/; # swap first two words + + if (/Time: (..):(..):(..)/) { + $hours = $1; + $minutes = $2; + $seconds = $3; + } + +You will note that all backslashed metacharacters in Perl are +alphanumeric, such as C<\b>, C<\w>, C<\n>. Unlike some other regular expression +languages, there are no backslashed symbols that aren't alphanumeric. +So anything that looks like \\, \(, \), \<, \>, \{, or \} is always +interpreted as a literal character, not a metacharacter. This makes it +simple to quote a string that you want to use for a pattern but that +you are afraid might contain metacharacters. Simply quote all the +non-alphanumeric characters: + + $pattern =~ s/(\W)/\\$1/g; + +You can also use the built-in quotemeta() function to do this. +An even easier way to quote metacharacters right in the match operator +is to say + + /$unquoted\Q$quoted\E$unquoted/ + +Perl 5 defines a consistent extension syntax for regular expressions. +The syntax is a pair of parens with a question mark as the first thing +within the parens (this was a syntax error in Perl 4). The character +after the question mark gives the function of the extension. Several +extensions are already supported: + +=over 10 + +=item (?#text) + +A comment. The text is ignored. + +=item (?:regexp) + +This groups things like "()" but doesn't make backrefences like "()" does. So + + split(/\b(?:a|b|c)\b/) + +is like + + split(/\b(a|b|c)\b/) + +but doesn't spit out extra fields. + +=item (?=regexp) + +A zero-width positive lookahead assertion. For example, C</\w+(?=\t)/> +matches a word followed by a tab, without including the tab in C<$&>. + +=item (?!regexp) + +A zero-width negative lookahead assertion. For example C</foo(?!bar)/> +matches any occurrence of "foo" that isn't followed by "bar". Note +however that lookahead and lookbehind are NOT the same thing. You cannot +use this for lookbehind: C</(?!foo)bar/> will not find an occurrence of +"bar" that is preceded by something which is not "foo". That's because +the C<(?!foo)> is just saying that the next thing cannot be "foo"--and +it's not, it's a "bar", so "foobar" will match. You would have to do +something like C</(?foo)...bar/> for that. We say "like" because there's +the case of your "bar" not having three characters before it. You could +cover that this way: C</(?:(?!foo)...|^..?)bar/>. Sometimes it's still +easier just to say: + + if (/foo/ && $` =~ /bar$/) + + +=item (?imsx) + +One or more embedded pattern-match modifiers. This is particularly +useful for patterns that are specified in a table somewhere, some of +which want to be case sensitive, and some of which don't. The case +insensitive ones merely need to include C<(?i)> at the front of the +pattern. For example: + + $pattern = "foobar"; + if ( /$pattern/i ) + + # more flexible: + + $pattern = "(?i)foobar"; + if ( /$pattern/ ) + +=back + +The specific choice of question mark for this and the new minimal +matching construct was because 1) question mark is pretty rare in older +regular expressions, and 2) whenever you see one, you should stop +and "question" exactly what is going on. That's psychology... + +=head2 Version 8 Regular Expressions + +In case you're not familiar with the "regular" Version 8 regexp +routines, here are the pattern-matching rules not described above. + +Any single character matches itself, unless it is a I<metacharacter> +with a special meaning described here or above. You can cause +characters which normally function as metacharacters to be interpreted +literally by prefixing them with a "\" (e.g. "\." matches a ".", not any +character; "\\" matches a "\"). A series of characters matches that +series of characters in the target string, so the pattern C<blurfl> +would match "blurfl" in the target string. + +You can specify a character class, by enclosing a list of characters +in C<[]>, which will match any one of the characters in the list. If the +first character after the "[" is "^", the class matches any character not +in the list. Within a list, the "-" character is used to specify a +range, so that C<a-z> represents all the characters between "a" and "z", +inclusive. + +Characters may be specified using a metacharacter syntax much like that +used in C: "\n" matches a newline, "\t" a tab, "\r" a carriage return, +"\f" a form feed, etc. More generally, \I<nnn>, where I<nnn> is a string +of octal digits, matches the character whose ASCII value is I<nnn>. +Similarly, \xI<nn>, where I<nn> are hexidecimal digits, matches the +character whose ASCII value is I<nn>. The expression \cI<x> matches the +ASCII character control-I<x>. Finally, the "." metacharacter matches any +character except "\n" (unless you use C</s>). + +You can specify a series of alternatives for a pattern using "|" to +separate them, so that C<fee|fie|foe> will match any of "fee", "fie", +or "foe" in the target string (as would C<f(e|i|o)e>). Note that the +first alternative includes everything from the last pattern delimiter +("(", "[", or the beginning of the pattern) up to the first "|", and +the last alternative contains everything from the last "|" to the next +pattern delimiter. For this reason, it's common practice to include +alternatives in parentheses, to minimize confusion about where they +start and end. Note also that the pattern C<(fee|fie|foe)> differs +from the pattern C<[fee|fie|foe]> in that the former matches "fee", +"fie", or "foe" in the target string, while the latter matches +anything matched by the classes C<[fee]>, C<[fie]>, or C<[foe]> (i.e. +the class C<[feio]>). + +Within a pattern, you may designate subpatterns for later reference by +enclosing them in parentheses, and you may refer back to the I<n>th +subpattern later in the pattern using the metacharacter \I<n>. +Subpatterns are numbered based on the left to right order of their +opening parenthesis. Note that a backreference matches whatever +actually matched the subpattern in the string being examined, not the +rules for that subpattern. Therefore, C<([0|0x])\d*\s\1\d*> will +match "0x1234 0x4321",but not "0x1234 01234", since subpattern 1 +actually matched "0x", even though the rule C<[0|0x]> could +potentially match the leading 0 in the second number. diff --git a/pod/perlref.pod b/pod/perlref.pod new file mode 100644 index 0000000000..0ad25dfe66 --- /dev/null +++ b/pod/perlref.pod @@ -0,0 +1,332 @@ +=head1 NAME + +perlref - Perl references and nested data structures + +=head1 DESCRIPTION + +In Perl 4 it was difficult to represent complex data structures, because +all references had to be symbolic, and even that was difficult to do when +you wanted to refer to a variable rather than a symbol table entry. Perl +5 not only makes it easier to use symbolic references to variables, but +lets you have "hard" references to any piece of data. Any scalar may hold +a hard reference. Since arrays and hashes contain scalars, you can now +easily build arrays of arrays, arrays of hashes, hashes of arrays, arrays +of hashes of functions, and so on. + +Hard references are smart--they keep track of reference counts for you, +automatically freeing the thing referred to when its reference count +goes to zero. If that thing happens to be an object, the object is +destructed. See L<perlobj> for more about objects. (In a sense, +everything in Perl is an object, but we usually reserve the word for +references to objects that have been officially "blessed" into a class package.) + +A symbolic reference contains the name of a variable, just as a +symbolic link in the filesystem merely contains the name of a file. +The C<*glob> notation is a kind of symbolic reference. Hard references +are more like hard links in the file system: merely another way +at getting at the same underlying object, irrespective of its name. + +"Hard" references are easy to use in Perl. There is just one +overriding principle: Perl does no implicit referencing or +dereferencing. When a scalar is holding a reference, it always behaves +as a scalar. It doesn't magically start being an array or a hash +unless you tell it so explicitly by dereferencing it. + +References can be constructed several ways. + +=over 4 + +=item 1. + +By using the backslash operator on a variable, subroutine, or value. +(This works much like the & (address-of) operator works in C.) Note +that this typically creates I<ANOTHER> reference to a variable, since +there's already a reference to the variable in the symbol table. But +the symbol table reference might go away, and you'll still have the +reference that the backslash returned. Here are some examples: + + $scalarref = \$foo; + $arrayref = \@ARGV; + $hashref = \%ENV; + $coderef = \&handler; + +=item 2. + +A reference to an anonymous array can be constructed using square +brackets: + + $arrayref = [1, 2, ['a', 'b', 'c']]; + +Here we've constructed a reference to an anonymous array of three elements +whose final element is itself reference to another anonymous array of three +elements. (The multidimensional syntax described later can be used to +access this. For example, after the above, $arrayref->[2][1] would have +the value "b".) + +=item 3. + +A reference to an anonymous hash can be constructed using curly +brackets: + + $hashref = { + 'Adam' => 'Eve', + 'Clyde' => 'Bonnie', + }; + +Anonymous hash and array constructors can be intermixed freely to +produce as complicated a structure as you want. The multidimensional +syntax described below works for these too. The values above are +literals, but variables and expressions would work just as well, because +assignment operators in Perl (even within local() or my()) are executable +statements, not compile-time declarations. + +Because curly brackets (braces) are used for several other things +including BLOCKs, you may occasionally have to disambiguate braces at the +beginning of a statement by putting a C<+> or a C<return> in front so +that Perl realizes the opening brace isn't starting a BLOCK. The economy and +mnemonic value of using curlies is deemed worth this occasional extra +hassle. + +For example, if you wanted a function to make a new hash and return a +reference to it, you have these options: + + sub hashem { { @_ } } # silently wrong + sub hashem { +{ @_ } } # ok + sub hashem { return { @_ } } # ok + +=item 4. + +A reference to an anonymous subroutine can be constructed by using +C<sub> without a subname: + + $coderef = sub { print "Boink!\n" }; + +Note the presence of the semicolon. Except for the fact that the code +inside isn't executed immediately, a C<sub {}> is not so much a +declaration as it is an operator, like C<do{}> or C<eval{}>. (However, no +matter how many times you execute that line (unless you're in an +C<eval("...")>), C<$coderef> will still have a reference to the I<SAME> +anonymous subroutine.) + +For those who worry about these things, the current implementation +uses shallow binding of local() variables; my() variables are not +accessible. This precludes true closures. However, you can work +around this with a run-time (rather than a compile-time) eval(): + + { + my $x = time; + $coderef = eval "sub { \$x }"; + } + +Normally--if you'd used just C<sub{}> or even C<eval{}>--your unew sub +would only have been able to access the global $x. But because you've +used a run-time eval(), this will not only generate a brand new subroutine +reference each time called, it will all grant access to the my() variable +lexically above it rather than the global one. The particular $x +accessed will be different for each new sub you create. This mechanism +yields deep binding of variables. (If you don't know what closures, deep +binding, or shallow binding are, don't worry too much about it.) + +=item 5. + +References are often returned by special subroutines called constructors. +Perl objects are just reference a special kind of object that happens to know +which package it's associated with. Constructors are just special +subroutines that know how to create that association. They do so by +starting with an ordinary reference, and it remains an ordinary reference +even while it's also being an object. Constructors are customarily +named new(), but don't have to be: + + $objref = new Doggie (Tail => 'short', Ears => 'long'); + +=item 6. + +References of the appropriate type can spring into existence if you +dereference them in a context that assumes they exist. Since we haven't +talked about dereferencing yet, we can't show you any examples yet. + +=back + +That's it for creating references. By now you're probably dying to +know how to use references to get back to your long-lost data. There +are several basic methods. + +=over 4 + +=item 1. + +Anywhere you'd put an identifier as part of a variable or subroutine +name, you can replace the identifier with a simple scalar variable +containing a reference of the correct type: + + $bar = $$scalarref; + push(@$arrayref, $filename); + $$arrayref[0] = "January"; + $$hashref{"KEY"} = "VALUE"; + &$coderef(1,2,3); + +It's important to understand that we are specifically I<NOT> dereferencing +C<$arrayref[0]> or C<$hashref{"KEY"}> there. The dereference of the +scalar variable happens I<BEFORE> it does any key lookups. Anything more +complicated than a simple scalar variable must use methods 2 or 3 below. +However, a "simple scalar" includes an identifier that itself uses method +1 recursively. Therefore, the following prints "howdy". + + $refrefref = \\\"howdy"; + print $$$$refrefref; + +=item 2. + +Anywhere you'd put an identifier as part of a variable or subroutine +name, you can replace the identifier with a BLOCK returning a reference +of the correct type. In other words, the previous examples could be +written like this: + + $bar = ${$scalarref}; + push(@{$arrayref}, $filename); + ${$arrayref}[0] = "January"; + ${$hashref}{"KEY"} = "VALUE"; + &{$coderef}(1,2,3); + +Admittedly, it's a little silly to use the curlies in this case, but +the BLOCK can contain any arbitrary expression, in particular, +subscripted expressions: + + &{ $dispatch{$index} }(1,2,3); # call correct routine + +Because of being able to omit the curlies for the simple case of C<$$x>, +people often make the mistake of viewing the dereferencing symbols as +proper operators, and wonder about their precedence. If they were, +though, you could use parens instead of braces. That's not the case. +Consider the difference below; case 0 is a short-hand version of case 1, +I<NOT> case 2: + + $$hashref{"KEY"} = "VALUE"; # CASE 0 + ${$hashref}{"KEY"} = "VALUE"; # CASE 1 + ${$hashref{"KEY"}} = "VALUE"; # CASE 2 + ${$hashref->{"KEY"}} = "VALUE"; # CASE 3 + +Case 2 is also deceptive in that you're accessing a variable +called %hashref, not dereferencing through $hashref to the hash +it's presumably referencing. That would be case 3. + +=item 3. + +The case of individual array elements arises often enough that it gets +cumbersome to use method 2. As a form of syntactic sugar, the two +lines like that above can be written: + + $arrayref->[0] = "January"; + $hashref->{"KEY} = "VALUE"; + +The left side of the array can be any expression returning a reference, +including a previous dereference. Note that C<$array[$x]> is I<NOT> the +same thing as C<$array-E<gt>[$x]> here: + + $array[$x]->{"foo"}->[0] = "January"; + +This is one of the cases we mentioned earlier in which references could +spring into existence when in an lvalue context. Before this +statement, C<$array[$x]> may have been undefined. If so, it's +automatically defined with a hash reference so that we can look up +C<{"foo"}> in it. Likewise C<$array[$x]-E<gt>{"foo"}> will automatically get +defined with an array reference so that we can look up C<[0]> in it. + +One more thing here. The arrow is optional I<BETWEEN> brackets +subscripts, so you can shrink the above down to + + $array[$x]{"foo"}[0] = "January"; + +Which, in the degenerate case of using only ordinary arrays, gives you +multidimensional arrays just like C's: + + $score[$x][$y][$z] += 42; + +Well, okay, not entirely like C's arrays, actually. C doesn't know how +to grow its arrays on demand. Perl does. + +=item 4. + +If a reference happens to be a reference to an object, then there are +probably methods to access the things referred to, and you should probably +stick to those methods unless you're in the class package that defines the +object's methods. In other words, be nice, and don't violate the object's +encapsulation without a very good reason. Perl does not enforce +encapsulation. We are not totalitarians here. We do expect some basic +civility though. + +=back + +The ref() operator may be used to determine what type of thing the +reference is pointing to. See L<perlfunc>. + +The bless() operator may be used to associate a reference with a package +functioning as an object class. See L<perlobj>. + +A type glob may be dereferenced the same way a reference can, since +the dereference syntax always indicates the kind of reference desired. +So C<${*foo}> and C<${\$foo}> both indicate the same scalar variable. + +Here's a trick for interpolating a subroutine call into a string: + + print "My sub returned ${\mysub(1,2,3)}\n"; + +The way it works is that when the C<${...}> is seen in the double-quoted +string, it's evaluated as a block. The block executes the call to +C<mysub(1,2,3)>, and then takes a reference to that. So the whole block +returns a reference to a scalar, which is then dereferenced by C<${...}> +and stuck into the double-quoted string. + +=head2 Symbolic references + +We said that references spring into existence as necessary if they are +undefined, but we didn't say what happens if a value used as a +reference is already defined, but I<ISN'T> a hard reference. If you +use it as a reference in this case, it'll be treated as a symbolic +reference. That is, the value of the scalar is taken to be the I<NAME> +of a variable, rather than a direct link to a (possibly) anonymous +value. + +People frequently expect it to work like this. So it does. + + $name = "foo"; + $$name = 1; # Sets $foo + ${$name} = 2; # Sets $foo + ${$name x 2} = 3; # Sets $foofoo + $name->[0] = 4; # Sets $foo[0] + @$name = (); # Clears @foo + &$name(); # Calls &foo() (as in Perl 4) + $pack = "THAT"; + ${"${pack}::$name"} = 5; # Sets $THAT::foo without eval + +This is very powerful, and slightly dangerous, in that it's possible +to intend (with the utmost sincerity) to use a hard reference, and +accidentally use a symbolic reference instead. To protect against +that, you can say + + use strict 'refs'; + +and then only hard references will be allowed for the rest of the enclosing +block. An inner block may countermand that with + + no strict 'refs'; + +Only package variables are visible to symbolic references. Lexical +variables (declared with my()) aren't in a symbol table, and thus are +invisible to this mechanism. For example: + + local($value) = 10; + $ref = \$value; + { + my $value = 20; + print $$ref; + } + +This will still print 10, not 20. Remember that local() affects package +variables, which are all "global" to the package. + +=head2 Further Reading + +Besides the obvious documents, source code can be instructive. +Some rather pathological examples of the use of references can be found +in the F<t/op/ref.t> regression test in the Perl source directory. diff --git a/pod/perlrun.pod b/pod/perlrun.pod new file mode 100644 index 0000000000..5179abccd4 --- /dev/null +++ b/pod/perlrun.pod @@ -0,0 +1,382 @@ +=head1 NAME + +perlrun - how to execute the Perl interpreter + +=head1 SYNOPSIS + +B<perl> [switches] filename args + +=head1 DESCRIPTION + +Upon startup, Perl looks for your script in one of the following +places: + +=over 4 + +=item 1. + +Specified line by line via B<-e> switches on the command line. + +=item 2. + +Contained in the file specified by the first filename on the command line. +(Note that systems supporting the #! notation invoke interpreters this way.) + +=item 3. + +Passed in implicitly via standard input. This only works if there are +no filename arguments--to pass arguments to a STDIN script you +must explicitly specify a "-" for the script name. + +=back + +With methods 2 and 3, Perl starts parsing the input file from the +beginning, unless you've specified a B<-x> switch, in which case it +scans for the first line starting with #! and containing the word +"perl", and starts there instead. This is useful for running a script +embedded in a larger message. (In this case you would indicate the end +of the script using the __END__ token.) + +As of Perl 5, the #! line is always examined for switches as the line is +being parsed. Thus, if you're on a machine that only allows one argument +with the #! line, or worse, doesn't even recognize the #! line, you still +can get consistent switch behavior regardless of how Perl was invoked, +even if B<-x> was used to find the beginning of the script. + +Because many operating systems silently chop off kernel interpretation of +the #! line after 32 characters, some switches may be passed in on the +command line, and some may not; you could even get a "-" without its +letter, if you're not careful. You probably want to make sure that all +your switches fall either before or after that 32 character boundary. +Most switches don't actually care if they're processed redundantly, but +getting a - instead of a complete switch could cause Perl to try to +execute standard input instead of your script. And a partial B<-I> switch +could also cause odd results. + +Parsing of the #! switches starts wherever "perl" is mentioned in the line. +The sequences "-*" and "- " are specifically ignored so that you could, +if you were so inclined, say + + #!/bin/sh -- # -*- perl -*- -p + eval 'exec perl $0 -S ${1+"$@"}' + if 0; + +to let Perl see the B<-p> switch. + +If the #! line does not contain the word "perl", the program named after +the #! is executed instead of the Perl interpreter. This is slightly +bizarre, but it helps people on machines that don't do #!, because they +can tell a program that their SHELL is /usr/bin/perl, and Perl will then +dispatch the program to the correct interpreter for them. + +After locating your script, Perl compiles the entire script to an +internal form. If there are any compilation errors, execution of the +script is not attempted. (This is unlike the typical shell script, +which might run partway through before finding a syntax error.) + +If the script is syntactically correct, it is executed. If the script +runs off the end without hitting an exit() or die() operator, an implicit +C<exit(0)> is provided to indicate successful completion. + +=head2 Switches + +A single-character switch may be combined with the following switch, if +any. + + #!/usr/bin/perl -spi.bak # same as -s -p -i.bak + +Switches include: + +=over 5 + +=item B<-0>I<digits> + +specifies the record separator (C<$/>) as an octal number. If there are +no digits, the null character is the separator. Other switches may +precede or follow the digits. For example, if you have a version of +B<find> which can print filenames terminated by the null character, you +can say this: + + find . -name '*.bak' -print0 | perl -n0e unlink + +The special value 00 will cause Perl to slurp files in paragraph mode. +The value 0777 will cause Perl to slurp files whole since there is no +legal character with that value. + +=item B<-a> + +turns on autosplit mode when used with a B<-n> or B<-p>. An implicit +split command to the @F array is done as the first thing inside the +implicit while loop produced by the B<-n> or B<-p>. + + perl -ane 'print pop(@F), "\n";' + +is equivalent to + + while (<>) { + @F = split(' '); + print pop(@F), "\n"; + } + +An alternate delimiter may be specified using B<-F>. + +=item B<-c> + +causes Perl to check the syntax of the script and then exit without +executing it. + +=item B<-d> + +runs the script under the Perl debugger. See L<perldebug>. + +=item B<-D>I<number> + +=item B<-D>I<list> + +sets debugging flags. To watch how it executes your script, use +B<-D14>. (This only works if debugging is compiled into your +Perl.) Another nice value is B<-D1024>, which lists your compiled +syntax tree. And B<-D512> displays compiled regular expressions. As an +alternative specify a list of letters instead of numbers (e.g. B<-D14> is +equivalent to B<-Dtls>): + + 1 p Tokenizing and Parsing + 2 s Stack Snapshots + 4 l Label Stack Processing + 8 t Trace Execution + 16 o Operator Node Construction + 32 c String/Numeric Conversions + 64 P Print Preprocessor Command for -P + 128 m Memory Allocation + 256 f Format Processing + 512 r Regular Expression Parsing + 1024 x Syntax Tree Dump + 2048 u Tainting Checks + 4096 L Memory Leaks (not supported anymore) + 8192 H Hash Dump -- usurps values() + 16384 X Scratchpad Allocation + 32768 D Cleaning Up + +=item B<-e> I<commandline> + +may be used to enter one line of script. +If B<-e> is given, Perl +will not look for a script filename in the argument list. +Multiple B<-e> commands may +be given to build up a multi-line script. +Make sure to use semicolons where you would in a normal program. + +=item B<-F>I<regexp> + +specifies a regular expression to split on if B<-a> is also in effect. +If regexp has C<//> around it, the slashes will be ignored. + +=item B<-i>I<extension> + +specifies that files processed by the C<E<lt>E<gt>> construct are to be edited +in-place. It does this by renaming the input file, opening the output +file by the original name, and selecting that output file as the default +for print() statements. The extension, if supplied, is added to the name +of the old file to make a backup copy. If no extension is supplied, no +backup is made. From the shell, saying + + $ perl -p -i.bak -e "s/foo/bar/; ... " + +is the same as using the script: + + #!/usr/bin/perl -pi.bak + s/foo/bar/; + +which is equivalent to + + #!/usr/bin/perl + while (<>) { + if ($ARGV ne $oldargv) { + rename($ARGV, $ARGV . '.bak'); + open(ARGVOUT, ">$ARGV"); + select(ARGVOUT); + $oldargv = $ARGV; + } + s/foo/bar/; + } + continue { + print; # this prints to original filename + } + select(STDOUT); + +except that the B<-i> form doesn't need to compare $ARGV to $oldargv to +know when the filename has changed. It does, however, use ARGVOUT for +the selected filehandle. Note that STDOUT is restored as the +default output filehandle after the loop. + +You can use C<eof> without parenthesis to locate the end of each input file, +in case you want to append to each file, or reset line numbering (see +example in L<perlfunc/eof>). + +=item B<-I>I<directory> + +may be used in conjunction with B<-P> to tell the C preprocessor where +to look for include files. By default /usr/include and /usr/lib/perl +are searched. + +=item B<-l>I<octnum> + +enables automatic line-ending processing. It has two effects: first, +it automatically chomps the line terminator when used with B<-n> or +B<-p>, and second, it assigns "C<$\>" to have the value of I<octnum> so that +any print statements will have that line terminator added back on. If +I<octnum> is omitted, sets "C<$\>" to the current value of "C<$/>". For +instance, to trim lines to 80 columns: + + perl -lpe 'substr($_, 80) = ""' + +Note that the assignment C<$\ = $/> is done when the switch is processed, +so the input record separator can be different than the output record +separator if the B<-l> switch is followed by a B<-0> switch: + + gnufind / -print0 | perl -ln0e 'print "found $_" if -p' + +This sets $\ to newline and then sets $/ to the null character. + +=item B<-n> + +causes Perl to assume the following loop around your script, which +makes it iterate over filename arguments somewhat like B<sed -n> or +B<awk>: + + while (<>) { + ... # your script goes here + } + +Note that the lines are not printed by default. See B<-p> to have +lines printed. Here is an efficient way to delete all files older than +a week: + + find . -mtime +7 -print | perl -nle 'unlink;' + +This is faster than using the C<-exec> switch of B<find> because you don't +have to start a process on every filename found. + +C<BEGIN> and C<END> blocks may be used to capture control before or after +the implicit loop, just as in B<awk>. + +=item B<-p> + +causes Perl to assume the following loop around your script, which +makes it iterate over filename arguments somewhat like B<sed>: + + + while (<>) { + ... # your script goes here + } continue { + print; + } + +Note that the lines are printed automatically. To suppress printing +use the B<-n> switch. A B<-p> overrides a B<-n> switch. + +C<BEGIN> and C<END> blocks may be used to capture control before or after +the implicit loop, just as in awk. + +=item B<-P> + +causes your script to be run through the C preprocessor before +compilation by Perl. (Since both comments and cpp directives begin +with the # character, you should avoid starting comments with any words +recognized by the C preprocessor such as "if", "else" or "define".) + +=item B<-s> + +enables some rudimentary switch parsing for switches on the command +line after the script name but before any filename arguments (or before +a B<-->). Any switch found there is removed from @ARGV and sets the +corresponding variable in the Perl script. The following script +prints "true" if and only if the script is invoked with a B<-xyz> switch. + + #!/usr/bin/perl -s + if ($xyz) { print "true\n"; } + +=item B<-S> + +makes Perl use the PATH environment variable to search for the +script (unless the name of the script starts with a slash). Typically +this is used to emulate #! startup on machines that don't support #!, +in the following manner: + + #!/usr/bin/perl + eval "exec /usr/bin/perl -S $0 $*" + if $running_under_some_shell; + +The system ignores the first line and feeds the script to /bin/sh, +which proceeds to try to execute the Perl script as a shell script. +The shell executes the second line as a normal shell command, and thus +starts up the Perl interpreter. On some systems $0 doesn't always +contain the full pathname, so the B<-S> tells Perl to search for the +script if necessary. After Perl locates the script, it parses the +lines and ignores them because the variable $running_under_some_shell +is never true. A better construct than C<$*> would be C<${1+"$@"}>, which +handles embedded spaces and such in the filenames, but doesn't work if +the script is being interpreted by csh. In order to start up sh rather +than csh, some systems may have to replace the #! line with a line +containing just a colon, which will be politely ignored by Perl. Other +systems can't control that, and need a totally devious construct that +will work under any of csh, sh or Perl, such as the following: + + eval '(exit $?0)' && eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + & eval 'exec /usr/bin/perl -S $0 $argv:q' + if 0; + +=item B<-T> + +forces "taint" checks to be turned on. Ordinarily these checks are +done only when running setuid or setgid. See L<perlsec>. + +=item B<-u> + +causes Perl to dump core after compiling your script. You can then +take this core dump and turn it into an executable file by using the +B<undump> program (not supplied). This speeds startup at the expense of +some disk space (which you can minimize by stripping the executable). +(Still, a "hello world" executable comes out to about 200K on my +machine.) If you want to execute a portion of your script before dumping, +use the dump() operator instead. Note: availability of B<undump> is +platform specific and may not be available for a specific port of +Perl. + +=item B<-U> + +allows Perl to do unsafe operations. Currently the only "unsafe" +operations are the unlinking of directories while running as superuser, +and running setuid programs with fatal taint checks turned into +warnings. + +=item B<-v> + +prints the version and patchlevel of your Perl executable. + +=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 +warns you if you use values as a number that doesn't look like numbers, using +a an array as though it were a scalar, if +your subroutines recurse more than 100 deep, and innumeriable other things. +See L<perldiag> and L<perltrap>. + +=item B<-x> I<directory> + +tells Perl that the script is embedded in a message. Leading +garbage will be discarded until the first line that starts with #! and +contains the string "perl". Any meaningful switches on that line will +be applied (but only one group of switches, as with normal #! +processing). If a directory name is specified, Perl will switch to +that directory before running the script. The B<-x> switch only +controls the the disposal of leading garbage. The script must be +terminated with C<__END__> if there is trailing garbage to be ignored (the +script can process any or all of the trailing garbage via the DATA +filehandle if desired). + + +=back diff --git a/pod/perlsec.pod b/pod/perlsec.pod new file mode 100644 index 0000000000..0be4f52798 --- /dev/null +++ b/pod/perlsec.pod @@ -0,0 +1,125 @@ +=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 Perl is executing a setuid script, it 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 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. + diff --git a/pod/perlstyle.pod b/pod/perlstyle.pod new file mode 100644 index 0000000000..43d53554f9 --- /dev/null +++ b/pod/perlstyle.pod @@ -0,0 +1,225 @@ +=head1 NAME + +perlstyle - Perl style guide + +=head1 DESCRIPTION + +=head2 Style + +Each programmer will, of course, have his or her own preferences in +regards to formatting, but there are some general guidelines that will +make your programs easier to read, understand, and maintain. + +Regarding aesthetics of code lay out, about the only thing Larry +cares strongly about is that the closing curly brace of +a multi-line BLOCK should line up with the keyword that started the construct. +Beyond that, he has other preferences that aren't so strong: + +=over 4 + +=item * + +4-column indent. + +=item * + +Opening curly on same line as keyword, if possible, otherwise line up. + +=item * + +Space before the opening curly of a multiline BLOCK. + +=item * + +One-line BLOCK may be put on one line, including curlies. + +=item * + +No space before the semicolon. + +=item * + +Semicolon omitted in "short" one-line BLOCK. + +=item * + +Space around most operators. + +=item * + +Space around a "complex" subscript (inside brackets). + +=item * + +Blank lines between chunks that do different things. + +=item * + +Uncuddled elses. + +=item * + +No space between function name and its opening paren. + +=item * + +Space after each comma. + +=item * + +Long lines broken after an operator (except "and" and "or"). + +=item * + +Space after last paren matching on current line. + +=item * + +Line up corresponding items vertically. + +=item * + +Omit redundant punctuation as long as clarity doesn't suffer. + +=back + +Larry has his reasons for each of these things, but he doen't claim that +everyone else's mind works the same as his does. + +Here are some other more substantive style issues to think about: + +=over 4 + +=item * + +Just because you I<CAN> do something a particular way doesn't mean that +you I<SHOULD> do it that way. Perl is designed to give you several +ways to do anything, so consider picking the most readable one. For +instance + + open(FOO,$foo) || die "Can't open $foo: $!"; + +is better than + + die "Can't open $foo: $!" unless open(FOO,$foo); + +because the second way hides the main point of the statement in a +modifier. On the other hand + + print "Starting analysis\n" if $verbose; + +is better than + + $verbose && print "Starting analysis\n"; + +since the main point isn't whether the user typed B<-v> or not. + +Similarly, just because an operator lets you assume default arguments +doesn't mean that you have to make use of the defaults. The defaults +are there for lazy systems programmers writing one-shot programs. If +you want your program to be readable, consider supplying the argument. + +Along the same lines, just because you I<CAN> omit parentheses in many +places doesn't mean that you ought to: + + return print reverse sort num values %array; + return print(reverse(sort num (values(%array)))); + +When in doubt, parenthesize. At the very least it will let some poor +schmuck bounce on the % key in B<vi>. + +Even if you aren't in doubt, consider the mental welfare of the person +who has to maintain the code after you, and who will probably put +parens in the wrong place. + +=item * + +Don't go through silly contortions to exit a loop at the top or the +bottom, when Perl provides the C<last> operator so you can exit in +the middle. Just "outdent" it a little to make it more visible: + + LINE: + for (;;) { + statements; + last LINE if $foo; + next LINE if /^#/; + statements; + } + +=item * + +Don't be afraid to use loop labels--they're there to enhance +readability as well as to allow multi-level loop breaks. See the +previous example. + +=item * + +For portability, when using features that may not be implemented on +every machine, test the construct in an eval to see if it fails. If +you know what version or patchlevel a particular feature was +implemented, you can test C<$]> ($PERL_VERSION in C<English>) to see if it +will be there. The C<Config> module will also let you interrogate values +determined by the B<Configure> program when Perl was installed. + +=item * + +Choose mnemonic identifiers. If you can't remember what mnemonic means, +you've got a problem. + +=item * + +If you have a really hairy regular expression, use the C</x> modifier and +put in some whitespace to make it look a little less like line noise. +Don't use slash as a delimiter when your regexp has slashes or backslashes. + +=item * + +Use the new "and" and "or" operators to avoid having to parenthesize +list operators so much, and to reduce the incidence of punctuational +operators like C<&&> and C<||>. Call your subroutines as if they were +functions or list operators to avoid excessive ampersands and parens. + +=item * + +Use here documents instead of repeated print() statements. + +=item * + +Line up corresponding things vertically, especially if it'd be too long +to fit on one line anyway. + + $IDX = $ST_MTIME; + $IDX = $ST_ATIME if $opt_u; + $IDX = $ST_CTIME if $opt_c; + $IDX = $ST_SIZE if $opt_s; + + mkdir $tmpdir, 0700 or die "can't mkdir $tmpdir: $!"; + chdir($tmpdir) or die "can't chdir $tmpdir: $!"; + mkdir 'tmp', 0777 or die "can't mkdir $tmpdir/tmp: $!"; + +=item * + +Line up your translations when it makes sense: + + tr [abc] + [xyz]; + +=item * + +Think about reusability. Why waste brainpower on a one-shot when you +might want to do something like it again? Consider generalizing your +code. Consider writing a module or object class. Consider making your +code run cleanly with C<use strict> and B<-w> in effect. Consider giving away +your code. Consider changing your whole world view. Consider... oh, +never mind. + +=item * + +Be consistent. + +=item * + +Be nice. + +=back + diff --git a/pod/perlsub.pod b/pod/perlsub.pod new file mode 100644 index 0000000000..cfc8b5611f --- /dev/null +++ b/pod/perlsub.pod @@ -0,0 +1,195 @@ +=head1 NAME + +perlsub - Perl subroutines + +=head1 SYNOPSIS + +To declare subroutines: + + sub NAME; # A "forward" declaration. + sub NAME BLOCK # A declaration and a definition. + +To import subroutines: + + use PACKAGE qw(NAME1 NAME2 NAME3); + +To call subroutines: + + &NAME # Passes current @_ to subroutine. + &NAME(LIST); # Parens required with & form. + NAME(LIST); # & is optional with parens. + NAME LIST; # Parens optional if predeclared/imported. + +=head1 DESCRIPTION + +Any arguments passed to the routine come in as array @_, that is +($_[0], $_[1], ...). The array @_ is a local array, but its values are +references to the actual scalar parameters. The return value of the +subroutine is the value of the last expression evaluated, and can be +either an array value or a scalar value. Alternately, a return +statement may be used to specify the returned value and exit the +subroutine. To create local variables see the local() and my() +operators. + +A subroutine may called using the "&" prefix. The "&" is optional in Perl +5, and so are the parens if the subroutine has been predeclared. +(Note, however, that the "&" is I<NOT> optional when you're just naming the +subroutine, such as when it's used as an argument to defined() or +undef(). Nor is it optional when you want to do an indirect subroutine +call with a subroutine name or reference using the C<&$subref()> or +C<&{$subref}()> constructs. See L<perlref> for more on that.) + +Example: + + sub MAX { + my $max = pop(@_); + foreach $foo (@_) { + $max = $foo if $max < $foo; + } + $max; + } + + ... + $bestday = &MAX($mon,$tue,$wed,$thu,$fri); + +Example: + + # get a line, combining continuation lines + # that start with whitespace + + sub get_line { + $thisline = $lookahead; + LINE: while ($lookahead = <STDIN>) { + if ($lookahead =~ /^[ \t]/) { + $thisline .= $lookahead; + } + else { + last LINE; + } + } + $thisline; + } + + $lookahead = <STDIN>; # get first line + while ($_ = get_line()) { + ... + } + +Use array assignment to a local list to name your formal arguments: + + sub maybeset { + my($key, $value) = @_; + $foo{$key} = $value unless $foo{$key}; + } + +This also has the effect of turning call-by-reference into +call-by-value, since the assignment copies the values. + +Subroutines may be called recursively. If a subroutine is called using +the "&" form, the argument list is optional. If omitted, no @_ array is +set up for the subroutine; the @_ array at the time of the call is +visible to subroutine instead. + + &foo(1,2,3); # pass three arguments + foo(1,2,3); # the same + + foo(); # pass a null list + &foo(); # the same + &foo; # pass no arguments--more efficient + +=head2 Passing Symbol Table Entries + +[Note: The mechanism described in this section works fine in Perl 5, but +the new reference mechanism is generally easier to work with. See L<perlref>.] + +Sometimes you don't want to pass the value of an array to a subroutine +but rather the name of it, so that the subroutine can modify the global +copy of it rather than working with a local copy. In perl you can +refer to all the objects of a particular name by prefixing the name +with a star: C<*foo>. This is often known as a "type glob", since the +star on the front can be thought of as a wildcard match for all the +funny prefix characters on variables and subroutines and such. + +When evaluated, the type glob produces a scalar value that represents +all the objects of that name, including any filehandle, format or +subroutine. When assigned to, it causes the name mentioned to refer to +whatever "*" value was assigned to it. Example: + + sub doubleary { + local(*someary) = @_; + foreach $elem (@someary) { + $elem *= 2; + } + } + doubleary(*foo); + doubleary(*bar); + +Note that scalars are already passed by reference, so you can modify +scalar arguments without using this mechanism by referring explicitly +to $_[0] etc. You can modify all the elements of an array by passing +all the elements as scalars, but you have to use the * mechanism (or +the equivalent reference mechanism) to push, pop or change the size of +an array. It will certainly be faster to pass the typeglob (or reference). + +Even if you don't want to modify an array, this mechanism is useful for +passing multiple arrays in a single LIST, since normally the LIST +mechanism will merge all the array values so that you can't extract out +the individual arrays. + +=head2 Overriding builtin functions + +Many builtin functions may be overridden, though this should only be +tried occasionally and for good reason. Typically this might be +done by a package attempting to emulate missing builtin functionality +on a non-Unix system. + +Overriding may only be done by importing the name from a +module--ordinary predeclaration isn't good enough. However, the +C<subs> pragma (compiler directive) lets you, in effect, predeclare subs +via the import syntax, and these names may then override the builtin ones: + + use subs 'chdir', 'chroot', 'chmod', 'chown'; + chdir $somewhere; + sub chdir { ... } + +Library modules should not in general export builtin names like "open" +or "chdir" as part of their default @EXPORT list, since these may +sneak into someone else's namespace and change the semantics unexpectedly. +Instead, if the module adds the name to the @EXPORT_OK list, then it's +possible for a user to import the name explicitly, but not implicitly. +That is, they could say + + use Module 'open'; + +and it would import the open override, but if they said + + use Module; + +they would get the default imports without the overrides. + +=head2 Autoloading + +If you call a subroutine that is undefined, you would ordinarily get an +immediate fatal error complaining that the subroutine doesn't exist. +(Likewise for subroutines being used as methods, when the method +doesn't exist in any of the base classes of the class package.) If, +however, there is an C<AUTOLOAD> subroutine defined in the package or +packages that were searched for the original subroutine, then that +C<AUTOLOAD> subroutine is called with the arguments that would have been +passed to the original subroutine. The fully qualified name of the +original subroutine magically appears in the $AUTOLOAD variable in the +same package as the C<AUTOLOAD> routine. The name is not passed as an +ordinary argument because, er, well, just because, that's why... + +Most C<AUTOLOAD> routines will load in a definition for the subroutine in +question using eval, and then execute that subroutine using a special +form of "goto" that erases the stack frame of the C<AUTOLOAD> routine +without a trace. (See the standard C<AutoLoader> module, for example.) +But an C<AUTOLOAD> routine can also just emulate the routine and never +define it. A good example of this is the standard Shell module, which +can treat undefined subroutine calls as calls to Unix programs. + +There are mechanisms available for modules to help them split themselves +up into autoloadable files to be used with the standard AutoLoader module. +See the document on extensions. + diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod new file mode 100644 index 0000000000..3ddb493c8b --- /dev/null +++ b/pod/perlsyn.pod @@ -0,0 +1,267 @@ +=head1 NAME + +perlsyn - Perl syntax + +=head1 DESCRIPTION + +A Perl script consists of a sequence of declarations and statements. +The only things that need to be declared in Perl are report formats +and subroutines. See the sections below for more information on those +declarations. All uninitialized user-created objects are assumed to +start with a null or 0 value until they are defined by some explicit +operation such as assignment. (Though you can get warnings about the +use of undefined values if you like.) The sequence of statements is +executed just once, unlike in B<sed> and B<awk> scripts, where the +sequence of statements is executed for each input line. While this means +that you must explicitly loop over the lines of your input file (or +files), it also means you have much more control over which files and +which lines you look at. (Actually, I'm lying--it is possible to do an +implicit loop with either the B<-n> or B<-p> switch. It's just not the +mandatory default like it is in B<sed> and B<awk>.) + +Perl is, for the most part, a free-form language. (The only +exception to this is format declarations, for obvious reasons.) Comments +are indicated by the "#" character, and extend to the end of the line. If +you attempt to use C</* */> C-style comments, it will be interpreted +either as division or pattern matching, depending on the context, and C++ +C<//> comments just look like a null regular expression, So don't do +that. + +A declaration can be put anywhere a statement can, but has no effect on +the execution of the primary sequence of statements--declarations all +take effect at compile time. Typically all the declarations are put at +the beginning or the end of the script. + +As of Perl 5, declaring a subroutine allows a subroutine name to be used +as if it were a list operator from that point forward in the program. You +can declare a subroutine without defining it by saying just + + sub myname; + $me = myname $0 or die "can't get myname"; + +Note that it functions as a list operator though, not a unary +operator, so be careful to use C<or> instead of C<||> there. + +Subroutines declarations can also be imported by a C<use> statement. + +Also as of Perl 5, a statement sequence may contain declarations of +lexically scoped variables, but apart from declaring a variable name, +the declaration acts like an ordinary statement, and is elaborated within +the sequence of statements as if it were an ordinary statement. + +=head2 Simple statements + +The only kind of simple statement is an expression evaluated for its +side effects. Every simple statement must be terminated with a +semicolon, unless it is the final statement in a block, in which case +the semicolon is optional. (A semicolon is still encouraged there if the +block takes up more than one line, since you may add another line.) +Note that there are some operators like C<eval {}> and C<do {}> that look +like compound statements, but aren't (they're just TERMs in an expression), +and thus need an explicit termination +if used as the last item in a statement. + +Any simple statement may optionally be followed by a I<SINGLE> modifier, +just before the terminating semicolon (or block ending). The possible +modifiers are: + + if EXPR + unless EXPR + while EXPR + until EXPR + +The C<if> and C<unless> modifiers have the expected semantics, +presuming you're a speaker of English. The C<while> and C<until> +modifiers also have the usual "while loop" semantics (conditional +evaluated first), except when applied to a do-BLOCK (or to the +now-deprecated do-SUBROUTINE statement), in which case the block +executes once before the conditional is evaluated. This is so that you +can write loops like: + + do { + $_ = <STDIN>; + ... + } until $_ eq ".\n"; + +See L<perlfunc/do>. Note also that the loop control +statements described later will I<NOT> work in this construct, since +modifiers don't take loop labels. Sorry. You can always wrap +another block around it to do that sort of thing.) + +=head2 Compound statements + +In Perl, a sequence of statements that defines a scope is called a block. +Sometimes a block is delimited by the file containing it (in the case +of a required file, or the program as a whole), and sometimes a block +is delimited by the extent of a string (in the case of an eval). + +But generally, a block is delimited by curly brackets, also known as braces. +We will call this syntactic construct a BLOCK. + +The following compound statements may be used to control flow: + + if (EXPR) BLOCK + if (EXPR) BLOCK else BLOCK + if (EXPR) BLOCK elsif (EXPR) BLOCK ... else BLOCK + LABEL while (EXPR) BLOCK + LABEL while (EXPR) BLOCK continue BLOCK + LABEL for (EXPR; EXPR; EXPR) BLOCK + LABEL foreach VAR (ARRAY) BLOCK + LABEL BLOCK continue BLOCK + +Note that, unlike C and Pascal, these are defined in terms of BLOCKs, +not statements. This means that the curly brackets are I<required>--no +dangling statements allowed. If you want to write conditionals without +curly brackets there are several other ways to do it. The following +all do the same thing: + + if (!open(FOO)) { die "Can't open $FOO: $!"; } + die "Can't open $FOO: $!" unless open(FOO); + open(FOO) or die "Can't open $FOO: $!"; # FOO or bust! + open(FOO) ? 'hi mom' : die "Can't open $FOO: $!"; + # a bit exotic, that last one + +The C<if> statement is straightforward. Since BLOCKs are always +bounded by curly brackets, there is never any ambiguity about which +C<if> an C<else> goes with. If you use C<unless> in place of C<if>, +the sense of the test is reversed. + +The C<while> statement executes the block as long as the expression is +true (does not evaluate to the null string or 0 or "0"). The LABEL is +optional, and if present, consists of an identifier followed by a +colon. The LABEL identifies the loop for the loop control statements +C<next>, C<last>, and C<redo> (see below). If there is a C<continue> +BLOCK, it is always executed just before the conditional is about to be +evaluated again, just like the third part of a C<for> loop in C. +Thus it can be used to increment a loop variable, even when the loop +has been continued via the C<next> statement (which is similar to the C +C<continue> statement). + +If the word C<while> is replaced by the word C<until>, the sense of the +test is reversed, but the conditional is still tested before the first +iteration. + +In either the C<if> or the C<while> statement, you may replace "(EXPR)" +with a BLOCK, and the conditional is true if the value of the last +statement in that block is true. (This feature continues to work in Perl +5 but is deprecated. Please change any occurrences of "if BLOCK" to +"if (do BLOCK)".) + +The C-style C<for> loop works exactly like the corresponding C<while> loop: + + for ($i = 1; $i < 10; $i++) { + ... + } + +is the same as + + $i = 1; + while ($i < 10) { + ... + } continue { + $i++; + } + +The foreach loop iterates over a normal list value and sets the +variable VAR to be each element of the list in turn. The variable is +implicitly local to the loop (unless declared previously with C<my>), +and regains its former value upon exiting the loop. The C<foreach> +keyword is actually a synonym for the C<for> keyword, so you can use +C<foreach> for readability or C<for> for brevity. If VAR is omitted, $_ +is set to each value. If ARRAY is an actual array (as opposed to an +expression returning a list value), you can modify each element of the +array by modifying VAR inside the loop. Examples: + + for (@ary) { s/foo/bar/; } + + foreach $elem (@elements) { + $elem *= 2; + } + + for ((10,9,8,7,6,5,4,3,2,1,'BOOM')) { + print $_, "\n"; sleep(1); + } + + for (1..15) { print "Merry Christmas\n"; } + + foreach $item (split(/:[\\\n:]*/, $ENV{'TERMCAP'})) { + print "Item: $item\n"; + } + +A BLOCK by itself (labeled or not) is semantically equivalent to a loop +that executes once. Thus you can use any of the loop control +statements in it to leave or restart the block. The C<continue> block +is optional. This construct is particularly nice for doing case +structures. + + SWITCH: { + if (/^abc/) { $abc = 1; last SWITCH; } + if (/^def/) { $def = 1; last SWITCH; } + if (/^xyz/) { $xyz = 1; last SWITCH; } + $nothing = 1; + } + +There is no official switch statement in Perl, because there are +already several ways to write the equivalent. In addition to the +above, you could write + + SWITCH: { + $abc = 1, last SWITCH if /^abc/; + $def = 1, last SWITCH if /^def/; + $xyz = 1, last SWITCH if /^xyz/; + $nothing = 1; + } + +(That's actually not as strange as it looks one you realize that you can +use loop control "operators" within an expression, That's just the normal +C comma operator.) + +or + + SWITCH: { + /^abc/ && do { $abc = 1; last SWITCH; }; + /^def/ && do { $def = 1; last SWITCH; }; + /^xyz/ && do { $xyz = 1; last SWITCH; }; + $nothing = 1; + } + +or formatted so it stands out more as a "proper" switch statement: + + SWITCH: { + /^abc/ && do { + $abc = 1; + last SWITCH; + }; + + /^def/ && do { + $def = 1; + last SWITCH; + }; + + /^xyz/ && do { + $xyz = 1; + last SWITCH; + }; + $nothing = 1; + } + +or + + SWITCH: { + /^abc/ and $abc = 1, last SWITCH; + /^def/ and $def = 1, last SWITCH; + /^xyz/ and $xyz = 1, last SWITCH; + $nothing = 1; + } + +or even, horrors, + + if (/^abc/) + { $abc = 1 } + elsif (/^def/) + { $def = 1 } + elsif (/^xyz/) + { $xyz = 1 } + else + { $nothing = 1 } + diff --git a/pod/perltrap.pod b/pod/perltrap.pod new file mode 100644 index 0000000000..51dac4770f --- /dev/null +++ b/pod/perltrap.pod @@ -0,0 +1,451 @@ +=head1 NAME + +perltrap - Perl traps for the unwary + +=head1 DESCRIPTION + +The biggest trap of all is forgetting to use the B<-w> switch; +see L<perlrun>. Making your entire program runnable under + + use strict; + +can help make your program more bullet-proof, but sometimes +it's too annoying for quick throw-away programs. + +=head2 Awk Traps + +Accustomed B<awk> users should take special note of the following: + +=over 4 + +=item * + +The English module, loaded via + + use English; + +allows you to refer to special variables (like $RS) as +though they were in B<awk>; see L<perlvar> for details. + +=item * + +Semicolons are required after all simple statements in Perl (except +at the end of a block). Newline is not a statement delimiter. + +=item * + +Curly brackets are required on C<if>s and C<while>s. + +=item * + +Variables begin with "$" or "@" in Perl. + +=item * + +Arrays index from 0. Likewise string positions in substr() and +index(). + +=item * + +You have to decide whether your array has numeric or string indices. + +=item * + +Associative array values do not spring into existence upon mere +reference. + +=item * + +You have to decide whether you want to use string or numeric +comparisons. + +=item * + +Reading an input line does not split it for you. You get to split it +yourself to an array. And split() operator has different +arguments. + +=item * + +The current input line is normally in $_, not $0. It generally does +not have the newline stripped. ($0 is the name of the program +executed.) See L<perlvar>. + +=item * + +$<I<digit>> does not refer to fields--it refers to substrings matched by +the last match pattern. + +=item * + +The print() statement does not add field and record separators unless +you set C<$,> and C<$.>. You can set $OFS and $ORS if you're using +the English module. + +=item * + +You must open your files before you print to them. + +=item * + +The range operator is "..", not comma. The comma operator works as in +C. + +=item * + +The match operator is "=~", not "~". ("~" is the one's complement +operator, as in C.) + +=item * + +The exponentiation operator is "**", not "^". "^" is the XOR +operator, as in C. (You know, one could get the feeling that B<awk> is +basically incompatible with C.) + +=item * + +The concatenation operator is ".", not the null string. (Using the +null string would render C</pat/ /pat/> unparsable, since the third slash +would be interpreted as a division operator--the tokener is in fact +slightly context sensitive for operators like "/", "?", and ">". +And in fact, "." itself can be the beginning of a number.) + +=item * + +The C<next>, C<exit>, and C<continue> keywords work differently. + +=item * + + +The following variables work differently: + + Awk Perl + ARGC $#ARGV or scalar @ARGV + ARGV[0] $0 + FILENAME $ARGV + FNR $. - something + FS (whatever you like) + NF $#Fld, or some such + NR $. + OFMT $# + OFS $, + ORS $\ + RLENGTH length($&) + RS $/ + RSTART length($`) + SUBSEP $; + +=item * + +You cannot set $RS to a pattern, only a string. + +=item * + +When in doubt, run the B<awk> construct through B<a2p> and see what it +gives you. + +=back + +=head2 C Traps + +Cerebral C programmers should take note of the following: + +=over 4 + +=item * + +Curly brackets are required on C<if>'s and C<while>'s. + +=item * + +You must use C<elsif> rather than C<else if>. + +=item * + +The C<break> and C<continue> keywords from C become in +Perl C<last> and C<next>, respectively. +Unlike in C, these do I<NOT> work within a C<do { } while> construct. + +=item * + +There's no switch statement. (But it's easy to build one on the fly.) + +=item * + +Variables begin with "$" or "@" in Perl. + +=item * + +printf() does not implement the "*" format for interpolating +field widths, but it's trivial to use interpolation of double-quoted +strings to achieve the same effect. + +=item * + +Comments begin with "#", not "/*". + +=item * + +You can't take the address of anything, although a similar operator +in Perl 5 is the backslash, which creates a reference. + +=item * + +C<ARGV> must be capitalized. + +=item * + +System calls such as link(), unlink(), rename(), etc. return nonzero for +success, not 0. + +=item * + +Signal handlers deal with signal names, not numbers. Use C<kill -l> +to find their names on your system. + +=back + +=head2 Sed Traps + +Seasoned B<sed> programmers should take note of the following: + +=over 4 + +=item * + +Backreferences in substitutions use "$" rather than "\". + +=item * + +The pattern matching metacharacters "(", ")", and "|" do not have backslashes +in front. + +=item * + +The range operator is C<...>, rather than comma. + +=back + +=head2 Shell Traps + +Sharp shell programmers should take note of the following: + +=over 4 + +=item * + +The backtick operator does variable interpretation without regard to +the presence of single quotes in the command. + +=item * + +The backtick operator does no translation of the return value, unlike B<csh>. + +=item * + +Shells (especially B<csh>) do several levels of substitution on each +command line. Perl does substitution only in certain constructs +such as double quotes, backticks, angle brackets, and search patterns. + +=item * + +Shells interpret scripts a little bit at a time. Perl compiles the +entire program before executing it (except for C<BEGIN> blocks, which +execute at compile time). + +=item * + +The arguments are available via @ARGV, not $1, $2, etc. + +=item * + +The environment is not automatically made available as separate scalar +variables. + +=back + +=head2 Perl Traps + +Practicing Perl Programmers should take note of the following: + +=over 4 + +=item * + +Remember that many operations behave differently in a list +context than they do in a scalar one. See L<perldata> for details. + +=item * + +Avoid barewords if you can, especially all lower-case ones. +You can't tell just by looking at it whether a bareword is +a function or a string. By using quotes on strings and +parens on function calls, you won't ever get them confused. + +=item * + +You cannot discern from mere inspection which built-ins +are unary operators (like chop() and chdir()) +and which are list operators (like print() and unlink()). +(User-defined subroutines can B<only> be list operators, never +unary ones.) See L<perlop>. + +=item * + +People have a hard type remembering that some functions +default to $_, or @ARGV, or whatever, but that others which +you might expect to do not. + +=item * + +Remember not to use "C<=>" when you need "C<=~>"; +these two constructs are quite different: + + $x = /foo/; + $x =~ /foo/; + +=item * + +The C<do {}> construct isn't a real loop that you can use +loop control on. + +=item * + +Use 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. + +=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 * + +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 * + +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 * + +Some error messages will be different. + +=item * + +Some bugs may have been inadvertently removed. + +=back diff --git a/pod/perlvar.pod b/pod/perlvar.pod new file mode 100644 index 0000000000..bdf24f6c89 --- /dev/null +++ b/pod/perlvar.pod @@ -0,0 +1,608 @@ +=head1 NAME + +perlvar - Perl predefined variables + +=head1 DESCRIPTION + +=head2 Predefined Names + +The following names have special meaning to Perl. Most of the +punctuational names have reasonable mnemonics, or analogues in one of +the shells. Nevertheless, if you wish to use the long variable names, +you just need to say + + use English; + +at the top of your program. This will alias all the short names to the +long names in the current package. Some of them even have medium names, +generally borrowed from B<awk>. + +To go a step further, those variables that depend on the currently +selected filehandle may instead be set by calling an object method on +the FileHandle object. (Summary lines below for this contain the word +HANDLE.) First you must say + + use FileHandle; + +after which you may use either + + method HANDLE EXPR + +or + + HANDLE->method(EXPR) + +Each of the methods returns the old value of the FileHandle attribute. +The methods each take an optional EXPR, which if supplied specifies the +new value for the FileHandle attribute in question. If not supplied, +most of the methods do nothing to the current value, except for +autoflush(), which will assume a 1 for you, just to be different. + +A few of these variables are considered "read-only". This means that if you +try to assign to this variable, either directly or indirectly through +a reference. If you attempt to do so, you'll raise a run-time exception. + +=over 8 + +=item $ARG + +=item $_ + +The default input and pattern-searching space. The following pairs are +equivalent: + + while (<>) {...} # only equivalent in while! + while ($_ = <>) {...} + + /^Subject:/ + $_ =~ /^Subject:/ + + tr/a-z/A-Z/ + $_ =~ tr/a-z/A-Z/ + + chop + chop($_) + +(Mnemonic: underline is understood in certain operations.) + +=item $<I<digit>> + +Contains the subpattern from the corresponding set of parentheses in +the last pattern matched, not counting patterns matched in nested +blocks that have been exited already. (Mnemonic: like \digit.) +These variables are all read-only. + +=item $MATCH + +=item $& + +The string matched by the last successful pattern match (not counting +any matches hidden within a BLOCK or eval() enclosed by the current +BLOCK). (Mnemonic: like & in some editors.) This variable is read-only. + +=item $PREMATCH + +=item $` + +The string preceding whatever was matched by the last successful +pattern match (not counting any matches hidden within a BLOCK or eval +enclosed by the current BLOCK). (Mnemonic: ` often precedes a quoted +string.) This variable is read-only. + +=item $POSTMATCH + +=item $' + +The string following whatever was matched by the last successful +pattern match (not counting any matches hidden within a BLOCK or eval() +enclosed by the current BLOCK). (Mnemonic: ' often follows a quoted +string.) Example: + + $_ = 'abcdefghi'; + /def/; + print "$`:$&:$'\n"; # prints abc:def:ghi + +This variable is read-only. + +=item $LAST_PAREN_MATCH + +=item $+ + +The last bracket matched by the last search pattern. This is useful if +you don't know which of a set of alternative patterns matched. For +example: + + /Version: (.*)|Revision: (.*)/ && ($rev = $+); + +(Mnemonic: be positive and forward looking.) +This variable is read-only. + +=item $MULTILINE_MATCHING + +=item $* + +Set to 1 to do multiline matching within a string, 0 to tell Perl +that it can assume that strings contain a single line, for the purpose +of optimizing pattern matches. Pattern matches on strings containing +multiple newlines can produce confusing results when "C<$*>" is 0. Default +is 0. (Mnemonic: * matches multiple things.) Note that this variable +only influences the interpretation of "C<^>" and "C<$>". A literal newline can +be searched for even when C<$* == 0>. + +Use of "C<$*>" is deprecated in Perl 5. + +=item input_line_number HANDLE EXPR + +=item $INPUT_LINE_NUMBER + +=item $NR + +=item $. + +The current input line number of the last filehandle that was read. +This variable should be considered read-only. +Remember that only 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()). +(Mnemonic: many programs use "." to mean the current line number.) + +=item input_record_separator HANDLE EXPR + +=item $INPUT_RECORD_SEPARATOR + +=item $RS + +=item $/ + +The input record separator, newline by default. Works like B<awk>'s RS +variable, including treating blank lines as delimiters if set to the +null string. You may set it to a multicharacter string to match a +multi-character delimiter. Note that setting it to C<"\n\n"> means +something slightly different than setting it to C<"">, if the file +contains consecutive blank lines. Setting it to C<""> will treat two or +more consecutive blank lines as a single blank line. Setting it to +C<"\n\n"> will blindly assume that the next input character belongs to the +next paragraph, even if it's a newline. (Mnemonic: / is used to +delimit line boundaries when quoting poetry.) + + undef $/; + $_ = <FH>; # whole file now here + s/\n[ \t]+/ /g; + +=item autoflush HANDLE EXPR + +=item $OUTPUT_AUTOFLUSH + +=item $| + +If set to nonzero, forces a flush after every write or print on the +currently selected output channel. Default is 0. Note that STDOUT +will typically be line buffered if output is to the terminal and block +buffered otherwise. Setting this variable is useful primarily when you +are outputting to a pipe, such as when you are running a Perl script +under rsh and want to see the output as it's happening. (Mnemonic: +when you want your pipes to be piping hot.) + +=item output_field_separator HANDLE EXPR + +=item $OUTPUT_FIELD_SEPARATOR + +=item $OFS + +=item $, + +The output field separator for the print operator. Ordinarily the +print operator simply prints out the comma separated fields you +specify. In order to get behavior more like B<awk>, set this variable +as you would set B<awk>'s OFS variable to specify what is printed +between fields. (Mnemonic: what is printed when there is a , in your +print statement.) + +=item output_record_separator HANDLE EXPR + +=item $OUTPUT_RECORD_SEPARATOR + +=item $ORS + +=item $\ + +The output record separator for the print operator. Ordinarily the +print operator simply prints out the comma separated fields you +specify, with no trailing newline or record separator assumed. In +order to get behavior more like B<awk>, set this variable as you would +set B<awk>'s ORS variable to specify what is printed at the end of the +print. (Mnemonic: you set "C<$\>" instead of adding \n at the end of the +print. Also, it's just like /, but it's what you get "back" from +Perl.) + +=item $LIST_SEPARATOR + +=item $" + +This is like "C<$,>" except that it applies to array values interpolated +into a double-quoted string (or similar interpreted string). Default +is a space. (Mnemonic: obvious, I think.) + +=item $SUBSCRIPT_SEPARATOR + +=item $SUBSEP + +=item $; + +The subscript separator for multi-dimensional array emulation. If you +refer to a hash element as + + $foo{$a,$b,$c} + +it really means + + $foo{join($;, $a, $b, $c)} + +But don't put + + @foo{$a,$b,$c} # a slice--note the @ + +which means + + ($foo{$a},$foo{$b},$foo{$c}) + +Default is "\034", the same as SUBSEP in B<awk>. Note that if your +keys contain binary data there might not be any safe value for "C<$;>". +(Mnemonic: comma (the syntactic subscript separator) is a +semi-semicolon. Yeah, I know, it's pretty lame, but "C<$,>" is already +taken for something more important.) + +Consider using "real" multi-dimensional arrays in Perl 5. + +=item $OFMT + +=item $# + +The output format for printed numbers. This variable is a half-hearted +attempt to emulate B<awk>'s OFMT variable. There are times, however, +when B<awk> and Perl have differing notions of what is in fact +numeric. 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. + +=item format_page_number HANDLE EXPR + +=item $FORMAT_PAGE_NUMBER + +=item $% + +The current page number of the currently selected output channel. +(Mnemonic: % is page number in B<nroff>.) + +=item format_lines_per_page HANDLE EXPR + +=item $FORMAT_LINES_PER_PAGE + +=item $= + +The current page length (printable lines) of the currently selected +output channel. Default is 60. (Mnemonic: = has horizontal lines.) + +=item format_lines_left HANDLE EXPR + +=item $FORMAT_LINES_LEFT + +=item $- + +The number of lines left on the page of the currently selected output +channel. (Mnemonic: lines_on_page - lines_printed.) + +=item format_name HANDLE EXPR + +=item $FORMAT_NAME + +=item $~ + +The name of the current report format for the currently selected output +channel. Default is name of the filehandle. (Mnemonic: brother to +"C<$^>".) + +=item format_top_name HANDLE EXPR + +=item $FORMAT_TOP_NAME + +=item $^ + +The name of the current top-of-page format for the currently selected +output channel. Default is name of the filehandle with _TOP +appended. (Mnemonic: points to top of page.) + +=item format_line_break_characters HANDLE EXPR + +=item $FORMAT_LINE_BREAK_CHARACTERS + +=item $: + +The current set of characters after which a string may be broken to +fill continuation fields (starting with ^) in a format. Default is +S<" \n-">, to break on whitespace or hyphens. (Mnemonic: a "colon" in +poetry is a part of a line.) + +=item format_formfeed HANDLE EXPR + +=item $FORMAT_FORMFEED + +=item $^L + +What formats output to perform a formfeed. Default is \f. + +=item $ACCUMULATOR + +=item $^A + +The current value of the write() accumulator for format() lines. A format +contains formline() commands that put their result into C<$^A>. After +calling its format, write() prints out the contents of C<$^A> and empties. +So you never actually see the contents of C<$^A> unless you call +formline() yourself and then look at it. See L<perlform> and +L<perlfunc/formline()>. + +=item $CHILD_ERROR + +=item $? + +The status returned by the last pipe close, backtick (C<``>) command, +or system() operator. Note that this is the status word returned by +the wait() system call, so the exit value of the subprocess is actually +(C<$? E<gt>E<gt> 8>). Thus on many systems, C<$? & 255> gives which signal, +if any, the process died from, and whether there was a core dump. +(Mnemonic: similar to B<sh> and B<ksh>.) + +=item $OS_ERROR + +=item $ERRNO + +=item $! + +If used in a numeric context, yields the current value of errno, with +all the usual caveats. (This means that you shouldn't depend on the +value of "C<$!>" to be anything in particular unless you've gotten a +specific error return indicating a system error.) If used in a string +context, yields the corresponding system error string. You can assign +to "C<$!>" in order to set I<errno> if, for instance, you want "C<$!>" to return the +string for error I<n>, or you want to set the exit value for the die() +operator. (Mnemonic: What just went bang?) + +=item $EVAL_ERROR + +=item $@ + +The Perl syntax error message from the last eval() command. If null, the +last eval() parsed and executed correctly (although the operations you +invoked may have failed in the normal fashion). (Mnemonic: Where was +the syntax error "at"?) + +=item $PROCESS_ID + +=item $PID + +=item $$ + +The process number of the Perl running this script. (Mnemonic: same +as shells.) + +=item $REAL_USER_ID + +=item $UID + +=item $< + +The real uid of this process. (Mnemonic: it's the uid you came I<FROM>, +if you're running setuid.) + +=item $EFFECTIVE_USER_ID + +=item $EUID + +=item $> + +The effective uid of this process. Example: + + $< = $>; # set real to effective uid + ($<,$>) = ($>,$<); # swap real and effective uid + +(Mnemonic: it's the uid you went I<TO>, if you're running setuid.) Note: +"C<$E<lt>>" and "C<$E<gt>>" can only be swapped on machines supporting setreuid(). + +=item $REAL_GROUP_ID + +=item $GID + +=item $( + +The real gid of this process. If you are on a machine that supports +membership in multiple groups simultaneously, gives a space separated +list of groups you are in. The first number is the one returned by +getgid(), and the subsequent ones by getgroups(), one of which may be +the same as the first number. (Mnemonic: parentheses are used to I<GROUP> +things. The real gid is the group you I<LEFT>, if you're running setgid.) + +=item $EFFECTIVE_GROUP_ID + +=item $EGID + +=item $) + +The effective gid of this process. If you are on a machine that +supports membership in multiple groups simultaneously, gives a space +separated list of groups you are in. The first number is the one +returned by getegid(), and the subsequent ones by getgroups(), one of +which may be the same as the first number. (Mnemonic: parentheses are +used to I<GROUP> things. The effective gid is the group that's I<RIGHT> for +you, if you're running setgid.) + +Note: "C<$E<lt>>", "C<$E<gt>>", "C<$(>" and "C<$)>" can only be set on machines +that support the corresponding I<set[re][ug]id()> routine. "C<$(>" and "C<$)>" +can only be swapped on machines supporting setregid(). + +=item $PROGRAM_NAME + +=item $0 + +Contains the name of the file containing the Perl script being +executed. Assigning to "C<$0>" modifies the argument area that the ps(1) +program sees. This is more useful as a way of indicating the +current program state than it is for hiding the program you're running. +(Mnemonic: same as B<sh> and B<ksh>.) + +=item $[ + +The index of the first element in an array, and of the first character +in a substring. Default is 0, but you could set it to 1 to make +Perl behave more like B<awk> (or Fortran) when subscripting and when +evaluating the index() and substr() functions. (Mnemonic: [ begins +subscripts.) + +As of Perl 5, assignment to "C<$[>" is treated as a compiler directive, +and cannot influence the behavior of any other file. Its use is +discouraged. + +=item $PERL_VERSION + +=item $] + +The string printed out when you say C<perl -v>. It can be used to +determine at the beginning of a script whether the perl interpreter +executing the script is in the right range of versions. If used in a +numeric context, returns the version + patchlevel / 1000. Example: + + # see if getc is available + ($version,$patchlevel) = + $] =~ /(\d+\.\d+).*\nPatch level: (\d+)/; + print STDERR "(No filename completion available.)\n" + if $version * 1000 + $patchlevel < 2016; + +or, used numerically, + + warn "No checksumming!\n" if $] < 3.019; + +(Mnemonic: Is this version of perl in the right bracket?) + +=item $DEBUGGING + +=item $^D + +The current value of the debugging flags. (Mnemonic: value of B<-D> +switch.) + +=item $SYSTEM_FD_MAX + +=item $^F + +The maximum system file descriptor, ordinarily 2. System file +descriptors are passed to exec()ed processes, while higher file +descriptors are not. Also, during an open(), system file descriptors are +preserved even if the open() fails. (Ordinary file descriptors are +closed before the open() is attempted.) Note that the close-on-exec +status of a file descriptor will be decided according to the value of +C<$^F> at the time of the open, not the time of the exec. + +=item $INPLACE_EDIT + +=item $^I + +The current value of the inplace-edit extension. Use C<undef> to disable +inplace editing. (Mnemonic: value of B<-i> switch.) + +=item $PERLDB + +=item $^P + +The internal flag that the debugger clears so that it doesn't debug +itself. You could conceivable disable debugging yourself by clearing +it. + +=item $BASETIME + +=item $^T + +The time at which the script began running, in seconds since the +epoch (beginning of 1970). The values returned by the B<-M>, B<-A> +and B<-C> filetests are +based on this value. + +=item $WARNING + +=item $^W + +The current value of the warning switch, either TRUE or FALSE. (Mnemonic: related to the +B<-w> switch.) + +=item $EXECUTABLE_NAME + +=item $^X + +The name that the Perl binary itself was executed as, from C's C<argv[0]>. + +=item $ARGV + +contains the name of the current file when reading from <>. + +=item @ARGV + +The array @ARGV contains the command line arguments intended for the +script. Note that C<$#ARGV> is the generally number of arguments minus +one, since C<$ARGV[0]> is the first argument, I<NOT> the command name. See +"C<$0>" for the command name. + +=item @INC + +The array @INC contains the list of places to look for Perl scripts to +be evaluated by the C<do EXPR>, C<require>, or C<use> constructs. It +initially consists of the arguments to any B<-I> command line switches, +followed by the default Perl library, probably "/usr/local/lib/perl", +followed by ".", to represent the current directory. + +=item %INC + +The hash %INC contains entries for each filename that has +been included via C<do> or C<require>. The key is the filename you +specified, and the value is the location of the file actually found. +The C<require> command uses this array to determine whether a given file +has already been included. + +=item $ENV{expr} + +The hash %ENV contains your current environment. Setting a +value in C<ENV> changes the environment for child processes. + +=item $SIG{expr} + +The hash %SIG is used to set signal handlers for various +signals. Example: + + sub handler { # 1st argument is signal name + local($sig) = @_; + print "Caught a SIG$sig--shutting down\n"; + close(LOG); + exit(0); + } + + $SIG{'INT'} = 'handler'; + $SIG{'QUIT'} = 'handler'; + ... + $SIG{'INT'} = 'DEFAULT'; # restore default action + $SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT + +The %SIG array only contains values for the signals actually set within +the Perl script. Here are some other examples: + + $SIG{PIPE} = Plumber; # SCARY!! + $SIG{"PIPE"} = "Plumber"; # just fine, assumes main::Plumber + $SIG{"PIPE"} = \&Plumber; # just fine; assume current Plumber + $SIG{"PIPE"} = Plumber(); # oops, what did Plumber() return?? + +The one marked scary is problematic because it's a bareword, which means +sometimes it's a string representing the function, and sometimes it's +going to call the subroutine call right then and there! Best to be sure +and quote it or take a reference to it. *Plumber works too. See <perlsubs>. + +=back + diff --git a/pod/pod2html b/pod/pod2html new file mode 100644 index 0000000000..1bfc8f6a6a --- /dev/null +++ b/pod/pod2html @@ -0,0 +1,209 @@ +#!../perl + +# The beginning of the url for the anchors to the other sections. +chop($wd=`pwd`); +$type="<A HREF=\"file://localhost".$wd."/"; +$debug=0; +$/ = ""; +$p=\%p; +@exclusions=("perldebug","perlform","perlobj","perlstyle","perltrap","perlmod"); +$indent=0; +opendir(DIR,"."); +@{$p->{"pods"}}=grep(/\.pod$/,readdir(DIR)); +closedir(DIR); + +# learn the important stuff + +foreach $tmpod (@{$p->{"pods"}}){ + ($pod=$tmpod)=~s/\.pod$//; + $p->{"podnames"}->{$pod}=1; + next if grep(/$pod/,@exclusions); + open(POD,"<$tmpod"); + while(<POD>){ + s/B<([^<>]*)>/$1/g; # bold + s/I<([^<>]*)>/$1/g; # bold + if (s/^=//) { + s/\n$//s; + s/\n/ /g; + ($cmd, $_) = split(' ', $_, 2); + if ($cmd eq "item") { + ($what,$rest)=split(' ', $_, 2); + $what=~s#(-.).*#$1#; + $what=~s/\s*$//; + next if defined $p->{"items"}->{$what}; + $p->{"items"}->{$what} = $pod."_".$i++; + } + elsif($cmd =~ /^head/){ + $_=~s/\s*$//; + next if defined($p->{"headers"}->{$_}); + $p->{"headers"}->{$_} = $pod."_".$i++; + } + } + } +} + +$/=""; + +# parse the pods, produce html +foreach $tmpod (@{$p->{"pods"}}){ + open(POD,"<$tmpod") || die "cant open $pod"; + ($pod=$tmpod)=~s/\.pod$//; + open(HTML,">$pod.html"); + print HTML "<!-- \$RCSfile\$\$Revision\$\$Date\$ -->\n"; + print HTML "<!-- \$Log\$ -->\n"; + print HTML "<HTML>\n"; + print HTML "<TITLE> \U$pod\E </TITLE>\n"; + $cutting = 1; + while (<POD>) { + if ($cutting) { + next unless /^=/; + $cutting = 0; + } + chop; + length || (print "\n") && next; + # Translate verabatim paragraph + + if (/^\s/) { + $unordered=0; + &pre_escapes; + &post_escapes; + @lines = split(/\n/); + if($lines[0]=~/^\s+(\w*)\t(.*)/){ # listing or unordered list + ($key,$rest)=($1,$2); + if(defined($p->{"podnames"}->{$key})){ + print HTML "\n<ul>\n"; + $unordered = 1; + } + else{ + print HTML "\n<listing>\n"; + } + foreach $line (@lines){ + ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rest)=($1,$2)); + print HTML defined($p->{"podnames"}->{$key}) ? + "<li>$type$key.html\">$key<\/A>\t$rest\n" : "$line \n"; + } + print HTML $unordered ? "</ul>\n" : "</listing>\n"; + next; + }else{ # preformatted text + print HTML "<pre>\n"; + for(@lines){ + s/^/ /; + s/\t/ /g; + print HTML $_,"\n"; + } + print HTML "</pre>\n"; + next; + } + } + &pre_escapes; + s/S<([^<>]*)>/$1/g; # embedded special + $_ = &Do_refs($_,$pod); + s/Z<>/<p>/g; # ? + s/E<([^<>]*)>/\&$1\;/g; # embedded special + &post_escapes; + if (s/^=//) { + s/\n$//s; + s/\n/ /g; + ($cmd, $_) = split(' ', $_, 2); + if ($cmd eq 'cut') { + $cutting = 1; + } + elsif ($cmd eq 'head1') { + print HTML qq{<h2>$_</h2>\n}; + } + elsif ($cmd eq 'head2') { + print HTML qq{<h3>$_</h3>\n}; + } + elsif ($cmd eq 'over') { + push(@indent,$indent); + $indent = $_ + 0; + print HTML qq{\n<dl>\n}; + } + elsif ($cmd eq 'back') { + $indent = pop(@indent); + warn "Unmatched =back\n" unless defined $indent; + $needspace = 1; + print HTML qq{\n</dl>\n\n}; + } + elsif ($cmd eq 'item') { + ($what,$rest)=split(' ', $_, 2); + $what=~s/\s*$//; + if($justdid ne $what){ + print HTML "\n<A NAME=\"".$p->{"items"}->{$what}."\"></A>\n"; + $justdid=$what; + } + print HTML qq{<dt><B>$_</B> </dt>\n}; + $next_para=1; + } + else { + warn "Unrecognized directive: $cmd\n"; + } + } + else { + length || next; + $next_para && (print HTML qq{<dd>\n}); + print HTML "$_<p>"; + $next_para && (print HTML qq{</dd>\n<p>\n}) && ($next_para=0); + } + } +} +print HTML "\n</HTML>\n"; + +######################################################################### + +sub pre_escapes { + s/\&/\&\;/g; + s/<</\<\;\<\;/g; + s/([^ESIBLCF])</$1\<\;/g; +} + +sub post_escapes{ + s/>>/\>\;\>\;/g; + s/([^"AIB])>/$1\>\;/g; +} + +sub Do_refs{ +local($para,$pod)=@_; +foreach $char ("L","C","I","B"){ + next unless /($char<[^<>]*>)/; + local(@ar) = split(/($char<[^<>]*>)/,$para); + local($this,$key,$num); + for($this=0;$this<=$#ar;$this++){ + next unless $ar[$this] =~ /${char}<([^<>]*)>/; + $key=$1; + + if((defined($p->{"podnames"}->{$key})) && ($char eq "L")){ + $ar[$this] = "\n$type$key.html\">\nthe $key manpage<\/A>\n"; # + } + elsif(defined($p->{"items"}->{$key})){ + ($pod2,$num)=split(/_/,$p->{"items"}->{$key},2); + $ar[$this] = (($pod2 eq $pod) && ($para=~/^\=item/)) ? + "\n<A NAME=\"".$p->{"items"}->{$key}."\">\n$key</A>\n" + : + "\n$type$pod2.html\#".$p->{"items"}->{$key}."\">$key<\/A>\n"; + } + elsif(defined($p->{"headers"}->{$key})){ + ($pod2,$num)=split(/_/,$p->{"headers"}->{$key},2); + $ar[$this] = (($pod eq $pod2) && ($para=~/^\=head/)) ? + "\n<A NAME=\"".$p->{"headers"}->{$key}."\">\n$key</A>\n" + : + "\n$type$pod2.html\#".$p->{"headers"}->{$key}."\">$key<\/A>\n"; + } + else{ + (warn "No \"=item\" or \"=head\" reference for $ar[$this] in $pod\n") if $debug; + if($char =~ /^[BCF]$/){ + $ar[$this]="<B>$key</B>"; + } + elsif($char eq "L"){ + $ar[$this]=$key; + } + elsif($char eq "I"){ + $ar[$this]="<I>$key</I>"; + } + } + } + $para=join('',@ar); +} +$para; +} +sub wait{1;} diff --git a/pod/pod2man b/pod/pod2man new file mode 100755 index 0000000000..5b577738e3 --- /dev/null +++ b/pod/pod2man @@ -0,0 +1,625 @@ +#!/usr/bin/perl + +$/ = ""; +$cutting = 1; + +$CFont = 'CW'; +if ($ARGV[0] =~ s/-fc(.*)//) { + shift; + $CFont = $1 || shift; +} + +if (length($CFont) == 2) { + $CFont_embed = "\\f($CFont"; +} +elsif (length($CFont) == 1) { + $CFont_embed = "\\f$CFont"; +} +else { + die "Roff font should be 1 or 2 chars, not `$CFont_embed'"; +} + +$name = @ARGV ? $ARGV[0] : "something"; +$name =~ s/\..*//; + +print <<"END"; +.rn '' }` +''' \$RCSfile\$\$Revision\$\$Date\$ +''' +''' \$Log\$ +''' +.de Sh +.br +.if t .Sp +.ne 5 +.PP +\\fB\\\\\$1\\fR +.PP +.. +.de Sp +.if t .sp .5v +.if n .sp +.. +.de Ip +.br +.ie \\\\n(.\$>=3 .ne \\\\\$3 +.el .ne 3 +.IP "\\\\\$1" \\\\\$2 +.. +.de Vb +.ft $CFont +.nf +.ne \\\\\$1 +.. +.de Ve +.ft R + +.fi +.. +''' +''' +''' Set up \\*(-- to give an unbreakable dash; +''' string Tr holds user defined translation string. +''' Bell System Logo is used as a dummy character. +''' +.tr \\(*W-|\\(bv\\*(Tr +.ie n \\{\\ +.ds -- \\(*W- +.if (\\n(.H=4u)&(1m=24u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-12u'-\\" diablo 10 pitch +.if (\\n(.H=4u)&(1m=20u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-8u'-\\" diablo 12 pitch +.ds L" "" +.ds R" "" +.ds L' ' +.ds R' ' +'br\\} +.el\\{\\ +.ds -- \\(em\\| +.tr \\*(Tr +.ds L" `` +.ds R" '' +.ds L' ` +.ds R' ' +.if t .ds PI \\(*p +.if n .ds PI PI +'br\\} +.TH \U$name\E 1 "\\*(RP" +.UC +END + +print <<'END'; +.if n .hy 0 +.if n .na +.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' +.de CQ \" put $1 in typewriter font +END +print ".ft $CFont\n"; +print <<'END'; +'if n "\c +'if t \\\\&\\\\$1\c +'if n \\\\&\\\\$1\c +'if n \&" +\\\\&\\\\$2 \\\\$3 \\\\$4 \\\\$5 \\\\$6 \\\\$7 +'.ft R +.. +.\" @(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2 +. \" AM - accent mark definitions +.bd S B 3 +. \" fudge factors for nroff and troff +.if n \{\ +. ds #H 0 +. ds #V .8m +. ds #F .3m +. ds #[ \f1 +. ds #] \fP +.\} +.if t \{\ +. ds #H ((1u-(\\\\\\\\n(.fu%2u))*.13m) +. ds #V .6m +. ds #F 0 +. ds #[ \& +. ds #] \& +.\} +. \" simple accents for nroff and troff +.if n \{\ +. ds ' \& +. ds ` \& +. ds ^ \& +. ds , \& +. ds ~ ~ +. ds ? ? +. ds ! ! +. ds / +. ds q +.\} +.if t \{\ +. ds ' \\\\k:\h'-(\\\\n(.wu*8/10-\*(#H)'\'\h"|\\\\n:u" +. ds ` \\\\k:\h'-(\\\\n(.wu*8/10-\*(#H)'\`\h'|\\\\n:u' +. ds ^ \\\\k:\h'-(\\\\n(.wu*10/11-\*(#H)'^\h'|\\\\n:u' +. ds , \\\\k:\h'-(\\\\n(.wu*8/10)',\h'|\\\\n:u' +. ds ~ \\\\k:\h'-(\\\\n(.wu-\*(#H-.1m)'~\h'|\\\\n:u' +. ds ? \s-2c\h'-\w'c'u*7/10'\u\h'\*(#H'\zi\d\s+2\h'\w'c'u*8/10' +. ds ! \s-2\(or\s+2\h'-\w'\(or'u'\v'-.8m'.\v'.8m' +. ds / \\\\k:\h'-(\\\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\\\n:u' +. ds q o\h'-\w'o'u*8/10'\s-4\v'.4m'\z\(*i\v'-.4m'\s+4\h'\w'o'u*8/10' +.\} +. \" troff and (daisy-wheel) nroff accents +.ds : \\\\k:\h'-(\\\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\\\n:u'\v'\*(#V' +.ds 8 \h'\*(#H'\(*b\h'-\*(#H' +.ds v \\\\k:\h'-(\\\\n(.wu*9/10-\*(#H)'\v'-\*(#V'\*(#[\s-4v\s0\v'\*(#V'\h'|\\\\n:u'\*(#] +.ds _ \\\\k:\h'-(\\\\n(.wu*9/10-\*(#H+(\*(#F*2/3))'\v'-.4m'\z\(hy\v'.4m'\h'|\\\\n:u' +.ds . \\\\k:\h'-(\\\\n(.wu*8/10)'\v'\*(#V*4/10'\z.\v'-\*(#V*4/10'\h'|\\\\n:u' +.ds 3 \*(#[\v'.2m'\s-2\&3\s0\v'-.2m'\*(#] +.ds o \\\\k:\h'-(\\\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\\\n:u'\*(#] +.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' +.ds D- D\\\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\\\n:u' +.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] +.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] +.ds ae a\h'-(\w'a'u*4/10)'e +.ds Ae A\h'-(\w'A'u*4/10)'E +.ds oe o\h'-(\w'o'u*4/10)'e +.ds Oe O\h'-(\w'O'u*4/10)'E +. \" corrections for vroff +.if v .ds ~ \\\\k:\h'-(\\\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\\\n:u' +.if v .ds ^ \\\\k:\h'-(\\\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\\\n:u' +. \" for low resolution devices (crt and lpr) +.if \n(.H>23 .if \n(.V>19 \ +\{\ +. ds : e +. ds 8 ss +. ds v \h'-1'\o'\(aa\(ga' +. ds _ \h'-1'^ +. ds . \h'-1'. +. ds 3 3 +. ds o a +. ds d- d\h'-1'\(ga +. ds D- D\h'-1'\(hy +. ds th \o'bp' +. ds Th \o'LP' +. ds ae ae +. ds Ae AE +. ds oe oe +. ds Oe OE +.\} +.rm #[ #] #H #V #F C +END + +$indent = 0; + +while (<>) { + if ($cutting) { + next unless /^=/; + $cutting = 0; + } + chomp; + + # Translate verbatim paragraph + + if (/^\s/) { + @lines = split(/\n/); + for (@lines) { + 1 while s + {^( [^\t]* ) \t ( \t* ) } + { $1 . ' ' x (8 - (length($1)%8) + 8 * (length($2))) }ex; + s/\\/\\e/g; + s/\A/\\&/s; + } + $lines = @lines; + makespace() unless $verbatim++; + print ".Vb $lines\n"; + print join("\n", @lines), "\n"; + print ".Ve\n"; + $needspace = 0; + next; + } + + $verbatim = 0; + + # check for things that'll hosed our noremap scheme; affects $_ + init_noremap(); + + if (!/^=item/) { + + # trofficate backslashes; must do it before what happens below + s/\\/noremap('\\e')/ge; + + # first hide the escapes in case we need to + # intuit something and get it wrong due to fmting + + s/([A-Z]<[^<>]*>)/noremap($1)/ge; + + # func() is a reference to a perl function + s{ + \b + ( + [:\w]+ \(\) + ) + } {I<$1>}gx; + + # func(n) is a reference to a man page + s{ + (\w+) + ( + \( + [^\s,\051]+ + \) + ) + } {I<$1>\\|$2}gx; + + # convert simple variable references + s/([\$\@%][\w:]+)/C<$1>/g; + + if (m{ ( + [\-\w]+ + \( + [^\051]*? + [\@\$,] + [^\051]*? + \) + ) + }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/) + { + warn "``$1'' should be a [LCI]<$1> ref"; + } + + while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) { + warn "``$1'' should be [CB]<$1> ref"; + } + + # put it back so we get the <> processed again; + clear_noremap(0); # 0 means leave the E's + + } else { + # trofficate backslashes + s/\\/noremap('\\e')/ge; + + } + + # need to hide E<> first; they're processed in clear_noremap + s/(E<[^<>]+>)/noremap($1)/ge; + + + $maxnest = 10; + while ($maxnest-- && /[A-Z]</) { + + # can't do C font here + s/([BI])<([^<>]*)>/font($1) . $2 . font('R')/eg; + + # files and filelike refs in italics + s/F<([^<>]*)>/I<$1>/g; + + # no break -- usually we want C<> for this + s/S<([^<>]*)>/nobreak($1)/eg; + + # LREF: a manpage(3f) + s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the I<$1>$2 manpage:g; + + # LREF: an =item on another manpage + s{ + L< + ([^/]+) + / + ( + [:\w]+ + (\(\))? + ) + > + } {the C<$2> entry in the I<$1> manpage}gx; + + # LREF: an =item on this manpage + s{ + ((?: + L< + / + ( + [:\w]+ + (\(\))? + ) + > + (,?\s+(and\s+)?)? + )+) + } { internal_lrefs($1) }gex; + + # LREF: a =head2 (head1?), maybe on a manpage, maybe right here + # the "func" can disambiguate + s{ + L< + (?: + ([a-zA-Z]\S+?) / + )? + "?(.*?)"? + > + }{ + do { + $1 # if no $1, assume it means on this page. + ? "the section on I<$2> in the I<$1> manpage" + : "the section on I<$2>" + } + }gex; + + s/Z<>/\\&/g; + + # comes last because not subject to reprocessing + s/C<([^<>]*)>/noremap("${CFont_embed}${1}\\fR")/eg; + } + + if (s/^=//) { + $needspace = 0; # Assume this. + + s/\n/ /g; + + ($Cmd, $_) = split(' ', $_, 2); + + if (defined $_) { + &escapes; + s/"/""/g; + } + + clear_noremap(1); + + if ($Cmd eq 'cut') { + $cutting = 1; + } + elsif ($Cmd eq 'head1') { + print qq{.SH "$_"\n} + } + elsif ($Cmd eq 'head2') { + print qq{.Sh "$_"\n} + } + elsif ($Cmd eq 'over') { + push(@indent,$indent); + $indent = $_ + 0; + } + elsif ($Cmd eq 'back') { + $indent = pop(@indent); + warn "Unmatched =back\n" unless defined $indent; + $needspace = 1; + } + elsif ($Cmd eq 'item') { + s/^\*( |$)/\\(bu$1/g; + print STDOUT qq{.Ip "$_" $indent\n}; + } + else { + warn "Unrecognized directive: $Cmd\n"; + } + } + else { + if ($needspace) { + &makespace; + } + &escapes; + clear_noremap(1); + print $_, "\n"; + $needspace = 1; + } +} + +print <<"END"; + +.rn }` '' +END + +######################################################################### + +sub nobreak { + my $string = shift; + $string =~ s/ /\\ /g; + $string; +} + +sub escapes { + + # translate the minus in foo-bar into foo\-bar for roff + s/([^0-9a-z-])-([^-])/$1\\-$2/g; + + # make -- into the string version \*(-- (defined above) + s/\b--\b/\\*(--/g; + s/"--([^"])/"\\*(--$1/g; # should be a better way + s/([^"])--"/$1\\*(--"/g; + + # fix up quotes; this is somewhat tricky + if (!/""/) { + s/(^|\s)(['"])/noremap("$1\\*(L$2")/ge; + s/(['"])($|[\-\s,;\\!?.])/noremap("\\*(R$1$2")/ge; + } + + #s/(?!")(?:.)--(?!")(?:.)/\\*(--/g; + #s/(?:(?!")(?:.)--(?:"))|(?:(?:")--(?!")(?:.))/\\*(--/g; + + + # make sure that func() keeps a bit a space tween the parens + ### s/\b\(\)/\\|()/g; + ### s/\b\(\)/(\\|)/g; + + # make C++ into \*C+, which is a squinched version (defined above) + s/\bC\+\+/\\*(C+/g; + + # make double underbars have a little tiny space between them + s/__/_\\|_/g; + + # PI goes to \*(-- (defined above) + s/\bPI\b/noremap('\\*(PI')/ge; + + # make all caps a teeny bit smaller, but don't muck with embedded code literals + my $hidCFont = font('C'); + if ($Cmd !~ /^head1/) { # SH already makes smaller + # /g isn't enough; 1 while or we'll be off + +# 1 while s{ +# (?!$hidCFont)(..|^.|^) +# \b +# ( +# [A-Z][\/A-Z+:\-\d_$.]+ +# ) +# (s?) +# \b +# } {$1\\s-1$2\\s0}gmox; + + 1 while s{ + (?!$hidCFont)(..|^.|^) + ( + \b[A-Z]{2,}[\/A-Z+:\-\d_\$]*\b + ) + } { + $1 . noremap( '\\s-1' . $2 . '\\s0' ) + }egmox; + + } +} + +# make troff just be normal, but make small nroff get quoted +# decided to just put the quotes in the text; sigh; +sub ccvt { + local($_,$prev) = @_; + if ( /^\W+$/ && !/^\$./ ) { + ($prev && "\n") . noremap(qq{.CQ $_ \n\\&}); + # what about $" ? + } else { + noremap(qq{${CFont_embed}$_\\fR}); + } + noremap(qq{.CQ "$_" \n\\&}); +} + +sub makespace { + if ($indent) { + print ".Sp\n"; + } + else { + print ".PP\n"; + } +} + +sub font { + local($font) = shift; + return '\\f' . noremap($font); +} + +sub noremap { + local($thing_to_hide) = shift; + $thing_to_hide =~ tr/\000-\177/\200-\377/; + return $thing_to_hide; +} + +sub init_noremap { + if ( /[\200-\377]/ ) { + warn "hit bit char in input stream"; + } +} + +sub clear_noremap { + my $ready_to_print = $_[0]; + + tr/\200-\377/\000-\177/; + + # trofficate backslashes + # s/(?!\\e)(?:..|^.|^)\\/\\e/g; + + # now for the E<>s, which have been hidden until now + # otherwise the interative \w<> processing would have + # been hosed by the E<gt> + s { + E< + ( [A-Za-z]+ ) + > + } { + do { + exists $HTML_Escapes{$1} + ? do { $HTML_Escapes{$1} } + : do { + warn "Unknown escape: $& in $_"; + "E<$1>"; + } + } + }egx if $ready_to_print; +} + +sub internal_lrefs { + local($_) = shift; + + s{L</([^>]+)>}{$1}g; + my(@items) = split( /(?:,?\s+(?:and\s+)?)/ ); + my $retstr = "the "; + my $i; + for ($i = 0; $i <= $#items; $i++) { + $retstr .= "C<$items[$i]>"; + $retstr .= ", " if @items > 2 && $i != $#items; + $retstr .= " and " if $i+2 == @items; + } + + $retstr .= " entr" . ( @items > 1 ? "ies" : "y" ) + . " elsewhere in this document"; + + return $retstr; + +} + +BEGIN { +%HTML_Escapes = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "A\\*'", # capital A, acute accent + "aacute" => "a\\*'", # small a, acute accent + "Acirc" => "A\\*^", # capital A, circumflex accent + "acirc" => "a\\*^", # small a, circumflex accent + "AElig" => '\*(AE', # capital AE diphthong (ligature) + "aelig" => '\*(ae', # small ae diphthong (ligature) + "Agrave" => "A\\*`", # capital A, grave accent + "agrave" => "A\\*`", # small a, grave accent + "Aring" => 'A\\*o', # capital A, ring + "aring" => 'a\\*o', # small a, ring + "Atilde" => 'A\\*~', # capital A, tilde + "atilde" => 'a\\*~', # small a, tilde + "Auml" => 'A\\*:', # capital A, dieresis or umlaut mark + "auml" => 'a\\*:', # small a, dieresis or umlaut mark + "Ccedil" => 'C\\*,', # capital C, cedilla + "ccedil" => 'c\\*,', # small c, cedilla + "Eacute" => "E\\*'", # capital E, acute accent + "eacute" => "e\\*'", # small e, acute accent + "Ecirc" => "E\\*^", # capital E, circumflex accent + "ecirc" => "e\\*^", # small e, circumflex accent + "Egrave" => "E\\*`", # capital E, grave accent + "egrave" => "e\\*`", # small e, grave accent + "ETH" => '\\*(D-', # capital Eth, Icelandic + "eth" => '\\*(d-', # small eth, Icelandic + "Euml" => "E\\*:", # capital E, dieresis or umlaut mark + "euml" => "e\\*:", # small e, dieresis or umlaut mark + "Iacute" => "I\\*'", # capital I, acute accent + "iacute" => "i\\*'", # small i, acute accent + "Icirc" => "I\\*^", # capital I, circumflex accent + "icirc" => "i\\*^", # small i, circumflex accent + "Igrave" => "I\\*`", # capital I, grave accent + "igrave" => "i\\*`", # small i, grave accent + "Iuml" => "I\\*:", # capital I, dieresis or umlaut mark + "iuml" => "i\\*:", # small i, dieresis or umlaut mark + "Ntilde" => 'N\*~', # capital N, tilde + "ntilde" => 'n\*~', # small n, tilde + "Oacute" => "O\\*'", # capital O, acute accent + "oacute" => "o\\*'", # small o, acute accent + "Ocirc" => "O\\*^", # capital O, circumflex accent + "ocirc" => "o\\*^", # small o, circumflex accent + "Ograve" => "O\\*`", # capital O, grave accent + "ograve" => "o\\*`", # small o, grave accent + "Oslash" => "O\\*/", # capital O, slash + "oslash" => "o\\*/", # small o, slash + "Otilde" => "O\\*~", # capital O, tilde + "otilde" => "o\\*~", # small o, tilde + "Ouml" => "O\\*:", # capital O, dieresis or umlaut mark + "ouml" => "o\\*:", # small o, dieresis or umlaut mark + "szlig" => '\*8', # small sharp s, German (sz ligature) + "THORN" => '\\*(Th', # capital THORN, Icelandic + "thorn" => '\\*(th',, # small thorn, Icelandic + "Uacute" => "U\\*'", # capital U, acute accent + "uacute" => "u\\*'", # small u, acute accent + "Ucirc" => "U\\*^", # capital U, circumflex accent + "ucirc" => "u\\*^", # small u, circumflex accent + "Ugrave" => "U\\*`", # capital U, grave accent + "ugrave" => "u\\*`", # small u, grave accent + "Uuml" => "U\\*:", # capital U, dieresis or umlaut mark + "uuml" => "u\\*:", # small u, dieresis or umlaut mark + "Yacute" => "Y\\*'", # capital Y, acute accent + "yacute" => "y\\*'", # small y, acute accent + "yuml" => "y\\*:", # small y, dieresis or umlaut mark +); +} diff --git a/pod/splitman b/pod/splitman new file mode 100755 index 0000000000..9fe404a061 --- /dev/null +++ b/pod/splitman @@ -0,0 +1,46 @@ +#!/usr/bin/perl + +while (<>) { + if ($seqno = 1 .. /^\.TH/) { + unless ($seqno =~ /e/i) { + $header .= $_; + } + next; + } + + if ( /^\.Ip\s*"(.*)"\s*\d+$/) { + $desking = 0; + $desc = $1; + if (name($desc) ne $myname) { + $myname = name($desc); + print $myname, "\n"; + open(MAN, "> $myname.3pl"); + print MAN <<EOALL; +$header +.TH $myname 3PL "\\*(RP" +.SH NAME +$myname +.SH SYNOPSIS +.B $desc +EOALL + } else { + print MAN <<EOMORE; +.br +.ti +3n +or +.br +.B $desc +EOMORE + } + next; + } + unless ($desking) { + print MAN ".SH DESCRIPTION\n"; + $desking = 1; + } + print MAN; +} + +sub name { + ($_[0] =~ /(\w+)/)[0]; +} @@ -1,111 +1,23 @@ -/*********************************************************** +/* pp.c * - * $Header: /usr/src/local/lwall/perl5/RCS/pp.c, v 4.1 92/08/07 18:26:21 lwall Exp Locker: lwall $ + * Copyright (c) 1991-1994, Larry Wall * - * Description: - * Push/Pop code. + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. * - * Standards: - * - * Created: - * Mon Jun 15 16:45:59 1992 - * - * Author: - * Larry Wall <lwall@netlabs.com> - * - * $Log: pp.c, v $ - * Revision 4.1 92/08/07 18:26:21 lwall - * - * - **********************************************************/ + */ + +/* + * "It's a big house this, and very peculiar. Always a bit more to discover, + * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise + */ #include "EXTERN.h" #include "perl.h" -#ifdef HAS_SOCKET -# include <sys/socket.h> -# include <netdb.h> -# ifndef ENOTSOCK -# ifdef I_NET_ERRNO -# include <net/errno.h> -# endif -# endif -#endif - -#ifdef HAS_SELECT -#ifdef I_SYS_SELECT -#ifndef I_SYS_TIME -#include <sys/select.h> -#endif -#endif -#endif - -#ifdef HOST_NOT_FOUND -extern int h_errno; -#endif - -#ifdef HAS_PASSWD -# ifdef I_PWD -# include <pwd.h> -# else - struct passwd *getpwnam P((char *)); - struct passwd *getpwuid P((Uid_t)); -# endif - struct passwd *getpwent(); -#endif - -#ifdef HAS_GROUP -# ifdef I_GRP -# include <grp.h> -# else - struct group *getgrnam P((char *)); - struct group *getgrgid P((Gid_t)); -# endif - struct group *getgrent(); -#endif - -#ifdef I_UTIME -#include <utime.h> -#endif -#ifdef I_FCNTL -#include <fcntl.h> -#endif -#ifdef I_SYS_FILE -#include <sys/file.h> -#endif - -#ifdef HAS_GETPGRP2 -# define getpgrp getpgrp2 -#endif - -#ifdef HAS_SETPGRP2 -# define setpgrp setpgrp2 -#endif - -#ifdef HAS_GETPGRP2 -# define getpgrp getpgrp2 -#endif - -#ifdef HAS_SETPGRP2 -# define setpgrp setpgrp2 -#endif - -#ifdef HAS_GETPGRP2 -# define getpgrp getpgrp2 -#endif - -#ifdef HAS_SETPGRP2 -# define setpgrp setpgrp2 -#endif +static void doencodes _((SV *sv, char *s, I32 len)); -static I32 dopoptosub P((I32 startingblock)); - -/* Nothing. */ - -PP(pp_null) -{ - return NORMAL; -} +/* variations on pp_null */ PP(pp_stub) { @@ -123,106 +35,13 @@ PP(pp_scalar) /* Pushy stuff. */ -PP(pp_pushmark) -{ - if (++markstack_ptr == markstack_max) { - I32 oldmax = markstack_max - markstack; - I32 newmax = oldmax * 3 / 2; - - Renew(markstack, newmax, I32); - markstack_ptr = markstack + oldmax; - markstack_max = markstack + newmax; - } - *markstack_ptr = stack_sp - stack_base; - return NORMAL; -} - -PP(pp_wantarray) -{ - dSP; - I32 cxix; - EXTEND(SP, 1); - - cxix = dopoptosub(cxstack_ix); - if (cxix < 0) - RETPUSHUNDEF; - - if (cxstack[cxix].blk_gimme == G_ARRAY) - RETPUSHYES; - else - RETPUSHNO; -} - -PP(pp_const) -{ - dSP; - XPUSHs(cSVOP->op_sv); - RETURN; -} - -static void -ucase(s,send) -register char *s; -register char *send; -{ - while (s < send) { - if (isLOWER(*s)) - *s = toupper(*s); - s++; - } -} - -static void -lcase(s,send) -register char *s; -register char *send; -{ - while (s < send) { - if (isUPPER(*s)) - *s = tolower(*s); - s++; - } -} - -PP(pp_interp) -{ - DIE("panic: pp_interp"); -} - -PP(pp_gvsv) -{ - dSP; - EXTEND(sp,1); - if (op->op_flags & OPf_INTRO) - PUSHs(save_scalar(cGVOP->op_gv)); - else - PUSHs(GvSV(cGVOP->op_gv)); - RETURN; -} - -PP(pp_gv) -{ - dSP; - XPUSHs((SV*)cGVOP->op_gv); - RETURN; -} - -PP(pp_padsv) -{ - dSP; dTARGET; - XPUSHs(TARG); - if (op->op_flags & OPf_INTRO) - SAVECLEARSV(curpad[op->op_targ]); - RETURN; -} - PP(pp_padav) { dSP; dTARGET; - if (op->op_flags & OPf_INTRO) + if (op->op_private & OPpLVAL_INTRO) SAVECLEARSV(curpad[op->op_targ]); EXTEND(SP, 1); - if (op->op_flags & OPf_LVAL) { + if (op->op_flags & OPf_REF) { PUSHs(TARG); RETURN; } @@ -245,12 +64,12 @@ PP(pp_padhv) { dSP; dTARGET; XPUSHs(TARG); - if (op->op_flags & OPf_INTRO) + if (op->op_private & OPpLVAL_INTRO) SAVECLEARSV(curpad[op->op_targ]); - if (op->op_flags & OPf_LVAL) + if (op->op_flags & OPf_REF) RETURN; if (GIMME == G_ARRAY) { /* array wanted */ - return do_kv(ARGS); + RETURNOP(do_kv(ARGS)); } else { SV* sv = sv_newmortal(); @@ -270,33 +89,37 @@ PP(pp_padany) DIE("NOT IMPL LINE %d",__LINE__); } -PP(pp_pushre) -{ - dSP; - XPUSHs((SV*)op); - RETURN; -} - /* Translations. */ PP(pp_rv2gv) { dSP; dTOPss; + if (SvROK(sv)) { + wasref: sv = SvRV(sv); if (SvTYPE(sv) != SVt_PVGV) - DIE("Not a symbol reference"); + DIE("Not a GLOB reference"); } else { if (SvTYPE(sv) != SVt_PVGV) { - if (!SvOK(sv)) - DIE(no_usym, "a symbol"); + if (SvGMAGICAL(sv)) { + mg_get(sv); + if (SvROK(sv)) + goto wasref; + } + if (!SvOK(sv)) { + if (op->op_flags & OPf_REF || + op->op_private & HINT_STRICT_REFS) + DIE(no_usym, "a symbol"); + RETSETUNDEF; + } if (op->op_private & HINT_STRICT_REFS) - DIE(no_hardref, "a symbol"); + DIE(no_symref, "a symbol"); sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE, SVt_PVGV); } } - if (op->op_flags & OPf_INTRO) { + if (op->op_private & OPpLVAL_INTRO) { GP *ogp = GvGP(sv); SSCHECK(3); @@ -304,8 +127,10 @@ PP(pp_rv2gv) SSPUSHPTR(ogp); SSPUSHINT(SAVEt_GP); - if (op->op_flags & OPf_SPECIAL) + if (op->op_flags & OPf_SPECIAL) { GvGP(sv)->gp_refcnt++; /* will soon be assigned */ + GvFLAGS(sv) |= GVf_INTRO; + } else { GP *gp; Newz(602,gp, 1, GP); @@ -333,55 +158,51 @@ PP(pp_rv2sv) dSP; dTOPss; if (SvROK(sv)) { + wasref: sv = SvRV(sv); switch (SvTYPE(sv)) { case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: - DIE("Not a scalar reference"); + DIE("Not a SCALAR reference"); } } else { GV *gv = sv; if (SvTYPE(gv) != SVt_PVGV) { - if (!SvOK(sv)) - DIE(no_usym, "a scalar"); + if (SvGMAGICAL(sv)) { + mg_get(sv); + if (SvROK(sv)) + goto wasref; + } + if (!SvOK(sv)) { + if (op->op_flags & OPf_REF || + op->op_private & HINT_STRICT_REFS) + DIE(no_usym, "a SCALAR"); + RETSETUNDEF; + } if (op->op_private & HINT_STRICT_REFS) - DIE(no_hardref, "a scalar"); + DIE(no_symref, "a SCALAR"); gv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE, SVt_PV); } sv = GvSV(gv); - if (op->op_private & (OPpDEREF_AV|OPpDEREF_HV)) { - if (op->op_private & OPpDEREF_HV && - (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVHV)) { - if (op->op_private & HINT_STRICT_REFS && !SvROK(sv) && SvOK(sv)) - DIE(no_hardref, "a hash"); - SvREFCNT_dec(sv); - sv = NEWSV(0,0); - sv_upgrade(sv, SVt_RV); - SvRV(sv) = SvREFCNT_inc(newHV()); - SvROK_on(sv); - ++sv_rvcount; - GvSV(gv) = sv; - } - else if (op->op_private & OPpDEREF_AV && - (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV)) { - if (op->op_private & HINT_STRICT_REFS && !SvROK(sv) && SvOK(sv)) - DIE(no_hardref, "an array"); - SvREFCNT_dec(sv); - sv = NEWSV(0,0); - sv_upgrade(sv, SVt_RV); - SvRV(sv) = SvREFCNT_inc(newAV()); + } + if (op->op_flags & OPf_MOD) { + if (op->op_private & OPpLVAL_INTRO) + sv = save_scalar((GV*)TOPs); + else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) { + if (SvGMAGICAL(sv)) + mg_get(sv); + if (!SvOK(sv)) { + (void)SvUPGRADE(sv, SVt_RV); + SvRV(sv) = (op->op_private & OPpDEREF_HV ? + (SV*)newHV() : (SV*)newAV()); SvROK_on(sv); - ++sv_rvcount; - GvSV(gv) = sv; + SvSETMAGIC(sv); } } } - if (op->op_flags & OPf_INTRO) - SETs(save_scalar((GV*)TOPs)); - else - SETs(sv); + SETs(sv); RETURN; } @@ -399,10 +220,33 @@ PP(pp_av2arylen) RETURN; } +PP(pp_pos) +{ + dSP; dTARGET; dPOPss; + + if (op->op_flags & OPf_MOD) { + LvTYPE(TARG) = '<'; + LvTARG(TARG) = sv; + PUSHs(TARG); /* no SvSETMAGIC */ + RETURN; + } + else { + MAGIC* mg; + + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + mg = mg_find(sv, 'g'); + if (mg && mg->mg_len >= 0) { + PUSHi(mg->mg_len + curcop->cop_arybase); + RETURN; + } + } + RETPUSHUNDEF; + } +} + PP(pp_rv2cv) { dSP; - SV *sv; GV *gv; HV *stash; @@ -413,19 +257,55 @@ PP(pp_rv2cv) RETURN; } -PP(pp_refgen) +PP(pp_anoncode) +{ + dSP; + XPUSHs(cSVOP->op_sv); + RETURN; +} + +PP(pp_srefgen) { dSP; dTOPss; SV* rv; - if (!sv) - RETSETUNDEF; rv = sv_newmortal(); sv_upgrade(rv, SVt_RV); - SvRV(rv) = SvREFCNT_inc(sv); + if (SvPADTMP(sv)) + sv = newSVsv(sv); + else { + SvTEMP_off(sv); + (void)SvREFCNT_inc(sv); + } + SvRV(rv) = sv; SvROK_on(rv); - ++sv_rvcount; SETs(rv); RETURN; +} + +PP(pp_refgen) +{ + dSP; dMARK; + SV* sv; + SV* rv; + if (GIMME != G_ARRAY) { + MARK[1] = *SP; + SP = MARK + 1; + } + while (MARK < SP) { + sv = *++MARK; + rv = sv_newmortal(); + sv_upgrade(rv, SVt_RV); + if (SvPADTMP(sv)) + sv = newSVsv(sv); + else { + SvTEMP_off(sv); + (void)SvREFCNT_inc(sv); + } + SvRV(rv) = sv; + SvROK_on(rv); + *MARK = rv; + } + RETURN; } PP(pp_ref) @@ -434,43 +314,12 @@ PP(pp_ref) SV *sv; char *pv; - if (MAXARG < 1) { - sv = GvSV(defgv); - EXTEND(SP, 1); - } - else - sv = POPs; - if (!SvROK(sv)) + sv = POPs; + if (!sv || !SvROK(sv)) RETPUSHUNDEF; sv = SvRV(sv); - if (SvOBJECT(sv)) - pv = HvNAME(SvSTASH(sv)); - else { - switch (SvTYPE(sv)) { - case SVt_NULL: - case SVt_IV: - case SVt_NV: - case SVt_RV: - case SVt_PV: - case SVt_PVIV: - case SVt_PVNV: - case SVt_PVMG: - case SVt_PVBM: - if (SvROK(sv)) - pv = "REF"; - else - pv = "SCALAR"; - break; - case SVt_PVLV: pv = "LVALUE"; break; - case SVt_PVAV: pv = "ARRAY"; break; - case SVt_PVHV: pv = "HASH"; break; - case SVt_PVCV: pv = "CODE"; break; - case SVt_PVGV: pv = "GLOB"; break; - case SVt_PVFM: pv = "FORMLINE"; break; - default: pv = "UNKNOWN"; break; - } - } + pv = sv_reftype(sv,TRUE); PUSHp(pv, strlen(pv)); RETURN; } @@ -478,763 +327,84 @@ PP(pp_ref) PP(pp_bless) { dSP; - register SV* ref; - SV *sv; HV *stash; if (MAXARG == 1) stash = curcop->cop_stash; else - stash = fetch_stash(POPs, TRUE); - - sv = TOPs; - if (!SvROK(sv)) - DIE("Can't bless non-reference value"); - ref = SvRV(sv); - SvOBJECT_on(ref); - SvUPGRADE(ref, SVt_PVMG); - SvSTASH(ref) = (HV*)SvREFCNT_inc(stash); - RETURN; -} - -/* Pushy I/O. */ - -PP(pp_backtick) -{ - dSP; dTARGET; - FILE *fp; - char *tmps = POPp; - TAINT_PROPER("``"); - fp = my_popen(tmps, "r"); - if (fp) { - sv_setpv(TARG, ""); /* note that this preserves previous buffer */ - if (GIMME == G_SCALAR) { - while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch) - /*SUPPRESS 530*/ - ; - XPUSHs(TARG); - } - else { - SV *sv; - - for (;;) { - sv = NEWSV(56, 80); - if (sv_gets(sv, fp, 0) == Nullch) { - SvREFCNT_dec(sv); - break; - } - XPUSHs(sv_2mortal(sv)); - if (SvLEN(sv) - SvCUR(sv) > 20) { - SvLEN_set(sv, SvCUR(sv)+1); - Renew(SvPVX(sv), SvLEN(sv), char); - } - } - } - statusvalue = my_pclose(fp); - } - else { - statusvalue = -1; - if (GIMME == G_SCALAR) - RETPUSHUNDEF; - } + stash = gv_stashsv(POPs, TRUE); + (void)sv_bless(TOPs, stash); RETURN; } -OP * -do_readline() -{ - dSP; dTARGETSTACKED; - register SV *sv; - STRLEN tmplen; - STRLEN offset; - FILE *fp; - register IO *io = GvIO(last_in_gv); - register I32 type = op->op_type; - - fp = Nullfp; - if (io) { - fp = IoIFP(io); - if (!fp) { - if (IoFLAGS(io) & IOf_ARGV) { - if (IoFLAGS(io) & IOf_START) { - IoFLAGS(io) &= ~IOf_START; - IoLINES(io) = 0; - if (av_len(GvAVn(last_in_gv)) < 0) { - SV *tmpstr = newSVpv("-", 1); /* assume stdin */ - (void)av_push(GvAVn(last_in_gv), tmpstr); - } - } - fp = nextargv(last_in_gv); - if (!fp) { /* Note: fp != IoIFP(io) */ - (void)do_close(last_in_gv, FALSE); /* now it does*/ - IoFLAGS(io) |= IOf_START; - } - } - else if (type == OP_GLOB) { - SV *tmpcmd = NEWSV(55, 0); - SV *tmpglob = POPs; - ENTER; - SAVEFREESV(tmpcmd); -#ifdef 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); - sv_catpv(tmpcmd, "'|"); -#else - sv_setpv(tmpcmd, "echo "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); -#endif /* !CSH */ -#endif /* !MSDOS */ - (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd)); - fp = IoIFP(io); - LEAVE; - } - } - else if (type == OP_GLOB) - SP--; - } - if (!fp) { - if (dowarn) - warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); - if (GIMME == G_SCALAR) - RETPUSHUNDEF; - RETURN; - } - if (GIMME == G_ARRAY) { - sv = sv_2mortal(NEWSV(57, 80)); - offset = 0; - } - else { - sv = TARG; - SvUPGRADE(sv, SVt_PV); - tmplen = SvLEN(sv); /* remember if already alloced */ - if (!tmplen) - Sv_Grow(sv, 80); /* try short-buffering it */ - if (type == OP_RCATLINE) - offset = SvCUR(sv); - else - offset = 0; - } - for (;;) { - if (!sv_gets(sv, fp, offset)) { - clearerr(fp); - if (IoFLAGS(io) & IOf_ARGV) { - fp = nextargv(last_in_gv); - if (fp) - continue; - (void)do_close(last_in_gv, FALSE); - IoFLAGS(io) |= IOf_START; - } - else if (type == OP_GLOB) { - (void)do_close(last_in_gv, FALSE); - } - if (GIMME == G_SCALAR) - RETPUSHUNDEF; - RETURN; - } - IoLINES(io)++; - XPUSHs(sv); - if (tainting) { - tainted = TRUE; - SvTAINT(sv); /* Anything from the outside world...*/ - } - if (type == OP_GLOB) { - char *tmps; - - if (SvCUR(sv) > 0) - SvCUR(sv)--; - if (*SvEND(sv) == rschar) - *SvEND(sv) = '\0'; - else - SvCUR(sv)++; - for (tmps = SvPVX(sv); *tmps; tmps++) - if (!isALPHA(*tmps) && !isDIGIT(*tmps) && - strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) - break; - if (*tmps && stat(SvPVX(sv), &statbuf) < 0) { - POPs; /* Unmatched wildcard? Chuck it... */ - continue; - } - } - if (GIMME == G_ARRAY) { - if (SvLEN(sv) - SvCUR(sv) > 20) { - SvLEN_set(sv, SvCUR(sv)+1); - Renew(SvPVX(sv), SvLEN(sv), char); - } - sv = sv_2mortal(NEWSV(58, 80)); - continue; - } - else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) { - /* try to reclaim a bit of scalar space (only on 1st alloc) */ - if (SvCUR(sv) < 60) - SvLEN_set(sv, 80); - else - SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */ - Renew(SvPVX(sv), SvLEN(sv), char); - } - RETURN; - } -} - -PP(pp_glob) -{ - OP *result; - ENTER; - SAVEINT(rschar); - SAVEINT(rslen); - - SAVESPTR(last_in_gv); /* We don't want this to be permanent. */ - last_in_gv = (GV*)*stack_sp--; - - rslen = 1; -#ifdef DOSISH - rschar = 0; -#else -#ifdef CSH - rschar = 0; -#else - rschar = '\n'; -#endif /* !CSH */ -#endif /* !MSDOS */ - result = do_readline(); - LEAVE; - return result; -} - -PP(pp_readline) -{ - last_in_gv = (GV*)(*stack_sp--); - return do_readline(); -} - -PP(pp_indread) -{ - last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*stack_sp--)), na), TRUE,SVt_PVIO); - return do_readline(); -} - -PP(pp_rcatline) -{ - last_in_gv = cGVOP->op_gv; - return do_readline(); -} - -PP(pp_regcmaybe) -{ - return NORMAL; -} - -PP(pp_regcomp) { - dSP; - register PMOP *pm = (PMOP*)cLOGOP->op_other; - register char *t; - SV *tmpstr; - STRLEN len; - - tmpstr = POPs; - t = SvPV(tmpstr, len); - - if (pm->op_pmregexp) { - regfree(pm->op_pmregexp); - pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ - } - - pm->op_pmregexp = regcomp(t, t + len, pm->op_pmflags & PMf_FOLD); - - if (!pm->op_pmregexp->prelen && curpm) - pm = curpm; - else if (strEQ("\\s+", pm->op_pmregexp->precomp)) - pm->op_pmflags |= PMf_WHITE; - - if (pm->op_pmflags & PMf_KEEP) { - if (!(pm->op_pmflags & PMf_FOLD)) - scan_prefix(pm, pm->op_pmregexp->precomp, - pm->op_pmregexp->prelen); - pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */ - hoistmust(pm); - cLOGOP->op_first->op_next = op->op_next; - /* XXX delete push code? */ - } - RETURN; -} +/* Pattern matching */ -PP(pp_match) +PP(pp_study) { - dSP; dTARG; - register PMOP *pm = cPMOP; - register char *t; - register char *s; - char *strend; - SV *tmpstr; - I32 global; - I32 safebase; - char *truebase; - register REGEXP *rx = pm->op_pmregexp; - I32 gimme = GIMME; + dSP; dTARGET; + register unsigned char *s; + register I32 pos; + register I32 ch; + register I32 *sfirst; + register I32 *snext; + I32 retval; STRLEN len; - if (op->op_flags & OPf_STACKED) - TARG = POPs; - else { - TARG = GvSV(defgv); - EXTEND(SP,1); - } - s = SvPV(TARG, len); - strend = s + len; - if (!s) - DIE("panic: do_match"); - - if (pm->op_pmflags & PMf_USED) { - if (gimme == G_ARRAY) - RETURN; - RETPUSHNO; - } - - if (!rx->prelen && curpm) { - pm = curpm; - rx = pm->op_pmregexp; - } - truebase = t = s; - if (global = pm->op_pmflags & PMf_GLOBAL) { - rx->startp[0] = 0; - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, 'g'); - if (mg && mg->mg_ptr) { - rx->startp[0] = mg->mg_ptr; - rx->endp[0] = mg->mg_ptr + mg->mg_len; - } - } - } - safebase = (gimme == G_ARRAY) || global; - -play_it_again: - if (global && rx->startp[0]) { - t = s = rx->endp[0]; - if (s == rx->startp[0]) - s++, t++; - if (s > strend) - goto nope; - } - if (pm->op_pmshort) { - if (pm->op_pmflags & PMf_SCANFIRST) { - if (SvSCREAM(TARG)) { - if (screamfirst[BmRARE(pm->op_pmshort)] < 0) - goto nope; - else if (!(s = screaminstr(TARG, pm->op_pmshort))) - goto nope; - else if (pm->op_pmflags & PMf_ALL) - goto yup; - } - else if (!(s = fbm_instr((unsigned char*)s, - (unsigned char*)strend, pm->op_pmshort))) - goto nope; - else if (pm->op_pmflags & PMf_ALL) - goto yup; - if (s && rx->regback >= 0) { - ++BmUSEFUL(pm->op_pmshort); - s -= rx->regback; - if (s < t) - s = t; - } - else - s = t; - } - else if (!multiline) { - if (*SvPVX(pm->op_pmshort) != *s || - bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) { - if (pm->op_pmflags & PMf_FOLD) { - if (ibcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) - goto nope; - } - else - goto nope; - } - } - if (--BmUSEFUL(pm->op_pmshort) < 0) { - SvREFCNT_dec(pm->op_pmshort); - pm->op_pmshort = Nullsv; /* opt is being useless */ - } - } - if (!rx->nparens && !global) { - gimme = G_SCALAR; /* accidental array context? */ - safebase = FALSE; - } - if (regexec(rx, s, strend, truebase, 0, - SvSCREAM(TARG) ? TARG : Nullsv, - safebase)) { - curpm = pm; - if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; - goto gotcha; + s = (unsigned char*)(SvPV(TARG, len)); + pos = len; + if (lastscream) + SvSCREAM_off(lastscream); + lastscream = TARG; + if (pos <= 0) { + retval = 0; + goto ret; } - else - goto ret_no; - /*NOTREACHED*/ - - gotcha: - if (gimme == G_ARRAY) { - I32 iters, i, len; - - iters = rx->nparens; - if (global && !iters) - i = 1; - else - i = 0; - EXTEND(SP, iters + i); - for (i = !i; i <= iters; i++) { - PUSHs(sv_newmortal()); - /*SUPPRESS 560*/ - if (s = rx->startp[i]) { - len = rx->endp[i] - s; - if (len > 0) - sv_setpvn(*SP, s, len); - } - } - if (global) { - truebase = rx->subbeg; - goto play_it_again; + if (pos > maxscream) { + if (maxscream < 0) { + maxscream = pos + 80; + New(301, screamfirst, 256, I32); + New(302, screamnext, maxscream, I32); } - RETURN; - } - else { - if (global) { - MAGIC* mg = 0; - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) - mg = mg_find(TARG, 'g'); - if (!mg) { - sv_magic(TARG, (SV*)0, 'g', Nullch, 0); - mg = mg_find(TARG, 'g'); - } - mg->mg_ptr = rx->startp[0]; - mg->mg_len = rx->endp[0] - rx->startp[0]; + else { + maxscream = pos + pos / 4; + Renew(screamnext, maxscream, I32); } - RETPUSHYES; - } - -yup: - ++BmUSEFUL(pm->op_pmshort); - curpm = pm; - if (pm->op_pmflags & PMf_ONCE) - pm->op_pmflags |= PMf_USED; - if (global) { - rx->subbeg = truebase; - rx->subend = strend; - rx->startp[0] = s; - rx->endp[0] = s + SvCUR(pm->op_pmshort); - goto gotcha; } - if (sawampersand) { - char *tmps; - - if (rx->subbase) - Safefree(rx->subbase); - tmps = rx->subbase = nsavestr(t, strend-t); - rx->subbeg = tmps; - rx->subend = tmps + (strend-t); - tmps = rx->startp[0] = tmps + (s - t); - rx->endp[0] = tmps + SvCUR(pm->op_pmshort); - } - RETPUSHYES; -nope: - if (pm->op_pmshort) - ++BmUSEFUL(pm->op_pmshort); - -ret_no: - if (global) { - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, 'g'); - if (mg) { - mg->mg_ptr = 0; - mg->mg_len = 0; - } - } - } - if (gimme == G_ARRAY) - RETURN; - RETPUSHNO; -} + sfirst = screamfirst; + snext = screamnext; -PP(pp_subst) -{ - dSP; dTARG; - register PMOP *pm = cPMOP; - PMOP *rpm = pm; - register SV *dstr; - register char *s; - char *strend; - register char *m; - char *c; - register char *d; - STRLEN clen; - I32 iters = 0; - I32 maxiters; - register I32 i; - bool once; - char *orig; - I32 safebase; - register REGEXP *rx = pm->op_pmregexp; - STRLEN len; + if (!sfirst || !snext) + DIE("do_study: out of memory"); - if (pm->op_pmflags & PMf_CONST) /* known replacement string? */ - dstr = POPs; - if (op->op_flags & OPf_STACKED) - TARG = POPs; - else { - TARG = GvSV(defgv); - EXTEND(SP,1); - } - s = SvPV(TARG, len); - if (!pm || !s) - DIE("panic: do_subst"); + for (ch = 256; ch; --ch) + *sfirst++ = -1; + sfirst -= 256; - strend = s + len; - maxiters = (strend - s) + 10; + while (--pos >= 0) { + ch = s[pos]; + if (sfirst[ch] >= 0) + snext[pos] = sfirst[ch] - pos; + else + snext[pos] = -pos; + sfirst[ch] = pos; - if (!rx->prelen && curpm) { - pm = curpm; - rx = pm->op_pmregexp; - } - safebase = ((!rx || !rx->nparens) && !sawampersand); - orig = m = s; - if (pm->op_pmshort) { - if (pm->op_pmflags & PMf_SCANFIRST) { - if (SvSCREAM(TARG)) { - if (screamfirst[BmRARE(pm->op_pmshort)] < 0) - goto nope; - else if (!(s = screaminstr(TARG, pm->op_pmshort))) - goto nope; - } - else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend, - pm->op_pmshort))) - goto nope; - if (s && rx->regback >= 0) { - ++BmUSEFUL(pm->op_pmshort); - s -= rx->regback; - if (s < m) - s = m; - } - else - s = m; - } - else if (!multiline) { - if (*SvPVX(pm->op_pmshort) != *s || - bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) { - if (pm->op_pmflags & PMf_FOLD) { - if (ibcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) - goto nope; - } - else - goto nope; - } - } - if (--BmUSEFUL(pm->op_pmshort) < 0) { - SvREFCNT_dec(pm->op_pmshort); - pm->op_pmshort = Nullsv; /* opt is being useless */ - } - } - once = !(rpm->op_pmflags & PMf_GLOBAL); - if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */ - c = SvPV(dstr, clen); - if (clen <= rx->minlen) { - /* can do inplace substitution */ - if (regexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { - if (rx->subbase) /* oops, no we can't */ - goto long_way; - d = s; - curpm = pm; - SvSCREAM_off(TARG); /* disable possible screamer */ - if (once) { - m = rx->startp[0]; - d = rx->endp[0]; - s = orig; - if (m - s > strend - d) { /* faster to shorten from end */ - if (clen) { - Copy(c, m, clen, char); - m += clen; - } - i = strend - d; - if (i > 0) { - Move(d, m, i, char); - m += i; - } - *m = '\0'; - SvCUR_set(TARG, m - s); - SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - RETURN; - } - /*SUPPRESS 560*/ - else if (i = m - s) { /* faster from front */ - d -= clen; - m = d; - sv_chop(TARG, d-i); - s += i; - while (i--) - *--d = *--s; - if (clen) - Copy(c, m, clen, char); - SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - RETURN; - } - else if (clen) { - d -= clen; - sv_chop(TARG, d); - Copy(c, d, clen, char); - SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - RETURN; - } - else { - sv_chop(TARG, d); - SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - RETURN; - } - /* NOTREACHED */ - } - do { - if (iters++ > maxiters) - DIE("Substitution loop"); - m = rx->startp[0]; - /*SUPPRESS 560*/ - if (i = m - s) { - if (s != d) - Move(s, d, i, char); - d += i; - } - if (clen) { - Copy(c, d, clen, char); - d += clen; - } - s = rx->endp[0]; - } while (regexec(rx, s, strend, orig, s == m, - Nullsv, TRUE)); /* (don't match same null twice) */ - if (s != d) { - i = strend - s; - SvCUR_set(TARG, d - SvPVX(TARG) + i); - Move(s, d, i+1, char); /* include the Null */ - } - SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(sv_2mortal(newSViv((I32)iters))); - RETURN; - } - PUSHs(&sv_no); - RETURN; - } - } - else - c = Nullch; - if (regexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { - long_way: - dstr = NEWSV(25, sv_len(TARG)); - sv_setpvn(dstr, m, s-m); - curpm = pm; - if (!c) { - register CONTEXT *cx; - PUSHSUBST(cx); - RETURNOP(cPMOP->op_pmreplroot); - } - do { - if (iters++ > maxiters) - DIE("Substitution loop"); - if (rx->subbase && rx->subbase != orig) { - m = s; - s = orig; - orig = rx->subbase; - s = orig + (m - s); - strend = s + (strend - m); - } - m = rx->startp[0]; - sv_catpvn(dstr, s, m-s); - s = rx->endp[0]; - if (clen) - sv_catpvn(dstr, c, clen); - if (once) - break; - } while (regexec(rx, s, strend, orig, s == m, Nullsv, - safebase)); - sv_catpvn(dstr, s, strend - s); - sv_replace(TARG, dstr); - SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(sv_2mortal(newSViv((I32)iters))); - RETURN; + /* If there were any case insensitive searches, we must assume they + * all are. This speeds up insensitive searches much more than + * it slows down sensitive ones. + */ + if (sawi) + sfirst[fold[ch]] = pos; } - PUSHs(&sv_no); - RETURN; -nope: - ++BmUSEFUL(pm->op_pmshort); - PUSHs(&sv_no); + SvSCREAM_on(TARG); + retval = 1; + ret: + XPUSHs(sv_2mortal(newSViv((I32)retval))); RETURN; } -PP(pp_substcont) -{ - dSP; - register PMOP *pm = (PMOP*) cLOGOP->op_other; - register CONTEXT *cx = &cxstack[cxstack_ix]; - register SV *dstr = cx->sb_dstr; - register char *s = cx->sb_s; - register char *m = cx->sb_m; - char *orig = cx->sb_orig; - register REGEXP *rx = pm->op_pmregexp; - - if (cx->sb_iters++) { - if (cx->sb_iters > cx->sb_maxiters) - DIE("Substitution loop"); - - sv_catsv(dstr, POPs); - if (rx->subbase) - Safefree(rx->subbase); - rx->subbase = cx->sb_subbase; - - /* Are we done */ - if (cx->sb_once || !regexec(rx, s, cx->sb_strend, orig, - s == m, Nullsv, cx->sb_safebase)) - { - SV *targ = cx->sb_targ; - sv_catpvn(dstr, s, cx->sb_strend - s); - sv_replace(targ, dstr); - SvPOK_only(targ); - SvSETMAGIC(targ); - PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); - POPSUBST(cx); - RETURNOP(pm->op_next); - } - } - if (rx->subbase && rx->subbase != orig) { - m = s; - s = orig; - cx->sb_orig = orig = rx->subbase; - s = orig + (m - s); - cx->sb_strend = s + (cx->sb_strend - m); - } - cx->sb_m = m = rx->startp[0]; - sv_catpvn(dstr, s, m-s); - cx->sb_s = rx->endp[0]; - cx->sb_subbase = rx->subbase; - - rx->subbase = Nullch; /* so recursion works */ - RETURNOP(pm->op_pmreplstart); -} - PP(pp_trans) { dSP; dTARG; @@ -1253,221 +423,38 @@ PP(pp_trans) /* Lvalue operators. */ -PP(pp_sassign) +PP(pp_schop) { - dSP; dPOPTOPssrl; - if (tainting && tainted && (!SvRMAGICAL(lstr) || !mg_find(lstr, 't'))) { - TAINT_NOT; - } - SvSetSV(rstr, lstr); - SvSETMAGIC(rstr); - SETs(rstr); + dSP; dTARGET; + do_chop(TARG, TOPs); + SETTARG; RETURN; } -PP(pp_aassign) +PP(pp_chop) { - dSP; - SV **lastlelem = stack_sp; - SV **lastrelem = stack_base + POPMARK; - SV **firstrelem = stack_base + POPMARK + 1; - SV **firstlelem = lastrelem + 1; - - register SV **relem; - register SV **lelem; - - register SV *sv; - register AV *ary; - - HV *hash; - I32 i; - int magic; - - delaymagic = DM_DELAY; /* catch simultaneous items */ - - /* If there's a common identifier on both sides we have to take - * special care that assigning the identifier on the left doesn't - * clobber a value on the right that's used later in the list. - */ - if (op->op_private & OPpASSIGN_COMMON) { - for (relem = firstrelem; relem <= lastrelem; relem++) { - /*SUPPRESS 560*/ - if (sv = *relem) - *relem = sv_mortalcopy(sv); - } - } - - relem = firstrelem; - lelem = firstlelem; - ary = Null(AV*); - hash = Null(HV*); - while (lelem <= lastlelem) { - sv = *lelem++; - switch (SvTYPE(sv)) { - case SVt_PVAV: - ary = (AV*)sv; - magic = SvSMAGICAL(ary) != 0; - AvREAL_on(ary); - AvFILL(ary) = -1; - i = 0; - while (relem <= lastrelem) { /* gobble up all the rest */ - sv = NEWSV(28,0); - if (*relem) - sv_setsv(sv,*relem); - *(relem++) = sv; - (void)av_store(ary,i++,sv); - if (magic) - mg_set(sv); - } - break; - case SVt_PVHV: { - char *tmps; - SV *tmpstr; - - hash = (HV*)sv; - magic = SvSMAGICAL(hash) != 0; - hv_clear(hash); - - while (relem < lastrelem) { /* gobble up all the rest */ - STRLEN len; - if (*relem) - sv = *(relem++); - else - sv = &sv_no, relem++; - tmps = SvPV(sv, len); - tmpstr = NEWSV(29,0); - if (*relem) - sv_setsv(tmpstr,*relem); /* value */ - *(relem++) = tmpstr; - (void)hv_store(hash,tmps,len,tmpstr,0); - if (magic) - mg_set(tmpstr); - } - } - break; - default: - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) { - if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no) - DIE(no_modify); - if (relem <= lastrelem) - relem++; - break; - } - if (SvROK(sv)) - sv_unref(sv); - } - if (relem <= lastrelem) { - sv_setsv(sv, *relem); - *(relem++) = sv; - } - else - sv_setsv(sv, &sv_undef); - SvSETMAGIC(sv); - break; - } - } - if (delaymagic & ~DM_DELAY) { - if (delaymagic & DM_UID) { -#ifdef HAS_SETRESUID - (void)setresuid(uid,euid,(Uid_t)-1); -#else /* not HAS_SETRESUID */ -#ifdef HAS_SETREUID - (void)setreuid(uid,euid); -#else /* not HAS_SETREUID */ -#ifdef HAS_SETRUID - if ((delaymagic & DM_UID) == DM_RUID) { - (void)setruid(uid); - delaymagic =~ DM_RUID; - } -#endif /* HAS_SETRUID */ -#endif /* HAS_SETRESUID */ -#ifdef HAS_SETEUID - if ((delaymagic & DM_UID) == DM_EUID) { - (void)seteuid(uid); - delaymagic =~ DM_EUID; - } -#endif /* HAS_SETEUID */ - if (delaymagic & DM_UID) { - if (uid != euid) - DIE("No setreuid available"); - (void)setuid(uid); - } -#endif /* not HAS_SETREUID */ - uid = (int)getuid(); - euid = (int)geteuid(); - } - if (delaymagic & DM_GID) { -#ifdef HAS_SETRESGID - (void)setresgid(gid,egid,(Gid_t)-1); -#else /* not HAS_SETREGID */ -#ifdef HAS_SETREGID - (void)setregid(gid,egid); -#else /* not HAS_SETREGID */ -#endif /* not HAS_SETRESGID */ -#ifdef HAS_SETRGID - if ((delaymagic & DM_GID) == DM_RGID) { - (void)setrgid(gid); - delaymagic =~ DM_RGID; - } -#endif /* HAS_SETRGID */ -#ifdef HAS_SETRESGID - (void)setresgid(gid,egid,(Gid_t)-1); -#else /* not HAS_SETREGID */ -#ifdef HAS_SETEGID - if ((delaymagic & DM_GID) == DM_EGID) { - (void)setegid(gid); - delaymagic =~ DM_EGID; - } -#endif /* HAS_SETEGID */ - if (delaymagic & DM_GID) { - if (gid != egid) - DIE("No setregid available"); - (void)setgid(gid); - } -#endif /* not HAS_SETRESGID */ -#endif /* not HAS_SETREGID */ - gid = (int)getgid(); - egid = (int)getegid(); - } - tainting |= (euid != uid || egid != gid); - } - delaymagic = 0; - if (GIMME == G_ARRAY) { - if (ary || hash) - SP = lastrelem; - else - SP = firstrelem + (lastlelem - firstlelem); - RETURN; - } - else { - dTARGET; - SP = firstrelem; - SETi(lastrelem - firstrelem + 1); - RETURN; - } + dSP; dMARK; dTARGET; + while (SP > MARK) + do_chop(TARG, POPs); + PUSHTARG; + RETURN; } -PP(pp_schop) +PP(pp_schomp) { dSP; dTARGET; - SV *sv; - - if (MAXARG < 1) - sv = GvSV(defgv); - else - sv = POPs; - do_chop(TARG, sv); - PUSHTARG; + SETi(do_chomp(TOPs)); RETURN; } -PP(pp_chop) +PP(pp_chomp) { dSP; dMARK; dTARGET; + register I32 count = 0; + while (SP > MARK) - do_chop(TARG, POPs); - PUSHTARG; + count += do_chomp(POPs); + PUSHi(count); RETURN; } @@ -1476,12 +463,7 @@ PP(pp_defined) dSP; register SV* sv; - if (MAXARG < 1) { - sv = GvSV(defgv); - EXTEND(SP, 1); - } - else - sv = POPs; + sv = POPs; if (!sv || !SvANY(sv)) RETPUSHNO; switch (SvTYPE(sv)) { @@ -1494,10 +476,12 @@ PP(pp_defined) RETPUSHYES; break; case SVt_PVCV: - if (CvROOT(sv)) + if (CvROOT(sv) || CvXSUB(sv)) RETPUSHYES; break; default: + if (SvGMAGICAL(sv)) + mg_get(sv); if (SvOK(sv)) RETPUSHYES; } @@ -1533,18 +517,18 @@ PP(pp_undef) hv_undef((HV*)sv); break; case SVt_PVCV: - sub_generation++; cv_undef((CV*)sv); + sub_generation++; break; default: if (sv != GvSV(defgv)) { if (SvPOK(sv) && SvLEN(sv)) { - SvOOK_off(sv); + (void)SvOOK_off(sv); Safefree(SvPVX(sv)); SvPV_set(sv, Nullch); SvLEN_set(sv, 0); } - SvOK_off(sv); + (void)SvOK_off(sv); SvSETMAGIC(sv); } } @@ -1552,79 +536,6 @@ PP(pp_undef) RETPUSHUNDEF; } -PP(pp_study) -{ - dSP; dTARGET; - register unsigned char *s; - register I32 pos; - register I32 ch; - register I32 *sfirst; - register I32 *snext; - I32 retval; - STRLEN len; - - s = (unsigned char*)(SvPV(TARG, len)); - pos = len; - if (lastscream) - SvSCREAM_off(lastscream); - lastscream = TARG; - if (pos <= 0) { - retval = 0; - goto ret; - } - if (pos > maxscream) { - if (maxscream < 0) { - maxscream = pos + 80; - New(301, screamfirst, 256, I32); - New(302, screamnext, maxscream, I32); - } - else { - maxscream = pos + pos / 4; - Renew(screamnext, maxscream, I32); - } - } - - sfirst = screamfirst; - snext = screamnext; - - if (!sfirst || !snext) - DIE("do_study: out of memory"); - - for (ch = 256; ch; --ch) - *sfirst++ = -1; - sfirst -= 256; - - while (--pos >= 0) { - ch = s[pos]; - if (sfirst[ch] >= 0) - snext[pos] = sfirst[ch] - pos; - else - snext[pos] = -pos; - sfirst[ch] = pos; - - /* If there were any case insensitive searches, we must assume they - * all are. This speeds up insensitive searches much more than - * it slows down sensitive ones. - */ - if (sawi) - sfirst[fold[ch]] = pos; - } - - SvSCREAM_on(TARG); - retval = 1; - ret: - XPUSHs(sv_2mortal(newSViv((I32)retval))); - RETURN; -} - -PP(pp_preinc) -{ - dSP; - sv_inc(TOPs); - SvSETMAGIC(TOPs); - return NORMAL; -} - PP(pp_predec) { dSP; @@ -1659,63 +570,74 @@ PP(pp_postdec) PP(pp_pow) { - dSP; dATARGET; dPOPTOPnnrl; - SETn( pow( left, right) ); - RETURN; + dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); + { + dPOPTOPnnrl; + SETn( pow( left, right) ); + RETURN; + } } PP(pp_multiply) { - dSP; dATARGET; dPOPTOPnnrl; - SETn( left * right ); - RETURN; + dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + { + dPOPTOPnnrl; + SETn( left * right ); + RETURN; + } } PP(pp_divide) { - dSP; dATARGET; dPOPnv; - if (value == 0.0) + dSP; dATARGET; tryAMAGICbin(div,opASSIGN); + { + dPOPnv; + if (value == 0.0) DIE("Illegal division by zero"); #ifdef SLOPPYDIVIDE - /* insure that 20./5. == 4. */ - { + /* insure that 20./5. == 4. */ + { double x; I32 k; x = POPn; - if ((double)(I32)x == x && - (double)(I32)value == value && - (k = (I32)x/(I32)value)*(I32)value == (I32)x) { + if ((double)I_32(x) == x && + (double)I_32(value) == value && + (k = I_32(x)/I_32(value))*I_32(value) == I_32(x)) { value = k; } else { value = x/value; } - } + } #else - value = POPn / value; + value = POPn / value; #endif - PUSHn( value ); - RETURN; + PUSHn( value ); + RETURN; + } } PP(pp_modulo) { - dSP; dATARGET; - register unsigned long tmpulong; - register long tmplong; - I32 value; + dSP; dATARGET; tryAMAGICbin(mod,opASSIGN); + { + register unsigned long tmpulong; + register long tmplong; + I32 value; - tmpulong = (unsigned long) POPn; - if (tmpulong == 0L) + tmpulong = (unsigned long) POPn; + if (tmpulong == 0L) DIE("Illegal modulus zero"); - value = TOPn; - if (value >= 0.0) + value = TOPn; + if (value >= 0.0) value = (I32)(((unsigned long)value) % tmpulong); - else { + else { tmplong = (long)value; value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1; + } + SETi(value); + RETURN; } - SETi(value); - RETURN; } PP(pp_repeat) @@ -1738,12 +660,14 @@ PP(pp_repeat) MARK++; repeatcpy((char*)(MARK + items), (char*)MARK, items * sizeof(SV*), count - 1); + SP += max; } - SP += max; + else if (count <= 0) + SP -= items; } else { /* Note: mark already snarfed by pp_list */ SV *tmpstr; - char *tmps; + STRLEN len; tmpstr = POPs; if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) { @@ -1753,19 +677,14 @@ PP(pp_repeat) sv_unref(tmpstr); } SvSetSV(TARG, tmpstr); + SvPV_force(TARG, len); if (count >= 1) { - STRLEN len; - STRLEN tlen; - tmpstr = NEWSV(50, 0); - tmps = SvPV(TARG, len); - sv_setpvn(tmpstr, tmps, len); - tmps = SvPV(tmpstr, tlen); /* force to be string */ SvGROW(TARG, (count * len) + 1); - repeatcpy((char*)SvPVX(TARG), tmps, tlen, count); + if (count > 1) + repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); SvCUR(TARG) *= count; *SvEND(TARG) = '\0'; - SvPOK_only(TARG); - SvREFCNT_dec(tmpstr); + (void)SvPOK_only(TARG); } else sv_setsv(TARG, &sv_no); @@ -1774,228 +693,269 @@ PP(pp_repeat) RETURN; } -PP(pp_add) -{ - dSP; dATARGET; dPOPTOPnnrl; - SETn( left + right ); - RETURN; -} - PP(pp_subtract) { - dSP; dATARGET; dPOPTOPnnrl; - SETn( left - right ); - RETURN; -} - -PP(pp_concat) -{ - dSP; dATARGET; dPOPTOPssrl; - STRLEN len; - char *s; - if (TARG != lstr) { - s = SvPV(lstr,len); - sv_setpvn(TARG,s,len); + dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + { + dPOPTOPnnrl; + SETn( left - right ); + RETURN; } - s = SvPV(rstr,len); - sv_catpvn(TARG,s,len); - SETTARG; - RETURN; } PP(pp_left_shift) { - dSP; dATARGET; dPOPTOPiirl; - SETi( left << right ); - RETURN; + dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); + { + dPOPTOPiirl; + SETi( left << right ); + RETURN; + } } PP(pp_right_shift) { - dSP; dATARGET; dPOPTOPiirl; - SETi( left >> right ); - RETURN; + dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); + { + dPOPTOPiirl; + SETi( left >> right ); + RETURN; + } } PP(pp_lt) { - dSP; dPOPnv; - SETs((TOPn < value) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(lt,0); + { + dPOPnv; + SETs((TOPn < value) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_gt) { - dSP; dPOPnv; - SETs((TOPn > value) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(gt,0); + { + dPOPnv; + SETs((TOPn > value) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_le) { - dSP; dPOPnv; - SETs((TOPn <= value) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(le,0); + { + dPOPnv; + SETs((TOPn <= value) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_ge) { - dSP; dPOPnv; - SETs((TOPn >= value) ? &sv_yes : &sv_no); - RETURN; -} - -PP(pp_eq) -{ - dSP; dPOPnv; - SETs((TOPn == value) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(ge,0); + { + dPOPnv; + SETs((TOPn >= value) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_ne) { - dSP; dPOPnv; - SETs((TOPn != value) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(ne,0); + { + dPOPnv; + SETs((TOPn != value) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_ncmp) { - dSP; dTARGET; dPOPTOPnnrl; - I32 value; + dSP; dTARGET; tryAMAGICbin(ncmp,0); + { + dPOPTOPnnrl; + I32 value; - if (left > right) + if (left > right) value = 1; - else if (left < right) + else if (left < right) value = -1; - else + else value = 0; - SETi(value); - RETURN; + SETi(value); + RETURN; + } } PP(pp_slt) { - dSP; dPOPTOPssrl; - SETs( sv_cmp(lstr, rstr) < 0 ? &sv_yes : &sv_no ); - RETURN; + dSP; tryAMAGICbinSET(slt,0); + { + dPOPTOPssrl; + SETs( sv_cmp(left, right) < 0 ? &sv_yes : &sv_no ); + RETURN; + } } PP(pp_sgt) { - dSP; dPOPTOPssrl; - SETs( sv_cmp(lstr, rstr) > 0 ? &sv_yes : &sv_no ); - RETURN; + dSP; tryAMAGICbinSET(sgt,0); + { + dPOPTOPssrl; + SETs( sv_cmp(left, right) > 0 ? &sv_yes : &sv_no ); + RETURN; + } } PP(pp_sle) { - dSP; dPOPTOPssrl; - SETs( sv_cmp(lstr, rstr) <= 0 ? &sv_yes : &sv_no ); - RETURN; + dSP; tryAMAGICbinSET(sle,0); + { + dPOPTOPssrl; + SETs( sv_cmp(left, right) <= 0 ? &sv_yes : &sv_no ); + RETURN; + } } PP(pp_sge) { - dSP; dPOPTOPssrl; - SETs( sv_cmp(lstr, rstr) >= 0 ? &sv_yes : &sv_no ); - RETURN; -} - -PP(pp_seq) -{ - dSP; dPOPTOPssrl; - SETs( sv_eq(lstr, rstr) ? &sv_yes : &sv_no ); - RETURN; + dSP; tryAMAGICbinSET(sge,0); + { + dPOPTOPssrl; + SETs( sv_cmp(left, right) >= 0 ? &sv_yes : &sv_no ); + RETURN; + } } PP(pp_sne) { - dSP; dPOPTOPssrl; - SETs( !sv_eq(lstr, rstr) ? &sv_yes : &sv_no ); - RETURN; + dSP; tryAMAGICbinSET(sne,0); + { + dPOPTOPssrl; + SETs( !sv_eq(left, right) ? &sv_yes : &sv_no ); + RETURN; + } } PP(pp_scmp) { - dSP; dTARGET; - dPOPTOPssrl; - SETi( sv_cmp(lstr, rstr) ); - RETURN; + dSP; dTARGET; tryAMAGICbin(scmp,0); + { + dPOPTOPssrl; + SETi( sv_cmp(left, right) ); + RETURN; + } } PP(pp_bit_and) { - dSP; dATARGET; dPOPTOPssrl; - if (SvNIOK(lstr) || SvNIOK(rstr)) { - unsigned long value = U_L(SvNV(lstr)); - value = value & U_L(SvNV(rstr)); + dSP; dATARGET; tryAMAGICbin(band,opASSIGN); + { + dPOPTOPssrl; + if (SvNIOK(left) || SvNIOK(right)) { + unsigned long value = U_L(SvNV(left)); + value = value & U_L(SvNV(right)); SETn((double)value); - } - else { - do_vop(op->op_type, TARG, lstr, rstr); + } + else { + do_vop(op->op_type, TARG, left, right); SETTARG; + } + RETURN; } - RETURN; } -PP(pp_xor) +PP(pp_bit_xor) { - dSP; dATARGET; dPOPTOPssrl; - if (SvNIOK(lstr) || SvNIOK(rstr)) { - unsigned long value = U_L(SvNV(lstr)); - value = value ^ U_L(SvNV(rstr)); + dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); + { + dPOPTOPssrl; + if (SvNIOK(left) || SvNIOK(right)) { + unsigned long value = U_L(SvNV(left)); + value = value ^ U_L(SvNV(right)); SETn((double)value); - } - else { - do_vop(op->op_type, TARG, lstr, rstr); + } + else { + do_vop(op->op_type, TARG, left, right); SETTARG; + } + RETURN; } - RETURN; } PP(pp_bit_or) { - dSP; dATARGET; dPOPTOPssrl; - if (SvNIOK(lstr) || SvNIOK(rstr)) { - unsigned long value = U_L(SvNV(lstr)); - value = value | U_L(SvNV(rstr)); + dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); + { + dPOPTOPssrl; + if (SvNIOK(left) || SvNIOK(right)) { + unsigned long value = U_L(SvNV(left)); + value = value | U_L(SvNV(right)); SETn((double)value); - } - else { - do_vop(op->op_type, TARG, lstr, rstr); + } + else { + do_vop(op->op_type, TARG, left, right); SETTARG; + } + RETURN; } - RETURN; } PP(pp_negate) { - dSP; dTARGET; - SETn(-TOPn); + dSP; dTARGET; tryAMAGICun(neg); + { + dTOPss; + if (SvNIOK(sv)) + SETn(-SvNV(sv)); + else if (SvPOK(sv)) { + STRLEN len; + char *s = SvPV(sv, len); + if (isALPHA(*s) || *s == '_') { + sv_setpvn(TARG, "-", 1); + sv_catsv(TARG, sv); + } + else if (*s == '+' || *s == '-') { + sv_setsv(TARG, sv); + *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; + } + else + sv_setnv(TARG, -SvNV(sv)); + SETTARG; + } + } RETURN; } PP(pp_not) { +#ifdef OVERLOAD + dSP; tryAMAGICunSET(not); +#endif /* OVERLOAD */ *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes; return NORMAL; } PP(pp_complement) { - dSP; dTARGET; dTOPss; - register I32 anum; + dSP; dTARGET; tryAMAGICun(compl); + { + dTOPss; + register I32 anum; - if (SvNIOK(sv)) { + if (SvNIOK(sv)) { SETi( ~SvIV(sv) ); - } - else { + } + else { register char *tmps; register long *tmpl; STRLEN len; SvSetSV(TARG, sv); - tmps = SvPV(TARG, len); + tmps = SvPV_force(TARG, len); anum = len; #ifdef LIBERAL for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) @@ -2009,25 +969,48 @@ PP(pp_complement) *tmps = ~*tmps; SETs(TARG); + } + RETURN; } - RETURN; } /* integer versions of some of the above */ PP(pp_i_preinc) { +#ifndef OVERLOAD dSP; dTOPiv; sv_setiv(TOPs, value + 1); SvSETMAGIC(TOPs); +#else + dSP; + if (SvAMAGIC(TOPs) ) { + sv_inc(TOPs); + } else { + dTOPiv; + sv_setiv(TOPs, value + 1); + SvSETMAGIC(TOPs); + } +#endif /* OVERLOAD */ return NORMAL; } PP(pp_i_predec) { +#ifndef OVERLOAD dSP; dTOPiv; sv_setiv(TOPs, value - 1); SvSETMAGIC(TOPs); +#else + dSP; + if (SvAMAGIC(TOPs)) { + sv_dec(TOPs); + } else { + dTOPiv; + sv_setiv(TOPs, value - 1); + SvSETMAGIC(TOPs); + } +#endif /* OVERLOAD */ return NORMAL; } @@ -2035,8 +1018,17 @@ PP(pp_i_postinc) { dSP; dTARGET; sv_setsv(TARG, TOPs); +#ifndef OVERLOAD sv_setiv(TOPs, SvIV(TOPs) + 1); SvSETMAGIC(TOPs); +#else + if (SvAMAGIC(TOPs) ) { + sv_inc(TOPs); + } else { + sv_setiv(TOPs, SvIV(TOPs) + 1); + SvSETMAGIC(TOPs); + } +#endif /* OVERLOAD */ if (!SvOK(TARG)) sv_setiv(TARG, 0); SETs(TARG); @@ -2047,110 +1039,155 @@ PP(pp_i_postdec) { dSP; dTARGET; sv_setsv(TARG, TOPs); +#ifndef OVERLOAD sv_setiv(TOPs, SvIV(TOPs) - 1); SvSETMAGIC(TOPs); +#else + if (SvAMAGIC(TOPs) ) { + sv_dec(TOPs); + } else { + sv_setiv(TOPs, SvIV(TOPs) - 1); + SvSETMAGIC(TOPs); + } +#endif /* OVERLOAD */ SETs(TARG); return NORMAL; } PP(pp_i_multiply) { - dSP; dATARGET; dPOPTOPiirl; - SETi( left * right ); - RETURN; + dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + { + dPOPTOPiirl; + SETi( left * right ); + RETURN; + } } PP(pp_i_divide) { - dSP; dATARGET; dPOPiv; - if (value == 0) + dSP; dATARGET; tryAMAGICbin(div,opASSIGN); + { + dPOPiv; + if (value == 0) DIE("Illegal division by zero"); - value = POPi / value; - PUSHi( value ); - RETURN; + value = POPi / value; + PUSHi( value ); + RETURN; + } } PP(pp_i_modulo) { - dSP; dATARGET; dPOPTOPiirl; - SETi( left % right ); - RETURN; + dSP; dATARGET; tryAMAGICbin(mod,opASSIGN); + { + dPOPTOPiirl; + SETi( left % right ); + RETURN; + } } PP(pp_i_add) { - dSP; dATARGET; dPOPTOPiirl; - SETi( left + right ); - RETURN; + dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + { + dPOPTOPiirl; + SETi( left + right ); + RETURN; + } } PP(pp_i_subtract) { - dSP; dATARGET; dPOPTOPiirl; - SETi( left - right ); - RETURN; + dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + { + dPOPTOPiirl; + SETi( left - right ); + RETURN; + } } PP(pp_i_lt) { - dSP; dPOPTOPiirl; - SETs((left < right) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(lt,0); + { + dPOPTOPiirl; + SETs((left < right) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_i_gt) { - dSP; dPOPTOPiirl; - SETs((left > right) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(gt,0); + { + dPOPTOPiirl; + SETs((left > right) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_i_le) { - dSP; dPOPTOPiirl; - SETs((left <= right) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(le,0); + { + dPOPTOPiirl; + SETs((left <= right) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_i_ge) { - dSP; dPOPTOPiirl; - SETs((left >= right) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(ge,0); + { + dPOPTOPiirl; + SETs((left >= right) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_i_eq) { - dSP; dPOPTOPiirl; - SETs((left == right) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(eq,0); + { + dPOPTOPiirl; + SETs((left == right) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_i_ne) { - dSP; dPOPTOPiirl; - SETs((left != right) ? &sv_yes : &sv_no); - RETURN; + dSP; tryAMAGICbinSET(ne,0); + { + dPOPTOPiirl; + SETs((left != right) ? &sv_yes : &sv_no); + RETURN; + } } PP(pp_i_ncmp) { - dSP; dTARGET; dPOPTOPiirl; - I32 value; + dSP; dTARGET; tryAMAGICbin(ncmp,0); + { + dPOPTOPiirl; + I32 value; - if (left > right) + if (left > right) value = 1; - else if (left < right) + else if (left < right) value = -1; - else + else value = 0; - SETi(value); - RETURN; + SETi(value); + RETURN; + } } PP(pp_i_negate) { - dSP; dTARGET; + dSP; dTARGET; tryAMAGICun(neg); SETi(-TOPi); RETURN; } @@ -2159,35 +1196,36 @@ PP(pp_i_negate) PP(pp_atan2) { - dSP; dTARGET; dPOPTOPnnrl; - SETn(atan2(left, right)); - RETURN; + dSP; dTARGET; tryAMAGICbin(atan2,0); + { + dPOPTOPnnrl; + SETn(atan2(left, right)); + RETURN; + } } PP(pp_sin) { - dSP; dTARGET; - double value; - if (MAXARG < 1) - value = SvNVx(GvSV(defgv)); - else - value = POPn; - value = sin(value); - XPUSHn(value); - RETURN; + dSP; dTARGET; tryAMAGICun(sin); + { + double value; + value = POPn; + value = sin(value); + XPUSHn(value); + RETURN; + } } PP(pp_cos) { - dSP; dTARGET; - double value; - if (MAXARG < 1) - value = SvNVx(GvSV(defgv)); - else - value = POPn; - value = cos(value); - XPUSHn(value); - RETURN; + dSP; dTARGET; tryAMAGICun(cos); + { + double value; + value = POPn; + value = cos(value); + XPUSHn(value); + RETURN; + } } PP(pp_rand) @@ -2236,55 +1274,49 @@ PP(pp_srand) PP(pp_exp) { - dSP; dTARGET; - double value; - if (MAXARG < 1) - value = SvNVx(GvSV(defgv)); - else - value = POPn; - value = exp(value); - XPUSHn(value); - RETURN; + dSP; dTARGET; tryAMAGICun(exp); + { + double value; + value = POPn; + value = exp(value); + XPUSHn(value); + RETURN; + } } PP(pp_log) { - dSP; dTARGET; - double value; - if (MAXARG < 1) - value = SvNVx(GvSV(defgv)); - else - value = POPn; - if (value <= 0.0) + dSP; dTARGET; tryAMAGICun(log); + { + double value; + value = POPn; + if (value <= 0.0) DIE("Can't take log of %g", value); - value = log(value); - XPUSHn(value); - RETURN; + value = log(value); + XPUSHn(value); + RETURN; + } } PP(pp_sqrt) { - dSP; dTARGET; - double value; - if (MAXARG < 1) - value = SvNVx(GvSV(defgv)); - else - value = POPn; - if (value < 0.0) + dSP; dTARGET; tryAMAGICun(sqrt); + { + double value; + value = POPn; + if (value < 0.0) DIE("Can't take sqrt of %g", value); - value = sqrt(value); - XPUSHn(value); - RETURN; + value = sqrt(value); + XPUSHn(value); + RETURN; + } } PP(pp_int) { dSP; dTARGET; double value; - if (MAXARG < 1) - value = SvNVx(GvSV(defgv)); - else - value = POPn; + value = POPn; if (value >= 0.0) (void)modf(value, &value); else { @@ -2297,18 +1329,17 @@ PP(pp_int) PP(pp_abs) { - dSP; dTARGET; - double value; - if (MAXARG < 1) - value = SvNVx(GvSV(defgv)); - else - value = POPn; + dSP; dTARGET; tryAMAGICun(abs); + { + double value; + value = POPn; - if (value < 0.0) + if (value < 0.0) value = -value; - XPUSHn(value); - RETURN; + XPUSHn(value); + RETURN; + } } PP(pp_hex) @@ -2317,10 +1348,7 @@ PP(pp_hex) char *tmps; I32 argtype; - if (MAXARG < 1) - tmps = SvPVx(GvSV(defgv), na); - else - tmps = POPp; + tmps = POPp; XPUSHi( scan_hex(tmps, 99, &argtype) ); RETURN; } @@ -2332,10 +1360,7 @@ PP(pp_oct) I32 argtype; char *tmps; - if (MAXARG < 1) - tmps = SvPVx(GvSV(defgv), na); - else - tmps = POPp; + tmps = POPp; while (*tmps && (isSPACE(*tmps) || *tmps == '0')) tmps++; if (*tmps == 'x') @@ -2351,11 +1376,7 @@ PP(pp_oct) PP(pp_length) { dSP; dTARGET; - if (MAXARG < 1) { - XPUSHi( sv_len(GvSV(defgv)) ); - } - else - SETi( sv_len(TOPs) ); + SETi( sv_len(TOPs) ); RETURN; } @@ -2367,41 +1388,44 @@ PP(pp_substr) STRLEN curlen; I32 pos; I32 rem; - I32 lvalue = op->op_flags & OPf_LVAL; + I32 lvalue = op->op_flags & OPf_MOD; char *tmps; + I32 arybase = curcop->cop_arybase; if (MAXARG > 2) len = POPi; pos = POPi - arybase; sv = POPs; - tmps = SvPV(sv, curlen); /* force conversion to string */ + tmps = SvPV(sv, curlen); if (pos < 0) pos += curlen + arybase; if (pos < 0 || pos > curlen) { - if (dowarn) + if (dowarn || lvalue) warn("substr outside of string"); RETPUSHUNDEF; } else { if (MAXARG < 3) len = curlen; - if (len < 0) - len = 0; + else if (len < 0) { + len += curlen; + if (len < 0) + len = 0; + } tmps += pos; rem = curlen - pos; /* rem=how many bytes left*/ if (rem > len) rem = len; sv_setpvn(TARG, tmps, rem); if (lvalue) { /* it's an lvalue! */ - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - DIE(no_modify); - if (SvROK(sv)) - DIE("Can't modify substr of a reference"); + if (SvTYPE(TARG) < SVt_PVLV) { + sv_upgrade(TARG, SVt_PVLV); + sv_magic(TARG, Nullsv, 'x', Nullch, 0); } + LvTYPE(TARG) = 's'; LvTARG(TARG) = sv; - LvTARGOFF(TARG) = tmps - SvPV(sv, na); + LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; } } @@ -2415,7 +1439,7 @@ PP(pp_vec) register I32 size = POPi; register I32 offset = POPi; register SV *src = POPs; - I32 lvalue = op->op_flags & OPf_LVAL; + I32 lvalue = op->op_flags & OPf_MOD; STRLEN srclen; unsigned char *s = (unsigned char*)SvPV(src, srclen); unsigned long retnum; @@ -2425,16 +1449,41 @@ PP(pp_vec) len = (offset + size + 7) / 8; if (offset < 0 || size < 1) retnum = 0; - else if (!lvalue && len > srclen) - retnum = 0; else { + if (lvalue) { /* it's an lvalue! */ + if (SvTYPE(TARG) < SVt_PVLV) { + sv_upgrade(TARG, SVt_PVLV); + sv_magic(TARG, Nullsv, 'v', Nullch, 0); + } + + LvTYPE(TARG) = 'v'; + LvTARG(TARG) = src; + LvTARGOFF(TARG) = offset; + LvTARGLEN(TARG) = size; + } if (len > srclen) { - SvGROW(src, len); - (void)memzero(SvPVX(src) + srclen, len - srclen); - SvCUR_set(src, len); + if (size <= 8) + retnum = 0; + else { + offset >>= 3; + if (size == 16) + retnum = (unsigned long) s[offset] << 8; + else if (size == 32) { + if (offset < len) { + if (offset + 1 < len) + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16) + + (s[offset + 2] << 8); + else + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16); + } + else + retnum = (unsigned long) s[offset] << 24; + } + } } - s = (unsigned char*)SvPV(src, na); - if (size < 8) + else if (size < 8) retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); else { offset >>= 3; @@ -2447,19 +1496,6 @@ PP(pp_vec) ((unsigned long) s[offset + 1] << 16) + (s[offset + 2] << 8) + s[offset+3]; } - - if (lvalue) { /* it's an lvalue! */ - if (SvTHINKFIRST(src)) { - if (SvREADONLY(src) && curcop != &compiling) - DIE(no_modify); - if (SvROK(src)) - DIE("Can't modify vec of a reference"); - } - LvTYPE(TARG) = 'v'; - LvTARG(TARG) = src; - LvTARGOFF(TARG) = offset; - LvTARGLEN(TARG) = size; - } } sv_setiv(TARG, (I32)retnum); @@ -2477,6 +1513,7 @@ PP(pp_index) char *tmps; char *tmps2; STRLEN biglen; + I32 arybase = curcop->cop_arybase; if (MAXARG < 3) offset = 0; @@ -2510,8 +1547,9 @@ PP(pp_rindex) I32 retval; char *tmps; char *tmps2; + I32 arybase = curcop->cop_arybase; - if (MAXARG == 3) + if (MAXARG >= 3) offstr = POPs; little = POPs; big = POPs; @@ -2543,485 +1581,18 @@ PP(pp_sprintf) RETURN; } -static void -doparseform(sv) -SV *sv; -{ - STRLEN len; - register char *s = SvPV(sv, len); - register char *send = s + len; - register char *base; - register I32 skipspaces = 0; - bool noblank; - bool repeat; - bool postspace = FALSE; - U16 *fops; - register U16 *fpc; - U16 *linepc; - register I32 arg; - bool ischop; - - New(804, fops, send - s, U16); /* Almost certainly too long... */ - fpc = fops; - - if (s < send) { - linepc = fpc; - *fpc++ = FF_LINEMARK; - noblank = repeat = FALSE; - base = s; - } - - while (s <= send) { - switch (*s++) { - default: - skipspaces = 0; - continue; - - case '~': - if (*s == '~') { - repeat = TRUE; - *s = ' '; - } - noblank = TRUE; - s[-1] = ' '; - /* FALL THROUGH */ - case ' ': case '\t': - skipspaces++; - continue; - - case '\n': case 0: - arg = s - base; - skipspaces++; - arg -= skipspaces; - if (arg) { - if (postspace) { - *fpc++ = FF_SPACE; - postspace = FALSE; - } - *fpc++ = FF_LITERAL; - *fpc++ = arg; - } - if (s <= send) - skipspaces--; - if (skipspaces) { - *fpc++ = FF_SKIP; - *fpc++ = skipspaces; - } - skipspaces = 0; - if (s <= send) - *fpc++ = FF_NEWLINE; - if (noblank) { - *fpc++ = FF_BLANK; - if (repeat) - arg = fpc - linepc + 1; - else - arg = 0; - *fpc++ = arg; - } - if (s < send) { - linepc = fpc; - *fpc++ = FF_LINEMARK; - noblank = repeat = FALSE; - base = s; - } - else - s++; - continue; - - case '@': - case '^': - ischop = s[-1] == '^'; - - if (postspace) { - *fpc++ = FF_SPACE; - postspace = FALSE; - } - arg = (s - base) - 1; - if (arg) { - *fpc++ = FF_LITERAL; - *fpc++ = arg; - } - - base = s - 1; - *fpc++ = FF_FETCH; - if (*s == '*') { - s++; - *fpc++ = 0; - *fpc++ = FF_LINEGLOB; - } - else if (*s == '#' || (*s == '.' && s[1] == '#')) { - arg = ischop ? 512 : 0; - base = s - 1; - while (*s == '#') - s++; - if (*s == '.') { - char *f; - s++; - f = s; - while (*s == '#') - s++; - arg |= 256 + (s - f); - } - *fpc++ = s - base; /* fieldsize for FETCH */ - *fpc++ = FF_DECIMAL; - *fpc++ = arg; - } - else { - I32 prespace = 0; - bool ismore = FALSE; - - if (*s == '>') { - while (*++s == '>') ; - prespace = FF_SPACE; - } - else if (*s == '|') { - while (*++s == '|') ; - prespace = FF_HALFSPACE; - postspace = TRUE; - } - else { - if (*s == '<') - while (*++s == '<') ; - postspace = TRUE; - } - if (*s == '.' && s[1] == '.' && s[2] == '.') { - s += 3; - ismore = TRUE; - } - *fpc++ = s - base; /* fieldsize for FETCH */ - - *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; - - if (prespace) - *fpc++ = prespace; - *fpc++ = FF_ITEM; - if (ismore) - *fpc++ = FF_MORE; - if (ischop) - *fpc++ = FF_CHOP; - } - base = s; - skipspaces = 0; - continue; - } - } - *fpc++ = FF_END; - - arg = fpc - fops; - SvGROW(sv, SvCUR(sv) + arg * sizeof(U16) + 4); - - s = SvPVX(sv) + SvCUR(sv); - s += 2 + (SvCUR(sv) & 1); - - Copy(fops, s, arg, U16); - Safefree(fops); -} - -PP(pp_formline) -{ - dSP; dMARK; dORIGMARK; - register SV *form = *++MARK; - register U16 *fpc; - register char *t; - register char *f; - register char *s; - register char *send; - register I32 arg; - register SV *sv; - char *item; - I32 itemsize; - I32 fieldsize; - I32 lines = 0; - bool chopspace = (strchr(chopset, ' ') != Nullch); - char *chophere; - char *linemark; - char *formmark; - SV **markmark; - double value; - bool gotsome; - STRLEN len; - - if (!SvCOMPILED(form)) { - SvREADONLY_off(form); - doparseform(form); - } - - SvUPGRADE(formtarget, SVt_PV); - SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1); - t = SvPV(formtarget, len); - t += len; - f = SvPV(form, len); - - s = f + len; - s += 2 + (len & 1); - - fpc = (U16*)s; - - for (;;) { - DEBUG_f( { - char *name = "???"; - arg = -1; - switch (*fpc) { - case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; - case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; - case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; - case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; - case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; - - case FF_CHECKNL: name = "CHECKNL"; break; - case FF_CHECKCHOP: name = "CHECKCHOP"; break; - case FF_SPACE: name = "SPACE"; break; - case FF_HALFSPACE: name = "HALFSPACE"; break; - case FF_ITEM: name = "ITEM"; break; - case FF_CHOP: name = "CHOP"; break; - case FF_LINEGLOB: name = "LINEGLOB"; break; - case FF_NEWLINE: name = "NEWLINE"; break; - case FF_MORE: name = "MORE"; break; - case FF_LINEMARK: name = "LINEMARK"; break; - case FF_END: name = "END"; break; - } - if (arg >= 0) - fprintf(stderr, "%-16s%d\n", name, arg); - else - fprintf(stderr, "%-16s\n", name); - } ) - switch (*fpc++) { - case FF_LINEMARK: - linemark = t; - formmark = f; - markmark = MARK; - lines++; - gotsome = FALSE; - break; - - case FF_LITERAL: - arg = *fpc++; - while (arg--) - *t++ = *f++; - break; - - case FF_SKIP: - f += *fpc++; - break; - - case FF_FETCH: - arg = *fpc++; - f += arg; - fieldsize = arg; - - if (MARK < SP) - sv = *++MARK; - else { - sv = &sv_no; - if (dowarn) - warn("Not enough format arguments"); - } - break; - - case FF_CHECKNL: - item = s = SvPV(sv, len); - itemsize = len; - if (itemsize > fieldsize) - itemsize = fieldsize; - send = chophere = s + itemsize; - while (s < send) { - if (*s & ~31) - gotsome = TRUE; - else if (*s == '\n') - break; - s++; - } - itemsize = s - item; - break; - - case FF_CHECKCHOP: - item = s = SvPV(sv, len); - itemsize = len; - if (itemsize <= fieldsize) { - send = chophere = s + itemsize; - while (s < send) { - if (*s == '\r') { - itemsize = s - item; - break; - } - if (*s++ & ~31) - gotsome = TRUE; - } - } - else { - itemsize = fieldsize; - send = chophere = s + itemsize; - while (s < send || (s == send && isSPACE(*s))) { - if (isSPACE(*s)) { - if (chopspace) - chophere = s; - if (*s == '\r') - break; - } - else { - if (*s & ~31) - gotsome = TRUE; - if (strchr(chopset, *s)) - chophere = s + 1; - } - s++; - } - itemsize = chophere - item; - } - break; - - case FF_SPACE: - arg = fieldsize - itemsize; - if (arg) { - fieldsize -= arg; - while (arg-- > 0) - *t++ = ' '; - } - break; - - case FF_HALFSPACE: - arg = fieldsize - itemsize; - if (arg) { - arg /= 2; - fieldsize -= arg; - while (arg-- > 0) - *t++ = ' '; - } - break; - - case FF_ITEM: - arg = itemsize; - s = item; - while (arg--) { - if ((*t++ = *s++) < ' ') - t[-1] = ' '; - } - break; - - case FF_CHOP: - s = chophere; - if (chopspace) { - while (*s && isSPACE(*s)) - s++; - } - sv_chop(sv,s); - break; - - case FF_LINEGLOB: - item = s = SvPV(sv, len); - itemsize = len; - if (itemsize) { - gotsome = TRUE; - send = s + itemsize; - while (s < send) { - if (*s++ == '\n') { - if (s == send) - itemsize--; - else - lines++; - } - } - SvCUR_set(formtarget, t - SvPVX(formtarget)); - sv_catpvn(formtarget, item, itemsize); - SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1); - t = SvPVX(formtarget) + SvCUR(formtarget); - } - break; - - case FF_DECIMAL: - /* If the field is marked with ^ and the value is undefined, - blank it out. */ - arg = *fpc++; - if ((arg & 512) && !SvOK(sv)) { - arg = fieldsize; - while (arg--) - *t++ = ' '; - break; - } - gotsome = TRUE; - value = SvNV(sv); - if (arg & 256) { - sprintf(t, "%#*.*f", fieldsize, arg & 255, value); - } else { - sprintf(t, "%*.0f", fieldsize, value); - } - t += fieldsize; - break; - - case FF_NEWLINE: - f++; - while (t-- > linemark && *t == ' ') ; - t++; - *t++ = '\n'; - break; - - case FF_BLANK: - arg = *fpc++; - if (gotsome) { - if (arg) { /* repeat until fields exhausted? */ - fpc -= arg; - f = formmark; - MARK = markmark; - if (lines == 200) { - arg = t - linemark; - if (strnEQ(linemark, linemark - arg, arg)) - DIE("Runaway format"); - } - arg = t - SvPVX(formtarget); - SvGROW(formtarget, - (t - SvPVX(formtarget)) + (f - formmark) + 1); - t = SvPVX(formtarget) + arg; - } - } - else { - t = linemark; - lines--; - } - break; - - case FF_MORE: - if (itemsize) { - arg = fieldsize - itemsize; - if (arg) { - fieldsize -= arg; - while (arg-- > 0) - *t++ = ' '; - } - s = t - 3; - if (strnEQ(s," ",3)) { - while (s > SvPVX(formtarget) && isSPACE(s[-1])) - s--; - } - *s++ = '.'; - *s++ = '.'; - *s++ = '.'; - } - break; - - case FF_END: - *t = '\0'; - SvCUR_set(formtarget, t - SvPVX(formtarget)); - FmLINES(formtarget) += lines; - SP = ORIGMARK; - RETPUSHYES; - } - } -} - PP(pp_ord) { dSP; dTARGET; I32 value; char *tmps; - I32 anum; - if (MAXARG < 1) - tmps = SvPVx(GvSV(defgv), na); - else - tmps = POPp; #ifndef I286 + tmps = POPp; value = (I32) (*tmps & 255); #else + I32 anum; + tmps = POPp; anum = (I32) *tmps; value = (I32) (anum & 255); #endif @@ -3034,17 +1605,14 @@ PP(pp_chr) dSP; dTARGET; char *tmps; - if (SvTYPE(TARG) == SVt_NULL) { - sv_upgrade(TARG,SVt_PV); + if (!SvPOK(TARG)) { + (void)SvUPGRADE(TARG,SVt_PV); SvGROW(TARG,1); } SvCUR_set(TARG, 1); tmps = SvPVX(TARG); - if (MAXARG < 1) - *tmps = SvIVx(GvSV(defgv)); - else - *tmps = POPi; - SvPOK_only(TARG); + *tmps = POPi; + (void)SvPOK_only(TARG); XPUSHs(TARG); RETURN; } @@ -3053,11 +1621,11 @@ PP(pp_crypt) { dSP; dTARGET; dPOPTOPssrl; #ifdef HAS_CRYPT - char *tmps = SvPV(lstr, na); + char *tmps = SvPV(left, na); #ifdef FCRYPT - sv_setpv(TARG, fcrypt(tmps, SvPV(rstr, na))); + sv_setpv(TARG, fcrypt(tmps, SvPV(right, na))); #else - sv_setpv(TARG, crypt(tmps, SvPV(rstr, na))); + sv_setpv(TARG, crypt(tmps, SvPV(right, na))); #endif #else DIE( @@ -3079,9 +1647,9 @@ PP(pp_ucfirst) sv = TARG; SETs(sv); } - s = SvPV(sv, na); - if (isascii(*s) && islower(*s)) - *s = toupper(*s); + s = SvPV_force(sv, na); + if (isLOWER(*s)) + *s = toUPPER(*s); RETURN; } @@ -3098,9 +1666,9 @@ PP(pp_lcfirst) sv = TARG; SETs(sv); } - s = SvPV(sv, na); - if (isascii(*s) && isupper(*s)) - *s = tolower(*s); + s = SvPV_force(sv, na); + if (isUPPER(*s)) + *s = toLOWER(*s); SETs(sv); RETURN; @@ -3120,11 +1688,11 @@ PP(pp_uc) sv = TARG; SETs(sv); } - s = SvPV(sv, len); + s = SvPV_force(sv, len); send = s + len; while (s < send) { - if (isascii(*s) && islower(*s)) - *s = toupper(*s); + if (isLOWER(*s)) + *s = toUPPER(*s); s++; } RETURN; @@ -3144,149 +1712,71 @@ PP(pp_lc) sv = TARG; SETs(sv); } - s = SvPV(sv, len); + s = SvPV_force(sv, len); send = s + len; while (s < send) { - if (isascii(*s) && isupper(*s)) - *s = tolower(*s); + if (isUPPER(*s)) + *s = toLOWER(*s); s++; } RETURN; } -/* Arrays. */ - -PP(pp_rv2av) -{ - dSP; dPOPss; - - AV *av; - - if (SvROK(sv)) { - av = (AV*)SvRV(sv); - if (SvTYPE(av) != SVt_PVAV) - DIE("Not an array reference"); - if (op->op_flags & OPf_LVAL) { - if (op->op_flags & OPf_INTRO) - av = (AV*)save_svref((SV**)sv); - PUSHs((SV*)av); - RETURN; - } - } - else { - if (SvTYPE(sv) == SVt_PVAV) { - av = (AV*)sv; - if (op->op_flags & OPf_LVAL) { - PUSHs((SV*)av); - RETURN; - } - } - else { - if (SvTYPE(sv) != SVt_PVGV) { - if (!SvOK(sv)) - DIE(no_usym, "an array"); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_hardref, "an array"); - sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE, SVt_PVAV); - } - av = GvAVn(sv); - if (op->op_flags & OPf_LVAL) { - if (op->op_flags & OPf_INTRO) - av = save_ary(sv); - PUSHs((SV*)av); - RETURN; - } - } - } - - if (GIMME == G_ARRAY) { - I32 maxarg = AvFILL(av) + 1; - EXTEND(SP, maxarg); - Copy(AvARRAY(av), SP+1, maxarg, SV*); - SP += maxarg; - } - else { - dTARGET; - I32 maxarg = AvFILL(av) + 1; - PUSHi(maxarg); - } - RETURN; -} - -PP(pp_aelemfast) +PP(pp_quotemeta) { - dSP; - AV *av = GvAV((GV*)cSVOP->op_sv); - SV** svp = av_fetch(av, op->op_private - arybase, op->op_flags & OPf_LVAL); - PUSHs(svp ? *svp : &sv_undef); - RETURN; -} - -PP(pp_aelem) -{ - dSP; - SV** svp; - I32 elem = POPi - arybase; - AV *av = (AV*)POPs; + dSP; dTARGET; + SV *sv = TOPs; + STRLEN len; + register char *s = SvPV(sv,len); + register char *d; - if (op->op_flags & OPf_LVAL) { - svp = av_fetch(av, elem, TRUE); - if (!svp || *svp == &sv_undef) - DIE(no_aelem, elem); - if (op->op_flags & OPf_INTRO) - save_svref(svp); - else if (!SvOK(*svp)) { - if (op->op_private & OPpDEREF_HV) { - SvREFCNT_dec(*svp); - *svp = NEWSV(0,0); - sv_upgrade(*svp, SVt_RV); - SvRV(*svp) = SvREFCNT_inc(newHV()); - SvROK_on(*svp); - ++sv_rvcount; - } - else if (op->op_private & OPpDEREF_AV) { - SvREFCNT_dec(*svp); - *svp = NEWSV(0,0); - sv_upgrade(*svp, SVt_RV); - SvRV(*svp) = SvREFCNT_inc(newAV()); - SvROK_on(*svp); - ++sv_rvcount; - } + if (len) { + (void)SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, len * 2); + d = SvPVX(TARG); + while (len--) { + if (!isALNUM(*s)) + *d++ = '\\'; + *d++ = *s++; } + *d = '\0'; + SvCUR_set(TARG, d - SvPVX(TARG)); + (void)SvPOK_only(TARG); } else - svp = av_fetch(av, elem, FALSE); - PUSHs(svp ? *svp : &sv_undef); + sv_setpvn(TARG, s, len); + SETs(TARG); RETURN; } +/* Arrays. */ + PP(pp_aslice) { dSP; dMARK; dORIGMARK; register SV** svp; register AV* av = (AV*)POPs; - register I32 lval = op->op_flags & OPf_LVAL; - I32 is_something_there = lval; - - while (++MARK <= SP) { - I32 elem = SvIVx(*MARK); - - if (lval) { - svp = av_fetch(av, elem, TRUE); - if (!svp || *svp == &sv_undef) - DIE(no_aelem, elem); - if (op->op_flags & OPf_INTRO) - save_svref(svp); - } - else { - svp = av_fetch(av, elem, FALSE); - if (!is_something_there && svp && SvOK(*svp)) - is_something_there = TRUE; + register I32 lval = op->op_flags & OPf_MOD; + + if (SvTYPE(av) == SVt_PVAV) { + while (++MARK <= SP) { + I32 elem = SvIVx(*MARK); + + svp = av_fetch(av, elem, lval); + if (lval) { + if (!svp || *svp == &sv_undef) + DIE(no_aelem, elem); + if (op->op_private & OPpLVAL_INTRO) + save_svref(svp); + } + *MARK = svp ? *svp : &sv_undef; } - *MARK = svp ? *svp : &sv_undef; } - if (!is_something_there) - SP = ORIGMARK; + else if (GIMME != G_ARRAY) { + MARK = ORIGMARK; + *++MARK = *SP; + SP = MARK; + } RETURN; } @@ -3335,8 +1825,8 @@ PP(pp_delete) HV *hv = (HV*)POPs; char *tmps; STRLEN len; - if (!hv) { - DIE("Not an associative array reference"); + if (SvTYPE(hv) != SVt_PVHV) { + DIE("Not a HASH reference"); } tmps = SvPV(tmpsv, len); sv = hv_delete(hv, tmps, len); @@ -3346,135 +1836,425 @@ PP(pp_delete) RETURN; } -PP(pp_rv2hv) +PP(pp_exists) { + dSP; + SV *tmpsv = POPs; + HV *hv = (HV*)POPs; + char *tmps; + STRLEN len; + if (SvTYPE(hv) != SVt_PVHV) { + DIE("Not a HASH reference"); + } + tmps = SvPV(tmpsv, len); + if (hv_exists(hv, tmps, len)) + RETPUSHYES; + RETPUSHNO; +} - dSP; dTOPss; +PP(pp_hslice) +{ + dSP; dMARK; dORIGMARK; + register SV **svp; + register HV *hv = (HV*)POPs; + register I32 lval = op->op_flags & OPf_MOD; - HV *hv; + if (SvTYPE(hv) == SVt_PVHV) { + while (++MARK <= SP) { + STRLEN keylen; + char *key = SvPV(*MARK, keylen); - if (SvROK(sv)) { - hv = (HV*)SvRV(sv); - if (SvTYPE(hv) != SVt_PVHV) - DIE("Not an associative array reference"); - if (op->op_flags & OPf_LVAL) { - if (op->op_flags & OPf_INTRO) - hv = (HV*)save_svref((SV**)sv); - SETs((SV*)hv); - RETURN; + 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) { + MARK = ORIGMARK; + *++MARK = *SP; + SP = MARK; + } + RETURN; +} + +/* List operators. */ + +PP(pp_list) +{ + dSP; dMARK; + if (GIMME != G_ARRAY) { + if (++MARK <= SP) + *MARK = *SP; /* unwanted list, return last item */ + else + *MARK = &sv_undef; + SP = MARK; + } + RETURN; +} + +PP(pp_lslice) +{ + dSP; + SV **lastrelem = stack_sp; + SV **lastlelem = stack_base + POPMARK; + SV **firstlelem = stack_base + POPMARK + 1; + register SV **firstrelem = lastlelem + 1; + I32 arybase = curcop->cop_arybase; + + register I32 max = lastrelem - lastlelem; + register SV **lelem; + register I32 ix; + + if (GIMME != G_ARRAY) { + ix = SvIVx(*lastlelem) - arybase; + if (ix < 0 || ix >= max) + *firstlelem = &sv_undef; + else + *firstlelem = firstrelem[ix]; + SP = firstlelem; + RETURN; + } + + if (max == 0) { + SP = firstlelem - 1; + RETURN; + } + + for (lelem = firstlelem; lelem <= lastlelem; lelem++) { + ix = SvIVx(*lelem) - arybase; + if (ix < 0) { + ix += max; + if (ix < 0) + *lelem = &sv_undef; + else if (!(*lelem = firstrelem[ix])) + *lelem = &sv_undef; + } + else if (ix >= max || !(*lelem = firstrelem[ix])) + *lelem = &sv_undef; + } + SP = lastlelem; + RETURN; +} + +PP(pp_anonlist) +{ + dSP; dMARK; + I32 items = SP - MARK; + SP = MARK; + XPUSHs((SV*)sv_2mortal((SV*)av_make(items, MARK+1))); + RETURN; +} + +PP(pp_anonhash) +{ + dSP; dMARK; dORIGMARK; + STRLEN len; + HV* hv = (HV*)sv_2mortal((SV*)newHV()); + + while (MARK < SP) { + SV* key = *++MARK; + char *tmps; + SV *val = NEWSV(46, 0); + if (MARK < SP) + sv_setsv(val, *++MARK); + else + 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); + RETURN; +} + +PP(pp_splice) +{ + dSP; dMARK; dORIGMARK; + register AV *ary = (AV*)*++MARK; + register SV **src; + register SV **dst; + register I32 i; + register I32 offset; + register I32 length; + I32 newlen; + I32 after; + I32 diff; + SV **tmparyval = 0; + + SP++; + + if (++MARK < SP) { + offset = SvIVx(*MARK); + if (offset < 0) + offset += AvFILL(ary) + 1; + else + offset -= curcop->cop_arybase; + if (++MARK < SP) { + length = SvIVx(*MARK++); + if (length < 0) + length = 0; } + else + length = AvMAX(ary) + 1; /* close enough to infinity */ } else { - if (SvTYPE(sv) == SVt_PVHV) { - hv = (HV*)sv; - if (op->op_flags & OPf_LVAL) { - SETs((SV*)hv); - RETURN; + offset = 0; + length = AvMAX(ary) + 1; + } + if (offset < 0) { + length += offset; + offset = 0; + if (length < 0) + length = 0; + } + if (offset > AvFILL(ary) + 1) + offset = AvFILL(ary) + 1; + after = AvFILL(ary) + 1 - (offset + length); + if (after < 0) { /* not that much array */ + length += after; /* offset+length now in array */ + after = 0; + if (!AvALLOC(ary)) + av_extend(ary, 0); + } + + /* At this point, MARK .. SP-1 is our new LIST */ + + newlen = SP - MARK; + diff = newlen - length; + + if (diff < 0) { /* shrinking the area */ + if (newlen) { + New(451, tmparyval, newlen, SV*); /* so remember insertion */ + Copy(MARK, tmparyval, newlen, SV*); + } + + MARK = ORIGMARK + 1; + if (GIMME == G_ARRAY) { /* copy return vals to stack */ + MEXTEND(MARK, length); + Copy(AvARRAY(ary)+offset, MARK, length, SV*); + if (AvREAL(ary)) { + for (i = length, dst = MARK; i; i--) + sv_2mortal(*dst++); /* free them eventualy */ } + MARK += length - 1; } else { - if (SvTYPE(sv) != SVt_PVGV) { - if (!SvOK(sv)) - DIE(no_usym, "a hash"); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_hardref, "a hash"); - sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE, SVt_PVHV); + *MARK = AvARRAY(ary)[offset+length-1]; + if (AvREAL(ary)) { + sv_2mortal(*MARK); + for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) + SvREFCNT_dec(*dst++); /* free them now */ } - hv = GvHVn(sv); - if (op->op_flags & OPf_LVAL) { - if (op->op_flags & OPf_INTRO) - hv = save_hash(sv); - SETs((SV*)hv); - RETURN; + } + AvFILL(ary) += diff; + + /* pull up or down? */ + + if (offset < after) { /* easier to pull up */ + if (offset) { /* esp. if nothing to pull */ + src = &AvARRAY(ary)[offset-1]; + dst = src - diff; /* diff is negative */ + for (i = offset; i > 0; i--) /* can't trust Copy */ + *dst-- = *src--; + } + dst = AvARRAY(ary); + SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */ + AvMAX(ary) += diff; + } + else { + if (after) { /* anything to pull down? */ + src = AvARRAY(ary) + offset + length; + dst = src + diff; /* diff is negative */ + Move(src, dst, after, SV*); } + dst = &AvARRAY(ary)[AvFILL(ary)+1]; + /* avoid later double free */ + } + i = -diff; + while (i) + dst[--i] = &sv_undef; + + if (newlen) { + for (src = tmparyval, dst = AvARRAY(ary) + offset; + newlen; newlen--) { + *dst = NEWSV(46, 0); + sv_setsv(*dst++, *src++); + } + Safefree(tmparyval); } } + else { /* no, expanding (or same) */ + if (length) { + New(452, tmparyval, length, SV*); /* so remember deletion */ + Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); + } - if (GIMME == G_ARRAY) { /* array wanted */ - *stack_sp = (SV*)hv; - return do_kv(ARGS); - } - else { - dTARGET; - if (HvFILL(hv)) { - sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1); - sv_setpv(TARG, buf); + if (diff > 0) { /* expanding */ + + /* push up or down? */ + + if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { + if (offset) { + src = AvARRAY(ary); + dst = src - diff; + Move(src, dst, offset, SV*); + } + SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */ + AvMAX(ary) += diff; + AvFILL(ary) += diff; + } + else { + if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */ + av_extend(ary, AvFILL(ary) + diff); + AvFILL(ary) += diff; + + if (after) { + dst = AvARRAY(ary) + AvFILL(ary); + src = dst - diff; + for (i = after; i; i--) { + *dst-- = *src--; + } + } + } + } + + for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) { + *dst = NEWSV(46, 0); + sv_setsv(*dst++, *src++); + } + MARK = ORIGMARK + 1; + if (GIMME == G_ARRAY) { /* copy return vals to stack */ + if (length) { + Copy(tmparyval, MARK, length, SV*); + if (AvREAL(ary)) { + for (i = length, dst = MARK; i; i--) + sv_2mortal(*dst++); /* free them eventualy */ + } + Safefree(tmparyval); + } + MARK += length - 1; + } + else if (length--) { + *MARK = tmparyval[length]; + if (AvREAL(ary)) { + sv_2mortal(*MARK); + while (length-- > 0) + SvREFCNT_dec(tmparyval[length]); + } + Safefree(tmparyval); } else - sv_setiv(TARG, 0); - SETTARG; - RETURN; + *MARK = &sv_undef; } + SP = MARK; + RETURN; } -PP(pp_helem) +PP(pp_push) +{ + dSP; dMARK; dORIGMARK; dTARGET; + register AV *ary = (AV*)*++MARK; + register SV *sv = &sv_undef; + + for (++MARK; MARK <= SP; MARK++) { + sv = NEWSV(51, 0); + if (*MARK) + sv_setsv(sv, *MARK); + av_push(ary, sv); + } + SP = ORIGMARK; + PUSHi( AvFILL(ary) + 1 ); + RETURN; +} + +PP(pp_pop) { dSP; - SV** svp; - SV *keysv = POPs; - STRLEN keylen; - char *key = SvPV(keysv, keylen); - HV *hv = (HV*)POPs; + AV *av = (AV*)POPs; + SV *sv = av_pop(av); + if (sv != &sv_undef && AvREAL(av)) + (void)sv_2mortal(sv); + PUSHs(sv); + RETURN; +} - if (op->op_flags & OPf_LVAL) { - svp = hv_fetch(hv, key, keylen, TRUE); - if (!svp || *svp == &sv_undef) - DIE(no_helem, key); - if (op->op_flags & OPf_INTRO) - save_svref(svp); - else if (!SvOK(*svp)) { - if (op->op_private & OPpDEREF_HV) { - SvREFCNT_dec(*svp); - *svp = NEWSV(0,0); - sv_upgrade(*svp, SVt_RV); - SvRV(*svp) = SvREFCNT_inc(newHV()); - SvROK_on(*svp); - ++sv_rvcount; - } - else if (op->op_private & OPpDEREF_AV) { - SvREFCNT_dec(*svp); - *svp = NEWSV(0,0); - sv_upgrade(*svp, SVt_RV); - SvRV(*svp) = SvREFCNT_inc(newAV()); - SvROK_on(*svp); - ++sv_rvcount; - } - } +PP(pp_shift) +{ + dSP; + AV *av = (AV*)POPs; + SV *sv = av_shift(av); + EXTEND(SP, 1); + if (!sv) + RETPUSHUNDEF; + if (sv != &sv_undef && AvREAL(av)) + (void)sv_2mortal(sv); + PUSHs(sv); + RETURN; +} + +PP(pp_unshift) +{ + dSP; dMARK; dORIGMARK; dTARGET; + register AV *ary = (AV*)*++MARK; + register SV *sv; + register I32 i = 0; + + av_unshift(ary, SP - MARK); + while (MARK < SP) { + sv = NEWSV(27, 0); + sv_setsv(sv, *++MARK); + (void)av_store(ary, i++, sv); } - else - svp = hv_fetch(hv, key, keylen, FALSE); - PUSHs(svp ? *svp : &sv_undef); + + SP = ORIGMARK; + PUSHi( AvFILL(ary) + 1 ); RETURN; } -PP(pp_hslice) +PP(pp_reverse) { - dSP; dMARK; dORIGMARK; - register SV **svp; - register HV *hv = (HV*)POPs; - register I32 lval = op->op_flags & OPf_LVAL; - I32 is_something_there = lval; - - while (++MARK <= SP) { - STRLEN keylen; - char *key = SvPV(*MARK, keylen); - - if (lval) { - svp = hv_fetch(hv, key, keylen, TRUE); - if (!svp || *svp == &sv_undef) - DIE(no_helem, key); - if (op->op_flags & OPf_INTRO) - save_svref(svp); + dSP; dMARK; + register SV *tmp; + SV **oldsp = SP; + + if (GIMME == G_ARRAY) { + MARK++; + while (MARK < SP) { + tmp = *MARK; + *MARK++ = *SP; + *SP-- = tmp; } - else { - svp = hv_fetch(hv, key, keylen, FALSE); - if (!is_something_there && svp && SvOK(*svp)) - is_something_there = TRUE; + SP = oldsp; + } + else { + register char *up; + register char *down; + register I32 tmp; + dTARGET; + STRLEN len; + + if (SP - MARK > 1) + do_join(TARG, &sv_no, MARK, SP); + else + sv_setsv(TARG, *SP); + up = SvPV_force(TARG, len); + if (len > 1) { + down = SvPVX(TARG) + len - 1; + while (down > up) { + tmp = *up; + *up++ = *down; + *down-- = tmp; + } + (void)SvPOK_only(TARG); } - *MARK = svp ? *svp : &sv_undef; + SP = MARK + 1; + SETTARG; } - if (!is_something_there) - SP = ORIGMARK; RETURN; } @@ -3487,8 +2267,8 @@ PP(pp_unpack) SV *sv; STRLEN llen; STRLEN rlen; - register char *pat = SvPV(lstr, llen); - register char *s = SvPV(rstr, rlen); + register char *pat = SvPV(left, llen); + register char *s = SvPV(right, rlen); char *strend = s + rlen; char *strbeg = s; register char *patend = pat + llen; @@ -3957,7 +2737,7 @@ PP(pp_unpack) s += sizeof(quad); } sv = NEWSV(42, 0); - sv_setnv(sv, (double)aquad); + sv_setiv(sv, (IV)aquad); PUSHs(sv_2mortal(sv)); } break; @@ -3971,7 +2751,7 @@ PP(pp_unpack) s += sizeof(unsigned quad); } sv = NEWSV(43, 0); - sv_setnv(sv, (double)auquad); + sv_setiv(sv, (IV)auquad); PUSHs(sv_2mortal(sv)); } break; @@ -4067,7 +2847,6 @@ PP(pp_unpack) sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || (checksum > 32 && strchr("iIlLN", datumtype)) ) { - double modf(); double trouble; adouble = 1.0; @@ -4452,14 +3231,14 @@ PP(pp_pack) case 'Q': while (len-- > 0) { fromstr = NEXTFROM; - auquad = (unsigned quad)SvNV(fromstr); + auquad = (unsigned quad)SvIV(fromstr); sv_catpvn(cat, (char*)&auquad, sizeof(unsigned quad)); } break; case 'q': while (len-- > 0) { fromstr = NEXTFROM; - aquad = (quad)SvNV(fromstr); + aquad = (quad)SvIV(fromstr); sv_catpvn(cat, (char*)&aquad, sizeof(quad)); } break; @@ -4470,7 +3249,7 @@ PP(pp_pack) case 'p': while (len-- > 0) { fromstr = NEXTFROM; - aptr = SvPV(fromstr, na); + aptr = SvPV_force(fromstr, na); /* XXX Error if TEMP? */ sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } break; @@ -4522,7 +3301,7 @@ PP(pp_split) I32 origlimit = limit; I32 realarray = 0; I32 base; - AV *oldstack; + AV *oldstack = stack; register REGEXP *rx = pm->op_pmregexp; I32 gimme = GIMME; @@ -4539,12 +3318,11 @@ PP(pp_split) if (!AvREAL(ary)) { AvREAL_on(ary); for (i = AvFILL(ary); i >= 0; i--) - AvARRAY(ary)[i] = Nullsv; /* don't free mere refs */ + AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */ } - av_fill(ary,0); /* force allocation */ - av_fill(ary,-1); + av_extend(ary,0); + av_clear(ary); /* temporarily switch stacks */ - oldstack = stack; SWITCHSTACK(stack, ary); } base = SP - stack_base; @@ -4591,12 +3369,12 @@ PP(pp_split) I32 fold = (pm->op_pmflags & PMf_FOLD); i = *SvPVX(pm->op_pmshort); if (fold && isUPPER(i)) - i = tolower(i); + i = toLOWER(i); while (--limit) { if (fold) { for ( m = s; m < strend && *m != i && - (!isUPPER(*m) || tolower(*m) != i); + (!isUPPER(*m) || toLOWER(*m) != i); m++) /*SUPPRESS 530*/ ; } @@ -4663,7 +3441,9 @@ PP(pp_split) iters = (SP - stack_base) - base; if (iters > maxiters) DIE("Split loop"); - if (s < strend || origlimit) { /* keep field after final delim? */ + + /* keep field after final delim? */ + if (s < strend || (iters && origlimit)) { dstr = NEWSV(34, strend-s); sv_setpvn(dstr, s, strend-s); if (!realarray) @@ -4671,7 +3451,7 @@ PP(pp_split) XPUSHs(dstr); iters++; } - else { + else if (!origlimit) { while (iters > 0 && SvCUR(TOPs) == 0) iters--, SP--; } @@ -4688,6025 +3468,11 @@ PP(pp_split) if (gimme == G_ARRAY) RETURN; } - GETTARGET; - PUSHi(iters); - RETURN; -} - -PP(pp_join) -{ - dSP; dMARK; dTARGET; - MARK++; - do_join(TARG, *MARK, MARK, SP); - SP = MARK; - SETs(TARG); - RETURN; -} - -/* List operators. */ - -PP(pp_list) -{ - dSP; dMARK; - if (GIMME != G_ARRAY) { - if (++MARK <= SP) - *MARK = *SP; /* unwanted list, return last item */ - else - *MARK = &sv_undef; - SP = MARK; - } - RETURN; -} - -PP(pp_lslice) -{ - dSP; - SV **lastrelem = stack_sp; - SV **lastlelem = stack_base + POPMARK; - SV **firstlelem = stack_base + POPMARK + 1; - register SV **firstrelem = lastlelem + 1; - I32 lval = op->op_flags & OPf_LVAL; - I32 is_something_there = lval; - - register I32 max = lastrelem - lastlelem; - register SV **lelem; - register I32 ix; - - if (GIMME != G_ARRAY) { - ix = SvIVx(*lastlelem) - arybase; - if (ix < 0 || ix >= max) - *firstlelem = &sv_undef; - else - *firstlelem = firstrelem[ix]; - SP = firstlelem; - RETURN; - } - - if (max == 0) { - SP = firstlelem - 1; - RETURN; - } - - for (lelem = firstlelem; lelem <= lastlelem; lelem++) { - ix = SvIVx(*lelem) - arybase; - if (ix < 0) { - ix += max; - if (ix < 0) - *lelem = &sv_undef; - else if (!(*lelem = firstrelem[ix])) - *lelem = &sv_undef; - } - else if (ix >= max || !(*lelem = firstrelem[ix])) - *lelem = &sv_undef; - if (!is_something_there && SvOK(*lelem)) - is_something_there = TRUE; - } - if (is_something_there) - SP = lastlelem; - else - SP = firstlelem - 1; - RETURN; -} - -PP(pp_anonlist) -{ - dSP; dMARK; - I32 items = SP - MARK; - SP = MARK; - XPUSHs((SV*)av_make(items, MARK+1)); - RETURN; -} - -PP(pp_anonhash) -{ - dSP; dMARK; dORIGMARK; - STRLEN len; - HV* hv = newHV(); - - SvREFCNT(hv) = 0; - while (MARK < SP) { - SV* key = *++MARK; - char *tmps; - SV *val = NEWSV(46, 0); - if (MARK < SP) - sv_setsv(val, *++MARK); - tmps = SvPV(key,len); - (void)hv_store(hv,tmps,len,val,0); - } - SP = ORIGMARK; - SvOK_on(hv); - XPUSHs((SV*)hv); - RETURN; -} - -PP(pp_splice) -{ - dSP; dMARK; dORIGMARK; - register AV *ary = (AV*)*++MARK; - register SV **src; - register SV **dst; - register I32 i; - register I32 offset; - register I32 length; - I32 newlen; - I32 after; - I32 diff; - SV **tmparyval; - - SP++; - - if (++MARK < SP) { - offset = SvIVx(*MARK); - if (offset < 0) - offset += AvFILL(ary) + 1; - else - offset -= arybase; - if (++MARK < SP) { - length = SvIVx(*MARK++); - if (length < 0) - length = 0; - } - else - length = AvMAX(ary) + 1; /* close enough to infinity */ - } - else { - offset = 0; - length = AvMAX(ary) + 1; - } - if (offset < 0) { - length += offset; - offset = 0; - if (length < 0) - length = 0; - } - if (offset > AvFILL(ary) + 1) - offset = AvFILL(ary) + 1; - after = AvFILL(ary) + 1 - (offset + length); - if (after < 0) { /* not that much array */ - length += after; /* offset+length now in array */ - after = 0; - if (!AvALLOC(ary)) { - av_fill(ary, 0); - av_fill(ary, -1); - } - } - - /* At this point, MARK .. SP-1 is our new LIST */ - - newlen = SP - MARK; - diff = newlen - length; - - if (diff < 0) { /* shrinking the area */ - if (newlen) { - New(451, tmparyval, newlen, SV*); /* so remember insertion */ - Copy(MARK, tmparyval, newlen, SV*); - } - - MARK = ORIGMARK + 1; - if (GIMME == G_ARRAY) { /* copy return vals to stack */ - MEXTEND(MARK, length); - Copy(AvARRAY(ary)+offset, MARK, length, SV*); - if (AvREAL(ary)) { - for (i = length, dst = MARK; i; i--) - sv_2mortal(*dst++); /* free them eventualy */ - } - MARK += length - 1; - } - else { - *MARK = AvARRAY(ary)[offset+length-1]; - if (AvREAL(ary)) { - sv_2mortal(*MARK); - for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) - SvREFCNT_dec(*dst++); /* free them now */ - } - } - AvFILL(ary) += diff; - - /* pull up or down? */ - - if (offset < after) { /* easier to pull up */ - if (offset) { /* esp. if nothing to pull */ - src = &AvARRAY(ary)[offset-1]; - dst = src - diff; /* diff is negative */ - for (i = offset; i > 0; i--) /* can't trust Copy */ - *dst-- = *src--; - } - Zero(AvARRAY(ary), -diff, SV*); - SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */ - AvMAX(ary) += diff; - } - else { - if (after) { /* anything to pull down? */ - src = AvARRAY(ary) + offset + length; - dst = src + diff; /* diff is negative */ - Move(src, dst, after, SV*); - } - Zero(&AvARRAY(ary)[AvFILL(ary)+1], -diff, SV*); - /* avoid later double free */ - } - if (newlen) { - for (src = tmparyval, dst = AvARRAY(ary) + offset; - newlen; newlen--) { - *dst = NEWSV(46, 0); - sv_setsv(*dst++, *src++); - } - Safefree(tmparyval); - } - } - else { /* no, expanding (or same) */ - if (length) { - New(452, tmparyval, length, SV*); /* so remember deletion */ - Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); - } - - if (diff > 0) { /* expanding */ - - /* push up or down? */ - - if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { - if (offset) { - src = AvARRAY(ary); - dst = src - diff; - Move(src, dst, offset, SV*); - } - SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */ - AvMAX(ary) += diff; - AvFILL(ary) += diff; - } - else { - if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */ - av_store(ary, AvFILL(ary) + diff, Nullsv); - else - AvFILL(ary) += diff; - dst = AvARRAY(ary) + AvFILL(ary); - for (i = diff; i > 0; i--) { - if (*dst) /* stuff was hanging around */ - SvREFCNT_dec(*dst); /* after $#foo */ - dst--; - } - if (after) { - dst = AvARRAY(ary) + AvFILL(ary); - src = dst - diff; - for (i = after; i; i--) { - *dst-- = *src--; - } - } - } - } - - for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) { - *dst = NEWSV(46, 0); - sv_setsv(*dst++, *src++); - } - MARK = ORIGMARK + 1; - if (GIMME == G_ARRAY) { /* copy return vals to stack */ - if (length) { - Copy(tmparyval, MARK, length, SV*); - if (AvREAL(ary)) { - for (i = length, dst = MARK; i; i--) - sv_2mortal(*dst++); /* free them eventualy */ - } - Safefree(tmparyval); - } - MARK += length - 1; - } - else if (length--) { - *MARK = tmparyval[length]; - if (AvREAL(ary)) { - sv_2mortal(*MARK); - while (length-- > 0) - SvREFCNT_dec(tmparyval[length]); - } - Safefree(tmparyval); - } - else - *MARK = &sv_undef; - } - SP = MARK; - RETURN; -} - -PP(pp_push) -{ - dSP; dMARK; dORIGMARK; dTARGET; - register AV *ary = (AV*)*++MARK; - register SV *sv = &sv_undef; - - for (++MARK; MARK <= SP; MARK++) { - sv = NEWSV(51, 0); - if (*MARK) - sv_setsv(sv, *MARK); - (void)av_push(ary, sv); - } - SP = ORIGMARK; - PUSHi( AvFILL(ary) + 1 ); - RETURN; -} - -PP(pp_pop) -{ - dSP; - AV *av = (AV*)POPs; - SV *sv = av_pop(av); - if (!sv) - RETPUSHUNDEF; - if (AvREAL(av)) - (void)sv_2mortal(sv); - PUSHs(sv); - RETURN; -} - -PP(pp_shift) -{ - dSP; - AV *av = (AV*)POPs; - SV *sv = av_shift(av); - EXTEND(SP, 1); - if (!sv) - RETPUSHUNDEF; - if (AvREAL(av)) - (void)sv_2mortal(sv); - PUSHs(sv); - RETURN; -} - -PP(pp_unshift) -{ - dSP; dMARK; dORIGMARK; dTARGET; - register AV *ary = (AV*)*++MARK; - register SV *sv; - register I32 i = 0; - - av_unshift(ary, SP - MARK); - while (MARK < SP) { - sv = NEWSV(27, 0); - sv_setsv(sv, *++MARK); - (void)av_store(ary, i++, sv); - } - - SP = ORIGMARK; - PUSHi( AvFILL(ary) + 1 ); - RETURN; -} - -PP(pp_grepstart) -{ - dSP; - SV *src; - - if (stack_base + *markstack_ptr == sp) { - POPMARK; - RETURNOP(op->op_next->op_next); - } - stack_sp = stack_base + *markstack_ptr + 1; - pp_pushmark(); /* push dst */ - pp_pushmark(); /* push src */ - ENTER; /* enter outer scope */ - - SAVETMPS; - SAVESPTR(GvSV(defgv)); - - ENTER; /* enter inner scope */ - SAVESPTR(curpm); - - if (src = stack_base[*markstack_ptr]) { - SvTEMP_off(src); - GvSV(defgv) = src; - } - else - GvSV(defgv) = sv_newmortal(); - - RETURNOP(((LOGOP*)op->op_next)->op_other); -} - -PP(pp_grepwhile) -{ - dSP; - - if (SvTRUEx(POPs)) - stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr]; - ++*markstack_ptr; - LEAVE; /* exit inner scope */ - - /* All done yet? */ - if (stack_base + *markstack_ptr > sp) { - I32 items; - - LEAVE; /* exit outer scope */ - POPMARK; /* pop src */ - items = --*markstack_ptr - markstack_ptr[-1]; - POPMARK; /* pop dst */ - SP = stack_base + POPMARK; /* pop original mark */ - if (GIMME != G_ARRAY) { - dTARGET; - XPUSHi(items); - RETURN; - } - SP += items; - RETURN; - } - else { - SV *src; - - ENTER; /* enter inner scope */ - SAVESPTR(curpm); - - if (src = stack_base[*markstack_ptr]) { - SvTEMP_off(src); - GvSV(defgv) = src; - } - else - GvSV(defgv) = sv_newmortal(); - - RETURNOP(cLOGOP->op_other); - } -} - -static int sortcmp(); -static int sortcv(); - -PP(pp_sort) -{ - dSP; dMARK; dORIGMARK; - register SV **up; - SV **myorigmark = ORIGMARK; - register I32 max; - register I32 i; - HV *stash; - SV *sortcvvar; - GV *gv; - CV *cv; - - if (GIMME != G_ARRAY) { - SP = MARK; - RETPUSHUNDEF; - } - - if (op->op_flags & OPf_STACKED) { - ENTER; - if (op->op_flags & OPf_SPECIAL) { - OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ - kid = kUNOP->op_first; /* pass rv2gv */ - kid = kUNOP->op_first; /* pass leave */ - sortcop = kid->op_next; - stash = curcop->cop_stash; - } - else { - cv = sv_2cv(*++MARK, &stash, &gv, 0); - if (!(cv && CvROOT(cv))) { - if (gv) { - SV *tmpstr = sv_newmortal(); - gv_efullname(tmpstr, gv); - if (CvUSERSUB(cv)) - DIE("Usersub \"%s\" called in sort", SvPVX(tmpstr)); - DIE("Undefined sort subroutine \"%s\" called", - SvPVX(tmpstr)); - } - if (cv) { - if (CvUSERSUB(cv)) - DIE("Usersub called in sort"); - DIE("Undefined subroutine in sort"); - } - DIE("Not a subroutine reference in sort"); - } - sortcop = CvSTART(cv); - SAVESPTR(CvROOT(cv)->op_ppaddr); - CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL]; - - SAVESPTR(curpad); - curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); - } - } - else { - sortcop = Nullop; - stash = curcop->cop_stash; - } - - up = myorigmark + 1; - while (MARK < SP) { /* This may or may not shift down one here. */ - /*SUPPRESS 560*/ - if (*up = *++MARK) { /* Weed out nulls. */ - if (!SvPOK(*up)) - (void)sv_2pv(*up, &na); - else - SvTEMP_off(*up); - up++; - } - } - max = --up - myorigmark; - if (max > 1) { - if (sortcop) { - AV *oldstack; - - SAVETMPS; - SAVESPTR(op); - - oldstack = stack; - if (!sortstack) { - sortstack = newAV(); - av_store(sortstack, 32, Nullsv); - av_clear(sortstack); - AvREAL_off(sortstack); - } - SWITCHSTACK(stack, sortstack); - if (sortstash != stash) { - firstgv = gv_fetchpv("a", TRUE, SVt_PV); - secondgv = gv_fetchpv("b", TRUE, SVt_PV); - sortstash = stash; - } - - SAVESPTR(GvSV(firstgv)); - SAVESPTR(GvSV(secondgv)); - - qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv); - - SWITCHSTACK(sortstack, oldstack); - - LEAVE; - } - else { - MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ - qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp); - } - } - SP = ORIGMARK + max; - RETURN; -} - -PP(pp_reverse) -{ - dSP; dMARK; - register SV *tmp; - SV **oldsp = SP; - - if (GIMME == G_ARRAY) { - MARK++; - while (MARK < SP) { - tmp = *MARK; - *MARK++ = *SP; - *SP-- = tmp; - } - SP = oldsp; - } - else { - register char *up; - register char *down; - register I32 tmp; - dTARGET; - STRLEN len; - - if (SP - MARK > 1) - do_join(TARG, &sv_no, MARK, SP); - else - sv_setsv(TARG, *SP); - up = SvPV(TARG, len); - if (len > 1) { - down = SvPVX(TARG) + len - 1; - while (down > up) { - tmp = *up; - *up++ = *down; - *down-- = tmp; - } - SvPOK_only(TARG); - } - SP = MARK + 1; - SETTARG; - } - RETURN; -} - -/* Range stuff. */ - -PP(pp_range) -{ - if (GIMME == G_ARRAY) - return cCONDOP->op_true; - return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true; -} - -PP(pp_flip) -{ - dSP; - - if (GIMME == G_ARRAY) { - RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); - } - else { - dTOPss; - SV *targ = PAD_SV(op->op_targ); - - if ((op->op_private & OPpFLIP_LINENUM) - ? last_in_gv && SvIV(sv) == IoLINES(GvIO(last_in_gv)) - : SvTRUE(sv) ) { - sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); - if (op->op_flags & OPf_SPECIAL) { - sv_setiv(targ, 1); - RETURN; - } - else { - sv_setiv(targ, 0); - sp--; - RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); - } - } - sv_setpv(TARG, ""); - SETs(targ); + if (iters || !pm->op_pmreplroot) { + GETTARGET; + PUSHi(iters); RETURN; } -} - -PP(pp_flop) -{ - dSP; - - if (GIMME == G_ARRAY) { - dPOPPOPssrl; - register I32 i; - register SV *sv; - I32 max; - - if (SvNIOK(lstr) || !SvPOK(lstr) || - (looks_like_number(lstr) && *SvPVX(lstr) != '0') ) { - i = SvIV(lstr); - max = SvIV(rstr); - if (max > i) - EXTEND(SP, max - i + 1); - while (i <= max) { - sv = sv_mortalcopy(&sv_no); - sv_setiv(sv,i++); - PUSHs(sv); - } - } - else { - SV *final = sv_mortalcopy(rstr); - STRLEN len; - char *tmps = SvPV(final, len); - - sv = sv_mortalcopy(lstr); - while (!SvNIOK(sv) && SvCUR(sv) <= len && - strNE(SvPVX(sv),tmps) ) { - XPUSHs(sv); - sv = sv_2mortal(newSVsv(sv)); - sv_inc(sv); - } - if (strEQ(SvPVX(sv),tmps)) - XPUSHs(sv); - } - } - else { - dTOPss; - SV *targ = PAD_SV(cUNOP->op_first->op_targ); - sv_inc(targ); - if ((op->op_private & OPpFLIP_LINENUM) - ? last_in_gv && SvIV(sv) == IoLINES(GvIO(last_in_gv)) - : SvTRUE(sv) ) { - sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); - sv_catpv(targ, "E0"); - } - SETs(targ); - } - - RETURN; -} - -/* Control. */ - -static I32 -dopoptolabel(label) -char *label; -{ - register I32 i; - register CONTEXT *cx; - - for (i = cxstack_ix; i >= 0; i--) { - cx = &cxstack[i]; - switch (cx->cx_type) { - case CXt_SUBST: - if (dowarn) - warn("Exiting substitution via %s", op_name[op->op_type]); - break; - case CXt_SUB: - if (dowarn) - warn("Exiting subroutine via %s", op_name[op->op_type]); - break; - case CXt_EVAL: - if (dowarn) - warn("Exiting eval via %s", op_name[op->op_type]); - break; - case CXt_LOOP: - if (!cx->blk_loop.label || - strNE(label, cx->blk_loop.label) ) { - DEBUG_l(deb("(Skipping label #%d %s)\n", - i, cx->blk_loop.label)); - continue; - } - DEBUG_l( deb("(Found label #%d %s)\n", i, label)); - return i; - } - } -} - -static I32 -dopoptosub(startingblock) -I32 startingblock; -{ - I32 i; - register CONTEXT *cx; - for (i = startingblock; i >= 0; i--) { - cx = &cxstack[i]; - switch (cx->cx_type) { - default: - continue; - case CXt_EVAL: - case CXt_SUB: - DEBUG_l( deb("(Found sub #%d)\n", i)); - return i; - } - } - return i; -} - -I32 -dopoptoeval(startingblock) -I32 startingblock; -{ - I32 i; - register CONTEXT *cx; - for (i = startingblock; i >= 0; i--) { - cx = &cxstack[i]; - switch (cx->cx_type) { - default: - continue; - case CXt_EVAL: - DEBUG_l( deb("(Found eval #%d)\n", i)); - return i; - } - } - return i; -} - -static I32 -dopoptoloop(startingblock) -I32 startingblock; -{ - I32 i; - register CONTEXT *cx; - for (i = startingblock; i >= 0; i--) { - cx = &cxstack[i]; - switch (cx->cx_type) { - case CXt_SUBST: - if (dowarn) - warn("Exiting substitition via %s", op_name[op->op_type]); - break; - case CXt_SUB: - if (dowarn) - warn("Exiting subroutine via %s", op_name[op->op_type]); - break; - case CXt_EVAL: - if (dowarn) - warn("Exiting eval via %s", op_name[op->op_type]); - break; - case CXt_LOOP: - DEBUG_l( deb("(Found loop #%d)\n", i)); - return i; - } - } - return i; -} - -static void -dounwind(cxix) -I32 cxix; -{ - register CONTEXT *cx; - SV **newsp; - I32 optype; - - while (cxstack_ix > cxix) { - cx = &cxstack[cxstack_ix--]; - DEBUG_l(fprintf(stderr, "Unwinding block %d, type %s\n", cxstack_ix+1, - block_type[cx->cx_type])); - /* Note: we don't need to restore the base context info till the end. */ - switch (cx->cx_type) { - case CXt_SUB: - POPSUB(cx); - break; - case CXt_EVAL: - POPEVAL(cx); - break; - case CXt_LOOP: - POPLOOP(cx); - break; - case CXt_SUBST: - break; - } - } -} - -#ifdef STANDARD_C -OP * -die(char* pat, ...) -#else -/*VARARGS0*/ -OP * -die(pat, va_alist) - char *pat; - va_dcl -#endif -{ - va_list args; - char *tmps; - char *message; - OP *retop; - -#ifdef STANDARD_C - va_start(args, pat); -#else - va_start(args); -#endif - message = mess(pat, &args); - va_end(args); - restartop = die_where(message); - if (stack != mainstack) - longjmp(top_env, 3); - return restartop; -} - -OP * -die_where(message) -char *message; -{ - if (in_eval) { - I32 cxix; - register CONTEXT *cx; - I32 gimme; - SV **newsp; - - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),message); - cxix = dopoptoeval(cxstack_ix); - if (cxix >= 0) { - I32 optype; - - if (cxix < cxstack_ix) - dounwind(cxix); - - POPBLOCK(cx); - if (cx->cx_type != CXt_EVAL) { - fprintf(stderr, "panic: die %s", message); - my_exit(1); - } - POPEVAL(cx); - - if (gimme == G_SCALAR) - *++newsp = &sv_undef; - stack_sp = newsp; - - LEAVE; - if (optype == OP_REQUIRE) - DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); - return pop_return(); - } - } - fputs(message, stderr); - (void)fflush(stderr); - if (e_fp) - (void)UNLINK(e_tmpname); - statusvalue >>= 8; - my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); - return 0; -} - -PP(pp_and) -{ - dSP; - if (!SvTRUE(TOPs)) - RETURN; - else { - --SP; - RETURNOP(cLOGOP->op_other); - } -} - -PP(pp_or) -{ - dSP; - if (SvTRUE(TOPs)) - RETURN; - else { - --SP; - RETURNOP(cLOGOP->op_other); - } -} - -PP(pp_cond_expr) -{ - dSP; - if (SvTRUEx(POPs)) - RETURNOP(cCONDOP->op_true); - else - RETURNOP(cCONDOP->op_false); -} - -PP(pp_andassign) -{ - dSP; - if (!SvTRUE(TOPs)) - RETURN; - else - RETURNOP(cLOGOP->op_other); -} - -PP(pp_orassign) -{ - dSP; - if (SvTRUE(TOPs)) - RETURN; - else - RETURNOP(cLOGOP->op_other); -} - -PP(pp_method) -{ - dSP; dPOPss; - SV* ob; - GV* gv; - - EXTEND(sp,2); - - gv = 0; - if (SvROK(sv)) - ob = SvRV(sv); - else { - GV* iogv; - IO* io; - - if (!SvOK(sv) || - !(iogv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO)) || - !(ob=(SV*)GvIO(iogv))) - { - char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv); - char tmpbuf[256]; - char* packname = SvPV(sv, na); - HV *stash; - if (!isALPHA(*packname)) -DIE("Can't call method \"%s\" without a package or object reference", name); - if (!(stash = fetch_stash(sv, FALSE))) - DIE("Can't call method \"%s\" in empty package \"%s\"", - name, packname); - gv = gv_fetchmethod(stash,name); - if (!gv) - DIE("Can't locate object method \"%s\" via package \"%s\"", - name, packname); - PUSHs(gv); - PUSHs(sv); - RETURN; - } - } - - if (!ob || !SvOBJECT(ob)) { - char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv); - DIE("Can't call method \"%s\" on unblessed reference", name); - } - - if (!gv) { /* nothing cached */ - char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv); - gv = gv_fetchmethod(SvSTASH(ob),name); - if (!gv) - DIE("Can't locate object method \"%s\" via package \"%s\"", - name, HvNAME(SvSTASH(ob))); - } - - PUSHs(gv); - PUSHs(sv); - RETURN; -} - -PP(pp_entersubr) -{ - dSP; dMARK; - SV *sv = *++MARK; - GV *gv; - HV *stash; - register CV *cv; - register I32 items = SP - MARK; - I32 hasargs = (op->op_flags & OPf_STACKED) != 0; - register CONTEXT *cx; - - if (!sv) - DIE("Not a subroutine reference"); - switch (SvTYPE(sv)) { - default: - if (!SvROK(sv)) { - if (!SvOK(sv)) - DIE(no_usym, "a subroutine"); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_hardref, "a subroutine"); - gv = gv_fetchpv(SvPV(sv, na), FALSE, SVt_PVCV); - if (!gv) - cv = 0; - else - cv = GvCV(gv); - break; - } - /* FALL THROUGH */ - case SVt_RV: - cv = (CV*)SvRV(sv); - if (SvTYPE(cv) == SVt_PVCV) - break; - /* FALL THROUGH */ - case SVt_PVHV: - case SVt_PVAV: - DIE("Not a subroutine reference"); - case SVt_PVCV: - cv = (CV*)sv; - break; - case SVt_PVGV: - if (!(cv = GvCV((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, TRUE); - break; - } - - ENTER; - SAVETMPS; - - retry: - if (!cv) - DIE("Not a subroutine reference"); - - if (!CvROOT(cv) && !CvUSERSUB(cv)) { - if (gv = CvGV(cv)) { - SV *tmpstr = sv_newmortal(); - GV *ngv; - gv_efullname(tmpstr, gv); - ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD"); - if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */ - gv = ngv; - sv_setsv(GvSV(gv), tmpstr); - goto retry; - } - else - DIE("Undefined subroutine &%s called",SvPVX(tmpstr)); - } - DIE("Undefined subroutine called"); - } - - if ((op->op_private & OPpDEREF_DB) && !CvUSERSUB(cv)) { - sv = GvSV(DBsub); - save_item(sv); - gv = CvGV(cv); - gv_efullname(sv,gv); - cv = GvCV(DBsub); - if (!cv) - DIE("No DBsub routine"); - } - - if (CvUSERSUB(cv)) { - items = (*CvUSERSUB(cv))(CvUSERINDEX(cv), MARK - stack_base, items); - sp = stack_base + items; - LEAVE; - RETURN; - } - else { - I32 gimme = GIMME; - AV* padlist = CvPADLIST(cv); - SV** svp = AvARRAY(padlist); - push_return(op->op_next); - PUSHBLOCK(cx, CXt_SUB, MARK - 1); - PUSHSUB(cx); - CvDEPTH(cv)++; - if (CvDEPTH(cv) >= 2) { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && dowarn) - warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv))); - if (CvDEPTH(cv) > AvFILL(padlist)) { - AV *newpad = newAV(); - I32 ix = AvFILL((AV*)svp[1]); - svp = AvARRAY(svp[0]); - while (ix > 0) { - if (svp[ix]) { - char *name = SvPVX(svp[ix]); /* XXX */ - if (*name == '@') - av_store(newpad, ix--, (SV*)newAV()); - else if (*name == '%') - av_store(newpad, ix--, (SV*)newHV()); - else - av_store(newpad, ix--, NEWSV(0,0)); - } - else - av_store(newpad, ix--, NEWSV(0,0)); - } - if (hasargs) { - AV* av = newAV(); - av_store(av, 0, Nullsv); - av_store(newpad, 0, (SV*)av); - SvOK_on(av); - AvREAL_off(av); - } - av_store(padlist, CvDEPTH(cv), (SV*)newpad); - AvFILL(padlist) = CvDEPTH(cv); - svp = AvARRAY(padlist); - } - } - SAVESPTR(curpad); - curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); - if (hasargs) { - AV* av = (AV*)curpad[0]; - SV** ary; - - cx->blk_sub.savearray = GvAV(defgv); - cx->blk_sub.argarray = av; - GvAV(defgv) = cx->blk_sub.argarray; - ++MARK; - - if (items >= AvMAX(av)) { - ary = AvALLOC(av); - if (AvARRAY(av) != ary) { - AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPVX(av) = (char*)ary; - } - if (items >= AvMAX(av)) { - AvMAX(av) = items - 1; - Renew(ary,items+1,SV*); - AvALLOC(av) = ary; - SvPVX(av) = (char*)ary; - } - } - Copy(MARK,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; - while (items--) { - if (*MARK) - SvTEMP_off(*MARK); - MARK++; - } - } - RETURNOP(CvSTART(cv)); - } -} - -PP(pp_leavesubr) -{ - dSP; - SV **mark; - SV **newsp; - I32 gimme; - register CONTEXT *cx; - - POPBLOCK(cx); - POPSUB(cx); - - if (gimme == G_SCALAR) { - MARK = newsp + 1; - if (MARK <= SP) - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - else { - MEXTEND(mark,0); - *MARK = &sv_undef; - } - SP = MARK; - } - else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) - *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ - } - - LEAVE; - PUTBACK; - return pop_return(); -} - -PP(pp_done) -{ - return pop_return(); -} - -PP(pp_caller) -{ - dSP; - register I32 cxix = dopoptosub(cxstack_ix); - I32 nextcxix; - register CONTEXT *cx; - SV *sv; - I32 count = 0; - - if (MAXARG) - count = POPi; - EXTEND(SP, 6); - for (;;) { - if (cxix < 0) { - if (GIMME != G_ARRAY) - RETPUSHUNDEF; - RETURN; - } - nextcxix = dopoptosub(cxix - 1); - if (DBsub && nextcxix >= 0 && - cxstack[nextcxix].blk_sub.cv == GvCV(DBsub)) - count++; - if (!count--) - break; - cxix = nextcxix; - } - cx = &cxstack[cxix]; - if (GIMME != G_ARRAY) { - dTARGET; - - sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash)); - PUSHs(TARG); - RETURN; - } - - PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0))); - PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0))); - PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); - if (!MAXARG) - RETURN; - if (cx->cx_type == CXt_SUB) { - sv = NEWSV(49, 0); - gv_efullname(sv, CvGV(cx->blk_sub.cv)); - PUSHs(sv_2mortal(sv)); - PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); - } - else { - PUSHs(sv_2mortal(newSVpv("(eval)",0))); - PUSHs(sv_2mortal(newSViv(0))); - } - PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme))); - if (cx->blk_sub.hasargs && curstash == debstash) { - AV *ary = cx->blk_sub.argarray; - - if (!dbargs) { - GV* tmpgv; - dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, - SVt_PVAV))); - SvMULTI_on(tmpgv); - AvREAL_off(dbargs); - } - if (AvMAX(dbargs) < AvFILL(ary)) - av_store(dbargs, AvFILL(ary), Nullsv); - Copy(AvARRAY(ary), AvARRAY(dbargs), AvFILL(ary)+1, SV*); - AvFILL(dbargs) = AvFILL(ary); - } - RETURN; -} - -static I32 -sortcv(str1, str2) -SV **str1; -SV **str2; -{ - I32 oldscopeix = scopestack_ix; - I32 result; - GvSV(firstgv) = *str1; - GvSV(secondgv) = *str2; - stack_sp = stack_base; - op = sortcop; - run(); - result = SvIVx(AvARRAY(stack)[1]); - while (scopestack_ix > oldscopeix) { - LEAVE; - } - return result; -} - -static I32 -sortcmp(strp1, strp2) -SV **strp1; -SV **strp2; -{ - register SV *str1 = *strp1; - register SV *str2 = *strp2; - I32 retval; - - if (SvCUR(str1) < SvCUR(str2)) { - /*SUPPRESS 560*/ - if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1))) - return retval; - else - return -1; - } - /*SUPPRESS 560*/ - else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2))) - return retval; - else if (SvCUR(str1) == SvCUR(str2)) - return 0; - else - return 1; -} - -PP(pp_warn) -{ - dSP; dMARK; - char *tmps; - if (SP - MARK != 1) { - dTARGET; - do_join(TARG, &sv_no, MARK, SP); - tmps = SvPV(TARG, na); - SP = MARK + 1; - } - else { - tmps = SvPV(TOPs, na); - } - if (!tmps || !*tmps) { - SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); - SvUPGRADE(error, SVt_PV); - if (SvPOK(error) && SvCUR(error)) - sv_catpv(error, "\t...caught"); - tmps = SvPV(error, na); - } - if (!tmps || !*tmps) - tmps = "Warning: something's wrong"; - warn("%s", tmps); - RETSETYES; -} - -PP(pp_die) -{ - dSP; dMARK; - char *tmps; - if (SP - MARK != 1) { - dTARGET; - do_join(TARG, &sv_no, MARK, SP); - tmps = SvPV(TARG, na); - SP = MARK + 1; - } - else { - tmps = SvPV(TOPs, na); - } - if (!tmps || !*tmps) { - SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); - SvUPGRADE(error, SVt_PV); - if (SvPOK(error) && SvCUR(error)) - sv_catpv(error, "\t...propagated"); - tmps = SvPV(error, na); - } - if (!tmps || !*tmps) - tmps = "Died"; - DIE("%s", tmps); -} - -PP(pp_reset) -{ - dSP; - double value; - char *tmps; - - if (MAXARG < 1) - tmps = ""; - else - tmps = POPp; - sv_reset(tmps, curcop->cop_stash); - PUSHs(&sv_yes); - RETURN; -} - -PP(pp_lineseq) -{ - return NORMAL; -} - -PP(pp_nextstate) -{ - curcop = (COP*)op; - TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; - FREE_TMPS(); - return NORMAL; -} - -PP(pp_dbstate) -{ - curcop = (COP*)op; - TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; - FREE_TMPS(); - - if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace)) - { - SV **sp; - register CV *cv; - register CONTEXT *cx; - I32 gimme = GIMME; - I32 hasargs; - GV *gv; - - ENTER; - SAVETMPS; - - SAVEI32(debug); - debug = 0; - hasargs = 0; - gv = DBgv; - cv = GvCV(gv); - sp = stack_sp; - *++sp = Nullsv; - - if (!cv) - DIE("No DB::DB routine defined"); - - if (CvDEPTH(cv) >= 1) /* don't do recursive DB::DB call */ - return NORMAL; - push_return(op->op_next); - PUSHBLOCK(cx, CXt_SUB, sp - 1); - PUSHSUB(cx); - CvDEPTH(cv)++; - SAVESPTR(curpad); - curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE)); - RETURNOP(CvSTART(cv)); - } - else - return NORMAL; -} - -PP(pp_unstack) -{ - I32 oldsave; - TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; - FREE_TMPS(); - oldsave = scopestack[scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); - return NORMAL; -} - -PP(pp_enter) -{ - dSP; - register CONTEXT *cx; - I32 gimme; - - /* - * We don't just use the GIMME macro here because it assumes there's - * already a context, which ain't necessarily so at initial startup. - */ - - if (op->op_flags & OPf_KNOW) - gimme = op->op_flags & OPf_LIST; - else if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else - gimme = G_SCALAR; - - ENTER; - - SAVETMPS; - PUSHBLOCK(cx, CXt_BLOCK, sp); - - RETURN; -} - -PP(pp_leave) -{ - dSP; - register CONTEXT *cx; - register SV **mark; - SV **newsp; - I32 gimme; - - POPBLOCK(cx); - - if (op->op_flags & OPf_KNOW) - gimme = op->op_flags & OPf_LIST; - else if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else - gimme = G_SCALAR; - - if (gimme == G_SCALAR) { - MARK = newsp + 1; - if (MARK <= SP) - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - else { - MEXTEND(mark,0); - *MARK = &sv_undef; - } - SP = MARK; - } - else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) - *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ - } - - LEAVE; - - RETURN; -} - -PP(pp_scope) -{ - return NORMAL; -} - -PP(pp_enteriter) -{ - dSP; dMARK; - register CONTEXT *cx; - I32 gimme = GIMME; - SV **svp; - - if (op->op_targ) - svp = &curpad[op->op_targ]; /* "my" variable */ - else - svp = &GvSV((GV*)POPs); /* symbol table variable */ - - ENTER; - SAVETMPS; - ENTER; - - PUSHBLOCK(cx, CXt_LOOP, SP); - PUSHLOOP(cx, svp, MARK); - cx->blk_loop.iterary = stack; - cx->blk_loop.iterix = MARK - stack_base; - - RETURN; -} - -PP(pp_iter) -{ - dSP; - register CONTEXT *cx; - SV *sv; - - EXTEND(sp, 1); - cx = &cxstack[cxstack_ix]; - if (cx->cx_type != CXt_LOOP) - DIE("panic: pp_iter"); - - if (cx->blk_loop.iterix >= cx->blk_oldsp) - RETPUSHNO; - - if (sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix]) { - SvTEMP_off(sv); - *cx->blk_loop.itervar = sv; - } - else - *cx->blk_loop.itervar = &sv_undef; - - RETPUSHYES; -} - -PP(pp_enterloop) -{ - dSP; - register CONTEXT *cx; - I32 gimme = GIMME; - - ENTER; - SAVETMPS; - ENTER; - - PUSHBLOCK(cx, CXt_LOOP, SP); - PUSHLOOP(cx, 0, SP); - - RETURN; -} - -PP(pp_leaveloop) -{ - dSP; - register CONTEXT *cx; - I32 gimme; - SV **newsp; - SV **mark; - - POPBLOCK(cx); - mark = newsp; - POPLOOP(cx); - if (gimme == G_SCALAR) { - if (mark < SP) - *++newsp = sv_mortalcopy(*SP); - else - *++newsp = &sv_undef; - } - else { - while (mark < SP) - *++newsp = sv_mortalcopy(*++mark); - } - sp = newsp; - LEAVE; - LEAVE; - - RETURN; -} - -PP(pp_return) -{ - dSP; dMARK; - I32 cxix; - register CONTEXT *cx; - I32 gimme; - SV **newsp; - I32 optype = 0; - - if (stack == sortstack) { - AvARRAY(stack)[1] = *SP; - return 0; - } - - cxix = dopoptosub(cxstack_ix); - if (cxix < 0) - DIE("Can't return outside a subroutine"); - if (cxix < cxstack_ix) - dounwind(cxix); - - POPBLOCK(cx); - switch (cx->cx_type) { - case CXt_SUB: - POPSUB(cx); - break; - case CXt_EVAL: - POPEVAL(cx); - break; - default: - DIE("panic: return"); - break; - } - - if (gimme == G_SCALAR) { - if (MARK < SP) - *++newsp = sv_mortalcopy(*SP); - else - *++newsp = &sv_undef; - if (optype == OP_REQUIRE && !SvTRUE(*newsp)) - DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); - } - else { - if (optype == OP_REQUIRE && MARK == SP) - DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); - while (MARK < SP) - *++newsp = sv_mortalcopy(*++MARK); - } - stack_sp = newsp; - - LEAVE; - return pop_return(); -} - -PP(pp_last) -{ - dSP; - I32 cxix; - register CONTEXT *cx; - I32 gimme; - I32 optype; - OP *nextop; - SV **newsp; - SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp; - /* XXX The sp is probably not right yet... */ - - if (op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE("Can't \"last\" outside a block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv); - if (cxix < 0) - DIE("Label not found for \"last %s\"", cPVOP->op_pv); - } - if (cxix < cxstack_ix) - dounwind(cxix); - - POPBLOCK(cx); - switch (cx->cx_type) { - case CXt_LOOP: - POPLOOP(cx); - nextop = cx->blk_loop.last_op->op_next; - LEAVE; - break; - case CXt_EVAL: - POPEVAL(cx); - nextop = pop_return(); - break; - case CXt_SUB: - POPSUB(cx); - nextop = pop_return(); - break; - default: - DIE("panic: last"); - break; - } - - if (gimme == G_SCALAR) { - if (mark < SP) - *++newsp = sv_mortalcopy(*SP); - else - *++newsp = &sv_undef; - } - else { - while (mark < SP) - *++newsp = sv_mortalcopy(*++mark); - } - sp = newsp; - - LEAVE; - RETURNOP(nextop); -} - -PP(pp_next) -{ - dSP; - I32 cxix; - register CONTEXT *cx; - I32 oldsave; - - if (op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE("Can't \"next\" outside a block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv); - if (cxix < 0) - DIE("Label not found for \"next %s\"", cPVOP->op_pv); - } - if (cxix < cxstack_ix) - dounwind(cxix); - - TOPBLOCK(cx); - oldsave = scopestack[scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); - return cx->blk_loop.next_op; -} - -PP(pp_redo) -{ - dSP; - I32 cxix; - register CONTEXT *cx; - I32 oldsave; - - if (op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE("Can't \"redo\" outside a block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv); - if (cxix < 0) - DIE("Label not found for \"redo %s\"", cPVOP->op_pv); - } - if (cxix < cxstack_ix) - dounwind(cxix); - - TOPBLOCK(cx); - oldsave = scopestack[scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); - return cx->blk_loop.redo_op; -} - -static OP* lastgotoprobe; - -OP * -dofindlabel(op,label,opstack) -OP *op; -char *label; -OP **opstack; -{ - OP *kid; - OP **ops = opstack; - - if (op->op_type == OP_LEAVE || - op->op_type == OP_SCOPE || - op->op_type == OP_LEAVELOOP || - op->op_type == OP_LEAVETRY) - *ops++ = cUNOP->op_first; - *ops = 0; - if (op->op_flags & OPf_KIDS) { - /* First try all the kids at this level, since that's likeliest. */ - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { - if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && - kCOP->cop_label && strEQ(kCOP->cop_label, label)) - return kid; - } - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { - if (kid == lastgotoprobe) - continue; - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { - if (ops > opstack && - (ops[-1]->op_type == OP_NEXTSTATE || - ops[-1]->op_type == OP_DBSTATE)) - *ops = kid; - else - *ops++ = kid; - } - if (op = dofindlabel(kid,label,ops)) - return op; - } - } - *ops = 0; - return 0; -} - -PP(pp_dump) -{ - return pp_goto(ARGS); - /*NOTREACHED*/ -} - -PP(pp_goto) -{ - dSP; - OP *retop = 0; - I32 ix; - register CONTEXT *cx; - I32 entering = 0; - OP *enterops[64]; - char *label; - - label = 0; - if (op->op_flags & OPf_STACKED) { - SV *sv = POPs; - - /* This egregious kludge implements goto &subroutine */ - if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { - I32 cxix; - register CONTEXT *cx; - CV* cv = (CV*)SvRV(sv); - SV** mark; - I32 items = 0; - I32 oldsave; - - /* First do some returnish stuff. */ - cxix = dopoptosub(cxstack_ix); - if (cxix < 0) - DIE("Can't goto subroutine outside a subroutine"); - if (cxix < cxstack_ix) - dounwind(cxix); - TOPBLOCK(cx); - mark = ++stack_sp; - *stack_sp = (SV*)cv; - if (cx->blk_sub.hasargs) { /* put @_ back onto stack */ - items = AvFILL(cx->blk_sub.argarray) + 1; - Copy(AvARRAY(cx->blk_sub.argarray), ++stack_sp, items, SV*); - stack_sp += items; - GvAV(defgv) = cx->blk_sub.savearray; - } - if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { - if (CvDELETED(cx->blk_sub.cv)) - SvREFCNT_dec(cx->blk_sub.cv); - } - oldsave = scopestack[scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); - - /* Now do some callish stuff. */ - if (CvUSERSUB(cv)) { - items = (*CvUSERSUB(cv))(CvUSERINDEX(cv), - mark - stack_base, items); - sp = stack_base + items; - LEAVE; - return pop_return(); - } - else { - AV* padlist = CvPADLIST(cv); - SV** svp = AvARRAY(padlist); - cx->blk_sub.cv = cv; - cx->blk_sub.olddepth = CvDEPTH(cv); - CvDEPTH(cv)++; - if (CvDEPTH(cv) >= 2) { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && dowarn) - warn("Deep recursion on subroutine \"%s\"", - GvENAME(CvGV(cv))); - if (CvDEPTH(cv) > AvFILL(padlist)) { - AV *newpad = newAV(); - I32 ix = AvFILL((AV*)svp[1]); - svp = AvARRAY(svp[0]); - while (ix > 0) { - if (svp[ix]) { - char *name = SvPVX(svp[ix]); /* XXX */ - if (*name == '@') - av_store(newpad, ix--, (SV*)newAV()); - else if (*name == '%') - av_store(newpad, ix--, (SV*)newHV()); - else - av_store(newpad, ix--, NEWSV(0,0)); - } - else - av_store(newpad, ix--, NEWSV(0,0)); - } - if (cx->blk_sub.hasargs) { - AV* av = newAV(); - av_store(av, 0, Nullsv); - av_store(newpad, 0, (SV*)av); - SvOK_on(av); - AvREAL_off(av); - } - av_store(padlist, CvDEPTH(cv), (SV*)newpad); - AvFILL(padlist) = CvDEPTH(cv); - svp = AvARRAY(padlist); - } - } - SAVESPTR(curpad); - curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); - if (cx->blk_sub.hasargs) { - AV* av = (AV*)curpad[0]; - SV** ary; - - cx->blk_sub.savearray = GvAV(defgv); - cx->blk_sub.argarray = av; - GvAV(defgv) = cx->blk_sub.argarray; - ++mark; - - if (items >= AvMAX(av)) { - ary = AvALLOC(av); - if (AvARRAY(av) != ary) { - AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPVX(av) = (char*)ary; - } - if (items >= AvMAX(av)) { - AvMAX(av) = items - 1; - Renew(ary,items+1,SV*); - AvALLOC(av) = ary; - SvPVX(av) = (char*)ary; - } - } - Copy(mark,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; - while (items--) { - if (*mark) - SvTEMP_off(*mark); - mark++; - } - } - RETURNOP(CvSTART(cv)); - } - } - else - label = SvPV(sv,na); - } - else if (op->op_flags & OPf_SPECIAL) { - if (op->op_type != OP_DUMP) - DIE("goto must have label"); - } - else - label = cPVOP->op_pv; - - if (label && *label) { - OP *gotoprobe; - - /* find label */ - - lastgotoprobe = 0; - *enterops = 0; - for (ix = cxstack_ix; ix >= 0; ix--) { - cx = &cxstack[ix]; - switch (cx->cx_type) { - case CXt_SUB: - gotoprobe = CvROOT(cx->blk_sub.cv); - break; - case CXt_EVAL: - gotoprobe = eval_root; /* XXX not good for nested eval */ - break; - case CXt_LOOP: - gotoprobe = cx->blk_oldcop->op_sibling; - break; - case CXt_SUBST: - continue; - case CXt_BLOCK: - if (ix) - gotoprobe = cx->blk_oldcop->op_sibling; - else - gotoprobe = main_root; - break; - default: - if (ix) - DIE("panic: goto"); - else - gotoprobe = main_root; - break; - } - retop = dofindlabel(gotoprobe, label, enterops); - if (retop) - break; - lastgotoprobe = gotoprobe; - } - if (!retop) - DIE("Can't find label %s", label); - - /* pop unwanted frames */ - - if (ix < cxstack_ix) { - I32 oldsave; - - if (ix < 0) - ix = 0; - dounwind(ix); - TOPBLOCK(cx); - oldsave = scopestack[scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); - } - - /* push wanted frames */ - - if (*enterops) { - OP *oldop = op; - for (ix = 0 + (gotoprobe == main_root); enterops[ix]; ix++) { - op = enterops[ix]; - (*op->op_ppaddr)(); - } - op = oldop; - } - } - - if (op->op_type == OP_DUMP) { - restartop = retop; - do_undump = TRUE; - - my_unexec(); - - restartop = 0; /* hmm, must be GNU unexec().. */ - do_undump = FALSE; - } - - RETURNOP(retop); -} - -PP(pp_exit) -{ - dSP; - I32 anum; - - if (MAXARG < 1) - anum = 0; - else - anum = SvIVx(POPs); - my_exit(anum); - PUSHs(&sv_undef); - RETURN; -} - -PP(pp_nswitch) -{ - dSP; - double value = SvNVx(GvSV(cCOP->cop_gv)); - register I32 match = (I32)value; - - if (value < 0.0) { - if (((double)match) > value) - --match; /* was fractional--truncate other way */ - } - match -= cCOP->uop.scop.scop_offset; - if (match < 0) - match = 0; - else if (match > cCOP->uop.scop.scop_max) - match = cCOP->uop.scop.scop_max; - op = cCOP->uop.scop.scop_next[match]; - RETURNOP(op); -} - -PP(pp_cswitch) -{ - dSP; - register I32 match; - - if (multiline) - op = op->op_next; /* can't assume anything */ - else { - match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255; - match -= cCOP->uop.scop.scop_offset; - if (match < 0) - match = 0; - else if (match > cCOP->uop.scop.scop_max) - match = cCOP->uop.scop.scop_max; - op = cCOP->uop.scop.scop_next[match]; - } - RETURNOP(op); -} - -/* I/O. */ - -PP(pp_open) -{ - dSP; dTARGET; - GV *gv; - SV *sv; - char *tmps; - STRLEN len; - - if (MAXARG > 1) - sv = POPs; - else - sv = GvSV(TOPs); - gv = (GV*)POPs; - tmps = SvPV(sv, len); - if (do_open(gv, tmps, len)) { - IoLINES(GvIO(gv)) = 0; - PUSHi( (I32)forkprocess ); - } - else if (forkprocess == 0) /* we are a new child */ - PUSHi(0); - else - RETPUSHUNDEF; - RETURN; -} - -PP(pp_close) -{ - dSP; - GV *gv; - - if (MAXARG == 0) - gv = defoutgv; - else - gv = (GV*)POPs; - EXTEND(SP, 1); - PUSHs( do_close(gv, TRUE) ? &sv_yes : &sv_no ); - RETURN; -} - -PP(pp_pipe_op) -{ - dSP; -#ifdef HAS_PIPE - GV *rgv; - GV *wgv; - register IO *rstio; - register IO *wstio; - int fd[2]; - - wgv = (GV*)POPs; - rgv = (GV*)POPs; - - if (!rgv || !wgv) - goto badexit; - - rstio = GvIOn(rgv); - wstio = GvIOn(wgv); - - if (IoIFP(rstio)) - do_close(rgv, FALSE); - if (IoIFP(wstio)) - do_close(wgv, FALSE); - - if (pipe(fd) < 0) - goto badexit; - - IoIFP(rstio) = fdopen(fd[0], "r"); - IoOFP(wstio) = fdopen(fd[1], "w"); - IoIFP(wstio) = IoOFP(wstio); - IoTYPE(rstio) = '<'; - IoTYPE(wstio) = '>'; - - if (!IoIFP(rstio) || !IoOFP(wstio)) { - if (IoIFP(rstio)) fclose(IoIFP(rstio)); - else close(fd[0]); - if (IoOFP(wstio)) fclose(IoOFP(wstio)); - else close(fd[1]); - goto badexit; - } - - RETPUSHYES; - -badexit: - RETPUSHUNDEF; -#else - DIE(no_func, "pipe"); -#endif -} - -PP(pp_fileno) -{ - dSP; dTARGET; - GV *gv; - IO *io; - FILE *fp; - if (MAXARG < 1) - RETPUSHUNDEF; - gv = (GV*)POPs; - if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) - RETPUSHUNDEF; - PUSHi(fileno(fp)); - RETURN; -} - -PP(pp_umask) -{ - dSP; dTARGET; - int anum; - -#ifdef HAS_UMASK - if (MAXARG < 1) { - anum = umask(0); - (void)umask(anum); - } - else - anum = umask(POPi); - TAINT_PROPER("umask"); - XPUSHi(anum); -#else - DIE(no_func, "Unsupported function umask"); -#endif - RETURN; -} - -PP(pp_binmode) -{ - dSP; - GV *gv; - IO *io; - FILE *fp; - - if (MAXARG < 1) - RETPUSHUNDEF; - - gv = (GV*)POPs; - - EXTEND(SP, 1); - if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) - RETSETUNDEF; - -#ifdef DOSISH -#ifdef atarist - if (!fflush(fp) && (fp->_flag |= _IOBIN)) - RETPUSHYES; - else - RETPUSHUNDEF; -#else - if (setmode(fileno(fp), OP_BINARY) != -1) - RETPUSHYES; - else - RETPUSHUNDEF; -#endif -#else - RETPUSHYES; -#endif -} - -PP(pp_tie) -{ - dSP; - SV *varsv; - HV* stash; - GV *gv; - BINOP myop; - SV *sv; - SV **mark = stack_base + *markstack_ptr + 1; /* reuse in entersubr */ - - varsv = mark[0]; - - stash = fetch_stash(mark[1], FALSE); - if (!stash || !(gv = gv_fetchmethod(stash, "new")) || !GvCV(gv)) - DIE("Can't tie to package %s", SvPV(mark[1],na)); - - Zero(&myop, 1, BINOP); - myop.op_last = (OP *) &myop; - myop.op_next = Nullop; - myop.op_flags = OPf_STACKED; - - ENTER; - SAVESPTR(op); - op = (OP *) &myop; - - mark[0] = gv; - PUTBACK; - - if (op = pp_entersubr()) - run(); - SPAGAIN; - - if (!sv_isobject(TOPs)) - DIE("new didn't return an object"); - sv = TOPs; - if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) - sv_magic(varsv, sv, 'P', 0, 0); - else - sv_magic(varsv, sv, 'p', 0, -1); - LEAVE; - SPAGAIN; - RETURN; -} - -PP(pp_untie) -{ - dSP; - if (SvTYPE(TOPs) == SVt_PVHV || SvTYPE(TOPs) == SVt_PVAV) - sv_unmagic(TOPs, 'P'); - else - sv_unmagic(TOPs, 'p'); - RETSETYES; -} - -PP(pp_dbmopen) -{ - dSP; - HV *hv; - dPOPPOPssrl; - HV* stash; - GV *gv; - BINOP myop; - SV *sv; - - hv = (HV*)POPs; - - sv = sv_mortalcopy(&sv_no); - sv_setpv(sv, "Any_DBM_File"); - stash = fetch_stash(sv, FALSE); - if (!stash || !(gv = gv_fetchmethod(stash, "new")) || !GvCV(gv)) - DIE("No dbm on this machine"); - - Zero(&myop, 1, BINOP); - myop.op_last = (OP *) &myop; - myop.op_next = Nullop; - myop.op_flags = OPf_STACKED; - - ENTER; - SAVESPTR(op); - op = (OP *) &myop; - PUTBACK; - pp_pushmark(); - - EXTEND(sp, 5); - PUSHs(gv); - PUSHs(sv); - PUSHs(lstr); - if (SvIV(rstr)) - PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT))); - else - PUSHs(sv_2mortal(newSViv(O_RDWR))); - PUSHs(rstr); - PUTBACK; - - if (op = pp_entersubr()) - run(); - LEAVE; - SPAGAIN; - - sv = TOPs; - sv_magic((SV*)hv, sv, 'P', 0, 0); - RETURN; -} - -PP(pp_dbmclose) -{ - return pp_untie(ARGS); -} - -PP(pp_sselect) -{ - dSP; dTARGET; -#ifdef HAS_SELECT - register I32 i; - register I32 j; - register char *s; - register SV *sv; - double value; - I32 maxlen = 0; - I32 nfound; - struct timeval timebuf; - struct timeval *tbuf = &timebuf; - I32 growsize; - char *fd_sets[4]; -#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 - I32 masksize; - I32 offset; - I32 k; - -# if BYTEORDER & 0xf0000 -# define ORDERBYTE (0x88888888 - BYTEORDER) -# else -# define ORDERBYTE (0x4444 - BYTEORDER) -# endif - -#endif - - SP -= 4; - for (i = 1; i <= 3; i++) { - if (!SvPOK(SP[i])) - continue; - j = SvCUR(SP[i]); - if (maxlen < j) - maxlen = j; - } - -#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 - growsize = maxlen; /* little endians can use vecs directly */ -#else -#ifdef NFDBITS - -#ifndef NBBY -#define NBBY 8 -#endif - - masksize = NFDBITS / NBBY; -#else - masksize = sizeof(long); /* documented int, everyone seems to use long */ -#endif - growsize = maxlen + (masksize - (maxlen % masksize)); - Zero(&fd_sets[0], 4, char*); -#endif - - sv = SP[4]; - if (SvOK(sv)) { - value = SvNV(sv); - if (value < 0.0) - value = 0.0; - timebuf.tv_sec = (long)value; - value -= (double)timebuf.tv_sec; - timebuf.tv_usec = (long)(value * 1000000.0); - } - else - tbuf = Null(struct timeval*); - - for (i = 1; i <= 3; i++) { - sv = SP[i]; - if (!SvPOK(sv)) { - fd_sets[i] = 0; - continue; - } - j = SvLEN(sv); - if (j < growsize) { - Sv_Grow(sv, growsize); - s = SvPV(sv, na) + j; - while (++j <= growsize) { - *s++ = '\0'; - } - } -#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 - s = SvPVX(sv); - New(403, fd_sets[i], growsize, char); - for (offset = 0; offset < growsize; offset += masksize) { - for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) - fd_sets[i][j+offset] = s[(k % masksize) + offset]; - } -#else - fd_sets[i] = SvPVX(sv); -#endif - } - - nfound = select( - maxlen * 8, - fd_sets[1], - fd_sets[2], - fd_sets[3], - tbuf); -#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 - for (i = 1; i <= 3; i++) { - if (fd_sets[i]) { - sv = SP[i]; - s = SvPVX(sv); - for (offset = 0; offset < growsize; offset += masksize) { - for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) - s[(k % masksize) + offset] = fd_sets[i][j+offset]; - } - Safefree(fd_sets[i]); - } - } -#endif - - PUSHi(nfound); - if (GIMME == G_ARRAY && tbuf) { - value = (double)(timebuf.tv_sec) + - (double)(timebuf.tv_usec) / 1000000.0; - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setnv(sv, value); - } - RETURN; -#else - DIE("select not implemented"); -#endif -} - -PP(pp_select) -{ - dSP; dTARGET; - GV *oldgv = defoutgv; - if (op->op_private > 0) { - defoutgv = (GV*)POPs; - if (!GvIO(defoutgv)) - GvIO(defoutgv) = newIO(); - curoutgv = defoutgv; - } - gv_efullname(TARG, oldgv); - XPUSHTARG; - RETURN; -} - -PP(pp_getc) -{ - dSP; dTARGET; - GV *gv; - - if (MAXARG <= 0) - gv = stdingv; - else - gv = (GV*)POPs; - if (!gv) - gv = argvgv; - if (!gv || do_eof(gv)) /* make sure we have fp with something */ - RETPUSHUNDEF; - TAINT_IF(1); - sv_setpv(TARG, " "); - *SvPVX(TARG) = getc(IoIFP(GvIO(gv))); /* should never be EOF */ - PUSHTARG; - RETURN; -} - -PP(pp_read) -{ - return pp_sysread(ARGS); -} - -static OP * -doform(cv,gv,retop) -CV *cv; -GV *gv; -OP *retop; -{ - register CONTEXT *cx; - I32 gimme = GIMME; - ENTER; - SAVETMPS; - - push_return(retop); - PUSHBLOCK(cx, CXt_SUB, stack_sp); - PUSHFORMAT(cx); - defoutgv = gv; /* locally select filehandle so $% et al work */ - return CvSTART(cv); -} - -PP(pp_enterwrite) -{ - dSP; - register GV *gv; - register IO *io; - GV *fgv; - FILE *fp; - CV *cv; - - if (MAXARG == 0) - gv = defoutgv; - else { - gv = (GV*)POPs; - if (!gv) - gv = defoutgv; - } - EXTEND(SP, 1); - io = GvIO(gv); - if (!io) { - RETPUSHNO; - } - curoutgv = gv; - if (IoFMT_GV(io)) - fgv = IoFMT_GV(io); - else - fgv = gv; - - cv = GvFORM(fgv); - - if (!cv) { - if (fgv) { - SV *tmpstr = sv_newmortal(); - gv_efullname(tmpstr, gv); - DIE("Undefined format \"%s\" called",SvPVX(tmpstr)); - } - DIE("Not a format reference"); - } - - return doform(cv,gv,op->op_next); -} - -PP(pp_leavewrite) -{ - dSP; - GV *gv = cxstack[cxstack_ix].blk_sub.gv; - register IO *io = GvIO(gv); - FILE *ofp = IoOFP(io); - FILE *fp; - SV **mark; - SV **newsp; - 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) - { - if (!IoTOP_GV(io)) { - GV *topgv; - char tmpbuf[256]; - - if (!IoTOP_NAME(io)) { - if (!IoFMT_NAME(io)) - IoFMT_NAME(io) = savestr(GvNAME(gv)); - sprintf(tmpbuf, "%s_TOP", IoFMT_NAME(io)); - topgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVFM); - if (topgv && GvFORM(topgv)) - IoTOP_NAME(io) = savestr(tmpbuf); - else - IoTOP_NAME(io) = savestr("top"); - } - topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM); - if (!topgv || !GvFORM(topgv)) { - IoLINES_LEFT(io) = 100000000; - goto forget_top; - } - IoTOP_GV(io) = topgv; - } - if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) - fwrite(SvPVX(formfeed), SvCUR(formfeed), 1, ofp); - IoLINES_LEFT(io) = IoPAGE_LEN(io); - IoPAGE(io)++; - formtarget = toptarget; - return doform(GvFORM(IoTOP_GV(io)),gv,op); - } - - forget_top: - POPBLOCK(cx); - POPFORMAT(cx); - LEAVE; - - fp = IoOFP(io); - if (!fp) { - if (dowarn) { - if (IoIFP(io)) - warn("Filehandle only opened for input"); - else - warn("Write on closed filehandle"); - } - PUSHs(&sv_no); - } - else { - if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) { - if (dowarn) - warn("page overflow"); - } - if (!fwrite(SvPVX(formtarget), 1, SvCUR(formtarget), ofp) || - ferror(fp)) - PUSHs(&sv_no); - else { - FmLINES(formtarget) = 0; - SvCUR_set(formtarget, 0); - if (IoFLAGS(io) & IOf_FLUSH) - (void)fflush(fp); - PUSHs(&sv_yes); - } - } - formtarget = bodytarget; - PUTBACK; - return pop_return(); -} - -PP(pp_prtf) -{ - dSP; dMARK; dORIGMARK; - GV *gv; - IO *io; - FILE *fp; - SV *sv = NEWSV(0,0); - - if (op->op_flags & OPf_STACKED) - gv = (GV*)*++MARK; - else - gv = defoutgv; - if (!(io = GvIO(gv))) { - if (dowarn) - warn("Filehandle %s never opened", GvNAME(gv)); - errno = EBADF; - goto just_say_no; - } - else if (!(fp = IoOFP(io))) { - if (dowarn) { - if (IoIFP(io)) - warn("Filehandle %s opened only for input", GvNAME(gv)); - else - warn("printf on closed filehandle %s", GvNAME(gv)); - } - errno = EBADF; - goto just_say_no; - } - else { - do_sprintf(sv, SP - MARK, MARK + 1); - if (!do_print(sv, fp)) - goto just_say_no; - - if (IoFLAGS(io) & IOf_FLUSH) - if (fflush(fp) == EOF) - goto just_say_no; - } - SvREFCNT_dec(sv); - SP = ORIGMARK; - PUSHs(&sv_yes); - RETURN; - - just_say_no: - SvREFCNT_dec(sv); - SP = ORIGMARK; - PUSHs(&sv_undef); - RETURN; -} - -PP(pp_print) -{ - dSP; dMARK; dORIGMARK; - GV *gv; - IO *io; - register FILE *fp; - - if (op->op_flags & OPf_STACKED) - gv = (GV*)*++MARK; - else - gv = defoutgv; - if (!(io = GvIO(gv))) { - if (dowarn) - warn("Filehandle %s never opened", GvNAME(gv)); - errno = EBADF; - goto just_say_no; - } - else if (!(fp = IoOFP(io))) { - if (dowarn) { - if (IoIFP(io)) - warn("Filehandle %s opened only for input", GvNAME(gv)); - else - warn("print on closed filehandle %s", GvNAME(gv)); - } - errno = EBADF; - goto just_say_no; - } - else { - MARK++; - if (ofslen) { - while (MARK <= SP) { - if (!do_print(*MARK, fp)) - break; - MARK++; - if (MARK <= SP) { - if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) { - MARK--; - break; - } - } - } - } - else { - while (MARK <= SP) { - if (!do_print(*MARK, fp)) - break; - MARK++; - } - } - if (MARK <= SP) - goto just_say_no; - else { - if (orslen) - if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp)) - goto just_say_no; - - if (IoFLAGS(io) & IOf_FLUSH) - if (fflush(fp) == EOF) - goto just_say_no; - } - } - SP = ORIGMARK; - PUSHs(&sv_yes); - RETURN; - - just_say_no: - SP = ORIGMARK; - PUSHs(&sv_undef); - RETURN; -} - -PP(pp_sysread) -{ - dSP; dMARK; dORIGMARK; dTARGET; - int offset; - GV *gv; - IO *io; - char *buffer; - int length; - int bufsize; - SV *bufstr; - STRLEN blen; - - gv = (GV*)*++MARK; - if (!gv) - goto say_undef; - bufstr = *++MARK; - buffer = SvPV(bufstr, blen); - length = SvIVx(*++MARK); - if (SvTHINKFIRST(bufstr)) { - if (SvREADONLY(bufstr) && curcop != &compiling) - DIE(no_modify); - if (SvROK(bufstr)) - sv_unref(bufstr); - } - errno = 0; - if (MARK < SP) - offset = SvIVx(*++MARK); - else - offset = 0; - if (MARK < SP) - warn("Too many args on read"); - io = GvIO(gv); - if (!io || !IoIFP(io)) - goto say_undef; -#ifdef HAS_SOCKET - if (op->op_type == OP_RECV) { - bufsize = sizeof buf; - SvGROW(bufstr, length+1), (buffer = SvPV(bufstr, blen)); /* sneaky */ - length = recvfrom(fileno(IoIFP(io)), buffer, length, offset, - (struct sockaddr *)buf, &bufsize); - if (length < 0) - RETPUSHUNDEF; - SvCUR_set(bufstr, length); - *SvEND(bufstr) = '\0'; - SvPOK_only(bufstr); - if (tainting) - sv_magic(bufstr, 0, 't', 0, 0); - SP = ORIGMARK; - sv_setpvn(TARG, buf, bufsize); - PUSHs(TARG); - RETURN; - } -#else - if (op->op_type == OP_RECV) - DIE(no_sock_func, "recv"); -#endif - SvGROW(bufstr, length+offset+1), (buffer = SvPV(bufstr, blen)); /* sneaky */ - if (op->op_type == OP_SYSREAD) { - length = read(fileno(IoIFP(io)), buffer+offset, length); - } - else -#ifdef HAS_SOCKET - if (IoTYPE(io) == 's') { - bufsize = sizeof buf; - length = recvfrom(fileno(IoIFP(io)), buffer+offset, length, 0, - (struct sockaddr *)buf, &bufsize); - } - else -#endif - length = fread(buffer+offset, 1, length, IoIFP(io)); - if (length < 0) - goto say_undef; - SvCUR_set(bufstr, length+offset); - *SvEND(bufstr) = '\0'; - SvPOK_only(bufstr); - if (tainting) - sv_magic(bufstr, 0, 't', 0, 0); - SP = ORIGMARK; - PUSHi(length); - RETURN; - - say_undef: - SP = ORIGMARK; - RETPUSHUNDEF; -} - -PP(pp_syswrite) -{ - return pp_send(ARGS); -} - -PP(pp_send) -{ - dSP; dMARK; dORIGMARK; dTARGET; - GV *gv; - IO *io; - int offset; - SV *bufstr; - char *buffer; - int length; - STRLEN blen; - - gv = (GV*)*++MARK; - if (!gv) - goto say_undef; - bufstr = *++MARK; - buffer = SvPV(bufstr, blen); - length = SvIVx(*++MARK); - errno = 0; - io = GvIO(gv); - if (!io || !IoIFP(io)) { - length = -1; - if (dowarn) { - if (op->op_type == OP_SYSWRITE) - warn("Syswrite on closed filehandle"); - else - warn("Send on closed socket"); - } - } - else if (op->op_type == OP_SYSWRITE) { - if (MARK < SP) - offset = SvIVx(*++MARK); - else - offset = 0; - if (MARK < SP) - warn("Too many args on syswrite"); - length = write(fileno(IoIFP(io)), buffer+offset, length); - } -#ifdef HAS_SOCKET - else if (SP >= MARK) { - STRLEN mlen; - if (SP > MARK) - warn("Too many args on send"); - buffer = SvPVx(*++MARK, mlen); - length = sendto(fileno(IoIFP(io)), buffer, blen, length, - (struct sockaddr *)buffer, mlen); - } - else - length = send(fileno(IoIFP(io)), buffer, blen, length); -#else - else - DIE(no_sock_func, "send"); -#endif - if (length < 0) - goto say_undef; - SP = ORIGMARK; - PUSHi(length); - RETURN; - - say_undef: - SP = ORIGMARK; - RETPUSHUNDEF; -} - -PP(pp_recv) -{ - return pp_sysread(ARGS); -} - -PP(pp_eof) -{ - dSP; - GV *gv; - - if (MAXARG <= 0) - gv = last_in_gv; - else - gv = last_in_gv = (GV*)POPs; - PUSHs(!gv || do_eof(gv) ? &sv_yes : &sv_no); - RETURN; -} - -PP(pp_tell) -{ - dSP; dTARGET; - GV *gv; - - if (MAXARG <= 0) - gv = last_in_gv; - else - gv = last_in_gv = (GV*)POPs; - PUSHi( do_tell(gv) ); - RETURN; -} - -PP(pp_seek) -{ - dSP; - GV *gv; - int whence = POPi; - long offset = POPl; - - gv = last_in_gv = (GV*)POPs; - PUSHs( do_seek(gv, offset, whence) ? &sv_yes : &sv_no ); - RETURN; -} - -PP(pp_truncate) -{ - dSP; - Off_t len = (Off_t)POPn; - int result = 1; - GV *tmpgv; - - errno = 0; -#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) -#ifdef HAS_TRUNCATE - if (op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO); - if (!tmpgv || !GvIO(tmpgv) || !IoIFP(GvIO(tmpgv)) || - ftruncate(fileno(IoIFP(GvIO(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 (!tmpgv || !GvIO(tmpgv) || !IoIFP(GvIO(tmpgv)) || - chsize(fileno(IoIFP(GvIO(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; - if (!errno) - errno = EBADF; - RETPUSHUNDEF; -#else - DIE("truncate not implemented"); -#endif -} - -PP(pp_fcntl) -{ - return pp_ioctl(ARGS); -} - -PP(pp_ioctl) -{ - dSP; dTARGET; - SV *argstr = POPs; - unsigned int func = U_I(POPn); - int optype = op->op_type; - char *s; - int retval; - GV *gv = (GV*)POPs; - IO *io = GvIOn(gv); - - if (!io || !argstr || !IoIFP(io)) { - errno = EBADF; /* well, sort of... */ - RETPUSHUNDEF; - } - - if (SvPOK(argstr) || !SvNIOK(argstr)) { - STRLEN len = 0; - if (!SvPOK(argstr)) - s = SvPV(argstr, len); - retval = IOCPARM_LEN(func); - if (len < retval) { - Sv_Grow(argstr, retval+1); - SvCUR_set(argstr, retval); - } - - s = SvPVX(argstr); - s[SvCUR(argstr)] = 17; /* a little sanity check here */ - } - else { - retval = SvIV(argstr); -#ifdef DOSISH - s = (char*)(long)retval; /* ouch */ -#else - s = (char*)retval; /* ouch */ -#endif - } - - TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl"); - - if (optype == OP_IOCTL) - retval = ioctl(fileno(IoIFP(io)), func, s); - else -#ifdef DOSISH - DIE("fcntl is not implemented"); -#else -# ifdef HAS_FCNTL - retval = fcntl(fileno(IoIFP(io)), func, s); -# else - DIE("fcntl is not implemented"); -# endif -#endif - - if (SvPOK(argstr)) { - if (s[SvCUR(argstr)] != 17) - DIE("Possible memory corruption: %s overflowed 3rd argument", - op_name[optype]); - s[SvCUR(argstr)] = 0; /* put our null back */ - } - - if (retval == -1) - RETPUSHUNDEF; - if (retval != 0) { - PUSHi(retval); - } - else { - PUSHp("0 but true", 10); - } - RETURN; -} - -PP(pp_flock) -{ - dSP; dTARGET; - I32 value; - int argtype; - GV *gv; - FILE *fp; -#ifdef HAS_FLOCK - argtype = POPi; - if (MAXARG <= 0) - gv = last_in_gv; - else - gv = (GV*)POPs; - if (gv && GvIO(gv)) - fp = IoIFP(GvIO(gv)); - else - fp = Nullfp; - if (fp) { - value = (I32)(flock(fileno(fp), argtype) >= 0); - } - else - value = 0; - PUSHi(value); - RETURN; -#else - DIE(no_func, "flock()"); -#endif -} - -/* Sockets. */ - -PP(pp_socket) -{ - dSP; -#ifdef HAS_SOCKET - GV *gv; - register IO *io; - int protocol = POPi; - int type = POPi; - int domain = POPi; - int fd; - - gv = (GV*)POPs; - - if (!gv) { - errno = EBADF; - RETPUSHUNDEF; - } - - io = GvIOn(gv); - if (IoIFP(io)) - do_close(gv, FALSE); - - TAINT_PROPER("socket"); - fd = socket(domain, type, protocol); - if (fd < 0) - RETPUSHUNDEF; - IoIFP(io) = fdopen(fd, "r"); /* stdio gets confused about sockets */ - IoOFP(io) = fdopen(fd, "w"); - IoTYPE(io) = 's'; - if (!IoIFP(io) || !IoOFP(io)) { - if (IoIFP(io)) fclose(IoIFP(io)); - if (IoOFP(io)) fclose(IoOFP(io)); - if (!IoIFP(io) && !IoOFP(io)) close(fd); - RETPUSHUNDEF; - } - - RETPUSHYES; -#else - DIE(no_sock_func, "socket"); -#endif -} - -PP(pp_sockpair) -{ - dSP; -#ifdef HAS_SOCKETPAIR - GV *gv1; - GV *gv2; - register IO *io1; - register IO *io2; - int protocol = POPi; - int type = POPi; - int domain = POPi; - int fd[2]; - - gv2 = (GV*)POPs; - gv1 = (GV*)POPs; - if (!gv1 || !gv2) - RETPUSHUNDEF; - - io1 = GvIOn(gv1); - io2 = GvIOn(gv2); - if (IoIFP(io1)) - do_close(gv1, FALSE); - if (IoIFP(io2)) - do_close(gv2, FALSE); - - TAINT_PROPER("socketpair"); - if (socketpair(domain, type, protocol, fd) < 0) - RETPUSHUNDEF; - IoIFP(io1) = fdopen(fd[0], "r"); - IoOFP(io1) = fdopen(fd[0], "w"); - IoTYPE(io1) = 's'; - IoIFP(io2) = fdopen(fd[1], "r"); - IoOFP(io2) = fdopen(fd[1], "w"); - IoTYPE(io2) = 's'; - if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { - if (IoIFP(io1)) fclose(IoIFP(io1)); - if (IoOFP(io1)) fclose(IoOFP(io1)); - if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]); - if (IoIFP(io2)) fclose(IoIFP(io2)); - if (IoOFP(io2)) fclose(IoOFP(io2)); - if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]); - RETPUSHUNDEF; - } - - RETPUSHYES; -#else - DIE(no_sock_func, "socketpair"); -#endif -} - -PP(pp_bind) -{ - dSP; -#ifdef HAS_SOCKET - SV *addrstr = POPs; - char *addr; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - STRLEN len; - - if (!io || !IoIFP(io)) - goto nuts; - - addr = SvPV(addrstr, len); - TAINT_PROPER("bind"); - if (bind(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) - RETPUSHYES; - else - RETPUSHUNDEF; - -nuts: - if (dowarn) - warn("bind() on closed fd"); - errno = EBADF; - RETPUSHUNDEF; -#else - DIE(no_sock_func, "bind"); -#endif -} - -PP(pp_connect) -{ - dSP; -#ifdef HAS_SOCKET - SV *addrstr = POPs; - char *addr; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - STRLEN len; - - if (!io || !IoIFP(io)) - goto nuts; - - addr = SvPV(addrstr, len); - TAINT_PROPER("connect"); - if (connect(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) - RETPUSHYES; - else - RETPUSHUNDEF; - -nuts: - if (dowarn) - warn("connect() on closed fd"); - errno = EBADF; - RETPUSHUNDEF; -#else - DIE(no_sock_func, "connect"); -#endif -} - -PP(pp_listen) -{ - dSP; -#ifdef HAS_SOCKET - int backlog = POPi; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoIFP(io)) - goto nuts; - - if (listen(fileno(IoIFP(io)), backlog) >= 0) - RETPUSHYES; - else - RETPUSHUNDEF; - -nuts: - if (dowarn) - warn("listen() on closed fd"); - errno = EBADF; - RETPUSHUNDEF; -#else - DIE(no_sock_func, "listen"); -#endif -} - -PP(pp_accept) -{ - dSP; dTARGET; -#ifdef HAS_SOCKET - GV *ngv; - GV *ggv; - register IO *nstio; - register IO *gstio; - int len = sizeof buf; - int fd; - - ggv = (GV*)POPs; - ngv = (GV*)POPs; - - if (!ngv) - goto badexit; - if (!ggv) - goto nuts; - - gstio = GvIO(ggv); - if (!gstio || !IoIFP(gstio)) - goto nuts; - - nstio = GvIOn(ngv); - if (IoIFP(nstio)) - do_close(ngv, FALSE); - - fd = accept(fileno(IoIFP(gstio)), (struct sockaddr *)buf, &len); - if (fd < 0) - goto badexit; - IoIFP(nstio) = fdopen(fd, "r"); - IoOFP(nstio) = fdopen(fd, "w"); - IoTYPE(nstio) = 's'; - if (!IoIFP(nstio) || !IoOFP(nstio)) { - if (IoIFP(nstio)) fclose(IoIFP(nstio)); - if (IoOFP(nstio)) fclose(IoOFP(nstio)); - if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd); - goto badexit; - } - - PUSHp(buf, len); - RETURN; - -nuts: - if (dowarn) - warn("accept() on closed fd"); - errno = EBADF; - -badexit: - RETPUSHUNDEF; - -#else - DIE(no_sock_func, "accept"); -#endif -} - -PP(pp_shutdown) -{ - dSP; dTARGET; -#ifdef HAS_SOCKET - int how = POPi; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoIFP(io)) - goto nuts; - - PUSHi( shutdown(fileno(IoIFP(io)), how) >= 0 ); - RETURN; - -nuts: - if (dowarn) - warn("shutdown() on closed fd"); - errno = EBADF; - RETPUSHUNDEF; -#else - DIE(no_sock_func, "shutdown"); -#endif -} - -PP(pp_gsockopt) -{ -#ifdef HAS_SOCKET - return pp_ssockopt(ARGS); -#else - DIE(no_sock_func, "getsockopt"); -#endif -} - -PP(pp_ssockopt) -{ - dSP; -#ifdef HAS_SOCKET - int optype = op->op_type; - SV *sv; - int fd; - unsigned int optname; - unsigned int lvl; - GV *gv; - register IO *io; - - if (optype == OP_GSOCKOPT) - sv = sv_2mortal(NEWSV(22, 257)); - else - sv = POPs; - optname = (unsigned int) POPi; - lvl = (unsigned int) POPi; - - gv = (GV*)POPs; - io = GvIOn(gv); - if (!io || !IoIFP(io)) - goto nuts; - - fd = fileno(IoIFP(io)); - switch (optype) { - case OP_GSOCKOPT: - SvCUR_set(sv, 256); - SvPOK_only(sv); - if (getsockopt(fd, lvl, optname, SvPVX(sv), (int*)&SvCUR(sv)) < 0) - goto nuts2; - PUSHs(sv); - break; - case OP_SSOCKOPT: - if (setsockopt(fd, lvl, optname, SvPVX(sv), SvCUR(sv)) < 0) - goto nuts2; - PUSHs(&sv_yes); - break; - } - RETURN; - -nuts: - if (dowarn) - warn("[gs]etsockopt() on closed fd"); - errno = EBADF; -nuts2: - RETPUSHUNDEF; - -#else - DIE(no_sock_func, "setsockopt"); -#endif -} - -PP(pp_getsockname) -{ -#ifdef HAS_SOCKET - return pp_getpeername(ARGS); -#else - DIE(no_sock_func, "getsockname"); -#endif -} - -PP(pp_getpeername) -{ - dSP; -#ifdef HAS_SOCKET - int optype = op->op_type; - SV *sv; - int fd; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoIFP(io)) - goto nuts; - - sv = sv_2mortal(NEWSV(22, 257)); - SvCUR_set(sv, 256); - SvPOK_on(sv); - fd = fileno(IoIFP(io)); - switch (optype) { - case OP_GETSOCKNAME: - if (getsockname(fd, (struct sockaddr *)SvPVX(sv), (int*)&SvCUR(sv)) < 0) - goto nuts2; - break; - case OP_GETPEERNAME: - if (getpeername(fd, (struct sockaddr *)SvPVX(sv), (int*)&SvCUR(sv)) < 0) - goto nuts2; - break; - } - PUSHs(sv); - RETURN; - -nuts: - if (dowarn) - warn("get{sock, peer}name() on closed fd"); - errno = EBADF; -nuts2: - RETPUSHUNDEF; - -#else - DIE(no_sock_func, "getpeername"); -#endif -} - -/* Stat calls. */ - -PP(pp_lstat) -{ - return pp_stat(ARGS); -} - -PP(pp_stat) -{ - dSP; - GV *tmpgv; - I32 max = 13; - - if (op->op_flags & OPf_SPECIAL) { - tmpgv = cGVOP->op_gv; - if (tmpgv != defgv) { - laststype = OP_STAT; - statgv = tmpgv; - sv_setpv(statname, ""); - if (!GvIO(tmpgv) || !IoIFP(GvIO(tmpgv)) || - fstat(fileno(IoIFP(GvIO(tmpgv))), &statcache) < 0) { - max = 0; - laststatval = -1; - } - } - else if (laststatval < 0) - max = 0; - } - else { - sv_setpv(statname, POPp); - statgv = Nullgv; -#ifdef HAS_LSTAT - laststype = op->op_type; - if (op->op_type == OP_LSTAT) - laststatval = lstat(SvPV(statname, na), &statcache); - else -#endif - laststatval = stat(SvPV(statname, na), &statcache); - if (laststatval < 0) { - if (dowarn && strchr(SvPV(statname, na), '\n')) - warn(warn_nl, "stat"); - max = 0; - } - } - - EXTEND(SP, 13); - if (GIMME != G_ARRAY) { - if (max) - RETPUSHYES; - else - RETPUSHUNDEF; - } - if (max) { - PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_size))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime))); -#ifdef USE_STAT_BLOCKS - PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize))); - PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks))); -#else - PUSHs(sv_2mortal(newSVpv("", 0))); - PUSHs(sv_2mortal(newSVpv("", 0))); -#endif - } - RETURN; -} - -PP(pp_ftrread) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IRUSR, 0, &statcache)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftrwrite) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IWUSR, 0, &statcache)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftrexec) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IXUSR, 0, &statcache)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_fteread) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IRUSR, 1, &statcache)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftewrite) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IWUSR, 1, &statcache)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_fteexec) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (cando(S_IXUSR, 1, &statcache)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftis) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - RETPUSHYES; -} - -PP(pp_fteowned) -{ - return pp_ftrowned(ARGS); -} - -PP(pp_ftrowned) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) ) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftzero) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (!statcache.st_size) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftsize) -{ - I32 result = my_stat(ARGS); - dSP; dTARGET; - if (result < 0) - RETPUSHUNDEF; - PUSHi(statcache.st_size); - RETURN; -} - -PP(pp_ftmtime) -{ - I32 result = my_stat(ARGS); - dSP; dTARGET; - if (result < 0) - RETPUSHUNDEF; - PUSHn( (basetime - statcache.st_mtime) / 86400.0 ); - RETURN; -} - -PP(pp_ftatime) -{ - I32 result = my_stat(ARGS); - dSP; dTARGET; - if (result < 0) - RETPUSHUNDEF; - PUSHn( (basetime - statcache.st_atime) / 86400.0 ); - RETURN; -} - -PP(pp_ftctime) -{ - I32 result = my_stat(ARGS); - dSP; dTARGET; - if (result < 0) - RETPUSHUNDEF; - PUSHn( (basetime - statcache.st_ctime) / 86400.0 ); - RETURN; -} - -PP(pp_ftsock) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISSOCK(statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftchr) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISCHR(statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftblk) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISBLK(statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftfile) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISREG(statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftdir) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISDIR(statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftpipe) -{ - I32 result = my_stat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISFIFO(statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftlink) -{ - I32 result = my_lstat(ARGS); - dSP; - if (result < 0) - RETPUSHUNDEF; - if (S_ISLNK(statcache.st_mode)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_ftsuid) -{ - dSP; -#ifdef S_ISUID - I32 result = my_stat(ARGS); - SPAGAIN; - if (result < 0) - RETPUSHUNDEF; - if (statcache.st_mode & S_ISUID) - RETPUSHYES; -#endif - RETPUSHNO; -} - -PP(pp_ftsgid) -{ - dSP; -#ifdef S_ISGID - I32 result = my_stat(ARGS); - SPAGAIN; - if (result < 0) - RETPUSHUNDEF; - if (statcache.st_mode & S_ISGID) - RETPUSHYES; -#endif - RETPUSHNO; -} - -PP(pp_ftsvtx) -{ - dSP; -#ifdef S_ISVTX - I32 result = my_stat(ARGS); - SPAGAIN; - if (result < 0) - RETPUSHUNDEF; - if (statcache.st_mode & S_ISVTX) - RETPUSHYES; -#endif - RETPUSHNO; -} - -PP(pp_fttty) -{ - dSP; - int fd; - GV *gv; - char *tmps; - if (op->op_flags & OPf_SPECIAL) { - gv = cGVOP->op_gv; - tmps = ""; - } - else - gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO); - if (gv && GvIO(gv) && IoIFP(GvIO(gv))) - fd = fileno(IoIFP(GvIO(gv))); - else if (isDIGIT(*tmps)) - fd = atoi(tmps); - else - RETPUSHUNDEF; - if (isatty(fd)) - RETPUSHYES; - RETPUSHNO; -} - -PP(pp_fttext) -{ - dSP; - I32 i; - I32 len; - I32 odd = 0; - STDCHAR tbuf[512]; - register STDCHAR *s; - register IO *io; - SV *sv; - - if (op->op_flags & OPf_SPECIAL) { - EXTEND(SP, 1); - if (cGVOP->op_gv == defgv) { - if (statgv) - io = GvIO(statgv); - else { - sv = statname; - goto really_filename; - } - } - else { - statgv = cGVOP->op_gv; - sv_setpv(statname, ""); - io = GvIO(statgv); - } - if (io && IoIFP(io)) { -#if defined(USE_STD_STDIO) || defined(atarist) /* this will work with atariST */ - fstat(fileno(IoIFP(io)), &statcache); - if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */ - if (op->op_type == OP_FTTEXT) - RETPUSHNO; - else - RETPUSHYES; - if (IoIFP(io)->_cnt <= 0) { - i = getc(IoIFP(io)); - if (i != EOF) - (void)ungetc(i, IoIFP(io)); - } - if (IoIFP(io)->_cnt <= 0) /* null file is anything */ - RETPUSHYES; - len = IoIFP(io)->_cnt + (IoIFP(io)->_ptr - IoIFP(io)->_base); - s = IoIFP(io)->_base; -#else - DIE("-T and -B not implemented on filehandles"); -#endif - } - else { - if (dowarn) - warn("Test on unopened file <%s>", - GvENAME(cGVOP->op_gv)); - errno = EBADF; - RETPUSHUNDEF; - } - } - else { - sv = POPs; - statgv = Nullgv; - sv_setpv(statname, SvPV(sv, na)); - really_filename: - i = open(SvPV(sv, na), 0); - if (i < 0) { - if (dowarn && strchr(SvPV(sv, na), '\n')) - warn(warn_nl, "open"); - RETPUSHUNDEF; - } - fstat(i, &statcache); - len = read(i, tbuf, 512); - (void)close(i); - if (len <= 0) { - if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT) - RETPUSHNO; /* special case NFS directories */ - RETPUSHYES; /* null file is anything */ - } - s = tbuf; - } - - /* now scan s to look for textiness */ - - for (i = 0; i < len; i++, s++) { - if (!*s) { /* null never allowed in text */ - odd += len; - break; - } - else if (*s & 128) - odd++; - else if (*s < 32 && - *s != '\n' && *s != '\r' && *s != '\b' && - *s != '\t' && *s != '\f' && *s != 27) - odd++; - } - - if ((odd * 10 > len) == (op->op_type == OP_FTTEXT)) /* allow 10% odd */ - RETPUSHNO; - else - RETPUSHYES; -} - -PP(pp_ftbinary) -{ - return pp_fttext(ARGS); -} - -/* File calls. */ - -PP(pp_chdir) -{ - dSP; dTARGET; - double value; - char *tmps; - SV **svp; - - if (MAXARG < 1) - tmps = Nullch; - else - tmps = POPp; - if (!tmps || !*tmps) { - svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE); - if (svp) - tmps = SvPV(*svp, na); - } - if (!tmps || !*tmps) { - svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE); - if (svp) - tmps = SvPV(*svp, na); - } - TAINT_PROPER("chdir"); - PUSHi( chdir(tmps) >= 0 ); - RETURN; -} - -PP(pp_chown) -{ - dSP; dMARK; dTARGET; - I32 value; -#ifdef HAS_CHOWN - value = (I32)apply(op->op_type, MARK, SP); - SP = MARK; - PUSHi(value); - RETURN; -#else - DIE(no_func, "Unsupported function chown"); -#endif -} - -PP(pp_chroot) -{ - dSP; dTARGET; - char *tmps; -#ifdef HAS_CHROOT - if (MAXARG < 1) - tmps = SvPVx(GvSV(defgv), na); - else - tmps = POPp; - TAINT_PROPER("chroot"); - PUSHi( chroot(tmps) >= 0 ); - RETURN; -#else - DIE(no_func, "chroot"); -#endif -} - -PP(pp_unlink) -{ - dSP; dMARK; dTARGET; - I32 value; - value = (I32)apply(op->op_type, MARK, SP); - SP = MARK; - PUSHi(value); - RETURN; -} - -PP(pp_chmod) -{ - dSP; dMARK; dTARGET; - I32 value; - value = (I32)apply(op->op_type, MARK, SP); - SP = MARK; - PUSHi(value); - RETURN; -} - -PP(pp_utime) -{ - dSP; dMARK; dTARGET; - I32 value; - value = (I32)apply(op->op_type, MARK, SP); - SP = MARK; - PUSHi(value); - RETURN; -} - -PP(pp_rename) -{ - dSP; dTARGET; - int anum; - - char *tmps2 = POPp; - char *tmps = SvPV(TOPs, na); - TAINT_PROPER("rename"); -#ifdef HAS_RENAME - anum = rename(tmps, tmps2); -#else - if (same_dirent(tmps2, tmps)) /* can always rename to same name */ - anum = 1; - else { - if (euid || stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) - (void)UNLINK(tmps2); - if (!(anum = link(tmps, tmps2))) - anum = UNLINK(tmps); - } -#endif - SETi( anum >= 0 ); - RETURN; -} - -PP(pp_link) -{ - dSP; dTARGET; -#ifdef HAS_LINK - char *tmps2 = POPp; - char *tmps = SvPV(TOPs, na); - TAINT_PROPER("link"); - SETi( link(tmps, tmps2) >= 0 ); -#else - DIE(no_func, "Unsupported function link"); -#endif - RETURN; -} - -PP(pp_symlink) -{ - dSP; dTARGET; -#ifdef HAS_SYMLINK - char *tmps2 = POPp; - char *tmps = SvPV(TOPs, na); - TAINT_PROPER("symlink"); - SETi( symlink(tmps, tmps2) >= 0 ); - RETURN; -#else - DIE(no_func, "symlink"); -#endif -} - -PP(pp_readlink) -{ - dSP; dTARGET; -#ifdef HAS_SYMLINK - char *tmps; - int len; - if (MAXARG < 1) - tmps = SvPVx(GvSV(defgv), na); - else - tmps = POPp; - len = readlink(tmps, buf, sizeof buf); - EXTEND(SP, 1); - if (len < 0) - RETPUSHUNDEF; - PUSHp(buf, len); - RETURN; -#else - EXTEND(SP, 1); - RETSETUNDEF; /* just pretend it's a normal file */ -#endif -} - -#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) -static void -dooneliner(cmd, filename) -char *cmd; -char *filename; -{ - char mybuf[8192]; - char *s; - int anum = 1; - FILE *myfp; - - strcpy(mybuf, cmd); - strcat(mybuf, " "); - for (s = mybuf+strlen(mybuf); *filename; ) { - *s++ = '\\'; - *s++ = *filename++; - } - strcpy(s, " 2>&1"); - myfp = my_popen(mybuf, "r"); - if (myfp) { - *mybuf = '\0'; - s = fgets(mybuf, sizeof mybuf, myfp); - (void)my_pclose(myfp); - if (s != Nullch) { - for (errno = 1; errno < sys_nerr; errno++) { - if (instr(mybuf, sys_errlist[errno])) /* you don't see this */ - return 0; - } - errno = 0; -#ifndef EACCES -#define EACCES EPERM -#endif - if (instr(mybuf, "cannot make")) - errno = EEXIST; - else if (instr(mybuf, "existing file")) - errno = EEXIST; - else if (instr(mybuf, "ile exists")) - errno = EEXIST; - else if (instr(mybuf, "non-exist")) - errno = ENOENT; - else if (instr(mybuf, "does not exist")) - errno = ENOENT; - else if (instr(mybuf, "not empty")) - errno = EBUSY; - else if (instr(mybuf, "cannot access")) - errno = EACCES; - else - errno = EPERM; - return 0; - } - else { /* some mkdirs return no failure indication */ - tmps = SvPVx(st[1], na); - anum = (stat(tmps, &statbuf) >= 0); - if (op->op_type == OP_RMDIR) - anum = !anum; - if (anum) - errno = 0; - else - errno = EACCES; /* a guess */ - } - return anum; - } - else - return 0; -} -#endif - -PP(pp_mkdir) -{ - dSP; dTARGET; - int mode = POPi; - int oldumask; - char *tmps = SvPV(TOPs, na); - - TAINT_PROPER("mkdir"); -#ifdef HAS_MKDIR - SETi( mkdir(tmps, mode) >= 0 ); -#else - SETi( dooneliner("mkdir", tmps) ); - oldumask = umask(0) - umask(oldumask); - chmod(tmps, (mode & ~oldumask) & 0777); -#endif - RETURN; -} - -PP(pp_rmdir) -{ - dSP; dTARGET; - char *tmps; - - if (MAXARG < 1) - tmps = SvPVx(GvSV(defgv), na); - else - tmps = POPp; - TAINT_PROPER("rmdir"); -#ifdef HAS_RMDIR - XPUSHi( rmdir(tmps) >= 0 ); -#else - XPUSHi( dooneliner("rmdir", tmps) ); -#endif - RETURN; -} - -/* Directory calls. */ - -PP(pp_open_dir) -{ - dSP; -#if defined(DIRENT) && defined(HAS_READDIR) - char *dirname = POPp; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io) - goto nope; - - if (IoDIRP(io)) - closedir(IoDIRP(io)); - if (!(IoDIRP(io) = opendir(dirname))) - goto nope; - - RETPUSHYES; -nope: - if (!errno) - errno = EBADF; RETPUSHUNDEF; -#else - DIE(no_dir_func, "opendir"); -#endif -} - -PP(pp_readdir) -{ - dSP; -#if defined(DIRENT) && defined(HAS_READDIR) -#ifndef I_DIRENT - struct DIRENT *readdir P((DIR *)); /* XXX is this *ever* needed? */ -#endif - register struct DIRENT *dp; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoDIRP(io)) - goto nope; - - if (GIMME == G_ARRAY) { - /*SUPPRESS 560*/ - while (dp = (struct DIRENT *)readdir(IoDIRP(io))) { -#ifdef DIRNAMLEN - XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen))); -#else - XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0))); -#endif - } - } - else { - if (!(dp = (struct DIRENT *)readdir(IoDIRP(io)))) - goto nope; -#ifdef DIRNAMLEN - XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen))); -#else - XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0))); -#endif - } - RETURN; - -nope: - if (!errno) - errno = EBADF; - if (GIMME == G_ARRAY) - RETURN; - else - RETPUSHUNDEF; -#else - DIE(no_dir_func, "readdir"); -#endif -} - -PP(pp_telldir) -{ - dSP; dTARGET; -#if defined(HAS_TELLDIR) || defined(telldir) -#ifndef telldir - long telldir(); -#endif - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoDIRP(io)) - goto nope; - - PUSHi( telldir(IoDIRP(io)) ); - RETURN; -nope: - if (!errno) - errno = EBADF; - RETPUSHUNDEF; -#else - DIE(no_dir_func, "telldir"); -#endif -} - -PP(pp_seekdir) -{ - dSP; -#if defined(HAS_SEEKDIR) || defined(seekdir) - long along = POPl; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoDIRP(io)) - goto nope; - - (void)seekdir(IoDIRP(io), along); - - RETPUSHYES; -nope: - if (!errno) - errno = EBADF; - RETPUSHUNDEF; -#else - DIE(no_dir_func, "seekdir"); -#endif -} - -PP(pp_rewinddir) -{ - dSP; -#if defined(HAS_REWINDDIR) || defined(rewinddir) - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoDIRP(io)) - goto nope; - - (void)rewinddir(IoDIRP(io)); - RETPUSHYES; -nope: - if (!errno) - errno = EBADF; - RETPUSHUNDEF; -#else - DIE(no_dir_func, "rewinddir"); -#endif -} - -PP(pp_closedir) -{ - dSP; -#if defined(DIRENT) && defined(HAS_READDIR) - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); - - if (!io || !IoDIRP(io)) - goto nope; - - if (closedir(IoDIRP(io)) < 0) - goto nope; - IoDIRP(io) = 0; - - RETPUSHYES; -nope: - if (!errno) - errno = EBADF; - RETPUSHUNDEF; -#else - DIE(no_dir_func, "closedir"); -#endif -} - -/* Process control. */ - -PP(pp_fork) -{ - dSP; dTARGET; - int childpid; - GV *tmpgv; - - EXTEND(SP, 1); -#ifdef HAS_FORK - childpid = fork(); - if (childpid < 0) - RETSETUNDEF; - if (!childpid) { - /*SUPPRESS 560*/ - if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (I32)getpid()); - hv_clear(pidstatus); /* no kids, so don't wait for 'em */ - } - PUSHi(childpid); - RETURN; -#else - DIE(no_func, "Unsupported function fork"); -#endif -} - -PP(pp_wait) -{ - dSP; dTARGET; - int childpid; - int argflags; - I32 value; - - EXTEND(SP, 1); -#ifdef HAS_WAIT - childpid = wait(&argflags); - if (childpid > 0) - pidgone(childpid, argflags); - value = (I32)childpid; - statusvalue = (U16)argflags; - PUSHi(value); - RETURN; -#else - DIE(no_func, "Unsupported function wait"); -#endif -} - -PP(pp_waitpid) -{ - dSP; dTARGET; - int childpid; - int optype; - int argflags; - I32 value; - -#ifdef HAS_WAIT - optype = POPi; - childpid = TOPi; - childpid = wait4pid(childpid, &argflags, optype); - value = (I32)childpid; - statusvalue = (U16)argflags; - SETi(value); - RETURN; -#else - DIE(no_func, "Unsupported function wait"); -#endif -} - -PP(pp_system) -{ - dSP; dMARK; dORIGMARK; dTARGET; - I32 value; - int childpid; - int result; - int status; - VOIDRET (*ihand)(); /* place to save signal during system() */ - VOIDRET (*qhand)(); /* place to save signal during system() */ - -#ifdef HAS_FORK - if (SP - MARK == 1) { - if (tainting) { - char *junk = SvPV(TOPs, na); - TAINT_ENV(); - TAINT_PROPER("system"); - } - } - while ((childpid = vfork()) == -1) { - if (errno != EAGAIN) { - value = -1; - SP = ORIGMARK; - PUSHi(value); - RETURN; - } - sleep(5); - } - if (childpid > 0) { - ihand = signal(SIGINT, SIG_IGN); - qhand = signal(SIGQUIT, SIG_IGN); - result = wait4pid(childpid, &status, 0); - (void)signal(SIGINT, ihand); - (void)signal(SIGQUIT, qhand); - statusvalue = (U16)status; - if (result < 0) - value = -1; - else { - value = (I32)((unsigned int)status & 0xffff); - } - do_execfree(); /* free any memory child malloced on vfork */ - SP = ORIGMARK; - PUSHi(value); - RETURN; - } - if (op->op_flags & OPf_STACKED) { - SV *really = *++MARK; - value = (I32)do_aexec(really, MARK, SP); - } - else if (SP - MARK != 1) - value = (I32)do_aexec(Nullsv, MARK, SP); - else { - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na)); - } - _exit(-1); -#else /* ! FORK */ - if ((op[1].op_type & A_MASK) == A_GV) - value = (I32)do_aspawn(st[1], arglast); - else if (arglast[2] - arglast[1] != 1) - value = (I32)do_aspawn(Nullsv, arglast); - else { - value = (I32)do_spawn(SvPVx(sv_mortalcopy(st[2]), na)); - } - PUSHi(value); -#endif /* FORK */ - RETURN; -} - -PP(pp_exec) -{ - dSP; dMARK; dORIGMARK; dTARGET; - I32 value; - - if (op->op_flags & OPf_STACKED) { - SV *really = *++MARK; - value = (I32)do_aexec(really, MARK, SP); - } - else if (SP - MARK != 1) - value = (I32)do_aexec(Nullsv, MARK, SP); - else { - if (tainting) { - char *junk = SvPV(*SP, na); - TAINT_ENV(); - TAINT_PROPER("exec"); - } - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na)); - } - SP = ORIGMARK; - PUSHi(value); - RETURN; -} - -PP(pp_kill) -{ - dSP; dMARK; dTARGET; - I32 value; -#ifdef HAS_KILL - value = (I32)apply(op->op_type, MARK, SP); - SP = MARK; - PUSHi(value); - RETURN; -#else - DIE(no_func, "Unsupported function kill"); -#endif -} - -PP(pp_getppid) -{ -#ifdef HAS_GETPPID - dSP; dTARGET; - XPUSHi( getppid() ); - RETURN; -#else - DIE(no_func, "getppid"); -#endif -} - -PP(pp_getpgrp) -{ -#ifdef HAS_GETPGRP - dSP; dTARGET; - int pid; - I32 value; - - if (MAXARG < 1) - pid = 0; - else - pid = SvIVx(POPs); -#ifdef _POSIX_SOURCE - if (pid != 0) - DIE("POSIX getpgrp can't take an argument"); - value = (I32)getpgrp(); -#else - value = (I32)getpgrp(pid); -#endif - XPUSHi(value); - RETURN; -#else - DIE(no_func, "getpgrp()"); -#endif -} - -PP(pp_setpgrp) -{ -#ifdef HAS_SETPGRP - dSP; dTARGET; - int pgrp = POPi; - int pid = TOPi; - - TAINT_PROPER("setpgrp"); - SETi( setpgrp(pid, pgrp) >= 0 ); - RETURN; -#else - DIE(no_func, "setpgrp()"); -#endif -} - -PP(pp_getpriority) -{ - dSP; dTARGET; - int which; - int who; -#ifdef HAS_GETPRIORITY - who = POPi; - which = TOPi; - SETi( getpriority(which, who) ); - RETURN; -#else - DIE(no_func, "getpriority()"); -#endif -} - -PP(pp_setpriority) -{ - dSP; dTARGET; - int which; - int who; - int niceval; -#ifdef HAS_SETPRIORITY - niceval = POPi; - who = POPi; - which = TOPi; - TAINT_PROPER("setpriority"); - SETi( setpriority(which, who, niceval) >= 0 ); - RETURN; -#else - DIE(no_func, "setpriority()"); -#endif -} - -/* Time calls. */ - -PP(pp_time) -{ - dSP; dTARGET; - XPUSHi( time(Null(Time_t*)) ); - RETURN; -} - -#ifndef HZ -#define HZ 60 -#endif - -PP(pp_tms) -{ - dSP; - -#if defined(MSDOS) || !defined(HAS_TIMES) - DIE("times not implemented"); -#else - EXTEND(SP, 4); - - (void)times(×buf); - - PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ))); - if (GIMME == G_ARRAY) { - PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ))); - PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ))); - PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ))); - } - RETURN; -#endif /* MSDOS */ -} - -PP(pp_localtime) -{ - return pp_gmtime(ARGS); -} - -PP(pp_gmtime) -{ - dSP; - Time_t when; - struct tm *tmbuf; - static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; - static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; - - if (MAXARG < 1) - (void)time(&when); - else - when = (Time_t)SvIVx(POPs); - - if (op->op_type == OP_LOCALTIME) - tmbuf = localtime(&when); - else - tmbuf = gmtime(&when); - - EXTEND(SP, 9); - if (GIMME != G_ARRAY) { - dTARGET; - char mybuf[30]; - if (!tmbuf) - RETPUSHUNDEF; - sprintf(mybuf, "%s %s %2d %02d:%02d:%02d %d", - dayname[tmbuf->tm_wday], - monname[tmbuf->tm_mon], - tmbuf->tm_mday, - tmbuf->tm_hour, - tmbuf->tm_min, - tmbuf->tm_sec, - tmbuf->tm_year + 1900); - PUSHp(mybuf, strlen(mybuf)); - } - else if (tmbuf) { - PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec))); - PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min))); - PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour))); - PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday))); - PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon))); - PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year))); - PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday))); - PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday))); - PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst))); - } - RETURN; -} - -PP(pp_alarm) -{ - dSP; dTARGET; - int anum; -#ifdef HAS_ALARM - if (MAXARG < 1) - anum = SvIVx(GvSV(defgv)); - else - anum = POPi; - anum = alarm((unsigned int)anum); - EXTEND(SP, 1); - if (anum < 0) - RETPUSHUNDEF; - PUSHi((I32)anum); - RETURN; -#else - DIE(no_func, "Unsupported function alarm"); - break; -#endif -} - -PP(pp_sleep) -{ - dSP; dTARGET; - char *tmps; - I32 duration; - Time_t lasttime; - Time_t when; - - (void)time(&lasttime); - if (MAXARG < 1) - pause(); - else { - duration = POPi; - sleep((unsigned int)duration); - } - (void)time(&when); - XPUSHi(when - lasttime); - RETURN; -} - -/* Shared memory. */ - -PP(pp_shmget) -{ - return pp_semget(ARGS); -} - -PP(pp_shmctl) -{ - return pp_semctl(ARGS); -} - -PP(pp_shmread) -{ - return pp_shmwrite(ARGS); -} - -PP(pp_shmwrite) -{ -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0); - SP = MARK; - PUSHi(value); - RETURN; -#else - pp_semget(ARGS); -#endif -} - -/* Message passing. */ - -PP(pp_msgget) -{ - return pp_semget(ARGS); -} - -PP(pp_msgctl) -{ - return pp_semctl(ARGS); -} - -PP(pp_msgsnd) -{ -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - I32 value = (I32)(do_msgsnd(MARK, SP) >= 0); - SP = MARK; - PUSHi(value); - RETURN; -#else - pp_semget(ARGS); -#endif -} - -PP(pp_msgrcv) -{ -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - I32 value = (I32)(do_msgrcv(MARK, SP) >= 0); - SP = MARK; - PUSHi(value); - RETURN; -#else - pp_semget(ARGS); -#endif -} - -/* Semaphores. */ - -PP(pp_semget) -{ -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - int anum = do_ipcget(op->op_type, MARK, SP); - SP = MARK; - if (anum == -1) - RETPUSHUNDEF; - PUSHi(anum); - RETURN; -#else - DIE("System V IPC is not implemented on this machine"); -#endif -} - -PP(pp_semctl) -{ -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - int anum = do_ipcctl(op->op_type, MARK, SP); - SP = MARK; - if (anum == -1) - RETSETUNDEF; - if (anum != 0) { - PUSHi(anum); - } - else { - PUSHp("0 but true",10); - } - RETURN; -#else - pp_semget(ARGS); -#endif -} - -PP(pp_semop) -{ -#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dSP; dMARK; dTARGET; - I32 value = (I32)(do_semop(MARK, SP) >= 0); - SP = MARK; - PUSHi(value); - RETURN; -#else - pp_semget(ARGS); -#endif -} - -/* Eval. */ - -static void -save_lines(array, sv) -AV *array; -SV *sv; -{ - register char *s = SvPVX(sv); - register char *send = SvPVX(sv) + SvCUR(sv); - register char *t; - register I32 line = 1; - - while (s && s < send) { - SV *tmpstr = NEWSV(85,0); - - sv_upgrade(tmpstr, SVt_PVMG); - t = strchr(s, '\n'); - if (t) - t++; - else - t = send; - - sv_setpvn(tmpstr, s, t - s); - av_store(array, line++, tmpstr); - s = t; - } -} - -OP * -doeval() -{ - dSP; - OP *saveop = op; - HV *newstash; - - in_eval = 1; - - /* set up a scratch pad */ - - SAVEINT(padix); - SAVESPTR(curpad); - SAVESPTR(comppad); - SAVESPTR(comppad_name); - SAVEINT(comppad_name_fill); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); - comppad = newAV(); - comppad_name = newAV(); - comppad_name_fill = 0; - min_intro_pending = 0; - av_push(comppad, Nullsv); - curpad = AvARRAY(comppad); - padix = 0; - - /* make sure we compile in the right package */ - - newstash = curcop->cop_stash; - if (curstash != newstash) { - SAVESPTR(curstash); - curstash = newstash; - } - SAVESPTR(beginav); - beginav = 0; - - /* try to compile it */ - - eval_root = Nullop; - error_count = 0; - curcop = &compiling; - rs = "\n"; - rslen = 1; - rschar = '\n'; - rspara = 0; - if (yyparse() || error_count || !eval_root) { - SV **newsp; - I32 gimme; - CONTEXT *cx; - I32 optype; - - op = saveop; - if (eval_root) { - op_free(eval_root); - eval_root = Nullop; - } - POPBLOCK(cx); - POPEVAL(cx); - pop_return(); - lex_end(); - LEAVE; - if (optype == OP_REQUIRE) - DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); - rs = nrs; - rslen = nrslen; - rschar = nrschar; - rspara = (nrslen == 2); - RETPUSHUNDEF; - } - rs = nrs; - rslen = nrslen; - rschar = nrschar; - rspara = (nrslen == 2); - compiling.cop_line = 0; - SAVEFREESV(comppad_name); - SAVEFREESV(comppad); - SAVEFREEOP(eval_root); - - DEBUG_x(dump_eval()); - - /* compiled okay, so do it */ - - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); - RETURNOP(eval_start); -} - -PP(pp_require) -{ - dSP; - register CONTEXT *cx; - SV *sv; - char *name; - char *tmpname; - SV** svp; - I32 gimme = G_SCALAR; - FILE *tryrsfp = 0; - - if (MAXARG < 1) { - sv = GvSV(defgv); - EXTEND(SP, 1); - } - else - sv = POPs; - if (SvNIOK(sv) && !SvPOKp(sv)) { - if (SvNV(sv) > atof(patchlevel) + 0.000999) - DIE("Perl %3.3f required--this is only version %s, stopped", - SvNV(sv),patchlevel); - RETPUSHYES; - } - name = SvPV(sv, na); - if (op->op_type == OP_REQUIRE && - (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) && - *svp != &sv_undef) - RETPUSHYES; - - /* prepare to compile file */ - - tmpname = savestr(name); - if (*tmpname == '/' || - (*tmpname == '.' && - (tmpname[1] == '/' || - (tmpname[1] == '.' && tmpname[2] == '/')))) - { - tryrsfp = fopen(tmpname,"r"); - } - else { - AV *ar = GvAVn(incgv); - I32 i; - - for (i = 0; i <= AvFILL(ar); i++) { - (void)sprintf(buf, "%s/%s", - SvPVx(*av_fetch(ar, i, TRUE), na), name); - tryrsfp = fopen(buf, "r"); - if (tryrsfp) { - char *s = buf; - - if (*s == '.' && s[1] == '/') - s += 2; - Safefree(tmpname); - tmpname = savestr(s); - break; - } - } - } - compiling.cop_filegv = gv_fetchfile(tmpname); - Safefree(tmpname); - tmpname = Nullch; - if (!tryrsfp) { - if (op->op_type == OP_REQUIRE) { - sprintf(tokenbuf,"Can't locate %s in @INC", name); - if (instr(tokenbuf,".h ")) - strcat(tokenbuf," (change .h to .ph maybe?)"); - if (instr(tokenbuf,".ph ")) - strcat(tokenbuf," (did you run h2ph?)"); - DIE("%s",tokenbuf); - } - - RETPUSHUNDEF; - } - - /* Assume success here to prevent recursive requirement. */ - (void)hv_store(GvHVn(incgv), name, strlen(name), - newSVsv(GvSV(compiling.cop_filegv)), 0 ); - - ENTER; - SAVETMPS; - lex_start(sv_2mortal(newSVpv("",0))); - rsfp = tryrsfp; - name = savestr(name); - SAVEFREEPV(name); - - /* switch to eval mode */ - - push_return(op->op_next); - PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, name, compiling.cop_filegv); - - compiling.cop_line = 0; - - PUTBACK; - return doeval(); -} - -PP(pp_dofile) -{ - return pp_require(ARGS); -} - -PP(pp_entereval) -{ - dSP; - register CONTEXT *cx; - dPOPss; - I32 gimme = GIMME; - char tmpbuf[32]; - - ENTER; - SAVETMPS; - lex_start(sv); - - /* switch to eval mode */ - - sprintf(tmpbuf, "_<(eval %d)", ++evalseq); - compiling.cop_filegv = gv_fetchfile(tmpbuf+2); - compiling.cop_line = 1; - SAVEDELETE(defstash, savestr(tmpbuf), strlen(tmpbuf)); - - push_return(op->op_next); - PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, 0, compiling.cop_filegv); - - /* prepare to compile string */ - - if (perldb && curstash != debstash) - save_lines(GvAV(compiling.cop_filegv), linestr); - PUTBACK; - return doeval(); -} - -PP(pp_leaveeval) -{ - dSP; - register SV **mark; - SV **newsp; - I32 gimme; - register CONTEXT *cx; - OP *retop; - I32 optype; - OP *eroot = eval_root; - - POPBLOCK(cx); - POPEVAL(cx); - retop = pop_return(); - - if (gimme == G_SCALAR) { - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & SVs_TEMP) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } - else { - MEXTEND(mark,0); - *MARK = &sv_undef; - } - SP = MARK; - } - else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(TOPs) & SVs_TEMP)) - *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ - } - - 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)); - - if (optype == OP_REQUIRE) - retop = die("%s did not return a true value", name); - } - } - - lex_end(); - LEAVE; - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); - - RETURNOP(retop); -} - -PP(pp_evalonce) -{ - dSP; -#ifdef NOTDEF - SP = do_eval(st[1], OP_EVAL, curcop->cop_stash, TRUE, - GIMME, arglast); - if (eval_root) { - SvREFCNT_dec(cSVOP->op_sv); - op[1].arg_ptr.arg_cmd = eval_root; - op[1].op_type = (A_CMD|A_DONT); - op[0].op_type = OP_TRY; - } - RETURN; - -#endif - RETURN; -} - -PP(pp_entertry) -{ - dSP; - register CONTEXT *cx; - I32 gimme = GIMME; - - ENTER; - SAVETMPS; - - push_return(cLOGOP->op_other->op_next); - PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, 0, 0); - eval_root = op; /* Only needed so that goto works right. */ - - in_eval = 1; - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); - RETURN; -} - -PP(pp_leavetry) -{ - dSP; - register SV **mark; - SV **newsp; - I32 gimme; - register CONTEXT *cx; - I32 optype; - - POPBLOCK(cx); - POPEVAL(cx); - pop_return(); - - if (gimme == G_SCALAR) { - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } - else { - MEXTEND(mark,0); - *MARK = &sv_undef; - } - SP = MARK; - } - else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))) - *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ - } - - LEAVE; - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); - RETURN; -} - -/* Get system info. */ - -PP(pp_ghbyname) -{ -#ifdef HAS_SOCKET - return pp_ghostent(ARGS); -#else - DIE(no_sock_func, "gethostbyname"); -#endif -} - -PP(pp_ghbyaddr) -{ -#ifdef HAS_SOCKET - return pp_ghostent(ARGS); -#else - DIE(no_sock_func, "gethostbyaddr"); -#endif -} - -PP(pp_ghostent) -{ - dSP; -#ifdef HAS_SOCKET - I32 which = op->op_type; - register char **elem; - register SV *sv; - struct hostent *gethostbyname(); - struct hostent *gethostbyaddr(); -#ifdef HAS_GETHOSTENT - struct hostent *gethostent(); -#endif - struct hostent *hent; - unsigned long len; - - EXTEND(SP, 10); - if (which == OP_GHBYNAME) { - hent = gethostbyname(POPp); - } - else if (which == OP_GHBYADDR) { - int addrtype = POPi; - SV *addrstr = POPs; - char *addr = SvPV(addrstr, na); - - hent = gethostbyaddr(addr, SvCUR(addrstr), addrtype); - } - else -#ifdef HAS_GETHOSTENT - hent = gethostent(); -#else - DIE("gethostent not implemented"); -#endif - -#ifdef HOST_NOT_FOUND - if (!hent) - statusvalue = (U16)h_errno & 0xffff; -#endif - - if (GIMME != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (hent) { - if (which == OP_GHBYNAME) { - sv_setpvn(sv, hent->h_addr, hent->h_length); - } - else - sv_setpv(sv, hent->h_name); - } - RETURN; - } - - if (hent) { - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, hent->h_name); - PUSHs(sv = sv_mortalcopy(&sv_no)); - for (elem = hent->h_aliases; *elem; elem++) { - sv_catpv(sv, *elem); - if (elem[1]) - sv_catpvn(sv, " ", 1); - } - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setiv(sv, (I32)hent->h_addrtype); - PUSHs(sv = sv_mortalcopy(&sv_no)); - len = hent->h_length; - sv_setiv(sv, (I32)len); -#ifdef h_addr - for (elem = hent->h_addr_list; *elem; elem++) { - XPUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpvn(sv, *elem, len); - } -#else - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpvn(sv, hent->h_addr, len); -#endif /* h_addr */ - } - RETURN; -#else - DIE(no_sock_func, "gethostent"); -#endif -} - -PP(pp_gnbyname) -{ -#ifdef HAS_SOCKET - return pp_gnetent(ARGS); -#else - DIE(no_sock_func, "getnetbyname"); -#endif -} - -PP(pp_gnbyaddr) -{ -#ifdef HAS_SOCKET - return pp_gnetent(ARGS); -#else - DIE(no_sock_func, "getnetbyaddr"); -#endif -} - -PP(pp_gnetent) -{ - dSP; -#ifdef HAS_SOCKET - I32 which = op->op_type; - register char **elem; - register SV *sv; - struct netent *getnetbyname(); - struct netent *getnetbyaddr(); - struct netent *getnetent(); - struct netent *nent; - - if (which == OP_GNBYNAME) - nent = getnetbyname(POPp); - else if (which == OP_GNBYADDR) { - int addrtype = POPi; - unsigned long addr = U_L(POPn); - nent = getnetbyaddr((long)addr, addrtype); - } - else - nent = getnetent(); - - EXTEND(SP, 4); - if (GIMME != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (nent) { - if (which == OP_GNBYNAME) - sv_setiv(sv, (I32)nent->n_net); - else - sv_setpv(sv, nent->n_name); - } - RETURN; - } - - if (nent) { - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, nent->n_name); - PUSHs(sv = sv_mortalcopy(&sv_no)); - for (elem = nent->n_aliases; *elem; elem++) { - sv_catpv(sv, *elem); - if (elem[1]) - sv_catpvn(sv, " ", 1); - } - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setiv(sv, (I32)nent->n_addrtype); - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setiv(sv, (I32)nent->n_net); - } - - RETURN; -#else - DIE(no_sock_func, "getnetent"); -#endif -} - -PP(pp_gpbyname) -{ -#ifdef HAS_SOCKET - return pp_gprotoent(ARGS); -#else - DIE(no_sock_func, "getprotobyname"); -#endif -} - -PP(pp_gpbynumber) -{ -#ifdef HAS_SOCKET - return pp_gprotoent(ARGS); -#else - DIE(no_sock_func, "getprotobynumber"); -#endif -} - -PP(pp_gprotoent) -{ - dSP; -#ifdef HAS_SOCKET - I32 which = op->op_type; - register char **elem; - register SV *sv; - struct protoent *getprotobyname(); - struct protoent *getprotobynumber(); - struct protoent *getprotoent(); - struct protoent *pent; - - if (which == OP_GPBYNAME) - pent = getprotobyname(POPp); - else if (which == OP_GPBYNUMBER) - pent = getprotobynumber(POPi); - else - pent = getprotoent(); - - EXTEND(SP, 3); - if (GIMME != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (pent) { - if (which == OP_GPBYNAME) - sv_setiv(sv, (I32)pent->p_proto); - else - sv_setpv(sv, pent->p_name); - } - RETURN; - } - - if (pent) { - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, pent->p_name); - PUSHs(sv = sv_mortalcopy(&sv_no)); - for (elem = pent->p_aliases; *elem; elem++) { - sv_catpv(sv, *elem); - if (elem[1]) - sv_catpvn(sv, " ", 1); - } - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setiv(sv, (I32)pent->p_proto); - } - - RETURN; -#else - DIE(no_sock_func, "getprotoent"); -#endif -} - -PP(pp_gsbyname) -{ -#ifdef HAS_SOCKET - return pp_gservent(ARGS); -#else - DIE(no_sock_func, "getservbyname"); -#endif -} - -PP(pp_gsbyport) -{ -#ifdef HAS_SOCKET - return pp_gservent(ARGS); -#else - DIE(no_sock_func, "getservbyport"); -#endif -} - -PP(pp_gservent) -{ - dSP; -#ifdef HAS_SOCKET - I32 which = op->op_type; - register char **elem; - register SV *sv; - struct servent *getservbyname(); - struct servent *getservbynumber(); - struct servent *getservent(); - struct servent *sent; - - if (which == OP_GSBYNAME) { - char *proto = POPp; - char *name = POPp; - - if (proto && !*proto) - proto = Nullch; - - sent = getservbyname(name, proto); - } - else if (which == OP_GSBYPORT) { - char *proto = POPp; - int port = POPi; - - sent = getservbyport(port, proto); - } - else - sent = getservent(); - - EXTEND(SP, 4); - if (GIMME != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (sent) { - if (which == OP_GSBYNAME) { -#ifdef HAS_NTOHS - sv_setiv(sv, (I32)ntohs(sent->s_port)); -#else - sv_setiv(sv, (I32)(sent->s_port)); -#endif - } - else - sv_setpv(sv, sent->s_name); - } - RETURN; - } - - if (sent) { - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, sent->s_name); - PUSHs(sv = sv_mortalcopy(&sv_no)); - for (elem = sent->s_aliases; *elem; elem++) { - sv_catpv(sv, *elem); - if (elem[1]) - sv_catpvn(sv, " ", 1); - } - PUSHs(sv = sv_mortalcopy(&sv_no)); -#ifdef HAS_NTOHS - sv_setiv(sv, (I32)ntohs(sent->s_port)); -#else - sv_setiv(sv, (I32)(sent->s_port)); -#endif - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, sent->s_proto); - } - - RETURN; -#else - DIE(no_sock_func, "getservent"); -#endif -} - -PP(pp_shostent) -{ - dSP; -#ifdef HAS_SOCKET - sethostent(TOPi); - RETSETYES; -#else - DIE(no_sock_func, "sethostent"); -#endif -} - -PP(pp_snetent) -{ - dSP; -#ifdef HAS_SOCKET - setnetent(TOPi); - RETSETYES; -#else - DIE(no_sock_func, "setnetent"); -#endif -} - -PP(pp_sprotoent) -{ - dSP; -#ifdef HAS_SOCKET - setprotoent(TOPi); - RETSETYES; -#else - DIE(no_sock_func, "setprotoent"); -#endif -} - -PP(pp_sservent) -{ - dSP; -#ifdef HAS_SOCKET - setservent(TOPi); - RETSETYES; -#else - DIE(no_sock_func, "setservent"); -#endif -} - -PP(pp_ehostent) -{ - dSP; -#ifdef HAS_SOCKET - endhostent(); - EXTEND(sp,1); - RETPUSHYES; -#else - DIE(no_sock_func, "endhostent"); -#endif -} - -PP(pp_enetent) -{ - dSP; -#ifdef HAS_SOCKET - endnetent(); - EXTEND(sp,1); - RETPUSHYES; -#else - DIE(no_sock_func, "endnetent"); -#endif -} - -PP(pp_eprotoent) -{ - dSP; -#ifdef HAS_SOCKET - endprotoent(); - EXTEND(sp,1); - RETPUSHYES; -#else - DIE(no_sock_func, "endprotoent"); -#endif -} - -PP(pp_eservent) -{ - dSP; -#ifdef HAS_SOCKET - endservent(); - EXTEND(sp,1); - RETPUSHYES; -#else - DIE(no_sock_func, "endservent"); -#endif -} - -PP(pp_gpwnam) -{ -#ifdef HAS_PASSWD - return pp_gpwent(ARGS); -#else - DIE(no_func, "getpwnam"); -#endif -} - -PP(pp_gpwuid) -{ -#ifdef HAS_PASSWD - return pp_gpwent(ARGS); -#else - DIE(no_func, "getpwuid"); -#endif -} - -PP(pp_gpwent) -{ - dSP; -#ifdef HAS_PASSWD - I32 which = op->op_type; - register AV *ary = stack; - register SV *sv; - struct passwd *pwent; - - if (which == OP_GPWNAM) - pwent = getpwnam(POPp); - else if (which == OP_GPWUID) - pwent = getpwuid(POPi); - else - pwent = (struct passwd *)getpwent(); - - EXTEND(SP, 10); - if (GIMME != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (pwent) { - if (which == OP_GPWNAM) - sv_setiv(sv, (I32)pwent->pw_uid); - else - sv_setpv(sv, pwent->pw_name); - } - RETURN; - } - - if (pwent) { - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, pwent->pw_name); - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, pwent->pw_passwd); - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setiv(sv, (I32)pwent->pw_uid); - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setiv(sv, (I32)pwent->pw_gid); - PUSHs(sv = sv_mortalcopy(&sv_no)); -#ifdef PWCHANGE - sv_setiv(sv, (I32)pwent->pw_change); -#else -#ifdef PWQUOTA - sv_setiv(sv, (I32)pwent->pw_quota); -#else -#ifdef PWAGE - sv_setpv(sv, pwent->pw_age); -#endif -#endif -#endif - PUSHs(sv = sv_mortalcopy(&sv_no)); -#ifdef PWCLASS - sv_setpv(sv, pwent->pw_class); -#else -#ifdef PWCOMMENT - sv_setpv(sv, pwent->pw_comment); -#endif -#endif - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, pwent->pw_gecos); - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, pwent->pw_dir); - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, pwent->pw_shell); -#ifdef PWEXPIRE - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setiv(sv, (I32)pwent->pw_expire); -#endif - } - RETURN; -#else - DIE(no_func, "getpwent"); -#endif -} - -PP(pp_spwent) -{ - dSP; dTARGET; -#ifdef HAS_PASSWD - setpwent(); - RETPUSHYES; -#else - DIE(no_func, "setpwent"); -#endif -} - -PP(pp_epwent) -{ - dSP; dTARGET; -#ifdef HAS_PASSWD - endpwent(); - RETPUSHYES; -#else - DIE(no_func, "endpwent"); -#endif -} - -PP(pp_ggrnam) -{ -#ifdef HAS_GROUP - return pp_ggrent(ARGS); -#else - DIE(no_func, "getgrnam"); -#endif -} - -PP(pp_ggrgid) -{ -#ifdef HAS_GROUP - return pp_ggrent(ARGS); -#else - DIE(no_func, "getgrgid"); -#endif -} - -PP(pp_ggrent) -{ - dSP; -#ifdef HAS_GROUP - I32 which = op->op_type; - register char **elem; - register SV *sv; - struct group *grent; - - if (which == OP_GGRNAM) - grent = getgrnam(POPp); - else if (which == OP_GGRGID) - grent = getgrgid(POPi); - else - grent = (struct group *)getgrent(); - - EXTEND(SP, 4); - if (GIMME != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (grent) { - if (which == OP_GGRNAM) - sv_setiv(sv, (I32)grent->gr_gid); - else - sv_setpv(sv, grent->gr_name); - } - RETURN; - } - - if (grent) { - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, grent->gr_name); - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setpv(sv, grent->gr_passwd); - PUSHs(sv = sv_mortalcopy(&sv_no)); - sv_setiv(sv, (I32)grent->gr_gid); - PUSHs(sv = sv_mortalcopy(&sv_no)); - for (elem = grent->gr_mem; *elem; elem++) { - sv_catpv(sv, *elem); - if (elem[1]) - sv_catpvn(sv, " ", 1); - } - } - - RETURN; -#else - DIE(no_func, "getgrent"); -#endif -} - -PP(pp_sgrent) -{ - dSP; dTARGET; -#ifdef HAS_GROUP - setgrent(); - RETPUSHYES; -#else - DIE(no_func, "setgrent"); -#endif -} - -PP(pp_egrent) -{ - dSP; dTARGET; -#ifdef HAS_GROUP - endgrent(); - RETPUSHYES; -#else - DIE(no_func, "endgrent"); -#endif -} - -PP(pp_getlogin) -{ - dSP; dTARGET; -#ifdef HAS_GETLOGIN - char *tmps; - EXTEND(SP, 1); - if (!(tmps = getlogin())) - RETPUSHUNDEF; - PUSHp(tmps, strlen(tmps)); - RETURN; -#else - DIE(no_func, "getlogin"); -#endif -} - -/* Miscellaneous. */ - -PP(pp_syscall) -{ -#ifdef HAS_SYSCALL - dSP; dMARK; dORIGMARK; dTARGET; - register I32 items = SP - MARK; - unsigned long a[20]; - register I32 i = 0; - I32 retval = -1; - - if (tainting) { - while (++MARK <= SP) { - if (SvRMAGICAL(*MARK) && mg_find(*MARK, 't')) - tainted = TRUE; - } - MARK = ORIGMARK; - TAINT_PROPER("syscall"); - } - - /* This probably won't work on machines where sizeof(long) != sizeof(int) - * or where sizeof(long) != sizeof(char*). But such machines will - * not likely have syscall implemented either, so who cares? - */ - while (++MARK <= SP) { - if (SvNIOK(*MARK) || !i) - a[i++] = SvIV(*MARK); - else - a[i++] = (unsigned long)SvPVX(*MARK); - if (i > 15) - break; - } - switch (items) { - default: - DIE("Too many args to syscall"); - case 0: - DIE("Too few args to syscall"); - case 1: - retval = syscall(a[0]); - break; - case 2: - retval = syscall(a[0],a[1]); - break; - case 3: - retval = syscall(a[0],a[1],a[2]); - break; - case 4: - retval = syscall(a[0],a[1],a[2],a[3]); - break; - case 5: - retval = syscall(a[0],a[1],a[2],a[3],a[4]); - break; - case 6: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]); - break; - case 7: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]); - break; - case 8: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]); - break; -#ifdef atarist - case 9: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]); - break; - case 10: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]); - break; - case 11: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10]); - break; - case 12: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10],a[11]); - break; - case 13: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10],a[11],a[12]); - break; - case 14: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], - a[10],a[11],a[12],a[13]); - break; -#endif /* atarist */ - } - SP = ORIGMARK; - PUSHi(retval); - RETURN; -#else - DIE(no_func, "syscall"); -#endif } @@ -1,23 +1,11 @@ -/*********************************************************** +/* pp.h * - * $Header: /usr/src/local/lwall/perl5/RCS/pp.h,v 4.1 92/08/07 18:26:20 lwall Exp Locker: lwall $ + * Copyright (c) 1991-1994, Larry Wall * - * Description: - * Push/Pop code defs. + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. * - * Standards: - * - * Created: - * Mon Jun 15 16:47:20 1992 - * - * Author: - * Larry Wall <lwall@netlabs.com> - * - * $Log: pp.h,v $ - * Revision 4.1 92/08/07 18:26:20 lwall - * - * - **********************************************************/ + */ #define ARGS #define ARGSproto void @@ -28,12 +16,18 @@ #define MARK mark #define TARG targ +#define PUSHMARK(p) if (++markstack_ptr == markstack_max) \ + markstack_grow(); \ + *markstack_ptr = (p) - stack_base + +#define TOPMARK (*markstack_ptr) #define POPMARK (*markstack_ptr--) + #define dSP register SV **sp = stack_sp #define dMARK register SV **mark = stack_base + POPMARK #define dORIGMARK I32 origmark = mark - stack_base #define SETORIGMARK origmark = mark - stack_base -#define ORIGMARK stack_base + origmark +#define ORIGMARK (stack_base + origmark) #define SPAGAIN sp = stack_sp #define MSPAGAIN sp = stack_sp; mark = ORIGMARK @@ -49,20 +43,8 @@ #define dTARG SV *targ -#define GETavn(a,g,st) \ - a = sv_2av(cGVOP->op_gv ? (SV*)cGVOP->op_gv : POPs, &st, &g, 1) -#define GEThvn(h,g,st) \ - h = sv_2hv(cGVOP->op_gv ? (SV*)cGVOP->op_gv : POPs, &st, &g, 1) -#define GETav(a,g,st) \ - a = sv_2av(cGVOP->op_gv ? (SV*)cGVOP->op_gv : POPs, &st, &g, 0) -#define GEThv(h,g,st) \ - h = sv_2hv(cGVOP->op_gv ? (SV*)cGVOP->op_gv : POPs, &st, &g, 0) -#define GETcv(r,g,st) \ - r = sv_2cv(POPs, &st, &g, 0) - #define NORMAL op->op_next #define DIE return die -#define PROP if (dying) return die("%s", dying); #define PUTBACK stack_sp = sp #define RETURN return PUTBACK, NORMAL @@ -72,69 +54,63 @@ #define POPs (*sp--) #define POPp (SvPVx(POPs, na)) #define POPn (SvNVx(POPs)) -#define POPi ((int)SvIVx(POPs)) +#define POPi ((IV)SvIVx(POPs)) #define POPl ((long)SvIVx(POPs)) #define TOPs (*sp) #define TOPp (SvPV(TOPs, na)) #define TOPn (SvNV(TOPs)) -#define TOPi ((int)SvIV(TOPs)) +#define TOPi ((IV)SvIV(TOPs)) #define TOPl ((long)SvIV(TOPs)) /* Go to some pains in the rare event that we must extend the stack. */ #define EXTEND(p,n) do { if (stack_max - p < (n)) { \ - av_fill(stack, (p - stack_base) + (n) + 128); \ - sp = AvARRAY(stack) + (sp - stack_base); \ - stack_base = AvARRAY(stack); \ - stack_max = stack_base + AvMAX(stack) - 1; \ + sp = stack_grow(sp,p, (int) (n)); \ } } while (0) + /* Same thing, but update mark register too. */ #define MEXTEND(p,n) do {if (stack_max - p < (n)) { \ - av_fill(stack, (p - stack_base) + (n) + 128); \ - sp = AvARRAY(stack) + (sp - stack_base); \ - mark = AvARRAY(stack) + (mark - stack_base); \ - stack_base = AvARRAY(stack); \ - stack_max = stack_base + AvMAX(stack) - 1; \ + int markoff = mark - stack_base; \ + sp = stack_grow(sp,p,(int) (n)); \ + mark = stack_base + markoff; \ } } while (0) #define PUSHs(s) (*++sp = (s)) #define PUSHTARG do { SvSETMAGIC(TARG); PUSHs(TARG); } while (0) #define PUSHp(p,l) do { sv_setpvn(TARG, (p), (l)); PUSHTARG; } while (0) -#define PUSHn(n) do { sv_setnv(TARG, (n)); PUSHTARG; } while (0) -#define PUSHi(i) do { sv_setiv(TARG, (i)); PUSHTARG; } while (0) +#define PUSHn(n) do { sv_setnv(TARG, (double)(n)); PUSHTARG; } while (0) +#define PUSHi(i) do { sv_setiv(TARG, (IV)(i)); PUSHTARG; } while (0) #define XPUSHs(s) do { EXTEND(sp,1); (*++sp = (s)); } while (0) #define XPUSHTARG do { SvSETMAGIC(TARG); XPUSHs(TARG); } while (0) #define XPUSHp(p,l) do { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } while (0) -#define XPUSHn(n) do { sv_setnv(TARG, (n)); XPUSHTARG; } while (0) -#define XPUSHi(i) do { sv_setiv(TARG, (i)); XPUSHTARG; } while (0) - -#define MXPUSHs(s) do { MEXTEND(sp,1); (*++sp = (s)); } while (0) -#define MXPUSHTARG do { SvSETMAGIC(TARG); XPUSHs(TARG); } while (0) -#define MXPUSHp(p,l) do { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } while (0) -#define MXPUSHn(n) do { sv_setnv(TARG, (n)); XPUSHTARG; } while (0) -#define MXPUSHi(i) do { sv_setiv(TARG, (i)); XPUSHTARG; } while (0) +#define XPUSHn(n) do { sv_setnv(TARG, (double)(n)); XPUSHTARG; } while (0) +#define XPUSHi(i) do { sv_setiv(TARG, (IV)(i)); XPUSHTARG; } while (0) #define SETs(s) (*sp = s) #define SETTARG do { SvSETMAGIC(TARG); SETs(TARG); } while (0) #define SETp(p,l) do { sv_setpvn(TARG, (p), (l)); SETTARG; } while (0) -#define SETn(n) do { sv_setnv(TARG, (n)); SETTARG; } while (0) -#define SETi(i) do { sv_setiv(TARG, (i)); SETTARG; } while (0) +#define SETn(n) do { sv_setnv(TARG, (double)(n)); SETTARG; } while (0) +#define SETi(i) do { sv_setiv(TARG, (IV)(i)); SETTARG; } while (0) + +#ifdef OVERLOAD +#define SETsv(sv) do { sv_setsv(TARG, (sv)); SETTARG; } while (0) +#endif /* OVERLOAD */ #define dTOPss SV *sv = TOPs #define dPOPss SV *sv = POPs #define dTOPnv double value = TOPn #define dPOPnv double value = POPn -#define dTOPiv I32 value = TOPi -#define dPOPiv I32 value = POPi +#define dTOPiv IV value = TOPi +#define dPOPiv IV value = POPi -#define dPOPPOPssrl SV *rstr = POPs; SV *lstr = POPs +#define dPOPPOPssrl SV *right = POPs; SV *left = POPs #define dPOPPOPnnrl double right = POPn; double left = POPn -#define dPOPPOPiirl I32 right = POPi; I32 left = POPi +#define dPOPPOPiirl IV right = POPi; IV left = POPi -#define dPOPTOPssrl SV *rstr = POPs; SV *lstr = TOPs +#define dPOPTOPssrl SV *right = POPs; SV *left = TOPs #define dPOPTOPnnrl double right = POPn; double left = TOPn -#define dPOPTOPiirl I32 right = POPi; I32 left = TOPi +#define dPOPTOPiirl IV right = POPi; IV left = TOPi #define RETPUSHYES RETURNX(PUSHs(&sv_yes)) #define RETPUSHNO RETURNX(PUSHs(&sv_no)) @@ -150,20 +126,68 @@ #define SWITCHSTACK(f,t) AvFILL(f) = sp - stack_base; \ stack_base = AvARRAY(t); \ stack_max = stack_base + AvMAX(t); \ - sp = stack_base + AvFILL(t); \ + sp = stack_sp = stack_base + AvFILL(t); \ stack = t; -#define ENTER push_scope() -#define LEAVE pop_scope() - -#define SAVEINT(i) save_int((int*)(&i)); -#define SAVEI32(i) save_I32((I32*)(&i)); -#define SAVELONG(l) save_long((long*)(&l)); -#define SAVESPTR(s) save_sptr((SV**)(&s)) -#define SAVEPPTR(s) save_pptr((char**)(&s)) -#define SAVETMPS save_int(&tmps_floor), tmps_floor = tmps_ix -#define SAVEFREESV(s) save_freesv((SV*)(s)) -#define SAVEFREEOP(o) save_freeop((OP*)(o)) -#define SAVEFREEPV(p) save_freepv((char*)(p)) -#define SAVECLEARSV(sv) save_clearsv((SV**)(&sv)) -#define SAVEDELETE(h,k,l) save_delete((HV*)(h), (char*)(k), (I32)l) +#ifdef OVERLOAD + +#define AMGf_noright 1 +#define AMGf_noleft 2 +#define AMGf_assign 4 +#define AMGf_unary 8 + +#define tryAMAGICbinW(meth,assign,set) do { \ + if (amagic_generation) { \ + SV* tmpsv; \ + SV* right= *(sp); SV* left= *(sp-1);\ + if ((SvAMAGIC(left)||SvAMAGIC(right))&&\ + (tmpsv=amagic_call(left, \ + right, \ + CAT2(meth,_amg), \ + (assign)? AMGf_assign: 0))) {\ + SPAGAIN; \ + (void)POPs; set(tmpsv); RETURN; } \ + } \ + } while (0) + +#define tryAMAGICbin(meth,assign) tryAMAGICbinW(meth,assign,SETsv) +#define tryAMAGICbinSET(meth,assign) tryAMAGICbinW(meth,assign,SETs) + +#define AMG_CALLun(sv,meth) amagic_call(sv,&sv_undef, \ + CAT2(meth,_amg),AMGf_noright | AMGf_unary) +#define AMG_CALLbinL(left,right,meth) \ + amagic_call(left,right,CAT2(meth,_amg),AMGf_noright) + +#define tryAMAGICunW(meth,set) do { \ + if (amagic_generation) { \ + SV* tmpsv; \ + SV* arg= *(sp); \ + if ((SvAMAGIC(arg))&&\ + (tmpsv=AMG_CALLun(arg,meth))) {\ + SPAGAIN; \ + set(tmpsv); RETURN; } \ + } \ + } while (0) + +#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 */ + + +#define RvDEEPCP(rv) do { SV* ref=SvRV(rv); \ + if (SvREFCNT(ref)>1) { \ + SvREFCNT_dec(ref); \ + SvRV(rv)=newSVsv(ref); \ + } } while (0) +#else + +#define tryAMAGICbin(a,b) +#define tryAMAGICbinSET(a,b) +#define tryAMAGICun(a) +#define tryAMAGICunSET(a) + +#endif /* OVERLOAD */ diff --git a/pp_ctl.c b/pp_ctl.c new file mode 100644 index 0000000000..db62e3cc07 --- /dev/null +++ b/pp_ctl.c @@ -0,0 +1,2348 @@ +/* pp_ctl.c + * + * Copyright (c) 1991-1994, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* + * Now far ahead the Road has gone, + * And I must follow, if I can, + * Pursuing it with eager feet, + * Until it joins some larger way + * Where many paths and errands meet. + * And whither then? I cannot say. + */ + +#include "EXTERN.h" +#include "perl.h" + +#ifndef WORD_ALIGN +#define WORD_ALIGN sizeof(U16) +#endif + +static OP *doeval _((int gimme)); +static OP *dofindlabel _((OP *op, char *label, OP **opstack)); +static void doparseform _((SV *sv)); +static I32 dopoptoeval _((I32 startingblock)); +static I32 dopoptolabel _((char *label)); +static I32 dopoptoloop _((I32 startingblock)); +static I32 dopoptosub _((I32 startingblock)); +static void save_lines _((AV *array, SV *sv)); +static int sortcmp _((const void *, const void *)); +static int sortcv _((const void *, const void *)); + +static I32 sortcxix; + +PP(pp_wantarray) +{ + dSP; + I32 cxix; + EXTEND(SP, 1); + + cxix = dopoptosub(cxstack_ix); + if (cxix < 0) + RETPUSHUNDEF; + + if (cxstack[cxix].blk_gimme == G_ARRAY) + RETPUSHYES; + else + RETPUSHNO; +} + +PP(pp_regcmaybe) +{ + return NORMAL; +} + +PP(pp_regcomp) { + dSP; + register PMOP *pm = (PMOP*)cLOGOP->op_other; + register char *t; + SV *tmpstr; + STRLEN len; + + tmpstr = POPs; + t = SvPV(tmpstr, len); + + if (pm->op_pmregexp) { + regfree(pm->op_pmregexp); + pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ + } + + pm->op_pmregexp = regcomp(t, t + len, pm); + + if (!pm->op_pmregexp->prelen && curpm) + pm = curpm; + else if (strEQ("\\s+", pm->op_pmregexp->precomp)) + pm->op_pmflags |= PMf_WHITE; + + if (pm->op_pmflags & PMf_KEEP) { +#ifdef NOTDEF + if (!(pm->op_pmflags & PMf_FOLD)) + scan_prefix(pm, pm->op_pmregexp->precomp, + pm->op_pmregexp->prelen); +#endif + pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */ + hoistmust(pm); + cLOGOP->op_first->op_next = op->op_next; + /* XXX delete push code? */ + } + RETURN; +} + +PP(pp_substcont) +{ + dSP; + register PMOP *pm = (PMOP*) cLOGOP->op_other; + register CONTEXT *cx = &cxstack[cxstack_ix]; + register SV *dstr = cx->sb_dstr; + register char *s = cx->sb_s; + register char *m = cx->sb_m; + char *orig = cx->sb_orig; + register REGEXP *rx = pm->op_pmregexp; + + if (cx->sb_iters++) { + if (cx->sb_iters > cx->sb_maxiters) + DIE("Substitution loop"); + + sv_catsv(dstr, POPs); + if (rx->subbase) + Safefree(rx->subbase); + rx->subbase = cx->sb_subbase; + + /* Are we done */ + if (cx->sb_once || !regexec(rx, s, cx->sb_strend, orig, + s == m, Nullsv, cx->sb_safebase)) + { + SV *targ = cx->sb_targ; + sv_catpvn(dstr, s, cx->sb_strend - s); + sv_replace(targ, dstr); + (void)SvPOK_only(targ); + SvSETMAGIC(targ); + PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); + POPSUBST(cx); + RETURNOP(pm->op_next); + } + } + if (rx->subbase && rx->subbase != orig) { + m = s; + s = orig; + cx->sb_orig = orig = rx->subbase; + s = orig + (m - s); + cx->sb_strend = s + (cx->sb_strend - m); + } + cx->sb_m = m = rx->startp[0]; + sv_catpvn(dstr, s, m-s); + cx->sb_s = rx->endp[0]; + cx->sb_subbase = rx->subbase; + + rx->subbase = Nullch; /* so recursion works */ + RETURNOP(pm->op_pmreplstart); +} + +PP(pp_formline) +{ + dSP; dMARK; dORIGMARK; + register SV *form = *++MARK; + register U16 *fpc; + register char *t; + register char *f; + register char *s; + register char *send; + register I32 arg; + register SV *sv; + char *item; + I32 itemsize; + I32 fieldsize; + I32 lines = 0; + bool chopspace = (strchr(chopset, ' ') != Nullch); + char *chophere; + char *linemark; + char *formmark; + SV **markmark; + double value; + bool gotsome; + STRLEN len; + + if (!SvCOMPILED(form)) { + SvREADONLY_off(form); + doparseform(form); + } + + SvPV_force(formtarget, len); + t = SvGROW(formtarget, len + SvCUR(form) + 1); /* XXX SvCUR bad */ + t += len; + f = SvPV(form, len); + /* need to jump to the next word */ + s = f + len + WORD_ALIGN - SvCUR(form) % WORD_ALIGN; + + fpc = (U16*)s; + + for (;;) { + DEBUG_f( { + char *name = "???"; + arg = -1; + switch (*fpc) { + case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; + case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; + case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; + case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; + case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; + + case FF_CHECKNL: name = "CHECKNL"; break; + case FF_CHECKCHOP: name = "CHECKCHOP"; break; + case FF_SPACE: name = "SPACE"; break; + case FF_HALFSPACE: name = "HALFSPACE"; break; + case FF_ITEM: name = "ITEM"; break; + case FF_CHOP: name = "CHOP"; break; + case FF_LINEGLOB: name = "LINEGLOB"; break; + case FF_NEWLINE: name = "NEWLINE"; break; + case FF_MORE: name = "MORE"; break; + case FF_LINEMARK: name = "LINEMARK"; break; + case FF_END: name = "END"; break; + } + if (arg >= 0) + fprintf(stderr, "%-16s%ld\n", name, (long) arg); + else + fprintf(stderr, "%-16s\n", name); + } ) + switch (*fpc++) { + case FF_LINEMARK: + linemark = t; + formmark = f; + markmark = MARK; + lines++; + gotsome = FALSE; + break; + + case FF_LITERAL: + arg = *fpc++; + while (arg--) + *t++ = *f++; + break; + + case FF_SKIP: + f += *fpc++; + break; + + case FF_FETCH: + arg = *fpc++; + f += arg; + fieldsize = arg; + + if (MARK < SP) + sv = *++MARK; + else { + sv = &sv_no; + if (dowarn) + warn("Not enough format arguments"); + } + break; + + case FF_CHECKNL: + item = s = SvPV(sv, len); + itemsize = len; + if (itemsize > fieldsize) + itemsize = fieldsize; + send = chophere = s + itemsize; + while (s < send) { + if (*s & ~31) + gotsome = TRUE; + else if (*s == '\n') + break; + s++; + } + itemsize = s - item; + break; + + case FF_CHECKCHOP: + item = s = SvPV(sv, len); + itemsize = len; + if (itemsize <= fieldsize) { + send = chophere = s + itemsize; + while (s < send) { + if (*s == '\r') { + itemsize = s - item; + break; + } + if (*s++ & ~31) + gotsome = TRUE; + } + } + else { + itemsize = fieldsize; + send = chophere = s + itemsize; + while (s < send || (s == send && isSPACE(*s))) { + if (isSPACE(*s)) { + if (chopspace) + chophere = s; + if (*s == '\r') + break; + } + else { + if (*s & ~31) + gotsome = TRUE; + if (strchr(chopset, *s)) + chophere = s + 1; + } + s++; + } + itemsize = chophere - item; + } + break; + + case FF_SPACE: + arg = fieldsize - itemsize; + if (arg) { + fieldsize -= arg; + while (arg-- > 0) + *t++ = ' '; + } + break; + + case FF_HALFSPACE: + arg = fieldsize - itemsize; + if (arg) { + arg /= 2; + fieldsize -= arg; + while (arg-- > 0) + *t++ = ' '; + } + break; + + case FF_ITEM: + arg = itemsize; + s = item; + while (arg--) { +#if 'z' - 'a' != 25 + int ch = *t++ = *s++; + if (!iscntrl(ch)) + t[-1] = ' '; +#else + if ( !((*t++ = *s++) & ~31) ) + t[-1] = ' '; +#endif + + } + break; + + case FF_CHOP: + s = chophere; + if (chopspace) { + while (*s && isSPACE(*s)) + s++; + } + sv_chop(sv,s); + break; + + case FF_LINEGLOB: + item = s = SvPV(sv, len); + itemsize = len; + if (itemsize) { + gotsome = TRUE; + send = s + itemsize; + while (s < send) { + if (*s++ == '\n') { + if (s == send) + itemsize--; + else + lines++; + } + } + SvCUR_set(formtarget, t - SvPVX(formtarget)); + sv_catpvn(formtarget, item, itemsize); + SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1); + t = SvPVX(formtarget) + SvCUR(formtarget); + } + break; + + case FF_DECIMAL: + /* If the field is marked with ^ and the value is undefined, + blank it out. */ + arg = *fpc++; + if ((arg & 512) && !SvOK(sv)) { + arg = fieldsize; + while (arg--) + *t++ = ' '; + break; + } + gotsome = TRUE; + value = SvNV(sv); + if (arg & 256) { + sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value); + } else { + sprintf(t, "%*.0f", (int) fieldsize, value); + } + t += fieldsize; + break; + + case FF_NEWLINE: + f++; + while (t-- > linemark && *t == ' ') ; + t++; + *t++ = '\n'; + break; + + case FF_BLANK: + arg = *fpc++; + if (gotsome) { + if (arg) { /* repeat until fields exhausted? */ + *t = '\0'; + SvCUR_set(formtarget, t - SvPVX(formtarget)); + lines += FmLINES(formtarget); + if (lines == 200) { + arg = t - linemark; + if (strnEQ(linemark, linemark - arg, arg)) + DIE("Runaway format"); + } + FmLINES(formtarget) = lines; + SP = ORIGMARK; + RETURNOP(cLISTOP->op_first); + } + } + else { + t = linemark; + lines--; + } + break; + + case FF_MORE: + if (itemsize) { + arg = fieldsize - itemsize; + if (arg) { + fieldsize -= arg; + while (arg-- > 0) + *t++ = ' '; + } + s = t - 3; + if (strnEQ(s," ",3)) { + while (s > SvPVX(formtarget) && isSPACE(s[-1])) + s--; + } + *s++ = '.'; + *s++ = '.'; + *s++ = '.'; + } + break; + + case FF_END: + *t = '\0'; + SvCUR_set(formtarget, t - SvPVX(formtarget)); + FmLINES(formtarget) += lines; + SP = ORIGMARK; + RETPUSHYES; + } + } +} + +PP(pp_grepstart) +{ + dSP; + SV *src; + + if (stack_base + *markstack_ptr == sp) { + (void)POPMARK; + if (GIMME != G_ARRAY) + XPUSHs(&sv_no); + RETURNOP(op->op_next->op_next); + } + stack_sp = stack_base + *markstack_ptr + 1; + pp_pushmark(); /* push dst */ + pp_pushmark(); /* push src */ + ENTER; /* enter outer scope */ + + SAVETMPS; + SAVESPTR(GvSV(defgv)); + + ENTER; /* enter inner scope */ + SAVESPTR(curpm); + + src = stack_base[*markstack_ptr]; + SvTEMP_off(src); + GvSV(defgv) = src; + + PUTBACK; + if (op->op_type == OP_MAPSTART) + pp_pushmark(); /* push top */ + return ((LOGOP*)op->op_next)->op_other; +} + +PP(pp_mapstart) +{ + DIE("panic: mapstart"); /* uses grepstart */ +} + +PP(pp_mapwhile) +{ + dSP; + I32 diff = (sp - stack_base) - *markstack_ptr; + I32 count; + I32 shift; + SV** src; + SV** dst; + + ++markstack_ptr[-1]; + if (diff) { + if (diff > markstack_ptr[-1] - markstack_ptr[-2]) { + shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]); + count = (sp - stack_base) - markstack_ptr[-1] + 2; + + EXTEND(sp,shift); + src = sp; + dst = (sp += shift); + markstack_ptr[-1] += shift; + *markstack_ptr += shift; + while (--count) + *dst-- = *src--; + } + dst = stack_base + (markstack_ptr[-2] += diff) - 1; + ++diff; + while (--diff) + *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); + } + LEAVE; /* exit inner scope */ + + /* All done yet? */ + if (markstack_ptr[-1] > *markstack_ptr) { + I32 items; + + (void)POPMARK; /* pop top */ + LEAVE; /* exit outer scope */ + (void)POPMARK; /* pop src */ + items = --*markstack_ptr - markstack_ptr[-1]; + (void)POPMARK; /* pop dst */ + SP = stack_base + POPMARK; /* pop original mark */ + if (GIMME != G_ARRAY) { + dTARGET; + XPUSHi(items); + RETURN; + } + SP += items; + RETURN; + } + else { + SV *src; + + ENTER; /* enter inner scope */ + SAVESPTR(curpm); + + src = stack_base[markstack_ptr[-1]]; + SvTEMP_off(src); + GvSV(defgv) = src; + + RETURNOP(cLOGOP->op_other); + } +} + + +PP(pp_sort) +{ + dSP; dMARK; dORIGMARK; + register SV **up; + SV **myorigmark = ORIGMARK; + register I32 max; + HV *stash; + GV *gv; + CV *cv; + I32 gimme = GIMME; + OP* nextop = op->op_next; + + if (gimme != G_ARRAY) { + SP = MARK; + RETPUSHUNDEF; + } + + if (op->op_flags & OPf_STACKED) { + ENTER; + if (op->op_flags & OPf_SPECIAL) { + OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ + kid = kUNOP->op_first; /* pass rv2gv */ + kid = kUNOP->op_first; /* pass leave */ + sortcop = kid->op_next; + stash = curcop->cop_stash; + } + else { + cv = sv_2cv(*++MARK, &stash, &gv, 0); + if (!(cv && CvROOT(cv))) { + if (gv) { + SV *tmpstr = sv_newmortal(); + gv_efullname(tmpstr, gv); + if (cv && CvXSUB(cv)) + DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr)); + DIE("Undefined sort subroutine \"%s\" called", + SvPVX(tmpstr)); + } + if (cv) { + if (CvXSUB(cv)) + DIE("Xsub called in sort"); + DIE("Undefined subroutine in sort"); + } + DIE("Not a CODE reference in sort"); + } + sortcop = CvSTART(cv); + SAVESPTR(CvROOT(cv)->op_ppaddr); + CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL]; + + SAVESPTR(curpad); + curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); + } + } + else { + sortcop = Nullop; + stash = curcop->cop_stash; + } + + up = myorigmark + 1; + while (MARK < SP) { /* This may or may not shift down one here. */ + /*SUPPRESS 560*/ + if (*up = *++MARK) { /* Weed out nulls. */ + if (!SvPOK(*up)) + (void)sv_2pv(*up, &na); + else + SvTEMP_off(*up); + up++; + } + } + max = --up - myorigmark; + if (sortcop) { + if (max > 1) { + AV *oldstack; + CONTEXT *cx; + SV** newsp; + + 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); + sortstash = stash; + } + + SAVESPTR(GvSV(firstgv)); + SAVESPTR(GvSV(secondgv)); + PUSHBLOCK(cx, CXt_LOOP, stack_base); + sortcxix = cxstack_ix; + + qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv); + + POPBLOCK(cx,curpm); + SWITCHSTACK(sortstack, oldstack); + } + LEAVE; + } + else { + if (max > 1) { + MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ + qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp); + } + } + stack_sp = ORIGMARK + max; + return nextop; +} + +/* Range stuff. */ + +PP(pp_range) +{ + if (GIMME == G_ARRAY) + return cCONDOP->op_true; + return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true; +} + +PP(pp_flip) +{ + dSP; + + if (GIMME == G_ARRAY) { + RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); + } + else { + dTOPss; + SV *targ = PAD_SV(op->op_targ); + + if ((op->op_private & OPpFLIP_LINENUM) + ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv)) + : SvTRUE(sv) ) { + sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); + if (op->op_flags & OPf_SPECIAL) { + sv_setiv(targ, 1); + RETURN; + } + else { + sv_setiv(targ, 0); + sp--; + RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); + } + } + sv_setpv(TARG, ""); + SETs(targ); + RETURN; + } +} + +PP(pp_flop) +{ + dSP; + + if (GIMME == G_ARRAY) { + dPOPPOPssrl; + register I32 i; + register SV *sv; + I32 max; + + if (SvNIOK(left) || !SvPOK(left) || + (looks_like_number(left) && *SvPVX(left) != '0') ) { + i = SvIV(left); + max = SvIV(right); + if (max > i) + EXTEND(SP, max - i + 1); + while (i <= max) { + sv = sv_mortalcopy(&sv_no); + sv_setiv(sv,i++); + PUSHs(sv); + } + } + else { + SV *final = sv_mortalcopy(right); + STRLEN len; + char *tmps = SvPV(final, len); + + sv = sv_mortalcopy(left); + while (!SvNIOK(sv) && SvCUR(sv) <= len && + strNE(SvPVX(sv),tmps) ) { + XPUSHs(sv); + sv = sv_2mortal(newSVsv(sv)); + sv_inc(sv); + } + if (strEQ(SvPVX(sv),tmps)) + XPUSHs(sv); + } + } + else { + dTOPss; + SV *targ = PAD_SV(cUNOP->op_first->op_targ); + sv_inc(targ); + if ((op->op_private & OPpFLIP_LINENUM) + ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv)) + : SvTRUE(sv) ) { + sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); + sv_catpv(targ, "E0"); + } + SETs(targ); + } + + RETURN; +} + +/* Control. */ + +static I32 +dopoptolabel(label) +char *label; +{ + register I32 i; + register CONTEXT *cx; + + for (i = cxstack_ix; i >= 0; i--) { + cx = &cxstack[i]; + switch (cx->cx_type) { + case CXt_SUBST: + if (dowarn) + warn("Exiting substitution via %s", op_name[op->op_type]); + break; + case CXt_SUB: + if (dowarn) + warn("Exiting subroutine via %s", op_name[op->op_type]); + break; + case CXt_EVAL: + if (dowarn) + warn("Exiting eval via %s", op_name[op->op_type]); + break; + case CXt_LOOP: + if (!cx->blk_loop.label || + strNE(label, cx->blk_loop.label) ) { + DEBUG_l(deb("(Skipping label #%d %s)\n", + i, cx->blk_loop.label)); + continue; + } + DEBUG_l( deb("(Found label #%d %s)\n", i, label)); + return i; + } + } + return i; +} + +static I32 +dopoptosub(startingblock) +I32 startingblock; +{ + I32 i; + register CONTEXT *cx; + for (i = startingblock; i >= 0; i--) { + cx = &cxstack[i]; + switch (cx->cx_type) { + default: + continue; + case CXt_EVAL: + case CXt_SUB: + DEBUG_l( deb("(Found sub #%d)\n", i)); + return i; + } + } + return i; +} + +static I32 +dopoptoeval(startingblock) +I32 startingblock; +{ + I32 i; + register CONTEXT *cx; + for (i = startingblock; i >= 0; i--) { + cx = &cxstack[i]; + switch (cx->cx_type) { + default: + continue; + case CXt_EVAL: + DEBUG_l( deb("(Found eval #%d)\n", i)); + return i; + } + } + return i; +} + +static I32 +dopoptoloop(startingblock) +I32 startingblock; +{ + I32 i; + register CONTEXT *cx; + for (i = startingblock; i >= 0; i--) { + cx = &cxstack[i]; + switch (cx->cx_type) { + case CXt_SUBST: + if (dowarn) + warn("Exiting substitition via %s", op_name[op->op_type]); + break; + case CXt_SUB: + if (dowarn) + warn("Exiting subroutine via %s", op_name[op->op_type]); + break; + case CXt_EVAL: + if (dowarn) + warn("Exiting eval via %s", op_name[op->op_type]); + break; + case CXt_LOOP: + DEBUG_l( deb("(Found loop #%d)\n", i)); + return i; + } + } + return i; +} + +void +dounwind(cxix) +I32 cxix; +{ + register CONTEXT *cx; + SV **newsp; + I32 optype; + + while (cxstack_ix > cxix) { + cx = &cxstack[cxstack_ix--]; + DEBUG_l(fprintf(stderr, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1, + block_type[cx->cx_type])); + /* Note: we don't need to restore the base context info till the end. */ + switch (cx->cx_type) { + case CXt_SUB: + POPSUB(cx); + break; + case CXt_EVAL: + POPEVAL(cx); + break; + case CXt_LOOP: + POPLOOP(cx); + break; + case CXt_SUBST: + break; + } + } +} + +#ifdef STANDARD_C +OP * +die(char* pat, ...) +#else +/*VARARGS0*/ +OP * +die(pat, va_alist) + char *pat; + va_dcl +#endif +{ + va_list args; + char *message; + int oldrunlevel = runlevel; + int was_in_eval = in_eval; + +#ifdef I_STDARG + va_start(args, pat); +#else + va_start(args); +#endif + message = mess(pat, &args); + va_end(args); + restartop = die_where(message); + if ((!restartop && was_in_eval) || oldrunlevel > 1) + longjmp(top_env, 3); + return restartop; +} + +OP * +die_where(message) +char *message; +{ + if (in_eval) { + I32 cxix; + register CONTEXT *cx; + I32 gimme; + SV **newsp; + + sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),message); + cxix = dopoptoeval(cxstack_ix); + if (cxix >= 0) { + I32 optype; + + if (cxix < cxstack_ix) + dounwind(cxix); + + POPBLOCK(cx,curpm); + if (cx->cx_type != CXt_EVAL) { + fprintf(stderr, "panic: die %s", message); + my_exit(1); + } + POPEVAL(cx); + + if (gimme == G_SCALAR) + *++newsp = &sv_undef; + stack_sp = newsp; + + LEAVE; + if (optype == OP_REQUIRE) + DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); + return pop_return(); + } + } + fputs(message, stderr); + (void)fflush(stderr); + if (e_fp) + (void)UNLINK(e_tmpname); + statusvalue >>= 8; + my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); + return 0; +} + +PP(pp_xor) +{ + dSP; dPOPTOPssrl; + if (SvTRUE(left) != SvTRUE(right)) + RETSETYES; + else + RETSETNO; +} + +PP(pp_andassign) +{ + dSP; + if (!SvTRUE(TOPs)) + RETURN; + else + RETURNOP(cLOGOP->op_other); +} + +PP(pp_orassign) +{ + dSP; + if (SvTRUE(TOPs)) + RETURN; + else + RETURNOP(cLOGOP->op_other); +} + +#ifdef DEPRECATED +PP(pp_entersubr) +{ + dSP; + SV** mark = (stack_base + *markstack_ptr + 1); + SV* cv = *mark; + while (mark < sp) { /* emulate old interface */ + *mark = mark[1]; + mark++; + } + *sp = cv; + return pp_entersub(); +} +#endif + +PP(pp_caller) +{ + dSP; + register I32 cxix = dopoptosub(cxstack_ix); + register CONTEXT *cx; + I32 dbcxix; + SV *sv; + I32 count = 0; + + if (MAXARG) + count = POPi; + EXTEND(SP, 6); + for (;;) { + if (cxix < 0) { + if (GIMME != G_ARRAY) + RETPUSHUNDEF; + RETURN; + } + if (DBsub && cxix >= 0 && + cxstack[cxix].blk_sub.cv == GvCV(DBsub)) + count++; + if (!count--) + break; + cxix = dopoptosub(cxix - 1); + } + cx = &cxstack[cxix]; + if (GIMME != G_ARRAY) { + dTARGET; + + sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash)); + PUSHs(TARG); + RETURN; + } + dbcxix = dopoptosub(cxix - 1); + if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub)) + cx = &cxstack[dbcxix]; + + PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0))); + PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0))); + PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); + if (!MAXARG) + RETURN; + if (cx->cx_type == CXt_SUB) { + sv = NEWSV(49, 0); + gv_efullname(sv, CvGV(cxstack[cxix].blk_sub.cv)); + PUSHs(sv_2mortal(sv)); + PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + } + else { + PUSHs(sv_2mortal(newSVpv("(eval)",0))); + PUSHs(sv_2mortal(newSViv(0))); + } + PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme))); + if (cx->blk_sub.hasargs && curcop->cop_stash == debstash) { + AV *ary = cx->blk_sub.argarray; + int off = AvARRAY(ary) - AvALLOC(ary); + + if (!dbargs) { + GV* tmpgv; + dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, + SVt_PVAV))); + SvMULTI_on(tmpgv); + AvREAL_off(dbargs); /* XXX Should be REIFY */ + } + + if (AvMAX(dbargs) < AvFILL(ary) + off) + av_extend(dbargs, AvFILL(ary) + off); + Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILL(ary) + 1 + off, SV*); + AvFILL(dbargs) = AvFILL(ary) + off; + } + RETURN; +} + +static int +sortcv(a, b) +const void *a; +const void *b; +{ + SV **str1 = (SV **) a; + SV **str2 = (SV **) b; + I32 oldscopeix = scopestack_ix; + I32 result; + GvSV(firstgv) = *str1; + GvSV(secondgv) = *str2; + stack_sp = stack_base; + op = sortcop; + run(); + if (stack_sp != stack_base + 1) + croak("Sort subroutine didn't return single value"); + if (!SvNIOK(*stack_sp)) + croak("Sort subroutine didn't return a numeric value"); + result = SvIV(*stack_sp); + while (scopestack_ix > oldscopeix) { + LEAVE; + } + return result; +} + +static int +sortcmp(a, b) +const void *a; +const void *b; +{ + register SV *str1 = *(SV **) a; + register SV *str2 = *(SV **) b; + I32 retval; + + if (SvCUR(str1) < SvCUR(str2)) { + /*SUPPRESS 560*/ + if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1))) + return retval; + else + return -1; + } + /*SUPPRESS 560*/ + else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2))) + return retval; + else if (SvCUR(str1) == SvCUR(str2)) + return 0; + else + return 1; +} + +PP(pp_reset) +{ + dSP; + char *tmps; + + if (MAXARG < 1) + tmps = ""; + else + tmps = POPp; + sv_reset(tmps, curcop->cop_stash); + PUSHs(&sv_yes); + RETURN; +} + +PP(pp_lineseq) +{ + return NORMAL; +} + +PP(pp_dbstate) +{ + curcop = (COP*)op; + TAINT_NOT; /* Each statement is presumed innocent */ + stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + FREETMPS; + + if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace)) + { + SV **sp; + register CV *cv; + register CONTEXT *cx; + I32 gimme = GIMME; + I32 hasargs; + GV *gv; + + ENTER; + SAVETMPS; + + SAVEI32(debug); + debug = 0; + hasargs = 0; + gv = DBgv; + cv = GvCV(gv); + sp = stack_sp; + *++sp = Nullsv; + + if (!cv) + DIE("No DB::DB routine defined"); + + if (CvDEPTH(cv) >= 1) /* don't do recursive DB::DB call */ + return NORMAL; + push_return(op->op_next); + PUSHBLOCK(cx, CXt_SUB, sp - 1); + PUSHSUB(cx); + CvDEPTH(cv)++; + (void)SvREFCNT_inc(cv); + SAVESPTR(curpad); + curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE)); + RETURNOP(CvSTART(cv)); + } + else + return NORMAL; +} + +PP(pp_scope) +{ + return NORMAL; +} + +PP(pp_enteriter) +{ + dSP; dMARK; + register CONTEXT *cx; + I32 gimme = GIMME; + SV **svp; + + if (op->op_targ) + svp = &curpad[op->op_targ]; /* "my" variable */ + else + svp = &GvSV((GV*)POPs); /* symbol table variable */ + + ENTER; + SAVETMPS; + ENTER; + + PUSHBLOCK(cx, CXt_LOOP, SP); + PUSHLOOP(cx, svp, MARK); + cx->blk_loop.iterary = stack; + cx->blk_loop.iterix = MARK - stack_base; + + RETURN; +} + +PP(pp_enterloop) +{ + dSP; + register CONTEXT *cx; + I32 gimme = GIMME; + + ENTER; + SAVETMPS; + ENTER; + + PUSHBLOCK(cx, CXt_LOOP, SP); + PUSHLOOP(cx, 0, SP); + + RETURN; +} + +PP(pp_leaveloop) +{ + dSP; + register CONTEXT *cx; + I32 gimme; + SV **newsp; + PMOP *newpm; + SV **mark; + + POPBLOCK(cx,newpm); + mark = newsp; + POPLOOP(cx); + if (gimme == G_SCALAR) { + if (op->op_private & OPpLEAVE_VOID) + ; + else { + if (mark < SP) + *++newsp = sv_mortalcopy(*SP); + else + *++newsp = &sv_undef; + } + } + else { + while (mark < SP) + *++newsp = sv_mortalcopy(*++mark); + } + curpm = newpm; /* Don't pop $1 et al till now */ + sp = newsp; + LEAVE; + LEAVE; + + RETURN; +} + +PP(pp_return) +{ + dSP; dMARK; + I32 cxix; + register CONTEXT *cx; + I32 gimme; + SV **newsp; + PMOP *newpm; + I32 optype = 0; + + if (stack == sortstack) { + if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) { + AvARRAY(stack)[1] = *SP; + stack_sp = stack_base + 1; + return 0; + } + } + + cxix = dopoptosub(cxstack_ix); + if (cxix < 0) + DIE("Can't return outside a subroutine"); + if (cxix < cxstack_ix) + dounwind(cxix); + + POPBLOCK(cx,newpm); + switch (cx->cx_type) { + case CXt_SUB: + POPSUB(cx); + break; + case CXt_EVAL: + POPEVAL(cx); + break; + default: + DIE("panic: return"); + break; + } + + if (gimme == G_SCALAR) { + if (MARK < SP) + *++newsp = sv_mortalcopy(*SP); + else + *++newsp = &sv_undef; + if (optype == OP_REQUIRE && !SvTRUE(*newsp)) + DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); + } + else { + if (optype == OP_REQUIRE && MARK == SP) + DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); + while (MARK < SP) + *++newsp = sv_mortalcopy(*++MARK); + } + curpm = newpm; /* Don't pop $1 et al till now */ + stack_sp = newsp; + + LEAVE; + return pop_return(); +} + +PP(pp_last) +{ + dSP; + I32 cxix; + register CONTEXT *cx; + I32 gimme; + I32 optype; + OP *nextop; + SV **newsp; + PMOP *newpm; + SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp; + /* XXX The sp is probably not right yet... */ + + if (op->op_flags & OPf_SPECIAL) { + cxix = dopoptoloop(cxstack_ix); + if (cxix < 0) + DIE("Can't \"last\" outside a block"); + } + else { + cxix = dopoptolabel(cPVOP->op_pv); + if (cxix < 0) + DIE("Label not found for \"last %s\"", cPVOP->op_pv); + } + if (cxix < cxstack_ix) + dounwind(cxix); + + POPBLOCK(cx,newpm); + switch (cx->cx_type) { + case CXt_LOOP: + POPLOOP(cx); + nextop = cx->blk_loop.last_op->op_next; + LEAVE; + break; + case CXt_EVAL: + POPEVAL(cx); + nextop = pop_return(); + break; + case CXt_SUB: + POPSUB(cx); + nextop = pop_return(); + break; + default: + DIE("panic: last"); + break; + } + + if (gimme == G_SCALAR) { + if (mark < SP) + *++newsp = sv_mortalcopy(*SP); + else + *++newsp = &sv_undef; + } + else { + while (mark < SP) + *++newsp = sv_mortalcopy(*++mark); + } + curpm = newpm; /* Don't pop $1 et al till now */ + sp = newsp; + + LEAVE; + RETURNOP(nextop); +} + +PP(pp_next) +{ + I32 cxix; + register CONTEXT *cx; + I32 oldsave; + + if (op->op_flags & OPf_SPECIAL) { + cxix = dopoptoloop(cxstack_ix); + if (cxix < 0) + DIE("Can't \"next\" outside a block"); + } + else { + cxix = dopoptolabel(cPVOP->op_pv); + if (cxix < 0) + DIE("Label not found for \"next %s\"", cPVOP->op_pv); + } + if (cxix < cxstack_ix) + dounwind(cxix); + + TOPBLOCK(cx); + oldsave = scopestack[scopestack_ix - 1]; + LEAVE_SCOPE(oldsave); + return cx->blk_loop.next_op; +} + +PP(pp_redo) +{ + I32 cxix; + register CONTEXT *cx; + I32 oldsave; + + if (op->op_flags & OPf_SPECIAL) { + cxix = dopoptoloop(cxstack_ix); + if (cxix < 0) + DIE("Can't \"redo\" outside a block"); + } + else { + cxix = dopoptolabel(cPVOP->op_pv); + if (cxix < 0) + DIE("Label not found for \"redo %s\"", cPVOP->op_pv); + } + if (cxix < cxstack_ix) + dounwind(cxix); + + TOPBLOCK(cx); + oldsave = scopestack[scopestack_ix - 1]; + LEAVE_SCOPE(oldsave); + return cx->blk_loop.redo_op; +} + +static OP* lastgotoprobe; + +static OP * +dofindlabel(op,label,opstack) +OP *op; +char *label; +OP **opstack; +{ + OP *kid; + OP **ops = opstack; + + if (op->op_type == OP_LEAVE || + op->op_type == OP_SCOPE || + op->op_type == OP_LEAVELOOP || + op->op_type == OP_LEAVETRY) + *ops++ = cUNOP->op_first; + *ops = 0; + if (op->op_flags & OPf_KIDS) { + /* First try all the kids at this level, since that's likeliest. */ + for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { + if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && + kCOP->cop_label && strEQ(kCOP->cop_label, label)) + return kid; + } + for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { + if (kid == lastgotoprobe) + continue; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + if (ops > opstack && + (ops[-1]->op_type == OP_NEXTSTATE || + ops[-1]->op_type == OP_DBSTATE)) + *ops = kid; + else + *ops++ = kid; + } + if (op = dofindlabel(kid,label,ops)) + return op; + } + } + *ops = 0; + return 0; +} + +PP(pp_dump) +{ + return pp_goto(ARGS); + /*NOTREACHED*/ +} + +PP(pp_goto) +{ + dSP; + OP *retop = 0; + I32 ix; + register CONTEXT *cx; + OP *enterops[64]; + char *label; + int do_dump = (op->op_type == OP_DUMP); + + label = 0; + if (op->op_flags & OPf_STACKED) { + SV *sv = POPs; + + /* This egregious kludge implements goto &subroutine */ + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { + I32 cxix; + register CONTEXT *cx; + CV* cv = (CV*)SvRV(sv); + SV** mark; + I32 items = 0; + I32 oldsave; + + /* First do some returnish stuff. */ + cxix = dopoptosub(cxstack_ix); + if (cxix < 0) + DIE("Can't goto subroutine outside a subroutine"); + if (cxix < cxstack_ix) + dounwind(cxix); + TOPBLOCK(cx); + mark = stack_sp; + if (cx->blk_sub.hasargs) { /* put @_ back onto stack */ + 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; + av_clear(av); + AvREAL_off(av); + } + if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) + SvREFCNT_dec(cx->blk_sub.cv); + oldsave = scopestack[scopestack_ix - 1]; + LEAVE_SCOPE(oldsave); + + /* Now do some callish stuff. */ + SAVETMPS; + if (CvXSUB(cv)) { + if (CvOLDSTYLE(cv)) { + while (sp > mark) { + sp[1] = sp[0]; + sp--; + } + items = (*(I32(*)_((int,int,int)))CvXSUB(cv))( + CvXSUBANY(cv).any_i32, + mark - stack_base + 1, + items); + sp = stack_base + items; + } + else { + (void)(*CvXSUB(cv))(cv); + } + LEAVE; + return pop_return(); + } + else { + AV* padlist = CvPADLIST(cv); + SV** svp = AvARRAY(padlist); + cx->blk_sub.cv = cv; + cx->blk_sub.olddepth = CvDEPTH(cv); + CvDEPTH(cv)++; + if (CvDEPTH(cv) < 2) + (void)SvREFCNT_inc(cv); + else { /* save temporaries on recursion? */ + if (CvDEPTH(cv) == 100 && dowarn) + warn("Deep recursion on subroutine \"%s\"", + GvENAME(CvGV(cv))); + if (CvDEPTH(cv) > AvFILL(padlist)) { + AV *newpad = newAV(); + I32 ix = AvFILL((AV*)svp[1]); + svp = AvARRAY(svp[0]); + while (ix > 0) { + if (svp[ix] != &sv_undef) { + char *name = SvPVX(svp[ix]); /* XXX */ + if (*name == '@') + av_store(newpad, ix--, sv = (SV*)newAV()); + else if (*name == '%') + av_store(newpad, ix--, sv = (SV*)newHV()); + else + av_store(newpad, ix--, sv = NEWSV(0,0)); + SvPADMY_on(sv); + } + else { + av_store(newpad, ix--, sv = NEWSV(0,0)); + SvPADTMP_on(sv); + } + } + if (cx->blk_sub.hasargs) { + AV* av = newAV(); + av_extend(av, 0); + av_store(newpad, 0, (SV*)av); + AvFLAGS(av) = AVf_REIFY; + } + av_store(padlist, CvDEPTH(cv), (SV*)newpad); + AvFILL(padlist) = CvDEPTH(cv); + svp = AvARRAY(padlist); + } + } + SAVESPTR(curpad); + curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); + if (cx->blk_sub.hasargs) { + AV* av = (AV*)curpad[0]; + SV** ary; + + cx->blk_sub.savearray = GvAV(defgv); + cx->blk_sub.argarray = av; + GvAV(defgv) = cx->blk_sub.argarray; + ++mark; + + if (items >= AvMAX(av) + 1) { + ary = AvALLOC(av); + if (AvARRAY(av) != ary) { + AvMAX(av) += AvARRAY(av) - AvALLOC(av); + SvPVX(av) = (char*)ary; + } + if (items >= AvMAX(av) + 1) { + AvMAX(av) = items - 1; + Renew(ary,items+1,SV*); + AvALLOC(av) = ary; + SvPVX(av) = (char*)ary; + } + } + Copy(mark,AvARRAY(av),items,SV*); + AvFILL(av) = items - 1; + + while (items--) { + if (*mark) + SvTEMP_off(*mark); + mark++; + } + } + RETURNOP(CvSTART(cv)); + } + } + else + label = SvPV(sv,na); + } + else if (op->op_flags & OPf_SPECIAL) { + if (! do_dump) + DIE("goto must have label"); + } + else + label = cPVOP->op_pv; + + if (label && *label) { + OP *gotoprobe = 0; + + /* find label */ + + lastgotoprobe = 0; + *enterops = 0; + for (ix = cxstack_ix; ix >= 0; ix--) { + cx = &cxstack[ix]; + switch (cx->cx_type) { + case CXt_SUB: + gotoprobe = CvROOT(cx->blk_sub.cv); + break; + case CXt_EVAL: + gotoprobe = eval_root; /* XXX not good for nested eval */ + break; + case CXt_LOOP: + gotoprobe = cx->blk_oldcop->op_sibling; + break; + case CXt_SUBST: + continue; + case CXt_BLOCK: + if (ix) + gotoprobe = cx->blk_oldcop->op_sibling; + else + gotoprobe = main_root; + break; + default: + if (ix) + DIE("panic: goto"); + else + gotoprobe = main_root; + break; + } + retop = dofindlabel(gotoprobe, label, enterops); + if (retop) + break; + lastgotoprobe = gotoprobe; + } + if (!retop) + DIE("Can't find label %s", label); + + /* pop unwanted frames */ + + if (ix < cxstack_ix) { + I32 oldsave; + + if (ix < 0) + ix = 0; + dounwind(ix); + TOPBLOCK(cx); + oldsave = scopestack[scopestack_ix]; + LEAVE_SCOPE(oldsave); + } + + /* push wanted frames */ + + if (*enterops) { + OP *oldop = op; + for (ix = 0 + (gotoprobe == main_root); enterops[ix]; ix++) { + op = enterops[ix]; + (*op->op_ppaddr)(); + } + op = oldop; + } + } + + if (do_dump) { + restartop = retop; + do_undump = TRUE; + + my_unexec(); + + restartop = 0; /* hmm, must be GNU unexec().. */ + do_undump = FALSE; + } + + RETURNOP(retop); +} + +PP(pp_exit) +{ + dSP; + I32 anum; + + if (MAXARG < 1) + anum = 0; + else + anum = SvIVx(POPs); + my_exit(anum); + PUSHs(&sv_undef); + RETURN; +} + +#ifdef NOTYET +PP(pp_nswitch) +{ + dSP; + double value = SvNVx(GvSV(cCOP->cop_gv)); + register I32 match = I_32(value); + + if (value < 0.0) { + if (((double)match) > value) + --match; /* was fractional--truncate other way */ + } + match -= cCOP->uop.scop.scop_offset; + if (match < 0) + match = 0; + else if (match > cCOP->uop.scop.scop_max) + match = cCOP->uop.scop.scop_max; + op = cCOP->uop.scop.scop_next[match]; + RETURNOP(op); +} + +PP(pp_cswitch) +{ + dSP; + register I32 match; + + if (multiline) + op = op->op_next; /* can't assume anything */ + else { + match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255; + match -= cCOP->uop.scop.scop_offset; + if (match < 0) + match = 0; + else if (match > cCOP->uop.scop.scop_max) + match = cCOP->uop.scop.scop_max; + op = cCOP->uop.scop.scop_next[match]; + } + RETURNOP(op); +} +#endif + +/* Eval. */ + +static void +save_lines(array, sv) +AV *array; +SV *sv; +{ + register char *s = SvPVX(sv); + register char *send = SvPVX(sv) + SvCUR(sv); + register char *t; + register I32 line = 1; + + while (s && s < send) { + SV *tmpstr = NEWSV(85,0); + + sv_upgrade(tmpstr, SVt_PVMG); + t = strchr(s, '\n'); + if (t) + t++; + else + t = send; + + sv_setpvn(tmpstr, s, t - s); + av_store(array, line++, tmpstr); + s = t; + } +} + +static OP * +doeval(gimme) +int gimme; +{ + dSP; + OP *saveop = op; + HV *newstash; + + in_eval = 1; + + /* set up a scratch pad */ + + SAVEINT(padix); + SAVESPTR(curpad); + SAVESPTR(comppad); + SAVESPTR(comppad_name); + SAVEINT(comppad_name_fill); + SAVEINT(min_intro_pending); + SAVEINT(max_intro_pending); + comppad = newAV(); + comppad_name = newAV(); + comppad_name_fill = 0; + min_intro_pending = 0; + av_push(comppad, Nullsv); + curpad = AvARRAY(comppad); + padix = 0; + + /* make sure we compile in the right package */ + + newstash = curcop->cop_stash; + if (curstash != newstash) { + SAVESPTR(curstash); + curstash = newstash; + } + SAVESPTR(beginav); + beginav = newAV(); + SAVEFREESV(beginav); + + /* try to compile it */ + + eval_root = Nullop; + error_count = 0; + curcop = &compiling; + curcop->cop_arybase = 0; + rs = "\n"; + rslen = 1; + rschar = '\n'; + rspara = 0; + sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + if (yyparse() || error_count || !eval_root) { + SV **newsp; + I32 gimme; + CONTEXT *cx; + I32 optype; + + op = saveop; + if (eval_root) { + op_free(eval_root); + eval_root = Nullop; + } + POPBLOCK(cx,curpm); + POPEVAL(cx); + pop_return(); + lex_end(); + LEAVE; + if (optype == OP_REQUIRE) + DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); + rs = nrs; + rslen = nrslen; + rschar = nrschar; + rspara = (nrslen == 2); + RETPUSHUNDEF; + } + rs = nrs; + rslen = nrslen; + rschar = nrschar; + rspara = (nrslen == 2); + compiling.cop_line = 0; + SAVEFREESV(comppad); + SAVEFREESV(comppad_name); + SAVEFREEOP(eval_root); + if (gimme & G_ARRAY) + list(eval_root); + else + scalar(eval_root); + + DEBUG_x(dump_eval()); + + /* compiled okay, so do it */ + + RETURNOP(eval_start); +} + +PP(pp_require) +{ + dSP; + register CONTEXT *cx; + SV *sv; + char *name; + char *tmpname; + SV** svp; + I32 gimme = G_SCALAR; + FILE *tryrsfp = 0; + + sv = POPs; + if (SvNIOK(sv) && !SvPOKp(sv)) { + if (atof(patchlevel) + 0.000999 < SvNV(sv)) + DIE("Perl %3.3f required--this is only version %s, stopped", + SvNV(sv),patchlevel); + RETPUSHYES; + } + name = SvPV(sv, na); + if (!*name) + DIE("Null filename used"); + if (op->op_type == OP_REQUIRE && + (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) && + *svp != &sv_undef) + RETPUSHYES; + + /* prepare to compile file */ + + tmpname = savepv(name); + if (*tmpname == '/' || + (*tmpname == '.' && + (tmpname[1] == '/' || + (tmpname[1] == '.' && tmpname[2] == '/')))) + { + tryrsfp = fopen(tmpname,"r"); + } + else { + AV *ar = GvAVn(incgv); + I32 i; + + for (i = 0; i <= AvFILL(ar); i++) { + (void)sprintf(buf, "%s/%s", + SvPVx(*av_fetch(ar, i, TRUE), na), name); + tryrsfp = fopen(buf, "r"); + if (tryrsfp) { + char *s = buf; + + if (*s == '.' && s[1] == '/') + s += 2; + Safefree(tmpname); + tmpname = savepv(s); + break; + } + } + } + SAVESPTR(compiling.cop_filegv); + compiling.cop_filegv = gv_fetchfile(tmpname); + Safefree(tmpname); + tmpname = Nullch; + if (!tryrsfp) { + if (op->op_type == OP_REQUIRE) { + sprintf(tokenbuf,"Can't locate %s in @INC", name); + if (instr(tokenbuf,".h ")) + strcat(tokenbuf," (change .h to .ph maybe?)"); + if (instr(tokenbuf,".ph ")) + strcat(tokenbuf," (did you run h2ph?)"); + DIE("%s",tokenbuf); + } + + RETPUSHUNDEF; + } + + /* Assume success here to prevent recursive requirement. */ + (void)hv_store(GvHVn(incgv), name, strlen(name), + newSVsv(GvSV(compiling.cop_filegv)), 0 ); + + ENTER; + SAVETMPS; + lex_start(sv_2mortal(newSVpv("",0))); + rsfp = tryrsfp; + name = savepv(name); + SAVEFREEPV(name); + SAVEI32(hints); + hints = 0; + + /* switch to eval mode */ + + push_return(op->op_next); + PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHEVAL(cx, name, compiling.cop_filegv); + + compiling.cop_line = 0; + + PUTBACK; + return doeval(G_SCALAR); +} + +PP(pp_dofile) +{ + return pp_require(ARGS); +} + +PP(pp_entereval) +{ + dSP; + register CONTEXT *cx; + dPOPss; + I32 gimme = GIMME; + char tmpbuf[32]; + STRLEN len; + + if (!SvPV(sv,len) || !len) + RETPUSHUNDEF; + + ENTER; + SAVETMPS; + lex_start(sv); + + /* switch to eval mode */ + + sprintf(tmpbuf, "_<(eval %d)", ++evalseq); + compiling.cop_filegv = gv_fetchfile(tmpbuf+2); + compiling.cop_line = 1; + SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf)); + SAVEI32(hints); + hints = op->op_targ; + + push_return(op->op_next); + PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHEVAL(cx, 0, compiling.cop_filegv); + + /* prepare to compile string */ + + if (perldb && curstash != debstash) + save_lines(GvAV(compiling.cop_filegv), linestr); + PUTBACK; + return doeval(gimme); +} + +PP(pp_leaveeval) +{ + dSP; + register SV **mark; + SV **newsp; + PMOP *newpm; + I32 gimme; + register CONTEXT *cx; + OP *retop; + I32 optype; + + POPBLOCK(cx,newpm); + POPEVAL(cx); + retop = pop_return(); + + if (gimme == G_SCALAR) { + if (op->op_private & OPpLEAVE_VOID) + MARK = newsp; + else { + MARK = newsp + 1; + if (MARK <= SP) { + if (SvFLAGS(TOPs) & SVs_TEMP) + *MARK = TOPs; + else + *MARK = sv_mortalcopy(TOPs); + } + else { + MEXTEND(mark,0); + *MARK = &sv_undef; + } + } + SP = MARK; + } + else { + for (mark = newsp + 1; mark <= SP; mark++) + if (!(SvFLAGS(TOPs) & SVs_TEMP)) + *mark = sv_mortalcopy(*mark); + /* in case LEAVE wipes old return values */ + } + 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)); + + if (optype == OP_REQUIRE) + retop = die("%s did not return a true value", name); + } + } + + lex_end(); + LEAVE; + sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + + RETURNOP(retop); +} + +#ifdef NOTYET +PP(pp_evalonce) +{ + dSP; + SP = do_eval(st[1], OP_EVAL, curcop->cop_stash, TRUE, + GIMME, arglast); + if (eval_root) { + SvREFCNT_dec(cSVOP->op_sv); + op[1].arg_ptr.arg_cmd = eval_root; + op[1].op_type = (A_CMD|A_DONT); + op[0].op_type = OP_TRY; + } + RETURN; +} +#endif + +PP(pp_entertry) +{ + dSP; + register CONTEXT *cx; + I32 gimme = GIMME; + + ENTER; + SAVETMPS; + + push_return(cLOGOP->op_other->op_next); + PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHEVAL(cx, 0, 0); + eval_root = op; /* Only needed so that goto works right. */ + + in_eval = 1; + sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + RETURN; +} + +PP(pp_leavetry) +{ + dSP; + register SV **mark; + SV **newsp; + PMOP *newpm; + I32 gimme; + register CONTEXT *cx; + I32 optype; + + POPBLOCK(cx,newpm); + POPEVAL(cx); + pop_return(); + + if (gimme == G_SCALAR) { + if (op->op_private & OPpLEAVE_VOID) + MARK = newsp; + else { + MARK = newsp + 1; + if (MARK <= SP) { + if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) + *MARK = TOPs; + else + *MARK = sv_mortalcopy(TOPs); + } + else { + MEXTEND(mark,0); + *MARK = &sv_undef; + } + } + SP = MARK; + } + else { + for (mark = newsp + 1; mark <= SP; mark++) + if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))) + *mark = sv_mortalcopy(*mark); + /* in case LEAVE wipes old return values */ + } + curpm = newpm; /* Don't pop $1 et al till now */ + + LEAVE; + sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + RETURN; +} + +static void +doparseform(sv) +SV *sv; +{ + STRLEN len; + register char *s = SvPV_force(sv, len); + register char *send = s + len; + register char *base; + register I32 skipspaces = 0; + bool noblank; + bool repeat; + bool postspace = FALSE; + U16 *fops; + register U16 *fpc; + U16 *linepc; + register I32 arg; + bool ischop; + + New(804, fops, (send - s)*3+2, U16); /* Almost certainly too long... */ + fpc = fops; + + if (s < send) { + linepc = fpc; + *fpc++ = FF_LINEMARK; + noblank = repeat = FALSE; + base = s; + } + + while (s <= send) { + switch (*s++) { + default: + skipspaces = 0; + continue; + + case '~': + if (*s == '~') { + repeat = TRUE; + *s = ' '; + } + noblank = TRUE; + s[-1] = ' '; + /* FALL THROUGH */ + case ' ': case '\t': + skipspaces++; + continue; + + case '\n': case 0: + arg = s - base; + skipspaces++; + arg -= skipspaces; + if (arg) { + if (postspace) { + *fpc++ = FF_SPACE; + postspace = FALSE; + } + *fpc++ = FF_LITERAL; + *fpc++ = arg; + } + if (s <= send) + skipspaces--; + if (skipspaces) { + *fpc++ = FF_SKIP; + *fpc++ = skipspaces; + } + skipspaces = 0; + if (s <= send) + *fpc++ = FF_NEWLINE; + if (noblank) { + *fpc++ = FF_BLANK; + if (repeat) + arg = fpc - linepc + 1; + else + arg = 0; + *fpc++ = arg; + } + if (s < send) { + linepc = fpc; + *fpc++ = FF_LINEMARK; + noblank = repeat = FALSE; + base = s; + } + else + s++; + continue; + + case '@': + case '^': + ischop = s[-1] == '^'; + + if (postspace) { + *fpc++ = FF_SPACE; + postspace = FALSE; + } + arg = (s - base) - 1; + if (arg) { + *fpc++ = FF_LITERAL; + *fpc++ = arg; + } + + base = s - 1; + *fpc++ = FF_FETCH; + if (*s == '*') { + s++; + *fpc++ = 0; + *fpc++ = FF_LINEGLOB; + } + else if (*s == '#' || (*s == '.' && s[1] == '#')) { + arg = ischop ? 512 : 0; + base = s - 1; + while (*s == '#') + s++; + if (*s == '.') { + char *f; + s++; + f = s; + while (*s == '#') + s++; + arg |= 256 + (s - f); + } + *fpc++ = s - base; /* fieldsize for FETCH */ + *fpc++ = FF_DECIMAL; + *fpc++ = arg; + } + else { + I32 prespace = 0; + bool ismore = FALSE; + + if (*s == '>') { + while (*++s == '>') ; + prespace = FF_SPACE; + } + else if (*s == '|') { + while (*++s == '|') ; + prespace = FF_HALFSPACE; + postspace = TRUE; + } + else { + if (*s == '<') + while (*++s == '<') ; + postspace = TRUE; + } + if (*s == '.' && s[1] == '.' && s[2] == '.') { + s += 3; + ismore = TRUE; + } + *fpc++ = s - base; /* fieldsize for FETCH */ + + *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; + + if (prespace) + *fpc++ = prespace; + *fpc++ = FF_ITEM; + if (ismore) + *fpc++ = FF_MORE; + if (ischop) + *fpc++ = FF_CHOP; + } + base = s; + skipspaces = 0; + continue; + } + } + *fpc++ = FF_END; + + arg = fpc - fops; + { /* need to jump to the next word */ + int z; + z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; + SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4); + s = SvPVX(sv) + SvCUR(sv) + z; + } + Copy(fops, s, arg, U16); + Safefree(fops); + SvCOMPILED_on(sv); +} + diff --git a/pp_hot.c b/pp_hot.c new file mode 100644 index 0000000000..69023cf005 --- /dev/null +++ b/pp_hot.c @@ -0,0 +1,1792 @@ +/* pp_hot.c + * + * Copyright (c) 1991-1994, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* + * Then he heard Merry change the note, and up went the Horn-cry of Buckland, + * shaking the air. + * + * Awake! Awake! Fear, Fire, Foes! Awake! + * Fire, Foes! Awake! + */ + +#include "EXTERN.h" +#include "perl.h" + +/* Hot code. */ + +PP(pp_const) +{ + dSP; + XPUSHs(cSVOP->op_sv); + RETURN; +} + +PP(pp_nextstate) +{ + curcop = (COP*)op; + TAINT_NOT; /* Each statement is presumed innocent */ + stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + FREETMPS; + return NORMAL; +} + +PP(pp_gvsv) +{ + dSP; + EXTEND(sp,1); + if (op->op_private & OPpLVAL_INTRO) + PUSHs(save_scalar(cGVOP->op_gv)); + else + PUSHs(GvSV(cGVOP->op_gv)); + RETURN; +} + +PP(pp_null) +{ + return NORMAL; +} + +PP(pp_pushmark) +{ + PUSHMARK(stack_sp); + return NORMAL; +} + +PP(pp_stringify) +{ + dSP; dTARGET; + STRLEN len; + char *s; + s = SvPV(TOPs,len); + sv_setpvn(TARG,s,len); + SETTARG; + RETURN; +} + +PP(pp_gv) +{ + dSP; + XPUSHs((SV*)cGVOP->op_gv); + RETURN; +} + +PP(pp_and) +{ + dSP; + if (!SvTRUE(TOPs)) + RETURN; + else { + --SP; + RETURNOP(cLOGOP->op_other); + } +} + +PP(pp_sassign) +{ + dSP; dPOPTOPssrl; + if (op->op_private & OPpASSIGN_BACKWARDS) { + SV *temp; + temp = left; left = right; right = temp; + } + if (tainting && tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) || + !mg_find(left, 't'))) { + TAINT_NOT; + } + SvSetSV(right, left); + SvSETMAGIC(right); + SETs(right); + RETURN; +} + +PP(pp_cond_expr) +{ + dSP; + if (SvTRUEx(POPs)) + RETURNOP(cCONDOP->op_true); + else + RETURNOP(cCONDOP->op_false); +} + +PP(pp_unstack) +{ + I32 oldsave; + TAINT_NOT; /* Each statement is presumed innocent */ + stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + FREETMPS; + oldsave = scopestack[scopestack_ix - 1]; + LEAVE_SCOPE(oldsave); + return NORMAL; +} + +PP(pp_seq) +{ + dSP; tryAMAGICbinSET(seq,0); + { + dPOPTOPssrl; + SETs( sv_eq(left, right) ? &sv_yes : &sv_no ); + RETURN; + } +} + +PP(pp_concat) +{ + dSP; dATARGET; dPOPTOPssrl; + STRLEN len; + char *s; + if (TARG != left) { + s = SvPV(left,len); + sv_setpvn(TARG,s,len); + } + s = SvPV(right,len); + sv_catpvn(TARG,s,len); + SETTARG; + RETURN; +} + +PP(pp_padsv) +{ + dSP; dTARGET; + XPUSHs(TARG); + if (op->op_private & OPpLVAL_INTRO) + SAVECLEARSV(curpad[op->op_targ]); + RETURN; +} + +PP(pp_readline) +{ + last_in_gv = (GV*)(*stack_sp--); + return do_readline(); +} + +PP(pp_eq) +{ + dSP; tryAMAGICbinSET(eq,0); + { + dPOPnv; + SETs((TOPn == value) ? &sv_yes : &sv_no); + RETURN; + } +} + +PP(pp_preinc) +{ + dSP; + sv_inc(TOPs); + SvSETMAGIC(TOPs); + return NORMAL; +} + +PP(pp_or) +{ + dSP; + if (SvTRUE(TOPs)) + RETURN; + else { + --SP; + RETURNOP(cLOGOP->op_other); + } +} + +PP(pp_add) +{ + dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + { + dPOPTOPnnrl; + SETn( left + right ); + RETURN; + } +} + +PP(pp_aelemfast) +{ + dSP; + AV *av = GvAV((GV*)cSVOP->op_sv); + SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD); + PUSHs(svp ? *svp : &sv_undef); + RETURN; +} + +PP(pp_join) +{ + dSP; dMARK; dTARGET; + MARK++; + do_join(TARG, *MARK, MARK, SP); + SP = MARK; + SETs(TARG); + RETURN; +} + +PP(pp_pushre) +{ + dSP; + XPUSHs((SV*)op); + RETURN; +} + +/* Oversized hot code. */ + +PP(pp_print) +{ + dSP; dMARK; dORIGMARK; + GV *gv; + IO *io; + register FILE *fp; + + if (op->op_flags & OPf_STACKED) + gv = (GV*)*++MARK; + else + gv = defoutgv; + if (!(io = GvIO(gv))) { + if (dowarn) + warn("Filehandle %s never opened", GvNAME(gv)); + errno = EBADF; + goto just_say_no; + } + else if (!(fp = IoOFP(io))) { + if (dowarn) { + if (IoIFP(io)) + warn("Filehandle %s opened only for input", GvNAME(gv)); + else + warn("print on closed filehandle %s", GvNAME(gv)); + } + errno = EBADF; + goto just_say_no; + } + else { + MARK++; + if (ofslen) { + while (MARK <= SP) { + if (!do_print(*MARK, fp)) + break; + MARK++; + if (MARK <= SP) { + if (fwrite1(ofs, 1, ofslen, fp) == 0 || ferror(fp)) { + MARK--; + break; + } + } + } + } + else { + while (MARK <= SP) { + if (!do_print(*MARK, fp)) + break; + MARK++; + } + } + if (MARK <= SP) + goto just_say_no; + else { + if (orslen) + if (fwrite1(ors, 1, orslen, fp) == 0 || ferror(fp)) + goto just_say_no; + + if (IoFLAGS(io) & IOf_FLUSH) + if (fflush(fp) == EOF) + goto just_say_no; + } + } + SP = ORIGMARK; + PUSHs(&sv_yes); + RETURN; + + just_say_no: + SP = ORIGMARK; + PUSHs(&sv_undef); + RETURN; +} + +PP(pp_rv2av) +{ + dSP; dPOPss; + + AV *av; + + if (SvROK(sv)) { + wasref: + av = (AV*)SvRV(sv); + if (SvTYPE(av) != SVt_PVAV) + DIE("Not an ARRAY reference"); + if (op->op_private & OPpLVAL_INTRO) + av = (AV*)save_svref((SV**)sv); + if (op->op_flags & OPf_REF) { + PUSHs((SV*)av); + RETURN; + } + } + else { + if (SvTYPE(sv) == SVt_PVAV) { + av = (AV*)sv; + if (op->op_flags & OPf_REF) { + PUSHs((SV*)av); + RETURN; + } + } + else { + if (SvTYPE(sv) != SVt_PVGV) { + if (SvGMAGICAL(sv)) { + mg_get(sv); + if (SvROK(sv)) + goto wasref; + } + if (!SvOK(sv)) { + if (op->op_flags & OPf_REF || + op->op_private & HINT_STRICT_REFS) + DIE(no_usym, "an ARRAY"); + RETPUSHUNDEF; + } + if (op->op_private & HINT_STRICT_REFS) + DIE(no_symref, "an ARRAY"); + sv = (SV*)gv_fetchpv(SvPV(sv, na), 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; + } + } + } + + if (GIMME == G_ARRAY) { + I32 maxarg = AvFILL(av) + 1; + EXTEND(SP, maxarg); + Copy(AvARRAY(av), SP+1, maxarg, SV*); + SP += maxarg; + } + else { + dTARGET; + I32 maxarg = AvFILL(av) + 1; + PUSHi(maxarg); + } + RETURN; +} + +PP(pp_rv2hv) +{ + + dSP; dTOPss; + + HV *hv; + + if (SvROK(sv)) { + wasref: + hv = (HV*)SvRV(sv); + if (SvTYPE(hv) != SVt_PVHV) + DIE("Not a HASH reference"); + if (op->op_private & OPpLVAL_INTRO) + hv = (HV*)save_svref((SV**)sv); + if (op->op_flags & OPf_REF) { + SETs((SV*)hv); + RETURN; + } + } + else { + if (SvTYPE(sv) == SVt_PVHV) { + hv = (HV*)sv; + if (op->op_flags & OPf_REF) { + SETs((SV*)hv); + RETURN; + } + } + else { + if (SvTYPE(sv) != SVt_PVGV) { + if (SvGMAGICAL(sv)) { + mg_get(sv); + if (SvROK(sv)) + goto wasref; + } + if (!SvOK(sv)) { + if (op->op_flags & OPf_REF || + op->op_private & HINT_STRICT_REFS) + DIE(no_usym, "a HASH"); + RETSETUNDEF; + } + if (op->op_private & HINT_STRICT_REFS) + DIE(no_symref, "a HASH"); + sv = (SV*)gv_fetchpv(SvPV(sv, na), 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; + } + } + } + + if (GIMME == G_ARRAY) { /* array wanted */ + *stack_sp = (SV*)hv; + return do_kv(ARGS); + } + else { + dTARGET; + if (HvFILL(hv)) { + sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1); + sv_setpv(TARG, buf); + } + else + sv_setiv(TARG, 0); + SETTARG; + RETURN; + } +} + +PP(pp_aassign) +{ + dSP; + SV **lastlelem = stack_sp; + SV **lastrelem = stack_base + POPMARK; + SV **firstrelem = stack_base + POPMARK + 1; + SV **firstlelem = lastrelem + 1; + + register SV **relem; + register SV **lelem; + + register SV *sv; + register AV *ary; + + HV *hash; + I32 i; + int magic; + + delaymagic = DM_DELAY; /* catch simultaneous items */ + + /* If there's a common identifier on both sides we have to take + * special care that assigning the identifier on the left doesn't + * clobber a value on the right that's used later in the list. + */ + if (op->op_private & OPpASSIGN_COMMON) { + for (relem = firstrelem; relem <= lastrelem; relem++) { + /*SUPPRESS 560*/ + if (sv = *relem) + *relem = sv_mortalcopy(sv); + } + } + + relem = firstrelem; + lelem = firstlelem; + ary = Null(AV*); + hash = Null(HV*); + while (lelem <= lastlelem) { + sv = *lelem++; + switch (SvTYPE(sv)) { + case SVt_PVAV: + ary = (AV*)sv; + magic = SvSMAGICAL(ary) != 0; + + av_clear(ary); + i = 0; + while (relem <= lastrelem) { /* gobble up all the rest */ + sv = NEWSV(28,0); + assert(*relem); + sv_setsv(sv,*relem); + *(relem++) = sv; + (void)av_store(ary,i++,sv); + if (magic) + mg_set(sv); + } + break; + case SVt_PVHV: { + char *tmps; + SV *tmpstr; + + hash = (HV*)sv; + magic = SvSMAGICAL(hash) != 0; + hv_clear(hash); + + while (relem < lastrelem) { /* gobble up all the rest */ + STRLEN len; + if (*relem) + sv = *(relem++); + else + sv = &sv_no, relem++; + tmps = SvPV(sv, len); + tmpstr = NEWSV(29,0); + if (*relem) + sv_setsv(tmpstr,*relem); /* value */ + *(relem++) = tmpstr; + (void)hv_store(hash,tmps,len,tmpstr,0); + if (magic) + mg_set(tmpstr); + } + } + break; + default: + if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv) && curcop != &compiling) { + if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no) + DIE(no_modify); + if (relem <= lastrelem) + relem++; + break; + } + if (SvROK(sv)) + sv_unref(sv); + } + if (relem <= lastrelem) { + sv_setsv(sv, *relem); + *(relem++) = sv; + } + else + sv_setsv(sv, &sv_undef); + SvSETMAGIC(sv); + break; + } + } + if (delaymagic & ~DM_DELAY) { + if (delaymagic & DM_UID) { +#ifdef HAS_SETRESUID + (void)setresuid(uid,euid,(Uid_t)-1); +#else /* not HAS_SETRESUID */ +#ifdef HAS_SETREUID + (void)setreuid(uid,euid); +#else /* not HAS_SETREUID */ +#ifdef HAS_SETRUID + if ((delaymagic & DM_UID) == DM_RUID) { + (void)setruid(uid); + delaymagic =~ DM_RUID; + } +#endif /* HAS_SETRUID */ +#endif /* HAS_SETRESUID */ +#ifdef HAS_SETEUID + if ((delaymagic & DM_UID) == DM_EUID) { + (void)seteuid(uid); + delaymagic =~ DM_EUID; + } +#endif /* HAS_SETEUID */ + if (delaymagic & DM_UID) { + if (uid != euid) + DIE("No setreuid available"); + (void)setuid(uid); + } +#endif /* not HAS_SETREUID */ + uid = (int)getuid(); + euid = (int)geteuid(); + } + if (delaymagic & DM_GID) { +#ifdef HAS_SETRESGID + (void)setresgid(gid,egid,(Gid_t)-1); +#else /* not HAS_SETREGID */ +#ifdef HAS_SETREGID + (void)setregid(gid,egid); +#else /* not HAS_SETREGID */ +#endif /* not HAS_SETRESGID */ +#ifdef HAS_SETRGID + if ((delaymagic & DM_GID) == DM_RGID) { + (void)setrgid(gid); + delaymagic =~ DM_RGID; + } +#endif /* HAS_SETRGID */ +#ifdef HAS_SETRESGID + (void)setresgid(gid,egid,(Gid_t)-1); +#else /* not HAS_SETREGID */ +#ifdef HAS_SETEGID + if ((delaymagic & DM_GID) == DM_EGID) { + (void)setegid(gid); + delaymagic =~ DM_EGID; + } +#endif /* HAS_SETEGID */ + if (delaymagic & DM_GID) { + if (gid != egid) + DIE("No setregid available"); + (void)setgid(gid); + } +#endif /* not HAS_SETRESGID */ +#endif /* not HAS_SETREGID */ + gid = (int)getgid(); + egid = (int)getegid(); + } + tainting |= (euid != uid || egid != gid); + } + delaymagic = 0; + if (GIMME == G_ARRAY) { + if (ary || hash) + SP = lastrelem; + else + SP = firstrelem + (lastlelem - firstlelem); + RETURN; + } + else { + SP = firstrelem; + for (relem = firstrelem; relem <= lastrelem; ++relem) { + if (SvOK(*relem)) { + dTARGET; + + SETi(lastrelem - firstrelem + 1); + RETURN; + } + } + RETSETUNDEF; + } +} + +PP(pp_match) +{ + dSP; dTARG; + register PMOP *pm = cPMOP; + register char *t; + register char *s; + char *strend; + I32 global; + I32 safebase; + char *truebase; + register REGEXP *rx = pm->op_pmregexp; + I32 gimme = GIMME; + STRLEN len; + + if (op->op_flags & OPf_STACKED) + TARG = POPs; + else { + TARG = GvSV(defgv); + EXTEND(SP,1); + } + s = SvPV(TARG, len); + strend = s + len; + if (!s) + DIE("panic: do_match"); + + if (pm->op_pmflags & PMf_USED) { + if (gimme == G_ARRAY) + RETURN; + RETPUSHNO; + } + + if (!rx->prelen && curpm) { + pm = curpm; + rx = pm->op_pmregexp; + } + truebase = t = s; + if (global = pm->op_pmflags & PMf_GLOBAL) { + rx->startp[0] = 0; + if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { + MAGIC* mg = mg_find(TARG, 'g'); + if (mg && mg->mg_len >= 0) + rx->endp[0] = rx->startp[0] = s + mg->mg_len; + } + } + safebase = (gimme == G_ARRAY) || global; + if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { + SAVEINT(multiline); + multiline = pm->op_pmflags & PMf_MULTILINE; + } + +play_it_again: + if (global && rx->startp[0]) { + t = s = rx->endp[0]; + if (s > strend) + goto nope; + } + if (pm->op_pmshort) { + if (pm->op_pmflags & PMf_SCANFIRST) { + if (SvSCREAM(TARG)) { + if (screamfirst[BmRARE(pm->op_pmshort)] < 0) + goto nope; + else if (!(s = screaminstr(TARG, pm->op_pmshort))) + goto nope; + else if (pm->op_pmflags & PMf_ALL) + goto yup; + } + else if (!(s = fbm_instr((unsigned char*)s, + (unsigned char*)strend, pm->op_pmshort))) + goto nope; + else if (pm->op_pmflags & PMf_ALL) + goto yup; + if (s && rx->regback >= 0) { + ++BmUSEFUL(pm->op_pmshort); + s -= rx->regback; + if (s < t) + s = t; + } + else + s = t; + } + else if (!multiline) { + if (*SvPVX(pm->op_pmshort) != *s || + bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) { + if (pm->op_pmflags & PMf_FOLD) { + if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) ) + goto nope; + } + else + goto nope; + } + } + if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) { + SvREFCNT_dec(pm->op_pmshort); + pm->op_pmshort = Nullsv; /* opt is being useless */ + } + } + if (!rx->nparens && !global) { + gimme = G_SCALAR; /* accidental array context? */ + safebase = FALSE; + } + if (regexec(rx, s, strend, truebase, 0, + SvSCREAM(TARG) ? TARG : Nullsv, + safebase)) { + curpm = pm; + if (pm->op_pmflags & PMf_ONCE) + pm->op_pmflags |= PMf_USED; + goto gotcha; + } + else + goto ret_no; + /*NOTREACHED*/ + + gotcha: + if (gimme == G_ARRAY) { + I32 iters, i, len; + + iters = rx->nparens; + if (global && !iters) + i = 1; + else + i = 0; + EXTEND(SP, iters + i); + for (i = !i; i <= iters; i++) { + PUSHs(sv_newmortal()); + /*SUPPRESS 560*/ + if ((s = rx->startp[i]) && rx->endp[i] ) { + len = rx->endp[i] - s; + sv_setpvn(*SP, s, len); + } + } + if (global) { + truebase = rx->subbeg; + if (rx->startp[0] && rx->startp[0] == rx->endp[0]) + ++rx->endp[0]; + goto play_it_again; + } + RETURN; + } + else { + if (global) { + MAGIC* mg = 0; + if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) + mg = mg_find(TARG, 'g'); + if (!mg) { + sv_magic(TARG, (SV*)0, 'g', Nullch, 0); + mg = mg_find(TARG, 'g'); + } + mg->mg_len = rx->startp[0] ? rx->endp[0] - truebase : -1; + } + RETPUSHYES; + } + +yup: + ++BmUSEFUL(pm->op_pmshort); + curpm = pm; + if (pm->op_pmflags & PMf_ONCE) + pm->op_pmflags |= PMf_USED; + if (global) { + rx->subbeg = truebase; + rx->subend = strend; + rx->startp[0] = s; + rx->endp[0] = s + SvCUR(pm->op_pmshort); + goto gotcha; + } + if (sawampersand) { + char *tmps; + + if (rx->subbase) + Safefree(rx->subbase); + tmps = rx->subbase = savepvn(t, strend-t); + rx->subbeg = tmps; + rx->subend = tmps + (strend-t); + tmps = rx->startp[0] = tmps + (s - t); + rx->endp[0] = tmps + SvCUR(pm->op_pmshort); + } + RETPUSHYES; + +nope: + if (pm->op_pmshort) + ++BmUSEFUL(pm->op_pmshort); + +ret_no: + if (global) { + if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { + MAGIC* mg = mg_find(TARG, 'g'); + if (mg) + mg->mg_len = -1; + } + } + if (gimme == G_ARRAY) + RETURN; + RETPUSHNO; +} + +OP * +do_readline() +{ + dSP; dTARGETSTACKED; + register SV *sv; + STRLEN tmplen = 0; + STRLEN offset; + FILE *fp; + register IO *io = GvIO(last_in_gv); + register I32 type = op->op_type; + + fp = Nullfp; + if (io) { + fp = IoIFP(io); + if (!fp) { + if (IoFLAGS(io) & IOf_ARGV) { + if (IoFLAGS(io) & IOf_START) { + IoFLAGS(io) &= ~IOf_START; + IoLINES(io) = 0; + if (av_len(GvAVn(last_in_gv)) < 0) { + SV *tmpstr = newSVpv("-", 1); /* assume stdin */ + av_push(GvAVn(last_in_gv), tmpstr); + } + } + fp = nextargv(last_in_gv); + if (!fp) { /* Note: fp != IoIFP(io) */ + (void)do_close(last_in_gv, FALSE); /* now it does*/ + IoFLAGS(io) |= IOf_START; + } + } + else if (type == OP_GLOB) { + SV *tmpcmd = NEWSV(55, 0); + SV *tmpglob = POPs; + ENTER; + SAVEFREESV(tmpcmd); +#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ + /* since spawning off a process is a real performance hit */ + { +#include <descrip.h> +#include <lib$routines.h> +#include <nam.h> +#include <rmsdef.h> + char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'}; + char vmsspec[NAM$C_MAXRSS+1]; + char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; + char tmpfnam[L_tmpnam] = "SYS$SCRATCH:"; + $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); + FILE *tmpfp; + STRLEN i; + struct dsc$descriptor_s wilddsc + = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct dsc$descriptor_vs rsdsc + = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt}; + unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0; + + /* We could find out if there's an explicit dev/dir or version + by peeking into lib$find_file's internal context at + ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb + but that's unsupported, so I don't want to do it now and + have it bite someone in the future. */ + strcat(tmpfnam,tmpnam(NULL)); + cp = SvPV(tmpglob,i); + for (; i; i--) { + if (cp[i] == ';') hasver = 1; + if (cp[i] == '.') { + if (sts) hasver = 1; + else sts = 1; + } + if (cp[i] == '/') { + hasdir = isunix = 1; + break; + } + if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { + hasdir = 1; + break; + } + } + if ((tmpfp = fopen(tmpfnam,"w+","fop=dlt")) != NULL) { + ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL); + if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer); + while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt, + &dfltdsc,NULL,NULL,NULL))&1)) { + end = rstr + (unsigned long int) *rslt; + if (!hasver) while (*end != ';') end--; + *(end++) = '\n'; *end = '\0'; + for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); + if (hasdir) { + if (isunix) trim_unixpath(SvPVX(tmpglob),rstr); + begin = rstr; + } + else { + begin = end; + while (*(--begin) != ']' && *begin != '>') ; + ++begin; + } + ok = (fputs(begin,tmpfp) != EOF); + } + if (cxt) (void)lib$find_file_end(&cxt); + if (ok && sts != RMS$_NMF) ok = 0; + if (!ok) { + fp = NULL; + } + else { + rewind(tmpfp); + IoTYPE(io) = '<'; + IoIFP(io) = fp = tmpfp; + } + } + } +#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); + sv_catpv(tmpcmd, "'|"); +#else + sv_setpv(tmpcmd, "echo "); + sv_catsv(tmpcmd, tmpglob); +#if 'z' - 'a' == 25 + sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); +#else + sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); +#endif +#endif /* !CSH */ +#endif /* !MSDOS */ + (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),Nullfp); + fp = IoIFP(io); +#endif /* !VMS */ + LEAVE; + } + } + else if (type == OP_GLOB) + SP--; + } + if (!fp) { + if (dowarn) + warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); + if (GIMME == G_SCALAR) { + (void)SvOK_off(TARG); + PUSHTARG; + } + RETURN; + } + if (GIMME == G_ARRAY) { + sv = sv_2mortal(NEWSV(57, 80)); + offset = 0; + } + else { + sv = TARG; + (void)SvUPGRADE(sv, SVt_PV); + tmplen = SvLEN(sv); /* remember if already alloced */ + if (!tmplen) + Sv_Grow(sv, 80); /* try short-buffering it */ + if (type == OP_RCATLINE) + offset = SvCUR(sv); + else + offset = 0; + } + for (;;) { + if (!sv_gets(sv, fp, offset)) { + clearerr(fp); + if (IoFLAGS(io) & IOf_ARGV) { + fp = nextargv(last_in_gv); + if (fp) + continue; + (void)do_close(last_in_gv, FALSE); + IoFLAGS(io) |= IOf_START; + } + else if (type == OP_GLOB) { + (void)do_close(last_in_gv, FALSE); + } + if (GIMME == G_SCALAR) { + (void)SvOK_off(TARG); + PUSHTARG; + } + RETURN; + } + IoLINES(io)++; + XPUSHs(sv); + if (tainting) { + tainted = TRUE; + SvTAINT(sv); /* Anything from the outside world...*/ + } + if (type == OP_GLOB) { + char *tmps; + + if (SvCUR(sv) > 0) + SvCUR(sv)--; + if (*SvEND(sv) == rschar) + *SvEND(sv) = '\0'; + else + SvCUR(sv)++; + for (tmps = SvPVX(sv); *tmps; tmps++) + if (!isALPHA(*tmps) && !isDIGIT(*tmps) && + strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) + break; + if (*tmps && Stat(SvPVX(sv), &statbuf) < 0) { + (void)POPs; /* Unmatched wildcard? Chuck it... */ + continue; + } + } + if (GIMME == G_ARRAY) { + if (SvLEN(sv) - SvCUR(sv) > 20) { + SvLEN_set(sv, SvCUR(sv)+1); + Renew(SvPVX(sv), SvLEN(sv), char); + } + sv = sv_2mortal(NEWSV(58, 80)); + continue; + } + else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) { + /* try to reclaim a bit of scalar space (only on 1st alloc) */ + if (SvCUR(sv) < 60) + SvLEN_set(sv, 80); + else + SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */ + Renew(SvPVX(sv), SvLEN(sv), char); + } + RETURN; + } +} + +PP(pp_enter) +{ + dSP; + register CONTEXT *cx; + I32 gimme; + + /* + * We don't just use the GIMME macro here because it assumes there's + * already a context, which ain't necessarily so at initial startup. + */ + + if (op->op_flags & OPf_KNOW) + gimme = op->op_flags & OPf_LIST; + else if (cxstack_ix >= 0) + gimme = cxstack[cxstack_ix].blk_gimme; + else + gimme = G_SCALAR; + + ENTER; + + SAVETMPS; + PUSHBLOCK(cx, CXt_BLOCK, sp); + + RETURN; +} + +PP(pp_helem) +{ + dSP; + SV** svp; + SV *keysv = POPs; + STRLEN keylen; + char *key = SvPV(keysv, keylen); + HV *hv = (HV*)POPs; + I32 lval = op->op_flags & OPf_MOD; + + if (SvTYPE(hv) != SVt_PVHV) + RETPUSHUNDEF; + svp = hv_fetch(hv, key, keylen, lval); + if (lval) { + if (!svp || *svp == &sv_undef) + DIE(no_helem, key); + if (op->op_private & OPpLVAL_INTRO) + save_svref(svp); + else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) { + SV* sv = *svp; + if (SvGMAGICAL(sv)) + mg_get(sv); + if (!SvOK(sv)) { + (void)SvUPGRADE(sv, SVt_RV); + SvRV(sv) = (op->op_private & OPpDEREF_HV ? + (SV*)newHV() : (SV*)newAV()); + SvROK_on(sv); + SvSETMAGIC(sv); + } + } + } + PUSHs(svp ? *svp : &sv_undef); + RETURN; +} + +PP(pp_leave) +{ + dSP; + register CONTEXT *cx; + register SV **mark; + SV **newsp; + PMOP *newpm; + I32 gimme; + + if (op->op_flags & OPf_SPECIAL) { + cx = &cxstack[cxstack_ix]; + cx->blk_oldpm = curpm; /* fake block should preserve $1 et al */ + } + + POPBLOCK(cx,newpm); + + if (op->op_flags & OPf_KNOW) + gimme = op->op_flags & OPf_LIST; + else if (cxstack_ix >= 0) + gimme = cxstack[cxstack_ix].blk_gimme; + else + gimme = G_SCALAR; + + if (gimme == G_SCALAR) { + if (op->op_private & OPpLEAVE_VOID) + SP = newsp; + else { + MARK = newsp + 1; + if (MARK <= SP) + if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) + *MARK = TOPs; + else + *MARK = sv_mortalcopy(TOPs); + else { + MEXTEND(mark,0); + *MARK = &sv_undef; + } + SP = MARK; + } + } + else { + for (mark = newsp + 1; mark <= SP; mark++) + if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) + *mark = sv_mortalcopy(*mark); + /* in case LEAVE wipes old return values */ + } + curpm = newpm; /* Don't pop $1 et al till now */ + + LEAVE; + + RETURN; +} + +PP(pp_iter) +{ + dSP; + register CONTEXT *cx; + SV *sv; + + EXTEND(sp, 1); + cx = &cxstack[cxstack_ix]; + if (cx->cx_type != CXt_LOOP) + DIE("panic: pp_iter"); + + if (cx->blk_loop.iterix >= cx->blk_oldsp) + RETPUSHNO; + + if (sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix]) { + SvTEMP_off(sv); + *cx->blk_loop.itervar = sv; + } + else + *cx->blk_loop.itervar = &sv_undef; + + RETPUSHYES; +} + +PP(pp_subst) +{ + dSP; dTARG; + register PMOP *pm = cPMOP; + PMOP *rpm = pm; + register SV *dstr; + register char *s; + char *strend; + register char *m; + char *c; + register char *d; + STRLEN clen; + I32 iters = 0; + I32 maxiters; + register I32 i; + bool once; + char *orig; + I32 safebase; + register REGEXP *rx = pm->op_pmregexp; + STRLEN len; + int force_on_match = 0; + + if (pm->op_pmflags & PMf_CONST) /* known replacement string? */ + dstr = POPs; + if (op->op_flags & OPf_STACKED) + TARG = POPs; + else { + TARG = GvSV(defgv); + EXTEND(SP,1); + } + s = SvPV(TARG, len); + if (!SvPOKp(TARG)) + force_on_match = 1; + + force_it: + if (!pm || !s) + DIE("panic: do_subst"); + + strend = s + len; + maxiters = (strend - s) + 10; + + if (!rx->prelen && curpm) { + pm = curpm; + rx = pm->op_pmregexp; + } + safebase = ((!rx || !rx->nparens) && !sawampersand); + if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { + SAVEINT(multiline); + multiline = pm->op_pmflags & PMf_MULTILINE; + } + orig = m = s; + if (pm->op_pmshort) { + if (pm->op_pmflags & PMf_SCANFIRST) { + if (SvSCREAM(TARG)) { + if (screamfirst[BmRARE(pm->op_pmshort)] < 0) + goto nope; + else if (!(s = screaminstr(TARG, pm->op_pmshort))) + goto nope; + } + else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend, + pm->op_pmshort))) + goto nope; + if (s && rx->regback >= 0) { + ++BmUSEFUL(pm->op_pmshort); + s -= rx->regback; + if (s < m) + s = m; + } + else + s = m; + } + else if (!multiline) { + if (*SvPVX(pm->op_pmshort) != *s || + bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) { + if (pm->op_pmflags & PMf_FOLD) { + if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) ) + goto nope; + } + else + goto nope; + } + } + if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) { + SvREFCNT_dec(pm->op_pmshort); + pm->op_pmshort = Nullsv; /* opt is being useless */ + } + } + once = !(rpm->op_pmflags & PMf_GLOBAL); + if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */ + c = SvPV(dstr, clen); + if (clen <= rx->minlen) { + /* can do inplace substitution */ + if (regexec(rx, s, strend, orig, 0, + SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { + if (force_on_match) { + force_on_match = 0; + s = SvPV_force(TARG, len); + goto force_it; + } + if (rx->subbase) /* oops, no we can't */ + goto long_way; + d = s; + curpm = pm; + SvSCREAM_off(TARG); /* disable possible screamer */ + if (once) { + m = rx->startp[0]; + d = rx->endp[0]; + s = orig; + if (m - s > strend - d) { /* faster to shorten from end */ + if (clen) { + Copy(c, m, clen, char); + m += clen; + } + i = strend - d; + if (i > 0) { + Move(d, m, i, char); + m += i; + } + *m = '\0'; + SvCUR_set(TARG, m - s); + (void)SvPOK_only(TARG); + SvSETMAGIC(TARG); + PUSHs(&sv_yes); + RETURN; + } + /*SUPPRESS 560*/ + else if (i = m - s) { /* faster from front */ + d -= clen; + m = d; + sv_chop(TARG, d-i); + s += i; + while (i--) + *--d = *--s; + if (clen) + Copy(c, m, clen, char); + (void)SvPOK_only(TARG); + SvSETMAGIC(TARG); + PUSHs(&sv_yes); + RETURN; + } + else if (clen) { + d -= clen; + sv_chop(TARG, d); + Copy(c, d, clen, char); + (void)SvPOK_only(TARG); + SvSETMAGIC(TARG); + PUSHs(&sv_yes); + RETURN; + } + else { + sv_chop(TARG, d); + (void)SvPOK_only(TARG); + SvSETMAGIC(TARG); + PUSHs(&sv_yes); + RETURN; + } + /* NOTREACHED */ + } + do { + if (iters++ > maxiters) + DIE("Substitution loop"); + m = rx->startp[0]; + /*SUPPRESS 560*/ + if (i = m - s) { + if (s != d) + Move(s, d, i, char); + d += i; + } + if (clen) { + Copy(c, d, clen, char); + d += clen; + } + s = rx->endp[0]; + } while (regexec(rx, s, strend, orig, s == m, + Nullsv, TRUE)); /* (don't match same null twice) */ + if (s != d) { + i = strend - s; + SvCUR_set(TARG, d - SvPVX(TARG) + i); + Move(s, d, i+1, char); /* include the Null */ + } + (void)SvPOK_only(TARG); + SvSETMAGIC(TARG); + PUSHs(sv_2mortal(newSViv((I32)iters))); + RETURN; + } + PUSHs(&sv_no); + RETURN; + } + } + else + c = Nullch; + if (regexec(rx, s, strend, orig, 0, + SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { + long_way: + if (force_on_match) { + force_on_match = 0; + s = SvPV_force(TARG, len); + goto force_it; + } + dstr = NEWSV(25, sv_len(TARG)); + sv_setpvn(dstr, m, s-m); + curpm = pm; + if (!c) { + register CONTEXT *cx; + PUSHSUBST(cx); + RETURNOP(cPMOP->op_pmreplroot); + } + do { + if (iters++ > maxiters) + DIE("Substitution loop"); + if (rx->subbase && rx->subbase != orig) { + m = s; + s = orig; + orig = rx->subbase; + s = orig + (m - s); + strend = s + (strend - m); + } + m = rx->startp[0]; + sv_catpvn(dstr, s, m-s); + s = rx->endp[0]; + if (clen) + sv_catpvn(dstr, c, clen); + if (once) + break; + } while (regexec(rx, s, strend, orig, s == m, Nullsv, + safebase)); + sv_catpvn(dstr, s, strend - s); + sv_replace(TARG, dstr); + (void)SvPOK_only(TARG); + SvSETMAGIC(TARG); + PUSHs(sv_2mortal(newSViv((I32)iters))); + RETURN; + } + PUSHs(&sv_no); + RETURN; + +nope: + ++BmUSEFUL(pm->op_pmshort); + PUSHs(&sv_no); + RETURN; +} + +PP(pp_grepwhile) +{ + dSP; + + if (SvTRUEx(POPs)) + stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr]; + ++*markstack_ptr; + LEAVE; /* exit inner scope */ + + /* All done yet? */ + if (stack_base + *markstack_ptr > sp) { + I32 items; + + LEAVE; /* exit outer scope */ + (void)POPMARK; /* pop src */ + items = --*markstack_ptr - markstack_ptr[-1]; + (void)POPMARK; /* pop dst */ + SP = stack_base + POPMARK; /* pop original mark */ + if (GIMME != G_ARRAY) { + dTARGET; + XPUSHi(items); + RETURN; + } + SP += items; + RETURN; + } + else { + SV *src; + + ENTER; /* enter inner scope */ + SAVESPTR(curpm); + + src = stack_base[*markstack_ptr]; + SvTEMP_off(src); + GvSV(defgv) = src; + + RETURNOP(cLOGOP->op_other); + } +} + +PP(pp_leavesub) +{ + dSP; + SV **mark; + SV **newsp; + PMOP *newpm; + I32 gimme; + register CONTEXT *cx; + + POPBLOCK(cx,newpm); + POPSUB(cx); + + if (gimme == G_SCALAR) { + MARK = newsp + 1; + if (MARK <= SP) + if (SvFLAGS(TOPs) & SVs_TEMP) + *MARK = TOPs; + else + *MARK = sv_mortalcopy(TOPs); + else { + MEXTEND(mark,0); + *MARK = &sv_undef; + } + SP = MARK; + } + else { + for (mark = newsp + 1; mark <= SP; mark++) + if (!(SvFLAGS(*mark) & SVs_TEMP)) + *mark = sv_mortalcopy(*mark); + /* in case LEAVE wipes old return values */ + } + + if (cx->blk_sub.hasargs) { /* You don't exist; go away. */ + AV* av = cx->blk_sub.argarray; + + av_clear(av); + AvREAL_off(av); + } + curpm = newpm; /* Don't pop $1 et al till now */ + + LEAVE; + PUTBACK; + return pop_return(); +} + +PP(pp_entersub) +{ + dSP; dPOPss; + GV *gv; + HV *stash; + register CV *cv; + register CONTEXT *cx; + + if (!sv) + DIE("Not a CODE reference"); + switch (SvTYPE(sv)) { + default: + if (!SvROK(sv)) { + if (sv == &sv_yes) /* unfound import, ignore */ + RETURN; + if (!SvOK(sv)) + DIE(no_usym, "a subroutine"); + if (op->op_private & HINT_STRICT_REFS) + DIE(no_symref, "a subroutine"); + gv = gv_fetchpv(SvPV(sv, na), FALSE, SVt_PVCV); + if (!gv) + cv = 0; + else + cv = GvCV(gv); + break; + } + cv = (CV*)SvRV(sv); + if (SvTYPE(cv) == SVt_PVCV) + break; + /* FALL THROUGH */ + case SVt_PVHV: + case SVt_PVAV: + DIE("Not a CODE reference"); + case SVt_PVCV: + cv = (CV*)sv; + break; + case SVt_PVGV: + if (!(cv = GvCV((GV*)sv))) + cv = sv_2cv(sv, &stash, &gv, TRUE); + break; + } + + ENTER; + SAVETMPS; + + retry: + if (!cv) + DIE("Not a CODE reference"); + + if (!CvROOT(cv) && !CvXSUB(cv)) { + if (gv = CvGV(cv)) { + SV *tmpstr = sv_newmortal(); + GV *ngv; + gv_efullname(tmpstr, gv); + ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD"); + if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */ + gv = ngv; + sv_setsv(GvSV(CvGV(cv)), tmpstr); /* Set CV's $AUTOLOAD */ + goto retry; + } + else + DIE("Undefined subroutine &%s called",SvPVX(tmpstr)); + } + DIE("Undefined subroutine called"); + } + + if ((op->op_private & OPpDEREF_DB) && !CvXSUB(cv)) { + sv = GvSV(DBsub); + save_item(sv); + gv = CvGV(cv); + gv_efullname(sv,gv); + cv = GvCV(DBsub); + if (!cv) + DIE("No DBsub routine"); + } + + if (CvXSUB(cv)) { + if (CvOLDSTYLE(cv)) { + dMARK; + register I32 items = SP - MARK; + while (sp > mark) { + sp[1] = sp[0]; + sp--; + } + stack_sp = mark + 1; + items = (*(I32(*)_((int,int,int)))CvXSUB(cv))(CvXSUBANY(cv).any_i32, + MARK - stack_base + 1, items); + stack_sp = stack_base + items; + } + else { + PUTBACK; + (void)(*CvXSUB(cv))(cv); + } + LEAVE; + return NORMAL; + } + else { + dMARK; + register I32 items = SP - MARK; + I32 hasargs = (op->op_flags & OPf_STACKED) != 0; + I32 gimme = GIMME; + AV* padlist = CvPADLIST(cv); + SV** svp = AvARRAY(padlist); + push_return(op->op_next); + PUSHBLOCK(cx, CXt_SUB, MARK); + PUSHSUB(cx); + CvDEPTH(cv)++; + if (CvDEPTH(cv) < 2) + (void)SvREFCNT_inc(cv); + else { /* save temporaries on recursion? */ + if (CvDEPTH(cv) == 100 && dowarn) + warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv))); + if (CvDEPTH(cv) > AvFILL(padlist)) { + AV *av; + AV *newpad = newAV(); + I32 ix = AvFILL((AV*)svp[1]); + svp = AvARRAY(svp[0]); + while (ix > 0) { + if (svp[ix] != &sv_undef) { + char *name = SvPVX(svp[ix]); /* XXX */ + if (*name == '@') + av_store(newpad, ix--, sv = (SV*)newAV()); + else if (*name == '%') + av_store(newpad, ix--, sv = (SV*)newHV()); + else + av_store(newpad, ix--, sv = NEWSV(0,0)); + SvPADMY_on(sv); + } + else { + av_store(newpad, ix--, sv = NEWSV(0,0)); + SvPADTMP_on(sv); + } + } + av = newAV(); /* will be @_ */ + av_extend(av, 0); + av_store(newpad, 0, (SV*)av); + AvFLAGS(av) = AVf_REIFY; + av_store(padlist, CvDEPTH(cv), (SV*)newpad); + AvFILL(padlist) = CvDEPTH(cv); + svp = AvARRAY(padlist); + } + } + SAVESPTR(curpad); + curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); + if (hasargs) { + AV* av = (AV*)curpad[0]; + SV** ary; + + if (AvREAL(av)) { + av_clear(av); + AvREAL_off(av); + } + cx->blk_sub.savearray = GvAV(defgv); + cx->blk_sub.argarray = av; + GvAV(defgv) = cx->blk_sub.argarray; + ++MARK; + + if (items > AvMAX(av) + 1) { + ary = AvALLOC(av); + if (AvARRAY(av) != ary) { + AvMAX(av) += AvARRAY(av) - AvALLOC(av); + SvPVX(av) = (char*)ary; + } + if (items > AvMAX(av) + 1) { + AvMAX(av) = items - 1; + Renew(ary,items,SV*); + AvALLOC(av) = ary; + SvPVX(av) = (char*)ary; + } + } + Copy(MARK,AvARRAY(av),items,SV*); + AvFILL(av) = items - 1; + + while (items--) { + if (*MARK) + SvTEMP_off(*MARK); + MARK++; + } + } + RETURNOP(CvSTART(cv)); + } +} + +PP(pp_aelem) +{ + dSP; + SV** svp; + I32 elem = POPi - curcop->cop_arybase; + AV *av = (AV*)POPs; + I32 lval = op->op_flags & OPf_MOD; + + if (SvTYPE(av) != SVt_PVAV) + RETPUSHUNDEF; + svp = av_fetch(av, elem, lval); + if (lval) { + if (!svp || *svp == &sv_undef) + DIE(no_aelem, elem); + if (op->op_private & OPpLVAL_INTRO) + save_svref(svp); + else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) { + SV* sv = *svp; + if (SvGMAGICAL(sv)) + mg_get(sv); + if (!SvOK(sv)) { + (void)SvUPGRADE(sv, SVt_RV); + SvRV(sv) = (op->op_private & OPpDEREF_HV ? + (SV*)newHV() : (SV*)newAV()); + SvROK_on(sv); + SvSETMAGIC(sv); + } + } + } + PUSHs(svp ? *svp : &sv_undef); + RETURN; +} + +PP(pp_method) +{ + dSP; + SV* sv; + SV* ob; + GV* gv; + SV* nm; + + nm = TOPs; + sv = *(stack_base + TOPMARK + 1); + + gv = 0; + if (SvROK(sv)) + ob = SvRV(sv); + else { + GV* iogv; + char* packname = 0; + + if (!SvOK(sv) || + !(packname = SvPV(sv, na)) || + !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || + !(ob=(SV*)GvIO(iogv))) + { + char *name = SvPV(nm, na); + HV *stash; + if (!packname || !isALPHA(*packname)) +DIE("Can't call method \"%s\" without a package or object reference", name); + if (!(stash = gv_stashpv(packname, FALSE))) { + if (gv_stashpv("UNIVERSAL", FALSE)) + stash = gv_stashpv(packname, TRUE); + else + DIE("Can't call method \"%s\" in empty package \"%s\"", + name, packname); + } + gv = gv_fetchmethod(stash,name); + if (!gv) + DIE("Can't locate object method \"%s\" via package \"%s\"", + name, packname); + SETs(gv); + RETURN; + } + } + + if (!ob || !SvOBJECT(ob)) { + char *name = SvPV(nm, na); + DIE("Can't call method \"%s\" on unblessed reference", name); + } + + if (!gv) { /* nothing cached */ + char *name = SvPV(nm, na); + gv = gv_fetchmethod(SvSTASH(ob),name); + if (!gv) + DIE("Can't locate object method \"%s\" via package \"%s\"", + name, HvNAME(SvSTASH(ob))); + } + + SETs(gv); + RETURN; +} + diff --git a/pp_sys.c b/pp_sys.c new file mode 100644 index 0000000000..78cf9d1a63 --- /dev/null +++ b/pp_sys.c @@ -0,0 +1,3811 @@ +/* pp_sys.c + * + * Copyright (c) 1991-1994, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* + * But only a short way ahead its floor and the walls on either side were + * cloven by a great fissure, out of which the red glare came, now leaping + * up, now dying down into darkness; and all the while far below there was + * a rumour and a trouble as of great engines throbbing and labouring. + */ + +#include "EXTERN.h" +#include "perl.h" + +/* Omit this -- it causes too much grief on mixed systems. +#ifdef I_UNISTD +#include <unistd.h> +#endif +*/ + +#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ +# include <sys/socket.h> +# include <netdb.h> +# ifndef ENOTSOCK +# ifdef I_NET_ERRNO +# include <net/errno.h> +# endif +# endif +#endif + +#ifdef HAS_SELECT +#ifdef I_SYS_SELECT +#ifndef I_SYS_TIME +#include <sys/select.h> +#endif +#endif +#endif + +#ifdef HOST_NOT_FOUND +extern int h_errno; +#endif + +#ifdef HAS_PASSWD +# ifdef I_PWD +# include <pwd.h> +# else + struct passwd *getpwnam _((char *)); + struct passwd *getpwuid _((Uid_t)); +# endif + struct passwd *getpwent _((void)); +#endif + +#ifdef HAS_GROUP +# ifdef I_GRP +# include <grp.h> +# else + struct group *getgrnam _((char *)); + struct group *getgrgid _((Gid_t)); +# endif + struct group *getgrent _((void)); +#endif + +#ifdef I_UTIME +#include <utime.h> +#endif +#ifdef I_FCNTL +#include <fcntl.h> +#endif +#ifdef I_SYS_FILE +#include <sys/file.h> +#endif + +#ifdef HAS_GETPGRP2 +# define getpgrp getpgrp2 +#endif + +#ifdef HAS_SETPGRP2 +# define setpgrp setpgrp2 +#endif + +#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) +static int dooneliner _((char *cmd, char *filename)); +#endif +/* Pushy I/O. */ + +PP(pp_backtick) +{ + dSP; dTARGET; + FILE *fp; + char *tmps = POPp; + TAINT_PROPER("``"); + fp = my_popen(tmps, "r"); + if (fp) { + sv_setpv(TARG, ""); /* note that this preserves previous buffer */ + if (GIMME == G_SCALAR) { + while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch) + /*SUPPRESS 530*/ + ; + XPUSHs(TARG); + } + else { + SV *sv; + + for (;;) { + sv = NEWSV(56, 80); + if (sv_gets(sv, fp, 0) == Nullch) { + SvREFCNT_dec(sv); + break; + } + XPUSHs(sv_2mortal(sv)); + if (SvLEN(sv) - SvCUR(sv) > 20) { + SvLEN_set(sv, SvCUR(sv)+1); + Renew(SvPVX(sv), SvLEN(sv), char); + } + } + } + statusvalue = my_pclose(fp); + } + else { + statusvalue = -1; + if (GIMME == G_SCALAR) + RETPUSHUNDEF; + } + + RETURN; +} + +PP(pp_glob) +{ + OP *result; + ENTER; + SAVEINT(rschar); + SAVEINT(rslen); + + SAVESPTR(last_in_gv); /* We don't want this to be permanent. */ + last_in_gv = (GV*)*stack_sp--; + + rslen = 1; +#ifdef DOSISH + rschar = 0; +#else +#ifdef CSH + rschar = 0; +#else + rschar = '\n'; +#endif /* !CSH */ +#endif /* !MSDOS */ + result = do_readline(); + LEAVE; + return result; +} + +PP(pp_indread) +{ + last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*stack_sp--)), na), TRUE,SVt_PVIO); + return do_readline(); +} + +PP(pp_rcatline) +{ + last_in_gv = cGVOP->op_gv; + return do_readline(); +} + +PP(pp_warn) +{ + dSP; dMARK; + char *tmps; + if (SP - MARK != 1) { + dTARGET; + do_join(TARG, &sv_no, MARK, SP); + tmps = SvPV(TARG, na); + SP = MARK + 1; + } + else { + tmps = SvPV(TOPs, na); + } + if (!tmps || !*tmps) { + SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); + (void)SvUPGRADE(error, SVt_PV); + if (SvPOK(error) && SvCUR(error)) + sv_catpv(error, "\t...caught"); + tmps = SvPV(error, na); + } + if (!tmps || !*tmps) + tmps = "Warning: something's wrong"; + warn("%s", tmps); + RETSETYES; +} + +PP(pp_die) +{ + dSP; dMARK; + char *tmps; + if (SP - MARK != 1) { + dTARGET; + do_join(TARG, &sv_no, MARK, SP); + tmps = SvPV(TARG, na); + SP = MARK + 1; + } + else { + tmps = SvPV(TOPs, na); + } + if (!tmps || !*tmps) { + SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV)); + (void)SvUPGRADE(error, SVt_PV); + if (SvPOK(error) && SvCUR(error)) + sv_catpv(error, "\t...propagated"); + tmps = SvPV(error, na); + } + if (!tmps || !*tmps) + tmps = "Died"; + DIE("%s", tmps); +} + +/* I/O. */ + +PP(pp_open) +{ + dSP; dTARGET; + GV *gv; + SV *sv; + char *tmps; + STRLEN len; + + if (MAXARG > 1) + sv = POPs; + else + sv = GvSV(TOPs); + gv = (GV*)POPs; + tmps = SvPV(sv, len); + if (do_open(gv, tmps, len,Nullfp)) { + IoLINES(GvIOp(gv)) = 0; + PUSHi( (I32)forkprocess ); + } + else if (forkprocess == 0) /* we are a new child */ + PUSHi(0); + else + RETPUSHUNDEF; + RETURN; +} + +PP(pp_close) +{ + dSP; + GV *gv; + + if (MAXARG == 0) + gv = defoutgv; + else + gv = (GV*)POPs; + EXTEND(SP, 1); + PUSHs( do_close(gv, TRUE) ? &sv_yes : &sv_no ); + RETURN; +} + +PP(pp_pipe_op) +{ + dSP; +#ifdef HAS_PIPE + GV *rgv; + GV *wgv; + register IO *rstio; + register IO *wstio; + int fd[2]; + + wgv = (GV*)POPs; + rgv = (GV*)POPs; + + if (!rgv || !wgv) + goto badexit; + + rstio = GvIOn(rgv); + wstio = GvIOn(wgv); + + if (IoIFP(rstio)) + do_close(rgv, FALSE); + if (IoIFP(wstio)) + do_close(wgv, FALSE); + + if (pipe(fd) < 0) + goto badexit; + + IoIFP(rstio) = fdopen(fd[0], "r"); + IoOFP(wstio) = fdopen(fd[1], "w"); + IoIFP(wstio) = IoOFP(wstio); + IoTYPE(rstio) = '<'; + IoTYPE(wstio) = '>'; + + if (!IoIFP(rstio) || !IoOFP(wstio)) { + if (IoIFP(rstio)) fclose(IoIFP(rstio)); + else close(fd[0]); + if (IoOFP(wstio)) fclose(IoOFP(wstio)); + else close(fd[1]); + goto badexit; + } + + RETPUSHYES; + +badexit: + RETPUSHUNDEF; +#else + DIE(no_func, "pipe"); +#endif +} + +PP(pp_fileno) +{ + dSP; dTARGET; + GV *gv; + IO *io; + FILE *fp; + if (MAXARG < 1) + RETPUSHUNDEF; + gv = (GV*)POPs; + if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) + RETPUSHUNDEF; + PUSHi(fileno(fp)); + RETURN; +} + +PP(pp_umask) +{ + dSP; dTARGET; + int anum; + +#ifdef HAS_UMASK + if (MAXARG < 1) { + anum = umask(0); + (void)umask(anum); + } + else + anum = umask(POPi); + TAINT_PROPER("umask"); + XPUSHi(anum); +#else + DIE(no_func, "Unsupported function umask"); +#endif + RETURN; +} + +PP(pp_binmode) +{ + dSP; + GV *gv; + IO *io; + FILE *fp; + + if (MAXARG < 1) + RETPUSHUNDEF; + + gv = (GV*)POPs; + + EXTEND(SP, 1); + if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) + RETSETUNDEF; + +#ifdef DOSISH +#ifdef atarist + if (!fflush(fp) && (fp->_flag |= _IOBIN)) + RETPUSHYES; + else + RETPUSHUNDEF; +#else + if (setmode(fileno(fp), OP_BINARY) != -1) + RETPUSHYES; + else + RETPUSHUNDEF; +#endif +#else + RETPUSHYES; +#endif +} + +PP(pp_tie) +{ + dSP; + SV *varsv; + HV* stash; + GV *gv; + BINOP myop; + SV *sv; + SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */ + I32 markoff = mark - stack_base - 1; + char *methname; + + varsv = mark[0]; + if (SvTYPE(varsv) == SVt_PVHV) + methname = "TIEHASH"; + else if (SvTYPE(varsv) == SVt_PVAV) + methname = "TIEARRAY"; + else if (SvTYPE(varsv) == SVt_PVGV) + methname = "TIEHANDLE"; + else + methname = "TIESCALAR"; + + stash = gv_stashsv(mark[1], FALSE); + if (!stash || !(gv = gv_fetchmethod(stash, methname)) || !GvCV(gv)) + DIE("Can't locate object method \"%s\" via package \"%s\"", + methname, SvPV(mark[1],na)); + + Zero(&myop, 1, BINOP); + myop.op_last = (OP *) &myop; + myop.op_next = Nullop; + myop.op_flags = OPf_KNOW|OPf_STACKED; + + ENTER; + SAVESPTR(op); + op = (OP *) &myop; + + XPUSHs(gv); + PUTBACK; + + if (op = pp_entersub()) + run(); + SPAGAIN; + + sv = TOPs; + if (sv_isobject(sv)) { + if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) { + sv_unmagic(varsv, 'P'); + sv_magic(varsv, sv, 'P', Nullch, 0); + } + else { + sv_unmagic(varsv, 'q'); + sv_magic(varsv, sv, 'q', Nullch, 0); + } + } + LEAVE; + SP = stack_base + markoff; + PUSHs(sv); + RETURN; +} + +PP(pp_untie) +{ + dSP; + if (SvTYPE(TOPs) == SVt_PVHV || SvTYPE(TOPs) == SVt_PVAV) + sv_unmagic(TOPs, 'P'); + else + sv_unmagic(TOPs, 'q'); + RETSETYES; +} + +PP(pp_dbmopen) +{ + dSP; + HV *hv; + dPOPPOPssrl; + HV* stash; + GV *gv; + BINOP myop; + SV *sv; + + hv = (HV*)POPs; + + sv = sv_mortalcopy(&sv_no); + sv_setpv(sv, "AnyDBM_File"); + stash = gv_stashsv(sv, FALSE); + if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv)) { + PUTBACK; + perl_requirepv("AnyDBM_File.pm"); + SPAGAIN; + if (!(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv)) + DIE("No dbm on this machine"); + } + + Zero(&myop, 1, BINOP); + myop.op_last = (OP *) &myop; + myop.op_next = Nullop; + myop.op_flags = OPf_KNOW|OPf_STACKED; + + ENTER; + SAVESPTR(op); + op = (OP *) &myop; + PUTBACK; + pp_pushmark(); + + EXTEND(sp, 5); + PUSHs(sv); + PUSHs(left); + if (SvIV(right)) + PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT))); + else + PUSHs(sv_2mortal(newSViv(O_RDWR))); + PUSHs(right); + PUSHs(gv); + PUTBACK; + + if (op = pp_entersub()) + run(); + SPAGAIN; + + if (!sv_isobject(TOPs)) { + sp--; + op = (OP *) &myop; + PUTBACK; + pp_pushmark(); + + PUSHs(sv); + PUSHs(left); + PUSHs(sv_2mortal(newSViv(O_RDONLY))); + PUSHs(right); + PUSHs(gv); + PUTBACK; + + if (op = pp_entersub()) + run(); + SPAGAIN; + } + + if (sv_isobject(TOPs)) + sv_magic((SV*)hv, TOPs, 'P', Nullch, 0); + LEAVE; + RETURN; +} + +PP(pp_dbmclose) +{ + return pp_untie(ARGS); +} + +PP(pp_sselect) +{ + dSP; dTARGET; +#ifdef HAS_SELECT + register I32 i; + register I32 j; + register char *s; + register SV *sv; + double value; + I32 maxlen = 0; + I32 nfound; + struct timeval timebuf; + struct timeval *tbuf = &timebuf; + I32 growsize; + char *fd_sets[4]; +#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 + I32 masksize; + I32 offset; + I32 k; + +# if BYTEORDER & 0xf0000 +# define ORDERBYTE (0x88888888 - BYTEORDER) +# else +# define ORDERBYTE (0x4444 - BYTEORDER) +# endif + +#endif + + SP -= 4; + for (i = 1; i <= 3; i++) { + if (!SvPOK(SP[i])) + continue; + j = SvCUR(SP[i]); + if (maxlen < j) + maxlen = j; + } + +#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 + growsize = maxlen; /* little endians can use vecs directly */ +#else +#ifdef NFDBITS + +#ifndef NBBY +#define NBBY 8 +#endif + + masksize = NFDBITS / NBBY; +#else + masksize = sizeof(long); /* documented int, everyone seems to use long */ +#endif + growsize = maxlen + (masksize - (maxlen % masksize)); + Zero(&fd_sets[0], 4, char*); +#endif + + sv = SP[4]; + if (SvOK(sv)) { + value = SvNV(sv); + if (value < 0.0) + value = 0.0; + timebuf.tv_sec = (long)value; + value -= (double)timebuf.tv_sec; + timebuf.tv_usec = (long)(value * 1000000.0); + } + else + tbuf = Null(struct timeval*); + + for (i = 1; i <= 3; i++) { + sv = SP[i]; + if (!SvOK(sv)) { + fd_sets[i] = 0; + continue; + } + else if (!SvPOK(sv)) + SvPV_force(sv,na); /* force string conversion */ + j = SvLEN(sv); + if (j < growsize) { + Sv_Grow(sv, growsize); + s = SvPVX(sv) + j; + while (++j <= growsize) { + *s++ = '\0'; + } + } +#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 + s = SvPVX(sv); + New(403, fd_sets[i], growsize, char); + for (offset = 0; offset < growsize; offset += masksize) { + for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) + fd_sets[i][j+offset] = s[(k % masksize) + offset]; + } +#else + fd_sets[i] = SvPVX(sv); +#endif + } + + nfound = select( + maxlen * 8, + (Select_fd_set_t) fd_sets[1], + (Select_fd_set_t) fd_sets[2], + (Select_fd_set_t) fd_sets[3], + tbuf); + for (i = 1; i <= 3; i++) { + if (fd_sets[i]) { + sv = SP[i]; +#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 + s = SvPVX(sv); + for (offset = 0; offset < growsize; offset += masksize) { + for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) + s[(k % masksize) + offset] = fd_sets[i][j+offset]; + } + Safefree(fd_sets[i]); +#endif + SvSETMAGIC(sv); + } + } + + PUSHi(nfound); + if (GIMME == G_ARRAY && tbuf) { + value = (double)(timebuf.tv_sec) + + (double)(timebuf.tv_usec) / 1000000.0; + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setnv(sv, value); + } + RETURN; +#else + DIE("select not implemented"); +#endif +} + +PP(pp_select) +{ + dSP; dTARGET; + GV *oldgv = defoutgv; + if (op->op_private > 0) { + defoutgv = (GV*)POPs; + if (!GvIO(defoutgv)) + gv_IOadd(defoutgv); + } + gv_efullname(TARG, oldgv); + XPUSHTARG; + RETURN; +} + +PP(pp_getc) +{ + dSP; dTARGET; + GV *gv; + + if (MAXARG <= 0) + gv = stdingv; + else + gv = (GV*)POPs; + if (!gv) + gv = argvgv; + if (!gv || do_eof(gv)) /* make sure we have fp with something */ + RETPUSHUNDEF; + TAINT_IF(1); + sv_setpv(TARG, " "); + *SvPVX(TARG) = getc(IoIFP(GvIOp(gv))); /* should never be EOF */ + PUSHTARG; + RETURN; +} + +PP(pp_read) +{ + return pp_sysread(ARGS); +} + +static OP * +doform(cv,gv,retop) +CV *cv; +GV *gv; +OP *retop; +{ + register CONTEXT *cx; + I32 gimme = GIMME; + AV* padlist = CvPADLIST(cv); + SV** svp = AvARRAY(padlist); + + ENTER; + SAVETMPS; + + push_return(retop); + PUSHBLOCK(cx, CXt_SUB, stack_sp); + PUSHFORMAT(cx); + SAVESPTR(curpad); + curpad = AvARRAY((AV*)svp[1]); + + defoutgv = gv; /* locally select filehandle so $% et al work */ + return CvSTART(cv); +} + +PP(pp_enterwrite) +{ + dSP; + register GV *gv; + register IO *io; + GV *fgv; + CV *cv; + + if (MAXARG == 0) + gv = defoutgv; + else { + gv = (GV*)POPs; + if (!gv) + gv = defoutgv; + } + EXTEND(SP, 1); + io = GvIO(gv); + if (!io) { + RETPUSHNO; + } + if (IoFMT_GV(io)) + fgv = IoFMT_GV(io); + else + fgv = gv; + + cv = GvFORM(fgv); + + if (!cv) { + if (fgv) { + SV *tmpstr = sv_newmortal(); + gv_efullname(tmpstr, gv); + DIE("Undefined format \"%s\" called",SvPVX(tmpstr)); + } + DIE("Not a format reference"); + } + + return doform(cv,gv,op->op_next); +} + +PP(pp_leavewrite) +{ + dSP; + GV *gv = cxstack[cxstack_ix].blk_sub.gv; + register IO *io = GvIOp(gv); + FILE *ofp = IoOFP(io); + FILE *fp; + SV **newsp; + 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) + { + if (!IoTOP_GV(io)) { + GV *topgv; + char tmpbuf[256]; + + if (!IoTOP_NAME(io)) { + if (!IoFMT_NAME(io)) + IoFMT_NAME(io) = savepv(GvNAME(gv)); + sprintf(tmpbuf, "%s_TOP", IoFMT_NAME(io)); + topgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVFM); + if ((topgv && GvFORM(topgv)) || + !gv_fetchpv("top",FALSE,SVt_PVFM)) + IoTOP_NAME(io) = savepv(tmpbuf); + else + IoTOP_NAME(io) = savepv("top"); + } + topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM); + if (!topgv || !GvFORM(topgv)) { + IoLINES_LEFT(io) = 100000000; + goto forget_top; + } + IoTOP_GV(io) = topgv; + } + if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) + fwrite1(SvPVX(formfeed), SvCUR(formfeed), 1, ofp); + IoLINES_LEFT(io) = IoPAGE_LEN(io); + IoPAGE(io)++; + formtarget = toptarget; + return doform(GvFORM(IoTOP_GV(io)),gv,op); + } + + forget_top: + POPBLOCK(cx,curpm); + POPFORMAT(cx); + LEAVE; + + fp = IoOFP(io); + if (!fp) { + if (dowarn) { + if (IoIFP(io)) + warn("Filehandle only opened for input"); + else + warn("Write on closed filehandle"); + } + PUSHs(&sv_no); + } + else { + if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) { + if (dowarn) + warn("page overflow"); + } + if (!fwrite1(SvPVX(formtarget), 1, SvCUR(formtarget), ofp) || + ferror(fp)) + PUSHs(&sv_no); + else { + FmLINES(formtarget) = 0; + SvCUR_set(formtarget, 0); + if (IoFLAGS(io) & IOf_FLUSH) + (void)fflush(fp); + PUSHs(&sv_yes); + } + } + formtarget = bodytarget; + PUTBACK; + return pop_return(); +} + +PP(pp_prtf) +{ + dSP; dMARK; dORIGMARK; + GV *gv; + IO *io; + FILE *fp; + SV *sv = NEWSV(0,0); + + if (op->op_flags & OPf_STACKED) + gv = (GV*)*++MARK; + else + gv = defoutgv; + if (!(io = GvIO(gv))) { + if (dowarn) + warn("Filehandle %s never opened", GvNAME(gv)); + errno = EBADF; + goto just_say_no; + } + else if (!(fp = IoOFP(io))) { + if (dowarn) { + if (IoIFP(io)) + warn("Filehandle %s opened only for input", GvNAME(gv)); + else + warn("printf on closed filehandle %s", GvNAME(gv)); + } + errno = EBADF; + goto just_say_no; + } + else { + do_sprintf(sv, SP - MARK, MARK + 1); + if (!do_print(sv, fp)) + goto just_say_no; + + if (IoFLAGS(io) & IOf_FLUSH) + if (fflush(fp) == EOF) + goto just_say_no; + } + SvREFCNT_dec(sv); + SP = ORIGMARK; + PUSHs(&sv_yes); + RETURN; + + just_say_no: + SvREFCNT_dec(sv); + SP = ORIGMARK; + PUSHs(&sv_undef); + RETURN; +} + +PP(pp_sysread) +{ + dSP; dMARK; dORIGMARK; dTARGET; + int offset; + GV *gv; + IO *io; + char *buffer; + int length; + int bufsize; + SV *bufstr; + STRLEN blen; + + gv = (GV*)*++MARK; + if (!gv) + goto say_undef; + bufstr = *++MARK; + buffer = SvPV_force(bufstr, blen); + length = SvIVx(*++MARK); + if (length < 0) + DIE("Negative length"); + errno = 0; + if (MARK < SP) + offset = SvIVx(*++MARK); + else + offset = 0; + io = GvIO(gv); + if (!io || !IoIFP(io)) + goto say_undef; +#ifdef HAS_SOCKET + if (op->op_type == OP_RECV) { + bufsize = sizeof buf; + buffer = SvGROW(bufstr, length+1); + length = recvfrom(fileno(IoIFP(io)), buffer, length, offset, + (struct sockaddr *)buf, &bufsize); + if (length < 0) + RETPUSHUNDEF; + SvCUR_set(bufstr, length); + *SvEND(bufstr) = '\0'; + (void)SvPOK_only(bufstr); + SvSETMAGIC(bufstr); + if (tainting) + sv_magic(bufstr, Nullsv, 't', Nullch, 0); + SP = ORIGMARK; + sv_setpvn(TARG, buf, bufsize); + PUSHs(TARG); + RETURN; + } +#else + if (op->op_type == OP_RECV) + DIE(no_sock_func, "recv"); +#endif + buffer = SvGROW(bufstr, length+offset+1); + if (op->op_type == OP_SYSREAD) { + length = read(fileno(IoIFP(io)), buffer+offset, length); + } + else +#ifdef HAS_SOCKET__bad_code_maybe + if (IoTYPE(io) == 's') { + bufsize = sizeof buf; + length = recvfrom(fileno(IoIFP(io)), buffer+offset, length, 0, + (struct sockaddr *)buf, &bufsize); + } + else +#endif + length = fread(buffer+offset, 1, length, IoIFP(io)); + if (length < 0) + goto say_undef; + SvCUR_set(bufstr, length+offset); + *SvEND(bufstr) = '\0'; + (void)SvPOK_only(bufstr); + SvSETMAGIC(bufstr); + if (tainting) + sv_magic(bufstr, Nullsv, 't', Nullch, 0); + SP = ORIGMARK; + PUSHi(length); + RETURN; + + say_undef: + SP = ORIGMARK; + RETPUSHUNDEF; +} + +PP(pp_syswrite) +{ + return pp_send(ARGS); +} + +PP(pp_send) +{ + dSP; dMARK; dORIGMARK; dTARGET; + GV *gv; + IO *io; + int offset; + SV *bufstr; + char *buffer; + int length; + STRLEN blen; + + gv = (GV*)*++MARK; + if (!gv) + goto say_undef; + bufstr = *++MARK; + buffer = SvPV(bufstr, blen); + length = SvIVx(*++MARK); + if (length < 0) + DIE("Negative length"); + errno = 0; + io = GvIO(gv); + if (!io || !IoIFP(io)) { + length = -1; + if (dowarn) { + if (op->op_type == OP_SYSWRITE) + warn("Syswrite on closed filehandle"); + else + warn("Send on closed socket"); + } + } + else if (op->op_type == OP_SYSWRITE) { + if (MARK < SP) + offset = SvIVx(*++MARK); + else + offset = 0; + if (length > blen - offset) + length = blen - offset; + length = write(fileno(IoIFP(io)), buffer+offset, length); + } +#ifdef HAS_SOCKET + else if (SP > MARK) { + char *sockbuf; + STRLEN mlen; + sockbuf = SvPVx(*++MARK, mlen); + length = sendto(fileno(IoIFP(io)), buffer, blen, length, + (struct sockaddr *)sockbuf, mlen); + } + else + length = send(fileno(IoIFP(io)), buffer, blen, length); +#else + else + DIE(no_sock_func, "send"); +#endif + if (length < 0) + goto say_undef; + SP = ORIGMARK; + PUSHi(length); + RETURN; + + say_undef: + SP = ORIGMARK; + RETPUSHUNDEF; +} + +PP(pp_recv) +{ + return pp_sysread(ARGS); +} + +PP(pp_eof) +{ + dSP; + GV *gv; + + if (MAXARG <= 0) + gv = last_in_gv; + else + gv = last_in_gv = (GV*)POPs; + PUSHs(!gv || do_eof(gv) ? &sv_yes : &sv_no); + RETURN; +} + +PP(pp_tell) +{ + dSP; dTARGET; + GV *gv; + + if (MAXARG <= 0) + gv = last_in_gv; + else + gv = last_in_gv = (GV*)POPs; + PUSHi( do_tell(gv) ); + RETURN; +} + +PP(pp_seek) +{ + dSP; + GV *gv; + int whence = POPi; + long offset = POPl; + + gv = last_in_gv = (GV*)POPs; + PUSHs( do_seek(gv, offset, whence) ? &sv_yes : &sv_no ); + RETURN; +} + +PP(pp_truncate) +{ + dSP; + Off_t len = (Off_t)POPn; + int result = 1; + GV *tmpgv; + + errno = 0; +#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) +#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; + if (!errno) + errno = EBADF; + RETPUSHUNDEF; +#else + DIE("truncate not implemented"); +#endif +} + +PP(pp_fcntl) +{ + return pp_ioctl(ARGS); +} + +PP(pp_ioctl) +{ + dSP; dTARGET; + SV *argstr = POPs; + unsigned int func = U_I(POPn); + int optype = op->op_type; + char *s; + int retval; + GV *gv = (GV*)POPs; + IO *io = GvIOn(gv); + + if (!io || !argstr || !IoIFP(io)) { + errno = EBADF; /* well, sort of... */ + RETPUSHUNDEF; + } + + if (SvPOK(argstr) || !SvNIOK(argstr)) { + STRLEN len; + s = SvPV_force(argstr, len); + retval = IOCPARM_LEN(func); + if (len < retval) { + s = Sv_Grow(argstr, retval+1); + SvCUR_set(argstr, retval); + } + + s[SvCUR(argstr)] = 17; /* a little sanity check here */ + } + else { + retval = SvIV(argstr); +#ifdef DOSISH + s = (char*)(long)retval; /* ouch */ +#else + s = (char*)retval; /* ouch */ +#endif + } + + TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl"); + + if (optype == OP_IOCTL) +#ifdef HAS_IOCTL + retval = ioctl(fileno(IoIFP(io)), func, s); +#else + DIE("ioctl is not implemented"); +#endif + else +#ifdef DOSISH + DIE("fcntl is not implemented"); +#else +# ifdef HAS_FCNTL + retval = fcntl(fileno(IoIFP(io)), func, s); +# else + DIE("fcntl is not implemented"); +# endif +#endif + + if (SvPOK(argstr)) { + if (s[SvCUR(argstr)] != 17) + DIE("Possible memory corruption: %s overflowed 3rd argument", + op_name[optype]); + s[SvCUR(argstr)] = 0; /* put our null back */ + SvSETMAGIC(argstr); /* Assume it has changed */ + } + + if (retval == -1) + RETPUSHUNDEF; + if (retval != 0) { + PUSHi(retval); + } + else { + PUSHp("0 but true", 10); + } + RETURN; +} + +PP(pp_flock) +{ + dSP; dTARGET; + I32 value; + int argtype; + GV *gv; + FILE *fp; +#ifdef HAS_FLOCK + argtype = POPi; + if (MAXARG <= 0) + gv = last_in_gv; + else + gv = (GV*)POPs; + if (gv && GvIO(gv)) + fp = IoIFP(GvIOp(gv)); + else + fp = Nullfp; + if (fp) { + value = (I32)(flock(fileno(fp), argtype) >= 0); + } + else + value = 0; + PUSHi(value); + RETURN; +#else +# ifdef HAS_LOCKF + DIE(no_func, "flock()"); /* XXX emulate flock() with lockf()? */ +# else + DIE(no_func, "flock()"); +# endif +#endif +} + +/* Sockets. */ + +PP(pp_socket) +{ + dSP; +#ifdef HAS_SOCKET + GV *gv; + register IO *io; + int protocol = POPi; + int type = POPi; + int domain = POPi; + int fd; + + gv = (GV*)POPs; + + if (!gv) { + errno = EBADF; + RETPUSHUNDEF; + } + + io = GvIOn(gv); + if (IoIFP(io)) + do_close(gv, FALSE); + + TAINT_PROPER("socket"); + fd = socket(domain, type, protocol); + if (fd < 0) + RETPUSHUNDEF; + IoIFP(io) = fdopen(fd, "r"); /* stdio gets confused about sockets */ + IoOFP(io) = fdopen(fd, "w"); + IoTYPE(io) = 's'; + if (!IoIFP(io) || !IoOFP(io)) { + if (IoIFP(io)) fclose(IoIFP(io)); + if (IoOFP(io)) fclose(IoOFP(io)); + if (!IoIFP(io) && !IoOFP(io)) close(fd); + RETPUSHUNDEF; + } + + RETPUSHYES; +#else + DIE(no_sock_func, "socket"); +#endif +} + +PP(pp_sockpair) +{ + dSP; +#ifdef HAS_SOCKETPAIR + GV *gv1; + GV *gv2; + register IO *io1; + register IO *io2; + int protocol = POPi; + int type = POPi; + int domain = POPi; + int fd[2]; + + gv2 = (GV*)POPs; + gv1 = (GV*)POPs; + if (!gv1 || !gv2) + RETPUSHUNDEF; + + io1 = GvIOn(gv1); + io2 = GvIOn(gv2); + if (IoIFP(io1)) + do_close(gv1, FALSE); + if (IoIFP(io2)) + do_close(gv2, FALSE); + + TAINT_PROPER("socketpair"); + if (socketpair(domain, type, protocol, fd) < 0) + RETPUSHUNDEF; + IoIFP(io1) = fdopen(fd[0], "r"); + IoOFP(io1) = fdopen(fd[0], "w"); + IoTYPE(io1) = 's'; + IoIFP(io2) = fdopen(fd[1], "r"); + IoOFP(io2) = fdopen(fd[1], "w"); + IoTYPE(io2) = 's'; + if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { + if (IoIFP(io1)) fclose(IoIFP(io1)); + if (IoOFP(io1)) fclose(IoOFP(io1)); + if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]); + if (IoIFP(io2)) fclose(IoIFP(io2)); + if (IoOFP(io2)) fclose(IoOFP(io2)); + if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]); + RETPUSHUNDEF; + } + + RETPUSHYES; +#else + DIE(no_sock_func, "socketpair"); +#endif +} + +PP(pp_bind) +{ + dSP; +#ifdef HAS_SOCKET + SV *addrstr = POPs; + char *addr; + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + STRLEN len; + + if (!io || !IoIFP(io)) + goto nuts; + + addr = SvPV(addrstr, len); + TAINT_PROPER("bind"); + if (bind(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) + RETPUSHYES; + else + RETPUSHUNDEF; + +nuts: + if (dowarn) + warn("bind() on closed fd"); + errno = EBADF; + RETPUSHUNDEF; +#else + DIE(no_sock_func, "bind"); +#endif +} + +PP(pp_connect) +{ + dSP; +#ifdef HAS_SOCKET + SV *addrstr = POPs; + char *addr; + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + STRLEN len; + + if (!io || !IoIFP(io)) + goto nuts; + + addr = SvPV(addrstr, len); + TAINT_PROPER("connect"); + if (connect(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) + RETPUSHYES; + else + RETPUSHUNDEF; + +nuts: + if (dowarn) + warn("connect() on closed fd"); + errno = EBADF; + RETPUSHUNDEF; +#else + DIE(no_sock_func, "connect"); +#endif +} + +PP(pp_listen) +{ + dSP; +#ifdef HAS_SOCKET + int backlog = POPi; + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + + if (!io || !IoIFP(io)) + goto nuts; + + if (listen(fileno(IoIFP(io)), backlog) >= 0) + RETPUSHYES; + else + RETPUSHUNDEF; + +nuts: + if (dowarn) + warn("listen() on closed fd"); + errno = EBADF; + RETPUSHUNDEF; +#else + DIE(no_sock_func, "listen"); +#endif +} + +PP(pp_accept) +{ + dSP; dTARGET; +#ifdef HAS_SOCKET + GV *ngv; + GV *ggv; + register IO *nstio; + register IO *gstio; + int len = sizeof buf; + int fd; + + ggv = (GV*)POPs; + ngv = (GV*)POPs; + + if (!ngv) + goto badexit; + if (!ggv) + goto nuts; + + gstio = GvIO(ggv); + if (!gstio || !IoIFP(gstio)) + goto nuts; + + nstio = GvIOn(ngv); + if (IoIFP(nstio)) + do_close(ngv, FALSE); + + fd = accept(fileno(IoIFP(gstio)), (struct sockaddr *)buf, &len); + if (fd < 0) + goto badexit; + IoIFP(nstio) = fdopen(fd, "r"); + IoOFP(nstio) = fdopen(fd, "w"); + IoTYPE(nstio) = 's'; + if (!IoIFP(nstio) || !IoOFP(nstio)) { + if (IoIFP(nstio)) fclose(IoIFP(nstio)); + if (IoOFP(nstio)) fclose(IoOFP(nstio)); + if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd); + goto badexit; + } + + PUSHp(buf, len); + RETURN; + +nuts: + if (dowarn) + warn("accept() on closed fd"); + errno = EBADF; + +badexit: + RETPUSHUNDEF; + +#else + DIE(no_sock_func, "accept"); +#endif +} + +PP(pp_shutdown) +{ + dSP; dTARGET; +#ifdef HAS_SOCKET + int how = POPi; + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + + if (!io || !IoIFP(io)) + goto nuts; + + PUSHi( shutdown(fileno(IoIFP(io)), how) >= 0 ); + RETURN; + +nuts: + if (dowarn) + warn("shutdown() on closed fd"); + errno = EBADF; + RETPUSHUNDEF; +#else + DIE(no_sock_func, "shutdown"); +#endif +} + +PP(pp_gsockopt) +{ +#ifdef HAS_SOCKET + return pp_ssockopt(ARGS); +#else + DIE(no_sock_func, "getsockopt"); +#endif +} + +PP(pp_ssockopt) +{ + dSP; +#ifdef HAS_SOCKET + int optype = op->op_type; + SV *sv; + int fd; + unsigned int optname; + unsigned int lvl; + GV *gv; + register IO *io; + + if (optype == OP_GSOCKOPT) + sv = sv_2mortal(NEWSV(22, 257)); + else + sv = POPs; + optname = (unsigned int) POPi; + lvl = (unsigned int) POPi; + + gv = (GV*)POPs; + io = GvIOn(gv); + if (!io || !IoIFP(io)) + goto nuts; + + fd = fileno(IoIFP(io)); + switch (optype) { + case OP_GSOCKOPT: + SvGROW(sv, 256); + (void)SvPOK_only(sv); + if (getsockopt(fd, lvl, optname, SvPVX(sv), (int*)&SvCUR(sv)) < 0) + goto nuts2; + PUSHs(sv); + break; + case OP_SSOCKOPT: { + int aint; + STRLEN len = 0; + char *buf = 0; + if (SvPOKp(sv)) + buf = SvPV(sv, len); + else if (SvOK(sv)) { + aint = (int)SvIV(sv); + buf = (char*)&aint; + len = sizeof(int); + } + if (setsockopt(fd, lvl, optname, buf, (int)len) < 0) + goto nuts2; + PUSHs(&sv_yes); + } + break; + } + RETURN; + +nuts: + if (dowarn) + warn("[gs]etsockopt() on closed fd"); + errno = EBADF; +nuts2: + RETPUSHUNDEF; + +#else + DIE(no_sock_func, "setsockopt"); +#endif +} + +PP(pp_getsockname) +{ +#ifdef HAS_SOCKET + return pp_getpeername(ARGS); +#else + DIE(no_sock_func, "getsockname"); +#endif +} + +PP(pp_getpeername) +{ + dSP; +#ifdef HAS_SOCKET + int optype = op->op_type; + SV *sv; + int fd; + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + + if (!io || !IoIFP(io)) + goto nuts; + + sv = sv_2mortal(NEWSV(22, 257)); + SvCUR_set(sv, 256); + SvPOK_on(sv); + fd = fileno(IoIFP(io)); + switch (optype) { + case OP_GETSOCKNAME: + if (getsockname(fd, (struct sockaddr *)SvPVX(sv), (int*)&SvCUR(sv)) < 0) + goto nuts2; + break; + case OP_GETPEERNAME: + if (getpeername(fd, (struct sockaddr *)SvPVX(sv), (int*)&SvCUR(sv)) < 0) + goto nuts2; + break; + } + PUSHs(sv); + RETURN; + +nuts: + if (dowarn) + warn("get{sock, peer}name() on closed fd"); + errno = EBADF; +nuts2: + RETPUSHUNDEF; + +#else + DIE(no_sock_func, "getpeername"); +#endif +} + +/* Stat calls. */ + +PP(pp_lstat) +{ + return pp_stat(ARGS); +} + +PP(pp_stat) +{ + dSP; + GV *tmpgv; + I32 max = 13; + + if (op->op_flags & OPf_REF) { + tmpgv = cGVOP->op_gv; + if (tmpgv != defgv) { + laststype = OP_STAT; + statgv = tmpgv; + sv_setpv(statname, ""); + if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || + Fstat(fileno(IoIFP(GvIOn(tmpgv))), &statcache) < 0) { + max = 0; + laststatval = -1; + } + } + else if (laststatval < 0) + max = 0; + } + else { + sv_setpv(statname, POPp); + statgv = Nullgv; +#ifdef HAS_LSTAT + laststype = op->op_type; + if (op->op_type == OP_LSTAT) + laststatval = lstat(SvPV(statname, na), &statcache); + else +#endif + laststatval = Stat(SvPV(statname, na), &statcache); + if (laststatval < 0) { + if (dowarn && strchr(SvPV(statname, na), '\n')) + warn(warn_nl, "stat"); + max = 0; + } + } + + EXTEND(SP, 13); + if (GIMME != G_ARRAY) { + if (max) + RETPUSHYES; + else + RETPUSHUNDEF; + } + if (max) { + PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_size))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime))); +#ifdef USE_STAT_BLOCKS + PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize))); + PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks))); +#else + PUSHs(sv_2mortal(newSVpv("", 0))); + PUSHs(sv_2mortal(newSVpv("", 0))); +#endif + } + RETURN; +} + +PP(pp_ftrread) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (cando(S_IRUSR, 0, &statcache)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftrwrite) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (cando(S_IWUSR, 0, &statcache)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftrexec) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (cando(S_IXUSR, 0, &statcache)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_fteread) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (cando(S_IRUSR, 1, &statcache)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftewrite) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (cando(S_IWUSR, 1, &statcache)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_fteexec) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (cando(S_IXUSR, 1, &statcache)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftis) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + RETPUSHYES; +} + +PP(pp_fteowned) +{ + return pp_ftrowned(ARGS); +} + +PP(pp_ftrowned) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) ) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftzero) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (!statcache.st_size) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftsize) +{ + I32 result = my_stat(ARGS); + dSP; dTARGET; + if (result < 0) + RETPUSHUNDEF; + PUSHi(statcache.st_size); + RETURN; +} + +PP(pp_ftmtime) +{ + I32 result = my_stat(ARGS); + dSP; dTARGET; + if (result < 0) + RETPUSHUNDEF; + PUSHn( (basetime - statcache.st_mtime) / 86400.0 ); + RETURN; +} + +PP(pp_ftatime) +{ + I32 result = my_stat(ARGS); + dSP; dTARGET; + if (result < 0) + RETPUSHUNDEF; + PUSHn( (basetime - statcache.st_atime) / 86400.0 ); + RETURN; +} + +PP(pp_ftctime) +{ + I32 result = my_stat(ARGS); + dSP; dTARGET; + if (result < 0) + RETPUSHUNDEF; + PUSHn( (basetime - statcache.st_ctime) / 86400.0 ); + RETURN; +} + +PP(pp_ftsock) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (S_ISSOCK(statcache.st_mode)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftchr) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (S_ISCHR(statcache.st_mode)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftblk) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (S_ISBLK(statcache.st_mode)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftfile) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (S_ISREG(statcache.st_mode)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftdir) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (S_ISDIR(statcache.st_mode)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftpipe) +{ + I32 result = my_stat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (S_ISFIFO(statcache.st_mode)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftlink) +{ + I32 result = my_lstat(ARGS); + dSP; + if (result < 0) + RETPUSHUNDEF; + if (S_ISLNK(statcache.st_mode)) + RETPUSHYES; + RETPUSHNO; +} + +PP(pp_ftsuid) +{ + dSP; +#ifdef S_ISUID + I32 result = my_stat(ARGS); + SPAGAIN; + if (result < 0) + RETPUSHUNDEF; + if (statcache.st_mode & S_ISUID) + RETPUSHYES; +#endif + RETPUSHNO; +} + +PP(pp_ftsgid) +{ + dSP; +#ifdef S_ISGID + I32 result = my_stat(ARGS); + SPAGAIN; + if (result < 0) + RETPUSHUNDEF; + if (statcache.st_mode & S_ISGID) + RETPUSHYES; +#endif + RETPUSHNO; +} + +PP(pp_ftsvtx) +{ + dSP; +#ifdef S_ISVTX + I32 result = my_stat(ARGS); + SPAGAIN; + if (result < 0) + RETPUSHUNDEF; + if (statcache.st_mode & S_ISVTX) + RETPUSHYES; +#endif + RETPUSHNO; +} + +PP(pp_fttty) +{ + dSP; + int fd; + GV *gv; + char *tmps; + if (op->op_flags & OPf_REF) { + gv = cGVOP->op_gv; + tmps = ""; + } + else + gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO); + if (GvIO(gv) && IoIFP(GvIOp(gv))) + fd = fileno(IoIFP(GvIOp(gv))); + else if (isDIGIT(*tmps)) + fd = atoi(tmps); + else + RETPUSHUNDEF; + if (isatty(fd)) + RETPUSHYES; + RETPUSHNO; +} + +#if defined(USE_STD_STDIO) || defined(atarist) /* this will work with atariST */ +# define FBASE(f) ((f)->_base) +# define FSIZE(f) ((f)->_cnt + ((f)->_ptr - (f)->_base)) +# define FPTR(f) ((f)->_ptr) +# define FCOUNT(f) ((f)->_cnt) +#else +# if defined(USE_LINUX_STDIO) +# define FBASE(f) ((f)->_IO_read_base) +# define FSIZE(f) ((f)->_IO_read_end - FBASE(f)) +# define FPTR(f) ((f)->_IO_read_ptr) +# define FCOUNT(f) ((f)->_IO_read_end - FPTR(f)) +# endif +#endif + +PP(pp_fttext) +{ + dSP; + I32 i; + I32 len; + I32 odd = 0; + STDCHAR tbuf[512]; + register STDCHAR *s; + register IO *io; + SV *sv; + + if (op->op_flags & OPf_REF) { + EXTEND(SP, 1); + if (cGVOP->op_gv == defgv) { + if (statgv) + io = GvIO(statgv); + else { + sv = statname; + goto really_filename; + } + } + else { + statgv = cGVOP->op_gv; + sv_setpv(statname, ""); + io = GvIO(statgv); + } + if (io && IoIFP(io)) { +#ifdef FBASE + Fstat(fileno(IoIFP(io)), &statcache); + if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */ + if (op->op_type == OP_FTTEXT) + RETPUSHNO; + else + RETPUSHYES; + if (FCOUNT(IoIFP(io)) <= 0) { + i = getc(IoIFP(io)); + if (i != EOF) + (void)ungetc(i, IoIFP(io)); + } + if (FCOUNT(IoIFP(io)) <= 0) /* null file is anything */ + RETPUSHYES; + len = FSIZE(IoIFP(io)); + s = FBASE(IoIFP(io)); +#else + DIE("-T and -B not implemented on filehandles"); +#endif + } + else { + if (dowarn) + warn("Test on unopened file <%s>", + GvENAME(cGVOP->op_gv)); + errno = EBADF; + RETPUSHUNDEF; + } + } + else { + sv = POPs; + statgv = Nullgv; + sv_setpv(statname, SvPV(sv, na)); + really_filename: +#ifdef HAS_OPEN3 + i = open(SvPV(sv, na), O_RDONLY, 0); +#else + i = open(SvPV(sv, na), 0); +#endif + if (i < 0) { + if (dowarn && strchr(SvPV(sv, na), '\n')) + warn(warn_nl, "open"); + RETPUSHUNDEF; + } + Fstat(i, &statcache); + len = read(i, tbuf, 512); + (void)close(i); + if (len <= 0) { + if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT) + RETPUSHNO; /* special case NFS directories */ + RETPUSHYES; /* null file is anything */ + } + s = tbuf; + } + + /* now scan s to look for textiness */ + + for (i = 0; i < len; i++, s++) { + if (!*s) { /* null never allowed in text */ + odd += len; + break; + } + else if (*s & 128) + odd++; + else if (*s < 32 && + *s != '\n' && *s != '\r' && *s != '\b' && + *s != '\t' && *s != '\f' && *s != 27) + odd++; + } + + if ((odd * 30 > len) == (op->op_type == OP_FTTEXT)) /* allow 30% odd */ + RETPUSHNO; + else + RETPUSHYES; +} + +PP(pp_ftbinary) +{ + return pp_fttext(ARGS); +} + +/* File calls. */ + +PP(pp_chdir) +{ + dSP; dTARGET; + char *tmps; + SV **svp; + + if (MAXARG < 1) + tmps = Nullch; + else + tmps = POPp; + if (!tmps || !*tmps) { + svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE); + if (svp) + tmps = SvPV(*svp, na); + } + if (!tmps || !*tmps) { + svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE); + if (svp) + tmps = SvPV(*svp, na); + } + TAINT_PROPER("chdir"); + PUSHi( chdir(tmps) >= 0 ); + RETURN; +} + +PP(pp_chown) +{ + dSP; dMARK; dTARGET; + I32 value; +#ifdef HAS_CHOWN + value = (I32)apply(op->op_type, MARK, SP); + SP = MARK; + PUSHi(value); + RETURN; +#else + DIE(no_func, "Unsupported function chown"); +#endif +} + +PP(pp_chroot) +{ + dSP; dTARGET; + char *tmps; +#ifdef HAS_CHROOT + tmps = POPp; + TAINT_PROPER("chroot"); + PUSHi( chroot(tmps) >= 0 ); + RETURN; +#else + DIE(no_func, "chroot"); +#endif +} + +PP(pp_unlink) +{ + dSP; dMARK; dTARGET; + I32 value; + value = (I32)apply(op->op_type, MARK, SP); + SP = MARK; + PUSHi(value); + RETURN; +} + +PP(pp_chmod) +{ + dSP; dMARK; dTARGET; + I32 value; + value = (I32)apply(op->op_type, MARK, SP); + SP = MARK; + PUSHi(value); + RETURN; +} + +PP(pp_utime) +{ + dSP; dMARK; dTARGET; + I32 value; + value = (I32)apply(op->op_type, MARK, SP); + SP = MARK; + PUSHi(value); + RETURN; +} + +PP(pp_rename) +{ + dSP; dTARGET; + int anum; + + char *tmps2 = POPp; + char *tmps = SvPV(TOPs, na); + TAINT_PROPER("rename"); +#ifdef HAS_RENAME + anum = rename(tmps, tmps2); +#else + if (same_dirent(tmps2, tmps)) /* can always rename to same name */ + anum = 1; + else { + if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) + (void)UNLINK(tmps2); + if (!(anum = link(tmps, tmps2))) + anum = UNLINK(tmps); + } +#endif + SETi( anum >= 0 ); + RETURN; +} + +PP(pp_link) +{ + dSP; dTARGET; +#ifdef HAS_LINK + char *tmps2 = POPp; + char *tmps = SvPV(TOPs, na); + TAINT_PROPER("link"); + SETi( link(tmps, tmps2) >= 0 ); +#else + DIE(no_func, "Unsupported function link"); +#endif + RETURN; +} + +PP(pp_symlink) +{ + dSP; dTARGET; +#ifdef HAS_SYMLINK + char *tmps2 = POPp; + char *tmps = SvPV(TOPs, na); + TAINT_PROPER("symlink"); + SETi( symlink(tmps, tmps2) >= 0 ); + RETURN; +#else + DIE(no_func, "symlink"); +#endif +} + +PP(pp_readlink) +{ + dSP; dTARGET; +#ifdef HAS_SYMLINK + char *tmps; + int len; + tmps = POPp; + len = readlink(tmps, buf, sizeof buf); + EXTEND(SP, 1); + if (len < 0) + RETPUSHUNDEF; + PUSHp(buf, len); + RETURN; +#else + EXTEND(SP, 1); + RETSETUNDEF; /* just pretend it's a normal file */ +#endif +} + +#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) +static int +dooneliner(cmd, filename) +char *cmd; +char *filename; +{ + char mybuf[8192]; + char *s, *tmps; + int anum = 1; + FILE *myfp; + + strcpy(mybuf, cmd); + strcat(mybuf, " "); + for (s = mybuf+strlen(mybuf); *filename; ) { + *s++ = '\\'; + *s++ = *filename++; + } + strcpy(s, " 2>&1"); + myfp = my_popen(mybuf, "r"); + if (myfp) { + *mybuf = '\0'; + s = fgets(mybuf, sizeof mybuf, myfp); + (void)my_pclose(myfp); + if (s != Nullch) { + for (errno = 1; errno < sys_nerr; errno++) { +#ifdef HAS_SYS_ERRLIST + if (instr(mybuf, sys_errlist[errno])) /* you don't see this */ + return 0; +#else + char *errmsg; /* especially if it isn't there */ + + if (instr(mybuf, + (errmsg = strerror(errno)) ? errmsg : "NoErRoR")) + return 0; +#endif + } + errno = 0; +#ifndef EACCES +#define EACCES EPERM +#endif + if (instr(mybuf, "cannot make")) + errno = EEXIST; + else if (instr(mybuf, "existing file")) + errno = EEXIST; + else if (instr(mybuf, "ile exists")) + errno = EEXIST; + else if (instr(mybuf, "non-exist")) + errno = ENOENT; + else if (instr(mybuf, "does not exist")) + errno = ENOENT; + else if (instr(mybuf, "not empty")) + errno = EBUSY; + else if (instr(mybuf, "cannot access")) + errno = EACCES; + else + errno = EPERM; + return 0; + } + else { /* some mkdirs return no failure indication */ + anum = (Stat(filename, &statbuf) >= 0); + if (op->op_type == OP_RMDIR) + anum = !anum; + if (anum) + errno = 0; + else + errno = EACCES; /* a guess */ + } + return anum; + } + else + return 0; +} +#endif + +PP(pp_mkdir) +{ + dSP; dTARGET; + int mode = POPi; +#ifndef HAS_MKDIR + int oldumask; +#endif + char *tmps = SvPV(TOPs, na); + + TAINT_PROPER("mkdir"); +#ifdef HAS_MKDIR + SETi( mkdir(tmps, mode) >= 0 ); +#else + SETi( dooneliner("mkdir", tmps) ); + oldumask = umask(0); + umask(oldumask); + chmod(tmps, (mode & ~oldumask) & 0777); +#endif + RETURN; +} + +PP(pp_rmdir) +{ + dSP; dTARGET; + char *tmps; + + tmps = POPp; + TAINT_PROPER("rmdir"); +#ifdef HAS_RMDIR + XPUSHi( rmdir(tmps) >= 0 ); +#else + XPUSHi( dooneliner("rmdir", tmps) ); +#endif + RETURN; +} + +/* Directory calls. */ + +PP(pp_open_dir) +{ + dSP; +#if defined(Direntry_t) && defined(HAS_READDIR) + char *dirname = POPp; + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + + if (!io) + goto nope; + + if (IoDIRP(io)) + closedir(IoDIRP(io)); + if (!(IoDIRP(io) = opendir(dirname))) + goto nope; + + RETPUSHYES; +nope: + if (!errno) + errno = EBADF; + RETPUSHUNDEF; +#else + DIE(no_dir_func, "opendir"); +#endif +} + +PP(pp_readdir) +{ + dSP; +#if defined(Direntry_t) && defined(HAS_READDIR) +#ifndef I_DIRENT + Direntry_t *readdir _((DIR *)); +#endif + register Direntry_t *dp; + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + + if (!io || !IoDIRP(io)) + goto nope; + + if (GIMME == G_ARRAY) { + /*SUPPRESS 560*/ + while (dp = (Direntry_t *)readdir(IoDIRP(io))) { +#ifdef DIRNAMLEN + XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen))); +#else + XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0))); +#endif + } + } + else { + if (!(dp = (Direntry_t *)readdir(IoDIRP(io)))) + goto nope; +#ifdef DIRNAMLEN + XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen))); +#else + XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0))); +#endif + } + RETURN; + +nope: + if (!errno) + errno = EBADF; + if (GIMME == G_ARRAY) + RETURN; + else + RETPUSHUNDEF; +#else + DIE(no_dir_func, "readdir"); +#endif +} + +PP(pp_telldir) +{ + dSP; dTARGET; +#if defined(HAS_TELLDIR) || defined(telldir) +#if !defined(telldir) && !defined(HAS_TELLDIR_PROTOTYPE) + long telldir _((DIR *)); +#endif + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + + if (!io || !IoDIRP(io)) + goto nope; + + PUSHi( telldir(IoDIRP(io)) ); + RETURN; +nope: + if (!errno) + errno = EBADF; + RETPUSHUNDEF; +#else + DIE(no_dir_func, "telldir"); +#endif +} + +PP(pp_seekdir) +{ + dSP; +#if defined(HAS_SEEKDIR) || defined(seekdir) + long along = POPl; + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + + if (!io || !IoDIRP(io)) + goto nope; + + (void)seekdir(IoDIRP(io), along); + + RETPUSHYES; +nope: + if (!errno) + errno = EBADF; + RETPUSHUNDEF; +#else + DIE(no_dir_func, "seekdir"); +#endif +} + +PP(pp_rewinddir) +{ + dSP; +#if defined(HAS_REWINDDIR) || defined(rewinddir) + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + + if (!io || !IoDIRP(io)) + goto nope; + + (void)rewinddir(IoDIRP(io)); + RETPUSHYES; +nope: + if (!errno) + errno = EBADF; + RETPUSHUNDEF; +#else + DIE(no_dir_func, "rewinddir"); +#endif +} + +PP(pp_closedir) +{ + dSP; +#if defined(Direntry_t) && defined(HAS_READDIR) + GV *gv = (GV*)POPs; + register IO *io = GvIOn(gv); + + if (!io || !IoDIRP(io)) + goto nope; + +#ifdef VOID_CLOSEDIR + closedir(IoDIRP(io)); +#else + if (closedir(IoDIRP(io)) < 0) + goto nope; +#endif + IoDIRP(io) = 0; + + RETPUSHYES; +nope: + if (!errno) + errno = EBADF; + RETPUSHUNDEF; +#else + DIE(no_dir_func, "closedir"); +#endif +} + +/* Process control. */ + +PP(pp_fork) +{ + dSP; dTARGET; + int childpid; + GV *tmpgv; + + EXTEND(SP, 1); +#ifdef HAS_FORK + childpid = fork(); + if (childpid < 0) + RETSETUNDEF; + if (!childpid) { + /*SUPPRESS 560*/ + if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) + sv_setiv(GvSV(tmpgv), (I32)getpid()); + hv_clear(pidstatus); /* no kids, so don't wait for 'em */ + } + PUSHi(childpid); + RETURN; +#else + DIE(no_func, "Unsupported function fork"); +#endif +} + +PP(pp_wait) +{ + dSP; dTARGET; + int childpid; + int argflags; + I32 value; + + EXTEND(SP, 1); +#ifdef HAS_WAIT + childpid = wait(&argflags); + if (childpid > 0) + pidgone(childpid, argflags); + value = (I32)childpid; + statusvalue = (U16)argflags; + PUSHi(value); + RETURN; +#else + DIE(no_func, "Unsupported function wait"); +#endif +} + +PP(pp_waitpid) +{ + dSP; dTARGET; + int childpid; + int optype; + int argflags; + I32 value; + +#ifdef HAS_WAIT + optype = POPi; + childpid = TOPi; + childpid = wait4pid(childpid, &argflags, optype); + value = (I32)childpid; + statusvalue = (U16)argflags; + SETi(value); + RETURN; +#else + DIE(no_func, "Unsupported function wait"); +#endif +} + +PP(pp_system) +{ + dSP; dMARK; dORIGMARK; dTARGET; + I32 value; + int childpid; + int result; + int status; + VOIDRET (*ihand)(); /* place to save signal during system() */ + VOIDRET (*qhand)(); /* place to save signal during system() */ + +#if defined(HAS_FORK) && !defined(VMS) + if (SP - MARK == 1) { + if (tainting) { + char *junk = SvPV(TOPs, na); + TAINT_ENV(); + TAINT_PROPER("system"); + } + } + while ((childpid = vfork()) == -1) { + if (errno != EAGAIN) { + value = -1; + SP = ORIGMARK; + PUSHi(value); + RETURN; + } + sleep(5); + } + if (childpid > 0) { + ihand = signal(SIGINT, SIG_IGN); + qhand = signal(SIGQUIT, SIG_IGN); + result = wait4pid(childpid, &status, 0); + (void)signal(SIGINT, ihand); + (void)signal(SIGQUIT, qhand); + statusvalue = (U16)status; + if (result < 0) + value = -1; + else { + value = (I32)((unsigned int)status & 0xffff); + } + do_execfree(); /* free any memory child malloced on vfork */ + SP = ORIGMARK; + PUSHi(value); + RETURN; + } + if (op->op_flags & OPf_STACKED) { + SV *really = *++MARK; + value = (I32)do_aexec(really, MARK, SP); + } + else if (SP - MARK != 1) + value = (I32)do_aexec(Nullsv, MARK, SP); + else { + value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na)); + } + _exit(-1); +#else /* ! FORK or VMS */ + if (op->op_flags & OPf_STACKED) { + SV *really = *++MARK; + value = (I32)do_aspawn(really, MARK, SP); + } + else if (SP - MARK != 1) + value = (I32)do_aspawn(Nullsv, MARK, SP); + else { + value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na)); + } + do_execfree(); + SP = ORIGMARK; + PUSHi(value); +#endif /* !FORK or VMS */ + RETURN; +} + +PP(pp_exec) +{ + dSP; dMARK; dORIGMARK; dTARGET; + I32 value; + + if (op->op_flags & OPf_STACKED) { + SV *really = *++MARK; + value = (I32)do_aexec(really, MARK, SP); + } + else if (SP - MARK != 1) +#ifdef VMS + value = (I32)vms_do_aexec(Nullsv, MARK, SP); +#else + value = (I32)do_aexec(Nullsv, MARK, SP); +#endif + else { + if (tainting) { + char *junk = SvPV(*SP, na); + TAINT_ENV(); + TAINT_PROPER("exec"); + } +#ifdef VMS + value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), na)); +#else + value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na)); +#endif + } + SP = ORIGMARK; + PUSHi(value); + RETURN; +} + +PP(pp_kill) +{ + dSP; dMARK; dTARGET; + I32 value; +#ifdef HAS_KILL + value = (I32)apply(op->op_type, MARK, SP); + SP = MARK; + PUSHi(value); + RETURN; +#else + DIE(no_func, "Unsupported function kill"); +#endif +} + +PP(pp_getppid) +{ +#ifdef HAS_GETPPID + dSP; dTARGET; + XPUSHi( getppid() ); + RETURN; +#else + DIE(no_func, "getppid"); +#endif +} + +PP(pp_getpgrp) +{ +#ifdef HAS_GETPGRP + dSP; dTARGET; + int pid; + I32 value; + + if (MAXARG < 1) + pid = 0; + else + pid = SvIVx(POPs); +#ifdef USE_BSDPGRP + value = (I32)getpgrp(pid); +#else + if (pid != 0) + DIE("POSIX getpgrp can't take an argument"); + value = (I32)getpgrp(); +#endif + XPUSHi(value); + RETURN; +#else + DIE(no_func, "getpgrp()"); +#endif +} + +PP(pp_setpgrp) +{ +#ifdef HAS_SETPGRP + dSP; dTARGET; + int pgrp; + int pid; + if (MAXARG < 2) { + pgrp = 0; + pid = 0; + } + else { + pgrp = POPi; + pid = TOPi; + } + + TAINT_PROPER("setpgrp"); +#ifdef USE_BSDPGRP + SETi( setpgrp(pid, pgrp) >= 0 ); +#else + if ((pgrp != 0) || (pid != 0)) { + DIE("POSIX setpgrp can't take an argument"); + } + SETi( setpgrp() >= 0 ); +#endif /* USE_BSDPGRP */ + RETURN; +#else + DIE(no_func, "setpgrp()"); +#endif +} + +PP(pp_getpriority) +{ + dSP; dTARGET; + int which; + int who; +#ifdef HAS_GETPRIORITY + who = POPi; + which = TOPi; + SETi( getpriority(which, who) ); + RETURN; +#else + DIE(no_func, "getpriority()"); +#endif +} + +PP(pp_setpriority) +{ + dSP; dTARGET; + int which; + int who; + int niceval; +#ifdef HAS_SETPRIORITY + niceval = POPi; + who = POPi; + which = TOPi; + TAINT_PROPER("setpriority"); + SETi( setpriority(which, who, niceval) >= 0 ); + RETURN; +#else + DIE(no_func, "setpriority()"); +#endif +} + +/* Time calls. */ + +PP(pp_time) +{ + dSP; dTARGET; + XPUSHi( time(Null(Time_t*)) ); + RETURN; +} + +#ifndef HZ +#define HZ 60 +#endif + +PP(pp_tms) +{ + dSP; + +#if defined(MSDOS) || !defined(HAS_TIMES) + DIE("times not implemented"); +#else + EXTEND(SP, 4); + +#ifndef VMS + (void)times(×buf); +#else + (void)times((tbuffer_t *)×buf); /* time.h uses different name for */ + /* struct tms, though same data */ + /* is returned. */ +#endif + + PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ))); + if (GIMME == G_ARRAY) { + PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ))); + PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ))); + PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ))); + } + RETURN; +#endif /* MSDOS */ +} + +PP(pp_localtime) +{ + return pp_gmtime(ARGS); +} + +PP(pp_gmtime) +{ + dSP; + Time_t when; + struct tm *tmbuf; + static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; + static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; + + if (MAXARG < 1) + (void)time(&when); + else + when = (Time_t)SvIVx(POPs); + + if (op->op_type == OP_LOCALTIME) + tmbuf = localtime(&when); + else + tmbuf = gmtime(&when); + + EXTEND(SP, 9); + if (GIMME != G_ARRAY) { + dTARGET; + char mybuf[30]; + if (!tmbuf) + RETPUSHUNDEF; + sprintf(mybuf, "%s %s %2d %02d:%02d:%02d %d", + dayname[tmbuf->tm_wday], + monname[tmbuf->tm_mon], + tmbuf->tm_mday, + tmbuf->tm_hour, + tmbuf->tm_min, + tmbuf->tm_sec, + tmbuf->tm_year + 1900); + PUSHp(mybuf, strlen(mybuf)); + } + else if (tmbuf) { + PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec))); + PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min))); + PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour))); + PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday))); + PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon))); + PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year))); + PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday))); + PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday))); + PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst))); + } + RETURN; +} + +PP(pp_alarm) +{ + dSP; dTARGET; + int anum; +#ifdef HAS_ALARM + anum = POPi; + anum = alarm((unsigned int)anum); + EXTEND(SP, 1); + if (anum < 0) + RETPUSHUNDEF; + PUSHi((I32)anum); + RETURN; +#else + DIE(no_func, "Unsupported function alarm"); + break; +#endif +} + +PP(pp_sleep) +{ + dSP; dTARGET; + I32 duration; + Time_t lasttime; + Time_t when; + + (void)time(&lasttime); + if (MAXARG < 1) + pause(); + else { + duration = POPi; + sleep((unsigned int)duration); + } + (void)time(&when); + XPUSHi(when - lasttime); + RETURN; +} + +/* Shared memory. */ + +PP(pp_shmget) +{ + return pp_semget(ARGS); +} + +PP(pp_shmctl) +{ + return pp_semctl(ARGS); +} + +PP(pp_shmread) +{ + return pp_shmwrite(ARGS); +} + +PP(pp_shmwrite) +{ +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) + dSP; dMARK; dTARGET; + I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0); + SP = MARK; + PUSHi(value); + RETURN; +#else + pp_semget(ARGS); +#endif +} + +/* Message passing. */ + +PP(pp_msgget) +{ + return pp_semget(ARGS); +} + +PP(pp_msgctl) +{ + return pp_semctl(ARGS); +} + +PP(pp_msgsnd) +{ +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) + dSP; dMARK; dTARGET; + I32 value = (I32)(do_msgsnd(MARK, SP) >= 0); + SP = MARK; + PUSHi(value); + RETURN; +#else + pp_semget(ARGS); +#endif +} + +PP(pp_msgrcv) +{ +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) + dSP; dMARK; dTARGET; + I32 value = (I32)(do_msgrcv(MARK, SP) >= 0); + SP = MARK; + PUSHi(value); + RETURN; +#else + pp_semget(ARGS); +#endif +} + +/* Semaphores. */ + +PP(pp_semget) +{ +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) + dSP; dMARK; dTARGET; + int anum = do_ipcget(op->op_type, MARK, SP); + SP = MARK; + if (anum == -1) + RETPUSHUNDEF; + PUSHi(anum); + RETURN; +#else + DIE("System V IPC is not implemented on this machine"); +#endif +} + +PP(pp_semctl) +{ +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) + dSP; dMARK; dTARGET; + int anum = do_ipcctl(op->op_type, MARK, SP); + SP = MARK; + if (anum == -1) + RETSETUNDEF; + if (anum != 0) { + PUSHi(anum); + } + else { + PUSHp("0 but true",10); + } + RETURN; +#else + pp_semget(ARGS); +#endif +} + +PP(pp_semop) +{ +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) + dSP; dMARK; dTARGET; + I32 value = (I32)(do_semop(MARK, SP) >= 0); + SP = MARK; + PUSHi(value); + RETURN; +#else + pp_semget(ARGS); +#endif +} + +/* Get system info. */ + +PP(pp_ghbyname) +{ +#ifdef HAS_SOCKET + return pp_ghostent(ARGS); +#else + DIE(no_sock_func, "gethostbyname"); +#endif +} + +PP(pp_ghbyaddr) +{ +#ifdef HAS_SOCKET + return pp_ghostent(ARGS); +#else + DIE(no_sock_func, "gethostbyaddr"); +#endif +} + +PP(pp_ghostent) +{ + dSP; +#ifdef HAS_SOCKET + I32 which = op->op_type; + register char **elem; + register SV *sv; + struct hostent *gethostbyname(); + struct hostent *gethostbyaddr(); +#ifdef HAS_GETHOSTENT + struct hostent *gethostent(); +#endif + struct hostent *hent; + unsigned long len; + + EXTEND(SP, 10); + if (which == OP_GHBYNAME) { + hent = gethostbyname(POPp); + } + else if (which == OP_GHBYADDR) { + int addrtype = POPi; + SV *addrstr = POPs; + STRLEN addrlen; + char *addr = SvPV(addrstr, addrlen); + + hent = gethostbyaddr(addr, addrlen, addrtype); + } + else +#ifdef HAS_GETHOSTENT + hent = gethostent(); +#else + DIE("gethostent not implemented"); +#endif + +#ifdef HOST_NOT_FOUND + if (!hent) + statusvalue = (U16)h_errno & 0xffff; +#endif + + if (GIMME != G_ARRAY) { + PUSHs(sv = sv_newmortal()); + if (hent) { + if (which == OP_GHBYNAME) { + sv_setpvn(sv, hent->h_addr, hent->h_length); + } + else + sv_setpv(sv, (char*)hent->h_name); + } + RETURN; + } + + if (hent) { + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, (char*)hent->h_name); + PUSHs(sv = sv_mortalcopy(&sv_no)); + for (elem = hent->h_aliases; elem && *elem; elem++) { + sv_catpv(sv, *elem); + if (elem[1]) + sv_catpvn(sv, " ", 1); + } + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setiv(sv, (I32)hent->h_addrtype); + PUSHs(sv = sv_mortalcopy(&sv_no)); + len = hent->h_length; + sv_setiv(sv, (I32)len); +#ifdef h_addr + for (elem = hent->h_addr_list; elem && *elem; elem++) { + XPUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpvn(sv, *elem, len); + } +#else + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpvn(sv, hent->h_addr, len); +#endif /* h_addr */ + } + RETURN; +#else + DIE(no_sock_func, "gethostent"); +#endif +} + +PP(pp_gnbyname) +{ +#ifdef HAS_SOCKET + return pp_gnetent(ARGS); +#else + DIE(no_sock_func, "getnetbyname"); +#endif +} + +PP(pp_gnbyaddr) +{ +#ifdef HAS_SOCKET + return pp_gnetent(ARGS); +#else + DIE(no_sock_func, "getnetbyaddr"); +#endif +} + +PP(pp_gnetent) +{ + dSP; +#ifdef HAS_SOCKET + I32 which = op->op_type; + register char **elem; + register SV *sv; + struct netent *getnetbyname(); + struct netent *getnetbyaddr(); + struct netent *getnetent(); + struct netent *nent; + + if (which == OP_GNBYNAME) + nent = getnetbyname(POPp); + else if (which == OP_GNBYADDR) { + int addrtype = POPi; + unsigned long addr = U_L(POPn); + nent = getnetbyaddr((long)addr, addrtype); + } + else + nent = getnetent(); + + EXTEND(SP, 4); + if (GIMME != G_ARRAY) { + PUSHs(sv = sv_newmortal()); + if (nent) { + if (which == OP_GNBYNAME) + sv_setiv(sv, (I32)nent->n_net); + else + sv_setpv(sv, nent->n_name); + } + RETURN; + } + + if (nent) { + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, nent->n_name); + PUSHs(sv = sv_mortalcopy(&sv_no)); + for (elem = nent->n_aliases; *elem; elem++) { + sv_catpv(sv, *elem); + if (elem[1]) + sv_catpvn(sv, " ", 1); + } + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setiv(sv, (I32)nent->n_addrtype); + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setiv(sv, (I32)nent->n_net); + } + + RETURN; +#else + DIE(no_sock_func, "getnetent"); +#endif +} + +PP(pp_gpbyname) +{ +#ifdef HAS_SOCKET + return pp_gprotoent(ARGS); +#else + DIE(no_sock_func, "getprotobyname"); +#endif +} + +PP(pp_gpbynumber) +{ +#ifdef HAS_SOCKET + return pp_gprotoent(ARGS); +#else + DIE(no_sock_func, "getprotobynumber"); +#endif +} + +PP(pp_gprotoent) +{ + dSP; +#ifdef HAS_SOCKET + I32 which = op->op_type; + register char **elem; + register SV *sv; + struct protoent *getprotobyname(); + struct protoent *getprotobynumber(); + struct protoent *getprotoent(); + struct protoent *pent; + + if (which == OP_GPBYNAME) + pent = getprotobyname(POPp); + else if (which == OP_GPBYNUMBER) + pent = getprotobynumber(POPi); + else + pent = getprotoent(); + + EXTEND(SP, 3); + if (GIMME != G_ARRAY) { + PUSHs(sv = sv_newmortal()); + if (pent) { + if (which == OP_GPBYNAME) + sv_setiv(sv, (I32)pent->p_proto); + else + sv_setpv(sv, pent->p_name); + } + RETURN; + } + + if (pent) { + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, pent->p_name); + PUSHs(sv = sv_mortalcopy(&sv_no)); + for (elem = pent->p_aliases; *elem; elem++) { + sv_catpv(sv, *elem); + if (elem[1]) + sv_catpvn(sv, " ", 1); + } + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setiv(sv, (I32)pent->p_proto); + } + + RETURN; +#else + DIE(no_sock_func, "getprotoent"); +#endif +} + +PP(pp_gsbyname) +{ +#ifdef HAS_SOCKET + return pp_gservent(ARGS); +#else + DIE(no_sock_func, "getservbyname"); +#endif +} + +PP(pp_gsbyport) +{ +#ifdef HAS_SOCKET + return pp_gservent(ARGS); +#else + DIE(no_sock_func, "getservbyport"); +#endif +} + +PP(pp_gservent) +{ + dSP; +#ifdef HAS_SOCKET + I32 which = op->op_type; + register char **elem; + register SV *sv; + struct servent *getservbyname(); + struct servent *getservbynumber(); + struct servent *getservent(); + struct servent *sent; + + if (which == OP_GSBYNAME) { + char *proto = POPp; + char *name = POPp; + + if (proto && !*proto) + proto = Nullch; + + sent = getservbyname(name, proto); + } + else if (which == OP_GSBYPORT) { + char *proto = POPp; + int port = POPi; + + sent = getservbyport(port, proto); + } + else + sent = getservent(); + + EXTEND(SP, 4); + if (GIMME != G_ARRAY) { + PUSHs(sv = sv_newmortal()); + if (sent) { + if (which == OP_GSBYNAME) { +#ifdef HAS_NTOHS + sv_setiv(sv, (I32)ntohs(sent->s_port)); +#else + sv_setiv(sv, (I32)(sent->s_port)); +#endif + } + else + sv_setpv(sv, sent->s_name); + } + RETURN; + } + + if (sent) { + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, sent->s_name); + PUSHs(sv = sv_mortalcopy(&sv_no)); + for (elem = sent->s_aliases; *elem; elem++) { + sv_catpv(sv, *elem); + if (elem[1]) + sv_catpvn(sv, " ", 1); + } + PUSHs(sv = sv_mortalcopy(&sv_no)); +#ifdef HAS_NTOHS + sv_setiv(sv, (I32)ntohs(sent->s_port)); +#else + sv_setiv(sv, (I32)(sent->s_port)); +#endif + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, sent->s_proto); + } + + RETURN; +#else + DIE(no_sock_func, "getservent"); +#endif +} + +PP(pp_shostent) +{ + dSP; +#ifdef HAS_SOCKET + sethostent(TOPi); + RETSETYES; +#else + DIE(no_sock_func, "sethostent"); +#endif +} + +PP(pp_snetent) +{ + dSP; +#ifdef HAS_SOCKET + setnetent(TOPi); + RETSETYES; +#else + DIE(no_sock_func, "setnetent"); +#endif +} + +PP(pp_sprotoent) +{ + dSP; +#ifdef HAS_SOCKET + setprotoent(TOPi); + RETSETYES; +#else + DIE(no_sock_func, "setprotoent"); +#endif +} + +PP(pp_sservent) +{ + dSP; +#ifdef HAS_SOCKET + setservent(TOPi); + RETSETYES; +#else + DIE(no_sock_func, "setservent"); +#endif +} + +PP(pp_ehostent) +{ + dSP; +#ifdef HAS_SOCKET + endhostent(); + EXTEND(sp,1); + RETPUSHYES; +#else + DIE(no_sock_func, "endhostent"); +#endif +} + +PP(pp_enetent) +{ + dSP; +#ifdef HAS_SOCKET + endnetent(); + EXTEND(sp,1); + RETPUSHYES; +#else + DIE(no_sock_func, "endnetent"); +#endif +} + +PP(pp_eprotoent) +{ + dSP; +#ifdef HAS_SOCKET + endprotoent(); + EXTEND(sp,1); + RETPUSHYES; +#else + DIE(no_sock_func, "endprotoent"); +#endif +} + +PP(pp_eservent) +{ + dSP; +#ifdef HAS_SOCKET + endservent(); + EXTEND(sp,1); + RETPUSHYES; +#else + DIE(no_sock_func, "endservent"); +#endif +} + +PP(pp_gpwnam) +{ +#ifdef HAS_PASSWD + return pp_gpwent(ARGS); +#else + DIE(no_func, "getpwnam"); +#endif +} + +PP(pp_gpwuid) +{ +#ifdef HAS_PASSWD + return pp_gpwent(ARGS); +#else + DIE(no_func, "getpwuid"); +#endif +} + +PP(pp_gpwent) +{ + dSP; +#ifdef HAS_PASSWD + I32 which = op->op_type; + register SV *sv; + struct passwd *pwent; + + if (which == OP_GPWNAM) + pwent = getpwnam(POPp); + else if (which == OP_GPWUID) + pwent = getpwuid(POPi); + else + pwent = (struct passwd *)getpwent(); + + EXTEND(SP, 10); + if (GIMME != G_ARRAY) { + PUSHs(sv = sv_newmortal()); + if (pwent) { + if (which == OP_GPWNAM) + sv_setiv(sv, (I32)pwent->pw_uid); + else + sv_setpv(sv, pwent->pw_name); + } + RETURN; + } + + if (pwent) { + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, pwent->pw_name); + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, pwent->pw_passwd); + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setiv(sv, (I32)pwent->pw_uid); + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setiv(sv, (I32)pwent->pw_gid); + PUSHs(sv = sv_mortalcopy(&sv_no)); +#ifdef PWCHANGE + sv_setiv(sv, (I32)pwent->pw_change); +#else +#ifdef PWQUOTA + sv_setiv(sv, (I32)pwent->pw_quota); +#else +#ifdef PWAGE + sv_setpv(sv, pwent->pw_age); +#endif +#endif +#endif + PUSHs(sv = sv_mortalcopy(&sv_no)); +#ifdef PWCLASS + sv_setpv(sv, pwent->pw_class); +#else +#ifdef PWCOMMENT + sv_setpv(sv, pwent->pw_comment); +#endif +#endif + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, pwent->pw_gecos); + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, pwent->pw_dir); + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, pwent->pw_shell); +#ifdef PWEXPIRE + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setiv(sv, (I32)pwent->pw_expire); +#endif + } + RETURN; +#else + DIE(no_func, "getpwent"); +#endif +} + +PP(pp_spwent) +{ + dSP; +#ifdef HAS_PASSWD + setpwent(); + RETPUSHYES; +#else + DIE(no_func, "setpwent"); +#endif +} + +PP(pp_epwent) +{ + dSP; +#ifdef HAS_PASSWD + endpwent(); + RETPUSHYES; +#else + DIE(no_func, "endpwent"); +#endif +} + +PP(pp_ggrnam) +{ +#ifdef HAS_GROUP + return pp_ggrent(ARGS); +#else + DIE(no_func, "getgrnam"); +#endif +} + +PP(pp_ggrgid) +{ +#ifdef HAS_GROUP + return pp_ggrent(ARGS); +#else + DIE(no_func, "getgrgid"); +#endif +} + +PP(pp_ggrent) +{ + dSP; +#ifdef HAS_GROUP + I32 which = op->op_type; + register char **elem; + register SV *sv; + struct group *grent; + + if (which == OP_GGRNAM) + grent = (struct group *)getgrnam(POPp); + else if (which == OP_GGRGID) + grent = (struct group *)getgrgid(POPi); + else + grent = (struct group *)getgrent(); + + EXTEND(SP, 4); + if (GIMME != G_ARRAY) { + PUSHs(sv = sv_newmortal()); + if (grent) { + if (which == OP_GGRNAM) + sv_setiv(sv, (I32)grent->gr_gid); + else + sv_setpv(sv, grent->gr_name); + } + RETURN; + } + + if (grent) { + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, grent->gr_name); + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setpv(sv, grent->gr_passwd); + PUSHs(sv = sv_mortalcopy(&sv_no)); + sv_setiv(sv, (I32)grent->gr_gid); + PUSHs(sv = sv_mortalcopy(&sv_no)); + for (elem = grent->gr_mem; *elem; elem++) { + sv_catpv(sv, *elem); + if (elem[1]) + sv_catpvn(sv, " ", 1); + } + } + + RETURN; +#else + DIE(no_func, "getgrent"); +#endif +} + +PP(pp_sgrent) +{ + dSP; +#ifdef HAS_GROUP + setgrent(); + RETPUSHYES; +#else + DIE(no_func, "setgrent"); +#endif +} + +PP(pp_egrent) +{ + dSP; +#ifdef HAS_GROUP + endgrent(); + RETPUSHYES; +#else + DIE(no_func, "endgrent"); +#endif +} + +PP(pp_getlogin) +{ + dSP; dTARGET; +#ifdef HAS_GETLOGIN + char *tmps; + EXTEND(SP, 1); + if (!(tmps = getlogin())) + RETPUSHUNDEF; + PUSHp(tmps, strlen(tmps)); + RETURN; +#else + DIE(no_func, "getlogin"); +#endif +} + +/* Miscellaneous. */ + +PP(pp_syscall) +{ +#ifdef HAS_SYSCALL + dSP; dMARK; dORIGMARK; dTARGET; + register I32 items = SP - MARK; + unsigned long a[20]; + register I32 i = 0; + I32 retval = -1; + + if (tainting) { + while (++MARK <= SP) { + if (SvGMAGICAL(*MARK) && SvSMAGICAL(*MARK) && mg_find(*MARK, 't')) + tainted = TRUE; + } + MARK = ORIGMARK; + TAINT_PROPER("syscall"); + } + + /* This probably won't work on machines where sizeof(long) != sizeof(int) + * or where sizeof(long) != sizeof(char*). But such machines will + * not likely have syscall implemented either, so who cares? + */ + while (++MARK <= SP) { + if (SvNIOK(*MARK) || !i) + a[i++] = SvIV(*MARK); + else + a[i++] = (unsigned long)SvPVX(*MARK); + if (i > 15) + break; + } + switch (items) { + default: + DIE("Too many args to syscall"); + case 0: + DIE("Too few args to syscall"); + case 1: + retval = syscall(a[0]); + break; + case 2: + retval = syscall(a[0],a[1]); + break; + case 3: + retval = syscall(a[0],a[1],a[2]); + break; + case 4: + retval = syscall(a[0],a[1],a[2],a[3]); + break; + case 5: + retval = syscall(a[0],a[1],a[2],a[3],a[4]); + break; + case 6: + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]); + break; + case 7: + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]); + break; + case 8: + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]); + break; +#ifdef atarist + case 9: + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]); + break; + case 10: + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]); + break; + case 11: + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], + a[10]); + break; + case 12: + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], + a[10],a[11]); + break; + case 13: + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], + a[10],a[11],a[12]); + break; + case 14: + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9], + a[10],a[11],a[12],a[13]); + break; +#endif /* atarist */ + } + SP = ORIGMARK; + PUSHi(retval); + RETURN; +#else + DIE(no_func, "syscall"); +#endif +} + @@ -1,408 +1,459 @@ -OP* CopDBadd P((OP* cur)); -OP* add_label P((char* lbl, OP* cmd)); -OP* addcond P((OP* cmd, OP* arg)); -OP* addflags P((I32 i, I32 flags, OP* arg)); -OP* addloop P((OP* cmd, OP* arg)); -OP* append_elem P((I32 optype, OP* head, OP* tail)); -OP* append_list P((I32 optype, LISTOP* first, LISTOP* last)); -I32 apply P((I32 type, SV** mark, SV** sp)); -void av_clear P((AV* ar)); -AV* av_fake P((I32 size, SV** svp)); -SV** av_fetch P((AV* ar, I32 key, I32 lval)); -void av_fill P((AV* ar, I32 fill)); -I32 av_len P((AV* ar)); -AV* av_make P((I32 size, SV** svp)); -SV* av_pop P((AV* ar)); -void av_popnulls P((AV* ar)); -bool av_push P((AV* ar, SV* val)); -SV* av_shift P((AV* ar)); -SV** av_store P((AV* ar, I32 key, SV* val)); -void av_undef P((AV* ar)); -void av_unshift P((AV* ar, I32 num)); -OP* bind_match P((I32 type, OP* left, OP* pat)); -OP* block_head P((OP* o, OP** startp)); -int boot_DB_File P((int ix, int sp, int items)); -/* int boot_DynamicLoader P((void)); */ -int boot_NDBM_File P((int ix, int sp, int items)); -int boot_GDBM_File P((int ix, int sp, int items)); -int boot_SDBM_File P((int ix, int sp, int items)); -int boot_ODBM_File P((int ix, int sp, int items)); -int boot_DBZ_File P((int ix, int sp, int items)); -int boot_POSIX P((int ix, int sp, int items)); -void calllist P((AV* list)); -I32 cando P((I32 bit, I32 effective, struct stat* statbufp)); -U32 cast_ulong P((double f)); -static void checkcomma P((char* s, char* name, char* what)); -I32 chsize P((int fd, Off_t length)); -OP* convert P((I32 optype, I32 flags, OP* op)); -OP* cop_to_arg P((OP* cmd)); -I32 copyopt P((OP* cmd, OP* which)); -void cpy7bit P((char* d, char* s, I32 l)); -char* cpytill P((char* to, char* from, char* fromend, I32 delim, I32* retlen)); -void croak P((char* pat,...)); -void cryptfilter P((FILE* fil)); -void cryptswitch P((void)); -void cv_undef P((CV* cv)); -void deb P((char* pat,...)); -void deb_growlevel P((void)); -OP* die P((char* pat,...)); -OP* die_where P((char* message)); -void do_accept P((SV* sv, GV* ngv, GV* ggv)); -bool do_aexec P((SV* really, SV** mark, SV** sp)); -void do_chop P((SV* asv, SV* sv)); -bool do_close P((GV* gv, bool explicit)); -int do_ctl P((I32 optype, GV* gv, I32 func, SV* argsv)); -bool do_eof P((GV* gv)); -bool do_exec P((char* cmd)); -void do_execfree P((void)); -SV* do_fttext P((OP* arg, SV* sv)); -I32 do_ipcctl P((I32 optype, SV** mark, SV** sp)); -I32 do_ipcget P((I32 optype, SV** mark, SV** sp)); -void do_join P((SV* sv, SV* del, SV** mark, SV** sp)); -OP* do_kv P((void)); -I32 do_msgrcv P((SV** mark, SV** sp)); -I32 do_msgsnd P((SV** mark, SV** sp)); -bool do_open P((GV* gv, char* name, I32 len)); -void do_pipe P((SV* sv, GV* rgv, GV* wgv)); -bool do_print P((SV* sv, FILE* fp)); -bool do_seek P((GV* gv, long pos, int whence)); -I32 do_semop P((SV** mark, SV** sp)); -I32 do_shmio P((I32 optype, SV** mark, SV** sp)); -void do_sprintf P((SV* sv, int len, SV** sarg)); -OP* do_subr P((void)); -long do_tell P((GV* gv)); -I32 do_trans P((SV* sv, OP* arg)); -void do_vecset P((SV* sv)); -void do_vop P((I32 optype, SV* sv, SV* left, SV* right)); -void do_write P((struct Outrec* orec, GV* gv)); -void dump_all P((void)); -void dump_cop P((OP* cmd, OP* alt)); -void dump_eval P((void)); -int dump_fds P((char* s)); -void dump_flags P((char* b, U32 flags)); -void dump_form P((GV* gv)); -void dump_gv P((GV* gv)); -void dump_op P((OP* arg)); -void dump_pm P((PMOP* pm)); -void dump_packsubs P((HV* stash)); -void dump_sub P((GV* gv)); -void fbm_compile P((SV* sv, I32 iflag)); -char* fbm_instr P((unsigned char* big, unsigned char* bigend, SV* littlesv)); -HV* fetch_stash P((SV* sv, I32 create)); -OP* flatten P((OP* arg)); -static void force_ident P((char* s)); -static char* force_word P((char* start, int token, int check_keyword, int allow_tick)); -OP* forcelist P((OP* arg)); -void free_tmps P((void)); -OP* gen_constant_list P((OP* op)); -I32 getgimme P((OP*op)); -void gp_free P((GV* gv)); -GP* gp_ref P((GP* gp)); -GV* gv_AVadd P((GV* gv)); -GV* gv_HVadd P((GV* gv)); -void gv_check P((HV* stash)); -void gv_efullname P((SV* sv, GV* gv)); -GV* gv_fetchfile P((char* name)); -GV* gv_fetchmethod P((HV* stash, char* name)); -GV* gv_fetchpv P((char* name, I32 add, I32 svtype)); -void gv_fullname P((SV* sv, GV* gv)); -STRLEN gv_len P((SV* sv)); -SV* gv_str P((SV* sv)); -OP* gv_to_op P((I32 atype, GV* gv)); -void he_delayfree P((HE* hent)); -void he_free P((HE* hent)); -void hoistmust P((PMOP* pm)); -void hv_clear P((HV* tb)); -SV* hv_delete P((HV* tb, char* key, U32 klen)); -SV** hv_fetch P((HV* tb, char* key, U32 klen, I32 lval)); -I32 hv_iterinit P((HV* tb)); -char* hv_iterkey P((HE* entry, I32* retlen)); -HE* hv_iternext P((HV* tb)); -SV* hv_iterval P((HV* tb, HE* entry)); -void hv_magic P((HV* hv, GV* gv, I32 how)); -SV** hv_store P((HV* tb, char* key, U32 klen, SV* val, U32 hash)); -void hv_undef P((HV* tb)); -I32 ibcmp P((char* a, char* b, I32 len)); -I32 ingroup P((int testgid, I32 effective)); -char* instr P((char* big, char* little)); -OP* invert P((OP* cmd)); -OP* jmaybe P((OP* arg)); -I32 keyword P((char* d, I32 len)); -void leave_scope P((I32 base)); -void lex_end P((void)); -void lex_start P((SV *line)); -OP* linklist P((OP* op)); -OP* list P((OP* o)); -OP* listkids P((OP* o)); -OP* localize P((OP* arg, I32 lexical)); -I32 looks_like_number P((SV* sv)); -OP* loopscope P((OP* o)); -I32 lop P((I32 f, char* s)); -int magic_clearenv P((SV* sv, MAGIC* mg)); -int magic_clearpack P((SV* sv, MAGIC* mg)); -int magic_get P((SV* sv, MAGIC* mg)); -int magic_getarylen P((SV* sv, MAGIC* mg)); -int magic_getpack P((SV* sv, MAGIC* mg)); -int magic_getglob P((SV* sv, MAGIC* mg)); -int magic_gettaint P((SV* sv, MAGIC* mg)); -int magic_getuvar P((SV* sv, MAGIC* mg)); -U32 magic_len P((SV* sv, MAGIC* mg)); -int magic_set P((SV* sv, MAGIC* mg)); -int magic_setarylen P((SV* sv, MAGIC* mg)); -int magic_setbm P((SV* sv, MAGIC* mg)); -int magic_setpack P((SV* sv, MAGIC* mg)); -int magic_setdbline P((SV* sv, MAGIC* mg)); -int magic_setenv P((SV* sv, MAGIC* mg)); -int magic_setisa P((SV* sv, MAGIC* mg)); -int magic_setglob P((SV* sv, MAGIC* mg)); -int magic_setmglob P((SV* sv, MAGIC* mg)); -int magic_setsig P((SV* sv, MAGIC* mg)); -int magic_setsubstr P((SV* sv, MAGIC* mg)); -int magic_settaint P((SV* sv, MAGIC* mg)); -int magic_setuvar P((SV* sv, MAGIC* mg)); -int magic_setvec P((SV* sv, MAGIC* mg)); -void magicalize P((char* list)); -void magicname P((char* sym, char* name, I32 namlen)); -int main P((int argc, char** argv, char** env)); +#ifndef GNUC_ATTRIBUTE_CHECK /* disable GNUC attribute checking if not GNUC */ +#ifdef __attribute__ /* Avoid possible redefinition errors */ +#undef __attribute__ +#endif +#define __attribute__(attr) +#endif +#ifdef OVERLOAD +SV* amagic_call _((SV* left,SV* right,int method,int dir)); +#endif /* OVERLOAD */ +OP* append_elem _((I32 optype, OP* head, OP* tail)); +OP* append_list _((I32 optype, LISTOP* first, LISTOP* last)); +I32 apply _((I32 type, SV** mark, SV** sp)); +void assertref _((OP* op)); +void av_clear _((AV* ar)); +void av_extend _((AV* ar, I32 key)); +AV* av_fake _((I32 size, SV** svp)); +SV** av_fetch _((AV* ar, I32 key, I32 lval)); +void av_fill _((AV* ar, I32 fill)); +I32 av_len _((AV* ar)); +AV* av_make _((I32 size, SV** svp)); +SV* av_pop _((AV* ar)); +void av_push _((AV* ar, SV* val)); +SV* av_shift _((AV* ar)); +SV** av_store _((AV* ar, I32 key, SV* val)); +void av_undef _((AV* ar)); +void av_unshift _((AV* ar, I32 num)); +OP* bind_match _((I32 type, OP* left, OP* pat)); +OP* block_end _((int line, int floor, OP* seq)); +int block_start _((void)); +void calllist _((AV* list)); +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)); +OP* convert _((I32 optype, I32 flags, OP* op)); +char* cpytill _((char* to, char* from, char* fromend, int delim, I32* retlen)); +void croak _((char* pat,...)) __attribute__((format(printf,1,2),noreturn)); +void cv_undef _((CV* cv)); +#ifdef DEBUGGING +void cx_dump _((CONTEXT* cs)); +#endif +void cryptswitch_add _((cryptswitch_t funcp)); +I32 cxinc _((void)); +void deb _((char* pat,...)) __attribute__((format(printf,1,2))); +void deb_growlevel _((void)); +I32 debop _((OP* op)); +I32 debstackptrs _((void)); +#ifdef DEBUGGING +void debprofdump _((void)); +#endif +I32 debstack _((void)); +void deprecate _((char* s)); +OP* die _((char* pat,...)) __attribute__((format(printf,1,2))); +OP* die_where _((char* message)); +void dounwind _((I32 cxix)); +bool do_aexec _((SV* really, SV** mark, SV** sp)); +void do_chop _((SV* asv, SV* sv)); +bool do_close _((GV* gv, bool explicit)); +bool do_eof _((GV* gv)); +bool do_exec _((char* cmd)); +void do_execfree _((void)); +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) +I32 do_ipcctl _((I32 optype, SV** mark, SV** sp)); +I32 do_ipcget _((I32 optype, SV** mark, SV** sp)); +#endif +void do_join _((SV* sv, SV* del, SV** mark, SV** sp)); +OP* do_kv _((void)); +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) +I32 do_msgrcv _((SV** mark, SV** sp)); +I32 do_msgsnd _((SV** mark, SV** sp)); +#endif +bool do_open _((GV* gv, char* name, I32 len, FILE* supplied_fp)); +void do_pipe _((SV* sv, GV* rgv, GV* wgv)); +bool do_print _((SV* sv, FILE* fp)); +OP * do_readline _((void)); +I32 do_chomp _((SV* sv)); +bool do_seek _((GV* gv, long pos, int whence)); +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) +I32 do_semop _((SV** mark, SV** sp)); +I32 do_shmio _((I32 optype, SV** mark, SV** sp)); +#endif +void do_sprintf _((SV* sv, I32 len, SV** sarg)); +long do_tell _((GV* gv)); +I32 do_trans _((SV* sv, OP* arg)); +void do_vecset _((SV* sv)); +void do_vop _((I32 optype, SV* sv, SV* left, SV* right)); +void dump_all _((void)); +void dump_eval _((void)); +#ifdef NOTDEF /* See util.c */ +int dump_fds _((char* s)); +#endif +void dump_form _((GV* gv)); +void dump_gv _((GV* gv)); +void dump_op _((OP* arg)); +void dump_pm _((PMOP* pm)); +void dump_packsubs _((HV* stash)); +void dump_sub _((GV* gv)); +void fbm_compile _((SV* sv, I32 iflag)); +char* fbm_instr _((unsigned char* big, unsigned char* bigend, SV* littlesv)); +OP* force_list _((OP* arg)); +OP* fold_constants _((OP * arg)); +void free_tmps _((void)); +OP* gen_constant_list _((OP* op)); +void gp_free _((GV* gv)); +GP* gp_ref _((GP* gp)); +GV* gv_AVadd _((GV* gv)); +GV* gv_HVadd _((GV* gv)); +GV* gv_IOadd _((GV* gv)); +void gv_check _((HV* stash)); +void gv_efullname _((SV* sv, GV* gv)); +GV* gv_fetchfile _((char* name)); +GV* gv_fetchmeth _((HV* stash, char* name, STRLEN len, I32 level)); +GV* gv_fetchmethod _((HV* stash, char* name)); +GV* gv_fetchpv _((char* name, I32 add, I32 sv_type)); +void gv_fullname _((SV* sv, GV* gv)); +void gv_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)); +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)); +char* instr _((char* big, char* little)); +OP* invert _((OP* cmd)); +OP* jmaybe _((OP* arg)); +I32 keyword _((char* d, I32 len)); +void leave_scope _((I32 base)); +void lex_end _((void)); +void lex_start _((SV *line)); +OP* linklist _((OP* op)); +OP* list _((OP* o)); +OP* listkids _((OP* o)); +OP* localize _((OP* arg, I32 lexical)); +I32 looks_like_number _((SV* sv)); +int magic_clearenv _((SV* sv, MAGIC* mg)); +int magic_clearpack _((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_gettaint _((SV* sv, MAGIC* mg)); +int magic_getuvar _((SV* sv, MAGIC* mg)); +U32 magic_len _((SV* sv, MAGIC* mg)); +int magic_nextpack _((SV* sv, MAGIC* mg, SV* key)); +int magic_set _((SV* sv, MAGIC* mg)); +#ifdef OVERLOAD +int magic_setamagic _((SV* sv, MAGIC* mg)); +#endif /* OVERLOAD */ +int magic_setarylen _((SV* sv, MAGIC* mg)); +int magic_setbm _((SV* sv, MAGIC* mg)); +int magic_setdbline _((SV* sv, MAGIC* mg)); +int magic_setenv _((SV* sv, MAGIC* mg)); +int magic_setisa _((SV* sv, MAGIC* mg)); +int magic_setglob _((SV* sv, MAGIC* mg)); +int magic_setmglob _((SV* sv, MAGIC* mg)); +int magic_setpack _((SV* sv, MAGIC* mg)); +int magic_setpos _((SV* sv, MAGIC* mg)); +int magic_setsig _((SV* sv, MAGIC* mg)); +int magic_setsubstr _((SV* sv, MAGIC* mg)); +int magic_settaint _((SV* sv, MAGIC* mg)); +int magic_setuvar _((SV* sv, MAGIC* mg)); +int magic_setvec _((SV* sv, MAGIC* mg)); +int magic_wipepack _((SV* sv, MAGIC* mg)); +void magicname _((char* sym, char* name, I32 namlen)); +int main _((int argc, char** argv, char** env)); #ifndef STANDARD_C -Malloc_t malloc P((MEM_SIZE nbytes)); +Malloc_t malloc _((MEM_SIZE nbytes)); #endif -OP* maybeforcelist P((I32 optype, OP* arg)); -char* mess P((char* pat, va_list* args)); -int mg_clear P((SV* sv)); -MAGIC* mg_find P((SV* sv, char type)); -int mg_free P((SV* sv)); -int mg_get P((SV* sv)); -U32 mg_len P((SV* sv)); -void mg_magical P((SV* sv)); -int mg_set P((SV* sv)); -OP* mod P((OP* op, I32 type)); -char* moreswitches P((char* s)); +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)); +U32 mg_len _((SV* sv)); +void mg_magical _((SV* sv)); +int mg_set _((SV* sv)); +OP* mod _((OP* op, I32 type)); +char* moreswitches _((char* s)); #ifdef MSTATS -void mstats P((char* s)); +void mstats _((char* s)); +#endif +OP * my _(( OP *)); +char* my_bcopy _((char* from, char* to, I32 len)); +#if !defined(HAS_BZERO) && !defined(HAS_MEMSET) +char* my_bzero _((char* loc, I32 len)); #endif -char* my_bcopy P((char* from, char* to, I32 len)); -char* my_bzero P((char* loc, I32 len)); -void my_exit P((I32 status)); -I32 my_lstat P((void)); -I32 my_memcmp P((unsigned char* s1, unsigned char* s2, I32 len)); -I32 my_pclose P((FILE* ptr)); -FILE* my_pfiopen P((FILE* fil, VOID (*func)())); -FILE* my_popen P((char* cmd, char* mode)); -void my_setenv P((char* nam, char* val)); -I32 my_stat P((void)); -short my_swap P((short s)); -void my_unexec P((void)); -OP* newANONLIST P((OP* op)); -OP* newANONHASH P((OP* op)); -OP* newASSIGNOP P((I32 flags, OP* left, OP* right)); -OP* newBINOP P((I32 optype, I32 flags, OP* left, OP* right)); -OP* newCONDOP P((I32 flags, OP* expr, OP* true, OP* false)); -void newFORM P((I32 floor, OP* op, OP* block)); -OP* newFOROP P((I32 flags, char* label, line_t forline, OP* scalar, OP* expr, OP*block, OP*cont)); -OP* newLOGOP P((I32 optype, I32 flags, OP* left, OP* right)); -OP* newLOOPEX P((I32 type, OP* label)); -OP* newLOOPOP P((I32 flags, I32 debuggable, OP* expr, OP* block)); -OP* newMETHOD P((OP* ref, OP* name)); -OP* newNAMEOP P((OP* o)); -OP* newNULLLIST P((void)); -OP* newOP P((I32 optype, I32 flags)); -OP* newRANGE P((I32 flags, OP* left, OP* right)); -OP* newSLICEOP P((I32 flags, OP* subscript, OP* list)); -OP* newSTATEOP P((I32 flags, char* label, OP* o)); -void newSUB P((I32 floor, OP* op, OP* block)); -OP* newUNOP P((I32 optype, I32 flags, OP* child)); -void newXSUB P((char *name, I32 ix, I32 (*subaddr)(int,int,int), char *filename)); -AV* newAV P((void)); -OP* newAVREF P((OP* o)); -OP* newBINOP P((I32 type, I32 flags, OP* first, OP* last)); -OP* newCVREF P((OP* o)); -OP* newGVOP P((I32 type, I32 flags, GV* gv)); -GV* newGVgen P((void)); -OP* newGVREF P((OP* o)); -OP* newHVREF P((OP* o)); -HV* newHV P((void)); -IO* newIO P((void)); -OP* newLISTOP P((I32 type, I32 flags, OP* first, OP* last)); -OP* newPMOP P((I32 type, I32 flags)); -OP* newPVOP P((I32 type, I32 flags, char* pv)); -SV* newRV P((SV* ref)); +void my_exit _((I32 status)) __attribute__((noreturn)); +I32 my_lstat _((void)); +#ifndef HAS_MEMCMP +I32 my_memcmp _((unsigned char* s1, unsigned char* s2, I32 len)); +#endif +I32 my_pclose _((FILE* ptr)); +FILE* my_popen _((char* cmd, char* mode)); +void my_setenv _((char* nam, char* val)); +I32 my_stat _((void)); +#ifdef MYSWAP +short my_swap _((short s)); +#endif +void my_unexec _((void)); +OP* newANONLIST _((OP* op)); +OP* newANONHASH _((OP* op)); +OP* newANONSUB _((I32 floor, OP* block)); +OP* newASSIGNOP _((I32 flags, OP* left, I32 optype, OP* right)); +OP* newBINOP _((I32 optype, I32 flags, OP* left, OP* right)); +OP* newCONDOP _((I32 flags, OP* expr, OP* true, OP* false)); +void newFORM _((I32 floor, OP* op, OP* block)); +OP* newFOROP _((I32 flags, char* label, line_t forline, OP* scalar, OP* expr, OP*block, OP*cont)); +OP* newLOGOP _((I32 optype, I32 flags, OP* left, OP* right)); +OP* newLOOPEX _((I32 type, OP* label)); +OP* newLOOPOP _((I32 flags, I32 debuggable, OP* expr, OP* block)); +OP* newMETHOD _((OP* ref, OP* name)); +OP* newNULLLIST _((void)); +OP* newOP _((I32 optype, I32 flags)); +void newPROG _((OP* op)); +OP* newRANGE _((I32 flags, OP* left, OP* right)); +OP* newSLICEOP _((I32 flags, OP* subscript, OP* list)); +OP* newSTATEOP _((I32 flags, char* label, OP* o)); +CV* newSUB _((I32 floor, OP* op, OP* block)); +OP* newUNOP _((I32 optype, I32 flags, OP* child)); +CV* newXS _((char *name, void (*subaddr)(CV* cv), char *filename)); +#ifdef DEPRECATED +CV* newXSUB _((char *name, I32 ix, I32 (*subaddr)(int,int,int), char *filename)); +#endif +AV* newAV _((void)); +OP* newAVREF _((OP* o)); +OP* newBINOP _((I32 type, I32 flags, OP* first, OP* last)); +OP* newCVREF _((OP* o)); +OP* newCVOP _((I32 type, I32 flags, CV* cv, OP* cont)); +OP* newGVOP _((I32 type, I32 flags, GV* gv)); +GV* newGVgen _((char *pack)); +OP* newGVREF _((I32 type, OP* o)); +OP* newHVREF _((OP* o)); +HV* newHV _((void)); +IO* newIO _((void)); +OP* newLISTOP _((I32 type, I32 flags, OP* first, OP* last)); +OP* newPMOP _((I32 type, I32 flags)); +OP* newPVOP _((I32 type, I32 flags, char* pv)); +SV* newRV _((SV* ref)); #ifdef LEAKTEST -SV* newSV P((I32 x, STRLEN len)); +SV* newSV _((I32 x, STRLEN len)); #else -SV* newSV P((STRLEN len)); +SV* newSV _((STRLEN len)); #endif -OP* newSVREF P((OP* o)); -OP* newSVOP P((I32 type, I32 flags, SV* sv)); -SV* newSViv P((I32 i)); -SV* newSVnv P((double n)); -SV* newSVpv P((char* s, STRLEN len)); -SV* newSVsv P((SV* old)); -OP* newUNOP P((I32 type, I32 flags, OP* first)); -OP * newWHILEOP P((I32 flags, I32 debuggable, LOOP* loop, OP* expr, OP* block, OP* cont)); -FILE* nextargv P((GV* gv)); -char* ninstr P((char* big, char* bigend, char* little, char* lend)); -char* nsavestr P((char* sv, I32 len)); -void op_behead P((OP* arg)); -OP* op_fold_const P((OP* arg)); -void op_free P((OP* arg)); -void op_optimize P((OP* cmd, I32 fliporflop, I32 acmd)); -OP* over P((GV* eachgv, OP* cmd)); -PADOFFSET pad_alloc P((I32 optype, U32 tmptype)); -PADOFFSET pad_allocmy P((char* name)); -PADOFFSET pad_findmy P((char* name)); -OP* oopsAV P((OP* o)); -OP* oopsHV P((OP* o)); -void pad_leavemy P((I32 fill)); -SV* pad_sv P((PADOFFSET po)); -void pad_free P((PADOFFSET po)); -void pad_reset P((void)); -void pad_swipe P((PADOFFSET po)); -OP* parse_list P((SV* sv)); -void peep P((OP* op)); -PerlInterpreter* perl_alloc P((void)); -I32 perl_callargv P((char* subname, I32 sp, I32 gimme, char** argv)); -I32 perl_callpv P((char* subname, I32 sp, I32 gimme, I32 hasargs, I32 numargs)); -I32 perl_callsv P((SV* sv, I32 sp, I32 gimme, I32 hasargs, I32 numargs)); -void perl_construct P((PerlInterpreter* sv_interp)); -void perl_destruct P((PerlInterpreter* sv_interp)); -void perl_free P((PerlInterpreter* sv_interp)); -void perl_init_ext P((void)); -I32 perl_parse P((PerlInterpreter* sv_interp, int argc, char** argv, char** env)); -I32 perl_run P((PerlInterpreter* sv_interp)); -void pidgone P((int pid, int status)); -OP* pmruntime P((OP* pm, OP* expr, OP* repl)); -OP* pop_return P((void)); -OP* prepend_elem P((I32 optype, OP* head, OP* tail)); -void push_return P((OP* op)); -OP* rcatmaybe P((OP* arg)); -regexp* regcomp P((char* exp, char* xend, I32 fold)); -OP* ref P((OP* op, I32 type)); -OP* refkids P((OP* op, I32 type)); -void regdump P((regexp* r)); -I32 regexec P((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, I32 safebase)); -void regfree P((struct regexp* r)); -char* regnext P((char* p)); -char* regprop P((char* op)); -void repeatcpy P((char* to, char* from, I32 len, I32 count)); -char* rninstr P((char* big, char* bigend, char* little, char* lend)); -void run_format P((struct Outrec* orec, FF* fcmd)); +OP* newSVREF _((OP* o)); +OP* newSVOP _((I32 type, I32 flags, SV* sv)); +SV* newSViv _((IV i)); +SV* newSVnv _((double n)); +SV* newSVpv _((char* s, STRLEN len)); +SV* newSVrv _((SV* rv, char* classname)); +SV* newSVsv _((SV* old)); +OP* newUNOP _((I32 type, I32 flags, OP* first)); +OP * newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, OP* expr, OP* block, OP* cont)); +FILE* nextargv _((GV* gv)); +char* ninstr _((char* big, char* bigend, char* little, char* lend)); +OP * oopsCV _((OP* o)); +void op_free _((OP* arg)); +void package _((OP* op)); +PADOFFSET pad_alloc _((I32 optype, U32 tmptype)); +PADOFFSET pad_allocmy _((char* name)); +PADOFFSET pad_findmy _((char* name)); +OP* oopsAV _((OP* o)); +OP* oopsHV _((OP* o)); +void pad_leavemy _((I32 fill)); +SV* pad_sv _((PADOFFSET po)); +void pad_free _((PADOFFSET po)); +void pad_reset _((void)); +void pad_swipe _((PADOFFSET po)); +void peep _((OP* op)); +PerlInterpreter* perl_alloc _((void)); +I32 perl_call_argv _((char* subname, I32 flags, char** argv)); +I32 perl_call_method _((char* methname, I32 flags)); +I32 perl_call_pv _((char* subname, I32 flags)); +I32 perl_call_sv _((SV* sv, I32 flags)); +#ifdef DEPRECATED +I32 perl_callargv _((char* subname, I32 sp, I32 gimme, char** argv)); +I32 perl_callpv _((char* subname, I32 sp, I32 gimme, I32 hasargs, I32 numargs)); +I32 perl_callsv _((SV* sv, I32 sp, I32 gimme, I32 hasargs, I32 numargs)); +#endif +void perl_construct _((PerlInterpreter* sv_interp)); +void perl_destruct _((PerlInterpreter* sv_interp, int destruct_level)); +void perl_free _((PerlInterpreter* sv_interp)); +SV* perl_get_sv _((char* name, I32 create)); +AV* perl_get_av _((char* name, I32 create)); +HV* perl_get_hv _((char* name, I32 create)); +CV* perl_get_cv _((char* name, I32 create)); +int perl_parse _((PerlInterpreter* sv_interp, void(*xsinit)(void), int argc, char** argv, char** env)); +void perl_requirepv _((char* pv)); +int perl_run _((PerlInterpreter* sv_interp)); +void pidgone _((int pid, int status)); +void pmflag _((U16* pmfl, int ch)); +OP* pmruntime _((OP* pm, OP* expr, OP* repl)); +OP* pmtrans _((OP* op, OP* expr, OP* repl)); +OP* pop_return _((void)); +void pop_scope _((void)); +OP* prepend_elem _((I32 optype, OP* head, OP* tail)); +void push_return _((OP* op)); +void push_scope _((void)); +regexp* regcomp _((char* exp, char* xend, PMOP* pm)); +OP* ref _((OP* op, I32 type)); +OP* refkids _((OP* op, I32 type)); +void regdump _((regexp* r)); +I32 regexec _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, I32 safebase)); +void regfree _((struct regexp* r)); +char* regnext _((char* p)); +char* regprop _((char* op)); +void repeatcpy _((char* to, char* from, I32 len, I32 count)); +char* rninstr _((char* big, char* bigend, char* little, char* lend)); +int run _((void)); #ifndef safemalloc -void safefree P((char* where)); -char* safemalloc P((MEM_SIZE size)); +void safefree _((char* where)); +char* safemalloc _((MEM_SIZE size)); #ifndef MSDOS -char* saferealloc P((char* where, MEM_SIZE size)); +char* saferealloc _((char* where, MEM_SIZE size)); #else -char* saferealloc P((char* where, unsigned long size)); +char* saferealloc _((char* where, unsigned long size)); +#endif +#endif +#ifdef LEAKTEST +void safexfree _((char* where)); +char* safexmalloc _((I32 x, MEM_SIZE size)); +char* safexrealloc _((char* where, MEM_SIZE size)); +#endif +#ifndef HAS_RENAME +I32 same_dirent _((char* a, char* b)); +#endif +char* savepv _((char* sv)); +char* savepvn _((char* sv, I32 len)); +void savestack_grow _((void)); +void save_aptr _((AV** aptr)); +AV* save_ary _((GV* gv)); +void save_clearsv _((SV** svp)); +void save_delete _((HV* hv, char* key, I32 klen)); +#ifndef titan /* TitanOS cc can't handle this */ +void save_destructor _((void (*f)(void*), void* p)); +#endif /* titan */ +void save_freesv _((SV* sv)); +void save_freeop _((OP* op)); +void save_freepv _((char* pv)); +HV* save_hash _((GV* gv)); +void save_hptr _((HV** hptr)); +void save_I32 _((I32* intp)); +void save_int _((int* intp)); +void save_item _((SV* item)); +void save_list _((SV** sarg, I32 maxsarg)); +void save_long _((long *longp)); +void save_nogv _((GV* gv)); +SV* save_scalar _((GV* gv)); +void save_pptr _((char **pptr)); +void save_sptr _((SV** sptr)); +SV* save_svref _((SV** sptr)); +OP* sawparens _((OP* o)); +OP* scalar _((OP* o)); +OP* scalarkids _((OP* op)); +OP* scalarseq _((OP* o)); +OP* scalarvoid _((OP* op)); +unsigned long scan_hex _((char* start, I32 len, I32* retlen)); +char* scan_num _((char* s)); +unsigned long scan_oct _((char* start, I32 len, I32* retlen)); +#ifdef NOTDEF /* See toke.c pp_ctl.c and op.c */ +void scan_prefix _((PMOP* pm, char* string, I32 len)); #endif +OP* scope _((OP* o)); +char* screaminstr _((SV* bigsv, SV* littlesv)); +#ifndef VMS +I32 setenv_getix _((char* nam)); #endif -void safexfree P((char* where)); -char* safexmalloc P((I32 x, MEM_SIZE size)); -char* safexrealloc P((char* where, MEM_SIZE size)); -I32 same_dirent P((char* a, char* b)); -void savestack_grow P((void)); -void save_aptr P((AV** aptr)); -AV* save_ary P((GV* gv)); -void save_clearsv P((SV** svp)); -void save_delete P((HV* hv, char* key, I32 klen)); -void save_freesv P((SV* sv)); -void save_freeop P((OP* op)); -void save_freepv P((char* pv)); -HV* save_hash P((GV* gv)); -void save_hptr P((HV** hptr)); -void save_I32 P((I32* intp)); -void save_int P((int* intp)); -void save_item P((SV* item)); -void save_list P((SV** sarg, I32 maxsarg)); -void save_nogv P((GV* gv)); -SV* save_scalar P((GV* gv)); -void save_sptr P((SV** sptr)); -SV* save_svref P((SV** sptr)); -char* savestr P((char* sv)); -OP* sawparens P((OP* o)); -OP* scalar P((OP* o)); -OP* scalarkids P((OP* op)); -OP* scalarseq P((OP* o)); -OP* scalarvoid P((OP* op)); -static char* scan_formline P((char* s)); -unsigned long scan_hex P((char* start, I32 len, I32* retlen)); -static char* scan_heredoc P((char* s)); -static char* scan_inputsymbol P((char* s)); -static char* scan_ident P((char* s, char* send, char* dest, I32 ck_uni)); -char* scan_num P((char* s)); -unsigned long scan_oct P((char* start, I32 len, I32* retlen)); -static char* scan_pat P((char* s)); -void scan_prefix P((PMOP* pm, char* string, I32 len)); -static char* scan_str P((char* start)); -static char* scan_subst P((char* start)); -static char* scan_trans P((char* start)); -static char* scan_word P((char* s, char* dest, int allow_package, STRLEN *slp)); -OP* scope P((OP* o)); -char* screaminstr P((SV* bigsv, SV* littlesv)); -I32 setenv_getix P((char* nam)); -VOIDRET sighandler P((I32 sig)); -static char* skipspace P((char* s)); -int start_subparse P((void)); -bool sv_2bool P((SV* sv)); -CV* sv_2cv P((SV* sv, HV** st, GV** gvp, I32 lref)); -I32 sv_2iv P((SV* sv)); -SV* sv_2mortal P((SV* sv)); -double sv_2nv P((SV* sv)); -char* sv_2pv P((SV* sv, STRLEN* lp)); -int sv_backoff P((SV* sv)); -void sv_catpv P((SV* sv, char* ptr)); -void sv_catpvn P((SV* sv, char* ptr, STRLEN len)); -void sv_catsv P((SV* dsv, SV* ssv)); -void sv_chop P((SV* sv, char* ptr)); -void sv_clean_all P((void)); -void sv_clean_magic P((void)); -void sv_clean_refs P((void)); -void sv_clear P((SV* sv)); -I32 sv_cmp P((SV* sv1, SV* sv2)); -void sv_dec P((SV* sv)); -void sv_dump P((SV* sv)); -I32 sv_eq P((SV* sv1, SV* sv2)); -void sv_free P((SV* sv)); -char* sv_gets P((SV* sv, FILE* fp, I32 append)); +VOIDRET sighandler _((int sig)); +SV** stack_grow _((SV** sp, SV**p, int n)); +int start_subparse _((void)); +bool sv_2bool _((SV* sv)); +CV* sv_2cv _((SV* sv, HV** st, GV** gvp, I32 lref)); +IO* sv_2io _((SV* sv)); +IV sv_2iv _((SV* sv)); +SV* sv_2mortal _((SV* sv)); +double sv_2nv _((SV* sv)); +char* sv_2pv _((SV* sv, STRLEN* lp)); +int sv_backoff _((SV* sv)); +SV* sv_bless _((SV* sv, HV* stash)); +void sv_catpv _((SV* sv, char* ptr)); +void sv_catpvn _((SV* sv, char* ptr, STRLEN len)); +void sv_catsv _((SV* dsv, SV* ssv)); +void sv_chop _((SV* sv, char* ptr)); +void sv_clean_all _((void)); +void sv_clean_objs _((void)); +void sv_clear _((SV* sv)); +I32 sv_cmp _((SV* sv1, SV* sv2)); +void sv_dec _((SV* sv)); +void sv_dump _((SV* sv)); +I32 sv_eq _((SV* sv1, SV* sv2)); +void sv_free _((SV* sv)); +char* sv_gets _((SV* sv, FILE* fp, I32 append)); #ifndef DOSISH -char* sv_grow P((SV* sv, I32 newlen)); +char* sv_grow _((SV* sv, I32 newlen)); #else -char* sv_grow P((SV* sv, unsigned long newlen)); +char* sv_grow _((SV* sv, unsigned long newlen)); #endif -void sv_inc P((SV* sv)); -void sv_insert P((SV* bigsv, STRLEN offset, STRLEN len, char* little, STRLEN littlelen)); -SV* sv_interp P((SV* sv, SV* src, I32 sp)); -void sv_intrpcompile P((SV* src)); -int sv_isa P((SV* sv, char* name)); -int sv_isobject P((SV* sv)); -STRLEN sv_len P((SV* sv)); -void sv_magic P((SV* sv, SV* obj, char how, char* name, I32 namlen)); -SV* sv_mortalcopy P((SV* oldsv)); -SV* sv_newmortal P((void)); -SV* sv_newref P((SV* sv)); -void sv_replace P((SV* sv, SV* nsv)); -void sv_report_used P((void)); -void sv_reset P((char* s, HV* stash)); -void sv_setiv P((SV* sv, I32 num)); -void sv_setnv P((SV* sv, double num)); -void sv_setpv P((SV* sv, char* ptr)); -void sv_setpvn P((SV* sv, char* ptr, STRLEN len)); -void sv_setsv P((SV* dsv, SV* ssv)); -int sv_unmagic P((SV* sv, char type)); -void sv_unref P((SV* sv)); -void sv_usepvn P((SV* sv, char* ptr, STRLEN len)); -void taint_env P((void)); -void taint_not P((char *s)); -void taint_proper P((char* f, char* s)); -I32 uni P((I32 f, char* s)); -I32 unlnk P((char* f)); -I32 userinit P((void)); -I32 wait4pid P((int pid, int* statusp, int flags)); -void warn P((char* pat,...)); -I32 whichsig P((char* sig)); -void while_io P((OP* cmd)); -OP* wopt P((OP* cmd)); -int yyerror P((char* s)); -int yylex P((void)); -int yyparse P((void)); -int yywarn P((char* s)); +void sv_inc _((SV* sv)); +void sv_insert _((SV* bigsv, STRLEN offset, STRLEN len, char* little, STRLEN littlelen)); +int sv_isa _((SV* sv, char* name)); +int sv_isobject _((SV* sv)); +STRLEN sv_len _((SV* sv)); +void sv_magic _((SV* sv, SV* obj, int how, char* name, I32 namlen)); +SV* sv_mortalcopy _((SV* oldsv)); +SV* sv_newmortal _((void)); +SV* sv_newref _((SV* sv)); +char * sv_peek _((SV* sv)); +char * sv_pvn_force _((SV* sv, STRLEN* lp)); +char* sv_reftype _((SV* sv, int ob)); +void sv_replace _((SV* sv, SV* nsv)); +void sv_report_used _((void)); +void sv_reset _((char* s, HV* stash)); +void sv_setiv _((SV* sv, IV num)); +void sv_setnv _((SV* sv, double num)); +SV* sv_setref_iv _((SV *rv, char *classname, IV iv)); +SV* sv_setref_nv _((SV *rv, char *classname, double nv)); +SV* sv_setref_pv _((SV *rv, char *classname, void* pv)); +SV* sv_setref_pvn _((SV *rv, char *classname, char* pv, I32 n)); +void sv_setpv _((SV* sv, char* ptr)); +void sv_setpvn _((SV* sv, char* ptr, STRLEN len)); +void sv_setsv _((SV* dsv, SV* ssv)); +int sv_unmagic _((SV* sv, int type)); +void sv_unref _((SV* sv)); +bool sv_upgrade _((SV* sv, U32 mt)); +void sv_usepvn _((SV* sv, char* ptr, STRLEN len)); +void taint_env _((void)); +void taint_not _((char *s)); +void taint_proper _((char* f, char* s)); +I32 unlnk _((char* f)); +void utilize _((int aver, 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)); +I32 whichsig _((char* sig)); +int yyerror _((char* s)); +int yylex _((void)); +int yyparse _((void)); +int yywarn _((char* s)); diff --git a/protos b/protos deleted file mode 100755 index ff399654c9..0000000000 --- a/protos +++ /dev/null @@ -1,42 +0,0 @@ -#!/usr/bin/perl - -$/ = "\n{\n"; - -while (<>) { - chop; next unless chop($_) eq "{"; - s/[^\0]*\n\n//; - $* = 1; - s/^#.*\n//g; - $* = 0; - tr/\n/ /; - s#\*/#\200#g; - s#/\*[^\200]*\200##g; - /\b\w+\(/ || next; - $funtype = $`; - $name = $&; - $_ = $'; - /\)\s*/ || next; - $args = $`; - $types = $'; - $args =~ tr/ \t//d; - @args = split(/,/,$args); - @types = split(/;\s*/, $types); - %type = (); - foreach $type (@types) { - $type =~ /.*\b(\w+)/; - $type{$1} = $type; - } - foreach $arg (@args) { - $arg = $type{$arg} || $arg; - $arg =~ s/register //; - } - $funtype =~ s/\* $/*/; - $funtype =~ s/^ *//; - chop $name; - if (@args) { - print $funtype, $name, " P((", join(', ', @args), "));\n"; - } - else { - print $funtype, $name, " P((void));\n"; - } -} diff --git a/pstruct b/pstruct deleted file mode 100644 index 373c689ab0..0000000000 --- a/pstruct +++ /dev/null @@ -1,1071 +0,0 @@ -#!/usr/local/bin/perl -# -# -# c2ph (aka pstruct) -# Tom Christiansen, <tchrist@convex.com> -# -# As pstruct, dump C structures as generated from 'cc -g -S' stabs. -# As c2ph, do this PLUS generate perl code for getting at the structures. -# -# See the usage message for more. If this isn't enough, read the code. -# - -$RCSID = '$RCSfile: c2ph.SH,v $$Revision: 4.1 $$Date: 92/08/07 17:19:10 $'; - - -###################################################################### - -# some handy data definitions. many of these can be reset later. - -$bitorder = 'b'; # ascending; set to B for descending bit fields - -%intrinsics = -%template = ( - 'char', 'c', - 'unsigned char', 'C', - 'short', 's', - 'short int', 's', - 'unsigned short', 'S', - 'unsigned short int', 'S', - 'short unsigned int', 'S', - 'int', 'i', - 'unsigned int', 'I', - 'long', 'l', - 'long int', 'l', - 'unsigned long', 'L', - 'unsigned long', 'L', - 'long unsigned int', 'L', - 'unsigned long int', 'L', - 'long long', 'q', - 'long long int', 'q', - 'unsigned long long', 'Q', - 'unsigned long long int', 'Q', - 'float', 'f', - 'double', 'd', - 'pointer', 'p', - 'null', 'x', - 'neganull', 'X', - 'bit', $bitorder, -); - -&buildscrunchlist; -delete $intrinsics{'neganull'}; -delete $intrinsics{'bit'}; -delete $intrinsics{'null'}; - -# use -s to recompute sizes -%sizeof = ( - 'char', '1', - 'unsigned char', '1', - 'short', '2', - 'short int', '2', - 'unsigned short', '2', - 'unsigned short int', '2', - 'short unsigned int', '2', - 'int', '4', - 'unsigned int', '4', - 'long', '4', - 'long int', '4', - 'unsigned long', '4', - 'unsigned long int', '4', - 'long unsigned int', '4', - 'long long', '8', - 'long long int', '8', - 'unsigned long long', '8', - 'unsigned long long int', '8', - 'float', '4', - 'double', '8', - 'pointer', '4', -); - -($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); - -($offset_fmt, $size_fmt) = ('d', 'd'); - -$indent = 2; - -$CC = 'cc'; -$CFLAGS = '-g -S'; -$DEFINES = ''; - -$perl++ if $0 =~ m#/?c2ph$#; - -require 'getopts.pl'; - -eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; - -&Getopts('aixdpvtnws:') || &usage(0); - -$opt_d && $debug++; -$opt_t && $trace++; -$opt_p && $perl++; -$opt_v && $verbose++; -$opt_n && ($perl = 0); - -if ($opt_w) { - ($type_width, $member_width, $offset_width) = (45, 35, 8); -} -if ($opt_x) { - ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); -} - -eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; - -sub PLUMBER { - select(STDERR); - print "oops, apperent pager foulup\n"; - $isatty++; - &usage(1); -} - -sub usage { - local($oops) = @_; - unless (-t STDOUT) { - select(STDERR); - } elsif (!$oops) { - $isatty++; - $| = 1; - print "hit <RETURN> for further explanation: "; - <STDIN>; - open (PIPE, "|". ($ENV{PAGER} || 'more')); - $SIG{PIPE} = PLUMBER; - select(PIPE); - } - - print "usage: $0 [-dpnP] [var=val] [files ...]\n"; - - exit unless $isatty; - - print <<EOF; - -Options: - --w wide; short for: type_width=45 member_width=35 offset_width=8 --x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04 - --n do not generate perl code (default when invoked as pstruct) --p generate perl code (default when invoked as c2ph) --v generate perl code, with C decls as comments - --i do NOT recompute sizes for intrinsic datatypes --a dump information on intrinsics also - --t trace execution --d spew reams of debugging output - --slist give comma-separated list a structures to dump - - -Var Name Default Value Meaning - -EOF - - &defvar('CC', 'which_compiler to call'); - &defvar('CFLAGS', 'how to generate *.s files with stabs'); - &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U'); - - print "\n"; - - &defvar('type_width', 'width of type field (column 1)'); - &defvar('member_width', 'width of member field (column 2)'); - &defvar('offset_width', 'width of offset field (column 3)'); - &defvar('size_width', 'width of size field (column 4)'); - - print "\n"; - - &defvar('offset_fmt', 'sprintf format type for offset'); - &defvar('size_fmt', 'sprintf format type for size'); - - print "\n"; - - &defvar('indent', 'how far to indent each nesting level'); - - print <<'EOF'; - - If any *.[ch] files are given, these will be catted together into - a temporary *.c file and sent through: - $CC $CFLAGS $DEFINES - and the resulting *.s groped for stab information. If no files are - supplied, then stdin is read directly with the assumption that it - contains stab information. All other liens will be ignored. At - most one *.s file should be supplied. - -EOF - close PIPE; - exit 1; -} - -sub defvar { - local($var, $msg) = @_; - printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg; -} - -$recurse = 1; - -if (@ARGV) { - if (grep(!/\.[csh]$/,@ARGV)) { - warn "Only *.[csh] files expected!\n"; - &usage; - } - elsif (grep(/\.s$/,@ARGV)) { - if (@ARGV > 1) { - warn "Only one *.s file allowed!\n"; - &usage; - } - } - elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { - local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; - $chdir = "cd $dir; " if $dir; - &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; - $ARGV[0] =~ s/\.c$/.s/; - } - else { - $TMP = "/tmp/c2ph.$$.c"; - &system("cat @ARGV > $TMP") && exit 1; - &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1; - unlink $TMP; - $TMP =~ s/\.c$/.s/; - @ARGV = ($TMP); - } -} - -if ($opt_s) { - for (split(/[\s,]+/, $opt_s)) { - $interested{$_}++; - } -} - - -$| = 1 if $debug; - -main: { - - if ($trace) { - if (-t && !@ARGV) { - print STDERR "reading from your keyboard: "; - } else { - print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": "; - } - } - -STAB: while (<>) { - if ($trace && !($. % 10)) { - $lineno = $..''; - print STDERR $lineno, "\b" x length($lineno); - } - next unless /^\s*\.stabs\s+/; - $line = $_; - s/^\s*\.stabs\s+//; - &stab; - } - print STDERR "$.\n" if $trace; - unlink $TMP if $TMP; - - &compute_intrinsics if $perl && !$opt_i; - - print STDERR "resolving types\n" if $trace; - - &resolve_types; - &adjust_start_addrs; - - $sum = 2 + $type_width + $member_width; - $pmask1 = "%-${type_width}s %-${member_width}s"; - $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; - - if ($perl) { - # resolve template -- should be in stab define order, but even this isn't enough. - print STDERR "\nbuilding type templates: " if $trace; - for $i (reverse 0..$#type) { - next unless defined($name = $type[$i]); - next unless defined $struct{$name}; - $build_recursed = 0; - &build_template($name) unless defined $template{&psou($name)} || - $opt_s && !$interested{$name}; - } - print STDERR "\n\n" if $trace; - } - - print STDERR "dumping structs: " if $trace; - - - foreach $name (sort keys %struct) { - next if $opt_s && !$interested{$name}; - print STDERR "$name " if $trace; - - undef @sizeof; - undef @typedef; - undef @offsetof; - undef @indices; - undef @typeof; - - $mname = &munge($name); - - $fname = &psou($name); - - print "# " if $perl && $verbose; - $pcode = ''; - print "$fname {\n" if !$perl || $verbose; - $template{$fname} = &scrunch($template{$fname}) if $perl; - &pstruct($name,$name,0); - print "# " if $perl && $verbose; - print "}\n" if !$perl || $verbose; - print "\n" if $perl && $verbose; - - if ($perl) { - print "$pcode"; - - printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); - - print <<EOF; -sub ${mname}'typedef { - local(\$${mname}'index) = shift; - defined \$${mname}'index - ? \$${mname}'typedef[\$${mname}'index] - : \$${mname}'typedef; -} -EOF - - print <<EOF; -sub ${mname}'sizeof { - local(\$${mname}'index) = shift; - defined \$${mname}'index - ? \$${mname}'sizeof[\$${mname}'index] - : \$${mname}'sizeof; -} -EOF - - print <<EOF; -sub ${mname}'offsetof { - local(\$${mname}'index) = shift; - defined \$${mname}index - ? \$${mname}'offsetof[\$${mname}'index] - : \$${mname}'sizeof; -} -EOF - - print <<EOF; -sub ${mname}'typeof { - local(\$${mname}'index) = shift; - defined \$${mname}index - ? \$${mname}'typeof[\$${mname}'index] - : '$name'; -} -EOF - - - print "\$${mname}'typedef = '" . &scrunch($template{$fname}) - . "';\n"; - - print "\$${mname}'sizeof = $sizeof{$name};\n\n"; - - - print "\@${mname}'indices = (", &squishseq(@indices), ");\n"; - - print "\n"; - - print "\@${mname}'typedef[\@${mname}'indices] = (", - join("\n\t", '', @typedef), "\n );\n\n"; - print "\@${mname}'sizeof[\@${mname}'indices] = (", - join("\n\t", '', @sizeof), "\n );\n\n"; - print "\@${mname}'offsetof[\@${mname}'indices] = (", - join("\n\t", '', @offsetof), "\n );\n\n"; - print "\@${mname}'typeof[\@${mname}'indices] = (", - join("\n\t", '', @typeof), "\n );\n\n"; - - $template_printed{$fname}++; - $size_printed{$fname}++; - } - print "\n"; - } - - print STDERR "\n" if $trace; - - unless ($perl && $opt_a) { - print "\n1;\n"; - exit; - } - - - - foreach $name (sort bysizevalue keys %intrinsics) { - next if $size_printed{$name}; - print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n"; - } - - print "\n"; - - sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; } - - - foreach $name (sort keys %intrinsics) { - print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; - } - - print "\n1;\n"; - - exit; -} - -######################################################################################## - - -sub stab { - next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun - s/"// || next; - s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; - - next if /^\s*$/; - - $size = $3 if $3; - - - $line = $_; - - if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { - print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; - &pdecl($pdecl); - next; - } - - - - if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { - local($ident) = $2; - push(@intrinsics, $ident); - $typeno = &typeno($3); - $type[$typeno] = $ident; - print STDERR "intrinsic $ident in new type $typeno\n" if $debug; - next; - } - - if (($name, $typeordef, $typeno, $extra, $struct, $_) - = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) - { - $typeno = &typeno($typeno); # sun foolery - } - elsif (/^[\$\w]+:/) { - next; # variable - } - else { - warn "can't grok stab: <$_> in: $line " if $_; - next; - } - - #warn "got size $size for $name\n"; - $sizeof{$name} = $size if $size; - - s/;[-\d]*;[-\d]*;$//; # we don't care about ranges - - $typenos{$name} = $typeno; - - unless (defined $type[$typeno]) { - &panic("type 0??") unless $typeno; - $type[$typeno] = $name unless defined $type[$typeno]; - printf "new type $typeno is $name" if $debug; - if ($extra =~ /\*/ && defined $type[$struct]) { - print ", a typedef for a pointer to " , $type[$struct] if $debug; - } - } else { - printf "%s is type %d", $name, $typeno if $debug; - print ", a typedef for " , $type[$typeno] if $debug; - } - print "\n" if $debug; - #next unless $extra =~ /[su*]/; - - #$type[$struct] = $name; - - if ($extra =~ /[us*]/) { - &sou($name, $extra); - $_ = &sdecl($name, $_, 0); - } - elsif (/^=ar/) { - print "it's a bare array typedef -- that's pretty sick\n" if $debug; - $_ = "$typeno$_"; - $scripts = ''; - $_ = &adecl($_,1); - - } - elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc - push(@intrinsics, $2); - $typeno = &typeno($3); - $type[$typeno] = $2; - print STDERR "intrinsic $2 in new type $typeno\n" if $debug; - } - elsif (s/^=e//) { # blessed by thy compiler; mine won't do this - &edecl; - } - else { - warn "Funny remainder for $name on line $_ left in $line " if $_; - } -} - -sub typeno { # sun thinks types are (0,27) instead of just 27 - local($_) = @_; - s/\(\d+,(\d+)\)/$1/; - $_; -} - -sub pstruct { - local($what,$prefix,$base) = @_; - local($field, $fieldname, $typeno, $count, $offset, $entry); - local($fieldtype); - local($type, $tname); - local($mytype, $mycount, $entry2); - local($struct_count) = 0; - local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); - local($bits,$bytes); - local($template); - - - local($mname) = &munge($name); - - sub munge { - local($_) = @_; - s/[\s\$\.]/_/g; - $_; - } - - local($sname) = &psou($what); - - $nesting++; - - for $field (split(/;/, $struct{$what})) { - $pad = $prepad = 0; - $entry = ''; - ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); - - $type = $type[$typeno]; - - $type =~ /([^[]*)(\[.*\])?/; - $mytype = $1; - $count .= $2; - $fieldtype = &psou($mytype); - - local($fname) = &psou($name); - - if ($build_templates) { - - $pad = ($offset - ($lastoffset + $lastlength))/8 - if defined $lastoffset; - - if (! $finished_template{$sname}) { - if ($isaunion{$what}) { - $template{$sname} .= 'X' x $revpad . ' ' if $revpad; - } else { - $template{$sname} .= 'x' x $pad . ' ' if $pad; - } - } - - $template = &fetch_template($type) x - ($count ? &scripts2count($count) : 1); - - if (! $finished_template{$sname}) { - $template{$sname} .= $template; - } - - $revpad = $length/8 if $isaunion{$what}; - - ($lastoffset, $lastlength) = ($offset, $length); - - } else { - print '# ' if $perl && $verbose; - $entry = sprintf($pmask1, - ' ' x ($nesting * $indent) . $fieldtype, - "$prefix.$fieldname" . $count); - - $entry =~ s/(\*+)( )/$2$1/; - - printf $pmask2, - $entry, - ($base+$offset)/8, - ($bits = ($base+$offset)%8) ? ".$bits" : " ", - $length/8, - ($bits = $length % 8) ? ".$bits": "" - if !$perl || $verbose; - - - if ($perl && $nesting == 1) { - $template = &scrunch(&fetch_template($type) x - ($count ? &scripts2count($count) : 1)); - push(@sizeof, int($length/8) .",\t# $fieldname"); - push(@offsetof, int($offset/8) .",\t# $fieldname"); - push(@typedef, "'$template', \t# $fieldname"); - $type =~ s/(struct|union) //; - push(@typeof, "'$type" . ($count ? $count : '') . - "',\t# $fieldname"); - } - - print ' ', ' ' x $indent x $nesting, $template - if $perl && $verbose; - - print "\n" if !$perl || $verbose; - - } - if ($perl) { - local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; - $mycount *= &scripts2count($count) if $count; - if ($nesting==1 && !$build_templates) { - $pcode .= sprintf("sub %-32s { %4d; }\n", - "${mname}'${fieldname}", $struct_count); - push(@indices, $struct_count); - } - $struct_count += $mycount; - } - - - &pstruct($type, "$prefix.$fieldname", $base+$offset) - if $recurse && defined $struct{$type}; - } - - $countof{$what} = $struct_count unless defined $countof{$whati}; - - $template{$sname} .= '$' if $build_templates; - $finished_template{$sname}++; - - if ($build_templates && !defined $sizeof{$name}) { - local($fmt) = &scrunch($template{$sname}); - print STDERR "no size for $name, punting with $fmt..." if $debug; - eval '$sizeof{$name} = length(pack($fmt, ()))'; - if ($@) { - chop $@; - warn "couldn't get size for \$name: $@"; - } else { - print STDERR $sizeof{$name}, "\n" if $debUg; - } - } - - --$nesting; -} - - -sub psize { - local($me) = @_; - local($amstruct) = $struct{$me} ? 'struct ' : ''; - - print '$sizeof{\'', $amstruct, $me, '\'} = '; - printf "%d;\n", $sizeof{$me}; -} - -sub pdecl { - local($pdecl) = @_; - local(@pdecls); - local($tname); - - warn "pdecl: $pdecl\n" if $debug; - - $pdecl =~ s/\(\d+,(\d+)\)/$1/g; - $pdecl =~ s/\*//g; - @pdecls = split(/=/, $pdecl); - $typeno = $pdecls[0]; - $tname = pop @pdecls; - - if ($tname =~ s/^f//) { $tname = "$tname&"; } - #else { $tname = "$tname*"; } - - for (reverse @pdecls) { - $tname .= s/^f// ? "&" : "*"; - #$tname =~ s/^f(.*)/$1&/; - print "type[$_] is $tname\n" if $debug; - $type[$_] = $tname unless defined $type[$_]; - } -} - - - -sub adecl { - ($arraytype, $unknown, $lower, $upper) = (); - #local($typeno); - # global $typeno, @type - local($_, $typedef) = @_; - - while (s/^((\d+)=)?ar(\d+);//) { - ($arraytype, $unknown) = ($2, $3); - if (s/^(\d+);(\d+);//) { - ($lower, $upper) = ($1, $2); - $scripts .= '[' . ($upper+1) . ']'; - } else { - warn "can't find array bounds: $_"; - } - } - if (s/^([\d*f=]*),(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - local($whatis) = $1; - if ($whatis =~ /^(\d+)=/) { - $typeno = $1; - &pdecl($whatis); - } else { - $typeno = $whatis; - } - } elsif (s/^(\d+)(=[*suf]\d*)//) { - local($whatis) = $2; - - if ($whatis =~ /[f*]/) { - &pdecl($whatis); - } elsif ($whatis =~ /[su]/) { # - print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" - if $debug; - #$type[$typeno] = $name unless defined $type[$typeno]; - ##printf "new type $typeno is $name" if $debug; - $typeno = $1; - $type[$typeno] = "$prefix.$fieldname"; - local($name) = $type[$typeno]; - &sou($name, $whatis); - $_ = &sdecl($name, $_, $start+$offset); - 1; - $start = $start{$name}; - $offset = $sizeof{$name}; - $length = $offset; - } else { - warn "what's this? $whatis in $line "; - } - } elsif (/^\d+$/) { - $typeno = $_; - } else { - warn "bad array stab: $_ in $line "; - next STAB; - } - #local($wasdef) = defined($type[$typeno]) && $debug; - #if ($typedef) { - #print "redefining $type[$typeno] to " if $wasdef; - #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; - #print "$type[$typeno]\n" if $wasdef; - #} else { - #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; - #} - $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; - print "type[$arraytype] is $type[$arraytype]\n" if $debug; - print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; - $_; -} - - - -sub sdecl { - local($prefix, $_, $offset) = @_; - - local($fieldname, $scripts, $type, $arraytype, $unknown, - $whatis, $pdecl, $upper,$lower, $start,$length) = (); - local($typeno,$sou); - - -SFIELD: - while (/^([^;]+);/) { - $scripts = ''; - warn "sdecl $_\n" if $debug; - if (s/^([\$\w]+)://) { - $fieldname = $1; - } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # - $typeno = &typeno($1); - $type[$typeno] = "$prefix.$fieldname"; - local($name) = "$prefix.$fieldname"; - &sou($name,$2); - $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - $start = $start{$name}; - $offset += $sizeof{$name}; - #print "done with anon, start is $start, offset is $offset\n"; - #next SFIELD; - } else { - warn "weird field $_ of $line" if $debug; - next STAB; - #$fieldname = &gensym; - #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - } - - if (/^\d+=ar/) { - $_ = &adecl($_); - } - elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { - ($start, $length) = ($2, $3); - &panic("no length?") unless $length; - $typeno = &typeno($1) if $1; - } - elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { - ($pdecl, $start, $length) = ($1,$5,$6); - &pdecl($pdecl); - } - elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct - ($typeno, $sou) = ($1, $2); - $typeno = &typeno($typeno); - if (defined($type[$typeno])) { - warn "now how did we get type $1 in $fieldname of $line?"; - } else { - print "anon type $typeno is $prefix.$fieldname\n" if $debug; - $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; - }; - local($name) = "$prefix.$fieldname"; - &sou($name,$sou); - print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; - $type[$typeno] = "$prefix.$fieldname"; - $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); - $start = $start{$name}; - $length = $sizeof{$name}; - } - else { - warn "can't grok stab for $name ($_) in line $line "; - next STAB; - } - - &panic("no length for $prefix.$fieldname") unless $length; - $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; - } - if (s/;\d*,(\d+),(\d+);//) { - local($start, $size) = ($1, $2); - $sizeof{$prefix} = $size; - print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; - $start{$prefix} = $start; - } - $_; -} - -sub edecl { - s/;$//; - $enum{$name} = $_; - $_ = ''; -} - -sub resolve_types { - local($sou); - for $i (0 .. $#type) { - next unless defined $type[$i]; - $_ = $type[$i]; - unless (/\d/) { - print "type[$i] $type[$i]\n" if $debug; - next; - } - print "type[$i] $_ ==> " if $debug; - s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; - s/^(\d+)\&/&type($1)/e; - s/^(\d+)/&type($1)/e; - s/(\*+)([^*]+)(\*+)/$1$3$2/; - s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; - s/^(\d+)([\*\[].*)/&type($1).$2/e; - #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; - $type[$i] = $_; - print "$_\n" if $debug; - } -} -sub type { &psou($type[$_[0]] || "<UNDEFINED>"); } - -sub adjust_start_addrs { - for (sort keys %start) { - ($basename = $_) =~ s/\.[^.]+$//; - $start{$_} += $start{$basename}; - print "start: $_ @ $start{$_}\n" if $debug; - } -} - -sub sou { - local($what, $_) = @_; - /u/ && $isaunion{$what}++; - /s/ && $isastruct{$what}++; -} - -sub psou { - local($what) = @_; - local($prefix) = ''; - if ($isaunion{$what}) { - $prefix = 'union '; - } elsif ($isastruct{$what}) { - $prefix = 'struct '; - } - $prefix . $what; -} - -sub scrunch { - local($_) = @_; - - study; - - s/\$//g; - s/ / /g; - 1 while s/(\w) \1/$1$1/g; - - # i wanna say this, but perl resists my efforts: - # s/(\w)(\1+)/$2 . length($1)/ge; - - &quick_scrunch; - - s/ $//; - - $_; -} - -sub buildscrunchlist { - $scrunch_code = "sub quick_scrunch {\n"; - for (values %intrinsics) { - $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n"; - } - $scrunch_code .= "}\n"; - print "$scrunch_code" if $debug; - eval $scrunch_code; - &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; -} - -sub fetch_template { - local($mytype) = @_; - local($fmt); - local($count) = 1; - - &panic("why do you care?") unless $perl; - - if ($mytype =~ s/(\[\d+\])+$//) { - $count .= $1; - } - - if ($mytype =~ /\*/) { - $fmt = $template{'pointer'}; - } - elsif (defined $template{$mytype}) { - $fmt = $template{$mytype}; - } - elsif (defined $struct{$mytype}) { - if (!defined $template{&psou($mytype)}) { - &build_template($mytype) unless $mytype eq $name; - } - elsif ($template{&psou($mytype)} !~ /\$$/) { - #warn "incomplete template for $mytype\n"; - } - $fmt = $template{&psou($mytype)} || '?'; - } - else { - warn "unknown fmt for $mytype\n"; - $fmt = '?'; - } - - $fmt x $count . ' '; -} - -sub compute_intrinsics { - local($TMP) = "/tmp/c2ph-i.$$.c"; - open (TMP, ">$TMP") || die "can't open $TMP: $!"; - select(TMP); - - print STDERR "computing intrinsic sizes: " if $trace; - - undef %intrinsics; - - print <<'EOF'; -main() { - char *mask = "%d %s\n"; -EOF - - for $type (@intrinsics) { - next if $type eq 'void'; - print <<"EOF"; - printf(mask,sizeof($type), "$type"); -EOF - } - - print <<'EOF'; - printf(mask,sizeof(char *), "pointer"); - exit(0); -} -EOF - close TMP; - - select(STDOUT); - open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|"); - while (<PIPE>) { - chop; - split(' ',$_,2);; - print "intrinsic $_[1] is size $_[0]\n" if $debug; - $sizeof{$_[1]} = $_[0]; - $intrinsics{$_[1]} = $template{$_[0]}; - } - close(PIPE) || die "couldn't read intrinsics!"; - unlink($TMP, '/tmp/a.out'); - print STDERR "done\n" if $trace; -} - -sub scripts2count { - local($_) = @_; - - s/^\[//; - s/\]$//; - s/\]\[/*/g; - $_ = eval; - &panic("$_: $@") if $@; - $_; -} - -sub system { - print STDERR "@_\n" if $trace; - system @_; -} - -sub build_template { - local($name) = @_; - - &panic("already got a template for $name") if defined $template{$name}; - - local($build_templates) = 1; - - local($lparen) = '(' x $build_recursed; - local($rparen) = ')' x $build_recursed; - - print STDERR "$lparen$name$rparen " if $trace; - $build_recursed++; - &pstruct($name,$name,0); - print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; - --$build_recursed; -} - - -sub panic { - - select(STDERR); - - print "\npanic: @_\n"; - - exit 1 if $] <= 4.003; # caller broken - - local($i,$_); - local($p,$f,$l,$s,$h,$a,@a,@sub); - for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { - @a = @DB'args; - for (@a) { - if (/^StB\000/ && length($_) == length($_main{'_main'})) { - $_ = sprintf("%s",$_); - } - else { - s/'/\\'/g; - s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; - } - } - $w = $w ? '@ = ' : '$ = '; - $a = $h ? '(' . join(', ', @a) . ')' : ''; - push(@sub, "$w&$s$a from file $f line $l\n"); - last if $signal; - } - for ($i=0; $i <= $#sub; $i++) { - last if $signal; - print $sub[$i]; - } - exit 1; -} - -sub squishseq { - local($num); - local($last) = -1e8; - local($string); - local($seq) = '..'; - - while (defined($num = shift)) { - if ($num == ($last + 1)) { - $string .= $seq unless $inseq++; - $last = $num; - next; - } elsif ($inseq) { - $string .= $last unless $last == -1e8; - } - - $string .= ',' if defined $string; - $string .= $num; - $last = $num; - $inseq = 0; - } - $string .= $last if $inseq && $last != -e18; - $string; -} @@ -1,3 +1,10 @@ +/* regcomp.c + */ + +/* + * "A fair jaw-cracker dwarf-language must be." --Samwise Gamgee + */ + /* NOTE: this is derived from Henry Spencer's regexp code, and should not * confused with the original package (see point 3 below). Thanks, Henry! */ @@ -7,38 +14,6 @@ * blame Henry for some of the lack of readability. */ -/* $RCSfile: regcomp.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:28 $ - * - * $Log: regcomp.c,v $ - * Revision 4.1 92/08/07 18:26:28 lwall - * - * Revision 4.0.1.5 92/06/08 15:23:36 lwall - * patch20: Perl now distinguishes overlapped copies from non-overlapped - * patch20: /^stuff/ wrongly assumed an implicit $* == 1 - * patch20: /x{0}/ was wrongly interpreted as /x{0,}/ - * patch20: added \W, \S and \D inside /[...]/ - * - * Revision 4.0.1.4 91/11/05 22:55:14 lwall - * patch11: Erratum - * - * Revision 4.0.1.3 91/11/05 18:22:28 lwall - * patch11: minimum match length calculation in regexp is now cumulative - * patch11: initial .* in pattern had dependency on value of $* - * patch11: certain patterns made use of garbage pointers from uncleared memory - * patch11: prepared for ctype implementations that don't define isascii() - * - * Revision 4.0.1.2 91/06/07 11:48:24 lwall - * patch4: new copyright notice - * patch4: /(x+) \1/ incorrectly optimized to not match "xxx xx" - * patch4: // wouldn't use previous pattern if it started with a null character - * - * Revision 4.0.1.1 91/04/12 09:04:45 lwall - * patch1: random cleanup in cpp namespace - * - * Revision 4.0 91/03/20 01:39:01 lwall - * 4.0 baseline. - * - */ /*SUPPRESS 112*/ /* * regcomp and regexec -- regsub and regerror are not used in perl @@ -63,7 +38,7 @@ * **** Alterations to Henry's code are... **** - **** Copyright (c) 1991, Larry Wall + **** Copyright (c) 1991-1994, Larry Wall **** **** You may distribute under the terms of either the GNU General Public **** License or the Artistic License, as specified in the README file. @@ -106,26 +81,30 @@ /* * Flags to be passed up and down. */ -#define HASWIDTH 01 /* Known never to match null string. */ -#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ -#define SPSTART 04 /* Starts with * or +. */ #define WORST 0 /* Worst case. */ +#define HASWIDTH 0x1 /* Known never to match null string. */ +#define SIMPLE 0x2 /* Simple enough to be STAR/PLUS operand. */ +#define SPSTART 0x4 /* Starts with * or +. */ +#define TRYAGAIN 0x8 /* Weeded out a declaration. */ /* * Forward declarations for regcomp()'s friends. */ -STATIC I32 regcurly(); -STATIC char *reg(); -STATIC char *regbranch(); -STATIC char *regpiece(); -STATIC char *regatom(); -STATIC char *regclass(); -STATIC char *regnode(); -STATIC char *reganode(); -STATIC void regc(); -STATIC void reginsert(); -STATIC void regtail(); -STATIC void regoptail(); + +static char *reg _((I32, I32 *)); +static char *reganode _((char, unsigned short)); +static char *regatom _((I32 *)); +static char *regbranch _((I32 *)); +static void regc _((char)); +static char *regclass _((void)); +STATIC I32 regcurly _((char *)); +static char *regnode _((char)); +static char *regpiece _((I32 *)); +static void reginsert _((char, char *)); +static void regoptail _((char *, char *)); +static void regset _((char *, I32, I32)); +static void regtail _((char *, char *)); +static char* nextchar _((void)); /* - regcomp - compile a regular expression into internal code @@ -143,245 +122,255 @@ STATIC void regoptail(); * of the structure of the compiled regexp. [I'll say.] */ regexp * -regcomp(exp,xend,fold) -char *exp; -char *xend; -I32 fold; +regcomp(exp,xend,pm) +char* exp; +char* xend; +PMOP* pm; { - register regexp *r; - register char *scan; - register SV *longish; - SV *longest; - register I32 len; - register char *first; - I32 flags; - I32 backish; - I32 backest; - I32 curback; - I32 minlen; - I32 sawplus = 0; - I32 sawopen = 0; - - if (exp == NULL) - croak("NULL regexp argument"); - - /* First pass: determine size, legality. */ - regfold = fold; - regparse = exp; - regxend = xend; - regprecomp = nsavestr(exp,xend-exp); - regsawbracket = 0; - regsawback = 0; - regnpar = 1; - regsize = 0L; - regcode = ®dummy; - regc((char)MAGIC); - if (reg(0, &flags) == NULL) { - Safefree(regprecomp); - regprecomp = Nullch; - return(NULL); + I32 fold = pm->op_pmflags & PMf_FOLD; + register regexp *r; + register char *scan; + register SV *longish; + SV *longest; + register I32 len; + register char *first; + I32 flags; + I32 backish; + I32 backest; + I32 curback; + I32 minlen = 0; + I32 sawplus = 0; + I32 sawopen = 0; + + if (exp == NULL) + croak("NULL regexp argument"); + + /* First pass: determine size, legality. */ + regflags = pm->op_pmflags; + regparse = exp; + regxend = xend; + regprecomp = savepvn(exp,xend-exp); + regnaughty = 0; + regsawback = 0; + regnpar = 1; + regsize = 0L; + regcode = ®dummy; + regc((char)MAGIC); + if (reg(0, &flags) == NULL) { + Safefree(regprecomp); + regprecomp = Nullch; + return(NULL); + } + + /* Small enough for pointer-storage convention? */ + if (regsize >= 32767L) /* Probably could be 65535L. */ + FAIL("regexp too big"); + + /* Allocate space. */ + Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp); + if (r == NULL) + FAIL("regexp out of space"); + + /* Second pass: emit code. */ + r->prelen = xend-exp; + r->precomp = regprecomp; + r->subbeg = r->subbase = NULL; + regnaughty = 0; + regparse = exp; + regnpar = 1; + regcode = r->program; + regc((char)MAGIC); + if (reg(0, &flags) == NULL) + return(NULL); + + /* Dig out information for optimizations. */ + pm->op_pmflags = regflags; + fold = pm->op_pmflags & PMf_FOLD; + r->regstart = Nullsv; /* Worst-case defaults. */ + r->reganch = 0; + r->regmust = Nullsv; + r->regback = -1; + r->regstclass = Nullch; + r->naughty = regnaughty >= 10; /* Probably an expensive pattern. */ + scan = r->program+1; /* First BRANCH. */ + if (OP(regnext(scan)) == END) {/* Only one top-level choice. */ + scan = NEXTOPER(scan); + + first = scan; + while ((OP(first) == OPEN && (sawopen = 1)) || + (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) || + (OP(first) == PLUS) || + (OP(first) == MINMOD) || + (regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) { + if (OP(first) == PLUS) + sawplus = 1; + else + first += regarglen[(U8)OP(first)]; + first = NEXTOPER(first); } - /* Small enough for pointer-storage convention? */ - if (regsize >= 32767L) /* Probably could be 65535L. */ - FAIL("regexp too big"); - - /* Allocate space. */ - Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp); - if (r == NULL) - FAIL("regexp out of space"); - - /* Second pass: emit code. */ - if (regsawbracket) - Copy(regprecomp,exp,xend-exp,char); - r->prelen = xend-exp; - r->precomp = regprecomp; - r->subbeg = r->subbase = NULL; - regparse = exp; - regnpar = 1; - regcode = r->program; - regc((char)MAGIC); - if (reg(0, &flags) == NULL) - return(NULL); - - /* Dig out information for optimizations. */ - r->regstart = Nullsv; /* Worst-case defaults. */ - r->reganch = 0; - r->regmust = Nullsv; - r->regback = -1; - r->regstclass = Nullch; - scan = r->program+1; /* First BRANCH. */ - if (OP(regnext(scan)) == END) {/* Only one top-level choice. */ - scan = NEXTOPER(scan); - - first = scan; - while ((OP(first) == OPEN && (sawopen = 1)) || - (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) || - (OP(first) == PLUS) || - (OP(first) == CURLY && ARG1(first) > 0) ) { - if (OP(first) == PLUS) - sawplus = 1; - else - first += regarglen[OP(first)]; - first = NEXTOPER(first); + /* Starting-point info. */ + again: + if (OP(first) == EXACTLY) { + r->regstart = newSVpv(OPERAND(first)+1,*OPERAND(first)); + if (SvCUR(r->regstart) > !(sawstudy|fold)) + fbm_compile(r->regstart,fold); + else + sv_upgrade(r->regstart, SVt_PVBM); + } + else if (strchr(simple+2,OP(first))) + r->regstclass = first; + else if (OP(first) == BOUND || OP(first) == NBOUND) + r->regstclass = first; + else if (regkind[(U8)OP(first)] == BOL) { + r->reganch = ROPT_ANCH; + first = NEXTOPER(first); + goto again; + } + else if ((OP(first) == STAR && + regkind[(U8)OP(NEXTOPER(first))] == ANY) && + !(r->reganch & ROPT_ANCH) ) + { + /* turn .* into ^.* with an implied $*=1 */ + r->reganch = ROPT_ANCH | ROPT_IMPLICIT; + first = NEXTOPER(first); + goto again; + } + if (sawplus && (!sawopen || !regsawback)) + r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */ + + DEBUG_r(fprintf(stderr,"first %d next %d offset %d\n", + OP(first), OP(NEXTOPER(first)), first - scan)); + /* + * If there's something expensive in the r.e., find the + * longest literal string that must appear and make it the + * regmust. Resolve ties in favor of later strings, since + * the regstart check works with the beginning of the r.e. + * and avoiding duplication strengthens checking. Not a + * strong reason, but sufficient in the absence of others. + * [Now we resolve ties in favor of the earlier string if + * it happens that curback has been invalidated, since the + * earlier string may buy us something the later one won't.] + */ + longish = newSVpv("",0); + longest = newSVpv("",0); + len = 0; + minlen = 0; + curback = 0; + backish = 0; + backest = 0; + while (OP(scan) != END) { + if (OP(scan) == BRANCH) { + if (OP(regnext(scan)) == BRANCH) { + curback = -30000; + while (OP(scan) == BRANCH) + scan = regnext(scan); } + else /* single branch is ok */ + scan = NEXTOPER(scan); + } + if (OP(scan) == UNLESSM) { + curback = -30000; + scan = regnext(scan); + } + if (OP(scan) == EXACTLY) { + char *t; - /* Starting-point info. */ - again: - if (OP(first) == EXACTLY) { - r->regstart = - newSVpv(OPERAND(first)+1,*OPERAND(first)); - if (SvCUR(r->regstart) > !(sawstudy|fold)) - fbm_compile(r->regstart,fold); - else - sv_upgrade(r->regstart, SVt_PVBM); - } - else if ((exp = strchr(simple,OP(first))) && exp > simple) - r->regstclass = first; - else if (OP(first) == BOUND || OP(first) == NBOUND) - r->regstclass = first; - else if (OP(first) == BOL) { - r->reganch = ROPT_ANCH; - first = NEXTOPER(first); - goto again; + first = scan; + while (OP(t = regnext(scan)) == CLOSE) + scan = t; + minlen += *OPERAND(first); + if (curback - backish == len) { + sv_catpvn(longish, OPERAND(first)+1, + *OPERAND(first)); + len += *OPERAND(first); + curback += *OPERAND(first); + first = regnext(scan); } - else if ((OP(first) == STAR && OP(NEXTOPER(first)) == ANY) && - !(r->reganch & ROPT_ANCH) ) { - /* turn .* into ^.* with an implied $*=1 */ - r->reganch = ROPT_ANCH | ROPT_IMPLICIT; - first = NEXTOPER(first); - goto again; + else if (*OPERAND(first) >= len + (curback >= 0)) { + len = *OPERAND(first); + sv_setpvn(longish, OPERAND(first)+1,len); + backish = curback; + curback += len; + first = regnext(scan); } - 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 - * longest literal string that must appear and make it the - * regmust. Resolve ties in favor of later strings, since - * the regstart check works with the beginning of the r.e. - * and avoiding duplication strengthens checking. Not a - * strong reason, but sufficient in the absence of others. - * [Now we resolve ties in favor of the earlier string if - * it happens that curback has been invalidated, since the - * earlier string may buy us something the later one won't.] - */ - longish = newSVpv("",0); - longest = newSVpv("",0); + else + curback += *OPERAND(first); + } + else if (strchr(varies,OP(scan))) { + curback = -30000; len = 0; - minlen = 0; - curback = 0; - backish = 0; - backest = 0; - while (OP(scan) != END) { - if (OP(scan) == BRANCH) { - if (OP(regnext(scan)) == BRANCH) { - curback = -30000; - while (OP(scan) == BRANCH) - scan = regnext(scan); - } - else /* single branch is ok */ - scan = NEXTOPER(scan); - } - if (OP(scan) == EXACTLY) { - char *t; - - first = scan; - while (OP(t = regnext(scan)) == CLOSE) - scan = t; - minlen += *OPERAND(first); - if (curback - backish == len) { - sv_catpvn(longish, OPERAND(first)+1, - *OPERAND(first)); - len += *OPERAND(first); - curback += *OPERAND(first); - first = regnext(scan); - } - else if (*OPERAND(first) >= len + (curback >= 0)) { - len = *OPERAND(first); - sv_setpvn(longish, OPERAND(first)+1,len); - backish = curback; - curback += len; - first = regnext(scan); - } - else - curback += *OPERAND(first); - } - else if (strchr(varies,OP(scan))) { - curback = -30000; - len = 0; - if (SvCUR(longish) > SvCUR(longest)) { - sv_setsv(longest,longish); - backest = backish; - } - sv_setpvn(longish,"",0); - if (OP(scan) == PLUS && - strchr(simple,OP(NEXTOPER(scan)))) - minlen++; - else if (OP(scan) == CURLY && - strchr(simple,OP(NEXTOPER(scan)+4))) - minlen += ARG1(scan); - } - else if (strchr(simple,OP(scan))) { - curback++; - minlen++; - len = 0; - if (SvCUR(longish) > SvCUR(longest)) { - sv_setsv(longest,longish); - backest = backish; - } - sv_setpvn(longish,"",0); - } - scan = regnext(scan); - } - - /* Prefer earlier on tie, unless we can tail match latter */ - - if (SvCUR(longish) + (OP(first) == EOL) > SvCUR(longest)) { + if (SvCUR(longish) > SvCUR(longest)) { sv_setsv(longest,longish); backest = backish; } - else - sv_setpvn(longish,"",0); - if (SvCUR(longest) - && - (!r->regstart - || - !fbm_instr((unsigned char*) SvPVX(r->regstart), - (unsigned char *) SvPVX(r->regstart) - + SvCUR(r->regstart), - longest) - ) - ) - { - r->regmust = longest; - if (backest < 0) - backest = -1; - r->regback = backest; - if (SvCUR(longest) - > !(sawstudy || fold || OP(first) == EOL) ) - fbm_compile(r->regmust,fold); - SvUPGRADE(r->regmust, SVt_PVBM); - BmUSEFUL(r->regmust) = 100; - if (OP(first) == EOL && SvCUR(longish)) - SvTAIL_on(r->regmust); - } - else { - SvREFCNT_dec(longest); - longest = Nullsv; + sv_setpvn(longish,"",0); + if (OP(scan) == PLUS && strchr(simple,OP(NEXTOPER(scan)))) + minlen++; + else if (regkind[(U8)OP(scan)] == CURLY && + strchr(simple,OP(NEXTOPER(scan)+4))) + minlen += ARG1(scan); + } + else if (strchr(simple,OP(scan))) { + curback++; + minlen++; + len = 0; + if (SvCUR(longish) > SvCUR(longest)) { + sv_setsv(longest,longish); + backest = backish; } - SvREFCNT_dec(longish); + sv_setpvn(longish,"",0); + } + scan = regnext(scan); } - r->do_folding = fold; - r->nparens = regnpar - 1; - r->minlen = minlen; - Newz(1002, r->startp, regnpar, char*); - Newz(1002, r->endp, regnpar, char*); - DEBUG_r(regdump(r)); - return(r); + /* Prefer earlier on tie, unless we can tail match latter */ + + if (SvCUR(longish) + (regkind[(U8)OP(first)] == EOL) > + SvCUR(longest)) + { + sv_setsv(longest,longish); + backest = backish; + } + else + sv_setpvn(longish,"",0); + if (SvCUR(longest) + && + (!r->regstart + || + !fbm_instr((unsigned char*) SvPVX(r->regstart), + (unsigned char *) SvPVX(r->regstart) + + SvCUR(r->regstart), + longest) + ) + ) + { + r->regmust = longest; + if (backest < 0) + backest = -1; + r->regback = backest; + if (SvCUR(longest) > !(sawstudy || fold || + regkind[(U8)OP(first)]==EOL)) + fbm_compile(r->regmust,fold); + (void)SvUPGRADE(r->regmust, SVt_PVBM); + BmUSEFUL(r->regmust) = 100; + if (regkind[(U8)OP(first)] == EOL && SvCUR(longish)) + SvTAIL_on(r->regmust); + } + else { + SvREFCNT_dec(longest); + longest = Nullsv; + } + SvREFCNT_dec(longish); + } + + r->do_folding = fold; + r->nparens = regnpar - 1; + r->minlen = minlen; + Newz(1002, r->startp, regnpar, char*); + Newz(1002, r->endp, regnpar, char*); + DEBUG_r(regdump(r)); + return(r); } /* @@ -398,67 +387,122 @@ reg(paren, flagp) I32 paren; /* Parenthesized? */ I32 *flagp; { - register char *ret; - register char *br; - register char *ender; - register I32 parno; - I32 flags; - - *flagp = HASWIDTH; /* Tentatively. */ - - /* Make an OPEN node, if parenthesized. */ - if (paren) { - parno = regnpar; - regnpar++; - ret = reganode(OPEN, parno); - } else - ret = NULL; - - /* Pick up the branches, linking them together. */ + register char *ret; + register char *br; + register char *ender = 0; + register I32 parno = 0; + I32 flags; + + *flagp = HASWIDTH; /* Tentatively. */ + + /* Make an OPEN node, if parenthesized. */ + if (paren) { + if (*regparse == '?') { + regparse++; + paren = *nextchar(); + ret = NULL; + switch (paren) { + case ':': + case '=': + case '!': + break; + case '$': + case '@': + croak("Sequence (?%c...) not implemented", paren); + break; + case '#': + while (*regparse && *regparse != ')') + regparse++; + if (*regparse != ')') + croak("Sequence (?#... not terminated", *regparse); + nextchar(); + *flagp = TRYAGAIN; + return NULL; + default: + --regparse; + while (*regparse && strchr("iogmsx", *regparse)) + pmflag(®flags, *regparse++); + if (*regparse != ')') + croak("Sequence (?%c...) not recognized", *regparse); + nextchar(); + *flagp = TRYAGAIN; + return NULL; + } + } + else { + parno = regnpar; + regnpar++; + ret = reganode(OPEN, parno); + } + } else + ret = NULL; + + /* Pick up the branches, linking them together. */ + br = regbranch(&flags); + if (br == NULL) + return(NULL); + if (ret != NULL) + regtail(ret, br); /* OPEN -> first. */ + else + ret = br; + if (!(flags&HASWIDTH)) + *flagp &= ~HASWIDTH; + *flagp |= flags&SPSTART; + while (*regparse == '|') { + nextchar(); br = regbranch(&flags); if (br == NULL) - return(NULL); - if (ret != NULL) - regtail(ret, br); /* OPEN -> first. */ - else - ret = br; + return(NULL); + regtail(ret, br); /* BRANCH -> BRANCH. */ if (!(flags&HASWIDTH)) - *flagp &= ~HASWIDTH; + *flagp &= ~HASWIDTH; *flagp |= flags&SPSTART; - while (*regparse == '|') { - regparse++; - br = regbranch(&flags); - if (br == NULL) - return(NULL); - regtail(ret, br); /* BRANCH -> BRANCH. */ - if (!(flags&HASWIDTH)) - *flagp &= ~HASWIDTH; - *flagp |= flags&SPSTART; - } - - /* Make a closing node, and hook it on the end. */ - if (paren) - ender = reganode(CLOSE, parno); - else - ender = regnode(END); - regtail(ret, ender); - - /* Hook the tails of the branches to the closing node. */ - for (br = ret; br != NULL; br = regnext(br)) - regoptail(br, ender); - - /* Check for proper termination. */ - if (paren && *regparse++ != ')') { - FAIL("unmatched () in regexp"); - } else if (!paren && regparse < regxend) { - if (*regparse == ')') { - FAIL("unmatched () in regexp"); - } else - FAIL("junk on end of regexp"); /* "Can't happen". */ - /* NOTREACHED */ - } + } + + /* Make a closing node, and hook it on the end. */ + switch (paren) { + case ':': + ender = regnode(NOTHING); + break; + case 1: + ender = reganode(CLOSE, parno); + break; + case '=': + case '!': + ender = regnode(SUCCEED); + *flagp &= ~HASWIDTH; + break; + case 0: + ender = regnode(END); + break; + } + regtail(ret, ender); + + /* Hook the tails of the branches to the closing node. */ + for (br = ret; br != NULL; br = regnext(br)) + regoptail(br, ender); + + if (paren == '=') { + reginsert(IFMATCH,ret); + regtail(ret, regnode(NOTHING)); + } + else if (paren == '!') { + reginsert(UNLESSM,ret); + regtail(ret, regnode(NOTHING)); + } + + /* Check for proper termination. */ + if (paren && *nextchar() != ')') { + FAIL("unmatched () in regexp"); + } else if (!paren && regparse < regxend) { + if (*regparse == ')') { + FAIL("unmatched () in regexp"); + } else + FAIL("junk on end of regexp"); /* "Can't happen". */ + /* NOTREACHED */ + } - return(ret); + return(ret); } /* @@ -470,30 +514,38 @@ static char * regbranch(flagp) I32 *flagp; { - register char *ret; - register char *chain; - register char *latest; - I32 flags; - - *flagp = WORST; /* Tentatively. */ - - ret = regnode(BRANCH); - chain = NULL; - while (regparse < regxend && *regparse != '|' && *regparse != ')') { - latest = regpiece(&flags); - if (latest == NULL) - return(NULL); - *flagp |= flags&HASWIDTH; - if (chain == NULL) /* First piece. */ - *flagp |= flags&SPSTART; - else - regtail(chain, latest); - chain = latest; + register char *ret; + register char *chain; + register char *latest; + I32 flags = 0; + + *flagp = WORST; /* Tentatively. */ + + ret = regnode(BRANCH); + chain = NULL; + regparse--; + nextchar(); + while (regparse < regxend && *regparse != '|' && *regparse != ')') { + flags &= ~TRYAGAIN; + latest = regpiece(&flags); + if (latest == NULL) { + if (flags & TRYAGAIN) + continue; + return(NULL); + } + *flagp |= flags&HASWIDTH; + if (chain == NULL) /* First piece. */ + *flagp |= flags&SPSTART; + else { + regnaughty++; + regtail(chain, latest); } - if (chain == NULL) /* Loop ran zero times. */ - (void) regnode(NOTHING); + chain = latest; + } + if (chain == NULL) /* Loop ran zero times. */ + (void) regnode(NOTHING); - return(ret); + return(ret); } /* @@ -509,165 +561,134 @@ static char * regpiece(flagp) I32 *flagp; { - register char *ret; - register char op; - register char *next; - I32 flags; - char *origparse = regparse; - I32 orignpar = regnpar; - char *max; - I32 iter; - char ch; - - ret = regatom(&flags); - if (ret == NULL) - return(NULL); - - op = *regparse; - - /* Here's a total kludge: if after the atom there's a {\d+,?\d*} - * then we decrement the first number by one and reset our - * parsing back to the beginning of the same atom. If the first number - * is down to 0, decrement the second number instead and fake up - * a ? after it. Given the way this compiler doesn't keep track - * of offsets on the first pass, this is the only way to replicate - * a piece of code. Sigh. - */ - if (op == '{' && regcurly(regparse)) { - next = regparse + 1; - max = Nullch; - while (isDIGIT(*next) || *next == ',') { - if (*next == ',') { - if (max) - break; - else - max = next; - } - next++; + register char *ret; + register char op; + register char *next; + I32 flags; + char *origparse = regparse; + char *maxpos; + I32 min; + I32 max = 32767; + + ret = regatom(&flags); + if (ret == NULL) { + if (flags & TRYAGAIN) + *flagp |= TRYAGAIN; + return(NULL); + } + + op = *regparse; + if (op == '(' && regparse[1] == '?' && regparse[2] == '#') { + while (op && op != ')') + op = *++regparse; + if (op) { + nextchar(); + op = *regparse; + } + } + + if (op == '{' && regcurly(regparse)) { + next = regparse + 1; + maxpos = Nullch; + while (isDIGIT(*next) || *next == ',') { + if (*next == ',') { + if (maxpos) + break; + else + maxpos = next; } - if (*next == '}') { /* got one */ - if (!max) - max = next; - regparse++; - iter = atoi(regparse); - if (flags&SIMPLE) { /* we can do it right after all */ - I32 tmp; - - reginsert(CURLY, ret); - if (iter > 0) - *flagp = (WORST|HASWIDTH); - if (*max == ',') - max++; - else - max = regparse; - tmp = atoi(max); - if (!tmp && *max != '0') - tmp = 32767; /* meaning "infinity" */ - if (tmp && tmp < iter) - croak("Can't do {n,m} with n > m"); - if (regcode != ®dummy) { + next++; + } + if (*next == '}') { /* got one */ + if (!maxpos) + maxpos = next; + regparse++; + min = atoi(regparse); + if (*maxpos == ',') + maxpos++; + else + maxpos = regparse; + max = atoi(maxpos); + if (!max && *maxpos != '0') + max = 32767; /* meaning "infinity" */ + regparse = next; + nextchar(); + + do_curly: + if ((flags&SIMPLE)) { + regnaughty += 2 + regnaughty / 2; + reginsert(CURLY, ret); + } + else { + regnaughty += 4 + regnaughty; /* compound interest */ + regtail(ret, regnode(WHILEM)); + reginsert(CURLYX,ret); + regtail(ret, regnode(NOTHING)); + } + + if (min > 0) + *flagp = (WORST|HASWIDTH); + if (max && max < min) + croak("Can't do {n,m} with n > m"); + if (regcode != ®dummy) { #ifdef REGALIGN - *(unsigned short *)(ret+3) = iter; - *(unsigned short *)(ret+5) = tmp; + *(unsigned short *)(ret+3) = min; + *(unsigned short *)(ret+5) = max; #else - ret[3] = iter >> 8; ret[4] = iter & 0377; - ret[5] = tmp >> 8; ret[6] = tmp & 0377; + ret[3] = min >> 8; ret[4] = min & 0377; + ret[5] = max >> 8; ret[6] = max & 0377; #endif - } - regparse = next; - goto nest_check; - } - regsawbracket++; /* remember we clobbered exp */ - if (iter > 0) { - ch = *max; - sprintf(regparse,"%.*d", max-regparse, iter - 1); - *max = ch; - if (*max == ',' && max[1] != '}') { - if (atoi(max+1) <= 0) - croak("Can't do {n,m} with n > m"); - ch = *next; - sprintf(max+1,"%.*d", next-(max+1), atoi(max+1) - 1); - *next = ch; - } - if (iter != 1 || *max == ',') { - regparse = origparse; /* back up input pointer */ - regnpar = orignpar; /* don't make more parens */ - } - else { - regparse = next; - goto nest_check; - } - *flagp = flags; - return ret; - } - if (*max == ',') { - max++; - iter = atoi(max); - if (max == next) { /* any number more? */ - regparse = next; - op = '*'; /* fake up one with a star */ - } - else if (iter > 0) { - op = '?'; /* fake up optional atom */ - ch = *next; - sprintf(max,"%.*d", next-max, iter - 1); - *next = ch; - if (iter == 1) - regparse = next; - else { - regparse = origparse - 1; /* offset ++ below */ - regnpar = orignpar; - } - } - else - croak("Can't do {n,0}"); - } - else - croak("Can't do {0}"); } - } - if (!ISMULT1(op)) { - *flagp = flags; - return(ret); + goto nest_check; } + } - if (!(flags&HASWIDTH) && op != '?') - FAIL("regexp *+ operand could be empty"); - *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); - - if (op == '*' && (flags&SIMPLE)) - reginsert(STAR, ret); - else if (op == '*') { - /* Emit x* as (x&|), where & means "self". */ - reginsert(BRANCH, ret); /* Either x */ - regoptail(ret, regnode(BACK)); /* and loop */ - regoptail(ret, ret); /* back */ - regtail(ret, regnode(BRANCH)); /* or */ - regtail(ret, regnode(NOTHING)); /* null. */ - } else if (op == '+' && (flags&SIMPLE)) - reginsert(PLUS, ret); - else if (op == '+') { - /* Emit x+ as x(&|), where & means "self". */ - next = regnode(BRANCH); /* Either */ - regtail(ret, next); - regtail(regnode(BACK), ret); /* loop back */ - regtail(next, regnode(BRANCH)); /* or */ - regtail(ret, regnode(NOTHING)); /* null. */ - } else if (op == '?') { - /* Emit x? as (x|) */ - reginsert(BRANCH, ret); /* Either x */ - regtail(ret, regnode(BRANCH)); /* or */ - next = regnode(NOTHING); /* null. */ - regtail(ret, next); - regoptail(ret, next); - } - nest_check: - regparse++; - if (ISMULT2(regparse)) - FAIL("nested *?+ in regexp"); - + if (!ISMULT1(op)) { + *flagp = flags; return(ret); + } + nextchar(); + + *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); + + if (op == '*' && (flags&SIMPLE)) { + reginsert(STAR, ret); + regnaughty += 4; + } + else if (op == '*') { + min = 0; + goto do_curly; + } else if (op == '+' && (flags&SIMPLE)) { + reginsert(PLUS, ret); + regnaughty += 3; + } + else if (op == '+') { + min = 1; + goto do_curly; + } else if (op == '?') { + min = 0; max = 1; + goto do_curly; + } + nest_check: + if (dowarn && regcode != ®dummy && !(flags&HASWIDTH) && max > 10000) { + warn("%.*s matches null string many times", + regparse - origparse, origparse); + } + + if (*regparse == '?') { + nextchar(); + reginsert(MINMOD, ret); +#ifdef REGALIGN + regtail(ret, ret + 4); +#else + regtail(ret, ret + 3); +#endif + } + if (ISMULT2(regparse)) + FAIL("nested *?+ in regexp"); + + return(ret); } /* @@ -684,241 +705,300 @@ static char * regatom(flagp) I32 *flagp; { - register char *ret; - I32 flags; - - *flagp = WORST; /* Tentatively. */ - - switch (*regparse++) { - case '^': - ret = regnode(BOL); - break; - case '$': - ret = regnode(EOL); - break; - case '.': - ret = regnode(ANY); - *flagp |= HASWIDTH|SIMPLE; - break; - case '[': - ret = regclass(); - *flagp |= HASWIDTH|SIMPLE; - break; - case '(': - ret = reg(1, &flags); - if (ret == NULL) - return(NULL); - *flagp |= flags&(HASWIDTH|SPSTART); - break; - case '|': - case ')': - FAIL("internal urp in regexp"); /* Supposed to be caught earlier. */ - break; - case '?': - case '+': - case '*': - FAIL("?+* follows nothing in regexp"); - break; - case '\\': - switch (*regparse) { - case 'w': - ret = regnode(ALNUM); - *flagp |= HASWIDTH|SIMPLE; + register char *ret = 0; + I32 flags; + + *flagp = WORST; /* Tentatively. */ + +tryagain: + switch (*regparse) { + case '^': + nextchar(); + if (regflags & PMf_MULTILINE) + ret = regnode(MBOL); + else if (regflags & PMf_SINGLELINE) + ret = regnode(SBOL); + else + ret = regnode(BOL); + break; + case '$': + nextchar(); + if (regflags & PMf_MULTILINE) + ret = regnode(MEOL); + else if (regflags & PMf_SINGLELINE) + ret = regnode(SEOL); + else + ret = regnode(EOL); + break; + case '.': + nextchar(); + if (regflags & PMf_SINGLELINE) + ret = regnode(SANY); + else + ret = regnode(ANY); + regnaughty++; + *flagp |= HASWIDTH|SIMPLE; + break; + case '[': + regparse++; + ret = regclass(); + *flagp |= HASWIDTH|SIMPLE; + break; + case '(': + nextchar(); + ret = reg(1, &flags); + if (ret == NULL) { + if (flags & TRYAGAIN) + goto tryagain; + return(NULL); + } + *flagp |= flags&(HASWIDTH|SPSTART); + break; + case '|': + case ')': + if (flags & TRYAGAIN) { + *flagp |= TRYAGAIN; + return NULL; + } + croak("internal urp in regexp at /%s/", regparse); + /* Supposed to be caught earlier. */ + break; + case '?': + case '+': + case '*': + FAIL("?+* follows nothing in regexp"); + break; + case '\\': + switch (*++regparse) { + case 'A': + ret = regnode(SBOL); + *flagp |= SIMPLE; + nextchar(); + break; + case 'G': + ret = regnode(GBOL); + *flagp |= SIMPLE; + nextchar(); + break; + case 'Z': + ret = regnode(SEOL); + *flagp |= SIMPLE; + nextchar(); + break; + case 'w': + ret = regnode(ALNUM); + *flagp |= HASWIDTH|SIMPLE; + nextchar(); + break; + case 'W': + ret = regnode(NALNUM); + *flagp |= HASWIDTH|SIMPLE; + nextchar(); + break; + case 'b': + ret = regnode(BOUND); + *flagp |= SIMPLE; + nextchar(); + break; + case 'B': + ret = regnode(NBOUND); + *flagp |= SIMPLE; + nextchar(); + break; + case 's': + ret = regnode(SPACE); + *flagp |= HASWIDTH|SIMPLE; + nextchar(); + break; + case 'S': + ret = regnode(NSPACE); + *flagp |= HASWIDTH|SIMPLE; + nextchar(); + break; + case 'd': + ret = regnode(DIGIT); + *flagp |= HASWIDTH|SIMPLE; + nextchar(); + break; + case 'D': + ret = regnode(NDIGIT); + *flagp |= HASWIDTH|SIMPLE; + nextchar(); + break; + case 'n': + case 'r': + case 't': + case 'f': + case 'e': + case 'a': + case 'x': + case 'c': + case '0': + goto defchar; + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + { + I32 num = atoi(regparse); + + if (num > 9 && num >= regnpar) + goto defchar; + else { + regsawback = 1; + ret = reganode(REF, num); + *flagp |= HASWIDTH; + while (isDIGIT(*regparse)) regparse++; + regparse--; + nextchar(); + } + } + break; + case '\0': + if (regparse >= regxend) + FAIL("trailing \\ in regexp"); + /* FALL THROUGH */ + default: + goto defchar; + } + break; + default: { + register I32 len; + register char ender; + register char *p; + char *oldp; + I32 numlen; + + regparse++; + + defchar: + ret = regnode(EXACTLY); + regc(0); /* save spot for len */ + for (len = 0, p = regparse - 1; + len < 127 && p < regxend; + len++) + { + oldp = p; + switch (*p) { + case '^': + case '$': + case '.': + case '[': + case '(': + case ')': + case '|': + goto loopdone; + case '\\': + switch (*++p) { + case 'A': + case 'G': + case 'Z': + case 'w': + case 'W': + case 'b': + case 'B': + case 's': + case 'S': + case 'd': + case 'D': + --p; + goto loopdone; + case 'n': + ender = '\n'; + p++; break; - case 'W': - ret = regnode(NALNUM); - *flagp |= HASWIDTH|SIMPLE; - regparse++; + case 'r': + ender = '\r'; + p++; break; - case 'b': - ret = regnode(BOUND); - *flagp |= SIMPLE; - regparse++; + case 't': + ender = '\t'; + p++; break; - case 'B': - ret = regnode(NBOUND); - *flagp |= SIMPLE; - regparse++; + case 'f': + ender = '\f'; + p++; break; - case 's': - ret = regnode(SPACE); - *flagp |= HASWIDTH|SIMPLE; - regparse++; + case 'e': + ender = '\033'; + p++; break; - case 'S': - ret = regnode(NSPACE); - *flagp |= HASWIDTH|SIMPLE; - regparse++; + case 'a': + ender = '\007'; + p++; break; - case 'd': - ret = regnode(DIGIT); - *flagp |= HASWIDTH|SIMPLE; - regparse++; + case 'x': + ender = scan_hex(++p, 2, &numlen); + p += numlen; break; - case 'D': - ret = regnode(NDIGIT); - *flagp |= HASWIDTH|SIMPLE; - regparse++; + case 'c': + p++; + ender = *p++; + if (isLOWER(ender)) + ender = toUPPER(ender); + ender ^= 64; break; - case 'n': - case 'r': - case 't': - case 'f': - case 'e': - case 'a': - case 'x': - case 'c': - case '0': - goto defchar; - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - { - I32 num = atoi(regparse); - - if (num > 9 && num >= regnpar) - goto defchar; - else { - regsawback = 1; - ret = reganode(REF, num); - while (isDIGIT(*regparse)) - regparse++; - *flagp |= SIMPLE; - } + case '0': case '1': case '2': case '3':case '4': + case '5': case '6': case '7': case '8':case '9': + if (*p == '0' || + (isDIGIT(p[1]) && atoi(p) >= regnpar) ) { + ender = scan_oct(p, 3, &numlen); + p += numlen; + } + else { + --p; + goto loopdone; } break; - case '\0': - if (regparse >= regxend) + case '\0': + if (p >= regxend) FAIL("trailing \\ in regexp"); /* FALL THROUGH */ + default: + ender = *p++; + break; + } + break; + case ' ': case '\t': case '\n': case '\r': case '\f': case '\v': + if (regflags & PMf_EXTENDED) { + p++; + len--; + continue; + } + /* FALL THROUGH */ default: - goto defchar; + ender = *p++; + break; } - break; - default: { - register I32 len; - register char ender; - register char *p; - char *oldp; - I32 numlen; - - defchar: - ret = regnode(EXACTLY); - regc(0); /* save spot for len */ - for (len=0, p=regparse-1; - len < 127 && p < regxend; - len++) - { - oldp = p; - switch (*p) { - case '^': - case '$': - case '.': - case '[': - case '(': - case ')': - case '|': - goto loopdone; - case '\\': - switch (*++p) { - case 'w': - case 'W': - case 'b': - case 'B': - case 's': - case 'S': - case 'd': - case 'D': - --p; - goto loopdone; - case 'n': - ender = '\n'; - p++; - break; - case 'r': - ender = '\r'; - p++; - break; - case 't': - ender = '\t'; - p++; - break; - case 'f': - ender = '\f'; - p++; - break; - case 'e': - ender = '\033'; - p++; - break; - case 'a': - ender = '\007'; - p++; - break; - case 'x': - ender = scan_hex(++p, 2, &numlen); - p += numlen; - break; - case 'c': - p++; - ender = *p++; - if (isLOWER(ender)) - ender = toupper(ender); - ender ^= 64; - break; - case '0': case '1': case '2': case '3':case '4': - case '5': case '6': case '7': case '8':case '9': - if (*p == '0' || - (isDIGIT(p[1]) && atoi(p) >= regnpar) ) { - ender = scan_oct(p, 3, &numlen); - p += numlen; - } - else { - --p; - goto loopdone; - } - break; - case '\0': - if (p >= regxend) - FAIL("trailing \\ in regexp"); - /* FALL THROUGH */ - default: - ender = *p++; - break; - } - break; - default: - ender = *p++; - break; - } - if (regfold && isUPPER(ender)) - ender = tolower(ender); - if (ISMULT2(p)) { /* Back off on ?+*. */ - if (len) - p = oldp; - else { - len++; - regc(ender); - } - break; - } - regc(ender); - } - loopdone: - regparse = p; - if (len <= 0) - FAIL("internal disaster in regexp"); - *flagp |= HASWIDTH; - if (len == 1) - *flagp |= SIMPLE; - if (regcode != ®dummy) - *OPERAND(ret) = len; - regc('\0'); + if (regflags & PMf_FOLD && isUPPER(ender)) + ender = toLOWER(ender); + if (ISMULT2(p)) { /* Back off on ?+*. */ + if (len) + p = oldp; + else { + len++; + regc(ender); + } + break; } - break; + regc(ender); + } + loopdone: + regparse = p - 1; + nextchar(); + if (len < 0) + FAIL("internal disaster in regexp"); + if (len > 0) + *flagp |= HASWIDTH; + if (len == 1) + *flagp |= SIMPLE; + if (regcode != ®dummy) + *OPERAND(ret) = len; + regc('\0'); } + break; + } - return(ret); + return(ret); } static void @@ -927,333 +1007,366 @@ char *bits; I32 def; register I32 c; { - if (regcode == ®dummy) - return; - c &= 255; - if (def) - bits[c >> 3] &= ~(1 << (c & 7)); - else - bits[c >> 3] |= (1 << (c & 7)); + if (regcode == ®dummy) + return; + c &= 255; + if (def) + bits[c >> 3] &= ~(1 << (c & 7)); + else + bits[c >> 3] |= (1 << (c & 7)); } static char * regclass() { - register char *bits; - register I32 class; - register I32 lastclass; - register I32 range = 0; - register char *ret; - register I32 def; - I32 numlen; - - ret = regnode(ANYOF); - if (*regparse == '^') { /* Complement of range. */ + register char *bits; + register I32 class; + register I32 lastclass = 1234; + register I32 range = 0; + register char *ret; + register I32 def; + I32 numlen; + + ret = regnode(ANYOF); + if (*regparse == '^') { /* Complement of range. */ + regnaughty++; + regparse++; + def = 0; + } else { + def = 255; + } + bits = regcode; + for (class = 0; class < 32; class++) + regc(def); + if (*regparse == ']' || *regparse == '-') + goto skipcond; /* allow 1st char to be ] or - */ + while (regparse < regxend && *regparse != ']') { + skipcond: + class = UCHARAT(regparse++); + if (class == '\\') { + class = UCHARAT(regparse++); + switch (class) { + case 'w': + for (class = 0; class < 256; class++) + if (isALNUM(class)) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'W': + for (class = 0; class < 256; class++) + if (!isALNUM(class)) + regset(bits,def,class); + lastclass = 1234; + continue; + case 's': + for (class = 0; class < 256; class++) + if (isSPACE(class)) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'S': + for (class = 0; class < 256; class++) + if (!isSPACE(class)) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'd': + for (class = '0'; class <= '9'; class++) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'D': + for (class = 0; class < '0'; class++) + regset(bits,def,class); + for (class = '9' + 1; class < 256; class++) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'n': + class = '\n'; + break; + case 'r': + class = '\r'; + break; + case 't': + class = '\t'; + break; + case 'f': + class = '\f'; + break; + case 'b': + class = '\b'; + break; + case 'e': + class = '\033'; + break; + case 'a': + class = '\007'; + break; + case 'x': + class = scan_hex(regparse, 2, &numlen); + regparse += numlen; + break; + case 'c': + class = *regparse++; + if (isLOWER(class)) + class = toUPPER(class); + class ^= 64; + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + class = scan_oct(--regparse, 3, &numlen); + regparse += numlen; + break; + } + } + if (range) { + if (lastclass > class) + FAIL("invalid [] range in regexp"); + range = 0; + } + else { + lastclass = class; + if (*regparse == '-' && regparse+1 < regxend && + regparse[1] != ']') { regparse++; - def = 0; - } else { - def = 255; + range = 1; + continue; /* do it next time */ + } } - bits = regcode; - for (class = 0; class < 32; class++) - regc(def); - if (*regparse == ']' || *regparse == '-') - goto skipcond; /* allow 1st char to be ] or - */ - while (regparse < regxend && *regparse != ']') { - skipcond: - class = UCHARAT(regparse++); - if (class == '\\') { - class = UCHARAT(regparse++); - switch (class) { - case 'w': - for (class = 0; class < 256; class++) - if (isALNUM(class)) - regset(bits,def,class); - lastclass = 1234; - continue; - case 'W': - for (class = 0; class < 256; class++) - if (!isALNUM(class)) - regset(bits,def,class); - lastclass = 1234; - continue; - case 's': - for (class = 0; class < 256; class++) - if (isSPACE(class)) - regset(bits,def,class); - lastclass = 1234; - continue; - case 'S': - for (class = 0; class < 256; class++) - if (!isSPACE(class)) - regset(bits,def,class); - lastclass = 1234; - continue; - case 'd': - for (class = '0'; class <= '9'; class++) - regset(bits,def,class); - lastclass = 1234; - continue; - case 'D': - for (class = 0; class < '0'; class++) - regset(bits,def,class); - for (class = '9' + 1; class < 256; class++) - regset(bits,def,class); - lastclass = 1234; - continue; - case 'n': - class = '\n'; - break; - case 'r': - class = '\r'; - break; - case 't': - class = '\t'; - break; - case 'f': - class = '\f'; - break; - case 'b': - class = '\b'; - break; - case 'e': - class = '\033'; - break; - case 'a': - class = '\007'; - break; - case 'x': - class = scan_hex(regparse, 2, &numlen); - regparse += numlen; - break; - case 'c': - class = *regparse++; - if (isLOWER(class)) - class = toupper(class); - class ^= 64; - break; - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - class = scan_oct(--regparse, 3, &numlen); - regparse += numlen; - break; - } - } - if (range) { - if (lastclass > class) - FAIL("invalid [] range in regexp"); - range = 0; - } - else { - lastclass = class; - if (*regparse == '-' && regparse+1 < regxend && - regparse[1] != ']') { - regparse++; - range = 1; - continue; /* do it next time */ - } - } - for ( ; lastclass <= class; lastclass++) { - regset(bits,def,lastclass); - if (regfold && isUPPER(lastclass)) - regset(bits,def,tolower(lastclass)); - } - lastclass = class; + for ( ; lastclass <= class; lastclass++) { + regset(bits,def,lastclass); + if (regflags & PMf_FOLD && isUPPER(lastclass)) + regset(bits,def,toLOWER(lastclass)); } - if (*regparse != ']') - FAIL("unmatched [] in regexp"); - regparse++; - return ret; + lastclass = class; + } + if (*regparse != ']') + FAIL("unmatched [] in regexp"); + nextchar(); + return ret; +} + +static char* +nextchar() +{ + char* retval = regparse++; + + if (regflags & PMf_EXTENDED) { + while (isSPACE(*regparse)) + regparse++; + } + return retval; } /* - - regnode - emit a node - */ +- regnode - emit a node +*/ +#ifdef CAN_PROTOTYPE +static char * /* Location. */ +regnode(char op) +#else static char * /* Location. */ regnode(op) char op; +#endif { - register char *ret; - register char *ptr; + register char *ret; + register char *ptr; - ret = regcode; - if (ret == ®dummy) { + ret = regcode; + if (ret == ®dummy) { #ifdef REGALIGN - if (!(regsize & 1)) - regsize++; + if (!(regsize & 1)) + regsize++; #endif - regsize += 3; - return(ret); - } + regsize += 3; + return(ret); + } #ifdef REGALIGN #ifndef lint - if (!((long)ret & 1)) - *ret++ = 127; + if (!((long)ret & 1)) + *ret++ = 127; #endif #endif - ptr = ret; - *ptr++ = op; - *ptr++ = '\0'; /* Null "next" pointer. */ - *ptr++ = '\0'; - regcode = ptr; + ptr = ret; + *ptr++ = op; + *ptr++ = '\0'; /* Null "next" pointer. */ + *ptr++ = '\0'; + regcode = ptr; - return(ret); + return(ret); } /* - - reganode - emit a node with an argument - */ +- reganode - emit a node with an argument +*/ +#ifdef CAN_PROTOTYPE +static char * /* Location. */ +reganode(char op, unsigned short arg) +#else static char * /* Location. */ reganode(op, arg) char op; unsigned short arg; +#endif { - register char *ret; - register char *ptr; + register char *ret; + register char *ptr; - ret = regcode; - if (ret == ®dummy) { + ret = regcode; + if (ret == ®dummy) { #ifdef REGALIGN - if (!(regsize & 1)) - regsize++; + if (!(regsize & 1)) + regsize++; #endif - regsize += 5; - return(ret); - } + regsize += 5; + return(ret); + } #ifdef REGALIGN #ifndef lint - if (!((long)ret & 1)) - *ret++ = 127; + if (!((long)ret & 1)) + *ret++ = 127; #endif #endif - ptr = ret; - *ptr++ = op; - *ptr++ = '\0'; /* Null "next" pointer. */ - *ptr++ = '\0'; + ptr = ret; + *ptr++ = op; + *ptr++ = '\0'; /* Null "next" pointer. */ + *ptr++ = '\0'; #ifdef REGALIGN - *(unsigned short *)(ret+3) = arg; + *(unsigned short *)(ret+3) = arg; #else - ret[3] = arg >> 8; ret[4] = arg & 0377; + ret[3] = arg >> 8; ret[4] = arg & 0377; #endif - ptr += 2; - regcode = ptr; + ptr += 2; + regcode = ptr; - return(ret); + return(ret); } /* - - regc - emit (if appropriate) a byte of code - */ +- regc - emit (if appropriate) a byte of code +*/ +#ifdef CAN_PROTOTYPE +static void +regc(char b) +#else static void regc(b) char b; +#endif { - if (regcode != ®dummy) - *regcode++ = b; - else - regsize++; + if (regcode != ®dummy) + *regcode++ = b; + else + regsize++; } /* - - reginsert - insert an operator in front of already-emitted operand - * - * Means relocating the operand. - */ +- reginsert - insert an operator in front of already-emitted operand +* +* Means relocating the operand. +*/ +#ifdef CAN_PROTOTYPE +static void +reginsert(char op, char *opnd) +#else static void reginsert(op, opnd) char op; char *opnd; +#endif { - register char *src; - register char *dst; - register char *place; - register offset = (op == CURLY ? 4 : 0); + register char *src; + register char *dst; + register char *place; + register int offset = (regkind[(U8)op] == CURLY ? 4 : 0); - if (regcode == ®dummy) { + if (regcode == ®dummy) { #ifdef REGALIGN - regsize += 4 + offset; + regsize += 4 + offset; #else - regsize += 3 + offset; + regsize += 3 + offset; #endif - return; - } + return; + } - src = regcode; + src = regcode; #ifdef REGALIGN - regcode += 4 + offset; + regcode += 4 + offset; #else - regcode += 3 + offset; + regcode += 3 + offset; #endif - dst = regcode; - while (src > opnd) - *--dst = *--src; - - place = opnd; /* Op node, where operand used to be. */ - *place++ = op; + dst = regcode; + while (src > opnd) + *--dst = *--src; + + place = opnd; /* Op node, where operand used to be. */ + *place++ = op; + *place++ = '\0'; + *place++ = '\0'; + while (offset-- > 0) *place++ = '\0'; - *place++ = '\0'; - while (offset-- > 0) - *place++ = '\0'; #ifdef REGALIGN - *place++ = '\177'; + *place++ = '\177'; #endif } /* - - regtail - set the next-pointer at the end of a node chain - */ +- regtail - set the next-pointer at the end of a node chain +*/ static void regtail(p, val) char *p; char *val; { - register char *scan; - register char *temp; - register I32 offset; - - if (p == ®dummy) - return; - - /* Find last node. */ - scan = p; - for (;;) { - temp = regnext(scan); - if (temp == NULL) - break; - scan = temp; - } + register char *scan; + register char *temp; + register I32 offset; + + if (p == ®dummy) + return; + + /* Find last node. */ + scan = p; + for (;;) { + temp = regnext(scan); + if (temp == NULL) + break; + scan = temp; + } #ifdef REGALIGN - offset = val - scan; + offset = val - scan; #ifndef lint - *(short*)(scan+1) = offset; + *(short*)(scan+1) = offset; #else - offset = offset; + offset = offset; #endif #else - if (OP(scan) == BACK) - offset = scan - val; - else - offset = val - scan; - *(scan+1) = (offset>>8)&0377; - *(scan+2) = offset&0377; + if (OP(scan) == BACK) + offset = scan - val; + else + offset = val - scan; + *(scan+1) = (offset>>8)&0377; + *(scan+2) = offset&0377; #endif } /* - - regoptail - regtail on operand of first argument; nop if operandless - */ +- regoptail - regtail on operand of first argument; nop if operandless +*/ static void regoptail(p, val) char *p; char *val; { - /* "Operandless" and "op != BRANCH" are synonymous in practice. */ - if (p == NULL || p == ®dummy || OP(p) != BRANCH) - return; - regtail(NEXTOPER(p), val); + /* "Operandless" and "op != BRANCH" are synonymous in practice. */ + if (p == NULL || p == ®dummy || regkind[(U8)OP(p)] != BRANCH) + return; + regtail(NEXTOPER(p), val); } /* @@ -1287,151 +1400,190 @@ void regdump(r) regexp *r; { - register char *s; - register char op = EXACTLY; /* Arbitrary non-END op. */ - register char *next; + register char *s; + register char op = EXACTLY; /* Arbitrary non-END op. */ + register char *next; - s = r->program + 1; - while (op != END) { /* While that wasn't END last time... */ + s = r->program + 1; + while (op != END) { /* While that wasn't END last time... */ #ifdef REGALIGN - if (!((long)s & 1)) - s++; + if (!((long)s & 1)) + s++; #endif - op = OP(s); - fprintf(stderr,"%2d%s", s-r->program, regprop(s)); /* Where, what. */ - next = regnext(s); - s += regarglen[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; - } - if (op == EXACTLY) { - /* Literal string, where present. */ - s++; - while (*s != '\0') { - (void)putc(*s, stderr); - s++; - } - s++; - } - (void)putc('\n', stderr); + 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; } - - /* 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 %d ", SvPVX(r->regmust), - r->regback); - fprintf(stderr, "minlen %d ", r->minlen); - fprintf(stderr,"\n"); + 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"); } /* - - regprop - printable representation of opcode - */ +- regprop - printable representation of opcode +*/ char * regprop(op) char *op; { - register char *p; - - (void) strcpy(buf, ":"); - - switch (OP(op)) { - case BOL: - p = "BOL"; - break; - case EOL: - p = "EOL"; - break; - case ANY: - p = "ANY"; - break; - case ANYOF: - p = "ANYOF"; - break; - case BRANCH: - p = "BRANCH"; - break; - case EXACTLY: - p = "EXACTLY"; - break; - case NOTHING: - p = "NOTHING"; - break; - case BACK: - p = "BACK"; - break; - case END: - p = "END"; - break; - case ALNUM: - p = "ALNUM"; - break; - case NALNUM: - p = "NALNUM"; - break; - case BOUND: - p = "BOUND"; - break; - case NBOUND: - p = "NBOUND"; - break; - case SPACE: - p = "SPACE"; - break; - case NSPACE: - p = "NSPACE"; - break; - case DIGIT: - p = "DIGIT"; - break; - case NDIGIT: - p = "NDIGIT"; - break; - case CURLY: - (void)sprintf(buf+strlen(buf), "CURLY {%d,%d}", - ARG1(op),ARG2(op)); - p = NULL; - break; - case REF: - (void)sprintf(buf+strlen(buf), "REF%d", ARG1(op)); - p = NULL; - break; - case OPEN: - (void)sprintf(buf+strlen(buf), "OPEN%d", ARG1(op)); - p = NULL; - break; - case CLOSE: - (void)sprintf(buf+strlen(buf), "CLOSE%d", ARG1(op)); - p = NULL; - break; - case STAR: - p = "STAR"; - break; - case PLUS: - p = "PLUS"; - break; - default: - FAIL("corrupted regexp opcode"); - } - if (p != NULL) - (void) strcat(buf, p); - return(buf); + register char *p = 0; + + (void) strcpy(buf, ":"); + + switch (OP(op)) { + case BOL: + p = "BOL"; + break; + case MBOL: + p = "MBOL"; + break; + case SBOL: + p = "SBOL"; + break; + case EOL: + p = "EOL"; + break; + case MEOL: + p = "MEOL"; + break; + case SEOL: + p = "SEOL"; + break; + case ANY: + p = "ANY"; + break; + case SANY: + p = "SANY"; + break; + case ANYOF: + p = "ANYOF"; + break; + case BRANCH: + p = "BRANCH"; + break; + case EXACTLY: + p = "EXACTLY"; + break; + case NOTHING: + p = "NOTHING"; + break; + case BACK: + p = "BACK"; + break; + case END: + p = "END"; + break; + case ALNUM: + p = "ALNUM"; + break; + case NALNUM: + p = "NALNUM"; + break; + case BOUND: + p = "BOUND"; + break; + case NBOUND: + p = "NBOUND"; + break; + case SPACE: + p = "SPACE"; + break; + case NSPACE: + p = "NSPACE"; + break; + case DIGIT: + p = "DIGIT"; + break; + case NDIGIT: + p = "NDIGIT"; + break; + case CURLY: + (void)sprintf(buf+strlen(buf), "CURLY {%d,%d}", ARG1(op),ARG2(op)); + p = NULL; + break; + case CURLYX: + (void)sprintf(buf+strlen(buf), "CURLYX {%d,%d}", ARG1(op),ARG2(op)); + p = NULL; + break; + case REF: + (void)sprintf(buf+strlen(buf), "REF%d", ARG1(op)); + p = NULL; + break; + case OPEN: + (void)sprintf(buf+strlen(buf), "OPEN%d", ARG1(op)); + p = NULL; + break; + case CLOSE: + (void)sprintf(buf+strlen(buf), "CLOSE%d", ARG1(op)); + p = NULL; + break; + case STAR: + p = "STAR"; + break; + case PLUS: + p = "PLUS"; + break; + case MINMOD: + p = "MINMOD"; + break; + case GBOL: + p = "GBOL"; + break; + case UNLESSM: + p = "UNLESSM"; + break; + case IFMATCH: + p = "IFMATCH"; + break; + case SUCCEED: + p = "SUCCEED"; + break; + case WHILEM: + p = "WHILEM"; + break; + default: + FAIL("corrupted regexp opcode"); + } + if (p != NULL) + (void) strcat(buf, p); + return(buf); } #endif /* DEBUGGING */ @@ -1439,23 +1591,25 @@ void regfree(r) struct regexp *r; { - if (r->precomp) { - Safefree(r->precomp); - r->precomp = Nullch; - } - if (r->subbase) { - Safefree(r->subbase); - r->subbase = Nullch; - } - if (r->regmust) { - SvREFCNT_dec(r->regmust); - r->regmust = Nullsv; - } - if (r->regstart) { - SvREFCNT_dec(r->regstart); - r->regstart = Nullsv; - } - Safefree(r->startp); - Safefree(r->endp); - Safefree(r); + if (!r) + return; + if (r->precomp) { + Safefree(r->precomp); + r->precomp = Nullch; + } + if (r->subbase) { + Safefree(r->subbase); + r->subbase = Nullch; + } + if (r->regmust) { + SvREFCNT_dec(r->regmust); + r->regmust = Nullsv; + } + if (r->regstart) { + SvREFCNT_dec(r->regstart); + r->regstart = Nullsv; + } + Safefree(r->startp); + Safefree(r->endp); + Safefree(r); } @@ -1,14 +1,4 @@ -/* $RCSfile: regcomp.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:31 $ - * - * $Log: regcomp.h,v $ - * Revision 4.1 92/08/07 18:26:31 lwall - * - * Revision 4.0.1.1 91/06/07 11:49:40 lwall - * patch4: no change - * - * Revision 4.0 91/03/20 01:39:09 lwall - * 4.0 baseline. - * +/* regcomp.h */ /* @@ -60,27 +50,39 @@ /* definition number opnd? meaning */ #define END 0 /* no End of program. */ #define BOL 1 /* no Match "" at beginning of line. */ -#define EOL 2 /* no Match "" at end of line. */ -#define ANY 3 /* no Match any one character. */ -#define ANYOF 4 /* sv Match character in (or not in) this class. */ -#define CURLY 5 /* sv Match this simple thing {n,m} times. */ -#define BRANCH 6 /* node Match this alternative, or the next... */ -#define BACK 7 /* no Match "", "next" ptr points backward. */ -#define EXACTLY 8 /* sv Match this string (preceded by length). */ -#define NOTHING 9 /* no Match empty string. */ -#define STAR 10 /* node Match this (simple) thing 0 or more times. */ -#define PLUS 11 /* node Match this (simple) thing 1 or more times. */ -#define ALNUM 12 /* no Match any alphanumeric character */ -#define NALNUM 13 /* no Match any non-alphanumeric character */ -#define BOUND 14 /* no Match "" at any word boundary */ -#define NBOUND 15 /* no Match "" at any word non-boundary */ -#define SPACE 16 /* no Match any whitespace character */ -#define NSPACE 17 /* no Match any non-whitespace character */ -#define DIGIT 18 /* no Match any numeric character */ -#define NDIGIT 19 /* no Match any non-numeric character */ -#define REF 20 /* num Match some already matched string */ -#define OPEN 21 /* num Mark this point in input as start of #n. */ -#define CLOSE 22 /* num Analogous to OPEN. */ +#define MBOL 2 /* no Same, assuming multiline. */ +#define SBOL 3 /* no Same, assuming singleline. */ +#define EOL 4 /* no Match "" at end of line. */ +#define MEOL 5 /* no Same, assuming multiline. */ +#define SEOL 6 /* no Same, assuming singleline. */ +#define ANY 7 /* no Match any one character (except newline). */ +#define SANY 8 /* no Match any one character. */ +#define ANYOF 9 /* sv Match character in (or not in) this class. */ +#define CURLY 10 /* sv Match this simple thing {n,m} times. */ +#define CURLYX 11 /* sv Match this complex thing {n,m} times. */ +#define BRANCH 12 /* node Match this alternative, or the next... */ +#define BACK 13 /* no Match "", "next" ptr points backward. */ +#define EXACTLY 14 /* sv Match this string (preceded by length). */ +#define NOTHING 15 /* no Match empty string. */ +#define STAR 16 /* node Match this (simple) thing 0 or more times. */ +#define PLUS 17 /* node Match this (simple) thing 1 or more times. */ +#define ALNUM 18 /* no Match any alphanumeric character */ +#define NALNUM 19 /* no Match any non-alphanumeric character */ +#define BOUND 20 /* no Match "" at any word boundary */ +#define NBOUND 21 /* no Match "" at any word non-boundary */ +#define SPACE 22 /* no Match any whitespace character */ +#define NSPACE 23 /* no Match any non-whitespace character */ +#define DIGIT 24 /* no Match any numeric character */ +#define NDIGIT 25 /* no Match any non-numeric character */ +#define REF 26 /* num Match some already matched string */ +#define OPEN 27 /* num Mark this point in input as start of #n. */ +#define CLOSE 28 /* num Analogous to OPEN. */ +#define MINMOD 29 /* no Next operator is not greedy. */ +#define GBOL 30 /* no Matches where last m//g left off. */ +#define IFMATCH 31 /* no Succeeds if the following matches. */ +#define UNLESSM 32 /* no Fails if the following matches. */ +#define SUCCEED 33 /* no Return from a subroutine, basically. */ +#define WHILEM 34 /* no Do curly processing and see if rest matches. */ /* * Opcode notes: @@ -105,23 +107,65 @@ */ #ifndef DOINIT -extern char regarglen[]; +EXT char regarglen[]; +#else +EXT char regarglen[] = {0,0,0,0,0,0,0,0,0,0,4,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,2,2,0,0,0,0,0}; +#endif + +#ifndef DOINIT +EXT char regkind[]; #else -char regarglen[] = {0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,2,2}; +EXT char regkind[] = { + END, + BOL, + BOL, + BOL, + EOL, + EOL, + EOL, + ANY, + ANY, + ANYOF, + CURLY, + CURLY, + BRANCH, + BACK, + EXACTLY, + NOTHING, + STAR, + PLUS, + ALNUM, + NALNUM, + BOUND, + NBOUND, + SPACE, + NSPACE, + DIGIT, + NDIGIT, + REF, + OPEN, + CLOSE, + MINMOD, + BOL, + BRANCH, + BRANCH, + END, + WHILEM +}; #endif /* The following have no fixed length. */ #ifndef DOINIT -extern char varies[]; +EXT char varies[]; #else -char varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,REF,0}; +EXT char varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,CURLYX,REF,WHILEM,0}; #endif /* The following always have a length of 1. */ #ifndef DOINIT -extern char simple[]; +EXT char simple[]; #else -char simple[] = {ANY,ANYOF,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0}; +EXT char simple[] = {ANY,SANY,ANYOF,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0}; #endif EXT char regdummy; @@ -170,8 +214,10 @@ EXT char regdummy; #ifdef REGALIGN #define NEXTOPER(p) ((p) + 4) +#define PREVOPER(p) ((p) - 4) #else #define NEXTOPER(p) ((p) + 3) +#define PREVOPER(p) ((p) - 3) #endif #define MAGIC 0234 @@ -189,4 +235,4 @@ EXT char regdummy; #define UCHARAT(p) regdummy #endif /* lint */ -#define FAIL(m) croak("/%s/: %s",regprecomp,m) +#define FAIL(m) croak("/%.127s/: %s",regprecomp,m) @@ -1,3 +1,10 @@ +/* regexec.c + */ + +/* + * "One Ring to rule them all, One Ring to find them..." + */ + /* NOTE: this is derived from Henry Spencer's regexp code, and should not * confused with the original package (see point 3 below). Thanks, Henry! */ @@ -7,31 +14,6 @@ * blame Henry for some of the lack of readability. */ -/* $RCSfile: regexec.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:32 $ - * - * $Log: regexec.c,v $ - * Revision 4.1 92/08/07 18:26:32 lwall - * - * Revision 4.0.1.4 92/06/08 15:25:50 lwall - * patch20: pattern modifiers i and g didn't interact right - * patch20: in some cases $` and $' didn't get set by match - * patch20: /x{0}/ was wrongly interpreted as /x{0,}/ - * - * Revision 4.0.1.3 91/11/05 18:23:55 lwall - * patch11: prepared for ctype implementations that don't define isascii() - * patch11: initial .* in pattern had dependency on value of $* - * - * Revision 4.0.1.2 91/06/07 11:50:33 lwall - * patch4: new copyright notice - * patch4: // wouldn't use previous pattern if it started with a null character - * - * Revision 4.0.1.1 91/04/12 09:07:39 lwall - * patch1: regexec only allocated space for 9 subexpresssions - * - * Revision 4.0 91/03/20 01:39:16 lwall - * 4.0 baseline. - * - */ /*SUPPRESS 112*/ /* * regcomp and regexec -- regsub and regerror are not used in perl @@ -55,7 +37,7 @@ * **** Alterations to Henry's code are... **** - **** Copyright (c) 1991, Larry Wall + **** Copyright (c) 1991-1994, Larry Wall **** **** You may distribute under the terms of either the GNU General Public **** License or the Artistic License, as specified in the README file. @@ -73,9 +55,82 @@ #endif #ifdef DEBUGGING -I32 regnarrate = 0; +static I32 regnarrate = 0; +static char* regprogram = 0; #endif +/* Current curly descriptor */ +typedef struct curcur CURCUR; +struct curcur { + int parenfloor; /* how far back to strip paren data */ + int cur; /* how many instances of scan we've matched */ + int min; /* the minimal number of scans to match */ + int max; /* the maximal number of scans to match */ + int minmod; /* whether to work our way up or down */ + char * scan; /* the thing to match */ + char * next; /* what has to match after it */ + char * lastloc; /* where we started matching this scan */ + CURCUR * oldcc; /* current curly before we started this one */ +}; + +static CURCUR* regcc; + +typedef I32 CHECKPOINT; + +CHECKPOINT regcppush _((I32 parenfloor)); +char * regcppop _((void)); + +CHECKPOINT +regcppush(parenfloor) +I32 parenfloor; +{ + int retval = savestack_ix; + int i = (regsize - parenfloor) * 3; + int p; + + SSCHECK(i + 5); + for (p = regsize; p > parenfloor; p--) { + SSPUSHPTR(regendp[p]); + SSPUSHPTR(regstartp[p]); + SSPUSHINT(p); + } + SSPUSHINT(regsize); + SSPUSHINT(*reglastparen); + SSPUSHPTR(reginput); + SSPUSHINT(i + 3); + SSPUSHINT(SAVEt_REGCONTEXT); + return retval; +} + +char* +regcppop() +{ + I32 i = SSPOPINT; + U32 paren = 0; + char *input; + char *tmps; + assert(i == SAVEt_REGCONTEXT); + i = SSPOPINT; + input = (char *) SSPOPPTR; + *reglastparen = SSPOPINT; + regsize = SSPOPINT; + for (i -= 3; i > 0; i -= 3) { + paren = (U32)SSPOPINT; + regstartp[paren] = (char *) SSPOPPTR; + tmps = (char*)SSPOPPTR; + if (paren <= *reglastparen) + regendp[paren] = tmps; + } + for (paren = *reglastparen + 1; paren <= regnpar; paren++) { + if (paren > regsize) + regstartp[paren] = Nullch; + regendp[paren] = Nullch; + } + return input; +} + +#define regcpblow(cp) leave_scope(cp) + /* * regexec and friends */ @@ -83,9 +138,10 @@ I32 regnarrate = 0; /* * Forwards. */ -STATIC I32 regtry(); -STATIC I32 regmatch(); -STATIC I32 regrepeat(); + +static I32 regmatch _((char *prog)); +static I32 regrepeat _((char *p, I32 max)); +static I32 regtry _((regexp *prog, char *startpos)); /* - regexec - match a regexp against a string @@ -100,404 +156,393 @@ I32 minend; /* end of match must be at least minend after stringarg */ SV *screamer; I32 safebase; /* no need to remember string in subbase */ { - register char *s; - register I32 i; - register char *c; - register char *string = stringarg; - register I32 tmp; - I32 minlen = 0; /* must match at least this many chars */ - I32 dontbother = 0; /* how many characters not to try at end */ - - /* Be paranoid... */ - if (prog == NULL || string == NULL) { - croak("NULL regexp parameter"); - return(0); - } + register char *s; + register I32 i; + register char *c; + register char *startpos = stringarg; + register I32 tmp; + I32 minlen = 0; /* must match at least this many chars */ + I32 dontbother = 0; /* how many characters not to try at end */ + CURCUR cc; - if (string == strbeg) /* is ^ valid at stringarg? */ - regprev = '\n'; - else { - regprev = stringarg[-1]; - if (!multiline && regprev == '\n') - regprev = '\0'; /* force ^ to NOT match */ + cc.cur = 0; + regcc = &cc; + +#ifdef DEBUGGING + regnarrate = debug & 512; + regprogram = prog->program; +#endif + + /* Be paranoid... */ + if (prog == NULL || startpos == NULL) { + croak("NULL regexp parameter"); + return 0; + } + + if (startpos == strbeg) /* is ^ valid at stringarg? */ + regprev = '\n'; + else { + regprev = stringarg[-1]; + if (!multiline && regprev == '\n') + regprev = '\0'; /* force ^ to NOT match */ + } + regprecomp = prog->precomp; + regnpar = prog->nparens; + /* Check validity of program. */ + if (UCHARAT(prog->program) != MAGIC) { + FAIL("corrupted regexp program"); + } + + if (prog->do_folding) { + i = strend - startpos; + New(1101,c,i+1,char); + Copy(startpos, c, i+1, char); + startpos = c; + strend = startpos + i; + for (s = startpos; s < strend; s++) + if (isUPPER(*s)) + *s = toLOWER(*s); + } + + /* If there is a "must appear" string, look for it. */ + s = startpos; + if (prog->regmust != Nullsv && + (!(prog->reganch & ROPT_ANCH) + || (multiline && prog->regback >= 0)) ) + { + if (stringarg == strbeg && screamer) { + if (screamfirst[BmRARE(prog->regmust)] >= 0) + s = screaminstr(screamer,prog->regmust); + else + s = Nullch; } - regprecomp = prog->precomp; - /* Check validity of program. */ - if (UCHARAT(prog->program) != MAGIC) { - FAIL("corrupted regexp program"); + else + s = fbm_instr((unsigned char*)s, (unsigned char*)strend, + prog->regmust); + if (!s) { + ++BmUSEFUL(prog->regmust); /* hooray */ + goto phooey; /* not present */ } - - if (prog->do_folding) { - i = strend - string; - New(1101,c,i+1,char); - Copy(string, c, i+1, char); - string = c; - strend = string + i; - for (s = string; s < strend; s++) - if (isUPPER(*s)) - *s = tolower(*s); + else if (prog->regback >= 0) { + s -= prog->regback; + if (s < startpos) + s = startpos; + minlen = prog->regback + SvCUR(prog->regmust); } - - /* If there is a "must appear" string, look for it. */ - s = string; - if (prog->regmust != Nullsv && - (!(prog->reganch & ROPT_ANCH) - || (multiline && prog->regback >= 0)) ) { - if (stringarg == strbeg && screamer) { - if (screamfirst[BmRARE(prog->regmust)] >= 0) - s = screaminstr(screamer,prog->regmust); - else - s = Nullch; - } -#ifndef lint - else - s = fbm_instr((unsigned char*)s, (unsigned char*)strend, - prog->regmust); -#endif - if (!s) { - ++BmUSEFUL(prog->regmust); /* hooray */ - goto phooey; /* not present */ - } - else if (prog->regback >= 0) { - s -= prog->regback; - if (s < string) - s = string; - minlen = prog->regback + SvCUR(prog->regmust); - } - else if (--BmUSEFUL(prog->regmust) < 0) { /* boo */ - SvREFCNT_dec(prog->regmust); - prog->regmust = Nullsv; /* disable regmust */ - s = string; - } - else { - s = string; - minlen = SvCUR(prog->regmust); - } + else if (!prog->naughty && --BmUSEFUL(prog->regmust) < 0) { /* boo */ + SvREFCNT_dec(prog->regmust); + prog->regmust = Nullsv; /* disable regmust */ + s = startpos; + } + else { + s = startpos; + minlen = SvCUR(prog->regmust); } + } - /* Mark beginning of line for ^ . */ - regbol = string; + /* Mark beginning of line for ^ . */ + regbol = startpos; - /* Mark end of line for $ (and such) */ - regeol = strend; + /* Mark end of line for $ (and such) */ + regeol = strend; - /* see how far we have to get to not match where we matched before */ - regtill = string+minend; + /* see how far we have to get to not match where we matched before */ + regtill = startpos+minend; - /* Allocate our backreference arrays */ - if ( regmyp_size < prog->nparens + 1 ) { - /* Allocate or enlarge the arrays */ - regmyp_size = prog->nparens + 1; - if ( regmyp_size < 10 ) regmyp_size = 10; /* minimum */ - if ( regmystartp ) { - /* reallocate larger */ - Renew(regmystartp,regmyp_size,char*); - Renew(regmyendp, regmyp_size,char*); - } - else { - /* Initial allocation */ - New(1102,regmystartp,regmyp_size,char*); - New(1102,regmyendp, regmyp_size,char*); + /* Simplest case: anchored match need be tried only once. */ + /* [unless multiline is set] */ + if (prog->reganch & ROPT_ANCH) { + if (regtry(prog, startpos)) + goto got_it; + else if (multiline || (prog->reganch & ROPT_IMPLICIT)) { + if (minlen) + dontbother = minlen - 1; + strend -= dontbother; + /* for multiline we only have to try after newlines */ + if (s > startpos) + s--; + while (s < strend) { + if (*s++ == '\n') { + if (s < strend && regtry(prog, s)) + goto got_it; + } } - } + goto phooey; + } - /* Simplest case: anchored match need be tried only once. */ - /* [unless multiline is set] */ - if (prog->reganch & ROPT_ANCH) { - if (regtry(prog, string)) + /* Messy cases: unanchored match. */ + if (prog->regstart) { + if (prog->reganch & ROPT_SKIP) { /* we have /x+whatever/ */ + /* it must be a one character string */ + i = SvPVX(prog->regstart)[0]; + while (s < strend) { + if (*s == i) { + if (regtry(prog, s)) goto got_it; - else if (multiline || (prog->reganch & ROPT_IMPLICIT)) { - if (minlen) - dontbother = minlen - 1; - strend -= dontbother; - /* for multiline we only have to try after newlines */ - if (s > string) - s--; - while (s < strend) { - if (*s++ == '\n') { - if (s < strend && regtry(prog, s)) - goto got_it; - } - } + s++; + while (s < strend && *s == i) + s++; } - goto phooey; + s++; + } } + else if (SvPOK(prog->regstart) == 3) { + /* We know what string it must start with. */ + while ((s = fbm_instr((unsigned char*)s, + (unsigned char*)strend, prog->regstart)) != NULL) + { + if (regtry(prog, s)) + goto got_it; + s++; + } + } + else { + c = SvPVX(prog->regstart); + while ((s = ninstr(s, strend, c, c + SvCUR(prog->regstart))) != NULL) + { + if (regtry(prog, s)) + goto got_it; + s++; + } + } + goto phooey; + } + /*SUPPRESS 560*/ + if (c = prog->regstclass) { + I32 doevery = (prog->reganch & ROPT_SKIP) == 0; - /* Messy cases: unanchored match. */ - if (prog->regstart) { - if (prog->reganch & ROPT_SKIP) { /* we have /x+whatever/ */ - /* it must be a one character string */ - i = SvPVX(prog->regstart)[0]; - while (s < strend) { - if (*s == i) { - if (regtry(prog, s)) - goto got_it; - s++; - while (s < strend && *s == i) - s++; - } - s++; - } - } - else if (SvPOK(prog->regstart) == 3) { - /* We know what string it must start with. */ -#ifndef lint - while ((s = fbm_instr((unsigned char*)s, - (unsigned char*)strend, prog->regstart)) != NULL) -#else - while (s = Nullch) -#endif - { - if (regtry(prog, s)) - goto got_it; - s++; - } + if (minlen) + dontbother = minlen - 1; + strend -= dontbother; /* don't bother with what can't match */ + tmp = 1; + /* We know what class it must start with. */ + switch (OP(c)) { + case ANYOF: + c = OPERAND(c); + while (s < strend) { + i = UCHARAT(s); + if (!(c[i >> 3] & (1 << (i&7)))) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; } - else { - c = SvPVX(prog->regstart); - while ((s = ninstr(s, strend, - c, c + SvCUR(prog->regstart) )) != NULL) { - if (regtry(prog, s)) - goto got_it; - s++; - } + else + tmp = 1; + s++; + } + break; + case BOUND: + if (minlen) + dontbother++,strend--; + if (s != startpos) { + i = s[-1]; + tmp = isALNUM(i); + } + else + tmp = isALNUM(regprev); /* assume not alphanumeric */ + while (s < strend) { + i = *s; + if (tmp != isALNUM(i)) { + tmp = !tmp; + if (regtry(prog, s)) + goto got_it; } - goto phooey; - } - /*SUPPRESS 560*/ - if (c = prog->regstclass) { - I32 doevery = (prog->reganch & ROPT_SKIP) == 0; - - if (minlen) - dontbother = minlen - 1; - strend -= dontbother; /* don't bother with what can't match */ - tmp = 1; - /* We know what class it must start with. */ - switch (OP(c)) { - case ANYOF: - c = OPERAND(c); - while (s < strend) { - i = UCHARAT(s); - if (!(c[i >> 3] & (1 << (i&7)))) { - if (tmp && regtry(prog, s)) - goto got_it; - else - tmp = doevery; - } - else - tmp = 1; - s++; - } - break; - case BOUND: - if (minlen) - dontbother++,strend--; - if (s != string) { - i = s[-1]; - tmp = isALNUM(i); - } + s++; + } + if ((minlen || tmp) && regtry(prog,s)) + goto got_it; + break; + case NBOUND: + if (minlen) + dontbother++,strend--; + if (s != startpos) { + i = s[-1]; + tmp = isALNUM(i); + } + else + tmp = isALNUM(regprev); /* assume not alphanumeric */ + while (s < strend) { + i = *s; + if (tmp != isALNUM(i)) + tmp = !tmp; + else if (regtry(prog, s)) + goto got_it; + s++; + } + if ((minlen || !tmp) && regtry(prog,s)) + goto got_it; + break; + case ALNUM: + while (s < strend) { + i = *s; + if (isALNUM(i)) { + if (tmp && regtry(prog, s)) + goto got_it; else - tmp = isALNUM(regprev); /* assume not alphanumeric */ - while (s < strend) { - i = *s; - if (tmp != isALNUM(i)) { - tmp = !tmp; - if (regtry(prog, s)) - goto got_it; - } - s++; - } - if ((minlen || tmp) && regtry(prog,s)) - goto got_it; - break; - case NBOUND: - if (minlen) - dontbother++,strend--; - if (s != string) { - i = s[-1]; - tmp = isALNUM(i); - } + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + case NALNUM: + while (s < strend) { + i = *s; + if (!isALNUM(i)) { + if (tmp && regtry(prog, s)) + goto got_it; else - tmp = isALNUM(regprev); /* assume not alphanumeric */ - while (s < strend) { - i = *s; - if (tmp != isALNUM(i)) - tmp = !tmp; - else if (regtry(prog, s)) - goto got_it; - s++; - } - if ((minlen || !tmp) && regtry(prog,s)) - goto got_it; - break; - case ALNUM: - while (s < strend) { - i = *s; - if (isALNUM(i)) { - if (tmp && regtry(prog, s)) - goto got_it; - else - tmp = doevery; - } - else - tmp = 1; - s++; - } - break; - case NALNUM: - while (s < strend) { - i = *s; - if (!isALNUM(i)) { - if (tmp && regtry(prog, s)) - goto got_it; - else - tmp = doevery; - } - else - tmp = 1; - s++; - } - break; - case SPACE: - while (s < strend) { - if (isSPACE(*s)) { - if (tmp && regtry(prog, s)) - goto got_it; - else - tmp = doevery; - } - else - tmp = 1; - s++; - } - break; - case NSPACE: - while (s < strend) { - if (!isSPACE(*s)) { - if (tmp && regtry(prog, s)) - goto got_it; - else - tmp = doevery; - } - else - tmp = 1; - s++; - } - break; - case DIGIT: - while (s < strend) { - if (isDIGIT(*s)) { - if (tmp && regtry(prog, s)) - goto got_it; - else - tmp = doevery; - } - else - tmp = 1; - s++; - } - break; - case NDIGIT: - while (s < strend) { - if (!isDIGIT(*s)) { - if (tmp && regtry(prog, s)) - goto got_it; - else - tmp = doevery; - } - else - tmp = 1; - s++; - } - break; + tmp = doevery; } - } - else { - if (minlen) - dontbother = minlen - 1; - strend -= dontbother; - /* We don't know much -- general case. */ - do { - if (regtry(prog, s)) - goto got_it; - } while (s++ < strend); - } - - /* Failure. */ - goto phooey; - - got_it: - prog->subbeg = strbeg; - prog->subend = strend; - if ((!safebase && (prog->nparens || sawampersand)) || prog->do_folding){ - strend += dontbother; /* uncheat */ - i = strend - string + (stringarg - strbeg); - if (safebase) { /* no need for $digit later */ - s = strbeg; - prog->subend = s+i; + else + tmp = 1; + s++; + } + break; + case SPACE: + while (s < strend) { + if (isSPACE(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; } - else if (strbeg != prog->subbase) { - s = nsavestr(strbeg,i); /* so $digit will work later */ - if (prog->subbase) - Safefree(prog->subbase); - prog->subbeg = prog->subbase = s; - prog->subend = s+i; + else + tmp = 1; + s++; + } + break; + case NSPACE: + while (s < strend) { + if (!isSPACE(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; } - else { - prog->subbeg = s = prog->subbase; - prog->subend = s+i; + else + tmp = 1; + s++; + } + break; + case DIGIT: + while (s < strend) { + if (isDIGIT(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; } - s += (stringarg - strbeg); - for (i = 0; i <= prog->nparens; i++) { - if (prog->endp[i]) { - prog->startp[i] = s + (prog->startp[i] - string); - prog->endp[i] = s + (prog->endp[i] - string); - } + else + tmp = 1; + s++; + } + break; + case NDIGIT: + while (s < strend) { + if (!isDIGIT(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; } - if (prog->do_folding) - Safefree(string); + else + tmp = 1; + s++; + } + break; } - return(1); + } + else { + if (minlen) + dontbother = minlen - 1; + strend -= dontbother; + /* We don't know much -- general case. */ + do { + if (regtry(prog, s)) + goto got_it; + } while (s++ < strend); + } + + /* Failure. */ + goto phooey; - phooey: +got_it: + prog->subbeg = strbeg; + prog->subend = strend; + if ((!safebase && (prog->nparens || sawampersand)) || prog->do_folding) { + strend += dontbother; /* uncheat */ + i = strend - startpos + (stringarg - strbeg); + if (safebase) { /* no need for $digit later */ + s = strbeg; + prog->subend = s+i; + } + else if (strbeg != prog->subbase) { + s = savepvn(strbeg,i); /* so $digit will work later */ + if (prog->subbase) + Safefree(prog->subbase); + prog->subbeg = prog->subbase = s; + prog->subend = s+i; + } + else { + prog->subbeg = s = prog->subbase; + prog->subend = s+i; + } + s += (stringarg - strbeg); + for (i = 0; i <= prog->nparens; i++) { + if (prog->endp[i]) { + prog->startp[i] = s + (prog->startp[i] - startpos); + prog->endp[i] = s + (prog->endp[i] - startpos); + } + } if (prog->do_folding) - Safefree(string); - return(0); + Safefree(startpos); + } + return 1; + +phooey: + if (prog->do_folding) + Safefree(startpos); + return 0; } /* - regtry - try match at specific point */ static I32 /* 0 failure, 1 success */ -regtry(prog, string) +regtry(prog, startpos) regexp *prog; -char *string; +char *startpos; { - register I32 i; - register char **sp; - register char **ep; - - reginput = string; - regstartp = prog->startp; - regendp = prog->endp; - reglastparen = &prog->lastparen; - prog->lastparen = 0; - - sp = prog->startp; - ep = prog->endp; - if (prog->nparens) { - for (i = prog->nparens; i >= 0; i--) { - *sp++ = NULL; - *ep++ = NULL; - } + register I32 i; + register char **sp; + register char **ep; + + reginput = startpos; + regstartp = prog->startp; + regendp = prog->endp; + reglastparen = &prog->lastparen; + prog->lastparen = 0; + regsize = 0; + + sp = prog->startp; + ep = prog->endp; + if (prog->nparens) { + for (i = prog->nparens; i >= 0; i--) { + *sp++ = NULL; + *ep++ = NULL; } - if (regmatch(prog->program + 1) && reginput >= regtill) { - prog->startp[0] = string; - prog->endp[0] = reginput; - return(1); - } else - return(0); + } + if (regmatch(prog->program + 1) && reginput >= regtill) { + prog->startp[0] = startpos; + prog->endp[0] = reginput; + return 1; + } + else + return 0; } /* @@ -518,296 +563,405 @@ static I32 /* 0 failure, 1 success */ regmatch(prog) char *prog; { - register char *scan; /* Current node. */ - char *next; /* Next node. */ - register I32 nextchar; - register I32 n; /* no or next */ - register I32 ln; /* len or last */ - register char *s; /* operand or save */ - register char *locinput = reginput; - - nextchar = *locinput; - scan = prog; -#ifdef DEBUGGING - if (scan != NULL && regnarrate) - fprintf(stderr, "%s(\n", regprop(scan)); -#endif - while (scan != NULL) { + register char *scan; /* Current node. */ + char *next; /* Next node. */ + register I32 nextchar; + register I32 n; /* no or next */ + register I32 ln; /* len or last */ + register char *s; /* operand or save */ + register char *locinput = reginput; + int minmod = 0; + + nextchar = *locinput; + scan = prog; + while (scan != NULL) { #ifdef DEBUGGING - if (regnarrate) - fprintf(stderr, "%s...\n", regprop(scan)); + if (regnarrate) + fprintf(stderr, "%2d%-8.8s\t<%.10s>\n", + scan - regprogram, regprop(scan), locinput); #endif #ifdef REGALIGN - next = scan + NEXT(scan); - if (next == scan) - next = NULL; + next = scan + NEXT(scan); + if (next == scan) + next = NULL; #else - next = regnext(scan); + next = regnext(scan); #endif - switch (OP(scan)) { - case BOL: - if (locinput == regbol ? regprev == '\n' : - ((nextchar || locinput < regeol) && - locinput[-1] == '\n') ) - { - /* regtill = regbol; */ - break; - } - return(0); - case EOL: - if ((nextchar || locinput < regeol) && nextchar != '\n') - return(0); - if (!multiline && regeol - locinput > 1) - return 0; - /* regtill = regbol; */ - break; - case ANY: - if ((nextchar == '\0' && locinput >= regeol) || - nextchar == '\n') - return(0); - nextchar = *++locinput; - break; - case EXACTLY: - s = OPERAND(scan); - ln = *s++; - /* Inline the first character, for speed. */ - if (*s != nextchar) - return(0); - if (regeol - locinput < ln) - return 0; - if (ln > 1 && bcmp(s, locinput, ln) != 0) - return(0); - locinput += ln; - nextchar = *locinput; - break; - case ANYOF: - s = OPERAND(scan); - if (nextchar < 0) - nextchar = UCHARAT(locinput); - if (s[nextchar >> 3] & (1 << (nextchar&7))) - return(0); - if (!nextchar && locinput >= regeol) - return 0; - nextchar = *++locinput; - break; - case ALNUM: - if (!nextchar) - return(0); - if (!isALNUM(nextchar)) - return(0); - nextchar = *++locinput; - break; - case NALNUM: - if (!nextchar && locinput >= regeol) - return(0); - if (isALNUM(nextchar)) - return(0); - nextchar = *++locinput; - break; - case NBOUND: - case BOUND: - if (locinput == regbol) /* was last char in word? */ - ln = isALNUM(regprev); - else - ln = isALNUM(locinput[-1]); - n = isALNUM(nextchar); /* is next char in word? */ - if ((ln == n) == (OP(scan) == BOUND)) - return(0); - break; - case SPACE: - if (!nextchar && locinput >= regeol) - return(0); - if (!isSPACE(nextchar)) - return(0); - nextchar = *++locinput; - break; - case NSPACE: - if (!nextchar) - return(0); - if (isSPACE(nextchar)) - return(0); - nextchar = *++locinput; - break; - case DIGIT: - if (!isDIGIT(nextchar)) - return(0); - nextchar = *++locinput; - break; - case NDIGIT: - if (!nextchar && locinput >= regeol) - return(0); - if (isDIGIT(nextchar)) - return(0); - nextchar = *++locinput; - break; - case REF: - n = ARG1(scan); /* which paren pair */ - s = regmystartp[n]; - if (!s) - return(0); - if (!regmyendp[n]) - return(0); - if (s == regmyendp[n]) - break; - /* Inline the first character, for speed. */ - if (*s != nextchar) - return(0); - ln = regmyendp[n] - s; - if (locinput + ln > regeol) - return 0; - if (ln > 1 && bcmp(s, locinput, ln) != 0) - return(0); - locinput += ln; - nextchar = *locinput; - break; - - case NOTHING: - break; - case BACK: - break; - case OPEN: - n = ARG1(scan); /* which paren pair */ - reginput = locinput; + switch (OP(scan)) { + case BOL: + if (locinput == regbol + ? regprev == '\n' + : ((nextchar || locinput < regeol) && locinput[-1] == '\n') ) + { + /* regtill = regbol; */ + break; + } + return 0; + case MBOL: + if (locinput == regbol + ? regprev == '\n' + : ((nextchar || locinput < regeol) && locinput[-1] == '\n') ) + { + break; + } + return 0; + case SBOL: + if (locinput == regbol && regprev == '\n') + break; + return 0; + case GBOL: + if (locinput == regbol) + break; + return 0; + case EOL: + if (multiline) + goto meol; + else + goto seol; + case MEOL: + meol: + if ((nextchar || locinput < regeol) && nextchar != '\n') + return 0; + break; + case SEOL: + seol: + if ((nextchar || locinput < regeol) && nextchar != '\n') + return 0; + if (regeol - locinput > 1) + return 0; + break; + case SANY: + if (!nextchar && locinput >= regeol) + return 0; + nextchar = *++locinput; + break; + case ANY: + if (!nextchar && locinput >= regeol || nextchar == '\n') + return 0; + nextchar = *++locinput; + break; + case EXACTLY: + s = OPERAND(scan); + ln = *s++; + /* Inline the first character, for speed. */ + if (*s != nextchar) + return 0; + if (regeol - locinput < ln) + return 0; + if (ln > 1 && bcmp(s, locinput, ln) != 0) + return 0; + locinput += ln; + nextchar = *locinput; + break; + case ANYOF: + s = OPERAND(scan); + if (nextchar < 0) + nextchar = UCHARAT(locinput); + if (s[nextchar >> 3] & (1 << (nextchar&7))) + return 0; + if (!nextchar && locinput >= regeol) + return 0; + nextchar = *++locinput; + break; + case ALNUM: + if (!nextchar) + return 0; + if (!isALNUM(nextchar)) + return 0; + nextchar = *++locinput; + break; + case NALNUM: + if (!nextchar && locinput >= regeol) + return 0; + if (isALNUM(nextchar)) + return 0; + nextchar = *++locinput; + break; + case NBOUND: + case BOUND: + if (locinput == regbol) /* was last char in word? */ + ln = isALNUM(regprev); + else + ln = isALNUM(locinput[-1]); + n = isALNUM(nextchar); /* is next char in word? */ + if ((ln == n) == (OP(scan) == BOUND)) + return 0; + break; + case SPACE: + if (!nextchar && locinput >= regeol) + return 0; + if (!isSPACE(nextchar)) + return 0; + nextchar = *++locinput; + break; + case NSPACE: + if (!nextchar) + return 0; + if (isSPACE(nextchar)) + return 0; + nextchar = *++locinput; + break; + case DIGIT: + if (!isDIGIT(nextchar)) + return 0; + nextchar = *++locinput; + break; + case NDIGIT: + if (!nextchar && locinput >= regeol) + return 0; + if (isDIGIT(nextchar)) + return 0; + nextchar = *++locinput; + break; + case REF: + n = ARG1(scan); /* which paren pair */ + s = regstartp[n]; + if (!s) + return 0; + if (!regendp[n]) + return 0; + if (s == regendp[n]) + break; + /* Inline the first character, for speed. */ + if (*s != nextchar) + return 0; + ln = regendp[n] - s; + if (locinput + ln > regeol) + return 0; + if (ln > 1 && bcmp(s, locinput, ln) != 0) + return 0; + locinput += ln; + nextchar = *locinput; + break; + + case NOTHING: + break; + case BACK: + break; + case OPEN: + n = ARG1(scan); /* which paren pair */ + regstartp[n] = locinput; + if (n > regsize) + regsize = n; + break; + case CLOSE: + n = ARG1(scan); /* which paren pair */ + regendp[n] = locinput; + if (n > *reglastparen) + *reglastparen = n; + break; + case CURLYX: { + CURCUR cc; + CHECKPOINT cp = savestack_ix; + cc.oldcc = regcc; + regcc = &cc; + cc.parenfloor = *reglastparen; + cc.cur = -1; + cc.min = ARG1(scan); + cc.max = ARG2(scan); + cc.scan = NEXTOPER(scan) + 4; + cc.next = next; + cc.minmod = minmod; + cc.lastloc = 0; + reginput = locinput; + n = regmatch(PREVOPER(next)); /* start on the WHILEM */ + regcpblow(cp); + regcc = cc.oldcc; + return n; + } + /* NOT REACHED */ + case WHILEM: { + /* + * This is really hard to understand, because after we match + * what we're trying to match, we must make sure the rest of + * the RE is going to match for sure, and to do that we have + * to go back UP the parse tree by recursing ever deeper. And + * if it fails, we have to reset our parent's current state + * that we can try again after backing off. + */ + + CURCUR* cc = regcc; + n = cc->cur + 1; + reginput = locinput; + + /* If degenerate scan matches "", assume scan done. */ + + if (locinput == cc->lastloc) { + regcc = cc->oldcc; + ln = regcc->cur; + if (regmatch(cc->next)) + return TRUE; + regcc->cur = ln; + regcc = cc; + return FALSE; + } + + /* First just match a string of min scans. */ + + if (n < cc->min) { + cc->cur = n; + cc->lastloc = locinput; + return regmatch(cc->scan); + } + + /* Prefer next over scan for minimal matching. */ + + if (cc->minmod) { + regcc = cc->oldcc; + ln = regcc->cur; + if (regmatch(cc->next)) + return TRUE; /* All done. */ + regcc->cur = ln; + regcc = cc; + + if (n >= cc->max) /* Maximum greed exceeded? */ + return FALSE; - regmystartp[n] = locinput; /* for REF */ - if (regmatch(next)) { - /* - * Don't set startp if some later - * invocation of the same parentheses - * already has. - */ - if (regstartp[n] == NULL) - regstartp[n] = locinput; - return(1); - } else - return(0); - /* NOTREACHED */ - case CLOSE: { - n = ARG1(scan); /* which paren pair */ - reginput = locinput; - - regmyendp[n] = locinput; /* for REF */ - if (regmatch(next)) { - /* - * Don't set endp if some later - * invocation of the same parentheses - * already has. - */ - if (regendp[n] == NULL) { - regendp[n] = locinput; - if (n > *reglastparen) - *reglastparen = n; - } - return(1); - } else - return(0); - } - /*NOTREACHED*/ - case BRANCH: { - if (OP(next) != BRANCH) /* No choice. */ - next = NEXTOPER(scan); /* Avoid recursion. */ - else { - do { - reginput = locinput; - if (regmatch(NEXTOPER(scan))) - return(1); + /* Try scanning more and see if it helps. */ + reginput = locinput; + cc->cur = n; + cc->lastloc = locinput; + return regmatch(cc->scan); + } + + /* Prefer scan over next for maximal matching. */ + + if (n < cc->max) { /* More greed allowed? */ + regcppush(cc->parenfloor); + cc->cur = n; + cc->lastloc = locinput; + if (regmatch(cc->scan)) + return TRUE; + regcppop(); /* Restore some previous $<digit>s? */ + reginput = locinput; + } + + /* Failed deeper matches of scan, so see if this one works. */ + regcc = cc->oldcc; + ln = regcc->cur; + if (regmatch(cc->next)) + return TRUE; + regcc->cur = ln; + regcc = cc; + return FALSE; + } + /* NOT REACHED */ + case BRANCH: { + if (OP(next) != BRANCH) /* No choice. */ + next = NEXTOPER(scan);/* Avoid recursion. */ + else { + do { + reginput = locinput; + if (regmatch(NEXTOPER(scan))) + return 1; #ifdef REGALIGN - /*SUPPRESS 560*/ - if (n = NEXT(scan)) - scan += n; - else - scan = NULL; + /*SUPPRESS 560*/ + if (n = NEXT(scan)) + scan += n; + else + scan = NULL; #else - scan = regnext(scan); -#endif - } while (scan != NULL && OP(scan) == BRANCH); - return(0); - /* NOTREACHED */ - } - } - break; -#ifdef NOTYET - case MINCURLY: - ln = ARG1(scan); /* min to match */ - n = -ARG2(scan); /* max to match */ - scan = NEXTOPER(scan) + 4; - goto repeat; + scan = regnext(scan); #endif - case CURLY: - ln = ARG1(scan); /* min to match */ - n = ARG2(scan); /* max to match */ - scan = NEXTOPER(scan) + 4; - goto repeat; - case STAR: - ln = 0; - n = 32767; - scan = NEXTOPER(scan); - goto repeat; - case PLUS: - /* - * Lookahead to avoid useless match attempts - * when we know what character comes next. - */ - ln = 1; - n = 32767; - scan = NEXTOPER(scan); - repeat: - if (OP(next) == EXACTLY) - nextchar = *(OPERAND(next)+1); - else - nextchar = -1000; - reginput = locinput; - if (n < 0) { - n = -n; - while (n >= ln) { - /* If it could work, try it. */ - if (nextchar == -1000 || - *reginput == nextchar) - if (regmatch(next)) - return(1); - /* Couldn't or didn't -- back up. */ - ln++; - reginput = locinput + ln; - } - } - else { - n = regrepeat(scan, n); - if (!multiline && OP(next) == EOL && ln < n) - ln = n; /* why back off? */ - while (n >= ln) { - /* If it could work, try it. */ - if (nextchar == -1000 || - *reginput == nextchar) - if (regmatch(next)) - return(1); - /* Couldn't or didn't -- back up. */ - n--; - reginput = locinput + n; - } - } - return(0); - case END: - reginput = locinput; /* put where regtry can find it */ - return(1); /* Success! */ - default: - printf("%x %d\n",scan,scan[1]); - FAIL("regexp memory corruption"); + } while (scan != NULL && OP(scan) == BRANCH); + return 0; + /* NOTREACHED */ } - - scan = next; + } + break; + case MINMOD: + minmod = 1; + break; + case CURLY: + ln = ARG1(scan); /* min to match */ + n = ARG2(scan); /* max to match */ + scan = NEXTOPER(scan) + 4; + goto repeat; + case STAR: + ln = 0; + n = 32767; + scan = NEXTOPER(scan); + goto repeat; + case PLUS: + /* + * Lookahead to avoid useless match attempts + * when we know what character comes next. + */ + ln = 1; + n = 32767; + scan = NEXTOPER(scan); + repeat: + if (OP(next) == EXACTLY) + nextchar = *(OPERAND(next)+1); + else + nextchar = -1000; + reginput = locinput; + if (minmod) { + minmod = 0; + if (ln && regrepeat(scan, ln) < ln) + return 0; + while (n >= ln) { + /* If it could work, try it. */ + if (nextchar == -1000 || *reginput == nextchar) + if (regmatch(next)) + return 1; + /* Couldn't or didn't -- back up. */ + if (regrepeat(scan, 1)) { + ln++; + reginput = locinput + ln; + } + else + return 0; + } + } + else { + n = regrepeat(scan, n); + if (ln < n && regkind[(U8)OP(next)] == EOL && + (!multiline || OP(next) == SEOL)) + ln = n; /* why back off? */ + while (n >= ln) { + /* If it could work, try it. */ + if (nextchar == -1000 || *reginput == nextchar) + if (regmatch(next)) + return 1; + /* Couldn't or didn't -- back up. */ + n--; + reginput = locinput + n; + } + } + return 0; + case SUCCEED: + case END: + reginput = locinput; /* put where regtry can find it */ + return 1; /* Success! */ + case IFMATCH: + reginput = locinput; + scan = NEXTOPER(scan); + if (!regmatch(scan)) + return 0; + break; + case UNLESSM: + reginput = locinput; + scan = NEXTOPER(scan); + if (regmatch(scan)) + return 0; + break; + default: + fprintf(stderr, "%x %d\n",(unsigned)scan,scan[1]); + FAIL("regexp memory corruption"); } + scan = next; + } - /* - * We get here only if there's trouble -- normally "case END" is - * the terminating point. - */ - FAIL("corrupted regexp pointers"); - /*NOTREACHED*/ -#ifdef lint - return 0; -#endif + /* + * We get here only if there's trouble -- normally "case END" is + * the terminating point. + */ + FAIL("corrupted regexp pointers"); + /*NOTREACHED*/ + return 0; } /* @@ -823,65 +977,67 @@ regrepeat(p, max) char *p; I32 max; { - register char *scan; - register char *opnd; - register I32 c; - register char *loceol = regeol; - - scan = reginput; - if (max != 32767 && max < loceol - scan) - loceol = scan + max; - opnd = OPERAND(p); - switch (OP(p)) { - case ANY: - while (scan < loceol && *scan != '\n') - scan++; - break; - case EXACTLY: /* length of string is 1 */ - opnd++; - while (scan < loceol && *opnd == *scan) - scan++; - break; - case ANYOF: - c = UCHARAT(scan); - while (scan < loceol && !(opnd[c >> 3] & (1 << (c & 7)))) { - scan++; - c = UCHARAT(scan); - } - break; - case ALNUM: - while (scan < loceol && isALNUM(*scan)) - scan++; - break; - case NALNUM: - while (scan < loceol && !isALNUM(*scan)) - scan++; - break; - case SPACE: - while (scan < loceol && isSPACE(*scan)) - scan++; - break; - case NSPACE: - while (scan < loceol && !isSPACE(*scan)) - scan++; - break; - case DIGIT: - while (scan < loceol && isDIGIT(*scan)) - scan++; - break; - case NDIGIT: - while (scan < loceol && !isDIGIT(*scan)) - scan++; - break; - default: /* Oh dear. Called inappropriately. */ - FAIL("internal regexp foulup"); - /* NOTREACHED */ + register char *scan; + register char *opnd; + register I32 c; + register char *loceol = regeol; + + scan = reginput; + if (max != 32767 && max < loceol - scan) + loceol = scan + max; + opnd = OPERAND(p); + switch (OP(p)) { + case ANY: + while (scan < loceol && *scan != '\n') + scan++; + break; + case SANY: + scan = loceol; + break; + case EXACTLY: /* length of string is 1 */ + opnd++; + while (scan < loceol && *opnd == *scan) + scan++; + break; + case ANYOF: + c = UCHARAT(scan); + while (scan < loceol && !(opnd[c >> 3] & (1 << (c & 7)))) { + scan++; + c = UCHARAT(scan); } + break; + case ALNUM: + while (scan < loceol && isALNUM(*scan)) + scan++; + break; + case NALNUM: + while (scan < loceol && !isALNUM(*scan)) + scan++; + break; + case SPACE: + while (scan < loceol && isSPACE(*scan)) + scan++; + break; + case NSPACE: + while (scan < loceol && !isSPACE(*scan)) + scan++; + break; + case DIGIT: + while (scan < loceol && isDIGIT(*scan)) + scan++; + break; + case NDIGIT: + while (scan < loceol && !isDIGIT(*scan)) + scan++; + break; + default: /* Called on something of 0 width. */ + break; /* So match right here or not at all. */ + } - c = scan - reginput; - reginput = scan; + c = scan - reginput; + reginput = scan; - return(c); + return(c); } /* @@ -894,21 +1050,21 @@ char * regnext(p) register char *p; { - register I32 offset; + register I32 offset; - if (p == ®dummy) - return(NULL); + if (p == ®dummy) + return(NULL); - offset = NEXT(p); - if (offset == 0) - return(NULL); + offset = NEXT(p); + if (offset == 0) + return(NULL); #ifdef REGALIGN - return(p+offset); + return(p+offset); #else - if (OP(p) == BACK) - return(p-offset); - else - return(p+offset); + if (OP(p) == BACK) + return(p-offset); + else + return(p+offset); #endif } @@ -1,3 +1,6 @@ +/* regexp.h + */ + /* * Definitions etc. for regexp(3) routines. * @@ -5,24 +8,6 @@ * not the System V one. */ -/* $RCSfile: regexp.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:35 $ - * - * $Log: regexp.h,v $ - * Revision 4.1 92/08/07 18:26:35 lwall - * - * Revision 4.0.1.2 91/11/05 18:24:31 lwall - * patch11: minimum match length calculation in regexp is now cumulative - * patch11: initial .* in pattern had dependency on value of $* - * - * Revision 4.0.1.1 91/06/07 11:51:18 lwall - * patch4: new copyright notice - * patch4: // wouldn't use previous pattern if it started with a null character - * patch4: $` was busted inside s/// - * - * Revision 4.0 91/03/20 01:39:23 lwall - * 4.0 baseline. - * - */ typedef struct regexp { char **startp; @@ -33,14 +18,15 @@ typedef struct regexp { I32 regback; /* Can regmust locate first try? */ I32 minlen; /* mininum possible length of $& */ I32 prelen; /* length of precomp */ + U32 nparens; /* number of parentheses */ + U32 lastparen; /* last paren matched */ char *precomp; /* pre-compilation regular expression */ char *subbase; /* saved string so \digit works forever */ char *subbeg; /* same, but not responsible for allocation */ char *subend; /* end of subbase */ + U16 naughty; /* how exponential is this pattern? */ char reganch; /* Internal use only. */ char do_folding; /* do case-insensitive match? */ - char lastparen; /* last paren matched */ - char nparens; /* number of parentheses */ char program[1]; /* Unwarranted chumminess with compiler. */ } regexp; @@ -1,35 +1,62 @@ +/* run.c + * + * Copyright (c) 1991-1994, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + #include "EXTERN.h" #include "perl.h" +/* + * "Away now, Shadowfax! Run, greatheart, run as you have never run before! + * Now we are come to the lands where you were foaled, and every stone you + * know. Run now! Hope is in speed!" --Gandalf + */ + char **watchaddr = 0; char *watchok; #ifndef DEBUGGING +int run() { + SAVEI32(runlevel); + runlevel++; + while ( op = (*op->op_ppaddr)() ) ; + return 0; } #else +static void debprof _((OP*op)); + +int run() { if (!op) { warn("NULL OP IN RUN"); - return; + return 0; } + + SAVEI32(runlevel); + runlevel++; + do { if (debug) { if (watchaddr != 0 && *watchaddr != watchok) fprintf(stderr, "WARNING: %lx changed from %lx to %lx\n", - watchaddr, watchok, *watchaddr); + (long)watchaddr, (long)watchok, (long)*watchaddr); DEBUG_s(debstack()); DEBUG_t(debop(op)); + DEBUG_P(debprof(op)); } } while ( op = (*op->op_ppaddr)() ); + return 0; } -#endif - I32 debop(op) OP *op; @@ -51,6 +78,8 @@ OP *op; else fprintf(stderr, "(NULL)"); break; + default: + break; } fprintf(stderr, "\n"); return 0; @@ -63,5 +92,29 @@ char **addr; watchaddr = addr; watchok = *addr; fprintf(stderr, "WATCHING, %lx is currently %lx\n", - watchaddr, watchok); + (long)watchaddr, (long)watchok); } + +static void +debprof(op) +OP* op; +{ + if (!profiledata) + New(000, profiledata, MAXO, U32); + ++profiledata[op->op_type]; +} + +void +debprofdump() +{ + U32 i; + if (!profiledata) + return; + for (i = 0; i < MAXO; i++) { + if (profiledata[i]) + fprintf(stderr, "%d\t%lu\n", i, profiledata[i]); + } +} + +#endif + @@ -1,16 +1,36 @@ -/* $RCSfile: op.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:16 $ +/* scope.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: op.c,v $ + */ + +/* + * "For the fashion of Minas Tirith was such that it was built on seven + * levels..." */ #include "EXTERN.h" #include "perl.h" +SV** +stack_grow(sp, p, n) +SV** sp; +SV** p; +int n; +{ + stack_sp = sp; + av_extend(stack, (p - stack_base) + (n) + 128); +#ifdef NOTDEF + stack_sp = AvARRAY(stack) + (sp - stack_base); + stack_base = AvARRAY(stack); + stack_max = stack_base + AvMAX(stack) - 1; +#endif + return stack_sp; +} + I32 cxinc() { @@ -58,6 +78,17 @@ pop_scope() } void +markstack_grow() +{ + I32 oldmax = markstack_max - markstack; + I32 newmax = oldmax * 3 / 2; + + Renew(markstack, newmax, I32); + markstack_ptr = markstack + oldmax; + markstack_max = markstack + newmax; +} + +void savestack_grow() { savestack_max = savestack_max * 3 / 2; @@ -94,11 +125,15 @@ GV *gv; SSPUSHINT(SAVEt_SV); sv = GvSV(gv) = NEWSV(0,0); - if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv)) { + if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) { sv_upgrade(sv, SvTYPE(osv)); - mg_get(osv); - SvFLAGS(osv) |= (SvFLAGS(osv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + if (SvGMAGICAL(osv)) { + mg_get(osv); + SvFLAGS(osv) |= (SvFLAGS(osv) & + (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + } SvMAGIC(sv) = SvMAGIC(osv); + SvFLAGS(sv) |= SvMAGICAL(osv); localizing = TRUE; SvSETMAGIC(sv); localizing = FALSE; @@ -141,9 +176,15 @@ SV **sptr; SSPUSHINT(SAVEt_SVREF); sv = *sptr = NEWSV(0,0); - if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(sv)) { + if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) { sv_upgrade(sv, SvTYPE(osv)); + if (SvGMAGICAL(osv)) { + mg_get(osv); + SvFLAGS(osv) |= (SvFLAGS(osv) & + (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + } SvMAGIC(sv) = SvMAGIC(osv); + SvFLAGS(sv) |= SvMAGICAL(osv); localizing = TRUE; SvSETMAGIC(sv); localizing = FALSE; @@ -221,6 +262,16 @@ I32 *intp; SSPUSHINT(SAVEt_I32); } +void +save_iv(ivp) +IV *ivp; +{ + SSCHECK(3); + SSPUSHINT(*ivp); + SSPUSHPTR(ivp); + SSPUSHINT(SAVEt_IV); +} + /* Cannot use save_sptr() to store a char* since the SV** cast will * force word-alignment and we'll miss the pointer. */ @@ -341,6 +392,17 @@ I32 maxsarg; } void +save_destructor(f,p) +void (*f) _((void*)); +void* p; +{ + SSCHECK(3); + SSPUSHDPTR(f); + SSPUSHPTR(p); + SSPUSHINT(SAVEt_DESTRUCTOR); +} + +void leave_scope(base) I32 base; { @@ -359,28 +421,43 @@ I32 base; value = (SV*)SSPOPPTR; sv = (SV*)SSPOPPTR; sv_replace(sv,value); + localizing = TRUE; SvSETMAGIC(sv); + localizing = FALSE; break; case SAVEt_SV: /* scalar reference */ value = (SV*)SSPOPPTR; gv = (GV*)SSPOPPTR; sv = GvSV(gv); - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) && SvTYPE(sv) != SVt_PVGV){ + (void)SvUPGRADE(value, SvTYPE(sv)); SvMAGIC(value) = SvMAGIC(sv); + SvFLAGS(value) |= SvMAGICAL(sv); + SvMAGICAL_off(sv); SvMAGIC(sv) = 0; } SvREFCNT_dec(sv); - GvSV(gv) = sv = value; - SvSETMAGIC(sv); + GvSV(gv) = value; + localizing = TRUE; + SvSETMAGIC(value); + localizing = FALSE; break; case SAVEt_SVREF: /* scalar reference */ ptr = SSPOPPTR; sv = *(SV**)ptr; - if (SvTYPE(sv) >= SVt_PVMG) + value = (SV*)SSPOPPTR; + if (SvTYPE(sv) >= SVt_PVMG && SvTYPE(sv) != SVt_PVGV) { + (void)SvUPGRADE(value, SvTYPE(sv)); + SvMAGIC(value) = SvMAGIC(sv); + SvFLAGS(value) |= SvMAGICAL(sv); + SvMAGICAL_off(sv); SvMAGIC(sv) = 0; + } SvREFCNT_dec(sv); - *(SV**)ptr = sv = (SV*)SSPOPPTR; - SvSETMAGIC(sv); + *(SV**)ptr = value; + localizing = TRUE; + SvSETMAGIC(value); + localizing = FALSE; break; case SAVEt_AV: /* array reference */ av = (AV*)SSPOPPTR; @@ -406,6 +483,10 @@ I32 base; ptr = SSPOPPTR; *(I32*)ptr = (I32)SSPOPINT; break; + case SAVEt_IV: /* IV reference */ + ptr = SSPOPPTR; + *(IV*)ptr = (IV)SSPOPIV; + break; case SAVEt_SPTR: /* SV* reference */ ptr = SSPOPPTR; *(SV**)ptr = (SV*)SSPOPPTR; @@ -448,13 +529,15 @@ I32 base; case SAVEt_CLEARSV: ptr = SSPOPPTR; sv = *(SV**)ptr; - if (SvREFCNT(sv) <= 1) { /* Can clear pad variable in place. */ + if (SvREFCNT(sv) <= 1) { /* Can clear pad variable in place. */ if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) croak("panic: leave_scope clearsv"); if (SvROK(sv)) sv_unref(sv); } + if (SvMAGICAL(sv)) + mg_free(sv); switch (SvTYPE(sv)) { case SVt_NULL: @@ -471,9 +554,8 @@ I32 base; break; default: if (SvPOK(sv) && SvLEN(sv)) - SvOOK_off(sv); - SvOK_off(sv); - SvSETMAGIC(sv); + (void)SvOOK_off(sv); + (void)SvOK_off(sv); break; } } @@ -492,6 +574,13 @@ I32 base; ptr = SSPOPPTR; hv_delete(hv, (char*)ptr, (U32)SSPOPINT); break; + case SAVEt_DESTRUCTOR: + ptr = SSPOPPTR; + (*SSPOPDPTR)(ptr); + break; + case SAVEt_REGCONTEXT: + savestack_ix -= SSPOPINT; /* regexp must have croaked */ + break; default: croak("panic: leave_scope inconsistency"); } @@ -5,26 +5,54 @@ #define SAVEt_INT 4 #define SAVEt_LONG 5 #define SAVEt_I32 6 -#define SAVEt_SPTR 7 -#define SAVEt_APTR 8 -#define SAVEt_HPTR 9 -#define SAVEt_PPTR 10 -#define SAVEt_NSTAB 11 -#define SAVEt_SVREF 12 -#define SAVEt_GP 13 -#define SAVEt_FREESV 14 -#define SAVEt_FREEOP 15 -#define SAVEt_FREEPV 16 -#define SAVEt_CLEARSV 17 -#define SAVEt_DELETE 18 +#define SAVEt_IV 7 +#define SAVEt_SPTR 8 +#define SAVEt_APTR 9 +#define SAVEt_HPTR 10 +#define SAVEt_PPTR 11 +#define SAVEt_NSTAB 12 +#define SAVEt_SVREF 13 +#define SAVEt_GP 14 +#define SAVEt_FREESV 15 +#define SAVEt_FREEOP 16 +#define SAVEt_FREEPV 17 +#define SAVEt_CLEARSV 18 +#define SAVEt_DELETE 19 +#define SAVEt_DESTRUCTOR 20 +#define SAVEt_REGCONTEXT 21 #define SSCHECK(need) if (savestack_ix + need > savestack_max) savestack_grow() #define SSPUSHINT(i) (savestack[savestack_ix++].any_i32 = (I32)(i)) #define SSPUSHLONG(i) (savestack[savestack_ix++].any_long = (long)(i)) +#define SSPUSHIV(i) (savestack[savestack_ix++].any_iv = (IV)(i)) #define SSPUSHPTR(p) (savestack[savestack_ix++].any_ptr = (void*)(p)) +#define SSPUSHDPTR(p) (savestack[savestack_ix++].any_dptr = (p)) #define SSPOPINT (savestack[--savestack_ix].any_i32) #define SSPOPLONG (savestack[--savestack_ix].any_long) +#define SSPOPIV (savestack[--savestack_ix].any_iv) #define SSPOPPTR (savestack[--savestack_ix].any_ptr) +#define SSPOPDPTR (savestack[--savestack_ix].any_dptr) -#define FREE_TMPS() if (tmps_ix > tmps_floor) free_tmps() +#define SAVETMPS save_int((int*)&tmps_floor), tmps_floor = tmps_ix +#define FREETMPS if (tmps_ix > tmps_floor) free_tmps() +#ifdef DEPRECATED +#define FREE_TMPS() FREETMPS +#endif + +#define ENTER push_scope() +#define LEAVE pop_scope() #define LEAVE_SCOPE(old) if (savestack_ix > old) leave_scope(old) + +#define SAVEINT(i) save_int((int*)(&i)); +#define SAVEIV(i) save_iv((IV*)(&i)); +#define SAVEI32(i) save_I32((I32*)(&i)); +#define SAVELONG(l) save_long((long*)(&l)); +#define SAVESPTR(s) save_sptr((SV**)(&s)) +#define SAVEPPTR(s) save_pptr((char**)(&s)) +#define SAVEFREESV(s) save_freesv((SV*)(s)) +#define SAVEFREEOP(o) save_freeop((OP*)(o)) +#define SAVEFREEPV(p) save_freepv((char*)(p)) +#define SAVECLEARSV(sv) save_clearsv((SV**)(&sv)) +#define SAVEDELETE(h,k,l) save_delete((HV*)(h), (char*)(k), (I32)l) +#define SAVEDESTRUCTOR(f,p) save_destructor(f,(void*)p) + @@ -1,56 +1,67 @@ -/* $RCSfile: sv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:45 $ +/* sv.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: sv.c,v $ - * Revision 4.1 92/08/07 18:26:45 lwall - * - * Revision 4.0.1.6 92/06/11 21:14:21 lwall - * patch34: quotes containing subscripts containing variables didn't parse right - * - * Revision 4.0.1.5 92/06/08 15:40:43 lwall - * patch20: removed implicit int declarations on functions - * patch20: Perl now distinguishes overlapped copies from non-overlapped - * patch20: paragraph mode now skips extra newlines automatically - * patch20: fixed memory leak in doube-quote interpretation - * patch20: made /\$$foo/ look for literal '$foo' - * patch20: "$var{$foo'bar}" didn't scan subscript correctly - * patch20: a splice on non-existent array elements could dump core - * patch20: running taintperl explicitly now does checks even if $< == $> - * - * Revision 4.0.1.4 91/11/05 18:40:51 lwall - * patch11: $foo .= <BAR> could overrun malloced memory - * patch11: \$ didn't always make it through double-quoter to regexp routines - * patch11: prepared for ctype implementations that don't define isascii() - * - * Revision 4.0.1.3 91/06/10 01:27:54 lwall - * patch10: $) and $| incorrectly handled in run-time patterns - * - * Revision 4.0.1.2 91/06/07 11:58:13 lwall - * patch4: new copyright notice - * patch4: taint check on undefined string could cause core dump - * - * Revision 4.0.1.1 91/04/12 09:15:30 lwall - * patch1: fixed undefined environ problem - * patch1: substr($ENV{"PATH"},0,0) = "/foo:" didn't modify environment - * patch1: $foo .= <BAR> could cause core dump for certain lengths of $foo - * - * Revision 4.0 91/03/20 01:39:55 lwall - * 4.0 baseline. - * + */ + +/* + * "I wonder what the Entish is for 'yes' and 'no'," he thought. */ #include "EXTERN.h" #include "perl.h" -#include "perly.h" -static void ucase(); -static void lcase(); +/* The following is all to get DBL_DIG, in order to pick a nice + default value for printing floating point numbers in Gconvert. + (see config.h) +*/ +#ifdef I_LIMITS +#include <limits.h> +#endif +#ifdef I_FLOAT +#include <float.h> +#endif +#ifndef HAS_DBL_DIG +#define DBL_DIG 15 /* A guess that works lots of places */ +#endif + +static SV *more_sv _((void)); +static XPVIV *more_xiv _((void)); +static XPVNV *more_xnv _((void)); +static XPV *more_xpv _((void)); +static XRV *more_xrv _((void)); +static SV *new_sv _((void)); +static XPVIV *new_xiv _((void)); +static XPVNV *new_xnv _((void)); +static XPV *new_xpv _((void)); +static XRV *new_xrv _((void)); +static void del_xiv _((XPVIV* p)); +static void del_xnv _((XPVNV* p)); +static void del_xpv _((XPV* p)); +static void del_xrv _((XRV* p)); +static void sv_mortalgrow _((void)); + +static void sv_unglob _((SV* sv)); + +#ifdef PURIFY -static SV* more_sv(); +#define new_SV() sv = (SV*)safemalloc(sizeof(SV)) +#define del_SV(p) free((char*)p) + +#else + +#define new_SV() \ + if (sv_root) { \ + sv = sv_root; \ + sv_root = (SV*)SvANY(sv); \ + ++sv_count; \ + } \ + else \ + sv = more_sv(); +#endif static SV* new_sv() @@ -65,19 +76,49 @@ new_sv() return more_sv(); } +#ifdef DEBUGGING +#define del_SV(p) \ + if (debug & 32768) \ + del_sv(p); \ + else { \ + SvANY(p) = (void *)sv_root; \ + sv_root = p; \ + --sv_count; \ + } + static void del_sv(p) SV* p; { - SvANY(p) = sv_root; + if (debug & 32768) { + SV* sv; + SV* svend; + int ok = 0; + for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(svend)) { + svend = &sv[1008 / sizeof(SV)]; + if (p >= sv && p < svend) + ok = 1; + } + if (!ok) { + warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p); + return; + } + } + SvANY(p) = (void *) sv_root; sv_root = p; --sv_count; } +#else +#define del_SV(p) \ + SvANY(p) = (void *)sv_root; \ + sv_root = p; \ + --sv_count; + +#endif static SV* more_sv() { - register int i; register SV* sv; register SV* svend; sv_root = (SV*)safemalloc(1012); @@ -85,13 +126,13 @@ more_sv() Zero(sv, 1012, char); svend = &sv[1008 / sizeof(SV) - 1]; while (sv < svend) { - SvANY(sv) = (SV*)(sv + 1); + SvANY(sv) = (void *)(SV*)(sv + 1); SvFLAGS(sv) = SVTYPEMASK; sv++; } SvANY(sv) = 0; sv++; - SvANY(sv) = sv_arenaroot; + SvANY(sv) = (void *) sv_arenaroot; sv_arenaroot = sv_root; return new_sv(); } @@ -102,7 +143,7 @@ sv_report_used() SV* sv; register SV* svend; - for (sv = sv_arenaroot; sv; sv = SvANY(sv)) { + for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { svend = &sv[1008 / sizeof(SV)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { @@ -115,22 +156,23 @@ sv_report_used() } void -sv_clean_refs() +sv_clean_objs() { register SV* sv; register SV* svend; + SV* rv; - for (sv = sv_arenaroot; sv; sv = SvANY(sv)) { + for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { svend = &sv[1008 / sizeof(SV)]; while (sv < svend) { - if (SvREFCNT(sv) == 1 && SvROK(sv)) { - DEBUG_D((fprintf(stderr, "Cleaning ref:\n "), sv_dump(sv));) - SvFLAGS(SvRV(sv)) |= SVf_BREAK; - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); - assert(sv_root == sv); - sv_root = (SV*)SvANY(sv); /* MUST NOT REUSE */ + if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { + DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "), + sv_dump(sv));) + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); } + /* XXX Might want to check arrays, etc. */ ++sv; } } @@ -142,7 +184,7 @@ sv_clean_all() register SV* sv; register SV* svend; - for (sv = sv_arenaroot; sv; sv = SvANY(sv)) { + for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { svend = &sv[1008 / sizeof(SV)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { @@ -155,18 +197,16 @@ sv_clean_all() } } -static XPVIV* more_xiv(); - static XPVIV* new_xiv() { - I32** xiv; + IV** xiv; if (xiv_root) { xiv = xiv_root; /* * See comment in more_xiv() -- RAM. */ - xiv_root = (I32**)*xiv; + xiv_root = (IV**)*xiv; return (XPVIV*)((char*)xiv - sizeof(XPV)); } return more_xiv(); @@ -176,30 +216,32 @@ static void del_xiv(p) XPVIV* p; { - I32** xiv = (I32**)((char*)(p) + sizeof(XPV)); - *xiv = (I32 *)xiv_root; + IV** xiv = (IV**)((char*)(p) + sizeof(XPV)); + *xiv = (IV *)xiv_root; xiv_root = xiv; } static XPVIV* more_xiv() { - register I32** xiv; - register I32** xivend; - xiv = (I32**)safemalloc(1008); - xivend = &xiv[1008 / sizeof(I32 *) - 1]; - xiv += (sizeof(XPV) - 1) / sizeof(I32 *) + 1; /* fudge by size of XPV */ + register IV** xiv; + register IV** xivend; + XPV* ptr = (XPV*)safemalloc(1008); + ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */ + xiv_arenaroot = ptr; /* to keep Purify happy */ + + xiv = (IV**) ptr; + xivend = &xiv[1008 / sizeof(IV *) - 1]; + xiv += (sizeof(XPV) - 1) / sizeof(IV *) + 1; /* fudge by size of XPV */ xiv_root = xiv; while (xiv < xivend) { - *xiv = (I32 *)(xiv + 1); + *xiv = (IV *)(xiv + 1); xiv++; } *xiv = 0; return new_xiv(); } -static XPVNV* more_xnv(); - static XPVNV* new_xnv() { @@ -224,7 +266,6 @@ XPVNV* p; static XPVNV* more_xnv() { - register int i; register double* xnv; register double* xnvend; xnv = (double*)safemalloc(1008); @@ -239,8 +280,6 @@ more_xnv() return new_xnv(); } -static XRV* more_xrv(); - static XRV* new_xrv() { @@ -264,7 +303,6 @@ XRV* p; static XRV* more_xrv() { - register int i; register XRV* xrv; register XRV* xrvend; xrv_root = (XRV*)safemalloc(1008); @@ -278,8 +316,6 @@ more_xrv() return new_xrv(); } -static XPV* more_xpv(); - static XPV* new_xpv() { @@ -303,7 +339,6 @@ XPV* p; static XPV* more_xpv() { - register int i; register XPV* xpv; register XPV* xpvend; xpv_root = (XPV*)safemalloc(1008); @@ -318,28 +353,6 @@ more_xpv() } #ifdef PURIFY - -#define new_SV() sv = (SV*)safemalloc(sizeof(SV)) -#define del_SV(p) free((char*)p) - -#else - -#define new_SV() \ - if (sv_root) { \ - sv = sv_root; \ - sv_root = (SV*)SvANY(sv); \ - ++sv_count; \ - } \ - else \ - sv = more_sv(); -#define del_SV(p) \ - SvANY(p) = sv_root; \ - sv_root = p; \ - --sv_count; - -#endif - -#ifdef PURIFY #define new_XIV() (void*)safemalloc(sizeof(XPVIV)) #define del_XIV(p) free((char*)p) #else @@ -412,7 +425,7 @@ U32 mt; char* pv; U32 cur; U32 len; - I32 iv; + IV iv; double nv; MAGIC* magic; HV* stash; @@ -461,7 +474,7 @@ U32 mt; pv = (char*)SvRV(sv); cur = 0; len = 0; - iv = (I32)pv; + iv = (IV)pv; nv = (double)(unsigned long)pv; del_XRV(SvANY(sv)); magic = 0; @@ -528,7 +541,6 @@ U32 mt; case SVt_RV: SvANY(sv) = new_XRV(); SvRV(sv) = (SV*)pv; - SvOK_on(sv); break; case SVt_PV: SvANY(sv) = new_XPV(); @@ -543,7 +555,7 @@ U32 mt; SvLEN(sv) = len; SvIVX(sv) = iv; if (SvNIOK(sv)) - SvIOK_on(sv); + (void)SvIOK_on(sv); SvNOK_off(sv); break; case SVt_PVNV: @@ -621,12 +633,12 @@ U32 mt; CvSTASH(sv) = 0; CvSTART(sv) = 0; CvROOT(sv) = 0; - CvUSERSUB(sv) = 0; - CvUSERINDEX(sv) = 0; + CvXSUB(sv) = 0; + CvXSUBANY(sv).any_ptr = 0; CvFILEGV(sv) = 0; CvDEPTH(sv) = 0; CvPADLIST(sv) = 0; - CvDELETED(sv) = 0; + CvOLDSTYLE(sv) = 0; break; case SVt_PVGV: SvANY(sv) = new_XPVGV(); @@ -698,109 +710,152 @@ U32 mt; return TRUE; } +#ifdef DEBUGGING char * sv_peek(sv) register SV *sv; { char *t = tokenbuf; - *t = '\0'; + int unref = 0; retry: if (!sv) { strcpy(t, "VOID"); - return tokenbuf; + goto finish; } else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') { strcpy(t, "WILD"); - return tokenbuf; + goto finish; + } + else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) { + if (sv == &sv_undef) { + strcpy(t, "SV_UNDEF"); + if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + SvREADONLY(sv)) + goto finish; + } + else if (sv == &sv_no) { + strcpy(t, "SV_NO"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 0 && + SvNVX(sv) == 0.0) + goto finish; + } + else { + strcpy(t, "SV_YES"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 1 && + SvPVX(sv) && *SvPVX(sv) == '1' && + SvNVX(sv) == 1.0) + goto finish; + } + t += strlen(t); + *t++ = ':'; } - else if (SvREFCNT(sv) == 0 && !SvREADONLY(sv)) { - strcpy(t, "UNREF"); - return tokenbuf; + else if (SvREFCNT(sv) == 0) { + *t++ = '('; + unref++; } - else { - switch (SvTYPE(sv)) { - default: - strcpy(t,"FREED"); - return tokenbuf; - break; - - case SVt_NULL: - strcpy(t,"UNDEF"); - return tokenbuf; - case SVt_IV: - strcpy(t,"IV"); - break; - case SVt_NV: - strcpy(t,"NV"); - break; - case SVt_RV: - *t++ = '\\'; - if (t - tokenbuf > 10) { - strcpy(tokenbuf + 3,"..."); - return tokenbuf; - } - sv = (SV*)SvRV(sv); - goto retry; - case SVt_PV: - strcpy(t,"PV"); - break; - case SVt_PVIV: - strcpy(t,"PVIV"); - break; - case SVt_PVNV: - strcpy(t,"PVNV"); - break; - case SVt_PVMG: - strcpy(t,"PVMG"); - break; - case SVt_PVLV: - strcpy(t,"PVLV"); - break; - case SVt_PVAV: - strcpy(t,"AV"); - break; - case SVt_PVHV: - strcpy(t,"HV"); - break; - case SVt_PVCV: - if (CvGV(sv)) - sprintf(t, "CV(%s)", GvNAME(CvGV(sv))); - else - strcpy(t, "CV()"); - return tokenbuf; - case SVt_PVGV: - strcpy(t,"GV"); - break; - case SVt_PVBM: - strcpy(t,"BM"); - break; - case SVt_PVFM: - strcpy(t,"FM"); - break; - case SVt_PVIO: - strcpy(t,"IO"); - break; + if (SvROK(sv)) { + *t++ = '\\'; + if (t - tokenbuf + unref > 10) { + strcpy(tokenbuf + unref + 3,"..."); + goto finish; } + sv = (SV*)SvRV(sv); + goto retry; + } + switch (SvTYPE(sv)) { + default: + strcpy(t,"FREED"); + goto finish; + + case SVt_NULL: + strcpy(t,"UNDEF"); + return tokenbuf; + case SVt_IV: + strcpy(t,"IV"); + break; + case SVt_NV: + strcpy(t,"NV"); + break; + case SVt_RV: + strcpy(t,"RV"); + break; + case SVt_PV: + strcpy(t,"PV"); + break; + case SVt_PVIV: + strcpy(t,"PVIV"); + break; + case SVt_PVNV: + strcpy(t,"PVNV"); + break; + case SVt_PVMG: + strcpy(t,"PVMG"); + break; + case SVt_PVLV: + strcpy(t,"PVLV"); + break; + case SVt_PVAV: + strcpy(t,"AV"); + break; + case SVt_PVHV: + strcpy(t,"HV"); + break; + case SVt_PVCV: + if (CvGV(sv)) + sprintf(t, "CV(%s)", GvNAME(CvGV(sv))); + else + strcpy(t, "CV()"); + goto finish; + case SVt_PVGV: + strcpy(t,"GV"); + break; + case SVt_PVBM: + strcpy(t,"BM"); + break; + case SVt_PVFM: + strcpy(t,"FM"); + break; + case SVt_PVIO: + strcpy(t,"IO"); + break; } t += strlen(t); - if (SvPOK(sv)) { + if (SvPOKp(sv)) { if (!SvPVX(sv)) - return "(null)"; + strcpy(t, "(null)"); if (SvOOK(sv)) sprintf(t,"(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv)); else sprintf(t,"(\"%.127s\")",SvPVX(sv)); } - else if (SvNOK(sv)) + else if (SvNOKp(sv)) sprintf(t,"(%g)",SvNVX(sv)); - else if (SvIOK(sv)) + else if (SvIOKp(sv)) sprintf(t,"(%ld)",(long)SvIVX(sv)); else strcpy(t,"()"); + + finish: + if (unref) { + t += strlen(t); + while (unref--) + *t++ = ')'; + *t = '\0'; + } return tokenbuf; } +#endif int sv_backoff(sv) @@ -815,6 +870,7 @@ register SV *sv; Move(s, SvPVX(sv), SvCUR(sv)+1, char); } SvFLAGS(sv) &= ~SVf_OOK; + return 0; } char * @@ -834,10 +890,8 @@ unsigned long newlen; my_exit(1); } #endif /* MSDOS */ - if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) - sv_unref(sv); - } + if (SvROK(sv)) + sv_unref(sv); if (SvTYPE(sv) < SVt_PV) { sv_upgrade(sv, SVt_PV); s = SvPVX(sv); @@ -864,7 +918,7 @@ unsigned long newlen; void sv_setiv(sv,i) register SV *sv; -I32 i; +IV i; { if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) @@ -883,9 +937,23 @@ I32 i; case SVt_PV: sv_upgrade(sv, SVt_PVIV); break; + + case SVt_PVGV: + if (SvFAKE(sv)) { + sv_unglob(sv); + break; + } + /* FALL THROUGH */ + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: + croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), + op_name[op->op_type]); } SvIVX(sv) = i; - SvIOK_only(sv); /* validate number */ + (void)SvIOK_only(sv); /* validate number */ SvTAINT(sv); } @@ -900,19 +968,81 @@ double num; if (SvROK(sv)) sv_unref(sv); } - if (SvTYPE(sv) < SVt_NV) + switch (SvTYPE(sv)) { + case SVt_NULL: + case SVt_IV: sv_upgrade(sv, SVt_NV); - else if (SvTYPE(sv) < SVt_PVNV) + break; + case SVt_NV: + case SVt_RV: + case SVt_PV: + case SVt_PVIV: sv_upgrade(sv, SVt_PVNV); - else if (SvPOK(sv)) { - SvOOK_off(sv); + /* FALL THROUGH */ + case SVt_PVNV: + case SVt_PVMG: + case SVt_PVBM: + case SVt_PVLV: + if (SvOOK(sv)) + (void)SvOOK_off(sv); + break; + case SVt_PVGV: + if (SvFAKE(sv)) { + sv_unglob(sv); + break; + } + /* FALL THROUGH */ + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: + croak("Can't coerce %s to number in %s", sv_reftype(sv,0), + op_name[op->op_type]); } SvNVX(sv) = num; - SvNOK_only(sv); /* validate number */ + (void)SvNOK_only(sv); /* validate number */ SvTAINT(sv); } -I32 +static void +not_a_number(sv) +SV *sv; +{ + char tmpbuf[64]; + char *d = tmpbuf; + char *s; + int i; + + for (s = SvPVX(sv), i = 50; *s && i; s++,i--) { + int ch = *s; + if (ch & 128 && !isprint(ch)) { + *d++ = 'M'; + *d++ = '-'; + ch &= 127; + } + if (isprint(ch)) + *d++ = ch; + else { + *d++ = '^'; + *d++ = ch ^ 64; + } + } + if (*s) { + *d++ = '.'; + *d++ = '.'; + *d++ = '.'; + } + *d = '\0'; + + if (op) + warn("Argument \"%s\" isn't numeric for %s", tmpbuf, + op_name[op->op_type]); + else + warn("Argument \"%s\" isn't numeric", tmpbuf); +} + +IV sv_2iv(sv) register SV *sv; { @@ -923,19 +1053,31 @@ register SV *sv; if (SvIOKp(sv)) return SvIVX(sv); if (SvNOKp(sv)) - return (I32)SvNVX(sv); - if (SvPOKp(sv) && SvLEN(sv)) - return (I32)atol(SvPVX(sv)); + return I_V(SvNVX(sv)); + if (SvPOKp(sv) && SvLEN(sv)) { + if (dowarn && !looks_like_number(sv)) + not_a_number(sv); + return (IV)atol(SvPVX(sv)); + } return 0; } if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) - return (I32)SvRV(sv); + if (SvROK(sv)) { +#ifdef OVERLOAD + SV* tmpstr; + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + return SvIV(tmpstr); +#endif /* OVERLOAD */ + return (IV)SvRV(sv); + } if (SvREADONLY(sv)) { if (SvNOK(sv)) - return (I32)SvNVX(sv); - if (SvPOK(sv) && SvLEN(sv)) - return (I32)atol(SvPVX(sv)); + return I_V(SvNVX(sv)); + if (SvPOK(sv) && SvLEN(sv)) { + if (dowarn && !looks_like_number(sv)) + not_a_number(sv); + return (IV)atol(SvPVX(sv)); + } if (dowarn) warn(warn_uninit); return 0; @@ -953,24 +1095,20 @@ register SV *sv; break; } if (SvNOK(sv)) - SvIVX(sv) = (I32)SvNVX(sv); + SvIVX(sv) = I_V(SvNVX(sv)); else if (SvPOK(sv) && SvLEN(sv)) { - if (dowarn && !looks_like_number(sv)) { - if (op) - warn("Argument wasn't numeric for \"%s\"",op_name[op->op_type]); - else - warn("Argument wasn't numeric"); - } - SvIVX(sv) = (I32)atol(SvPVX(sv)); + if (dowarn && !looks_like_number(sv)) + not_a_number(sv); + SvIVX(sv) = (IV)atol(SvPVX(sv)); } else { - if (dowarn) + if (dowarn && !localizing) warn(warn_uninit); - SvUPGRADE(sv, SVt_IV); - SvIVX(sv) = 0; + return 0; } - SvIOK_on(sv); - DEBUG_c((stderr,"0x%lx 2iv(%ld)\n",sv,(long)SvIVX(sv))); + (void)SvIOK_on(sv); + DEBUG_c(fprintf(stderr,"0x%lx 2iv(%ld)\n", + (unsigned long)sv,(long)SvIVX(sv))); return SvIVX(sv); } @@ -984,18 +1122,30 @@ register SV *sv; mg_get(sv); if (SvNOKp(sv)) return SvNVX(sv); - if (SvPOKp(sv) && SvLEN(sv)) + if (SvPOKp(sv) && SvLEN(sv)) { + if (dowarn && !SvIOK(sv) && !looks_like_number(sv)) + not_a_number(sv); return atof(SvPVX(sv)); + } if (SvIOKp(sv)) return (double)SvIVX(sv); return 0; } if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) - return (double)(unsigned long)SvRV(sv); + if (SvROK(sv)) { +#ifdef OVERLOAD + SV* tmpstr; + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) + return SvNV(tmpstr); +#endif /* OVERLOAD */ + return (double)(unsigned long)SvRV(sv); + } if (SvREADONLY(sv)) { - if (SvPOK(sv) && SvLEN(sv)) + if (SvPOK(sv) && SvLEN(sv)) { + if (dowarn && !SvIOK(sv) && !looks_like_number(sv)) + not_a_number(sv); return atof(SvPVX(sv)); + } if (SvIOK(sv)) return (double)SvIVX(sv); if (dowarn) @@ -1008,7 +1158,7 @@ register SV *sv; sv_upgrade(sv, SVt_PVNV); else sv_upgrade(sv, SVt_NV); - DEBUG_c((stderr,"0x%lx num(%g)\n",sv,SvNVX(sv))); + 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); @@ -1018,21 +1168,17 @@ register SV *sv; SvNVX(sv) = (double)SvIVX(sv); } else if (SvPOK(sv) && SvLEN(sv)) { - if (dowarn && !SvIOK(sv) && !looks_like_number(sv)) { - if (op) - warn("Argument wasn't numeric for \"%s\"",op_name[op->op_type]); - else - warn("Argument wasn't numeric"); - } + if (dowarn && !SvIOK(sv) && !looks_like_number(sv)) + not_a_number(sv); SvNVX(sv) = atof(SvPVX(sv)); } else { - if (dowarn) + if (dowarn && !localizing) warn(warn_uninit); - SvNVX(sv) = 0.0; + return 0.0; } SvNOK_on(sv); - DEBUG_c((stderr,"0x%lx 2nv(%g)\n",sv,SvNVX(sv))); + DEBUG_c(fprintf(stderr,"0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); return SvNVX(sv); } @@ -1055,20 +1201,23 @@ STRLEN *lp; return SvPVX(sv); } if (SvIOKp(sv)) { - (void)sprintf(tokenbuf,"%ld",SvIVX(sv)); - *lp = strlen(tokenbuf); - return tokenbuf; + (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); + goto tokensave; } if (SvNOKp(sv)) { - (void)sprintf(tokenbuf,"%.20g",SvNVX(sv)); - *lp = strlen(tokenbuf); - return tokenbuf; + Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); + goto tokensave; } *lp = 0; return ""; } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { +#ifdef OVERLOAD + SV* tmpstr; + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string))) + return SvPV(tmpstr,*lp); +#endif /* OVERLOAD */ sv = (SV*)SvRV(sv); if (!sv) s = "NULLREF"; @@ -1097,21 +1246,19 @@ STRLEN *lp; HvNAME(SvSTASH(sv)), s, (unsigned long)sv); else sprintf(tokenbuf, "%s(0x%lx)", s, (unsigned long)sv); - s = tokenbuf; + goto tokensaveref; } *lp = strlen(s); return s; } if (SvREADONLY(sv)) { if (SvIOK(sv)) { - (void)sprintf(tokenbuf,"%ld",SvIVX(sv)); - *lp = strlen(tokenbuf); - return tokenbuf; + (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); + goto tokensave; } if (SvNOK(sv)) { - (void)sprintf(tokenbuf,"%.20g",SvNVX(sv)); - *lp = strlen(tokenbuf); - return tokenbuf; + Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); + goto tokensave; } if (dowarn) warn(warn_uninit); @@ -1127,17 +1274,17 @@ STRLEN *lp; SvGROW(sv, 28); s = SvPVX(sv); olderrno = errno; /* some Xenix systems wipe out errno here */ -#if defined(scs) && defined(ns32000) - gcvt(SvNVX(sv),20,s); -#else #ifdef apollo if (SvNVX(sv) == 0.0) (void)strcpy(s,"0"); else #endif /*apollo*/ - (void)sprintf(s,"%.20g",SvNVX(sv)); -#endif /*scs*/ + Gconvert(SvNVX(sv), DBL_DIG, 0, s); errno = olderrno; +#ifdef FIXNEGATIVEZERO + if (*s == '-' && s[1] == '0' && !s[2]) + strcpy(s,"0"); +#endif while (*s) s++; #ifdef hcx if (s[-1] == '.') @@ -1150,22 +1297,48 @@ STRLEN *lp; SvGROW(sv, 11); s = SvPVX(sv); olderrno = errno; /* some Xenix systems wipe out errno here */ - (void)sprintf(s,"%ld",SvIVX(sv)); + (void)sprintf(s,"%ld",(long)SvIVX(sv)); errno = olderrno; while (*s) s++; } else { - if (dowarn) + if (dowarn && !localizing) warn(warn_uninit); - sv_grow(sv, 1); - s = SvPVX(sv); + *lp = 0; + return ""; } *s = '\0'; *lp = s - SvPVX(sv); SvCUR_set(sv, *lp); SvPOK_on(sv); - DEBUG_c((stderr,"0x%lx 2pv(%s)\n",sv,SvPVX(sv))); + DEBUG_c(fprintf(stderr,"0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv))); return SvPVX(sv); + + tokensave: + if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */ + /* Sneaky stuff here */ + + tokensaveref: + sv = sv_newmortal(); + *lp = strlen(tokenbuf); + sv_setpvn(sv, tokenbuf, *lp); + return SvPVX(sv); + } + else { + STRLEN len; + +#ifdef FIXNEGATIVEZERO + if (*tokenbuf == '-' && tokenbuf[1] == '0' && !tokenbuf[2]) + strcpy(tokenbuf,"0"); +#endif + (void)SvUPGRADE(sv, SVt_PV); + len = *lp = strlen(tokenbuf); + s = SvGROW(sv, len + 1); + SvCUR_set(sv, len); + (void)strcpy(s, tokenbuf); + /* NO SvPOK_on(sv) here! */ + return s; + } } /* This function is only called on magical items */ @@ -1176,8 +1349,18 @@ register SV *sv; if (SvGMAGICAL(sv)) mg_get(sv); - if (SvROK(sv)) - return SvRV(sv) != 0; + if (!SvOK(sv)) + return 0; + if (SvROK(sv)) { +#ifdef OVERLOAD + { + SV* tmpsv; + if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_))) + return SvTRUE(tmpsv); + } +#endif /* OVERLOAD */ + return SvRV(sv) != 0; + } if (SvPOKp(sv)) { register XPV* Xpv; if ((Xpv = (XPV*)SvANY(sv)) && @@ -1227,30 +1410,33 @@ register SV *sstr; stype = SvTYPE(sstr); dtype = SvTYPE(dstr); +#ifdef OVERLOAD + SvAMAGIC_off(dstr); +#endif /* OVERLOAD */ /* There's a lot of redundancy below but we're going for speed here */ switch (stype) { case SVt_NULL: - SvOK_off(dstr); + (void)SvOK_off(dstr); return; case SVt_IV: if (dtype <= SVt_PV) { if (dtype < SVt_IV) sv_upgrade(dstr, SVt_IV); - else if (dtype == SVt_PV) - sv_upgrade(dstr, SVt_PVIV); else if (dtype == SVt_NV) sv_upgrade(dstr, SVt_PVNV); + else if (dtype <= SVt_PV) + sv_upgrade(dstr, SVt_PVIV); } break; case SVt_NV: if (dtype <= SVt_PVIV) { if (dtype < SVt_NV) sv_upgrade(dstr, SVt_NV); - else if (dtype == SVt_PV) - sv_upgrade(dstr, SVt_PVNV); else if (dtype == SVt_PVIV) sv_upgrade(dstr, SVt_PVNV); + else if (dtype <= SVt_PV) + sv_upgrade(dstr, SVt_PVNV); } break; case SVt_RV: @@ -1271,19 +1457,28 @@ register SV *sstr; break; case SVt_PVGV: if (dtype <= SVt_PVGV) { - if (dtype < SVt_PVGV) + if (dtype < SVt_PVGV) { + char *name = GvNAME(sstr); + STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); - SvOK_off(dstr); + sv_magic(dstr, dstr, '*', name, len); + GvSTASH(dstr) = GvSTASH(sstr); + GvNAME(dstr) = savepvn(name, len); + GvNAMELEN(dstr) = len; + SvFAKE_on(dstr); /* can coerce to non-glob */ + } + (void)SvOK_off(dstr); if (!GvAV(sstr)) gv_AVadd(sstr); if (!GvHV(sstr)) gv_HVadd(sstr); if (!GvIO(sstr)) - GvIO(sstr) = newIO(); + gv_IOadd(sstr); if (GvGP(dstr)) gp_free(dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); + GvFLAGS(dstr) &= ~GVf_INTRO; /* one-shot flag */ return; } /* FALL THROUGH */ @@ -1302,47 +1497,79 @@ register SV *sstr; if (dtype == SVt_PVGV) { SV *sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; - GP *oldgp = GvGP(dstr); - GP *gp; - + int intro = GvFLAGS(dstr) & GVf_INTRO; + + if (intro) { + GP *gp; + GvGP(dstr)->gp_refcnt--; + Newz(602,gp, 1, GP); + GvGP(dstr) = gp; + GvREFCNT(dstr) = 1; + GvSV(dstr) = NEWSV(72,0); + GvLINE(dstr) = curcop->cop_line; + GvEGV(dstr) = dstr; + GvFLAGS(dstr) &= ~GVf_INTRO; /* one-shot flag */ + } + SvMULTI_on(dstr); switch (SvTYPE(sref)) { case SVt_PVAV: - dref = (SV*)GvAV(dstr); + if (intro) + SAVESPTR(GvAV(dstr)); + else + dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; break; case SVt_PVHV: - dref = (SV*)GvHV(dstr); + if (intro) + SAVESPTR(GvHV(dstr)); + else + dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; break; case SVt_PVCV: - dref = (SV*)GvCV(dstr); + if (intro) + SAVESPTR(GvCV(dstr)); + else + dref = (SV*)GvCV(dstr); + GvFLAGS(dstr) |= GVf_IMPORTED; GvCV(dstr) = (CV*)sref; break; default: - dref = (SV*)GvSV(dstr); + if (intro) + SAVESPTR(GvSV(dstr)); + else + dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; break; } if (dref) SvREFCNT_dec(dref); + if (intro) + SAVEFREESV(sref); SvTAINT(dstr); return; } - if (SvPVX(dstr)) + if (SvPVX(dstr)) { Safefree(SvPVX(dstr)); + SvLEN(dstr)=SvCUR(dstr)=0; + } } - SvOK_off(dstr); + (void)SvOK_off(dstr); SvRV(dstr) = SvREFCNT_inc(SvRV(sstr)); SvROK_on(dstr); - ++sv_rvcount; if (sflags & SVp_NOK) { SvNOK_on(dstr); SvNVX(dstr) = SvNVX(sstr); } if (sflags & SVp_IOK) { - SvIOK_on(dstr); + (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); } +#ifdef OVERLOAD + if (SvAMAGIC(sstr)) { + SvAMAGIC_on(dstr); + } +#endif /* OVERLOAD */ } else if (sflags & SVp_POK) { @@ -1355,13 +1582,13 @@ register SV *sstr; if (SvTEMP(sstr)) { /* slated for free anyway? */ if (SvPOK(dstr)) { - SvOOK_off(dstr); + (void)SvOOK_off(dstr); Safefree(SvPVX(dstr)); } SvPV_set(dstr, SvPVX(sstr)); SvLEN_set(dstr, SvLEN(sstr)); SvCUR_set(dstr, SvCUR(sstr)); - SvPOK_only(dstr); + (void)SvPOK_only(dstr); SvTEMP_off(dstr); SvPV_set(sstr, Nullch); SvLEN_set(sstr, 0); @@ -1375,7 +1602,7 @@ register SV *sstr; Move(SvPVX(sstr),SvPVX(dstr),len,char); SvCUR_set(dstr, len); *SvEND(dstr) = '\0'; - SvPOK_only(dstr); + (void)SvPOK_only(dstr); } /*SUPPRESS 560*/ if (sflags & SVp_NOK) { @@ -1383,24 +1610,28 @@ register SV *sstr; SvNVX(dstr) = SvNVX(sstr); } if (sflags & SVp_IOK) { - SvIOK_on(dstr); + (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); } } else if (sflags & SVp_NOK) { SvNVX(dstr) = SvNVX(sstr); - SvNOK_only(dstr); + (void)SvNOK_only(dstr); if (SvIOK(sstr)) { - SvIOK_on(dstr); + (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); } } else if (sflags & SVp_IOK) { - SvIOK_only(dstr); + (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); } else { - SvOK_off(dstr); + (void)SvOK_off(dstr); + } + if (SvOBJECT(sstr)) { + SvOBJECT_on(dstr); + SvSTASH(dstr) = (HV*)SvREFCNT_inc(SvSTASH(sstr)); } SvTAINT(dstr); } @@ -1418,17 +1649,16 @@ register STRLEN len; sv_unref(sv); } if (!ptr) { - SvOK_off(sv); + (void)SvOK_off(sv); return; } if (!SvUPGRADE(sv, SVt_PV)) return; SvGROW(sv, len + 1); - if (ptr) - Move(ptr,SvPVX(sv),len,char); + Move(ptr,SvPVX(sv),len,char); SvCUR_set(sv, len); *SvEND(sv) = '\0'; - SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only(sv); /* validate pointer */ SvTAINT(sv); } @@ -1446,7 +1676,7 @@ register char *ptr; sv_unref(sv); } if (!ptr) { - SvOK_off(sv); + (void)SvOK_off(sv); return; } len = strlen(ptr); @@ -1455,7 +1685,7 @@ register char *ptr; SvGROW(sv, len + 1); Move(ptr,SvPVX(sv),len+1,char); SvCUR_set(sv, len); - SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only(sv); /* validate pointer */ SvTAINT(sv); } @@ -1474,7 +1704,7 @@ register STRLEN len; if (!SvUPGRADE(sv, SVt_PV)) return; if (!ptr) { - SvOK_off(sv); + (void)SvOK_off(sv); return; } if (SvPVX(sv)) @@ -1484,7 +1714,7 @@ register STRLEN len; SvCUR_set(sv, len); SvLEN_set(sv, len+1); *SvEND(sv) = '\0'; - SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only(sv); /* validate pointer */ SvTAINT(sv); } @@ -1495,7 +1725,7 @@ register char *ptr; { register STRLEN delta; - if (!ptr || !SvPOK(sv)) + if (!ptr || !SvPOKp(sv)) return; if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) @@ -1526,21 +1756,13 @@ register STRLEN len; { STRLEN tlen; char *s; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) { - s = SvPV(sv, tlen); - sv_unref(sv); - sv_setpvn(sv, s, tlen); - } - } - s = SvPV(sv, tlen); + + s = SvPV_force(sv, tlen); SvGROW(sv, tlen + len + 1); Move(ptr,SvPVX(sv)+tlen,len,char); SvCUR(sv) += len; *SvEND(sv) = '\0'; - SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only(sv); /* validate pointer */ SvTAINT(sv); } @@ -1566,20 +1788,14 @@ register char *ptr; STRLEN tlen; char *s; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); - } if (!ptr) return; - s = SvPV(sv, tlen); + s = SvPV_force(sv, tlen); len = strlen(ptr); SvGROW(sv, tlen + len + 1); Move(ptr,SvPVX(sv)+tlen,len+1,char); SvCUR(sv) += len; - SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only(sv); /* validate pointer */ SvTAINT(sv); } @@ -1606,23 +1822,17 @@ STRLEN len; } void -#ifndef STANDARD_C sv_magic(sv, obj, how, name, namlen) register SV *sv; SV *obj; -char how; +int how; char *name; I32 namlen; -#else -sv_magic(register SV *sv, SV *obj, char how, char *name, I32 namlen) -#endif /* STANDARD_C */ { MAGIC* mg; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how)) - croak(no_modify); - } + if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how)) + croak(no_modify); if (SvMAGICAL(sv)) { if (SvMAGIC(sv) && mg_find(sv, how)) return; @@ -1635,7 +1845,7 @@ sv_magic(register SV *sv, SV *obj, char how, char *name, I32 namlen) mg->mg_moremagic = SvMAGIC(sv); SvMAGIC(sv) = mg; - if (obj == sv) + if (obj == sv || how == '#') mg->mg_obj = obj; else { mg->mg_obj = SvREFCNT_inc(obj); @@ -1644,11 +1854,22 @@ sv_magic(register SV *sv, SV *obj, char how, char *name, I32 namlen) mg->mg_type = how; mg->mg_len = namlen; if (name && namlen >= 0) - mg->mg_ptr = nsavestr(name, namlen); + mg->mg_ptr = savepvn(name, namlen); switch (how) { case 0: mg->mg_virtual = &vtbl_sv; break; +#ifdef OVERLOAD + case 'A': + mg->mg_virtual = &vtbl_amagic; + break; + case 'a': + mg->mg_virtual = &vtbl_amagicelem; + break; + case 'c': + mg->mg_virtual = 0; + break; +#endif /* OVERLOAD */ case 'B': mg->mg_virtual = &vtbl_bm; break; @@ -1668,6 +1889,7 @@ sv_magic(register SV *sv, SV *obj, char how, char *name, I32 namlen) mg->mg_virtual = &vtbl_isaelem; break; case 'L': + SvRMAGICAL_on(sv); mg->mg_virtual = 0; break; case 'l': @@ -1677,6 +1899,7 @@ sv_magic(register SV *sv, SV *obj, char how, char *name, I32 namlen) mg->mg_virtual = &vtbl_pack; break; case 'p': + case 'q': mg->mg_virtual = &vtbl_packelem; break; case 'S': @@ -1703,6 +1926,11 @@ sv_magic(register SV *sv, SV *obj, char how, char *name, I32 namlen) case '#': mg->mg_virtual = &vtbl_arylen; break; + case '.': + mg->mg_virtual = &vtbl_pos; + break; + case '~': /* reserved for extensions but multiple extensions may clash */ + break; default: croak("Don't know how to handle magic of type '%c'", how); } @@ -1712,13 +1940,9 @@ sv_magic(register SV *sv, SV *obj, char how, char *name, I32 namlen) } int -#ifndef STANDARD_C sv_unmagic(sv, type) SV* sv; -char type; -#else -sv_unmagic(SV *sv, char type) -#endif /* STANDARD_C */ +int type; { MAGIC* mg; MAGIC** mgp; @@ -1733,7 +1957,8 @@ sv_unmagic(SV *sv, char type) (*vtbl->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') Safefree(mg->mg_ptr); - SvREFCNT_dec(mg->mg_obj); + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); Safefree(mg); } else @@ -1763,20 +1988,11 @@ STRLEN littlelen; if (!bigstr) croak("Can't modify non-existent substring"); - if (SvTHINKFIRST(bigstr)) { - if (SvREADONLY(bigstr) && curcop != &compiling) - croak(no_modify); - if (SvROK(bigstr)) - sv_unref(bigstr); - } - SvPOK_only(bigstr); + SvPV_force(bigstr, na); i = littlelen - len; if (i > 0) { /* string might grow */ - if (!SvUPGRADE(bigstr, SVt_PV)) - return; - SvGROW(bigstr, SvCUR(bigstr) + i + 1); - big = SvPVX(bigstr); + big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); mid = big + offset + len; midend = bigend = big + SvCUR(bigstr); bigend += i; @@ -1854,9 +2070,12 @@ register SV *nsv; if (SvREFCNT(nsv) != 1) warn("Reference miscount in sv_replace()"); if (SvMAGICAL(sv)) { - SvUPGRADE(nsv, SVt_PVMG); + if (SvMAGICAL(nsv)) + mg_free(nsv); + else + sv_upgrade(nsv, SVt_PVMG); SvMAGIC(nsv) = SvMAGIC(sv); - SvMAGICAL_on(nsv); + SvFLAGS(nsv) |= SvMAGICAL(sv); SvMAGICAL_off(sv); SvMAGIC(sv) = 0; } @@ -1876,97 +2095,80 @@ register SV *sv; if (SvOBJECT(sv)) { dSP; - BINOP myop; /* fake syntax tree node */ GV* destructor; - SvOBJECT_off(sv); /* Curse the object. */ - - ENTER; - SAVETMPS; - SAVESPTR(curcop); - SAVESPTR(op); - curcop = &compiling; - curstash = SvSTASH(sv); - destructor = gv_fetchpv("DESTROY", FALSE, SVt_PVCV); - - if (destructor && GvCV(destructor)) { - SV ref; - Zero(&ref, 1, SV); - sv_upgrade(&ref, SVt_RV); - SvRV(&ref) = SvREFCNT_inc(sv); - SvROK_on(&ref); - - op = (OP*)&myop; - Zero(op, 1, OP); - myop.op_last = (OP*)&myop; - myop.op_flags = OPf_STACKED; - myop.op_next = Nullop; - - EXTEND(SP, 2); - PUSHs((SV*)destructor); - pp_pushmark(); - PUSHs(&ref); - PUTBACK; - op = pp_entersubr(); - if (op) - run(); - stack_sp--; - SvREFCNT(sv) = 0; - FREE_TMPS(); - } - SvREFCNT_dec(SvSTASH(sv)); - LEAVE; + if (defstash) { /* Still have a symbol table? */ + destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + + ENTER; + SAVEFREESV(SvSTASH(sv)); + if (destructor && GvCV(destructor)) { + SV ref; + + Zero(&ref, 1, SV); + sv_upgrade(&ref, SVt_RV); + SAVEI32(SvREFCNT(sv)); + SvRV(&ref) = SvREFCNT_inc(sv); + SvROK_on(&ref); + + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(&ref); + PUTBACK; + perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL); + } + LEAVE; + } + if (SvOBJECT(sv)) { + SvOBJECT_off(sv); /* Curse the object. */ + if (SvTYPE(sv) != SVt_PVIO) + --sv_objcount; /* XXX Might want something more general */ + } } + if (SvMAGICAL(sv)) + mg_free(sv); switch (SvTYPE(sv)) { case SVt_PVIO: Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); - goto freemagic; + /* FALL THROUGH */ case SVt_PVFM: - goto freemagic; case SVt_PVBM: - goto freemagic; - case SVt_PVGV: - gp_free(sv); - Safefree(GvNAME(sv)); - goto freemagic; + goto freescalar; case SVt_PVCV: cv_undef((CV*)sv); - goto freemagic; + goto freescalar; case SVt_PVHV: hv_undef((HV*)sv); - SvPVX(sv)= 0; - goto freemagic; + break; case SVt_PVAV: av_undef((AV*)sv); - SvPVX(sv)= 0; - goto freemagic; + break; + case SVt_PVGV: + gp_free(sv); + Safefree(GvNAME(sv)); + /* FALL THROUGH */ case SVt_PVLV: - goto freemagic; case SVt_PVMG: - freemagic: - if (SvMAGICAL(sv)) - mg_free(sv); case SVt_PVNV: case SVt_PVIV: - SvOOK_off(sv); + freescalar: + (void)SvOOK_off(sv); /* FALL THROUGH */ case SVt_PV: + case SVt_RV: if (SvROK(sv)) SvREFCNT_dec(SvRV(sv)); else if (SvPVX(sv)) Safefree(SvPVX(sv)); break; +/* case SVt_NV: - break; case SVt_IV: - break; - case SVt_RV: - SvREFCNT_dec(SvRV(sv)); - break; case SVt_NULL: break; +*/ } switch (SvTYPE(sv)) { @@ -2018,6 +2220,7 @@ register SV *sv; del_XPVIO(SvANY(sv)); break; } + SvFLAGS(sv) &= SVf_BREAK; SvFLAGS(sv) |= SVTYPEMASK; } @@ -2036,13 +2239,13 @@ SV *sv; { if (!sv) return; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { - if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no) - return; - } + if (SvREADONLY(sv)) { + if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no) + return; } - if (SvREFCNT(sv) == 0 && !(SvFLAGS(sv) & SVf_BREAK)) { + if (SvREFCNT(sv) == 0) { + if (SvFLAGS(sv) & SVf_BREAK) + return; warn("Attempt to free unreferenced scalar"); return; } @@ -2170,11 +2373,15 @@ I32 append; sv_unref(sv); } if (!SvUPGRADE(sv, SVt_PV)) - return; + return 0; if (rspara) { /* have to do this both before and after */ do { /* to make sure file boundaries work right */ + if (feof(fp)) + return 0; i = getc(fp); if (i != '\n') { + if (i == -1) + return 0; ungetc(i,fp); break; } @@ -2182,7 +2389,7 @@ I32 append; } #ifdef USE_STD_STDIO /* Here is some breathtakingly efficient cheating */ cnt = fp->_cnt; /* get count into register */ - SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only(sv); /* validate pointer */ if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */ if (cnt > 80 && SvLEN(sv) > append) { shortbuffered = cnt - SvLEN(sv) + append + 1; @@ -2306,27 +2513,31 @@ register SV *sv; if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); + if (SvROK(sv)) { +#ifdef OVERLOAD + if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; +#endif /* OVERLOAD */ + sv_unref(sv); + } } if (SvGMAGICAL(sv)) mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_IOK) { ++SvIVX(sv); - SvIOK_only(sv); + (void)SvIOK_only(sv); return; } if (flags & SVp_NOK) { SvNVX(sv) += 1.0; - SvNOK_only(sv); + (void)SvNOK_only(sv); return; } if (!(flags & SVp_POK) || !*SvPVX(sv)) { if (!SvUPGRADE(sv, SVt_NV)) return; SvNVX(sv) = 1.0; - SvNOK_only(sv); + (void)SvNOK_only(sv); return; } d = SvPVX(sv); @@ -2372,27 +2583,31 @@ register SV *sv; if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); + if (SvROK(sv)) { +#ifdef OVERLOAD + if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; +#endif /* OVERLOAD */ + sv_unref(sv); + } } if (SvGMAGICAL(sv)) mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_IOK) { --SvIVX(sv); - SvIOK_only(sv); + (void)SvIOK_only(sv); return; } if (flags & SVp_NOK) { SvNVX(sv) -= 1.0; - SvNOK_only(sv); + (void)SvNOK_only(sv); return; } if (!(flags & SVp_POK)) { if (!SvUPGRADE(sv, SVt_NV)) return; SvNVX(sv) = -1.0; - SvNOK_only(sv); + (void)SvNOK_only(sv); return; } sv_setnv(sv,atof(SvPVX(sv)) - 1.0); @@ -2451,10 +2666,8 @@ register SV *sv; { if (!sv) return sv; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - } + if (SvREADONLY(sv) && curcop != &compiling) + croak(no_modify); if (++tmps_ix >= tmps_max) sv_mortalgrow(); tmps_stack[tmps_ix] = sv; @@ -2495,7 +2708,7 @@ double n; SV * newSViv(i) -I32 i; +IV i; { register SV *sv; @@ -2518,9 +2731,9 @@ SV *ref; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv_upgrade(sv, SVt_RV); + SvTEMP_off(ref); SvRV(sv) = SvREFCNT_inc(ref); SvROK_on(sv); - ++sv_rvcount; return sv; } @@ -2587,7 +2800,7 @@ HV *stash; for ( ; i <= max; i++) { todo[i] = 1; } - for (i = 0; i <= HvMAX(stash); i++) { + for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) { @@ -2595,7 +2808,7 @@ HV *stash; continue; gv = (GV*)entry->hent_val; sv = GvSV(gv); - SvOK_off(sv); + (void)SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { SvCUR_set(sv, 0); SvTAINT(sv); @@ -2606,9 +2819,13 @@ HV *stash; av_clear(GvAV(gv)); } if (GvHV(gv)) { + if (HvNAME(GvHV(gv))) + continue; hv_clear(GvHV(gv)); +#ifndef VMS /* VMS has no environ array */ if (gv == envgv) environ[0] = Nullch; +#endif } } } @@ -2628,14 +2845,6 @@ I32 lref; if (!sv) return *gvp = Nullgv, Nullcv; switch (SvTYPE(sv)) { - case SVt_RV: - is_rv: - cv = (CV*)SvRV(sv); - if (SvTYPE(cv) != SVt_PVCV) - croak("Not a subroutine reference"); - *gvp = Nullgv; - *st = CvSTASH(cv); - return cv; case SVt_PVCV: *st = CvSTASH(sv); *gvp = Nullgv; @@ -2646,12 +2855,21 @@ I32 lref; return Nullcv; case SVt_PVGV: gv = (GV*)sv; + *gvp = gv; *st = GvESTASH(gv); goto fix_gv; default: - if (SvROK(sv)) - goto is_rv; + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv)) { + cv = (CV*)SvRV(sv); + if (SvTYPE(cv) != SVt_PVCV) + croak("Not a subroutine reference"); + *gvp = Nullgv; + *st = CvSTASH(cv); + return cv; + } if (isGV(sv)) gv = (GV*)sv; else @@ -2662,7 +2880,7 @@ I32 lref; *st = GvESTASH(gv); fix_gv: if (lref && !GvCV(gv)) { - sv = NEWSV(0,0); + sv = NEWSV(704,0); gv_efullname(sv, gv); newSUB(savestack_ix, newSVOP(OP_CONST, 0, sv), @@ -2705,7 +2923,7 @@ register SV *sv; #endif /* SvTRUE */ #ifndef SvIV -I32 SvIV(Sv) +IV SvIV(Sv) register SV *Sv; { if (SvIOK(Sv)) @@ -2735,12 +2953,88 @@ STRLEN *lp; { if (SvPOK(sv)) { *lp = SvCUR(sv); - return SvPVX(sv) + return SvPVX(sv); } return sv_2pv(sv, lp); } #endif +char * +sv_pvn_force(sv, lp) +SV *sv; +STRLEN *lp; +{ + char *s; + + if (SvREADONLY(sv) && curcop != &compiling) + croak(no_modify); + + if (SvPOK(sv)) { + *lp = SvCUR(sv); + } + else { + if (SvTYPE(sv) > SVt_PVLV) { + if (SvFAKE(sv)) + sv_unglob(sv); + else + croak("Can't coerce %s to string in %s", sv_reftype(sv,0), + op_name[op->op_type]); + } + s = sv_2pv(sv, lp); + if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */ + STRLEN len = *lp; + + if (SvROK(sv)) + sv_unref(sv); + (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */ + SvGROW(sv, len + 1); + Move(s,SvPVX(sv),len,char); + SvCUR_set(sv, len); + *SvEND(sv) = '\0'; + } + if (!SvPOK(sv)) { + SvPOK_on(sv); /* validate pointer */ + SvTAINT(sv); + DEBUG_c(fprintf(stderr,"0x%lx 2pv(%s)\n", + (unsigned long)sv,SvPVX(sv))); + } + } + return SvPVX(sv); +} + +char * +sv_reftype(sv, ob) +SV* sv; +int ob; +{ + if (ob && SvOBJECT(sv)) + return HvNAME(SvSTASH(sv)); + else { + switch (SvTYPE(sv)) { + case SVt_NULL: + case SVt_IV: + case SVt_NV: + case SVt_RV: + case SVt_PV: + case SVt_PVIV: + case SVt_PVNV: + case SVt_PVMG: + case SVt_PVBM: + if (SvROK(sv)) + return "REF"; + else + return "SCALAR"; + case SVt_PVLV: return "LVALUE"; + case SVt_PVAV: return "ARRAY"; + case SVt_PVHV: return "HASH"; + case SVt_PVCV: return "CODE"; + case SVt_PVGV: return "GLOB"; + case SVt_PVFM: return "FORMLINE"; + default: return "UNKNOWN"; + } + } +} + int sv_isobject(sv) SV *sv; @@ -2768,50 +3062,123 @@ char *name; } SV* -sv_setptrobj(rv, ptr, name) +newSVrv(rv, classname) SV *rv; -void *ptr; -char *name; +char *classname; { - HV *stash; SV *sv; - if (!ptr) - return rv; - new_SV(); SvANY(sv) = 0; - SvREFCNT(sv) = 1; + SvREFCNT(sv) = 0; SvFLAGS(sv) = 0; - sv_setnv(sv, (double)(unsigned long)ptr); sv_upgrade(rv, SVt_RV); SvRV(rv) = SvREFCNT_inc(sv); SvROK_on(rv); - ++sv_rvcount; - stash = fetch_stash(newSVpv(name,0), TRUE); - SvOBJECT_on(sv); - SvUPGRADE(sv, SVt_PVMG); - SvSTASH(sv) = (HV*)SvREFCNT_inc(stash); + if (classname) { + HV* stash = gv_stashpv(classname, TRUE); + (void)sv_bless(rv, stash); + } + return sv; +} + +SV* +sv_setref_pv(rv, classname, pv) +SV *rv; +char *classname; +void* pv; +{ + if (!pv) + sv_setsv(rv, &sv_undef); + else + sv_setiv(newSVrv(rv,classname), (IV)pv); + return rv; +} + +SV* +sv_setref_iv(rv, classname, iv) +SV *rv; +char *classname; +IV iv; +{ + sv_setiv(newSVrv(rv,classname), iv); + return rv; +} + +SV* +sv_setref_nv(rv, classname, nv) +SV *rv; +char *classname; +double nv; +{ + sv_setnv(newSVrv(rv,classname), nv); + return rv; +} +SV* +sv_setref_pvn(rv, classname, pv, n) +SV *rv; +char *classname; +char* pv; +I32 n; +{ + sv_setpvn(newSVrv(rv,classname), pv, n); return rv; } +SV* +sv_bless(sv,stash) +SV* sv; +HV* stash; +{ + SV *ref; + if (!SvROK(sv)) + croak("Can't bless non-reference value"); + ref = SvRV(sv); + if (SvFLAGS(ref) & (SVs_OBJECT|SVf_READONLY)) { + if (SvREADONLY(ref)) + croak(no_modify); + if (SvOBJECT(ref) && SvTYPE(ref) != SVt_PVIO) + --sv_objcount; + } + SvOBJECT_on(ref); + ++sv_objcount; + (void)SvUPGRADE(ref, SVt_PVMG); + SvSTASH(ref) = (HV*)SvREFCNT_inc(stash); + +#ifdef OVERLOAD + if (Gv_AMG(stash)) { + SvAMAGIC_on(sv); + } +#endif /* OVERLOAD */ + + return sv; +} + +static void +sv_unglob(sv) +SV* sv; +{ + assert(SvTYPE(sv) == SVt_PVGV); + SvFAKE_off(sv); + if (GvGP(sv)) + gp_free(sv); + sv_unmagic(sv, '*'); + Safefree(GvNAME(sv)); + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= SVt_PVMG; +} + void sv_unref(sv) SV* sv; { - SvREFCNT_dec(SvRV(sv)); + SV* rv = SvRV(sv); + SvRV(sv) = 0; SvROK_off(sv); - if (!(SvFLAGS(sv) & (SVp_IOK|SVp_NOK))) { - SvFLAGS(sv) &= ~SVf_OK; - if (SvTYPE(sv) == SVt_RV) { - del_XRV(SvANY(sv)); - SvFLAGS(sv) &= ~SVTYPEMASK; /* Make into type NULL. */ - } - } - --sv_rvcount; + SvREFCNT_dec(rv); } #ifdef DEBUGGING @@ -2849,8 +3216,8 @@ SV* sv; if (flags & SVf_NOK) strcat(d, "NOK,"); if (flags & SVf_POK) strcat(d, "POK,"); if (flags & SVf_ROK) strcat(d, "ROK,"); - if (flags & SVf_OK) strcat(d, "OK,"); if (flags & SVf_OOK) strcat(d, "OOK,"); + if (flags & SVf_FAKE) strcat(d, "FAKE,"); if (flags & SVf_READONLY) strcat(d, "READONLY,"); d += strlen(d); @@ -2921,9 +3288,9 @@ SV* sv; 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 = %.20g\n", SvNVX(sv)); + fprintf(stderr, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); if (SvROK(sv)) { - fprintf(stderr, " RV = 0x%lx\n", SvRV(sv)); + fprintf(stderr, " RV = 0x%lx\n", (long)SvRV(sv)); sv_dump(SvRV(sv)); return; } @@ -2932,13 +3299,13 @@ SV* sv; if (type <= SVt_PVLV) { if (SvPVX(sv)) fprintf(stderr, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n", - SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv)); + (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", SvMAGIC(sv)); + fprintf(stderr, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv)); } if (SvSTASH(sv)) fprintf(stderr, " STASH = %s\n", HvNAME(SvSTASH(sv))); @@ -2948,82 +3315,81 @@ SV* sv; 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", LvTARG(sv)); + fprintf(stderr, " TARG = 0x%lx\n", (long)LvTARG(sv)); sv_dump(LvTARG(sv)); break; case SVt_PVAV: - fprintf(stderr, " ARRAY = 0x%lx\n", AvARRAY(sv)); - fprintf(stderr, " ALLOC = 0x%lx\n", AvALLOC(sv)); + 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", AvARYLEN(sv)); + fprintf(stderr, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv)); if (AvREAL(sv)) fprintf(stderr, " FLAGS = (REAL)\n"); else fprintf(stderr, " FLAGS = ()\n"); break; case SVt_PVHV: - fprintf(stderr, " ARRAY = 0x%lx\n", HvARRAY(sv)); + 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", HvEITER(sv)); + fprintf(stderr, " EITER = 0x%lx\n",(long) HvEITER(sv)); if (HvPMROOT(sv)) - fprintf(stderr, " PMROOT = 0x%lx\n", 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", CvSTASH(sv)); - fprintf(stderr, " START = 0x%lx\n", CvSTART(sv)); - fprintf(stderr, " ROOT = 0x%lx\n", CvROOT(sv)); - fprintf(stderr, " USERSUB = 0x%lx\n", CvUSERSUB(sv)); - fprintf(stderr, " USERINDEX = %ld\n", (long)CvUSERINDEX(sv)); - fprintf(stderr, " FILEGV = 0x%lx\n", CvFILEGV(sv)); + 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", CvPADLIST(sv)); - fprintf(stderr, " DELETED = %ld\n", (long)CvDELETED(sv)); + fprintf(stderr, " PADLIST = 0x%lx\n", (long)CvPADLIST(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", GvSTASH(sv)); - fprintf(stderr, " GP = 0x%lx\n", GvGP(sv)); - fprintf(stderr, " SV = 0x%lx\n", GvSV(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", GvIO(sv)); - fprintf(stderr, " FORM = 0x%lx\n", GvFORM(sv)); - fprintf(stderr, " AV = 0x%lx\n", GvAV(sv)); - fprintf(stderr, " HV = 0x%lx\n", GvHV(sv)); - fprintf(stderr, " CV = 0x%lx\n", GvCV(sv)); - fprintf(stderr, " CVGEN = 0x%lx\n", GvCVGEN(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", GvSTASH(sv)); - fprintf(stderr, " EGV = 0x%lx\n", GvEGV(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", IoIFP(sv)); - fprintf(stderr, " OFP = 0x%lx\n", IoOFP(sv)); - fprintf(stderr, " DIRP = 0x%lx\n", IoDIRP(sv)); + 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", IoTOP_GV(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", IoFMT_GV(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", IoBOTTOM_GV(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", IoFLAGS(sv)); + fprintf(stderr, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); break; } } @@ -3034,3 +3400,38 @@ SV* sv; { } #endif + +IO* +sv_2io(sv) +SV *sv; +{ + IO* io; + GV* gv; + + switch (SvTYPE(sv)) { + case SVt_PVIO: + io = (IO*)sv; + break; + case SVt_PVGV: + gv = (GV*)sv; + io = GvIO(gv); + if (!io) + croak("Bad filehandle: %s", GvNAME(gv)); + break; + default: + if (!SvOK(sv)) + croak(no_usym, "filehandle"); + if (SvROK(sv)) + return sv_2io(SvRV(sv)); + gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO); + if (gv) + io = GvIO(gv); + else + io = 0; + if (!io) + croak("Bad filehandle: %s", SvPV(sv,na)); + break; + } + return io; +} + @@ -1,49 +1,33 @@ -/* $RCSfile: sv.h,v $$Revision: 4.1 $$Date: 92/08/07 18:26:57 $ +/* sv.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: sv.h,v $ - * Revision 4.1 92/08/07 18:26:57 lwall - * - * Revision 4.0.1.4 92/06/08 15:41:45 lwall - * patch20: fixed confusion between a *var's real name and its effective name - * patch20: removed implicit int declarations on functions - * - * Revision 4.0.1.3 91/11/05 18:41:47 lwall - * patch11: random cleanup - * patch11: solitary subroutine references no longer trigger typo warnings - * - * Revision 4.0.1.2 91/06/07 11:58:33 lwall - * patch4: new copyright notice - * - * Revision 4.0.1.1 91/04/12 09:16:12 lwall - * patch1: you may now use "die" and "caller" in a signal handler - * - * Revision 4.0 91/03/20 01:40:04 lwall - * 4.0 baseline. - * */ +#ifdef sv_flags +#undef sv_flags /* Convex has this in <signal.h> for sigvec() */ +#endif + typedef enum { - SVt_NULL, - SVt_IV, - SVt_NV, - SVt_RV, - SVt_PV, - SVt_PVIV, - SVt_PVNV, - SVt_PVMG, - SVt_PVBM, - SVt_PVLV, - SVt_PVAV, - SVt_PVHV, - SVt_PVCV, - SVt_PVGV, - SVt_PVFM, - SVt_PVIO + SVt_NULL, /* 0 */ + SVt_IV, /* 1 */ + SVt_NV, /* 2 */ + SVt_RV, /* 3 */ + SVt_PV, /* 4 */ + SVt_PVIV, /* 5 */ + SVt_PVNV, /* 6 */ + SVt_PVMG, /* 7 */ + SVt_PVBM, /* 8 */ + SVt_PVLV, /* 9 */ + SVt_PVAV, /* 10 */ + SVt_PVHV, /* 11 */ + SVt_PVCV, /* 12 */ + SVt_PVGV, /* 13 */ + SVt_PVFM, /* 14 */ + SVt_PVIO /* 15 */ } svtype; /* Using C's structural equivalence to help emulate C++ inheritance here... */ @@ -115,16 +99,26 @@ struct io { #define SVf_NOK 0x00020000 /* has valid public numeric value */ #define SVf_POK 0x00040000 /* has valid public pointer value */ #define SVf_ROK 0x00080000 /* has a valid reference pointer */ -#define SVf_OK 0x00100000 /* has defined value */ + +#define SVf_FAKE 0x00100000 /* glob is just a copy */ #define SVf_OOK 0x00200000 /* has valid offset value */ #define SVf_BREAK 0x00400000 /* refcnt is artificially low */ #define SVf_READONLY 0x00800000 /* may not be modified */ +#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK) + #define SVp_IOK 0x01000000 /* has valid non-public integer value */ #define SVp_NOK 0x02000000 /* has valid non-public numeric value */ #define SVp_POK 0x04000000 /* has valid non-public pointer value */ #define SVp_SCREAM 0x08000000 /* has been studied? */ +#define SVf_OK (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \ + SVp_IOK|SVp_NOK|SVp_POK) + +#ifdef OVERLOAD +#define SVf_AMAGIC 0x10000000 /* has magical overloaded methods */ +#endif /* OVERLOAD */ + #define PRIVSHIFT 8 /* Some private flags. */ @@ -137,6 +131,11 @@ struct io { #define SVpgv_MULTI 0x80000000 +#ifdef OVERLOAD +#define SVpgv_AM 0x40000000 +/* #define SVpgv_badAM 0x20000000 */ +#endif /* OVERLOAD */ + struct xrv { SV * xrv_rv; /* pointer to another SV */ }; @@ -151,14 +150,14 @@ struct xpviv { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ + IV xiv_iv; /* integer value or pv offset */ }; struct xpvnv { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ + IV xiv_iv; /* integer value or pv offset */ double xnv_nv; /* numeric value, if any */ }; @@ -166,7 +165,7 @@ struct xpvmg { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ + IV xiv_iv; /* integer value or pv offset */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* linked list of magicalness */ HV* xmg_stash; /* class package */ @@ -176,7 +175,7 @@ struct xpvlv { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ + IV xiv_iv; /* integer value or pv offset */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* linked list of magicalness */ HV* xmg_stash; /* class package */ @@ -191,7 +190,7 @@ struct xpvgv { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ + IV xiv_iv; /* integer value or pv offset */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* linked list of magicalness */ HV* xmg_stash; /* class package */ @@ -206,7 +205,7 @@ struct xpvbm { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ + IV xiv_iv; /* integer value or pv offset */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* linked list of magicalness */ HV* xmg_stash; /* class package */ @@ -220,7 +219,7 @@ struct xpvfm { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ + IV xiv_iv; /* integer value or pv offset */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* linked list of magicalness */ HV* xmg_stash; /* class package */ @@ -228,12 +227,12 @@ struct xpvfm { HV * xcv_stash; OP * xcv_start; OP * xcv_root; - I32 (*xcv_usersub)(); - I32 xcv_userindex; + void (*xcv_xsub)_((CV*)); + ANY xcv_xsubany; + GV * xcv_gv; GV * xcv_filegv; long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; - bool xcv_deleted; I32 xfm_lines; }; @@ -241,7 +240,7 @@ struct xpvio { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ STRLEN xpv_len; /* allocated size */ - I32 xiv_iv; /* integer value or pv offset */ + IV xiv_iv; /* integer value or pv offset */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* linked list of magicalness */ HV* xmg_stash; /* class package */ @@ -271,13 +270,17 @@ struct xpvio { /* The following macros define implementation-independent predicates on SVs. */ #define SvNIOK(sv) (SvFLAGS(sv) & (SVf_IOK|SVf_NOK)) +#define SvNIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK| \ + SVp_IOK|SVp_NOK)) #define SvOK(sv) (SvFLAGS(sv) & SVf_OK) -#define SvOK_on(sv) (SvFLAGS(sv) |= SVf_OK) -#define SvOK_off(sv) (SvFLAGS(sv) &= \ - ~(SVf_IOK|SVf_NOK|SVf_POK|SVf_OK| \ - SVp_IOK|SVp_NOK|SVp_POK|SVf_ROK),\ - SvOOK_off(sv)) + +#ifdef OVERLOAD +#define SvOK_off(sv) (SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC), \ + SvOOK_off(sv)) +#else +#define SvOK_off(sv) (SvFLAGS(sv) &= ~SVf_OK, SvOOK_off(sv)) +#endif /* OVERLOAD */ #define SvOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) #define SvIOKp(sv) (SvFLAGS(sv) & SVp_IOK) @@ -289,30 +292,39 @@ struct xpvio { #define SvIOK(sv) (SvFLAGS(sv) & SVf_IOK) #define SvIOK_on(sv) (SvOOK_off(sv), \ - SvFLAGS(sv) |= (SVf_IOK|SVp_IOK|SVf_OK)) + SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) #define SvIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK)) #define SvIOK_only(sv) (SvOK_off(sv), \ - SvFLAGS(sv) |= (SVf_IOK|SVp_IOK|SVf_OK)) + SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) #define SvNOK(sv) (SvFLAGS(sv) & SVf_NOK) -#define SvNOK_on(sv) (SvFLAGS(sv) |= (SVf_NOK|SVp_NOK|SVf_OK)) +#define SvNOK_on(sv) (SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) #define SvNOK_off(sv) (SvFLAGS(sv) &= ~(SVf_NOK|SVp_NOK)) #define SvNOK_only(sv) (SvOK_off(sv), \ - SvFLAGS(sv) |= (SVf_NOK|SVp_NOK|SVf_OK)) + SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) #define SvPOK(sv) (SvFLAGS(sv) & SVf_POK) -#define SvPOK_on(sv) (SvFLAGS(sv) |= (SVf_POK|SVp_POK|SVf_OK)) +#define SvPOK_on(sv) (SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvPOK_off(sv) (SvFLAGS(sv) &= ~(SVf_POK|SVp_POK)) #define SvPOK_only(sv) (SvOK_off(sv), \ - SvFLAGS(sv) |= (SVf_POK|SVp_POK|SVf_OK)) + SvFLAGS(sv) |= (SVf_POK|SVp_POK)) #define SvOOK(sv) (SvFLAGS(sv) & SVf_OOK) #define SvOOK_on(sv) (SvIOK_off(sv), SvFLAGS(sv) |= SVf_OOK) #define SvOOK_off(sv) (SvOOK(sv) && sv_backoff(sv)) +#define SvFAKE(sv) (SvFLAGS(sv) & SVf_FAKE) +#define SvFAKE_on(sv) (SvFLAGS(sv) |= SVf_FAKE) +#define SvFAKE_off(sv) (SvFLAGS(sv) &= ~SVf_FAKE) + #define SvROK(sv) (SvFLAGS(sv) & SVf_ROK) -#define SvROK_on(sv) (SvFLAGS(sv) |= SVf_ROK|SVf_OK) +#define SvROK_on(sv) (SvFLAGS(sv) |= SVf_ROK) + +#ifdef OVERLOAD +#define SvROK_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVf_AMAGIC)) +#else #define SvROK_off(sv) (SvFLAGS(sv) &= ~SVf_ROK) +#endif /* OVERLOAD */ #define SvMAGICAL(sv) (SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) #define SvMAGICAL_on(sv) (SvFLAGS(sv) |= (SVs_GMG|SVs_SMG|SVs_RMG)) @@ -330,7 +342,20 @@ struct xpvio { #define SvRMAGICAL_on(sv) (SvFLAGS(sv) |= SVs_RMG) #define SvRMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_RMG) -#define SvTHINKFIRST(sv) (SvFLAGS(sv) & (SVf_ROK|SVf_READONLY)) +#ifdef OVERLOAD +#define SvAMAGIC(sv) (SvFLAGS(sv) & SVf_AMAGIC) +#define SvAMAGIC_on(sv) (SvFLAGS(sv) |= SVf_AMAGIC) +#define SvAMAGIC_off(sv) (SvFLAGS(sv) &= ~SVf_AMAGIC) + +/* +#define Gv_AMG(stash) \ + (HV_AMAGICmb(stash) && \ + ((!HV_AMAGICbad(stash) && HV_AMAGIC(stash)) || Gv_AMupdate(stash))) +*/ +#define Gv_AMG(stash) (amagic_generation && Gv_AMupdate(stash)) +#endif /* OVERLOAD */ + +#define SvTHINKFIRST(sv) (SvFLAGS(sv) & SVf_THINKFIRST) #define SvPADBUSY(sv) (SvFLAGS(sv) & SVs_PADBUSY) @@ -441,19 +466,21 @@ struct xpvio { #define IoTYPE(sv) ((XPVIO*) SvANY(sv))->xio_type #define IoFLAGS(sv) ((XPVIO*) SvANY(sv))->xio_flags -#define SvTAINT(sv) if (tainting && tainted) sv_magic(sv, 0, 't', 0, 0) +#define SvTAINT(sv) if (tainting && tainted) sv_magic(sv, Nullsv, 't', Nullch, 0) #ifdef CRIPPLED_CC -I32 SvIV(); -double SvNV(); +IV SvIV _((SV* sv)); +double SvNV _((SV* sv)); +#define SvPV_force(sv, lp) sv_pvn_force(sv, &lp) #define SvPV(sv, lp) sv_pvn(sv, &lp) -char *sv_pvn(); -I32 SvTRUE(); +char *sv_pvn _((SV *, STRLEN *)); +I32 SvTRUE _((SV *)); #define SvIVx(sv) SvIV(sv) #define SvNVx(sv) SvNV(sv) #define SvPVx(sv, lp) sv_pvn(sv, &lp) +#define SvPVx_force(sv, lp) sv_pvn_force(sv, &lp) #define SvTRUEx(sv) SvTRUE(sv) #else /* !CRIPPLED_CC */ @@ -464,6 +491,8 @@ I32 SvTRUE(); #define SvPV(sv, lp) (SvPOK(sv) ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp)) +#define SvPV_force(sv, lp) ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force(sv, &lp)) + #define SvTRUE(sv) ( \ !sv \ ? 0 \ @@ -499,11 +528,11 @@ I32 SvTRUE(); #define isGV(sv) (SvTYPE(sv) == SVt_PVGV) #ifndef DOSISH -# define SvGROW(sv,len) if (SvLEN(sv) < (len)) sv_grow(sv,len) +# define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) # define Sv_Grow sv_grow #else /* extra parentheses intentionally NOT placed around "len"! */ -# define SvGROW(sv,len) if (SvLEN(sv) < (unsigned long)len) \ - sv_grow(sv,(unsigned long)len) +# define SvGROW(sv,len) ((SvLEN(sv) < (unsigned long)len) \ + ? sv_grow(sv,(unsigned long)len) : SvPVX(sv)) # define Sv_Grow(sv,len) sv_grow(sv,(unsigned long)(len)) #endif /* DOSISH */ @@ -8,4 +8,9 @@ If you put out extra lines with a '#' character on the front, you don't have to worry about removing the extra print statements later since TEST ignores lines beginning with '#'. +Several tests assume you have sucessfully included the POSIX +extension. If you have not, lib/[nos]dbm.t will fail. Try replacing +the O_CREAT|O_RDWR with either 0x202 or 0x102 in the tie statements +and run the tests again. + If you come up with new tests, send them to lwall@netlabs.com. diff --git a/t/SDBM_File.so b/t/SDBM_File.so deleted file mode 100755 index ace796d88b..0000000000 --- a/t/SDBM_File.so +++ /dev/null @@ -1,4 +0,0 @@ -#!./perl -Dst - -$ref = [[],2,[3,4,5,]]; -print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n"; @@ -37,7 +37,7 @@ while ($test = shift) { chop($te); print "$te" . '.' x (15 - length($te)); if ($sharpbang) { - open(results,"./$test|") || (print "can't run.\n"); + open(results,"./$test |") || (print "can't run.\n"); } else { open(script,"$test") || die "Can't run $test.\n"; $_ = <script>; @@ -47,7 +47,7 @@ while ($test = shift) { } else { $switch = ''; } - open(results,"./perl$switch $test|") || (print "can't run.\n"); + open(results,"./perl$switch $test |") || (print "can't run.\n"); } $ok = 0; $next = 0; diff --git a/t/bar b/t/bar deleted file mode 100755 index 0170138188..0000000000 --- a/t/bar +++ /dev/null @@ -1,110 +0,0 @@ -#!./perl -Dxst -require "../lib/bigint.pl"; - -$test = 0; -$| = 1; -print "1..246\n"; -while (<DATA>) { - chop; - if (/^&/) { - $f = $_; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "$f('" . join("','", @args) . "');"; - if (($ans1 = eval($try)) eq $ans) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} -__END__ -&bdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+1 --1:-1:+1 -+1:-1:-1 --1:+1:-1 -+1:+2:+0 -+2:+1:+2 -+1000000000:+9:+111111111 -+2000000000:+9:+222222222 -+3000000000:+9:+333333333 -+4000000000:+9:+444444444 -+5000000000:+9:+555555555 -+6000000000:+9:+666666666 -+7000000000:+9:+777777777 -+8000000000:+9:+888888888 -+9000000000:+9:+1000000000 -+35500000:+113:+314159 -+71000000:+226:+314159 -+106500000:+339:+314159 -+1000000000:+3:+333333333 -+10:+5:+2 -+100:+4:+25 -+1000:+8:+125 -+10000:+16:+625 -+999999999999:+9:+111111111111 -+999999999999:+99:+10101010101 -+999999999999:+999:+1001001001 -+999999999999:+9999:+100010001 -+999999999999999:+99999:+10000100001 -&bmod -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+0 --1:-1:+0 -+1:-1:+0 --1:+1:+0 -+1:+2:+1 -+2:+1:+0 -+1000000000:+9:+1 -+2000000000:+9:+2 -+3000000000:+9:+3 -+4000000000:+9:+4 -+5000000000:+9:+5 -+6000000000:+9:+6 -+7000000000:+9:+7 -+8000000000:+9:+8 -+9000000000:+9:+0 -+35500000:+113:+33 -+71000000:+226:+66 -+106500000:+339:+99 -+1000000000:+3:+1 -+10:+5:+0 -+100:+4:+0 -+1000:+8:+0 -+10000:+16:+0 -+999999999999:+9:+0 -+999999999999:+99:+0 -+999999999999:+999:+0 -+999999999999:+9999:+0 -+999999999999999:+99999:+0 -&bgcd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+1 -+1:+0:+1 -+1:+1:+1 -+2:+3:+1 -+3:+2:+1 -+100:+625:+25 -+4096:+81:+1 diff --git a/t/base/lex.t b/t/base/lex.t index 1828ac62e8..f25cd2a12c 100755 --- a/t/base/lex.t +++ b/t/base/lex.t @@ -65,7 +65,7 @@ print qq/ok 14\n/; print qq(ok 15\n); print qq -ok 16\n +[ok 16\n] ; print q<ok 17 diff --git a/t/base/term.t b/t/base/term.t index 0f9a46f6c9..42cd56fe0b 100755 --- a/t/base/term.t +++ b/t/base/term.t @@ -29,7 +29,7 @@ if ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";} # check <> pseudoliteral -open(try, "/dev/null") || (die "Can't open /dev/null."); +open(try, "/dev/null") || open(try,"nla0:") || (die "Can't open /dev/null."); if (<try> eq '') { print "ok 5\n"; } @@ -38,5 +38,5 @@ else { die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null'; } -open(try, "../Makefile") || (die "Can't open ../Makefile."); +open(try, "../Configure") || (die "Can't open ../Configure."); if (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";} @@ -1 +0,0 @@ -TEST
\ No newline at end of file diff --git a/t/cmd/elsif.t b/t/cmd/elsif.t index e42fa61137..7eace161e0 100755 --- a/t/cmd/elsif.t +++ b/t/cmd/elsif.t @@ -19,7 +19,7 @@ sub foo { print "1..4\n"; -if (($x = do foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1 '$x'\n";} -if (($x = do foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2 '$x'\n";} -if (($x = do foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3 '$x'\n";} -if (($x = do foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4 '$x'\n";} +if (($x = &foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1 '$x'\n";} +if (($x = &foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2 '$x'\n";} +if (($x = &foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3 '$x'\n";} +if (($x = &foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4 '$x'\n";} diff --git a/t/cmd/while.t b/t/cmd/while.t index f42174eeca..4c8c10e990 100755 --- a/t/cmd/while.t +++ b/t/cmd/while.t @@ -4,7 +4,7 @@ print "1..10\n"; -open (tmp,'>Cmd.while.tmp') || die "Can't create Cmd.while.tmp."; +open (tmp,'>Cmd_while.tmp') || die "Can't create Cmd_while.tmp."; print tmp "tvi925\n"; print tmp "tvi920\n"; print tmp "vt100\n"; @@ -14,7 +14,7 @@ close tmp; # test "last" command -open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; while (<fh>) { last if /vt100/; } @@ -23,7 +23,7 @@ if (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1 $_\n";} # test "next" command $bad = ''; -open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; while (<fh>) { next if /vt100/; $bad = 1 if /vt100/; @@ -33,7 +33,7 @@ if (!eof || /vt100/ || $bad) {print "not ok 2\n";} else {print "ok 2\n";} # test "redo" command $bad = ''; -open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; while (<fh>) { if (s/vt100/VT100/g) { s/VT100/Vt100/g; @@ -49,7 +49,7 @@ if (!eof || $bad) {print "not ok 3\n";} else {print "ok 3\n";} # test "last" command $badcont = ''; -open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; line: while (<fh>) { if (/vt100/) {last line;} } continue { @@ -62,7 +62,7 @@ if (!$badcont) {print "ok 5\n";} else {print "not ok 5\n";} $bad = ''; $badcont = 1; -open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; entry: while (<fh>) { next entry if /vt100/; $bad = 1 if /vt100/; @@ -76,7 +76,7 @@ if (!$badcont) {print "ok 7\n";} else {print "not ok 7\n";} $bad = ''; $badcont = ''; -open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp."; loop: while (<fh>) { if (s/vt100/VT100/g) { s/VT100/Vt100/g; @@ -90,7 +90,7 @@ loop: while (<fh>) { if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";} if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";} -`/bin/rm -f Cmd.while.tmp`; +unlink 'Cmd_while.tmp' || `/bin/rm Cmd_While.tmp`; #$x = 0; #while (1) { diff --git a/t/comp/multiline.t b/t/comp/multiline.t index 1d238f95b3..634b06a7a8 100755 --- a/t/comp/multiline.t +++ b/t/comp/multiline.t @@ -35,6 +35,6 @@ if ($count == 3) {print "ok 3\n";} else {print "not ok 3\n";} $_ = `cat Comp.try`; if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";} -`/bin/rm -f Comp.try`; +unlink 'Comp.try' || `/bin/rm -f Comp.try`; if ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";} diff --git a/t/comp/package.t b/t/comp/package.t index 456c0ffa4d..ca800bb364 100755 --- a/t/comp/package.t +++ b/t/comp/package.t @@ -19,9 +19,9 @@ $ABC'dyick = 6; $xyz = 2; -$main = join(':', sort(keys %::_main)); -$XYZ = join(':', sort(keys %::_XYZ)); -$ABC = join(':', sort(keys %::_ABC)); +$main = join(':', sort(keys %main::)); +$XYZ = join(':', sort(keys %XYZ::)); +$ABC = join(':', sort(keys %ABC::)); print $XYZ eq 'ABC:XYZ:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$XYZ'\n"; print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n"; diff --git a/t/comp/script.t b/t/comp/script.t index 7dd78cdd95..f37e46bb66 100755 --- a/t/comp/script.t +++ b/t/comp/script.t @@ -5,6 +5,7 @@ print "1..3\n"; $x = `./perl -e 'print "ok\n";'`; +if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "print ""ok\n""";`; } if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";} @@ -13,11 +14,13 @@ print try 'print "ok\n";'; print try "\n"; close try; $x = `./perl Comp.script`; +if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. Comp.script`; } if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";} $x = `./perl <Comp.script`; +if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. <Comp.script`; } if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";} -`/bin/rm -f Comp.script`; +unlink 'Comp.script' || `/bin/rm -f Comp.script`; diff --git a/t/foo b/t/foo deleted file mode 100755 index 034c5c6457..0000000000 --- a/t/foo +++ /dev/null @@ -1,282 +0,0 @@ -#!./perl - -BEGIN { @INC = '../lib' } -require "bigint.pl"; - -$test = 0; -$| = 1; -print "1..246\n"; -while (<DATA>) { - chop; - if (/^&/) { - $f = $_; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "$f('" . join("','", @args) . "');"; - if (($ans1 = eval($try)) eq $ans) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} -__END__ -&bnorm -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:+0 -+0:+0 -+00:+0 -+0 0 0:+0 -000000 0000000 00000:+0 --0:+0 --0000:+0 -+1:+1 -+01:+1 -+001:+1 -+00000100000:+100000 -123456789:+123456789 --1:-1 --01:-1 --001:-1 --123456789:-123456789 --00000100000:-100000 -&bneg -abd:NaN -+0:+0 -+1:-1 --1:+1 -+123456789:-123456789 --123456789:+123456789 -&babs -abc:NaN -+0:+0 -+1:+1 --1:+1 -+123456789:+123456789 --123456789:+123456789 -&bcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -&badd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+1:+0:+1 -+0:+1:+1 -+1:+1:+2 --1:+0:-1 -+0:-1:-1 --1:-1:-2 --1:+1:+0 -+1:-1:+0 -+9:+1:+10 -+99:+1:+100 -+999:+1:+1000 -+9999:+1:+10000 -+99999:+1:+100000 -+999999:+1:+1000000 -+9999999:+1:+10000000 -+99999999:+1:+100000000 -+999999999:+1:+1000000000 -+9999999999:+1:+10000000000 -+99999999999:+1:+100000000000 -+10:-1:+9 -+100:-1:+99 -+1000:-1:+999 -+10000:-1:+9999 -+100000:-1:+99999 -+1000000:-1:+999999 -+10000000:-1:+9999999 -+100000000:-1:+99999999 -+1000000000:-1:+999999999 -+10000000000:-1:+9999999999 -+123456789:+987654321:+1111111110 --123456789:+987654321:+864197532 --123456789:-987654321:-1111111110 -+123456789:-987654321:-864197532 -&bsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+1:+0:+1 -+0:+1:-1 -+1:+1:+0 --1:+0:-1 -+0:-1:+1 --1:-1:+0 --1:+1:-2 -+1:-1:+2 -+9:+1:+8 -+99:+1:+98 -+999:+1:+998 -+9999:+1:+9998 -+99999:+1:+99998 -+999999:+1:+999998 -+9999999:+1:+9999998 -+99999999:+1:+99999998 -+999999999:+1:+999999998 -+9999999999:+1:+9999999998 -+99999999999:+1:+99999999998 -+10:-1:+11 -+100:-1:+101 -+1000:-1:+1001 -+10000:-1:+10001 -+100000:-1:+100001 -+1000000:-1:+1000001 -+10000000:-1:+10000001 -+100000000:-1:+100000001 -+1000000000:-1:+1000000001 -+10000000000:-1:+10000000001 -+123456789:+987654321:-864197532 --123456789:+987654321:-1111111110 --123456789:-987654321:+864197532 -+123456789:-987654321:+1111111110 -&bmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+0 -+1:+0:+0 -+0:-1:+0 --1:+0:+0 -+123456789123456789:+0:+0 -+0:+123456789123456789:+0 --1:-1:+1 --1:+1:-1 -+1:-1:-1 -+1:+1:+1 -+2:+3:+6 --2:+3:-6 -+2:-3:-6 --2:-3:+6 -+111:+111:+12321 -+10101:+10101:+102030201 -+1001001:+1001001:+1002003002001 -+100010001:+100010001:+10002000300020001 -+10000100001:+10000100001:+100002000030000200001 -+11111111111:+9:+99999999999 -+22222222222:+9:+199999999998 -+33333333333:+9:+299999999997 -+44444444444:+9:+399999999996 -+55555555555:+9:+499999999995 -+66666666666:+9:+599999999994 -+77777777777:+9:+699999999993 -+88888888888:+9:+799999999992 -+99999999999:+9:+899999999991 -&bdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+1 --1:-1:+1 -+1:-1:-1 --1:+1:-1 -+1:+2:+0 -+2:+1:+2 -+1000000000:+9:+111111111 -+2000000000:+9:+222222222 -+3000000000:+9:+333333333 -+4000000000:+9:+444444444 -+5000000000:+9:+555555555 -+6000000000:+9:+666666666 -+7000000000:+9:+777777777 -+8000000000:+9:+888888888 -+9000000000:+9:+1000000000 -+35500000:+113:+314159 -+71000000:+226:+314159 -+106500000:+339:+314159 -+1000000000:+3:+333333333 -+10:+5:+2 -+100:+4:+25 -+1000:+8:+125 -+10000:+16:+625 -+999999999999:+9:+111111111111 -+999999999999:+99:+10101010101 -+999999999999:+999:+1001001001 -+999999999999:+9999:+100010001 -+999999999999999:+99999:+10000100001 -&bmod -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+0 --1:-1:+0 -+1:-1:+0 --1:+1:+0 -+1:+2:+1 -+2:+1:+0 -+1000000000:+9:+1 -+2000000000:+9:+2 -+3000000000:+9:+3 -+4000000000:+9:+4 -+5000000000:+9:+5 -+6000000000:+9:+6 -+7000000000:+9:+7 -+8000000000:+9:+8 -+9000000000:+9:+0 -+35500000:+113:+33 -+71000000:+226:+66 -+106500000:+339:+99 -+1000000000:+3:+1 -+10:+5:+0 -+100:+4:+0 -+1000:+8:+0 -+10000:+16:+0 -+999999999999:+9:+0 -+999999999999:+99:+0 -+999999999999:+999:+0 -+999999999999:+9999:+0 -+999999999999999:+99999:+0 -&bgcd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+1 -+1:+0:+1 -+1:+1:+1 -+2:+3:+1 -+3:+2:+1 -+100:+625:+25 -+4096:+81:+1 diff --git a/t/foo.out b/t/foo.out deleted file mode 100644 index 422ebf8155..0000000000 --- a/t/foo.out +++ /dev/null @@ -1,36 +0,0 @@ -{ -5 TYPE = block exit ===> DONE - FLAGS = (UNKNOWN,KIDS,PARENS) - { -1 TYPE = block entry ===> 2 - } - { -2 TYPE = next statement ===> 3 - FLAGS = (SCALAR) - LINE = 1 - } - { -4 TYPE = subroutine entry ===> 5 - FLAGS = (UNKNOWN,KIDS) - { - TYPE = null operation ===> (4) - WAS = subroutine reference - FLAGS = (SCALAR,KIDS) - { -3 TYPE = glob value ===> 4 - FLAGS = (SCALAR) - GV = main::foo - } - } - } -} - -SUB ODBM_File::init = (xsub 0x7efb8 0) - -SUB SDBM_File::init = (xsub 0x80318 0) - -SUB NDBM_File::init = (xsub 0x7ddf8 0) - -EXECUTING... - -- syntax OK diff --git a/t/foo_tests b/t/foo_tests deleted file mode 100644 index ee8f80050a..0000000000 --- a/t/foo_tests +++ /dev/null @@ -1 +0,0 @@ -'((a))'i ABC y $&-$1-$2 A-A-A diff --git a/t/io/tell.t b/t/io/tell.t index af012b08cf..5badafeacb 100755 --- a/t/io/tell.t +++ b/t/io/tell.t @@ -6,7 +6,7 @@ print "1..13\n"; $TST = 'tst'; -open($TST, '../Makefile') || (die "Can't open ../Makefile"); +open($TST, '../Configure') || (die "Can't open ../Configure"); if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; } diff --git a/atarist/test/gdbm.t b/t/lib/anydbm.t index 8e4a3a13b1..11ac103a64 100644..100755 --- a/atarist/test/gdbm.t +++ b/t/lib/anydbm.t @@ -1,17 +1,30 @@ #!./perl -# -# based on t/op/dbm.t modified for gdbm and atariST stat() semantics -# +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} +require AnyDBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + print "1..12\n"; -unlink <Op.dbm>; +unlink <Op.dbmx*>; + umask(0); -print (dbmopen(h,'Op.dbm',0640) ? "ok 1\n" : "not ok 1\n"); +print (tie(%h,AnyDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); + +$Dfile = "Op.dbmx.pag"; +if (! -e $Dfile) { + ($Dfile) = <Op.dbmx*>; +} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('Op.dbm'); -print (($mode & 0770) == 0640 ? "ok 2\n" : "not ok 2\n"); -while (($key,$value) = each(h)) { + $blksize,$blocks) = stat($Dfile); +print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +while (($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -35,8 +48,8 @@ $h{'i'} = 'I'; $h{'goner2'} = 'snork'; delete $h{'goner2'}; -dbmclose(h); -print (dbmopen(h,'Op.dbm',0640) ? "ok 4\n" : "not ok 4\n"); +untie(%h); +print (tie(%h,AnyDBM_File,'Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -88,7 +101,7 @@ for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('Op.dbm'); + $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; @@ -98,4 +111,4 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); -unlink 'Op.dbm'; +unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t new file mode 100755 index 0000000000..308b8f489a --- /dev/null +++ b/t/lib/db-btree.t @@ -0,0 +1,351 @@ +#!./perl + +BEGIN { + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDB_File\b/) { + print "1..0\n"; + exit 0; + } +} + +use DB_File; +use Fcntl; + +print "1..73\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") ; +print (($dbh->{lorder} == undef) ? "ok 4\n" : "not ok 4\n") ; +print (($dbh->{minkeypage} == undef) ? "ok 5\n" : "not ok 5\n") ; +print (($dbh->{maxkeypage} == undef) ? "ok 6\n" : "not ok 6\n") ; +print (($dbh->{compare} == undef) ? "ok 7\n" : "not ok 7\n") ; +print (($dbh->{prefix} == undef) ? "ok 8\n" : "not ok 8\n") ; + +$dbh->{flags} = 3000 ; +print ($dbh->{flags} == 3000 ? "ok 9\n" : "not ok 9\n") ; + +$dbh->{cachesize} = 9000 ; +print ($dbh->{cachesize} == 9000 ? "ok 10\n" : "not ok 10\n") ; +# +$dbh->{psize} = 400 ; +print (($dbh->{psize} == 400) ? "ok 11\n" : "not ok 11\n") ; + +$dbh->{lorder} = 65 ; +print (($dbh->{lorder} == 65) ? "ok 12\n" : "not ok 12\n") ; + +$dbh->{minkeypage} = 123 ; +print (($dbh->{minkeypage} == 123) ? "ok 13\n" : "not ok 13\n") ; + +$dbh->{maxkeypage} = 1234 ; +print ($dbh->{maxkeypage} == 1234 ? "ok 14\n" : "not ok 14\n") ; + +$dbh->{compare} = 1234 ; +print ($dbh->{compare} == 1234 ? "ok 15\n" : "not ok 15\n") ; + +$dbh->{prefix} = 1234 ; +print ($dbh->{prefix} == 1234 ? "ok 16\n" : "not ok 16\n") ; + +# 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 + +print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print (($mode & 0777) == 0640 ? "ok 20\n" : "not ok 20\n"); + +while (($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 21\n" : "not ok 21\n"); + +$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'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + + +# tie to the same file again +print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE)) ? "ok 24\n" : "not ok 24\n"); + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +@keys = keys(%h); +@values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 25\n";} else {print "not ok 25\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; + } +} + +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 +$ok = 1 ; +foreach (keys %h) +{ + ($ok = 0), last if defined $previous && $previous gt $_ ; + $previous = $_ ; +} +print ($ok ? "ok 28\n" : "not ok 28\n") ; + +$h{'foo'} = ''; +print ($h{'foo'} eq '' ? "ok 29\n" : "not ok 29\n") ; + +$h{''} = 'bar'; +print ($h{''} eq 'bar' ? "ok 30\n" : "not ok 30\n") ; + +# check cache overflow and numeric keys and contents +$ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 31\n" : "not ok 31\n"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 32\n" : "not ok 32\n"); + +@h{0..200} = 200..400; +@foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n"; + +# Now check all the non-tie specific stuff + + +# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite +# an existing record. + +$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +print ($status == 1 ? "ok 34\n" : "not ok 34\n") ; + +# check that the value of the key 'x' has not been changed by the +# previous test +print ($h{'x'} eq 'X' ? "ok 35\n" : "not ok 35\n") ; + +# standard put +$status = $X->put('key', 'value') ; +print ($status == 0 ? "ok 36\n" : "not ok 36\n") ; + +#check that previous put can be retrieved +$status = $X->get('key', $value) ; +print ($status == 0 ? "ok 37\n" : "not ok 37\n") ; +print ($value eq 'value' ? "ok 38\n" : "not ok 38\n") ; + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +print ($status == 0 ? "ok 39\n" : "not ok 39\n") ; +$status = $X->del('') ; +print ($status == 0 ? "ok 40\n" : "not ok 40\n") ; + +# Make sure that the key deleted, cannot be retrieved +print (($h{'q'} eq undef) ? "ok 41\n" : "not ok 41\n") ; +print (($h{''} eq undef) ? "ok 42\n" : "not ok 42\n") ; + +undef $X ; +untie %h ; + +print (($X = tie(%h, DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE )) ? "ok 43\n" : "not ok 43"); + +# Attempting to delete a non-existant key should fail + +$status = $X->del('joe') ; +print ($status == 1 ? "ok 44\n" : "not ok 44\n") ; + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +print ($status == 1 ? "ok 45\n" : "not ok 45\n") ; + +# Next an existing key +$status = $X->get('a', $value) ; +print ($status == 0 ? "ok 46\n" : "not ok 46\n") ; +print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ; + +# seq +# ### + +# use seq to find an approximate match +$key = 'ke' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +print ($status == 0 ? "ok 48\n" : "not ok 48\n") ; +print ($key eq 'key' ? "ok 49\n" : "not ok 49\n") ; +print ($value eq 'value' ? "ok 50\n" : "not ok 50\n") ; + +# seq when the key does not match +$key = 'zzz' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +print ($status == 1 ? "ok 51\n" : "not ok 51\n") ; + + +# use seq to set the cursor, then delete the record @ the cursor. + +$key = 'x' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +print ($status == 0 ? "ok 52\n" : "not ok 52\n") ; +print ($key eq 'x' ? "ok 53\n" : "not ok 53\n") ; +print ($value eq 'X' ? "ok 54\n" : "not ok 54\n") ; +$status = $X->del(0, R_CURSOR) ; +print ($status == 0 ? "ok 55\n" : "not ok 55\n") ; +$status = $X->get('x', $value) ; +print ($status == 1 ? "ok 56\n" : "not ok 56\n") ; + +# ditto, but use put to replace the key/value pair. +$key = 'y' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +print ($status == 0 ? "ok 57\n" : "not ok 57\n") ; +print ($key eq 'y' ? "ok 58\n" : "not ok 58\n") ; +print ($value eq 'Y' ? "ok 59\n" : "not ok 59\n") ; + +$key = "replace key" ; +$value = "replace value" ; +$status = $X->put($key, $value, R_CURSOR) ; +print ($status == 0 ? "ok 60\n" : "not ok 60\n") ; +print ($key eq 'replace key' ? "ok 61\n" : "not ok 61\n") ; +print ($value eq 'replace value' ? "ok 62\n" : "not ok 62\n") ; +$status = $X->get('y', $value) ; +print ($status == 1 ? "ok 63\n" : "not ok 63\n") ; + +# use seq to walk forwards through a file + +$status = $X->seq($key, $value, R_FIRST) ; +print ($status == 0 ? "ok 64\n" : "not ok 64\n") ; +$previous = $key ; + +$ok = 1 ; +while (($status = $X->seq($key, $value, R_NEXT)) == 0) +{ + ($ok = 0), last if ($previous cmp $key) == 1 ; +} + +print ($status == 1 ? "ok 65\n" : "not ok 65\n") ; +print ($ok == 1 ? "ok 66\n" : "not ok 66\n") ; + +# use seq to walk backwards through a file +$status = $X->seq($key, $value, R_LAST) ; +print ($status == 0 ? "ok 67\n" : "not ok 67\n") ; +$previous = $key ; + +$ok = 1 ; +while (($status = $X->seq($key, $value, R_PREV)) == 0) +{ + ($ok = 0), last if ($previous cmp $key) == -1 ; + #print "key = [$key] value = [$value]\n" ; +} + +print ($status == 1 ? "ok 68\n" : "not ok 68\n") ; +print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ; + + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +print ($status == 0 ? "ok 70\n" : "not ok 70\n") ; + + +# fd +# ## + +$status = $X->fd ; +print ($status != 0 ? "ok 71\n" : "not ok 71\n") ; + + +undef $X ; +untie %h ; + +unlink $Dfile; + +# Now try an in memory file +print (($Y = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 72\n" : "not ok 72"); + +# fd with an in memory file should return failure +$status = $Y->fd ; +print ($status == -1 ? "ok 73\n" : "not ok 73\n") ; + +undef $Y ; +untie %h ; + +exit ; diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t new file mode 100755 index 0000000000..6c3ef55200 --- /dev/null +++ b/t/lib/db-hash.t @@ -0,0 +1,253 @@ +#!./perl + +BEGIN { + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDB_File\b/) { + print "1..0\n"; + exit 0; + } +} + +use DB_File; +use Fcntl; + +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") ; +print (($dbh->{cachesize} == undef) ? "ok 4\n" : "not ok 4\n") ; +print (($dbh->{hash} == undef) ? "ok 5\n" : "not ok 5\n") ; +print (($dbh->{lorder} == undef) ? "ok 6\n" : "not ok 6\n") ; + +$dbh->{bsize} = 3000 ; +print ($dbh->{bsize} == 3000 ? "ok 7\n" : "not ok 7\n") ; + +$dbh->{ffactor} = 9000 ; +print ($dbh->{ffactor} == 9000 ? "ok 8\n" : "not ok 8\n") ; +# +$dbh->{nelem} = 400 ; +print (($dbh->{nelem} == 400) ? "ok 9\n" : "not ok 9\n") ; + +$dbh->{cachesize} = 65 ; +print (($dbh->{cachesize} == 65) ? "ok 10\n" : "not ok 10\n") ; + +$dbh->{hash} = "abc" ; +print (($dbh->{hash} eq "abc") ? "ok 11\n" : "not ok 11\n") ; + +$dbh->{lorder} = 1234 ; +print ($dbh->{lorder} == 1234 ? "ok 12\n" : "not ok 12\n") ; + +# 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 + +print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH )) ? "ok 15\n" : "not ok 15"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print (($mode & 0777) == 0640 ? "ok 16\n" : "not ok 16\n"); + +while (($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 17\n" : "not ok 17\n"); + +$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'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + + +# tie to the same file again, do not supply a type - should default to HASH +print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640)) ? "ok 20\n" : "not ok 20: $!\n"); + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +@keys = keys(%h); +@values = values(%h); + +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; + } +} + +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'} = ''; +print ($h{'foo'} eq '' ? "ok 24\n" : "not ok 24\n") ; + +$h{''} = 'bar'; +print ($h{''} eq 'bar' ? "ok 25\n" : "not ok 25\n") ; + +# check cache overflow and numeric keys and contents +$ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 26\n" : "not ok 26\n"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 27\n" : "not ok 27\n"); + +@h{0..200} = 200..400; +@foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 28\n" : "not ok 28\n"; + + +# Now check all the non-tie specific stuff + +# Check NOOVERWRITE will make put fail when attempting to overwrite +# an existing record. + +$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +print ($status == 1 ? "ok 29\n" : "not ok 29\n") ; + +# check that the value of the key 'x' has not been changed by the +# previous test +print ($h{'x'} eq 'X' ? "ok 30\n" : "not ok 30\n") ; + +# standard put +$status = $X->put('key', 'value') ; +print ($status == 0 ? "ok 31\n" : "not ok 31\n") ; + +#check that previous put can be retrieved +$status = $X->get('key', $value) ; +print ($status == 0 ? "ok 32\n" : "not ok 32\n") ; +print ($value eq 'value' ? "ok 33\n" : "not ok 33\n") ; + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +print ($status == 0 ? "ok 34\n" : "not ok 34\n") ; + +# Make sure that the key deleted, cannot be retrieved +print (($h{'q'} eq undef) ? "ok 35\n" : "not ok 35\n") ; + +# Attempting to delete a non-existant key should fail + +$status = $X->del('joe') ; +print ($status == 1 ? "ok 36\n" : "not ok 36\n") ; + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +print ($status == 1 ? "ok 37\n" : "not ok 37\n") ; + +# Next an existing key +$status = $X->get('a', $value) ; +print ($status == 0 ? "ok 38\n" : "not ok 38\n") ; +print ($value eq 'A' ? "ok 39\n" : "not ok 39\n") ; + +# seq +# ### + +# ditto, but use put to replace the key/value pair. + +# use seq to walk backwards through a file - check that this reversed is + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +print ($status == 0 ? "ok 40\n" : "not ok 40\n") ; + + +# fd +# ## + +$status = $X->fd ; +print ($status != 0 ? "ok 41\n" : "not ok 41\n") ; + +undef $X ; +untie %h ; + +unlink $Dfile; + +# Now try an in memory file +print (($X = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_HASH )) ? "ok 42\n" : "not ok 42"); + +# fd with an in memory file should return fail +$status = $X->fd ; +print ($status == -1 ? "ok 43\n" : "not ok 43\n") ; + +untie %h ; +undef $X ; + +exit ; diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t new file mode 100755 index 0000000000..64ad7b8a9e --- /dev/null +++ b/t/lib/db-recno.t @@ -0,0 +1,142 @@ +#!./perl + +BEGIN { + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDB_File\b/) { + print "1..0\n"; + exit 0; + } +} + +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") ; + +$dbh->{cachesize} = 9000 ; +print ($dbh->{cachesize} == 9000 ? "ok 9\n" : "not ok 9\n") ; + +$dbh->{psize} = 400 ; +print (($dbh->{psize} == 400) ? "ok 10\n" : "not ok 10\n") ; + +$dbh->{flags} = 65 ; +print (($dbh->{flags} == 65) ? "ok 11\n" : "not ok 11\n") ; + +$dbh->{lorder} = 123 ; +print (($dbh->{lorder} == 123) ? "ok 12\n" : "not ok 12\n") ; + +$dbh->{reclen} = 1234 ; +print ($dbh->{reclen} == 1234 ? "ok 13\n" : "not ok 13\n") ; + +$dbh->{bfname} = 1234 ; +print ($dbh->{bfname} == 1234 ? "ok 14\n" : "not ok 14\n") ; + + +# 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] = $_ } + +unshift (@data, 'a') ; + +print (defined $h[1] ? "ok 21\n" : "not ok 21\n"); +print (! defined $h[16] ? "ok 22\n" : "not ok 22\n"); +print ($X->length == @data ? "ok 23\n" : "not ok 23\n") ; + + +# Overwrite an entry & check fetch it +$h[3] = 'replaced' ; +$data[3] = 'replaced' ; +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) ; +print ($h[++$i] eq 'added' ? "ok 25\n" : "not ok 25\n"); + +# POP +pop (@data) ; +#$value = pop(@h) ; +$value = $X->pop ; +print ($value eq 'end' ? "not ok 26\n" : "ok 26\n"); + +# SHIFT +#$value = shift @h +$value = $X->shift ; +print ($value eq shift @data ? "not ok 27\n" : "ok 27\n"); + +# UNSHIFT + +# empty list +$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) ; +print ($X->length == @data ? "ok 29\n" : "not ok 29\n") ; + +# SPLICE + +# 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. +undef $X ; +untie(@h); + +unlink $Dfile; + +exit ; diff --git a/t/lib/english.t b/t/lib/english.t index 5c76407357..d7a30f9305 100755 --- a/t/lib/english.t +++ b/t/lib/english.t @@ -3,7 +3,7 @@ print "1..16\n"; BEGIN { @INC = '../lib' } -require English; import English; +use English; print $PID == $$ ? "ok 1\n" : "not ok 1\n"; @@ -29,7 +29,7 @@ $LIST_SEPARATOR = "\n"; print "@foo"; undef $OUTPUT_RECORD_SEPARATOR; -eval 'no such function'; +eval 'NO SUCH FUNCTION'; print "ok 10\n" if $EVAL_ERROR =~ /method/; print $UID == $< ? "ok 11\n" : "not ok 11\n"; diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t new file mode 100755 index 0000000000..0d2c1fe023 --- /dev/null +++ b/t/lib/gdbm.t @@ -0,0 +1,117 @@ +#!./perl + +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bGDBM_File\b/) { + print "1..0\n"; + exit 0; + } +} + +use GDBM_File; + +print "1..12\n"; + +unlink <Op.dbmx*>; + +umask(0); +print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); + +$Dfile = "Op.dbmx.pag"; +if (! -e $Dfile) { + ($Dfile) = <Op.dbmx*>; +} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +while (($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 3\n" : "not ok 3\n"); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; +$h{'b'} = 'B'; +$h{'c'} = 'C'; +$h{'d'} = 'D'; +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'G'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + +untie(%h); +print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +delete $h{'goner3'}; + +@keys = keys(%h); +@values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} + +while (($key,$value) = each(h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} + +@keys = ('blurfl', keys(h), 'dyick'); +if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} + +$h{'foo'} = ''; +$h{''} = 'bar'; + +# check cache overflow and numeric keys and contents +$ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 8\n" : "not ok 8\n"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + +@h{0..200} = 200..400; +@foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; + +print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + +unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t index c69e2f8739..e3093dbcfb 100755 --- a/t/lib/ndbm.t +++ b/t/lib/ndbm.t @@ -3,6 +3,7 @@ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ BEGIN { + chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bNDBM_File\b/) { @@ -12,13 +13,15 @@ BEGIN { } require NDBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; print "1..12\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,NDBM_File,'Op.dbmx', 0x202, 0640) ? "ok 1\n" : "not ok 1\n"); +print (tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { @@ -52,7 +55,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,NDBM_File,'Op.dbmx', 0x2, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,NDBM_File,'Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; diff --git a/t/lib/odbm.t b/t/lib/odbm.t new file mode 100755 index 0000000000..b49aa91043 --- /dev/null +++ b/t/lib/odbm.t @@ -0,0 +1,120 @@ +#!./perl + +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bODBM_File\b/) { + print "1..0\n"; + exit 0; + } +} + +require ODBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + +print "1..12\n"; + +unlink <Op.dbmx*>; + +umask(0); +print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); + +$Dfile = "Op.dbmx.pag"; +if (! -e $Dfile) { + ($Dfile) = <Op.dbmx*>; +} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +while (($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 3\n" : "not ok 3\n"); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; +$h{'b'} = 'B'; +$h{'c'} = 'C'; +$h{'d'} = 'D'; +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'G'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + +untie(%h); +print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +delete $h{'goner3'}; + +@keys = keys(%h); +@values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} + +while (($key,$value) = each(h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} + +@keys = ('blurfl', keys(h), 'dyick'); +if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} + +$h{'foo'} = ''; +$h{''} = 'bar'; + +# check cache overflow and numeric keys and contents +$ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 8\n" : "not ok 8\n"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + +@h{0..200} = 200..400; +@foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; + +print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + +unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/posix.t b/t/lib/posix.t new file mode 100755 index 0000000000..bde6e0bbac --- /dev/null +++ b/t/lib/posix.t @@ -0,0 +1,74 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bPOSIX\b/) { + print STDERR "1..0\n"; + exit 0; + } +} +use FileHandle; +use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read write); +use strict subs; + +$mystdout = new_from_fd FileHandle 1,"w"; +autoflush STDOUT; +autoflush $mystdout; +print "1..16\n"; + +print $mystdout "ok ",fileno($mystdout),"\n"; +write(1,"ok 2\nnot ok 2\n", 5); + +$testfd = open("TEST", O_RDONLY, 0) and print "ok 3\n"; +read($testfd, $buffer, 9) if $testfd > 2; +print $buffer eq "#!./perl\n" ? "ok 4\n" : "not ok 4\n"; + +@fds = POSIX::pipe(); +print $fds[0] == $testfd + 1 ? "ok 5\n" : "not ok 5\n"; +$writer = FileHandle->new_from_fd($fds[1], "w"); +$reader = FileHandle->new_from_fd($fds[0], "r"); +print $writer "ok 6\n"; +close $writer; +print <$reader>; +close $reader; + +$sigset = new POSIX::SigSet 1,3; +delset $sigset 1; +if (!ismember $sigset 1) { print "ok 7\n" } +if (ismember $sigset 3) { print "ok 8\n" } +$mask = new POSIX::SigSet &SIGINT; +$action = new POSIX::SigAction 'main::SigHUP', $mask, 0; +sigaction(&SIGHUP, $action); +$SIG{'INT'} = 'SigINT'; +kill 'HUP', $$; +sleep 1; +print "ok 12\n"; + +sub SigHUP { + print "ok 9\n"; + kill 'INT', $$; + sleep 2; + print "ok 10\n"; +} + +sub SigINT { + print "ok 11\n"; +} + +print &_POSIX_OPEN_MAX > $fds[1] ? "ok 13\n" : "not ok 13\n"; + +print getcwd() =~ m#/t$# ? "ok 14\n" : "not ok 14\n"; + +# Pick up whether we're really able to dynamically load everything. +print &POSIX::acos(1.0) == 0.0 ? "ok 15\n" : "not ok 15\n"; + +ungetc STDIN 65; +CORE::read(STDIN, $buf,1); +print $buf eq 'A' ? "ok 16\n" : "not ok 16\n"; + +flush STDOUT; +autoflush STDOUT 0; +print '@#!*$@(!@#$'; +_exit(0); diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t index 1304be29b2..a754bb72a4 100755 --- a/t/lib/sdbm.t +++ b/t/lib/sdbm.t @@ -3,21 +3,24 @@ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ BEGIN { + chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bSDBM_File\b/) { - print STDERR "1..0\n"; + print "1..0\n"; exit 0; } } require SDBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; print "1..12\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,SDBM_File,'Op.dbmx', 0x202, 0640) ? "ok 1\n" : "not ok 1\n"); +print (tie(%h,SDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { @@ -51,7 +54,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,SDBM_File,'Op.dbmx', 0x2, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,SDBM_File,'Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; diff --git a/t/lib/soundex.t b/t/lib/soundex.t new file mode 100755 index 0000000000..d35f264c7a --- /dev/null +++ b/t/lib/soundex.t @@ -0,0 +1,143 @@ +#!./perl +# +# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $ +# +# test module for soundex.pl +# +# $Log: soundex.t,v $ +# Revision 1.2 1994/03/24 00:30:27 mike +# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> +# in the way I handles leasing characters which were different but had +# the same soundex code. This showed up comparing it with Oracle's +# soundex output. +# +# Revision 1.1 1994/03/02 13:03:02 mike +# Initial revision +# +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Text::Soundex; + +$test = 0; +print "1..13\n"; + +while (<DATA>) +{ + chop; + next if /^\s*;?#/; + next if /^\s*$/; + + ++$test; + $bad = 0; + + if (/^eval\s+/) + { + ($try = $_) =~ s/^eval\s+//; + + eval ($try); + if ($@) + { + $bad++; + print "not ok $test\n"; + print "# eval '$try' returned $@"; + } + } + elsif (/^\(/) + { + ($in, $out) = split (':'); + + $try = "\@expect = $out; \@got = &soundex $in;"; + eval ($try); + + if (@expect != @got) + { + $bad++; + print "not ok $test\n"; + print "# expected ", scalar @expect, " results, got ", scalar @got, "\n"; + print "# expected (", join (', ', @expect), + ") got (", join (', ', @got), ")\n"; + } + else + { + while (@got) + { + $expect = shift @expect; + $got = shift @got; + + if ($expect ne $got) + { + $bad++; + print "not ok $test\n"; + print "# expected $expect, got $got\n"; + } + } + } + } + else + { + ($in, $out) = split (':'); + + $try = "\$expect = $out; \$got = &soundex ($in);"; + eval ($try); + + if ($expect ne $got) + { + $bad++; + print "not ok $test\n"; + print "# expected $expect, got $got\n"; + } + } + + print "ok $test\n" unless $bad; +} + +__END__ +# +# 1..6 +# +# Knuth's test cases, scalar in, scalar out +# +'Euler':'E460' +'Gauss':'G200' +'Hilbert':'H416' +'Knuth':'K530' +'Lloyd':'L300' +'Lukasiewicz':'L222' +# +# 7..8 +# +# check default bad code +# +'2 + 2 = 4':undef +undef:undef +# +# 9 +# +# check array in, array out +# +('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222') +# +# 10 +# +# check array with explicit undef +# +('Mike', undef, 'Stok'):('M200', undef, 'S320') +# +# 11..12 +# +# check setting $Text::Soundex::noCode +# +eval $soundex_nocode = 'Z000'; +('Mike', undef, 'Stok'):('M200', 'Z000', 'S320') +# +# 13 +# +# a subtle difference between me & oracle, spotted by Rich Pinder +# <rpinder@hsc.usc.edu> +# +CZARKOWSKA:C622 diff --git a/t/make.out b/t/make.out deleted file mode 100644 index bc43d67974..0000000000 --- a/t/make.out +++ /dev/null @@ -1 +0,0 @@ -forceme 'cd ..; make' diff --git a/t/makefile b/t/makefile deleted file mode 100644 index 5ef5395865..0000000000 --- a/t/makefile +++ /dev/null @@ -1,7 +0,0 @@ -all: - forceme 'cd ..; $(MAKE)' - -perl: fooperl - -fooperl: - forceme 'cd ..; $(MAKE) perl' diff --git a/t/op/array.t b/t/op/array.t index 089fb5528e..ed471b4c4d 100755 --- a/t/op/array.t +++ b/t/op/array.t @@ -23,9 +23,9 @@ if (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";} if ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";} -$#ary += 1; # see if we can recover element 5 +$#ary += 1; # see if element 5 gone for good if ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";} -if ($ary[5] == 5) {print "ok 11\n";} else {print "not ok 11\n";} +if (defined $ary[5]) {print "not ok 11\n";} else {print "ok 11\n";} $[ = 0; @foo = (); diff --git a/t/op/chop.t b/t/op/chop.t index d20b546465..3516c2d18c 100755 --- a/t/op/chop.t +++ b/t/op/chop.t @@ -2,7 +2,7 @@ # $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $ -print "1..4\n"; +print "1..22\n"; # optimized @@ -28,3 +28,45 @@ print join('',@bar) eq 'hi there!' ? "ok 3\n" : "not ok 3\n"; $foo = "\n"; chop($foo,@foo); print join('',$foo,@foo) eq 'hi there!' ? "ok 4\n" : "not ok 4\n"; + +$_ = "foo\n\n"; +print chomp() == 1 ? "ok 5\n" : "not ok 5\n"; +print $_ eq "foo\n" ? "ok 6\n" : "not ok 6\n"; + +$_ = "foo\n"; +print chomp() == 1 ? "ok 7\n" : "not ok 7\n"; +print $_ eq "foo" ? "ok 8\n" : "not ok 8\n"; + +$_ = "foo"; +print chomp() == 0 ? "ok 9\n" : "not ok 9\n"; +print $_ eq "foo" ? "ok 10\n" : "not ok 10\n"; + +$_ = "foo"; +$/ = "oo"; +print chomp() == 2 ? "ok 11\n" : "not ok 11\n"; +print $_ eq "f" ? "ok 12\n" : "not ok 12\n"; + +$_ = "bar"; +$/ = "oo"; +print chomp() == 0 ? "ok 13\n" : "not ok 13\n"; +print $_ eq "bar" ? "ok 14\n" : "not ok 14\n"; + +$_ = "f\n\n\n\n\n"; +$/ = ""; +print chomp() == 5 ? "ok 15\n" : "not ok 15\n"; +print $_ eq "f" ? "ok 16\n" : "not ok 16\n"; + +$_ = "f\n\n"; +$/ = ""; +print chomp() == 2 ? "ok 17\n" : "not ok 17\n"; +print $_ eq "f" ? "ok 18\n" : "not ok 18\n"; + +$_ = "f\n"; +$/ = ""; +print chomp() == 1 ? "ok 19\n" : "not ok 19\n"; +print $_ eq "f" ? "ok 20\n" : "not ok 20\n"; + +$_ = "f"; +$/ = ""; +print chomp() == 0 ? "ok 21\n" : "not ok 21\n"; +print $_ eq "f" ? "ok 22\n" : "not ok 22\n"; diff --git a/t/op/delete.t b/t/op/delete.t index 86ed9b47ba..010cbf1003 100755 --- a/t/op/delete.t +++ b/t/op/delete.t @@ -2,7 +2,7 @@ # $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $ -print "1..6\n"; +print "1..7\n"; $foo{1} = 'a'; $foo{2} = 'b'; @@ -27,3 +27,11 @@ $foo{'bar'} = 'y'; $foo = join('',values(foo)); if ($foo eq 'xy' || $foo eq 'yx') {print "ok 6\n";} else {print "not ok 6\n";} + +$refhash{"top"}->{"foo"} = "FOO"; +$refhash{"top"}->{"bar"} = "BAR"; + +delete $refhash{"top"}->{"bar"}; +@list = keys %{$refhash{"top"}}; + +print "@list" eq "foo" ? "ok 7\n" : "not ok 7 @list\n"; diff --git a/t/op/flip.t b/t/op/flip.t index 72425da3a2..475f55a8c8 100755 --- a/t/op/flip.t +++ b/t/op/flip.t @@ -17,9 +17,9 @@ if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";} @a = ('a','b','c','d','e','f','g'); -open(of,'../Makefile'); +open(of,'../Configure'); while (<of>) { - (3 .. 5) && $foo .= $_; + (3 .. 5) && ($foo .= $_); } $x = ($foo =~ y/\n/\n/); diff --git a/t/op/goto.t b/t/op/goto.t index 21a35c1de3..087331907e 100755 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -32,6 +32,8 @@ print "#2\t:$foo: == 4\n"; if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} $x = `./perl -e 'goto foo;' 2>&1`; +if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "goto foo;"`; } + if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} sub foo { diff --git a/t/op/magic.t b/t/op/magic.t index 3243c625ce..b43f71c809 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -12,7 +12,7 @@ if (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";} unlink 'ajslkdfpqjsjfk'; $! = 0; open(foo,'ajslkdfpqjsjfk'); -if ($! == 2) {print "ok 2\n";} else {print "not ok 2\n";} +if ($!) {print "ok 2\n";} else {print "not ok 2\n";} # the next tests are embedded inside system simply because sh spits out # a newline onto stderr when a child process kills itself with SIGINT. diff --git a/t/op/misc.t b/t/op/misc.t new file mode 100755 index 0000000000..decba2d609 --- /dev/null +++ b/t/op/misc.t @@ -0,0 +1,174 @@ +#!./perl + +chdir 't' if -d 't'; +@INC = "../lib"; +$ENV{PERL5LIB} = "../lib"; + +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "misctmp000"; +1 while -f ++$tmpfile; +END { unlink $tmpfile if $tmpfile; } + +for (@prgs){ + my $switch; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; + print TEST $prog, "\n"; + close TEST; + $status = $?; + $results = `cat $tmpfile`; + $results =~ s/\n+$//; + $expected =~ s/\n+$//; + if ( $results ne $expected){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +__END__ +$foo=undef; $foo->go; +EXPECT +Can't call method "go" without a package or object reference at - line 1. +######## +BEGIN + { + "foo"; + } +######## +-P +use POSIX; +######## +$array[128]=1 +######## +$x=0x0eabcd; print $x->ref; +EXPECT +Can't call method "ref" without a package or object reference at - line 1. +######## +chop ($str .= <STDIN>); +######## +close ($banana); +######## +$x=2;$y=3;$x<$y ? $x : $y += 23;print $x; +EXPECT +25 +######## +eval {sub bar {print "In bar";}} +######## +system "./perl -ne 'print if eof' /dev/null" +######## +chop($file = <>); +######## +package N; +sub new {my ($obj,$n)=@_; bless \$n} +$aa=new N 1; +$aa=12345; +print $aa; +EXPECT +12345 +######## +%@x=0; +EXPECT +Can't coerce HASH to string in repeat at - line 1. +######## +$_="foo"; +printf(STDOUT "%s\n", $_); +EXPECT +foo +######## +push(@a, 1, 2, 3,) +######## +quotemeta "" +######## +for ("ABCDE") { + ⊂ +s/./&sub($&)/eg; +print;} +sub sub {local($_) = @_; +$_ x 4;} +EXPECT +Modification of a read-only value attempted at - line 3. +######## +package FOO;sub new {bless {FOO => BAR}}; +package main; +use strict vars; +my $self = new FOO; +print $$self{FOO}; +EXPECT +BAR +######## +$_="foo"; +s/.{1}//s; +print; +EXPECT +oo +######## +print scalar ("foo","bar") +EXPECT +bar +######## +sub by_number { $a <=> $b; };# inline function for sort below +$as_ary{0}="a0"; +@ordered_array=sort by_number keys(%as_ary); +######## +sub NewShell +{ + local($Host) = @_; + my($m2) = $#Shells++; + $Shells[$m2]{HOST} = $Host; + return $m2; +} + +sub ShowShell +{ + local($i) = @_; +} + +&ShowShell(&NewShell(beach,Work,"+0+0")); +&ShowShell(&NewShell(beach,Work,"+0+0")); +&ShowShell(&NewShell(beach,Work,"+0+0")); +######## + { + package FAKEARRAY; + + sub TIEARRAY + { print "TIEARRAY @_\n"; + die "bomb out\n" unless $count ++ ; + bless ['foo'] + } + sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] } + sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] } + sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; } + } + +eval 'tie @h, FAKEARRAY, fred' ; +tie @h, FAKEARRAY, fred ; +EXPECT +TIEARRAY FAKEARRAY fred +TIEARRAY FAKEARRAY fred +DESTROY +######## +BEGIN { die "phooey\n" } +EXPECT +phooey +BEGIN failed--compilation aborted at - line 1. +######## +BEGIN { 1/$zero } +EXPECT +Illegal division by zero at - line 1. +BEGIN failed--compilation aborted at - line 1. +######## +BEGIN { undef = 0 } +EXPECT +Modification of a read-only value attempted at - line 1. +BEGIN failed--compilation aborted at - line 1. diff --git a/t/op/pat.t b/t/op/pat.t index a669526177..d93e6d66e2 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -2,7 +2,7 @@ # $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $ -print "1..51\n"; +print "1..60\n"; $x = "abc\ndef\n"; @@ -73,7 +73,7 @@ while ($_ = shift(XXX)) { /not ok 26/ && reset 'X'; } -while (($key,$val) = each(XXX)) { +while (($key,$val) = each(%XXX)) { print "not ok 27\n"; exit; } @@ -182,3 +182,25 @@ print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n"; eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; print $@ eq "" ? "ok 50\n" : "not ok 50\n"; print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n"; + + +$_="abcfooabcbar"; +$x=/abc/g; +print $` eq "" ? "ok 52\n" : "not ok 52\n" if $x; +$x=/abc/g; +print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x; +$x=/abc/g; +print $x == 0 ? "ok 54\n" : "not ok 54\n"; +$x=/ABC/gi; +print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x; +$x=/ABC/gi; +print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x; +$x=/ABC/gi; +print $x == 0 ? "ok 57\n" : "not ok 57\n"; +$x=/abc/g; +print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x; +$x=/abc/g; +print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x; +$_ .= ''; +@x=/abc/g; +print scalar @x == 2 ? "ok 60\n" : "not ok 60\n"; diff --git a/t/op/quotemeta.t b/t/op/quotemeta.t new file mode 100755 index 0000000000..09794571b1 --- /dev/null +++ b/t/op/quotemeta.t @@ -0,0 +1,26 @@ +#!./perl +print "1..15\n"; + +$_=join "", grep $_=chr($_), 32..127; + +#95 characters - 52 letters - 10 digits = 33 backslashes +#95 characters + 33 backslashes = 128 characters +$_=quotemeta $_; +if ( length == 128 ){print "ok 1\n"} else {print "not ok 1\n"} +if (tr/\\//cd == 94){print "ok 2\n"} else {print "not ok 2\n"} + +#perl5a11 bus errors on this: +if (length quotemeta "" == 0){print "ok 3\n"} else {print "not ok 3\n"} + +print "aA\UbB\LcC\EdD" eq "aABBccdD" ? "ok 4\n" : "not ok 4 \n"; +print "aA\LbB\UcC\EdD" eq "aAbbCCdD" ? "ok 5\n" : "not ok 5 \n"; +print "\L\upERL" eq "Perl" ? "ok 6\n" : "not ok 6 \n"; +print "\u\LpERL" eq "Perl" ? "ok 7\n" : "not ok 7 \n"; +print "\U\lPerl" eq "pERL" ? "ok 8\n" : "not ok 8 \n"; +print "\l\UPerl" eq "pERL" ? "ok 9\n" : "not ok 9 \n"; +print "\u\LpE\Q#X#\ER\EL" eq "Pe\\#x\\#rL" ? "ok 10\n" : "not ok 10 \n"; +print "\l\UPe\Q!x!\Er\El" eq "pE\\!X\\!Rl" ? "ok 11\n" : "not ok 11 \n"; +print "\Q\u\LpE.X.R\EL\E." eq "Pe\\.x\\.rL." ? "ok 12\n" : "not ok 12 \n"; +print "\Q\l\UPe*x*r\El\E*" eq "pE\\*X\\*Rl*" ? "ok 13\n" : "not ok 13 \n"; +print "\U\lPerl\E\E\E\E" eq "pERL" ? "ok 14\n" : "not ok 14 \n"; +print "\l\UPerl\E\E\E\E" eq "pERL" ? "ok 15\n" : "not ok 15 \n"; diff --git a/t/op/rand.t b/t/op/rand.t new file mode 100755 index 0000000000..14e6ccfbed --- /dev/null +++ b/t/op/rand.t @@ -0,0 +1,25 @@ +#!./perl + +#From jhi@snakemail.hut.fi Mon May 16 10:36:46 1994 +#Date: Sun, 15 May 1994 20:39:09 +0300 +#From: Jarkko Hietaniemi <jhi@snakemail.hut.fi> + +print "1..2\n"; + +$n = 1000; + +$c = 0; +for (1..$n) { + last if (rand() > 1 || rand() < 0); + $c++; +} + +if ($c == $n) {print "ok 1\n";} else {print "not ok 1\n"} + +$c = 0; +for (1..$n) { + last if (rand(10) > 10 || rand(10) < 0); + $c++; +} + +if ($c == $n) {print "ok 2\n";} else {print "not ok 2\n"} diff --git a/t/op/re_tests b/t/op/re_tests index ee03d6fdbd..f8c4c6eafb 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -56,10 +56,7 @@ a[^]b]c adc y $& adc ab|cd abc y $& ab ab|cd abcd y $& ab ()ef def y $&-$1 ef- -()* - c - - *a - c - - -^* - c - - -$* - c - - (*)b - c - - $b b n - - a\ - c - - @@ -74,19 +71,13 @@ abc) - c - - a+b+c aabbabc y $& abc a{1,}b{1,}c aabbabc y $& abc a** - c - - -a*? - c - - -(a*)* - c - - -(a*)+ - c - - -(a|)* - c - - -(a*|b)* - c - - +a.+?c abcabc y $& abc (a+|b)* ab y $&-$1 ab-b (a+|b){0,} ab y $&-$1 ab-b (a+|b)+ ab y $&-$1 ab-b (a+|b){1,} ab y $&-$1 ab-b (a+|b)? ab y $&-$1 a-a (a+|b){0,1} ab y $&-$1 a-a -(^)* - c - - -(ab|)* - c - - )( - c - - [^ab]* cde y $& cde abc n - - @@ -95,7 +86,6 @@ a* y $& ([abc])*bcd abcd y $&-$1 abcd-a a|b|c|d|e e y $& e (a|b|c|d|e)f ef y $&-$1 ef-e -((a*|b))* - c - - abcd*efg abcdefg y $& abcdefg ab* xabyabbbz y $& ab ab* xayabbbz y $& a @@ -144,23 +134,23 @@ a[-]?c ac y $& ac 'ab*c'i ABC y $& ABC 'ab*bc'i ABC y $& ABC 'ab*bc'i ABBC y $& ABBC -'ab*bc'i ABBBBC y $& ABBBBC -'ab{0,}bc'i ABBBBC y $& ABBBBC -'ab+bc'i ABBC y $& ABBC +'ab*?bc'i ABBBBC y $& ABBBBC +'ab{0,}?bc'i ABBBBC y $& ABBBBC +'ab+?bc'i ABBC y $& ABBC 'ab+bc'i ABC n - - 'ab+bc'i ABQ n - - 'ab{1,}bc'i ABQ n - - 'ab+bc'i ABBBBC y $& ABBBBC -'ab{1,}bc'i ABBBBC y $& ABBBBC -'ab{1,3}bc'i ABBBBC y $& ABBBBC -'ab{3,4}bc'i ABBBBC y $& ABBBBC -'ab{4,5}bc'i ABBBBC n - - -'ab?bc'i ABBC y $& ABBC -'ab?bc'i ABC y $& ABC -'ab{0,1}bc'i ABC y $& ABC -'ab?bc'i ABBBBC n - - -'ab?c'i ABC y $& ABC -'ab{0,1}c'i ABC y $& ABC +'ab{1,}?bc'i ABBBBC y $& ABBBBC +'ab{1,3}?bc'i ABBBBC y $& ABBBBC +'ab{3,4}?bc'i ABBBBC y $& ABBBBC +'ab{4,5}?bc'i ABBBBC n - - +'ab??bc'i ABBC y $& ABBC +'ab??bc'i ABC y $& ABC +'ab{0,1}?bc'i ABC y $& ABC +'ab??bc'i ABBBBC n - - +'ab??c'i ABC y $& ABC +'ab{0,1}?c'i ABC y $& ABC '^abc$'i ABC y $& ABC '^abc$'i ABCC n - - '^abc'i ABCC y $& ABC @@ -170,7 +160,7 @@ a[-]?c ac y $& ac '$'i ABC y $& 'a.c'i ABC y $& ABC 'a.c'i AXC y $& AXC -'a.*c'i AXYZC y $& AXYZC +'a.*?c'i AXYZC y $& AXYZC 'a.*c'i AXYZD n - - 'a[bc]d'i ABC n - - 'a[bc]d'i ABD y $& ABD @@ -193,10 +183,7 @@ a[-]?c ac y $& ac 'ab|cd'i ABC y $& AB 'ab|cd'i ABCD y $& AB '()ef'i DEF y $&-$1 EF- -'()*'i - c - - '*a'i - c - - -'^*'i - c - - -'$*'i - c - - '(*)b'i - c - - '$b'i B n - - 'a\'i - c - - @@ -211,19 +198,16 @@ a[-]?c ac y $& ac 'a+b+c'i AABBABC y $& ABC 'a{1,}b{1,}c'i AABBABC y $& ABC 'a**'i - c - - -'a*?'i - c - - -'(a*)*'i - c - - -'(a*)+'i - c - - -'(a|)*'i - c - - -'(a*|b)*'i - c - - +'a.+?c'i ABCABC y $& ABC +'a.*?c'i ABCABC y $& ABC +'a.{0,5}?c'i ABCABC y $& ABC '(a+|b)*'i AB y $&-$1 AB-B '(a+|b){0,}'i AB y $&-$1 AB-B '(a+|b)+'i AB y $&-$1 AB-B '(a+|b){1,}'i AB y $&-$1 AB-B '(a+|b)?'i AB y $&-$1 A-A '(a+|b){0,1}'i AB y $&-$1 A-A -'(^)*'i - c - - -'(ab|)*'i - c - - +'(a+|b){0,1}?'i AB y $&-$1 - ')('i - c - - '[^ab]*'i CDE y $& CDE 'abc'i n - - @@ -232,7 +216,6 @@ a[-]?c ac y $& ac '([abc])*bcd'i ABCD y $&-$1 ABCD-A 'a|b|c|d|e'i E y $& E '(a|b|c|d|e)f'i EF y $&-$1 EF-E -'((a*|b))*'i - c - - 'abcd*efg'i ABCDEFG y $& ABCDEFG 'ab*'i XABYABBBZ y $& AB 'ab*'i XAYABBBZ y $& A @@ -262,6 +245,8 @@ a[-]?c ac y $& ac '((((((((((a))))))))))\41'i AA n - - '((((((((((a))))))))))\41'i A! y $& A! '(((((((((a)))))))))'i A y $& A +'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))'i A y $1 A +'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))'i C y $1 C 'multiple words of text'i UH-UH n - - 'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS '(.*)c(.*)'i ABCDE y $&-$1-$2 ABCDE-AB-DE @@ -272,3 +257,11 @@ a[-]?c ac y $& ac 'a[-]?c'i AC y $& AC '(abc)\1'i ABCABC y $1 ABC '([a-c]*)\1'i ABCABC y $1 ABC +a(?!b). abad y $& ad +a(?=d). abad y $& ad +a(?=c|d). abad y $& ad +a(?:b|c|d)(.) ace y $1 e +a(?:b|c|d)*(.) ace y $1 e +a(?:b|c|d)+?(.) ace y $1 e +a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce +^(.+)?B AB y $1 A diff --git a/t/op/read.t b/t/op/read.t index 8c571c035b..2746970d15 100755 --- a/t/op/read.t +++ b/t/op/read.t @@ -12,7 +12,7 @@ $got = read(FOO,$buf,4); print ($got == 4 ? "ok 1\n" : "not ok 1\n"); print ($buf eq "perl" ? "ok 2\n" : "not ok 2 :$buf:\n"); -seek(FOO,20000,0); +seek (FOO,0,2) || seek(FOO,20000,0); $got = read(FOO,$buf,4); print ($got == 0 ? "ok 3\n" : "not ok 3\n"); diff --git a/t/op/readdir.t b/t/op/readdir.t index 18006991cd..1215f11c8a 100755 --- a/t/op/readdir.t +++ b/t/op/readdir.t @@ -6,13 +6,18 @@ if ($@) { print "1..0\n"; exit; } print "1..3\n"; if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } -@D = grep(/^[^\.].*\.t$/, readdir(OP)); +@D = grep(/^[^\.].*\.t$/i, readdir(OP)); closedir(OP); if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; } @R = sort @D; @G = <op/*.t>; +if ($G[0] =~ m#.*\](\w+\.t)#i) { + # grep is to convert filespecs returned from glob under VMS to format + # identical to that returned by readdir + @G = grep(s#.*\](\w+\.t).*#op/$1#i,<op/*.t>); +} while (@R && @G && "op/".$R[0] eq $G[0]) { shift(@R); shift(@G); diff --git a/t/op/ref.t b/t/op/ref.t index 60bb75ce33..73a54ff3c8 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..40\n"; +print "1..41\n"; # Test glob operations. @@ -73,7 +73,7 @@ print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n"; print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n"; print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n"; -print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 18\n"; +print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n"; # Test references to hashes of references. @@ -151,8 +151,8 @@ DESTROY { return unless $string; print $string; - # Test that the object has already been "cursed". - print ref shift eq HASH ? "ok 35\n" : "not ok 35\n"; + # Test that the object has not already been "cursed". + print ref shift ne HASH ? "ok 35\n" : "not ok 35\n"; } # Now test inheritance of methods. @@ -180,12 +180,21 @@ sub BASEOBJ'doit { $ref->{shift}; } +package UNIVERSAL; +@ISA = 'LASTCHANCE'; + +package LASTCHANCE; +sub foo { print $_[1] } + +package WHATEVER; +foo WHATEVER "ok 38\n"; + package FINALE; { - $ref3 = bless ["ok 40\n"]; # package destruction - my $ref2 = bless ["ok 39\n"]; # lexical destruction - local $ref1 = bless ["ok 38\n"]; # dynamic destruction + $ref3 = bless ["ok 41\n"]; # package destruction + my $ref2 = bless ["ok 40\n"]; # lexical destruction + local $ref1 = bless ["ok 39\n"]; # dynamic destruction 1; # flush any temp values on stack } diff --git a/t/op/sort.t b/t/op/sort.t index 56a0fd3e92..dc01e5f11d 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -12,7 +12,7 @@ sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0; } $x = join('', sort @harry); print ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n"); -$x = join('', sort backwards @harry); +$x = join('', sort( backwards @harry)); print ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n"); $x = join('', sort @george, 'to', @harry); diff --git a/t/op/split.t b/t/op/split.t index d87998e098..2354530817 100755 --- a/t/op/split.t +++ b/t/op/split.t @@ -48,6 +48,9 @@ print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; # Does assignment to a list imply split to one more field than that? $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`; +if ($foo =~ /DCL-W-NOCOMD/) { + $foo = `\$ mcr sys\$disk:[]perl. "-D1024" -e "(\$a,\$b) = split;"`; +} print $foo =~ /DEBUGGING/ || $foo =~ /SV = IV\(3\)/ ? "ok 11\n" : "not ok 11\n"; # Can we say how many fields to split to when assigning to a list? diff --git a/t/op/substr.t b/t/op/substr.t index 25336365b9..08e1c39969 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -10,7 +10,7 @@ print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); print (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n"); -print (substr($a,6,-1) eq '' ? "ok 5\n" : "not ok 5\n"); +print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); $[ = 1; @@ -19,7 +19,7 @@ print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); print (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n"); -print (substr($a,7,-1) eq '' ? "ok 11\n" : "not ok 11\n"); +print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n"); print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); $[ = 0; diff --git a/t/op/time.t b/t/op/time.t index 6d23832dfa..186a81cf8a 100755 --- a/t/op/time.t +++ b/t/op/time.t @@ -2,7 +2,8 @@ # $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $ -print "1..5\n"; +if ($does_gmtime = gmtime(time)) { print "1..5\n" } +else { print "1..3\n" } ($beguser,$begsys) = times; @@ -14,7 +15,8 @@ if ($now > $beg && $now - $beg < 10){print "ok 1\n";} else {print "not ok 1\n";} for ($i = 0; $i < 100000; $i++) { ($nowuser, $nowsys) = times; - $i = 200000 if $nowuser > $beguser && $nowsys > $begsys; + $i = 200000 if $nowuser > $beguser && ( $nowsys > $begsys || + (!$nowsys && !$begsys)); last if time - $beg > 20; } @@ -29,6 +31,8 @@ if ($sec != $xsec && $mday && $year) else {print "not ok 3\n";} +exit 0 unless $does_gmtime; + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg); ($xsec,$foo) = localtime($now); diff --git a/t/op/write.t b/t/op/write.t index eb00d81b59..bfb4785155 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -17,10 +17,12 @@ $foo ^<<<<<<... $foo now @<<the@>>>> for all@|||||men to come @<<<< -'i' . 's', "time\n", $good, 'to' +{ + 'i' . 's', "time\n", $good, 'to' +} . -open(OUT, '>Op.write.tmp') || die "Can't create Op.write.tmp"; +open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; $fox = 'foxiness'; $good = 'good'; @@ -40,8 +42,8 @@ the course of huma... now is the time for all good men to come to\n"; -if (`cat Op.write.tmp` eq $right) - { print "ok 1\n"; unlink 'Op.write.tmp'; } +if (`cat Op_write.tmp` eq $right) + { print "ok 1\n"; unlink 'Op_write.tmp'; } else { print "not ok 1\n"; } @@ -57,7 +59,7 @@ now @<<the@>>>> for all@|||||men to come @<<<< 'i' . 's', "time\n", $good, 'to' . -open OUT2, '>Op.write.tmp' or die "Can't create Op.write.tmp"; +open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; $fox = 'foxiness'; $good = 'good'; @@ -80,8 +82,8 @@ becomes necessary now is the time for all good men to come to\n"; -if (`cat Op.write.tmp` eq $right) - { print "ok 2\n"; unlink 'Op.write.tmp'; } +if (`cat Op_write.tmp` eq $right) + { print "ok 2\n"; unlink 'Op_write.tmp'; } else { print "not ok 2\n"; } @@ -92,6 +94,7 @@ $fox jumped @* $multiline +and ^<<<<<<<<< ~~ $foo now @<<the@>>>> for all@|||||men to come @<<<< @@ -99,7 +102,7 @@ now @<<the@>>>> for all@|||||men to come @<<<< . EOFORMAT -open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp"; +open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; $fox = 'foxiness'; $good = 'good'; @@ -114,6 +117,7 @@ jumped forescore and seven years +and when in the course of human @@ -122,8 +126,8 @@ becomes necessary now is the time for all good men to come to\n"; -if (`cat Op.write.tmp` eq $right) - { print "ok 3\n"; unlink 'Op.write.tmp'; } +if (`cat Op_write.tmp` eq $right) + { print "ok 3\n"; unlink 'Op_write.tmp'; } else { print "not ok 3\n"; } diff --git a/t/perl b/t/perl deleted file mode 120000 index f2271dea4a..0000000000 --- a/t/perl +++ /dev/null @@ -1 +0,0 @@ -../perl
\ No newline at end of file diff --git a/t/perl5a1.tar b/t/perl5a1.tar Binary files differdeleted file mode 100644 index 0c0b43ce1b..0000000000 --- a/t/perl5a1.tar +++ /dev/null diff --git a/t/re_tests b/t/re_tests new file mode 100644 index 0000000000..b1a5ef28cf --- /dev/null +++ b/t/re_tests @@ -0,0 +1,274 @@ +abc abc y $& abc +abc xbc n - - +abc axc n - - +abc abx n - - +abc xabcy y $& abc +abc ababc y $& abc +ab*c abc y $& abc +ab*bc abc y $& abc +ab*bc abbc y $& abbc +ab*bc abbbbc y $& abbbbc +ab{0,}bc abbbbc y $& abbbbc +ab+bc abbc y $& abbc +ab+bc abc n - - +ab+bc abq n - - +ab{1,}bc abq n - - +ab+bc abbbbc y $& abbbbc +ab{1,}bc abbbbc y $& abbbbc +ab{1,3}bc abbbbc y $& abbbbc +ab{3,4}bc abbbbc y $& abbbbc +ab{4,5}bc abbbbc n - - +ab?bc abbc y $& abbc +ab?bc abc y $& abc +ab{0,1}bc abc y $& abc +ab?bc abbbbc n - - +ab?c abc y $& abc +ab{0,1}c abc y $& abc +^abc$ abc y $& abc +^abc$ abcc n - - +^abc abcc y $& abc +^abc$ aabc n - - +abc$ aabc y $& abc +^ abc y $& +$ abc y $& +a.c abc y $& abc +a.c axc y $& axc +a.*c axyzc y $& axyzc +a.*c axyzd n - - +a[bc]d abc n - - +a[bc]d abd y $& abd +a[b-d]e abd n - - +a[b-d]e ace y $& ace +a[b-d] aac y $& ac +a[-b] a- y $& a- +a[b-] a- y $& a- +a[b-a] - c - - +a[]b - c - - +a[ - c - - +a] a] y $& a] +a[]]b a]b y $& a]b +a[^bc]d aed y $& aed +a[^bc]d abd n - - +a[^-b]c adc y $& adc +a[^-b]c a-c n - - +a[^]b]c a]c n - - +a[^]b]c adc y $& adc +ab|cd abc y $& ab +ab|cd abcd y $& ab +()ef def y $&-$1 ef- +()* - c - - +*a - c - - +^* - c - - +$* - c - - +(*)b - c - - +$b b n - - +a\ - c - - +a\(b a(b y $&-$1 a(b- +a\(*b ab y $& ab +a\(*b a((b y $& a((b +a\\b a\b y $& a\b +abc) - c - - +(abc - c - - +((a)) abc y $&-$1-$2 a-a-a +(a)b(c) abc y $&-$1-$2 abc-a-c +a+b+c aabbabc y $& abc +a{1,}b{1,}c aabbabc y $& abc +a** - c - - +a.+?c abcabc y $& abc +(a*)* - c - - +(a*)+ - c - - +(a|)* - c - - +(a*|b)* - c - - +(a+|b)* ab y $&-$1 ab-b +(a+|b){0,} ab y $&-$1 ab-b +(a+|b)+ ab y $&-$1 ab-b +(a+|b){1,} ab y $&-$1 ab-b +(a+|b)? ab y $&-$1 a-a +(a+|b){0,1} ab y $&-$1 a-a +(^)* - c - - +(ab|)* - c - - +)( - c - - +[^ab]* cde y $& cde +abc n - - +a* y $& +([abc])*d abbbcd y $&-$1 abbbcd-c +([abc])*bcd abcd y $&-$1 abcd-a +a|b|c|d|e e y $& e +(a|b|c|d|e)f ef y $&-$1 ef-e +((a*|b))* - c - - +abcd*efg abcdefg y $& abcdefg +ab* xabyabbbz y $& ab +ab* xayabbbz y $& a +(ab|cd)e abcde y $&-$1 cde-cd +[abhgefdc]ij hij y $& hij +^(ab|cd)e abcde n x$1y xy +(abc|)ef abcdef y $&-$1 ef- +(a|b)c*d abcd y $&-$1 bcd-b +(ab|ab*)bc abc y $&-$1 abc-a +a([bc]*)c* abc y $&-$1 abc-bc +a([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d +a([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d +a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd +a[bcd]*dcdcde adcdcde y $& adcdcde +a[bcd]+dcdcde adcdcde n - - +(ab|a)b*c abc y $&-$1 abc-ab +((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d +[a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha +^a(bc+|b[eh])g|.h$ abh y $&-$1 bh- +(bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz- +(bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j +(bc+d$|ef*g.|h?i(j|k)) effg n - - +(bc+d$|ef*g.|h?i(j|k)) bcdd n - - +(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz- +((((((((((a)))))))))) a y $10 a +((((((((((a))))))))))\10 aa y $& aa +((((((((((a))))))))))\41 aa n - - +((((((((((a))))))))))\41 a! y $& a! +(((((((((a))))))))) a y $& a +multiple words of text uh-uh n - - +multiple words multiple words, yeah y $& multiple words +(.*)c(.*) abcde y $&-$1-$2 abcde-ab-de +\((.*), (.*)\) (a, b) y ($2, $1) (b, a) +[k] ab n - - +abcd abcd y $&-\$&-\\$& abcd-$&-\abcd +a(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc +a[-]?c ac y $& ac +(abc)\1 abcabc y $1 abc +([a-c]*)\1 abcabc y $1 abc +'abc'i ABC y $& ABC +'abc'i XBC n - - +'abc'i AXC n - - +'abc'i ABX n - - +'abc'i XABCY y $& ABC +'abc'i ABABC y $& ABC +'ab*c'i ABC y $& ABC +'ab*bc'i ABC y $& ABC +'ab*bc'i ABBC y $& ABBC +'ab*bc'i ABBBBC y $& ABBBBC +'ab{0,}bc'i ABBBBC y $& ABBBBC +'ab+bc'i ABBC y $& ABBC +'ab+bc'i ABC n - - +'ab+bc'i ABQ n - - +'ab{1,}bc'i ABQ n - - +'ab+bc'i ABBBBC y $& ABBBBC +'ab{1,}bc'i ABBBBC y $& ABBBBC +'ab{1,3}bc'i ABBBBC y $& ABBBBC +'ab{3,4}bc'i ABBBBC y $& ABBBBC +'ab{4,5}bc'i ABBBBC n - - +'ab?bc'i ABBC y $& ABBC +'ab?bc'i ABC y $& ABC +'ab{0,1}bc'i ABC y $& ABC +'ab?bc'i ABBBBC n - - +'ab?c'i ABC y $& ABC +'ab{0,1}c'i ABC y $& ABC +'^abc$'i ABC y $& ABC +'^abc$'i ABCC n - - +'^abc'i ABCC y $& ABC +'^abc$'i AABC n - - +'abc$'i AABC y $& ABC +'^'i ABC y $& +'$'i ABC y $& +'a.c'i ABC y $& ABC +'a.c'i AXC y $& AXC +'a.*c'i AXYZC y $& AXYZC +'a.*c'i AXYZD n - - +'a[bc]d'i ABC n - - +'a[bc]d'i ABD y $& ABD +'a[b-d]e'i ABD n - - +'a[b-d]e'i ACE y $& ACE +'a[b-d]'i AAC y $& AC +'a[-b]'i A- y $& A- +'a[b-]'i A- y $& A- +'a[b-a]'i - c - - +'a[]b'i - c - - +'a['i - c - - +'a]'i A] y $& A] +'a[]]b'i A]B y $& A]B +'a[^bc]d'i AED y $& AED +'a[^bc]d'i ABD n - - +'a[^-b]c'i ADC y $& ADC +'a[^-b]c'i A-C n - - +'a[^]b]c'i A]C n - - +'a[^]b]c'i ADC y $& ADC +'ab|cd'i ABC y $& AB +'ab|cd'i ABCD y $& AB +'()ef'i DEF y $&-$1 EF- +'()*'i - c - - +'*a'i - c - - +'^*'i - c - - +'$*'i - c - - +'(*)b'i - c - - +'$b'i B n - - +'a\'i - c - - +'a\(b'i A(B y $&-$1 A(B- +'a\(*b'i AB y $& AB +'a\(*b'i A((B y $& A((B +'a\\b'i A\B y $& A\B +'abc)'i - c - - +'(abc'i - c - - +'((a))'i ABC y $&-$1-$2 A-A-A +'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C +'a+b+c'i AABBABC y $& ABC +'a{1,}b{1,}c'i AABBABC y $& ABC +'a**'i - c - - +'a.+?c'i ABCABC y $& ABC +'(a*)*'i - c - - +'(a*)+'i - c - - +'(a|)*'i - c - - +'(a*|b)*'i - c - - +'(a+|b)*'i AB y $&-$1 AB-B +'(a+|b){0,}'i AB y $&-$1 AB-B +'(a+|b)+'i AB y $&-$1 AB-B +'(a+|b){1,}'i AB y $&-$1 AB-B +'(a+|b)?'i AB y $&-$1 A-A +'(a+|b){0,1}'i AB y $&-$1 A-A +'(^)*'i - c - - +'(ab|)*'i - c - - +')('i - c - - +'[^ab]*'i CDE y $& CDE +'abc'i n - - +'a*'i y $& +'([abc])*d'i ABBBCD y $&-$1 ABBBCD-C +'([abc])*bcd'i ABCD y $&-$1 ABCD-A +'a|b|c|d|e'i E y $& E +'(a|b|c|d|e)f'i EF y $&-$1 EF-E +'((a*|b))*'i - c - - +'abcd*efg'i ABCDEFG y $& ABCDEFG +'ab*'i XABYABBBZ y $& AB +'ab*'i XAYABBBZ y $& A +'(ab|cd)e'i ABCDE y $&-$1 CDE-CD +'[abhgefdc]ij'i HIJ y $& HIJ +'^(ab|cd)e'i ABCDE n x$1y XY +'(abc|)ef'i ABCDEF y $&-$1 EF- +'(a|b)c*d'i ABCD y $&-$1 BCD-B +'(ab|ab*)bc'i ABC y $&-$1 ABC-A +'a([bc]*)c*'i ABC y $&-$1 ABC-BC +'a([bc]*)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D +'a([bc]+)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D +'a([bc]*)(c+d)'i ABCD y $&-$1-$2 ABCD-B-CD +'a[bcd]*dcdcde'i ADCDCDE y $& ADCDCDE +'a[bcd]+dcdcde'i ADCDCDE n - - +'(ab|a)b*c'i ABC y $&-$1 ABC-AB +'((a)(b)c)(d)'i ABCD y $1-$2-$3-$4 ABC-A-B-D +'[a-zA-Z_][a-zA-Z0-9_]*'i ALPHA y $& ALPHA +'^a(bc+|b[eh])g|.h$'i ABH y $&-$1 BH- +'(bc+d$|ef*g.|h?i(j|k))'i EFFGZ y $&-$1-$2 EFFGZ-EFFGZ- +'(bc+d$|ef*g.|h?i(j|k))'i IJ y $&-$1-$2 IJ-IJ-J +'(bc+d$|ef*g.|h?i(j|k))'i EFFG n - - +'(bc+d$|ef*g.|h?i(j|k))'i BCDD n - - +'(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ- +'((((((((((a))))))))))'i A y $10 A +'((((((((((a))))))))))\10'i AA y $& AA +'((((((((((a))))))))))\41'i AA n - - +'((((((((((a))))))))))\41'i A! y $& A! +'(((((((((a)))))))))'i A y $& A +'multiple words of text'i UH-UH n - - +'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS +'(.*)c(.*)'i ABCDE y $&-$1-$2 ABCDE-AB-DE +'\((.*), (.*)\)'i (A, B) y ($2, $1) (B, A) +'[k]'i AB n - - +'abcd'i ABCD y $&-\$&-\\$& ABCD-$&-\ABCD +'a(bc)d'i ABCD y $1-\$1-\\$1 BC-$1-\BC +'a[-]?c'i AC y $& AC +'(abc)\1'i ABCABC y $1 ABC +'([a-c]*)\1'i ABCABC y $1 ABC diff --git a/t/tmp/bullet b/t/tmp/bullet deleted file mode 100644 index 048f271a1f..0000000000 --- a/t/tmp/bullet +++ /dev/null @@ -1,13 +0,0 @@ - - Upgrades to obed - - * design high-level API and use it - * minimize oidtypes usage and boot time - * use more metadata (read-only attributes, etc.) - * use compiled types - * collection generators and filters - * type-directed entry - * event interlocking - * cloning app window - * add accelerators - * study scaling and psychology (does it feel fast?) @@ -1,3 +0,0 @@ -#!./perl -Dx - -$foo !~ /foo/; @@ -1,692 +0,0 @@ -AOP toke.c /^#define AOP(f) return(yylval.ival=f,expectterm = T/ -ASSERT malloc.c /^#define ASSERT(p) if (!(p)) botch("p"); else$/ -BAOP toke.c /^#define BAOP(f) return(yylval.ival=f,expectterm = / -BOOP toke.c /^#define BOOP(f) return(yylval.ival=f,expectterm = / -CHKLEN form.c /^#define CHKLEN(allow) \\$/ -EOP toke.c /^#define EOP(f) return(yylval.ival=f,expectterm = T/ -EXTEND pp.c /^#define EXTEND(n) if (n > 0 && stack->ary_fill + n/ -FL toke.c /^#define FL(f) return(yylval.ival=f,expectterm = FA/ -FL2 toke.c /^#define FL2(f) return(yylval.ival=f,expectterm = F/ -FOP toke.c /^#define FOP(f) return(yylval.ival=f,expectterm = F/ -FOP2 toke.c /^#define FOP2(f) return(yylval.ival=f,expectterm = / -FOP22 toke.c /^#define FOP22(f) return(yylval.ival=f,expectterm =/ -FOP25 toke.c /^#define FOP25(f) return(yylval.ival=f,expectterm =/ -FOP3 toke.c /^#define FOP3(f) return(yylval.ival=f,expectterm = / -FOP4 toke.c /^#define FOP4(f) return(yylval.ival=f,expectterm = / -FTST toke.c /^#define FTST(f) return(yylval.ival=f,expectterm = / -FUN0 toke.c /^#define FUN0(f) return(yylval.ival = f,expectterm / -FUN1 toke.c /^#define FUN1(f) return(yylval.ival = f,expectterm / -FUN2 toke.c /^#define FUN2(f) return(yylval.ival = f,expectterm / -FUN2x toke.c /^#define FUN2x(f) return(yylval.ival = f,expectterm/ -FUN3 toke.c /^#define FUN3(f) return(yylval.ival = f,expectterm / -FUN4 toke.c /^#define FUN4(f) return(yylval.ival = f,expectterm / -FUN5 toke.c /^#define FUN5(f) return(yylval.ival = f,expectterm / -HFUN toke.c /^#define HFUN(f) return(yylval.ival=f,expectterm = / -HFUN3 toke.c /^#define HFUN3(f) return(yylval.ival=f,expectterm =/ -HTOV util.c /^#define HTOV(name,type) \\$/ -ISMULT1 regcomp.c /^#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c/ -ISMULT2 regcomp.c /^#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || / -LFUN toke.c /^#define LFUN(f) return(yylval.ival=f,expectterm = / -LOOPX toke.c /^#define LOOPX(f) return(yylval.ival=f,expectterm =/ -LOP toke.c /^#define LOP(f) return(yylval.ival = f, \\$/ -META toke.c /^#define META(c) ((c) | 128)$/ -MOP toke.c /^#define MOP(f) return(yylval.ival=f,expectterm = T/ -Mmain main.c /^main(argc, argv, env)$/ -OLDLOP toke.c /^#define OLDLOP(f) return(yylval.ival=f,expectterm / -OPERATOR toke.c /^#define OPERATOR(retval) return (expectterm = TRUE/ -PERL_META toke.c /^#define PERL_META(c) ((c) | 128)$/ -PMOP toke.c /^#define PMOP(f) return(yylval.ival=f,expectterm = / -PUSHc pp.c /^#define PUSHc(c,l) str_nset(TMP, (c), (l)); PUSHTM/ -PUSHn pp.c /^#define PUSHn(n) str_numset(TMP, (n)); PUSHTMP$/ -PUSHs pp.c /^#define PUSHs(s) (*++SP = (s))$/ -PWOP toke.c /^#define PWOP(f) return(yylval.ival=f,expectterm = / -RETURN toke.c /^#define RETURN(retval) return (bufptr = s,(int)ret/ -ROP toke.c /^#define ROP(f) return(yylval.ival=f,expectterm = T/ -SETc pp.c /^#define SETc(c,l) str_set(TMP, (c), (l)); SETTMP$/ -SETn pp.c /^#define SETn(n) str_numset(TMP, (n)); SETTMP$/ -SETs pp.c /^#define SETs(s) *SP = s$/ -SHOP toke.c /^#define SHOP(f) return(yylval.ival=f,expectterm = / -TERM toke.c /^#define TERM(retval) return (CLINE, expectterm = F/ -UNI toke.c /^#define UNI(f) return(yylval.ival = f, \\$/ -VTOH util.c /^#define VTOH(name,type) \\$/ -YYBACKUP perly.c /^#define YYBACKUP( newtoken, newvalue )\\$/ -YYRECOVERING perly.c /^#define YYRECOVERING() (!!yyerrflag)$/ -aadd stab.c /^aadd(stab)$/ -aclear array.c /^aclear(ar)$/ -add_label cons.c /^add_label(lbl,cmd)$/ -addcond cons.c /^addcond(cmd, arg)$/ -addflags consarg.c /^addflags(i,flags,arg)$/ -addloop cons.c /^addloop(cmd, arg)$/ -afake array.c /^afake(stab,size,strp)$/ -afetch array.c /^afetch(ar,key,lval)$/ -afill array.c /^afill(ar, fill)$/ -afree array.c /^afree(ar)$/ -alen array.c /^alen(ar)$/ -anew array.c /^anew(stab)$/ -apop array.c /^apop(ar)$/ -append_line cons.c /^append_line(head,tail)$/ -apply doio.c /^apply(type,arglast)$/ -apush array.c /^apush(ar,val)$/ -arg_common consarg.c /^arg_common(arg,exprnum,marking)$/ -arg_free cons.c /^arg_free(arg)$/ -arg_tosave cons.c /^arg_tosave(arg,willsave)$/ -ashift array.c /^ashift(ar)$/ -astore array.c /^astore(ar,key,val)$/ -aunshift array.c /^aunshift(ar,num)$/ -block_head cons.c /^block_head(tail)$/ -botch malloc.c /^botch(s)$/ -cando doio.c /^cando(bit, effective, statbufp)$/ -castulong util.c /^castulong(f)$/ -check_uni toke.c /^check_uni() {$/ -checkcomma toke.c /^checkcomma(s,name,what)$/ -chsize doio.c /^int chsize(fd, length)$/ -cmd_exec cmd.c /^cmd_exec(cmdparm,gimme,sp)$/ -cmd_free cons.c /^cmd_free(cmd)$/ -cmd_to_arg consarg.c /^cmd_to_arg(cmd)$/ -cmd_tosave cons.c /^cmd_tosave(cmd,willsave)$/ -copyopt cmd.c /^copyopt(cmd,which)$/ -countlines form.c /^countlines(s,size)$/ -cpy7bit cons.c /^cpy7bit(d,s,l)$/ -cpytill util.c /^cpytill(to,from,fromend,delim,retlen)$/ -cryptfilter usersub.c /^cryptfilter( fil )$/ -cryptswitch usersub.c /^cryptswitch()$/ -cval_to_arg consarg.c /^cval_to_arg(cval)$/ -deb cmd.c /^void deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)$/ -dehoist consarg.c /^dehoist(arg,i)$/ -do_accept doio.c /^do_accept(str, nstab, gstab)$/ -do_aexec doio.c /^do_aexec(really,arglast)$/ -do_aprint doio.c /^do_aprint(arg,fp,arglast)$/ -do_assign doarg.c /^do_assign(arg,gimme,arglast)$/ -do_bind doio.c /^do_bind(stab, arglast)$/ -do_caller dolist.c /^do_caller(arg,maxarg,gimme,arglast)$/ -do_chop doarg.c /^do_chop(astr,str)$/ -do_close doio.c /^do_close(stab,explicit)$/ -do_connect doio.c /^do_connect(stab, arglast)$/ -do_ctl doio.c /^do_ctl(optype,stab,func,argstr)$/ -do_defined doarg.c /^do_defined(str,arg,gimme,arglast)$/ -do_dirop doio.c /^do_dirop(optype,stab,gimme,arglast)$/ -do_each dolist.c /^do_each(str,hash,gimme,arglast)$/ -do_eof doio.c /^do_eof(stab)$/ -do_eval perl.c /^do_eval(str,optype,stash,savecmd,gimme,arglast)$/ -do_exec doio.c /^do_exec(cmd)$/ -do_execfree doio.c /^do_execfree()$/ -do_fttext doio.c /^do_fttext(arg,str)$/ -do_getsockname doio.c /^do_getsockname(optype, stab, arglast)$/ -do_ggrent doio.c /^do_ggrent(which,gimme,arglast)$/ -do_ghent doio.c /^do_ghent(which,gimme,arglast)$/ -do_gnent doio.c /^do_gnent(which,gimme,arglast)$/ -do_gpent doio.c /^do_gpent(which,gimme,arglast)$/ -do_gpwent doio.c /^do_gpwent(which,gimme,arglast)$/ -do_grep dolist.c /^do_grep(arg,str,gimme,arglast)$/ -do_gsent doio.c /^do_gsent(which,gimme,arglast)$/ -do_ipcctl doio.c /^do_ipcctl(optype, arglast)$/ -do_ipcget doio.c /^do_ipcget(optype, arglast)$/ -do_join doarg.c /^do_join(str,arglast)$/ -do_kv dolist.c /^do_kv(str,hash,kv,gimme,arglast)$/ -do_listen doio.c /^do_listen(stab, arglast)$/ -do_match dolist.c /^do_match(str,arg,gimme,arglast)$/ -do_msgrcv doio.c /^do_msgrcv(arglast)$/ -do_msgsnd doio.c /^do_msgsnd(arglast)$/ -do_open doio.c /^do_open(stab,name,len)$/ -do_pack doarg.c /^do_pack(str,arglast)$/ -do_pipe doio.c /^do_pipe(str, rstab, wstab)$/ -do_print doio.c /^do_print(str,fp)$/ -do_push doarg.c /^do_push(ary,arglast)$/ -do_range dolist.c /^do_range(gimme,arglast)$/ -do_repeatary dolist.c /^do_repeatary(arglast)$/ -do_reverse dolist.c /^do_reverse(arglast)$/ -do_seek doio.c /^do_seek(stab, pos, whence)$/ -do_select doio.c /^do_select(gimme,arglast)$/ -do_semop doio.c /^do_semop(arglast)$/ -do_shmio doio.c /^do_shmio(optype, arglast)$/ -do_shutdown doio.c /^do_shutdown(stab, arglast)$/ -do_slice dolist.c /^do_slice(stab,str,numarray,lval,gimme,arglast)$/ -do_socket doio.c /^do_socket(stab, arglast)$/ -do_sopt doio.c /^do_sopt(optype, stab, arglast)$/ -do_sort dolist.c /^do_sort(str,arg,gimme,arglast)$/ -do_spair doio.c /^do_spair(stab1, stab2, arglast)$/ -do_splice dolist.c /^do_splice(ary,gimme,arglast)$/ -do_split dolist.c /^do_split(str,spat,limit,gimme,arglast)$/ -do_sprintf doarg.c /^do_sprintf(str,len,sarg)$/ -do_sreverse dolist.c /^do_sreverse(str,arglast)$/ -do_stat doio.c /^do_stat(str,arg,gimme,arglast)$/ -do_study doarg.c /^do_study(str,arg,gimme,arglast)$/ -do_subr doarg.c /^do_subr(arg,gimme,arglast)$/ -do_subst doarg.c /^do_subst(str,arg,sp)$/ -do_syscall doarg.c /^do_syscall(arglast)$/ -do_tell doio.c /^do_tell(stab)$/ -do_time dolist.c /^do_time(str,tmbuf,gimme,arglast)$/ -do_tms dolist.c /^do_tms(str,gimme,arglast)$/ -do_trans doarg.c /^do_trans(str,arg)$/ -do_truncate doio.c /^do_truncate(str,arg,gimme,arglast)$/ -do_try perl.c /^do_try(cmd,gimme,arglast)$/ -do_undef doarg.c /^do_undef(str,arg,gimme,arglast)$/ -do_unpack dolist.c /^do_unpack(str,gimme,arglast)$/ -do_unshift doarg.c /^do_unshift(ary,arglast)$/ -do_vec doarg.c /^do_vec(lvalue,astr,arglast)$/ -do_vecset doarg.c /^do_vecset(mstr,str)$/ -do_vop doarg.c /^do_vop(optype,str,left,right)$/ -do_write form.c /^do_write(orec,stab,sp)$/ -dodb cons.c /^dodb(cur)$/ -doencodes doarg.c /^doencodes(str, s, len)$/ -dump dump.c /^static void dump(arg1,arg2,arg3,arg4,arg5)$/ -dump_all dump.c /^dump_all()$/ -dump_arg dump.c /^dump_arg(arg)$/ -dump_cmd dump.c /^dump_cmd(cmd,alt)$/ -dump_flags dump.c /^dump_flags(b,flags)$/ -dump_spat dump.c /^dump_spat(spat)$/ -dump_stab dump.c /^dump_stab(stab)$/ -dumpfds util.c /^dumpfds(s)$/ -dup2 util.c /^dup2(oldfd,newfd)$/ -envix util.c /^envix(nam)$/ -eval eval.c /^eval(arg,gimme,sp)$/ -evalstatic consarg.c /^evalstatic(arg)$/ -fatal util.c /^void fatal(pat,a1,a2,a3,a4)$/ -fbmcompile util.c /^fbmcompile(str, iflag)$/ -fbminstr util.c /^fbminstr(big, bigend, littlestr)$/ -find_beginning perl.c /^find_beginning()$/ -findbucket malloc.c /^findbucket(freep, srchlen)$/ -fixl consarg.c /^fixl(type,arg)$/ -forceword toke.c /^forceword(s)$/ -form_parseargs form.c /^form_parseargs(fcmd)$/ -format form.c /^format(orec,fcmd,sp)$/ -free malloc.c /^free(mp)$/ -free_arg consarg.c /^free_arg(arg)$/ -fstab stab.c /^fstab(name)$/ -function doarg.c /^ #pragma function(memcmp)$/ -genstab stab.c /^genstab()$/ -grow_dlevel cmd.c /^grow_dlevel()$/ -growstr util.c /^growstr(strptr,curlen,newlen)$/ -hadd stab.c /^hadd(stab)$/ -hclear hash.c /^hclear(tb,dodbm)$/ -hdbmclose hash.c /^hdbmclose(tb)$/ -hdbmopen hash.c /^hdbmopen(tb,fname,mode)$/ -hdbmstore hash.c /^hdbmstore(tb,key,klen,str)$/ -hdelete hash.c /^hdelete(tb,key,klen)$/ -hentdelayfree hash.c /^hentdelayfree(hent)$/ -hentfree hash.c /^hentfree(hent)$/ -hfetch hash.c /^hfetch(tb,key,klen,lval)$/ -hfree hash.c /^hfree(tb,dodbm)$/ -hfreeentries hash.c /^hfreeentries(tb,dodbm)$/ -hide_ary consarg.c /^hide_ary(arg)$/ -hiterinit hash.c /^hiterinit(tb)$/ -hiterkey hash.c /^hiterkey(entry,retlen)$/ -hiternext hash.c /^hiternext(tb)$/ -hiterval hash.c /^hiterval(tb,entry)$/ -hnew hash.c /^hnew(lookat)$/ -hoistmust toke.c /^hoistmust(spat)$/ -hsplit hash.c /^hsplit(tb)$/ -hstore hash.c /^hstore(tb,key,klen,val,hash)$/ -htonl util.c /^htonl(l)$/ -if pp.c /^ if (debug) {$/ -incpush perl.c /^incpush(p)$/ -ingroup doio.c /^ingroup(testgid,effective)$/ -init_debugger perl.c /^init_debugger()$/ -init_lexer perl.c /^init_lexer()$/ -init_loop_stack perl.c /^init_loop_stack()$/ -init_main_stash perl.c /^init_main_stash()$/ -init_perllib perl.c /^init_perllib()$/ -init_postdump_symbols perl.c /^init_postdump_symbols(argc,argv,env)$/ -init_predump_symbols perl.c /^init_predump_symbols()$/ -init_stack perl.c /^init_stack()$/ -instr util.c /^instr(big, little)$/ -interp str.c /^interp(str,src,sp)$/ -intrinsic doarg.c /^ #pragma intrinsic(memcmp)$/ -intrpcompile str.c /^intrpcompile(src)$/ -invert cons.c /^invert(cmd)$/ -jmaybe consarg.c /^jmaybe(arg)$/ -keyword toke.c /^keyword(d)$/ -l consarg.c /^l(arg)$/ -lcase str.c /^lcase(s,send)$/ -listish consarg.c /^listish(arg)$/ -load_format toke.c /^load_format()$/ -localize consarg.c /^localize(arg)$/ -looks_like_number doio.c /^looks_like_number(str)$/ -lop toke.c /^lop(f,s)$/ -magicalize perl.c /^magicalize(list)$/ -magicname perl.c /^magicname(sym,name,namlen)$/ -make_acmd cons.c /^make_acmd(type,stab,cond,arg)$/ -make_ccmd cons.c /^make_ccmd(type,debuggable,arg,cblock)$/ -make_cswitch cons.c /^make_cswitch(head,count)$/ -make_form cons.c /^make_form(stab,fcmd)$/ -make_icmd cons.c /^make_icmd(type,arg,cblock)$/ -make_list consarg.c /^make_list(arg)$/ -make_match consarg.c /^make_match(type,expr,spat)$/ -make_nswitch cons.c /^make_nswitch(head,count)$/ -make_op consarg.c /^make_op(type,newlen,arg1,arg2,arg3)$/ -make_split consarg.c /^make_split(stab,arg,limarg)$/ -make_sub cons.c /^make_sub(name,cmd)$/ -make_usub cons.c /^make_usub(name, ix, subaddr, filename)$/ -malloc malloc.c /^malloc(nbytes)$/ -maybelistish consarg.c /^maybelistish(optype, arg)$/ -mess util.c /^mess(pat,a1,a2,a3,a4)$/ -mod_match consarg.c /^mod_match(type,left,pat)$/ -morecore malloc.c /^morecore(bucket)$/ -moreswitches perl.c /^moreswitches(s)$/ -mstats malloc.c /^mstats(s)$/ -my_bcopy util.c /^my_bcopy(from,to,len)$/ -my_bzero util.c /^my_bzero(loc,len)$/ -my_exit perl.c /^my_exit(status)$/ -my_memcmp util.c /^my_memcmp(s1,s2,len)$/ -my_setenv util.c /^my_setenv(nam,val)$/ -my_swap util.c /^my_swap(s)$/ -my_unexec perl.c /^my_unexec()$/ -mylstat doio.c /^mylstat(arg,str)$/ -mypclose util.c /^mypclose(ptr)$/ -mypfiopen usersub.c /^mypfiopen(fil,func) \/* open a pipe to function ca/ -mypopen util.c /^mypopen(cmd,mode)$/ -mystat doio.c /^mystat(arg,str)$/ -nextargv doio.c /^nextargv(stab)$/ -ninstr util.c /^ninstr(big, bigend, little, lend)$/ -nothing_in_common consarg.c /^nothing_in_common(arg1,arg2)$/ -nsavestr util.c /^nsavestr(str, len)$/ -ntohl util.c /^ntohl(l)$/ -op_new consarg.c /^op_new(numargs)$/ -open_script perl.c /^open_script(scriptname,dosearch,str)$/ -opt_arg cons.c /^opt_arg(cmd,fliporflop,acmd)$/ -over cons.c /^over(eachstab,cmd)$/ -parselist str.c /^parselist(str)$/ -perl_alloc perl.c /^perl_alloc()$/ -perl_callback perl.c /^perl_callback(subname, sp, gimme, hasargs, numargs/ -perl_callv perl.c /^perl_callv(subname, sp, gimme, argv)$/ -perl_construct perl.c /^perl_construct( interp )$/ -perl_destruct perl.c /^perl_destruct(interp)$/ -perl_free perl.c /^perl_free(interp)$/ -perl_parse perl.c /^perl_parse(interp, argc, argv, env)$/ -perl_run perl.c /^perl_run(interp)$/ -pidgone util.c /^pidgone(pid,status)$/ -pp_aassign pp.c /^pp_aassign(ARGS)$/ -pp_accept pp.c /^pp_accept(ARGS)$/ -pp_add pp.c /^pp_add(ARGS)$/ -pp_aelem pp.c /^pp_aelem(ARGS)$/ -pp_alarm pp.c /^pp_alarm(ARGS)$/ -pp_and pp.c /^pp_and(ARGS)$/ -pp_array pp.c /^pp_array(ARGS)$/ -pp_aslice pp.c /^pp_aslice(ARGS)$/ -pp_assign pp.c /^pp_assign(ARGS)$/ -pp_atan pp.c /^pp_atan(ARGS)$/ -pp_bind pp.c /^pp_bind(ARGS)$/ -pp_binmode pp.c /^pp_binmode(ARGS)$/ -pp_bit_and pp.c /^pp_bit_and(ARGS)$/ -pp_bit_or pp.c /^pp_bit_or(ARGS)$/ -pp_caller pp.c /^pp_caller(ARGS)$/ -pp_chdir pp.c /^pp_chdir(ARGS)$/ -pp_chmod pp.c /^pp_chmod(ARGS)$/ -pp_chop pp.c /^pp_chop(ARGS)$/ -pp_chown pp.c /^pp_chown(ARGS)$/ -pp_chroot pp.c /^pp_chroot(ARGS)$/ -pp_close pp.c /^pp_close(ARGS)$/ -pp_closedir pp.c /^pp_closedir(ARGS)$/ -pp_comma pp.c /^pp_comma(ARGS)$/ -pp_complement pp.c /^pp_complement(ARGS)$/ -pp_concat pp.c /^pp_concat(ARGS)$/ -pp_cond_expr pp.c /^pp_cond_expr(ARGS)$/ -pp_connect pp.c /^pp_connect(ARGS)$/ -pp_cos pp.c /^pp_cos(ARGS)$/ -pp_crypt pp.c /^pp_crypt(ARGS)$/ -pp_dbmclose pp.c /^pp_dbmclose(ARGS)$/ -pp_dbmopen pp.c /^pp_dbmopen(ARGS)$/ -pp_dbsubr pp.c /^pp_dbsubr(ARGS)$/ -pp_defined pp.c /^pp_defined(ARGS)$/ -pp_delete pp.c /^pp_delete(ARGS)$/ -pp_die pp.c /^pp_die(ARGS)$/ -pp_divide pp.c /^pp_divide(ARGS)$/ -pp_dofile pp.c /^pp_dofile(ARGS)$/ -pp_dump pp.c /^pp_dump(ARGS)$/ -pp_each pp.c /^pp_each(ARGS)$/ -pp_egrent pp.c /^pp_egrent(ARGS)$/ -pp_ehostent pp.c /^pp_ehostent(ARGS)$/ -pp_enetent pp.c /^pp_enetent(ARGS)$/ -pp_eof pp.c /^pp_eof(ARGS)$/ -pp_eprotoent pp.c /^pp_eprotoent(ARGS)$/ -pp_epwent pp.c /^pp_epwent(ARGS)$/ -pp_eq pp.c /^pp_eq(ARGS)$/ -pp_eservent pp.c /^pp_eservent(ARGS)$/ -pp_eval pp.c /^pp_eval(ARGS)$/ -pp_evalonce pp.c /^pp_evalonce(ARGS)$/ -pp_exec_op pp.c /^pp_exec_op(ARGS)$/ -pp_exit pp.c /^pp_exit(ARGS)$/ -pp_exp pp.c /^pp_exp(ARGS)$/ -pp_f_or_r pp.c /^pp_f_or_r(ARGS)$/ -pp_fcntl pp.c /^pp_fcntl(ARGS)$/ -pp_fileno pp.c /^pp_fileno(ARGS)$/ -pp_flip pp.c /^pp_flip(ARGS)$/ -pp_flock pp.c /^pp_flock(ARGS)$/ -pp_flop pp.c /^pp_flop(ARGS)$/ -pp_fork pp.c /^pp_fork(ARGS)$/ -pp_ftatime pp.c /^pp_ftatime(ARGS)$/ -pp_ftbinary pp.c /^pp_ftbinary(ARGS)$/ -pp_ftblk pp.c /^pp_ftblk(ARGS)$/ -pp_ftchr pp.c /^pp_ftchr(ARGS)$/ -pp_ftctime pp.c /^pp_ftctime(ARGS)$/ -pp_ftdir pp.c /^pp_ftdir(ARGS)$/ -pp_fteexec pp.c /^pp_fteexec(ARGS)$/ -pp_fteowned pp.c /^pp_fteowned(ARGS)$/ -pp_fteread pp.c /^pp_fteread(ARGS)$/ -pp_ftewrite pp.c /^pp_ftewrite(ARGS)$/ -pp_ftfile pp.c /^pp_ftfile(ARGS)$/ -pp_ftis pp.c /^pp_ftis(ARGS)$/ -pp_ftlink pp.c /^pp_ftlink(ARGS)$/ -pp_ftmtime pp.c /^pp_ftmtime(ARGS)$/ -pp_ftpipe pp.c /^pp_ftpipe(ARGS)$/ -pp_ftrexec pp.c /^pp_ftrexec(ARGS)$/ -pp_ftrowned pp.c /^pp_ftrowned(ARGS)$/ -pp_ftrread pp.c /^pp_ftrread(ARGS)$/ -pp_ftrwrite pp.c /^pp_ftrwrite(ARGS)$/ -pp_ftsgid pp.c /^pp_ftsgid(ARGS)$/ -pp_ftsize pp.c /^pp_ftsize(ARGS)$/ -pp_ftsock pp.c /^pp_ftsock(ARGS)$/ -pp_ftsuid pp.c /^pp_ftsuid(ARGS)$/ -pp_ftsvtx pp.c /^pp_ftsvtx(ARGS)$/ -pp_fttext pp.c /^pp_fttext(ARGS)$/ -pp_fttty pp.c /^pp_fttty(ARGS)$/ -pp_ftzero pp.c /^pp_ftzero(ARGS)$/ -pp_ge pp.c /^pp_ge(ARGS)$/ -pp_getc pp.c /^pp_getc(ARGS)$/ -pp_getlogin pp.c /^pp_getlogin(ARGS)$/ -pp_getpeername pp.c /^pp_getpeername(ARGS)$/ -pp_getpgrp pp.c /^pp_getpgrp(ARGS)$/ -pp_getppid pp.c /^pp_getppid(ARGS)$/ -pp_getpriority pp.c /^pp_getpriority(ARGS)$/ -pp_getsockname pp.c /^pp_getsockname(ARGS)$/ -pp_ggrent pp.c /^pp_ggrent(ARGS)$/ -pp_ggrgid pp.c /^pp_ggrgid(ARGS)$/ -pp_ggrnam pp.c /^pp_ggrnam(ARGS)$/ -pp_ghbyaddr pp.c /^pp_ghbyaddr(ARGS)$/ -pp_ghbyname pp.c /^pp_ghbyname(ARGS)$/ -pp_ghostent pp.c /^pp_ghostent(ARGS)$/ -pp_gmtime pp.c /^pp_gmtime(ARGS)$/ -pp_gnbyaddr pp.c /^pp_gnbyaddr(ARGS)$/ -pp_gnbyname pp.c /^pp_gnbyname(ARGS)$/ -pp_gnetent pp.c /^pp_gnetent(ARGS)$/ -pp_goto pp.c /^pp_goto(ARGS)$/ -pp_gpbyname pp.c /^pp_gpbyname(ARGS)$/ -pp_gpbynumber pp.c /^pp_gpbynumber(ARGS)$/ -pp_gprotoent pp.c /^pp_gprotoent(ARGS)$/ -pp_gpwent pp.c /^pp_gpwent(ARGS)$/ -pp_gpwnam pp.c /^pp_gpwnam(ARGS)$/ -pp_gpwuid pp.c /^pp_gpwuid(ARGS)$/ -pp_grep pp.c /^pp_grep(ARGS)$/ -pp_gsbyname pp.c /^pp_gsbyname(ARGS)$/ -pp_gsbyport pp.c /^pp_gsbyport(ARGS)$/ -pp_gservent pp.c /^pp_gservent(ARGS)$/ -pp_gsockopt pp.c /^pp_gsockopt(ARGS)$/ -pp_gt pp.c /^pp_gt(ARGS)$/ -pp_hash pp.c /^pp_hash(ARGS)$/ -pp_helem pp.c /^pp_helem(ARGS)$/ -pp_hex pp.c /^pp_hex(ARGS)$/ -pp_hslice pp.c /^pp_hslice(ARGS)$/ -pp_index pp.c /^pp_index(ARGS)$/ -pp_int pp.c /^pp_int(ARGS)$/ -pp_ioctl pp.c /^pp_ioctl(ARGS)$/ -pp_item pp.c /^pp_item(ARGS)$/ -pp_item2 pp.c /^pp_item2(ARGS)$/ -pp_item3 pp.c /^pp_item3(ARGS)$/ -pp_join pp.c /^pp_join(ARGS)$/ -pp_keys pp.c /^pp_keys(ARGS)$/ -pp_kill pp.c /^pp_kill(ARGS)$/ -pp_laelem pp.c /^pp_laelem(ARGS)$/ -pp_larray pp.c /^pp_larray(ARGS)$/ -pp_laslice pp.c /^pp_laslice(ARGS)$/ -pp_last pp.c /^pp_last(ARGS)$/ -pp_le pp.c /^pp_le(ARGS)$/ -pp_left_shift pp.c /^pp_left_shift(ARGS)$/ -pp_length pp.c /^pp_length(ARGS)$/ -pp_lhash pp.c /^pp_lhash(ARGS)$/ -pp_lhelem pp.c /^pp_lhelem(ARGS)$/ -pp_lhslice pp.c /^pp_lhslice(ARGS)$/ -pp_link pp.c /^pp_link(ARGS)$/ -pp_list pp.c /^pp_list(ARGS)$/ -pp_listen pp.c /^pp_listen(ARGS)$/ -pp_local pp.c /^pp_local(ARGS)$/ -pp_localtime pp.c /^pp_localtime(ARGS)$/ -pp_log pp.c /^pp_log(ARGS)$/ -pp_lslice pp.c /^pp_lslice(ARGS)$/ -pp_lstat pp.c /^pp_lstat(ARGS)$/ -pp_lt pp.c /^pp_lt(ARGS)$/ -pp_match pp.c /^pp_match(ARGS)$/ -pp_mkdir pp.c /^pp_mkdir(ARGS)$/ -pp_modulo pp.c /^pp_modulo(ARGS)$/ -pp_msgctl pp.c /^pp_msgctl(ARGS)$/ -pp_msgget pp.c /^pp_msgget(ARGS)$/ -pp_msgrcv pp.c /^pp_msgrcv(ARGS)$/ -pp_msgsnd pp.c /^pp_msgsnd(ARGS)$/ -pp_multiply pp.c /^pp_multiply(ARGS)$/ -pp_ncmp pp.c /^pp_ncmp(ARGS)$/ -pp_ne pp.c /^pp_ne(ARGS)$/ -pp_negate pp.c /^pp_negate(ARGS)$/ -pp_next pp.c /^pp_next(ARGS)$/ -pp_nmatch pp.c /^pp_nmatch(ARGS)$/ -pp_not pp.c /^pp_not(ARGS)$/ -pp_nsubst pp.c /^pp_nsubst(ARGS)$/ -pp_ntrans pp.c /^pp_ntrans(ARGS)$/ -pp_null pp.c /^pp_null(ARGS)$/ -pp_oct pp.c /^pp_oct(ARGS)$/ -pp_open pp.c /^pp_open(ARGS)$/ -pp_open_dir pp.c /^pp_open_dir(ARGS)$/ -pp_or pp.c /^pp_or(ARGS)$/ -pp_ord pp.c /^pp_ord(ARGS)$/ -pp_pack pp.c /^pp_pack(ARGS)$/ -pp_pipe_op pp.c /^pp_pipe_op(ARGS)$/ -pp_pop pp.c /^pp_pop(ARGS)$/ -pp_pow pp.c /^pp_pow(ARGS)$/ -pp_print pp.c /^pp_print(ARGS)$/ -pp_prtf pp.c /^pp_prtf(ARGS)$/ -pp_push pp.c /^pp_push(ARGS)$/ -pp_rand pp.c /^pp_rand(ARGS)$/ -pp_range pp.c /^pp_range(ARGS)$/ -pp_rcat pp.c /^pp_rcat(ARGS)$/ -pp_read pp.c /^pp_read(ARGS)$/ -pp_readdir pp.c /^pp_readdir(ARGS)$/ -pp_readlink pp.c /^pp_readlink(ARGS)$/ -pp_recv pp.c /^pp_recv(ARGS)$/ -pp_redo pp.c /^pp_redo(ARGS)$/ -pp_rename pp.c /^pp_rename(ARGS)$/ -pp_repeat pp.c /^pp_repeat(ARGS)$/ -pp_require pp.c /^pp_require(ARGS)$/ -pp_reset pp.c /^pp_reset(ARGS)$/ -pp_return pp.c /^pp_return(ARGS)$/ -pp_reverse pp.c /^pp_reverse(ARGS)$/ -pp_rewinddir pp.c /^pp_rewinddir(ARGS)$/ -pp_right_shift pp.c /^pp_right_shift(ARGS)$/ -pp_rindex pp.c /^pp_rindex(ARGS)$/ -pp_rmdir pp.c /^pp_rmdir(ARGS)$/ -pp_sassign pp.c /^pp_sassign(ARGS)$/ -pp_scalar pp.c /^pp_scalar(ARGS)$/ -pp_scmp pp.c /^pp_scmp(ARGS)$/ -pp_seek pp.c /^pp_seek(ARGS)$/ -pp_seekdir pp.c /^pp_seekdir(ARGS)$/ -pp_select pp.c /^pp_select(ARGS)$/ -pp_semctl pp.c /^pp_semctl(ARGS)$/ -pp_semget pp.c /^pp_semget(ARGS)$/ -pp_semop pp.c /^pp_semop(ARGS)$/ -pp_send pp.c /^pp_send(ARGS)$/ -pp_seq pp.c /^pp_seq(ARGS)$/ -pp_setpgrp pp.c /^pp_setpgrp(ARGS)$/ -pp_setpriority pp.c /^pp_setpriority(ARGS)$/ -pp_sge pp.c /^pp_sge(ARGS)$/ -pp_sgrent pp.c /^pp_sgrent(ARGS)$/ -pp_sgt pp.c /^pp_sgt(ARGS)$/ -pp_shift pp.c /^pp_shift(ARGS)$/ -pp_shmctl pp.c /^pp_shmctl(ARGS)$/ -pp_shmget pp.c /^pp_shmget(ARGS)$/ -pp_shmread pp.c /^pp_shmread(ARGS)$/ -pp_shmwrite pp.c /^pp_shmwrite(ARGS)$/ -pp_shostent pp.c /^pp_shostent(ARGS)$/ -pp_shutdown pp.c /^pp_shutdown(ARGS)$/ -pp_sin pp.c /^pp_sin(ARGS)$/ -pp_sle pp.c /^pp_sle(ARGS)$/ -pp_sleep pp.c /^pp_sleep(ARGS)$/ -pp_slt pp.c /^pp_slt(ARGS)$/ -pp_sne pp.c /^pp_sne(ARGS)$/ -pp_snetent pp.c /^pp_snetent(ARGS)$/ -pp_socket pp.c /^pp_socket(ARGS)$/ -pp_sockpair pp.c /^pp_sockpair(ARGS)$/ -pp_sort pp.c /^pp_sort(ARGS)$/ -pp_splice pp.c /^pp_splice(ARGS)$/ -pp_split pp.c /^pp_split(ARGS)$/ -pp_sprintf pp.c /^pp_sprintf(ARGS)$/ -pp_sprotoent pp.c /^pp_sprotoent(ARGS)$/ -pp_spwent pp.c /^pp_spwent(ARGS)$/ -pp_sqrt pp.c /^pp_sqrt(ARGS)$/ -pp_srand pp.c /^pp_srand(ARGS)$/ -pp_sselect pp.c /^pp_sselect(ARGS)$/ -pp_sservent pp.c /^pp_sservent(ARGS)$/ -pp_ssockopt pp.c /^pp_ssockopt(ARGS)$/ -pp_stat pp.c /^pp_stat(ARGS)$/ -pp_study pp.c /^pp_study(ARGS)$/ -pp_subr pp.c /^pp_subr(ARGS)$/ -pp_subst pp.c /^pp_subst(ARGS)$/ -pp_substr pp.c /^pp_substr(ARGS)$/ -pp_subtract pp.c /^pp_subtract(ARGS)$/ -pp_symlink pp.c /^pp_symlink(ARGS)$/ -pp_syscall pp.c /^pp_syscall(ARGS)$/ -pp_sysread pp.c /^pp_sysread(ARGS)$/ -pp_system pp.c /^pp_system(ARGS)$/ -pp_syswrite pp.c /^pp_syswrite(ARGS)$/ -pp_tell pp.c /^pp_tell(ARGS)$/ -pp_telldir pp.c /^pp_telldir(ARGS)$/ -pp_time pp.c /^pp_time(ARGS)$/ -pp_tms pp.c /^pp_tms(ARGS)$/ -pp_trans pp.c /^pp_trans(ARGS)$/ -pp_truncate pp.c /^pp_truncate(ARGS)$/ -pp_try pp.c /^pp_try(ARGS)$/ -pp_umask pp.c /^pp_umask(ARGS)$/ -pp_undef pp.c /^pp_undef(ARGS)$/ -pp_unlink pp.c /^pp_unlink(ARGS)$/ -pp_unpack pp.c /^pp_unpack(ARGS)$/ -pp_unshift pp.c /^pp_unshift(ARGS)$/ -pp_utime pp.c /^pp_utime(ARGS)$/ -pp_values pp.c /^pp_values(ARGS)$/ -pp_vec pp.c /^pp_vec(ARGS)$/ -pp_wait pp.c /^pp_wait(ARGS)$/ -pp_waitpid pp.c /^pp_waitpid(ARGS)$/ -pp_warn pp.c /^pp_warn(ARGS)$/ -pp_write pp.c /^pp_write(ARGS)$/ -pp_xor pp.c /^pp_xor(ARGS)$/ -rcatmaybe consarg.c /^rcatmaybe(arg)$/ -realloc malloc.c /^realloc(mp, nbytes)$/ -reg regcomp.c /^reg(paren, flagp)$/ -reganode regcomp.c /^reganode(op, arg)$/ -regatom regcomp.c /^regatom(flagp)$/ -regbranch regcomp.c /^regbranch(flagp)$/ -regc regcomp.c /^regc(b)$/ -regclass regcomp.c /^regclass()$/ -regcomp regcomp.c /^regcomp(exp,xend,fold)$/ -regcurly regcomp.c /^regcurly(s)$/ -regdump regcomp.c /^regdump(r)$/ -regexec regexec.c /^regexec(prog, stringarg, strend, strbeg, minend, s/ -regfree regcomp.c /^regfree(r)$/ -reginsert regcomp.c /^reginsert(op, opnd)$/ -regmatch regexec.c /^regmatch(prog)$/ -regnext regexec.c /^regnext(p)$/ -regnode regcomp.c /^regnode(op)$/ -regoptail regcomp.c /^regoptail(p, val)$/ -regpiece regcomp.c /^regpiece(flagp)$/ -regprop regcomp.c /^regprop(op)$/ -regrepeat regexec.c /^regrepeat(p, max)$/ -regset regcomp.c /^regset(bits,def,c)$/ -regtail regcomp.c /^regtail(p, val)$/ -regtry regexec.c /^regtry(prog, string)$/ -repeatcpy util.c /^repeatcpy(to,from,len,count)$/ -restorelist cmd.c /^restorelist(base)$/ -rninstr util.c /^rninstr(big, bigend, little, lend)$/ -safefree util.c /^safefree(where)$/ -safemalloc util.c /^safemalloc(size)$/ -saferealloc util.c /^saferealloc(where,size)$/ -safexfree util.c /^safexfree(where)$/ -safexmalloc util.c /^safexmalloc(x,size)$/ -safexrealloc util.c /^safexrealloc(where,size)$/ -same_dirent util.c /^same_dirent(a,b)$/ -saveaptr cmd.c /^saveaptr(aptr)$/ -saveary cmd.c /^saveary(stab)$/ -savehash cmd.c /^savehash(stab)$/ -savehptr cmd.c /^savehptr(hptr)$/ -saveint cmd.c /^saveint(intp)$/ -saveitem cmd.c /^saveitem(item)$/ -savelines perl.c /^savelines(array, str)$/ -savelist cmd.c /^savelist(sarg,maxsarg)$/ -savelong cmd.c /^savelong(longp)$/ -savenostab cmd.c /^savenostab(stab)$/ -savesptr cmd.c /^savesptr(sptr)$/ -savestr util.c /^savestr(str)$/ -scanconst toke.c /^scanconst(spat,string,len)$/ -scanhex util.c /^scanhex(start, len, retlen)$/ -scanident toke.c /^scanident(s,send,dest)$/ -scanoct util.c /^scanoct(start, len, retlen)$/ -scanpat toke.c /^scanpat(s)$/ -scanstr toke.c /^scanstr(start, in_what)$/ -scansubst toke.c /^scansubst(start)$/ -scantrans toke.c /^scantrans(start)$/ -screaminstr util.c /^screaminstr(bigstr, littlestr)$/ -set_csh toke.c /^set_csh()$/ -sighandler stab.c /^sighandler(sig)$/ -skipspace toke.c /^skipspace(s)$/ -sortcmp dolist.c /^sortcmp(strp1,strp2)$/ -sortsub dolist.c /^sortsub(str1,str2)$/ -spat_common consarg.c /^spat_common(spat,exprnum,marking)$/ -spat_free cons.c /^spat_free(spat)$/ -spat_tosave cons.c /^spat_tosave(spat)$/ -stab2arg consarg.c /^stab2arg(atype,stab)$/ -stab_array stab.c /^ARRAY *stab_array(stab)$/ -stab_check stab.c /^stab_check(min,max)$/ -stab_clear stab.c /^stab_clear(stab)$/ -stab_efullname stab.c /^stab_efullname(str,stab)$/ -stab_fullname stab.c /^stab_fullname(str,stab)$/ -stab_hash stab.c /^HASH *stab_hash(stab)$/ -stab_len stab.c /^stab_len(str)$/ -stab_str stab.c /^stab_str(str)$/ -stabent stab.c /^stabent(name,add)$/ -stabset stab.c /^stabset(mstr,str)$/ -stio_new stab.c /^stio_new()$/ -str_2mortal str.c /^str_2mortal(str)$/ -str_2num str.c /^str_2num(str)$/ -str_2ptr str.c /^str_2ptr(str)$/ -str_append_till str.c /^str_append_till(str,from,fromend,delim,keeplist)$/ -str_cat str.c /^str_cat(str,ptr)$/ -str_chop str.c /^str_chop(str,ptr) \/* like set but assuming ptr is / -str_cmp str.c /^str_cmp(str1,str2)$/ -str_dec str.c /^str_dec(str)$/ -str_eq str.c /^str_eq(str1,str2)$/ -str_free str.c /^str_free(str)$/ -str_get str.c /^str_get(str)$/ -str_gets str.c /^str_gets(str,fp,append)$/ -str_gnum str.c /^double str_gnum(Str)$/ -str_grow str.c /^str_grow(str,newlen)$/ -str_inc str.c /^str_inc(str)$/ -str_insert str.c /^str_insert(bigstr,offset,len,little,littlelen)$/ -str_len str.c /^str_len(str)$/ -str_magic str.c /^str_magic(str, stab, how, name, namlen)$/ -str_make str.c /^str_make(s,len)$/ -str_mortal str.c /^str_mortal(oldstr)$/ -str_ncat str.c /^str_ncat(str,ptr,len)$/ -str_new str.c /^str_new(x,len)$/ -str_nmake str.c /^str_nmake(n)$/ -str_nset str.c /^str_nset(str,ptr,len)$/ -str_numset str.c /^str_numset(str,num)$/ -str_replace str.c /^str_replace(str,nstr)$/ -str_reset str.c /^str_reset(s,stash)$/ -str_scat str.c /^str_scat(dstr,sstr)$/ -str_set str.c /^str_set(str,ptr)$/ -str_smake str.c /^str_smake(old)$/ -str_sset str.c /^str_sset(dstr,sstr)$/ -str_true str.c /^str_true(Str)$/ -switch pp.c /^ switch (optype) {$/ -taintenv str.c /^taintenv()$/ -taintproper str.c /^taintproper(s)$/ -ucase str.c /^ucase(s,send)$/ -uni toke.c /^uni(f,s)$/ -unlnk util.c /^unlnk(f) \/* unlink all versions of a file *\/$/ -userinit usersub.c /^userinit()$/ -validate_suid perl.c /^validate_suid(validarg)$/ -vfprintf util.c /^vfprintf(fd, pat, args)$/ -vsprintf util.c /^vsprintf(dest, pat, args)$/ -wait4pid util.c /^wait4pid(pid,statusp,flags)$/ -warn util.c /^void warn(pat,a1,a2,a3,a4)$/ -whichsig stab.c /^whichsig(sig)$/ -while_io cons.c /^while_io(cmd)$/ -wopt cons.c /^wopt(cmd)$/ -xstat util.c /^xstat()$/ -yyerror cons.c /^yyerror(s)$/ -yylex toke.c /^yylex()$/ -yyparse perly.c /^yyparse()$/ @@ -1,3 +1,9 @@ +/* + * "...we will have peace, when you and all your works have perished--and + * the works of your dark master to whom you would deliver us. You are a + * liar, Saruman, and a corrupter of men's hearts." --Theoden + */ + #include "EXTERN.h" #include "perl.h" @@ -47,14 +53,14 @@ taint_env() if (!svp || *svp == &sv_undef || (mg = mg_find(*svp, 't'))) { tainted = 1; if (mg && MgTAINTEDDIR(mg)) - taint_proper("Insecure directory in %s%s", "PATH"); + taint_proper("Insecure directory in %s%s", "$ENV{PATH}"); else - taint_proper("Insecure %s%s", "PATH"); + taint_proper("Insecure %s%s", "$ENV{PATH}"); } svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE); if (svp && *svp != &sv_undef && mg_find(*svp, 't')) { tainted = 1; - taint_proper("Insecure %s%s", "IFS"); + taint_proper("Insecure %s%s", "$ENV{IFS}"); } } } diff --git a/test.data b/test.data deleted file mode 100644 index 3c138f90a3..0000000000 --- a/test.data +++ /dev/null @@ -1,6 +0,0 @@ -foo --- -bar --- -baz --- diff --git a/test.pl b/test.pl deleted file mode 100644 index c3eeb03629..0000000000 --- a/test.pl +++ /dev/null @@ -1,6 +0,0 @@ -$* = 1; -undef $/; -$input = <>; -@records = split(/^--\n/, $input); -print @records + 0, "\n"; -print $records[0], "\n"; diff --git a/tiearray b/tiearray deleted file mode 100755 index b765a853d5..0000000000 --- a/tiearray +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -{ - package Any_DBM_File; - @ISA = (NDBM_File, ODBM_File, GDBM_File, SDBM_File, DB_File, DBZ_File); -} -{ - package FAKEARRAY; - sub new { print "new @_\n"; bless ['foo'] } - sub fetch { print "fetch @_\n"; $_[0]->[$_[1]] } - sub store { print "store @_\n"; $_[0]->[$_[1]] = $_[2] } - sub DESTROY { print "DESTROY @_\n"; undef @{$_[0]}; } -} - -tie @h, FAKEARRAY, ONE, TWO, THREE; - -$h[1] = 'bar'; -$h[2] = 'baz'; -print $h[0], "\n"; -print $h[1], "\n"; -print $h[2], "\n"; - -untie @h; - diff --git a/tiedbm b/tiedbm deleted file mode 100755 index 8a675aa4be..0000000000 --- a/tiedbm +++ /dev/null @@ -1,34 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -{ - package Any_DBM_File; - @ISA = (NDBM_File, ODBM_File, GDBM_File, SDBM_File, DB_File, DBZ_File); -} -{ - package XDBM_File; - sub new { print "new @_\n"; bless {FOO => 'foo'} } - sub fetch { print "fetch @_\n"; $_[0]->{$_[1]} } - sub store { print "store @_\n"; $_[0]->{$_[1]} = $_[2] } - sub delete { print "delete @_\n"; delete ${$_[0]}{$_[1]} } - sub DESTROY { print "DESTROY @_\n"; undef %{$_[0]}; } -} - -init SDBM_File; - -tie %h, SDBM_File, 'Op.sdbm', 0x202, 0640; - -$h{BAR} = 'bar'; -$h{FOO} = 'foo'; -#print $h{BAR}, "\n"; -#delete $h{BAR}; -#print $h{BAR}, "\n"; - -while (($key,$val) = each %h) { print "$key => $val\n"; } -@keys = sort keys %h; -@values = sort values %h; -print "@keys\n@values\n"; - -untie %h; - diff --git a/tiescalar b/tiescalar deleted file mode 100755 index ab92a2e333..0000000000 --- a/tiescalar +++ /dev/null @@ -1,20 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ -{ - package SOMEPACK; - sub new { local($x); bless \$x } - sub fetch { warn "fetch @_\n"; ${$_[0]} } - sub store { warn "store @_\n"; ${$_[0]} = $_[1] } - sub DESTROY { warn "DESTROY @_\n" } -} - -tie $h, SOMEPACK; - -$h = 'bar'; -print $h, "\n"; - -untie $h; -1; - - @@ -1,99 +1,64 @@ -/* $RCSfile: toke.c,v $$Revision: 4.1 $$Date: 92/08/07 18:28:39 $ +/* toke.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: toke.c,v $ - * Revision 4.1 92/08/07 18:28:39 lwall - * - * Revision 4.0.1.7 92/06/11 21:16:30 lwall - * patch34: expect incorrectly set to indicate start of program or block - * - * Revision 4.0.1.6 92/06/08 16:03:49 lwall - * patch20: an EXPR may now start with a bareword - * patch20: print $fh EXPR can now expect term rather than operator in EXPR - * patch20: added ... as variant on .. - * patch20: new warning on spurious backslash - * patch20: new warning on missing $ for foreach variable - * patch20: "foo"x1024 now legal without space after x - * patch20: new warning on print accidentally used as function - * patch20: tr/stuff// wasn't working right - * patch20: 2. now eats the dot - * patch20: <@ARGV> now notices @ARGV - * patch20: tr/// now lets you say \- - * - * Revision 4.0.1.5 91/11/11 16:45:51 lwall - * patch19: default arg for shift was wrong after first subroutine definition - * - * Revision 4.0.1.4 91/11/05 19:02:48 lwall - * patch11: \x and \c were subject to double interpretation in regexps - * patch11: prepared for ctype implementations that don't define isascii() - * patch11: nested list operators could miscount parens - * patch11: once-thru blocks didn't display right in the debugger - * patch11: sort eval "whatever" didn't work - * patch11: underscore is now allowed within literal octal and hex numbers - * - * Revision 4.0.1.3 91/06/10 01:32:26 lwall - * patch10: m'$foo' now treats string as single quoted - * patch10: certain pattern optimizations were botched - * - * Revision 4.0.1.2 91/06/07 12:05:56 lwall - * patch4: new copyright notice - * patch4: debugger lost track of lines in eval - * patch4: //o and s///o now optimize themselves fully at runtime - * patch4: added global modifier for pattern matches - * - * Revision 4.0.1.1 91/04/12 09:18:18 lwall - * patch1: perl -de "print" wouldn't stop at the first statement - * - * Revision 4.0 91/03/20 01:42:14 lwall - * 4.0 baseline. - * + */ + +/* + * "It all comes from here, the stench and the peril." --Frodo */ #include "EXTERN.h" #include "perl.h" -#include "perly.h" -static void set_csh(); +static void check_uni _((void)); +static void force_next _((I32 type)); +static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick)); +static SV *q _((SV *sv)); +static char *scan_const _((char *start)); +static char *scan_formline _((char *s)); +static char *scan_heredoc _((char *s)); +static char *scan_ident _((char *s, char *send, char *dest, I32 ck_uni)); +static char *scan_inputsymbol _((char *start)); +static char *scan_pat _((char *start)); +static char *scan_str _((char *start)); +static char *scan_subst _((char *start)); +static char *scan_trans _((char *start)); +static char *scan_word _((char *s, char *dest, int allow_package, STRLEN *slp)); +static char *skipspace _((char *s)); +static void checkcomma _((char *s, char *name, char *what)); +static void force_ident _((char *s, int kind)); +static void incline _((char *s)); +static int intuit_method _((char *s, GV *gv)); +static int intuit_more _((char *s)); +static I32 lop _((I32 f, expectation x, char *s)); +static void missingterm _((char *s)); +static void no_op _((char *what, char *s)); +static void set_csh _((void)); +static I32 sublex_done _((void)); +static I32 sublex_start _((void)); +#ifdef CRIPPLED_CC +static int uni _((I32 f, char *s)); +#endif /* The following are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). */ -#define LEX_NORMAL 8 -#define LEX_INTERPNORMAL 7 -#define LEX_INTERPCASEMOD 6 -#define LEX_INTERPSTART 5 -#define LEX_INTERPEND 4 -#define LEX_INTERPENDMAYBE 3 -#define LEX_INTERPCONCAT 2 -#define LEX_INTERPCONST 1 +#define LEX_NORMAL 9 +#define LEX_INTERPNORMAL 8 +#define LEX_INTERPCASEMOD 7 +#define LEX_INTERPSTART 6 +#define LEX_INTERPEND 5 +#define LEX_INTERPENDMAYBE 4 +#define LEX_INTERPCONCAT 3 +#define LEX_INTERPCONST 2 +#define LEX_FORMLINE 1 #define LEX_KNOWNEXT 0 -static U32 lex_state = LEX_NORMAL; /* next token is determined */ -static U32 lex_defer; /* state after determined token */ -static expectation lex_expect; /* expect after determined token */ -static I32 lex_brackets; /* bracket count */ -static I32 lex_formbrack; /* bracket count at outer format level */ -static I32 lex_fakebrack; /* outer bracket is mere delimiter */ -static I32 lex_casemods; /* casemod count */ -static I32 lex_dojoin; /* doing an array interpolation */ -static I32 lex_starts; /* how many interps done on level */ -static SV * lex_stuff; /* runtime pattern from m// or s/// */ -static SV * lex_repl; /* runtime replacement from s/// */ -static OP * lex_op; /* extra info to pass back on op */ -static I32 lex_inpat; /* in pattern $) and $| are special */ -static I32 lex_inwhat; /* what kind of quoting are we in */ -static char * lex_brackstack; /* what kind of brackets to pop */ - -/* What we know when we're in LEX_KNOWNEXT state. */ -static YYSTYPE nextval[5]; /* value of next token, if any */ -static I32 nexttype[5]; /* type of next token */ -static I32 nexttoke = 0; - #ifdef I_FCNTL #include <fcntl.h> #endif @@ -112,28 +77,24 @@ static I32 nexttoke = 0; #endif #define CLINE (copline = (curcop->cop_line < copline ? curcop->cop_line : copline)) -#ifdef atarist -#define PERL_META(c) ((c) | 128) -#else -#define META(c) ((c) | 128) -#endif - #define TOKEN(retval) return (bufptr = s,(int)retval) #define OPERATOR(retval) return (expect = XTERM,bufptr = s,(int)retval) +#define AOPERATOR(retval) return ao((expect = XTERM,bufptr = s,(int)retval)) #define PREBLOCK(retval) return (expect = XBLOCK,bufptr = s,(int)retval) +#define PRETERMBLOCK(retval) return (expect = XTERMBLOCK,bufptr = s,(int)retval) #define PREREF(retval) return (expect = XREF,bufptr = s,(int)retval) #define TERM(retval) return (CLINE, expect = XOPERATOR,bufptr = s,(int)retval) #define LOOPX(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LOOPEX) #define FTST(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)UNIOP) #define FUN0(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC0) #define FUN1(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC1) -#define BOop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP) -#define BAop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP) -#define SHop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP) -#define PWop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP) +#define BOop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP)) +#define BAop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP)) +#define SHop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP)) +#define PWop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP)) #define PMop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MATCHOP) -#define Aop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP) -#define Mop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP) +#define Aop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP)) +#define Mop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP)) #define Eop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)EQOP) #define Rop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)RELOP) @@ -144,6 +105,7 @@ static I32 nexttoke = 0; expect = XTERM, \ bufptr = s, \ last_uni = oldbufptr, \ + last_lop_op = f, \ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) ) #define UNIBRACK(f) return(yylval.ival = f, \ @@ -151,18 +113,26 @@ static I32 nexttoke = 0; last_uni = oldbufptr, \ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) ) -/* This does similarly for list operators */ -#define LOP(f) return(yylval.ival = f, \ - CLINE, \ - expect = XREF, \ - bufptr = s, \ - last_lop = oldbufptr, \ - last_lop_op = f, \ - (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC : (int)LSTOP) ) - /* grandfather return to old style */ #define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP) +static cryptswitch_t cryptswitch_fp = NULL; + +static int +ao(toketype) +int toketype; +{ + if (*bufptr == '=') { + bufptr++; + if (toketype == ANDAND) + yylval.ival = OP_ANDASSIGN; + else if (toketype == OROR) + yylval.ival = OP_ORASSIGN; + toketype = ASSIGNOP; + } + return toketype; +} + static void no_op(what, s) char *what; @@ -173,8 +143,8 @@ char *s; bufptr = s; sprintf(tmpbuf, "%s found where operator expected", what); yywarn(tmpbuf); - if (bufptr == SvPVX(linestr)) - warn("\t(Missing semicolon on previous line?)\n", what); + if (oldbufptr == SvPVX(linestr)) + warn("\t(Missing semicolon on previous line?)\n"); bufptr = oldbufptr; } @@ -206,6 +176,20 @@ char *s; } void +deprecate(s) +char *s; +{ + if (dowarn) + warn("Use of %s is deprecated", s); +} + +static void +depcom() +{ + deprecate("comma-less variable list"); +} + +void lex_start(line) SV *line; { @@ -218,7 +202,7 @@ SV *line; SAVEINT(lex_casemods); SAVEINT(lex_starts); SAVEINT(lex_state); - SAVEINT(lex_inpat); + SAVESPTR(lex_inpat); SAVEINT(lex_inwhat); SAVEINT(curcop->cop_line); SAVEPPTR(bufptr); @@ -227,6 +211,7 @@ SV *line; SAVEPPTR(oldoldbufptr); SAVESPTR(linestr); SAVEPPTR(lex_brackstack); + SAVEPPTR(lex_casestack); SAVESPTR(rsfp); lex_state = LEX_NORMAL; @@ -234,11 +219,12 @@ SV *line; expect = XSTATE; lex_brackets = 0; lex_fakebrack = 0; - if (lex_brackstack) - SAVEPPTR(lex_brackstack); New(899, lex_brackstack, 120, char); + New(899, lex_casestack, 12, char); SAVEFREEPV(lex_brackstack); + SAVEFREEPV(lex_casestack); lex_casemods = 0; + *lex_casestack = '\0'; lex_dojoin = 0; lex_starts = 0; if (lex_stuff) @@ -254,7 +240,7 @@ SV *line; linestr = sv_2mortal(newSVsv(linestr)); s = SvPV(linestr, len); if (len && s[len-1] != ';') { - if (!(SvFLAGS(linestr) & SVs_TEMP)); + if (!(SvFLAGS(linestr) & SVs_TEMP)) linestr = sv_2mortal(newSVsv(linestr)); sv_catpvn(linestr, "\n;", 2); } @@ -332,13 +318,19 @@ register char *s; if (s < bufend) s++; } - if (s < bufend || !rsfp) + if (s < bufend || !rsfp || lex_state != LEX_NORMAL) return s; if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) { - sv_setpv(linestr,";"); + if (minus_n || minus_p) { + sv_setpv(linestr,minus_p ? ";}continue{print" : ""); + sv_catpv(linestr,";}"); + minus_n = minus_p = 0; + } + else + sv_setpv(linestr,";"); oldoldbufptr = oldbufptr = bufptr = s = SvPVX(linestr); - bufend = s+1; - if (preprocess) + bufend = SvPVX(linestr) + SvCUR(linestr); + if (preprocess && !in_eval) (void)my_pclose(rsfp); else if ((FILE*)rsfp == stdin) clearerr(stdin); @@ -349,6 +341,7 @@ register char *s; } oldoldbufptr = oldbufptr = bufptr = s; bufend = bufptr + SvCUR(linestr); + incline(s); if (perldb && curstash != debstash) { SV *sv = NEWSV(85,0); @@ -356,7 +349,6 @@ register char *s; sv_setsv(sv,linestr); av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv); } - incline(s); } } @@ -364,12 +356,15 @@ static void check_uni() { char *s; char ch; + char *t; if (oldoldbufptr != last_uni) return; while (isSPACE(*last_uni)) last_uni++; for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ; + if ((t = strchr(s, '(')) && t < bufptr) + return; ch = *s; *s = '\0'; warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni); @@ -379,9 +374,7 @@ check_uni() { #ifdef CRIPPLED_CC #undef UNI -#undef LOP #define UNI(f) return uni(f,s) -#define LOP(f) return lop(f,s) static int uni(f,s) @@ -392,6 +385,7 @@ char *s; expect = XTERM; bufptr = s; last_uni = oldbufptr; + last_lop_op = f; if (*s == '(') return FUNC1; s = skipspace(s); @@ -401,17 +395,24 @@ char *s; return UNIOP; } +#endif /* CRIPPLED_CC */ + +#define LOP(f,x) return lop(f,x,s) + static I32 -lop(f,s) +lop(f,x,s) I32 f; +expectation x; char *s; { yylval.ival = f; CLINE; - expect = XREF; + expect = x; bufptr = s; last_lop = oldbufptr; last_lop_op = f; + if (nexttoke) + return LSTOP; if (*s == '(') return FUNC; s = skipspace(s); @@ -421,8 +422,6 @@ char *s; return LSTOP; } -#endif /* CRIPPLED_CC */ - static void force_next(type) I32 type; @@ -437,10 +436,11 @@ I32 type; } static char * -force_word(start,token,check_keyword,allow_tick) +force_word(start,token,check_keyword,allow_pack,allow_tick) register char *start; int token; int check_keyword; +int allow_pack; int allow_tick; { register char *s; @@ -448,8 +448,11 @@ int allow_tick; start = skipspace(start); s = start; - if (isIDFIRST(*s) || (allow_tick && (*s == '\'' || *s == ':'))) { - s = scan_word(s, tokenbuf, allow_tick, &len); + if (isIDFIRST(*s) || + (allow_pack && *s == ':') || + (allow_tick && *s == '\'') ) + { + s = scan_word(s, tokenbuf, allow_pack, &len); if (check_keyword && keyword(tokenbuf, len)) return start; if (token == METHOD) { @@ -470,12 +473,20 @@ int allow_tick; } static void -force_ident(s) +force_ident(s, kind) register char *s; +int kind; { if (s && *s) { nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0)); force_next(WORD); + if (kind) + gv_fetchpv(s, TRUE, + kind == '$' ? SVt_PV : + kind == '@' ? SVt_PVAV : + kind == '%' ? SVt_PVHV : + SVt_PVGV + ); } } @@ -486,23 +497,21 @@ SV *sv; register char *s; register char *send; register char *d; - register char delim; STRLEN len; if (!SvLEN(sv)) return sv; - s = SvPV(sv, len); + s = SvPV_force(sv, len); send = s + len; while (s < send && *s != '\\') s++; if (s == send) return sv; d = s; - delim = SvIVX(sv); while (s < send) { if (*s == '\\') { - if (s + 1 < send && (s[1] == '\\' || s[1] == delim)) + if (s + 1 < send && (s[1] == '\\')) s++; /* all that, just for this */ } *d++ = *s++; @@ -517,8 +526,6 @@ static I32 sublex_start() { register I32 op_type = yylval.ival; - SV *sv; - STRLEN len; if (op_type == OP_NULL) { yylval.opval = lex_op; @@ -538,7 +545,7 @@ sublex_start() SAVEINT(lex_casemods); SAVEINT(lex_starts); SAVEINT(lex_state); - SAVEINT(lex_inpat); + SAVESPTR(lex_inpat); SAVEINT(lex_inwhat); SAVEINT(curcop->cop_line); SAVEPPTR(bufptr); @@ -546,6 +553,7 @@ sublex_start() SAVEPPTR(oldoldbufptr); SAVESPTR(linestr); SAVEPPTR(lex_brackstack); + SAVEPPTR(lex_casestack); linestr = lex_stuff; lex_stuff = Nullsv; @@ -558,15 +566,18 @@ sublex_start() lex_brackets = 0; lex_fakebrack = 0; New(899, lex_brackstack, 120, char); + New(899, lex_casestack, 12, char); SAVEFREEPV(lex_brackstack); + SAVEFREEPV(lex_casestack); lex_casemods = 0; + *lex_casestack = '\0'; lex_starts = 0; lex_state = LEX_INTERPCONCAT; curcop->cop_line = multi_start; lex_inwhat = op_type; if (op_type == OP_MATCH || op_type == OP_SUBST) - lex_inpat = op_type; + lex_inpat = lex_op; else lex_inpat = 0; @@ -606,6 +617,7 @@ sublex_done() lex_brackets = 0; lex_fakebrack = 0; lex_casemods = 0; + *lex_casestack = '\0'; lex_starts = 0; if (SvCOMPILED(lex_repl)) { lex_state = LEX_INTERPNORMAL; @@ -638,7 +650,7 @@ char *start; I32 len; char *leave = lex_inpat - ? "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}" + ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]}" : (lex_inwhat & OP_TRANS) ? "" : ""; @@ -663,32 +675,36 @@ char *start; s++; } } - else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{", s[1]))) + else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1]))) break; else if (*s == '$') { if (!lex_inpat) /* not a regexp, so $ must be var */ break; - if (s + 1 < send && s[1] != ')' && s[1] != '|') + if (s + 1 < send && !strchr(")| \n\t", s[1])) break; /* in regexp, $ might be tail anchor */ } if (*s == '\\' && s+1 < send) { s++; +#ifdef NOTDEF if (*s == delim) { *d++ = *s++; continue; } +#endif if (*s && strchr(leave, *s)) { *d++ = '\\'; *d++ = *s++; continue; } if (lex_inwhat == OP_SUBST && !lex_inpat && - isDIGIT(*s) && !isDIGIT(s[1])) + isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { + if (dowarn) + warn("\\%c better written as $%c", *s, *s); *--s = '$'; break; } - if (lex_inwhat != OP_TRANS && *s && strchr("lLuUE", *s)) { + if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) { --s; break; } @@ -715,7 +731,7 @@ char *start; s++; *d = *s++; if (isLOWER(*d)) - *d = toupper(*d); + *d = toUPPER(*d); *d++ ^= 64; continue; case 'b': @@ -827,7 +843,7 @@ register char *s; weight -= seen[un_char] * 10; if (isALNUM(s[1])) { scan_ident(s,send,tmpbuf,FALSE); - if (strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV)) + if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV)) weight -= 100; else weight -= 10; @@ -890,7 +906,80 @@ register char *s; return TRUE; } -static char* exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK" }; +static int +intuit_method(start,gv) +char *start; +GV *gv; +{ + char *s = start + (*start == '$'); + char tmpbuf[1024]; + STRLEN len; + GV* indirgv; + + if (gv) { + if (GvIO(gv)) + return 0; + if (!GvCV(gv)) + gv = 0; + } + s = scan_word(s, tmpbuf, TRUE, &len); + if (*start == '$') { + if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf)) + return 0; + s = skipspace(s); + bufptr = start; + expect = XREF; + return *s == '(' ? FUNCMETH : METHOD; + } + if (!keyword(tmpbuf, len)) { + indirgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVCV); + 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, + newSVpv(tmpbuf,0)); + nextval[nexttoke].opval->op_private = + OPpCONST_BARE; + expect = XTERM; + force_next(WORD); + bufptr = s; + return *s == '(' ? FUNCMETH : METHOD; + } + } + return 0; +} + +static char* +incl_perldb() +{ + if (perldb) { + char *pdb = getenv("PERL5DB"); + + if (pdb) + return pdb; + return "BEGIN { require 'perl5db.pl' }"; + } + return ""; +} + + +/* Encrypted script support: cryptswitch_add() may be called to */ +/* define a function which may manipulate the input stream */ +/* (via popen() etc) to decode the input if required. */ +/* At the moment we only allow one cryptswitch function. */ +void +cryptswitch_add(funcp) + cryptswitch_t funcp; +{ + cryptswitch_fp = funcp; +} + + +static char* exp_name[] = + { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" }; extern int yychar; /* last token */ @@ -915,6 +1004,7 @@ yylex() if (!nexttoke) { lex_state = lex_defer; expect = lex_expect; + lex_defer = LEX_NORMAL; } return(nexttype[nexttoke]); @@ -924,26 +1014,40 @@ yylex() croak("panic: INTERPCASEMOD"); #endif if (bufptr == bufend || bufptr[1] == 'E') { - if (lex_casemods <= 1) { - if (bufptr != bufend) - bufptr += 2; - lex_state = LEX_INTERPSTART; - } + char oldmod; if (lex_casemods) { - --lex_casemods; + oldmod = lex_casestack[--lex_casemods]; + lex_casestack[lex_casemods] = '\0'; + if (bufptr != bufend && strchr("LUQ", oldmod)) { + bufptr += 2; + lex_state = LEX_INTERPCONCAT; + } return ')'; } + if (bufptr != bufend) + bufptr += 2; + lex_state = LEX_INTERPCONCAT; return yylex(); } - else if (lex_casemods) { - --lex_casemods; - return ')'; - } else { s = bufptr + 1; if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */ - ++lex_casemods; + if (strchr("LU", *s) && + (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U'))) + { + lex_casestack[--lex_casemods] = '\0'; + return ')'; + } + if (lex_casemods > 10) { + char* newlb = (char*)realloc(lex_casestack, lex_casemods + 2); + if (newlb != lex_casestack) { + SAVEFREEPV(newlb); + lex_casestack = newlb; + } + } + lex_casestack[lex_casemods++] = *s; + lex_casestack[lex_casemods] = '\0'; lex_state = LEX_INTERPCONCAT; nextval[nexttoke].ival = 0; force_next('('); @@ -955,6 +1059,8 @@ yylex() nextval[nexttoke].ival = OP_LC; else if (*s == 'U') nextval[nexttoke].ival = OP_UC; + else if (*s == 'Q') + nextval[nexttoke].ival = OP_QUOTEMETA; else croak("panic: yylex"); bufptr = s + 1; @@ -977,7 +1083,7 @@ yylex() if (lex_dojoin) { nextval[nexttoke].ival = 0; force_next(','); - force_ident("\""); + force_ident("\"", '$'); nextval[nexttoke].ival = 0; force_next('$'); nextval[nexttoke].ival = 0; @@ -1043,6 +1149,12 @@ yylex() } return yylex(); + case LEX_FORMLINE: + lex_state = LEX_NORMAL; + s = scan_formline(bufptr); + if (!lex_formbrack) + goto rightbracket; + OPERATOR(';'); } s = bufptr; @@ -1053,25 +1165,9 @@ yylex() } ) retry: -#ifdef BADSWITCH - if (*s & 128) { - if ((*s & 127) == '}') { - *s++ = '}'; - TOKEN('}'); - } - else - warn("Unrecognized character \\%03o ignored", *s++ & 255); - goto retry; - } -#endif switch (*s) { default: - if ((*s & 127) == '}') { - *s++ = '}'; - TOKEN('}'); - } - else - warn("Unrecognized character \\%03o ignored", *s++ & 255); + warn("Unrecognized character \\%03o ignored", *s++ & 255); goto retry; case 4: case 26: @@ -1086,18 +1182,15 @@ yylex() goto retry; /* ignore stray nulls */ last_uni = 0; last_lop = 0; - if (!preambled) { + if (!in_eval && !preambled) { preambled = TRUE; - sv_setpv(linestr,""); - if (perldb) { - char *pdb = getenv("PERLDB"); - - sv_catpv(linestr, pdb ? pdb : "BEGIN { require 'perldb.pl' }"); - } + sv_setpv(linestr,incl_perldb()); + if (autoboot_preamble) + sv_catpv(linestr, autoboot_preamble); if (minus_n || minus_p) { sv_catpv(linestr, "LINE: while (<>) {"); if (minus_l) - sv_catpv(linestr,"chop;"); + sv_catpv(linestr,"chomp;"); if (minus_a){ if (minus_F){ char tmpbuf1[50]; @@ -1113,18 +1206,27 @@ yylex() sv_catpv(linestr,"@F=split(' ');"); } } + sv_catpv(linestr, "\n"); oldoldbufptr = oldbufptr = s = SvPVX(linestr); bufend = SvPVX(linestr) + SvCUR(linestr); + if (perldb && curstash != debstash) { + SV *sv = NEWSV(85,0); + + sv_upgrade(sv, SVt_PVMG); + sv_setsv(sv,linestr); + av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv); + } goto retry; } -#ifdef CRYPTSCRIPT - cryptswitch(); -#endif /* CRYPTSCRIPT */ + /* Give cryptswitch a chance. Note that cryptswitch_fp may */ + /* be called several times owing to "goto retry;"'s below. */ + if (cryptswitch_fp) + rsfp = (*cryptswitch_fp)(rsfp); do { if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) { fake_eof: if (rsfp) { - if (preprocess) + if (preprocess && !in_eval) (void)my_pclose(rsfp); else if ((FILE*)rsfp == stdin) clearerr(stdin); @@ -1132,7 +1234,7 @@ yylex() (void)fclose(rsfp); rsfp = Nullfp; } - if (minus_n || minus_p) { + if (!in_eval && (minus_n || minus_p)) { sv_setpv(linestr,minus_p ? ";}continue{print" : ""); sv_catpv(linestr,";}"); oldoldbufptr = oldbufptr = s = SvPVX(linestr); @@ -1144,8 +1246,18 @@ yylex() sv_setpv(linestr,""); TOKEN(';'); /* not infinite loop because rsfp is NULL now */ } - if (doextract && *s == '#') - doextract = FALSE; + if (doextract) { + if (*s == '#' && s[1] == '!' && instr(s,"perl")) + doextract = FALSE; + + /* Incest with pod. */ + if (*s == '=' && strnEQ(s, "=cut", 4)) { + sv_setpv(linestr, ""); + oldoldbufptr = oldbufptr = s = SvPVX(linestr); + bufend = SvPVX(linestr) + SvCUR(linestr); + doextract = FALSE; + } + } incline(s); } while (doextract); oldoldbufptr = oldbufptr = bufptr = s; @@ -1160,10 +1272,10 @@ yylex() if (curcop->cop_line == 1) { while (s < bufend && isSPACE(*s)) s++; - if (*s == ':') /* for csh's that have to exec sh scripts */ + if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */ s++; - if (*s == '#' && s[1] == '!') { - if (!in_eval && !instr(s,"perl") && !instr(s,"indir") && + if (!in_eval && *s == '#' && s[1] == '!') { + if (!instr(s,"perl") && !instr(s,"indir") && instr(origargv[0],"perl")) { char **newargv; char *cmd; @@ -1192,17 +1304,31 @@ yylex() croak("Can't exec %s", cmd); } if (d = instr(s, "perl -")) { + int oldpdb = perldb; + int oldn = minus_n; + int oldp = minus_p; d += 6; /*SUPPRESS 530*/ while (d = moreswitches(d)) ; + if (perldb && !oldpdb || + minus_n && !oldn || + minus_p && !oldp) + { + sv_setpv(linestr, ""); + oldoldbufptr = oldbufptr = s = SvPVX(linestr); + bufend = SvPVX(linestr) + SvCUR(linestr); + preambled = FALSE; + if (perldb) + (void)gv_fetchfile(origfilename); + goto retry; + } } } } if (lex_formbrack && lex_brackets <= lex_formbrack) { - s = scan_formline(s); - if (!lex_formbrack) - goto rightbracket; - OPERATOR(';'); + bufptr = s; + lex_state = LEX_FORMLINE; + return yylex(); } goto retry; case ' ': case '\t': case '\f': case '\r': case 013: @@ -1218,10 +1344,9 @@ yylex() s++; incline(s); if (lex_formbrack && lex_brackets <= lex_formbrack) { - s = scan_formline(s); - if (!lex_formbrack) - goto rightbracket; - OPERATOR(';'); + bufptr = s; + lex_state = LEX_FORMLINE; + return yylex(); } } else { @@ -1233,6 +1358,7 @@ yylex() if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { s++; last_uni = oldbufptr; + last_lop_op = OP_FTEREAD; /* good enough */ switch (*s++) { case 'r': FTST(OP_FTEREAD); case 'w': FTST(OP_FTEWRITE); @@ -1278,7 +1404,7 @@ yylex() s++; s = skipspace(s); if (isIDFIRST(*s)) { - s = force_word(s,METHOD,FALSE,TRUE); + s = force_word(s,METHOD,FALSE,TRUE,FALSE); TOKEN(ARROW); } else @@ -1313,7 +1439,9 @@ yylex() if (expect != XOPERATOR) { s = scan_ident(s, bufend, tokenbuf, TRUE); expect = XOPERATOR; - force_ident(tokenbuf); + force_ident(tokenbuf, '*'); + if (!*tokenbuf) + PREREF('*'); TERM('*'); } s++; @@ -1345,7 +1473,7 @@ yylex() TERM('%'); } } - force_ident(tokenbuf + 1); + force_ident(tokenbuf + 1, *tokenbuf); } else PREREF('%'); @@ -1356,20 +1484,28 @@ yylex() case '^': s++; - BOop(OP_XOR); + BOop(OP_BIT_XOR); case '[': lex_brackets++; /* FALL THROUGH */ case '~': case ',': - case ':': tmp = *s++; OPERATOR(tmp); + case ':': + if (s[1] == ':') { + len = 0; + goto just_a_word; + } + s++; + OPERATOR(':'); case '(': s++; - if (last_lop == oldoldbufptr) + if (last_lop == oldoldbufptr || last_uni == oldoldbufptr) oldbufptr = oldoldbufptr; /* allow print(STDOUT 123) */ - OPERATOR('('); + else + expect = XTERM; + TOKEN('('); case ';': if (curcop->cop_line < copline) copline = curcop->cop_line; @@ -1386,7 +1522,7 @@ yylex() --lex_brackets; if (lex_state == LEX_INTERPNORMAL) { if (lex_brackets == 0) { - if (*s != '-' || s[1] != '>') + if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>')) lex_state = LEX_INTERPEND; } } @@ -1401,33 +1537,58 @@ yylex() lex_brackstack = newlb; } } - if (oldoldbufptr == last_lop) - lex_brackstack[lex_brackets++] = XTERM; - else - lex_brackstack[lex_brackets++] = XOPERATOR; - if (expect == XTERM) + switch (expect) { + case XTERM: + if (lex_formbrack) { + s--; + PRETERMBLOCK(DO); + } + if (oldoldbufptr == last_lop) + lex_brackstack[lex_brackets++] = XTERM; + else + lex_brackstack[lex_brackets++] = XOPERATOR; OPERATOR(HASHBRACK); - else if (expect == XBLOCK || expect == XOPERATOR) { - lex_brackstack[lex_brackets-1] = XSTATE; + break; + case XBLOCK: + case XOPERATOR: + lex_brackstack[lex_brackets++] = XSTATE; expect = XSTATE; - } - else { - char *t; - s = skipspace(s); - if (*s == '}') - OPERATOR(HASHBRACK); - for (t = s; - t < bufend && - (isSPACE(*t) || isALPHA(*t) || *t == '"' || *t == '\''); - t++) ; - if (*t == ',' || (*t == '=' && t[1] == '>')) - OPERATOR(HASHBRACK); - if (expect == XREF) - expect = XTERM; - else { - lex_brackstack[lex_brackets-1] = XSTATE; - expect = XSTATE; + break; + case XTERMBLOCK: + lex_brackstack[lex_brackets++] = XOPERATOR; + expect = XSTATE; + break; + default: { + char *t; + if (oldoldbufptr == last_lop) + lex_brackstack[lex_brackets++] = XTERM; + else + lex_brackstack[lex_brackets++] = XOPERATOR; + s = skipspace(s); + if (*s == '}') + OPERATOR(HASHBRACK); + if (isALPHA(*s)) { + for (t = s; t < bufend && isALPHA(*t); t++) ; + } + else if (*s == '\'' || *s == '"') { + t = strchr(s+1,*s); + if (!t++) + t = s; + } + else + t = s; + while (t < bufend && isSPACE(*t)) + t++; + if ((*t == ',' && !isLOWER(*s)) || (*t == '=' && t[1] == '>')) + OPERATOR(HASHBRACK); + if (expect == XREF) + expect = XTERM; + else { + lex_brackstack[lex_brackets-1] = XSTATE; + expect = XSTATE; + } } + break; } yylval.ival = curcop->cop_line; if (isSPACE(*s) || *s == '#') @@ -1449,7 +1610,7 @@ yylex() bufptr = s; return yylex(); /* ignore fake brackets */ } - if (*s != '-' || s[1] != '>') + if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>')) lex_state = LEX_INTERPEND; } } @@ -1459,10 +1620,10 @@ yylex() s++; tmp = *s++; if (tmp == '&') - OPERATOR(ANDAND); + AOPERATOR(ANDAND); s--; if (expect == XOPERATOR) { - if (dowarn && isALPHA(*s) && bufptr == SvPVX(linestr)) { + if (isALPHA(*s) && bufptr == SvPVX(linestr)) { curcop->cop_line--; warn(warn_nosemi); curcop->cop_line++; @@ -1473,7 +1634,7 @@ yylex() s = scan_ident(s-1, bufend, tokenbuf, TRUE); if (*tokenbuf) { expect = XOPERATOR; - force_ident(tokenbuf); + force_ident(tokenbuf, '&'); } else PREREF('&'); @@ -1483,7 +1644,7 @@ yylex() s++; tmp = *s++; if (tmp == '|') - OPERATOR(OROR); + AOPERATOR(OROR); s--; BOop(OP_BIT_OR); case '=': @@ -1498,12 +1659,22 @@ yylex() if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) warn("Reversed %c= operator",tmp); s--; - if (lex_brackets < lex_formbrack && (tmp == '\n' || s[1] == '\n')) { - s--; - expect = XBLOCK; - goto leftbracket; + if (isALPHA(tmp) && s == SvPVX(linestr)+1) { + s = bufend; + doextract = TRUE; + goto retry; + } + if (lex_brackets < lex_formbrack) { + char *t; + for (t = s; *t == ' ' || *t == '\t'; t++) ; + if (*t == '\n' || *t == '#') { + s--; + expect = XBLOCK; + goto leftbracket; + } } - OPERATOR('='); + yylval.ival = 0; + OPERATOR(ASSIGNOP); case '!': s++; tmp = *s++; @@ -1547,42 +1718,80 @@ yylex() Rop(OP_GT); case '$': - if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_' || s[2] == '{')) { - s = scan_ident(s+1, bufend, tokenbuf, FALSE); + if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$", s[2]))) { + s = scan_ident(s+1, bufend, tokenbuf+1, FALSE); if (expect == XOPERATOR) { - if (lex_formbrack && lex_brackets == lex_formbrack) - OPERATOR(','); /* grandfather non-comma-format format */ + if (lex_formbrack && lex_brackets == lex_formbrack) { + expect = XTERM; + depcom(); + return ','; /* grandfather non-comma-format format */ + } else no_op("Array length",s); } + else if (!tokenbuf[1]) + PREREF(DOLSHARP); + if (!strchr(tokenbuf+1,':')) { + tokenbuf[0] = '@'; + if (tmp = pad_findmy(tokenbuf)) { + nextval[nexttoke].opval = newOP(OP_PADANY, 0); + nextval[nexttoke].opval->op_targ = tmp; + expect = XOPERATOR; + force_next(PRIVATEREF); + TOKEN(DOLSHARP); + } + } expect = XOPERATOR; - force_ident(tokenbuf); + force_ident(tokenbuf+1, *tokenbuf); TOKEN(DOLSHARP); } s = scan_ident(s, bufend, tokenbuf+1, FALSE); if (expect == XOPERATOR) { - if (lex_formbrack && lex_brackets == lex_formbrack) - OPERATOR(','); /* grandfather non-comma-format format */ + if (lex_formbrack && lex_brackets == lex_formbrack) { + expect = XTERM; + depcom(); + return ','; /* grandfather non-comma-format format */ + } else no_op("Scalar",s); } if (tokenbuf[1]) { + expectation oldexpect = expect; + + /* This kludge not intended to be bulletproof. */ + if (tokenbuf[1] == '[' && !tokenbuf[2]) { + yylval.opval = newSVOP(OP_CONST, OPf_SPECIAL, + newSViv((IV)compiling.cop_arybase)); + TERM(THING); + } tokenbuf[0] = '$'; - if (dowarn && *s == '[') { + if (dowarn) { char *t; - for (t = s+1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; - if (*t++ == ',') { - bufptr = skipspace(bufptr); - while (t < bufend && *t != ']') t++; - warn("Multidimensional syntax %.*s not supported", - t-bufptr+1, bufptr); + if (*s == '[' && oldexpect != XREF) { + for (t = s+1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; + if (*t++ == ',') { + bufptr = skipspace(bufptr); + while (t < bufend && *t != ']') t++; + warn("Multidimensional syntax %.*s not supported", + t-bufptr+1, bufptr); + } + } + if (*s == '{' && strEQ(tokenbuf, "$SIG") && + (t = strchr(s,'}')) && (t = strchr(t,'='))) { + char tmpbuf[1024]; + char *d = tmpbuf; + STRLEN len; + for (t++; isSPACE(*t); t++) ; + t = scan_word(t, tmpbuf, TRUE, &len); + if (*t != '(' && perl_get_cv(tmpbuf, FALSE)) + warn("You need to quote \"%s\"", tmpbuf); } } expect = XOPERATOR; if (lex_state == LEX_NORMAL && isSPACE(*s)) { bool islop = (last_lop == oldoldbufptr); s = skipspace(s); - if (!islop) + if (!islop || last_lop_op == OP_GREPSTART) expect = XOPERATOR; else if (strchr("$@\"'`q", *s)) expect = XTERM; /* e.g. print $fh "foo" */ @@ -1605,20 +1814,22 @@ yylex() force_next(PRIVATEREF); } else if (!strchr(tokenbuf,':')) { - if (*s == '[') - tokenbuf[0] = '@'; - else if (*s == '{') - tokenbuf[0] = '%'; + if (oldexpect != XREF) { + if (*s == '[') + tokenbuf[0] = '@'; + else if (*s == '{') + tokenbuf[0] = '%'; + } if (tmp = pad_findmy(tokenbuf)) { nextval[nexttoke].opval = newOP(OP_PADANY, 0); nextval[nexttoke].opval->op_targ = tmp; force_next(PRIVATEREF); } else - force_ident(tokenbuf+1); + force_ident(tokenbuf+1, *tokenbuf); } else - force_ident(tokenbuf+1); + force_ident(tokenbuf+1, *tokenbuf); } else { if (s == bufend) @@ -1632,6 +1843,8 @@ yylex() if (expect == XOPERATOR) no_op("Array",s); if (tokenbuf[1]) { + GV* gv; + tokenbuf[0] = '@'; expect = XOPERATOR; if (in_my) { @@ -1652,18 +1865,34 @@ yylex() TERM('@'); } } - if (dowarn && (*s == '[' || *s == '{')) { - char *t = s + 1; - while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t))) - t++; - if (*t == '}' || *t == ']') { - t++; - bufptr = skipspace(bufptr); - warn("Scalar value %.*s better written as $%.*s", - t-bufptr, bufptr, t-bufptr-1, bufptr+1); + + /* Force them to make up their mind on "@foo". */ + if (lex_state != LEX_NORMAL && + ( !(gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV)) || + (*tokenbuf == '@' + ? !GvAV(gv) + : !GvHV(gv) ))) + { + char tmpbuf[1024]; + sprintf(tmpbuf, "Literal @%s now requires backslash",tokenbuf+1); + yyerror(tmpbuf); + } + + /* Warn about @ where they meant $. */ + if (dowarn) { + if (*s == '[' || *s == '{') { + char *t = s + 1; + while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t))) + t++; + if (*t == '}' || *t == ']') { + t++; + bufptr = skipspace(bufptr); + warn("Scalar value %.*s better written as $%.*s", + t-bufptr, bufptr, t-bufptr-1, bufptr+1); + } } } - force_ident(tokenbuf+1); + force_ident(tokenbuf+1, *tokenbuf); } else { if (s == bufend) @@ -1717,8 +1946,11 @@ yylex() case '\'': s = scan_str(s); if (expect == XOPERATOR) { - if (lex_formbrack && lex_brackets == lex_formbrack) - OPERATOR(','); /* grandfather non-comma-format format */ + if (lex_formbrack && lex_brackets == lex_formbrack) { + expect = XTERM; + depcom(); + return ','; /* grandfather non-comma-format format */ + } else no_op("String",s); } @@ -1730,14 +1962,17 @@ yylex() case '"': s = scan_str(s); if (expect == XOPERATOR) { - if (lex_formbrack && lex_brackets == lex_formbrack) - OPERATOR(','); /* grandfather non-comma-format format */ + if (lex_formbrack && lex_brackets == lex_formbrack) { + expect = XTERM; + depcom(); + return ','; /* grandfather non-comma-format format */ + } else no_op("String",s); } if (!s) missingterm((char*)0); - yylval.ival = OP_SCALAR; + yylval.ival = OP_STRINGIFY; TERM(sublex_start()); case '`': @@ -1795,7 +2030,23 @@ yylex() d = s; s = scan_word(s, tokenbuf, FALSE, &len); - switch (tmp = keyword(tokenbuf, len)) { + tmp = keyword(tokenbuf, len); + if (tmp < 0) { /* second-class keyword? */ + GV* gv; + if (expect != XOPERATOR && + (*s != ':' || s[1] != ':') && + (gv = gv_fetchpv(tokenbuf,FALSE, SVt_PVCV)) && + (GvFLAGS(gv) & GVf_IMPORTED) && + GvCV(gv)) + { + tmp = 0; + } + else + tmp = -tmp; + } + + reserved_word: + switch (tmp) { default: /* not a keyword */ just_a_word: { @@ -1803,21 +2054,24 @@ yylex() /* Get the rest if it looks like a package qualifier */ - if (*s == '\'' || *s == ':') + if (*s == '\'' || *s == ':' && s[1] == ':') { s = scan_word(s, tokenbuf + len, TRUE, &len); + if (!len) + croak("Bad name after %s::", tokenbuf); + } /* Do special processing at start of statement. */ if (expect == XSTATE) { while (isSPACE(*s)) s++; if (*s == ':') { /* It's a label. */ - yylval.pval = savestr(tokenbuf); + yylval.pval = savepv(tokenbuf); s++; CLINE; TOKEN(LABEL); } } - else if (dowarn && expect == XOPERATOR) { + else if (expect == XOPERATOR) { if (bufptr == SvPVX(linestr)) { curcop->cop_line--; warn(warn_nosemi); @@ -1831,17 +2085,34 @@ yylex() gv = gv_fetchpv(tokenbuf,FALSE, SVt_PVCV); + /* Presume this is going to be a bareword of some sort. */ + + CLINE; + yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0)); + yylval.opval->op_private = OPpCONST_BARE; + /* See if it's the indirect object for a list operator. */ - if (oldoldbufptr && oldoldbufptr < bufptr) { - if (oldoldbufptr == last_lop && - (!gv || !GvCV(gv) || last_lop_op == OP_SORT)) - { - expect = XTERM; - CLINE; - yylval.opval = (OP*)newSVOP(OP_CONST, 0, - newSVpv(tokenbuf,0)); - yylval.opval->op_private = OPpCONST_BARE; + if (oldoldbufptr && + oldoldbufptr < bufptr && + (oldoldbufptr == last_lop || oldoldbufptr == last_uni) && + /* NO SKIPSPACE BEFORE HERE! */ + (expect == XREF || + (opargs[last_lop_op] >> OASHIFT & 7) == OA_FILEREF) ) + { + /* (Now we can afford to cross potential line boundary.) */ + s = skipspace(s); + + /* Two barewords in a row may indicate method call. */ + + if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv))) + return tmp; + + /* If not a declared subroutine, it's an indirect object. */ + /* (But it's an indir obj regardless for sort.) */ + + if (last_lop_op == OP_SORT || !gv || !GvCV(gv)) { + expect = last_lop == oldoldbufptr ? XTERM : XOPERATOR; for (d = tokenbuf; *d && isLOWER(*d); d++) ; if (dowarn && !*d) warn(warn_reserved, tokenbuf); @@ -1855,18 +2126,13 @@ yylex() s = skipspace(s); if (*s == '(') { CLINE; - nextval[nexttoke].opval = - (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0)); - nextval[nexttoke].opval->op_private = OPpCONST_BARE; + nextval[nexttoke].opval = yylval.opval; expect = XOPERATOR; force_next(WORD); TOKEN('&'); } - CLINE; - yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0)); - yylval.opval->op_private = OPpCONST_BARE; - /* If followed by var or block, call it a method (maybe). */ + /* If followed by var or block, call it a method (unless sub) */ if ((*s == '$' || *s == '{') && (!gv || !GvCV(gv))) { last_lop = oldbufptr; @@ -1876,29 +2142,8 @@ yylex() /* If followed by a bareword, see if it looks like indir obj. */ - if (isALPHA(*s)) { - char *olds = s; - char tmpbuf[1024]; - GV* indirgv; - s = scan_word(s, tmpbuf, TRUE, &len); - if (!keyword(tmpbuf, len)) { - SV* tmpsv = newSVpv(tmpbuf,0); - indirgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVCV); - if (!indirgv || !GvCV(indirgv)) { - if (!gv || !GvCV(gv) || fetch_stash(tmpsv, FALSE)) { - nextval[nexttoke].opval = - (OP*)newSVOP(OP_CONST, 0, tmpsv); - nextval[nexttoke].opval->op_private = - OPpCONST_BARE; - expect = XTERM; - force_next(WORD); - TOKEN(METHOD); - } - } - SvREFCNT_dec(tmpsv); - } - s = olds; - } + if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv))) + return tmp; /* Not a method, so call it a subroutine (if defined) */ @@ -1910,13 +2155,19 @@ yylex() TOKEN('&'); } last_lop = oldbufptr; - last_lop_op = OP_ENTERSUBR; + last_lop_op = OP_ENTERSUB; expect = XTERM; force_next(WORD); TOKEN(NOAMP); } - else if (hints & HINT_STRICT_SUBS) { - warn("Bareword \"%s\" not allowed while \"strict subs\" averred", + else if (hints & HINT_STRICT_SUBS && + strnNE(s,"->",2) && + last_lop_op != OP_ACCEPT && + last_lop_op != OP_PIPE_OP && + last_lop_op != OP_SOCKPAIR) + { + warn( + "Bareword \"%s\" not allowed while \"strict subs\" in use", tokenbuf); ++error_count; } @@ -1941,25 +2192,26 @@ yylex() case KEY___END__: { GV *gv; - int fd; /*SUPPRESS 560*/ if (!in_eval) { gv = gv_fetchpv("DATA",TRUE, SVt_PVIO); SvMULTI_on(gv); if (!GvIO(gv)) - GvIO(gv) = newIO(); - IoIFP(GvIO(gv)) = rsfp; -#if defined(HAS_FCNTL) && defined(FFt_SETFD) - fd = fileno(rsfp); - fcntl(fd,FFt_SETFD,fd >= 3); + GvIOp(gv) = newIO(); + IoIFP(GvIOp(gv)) = rsfp; +#if defined(HAS_FCNTL) && defined(F_SETFD) + { + int fd = fileno(rsfp); + fcntl(fd,F_SETFD,fd >= 3); + } #endif if (preprocess) - IoTYPE(GvIO(gv)) = '|'; + IoTYPE(GvIOp(gv)) = '|'; else if ((FILE*)rsfp == stdin) - IoTYPE(GvIO(gv)) = '-'; + IoTYPE(GvIOp(gv)) = '-'; else - IoTYPE(GvIO(gv)) = '<'; + IoTYPE(GvIOp(gv)) = '<'; rsfp = Nullfp; } goto fake_eof; @@ -1969,13 +2221,23 @@ yylex() case KEY_DESTROY: case KEY_BEGIN: case KEY_END: - s = skipspace(s); - if (expect == XSTATE && (minus_p || minus_n || *s == '{' )) { + if (expect == XSTATE) { s = bufptr; goto really_sub; } goto just_a_word; + case KEY_CORE: + if (*s == ':' && s[1] == ':') { + s += 2; + s = scan_word(s, tokenbuf, FALSE, &len); + tmp = keyword(tokenbuf, len); + if (tmp < 0) + tmp = -tmp; + goto reserved_word; + } + goto just_a_word; + case KEY_abs: UNI(OP_ABS); @@ -1983,27 +2245,22 @@ yylex() UNI(OP_ALARM); case KEY_accept: - LOP(OP_ACCEPT); + LOP(OP_ACCEPT,XTERM); case KEY_and: OPERATOR(ANDOP); case KEY_atan2: - LOP(OP_ATAN2); - - case KEY_aver: - s = force_word(s,WORD,FALSE,FALSE); - yylval.ival = 1; - OPERATOR(HINT); + LOP(OP_ATAN2,XTERM); case KEY_bind: - LOP(OP_BIND); + LOP(OP_BIND,XTERM); case KEY_binmode: UNI(OP_BINMODE); case KEY_bless: - LOP(OP_BLESS); + LOP(OP_BLESS,XTERM); case KEY_chop: UNI(OP_CHOP); @@ -2032,19 +2289,19 @@ yylex() if (!cryptseen++) init_des(); #endif - LOP(OP_CRYPT); + LOP(OP_CRYPT,XTERM); case KEY_chmod: s = skipspace(s); if (dowarn && *s != '0' && isDIGIT(*s)) yywarn("chmod: mode argument is missing initial 0"); - LOP(OP_CHMOD); + LOP(OP_CHMOD,XTERM); case KEY_chown: - LOP(OP_CHOWN); + LOP(OP_CHOWN,XTERM); case KEY_connect: - LOP(OP_CONNECT); + LOP(OP_CONNECT,XTERM); case KEY_chr: UNI(OP_CHR); @@ -2055,37 +2312,33 @@ yylex() case KEY_chroot: UNI(OP_CHROOT); - case KEY_deny: - s = force_word(s,WORD,FALSE,FALSE); - yylval.ival = 0; - OPERATOR(HINT); - case KEY_do: s = skipspace(s); if (*s == '{') - PREBLOCK(DO); + PRETERMBLOCK(DO); if (*s != '\'') - s = force_word(s,WORD,FALSE,TRUE); + s = force_word(s,WORD,FALSE,TRUE,FALSE); OPERATOR(DO); case KEY_die: - LOP(OP_DIE); + hints |= HINT_BLOCK_SCOPE; + LOP(OP_DIE,XTERM); case KEY_defined: UNI(OP_DEFINED); case KEY_delete: - OPERATOR(DELETE); + UNI(OP_DELETE); case KEY_dbmopen: - gv_fetchpv("Any_DBM_FILE::ISA", 2, SVt_PVAV); - LOP(OP_DBMOPEN); + gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV); + LOP(OP_DBMOPEN,XTERM); case KEY_dbmclose: UNI(OP_DBMCLOSE); case KEY_dump: - s = force_word(s,WORD,TRUE,FALSE); + s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_DUMP); case KEY_else: @@ -2098,12 +2351,15 @@ yylex() case KEY_eq: Eop(OP_SEQ); + case KEY_exists: + UNI(OP_EXISTS); + case KEY_exit: UNI(OP_EXIT); case KEY_eval: s = skipspace(s); - expect = (*s == '{') ? XBLOCK : XTERM; + expect = (*s == '{') ? XTERMBLOCK : XTERM; UNIBRACK(OP_ENTEREVAL); case KEY_eof: @@ -2117,7 +2373,7 @@ yylex() case KEY_exec: set_csh(); - LOP(OP_EXEC); + LOP(OP_EXEC,XREF); case KEY_endhostent: FUN0(OP_EHOSTENT); @@ -2147,19 +2403,19 @@ yylex() OPERATOR(FOR); case KEY_formline: - LOP(OP_FORMLINE); + LOP(OP_FORMLINE,XTERM); case KEY_fork: FUN0(OP_FORK); case KEY_fcntl: - LOP(OP_FCNTL); + LOP(OP_FCNTL,XTERM); case KEY_fileno: UNI(OP_FILENO); case KEY_flock: - LOP(OP_FLOCK); + LOP(OP_FLOCK,XTERM); case KEY_gt: Rop(OP_SGT); @@ -2168,10 +2424,10 @@ yylex() Rop(OP_SGE); case KEY_grep: - LOP(OP_GREPSTART); + LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF); case KEY_goto: - s = force_word(s,WORD,TRUE,FALSE); + s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_GOTO); case KEY_gmtime: @@ -2187,13 +2443,13 @@ yylex() UNI(OP_GETPGRP); case KEY_getpriority: - LOP(OP_GETPRIORITY); + LOP(OP_GETPRIORITY,XTERM); case KEY_getprotobyname: UNI(OP_GPBYNAME); case KEY_getprotobynumber: - LOP(OP_GPBYNUMBER); + LOP(OP_GPBYNUMBER,XTERM); case KEY_getprotoent: FUN0(OP_GPROTOENT); @@ -2214,7 +2470,7 @@ yylex() UNI(OP_GHBYNAME); case KEY_gethostbyaddr: - LOP(OP_GHBYADDR); + LOP(OP_GHBYADDR,XTERM); case KEY_gethostent: FUN0(OP_GHOSTENT); @@ -2223,16 +2479,16 @@ yylex() UNI(OP_GNBYNAME); case KEY_getnetbyaddr: - LOP(OP_GNBYADDR); + LOP(OP_GNBYADDR,XTERM); case KEY_getnetent: FUN0(OP_GNETENT); case KEY_getservbyname: - LOP(OP_GSBYNAME); + LOP(OP_GSBYNAME,XTERM); case KEY_getservbyport: - LOP(OP_GSBYPORT); + LOP(OP_GSBYPORT,XTERM); case KEY_getservent: FUN0(OP_GSERVENT); @@ -2241,7 +2497,7 @@ yylex() UNI(OP_GETSOCKNAME); case KEY_getsockopt: - LOP(OP_GSOCKOPT); + LOP(OP_GSOCKOPT,XTERM); case KEY_getgrent: FUN0(OP_GGRENT); @@ -2256,7 +2512,8 @@ yylex() FUN0(OP_GETLOGIN); case KEY_glob: - UNI(OP_GLOB); + set_csh(); + LOP(OP_GLOB,XTERM); case KEY_hex: UNI(OP_HEX); @@ -2266,27 +2523,27 @@ yylex() OPERATOR(IF); case KEY_index: - LOP(OP_INDEX); + LOP(OP_INDEX,XTERM); case KEY_int: UNI(OP_INT); case KEY_ioctl: - LOP(OP_IOCTL); + LOP(OP_IOCTL,XTERM); case KEY_join: - LOP(OP_JOIN); + LOP(OP_JOIN,XTERM); case KEY_keys: UNI(OP_KEYS); case KEY_kill: - LOP(OP_KILL); + LOP(OP_KILL,XTERM); case KEY_last: - s = force_word(s,WORD,TRUE,FALSE); + s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_LAST); - + case KEY_lc: UNI(OP_LC); @@ -2313,10 +2570,10 @@ yylex() UNI(OP_LOG); case KEY_link: - LOP(OP_LINK); + LOP(OP_LINK,XTERM); case KEY_listen: - LOP(OP_LISTEN); + LOP(OP_LISTEN,XTERM); case KEY_lstat: UNI(OP_LSTAT); @@ -2325,20 +2582,23 @@ yylex() s = scan_pat(s); TERM(sublex_start()); + case KEY_map: + LOP(OP_MAPSTART,XREF); + case KEY_mkdir: - LOP(OP_MKDIR); + LOP(OP_MKDIR,XTERM); case KEY_msgctl: - LOP(OP_MSGCTL); + LOP(OP_MSGCTL,XTERM); case KEY_msgget: - LOP(OP_MSGGET); + LOP(OP_MSGGET,XTERM); case KEY_msgrcv: - LOP(OP_MSGRCV); + LOP(OP_MSGRCV,XTERM); case KEY_msgsnd: - LOP(OP_MSGSND); + LOP(OP_MSGSND,XTERM); case KEY_my: in_my = TRUE; @@ -2346,12 +2606,22 @@ yylex() OPERATOR(LOCAL); case KEY_next: - s = force_word(s,WORD,TRUE,FALSE); + s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_NEXT); case KEY_ne: Eop(OP_SNE); + case KEY_no: + if (expect != XSTATE) + yyerror("\"no\" not allowed in expression"); + s = force_word(s,WORD,FALSE,TRUE,FALSE); + yylval.ival = 0; + OPERATOR(USE); + + case KEY_not: + OPERATOR(NOTOP); + case KEY_open: s = skipspace(s); if (isIDFIRST(*s)) { @@ -2362,9 +2632,10 @@ yylex() warn("Precedence problem: open %.*s should be open(%.*s)", d-s,s, d-s,s); } - LOP(OP_OPEN); + LOP(OP_OPEN,XTERM); case KEY_or: + yylval.ival = OP_OR; OPERATOR(OROP); case KEY_ord: @@ -2374,31 +2645,34 @@ yylex() UNI(OP_OCT); case KEY_opendir: - LOP(OP_OPEN_DIR); + LOP(OP_OPEN_DIR,XTERM); case KEY_print: checkcomma(s,tokenbuf,"filehandle"); - LOP(OP_PRINT); + LOP(OP_PRINT,XREF); case KEY_printf: checkcomma(s,tokenbuf,"filehandle"); - LOP(OP_PRTF); + LOP(OP_PRTF,XREF); case KEY_push: - LOP(OP_PUSH); + LOP(OP_PUSH,XTERM); case KEY_pop: UNI(OP_POP); + case KEY_pos: + UNI(OP_POS); + case KEY_pack: - LOP(OP_PACK); + LOP(OP_PACK,XTERM); case KEY_package: - s = force_word(s,WORD,FALSE,TRUE); + s = force_word(s,WORD,FALSE,TRUE,FALSE); OPERATOR(PACKAGE); case KEY_pipe: - LOP(OP_PIPE_OP); + LOP(OP_PIPE_OP,XTERM); case KEY_q: s = scan_str(s); @@ -2407,6 +2681,9 @@ yylex() yylval.ival = OP_CONST; TERM(sublex_start()); + case KEY_quotemeta: + UNI(OP_QUOTEMETA); + case KEY_qw: s = scan_str(s); if (!s) @@ -2419,13 +2696,19 @@ yylex() nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1)); force_next(THING); force_next('('); - LOP(OP_SPLIT); + yylval.ival = OP_SPLIT; + CLINE; + expect = XTERM; + bufptr = s; + last_lop = oldbufptr; + last_lop_op = OP_SPLIT; + return FUNC; case KEY_qq: s = scan_str(s); if (!s) missingterm((char*)0); - yylval.ival = OP_SCALAR; + yylval.ival = OP_STRINGIFY; if (SvIVX(lex_stuff) == '\'') SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */ TERM(sublex_start()); @@ -2442,18 +2725,20 @@ yylex() OLDLOP(OP_RETURN); case KEY_require: - s = force_word(s,WORD,TRUE,FALSE); + s = force_word(s,WORD,TRUE,TRUE,FALSE); + if (*s == '<') + yyerror("<> should be quotes"); UNI(OP_REQUIRE); case KEY_reset: UNI(OP_RESET); case KEY_redo: - s = force_word(s,WORD,TRUE,FALSE); + s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_REDO); case KEY_rename: - LOP(OP_RENAME); + LOP(OP_RENAME,XTERM); case KEY_rand: UNI(OP_RAND); @@ -2462,10 +2747,10 @@ yylex() UNI(OP_RMDIR); case KEY_rindex: - LOP(OP_RINDEX); + LOP(OP_RINDEX,XTERM); case KEY_read: - LOP(OP_READ); + LOP(OP_READ,XTERM); case KEY_readdir: UNI(OP_READDIR); @@ -2482,10 +2767,10 @@ yylex() UNI(OP_REWINDDIR); case KEY_recv: - LOP(OP_RECV); + LOP(OP_RECV,XTERM); case KEY_reverse: - LOP(OP_REVERSE); + LOP(OP_REVERSE,XTERM); case KEY_readlink: UNI(OP_READLINK); @@ -2500,32 +2785,35 @@ yylex() else TOKEN(1); /* force error */ + case KEY_chomp: + UNI(OP_CHOMP); + case KEY_scalar: UNI(OP_SCALAR); case KEY_select: - LOP(OP_SELECT); + LOP(OP_SELECT,XTERM); case KEY_seek: - LOP(OP_SEEK); + LOP(OP_SEEK,XTERM); case KEY_semctl: - LOP(OP_SEMCTL); + LOP(OP_SEMCTL,XTERM); case KEY_semget: - LOP(OP_SEMGET); + LOP(OP_SEMGET,XTERM); case KEY_semop: - LOP(OP_SEMOP); + LOP(OP_SEMOP,XTERM); case KEY_send: - LOP(OP_SEND); + LOP(OP_SEND,XTERM); case KEY_setpgrp: - LOP(OP_SETPGRP); + LOP(OP_SETPGRP,XTERM); case KEY_setpriority: - LOP(OP_SETPRIORITY); + LOP(OP_SETPRIORITY,XTERM); case KEY_sethostent: FUN1(OP_SHOSTENT); @@ -2546,28 +2834,28 @@ yylex() FUN0(OP_SGRENT); case KEY_seekdir: - LOP(OP_SEEKDIR); + LOP(OP_SEEKDIR,XTERM); case KEY_setsockopt: - LOP(OP_SSOCKOPT); + LOP(OP_SSOCKOPT,XTERM); case KEY_shift: UNI(OP_SHIFT); case KEY_shmctl: - LOP(OP_SHMCTL); + LOP(OP_SHMCTL,XTERM); case KEY_shmget: - LOP(OP_SHMGET); + LOP(OP_SHMGET,XTERM); case KEY_shmread: - LOP(OP_SHMREAD); + LOP(OP_SHMREAD,XTERM); case KEY_shmwrite: - LOP(OP_SHMWRITE); + LOP(OP_SHMWRITE,XTERM); case KEY_shutdown: - LOP(OP_SHUTDOWN); + LOP(OP_SHUTDOWN,XTERM); case KEY_sin: UNI(OP_SIN); @@ -2576,10 +2864,10 @@ yylex() UNI(OP_SLEEP); case KEY_socket: - LOP(OP_SOCKET); + LOP(OP_SOCKET,XTERM); case KEY_socketpair: - LOP(OP_SOCKPAIR); + LOP(OP_SOCKPAIR,XTERM); case KEY_sort: checkcomma(s,tokenbuf,"subroutine name"); @@ -2587,17 +2875,17 @@ yylex() if (*s == ';' || *s == ')') /* probably a close */ croak("sort is now a reserved word"); expect = XTERM; - s = force_word(s,WORD,TRUE,TRUE); - LOP(OP_SORT); + s = force_word(s,WORD,TRUE,TRUE,TRUE); + LOP(OP_SORT,XREF); case KEY_split: - LOP(OP_SPLIT); + LOP(OP_SPLIT,XTERM); case KEY_sprintf: - LOP(OP_SPRINTF); + LOP(OP_SPRINTF,XTERM); case KEY_splice: - LOP(OP_SPLICE); + LOP(OP_SPLICE,XTERM); case KEY_sqrt: UNI(OP_SQRT); @@ -2613,13 +2901,16 @@ yylex() UNI(OP_STUDY); case KEY_substr: - LOP(OP_SUBSTR); + LOP(OP_SUBSTR,XTERM); case KEY_format: case KEY_sub: really_sub: - yylval.ival = start_subparse(); s = skipspace(s); + if (*s == '{' && tmp == KEY_sub) { + sv_setpv(subname,"__ANON__"); + PRETERMBLOCK(ANONSUB); + } expect = XBLOCK; if (isIDFIRST(*s) || *s == '\'' || *s == ':') { char tmpbuf[128]; @@ -2631,7 +2922,7 @@ yylex() sv_catpvn(subname,"::",2); sv_catpvn(subname,tmpbuf,len); } - s = force_word(s,WORD,FALSE,TRUE); + s = force_word(s,WORD,FALSE,TRUE,TRUE); } else sv_setpv(subname,"?"); @@ -2646,19 +2937,19 @@ yylex() case KEY_system: set_csh(); - LOP(OP_SYSTEM); + LOP(OP_SYSTEM,XREF); case KEY_symlink: - LOP(OP_SYMLINK); + LOP(OP_SYMLINK,XTERM); case KEY_syscall: - LOP(OP_SYSCALL); + LOP(OP_SYSCALL,XTERM); case KEY_sysread: - LOP(OP_SYSREAD); + LOP(OP_SYSREAD,XTERM); case KEY_syswrite: - LOP(OP_SYSWRITE); + LOP(OP_SYSWRITE,XTERM); case KEY_tr: s = scan_trans(s); @@ -2671,7 +2962,7 @@ yylex() UNI(OP_TELLDIR); case KEY_tie: - LOP(OP_TIE); + LOP(OP_TIE,XTERM); case KEY_time: FUN0(OP_TIME); @@ -2680,7 +2971,7 @@ yylex() FUN0(OP_TMS); case KEY_truncate: - LOP(OP_TRUNCATE); + LOP(OP_TRUNCATE,XTERM); case KEY_uc: UNI(OP_UC); @@ -2700,16 +2991,16 @@ yylex() OPERATOR(UNLESS); case KEY_unlink: - LOP(OP_UNLINK); + LOP(OP_UNLINK,XTERM); case KEY_undef: UNI(OP_UNDEF); case KEY_unpack: - LOP(OP_UNPACK); + LOP(OP_UNPACK,XTERM); case KEY_utime: - LOP(OP_UTIME); + LOP(OP_UTIME,XTERM); case KEY_umask: s = skipspace(s); @@ -2718,27 +3009,35 @@ yylex() UNI(OP_UMASK); case KEY_unshift: - LOP(OP_UNSHIFT); + LOP(OP_UNSHIFT,XTERM); + + 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); case KEY_values: UNI(OP_VALUES); case KEY_vec: sawvec = TRUE; - LOP(OP_VEC); + LOP(OP_VEC,XTERM); case KEY_while: yylval.ival = curcop->cop_line; OPERATOR(WHILE); case KEY_warn: - LOP(OP_WARN); + hints |= HINT_BLOCK_SCOPE; + LOP(OP_WARN,XTERM); case KEY_wait: FUN0(OP_WAIT); case KEY_waitpid: - LOP(OP_WAITPID); + LOP(OP_WAITPID,XTERM); case KEY_wantarray: FUN0(OP_WANTARRAY); @@ -2753,6 +3052,10 @@ yylex() check_uni(); goto just_a_word; + case KEY_xor: + yylval.ival = OP_XOR; + OPERATOR(OROP); + case KEY_y: s = scan_trans(s); TERM(sublex_start()); @@ -2768,8 +3071,8 @@ I32 len; switch (*d) { case '_': if (d[1] == '_') { - if (strEQ(d,"__LINE__")) return KEY___LINE__; - if (strEQ(d,"__FILE__")) return KEY___FILE__; + if (strEQ(d,"__LINE__")) return -KEY___LINE__; + if (strEQ(d,"__FILE__")) return -KEY___FILE__; if (strEQ(d,"__END__")) return KEY___END__; } break; @@ -2779,18 +3082,15 @@ I32 len; case 'a': switch (len) { case 3: - if (strEQ(d,"and")) return KEY_and; - if (strEQ(d,"abs")) return KEY_abs; - break; - case 4: - if (strEQ(d,"aver")) return KEY_aver; + if (strEQ(d,"and")) return -KEY_and; + if (strEQ(d,"abs")) return -KEY_abs; break; case 5: - if (strEQ(d,"alarm")) return KEY_alarm; - if (strEQ(d,"atan2")) return KEY_atan2; + if (strEQ(d,"alarm")) return -KEY_alarm; + if (strEQ(d,"atan2")) return -KEY_atan2; break; case 6: - if (strEQ(d,"accept")) return KEY_accept; + if (strEQ(d,"accept")) return -KEY_accept; break; } break; @@ -2798,37 +3098,41 @@ I32 len; if (strEQ(d,"BEGIN")) return KEY_BEGIN; break; case 'b': - if (strEQ(d,"bless")) return KEY_bless; - if (strEQ(d,"bind")) return KEY_bind; - if (strEQ(d,"binmode")) return KEY_binmode; + if (strEQ(d,"bless")) return -KEY_bless; + if (strEQ(d,"bind")) return -KEY_bind; + if (strEQ(d,"binmode")) return -KEY_binmode; + break; + case 'C': + if (strEQ(d,"CORE")) return -KEY_CORE; break; case 'c': switch (len) { case 3: - if (strEQ(d,"cmp")) return KEY_cmp; - if (strEQ(d,"chr")) return KEY_chr; - if (strEQ(d,"cos")) return KEY_cos; + if (strEQ(d,"cmp")) return -KEY_cmp; + if (strEQ(d,"chr")) return -KEY_chr; + if (strEQ(d,"cos")) return -KEY_cos; break; case 4: if (strEQ(d,"chop")) return KEY_chop; break; case 5: - if (strEQ(d,"close")) return KEY_close; - if (strEQ(d,"chdir")) return KEY_chdir; - if (strEQ(d,"chmod")) return KEY_chmod; - if (strEQ(d,"chown")) return KEY_chown; - if (strEQ(d,"crypt")) return KEY_crypt; + if (strEQ(d,"close")) return -KEY_close; + if (strEQ(d,"chdir")) return -KEY_chdir; + if (strEQ(d,"chomp")) return KEY_chomp; + if (strEQ(d,"chmod")) return -KEY_chmod; + if (strEQ(d,"chown")) return -KEY_chown; + if (strEQ(d,"crypt")) return -KEY_crypt; break; case 6: - if (strEQ(d,"chroot")) return KEY_chroot; - if (strEQ(d,"caller")) return KEY_caller; + if (strEQ(d,"chroot")) return -KEY_chroot; + if (strEQ(d,"caller")) return -KEY_caller; break; case 7: - if (strEQ(d,"connect")) return KEY_connect; + if (strEQ(d,"connect")) return -KEY_connect; break; case 8: - if (strEQ(d,"closedir")) return KEY_closedir; - if (strEQ(d,"continue")) return KEY_continue; + if (strEQ(d,"closedir")) return -KEY_closedir; + if (strEQ(d,"continue")) return -KEY_continue; break; } break; @@ -2841,60 +3145,62 @@ I32 len; if (strEQ(d,"do")) return KEY_do; break; case 3: - if (strEQ(d,"die")) return KEY_die; + if (strEQ(d,"die")) return -KEY_die; break; case 4: - if (strEQ(d,"deny")) return KEY_deny; - if (strEQ(d,"dump")) return KEY_dump; + if (strEQ(d,"dump")) return -KEY_dump; break; case 6: if (strEQ(d,"delete")) return KEY_delete; break; case 7: if (strEQ(d,"defined")) return KEY_defined; - if (strEQ(d,"dbmopen")) return KEY_dbmopen; + if (strEQ(d,"dbmopen")) return -KEY_dbmopen; break; case 8: - if (strEQ(d,"dbmclose")) return KEY_dbmclose; + if (strEQ(d,"dbmclose")) return -KEY_dbmclose; break; } break; case 'E': - if (strEQ(d,"EQ")) return KEY_eq; + if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;} if (strEQ(d,"END")) return KEY_END; break; case 'e': switch (len) { case 2: - if (strEQ(d,"eq")) return KEY_eq; + if (strEQ(d,"eq")) return -KEY_eq; break; case 3: - if (strEQ(d,"eof")) return KEY_eof; - if (strEQ(d,"exp")) return KEY_exp; + if (strEQ(d,"eof")) return -KEY_eof; + if (strEQ(d,"exp")) return -KEY_exp; break; case 4: if (strEQ(d,"else")) return KEY_else; - if (strEQ(d,"exit")) return KEY_exit; + if (strEQ(d,"exit")) return -KEY_exit; if (strEQ(d,"eval")) return KEY_eval; - if (strEQ(d,"exec")) return KEY_exec; + if (strEQ(d,"exec")) return -KEY_exec; if (strEQ(d,"each")) return KEY_each; break; case 5: if (strEQ(d,"elsif")) return KEY_elsif; break; + case 6: + if (strEQ(d,"exists")) return KEY_exists; + break; case 8: - if (strEQ(d,"endgrent")) return KEY_endgrent; - if (strEQ(d,"endpwent")) return KEY_endpwent; + if (strEQ(d,"endgrent")) return -KEY_endgrent; + if (strEQ(d,"endpwent")) return -KEY_endpwent; break; case 9: - if (strEQ(d,"endnetent")) return KEY_endnetent; + if (strEQ(d,"endnetent")) return -KEY_endnetent; break; case 10: - if (strEQ(d,"endhostent")) return KEY_endhostent; - if (strEQ(d,"endservent")) return KEY_endservent; + if (strEQ(d,"endhostent")) return -KEY_endhostent; + if (strEQ(d,"endservent")) return -KEY_endservent; break; case 11: - if (strEQ(d,"endprotoent")) return KEY_endprotoent; + if (strEQ(d,"endprotoent")) return -KEY_endprotoent; break; } break; @@ -2904,28 +3210,28 @@ I32 len; if (strEQ(d,"for")) return KEY_for; break; case 4: - if (strEQ(d,"fork")) return KEY_fork; + if (strEQ(d,"fork")) return -KEY_fork; break; case 5: - if (strEQ(d,"fcntl")) return KEY_fcntl; - if (strEQ(d,"flock")) return KEY_flock; + if (strEQ(d,"fcntl")) return -KEY_fcntl; + if (strEQ(d,"flock")) return -KEY_flock; break; case 6: if (strEQ(d,"format")) return KEY_format; - if (strEQ(d,"fileno")) return KEY_fileno; + if (strEQ(d,"fileno")) return -KEY_fileno; break; case 7: if (strEQ(d,"foreach")) return KEY_foreach; break; case 8: - if (strEQ(d,"formline")) return KEY_formline; + if (strEQ(d,"formline")) return -KEY_formline; break; } break; case 'G': if (len == 2) { - if (strEQ(d,"GT")) return KEY_gt; - if (strEQ(d,"GE")) return KEY_ge; + if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;} + if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;} } break; case 'g': @@ -2934,72 +3240,72 @@ I32 len; if (*d == 'p') { switch (len) { case 7: - if (strEQ(d,"ppid")) return KEY_getppid; - if (strEQ(d,"pgrp")) return KEY_getpgrp; + if (strEQ(d,"ppid")) return -KEY_getppid; + if (strEQ(d,"pgrp")) return -KEY_getpgrp; break; case 8: - if (strEQ(d,"pwent")) return KEY_getpwent; - if (strEQ(d,"pwnam")) return KEY_getpwnam; - if (strEQ(d,"pwuid")) return KEY_getpwuid; + if (strEQ(d,"pwent")) return -KEY_getpwent; + if (strEQ(d,"pwnam")) return -KEY_getpwnam; + if (strEQ(d,"pwuid")) return -KEY_getpwuid; break; case 11: - if (strEQ(d,"peername")) return KEY_getpeername; - if (strEQ(d,"protoent")) return KEY_getprotoent; - if (strEQ(d,"priority")) return KEY_getpriority; + if (strEQ(d,"peername")) return -KEY_getpeername; + if (strEQ(d,"protoent")) return -KEY_getprotoent; + if (strEQ(d,"priority")) return -KEY_getpriority; break; case 14: - if (strEQ(d,"protobyname")) return KEY_getprotobyname; + if (strEQ(d,"protobyname")) return -KEY_getprotobyname; break; case 16: - if (strEQ(d,"protobynumber"))return KEY_getprotobynumber; + if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber; break; } } else if (*d == 'h') { - if (strEQ(d,"hostbyname")) return KEY_gethostbyname; - if (strEQ(d,"hostbyaddr")) return KEY_gethostbyaddr; - if (strEQ(d,"hostent")) return KEY_gethostent; + if (strEQ(d,"hostbyname")) return -KEY_gethostbyname; + if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr; + if (strEQ(d,"hostent")) return -KEY_gethostent; } else if (*d == 'n') { - if (strEQ(d,"netbyname")) return KEY_getnetbyname; - if (strEQ(d,"netbyaddr")) return KEY_getnetbyaddr; - if (strEQ(d,"netent")) return KEY_getnetent; + if (strEQ(d,"netbyname")) return -KEY_getnetbyname; + if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr; + if (strEQ(d,"netent")) return -KEY_getnetent; } else if (*d == 's') { - if (strEQ(d,"servbyname")) return KEY_getservbyname; - if (strEQ(d,"servbyport")) return KEY_getservbyport; - if (strEQ(d,"servent")) return KEY_getservent; - if (strEQ(d,"sockname")) return KEY_getsockname; - if (strEQ(d,"sockopt")) return KEY_getsockopt; + if (strEQ(d,"servbyname")) return -KEY_getservbyname; + if (strEQ(d,"servbyport")) return -KEY_getservbyport; + if (strEQ(d,"servent")) return -KEY_getservent; + if (strEQ(d,"sockname")) return -KEY_getsockname; + if (strEQ(d,"sockopt")) return -KEY_getsockopt; } else if (*d == 'g') { - if (strEQ(d,"grent")) return KEY_getgrent; - if (strEQ(d,"grnam")) return KEY_getgrnam; - if (strEQ(d,"grgid")) return KEY_getgrgid; + if (strEQ(d,"grent")) return -KEY_getgrent; + if (strEQ(d,"grnam")) return -KEY_getgrnam; + if (strEQ(d,"grgid")) return -KEY_getgrgid; } else if (*d == 'l') { - if (strEQ(d,"login")) return KEY_getlogin; + if (strEQ(d,"login")) return -KEY_getlogin; } - else if (strEQ(d,"c")) return KEY_getc; + else if (strEQ(d,"c")) return -KEY_getc; break; } switch (len) { case 2: - if (strEQ(d,"gt")) return KEY_gt; - if (strEQ(d,"ge")) return KEY_ge; + if (strEQ(d,"gt")) return -KEY_gt; + if (strEQ(d,"ge")) return -KEY_ge; break; case 4: if (strEQ(d,"grep")) return KEY_grep; if (strEQ(d,"goto")) return KEY_goto; - if (strEQ(d,"glob")) return KEY_glob; + if (strEQ(d,"glob")) return -KEY_glob; break; case 6: - if (strEQ(d,"gmtime")) return KEY_gmtime; + if (strEQ(d,"gmtime")) return -KEY_gmtime; break; } break; case 'h': - if (strEQ(d,"hex")) return KEY_hex; + if (strEQ(d,"hex")) return -KEY_hex; break; case 'i': switch (len) { @@ -3007,56 +3313,56 @@ I32 len; if (strEQ(d,"if")) return KEY_if; break; case 3: - if (strEQ(d,"int")) return KEY_int; + if (strEQ(d,"int")) return -KEY_int; break; case 5: - if (strEQ(d,"index")) return KEY_index; - if (strEQ(d,"ioctl")) return KEY_ioctl; + if (strEQ(d,"index")) return -KEY_index; + if (strEQ(d,"ioctl")) return -KEY_ioctl; break; } break; case 'j': - if (strEQ(d,"join")) return KEY_join; + if (strEQ(d,"join")) return -KEY_join; break; case 'k': if (len == 4) { if (strEQ(d,"keys")) return KEY_keys; - if (strEQ(d,"kill")) return KEY_kill; + if (strEQ(d,"kill")) return -KEY_kill; } break; case 'L': if (len == 2) { - if (strEQ(d,"LT")) return KEY_lt; - if (strEQ(d,"LE")) return KEY_le; + if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;} + if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;} } break; case 'l': switch (len) { case 2: - if (strEQ(d,"lt")) return KEY_lt; - if (strEQ(d,"le")) return KEY_le; - if (strEQ(d,"lc")) return KEY_lc; + if (strEQ(d,"lt")) return -KEY_lt; + if (strEQ(d,"le")) return -KEY_le; + if (strEQ(d,"lc")) return -KEY_lc; break; case 3: - if (strEQ(d,"log")) return KEY_log; + if (strEQ(d,"log")) return -KEY_log; break; case 4: if (strEQ(d,"last")) return KEY_last; - if (strEQ(d,"link")) return KEY_link; + if (strEQ(d,"link")) return -KEY_link; break; case 5: if (strEQ(d,"local")) return KEY_local; - if (strEQ(d,"lstat")) return KEY_lstat; + if (strEQ(d,"lstat")) return -KEY_lstat; break; case 6: - if (strEQ(d,"length")) return KEY_length; - if (strEQ(d,"listen")) return KEY_listen; + if (strEQ(d,"length")) return -KEY_length; + if (strEQ(d,"listen")) return -KEY_listen; break; case 7: - if (strEQ(d,"lcfirst")) return KEY_lcfirst; + if (strEQ(d,"lcfirst")) return -KEY_lcfirst; break; case 9: - if (strEQ(d,"localtime")) return KEY_localtime; + if (strEQ(d,"localtime")) return -KEY_localtime; break; } break; @@ -3066,38 +3372,43 @@ I32 len; case 2: if (strEQ(d,"my")) return KEY_my; break; + case 3: + if (strEQ(d,"map")) return KEY_map; + break; case 5: - if (strEQ(d,"mkdir")) return KEY_mkdir; + if (strEQ(d,"mkdir")) return -KEY_mkdir; break; case 6: - if (strEQ(d,"msgctl")) return KEY_msgctl; - if (strEQ(d,"msgget")) return KEY_msgget; - if (strEQ(d,"msgrcv")) return KEY_msgrcv; - if (strEQ(d,"msgsnd")) return KEY_msgsnd; + if (strEQ(d,"msgctl")) return -KEY_msgctl; + if (strEQ(d,"msgget")) return -KEY_msgget; + if (strEQ(d,"msgrcv")) return -KEY_msgrcv; + if (strEQ(d,"msgsnd")) return -KEY_msgsnd; break; } break; case 'N': - if (strEQ(d,"NE")) return KEY_ne; + if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;} break; case 'n': if (strEQ(d,"next")) return KEY_next; - if (strEQ(d,"ne")) return KEY_ne; + if (strEQ(d,"ne")) return -KEY_ne; + if (strEQ(d,"not")) return -KEY_not; + if (strEQ(d,"no")) return KEY_no; break; case 'o': switch (len) { case 2: - if (strEQ(d,"or")) return KEY_or; + if (strEQ(d,"or")) return -KEY_or; break; case 3: - if (strEQ(d,"ord")) return KEY_ord; - if (strEQ(d,"oct")) return KEY_oct; + if (strEQ(d,"ord")) return -KEY_ord; + if (strEQ(d,"oct")) return -KEY_oct; break; case 4: - if (strEQ(d,"open")) return KEY_open; + if (strEQ(d,"open")) return -KEY_open; break; case 7: - if (strEQ(d,"opendir")) return KEY_opendir; + if (strEQ(d,"opendir")) return -KEY_opendir; break; } break; @@ -3105,11 +3416,12 @@ I32 len; switch (len) { case 3: if (strEQ(d,"pop")) return KEY_pop; + if (strEQ(d,"pos")) return KEY_pos; break; case 4: if (strEQ(d,"push")) return KEY_push; - if (strEQ(d,"pack")) return KEY_pack; - if (strEQ(d,"pipe")) return KEY_pipe; + if (strEQ(d,"pack")) return -KEY_pack; + if (strEQ(d,"pipe")) return -KEY_pipe; break; case 5: if (strEQ(d,"print")) return KEY_print; @@ -3129,39 +3441,40 @@ I32 len; if (strEQ(d,"qw")) return KEY_qw; if (strEQ(d,"qx")) return KEY_qx; } + else if (strEQ(d,"quotemeta")) return -KEY_quotemeta; break; case 'r': switch (len) { case 3: - if (strEQ(d,"ref")) return KEY_ref; + if (strEQ(d,"ref")) return -KEY_ref; break; case 4: - if (strEQ(d,"read")) return KEY_read; - if (strEQ(d,"rand")) return KEY_rand; - if (strEQ(d,"recv")) return KEY_recv; + if (strEQ(d,"read")) return -KEY_read; + if (strEQ(d,"rand")) return -KEY_rand; + if (strEQ(d,"recv")) return -KEY_recv; if (strEQ(d,"redo")) return KEY_redo; break; case 5: - if (strEQ(d,"rmdir")) return KEY_rmdir; - if (strEQ(d,"reset")) return KEY_reset; + if (strEQ(d,"rmdir")) return -KEY_rmdir; + if (strEQ(d,"reset")) return -KEY_reset; break; case 6: if (strEQ(d,"return")) return KEY_return; - if (strEQ(d,"rename")) return KEY_rename; - if (strEQ(d,"rindex")) return KEY_rindex; + if (strEQ(d,"rename")) return -KEY_rename; + if (strEQ(d,"rindex")) return -KEY_rindex; break; case 7: - if (strEQ(d,"require")) return KEY_require; - if (strEQ(d,"reverse")) return KEY_reverse; - if (strEQ(d,"readdir")) return KEY_readdir; + if (strEQ(d,"require")) return -KEY_require; + if (strEQ(d,"reverse")) return -KEY_reverse; + if (strEQ(d,"readdir")) return -KEY_readdir; break; case 8: - if (strEQ(d,"readlink")) return KEY_readlink; - if (strEQ(d,"readline")) return KEY_readline; - if (strEQ(d,"readpipe")) return KEY_readpipe; + if (strEQ(d,"readlink")) return -KEY_readlink; + if (strEQ(d,"readline")) return -KEY_readline; + if (strEQ(d,"readpipe")) return -KEY_readpipe; break; case 9: - if (strEQ(d,"rewinddir")) return KEY_rewinddir; + if (strEQ(d,"rewinddir")) return -KEY_rewinddir; break; } break; @@ -3174,36 +3487,36 @@ I32 len; case 'e': switch (len) { case 4: - if (strEQ(d,"seek")) return KEY_seek; - if (strEQ(d,"send")) return KEY_send; + if (strEQ(d,"seek")) return -KEY_seek; + if (strEQ(d,"send")) return -KEY_send; break; case 5: - if (strEQ(d,"semop")) return KEY_semop; + if (strEQ(d,"semop")) return -KEY_semop; break; case 6: - if (strEQ(d,"select")) return KEY_select; - if (strEQ(d,"semctl")) return KEY_semctl; - if (strEQ(d,"semget")) return KEY_semget; + if (strEQ(d,"select")) return -KEY_select; + if (strEQ(d,"semctl")) return -KEY_semctl; + if (strEQ(d,"semget")) return -KEY_semget; break; case 7: - if (strEQ(d,"setpgrp")) return KEY_setpgrp; - if (strEQ(d,"seekdir")) return KEY_seekdir; + if (strEQ(d,"setpgrp")) return -KEY_setpgrp; + if (strEQ(d,"seekdir")) return -KEY_seekdir; break; case 8: - if (strEQ(d,"setpwent")) return KEY_setpwent; - if (strEQ(d,"setgrent")) return KEY_setgrent; + if (strEQ(d,"setpwent")) return -KEY_setpwent; + if (strEQ(d,"setgrent")) return -KEY_setgrent; break; case 9: - if (strEQ(d,"setnetent")) return KEY_setnetent; + if (strEQ(d,"setnetent")) return -KEY_setnetent; break; case 10: - if (strEQ(d,"setsockopt")) return KEY_setsockopt; - if (strEQ(d,"sethostent")) return KEY_sethostent; - if (strEQ(d,"setservent")) return KEY_setservent; + if (strEQ(d,"setsockopt")) return -KEY_setsockopt; + if (strEQ(d,"sethostent")) return -KEY_sethostent; + if (strEQ(d,"setservent")) return -KEY_setservent; break; case 11: - if (strEQ(d,"setpriority")) return KEY_setpriority; - if (strEQ(d,"setprotoent")) return KEY_setprotoent; + if (strEQ(d,"setpriority")) return -KEY_setpriority; + if (strEQ(d,"setprotoent")) return -KEY_setprotoent; break; } break; @@ -3213,60 +3526,60 @@ I32 len; if (strEQ(d,"shift")) return KEY_shift; break; case 6: - if (strEQ(d,"shmctl")) return KEY_shmctl; - if (strEQ(d,"shmget")) return KEY_shmget; + if (strEQ(d,"shmctl")) return -KEY_shmctl; + if (strEQ(d,"shmget")) return -KEY_shmget; break; case 7: - if (strEQ(d,"shmread")) return KEY_shmread; + if (strEQ(d,"shmread")) return -KEY_shmread; break; case 8: - if (strEQ(d,"shmwrite")) return KEY_shmwrite; - if (strEQ(d,"shutdown")) return KEY_shutdown; + if (strEQ(d,"shmwrite")) return -KEY_shmwrite; + if (strEQ(d,"shutdown")) return -KEY_shutdown; break; } break; case 'i': - if (strEQ(d,"sin")) return KEY_sin; + if (strEQ(d,"sin")) return -KEY_sin; break; case 'l': - if (strEQ(d,"sleep")) return KEY_sleep; + if (strEQ(d,"sleep")) return -KEY_sleep; break; case 'o': if (strEQ(d,"sort")) return KEY_sort; - if (strEQ(d,"socket")) return KEY_socket; - if (strEQ(d,"socketpair")) return KEY_socketpair; + if (strEQ(d,"socket")) return -KEY_socket; + if (strEQ(d,"socketpair")) return -KEY_socketpair; break; case 'p': if (strEQ(d,"split")) return KEY_split; - if (strEQ(d,"sprintf")) return KEY_sprintf; + if (strEQ(d,"sprintf")) return -KEY_sprintf; if (strEQ(d,"splice")) return KEY_splice; break; case 'q': - if (strEQ(d,"sqrt")) return KEY_sqrt; + if (strEQ(d,"sqrt")) return -KEY_sqrt; break; case 'r': - if (strEQ(d,"srand")) return KEY_srand; + if (strEQ(d,"srand")) return -KEY_srand; break; case 't': - if (strEQ(d,"stat")) return KEY_stat; + if (strEQ(d,"stat")) return -KEY_stat; if (strEQ(d,"study")) return KEY_study; break; case 'u': - if (strEQ(d,"substr")) return KEY_substr; + if (strEQ(d,"substr")) return -KEY_substr; if (strEQ(d,"sub")) return KEY_sub; break; case 'y': switch (len) { case 6: - if (strEQ(d,"system")) return KEY_system; + if (strEQ(d,"system")) return -KEY_system; break; case 7: - if (strEQ(d,"sysread")) return KEY_sysread; - if (strEQ(d,"symlink")) return KEY_symlink; - if (strEQ(d,"syscall")) return KEY_syscall; + if (strEQ(d,"sysread")) return -KEY_sysread; + if (strEQ(d,"symlink")) return -KEY_symlink; + if (strEQ(d,"syscall")) return -KEY_syscall; break; case 8: - if (strEQ(d,"syswrite")) return KEY_syswrite; + if (strEQ(d,"syswrite")) return -KEY_syswrite; break; } break; @@ -3281,67 +3594,71 @@ I32 len; if (strEQ(d,"tie")) return KEY_tie; break; case 4: - if (strEQ(d,"tell")) return KEY_tell; - if (strEQ(d,"time")) return KEY_time; + if (strEQ(d,"tell")) return -KEY_tell; + if (strEQ(d,"time")) return -KEY_time; break; case 5: - if (strEQ(d,"times")) return KEY_times; + if (strEQ(d,"times")) return -KEY_times; break; case 7: - if (strEQ(d,"telldir")) return KEY_telldir; + if (strEQ(d,"telldir")) return -KEY_telldir; break; case 8: - if (strEQ(d,"truncate")) return KEY_truncate; + if (strEQ(d,"truncate")) return -KEY_truncate; break; } break; case 'u': switch (len) { case 2: - if (strEQ(d,"uc")) return KEY_uc; + if (strEQ(d,"uc")) return -KEY_uc; + break; + case 3: + if (strEQ(d,"use")) return KEY_use; break; case 5: if (strEQ(d,"undef")) return KEY_undef; if (strEQ(d,"until")) return KEY_until; if (strEQ(d,"untie")) return KEY_untie; - if (strEQ(d,"utime")) return KEY_utime; - if (strEQ(d,"umask")) return KEY_umask; + if (strEQ(d,"utime")) return -KEY_utime; + if (strEQ(d,"umask")) return -KEY_umask; break; case 6: if (strEQ(d,"unless")) return KEY_unless; - if (strEQ(d,"unpack")) return KEY_unpack; - if (strEQ(d,"unlink")) return KEY_unlink; + if (strEQ(d,"unpack")) return -KEY_unpack; + if (strEQ(d,"unlink")) return -KEY_unlink; break; case 7: if (strEQ(d,"unshift")) return KEY_unshift; - if (strEQ(d,"ucfirst")) return KEY_ucfirst; + if (strEQ(d,"ucfirst")) return -KEY_ucfirst; break; } break; case 'v': - if (strEQ(d,"values")) return KEY_values; - if (strEQ(d,"vec")) return KEY_vec; + if (strEQ(d,"values")) return -KEY_values; + if (strEQ(d,"vec")) return -KEY_vec; break; case 'w': switch (len) { case 4: - if (strEQ(d,"warn")) return KEY_warn; - if (strEQ(d,"wait")) return KEY_wait; + if (strEQ(d,"warn")) return -KEY_warn; + if (strEQ(d,"wait")) return -KEY_wait; break; case 5: if (strEQ(d,"while")) return KEY_while; - if (strEQ(d,"write")) return KEY_write; + if (strEQ(d,"write")) return -KEY_write; break; case 7: - if (strEQ(d,"waitpid")) return KEY_waitpid; + if (strEQ(d,"waitpid")) return -KEY_waitpid; break; case 9: - if (strEQ(d,"wantarray")) return KEY_wantarray; + if (strEQ(d,"wantarray")) return -KEY_wantarray; break; } break; case 'x': - if (len == 1) return KEY_x; + if (len == 1) return -KEY_x; + if (strEQ(d,"xor")) return -KEY_xor; break; case 'y': if (len == 1) return KEY_y; @@ -3361,10 +3678,16 @@ char *what; char *w; if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ - w = strchr(s,')'); - if (w) - for (w++; *w && isSPACE(*w); w++) ; - if (!w || !*w || !strchr(";|}", *w)) /* an advisory hack only... */ + int level = 1; + for (w = s+2; *w && level; w++) { + if (*w == '(') + ++level; + else if (*w == ')') + --level; + } + if (*w) + for (; *w && isSPACE(*w); w++) ; + if (!*w || !strchr(";|})]oa!=", *w)) /* an advisory hack only... */ warn("%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) @@ -3432,6 +3755,8 @@ I32 ck_uni; if (lex_brackets == 0) lex_fakebrack = 0; s++; + if (isSPACE(*s)) + s = skipspace(s); d = dest; if (isDIGIT(*s)) { while (isDIGIT(*s)) @@ -3446,7 +3771,7 @@ I32 ck_uni; *d++ = ':'; s++; } - else if (*s == ':' && s[1] == ':' && isIDFIRST(s[2])) { + else if (*s == ':' && s[1] == ':') { *d++ = *s++; *d++ = *s++; } @@ -3461,10 +3786,11 @@ I32 ck_uni; lex_state = LEX_INTERPENDMAYBE; return s; } - if (isSPACE(*s) || - (*s == '$' && s[1] && (isALPHA(s[1]) || strchr("$_{", s[1])))) - return s; + if (*s == '$' && s[1] && (isALPHA(s[1]) || strchr("$_{", s[1]))) + return s; if (*s == '{') { + if (lex_state == LEX_NORMAL) + return s; bracket = s; s++; } @@ -3482,12 +3808,12 @@ I32 ck_uni; while (isALNUM(*s)) *d++ = *s++; *d = '\0'; - if (*s == '[' || *s == '{') { + if ((*s == '[' || *s == '{') && !keyword(dest,d-dest)) { if (lex_brackets) croak("Can't use delimiter brackets within expression"); lex_fakebrack = TRUE; bracket++; - lex_brackets++; + lex_brackstack[lex_brackets++] = XOPERATOR; return s; } } @@ -3506,6 +3832,7 @@ I32 ck_uni; return s; } +#ifdef NOTDEF void scan_prefix(pm,string,len) PMOP *pm; @@ -3536,12 +3863,18 @@ I32 len; else goto defchar; break; - case '.': case '[': case '$': case '(': case ')': case '|': case '+': + case '(': + if (d[1] == '?') { /* All bets off. */ + SvREFCNT_dec(tmpstr); + return; + } + /* FALL THROUGH */ + case '.': case '[': case '$': case ')': case '|': case '+': case '^': e = d; break; case '\\': - if (d[1] && strchr("wWbB0123456789sSdDlLuUExc",d[1])) { + if (d[1] && strchr("AGZwWbB0123456789sSdDlLuUExc",d[1])) { e = d; break; } @@ -3590,6 +3923,27 @@ I32 len; pm->op_pmshort = tmpstr; pm->op_pmslen = d - t; } +#endif + +void pmflag(pmfl,ch) +U16* pmfl; +int ch; +{ + if (ch == 'i') { + sawi = TRUE; + *pmfl |= PMf_FOLD; + } + else if (ch == 'g') + *pmfl |= PMf_GLOBAL; + else if (ch == 'o') + *pmfl |= PMf_KEEP; + else if (ch == 'm') + *pmfl |= PMf_MULTILINE; + else if (ch == 's') + *pmfl |= PMf_SINGLELINE; + else if (ch == 'x') + *pmfl |= PMf_EXTENDED; +} static char * scan_pat(start) @@ -3598,8 +3952,6 @@ char *start; PMOP *pm; char *s; - multi_start = curcop->cop_line; - s = scan_str(start); if (!s) { if (lex_stuff) @@ -3608,24 +3960,11 @@ char *start; croak("Search pattern not terminated"); } pm = (PMOP*)newPMOP(OP_MATCH, 0); - if (*start == '?') + if (multi_open == '?') pm->op_pmflags |= PMf_ONCE; - while (*s == 'i' || *s == 'o' || *s == 'g') { - if (*s == 'i') { - s++; - sawi = TRUE; - pm->op_pmflags |= PMf_FOLD; - } - if (*s == 'o') { - s++; - pm->op_pmflags |= PMf_KEEP; - } - if (*s == 'g') { - s++; - pm->op_pmflags |= PMf_GLOBAL; - } - } + while (*s && strchr("iogmsx", *s)) + pmflag(&pm->op_pmflags,*s++); lex_op = (OP*)pm; yylval.ival = OP_MATCH; @@ -3636,14 +3975,13 @@ static char * scan_subst(start) char *start; { - register char *s = start; + register char *s; register PMOP *pm; I32 es = 0; - multi_start = curcop->cop_line; yylval.ival = OP_NULL; - s = scan_str(s); + s = scan_str(start); if (!s) { if (lex_stuff) @@ -3652,7 +3990,7 @@ char *start; croak("Substitution pattern not terminated"); } - if (s[-1] == *start) + if (s[-1] == multi_open) s--; s = scan_str(s); @@ -3667,24 +4005,13 @@ char *start; } pm = (PMOP*)newPMOP(OP_SUBST, 0); - while (*s == 'g' || *s == 'i' || *s == 'e' || *s == 'o') { + while (*s && strchr("iogmsex", *s)) { if (*s == 'e') { s++; es++; } - if (*s == 'g') { - s++; - pm->op_pmflags |= PMf_GLOBAL; - } - if (*s == 'i') { - s++; - sawi = TRUE; - pm->op_pmflags |= PMf_FOLD; - } - if (*s == 'o') { - s++; - pm->op_pmflags |= PMf_KEEP; - } + else + pmflag(&pm->op_pmflags,*s++); } if (es) { @@ -3692,7 +4019,7 @@ char *start; pm->op_pmflags |= PMf_EVAL; repl = newSVpv("",0); while (es-- > 0) - sv_catpvn(repl, "eval ", 5); + sv_catpv(repl, es ? "eval " : "do "); sv_catpvn(repl, "{ ", 2); sv_catsv(repl, lex_repl); sv_catpvn(repl, " };", 2); @@ -3748,7 +4075,7 @@ static char * scan_trans(start) char *start; { - register char *s = start; + register char* s; OP *op; short *tbl; I32 squash; @@ -3757,14 +4084,14 @@ char *start; yylval.ival = OP_NULL; - s = scan_str(s); + s = scan_str(start); if (!s) { if (lex_stuff) SvREFCNT_dec(lex_stuff); lex_stuff = Nullsv; croak("Translation pattern not terminated"); } - if (s[-1] == *start) + if (s[-1] == multi_open) s--; s = scan_str(s); @@ -3846,6 +4173,8 @@ register char *s; multi_start = curcop->cop_line; multi_open = multi_close = '<'; tmpstr = NEWSV(87,80); + sv_upgrade(tmpstr, SVt_PVIV); + SvIVX(tmpstr) = '\\'; term = *tokenbuf; if (!rsfp) { d = s; @@ -3922,7 +4251,7 @@ char *start; croak("Unterminated <> operator"); if (*d == '$') d++; - while (*d && (isALNUM(*d) || *d == '\'')) + while (*d && (isALNUM(*d) || *d == '\'' || *d == ':')) d++; if (d - tokenbuf != len) { yylval.ival = OP_GLOB; @@ -3937,22 +4266,23 @@ char *start; if (!len) (void)strcpy(d,"ARGV"); if (*d == '$') { - GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV); - lex_op = (OP*)newUNOP(OP_READLINE, 0, - newUNOP(OP_RV2GV, 0, - newUNOP(OP_RV2SV, 0, - newGVOP(OP_GV, 0, gv)))); + I32 tmp; + if (tmp = pad_findmy(d)) { + OP *op = newOP(OP_PADSV, 0); + op->op_targ = tmp; + lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, op)); + } + else { + GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV); + lex_op = (OP*)newUNOP(OP_READLINE, 0, + newUNOP(OP_RV2GV, 0, + newUNOP(OP_RV2SV, 0, + newGVOP(OP_GV, 0, gv)))); + } yylval.ival = OP_NULL; } else { - IO *io; - GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO); - io = GvIOn(gv); - if (strEQ(d,"ARGV")) { - GvAVn(gv); - IoFLAGS(io) |= IOf_ARGV|IOf_START; - } lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv)); yylval.ival = OP_NULL; } @@ -3967,11 +4297,14 @@ char *start; SV *sv; char *tmps; register char *s = start; - register char term = *s; + register char term; register char *to; I32 brackets = 1; + if (isSPACE(*s)) + s = skipspace(s); CLINE; + term = *s; multi_start = curcop->cop_line; multi_open = term; if (term && (tmps = strchr("([{< )]}> )]}>",term))) @@ -3981,7 +4314,7 @@ char *start; sv = NEWSV(87,80); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = term; - SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only(sv); /* validate pointer */ s++; for (;;) { SvGROW(sv, SvCUR(sv) + (bufend - s) + 1); @@ -3990,8 +4323,12 @@ char *start; for (; s < bufend; s++,to++) { if (*s == '\n' && !rsfp) curcop->cop_line++; - if (*s == '\\' && s+1 < bufend && term != '\\') - *to++ = *s++; + if (*s == '\\' && s+1 < bufend && term != '\\') { + if (s[1] == term) + s++; + else + *to++ = *s++; + } else if (*s == term) break; *to = *s; @@ -4001,8 +4338,12 @@ char *start; for (; s < bufend; s++,to++) { if (*s == '\n' && !rsfp) curcop->cop_line++; - if (*s == '\\' && s+1 < bufend && term != '\\') - *to++ = *s++; + if (*s == '\\' && s+1 < bufend && term != '\\') { + if (s[1] == term) + s++; + else + *to++ = *s++; + } else if (*s == term && --brackets <= 0) break; else if (*s == multi_open) @@ -4164,7 +4505,7 @@ register char *s; { register char *eol; register char *t; - SV *stuff = newSV(0); + SV *stuff = newSVpv("",0); bool needargs = FALSE; while (!needargs) { @@ -4182,19 +4523,21 @@ register char *s; else eol = bufend = SvPVX(linestr) + SvCUR(linestr); if (*s != '#') { - sv_catpvn(stuff, s, eol-s); - while (s < eol) { - if (*s == '@' || *s == '^') { - needargs = TRUE; - break; + for (t = s; t < eol; t++) { + if (*t == '~' && t[1] == '~' && SvCUR(stuff)) { + needargs = FALSE; + goto enough; /* ~~ must be first line in formline */ } - s++; + if (*t == '@' || *t == '^') + needargs = TRUE; } + sv_catpvn(stuff, s, eol-s); } s = eol; if (rsfp) { s = sv_gets(linestr, rsfp, 0); oldoldbufptr = oldbufptr = bufptr = SvPVX(linestr); + bufend = bufptr + SvCUR(linestr); if (!s) { s = bufptr; yyerror("Format not terminated"); @@ -4203,12 +4546,16 @@ register char *s; } incline(s); } - if (SvPOK(stuff)) { + enough: + if (SvCUR(stuff)) { expect = XTERM; if (needargs) { + lex_state = LEX_NORMAL; nextval[nexttoke].ival = 0; force_next(','); } + else + lex_state = LEX_FORMLINE; nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff); force_next(THING); nextval[nexttoke].ival = OP_FORMLINE; @@ -4246,7 +4593,9 @@ start_subparse() SAVEINT(min_intro_pending); SAVEINT(max_intro_pending); comppad = newAV(); + SAVEFREESV((SV*)comppad); comppad_name = newAV(); + SAVEFREESV((SV*)comppad_name); comppad_name_fill = 0; min_intro_pending = 0; av_push(comppad, Nullsv); @@ -4270,22 +4619,19 @@ yyerror(s) char *s; { char tmpbuf[258]; - char tmp2buf[258]; char *tname = tmpbuf; if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 && oldoldbufptr != oldbufptr && oldbufptr != bufptr) { while (isSPACE(*oldoldbufptr)) oldoldbufptr++; - cpy7bit(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr); - sprintf(tname,"near \"%s\"",tmp2buf); + sprintf(tname,"near \"%.*s\"",bufptr - oldoldbufptr, oldoldbufptr); } else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 && oldbufptr != bufptr) { while (isSPACE(*oldbufptr)) oldbufptr++; - cpy7bit(tmp2buf, oldbufptr, bufptr - oldbufptr); - sprintf(tname,"near \"%s\"",tmp2buf); + sprintf(tname,"near \"%.*s\"",bufptr - oldbufptr, oldbufptr); } else if (yychar > 255) tname = "next token ???"; @@ -4296,7 +4642,7 @@ char *s; (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL)) (void)strcpy(tname,"at end of line"); else - (void)strcpy(tname,"at end of string"); + (void)strcpy(tname,"within string"); } else if (yychar < 32) (void)sprintf(tname,"next char ^%c",yychar+64); @@ -4304,10 +4650,12 @@ char *s; (void)sprintf(tname,"next char %c",yychar); (void)sprintf(buf, "%s at %s line %d, %s\n", s,SvPVX(GvSV(curcop->cop_filegv)),curcop->cop_line,tname); - if (curcop->cop_line == multi_end && multi_start < multi_end) + if (curcop->cop_line == multi_end && multi_start < multi_end) { sprintf(buf+strlen(buf), - " (Might be a runaway multi-line %c%c string starting on line %d)\n", - multi_open,multi_close,multi_start); + " (Might be a runaway multi-line %c%c string starting on line %ld)\n", + multi_open,multi_close,(long)multi_start); + multi_end = 0; + } if (in_eval) sv_catpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),buf); else diff --git a/toke.c.pat1 b/toke.c.pat1 deleted file mode 100644 index 60ec8bb721..0000000000 --- a/toke.c.pat1 +++ /dev/null @@ -1,21 +0,0 @@ -*** /scalpel/lwall/perl5alpha6/toke.c Tue Feb 15 16:27:34 1994 ---- toke.c Thu Feb 17 11:13:27 1994 -*************** -*** 1398,1405 **** - if (expect == XTERM) - OPERATOR(HASHBRACK); - else if (expect == XBLOCK || expect == XOPERATOR) { -! lex_brackstack[lex_brackets-1] = XBLOCK; -! expect = XBLOCK; - } - else { - char *t; ---- 1398,1405 ---- - if (expect == XTERM) - OPERATOR(HASHBRACK); - else if (expect == XBLOCK || expect == XOPERATOR) { -! lex_brackstack[lex_brackets-1] = XSTATE; -! expect = XSTATE; - } - else { - char *t; diff --git a/trace.out b/trace.out deleted file mode 100644 index e69de29bb2..0000000000 --- a/trace.out +++ /dev/null @@ -1,100 +0,0 @@ -#!./perl -Dxstp - -# This is written in a peculiar style, since we're trying to avoid -# most of the constructs we'll be testing for. - -$| = 1; - -if ($ARGV[0] eq '-v') { - $verbose = 1; - shift; -} - -chdir 't' if -f 't/TEST'; - -if ($ARGV[0] eq '') { - @ARGV = split(/[ \n]/, - `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`); -} - -open(CONFIG,"../foo.sh"); -while (<CONFIG>) { - if (/sharpbang='(.*)'/) { - $sharpbang = ($1 eq '#!'); - last; - } -} -$bad = 0; -while ($test = shift) { - if ($test =~ /^$/) { - next; - } - $te = $test; - chop($te); - print "$te" . '.' x (15 - length($te)); - if ($sharpbang) { - open(results,"./$test|") || (print "can't run.\n"); - } else { - open(script,"$test") || die "Can't run $test.\n"; - $_ = <script>; - close(script); - if (/#!..perl(.*)/) { - $switch = $1; - } else { - $switch = ''; - } - open(results,"./perl$switch $test|") || (print "can't run.\n"); - } - $ok = 0; - $next = 0; - while (<results>) { - if ($verbose) { - print $_; - } - unless (/^#/) { - if (/^1\.\.([0-9]+)/) { - $max = $1; - $totmax += $max; - $files += 1; - $next = 1; - $ok = 1; - } else { - $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; - if (/^ok (.*)/ && $1 == $next) { - $next = $next + 1; - } else { - $ok = 0; - } - } - } - } - $next = $next - 1; - if ($ok && $next == $max) { - print "ok\n"; - } else { - $next += 1; - print "FAILED on test $next\n"; - $bad = $bad + 1; - $_ = $test; - if (/^base/) { - die "Failed a basic test--cannot continue.\n"; - } - } -} - -if ($bad == 0) { - if ($ok) { - print "All tests successful.\n"; - } else { - die "FAILED--no tests were run for some reason.\n"; - } -} else { - if ($bad == 1) { - die "Failed 1 test.\n"; - } else { - die "Failed $bad tests.\n"; - } -} -($user,$sys,$cuser,$csys) = times; -print sprintf("u=%g s=%g cu=%g cs=%g files=%d tests=%d\n", - $user,$sys,$cuser,$csys,$files,$totmax); @@ -1,12 +0,0 @@ -#!/usr/bin/perl -00 - -$* = 1; -while (<>) { - if (/^do_(\w+)/) { - open(OUT, ">>do/$1"); - } - print OUT; - chop; - chop; - close OUT if chop eq '}' && chop eq "\n"; -} @@ -5,18 +5,22 @@ * are not checked by the configuration script, but are directly defined * here. */ -#define HAS_ALARM -#define HAS_CHOWN -#define HAS_CHROOT -#define HAS_FORK -#define HAS_GETLOGIN -#define HAS_GETPPID + +/* 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 /**/ + #define HAS_KILL #define HAS_LINK -#define HAS_PIPE #define HAS_WAIT -#define HAS_UMASK -#define HAS_PAUSE /* * The following symbols are defined if your operating system supports * password and group functions in general. All Unix systems do. @@ -41,3 +45,15 @@ #endif #define ABORT() kill(getpid(),SIGABRT); +/* + * fwrite1() should be a routine with the same calling sequence as fwrite(), + * but which outputs all of the bytes requested as a single stream (unlike + * fwrite() itself, which on some systems outputs several distinct records + * if the number_of_items parameter is >1). + */ +#define fwrite1 fwrite + +#define Stat(fname,bufptr) stat((fname),(bufptr)) +#define Fstat(fd,bufptr) fstat((fd),(bufptr)) + +#define my_getenv(var) getenv(var) diff --git a/unobsolete b/unobsolete deleted file mode 100644 index d766e79f22..0000000000 --- a/unobsolete +++ /dev/null @@ -1,11 +0,0 @@ -replace HAS_NDBM I_NDBM atarist/config.h -replace HAS_ODBM I_DBM atarist/config.h -replace HAS_NDBM I_NDBM config_c++.h -replace HAS_ODBM I_DBM config_c++.h -replace HAS_NDBM I_NDBM hvdbm.h -replace HAS_ODBM I_DBM hvdbm.h -replace HAS_NDBM I_NDBM msdos/config.h -replace HAS_ODBM I_DBM msdos/config.h -replace HAS_NDBM I_NDBM os2/config.h -replace HAS_ODBM I_DBM os2/config.h -replace HAS_NDBM I_NDBM perl.h diff --git a/usersub.c b/usersub.c deleted file mode 100644 index 11cf321a7d..0000000000 --- a/usersub.c +++ /dev/null @@ -1,147 +0,0 @@ -/* $RCSfile: usersub.c,v $$Revision: 4.1 $$Date: 92/08/07 18:28:45 $ - * - * This file contains stubs for routines that the user may define to - * set up glue routines for C libraries or to decrypt encrypted scripts - * for execution. - * - * $Log: usersub.c,v $ - * Revision 4.1 92/08/07 18:28:45 lwall - * - * Revision 4.0.1.2 92/06/08 16:04:24 lwall - * patch20: removed implicit int declarations on functions - * - * Revision 4.0.1.1 91/11/11 16:47:17 lwall - * patch19: deleted some unused functions from usersub.c - * - * Revision 4.0 91/03/20 01:55:56 lwall - * 4.0 baseline. - * - */ - -#include "EXTERN.h" -#include "perl.h" - -int -userinit() -{ - return 0; -} - -/* - * The following is supplied by John Macdonald as a means of decrypting - * and executing (presumably proprietary) scripts that have been encrypted - * by a (presumably secret) method. The idea is that you supply your own - * routine in place of cryptfilter (which is purposefully a very weak - * encryption). If an encrypted script is detected, a process is forked - * off to run the cryptfilter routine as input to perl. - */ - -#ifdef CRYPTSCRIPT - -#include <signal.h> -#ifdef I_VFORK -#include <vfork.h> -#endif - -#ifdef CRYPTLOCAL - -#include "cryptlocal.h" - -#else /* ndef CRYPTLOCAL */ - -#define CRYPT_MAGIC_1 0xfb -#define CRYPT_MAGIC_2 0xf1 - -void -cryptfilter( fil ) -FILE * fil; -{ - int ch; - - while( (ch = getc( fil )) != EOF ) { - putchar( (ch ^ 0x80) ); - } -} - -#endif /* CRYPTLOCAL */ - -#ifndef MSDOS -static FILE *lastpipefile; -static int pipepid; - -#ifdef VOIDSIG -# define VOID void -#else -# define VOID int -#endif - -FILE * -my_pfiopen(fil,func) /* open a pipe to function call for input */ -FILE *fil; -VOID (*func)(); -{ - int p[2]; - SV *sv; - - if (pipe(p) < 0) { - fclose( fil ); - croak("Can't get pipe for decrypt"); - } - - /* make sure that the child doesn't get anything extra */ - fflush(stdout); - fflush(stderr); - - while ((pipepid = fork()) < 0) { - if (errno != EAGAIN) { - close(p[0]); - close(p[1]); - fclose( fil ); - croak("Can't fork for decrypt"); - } - sleep(5); - } - if (pipepid == 0) { - close(p[0]); - if (p[1] != 1) { - dup2(p[1], 1); - close(p[1]); - } - (*func)(fil); - fflush(stdout); - fflush(stderr); - _exit(0); - } - close(p[1]); - close(fileno(fil)); - fclose(fil); - sv = *av_fetch(fdpid,p[0],TRUE); - sv->sv_u.sv_useful = pipepid; - return fdopen(p[0], "r"); -} - -void -cryptswitch() -{ - int ch; -#ifdef USE_STD_STDIO - /* cheat on stdio if possible */ - if (rsfp->_cnt > 0 && (*rsfp->_ptr & 0xff) != CRYPT_MAGIC_1) - return; -#endif - ch = getc(rsfp); - if (ch == CRYPT_MAGIC_1) { - if (getc(rsfp) == CRYPT_MAGIC_2) { - if( perldb ) croak("can't debug an encrypted script"); - rsfp = my_pfiopen( rsfp, cryptfilter ); - preprocess = 1; /* force call to pclose when done */ - } - else - croak( "bad encryption run_format" ); - } - else - ungetc(ch,rsfp); -} -#endif /* !MSDOS */ - -#endif /* CRYPTSCRIPT */ @@ -1,48 +1,16 @@ -/* $RCSfile: util.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:00 $ +/* util.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: util.c,v $ - * Revision 4.1 92/08/07 18:29:00 lwall - * - * Revision 4.0.1.6 92/06/11 21:18:47 lwall - * patch34: boneheaded typo in my_bcopy() - * - * Revision 4.0.1.5 92/06/08 16:08:37 lwall - * patch20: removed implicit int declarations on functions - * patch20: Perl now distinguishes overlapped copies from non-overlapped - * patch20: fixed confusion between a *var's real name and its effective name - * patch20: bcopy() and memcpy() now tested for overlap safety - * patch20: added Atari ST portability - * - * Revision 4.0.1.4 91/11/11 16:48:54 lwall - * patch19: study was busted by 4.018 - * patch19: added little-endian pack/unpack options - * - * Revision 4.0.1.3 91/11/05 19:18:26 lwall - * patch11: safe malloc code now integrated into Perl's malloc when possible - * patch11: strchr("little", "longer string") could visit faraway places - * patch11: warn '-' x 10000 dumped core - * patch11: forked exec on non-existent program now issues a warning - * - * Revision 4.0.1.2 91/06/07 12:10:42 lwall - * patch4: new copyright notice - * patch4: made some allowances for "semi-standard" C - * patch4: strchr() could blow up searching for null string - * patch4: taintchecks could improperly modify parent in vfork() - * patch4: exec would close files even if you cleared close-on-exec flag - * - * Revision 4.0.1.1 91/04/12 09:19:25 lwall - * patch1: random cleanup in cpp namespace - * - * Revision 4.0 91/03/20 01:56:39 lwall - * 4.0 baseline. - * */ -/*SUPPRESS 112*/ + +/* + * "Very useful, no doubt, that was to Saruman; yet it seems that he was + * not content." --Gandalf + */ #include "EXTERN.h" #include "perl.h" @@ -68,6 +36,10 @@ #define FLUSH +#ifdef LEAKTEST +static void xstat _((void)); +#endif + #ifndef safemalloc /* paranoid version of malloc */ @@ -208,7 +180,8 @@ safexrealloc(where,size) char *where; MEM_SIZE size; { - return saferealloc(where - ALIGN, size + ALIGN) + ALIGN; + register char *new = saferealloc(where - ALIGN, size + ALIGN); + return new + ALIGN; } void @@ -247,7 +220,7 @@ cpytill(to,from,fromend,delim,retlen) register char *to; register char *from; register char *fromend; -register I32 delim; +register int delim; I32 *retlen; { char *origto = to; @@ -314,7 +287,7 @@ char *lend; register I32 first = *little; register char *littleend = lend; - if (!first && little > littleend) + if (!first && little >= littleend) return big; if (bigend - big < littleend - little) return Nullch; @@ -348,7 +321,7 @@ char *lend; register I32 first = *little; register char *littleend = lend; - if (!first && little > littleend) + if (!first && little >= littleend) return bigend; bigbeg = big; big = bigend - (littleend - little++); @@ -406,7 +379,7 @@ I32 iflag; s--,i++; } sv_upgrade(sv, SVt_PVBM); - sv_magic(sv, 0, 'B', 0, 0); /* deep magic */ + sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ SvVALID_on(sv); s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ @@ -451,10 +424,11 @@ SV *littlestr; register unsigned char *oldlittle; if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { - if (!SvPOK(littlestr) || !SvPVX(littlestr)) + STRLEN len; + char *l = SvPV(littlestr,len); + if (!len) return (char*)big; - return ninstr((char*)big,(char*)bigend, - SvPVX(littlestr), SvPVX(littlestr) + SvCUR(littlestr)); + return ninstr((char*)big,(char*)bigend, l, l + len); } littlelen = SvCUR(littlestr); @@ -657,8 +631,8 @@ SV *littlestr; I32 ibcmp(a,b,len) -register char *a; -register char *b; +register U8 *a; +register U8 *b; register I32 len; { while (len--) { @@ -676,7 +650,7 @@ register I32 len; /* copy a string to a safe spot */ char * -savestr(sv) +savepv(sv) char *sv; { register char *newaddr; @@ -689,7 +663,7 @@ char *sv; /* same thing but with a known length */ char * -nsavestr(sv, len) +savepvn(sv, len) char *sv; register I32 len; { @@ -701,7 +675,7 @@ register I32 len; return newaddr; } -#if !defined(STANDARD_C) && !defined(I_VARARGS) +#if !defined(I_STDARG) && !defined(I_VARARGS) /* * Fallback on the old hackers way of doing varargs @@ -737,13 +711,12 @@ long a1, a2, a3, a4; SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line); s += strlen(s); } - if (last_in_gv && - GvIO(last_in_gv) && - IoLINES(GvIO(last_in_gv)) ) { + if (GvIO(last_in_gv) && + IoLINES(GvIOp(last_in_gv)) ) { (void)sprintf(s,", <%s> %s %ld", last_in_gv == argvgv ? "" : GvENAME(last_in_gv), strEQ(rs,"\n") ? "line" : "chunk", - (long)IoLINES(GvIO(last_in_gv))); + (long)IoLINES(GvIOp(last_in_gv))); s += strlen(s); } (void)strcpy(s,".\n"); @@ -766,6 +739,10 @@ long a1, a2, a3, a4; char *message; message = mess(pat,a1,a2,a3,a4); + if (in_eval) { + restartop = die_where(message); + longjmp(top_env, 3); + } fputs(message,stderr); (void)fflush(stderr); if (e_fp) @@ -789,9 +766,9 @@ long a1, a2, a3, a4; (void)fflush(stderr); } -#else /* !defined(STANDARD_C) && !defined(I_VARARGS) */ +#else /* !defined(I_STDARG) && !defined(I_VARARGS) */ -#ifdef STANDARD_C +#ifdef I_STDARG char * mess(char *pat, va_list *args) #else @@ -835,13 +812,12 @@ mess(pat, args) SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line); s += strlen(s); } - if (last_in_gv && - GvIO(last_in_gv) && - IoLINES(GvIO(last_in_gv)) ) { + if (GvIO(last_in_gv) && + IoLINES(GvIOp(last_in_gv)) ) { (void)sprintf(s,", <%s> %s %ld", last_in_gv == argvgv ? "" : GvNAME(last_in_gv), strEQ(rs,"\n") ? "line" : "chunk", - (long)IoLINES(GvIO(last_in_gv))); + (long)IoLINES(GvIOp(last_in_gv))); s += strlen(s); } (void)strcpy(s,".\n"); @@ -868,18 +844,19 @@ croak(pat, va_alist) #endif { va_list args; - char *tmps; char *message; -#ifdef STANDARD_C +#ifdef I_STDARG va_start(args, pat); #else va_start(args); #endif message = mess(pat, &args); va_end(args); - if (restartop = die_where(message)) + if (in_eval) { + restartop = die_where(message); longjmp(top_env, 3); + } fputs(message,stderr); (void)fflush(stderr); if (e_fp) @@ -901,7 +878,7 @@ warn(pat,va_alist) va_list args; char *message; -#ifdef STANDARD_C +#ifdef I_STDARG va_start(args, pat); #else va_start(args); @@ -915,8 +892,9 @@ warn(pat,va_alist) #endif (void)fflush(stderr); } -#endif /* !defined(STANDARD_C) && !defined(I_VARARGS) */ +#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ +#ifndef VMS /* VMS' my_setenv() is in VMS.c */ void my_setenv(nam,val) char *nam, *val; @@ -932,7 +910,7 @@ char *nam, *val; for (max = i; environ[max]; max++) ; New(901,tmpenv, max+2, char*); for (j=0; j<max; j++) /* copy environment */ - tmpenv[j] = savestr(environ[j]); + tmpenv[j] = savepv(environ[j]); tmpenv[max] = Nullch; environ = tmpenv; /* tell exec where it is now */ } @@ -975,6 +953,7 @@ char *nam; } /* potential SEGV's */ return i; } +#endif /* !VMS */ #ifdef EUNICE I32 @@ -1227,7 +1206,7 @@ VTOH(vtohs,short) VTOH(vtohl,long) #endif -#ifndef DOSISH +#if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ FILE * my_popen(cmd,mode) char *cmd; @@ -1269,7 +1248,7 @@ char *mode; close(p[THIS]); } if (doexec) { -#if !defined(HAS_FCNTL) || !defined(FFt_SETFD) +#if !defined(HAS_FCNTL) || !defined(F_SETFD) int fd; #ifndef NOFILE @@ -1279,7 +1258,6 @@ char *mode; close(fd); #endif do_exec(cmd); /* may or may not use the shell */ - warn("Can't exec \"%s\": %s", cmd, Strerror(errno)); _exit(1); } /*SUPPRESS 560*/ @@ -1299,7 +1277,7 @@ char *mode; p[this] = p[that]; } sv = *av_fetch(fdpid,p[this],TRUE); - SvUPGRADE(sv,SVt_IV); + (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; forkprocess = pid; return fdopen(p[this], mode); @@ -1327,7 +1305,7 @@ char *s; fprintf(stderr,"%s", s); for (fd = 0; fd < 32; fd++) { - if (fstat(fd,&tmpstatbuf) >= 0) + if (Fstat(fd,&tmpstatbuf) >= 0) fprintf(stderr," %d",fd); } fprintf(stderr,"\n"); @@ -1339,9 +1317,9 @@ dup2(oldfd,newfd) int oldfd; int newfd; { -#if defined(HAS_FCNTL) && defined(FFt_DUPFD) +#if defined(HAS_FCNTL) && defined(F_DUPFD) close(newfd); - fcntl(oldfd, FFt_DUPFD, newfd); + fcntl(oldfd, F_DUPFD, newfd); #else int fdtmp[256]; I32 fdx = 0; @@ -1359,6 +1337,7 @@ int newfd; #endif #ifndef DOSISH +#ifndef VMS /* VMS' my_pclose() is in VMS.c */ I32 my_pclose(ptr) FILE *ptr; @@ -1369,12 +1348,13 @@ FILE *ptr; int (*hstat)(), (*istat)(), (*qstat)(); #endif int status; - SV *sv; + SV **svp; int pid; - sv = *av_fetch(fdpid,fileno(ptr),TRUE); - pid = SvIVX(sv); - av_store(fdpid,fileno(ptr),Nullsv); + svp = av_fetch(fdpid,fileno(ptr),TRUE); + pid = SvIVX(*svp); + SvREFCNT_dec(*svp); + *svp = &sv_undef; fclose(ptr); #ifdef UTS if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ @@ -1388,14 +1368,13 @@ FILE *ptr; signal(SIGQUIT, qstat); return(pid < 0 ? pid : status); } - +#endif /* !VMS */ I32 wait4pid(pid,statusp,flags) int pid; int *statusp; int flags; { - I32 result; SV *sv; SV** svp; char spid[16]; @@ -1416,7 +1395,7 @@ int flags; hv_iterinit(pidstatus); if (entry = hv_iternext(pidstatus)) { - pid = atoi(hv_iterkey(entry,statusp)); + pid = atoi(hv_iterkey(entry,(I32*)statusp)); sv = hv_iterval(pidstatus,entry); *statusp = SvIVX(sv); sprintf(spid, "%d", pid); @@ -1424,21 +1403,24 @@ int flags; return pid; } } -#ifdef HAS_WAIT4 - return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); -#else #ifdef HAS_WAITPID return waitpid(pid,statusp,flags); #else - if (flags) - croak("Can't do waitpid with flags"); - else { - while ((result = wait(statusp)) != pid && pid > 0 && result >= 0) - pidgone(result,*statusp); - if (result < 0) - *statusp = -1; +#ifdef HAS_WAIT4 + return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); +#else + { + I32 result; + if (flags) + croak("Can't do waitpid with flags"); + else { + while ((result = wait(statusp)) != pid && pid > 0 && result >= 0) + pidgone(result,*statusp); + if (result < 0) + *statusp = -1; + } + return result; } - return result; #endif #endif } @@ -1455,7 +1437,7 @@ int status; sprintf(spid, "%d", pid); sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE); - SvUPGRADE(sv,SVt_IV); + (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = status; return; } @@ -1529,6 +1511,22 @@ double f; } # undef BIGDOUBLE # undef BIGNEGDOUBLE + +IV +cast_iv(f) +double f; +{ + /* XXX This should be fixed. It assumes 32 bit IV's. */ +# define BIGDOUBLE 2147483648.0 /* Assume 32 bit IV's ! */ +# define BIGNEGDOUBLE (-2147483648.0) + if (f >= BIGDOUBLE) + return (IV)fmod(f, BIGDOUBLE); + if (f <= BIGNEGDOUBLE) + return (IV)fmod(f, BIGNEGDOUBLE); + return (IV) f; +} +# undef BIGDOUBLE +# undef BIGNEGDOUBLE #endif #ifndef HAS_RENAME @@ -1560,13 +1558,13 @@ char *b; strcpy(tmpbuf,"."); else strncpy(tmpbuf, a, fa - a); - if (stat(tmpbuf, &tmpstatbuf1) < 0) + if (Stat(tmpbuf, &tmpstatbuf1) < 0) return FALSE; if (fb == b) strcpy(tmpbuf,"."); else strncpy(tmpbuf, b, fb - b); - if (stat(tmpbuf, &tmpstatbuf2) < 0) + if (Stat(tmpbuf, &tmpstatbuf2) < 0) return FALSE; return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; @@ -1,26 +1,8 @@ -/* $RCSfile: util.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:03 $ +/* util.h * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: util.h,v $ - * Revision 4.1 92/08/07 18:29:03 lwall - * - * Revision 4.0.1.4 92/06/11 21:19:36 lwall - * patch34: pidgone() wasn't declared right - * - * Revision 4.0.1.3 92/06/08 16:09:20 lwall - * patch20: bcopy() and memcpy() now tested for overlap safety - * - * Revision 4.0.1.2 91/11/05 19:18:40 lwall - * patch11: safe malloc code now integrated into Perl's malloc when possible - * - * Revision 4.0.1.1 91/06/07 12:11:00 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:56:48 lwall - * 4.0 baseline. - * */ diff --git a/config.h b/vms/config.vms index d4252a3d22..6deaac7eca 100644 --- a/config.h +++ b/vms/config.vms @@ -1,34 +1,65 @@ /* - * 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. + * This file was produced by hand because the configure utilities which + * are in the perl distribution are all shell scripts. Someday, I hope + * we'll get a perl configure utility, but until then . . . + * + * Feel free to add or change things to suit your needs, but be careful + * about moving the comments which say "config-skip" - they're used by + * GenConfig.pl when producing Config.pm. * - * 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.2 1993/08/24 12:13:20 ram Exp $ - */ + * config.h for VMS + */ -/* Configuration time: Wed May 4 15:10:39 PDT 1994 - * Configured by: lwall - * Target system: sunos scalpel 4.1.3 3 sun4c +/* Configuration time: 12-Oct-1994 17:00 + * Configured by: Charles Bailey bailey@genetics.upenn.edu + * Target system: VMS */ #ifndef _config_h_ #define _config_h_ -/* 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. +/* MEM_ALIGNBYTES: + * This symbol contains the number of bytes required to align a + * double. Usual values are 2, 4 and 8. */ -#define BIN "/usr/local/bin" /**/ +#define MEM_ALIGNBYTES 8 /**/ /* BYTEORDER: * This symbol hold the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... */ -#define BYTEORDER 0x4321 /* large digits for MSB */ +#define BYTEORDER 0x1234 /* large digits for MSB */ + +/* ARCHLIB: + * This variable, if defined, holds the name of the directory in + * which the user wants to put architecture-dependent public + * library files for $package. It is most often a local directory + * such as /usr/local/lib. Programs using this variable must be + * prepared to deal with filename expansion. If ARCHLIB is the + * same as PRIVLIB, it is not defined, since presumably the + * program already searches PRIVLIB. + */ +#undef ARCHLIB /**/ + +/* CAT2: + * This macro catenates 2 tokens together. + */ +/* STRINGIFY: + * This macro surrounds its token with double quotes. + */ +#ifdef __STDC__ +#define CAT2(a,b) a##b /* config-skip */ +#define CAT3(a,b,c) a##b##c /* config-skip */ +#define CAT4(a,b,c,d) a##b##c##d /* config-skip */ +#define CAT5(a,b,c,d,e) a##b##c##d##e /* config-skip */ +#define STRINGIFY(a) #a /* config-skip */ +#else +#define CAT2(a,b) a/**/b /* config-skip */ +#define CAT3(a,b,c) a/**/b/**/c /* config-skip */ +#define CAT4(a,b,c,d) a/**/b/**/c/**/d /* config-skip */ +#define CAT5(a,b,c,d,e) a/**/b/**/c/**/d/**/e /* config-skip */ +#define STRINGIFY(a) "a" /* config-skip */ +#endif /* CPPSTDIN: * This symbol contains the first part of the string which will invoke @@ -42,26 +73,26 @@ * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ -#define CPPSTDIN "/tmp_mnt/net/vaccine/export/src/local/lwall/perl5/cppstdin" +#define CPPSTDIN "cc/noobj/preprocess=sys$output sys$input" #define CPPMINUS "" /* HAS_BCMP: * This symbol is defined if the bcmp() routine is available to * compare blocks of memory. */ -#define HAS_BCMP /**/ +#undef HAS_BCMP /**/ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ -#define HAS_BCOPY /**/ +#undef HAS_BCOPY /**/ /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ -#define HAS_BZERO /**/ +#undef HAS_BZERO /**/ /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative @@ -83,13 +114,13 @@ * is up to the package author to declare sprintf correctly based on the * symbol. */ -#define CHARSPRINTF /**/ +#undef CHARSPRINTF /**/ /* HAS_CHSIZE: * This symbol, if defined, indicates that the chsize routine is available * to truncate files. You might need a -lx to get this routine. */ -/*#define HAS_CHSIZE /**/ +#undef HAS_CHSIZE /**/ /* HASCONST: * This symbol, if defined, indicates that this C compiler knows about @@ -97,7 +128,7 @@ * within your programs. The mere use of the "const" keyword will * trigger the necessary tests. */ -/*#define HASCONST /**/ +#define HASCONST /**/ #ifndef HASCONST #define const #endif @@ -106,28 +137,13 @@ * This symbol, if defined, indicates that the crypt routine is available * to encrypt passwords and the like. */ -#define HAS_CRYPT /**/ +#undef HAS_CRYPT /**/ /* CSH: * This symbol, if defined, indicates that the C-shell exists. * If defined, contains the full pathname of csh. */ -#define CSH "/bin/csh" /**/ - -/* 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 DOSUID /**/ +#undef CSH /**/ /* HAS_DUP2: * This symbol, if defined, indicates that the dup2 routine is @@ -139,19 +155,25 @@ * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). */ -#define HAS_FCHMOD /**/ +#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(). */ -#define HAS_FCHOWN /**/ +#undef HAS_FCHOWN /**/ /* HAS_FCNTL: * This symbol, if defined, indicates to the C program that * the fcntl() function exists. */ -#define HAS_FCNTL /**/ +#undef 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 @@ -163,64 +185,82 @@ * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ -#define HAS_FLOCK /**/ +#undef HAS_FLOCK /**/ + +/* 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. */ -#define HAS_GETGROUPS /**/ - -/* HAS_GETHOSTENT: - * This symbol, if defined, indicates that the gethostent routine is - * available to lookup host names in some data base or other. - */ -/*#define HAS_GETHOSTENT /**/ +#undef HAS_GETGROUPS /**/ /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME * and PHOSTNAME. */ -#define HAS_UNAME /**/ +#undef HAS_UNAME /**/ /* HAS_GETPGRP: * This symbol, if defined, indicates that the getpgrp routine is * available to get the current process group. */ -#define HAS_GETPGRP /**/ +#undef HAS_GETPGRP /**/ /* HAS_GETPGRP2: * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) * routine is available to get the current process group. */ -/*#define HAS_GETPGRP2 /**/ +#undef HAS_GETPGRP2 /**/ /* HAS_GETPRIORITY: * This symbol, if defined, indicates that the getpriority routine is * available to get a process's priority. */ -#define HAS_GETPRIORITY /**/ +#undef HAS_GETPRIORITY /**/ /* HAS_KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill * with a negative process number. */ -#define HAS_KILLPG /**/ +#undef HAS_KILLPG /**/ /* HAS_LINK: * This symbol, if defined, indicates that the link routine is * available to create hard links. */ -#define HAS_LINK /**/ +#undef HAS_LINK /**/ /* HAS_LSTAT: * This symbol, if defined, indicates that the lstat routine is * available to do file stats on symbolic links. */ -#define HAS_LSTAT /**/ +#undef HAS_LSTAT /**/ + +/* HAS_LOCKF: + * This symbol, if defined, indicates that the lockf routine is + * available to do file locking. + */ +#undef HAS_LOCKF /**/ + +/* HAS_MBSTOWCS: + * This symbol, if defined, indicates that the mbstowcs routine is + * available to covert a multibyte string into a wide character string. + */ +#undef HAS_MBSTOWCS /**/ + +/* HAS_MBTOWC: + * This symbol, if defined, indicates that the mbtowc routine is available + * to covert a multibyte to a wide character. + */ +#undef HAS_MBTOWC /**/ /* HAS_MEMCMP: * This symbol, if defined, indicates that the memcmp routine is available @@ -240,7 +280,7 @@ * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your * own version. */ -/*#define HAS_MEMMOVE /**/ +#define HAS_MEMMOVE /**/ /* HAS_MEMSET: * This symbol, if defined, indicates that the memset routine is available @@ -259,37 +299,38 @@ * This symbol, if defined, indicates that the entire msg*(2) library is * supported (IPC mechanism based on message queues). */ -#define HAS_MSG /**/ +#undef HAS_MSG /**/ -/* HAS_MSGCTL: - * This symbol, if defined, indicates that the msgctl() routine is - * available to perform message control operations. +/* HAS_OPEN3: + * This manifest constant lets the C program know that the three + * argument form of open(2) is available. */ -#define HAS_MSGCTL /**/ +#define HAS_OPEN3 /**/ -/* HAS_MSGGET: - * This symbol, if defined, indicates that the msgget() routine is - * available to get a new message queue. +/* 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_MSGGET /**/ +#define HAS_READDIR /**/ -/* HAS_MSGRCV: - * This symbol, if defined, indicates that the msgrcv() routine is - * available to extract a message from the message queue. +/* HAS_SEEKDIR: + * This symbol, if defined, indicates that the seekdir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. */ -#define HAS_MSGRCV /**/ +#define HAS_SEEKDIR /**/ -/* HAS_MSGSND: - * This symbol, if defined, indicates that the msgsnd() routine is - * available to send a message into the message queue. +/* HAS_TELLDIR: + * This symbol, if defined, indicates that the telldir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. */ -#define HAS_MSGSND /**/ +#define HAS_TELLDIR /**/ -/* HAS_OPEN3: - * This manifest constant lets the C program know that the three - * argument form of open(2) is available. +/* 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_OPEN3 /**/ +#define HAS_REWINDDIR /**/ /* HAS_RENAME: * This symbol, if defined, indicates that the rename routine is available @@ -310,67 +351,49 @@ * available to select active file descriptors. If the timeout field * is used, <sys/time.h> may need to be included. */ -#define HAS_SELECT /**/ +#undef HAS_SELECT /**/ /* HAS_SEM: * This symbol, if defined, indicates that the entire sem*(2) library is * supported. */ -#define HAS_SEM /**/ - -/* HAS_SEMCTL: - * This symbol, if defined, indicates that the semctl() routine is - * available to perform semaphore control operations. - */ -#define HAS_SEMCTL /**/ - -/* HAS_SEMGET: - * This symbol, if defined, indicates that the semget() routine is - * available to get a set of semaphores. - */ -#define HAS_SEMGET /**/ - -/* HAS_SEMOP: - * This symbol, if defined, indicates that the semop() routine is - * available to execute semaphore operations. - */ -#define HAS_SEMOP /**/ +#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. */ -#define HAS_SETEGID /**/ +#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. */ -#define HAS_SETEUID /**/ +#undef HAS_SETEUID /**/ + +/* HAS_SETLOCALE: + * This symbol, if defined, indicates that the setlocale routine is + * available to handle locale-specific ctype implementations. + */ +#undef HAS_SETLOCALE /**/ /* HAS_SETPGID: * This symbol, if defined, indicates that the setpgid routine is * available to set process group ID. */ -#define HAS_SETPGID /**/ - -/* HAS_SETPGRP: - * This symbol, if defined, indicates that the setpgrp routine is - * available to set the current process group. - */ -#define HAS_SETPGRP /**/ +#undef HAS_SETPGID /**/ /* HAS_SETPGRP2: * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) * routine is available to set the current process group. */ -/*#define HAS_SETPGRP2 /**/ +#undef HAS_SETPGRP2 /**/ /* HAS_SETPRIORITY: * This symbol, if defined, indicates that the setpriority routine is * available to set a process's priority. */ -#define HAS_SETPRIORITY /**/ +#undef HAS_SETPRIORITY /**/ /* HAS_SETREGID: * This symbol, if defined, indicates that the setregid routine is @@ -382,8 +405,8 @@ * available to change the real, effective and saved gid of the current * process. */ -#define HAS_SETREGID /**/ -/*#define HAS_SETRESGID /**/ +#undef HAS_SETREGID /**/ +#undef HAS_SETRESGID /**/ /* HAS_SETREUID: * This symbol, if defined, indicates that the setreuid routine is @@ -395,79 +418,58 @@ * available to change the real, effective and saved uid of the current * process. */ -#define HAS_SETREUID /**/ -/*#define HAS_SETRESUID /**/ +#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. */ -#define HAS_SETRGID /**/ +#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. */ -#define HAS_SETRUID /**/ +#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 /**/ +#undef HAS_SETSID /**/ /* HAS_SHM: * This symbol, if defined, indicates that the entire shm*(2) library is * supported. */ -#define HAS_SHM /**/ - -/* HAS_SHMCTL: - * This symbol, if defined, indicates that the shmctl() routine is - * available to perform shared memory control operations. - */ -#define HAS_SHMCTL /**/ - -/* HAS_SHMDT: - * This symbol, if defined, indicates that the shmdt() routine is - * available to detach a shared memory segment from the process space. - */ -#define HAS_SHMDT /**/ +#undef HAS_SHM /**/ -/* HAS_SHMGET: - * This symbol, if defined, indicates that the shmget() routine is - * available to request a shared memory segment from the kernel. - */ -#define HAS_SHMGET /**/ - -/* 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. +/* Shmat_t: + * This symbol holds the return type of the shmat() system call. + * Usually set to 'void *' or 'char *'. */ -/* USE_OLDSOCKET: - * This symbol, if defined, indicates that the 4.1c BSD socket interface - * is supported instead of the 4.2/4.3 BSD socket interface. For instance, - * there is no setsockopt() call. +/* HAS_SHMAT_PROTOTYPE: + * This symbol, if defined, indicates that the sys/shm.h includes + * a prototype for shmat(). Otherwise, it is up to the program to + * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess, + * but not always right so it should be emitted by the program only + * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. */ -#define HAS_SOCKET /**/ -#define HAS_SOCKETPAIR /**/ -/*#define USE_OLDSOCKET /**/ +#undef Shmat_t char * /**/ /* config-skip */ +#undef HAS_SHMAT_PROTOTYPE /**/ /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. */ -#define USE_STAT_BLOCKS /**/ +#undef USE_STAT_BLOCKS /**/ /* USE_STD_STDIO: * This symbol is defined if this system has a FILE structure declaring * _ptr and _cnt in stdio.h. */ -#define USE_STD_STDIO /**/ +#undef USE_STD_STDIO /**/ /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how @@ -476,17 +478,40 @@ */ #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 /**/ +#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 * to create symbolic links. */ -#define HAS_SYMLINK /**/ +#undef HAS_SYMLINK /**/ /* HAS_SYSCALL: * This symbol, if defined, indicates that the syscall routine is * available to call arbitrary system calls. If undefined, that's tough. */ -#define HAS_SYSCALL /**/ +#undef HAS_SYSCALL /**/ /* HAS_SYSTEM: * This symbol, if defined, indicates that the system routine is @@ -499,42 +524,27 @@ * or time_t on BSD sites (in which case <sys/types.h> should be * included). */ -#define Time_t long /* 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 /**/ +#define Time_t time_t /* Time type */ /* HAS_TRUNCATE: * This symbol, if defined, indicates that the truncate routine is * available to truncate files. */ -#define HAS_TRUNCATE /**/ +#undef HAS_TRUNCATE /**/ -/* I_NDIR: - * This symbol, if defined, indicates that the program should include the - * system's version of ndir.h, rather than the one with this package. - */ -/*#define I_NDIR /**/ -/* VOIDSIG: - * This symbol is defined if this system declares "void (*signal(...))()" in - * signal.h. The old way was to declare it as "int (*signal(...))()". It - * is up to the package author to declare things correctly based on the - * symbol. +/* HAS_VFORK: + * This symbol, if defined, indicates that vfork() exists. */ -#define VOIDSIG /**/ +#define HAS_VFORK /**/ /* HASVOLATILE: * This symbol, if defined, indicates that this C compiler knows about * the volatile declaration. */ -/*#define HASVOLATILE /**/ +#define HASVOLATILE /**/ #ifndef HASVOLATILE -#define volatile +#define volatile /* config-skip */ #endif /* HAS_VPRINTF: @@ -549,24 +559,24 @@ * symbol. */ #define HAS_VPRINTF /**/ -#define USE_CHAR_VSPRINTF /**/ +#undef USE_CHAR_VSPRINTF /**/ /* HAS_WAIT4: * This symbol, if defined, indicates that wait4() exists. */ -#define HAS_WAIT4 /**/ +#undef HAS_WAIT4 /**/ /* HAS_WAITPID: * This symbol, if defined, indicates that the waitpid routine is * available to wait for child process. */ -#define HAS_WAITPID /**/ +#undef HAS_WAITPID /**/ -/* I_DBM: - * This symbol, if defined, indicates to the C program that it should - * include <dbm.h>. +/* HAS_WCSTOMBS: + * This symbol, if defined, indicates that the wcstombs routine is + * available to convert wide character strings to multibyte strings. */ -#define I_DBM /**/ +#undef HAS_WCSTOMBS /**/ /* I_DIRENT: * This symbol, if defined, indicates to the C program that it should @@ -579,53 +589,81 @@ * of directory entry names is provided by a d_namlen field. Otherwise * you need to do strlen() on the d_name field. */ -#define I_DIRENT /**/ -/*#define DIRNAMLEN /**/ -#ifdef I_DIRENT +#undef I_DIRENT /**/ +#define DIRNAMLEN /**/ #define Direntry_t struct dirent -#else -#define Direntry_t struct direct -#endif /* I_FCNTL: * This manifest constant tells the C program to include <fcntl.h>. */ -/*#define I_FCNTL /**/ - -/* I_GDBM: - * This symbol, if defined, indicates that gdbm.h exists and should - * be included. - */ -/*#define I_GDBM /**/ +#undef I_FCNTL /**/ /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include <grp.h>. */ -#define I_GRP /**/ +#undef I_GRP /**/ -/* I_NDBM: - * This symbol, if defined, indicates that ndbm.h exists and should - * be included. +/* 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_NDBM /**/ +#undef I_LIMITS /**/ -/* I_NETINET_IN: +/* I_MEMORY: * This symbol, if defined, indicates to the C program that it should - * include <netinet/in.h>. Otherwise, you may try <sys/in.h>. + * include <memory.h>. */ -/* I_SYS_IN: - * This symbol, if defined, indicates to the C program that it should - * include <sys/in.h> instead of <netinet/in.h>. +#undef I_MEMORY /**/ + +/* I_NDBM: + * This symbol, if defined, indicates that ndbm.h exists and should + * be included. */ -#define I_NETINET_IN /**/ -/*#define I_SYS_IN /**/ +#undef I_NDBM /**/ /* I_STDARG: * This symbol, if defined, indicates that <stdarg.h> exists and should * be included. */ -/*#define I_STDARG /**/ +#define I_STDARG /**/ + +/* 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. + */ +#undef 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 @@ -633,6 +671,12 @@ */ #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). @@ -643,31 +687,64 @@ * This symbol, if defined, indicates to the C program that it should * include <sys/dir.h>. */ -#define I_SYS_DIR /**/ +#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. */ -#define I_SYS_FILE /**/ +#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 /**/ +#undef I_SYS_IOCTL /**/ + +/* HAS_IOCTL: + * This symbol, if defined, indicates that the ioctl() routine is + * available to set I/O characteristics + */ +#undef HAS_IOCTL /**/ /* I_SYS_NDIR: * This symbol, if defined, indicates to the C program that it should * include <sys/ndir.h>. */ -/*#define I_SYS_NDIR /**/ +#undef I_SYS_NDIR /**/ /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include <sys/select.h> in order to get definition of struct timeval. */ -/*#define I_SYS_SELECT /**/ +#undef I_SYS_SELECT /**/ + + +/* I_SYS_TIMES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/times.h>. + */ +#undef I_SYS_TIMES /**/ + +/* 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 /**/ +#undef I_SGTTY /**/ +#undef I_TERMIOS /**/ /* I_TIME: * This symbol, if defined, indicates to the C program that it should @@ -681,27 +758,45 @@ * This symbol, if defined, indicates to the C program that it should * include <sys/time.h> with KERNEL defined. */ -/*#define I_TIME /**/ -#define I_SYS_TIME /**/ -/*#define I_SYS_TIME_KERNEL /**/ +#define I_TIME /**/ +#undef 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 /**/ +#undef I_UNISTD /**/ /* I_UTIME: * This symbol, if defined, indicates to the C program that it should * include <utime.h>. */ -#define I_UTIME /**/ +#undef I_UTIME /**/ + +/* HAS_UTIME: + * This symbol, if defined, indicates that the routine utime() is + * available to update the access and modification times of files. + */ +#undef HAS_UTIME /**/ +/* I_STDARG: + * This symbol, if defined, indicates that <stdarg.h> exists and should + * be included. + */ /* I_VARARGS: * This symbol, if defined, indicates to the C program that it should * include <varargs.h>. */ -#define I_VARARGS /**/ +#define I_STDARG /**/ +#undef I_VARARGS /**/ + + +/* I_VFORK: + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +#undef I_VFORK /**/ /* INTSIZE: * This symbol contains the size of an int, so that the C preprocessor @@ -709,26 +804,24 @@ */ #define INTSIZE 4 /**/ -/* 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 */ -/* PRIVLIB: - * This symbol contains the name of the private library for this package. - * The library is private in the sense that it needn't be in anyone's - * execution path, but it should be accessible by the world. The program - * should be prepared to do ~ expansion. +/* CAN_PROTOTYPE: + * If defined, this macro indicates that the C compiler can handle + * function prototypes. */ -#define PRIVLIB "/usr/local/lib/perl" /**/ - -/* PTRSIZE: - * This symbol contains the size of a pointer, so that the C preprocessor - * can make decisions based on it. +/* _: + * 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 PTRSIZE 4 /**/ +#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() @@ -736,26 +829,46 @@ */ #define RANDBITS 31 /**/ -/* 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. + +/* 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 SCRIPTDIR "/usr/local/bin" /**/ +#define Select_fd_set_t fd_set * /**/ /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ -#define STDCHAR unsigned char /**/ +#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. +/* 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. */ -#define Uid_t uid_t /* UID type */ +#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 + /* EUNICE: * This symbol, if defined, indicates that the program is being compiled @@ -768,14 +881,29 @@ * This symbol, if defined, indicates that the program is running under * VMS. It is currently only set in conjunction with the EUNICE symbol. */ -/*#define EUNICE /**/ -/*#define VMS /**/ +#define EUNICE /**/ +/* This symbol is automagically defined by all VMS C compilers I've seen. + * Just in case, however . . . */ +#ifndef VMS +#define VMS /**/ +#endif -/* MEM_ALIGNBYTES: - * This symbol contains the number of bytes required to align a - * double. Usual values are 2, 4 and 8. +/* LOC_SED: + * This symbol holds the complete pathname to the sed program. */ -#define MEM_ALIGNBYTES 8 /**/ +#define LOC_SED "_NLA0:" /**/ + +/* 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 "/perl_root/000000" /**/ + +/* HAS_ALARM: + * This symbol, if defined, indicates that the alarm routine is + * available. + */ +#define HAS_ALARM /**/ /* CASTI32: * This symbol is defined if the C compiler can cast negative @@ -783,6 +911,67 @@ */ #define CASTI32 /**/ +/* HAS_CHOWN: + * This symbol, if defined, indicates that the chown routine is + * available. + */ +#define HAS_CHOWN /**/ + +/* HAS_CHROOT: + * This symbol, if defined, indicates that the chroot routine is + * available. + */ +#undef HAS_CHROOT /**/ + +/* HAS_CUSERID: + * This symbol, if defined, indicates that the cuserid routine is + * available to get character login names. + */ +#define HAS_CUSERID /**/ + +/* HAS_DBL_DIG: + * This symbol, if defined, indicates that this system's <float.h> + * or <limits.h> defines the symbol DBL_DIG, which is the number + * of significant digits in a double precision number. If this + * symbol is not defined, a guess of 15 is usually pretty good. + */ +#define HAS_DBL_DIG /* */ + +/* HAS_DIFFTIME: + * This symbol, if defined, indicates that the difftime routine is + * available. + */ +#define HAS_DIFFTIME /**/ + +/* HAS_FORK: + * This symbol, if defined, indicates that the fork routine is + * available. + */ +/* VMS: In vmsish.h, fork is #defined to vfork. This kludge gets around + * some obsolete code in pp.c, which should be fixed in its own right + * sometime. - C. Bailey 26-Aug-1994 + */ +#define HAS_FORK /**/ + +/* HAS_GETLOGIN: + * This symbol, if defined, indicates that the getlogin routine is + * available. + */ +#undef HAS_GETLOGIN /**/ + +/* HAS_GETPPID: + * This symbol, if defined, indicates that the getppid routine is + * available. + */ +#undef HAS_GETPPID /**/ + +/* HAS_GROUP: + * This symbol, if defined, indicates that the group routine is + * available. + */ +#undef HAS_GROUP /**/ + + /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network @@ -803,109 +992,135 @@ * friends htonl() htons() ntohl()) are available to do network * order byte swapping. */ -#define HAS_HTONL /**/ -#define HAS_HTONS /**/ -#define HAS_NTOHL /**/ -#define HAS_NTOHS /**/ +#define HAS_HTONL /**/ +#define HAS_HTONS /**/ +#define HAS_NTOHL /**/ +#define HAS_NTOHS /**/ + +/* HAS_MBLEN: + * This symbol, if defined, indicates that the mblen routine is available + * to find the number of bytes in a multibye character. + */ +#undef HAS_MBLEN /**/ -/* HAS_ISASCII: - * This manifest constant lets the C program know that the - * isascii is available. +/* HAS_MKTIME: + * This symbol, if defined, indicates that the mktime routine is + * available. */ -#define HAS_ISASCII /**/ +#undef HAS_MKTIME /**/ -/* 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. +/* HAS_NICE: + * This symbol, if defined, indicates that the nice routine is + * available. */ -#define HAS_READDIR /**/ +#define HAS_NICE /**/ -/* HAS_SEEKDIR: - * This symbol, if defined, indicates that the seekdir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. +/* HAS_PASSWD: + * This symbol, if defined, indicates that the passwd routine is + * available. */ -#define HAS_SEEKDIR /**/ +#undef HAS_PASSWD /**/ -/* HAS_TELLDIR: - * This symbol, if defined, indicates that the telldir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. +/* HAS_PAUSE: + * This symbol, if defined, indicates that the pause routine is + * available. */ -#define HAS_TELLDIR /**/ +#define HAS_PAUSE /**/ -/* HAS_REWINDDIR: - * This symbol, if defined, indicates that the rewinddir routine is - * available. You may have to include <dirent.h>. See I_DIRENT. +/* HAS_PIPE: + * This symbol, if defined, indicates that the pipe routine is + * available. */ -#define HAS_REWINDDIR /**/ +#define HAS_PIPE /**/ -/* 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. +/* HAS_READLINK: + * This symbol, if defined, indicates that the readlink routine is + * available. */ -#define HAS_SAFE_BCOPY /**/ +#undef HAS_READLINK /**/ -/* 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. +/* HAS_SETLINEBUF: + * This symbol, if defined, indicates that the setlinebuf routine is + * available to change stderr or stdout from block-buffered or unbuffered + * to a line-buffered mode. */ -/*#define HAS_SAFE_MEMCPY /**/ +#undef HAS_SETLINEBUF /**/ -/* HAS_SETLOCALE: - * This symbol, if defined, indicates that the setlocale routine is - * available to handle locale-specific ctype implementations. +/* 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_SETLOCALE /**/ +#define HAS_STRCHR /**/ +#undef HAS_INDEX /**/ -/* HAS_SHMAT: - * This symbol, if defined, indicates that the shmat() routine is - * available to attach a shared memory segment to the process space. +/* HAS_STRCOLL: + * This symbol, if defined, indicates that the strcoll routine is + * available to compare strings using collating information. */ -#define HAS_SHMAT /**/ +#undef HAS_STRCOLL /**/ -/* VOIDSHMAT: - * This symbol, if defined, indicates that the shmat() routine - * returns a pointer of type void*. Otherwise, char* is assumed. +/* HAS_STRXFRM: + * This symbol, if defined, indicates that the strxfrm() routine is + * available to compare strings using collating information. */ -/*#define VOIDSHMAT /**/ +#undef HAS_STRXFRM /**/ -/* 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_TCGETPGRP: + * This symbol, if defined, indicates that the tcgetpgrp routine is + * available to get foreground process group ID. */ -/* 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. +#undef HAS_TCGETPGRP /**/ + +/* HAS_TCSETPGRP: + * This symbol, if defined, indicates that the tcsetpgrp routine is + * available to set foreground process group ID. */ -/* 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. +#undef HAS_TCSETPGRP /**/ + +/* 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_STRERROR /**/ -#define HAS_SYS_ERRLIST /**/ -#ifdef HAS_STRERROR -# define Strerror strerror -#else -#define Strerror(e) ((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e]) /**/ -#endif +#define HAS_TIMES /**/ -/* HAS_VFORK: - * This symbol, if defined, indicates that vfork() exists. +/* HAS_TZNAME: + * This symbol, if defined, indicates that the tzname[] array is + * available to access timezone names. */ -/*#define HAS_VFORK /**/ +#undef HAS_TZNAME /**/ -/* USE_DYNAMIC_LOADING: - * This symbol, if defined, indicates that dynamic loading of - * some sort is available. +/* HAS_UMASK: + * This symbol, if defined, indicates that the umask routine is + * available to get the file creation mask. */ -#define USE_DYNAMIC_LOADING /**/ +#define HAS_UMASK /**/ + +/* VOIDSIG: + * This symbol is defined if this system declares "void (*signal(...))()" in + * signal.h. The old way was to declare it as "int (*signal(...))()". It + * is up to the package author to declare things correctly based on the + * symbol. + */ +#define VOIDSIG /**/ + +/* HAS_WCTOMB: + * This symbol, if defined, indicates that the wctomb routine is available + * to covert a wide character to a multibyte. + */ +#undef 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 @@ -914,231 +1129,312 @@ * It can be int, ushort, uid_t, etc... It may be necessary to include * <sys/types.h> to get any typedef'ed information. */ -#define Gid_t gid_t /* Type for getgid(), etc... */ - -/* GROUPSTYPE: - * 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 GROUPSTYPE int /* Type for 2nd arg to getgroups() */ -#endif +#define Gid_t unsigned int /* Type for getgid(), etc... */ /* I_DLFCN: * This symbol, if defined, indicates that <dlfcn.h> exists and should * be included. */ -#define I_DLFCN /**/ +#undef I_DLFCN /**/ -/* I_MEMORY: +/* I_FLOAT: * This symbol, if defined, indicates to the C program that it should - * include <memory.h>. + * include <float.h> to get definition of symbols like DBL_MAX or + * DBL_MIN, i.e. machine dependent floating point values. */ -#define I_MEMORY /**/ +#define I_FLOAT /**/ -/* I_NET_ERRNO: - * This symbol, if defined, indicates that <net/errno.h> exists and - * should be included. +/* I_MATH: + * This symbol, if defined, indicates to the C program that it should + * include <math.h>. */ -/*#define I_NET_ERRNO /**/ +#define I_MATH /**/ -/* I_PWD: - * This symbol, if defined, indicates to the C program that it should - * include <pwd.h>. +/* 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. */ -/* PWQUOTA: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_quota. +#define Off_t int /* <offset> type */ +/* Malloc_t: + * This symbol is the type of pointer returned by malloc and realloc. */ -/* PWAGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_age. +#define Malloc_t void * /**/ + +/* MYMALLOC: + * This symbol, if defined, indicates that we're using our own malloc. */ -/* PWCHANGE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_change. +#undef MYMALLOC /**/ + +/* 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. */ -/* PWCLASS: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_class. +#define Mode_t unsigned int /* file mode parameter for system calls*/ + +/* 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). */ -/* PWEXPIRE: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_expire. +#define SSize_t int /* signed count of bytes */ + + +/* PRIVLIB: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. */ -/* PWCOMMENT: - * This symbol, if defined, indicates to the C program that struct passwd - * contains pw_comment. +#define PRIVLIB "/perl_root/lib" /**/ + +/* 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 I_PWD /**/ -/*#define PWQUOTA /**/ -#define PWAGE /**/ -/*#define PWCHANGE /**/ -/*#define PWCLASS /**/ -/*#define PWEXPIRE /**/ -#define PWCOMMENT /**/ +#define SCRIPTDIR "/perl_root/script" /**/ -/* 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. +/* SIG_NAME: + * This symbol contains a list of signal names in order. This is intended + * to be used as a static array initialization, like this: + * 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". */ -/* 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. +#define SIG_NAME "HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE","KILL",\ + "BUS","SEGV","SYS","PIPE","ALRM","TERM" + +/* 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. */ -/* I_SGTTY: - * This symbol, if defined, indicates that the program should include - * <sgtty.h> rather than <termio.h>. There are also differences in - * the ioctl() calls that depend on the value of this symbol. +#define Size_t size_t /* length paramater for string functions */ + +/* Uid_t: + * This symbol holds the type used to declare user ids in the kernel. + * It can be int, ushort, uid_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. */ -/*#define I_TERMIO /**/ -#define I_TERMIOS /**/ -/*#define I_SGTTY /**/ +#define Uid_t unsigned int /* UID type */ -/* I_VFORK: +/* I_SYS_PARAM: * This symbol, if defined, indicates to the C program that it should - * include vfork.h. + * include <sys/param.h>. */ -/*#define I_VFORK /**/ +#undef I_SYS_PARAM -/* LOC_SED: - * This symbol holds the complete pathname to the sed program. +/* 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 LOC_SED "/bin/sed" /**/ +/*#define GNUC_ATTRIBUTE_CHECK /* */ -/* Malloc_t: - * This symbol is the type of pointer returned by malloc and realloc. +/* VOID_CLOSEDIR: + * This symbol, if defined, indicates that the closedir() routine + * does not return a value. */ -#define Malloc_t char * /**/ +#define VOID_CLOSEDIR /**/ -/* MYMALLOC: - * This symbol, if defined, indicates that we're using our own malloc. +/* HAS_DLERROR: + * This symbol, if defined, indicates that the dlerror routine is + * available. +*/ +#undef HAS_DLERROR /**/ + +/* DLSYM_NEEDS_UNDERSCORE: + * This symbol, if defined, indicates that we need to prepend an + * underscore to the symbol name before calling dlsym(). This only + * makes sense if you *have* dlsym, which we will presume is the + * case if you're using dl_dlopen.xs. */ -#define MYMALLOC /**/ +#undef DLSYM_NEEDS_UNDERSCORE /* */ -/* CAN_PROTOTYPE: - * If defined, this macro indicates that the C compiler can handle - * function prototypes. +/* SETUID_SCRIPTS_ARE_SECURE_NOW: + * This symbol, if defined, indicates that setuid scripts are secure. */ -/*#define CAN_PROTOTYPE /**/ -#ifdef CAN_PROTOTYPE -#else -#endif +/* 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. + */ +#undef SETUID_SCRIPTS_ARE_SECURE_NOW /**/ +#undef DOSUID /**/ -/* SIG_NAME: - * This symbol contains a list of signal names in order. This is intended - * to be used as a static array initialization, like this: - * 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". +/* HAS_DREM: + * This symbol, if defined, indicates that the drem routine is + * available. This is a Pyramid routine that is the same as + * fmod. */ -#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","LOST","USR1","USR2" /**/ +#undef HAS_DREM /**/ -/* 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. +/* HAS_FMOD: + * This symbol, if defined, indicates that the fmod routine is + * available. */ -#ifndef VOIDUSED -# define VOIDUSED 15 -#endif -#define VOIDFLAGS 15 -#if (VOIDFLAGS & VOIDUSED) != VOIDUSED -# define void int /* is void to be avoided? */ -# define M_VOID /* Xenix strikes again */ -# define VOID -#else -# define VOID void -#endif +#define HAS_FMOD /**/ -/* - * The following symbols are obsolete. They are mapped to the the new - * symbols only to ease the transition process. The sources should be - * updated so as to use the new symbols only, as the support for these - * obsolete symbols may end without notice. +/* 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. */ +#define Gconvert(x,n,t,b) my_gconvert(x,n,t,b) -#ifdef MEM_ALIGNBYTES -#define ALIGNBYTES MEM_ALIGNBYTES -#endif +/* HAS_ISASCII: + * This manifest constant lets the C program know that the + * isascii is available. + */ +#define HAS_ISASCII /**/ -#ifdef USE_CHAR_VSPRINTF -#define CHARVSPRINTF USE_CHAR_VSPRINTF -#endif +/* USE_LINUX_STDIO: + * This symbol is defined if this system has a FILE structure declaring + * _IO_read_base, _IO_read_ptr, and _IO_read_end in stdio.h. + */ +#undef USE_LINUX_STDIO /**/ -#ifdef Gid_t -#define GIDTYPE Gid_t -#endif +/* HAS_LOCALECONV: + * This symbol, if defined, indicates that the localeconv routine is + * available for numeric and monetary formatting conventions. + */ +#undef HAS_LOCALECONV /**/ -#ifdef I_GDBM -#define HAS_GDBM I_GDBM -#endif +/* HAS_MKFIFO: + * This symbol, if defined, indicates that the mkfifo routine is + * available. + */ +#undef HAS_MKFIFO /**/ -#ifdef I_NDBM -#define HAS_NDBM I_NDBM -#endif +/* 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. + */ +#undef HAS_PATHCONF /**/ +#undef HAS_FPATHCONF /**/ -#ifdef I_DBM -#define HAS_ODBM I_DBM -#endif +/* 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 /**/ -#ifdef I_SYS_IOCTL -#define I_SYSIOCTL I_SYS_IOCTL -#endif +/* HAS_SAFE_MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy potentially overlapping memory blocks. Otherwise you should + * probably use memmove() or memcpy(). If neither is defined, roll your + * own version. + */ +#define HAS_SAFE_MEMCPY /**/ -#ifdef Malloc_t -#define MALLOCPTRTYPE Malloc_t -#endif +/* 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 /**/ -#ifdef USE_OLDSOCKET -#define OLDSOCKET USE_OLDSOCKET -#endif +/* HAS_SYSCONF: + * This symbol, if defined, indicates that sysconf() is available + * to determine system related limits and options. + */ +#undef HAS_SYSCONF /**/ -#ifdef HAS_SAFE_BCOPY -#define SAFE_BCOPY HAS_SAFE_BCOPY -#endif +/* USE_DYNAMIC_LOADING: + * This symbol, if defined, indicates that dynamic loading of + * some sort is available. + */ +#define USE_DYNAMIC_LOADING /**/ -#ifdef HAS_SAFE_MEMCPY -#define SAFE_MEMCPY HAS_SAFE_MEMCPY -#endif +#ifdef VMS_DO_SOCKETS +/* 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 /**/ /* config-skip */ +#undef HAS_SOCKETPAIR /**/ /* config-skip */ -#ifdef USE_STAT_BLOCKS -#define STATBLOCKS USE_STAT_BLOCKS -#endif +/* HAS_GETHOSTENT: + * This symbol, if defined, indicates that the gethostent routine is + * available to lookup host names in some data base or other. + */ +#define HAS_GETHOSTENT /**/ /* config-skip */ -#ifdef USE_STD_STDIO -#define STDSTDIO USE_STD_STDIO -#endif +/* VMS: In general, TCP/IP header files should be included from + * sockadapt.h, instead of here, in order to keep the TCP/IP code + * together as much as possible. + */ +/* 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>. + */ +#undef I_NETINET_IN /**/ /* config-skip */ -#ifdef USE_STRUCT_COPY -#define STRUCTCOPY USE_STRUCT_COPY +/* 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 -#ifdef HAS_SYSTEM -#define SYSTEM HAS_SYSTEM -#endif +/* I_NET_ERRNO: + * This symbol, if defined, indicates that <net/errno.h> exists and + * should be included. +*/ +#undef I_NET_ERRNO /**/ /* config-skip */ -#ifdef Uid_t -#define UIDTYPE Uid_t -#endif +#else /* VMS_DO_SOCKETS */ + +#undef HAS_SOCKET /**/ /* config-skip */ +#undef HAS_SOCKETPAIR /**/ /* config-skip */ +#undef HAS_GETHOSTENT /**/ /* config-skip */ +#undef I_NETINET_IN /**/ /* config-skip */ +#undef I_NET_ERRNO /**/ /* config-skip */ + +#endif /* !VMS_DO_SOCKETS */ #endif diff --git a/vms/descrip.mms b/vms/descrip.mms new file mode 100644 index 0000000000..bd30a87095 --- /dev/null +++ b/vms/descrip.mms @@ -0,0 +1,858 @@ +# Descrip.MMS for perl5 on VMS +# Last revised 12-Oct-1994 by Charles Bailey bailey@genetics.upenn.edu +# +#: This file uses MMS syntax, and can be processed using DEC's MMS product, +#: or the free MMK clone (available by ftp at ftp.spc.edu). If you want to +#: a Unix-style MAKE tool, run this file through mms2make.pl, which should +#: be found in the same directory as this file. (There should be a pre-made +#: copy of Makefile for VAXC in this directory to allow you to build perl.) +#: +#: Lines beginning with "#:" will be removed by mms2make.pl when converting +#: this file to MAKE syntax. +#: +#: Usage: +#: Building with VAX C, on system without DEC C installed or with VAX C default: +#: $ MMS +#: Building with VAX C, on system with DEC C installed as default C compiler: +#: $ MMS /MACRO=("cc=CC/VAXC") +#: Building with DEC C, on system without VAX C installed or with DEC C default: +#: $ MMS /MACRO=("decc=1") +#: Building with DEC C, on system with VAX C installed as default C compiler: +#: $ MMS /MACRO=("decc=1","cc=CC/DECC") +#: Building with GNU C, on system with GCC command installed in DCLTABLES: +#: $ MMS /MACRO=("gnuc=1") +#: Building with GNU C, on system without GCC command installed in DCLTABLES: +#: $ MMS /MACRO=("gnuc=1") gcc_cld_setup,all +#: note: `gcc_cld_setup' target must explicitly precede `all' or `[mini]perl' +#: +#: To each of the above, add /Macro="__AXP__=1" if building on an AXP, +#: /Macro="__DEBUG__=1" to build a debug version +#: (i.e. VMS debugger, not perl -D), and +#: /Macro="SOCKET=1" to include socket support. +# +# tidy -- purge files generated by executing this file +# clean -- remove all files generated by executing this file +# cleansrc -- `clean' + purge *.c,*.h,descrip.mms +# gcc_cld_setup -- GCC initialization; see above +# crtl.opt -- compiler-specific linker options file (made automatically) +# + +#### Start of system configuration section. #### + +.ifdef AXE +# File type to use for object files +O = .abj +# File type to use for executable images +E = .axe +.else +# File type to use for object files +O = .obj +# File type to use for executable images +E = .exe +.endif + +# used to incorporate 'custom' malloc routines +mallocsrc = +mallocobj = + +#: Process hardware architecture macros +.ifdef __AXP__ +SYMOPT = +DECC = 1 +.else +# We need separate MACRO files declaring global symbols +SYMOPT = ,perlshr_gbl.opt/Option +.endif + +#: Process compiler selection macros +.ifdef GNUC +.first + @ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS] +CC = gcc +XTRACCFLAGS = /Obj=$(MMS$TARGET_NAME)$(O) +DBGSPECFLAGS = +XTRADEF = ,GNUC_ATTRIBUTE_CHECK +XTRAOBJS = +LIBS1 = GNU_CC:[000000]GCCLIB.OLB/Library +LIBS2 = Sys$Share:VAXCRTL.Exe/Shareable +.else +.first + @ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS Sys$Library +XTRAOBJS = +LIBS1 = $(XTRAOBJS) +DBGSPECFLAGS = /Show=(Source,Include,Expansion) +.ifdef decc +LIBS2 = +XTRACCFLAGS = /Standard=VAXC/Include=[]/Prefix=All/Obj=$(MMS$TARGET_NAME)$(O) +XTRADEF = +.else # VAXC +XTRACCFLAGS = /Include=[]/Object=$(O) +XTRADEF = +LIBS2 = Sys$Share:VAXCRTL.Exe/Shareable +.endif +.endif + +.ifdef __DEBUG__ +DBGCCFLAGS = /List/Debug/NoOpt$(DBGSPECFLAGS) +DBGLINKFLAGS = /Debug/Map/Full/Cross +DBG = DBG +.else +DBGCCFLAGS = /NoList +DBGLINKFLAGS = /NoMap +DBG = +.endif + +# Process option macros +.ifdef SOCKET +SOCKDEF = ,VMS_DO_SOCKETS +SOCKLIB = SocketShr/Share +# N.B. the targets for $(SOCKC) and $(SOCKH) assume that the permanent +# copies live in [.vms], and the `clean' target will delete copies of +# these files in the current default directory. +SOCKC = sockadapt.c +SOCKH = sockadapt.h +SOCKCLIS = ,$(SOCKC) +SOCKHLIS = ,$(SOCKH) +SOCKOBJ = ,sockadapt$(O) +.else +SOCKDEF = +SOCKLIB = +SOCKC = +SOCKH = +SOCKCLIS = +SOCKHLIS = +SOCKOBJ = +.endif + +# DEBUGGING ==> perl -D, not the VMS debugger +CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS) +LINKFLAGS = $(DBGLINKFLAGS) + +MAKEFILE = [.VMS]Descrip.MMS # this file +NOOP = continue + +XSUBPP = MCR Sys$Disk:[]Miniperl$(E) [.ext]xsubpp -typemap [-]typemap +# List of extensions to build into perlmain; enclose each in quotes and +# separate by spaces. +EXT = "DynaLoader" +# Source and object files for these extensions; leading comma is required +# These must be built separately, or you must add rules below to build them +extobj = , [.ext.dynaloader]dl_vms$(O) + +#### End of system configuration section. #### + + +h1 = EXTERN.h, INTERN.h, XSUB.h, av.h, config.h, cop.h, cv.h +h2 = embed.h, form.h, gv.h, handy.h, hv.h, keywords.h, mg.h, op.h +h3 = opcode.h, patchlevel.h, perl.h, perly.h, pp.h, proto.h, regcomp.h +h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h +h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS) + +c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c $(mallocsrc) +c2 = mg.c, perly.c, pp.c, pp_ctl.c, pp_hot.c, pp_sys.c, regcomp.c, regexec.c +c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, vms.c $(SOCKCLIS) + +c = $(c1), $(c2), $(c3), perl.c, miniperlmain.c, perlmain.c + +obj1 = av$(O), scope$(O), op$(O), doop$(O), doio$(O), dump$(O), hv$(O) $(mallocobj) +obj2 = mg$(O), perly$(O), pp$(O), pp_ctl$(O), pp_hot$(O), pp_sys$(O), regcomp$(O), regexec$(O) +obj3 = gv$(O), sv$(O), taint$(O), toke$(O), util$(O), deb$(O), run$(O), vms$(O) $(SOCKOBJ) + +obj = $(obj1), $(obj2), $(obj3) + +CRTL = []crtl.opt +CRTLOPTS =,$(CRTL)/Options + +.SUFFIXES +.SUFFIXES $(O) .c + +.c$(O) : + $(CC) $(CFLAGS) $(MMS$SOURCE) + +all : base extras + @ $(NOOP) +base : $(DBG)miniperl$(E) perl$(E) [.lib]Config.pm + @ $(NOOP) +extras : [.lib]DynaLoader.pm + @ $(NOOP) + +miniperl_objs = miniperlmain$(O), perl$(O), $(obj) +miniperl$(E) : $(miniperl_objs) , coreobjs.opt $(CRTL) + Link $(LINKFLAGS)/NoDebug/Exe=$(MMS$TARGET) miniperlmain$(O), perl$(O), coreobjs.opt/Option $(CRTLOPTS) +.ifdef DBG +$(DBG)miniperl$(E) : $(miniperl_objs) , coreobjs.opt $(CRTL) + Link $(LINKFLAGS)/Exe=$(MMS$TARGET) miniperlmain$(O), perl$(O), coreobjs.opt/Option $(CRTLOPTS) +.endif + +# Use an options file to list object files since some Makes don't feed +# long lines to DCL properly +coreobjs.opt : $(MAKEFILE) + @ @[.vms]genopt "$(MMS$TARGET)/Write" "|" "$(obj1)" + @ @[.vms]genopt "$(MMS$TARGET)/Append" "|" "$(obj2)" + @ @[.vms]genopt "$(MMS$TARGET)/Append" "|" "$(obj3)" + +perlmain.c : miniperlmain.c miniperl$(E) + MCR Sys$Disk:[]Miniperl$(E) [.VMS]Writemain.pl $(EXT) + +perl$(E) : perlmain$(O) $(extobj), perlshr$(E), perlshr_attr.opt $(CRTL) + @ @[.vms]genopt "PerlShr.Opt/Write" "|" "''F$Environment("Default")'$(DBG)PerlShr$(E)/Share" + Link $(LINKFLAGS)/Exe=$(DBG)$(MMS$TARGET) perlmain$(O) $(extobj),[]perlshr.opt/Option,perlshr_attr.opt/Option +shr_objs = perlshr$(O) ,perl$(O), $(obj) +perlshr$(E) : $(shr_objs) ,perlshr_xtras.ts ,coreobjs.opt ,$(CRTL) + Link $(LINKFLAGS)/Share/Exe=$(DBG)$(MMS$TARGET) perlshr$(O), perl$(O), coreobjs.opt/Option $(SYMOPT) , perlshr_attr.opt/Option, perlshr_sym.opt/Option $(CRTLOPTS) +perlshr$(O) : [.vms]perlshr.c + $(CC) $(CFLAGS)/NoOptimize/Object=$(MMS$TARGET) $(MMS$SOURCE) +# The following files are built in one go by gen_shrfls.pl: +# perlshr_attr.opt, perlshr_sym.opt - VAX and AXP +# perlshr_gbl*.mar, perlshr_gbl*$(O), perlshr_gbl.opt - VAX only +.ifdef DECC_PIPES_BROKEN +# This is a backup target used only with older versions of the DECCRTL which +# can't deal with pipes properly. See ReadMe.VMS for details. +perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl miniperl$(E) $(MAKEFILE) + $(CC) $(CFLAGS)/NoObject/NoList/PreProcess=perl.i perl.h + MCR Sys$Disk:[]Miniperl$(E) [.vms]gen_shrfls.pl "~~NOCC~~perl.i" $(O) + @ Delete/NoLog/NoConfirm perl.i; + @ Copy NLA0: perlshr_xtras.ts + @ Purge/NoLog/NoConfirm perlshr_xtras.ts +.else +perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl miniperl$(E) $(MAKEFILE) + MCR Sys$Disk:[]Miniperl$(E) [.vms]gen_shrfls.pl "$(CC)$(CFLAGS)" $(O) + @ Copy NLA0: perlshr_xtras.ts + @ Purge/NoLog/NoConfirm perlshr_xtras.ts +.endif + +[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl miniperl$(E) + MCR Sys$Disk:[]Miniperl$(E) [.VMS]GenConfig.Pl + MCR Sys$Disk:[]Miniperl$(E) ConfigPM. + +[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs miniperl$(E) + $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET) + +[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c + $(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE) + +preplibrary : miniperl$(E) [.lib]Config.pm + @ Create/Directory [.lib.auto] + MCR Sys$Disk:[]Miniperl$(E) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm + +[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm preplibrary + Copy/Log/NoConfirm [.ext.dynaloader]dynaloader.pm [.lib]DynaLoader.pm + MCR Sys$Disk:[]Miniperl$(E) autosplit DynaLoader + +.ifdef SOCKET +$(SOCKOBJ) : $(SOCKC) $(SOCKH) + +vmsish.h : $(SOCKH) + +$(SOCKC) : [.vms]$(SOCKC) + Copy/Log/NoConfirm [.vms]$(SOCKC) []$(SOCKC) + +$(SOCKH) : [.vms]$(SOCKH) + Copy/Log/NoConfirm [.vms]$(SOCKH) []$(SOCKH) +.endif + +#opcode.h : opcode.pl +# MCR Sys$Disk:[]Miniperl$(E) opcode.pl + +perly.h : perly.c # Quick and dirty 'touch' + Copy/Log/NoConfirm perly.h; ; + Delete/Log/NoConfirm perly.h;-1 + +# I now supply perly.c with the kits, so the following section is +# commented out if you don't have byacc. + +# perly.c: +# @ echo 'Expect' 80 shift/reduce and 62 reduce/reduce conflicts +# \$(BYACC) -d perly.y +# sh \$(shellflags) ./perly.fixer y.tab.c perly.c +# mv y.tab.h perly.h +# echo 'extern YYSTYPE yylval;' >>perly.h + +perly$(O) : perly.c, perly.h, $(h) + $(CC) $(CFLAGS) $(MMS$SOURCE) + +test : perl$(E) + - @[.VMS]Test.Com + +# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE +# If this runs make out of memory, delete /usr/include lines. +av$(O) : EXTERN.h +av$(O) : av.c +av$(O) : av.h +av$(O) : config.h +av$(O) : cop.h +av$(O) : cv.h +av$(O) : embed.h +av$(O) : form.h +av$(O) : gv.h +av$(O) : handy.h +av$(O) : hv.h +av$(O) : mg.h +av$(O) : op.h +av$(O) : opcode.h +av$(O) : perl.h +av$(O) : pp.h +av$(O) : proto.h +av$(O) : regexp.h +av$(O) : scope.h +av$(O) : sv.h +av$(O) : vmsish.h +av$(O) : util.h +scope$(O) : EXTERN.h +scope$(O) : av.h +scope$(O) : config.h +scope$(O) : cop.h +scope$(O) : cv.h +scope$(O) : embed.h +scope$(O) : form.h +scope$(O) : gv.h +scope$(O) : handy.h +scope$(O) : hv.h +scope$(O) : mg.h +scope$(O) : op.h +scope$(O) : opcode.h +scope$(O) : perl.h +scope$(O) : pp.h +scope$(O) : proto.h +scope$(O) : regexp.h +scope$(O) : scope.c +scope$(O) : scope.h +scope$(O) : sv.h +scope$(O) : vmsish.h +scope$(O) : util.h +op$(O) : EXTERN.h +op$(O) : av.h +op$(O) : config.h +op$(O) : cop.h +op$(O) : cv.h +op$(O) : embed.h +op$(O) : form.h +op$(O) : gv.h +op$(O) : handy.h +op$(O) : hv.h +op$(O) : mg.h +op$(O) : op.c +op$(O) : op.h +op$(O) : opcode.h +op$(O) : perl.h +op$(O) : pp.h +op$(O) : proto.h +op$(O) : regexp.h +op$(O) : scope.h +op$(O) : sv.h +op$(O) : vmsish.h +op$(O) : util.h +doop$(O) : EXTERN.h +doop$(O) : av.h +doop$(O) : config.h +doop$(O) : cop.h +doop$(O) : cv.h +doop$(O) : doop.c +doop$(O) : embed.h +doop$(O) : form.h +doop$(O) : gv.h +doop$(O) : handy.h +doop$(O) : hv.h +doop$(O) : mg.h +doop$(O) : op.h +doop$(O) : opcode.h +doop$(O) : perl.h +doop$(O) : pp.h +doop$(O) : proto.h +doop$(O) : regexp.h +doop$(O) : scope.h +doop$(O) : sv.h +doop$(O) : vmsish.h +doop$(O) : util.h +doio$(O) : EXTERN.h +doio$(O) : av.h +doio$(O) : config.h +doio$(O) : cop.h +doio$(O) : cv.h +doio$(O) : doio.c +doio$(O) : embed.h +doio$(O) : form.h +doio$(O) : gv.h +doio$(O) : handy.h +doio$(O) : hv.h +doio$(O) : mg.h +doio$(O) : op.h +doio$(O) : opcode.h +doio$(O) : perl.h +doio$(O) : pp.h +doio$(O) : proto.h +doio$(O) : regexp.h +doio$(O) : scope.h +doio$(O) : sv.h +doio$(O) : vmsish.h +doio$(O) : util.h +dump$(O) : EXTERN.h +dump$(O) : av.h +dump$(O) : config.h +dump$(O) : cop.h +dump$(O) : cv.h +dump$(O) : dump.c +dump$(O) : embed.h +dump$(O) : form.h +dump$(O) : gv.h +dump$(O) : handy.h +dump$(O) : hv.h +dump$(O) : mg.h +dump$(O) : op.h +dump$(O) : opcode.h +dump$(O) : perl.h +dump$(O) : pp.h +dump$(O) : proto.h +dump$(O) : regexp.h +dump$(O) : scope.h +dump$(O) : sv.h +dump$(O) : vmsish.h +dump$(O) : util.h +hv$(O) : EXTERN.h +hv$(O) : av.h +hv$(O) : config.h +hv$(O) : cop.h +hv$(O) : cv.h +hv$(O) : embed.h +hv$(O) : form.h +hv$(O) : gv.h +hv$(O) : handy.h +hv$(O) : hv.c +hv$(O) : hv.h +hv$(O) : mg.h +hv$(O) : op.h +hv$(O) : opcode.h +hv$(O) : perl.h +hv$(O) : pp.h +hv$(O) : proto.h +hv$(O) : regexp.h +hv$(O) : scope.h +hv$(O) : sv.h +hv$(O) : vmsish.h +hv$(O) : util.h +malloc$(O) : EXTERN.h +malloc$(O) : av.h +malloc$(O) : config.h +malloc$(O) : cop.h +malloc$(O) : cv.h +malloc$(O) : embed.h +malloc$(O) : form.h +malloc$(O) : gv.h +malloc$(O) : handy.h +malloc$(O) : hv.h +malloc$(O) : malloc.c +malloc$(O) : mg.h +malloc$(O) : op.h +malloc$(O) : opcode.h +malloc$(O) : perl.h +malloc$(O) : pp.h +malloc$(O) : proto.h +malloc$(O) : regexp.h +malloc$(O) : scope.h +malloc$(O) : sv.h +malloc$(O) : vmsish.h +malloc$(O) : util.h +mg$(O) : EXTERN.h +mg$(O) : av.h +mg$(O) : config.h +mg$(O) : cop.h +mg$(O) : cv.h +mg$(O) : embed.h +mg$(O) : form.h +mg$(O) : gv.h +mg$(O) : handy.h +mg$(O) : hv.h +mg$(O) : mg.c +mg$(O) : mg.h +mg$(O) : op.h +mg$(O) : opcode.h +mg$(O) : perl.h +mg$(O) : pp.h +mg$(O) : proto.h +mg$(O) : regexp.h +mg$(O) : scope.h +mg$(O) : sv.h +mg$(O) : vmsish.h +mg$(O) : util.h +perly$(O) : EXTERN.h +perly$(O) : av.h +perly$(O) : config.h +perly$(O) : cop.h +perly$(O) : cv.h +perly$(O) : embed.h +perly$(O) : form.h +perly$(O) : gv.h +perly$(O) : handy.h +perly$(O) : hv.h +perly$(O) : mg.h +perly$(O) : op.h +perly$(O) : opcode.h +perly$(O) : perl.h +perly$(O) : perly.c +perly$(O) : pp.h +perly$(O) : proto.h +perly$(O) : regexp.h +perly$(O) : scope.h +perly$(O) : sv.h +perly$(O) : vmsish.h +perly$(O) : util.h +pp$(O) : EXTERN.h +pp$(O) : av.h +pp$(O) : config.h +pp$(O) : cop.h +pp$(O) : cv.h +pp$(O) : embed.h +pp$(O) : form.h +pp$(O) : gv.h +pp$(O) : handy.h +pp$(O) : hv.h +pp$(O) : mg.h +pp$(O) : op.h +pp$(O) : opcode.h +pp$(O) : perl.h +pp$(O) : pp.c +pp$(O) : pp.h +pp$(O) : proto.h +pp$(O) : regexp.h +pp$(O) : scope.h +pp$(O) : sv.h +pp$(O) : vmsish.h +pp$(O) : util.h +regcomp$(O) : EXTERN.h +regcomp$(O) : INTERN.h +regcomp$(O) : av.h +regcomp$(O) : config.h +regcomp$(O) : cop.h +regcomp$(O) : cv.h +regcomp$(O) : embed.h +regcomp$(O) : form.h +regcomp$(O) : gv.h +regcomp$(O) : handy.h +regcomp$(O) : hv.h +regcomp$(O) : mg.h +regcomp$(O) : op.h +regcomp$(O) : opcode.h +regcomp$(O) : perl.h +regcomp$(O) : pp.h +regcomp$(O) : proto.h +regcomp$(O) : regcomp.c +regcomp$(O) : regcomp.h +regcomp$(O) : regexp.h +regcomp$(O) : scope.h +regcomp$(O) : sv.h +regcomp$(O) : vmsish.h +regcomp$(O) : util.h +regexec$(O) : EXTERN.h +regexec$(O) : av.h +regexec$(O) : config.h +regexec$(O) : cop.h +regexec$(O) : cv.h +regexec$(O) : embed.h +regexec$(O) : form.h +regexec$(O) : gv.h +regexec$(O) : handy.h +regexec$(O) : hv.h +regexec$(O) : mg.h +regexec$(O) : op.h +regexec$(O) : opcode.h +regexec$(O) : perl.h +regexec$(O) : pp.h +regexec$(O) : proto.h +regexec$(O) : regcomp.h +regexec$(O) : regexec.c +regexec$(O) : regexp.h +regexec$(O) : scope.h +regexec$(O) : sv.h +regexec$(O) : vmsish.h +regexec$(O) : util.h +gv$(O) : EXTERN.h +gv$(O) : av.h +gv$(O) : config.h +gv$(O) : cop.h +gv$(O) : cv.h +gv$(O) : embed.h +gv$(O) : form.h +gv$(O) : gv.c +gv$(O) : gv.h +gv$(O) : handy.h +gv$(O) : hv.h +gv$(O) : mg.h +gv$(O) : op.h +gv$(O) : opcode.h +gv$(O) : perl.h +gv$(O) : pp.h +gv$(O) : proto.h +gv$(O) : regexp.h +gv$(O) : scope.h +gv$(O) : sv.h +gv$(O) : vmsish.h +gv$(O) : util.h +sv$(O) : EXTERN.h +sv$(O) : av.h +sv$(O) : config.h +sv$(O) : cop.h +sv$(O) : cv.h +sv$(O) : embed.h +sv$(O) : form.h +sv$(O) : gv.h +sv$(O) : handy.h +sv$(O) : hv.h +sv$(O) : mg.h +sv$(O) : op.h +sv$(O) : opcode.h +sv$(O) : perl.h +sv$(O) : perly.h +sv$(O) : pp.h +sv$(O) : proto.h +sv$(O) : regexp.h +sv$(O) : scope.h +sv$(O) : sv.c +sv$(O) : sv.h +sv$(O) : vmsish.h +sv$(O) : util.h +taint$(O) : EXTERN.h +taint$(O) : av.h +taint$(O) : config.h +taint$(O) : cop.h +taint$(O) : cv.h +taint$(O) : embed.h +taint$(O) : form.h +taint$(O) : gv.h +taint$(O) : handy.h +taint$(O) : hv.h +taint$(O) : mg.h +taint$(O) : op.h +taint$(O) : opcode.h +taint$(O) : perl.h +taint$(O) : pp.h +taint$(O) : proto.h +taint$(O) : regexp.h +taint$(O) : scope.h +taint$(O) : sv.h +taint$(O) : taint.c +taint$(O) : vmsish.h +taint$(O) : util.h +toke$(O) : EXTERN.h +toke$(O) : av.h +toke$(O) : config.h +toke$(O) : cop.h +toke$(O) : cv.h +toke$(O) : embed.h +toke$(O) : form.h +toke$(O) : gv.h +toke$(O) : handy.h +toke$(O) : hv.h +toke$(O) : keywords.h +toke$(O) : mg.h +toke$(O) : op.h +toke$(O) : opcode.h +toke$(O) : perl.h +toke$(O) : perly.h +toke$(O) : pp.h +toke$(O) : proto.h +toke$(O) : regexp.h +toke$(O) : scope.h +toke$(O) : sv.h +toke$(O) : toke.c +toke$(O) : vmsish.h +toke$(O) : util.h +util$(O) : EXTERN.h +util$(O) : av.h +util$(O) : config.h +util$(O) : cop.h +util$(O) : cv.h +util$(O) : embed.h +util$(O) : form.h +util$(O) : gv.h +util$(O) : handy.h +util$(O) : hv.h +util$(O) : mg.h +util$(O) : op.h +util$(O) : opcode.h +util$(O) : perl.h +util$(O) : pp.h +util$(O) : proto.h +util$(O) : regexp.h +util$(O) : scope.h +util$(O) : sv.h +util$(O) : vmsish.h +util$(O) : util.c +util$(O) : util.h +deb$(O) : EXTERN.h +deb$(O) : av.h +deb$(O) : config.h +deb$(O) : cop.h +deb$(O) : cv.h +deb$(O) : deb.c +deb$(O) : embed.h +deb$(O) : form.h +deb$(O) : gv.h +deb$(O) : handy.h +deb$(O) : hv.h +deb$(O) : mg.h +deb$(O) : op.h +deb$(O) : opcode.h +deb$(O) : perl.h +deb$(O) : pp.h +deb$(O) : proto.h +deb$(O) : regexp.h +deb$(O) : scope.h +deb$(O) : sv.h +deb$(O) : vmsish.h +deb$(O) : util.h +run$(O) : EXTERN.h +run$(O) : av.h +run$(O) : config.h +run$(O) : cop.h +run$(O) : cv.h +run$(O) : embed.h +run$(O) : form.h +run$(O) : gv.h +run$(O) : handy.h +run$(O) : hv.h +run$(O) : mg.h +run$(O) : op.h +run$(O) : opcode.h +run$(O) : perl.h +run$(O) : pp.h +run$(O) : proto.h +run$(O) : regexp.h +run$(O) : run.c +run$(O) : scope.h +run$(O) : sv.h +run$(O) : vmsish.h +run$(O) : util.h +vms$(O) : EXTERN.h +vms$(O) : av.h +vms$(O) : config.h +vms$(O) : cop.h +vms$(O) : cv.h +vms$(O) : embed.h +vms$(O) : form.h +vms$(O) : gv.h +vms$(O) : handy.h +vms$(O) : hv.h +vms$(O) : mg.h +vms$(O) : op.h +vms$(O) : opcode.h +vms$(O) : perl.h +vms$(O) : pp.h +vms$(O) : proto.h +vms$(O) : regexp.h +vms$(O) : vms.c +vms$(O) : scope.h +vms$(O) : sv.h +vms$(O) : vmsish.h +vms$(O) : util.h +miniperlmain$(O) : INTERN.h +miniperlmain$(O) : av.h +miniperlmain$(O) : config.h +miniperlmain$(O) : cop.h +miniperlmain$(O) : cv.h +miniperlmain$(O) : embed.h +miniperlmain$(O) : form.h +miniperlmain$(O) : gv.h +miniperlmain$(O) : handy.h +miniperlmain$(O) : hv.h +miniperlmain$(O) : mg.h +miniperlmain$(O) : miniperlmain.c +miniperlmain$(O) : op.h +miniperlmain$(O) : opcode.h +miniperlmain$(O) : perl.h +miniperlmain$(O) : pp.h +miniperlmain$(O) : proto.h +miniperlmain$(O) : regexp.h +miniperlmain$(O) : scope.h +miniperlmain$(O) : sv.h +miniperlmain$(O) : vmsish.h +miniperlmain$(O) : util.h +perlmain$(O) : INTERN.h +perlmain$(O) : av.h +perlmain$(O) : config.h +perlmain$(O) : cop.h +perlmain$(O) : cv.h +perlmain$(O) : embed.h +perlmain$(O) : form.h +perlmain$(O) : gv.h +perlmain$(O) : handy.h +perlmain$(O) : hv.h +perlmain$(O) : mg.h +perlmain$(O) : op.h +perlmain$(O) : opcode.h +perlmain$(O) : perl.h +perlmain$(O) : perlmain.c +perlmain$(O) : pp.h +perlmain$(O) : proto.h +perlmain$(O) : regexp.h +perlmain$(O) : scope.h +perlmain$(O) : sv.h +perlmain$(O) : vmsish.h +perlmain$(O) : util.h + +config.h : [.vms]config.vms + Copy/Log/NoConfirm [.vms]config.vms []config.h + +vmsish.h : [.vms]vmsish.h + Copy/Log/NoConfirm [.vms]vmsish.h []vmsish.h + +vms.c : [.vms]vms.c + Copy/Log/Noconfirm [.vms]vms.c [] + +$(CRTL) : $(MAKEFILE) + @ @[.vms]genopt "$(CRTL)/Write" "|" "$(LIBS1)|$(LIBS2)|$(SOCKLIB)" + + +cleanlis : + - If F$Search("*.Lis").nes."" Then Delete/NoConfirm/Log *.Lis;* + - If F$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;* + +tidy : cleanlis + - If F$Search("*.Opt;-1").nes."" Then Purge/NoConfirm/Log *.Opt + - If F$Search("*$(O);-1").nes."" Then Purge/NoConfirm/Log *$(O) + - If F$Search("*$(E);-1").nes."" Then Purge/NoConfirm/Log *$(E) + - If F$Search("Config.H;-1").nes."" Then Purge/NoConfirm/Log Config.H + - If F$Search("Config.SH;-1").nes."" Then Purge/NoConfirm/Log Config.SH + - If F$Search("VMSish.H;-1").nes."" Then Purge/NoConfirm/Log VMSish.H + - If F$Search("VMS.C;-1") .nes."" Then Purge/NoConfirm/Log VMS.C + - If F$Search("Perlmain.C;-1") .nes."" Then Purge/NoConfirm/Log Perlmain.C + - If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar + - If F$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O) + - If F$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C + - If F$Search("[.Lib.Auto...]*.al;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]*.al + - If F$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ts + +clean : tidy + - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_Attr.Opt + - If F$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);* + - If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;* + - If F$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;* + - If F$Search(F$Parse("Sys$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);* + - If F$Search(F$Parse("Sys$Disk:[]","$(SOCKC)")).nes."" Then Delete/NoConfirm/Log $(SOCKC);* + - If F$Search("VMSish.H").nes."" Then Delete/NoConfirm/Log VMSish.H;* + - If F$Search("VMS.C") .nes."" Then Delete/NoConfirm/Log VMS.C;* + - If F$Search("Perlmain.C") .nes."" Then Delete/NoConfirm/Log Perlmain.C;* + - If F$Search("Perlshr_Gbl*.Mar") .nes."" Then Delete/NoConfirm/Log Perlshr_Gbl*.Mar;* + - If F$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;* + - If F$Search("[.Ext.DynaLoader]DL_VMS$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O);* + - If F$Search("[.Ext.DynaLoader]DL_VMS.C").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C;* + +realclean : clean + - If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* + - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;* + - If F$Search("[.Lib.Auto...]*.al;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;* + - If F$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;* + +cleansrc : clean + - If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* + - If F$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C + - If F$Search("*.H;-1").nes."" Then Purge/NoConfirm/Log *.H + - If F$Search("*.VMS;-1").nes."" Then Purge/NoConfirm/Log *.VMS + - If F$Search("$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log $(MAKEFILE) + - If F$Search("[.VMS]$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log [.VMS]$(MAKEFILE) + - If F$Search("[.VMS]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.C + - If F$Search("[.VMS]*.H;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.H + - If F$Search("[.VMS]*.Pl;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.Pl + - If F$Search("[.VMS]*.VMS;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.VMS + - If F$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;* + - If F$Search("[.Lib.Auto...]autosplit.ts;").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;* + - If F$Search("[.Lib]Config.pm;").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;* diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl new file mode 100644 index 0000000000..120c355cd7 --- /dev/null +++ b/vms/gen_shrfls.pl @@ -0,0 +1,229 @@ +# Create global symbol declarations, transfer vector, and +# linker options files for PerlShr. +# +# Input: +# $cflags - command line qualifiers passed to cc when preprocesing perl.h +# Note: A rather simple-minded attempt is made to restore quotes to +# a /Define clause - use with care. +# $objsuffix - file type (including '.') used for object files. +# +# Output: +# PerlShr_Attr.Opt - linker options file which speficies that global vars +# be placed in NOSHR,WRT psects. Use when linking any object files +# against PerlShr.Exe, since cc places global vars in SHR,WRT psects +# by default. +# PerlShr_Sym.Opt - declares universal symbols for PerlShr.Exe +# Perlshr_Gbl*.Mar, Perlshr_Gbl*.Obj (VAX only) - declares global symbols +# for global vars (done here because gcc can't globaldef) and creates +# transfer vectors for routines on a VAX. +# PerlShr_Gbl.Opt (VAX only) - list of PerlShr_Gbl*.Obj, used for input +# to the linker when building PerlShr.Exe. +# +# To do: +# - figure out a good way to collect global vars in one psect, given that +# we can't use globaldef because of gcc. +# - then, check for existing files and preserve symbol and transfer vector +# order for upward compatibility +# - then, add GSMATCH to options file - but how do we insure that new +# library has everything old one did +# (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)? +# +# Author: Charles Bailey bailey@genetics.upenn.edu +# Revised: 21-Sep-1994 + +require 5.000; + +$debug = $ENV{'GEN_SHRFLS_DEBUG'}; +$cc_cmd = shift @ARGV; +print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug; +$docc = ($cc_cmd !~ /~~NOCC~~/); +print "\$docc = $docc\n" if $debug; + +if ($docc) { + # put quotes back onto defines - they were removed by DCL on the way in + if (($prefix,$defines,$suffix) = + ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) { + $defines =~ s/^\((.*)\)$/$1/; + @defines = split(/,/,$defines); + $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines)) + . ')' . $suffix; + } + print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug; + + if (-f 'perl.h') { $dir = '[]'; } + elsif (-f '[-]perl.h') { $dir = '[-]'; } + else { die "$0: Can't find perl.h\n"; } +} +else { ($cpp_file) = ($cc_cmd =~ /~~NOCC~~(.*)/) } + +$objsuffix = shift @ARGV; +print "\$objsuffix: \\$objsuffix\\\n" if $debug; + +# Someday, we'll have $GetSyI built into perl . . . +$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024; +print "\$isvax: \\$isvax\\\n" if $debug; + +sub scan_var { + my($line) = @_; + + print "\tchecking for global variable\n" if $debug; + $line =~ s/INIT\(.*\)//; + $line =~ s/\[.*//; + $line =~ s/=.*//; + $line =~ s/\W*;?\s*$//; + print "\tfiltered to \\$line\\\n" if $debug; + if ($line =~ /(\w+)$/) { + print "\tvar name is \\$1\\\n" if $debug; + $vars{$1}++; + } +} + +sub scan_func { + my($line) = @_; + + print "\tchecking for global routine\n" if $debug; + if ( /(\w+)\s+\(/ ) { + print "\troutine name is \\$1\\\n" if $debug; + if ($1 eq 'main' || $1 eq 'perl_init_ext') { + print "\tskipped\n" if $debug; + } + else { $funcs{$1}++ } + } +} + +if ($docc) { + open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output ${dir}perl.h|") + or die "$0: Can't preprocess ${dir}perl.h: $!\n"; +} +else { + open(CPP,"$cpp_file") or die "$0: Can't read $cpp_file: $!\n"; +} +LINE: while (<CPP>) { + while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) { + while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) { + print "vms_proto>> $_" if $debug; + &scan_func($_); + if (/^EXT/) { &scan_var($_); } + last LINE unless $_ = <CPP>; + } + print "vmsish.h>> $_" if $debug; + if (/^EXT/) { &scan_var($_); } + last LINE unless $_ = <CPP>; + } + while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) { + print "opcode.h>> $_" if $debug; + if (/^OP \*\s/) { &scan_func($_); } + if (/^EXT/) { &scan_var($_); } + last LINE unless $_ = <CPP>; + } + while (/^#.*proto\.h/i .. /^#.*perl\.h/i) { + print "proto.h>> $_" if $debug; + &scan_func($_); + if (/^EXT/) { &scan_var($_); } + last LINE unless $_ = <CPP>; + } + print $_ if $debug; + if (/^EXT/) { &scan_var($_); } +} +close CPP; +while (<DATA>) { + next if /^#/; + s/\s+#.*\n//; + ($key,$array) = split('=',$_); + print "Adding $key to \%$array list\n" if $debug; + ${$array}{$key}++; +} + +# Eventually, we'll check against existing copies here, so we can add new +# symbols to an existing options file in an upwardly-compatible manner. + +$marord++; +open(OPTSYM,">${dir}perlshr_sym.opt") + or die "$0: Can't write to ${dir}perlshr_sym.opt: $!\n"; +open(OPTATTR,">${dir}perlshr_attr.opt") + or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; +if ($isvax) { + open(MAR,">${dir}perlshr_gbl${marord}.mar") + or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; +} +print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; +foreach $var (sort keys %vars) { + print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; + if ($isvax) { print OPTSYM "UNIVERSAL=$var\n"; } + else { print OPTSYM "SYMBOL_VECTOR=($var=DATA)\n"; } + if ($isvax) { + if ($count++ > 200) { # max 254 psects/file + print MAR "\t.end\n"; + close MAR; + $marord++; + open(MAR,">${dir}perlshr_gbl${marord}.mar") + or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; + $count = 0; + } + # This hack brought to you by the lack of a globaldef in gcc. + print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n"; + print MAR "\t${var}:: .blkl 1\n"; + } +} + +print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax); +foreach $func (sort keys %funcs) { + if ($isvax) { + print MAR "\t.transfer $func\n"; + print MAR "\t.mask $func\n"; + print MAR "\tjmp L\^${func}+2\n"; + } + else { print OPTSYM "SYMBOL_VECTOR=($func=PROCEDURE)\n"; } +} + +close OPTSYM; +close OPTATTR; +if ($isvax) { + print MAR "\t.end\n"; + close MAR; + open (GBLOPT,">PerlShr_Gbl.Opt") or die "$0: Can't write to PerlShr_Gbl.Opt: $!\n"; + $drvrname = "Compile_shrmars.tmp_".time; + open (DRVR,">$drvrname") or die "$0: Can't write to $drvrname: $!\n"; + print DRVR "\$ Set NoOn\n"; + print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n"; + print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n"; + print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n"; + print DRVR "\$ Set Verify\n"; + do { + print GBLOPT "PerlShr_Gbl${marord}$objsuffix\n"; + print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n"; + } while (--$marord); + print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n"; + close DRVR; + close GBLOPT; + exec "\$ \@$drvrname"; +} +__END__ + +# Oddball cases, so we can keep the perl.h scan above simple +error=vars # declared in perl.h only when DOINIT defined by INTERN.h +rcsid=vars # declared in perl.c +regarglen=vars # declared in regcomp.h +regdummy=vars # declared in regcomp.h +regkind=vars # declared in regcomp.h +simple=vars # declared in regcomp.h +varies=vars # declared in regcomp.h +watchaddr=vars # declared in run.c +watchok=vars # declared in run.c +yychar=vars # generated by byacc in perly.c +yycheck=vars # generated by byacc in perly.c +yydebug=vars # generated by byacc in perly.c +yydefred=vars # generated by byacc in perly.c +yydgoto=vars # generated by byacc in perly.c +yyerrflag=vars # generated by byacc in perly.c +yygindex=vars # generated by byacc in perly.c +yylen=vars # generated by byacc in perly.c +yylhs=vars # generated by byacc in perly.c +yylval=vars # generated by byacc in perly.c +yyname=vars # generated by byacc in perly.c +yynerrs=vars # generated by byacc in perly.c +yyrindex=vars # generated by byacc in perly.c +yyrule=vars # generated by byacc in perly.c +yysindex=vars # generated by byacc in perly.c +yytable=vars # generated by byacc in perly.c +yyval=vars # generated by byacc in perly.c diff --git a/vms/genconfig.pl b/vms/genconfig.pl new file mode 100644 index 0000000000..18bc9851db --- /dev/null +++ b/vms/genconfig.pl @@ -0,0 +1,112 @@ +#!/usr/bin/perl +# Habit . . . +# +# Extract info from Config.VMS, 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. +# +# Rev. 30-Sep-1994 Charles Bailey bailey@genetics.upenn.edu +# + +unshift(@INC,'lib'); # In case someone didn't define Perl_Root + # before the build +require 'ctime.pl' || die "Couldn't execute ctime.pl: $!\n"; + +if (-f "config.vms") { $infile = "config.vms"; $outdir = "[-]"; } +elsif (-f "[.vms]config.vms") { $infile = "[.vms]config.vms"; $outdir = "[]"; } +elsif (-f "config.h") { $infile = "config.h"; $outdir = "[]";} + +if ($infile) { print "Generating Config.sh from $infile . . .\n"; } +else { die <<EndOfGasp; +Can't find config.vms or config.h to read! + Please run this script from the perl source directory or + the VMS 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"; +select OUT; + + +$time = &ctime(time()); +print <<EndOfIntro; +# This file generated by GenConfig.pl on a VMS system. +# Input obtained from: +# $infile +# $0 +# Time: $time + +EndOfIntro + +while (<IN>) { # roll through the comment header in Config.VMS + last if /^#define _config_h_/; +} + +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*(.*)%; + next if /config-skip/; + $state = ($blocked || $un) ? 'undef' : 'define'; + $token =~ tr/A-Z/a-z/; + $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 "$token=\'$val\'\n"; } + else { + $token = "d_$token" unless $token =~ /^i_/; + print "$token=\'$state\'\n"; } +} +close IN; + +while (<DATA>) { + next if /^\s*#/ or /^\s*$/; + s/#.*$//; s/\s*$//; + ($key,$val) = split('=',$_,2); + print "$key=\'$val\'\n"; +} + +__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. +osname=VMS # DO NOT CHANGE THIS! Tests elsewhere depend on this to identify + # VMS. Use the 'arch' item below to specify hardware version. +CONFIG=true +PATCHLEVEL=0 +dldir=/ext/dl +dlobj=dl_vms.obj +dlsrc=dl_vms.c +so=exe +dlext=exe +libpth=/sys$share /sys$library +hintfile= +intsize=4 +alignbytes=8 +shrplib=define +signal_t=void +timetype=long +usemymalloc=n +builddir=perl_root:[000000] + +# The definitions in this block are site-specific, and will probably need to +# be changed on most systems. +myhostname=nowhere.loopback.edu +arch=VAX +osvers=5.5-2 +cppflags=/Define=(DEBUGGING) +d_vms_do_sockets=undef #=define if perl5 built with socket support +d_has_sockets=undef # This should have the same value as d_vms_do_sockets +libs= # This should list RTLs other than the C RTL and IMAGELIB (e.g. socket RTL) diff --git a/vms/genopt.com b/vms/genopt.com new file mode 100644 index 0000000000..70013aec42 --- /dev/null +++ b/vms/genopt.com @@ -0,0 +1,18 @@ +$! generates options file for vms link +$! p1 is filename and mode to open file (filename/write or filename/append) +$! p2 is delimiter separating elements of list in p3 +$! p3 is list of items to be written, one per line, into options file +$ +$ open file 'p1' +$ element=0 +$loop: +$ x=f$element(element,p2,p3) +$ if x .eqs. p2 then goto out +$ y=f$edit(x,"COLLAPSE") ! lose spaces +$ if y .nes. "" then write file y +$ element=element+1 +$ goto loop +$ +$out: +$ close file +$ exit diff --git a/vms/makefile. b/vms/makefile. new file mode 100644 index 0000000000..bc5a58c46f --- /dev/null +++ b/vms/makefile. @@ -0,0 +1,764 @@ +#> This file produced from Descrip.MMS by mms2make.pl +#> Lines beginning with "#>" were commented out during the +#> conversion process. For more information, see mms2make.pl +#> +# Makefile. for perl5 on VMS +# Last revised 30-Sep-1994 by Charles Bailey bailey@genetics.upenn.edu +# +# +# tidy -- purge files generated by executing this file +# clean -- remove all files generated by executing this file +# cleansrc -- `clean' + purge *.c,*.h,Makefile. +# gcc_cld_setup -- GCC initialization; see above +# crtl.opt -- compiler-specific linker options file (made automatically) +# + +#### Start of system configuration section. #### + +# File type to use for object files +# File type to use for executable images +# File type to use for object files +O = .obj +# File type to use for executable images +E = .exe + +# used to incorporate 'custom' malloc routines +mallocsrc = +mallocobj = + +# We need separate MACRO files declaring global symbols +SYMOPT = ,perlshr_gbl.opt/Option + +.first: + @ If f$$TrnLnm("Sys").eqs."" Then Define/NoLog SYS sys$$Library +XTRAOBJS = +LIBS1 = $(XTRAOBJS) +DBGSPECFLAGS = /Show=(Source,Include,Expansion) +XTRACCFLAGS = /Include=[]/Object=$(O) +XTRADEF = +LIBS2 = sys$$Share:VAXCRTL.Exe/Shareable + +DBGCCFLAGS = /NoList +DBGLINKFLAGS = /NoMap +DBG = + +# Process option macros +# N.B. the targets for $(SOCKC) and $(SOCKH) assume that the permanent +# copies live in [.vms], and the `clean' target will delete copies of +# these files in the current default directory. +SOCKDEF = +SOCKLIB = +SOCKC = +SOCKH = +SOCKCLIS = +SOCKHLIS = +SOCKOBJ = + +# DEBUGGING ==> perl -D, not the VMS debugger +CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS) +LINKFLAGS = $(DBGLINKFLAGS) + +MAKEFILE = [.VMS]Makefile. # this file +NOOP = continue + +XSUBPP = MCR sys$$Disk:[]Miniperl$(E) [.ext]xsubpp -typemap [-]typemap +# List of extensions to build into perlmain; enclose each in quotes and +# separate by spaces. +EXT = "DynaLoader" +# Source and object files for these extensions; leading comma is required +# These must be built separately, or you must add rules below to build them +extobj = , [.ext.dynaloader]dl_vms$(O) + +#### End of system configuration section. #### + + +h1 = EXTERN.h, INTERN.h, XSUB.h, av.h, config.h, cop.h, cv.h +h2 = embed.h, form.h, gv.h, handy.h, hv.h, keywords.h, mg.h, op.h +h3 = opcode.h, patchlevel.h, perl.h, perly.h, pp.h, proto.h, regcomp.h +h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h +h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS) + +c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c $(mallocsrc) +c2 = mg.c, perly.c, pp.c, pp_ctl.c, pp_hot.c, pp_sys.c, regcomp.c, regexec.c +c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, vms.c $(SOCKCLIS) + +c = $(c1), $(c2), $(c3), perl.c, miniperlmain.c, perlmain.c + +obj1 = av$(O), scope$(O), op$(O), doop$(O), doio$(O), dump$(O), hv$(O) $(mallocobj) +obj2 = mg$(O), perly$(O), pp$(O), pp_ctl$(O), pp_hot$(O), pp_sys$(O), regcomp$(O), regexec$(O) +obj3 = gv$(O), sv$(O), taint$(O), toke$(O), util$(O), deb$(O), run$(O), vms$(O) $(SOCKOBJ) + +obj = $(obj1), $(obj2), $(obj3) + +CRTL = []crtl.opt +CRTLOPTS =,$(CRTL)/Options + +.suffixes: +.suffixes: $(O) .c + +.c$(O) : + $(CC) $(CFLAGS) $< + +all : base extras + @ $(NOOP) +base : $(DBG)miniperl$(E) perl$(E) [.lib]Config.pm + @ $(NOOP) +extras : [.lib]DynaLoader.pm + @ $(NOOP) + +miniperl_objs = miniperlmain$(O), perl$(O), $(obj) +miniperl$(E) : $(miniperl_objs) , coreobjs.opt $(CRTL) + Link $(LINKFLAGS)/NoDebug/Exe=$@ miniperlmain$(O), perl$(O), coreobjs.opt/Option $(CRTLOPTS) + +# Use an options file to list object files since some Makes don't feed +# long lines to DCL properly +coreobjs.opt : $(MAKEFILE) + @ $$@[.vms]genopt "$@/Write" "|" "$(obj1)" + @ $$@[.vms]genopt "$@/Append" "|" "$(obj2)" + @ $$@[.vms]genopt "$@/Append" "|" "$(obj3)" + +perlmain.c : miniperlmain.c miniperl$(E) + MCR sys$$Disk:[]Miniperl$(E) [.VMS]Writemain.pl $(EXT) + +perl$(E) : perlmain$(O) $(extobj), perlshr$(E), perlshr_attr.opt $(CRTL) + @ $$@[.vms]genopt "PerlShr.Opt/Write" "|" "''f$$Environment("Default")'$(DBG)PerlShr$(E)/Share" + Link $(LINKFLAGS)/Exe=$(DBG)$@ perlmain$(O) $(extobj),[]perlshr.opt/Option,perlshr_attr.opt/Option +shr_objs = perlshr$(O) ,perl$(O), $(obj) +perlshr$(E) : $(shr_objs) ,perlshr_xtras.ts ,coreobjs.opt ,$(CRTL) + Link $(LINKFLAGS)/Share/Exe=$(DBG)$@ perlshr$(O), perl$(O), coreobjs.opt/Option $(SYMOPT) , perlshr_attr.opt/Option, perlshr_sym.opt/Option $(CRTLOPTS) +perlshr$(O) : [.vms]perlshr.c + $(CC) $(CFLAGS)/NoOptimize/Object=$@ [.vms]perlshr.c +# The following files are built in one go by gen_shrfls.pl: +# perlshr_attr.opt, perlshr_sym.opt - VAX and AXP +# perlshr_gbl*.mar, perlshr_gbl*$(O), perlshr_gbl.opt - VAX only +# This is a backup target used only with older versions of the DECCRTL which +# can't deal with pipes properly. See ReadMe.VMS for details. +perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl miniperl$(E) $(MAKEFILE) + MCR sys$$Disk:[]Miniperl$(E) [.vms]gen_shrfls.pl "$(CC)$(CFLAGS)" $(O) + @ Copy NLA0: perlshr_xtras.ts + @ Purge/NoLog/NoConfirm perlshr_xtras.ts + +[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl miniperl$(E) + MCR sys$$Disk:[]Miniperl$(E) [.VMS]GenConfig.Pl + MCR sys$$Disk:[]Miniperl$(E) ConfigPM. + +[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs miniperl$(E) + $(XSUBPP) [.ext.dynaloader]dl_vms.xs >$@ + +[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c + $(CC) $(CFLAGS) /Object=$@ [.ext.dynaloader]dl_vms.c + +preplibrary : miniperl$(E) [.lib]Config.pm + @ Create/Directory [.lib.auto] + MCR sys$$Disk:[]Miniperl$(E) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm + +[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm preplibrary + Copy/Log/NoConfirm [.ext.dynaloader]dynaloader.pm [.lib]DynaLoader.pm + MCR sys$$Disk:[]Miniperl$(E) autosplit DynaLoader + + +#opcode.h : opcode.pl +# MCR Sys$Disk:[]Miniperl$(E) opcode.pl + +perly.h : perly.c # Quick and dirty 'touch' + Copy/Log/NoConfirm perly.h; ; + Delete/Log/NoConfirm perly.h;-1 + +# I now supply perly.c with the kits, so the following section is +# commented out if you don't have byacc. + +# perly.c: +# @ echo 'Expect' 80 shift/reduce and 62 reduce/reduce conflicts +# \$(BYACC) -d perly.y +# sh \$(shellflags) ./perly.fixer y.tab.c perly.c +# mv y.tab.h perly.h +# echo 'extern YYSTYPE yylval;' >>perly.h + +perly$(O) : perly.c, perly.h, $(h) + $(CC) $(CFLAGS) perly.c + +test : perl$(E) + - @[.VMS]Test.Com + +# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE +# If this runs make out of memory, delete /usr/include lines. +av$(O) : EXTERN.h +av$(O) : av.c +av$(O) : av.h +av$(O) : config.h +av$(O) : cop.h +av$(O) : cv.h +av$(O) : embed.h +av$(O) : form.h +av$(O) : gv.h +av$(O) : handy.h +av$(O) : hv.h +av$(O) : mg.h +av$(O) : op.h +av$(O) : opcode.h +av$(O) : perl.h +av$(O) : pp.h +av$(O) : proto.h +av$(O) : regexp.h +av$(O) : scope.h +av$(O) : sv.h +av$(O) : vmsish.h +av$(O) : util.h +scope$(O) : EXTERN.h +scope$(O) : av.h +scope$(O) : config.h +scope$(O) : cop.h +scope$(O) : cv.h +scope$(O) : embed.h +scope$(O) : form.h +scope$(O) : gv.h +scope$(O) : handy.h +scope$(O) : hv.h +scope$(O) : mg.h +scope$(O) : op.h +scope$(O) : opcode.h +scope$(O) : perl.h +scope$(O) : pp.h +scope$(O) : proto.h +scope$(O) : regexp.h +scope$(O) : scope.c +scope$(O) : scope.h +scope$(O) : sv.h +scope$(O) : vmsish.h +scope$(O) : util.h +op$(O) : EXTERN.h +op$(O) : av.h +op$(O) : config.h +op$(O) : cop.h +op$(O) : cv.h +op$(O) : embed.h +op$(O) : form.h +op$(O) : gv.h +op$(O) : handy.h +op$(O) : hv.h +op$(O) : mg.h +op$(O) : op.c +op$(O) : op.h +op$(O) : opcode.h +op$(O) : perl.h +op$(O) : pp.h +op$(O) : proto.h +op$(O) : regexp.h +op$(O) : scope.h +op$(O) : sv.h +op$(O) : vmsish.h +op$(O) : util.h +doop$(O) : EXTERN.h +doop$(O) : av.h +doop$(O) : config.h +doop$(O) : cop.h +doop$(O) : cv.h +doop$(O) : doop.c +doop$(O) : embed.h +doop$(O) : form.h +doop$(O) : gv.h +doop$(O) : handy.h +doop$(O) : hv.h +doop$(O) : mg.h +doop$(O) : op.h +doop$(O) : opcode.h +doop$(O) : perl.h +doop$(O) : pp.h +doop$(O) : proto.h +doop$(O) : regexp.h +doop$(O) : scope.h +doop$(O) : sv.h +doop$(O) : vmsish.h +doop$(O) : util.h +doio$(O) : EXTERN.h +doio$(O) : av.h +doio$(O) : config.h +doio$(O) : cop.h +doio$(O) : cv.h +doio$(O) : doio.c +doio$(O) : embed.h +doio$(O) : form.h +doio$(O) : gv.h +doio$(O) : handy.h +doio$(O) : hv.h +doio$(O) : mg.h +doio$(O) : op.h +doio$(O) : opcode.h +doio$(O) : perl.h +doio$(O) : pp.h +doio$(O) : proto.h +doio$(O) : regexp.h +doio$(O) : scope.h +doio$(O) : sv.h +doio$(O) : vmsish.h +doio$(O) : util.h +dump$(O) : EXTERN.h +dump$(O) : av.h +dump$(O) : config.h +dump$(O) : cop.h +dump$(O) : cv.h +dump$(O) : dump.c +dump$(O) : embed.h +dump$(O) : form.h +dump$(O) : gv.h +dump$(O) : handy.h +dump$(O) : hv.h +dump$(O) : mg.h +dump$(O) : op.h +dump$(O) : opcode.h +dump$(O) : perl.h +dump$(O) : pp.h +dump$(O) : proto.h +dump$(O) : regexp.h +dump$(O) : scope.h +dump$(O) : sv.h +dump$(O) : vmsish.h +dump$(O) : util.h +hv$(O) : EXTERN.h +hv$(O) : av.h +hv$(O) : config.h +hv$(O) : cop.h +hv$(O) : cv.h +hv$(O) : embed.h +hv$(O) : form.h +hv$(O) : gv.h +hv$(O) : handy.h +hv$(O) : hv.c +hv$(O) : hv.h +hv$(O) : mg.h +hv$(O) : op.h +hv$(O) : opcode.h +hv$(O) : perl.h +hv$(O) : pp.h +hv$(O) : proto.h +hv$(O) : regexp.h +hv$(O) : scope.h +hv$(O) : sv.h +hv$(O) : vmsish.h +hv$(O) : util.h +malloc$(O) : EXTERN.h +malloc$(O) : av.h +malloc$(O) : config.h +malloc$(O) : cop.h +malloc$(O) : cv.h +malloc$(O) : embed.h +malloc$(O) : form.h +malloc$(O) : gv.h +malloc$(O) : handy.h +malloc$(O) : hv.h +malloc$(O) : malloc.c +malloc$(O) : mg.h +malloc$(O) : op.h +malloc$(O) : opcode.h +malloc$(O) : perl.h +malloc$(O) : pp.h +malloc$(O) : proto.h +malloc$(O) : regexp.h +malloc$(O) : scope.h +malloc$(O) : sv.h +malloc$(O) : vmsish.h +malloc$(O) : util.h +mg$(O) : EXTERN.h +mg$(O) : av.h +mg$(O) : config.h +mg$(O) : cop.h +mg$(O) : cv.h +mg$(O) : embed.h +mg$(O) : form.h +mg$(O) : gv.h +mg$(O) : handy.h +mg$(O) : hv.h +mg$(O) : mg.c +mg$(O) : mg.h +mg$(O) : op.h +mg$(O) : opcode.h +mg$(O) : perl.h +mg$(O) : pp.h +mg$(O) : proto.h +mg$(O) : regexp.h +mg$(O) : scope.h +mg$(O) : sv.h +mg$(O) : vmsish.h +mg$(O) : util.h +perly$(O) : EXTERN.h +perly$(O) : av.h +perly$(O) : config.h +perly$(O) : cop.h +perly$(O) : cv.h +perly$(O) : embed.h +perly$(O) : form.h +perly$(O) : gv.h +perly$(O) : handy.h +perly$(O) : hv.h +perly$(O) : mg.h +perly$(O) : op.h +perly$(O) : opcode.h +perly$(O) : perl.h +perly$(O) : perly.c +perly$(O) : pp.h +perly$(O) : proto.h +perly$(O) : regexp.h +perly$(O) : scope.h +perly$(O) : sv.h +perly$(O) : vmsish.h +perly$(O) : util.h +pp$(O) : EXTERN.h +pp$(O) : av.h +pp$(O) : config.h +pp$(O) : cop.h +pp$(O) : cv.h +pp$(O) : embed.h +pp$(O) : form.h +pp$(O) : gv.h +pp$(O) : handy.h +pp$(O) : hv.h +pp$(O) : mg.h +pp$(O) : op.h +pp$(O) : opcode.h +pp$(O) : perl.h +pp$(O) : pp.c +pp$(O) : pp.h +pp$(O) : proto.h +pp$(O) : regexp.h +pp$(O) : scope.h +pp$(O) : sv.h +pp$(O) : vmsish.h +pp$(O) : util.h +regcomp$(O) : EXTERN.h +regcomp$(O) : INTERN.h +regcomp$(O) : av.h +regcomp$(O) : config.h +regcomp$(O) : cop.h +regcomp$(O) : cv.h +regcomp$(O) : embed.h +regcomp$(O) : form.h +regcomp$(O) : gv.h +regcomp$(O) : handy.h +regcomp$(O) : hv.h +regcomp$(O) : mg.h +regcomp$(O) : op.h +regcomp$(O) : opcode.h +regcomp$(O) : perl.h +regcomp$(O) : pp.h +regcomp$(O) : proto.h +regcomp$(O) : regcomp.c +regcomp$(O) : regcomp.h +regcomp$(O) : regexp.h +regcomp$(O) : scope.h +regcomp$(O) : sv.h +regcomp$(O) : vmsish.h +regcomp$(O) : util.h +regexec$(O) : EXTERN.h +regexec$(O) : av.h +regexec$(O) : config.h +regexec$(O) : cop.h +regexec$(O) : cv.h +regexec$(O) : embed.h +regexec$(O) : form.h +regexec$(O) : gv.h +regexec$(O) : handy.h +regexec$(O) : hv.h +regexec$(O) : mg.h +regexec$(O) : op.h +regexec$(O) : opcode.h +regexec$(O) : perl.h +regexec$(O) : pp.h +regexec$(O) : proto.h +regexec$(O) : regcomp.h +regexec$(O) : regexec.c +regexec$(O) : regexp.h +regexec$(O) : scope.h +regexec$(O) : sv.h +regexec$(O) : vmsish.h +regexec$(O) : util.h +gv$(O) : EXTERN.h +gv$(O) : av.h +gv$(O) : config.h +gv$(O) : cop.h +gv$(O) : cv.h +gv$(O) : embed.h +gv$(O) : form.h +gv$(O) : gv.c +gv$(O) : gv.h +gv$(O) : handy.h +gv$(O) : hv.h +gv$(O) : mg.h +gv$(O) : op.h +gv$(O) : opcode.h +gv$(O) : perl.h +gv$(O) : pp.h +gv$(O) : proto.h +gv$(O) : regexp.h +gv$(O) : scope.h +gv$(O) : sv.h +gv$(O) : vmsish.h +gv$(O) : util.h +sv$(O) : EXTERN.h +sv$(O) : av.h +sv$(O) : config.h +sv$(O) : cop.h +sv$(O) : cv.h +sv$(O) : embed.h +sv$(O) : form.h +sv$(O) : gv.h +sv$(O) : handy.h +sv$(O) : hv.h +sv$(O) : mg.h +sv$(O) : op.h +sv$(O) : opcode.h +sv$(O) : perl.h +sv$(O) : perly.h +sv$(O) : pp.h +sv$(O) : proto.h +sv$(O) : regexp.h +sv$(O) : scope.h +sv$(O) : sv.c +sv$(O) : sv.h +sv$(O) : vmsish.h +sv$(O) : util.h +taint$(O) : EXTERN.h +taint$(O) : av.h +taint$(O) : config.h +taint$(O) : cop.h +taint$(O) : cv.h +taint$(O) : embed.h +taint$(O) : form.h +taint$(O) : gv.h +taint$(O) : handy.h +taint$(O) : hv.h +taint$(O) : mg.h +taint$(O) : op.h +taint$(O) : opcode.h +taint$(O) : perl.h +taint$(O) : pp.h +taint$(O) : proto.h +taint$(O) : regexp.h +taint$(O) : scope.h +taint$(O) : sv.h +taint$(O) : taint.c +taint$(O) : vmsish.h +taint$(O) : util.h +toke$(O) : EXTERN.h +toke$(O) : av.h +toke$(O) : config.h +toke$(O) : cop.h +toke$(O) : cv.h +toke$(O) : embed.h +toke$(O) : form.h +toke$(O) : gv.h +toke$(O) : handy.h +toke$(O) : hv.h +toke$(O) : keywords.h +toke$(O) : mg.h +toke$(O) : op.h +toke$(O) : opcode.h +toke$(O) : perl.h +toke$(O) : perly.h +toke$(O) : pp.h +toke$(O) : proto.h +toke$(O) : regexp.h +toke$(O) : scope.h +toke$(O) : sv.h +toke$(O) : toke.c +toke$(O) : vmsish.h +toke$(O) : util.h +util$(O) : EXTERN.h +util$(O) : av.h +util$(O) : config.h +util$(O) : cop.h +util$(O) : cv.h +util$(O) : embed.h +util$(O) : form.h +util$(O) : gv.h +util$(O) : handy.h +util$(O) : hv.h +util$(O) : mg.h +util$(O) : op.h +util$(O) : opcode.h +util$(O) : perl.h +util$(O) : pp.h +util$(O) : proto.h +util$(O) : regexp.h +util$(O) : scope.h +util$(O) : sv.h +util$(O) : vmsish.h +util$(O) : util.c +util$(O) : util.h +deb$(O) : EXTERN.h +deb$(O) : av.h +deb$(O) : config.h +deb$(O) : cop.h +deb$(O) : cv.h +deb$(O) : deb.c +deb$(O) : embed.h +deb$(O) : form.h +deb$(O) : gv.h +deb$(O) : handy.h +deb$(O) : hv.h +deb$(O) : mg.h +deb$(O) : op.h +deb$(O) : opcode.h +deb$(O) : perl.h +deb$(O) : pp.h +deb$(O) : proto.h +deb$(O) : regexp.h +deb$(O) : scope.h +deb$(O) : sv.h +deb$(O) : vmsish.h +deb$(O) : util.h +run$(O) : EXTERN.h +run$(O) : av.h +run$(O) : config.h +run$(O) : cop.h +run$(O) : cv.h +run$(O) : embed.h +run$(O) : form.h +run$(O) : gv.h +run$(O) : handy.h +run$(O) : hv.h +run$(O) : mg.h +run$(O) : op.h +run$(O) : opcode.h +run$(O) : perl.h +run$(O) : pp.h +run$(O) : proto.h +run$(O) : regexp.h +run$(O) : run.c +run$(O) : scope.h +run$(O) : sv.h +run$(O) : vmsish.h +run$(O) : util.h +vms$(O) : EXTERN.h +vms$(O) : av.h +vms$(O) : config.h +vms$(O) : cop.h +vms$(O) : cv.h +vms$(O) : embed.h +vms$(O) : form.h +vms$(O) : gv.h +vms$(O) : handy.h +vms$(O) : hv.h +vms$(O) : mg.h +vms$(O) : op.h +vms$(O) : opcode.h +vms$(O) : perl.h +vms$(O) : pp.h +vms$(O) : proto.h +vms$(O) : regexp.h +vms$(O) : vms.c +vms$(O) : scope.h +vms$(O) : sv.h +vms$(O) : vmsish.h +vms$(O) : util.h +miniperlmain$(O) : INTERN.h +miniperlmain$(O) : av.h +miniperlmain$(O) : config.h +miniperlmain$(O) : cop.h +miniperlmain$(O) : cv.h +miniperlmain$(O) : embed.h +miniperlmain$(O) : form.h +miniperlmain$(O) : gv.h +miniperlmain$(O) : handy.h +miniperlmain$(O) : hv.h +miniperlmain$(O) : mg.h +miniperlmain$(O) : miniperlmain.c +miniperlmain$(O) : op.h +miniperlmain$(O) : opcode.h +miniperlmain$(O) : perl.h +miniperlmain$(O) : pp.h +miniperlmain$(O) : proto.h +miniperlmain$(O) : regexp.h +miniperlmain$(O) : scope.h +miniperlmain$(O) : sv.h +miniperlmain$(O) : vmsish.h +miniperlmain$(O) : util.h +perlmain$(O) : INTERN.h +perlmain$(O) : av.h +perlmain$(O) : config.h +perlmain$(O) : cop.h +perlmain$(O) : cv.h +perlmain$(O) : embed.h +perlmain$(O) : form.h +perlmain$(O) : gv.h +perlmain$(O) : handy.h +perlmain$(O) : hv.h +perlmain$(O) : mg.h +perlmain$(O) : op.h +perlmain$(O) : opcode.h +perlmain$(O) : perl.h +perlmain$(O) : perlmain.c +perlmain$(O) : pp.h +perlmain$(O) : proto.h +perlmain$(O) : regexp.h +perlmain$(O) : scope.h +perlmain$(O) : sv.h +perlmain$(O) : vmsish.h +perlmain$(O) : util.h + +config.h : [.vms]config.vms + Copy/Log/NoConfirm [.vms]config.vms []config.h + +vmsish.h : [.vms]vmsish.h + Copy/Log/NoConfirm [.vms]vmsish.h []vmsish.h + +vms.c : [.vms]vms.c + Copy/Log/Noconfirm [.vms]vms.c [] + +$(CRTL) : $(MAKEFILE) + @ $$@[.vms]genopt "$(CRTL)/Write" "|" "$(LIBS1)|$(LIBS2)|$(SOCKLIB)" + + +cleanlis : + - If f$$Search("*.Lis").nes."" Then Delete/NoConfirm/Log *.Lis;* + - If f$$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;* + +tidy : cleanlis + - If f$$Search("*.Opt;-1").nes."" Then Purge/NoConfirm/Log *.Opt + - If f$$Search("*$(O);-1").nes."" Then Purge/NoConfirm/Log *$(O) + - If f$$Search("*$(E);-1").nes."" Then Purge/NoConfirm/Log *$(E) + - If f$$Search("Config.H;-1").nes."" Then Purge/NoConfirm/Log Config.H + - If f$$Search("Config.SH;-1").nes."" Then Purge/NoConfirm/Log Config.SH + - If f$$Search("VMSish.H;-1").nes."" Then Purge/NoConfirm/Log VMSish.H + - If f$$Search("VMS.C;-1") .nes."" Then Purge/NoConfirm/Log VMS.C + - If f$$Search("Perlmain.C;-1") .nes."" Then Purge/NoConfirm/Log Perlmain.C + - If f$$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar + - If f$$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O) + - If f$$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C + - If f$$Search("[.Lib.Auto...]*.al;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]*.al + - If f$$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ts + +clean : tidy + - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_Attr.Opt + - If f$$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);* + - If f$$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;* + - If f$$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;* + - If f$$Search(f$$Parse("sys$$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);* + - If f$$Search(f$$Parse("sys$$Disk:[]","$(SOCKC)")).nes."" Then Delete/NoConfirm/Log $(SOCKC);* + - If f$$Search("VMSish.H").nes."" Then Delete/NoConfirm/Log VMSish.H;* + - If f$$Search("VMS.C") .nes."" Then Delete/NoConfirm/Log VMS.C;* + - If f$$Search("Perlmain.C") .nes."" Then Delete/NoConfirm/Log Perlmain.C;* + - If f$$Search("Perlshr_Gbl*.Mar") .nes."" Then Delete/NoConfirm/Log Perlshr_Gbl*.Mar;* + - If f$$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;* + - If f$$Search("[.Ext.DynaLoader]DL_VMS$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O);* + - If f$$Search("[.Ext.DynaLoader]DL_VMS.C").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C;* + +realclean : clean + - If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* + - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;* + - If f$$Search("[.Lib.Auto...]*.al;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;* + - If f$$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;* + +cleansrc : clean + - If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* + - If f$$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C + - If f$$Search("*.H;-1").nes."" Then Purge/NoConfirm/Log *.H + - If f$$Search("*.VMS;-1").nes."" Then Purge/NoConfirm/Log *.VMS + - If f$$Search("$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log $(MAKEFILE) + - If f$$Search("[.VMS]$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log [.VMS]$(MAKEFILE) + - If f$$Search("[.VMS]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.C + - If f$$Search("[.VMS]*.H;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.H + - If f$$Search("[.VMS]*.Pl;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.Pl + - If f$$Search("[.VMS]*.VMS;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.VMS + - If f$$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;* + - If f$$Search("[.Lib.Auto...]autosplit.ts;").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;* + - If f$$Search("[.Lib]Config.pm;").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;* diff --git a/vms/mms2make.pl b/vms/mms2make.pl new file mode 100644 index 0000000000..54db616c86 --- /dev/null +++ b/vms/mms2make.pl @@ -0,0 +1,102 @@ +#!/usr/bin/perl +# +# mms2make.pl - convert Descrip.MMS file to Makefile +# Version 2.0 29-Sep-1994 +# David Denholm <denholm@conmat.phys.soton.ac.uk> +# +# 1.0 06-Aug-1994 Charles Bailey bailey@genetics.upenn.edu +# - original version +# 2.0 29-Sep-1994 David Denholm <denholm@conmat.phys.soton.ac.uk> +# - take action based on MMS .if / .else / .endif +# any command line options after filenames are set in an assoc array %macros +# maintain "@condition as a stack of current conditions +# we unshift a 0 or 1 to front of @conditions at an .ifdef +# we invert top of stack at a .else +# we pop at a .endif +# we deselect any other line if $conditions[0] is 0 +# I'm being very lazy - push a 1 at start, then dont need to check for +# an empty @conditions [assume nesting in descrip.mms is correct] + +if ($#ARGV > -1 && $ARGV[0] =~ /^[\-\/]trim/i) { + $do_trim = 1; + shift @ARGV; +} +$infile = $#ARGV > -1 ? shift(@ARGV) : "Descrip.MMS"; +$outfile = $#ARGV > -1 ? shift(@ARGV) : "Makefile."; + +# set any other args in %macros - set VAXC by default +foreach (@ARGV) { $macros{"\U$_"}=1 } + +# consistency check +$macros{"DECC"} = 1 if $macros{"__AXP__"}; + +# set conditions as if there was a .if 1 around whole file +# [lazy - saves having to check for empty array - just test [0]==1] +@conditions = (1); + +open(INFIL,$infile) || die "Can't open $infile: $!\n"; +open(OUTFIL,">$outfile") || die "Can't open $outfile: $!\n"; + +print OUTFIL "#> This file produced from $infile by $0\n"; +print OUTFIL "#> Lines beginning with \"#>\" were commented out during the\n"; +print OUTFIL "#> conversion process. For more information, see $0\n"; +print OUTFIL "#>\n"; + +while (<INFIL>) { + s/$infile/$outfile/eoi; + if (/^\#/) { + if (!/^\#\:/) {print OUTFIL;} + next; + } + +# look for ".ifdef macro" and push 1 or 0 to head of @conditions +# push 0 if we are in false branch of another if + if (/^\.ifdef\s*(.+)/i) + { + print OUTFIL "#> ",$_ unless $do_trim; + unshift @conditions, ($macros{"\U$1"} ? $conditions[0] : 0); + next; + } + +# reverse $conditions[0] for .else provided surrounding if is active + if (/^\.else/i) + { + print OUTFIL "#> ",$_ unless $do_trim; + $conditions[0] = $conditions[1] && !$conditions[0]; + next; + } + +# pop top condition for .endif + if (/^\.endif/i) + { + print OUTFIL "#> ",$_ unless $do_trim; + shift @conditions; + next; + } + + next if ($do_trim && !$conditions[0]); + +# spot new rule and pick up first source file, since some versions of +# Make don't provide a macro for this + if (/[^#!]*:\s+/) { + if (/:\s+([^\s,]+)/) { $firstsrc = $1 } + else { $firstsrc = "\$<" } + } + + s/^ +/\t/; + s/^\.first/\.first:/i; + s/^\.suffixes/\.suffixes:/i; + s/\@\[\.vms\]/\$\$\@\[\.vms\]/; + s/f\$/f\$\$/goi; + s/\$\(mms\$source\)/$firstsrc/i; + s/\$\(mms\$target\)/\$\@/i; + s/\$\(mms\$target_name\)\$\(O\)/\$\@/i; + s/\$\(mms\$target_name\)/\$\*/i; + s/sys\$([^\(])/sys\$\$$1/gi; + print OUTFIL "#> " unless $conditions[0]; + print OUTFIL $_; +} + +close INFIL; +close OUTFIL; + diff --git a/vms/perlshr.c b/vms/perlshr.c new file mode 100644 index 0000000000..92e6d44cf5 --- /dev/null +++ b/vms/perlshr.c @@ -0,0 +1,13 @@ +/* perlshr.c + * + * Small stub to create object module containing global variables + * for use in PerlShr.C. Written as a separate file because some + * old Make implementations won't deal correctly with DCL Open/Write + * statements in the makefile. + * + */ + +#include "INTERN.h" +#include "perl.h" + +/* That's it. */ diff --git a/vms/perlvms.pod b/vms/perlvms.pod new file mode 100644 index 0000000000..77ec503f61 --- /dev/null +++ b/vms/perlvms.pod @@ -0,0 +1,264 @@ +=head1 Notes on Perl5 for VMS + +Gathered below are notes describing details of perl 5's +behavior on VMS. They are a supplement to the regular perl 5 +documentation, so we have focussed on the ways in which perl +5 functions differently under VMS thatn it does under Unix, +and on teh interactions between perl and the rest of the +operating system. We haven't tried to duplicate complete +descriptions of perl5 features from the main perl +documentation, which can be found in the F<[.pod]> +subdirectory of the perl 5 distribution. + +We hope these notes will save you from confusion and lost +sleep when writing perl scripts on VMS. If you find we've +missed something you think should appear here, please don't +hesitate to drop a line to vmsperl@genetics.upenn.edu. + +=head2 Installation + +Directions for building and installing perl 5 can be found in +the file F<ReadMe.VMS> in the main source directory of the +perl5 distribution.. + +=head2 File specifications + +We have tried to make perl aware of both VMS-style and Unix- +style file specifications wherever possible. You may use +either style, or both, on the command line and in scripts, +but you may not combine the two styles within a single fle +specfication. Filenames are, of course, still case- +insensitive. For consistency, most perl5 routines return +filespecs using lower case latters only, regardless of the +case used in the arguments passed to them. (This is true +only when running under VMS; perl5 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, +as well as some scripts written for Unix systems, will +require that you use Unix syntax, since they will assume that +'/' is the directory separator, etc. If you find instances +of this in the perl distribution itself, please let us know, +so we can try to work around them. + +=head2 Command line redirection + +Perl for VMS supports redirection of input and output on the +command line, using a subset of Bourne shell syntax: + <F<file> reads stdin from F<file>, + >F<file> writes stdout to F<file>, + >>F<file> appends stdout to F<file>, + 2>F<file> wrtits stderr to F<file>, and + 2>>F<file> appends stderr to F<file>. + +In addition, output may be piped to a subprocess, using the +character '|'. Anything after this character on the command +line is passed to a subprocess for execution; the subprocess +takes the output of perl as its input. + +Finally, if the command line ends with '&', the entire +command is run in the background as an asynchronous +subprocess. + +=head2 Pipes + +Input and output pipes to perl filehandles are supported; the +"file name" is passed to lib$spawn() for asynchronous +execution. You should be careful to close any pipes you have +opened in a perl script, lest you leave any "orphaned" +subprocesses around when perl exits. + +You may also use backticks to invoke a DCL subprocess, whose +output is used as the return value of the expression. The +string between the backticks is passed directly to lib$spawn +as the command to execute. In this case, perl will wait for +the subprocess to complete before continuing. + +=head2 Wildcard expansion + +File specifications containing wildcards are allowed both on +the command line and within perl globs (e.g. <C<*.c>>). If +the wildcard filespec uses VMS syntax, the resultant +filespecs will follow VMS syntax; if a Unix-style filespec is +passed in, Unix-style filespecs will be returned.. + +If the wildcard filespec contains a device or directory +specification, then the resultant filespecs will also contain +a device and directory; otherwise, device and directory +information are removed. VMS-style resultant filespecs will +contain a full device and directory, while Unix-style +resultant filespecs will contain only as much of a directory +path as was present in the input filespec. For example, if +your default directory is Perl_Root:[000000], the expansion +of C<[.t]*.*> will yield filespecs like +"perl_root:[t]base.dir", while the expansion of C<t/*/*> will +yield filespecs like "t/base.dir". (This is done to match +the behavior of glob expansion performed by Unix shells.) + +Similarly, the resultant filespec will the file version only +if one was present in the input filespec. + +=head2 %ENV + +Reading the elements of the %ENV array returns the +translation of the logical name specified by the key, +according to the normal search order of access modes and +logical name tables. In addition, the keys C<home>, +C<path>,C<term>, and C<user> return the CRTL "environment +variables" of the same names. The key C<default> returns the +current default device and directory specification. + +Setting an element of %ENV defines a supervisor-mode logical +name in the process logical name table. B<Undef>ing or +B<delete>ing an element of %ENV deletes the equivalent user- +mode or supervisor-mode logical name from the process logical +name table. If you use B<undef>, the %ENV element remains +empty. If you use B<delete>, another attempt is made at +logical name translation after the deletion, so an inner-mode +logical name or a name in another logical name table will +replace the logical name just deleted. + +In all operations on %ENV, the key string is treated as if it +were entirely uppercase, regardless of the case actually +specified in the perl expression. + +=head2 Perl functions + +As of the time this document was last revised, the following +perl functions were implemented in the VMS port of perl +(functions marked with * are discussed in more detail below): + + file tests*, abs, alarm, atan, binmode*, bless, + caller, chdir, chmod, chown, chomp, chop, chr, + close, closedir, cos, defined, delete, die, do, + each, eof, eval, exec*, exists, exit, exp, fileno, + fork*, getc, glob, goto, grep, hex, import, index, + int, join, keys, kill, last, lc, lcfirst, length, + local, localtime, log, m//, map, mkdir, my, next, + no, oct, open, opendir, ord, pack, pipe, pop, pos, + print, printf, push, q//, qq//, qw//, qx//, + quotemeta, rand, read, readdir, redo, ref, rename, + require, reset, return, reverse, rewinddir, rindex, + rmdir, s///, scalar, seek, seekdir, select(internal)*, + shift, sin, sleep, sort, splice, split, sprintf, + sqrt, srand, stat, study, substr, sysread, system*, + syswrite, tell, telldir, tie, time, times*, tr///, + uc, ucfirst, umask, undef, unlink, unpack, untie, + unshift, use, values, vec, wait, wantarray, warn, + write, y/// + +The following functions were not implemented in the VMS port, +and calling them produces a fatal error (usually) or +undefined behavior (rarely, we hope): + + chroot, crypt, dbmclose, dbmopen, dump, fcntl, + flock, getlogin, getpgrp, getppid, getpriority, + getpwent, getgrent, kill, getgrgid, getgrnam, + getpwnam, getpwuid, setpwent, setgrent, + endpwent, endgrent, gmtime, ioctl, link, lstst, + msgctl, msgget, msgsend, msgrcv, readlink, + select(system call), semctl, semget, semop, + setpgrp, setpriority, shmctl, shmget, shmread, + shmwrite, socketpair, symlink, syscall, truncate, + utime, waitpid + +The following functions may or may not be implemented, +depending on what type of socket support you've built into +your copy of perl: + accept, bind, connect, getpeername, + gethostbyname, getnetbyname, getprotobyname, + getservbyname, gethostbyaddr, getnetbyaddr, + getprotobynumber, getservbyport, gethostent, + getnetent, getprotoent, getservent, sethostent, + setnetent, setprotoent, setservent, endhostent, + endnetent, endprotoent, endservent, getsockname, + getsockopt, listen, recv, send, setsockopt, + shutdown, socket + + +=item File tests + +The tests -b, -B, -c, -C, -d, -e, -f, -o, -M, -s, -S, -t, -T, +and -z work as advertised. The return values for -r, -w, and +-x tell you whether you can actually access the file; this +may mot reflect the UIC-based file protections. Since real +and effective UIC don't differ under VMS, -O, -R, -W, and -X +are equivalent to -o, -r, -w, and -x. Similarly, several +other tests, including -A, -g, -k, -l,-p, and -u, aren't +particularly meaningful under VMS, and the values returned by +these tests reflect whatever your CRTL stat() routine does to +the equivalent bits in the st_mode field. + +=item binmode + +The B<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 exec + +The B<exec> operator behaves in one of two different ways. +If called after a call to B<fork>, it will invoke the CRTL +L<execv()> routine, passing its arguments to the subprocess +created by B<fork> for execution. In this case, it is +subject to all limitation that affect L<execv>. (In +particular, this usually means that the command executed in +the subprocess must be an image compiled from C source code, +and that your options for passing file descriptors and signal +handlers to the subprocess are limited.) + +If the call to B<exec> does not follow a call to B<fork>, it +will cause perl to exit, and to invoke the command given as +an argument to B<exec> via lib$do_command. If the argument +begins with a '$' (other than as part of a filespec), then it +is executed as a DCL command. Otherwise, the first token on +the command line is treated as the filespec of an image to +run, and an attempt is made to invoke it (using F<.Exe> and +the process defaults to expand the filespec) and pass the +rest of B<exec>'s argument to it as parameters. + +You can use B<exec> in both ways within the same script, as +long as you call B<fork> and B<exec> in pairs. Perl only +keeps track of whether B<fork> has been called since the last +call to B<exec> when figuring out what to do, so multiple +calls to B<fork> do not generate multiple levels of "fork +context". + +=item fork + +The B<fork> operator works in the same way as the CRTL +L<fork()> routine, which is quite different under VMS than +under Unix. Sepcifically, while B<fork> returns 0 after it +is called and the subprocess PID after B<exec> is called, in +both cases the thread of execution is within the parent +process, so there is no opportunity to perform operations in +the subprocess before calling B<exec>. + +In general, the use of B<fork> and B<exec> to create +subprocess is not recommended under VMS; wherever possible, +use the B<system> operator or piped filehandles instead. + +=item system + +The B<system> operator creates a subprocess, and passes its +arguments to the subprocess for execution as a DCL command. +Since the subprocess is created directly via lib$spawn, any +valid DCL command string may be specified. Perl waits for +the subprocess to complete before continuing execution in the +current process. + +=item times + +The array returned by the B<times> operator is divided up +according to the same rules the CRTL L<times()> routine. +Therefore, the "system time" elements will always be 0, since +there is no difference between "user time" and "system" time +under VMS, and the time accumulated by subprocess may or may +not appear separately in the "child time" field, depending on +whether L<times> keeps track of subprocesses separately. + +=head2 Revision date + +This document was last updated on 16-Oct-1994, for perl 5, +patchlevel 0. diff --git a/vms/sockadapt.c b/vms/sockadapt.c new file mode 100644 index 0000000000..fc42bcc5a4 --- /dev/null +++ b/vms/sockadapt.c @@ -0,0 +1,43 @@ +/* sockadapt.c + * + * Author: Charles Bailey bailey@genetics.upenn.edu + * Last Revised: 05-Oct-1994 + * + * This file should contain stubs for any of the TCP/IP functions perl5 + * requires which are not supported by your TCP/IP stack. These stubs + * can attempt to emulate the routine in question, or can just return + * an error status or cause perl to die. + * + * This version is set up for perl5 with socketshr 0.9A TCP/IP support. + */ + +#include "sockadapt.h" + +#ifdef __STDC__ +#define STRINGIFY(a) #a /* config-skip */ +#else +#define STRINGIFY(a) "a" /* config-skip */ +#endif + +#define FATALSTUB(func) \ + void func() {\ + croak("Function %s not implemented in this version of perl",\ + STRINGIFY(func));\ + } + +FATALSTUB(endhostent); +FATALSTUB(endnetent); +FATALSTUB(endprotoent); +FATALSTUB(endservent); +FATALSTUB(gethostent); +FATALSTUB(getnetbyaddr); +FATALSTUB(getnetbyname); +FATALSTUB(getnetent); +FATALSTUB(getprotobyname); +FATALSTUB(getprotobynumber); +FATALSTUB(getprotoent); +FATALSTUB(getservent); +FATALSTUB(sethostent); +FATALSTUB(setnetent); +FATALSTUB(setprotoent); +FATALSTUB(setservent); diff --git a/vms/sockadapt.h b/vms/sockadapt.h new file mode 100644 index 0000000000..60890bddce --- /dev/null +++ b/vms/sockadapt.h @@ -0,0 +1,54 @@ +/* sockadapt.h + * + * Authors: Charles Bailey bailey@genetics.upenn.edu + * David Denholm denholm@conmat.phys.soton.ac.uk + * Last Revised: 05-Oct-1994 + * + * This file should include any other header files and procide any + * declarations, typedefs, and prototypes needed by perl for TCP/IP + * operations. + * + * This version is set up for perl5 with socketshr 0.9A TCP/IP support. + */ + +#include <socketshr.h> + +/* we may not have socket.h etc, so lets just do these here - div */ +/* built up from a variety of sources */ +/* no harm doing this for all .c files - needed only by pp_sys.c */ + +struct hostent { + char *h_name; + char *h_aliases; + int h_addrtype; + int h_length; + char **h_addr_list; +}; +#define h_addr h_addr_list[0] + +struct sockaddr_in { + short sin_family; + unsigned short sin_port; + unsigned long sin_addr; + char sin_zero[8]; +}; + +struct netent { + char *n_name; + char **n_aliases; + int n_addrtype; + long n_net; +}; + +struct servent { + char *s_name; /* official service name */ + char **s_aliases; /* alias list */ + int s_port; /* port # */ + char *s_proto; /* protocol to use */ +}; + +struct protoent { + char *p_name; /* official protocol name */ + char **p_aliases; /* alias list */ + int p_proto; /* protocol # */ +}; diff --git a/vms/test.com b/vms/test.com new file mode 100644 index 0000000000..3e42a11474 --- /dev/null +++ b/vms/test.com @@ -0,0 +1,184 @@ +$! Test.Com - DCL driver for perl5 regression tests +$! +$! Version 1.0 30-Sep-1994 +$! Charles Bailey bailey@genetics.upenn.edu +$ +$! A little basic setup +$ On Error Then Goto wrapup +$ olddef = F$Environment("Default") +$ Set Default Perl_Root:[t] +$ +$! 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" +$ Macro/NoDebug/Object=Echo.Obj Sys$Input + .title echo + .psect data,wrt,noexe + dsc: + .word 0 + .byte 14 ; DSC$K_DTYPE_T + .byte 2 ; DSC$K_CLASS_D + .long 0 + .psect code,nowrt,exe + .entry echo,^m<r2,r3> + movab dsc,r2 + pushab (r2) + calls #1,G^LIB$GET_FOREIGN + movl 4(r2),r3 + movzwl (r2),r0 + addl2 4(r2),r0 + cmpl r3,r0 + bgtru sym.3 + nop + sym.1: + movb (r3),r0 + cmpb r0,#65 + blss sym.2 + cmpb r0,#90 + bgtr sym.2 + cvtbl r0,r0 + addl2 #32,r0 + cvtlb r0,(r3) + sym.2: + incl r3 + movzwl (r2),r0 + addl2 4(r2),r0 + cmpl r3,r0 + blequ sym.1 + sym.3: + pushab (r2) + calls #1,G^LIB$PUT_OUTPUT + movl #1,r0 + ret + .end echo +$ Link/NoTrace Echo.Obj; +$ Delete/Log/NoConfirm Echo.Obj;* +$ echo = "$Perl_Root:[T]Echo.Exe" +$ +$! And do it +$ MCR Sys$Disk:[]Perl. +$ 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 +# +# This is written in a peculiar style, since we're trying to avoid +# 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}++; } + +$| = 1; + +#if ($ARGV[0] eq '-v') { + $verbose = 1; +# shift; +#} + +chdir 't' if -f 't/TEST'; + +if ($ARGV[0] eq '') { + @files = split(/[ \n]/, `\$ dir/col=1/nohead/notrail [...]*.t;`); + foreach (@files) { + $fname = $_; + $fname =~ s/.*\]([\w\$\-]+\.T);.*/$1/; + if ($skip{"\L$fname"}) { push(@skipped,$_); } + else { push(@ARGV,$_); } + } +} + +if (@skipped) { + print "The following tests were skipped because they rely extensively on\n"; + print " Unixisms not compatible with the current version of perl for VMS:\n"; + print "\t",join("\n\t",@skipped); +} + +$bad = 0; +$good = 0; +$total = @ARGV; +while ($test = shift) { + if ($test =~ /^$/) { + next; + } + $te = $test; + chop($te); + print "$te" . '.' x (15 - length($te)) . "\n"; + open(script,"$test") || die "Can't run $test.\n"; + $_ = <script>; + close(script); + if (/#!..perl(.*)/) { + $switch = $1; + } else { + $switch = ''; + } + open(results,"\$ MCR Sys\$Disk:[]Perl. $switch $test |") || (print "can't run.\n"); + $ok = 0; + $next = 0; + while (<results>) { + if ($verbose) { + print $_; + } + unless (/^#/) { + if (/^1\.\.([0-9]+)/) { + $max = $1; + $totmax += $max; + $files += 1; + $next = 1; + $ok = 1; + } else { + $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; + next if /^\s*$/; # our 'echo' substitute produces one more \n than Unix' + if (/^ok (.*)/ && $1 == $next) { + $next = $next + 1; + } else { + $ok = 0; + } + } + } + } + $next = $next - 1; + if ($ok && $next == $max) { + print "ok\n"; + $good = $good + 1; + } else { + $next += 1; + print "FAILED on test $next\n"; + $bad = $bad + 1; + $_ = $test; + if (/^base/) { + die "Failed a basic test--cannot continue.\n"; + } + } +} + +if ($bad == 0) { + if ($ok) { + print "All tests successful.\n"; + } else { + die "FAILED--no tests were run for some reason.\n"; + } +} else { + $pct = sprintf("%.2f", $good / $total * 100); + if ($bad == 1) { + warn "Failed 1 test, $pct% okay.\n"; + } else { + warn "Failed $bad/$total tests, $pct% okay.\n"; + } +} +($user,$sys,$cuser,$csys) = times; +print sprintf("u=%g s=%g cu=%g cs=%g files=%d tests=%d\n", + $user,$sys,$cuser,$csys,$files,$totmax); +$$END-OF-TEST$$ +$ wrapup: +$ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;* +$ Set Default &olddef +$ Exit diff --git a/vms/vms.c b/vms/vms.c new file mode 100644 index 0000000000..26aeecb4a5 --- /dev/null +++ b/vms/vms.c @@ -0,0 +1,2095 @@ +/* VMS-specific routines for perl5 + * + * Last revised: 09-Oct-1994 + */ + +#include <acedef.h> +#include <acldef.h> +#include <armdef.h> +#include <chpdef.h> +#include <descrip.h> +#include <dvidef.h> +#include <float.h> +#include <fscndef.h> +#include <iodef.h> +#include <jpidef.h> +#include <libdef.h> +#include <lib$routines.h> +#include <lnmdef.h> +#include <psldef.h> +#include <rms.h> +#include <shrdef.h> +#include <ssdef.h> +#include <starlet.h> +#include <stsdef.h> +#include <syidef.h> + + +#include "EXTERN.h" +#include "perl.h" + +struct itmlst_3 { + unsigned short int buflen; + unsigned short int itmcode; + void *bufadr; + unsigned long int retlen; +}; + +static unsigned long int sts; + +#define _cksts(call) \ + if (!(sts=(call))&1) { \ + errno = EVMSERR; vaxc$errno = sts; \ + croak("fatal error at %s, line %d",__FILE__,__LINE__); \ + } else { 1; } + +/* my_getenv + * Translate a logical name. Substitute for CRTL getenv() to avoid + * memory leak, and to keep my_getenv() and my_setenv() in the same + * domain (mostly - my_getenv() need not return a translation from + * the process logical name table) + * + * Note: Uses static buffer -- not thread-safe! + */ +/*{{{ char *my_getenv(char *lnm)*/ +char * +my_getenv(char *lnm) +{ + static char __my_getenv_eqv[LNM$C_NAMLENGTH+1]; + char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; + unsigned short int eqvlen; + unsigned long int retsts, attr = LNM$M_CASE_BLIND; + $DESCRIPTOR(sysdiskdsc,"SYS$DISK"); + $DESCRIPTOR(tabdsc,"LNM$FILE_DEV"); + struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm}, + eqvdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T, + DSC$K_CLASS_S, __my_getenv_eqv}; + struct itmlst_3 lnmlst[2] = {sizeof __my_getenv_eqv - 1, LNM$_STRING, + __my_getenv_eqv, &eqvlen, 0, 0, 0, 0}; + + for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1); + *cp2 = '\0'; + lnmdsc.dsc$w_length = cp1 - lnm; + if (lnmdsc.dsc$w_length = 7 && !strncmp(uplnm,"DEFAULT",7)) { + _cksts(sys$trnlnm(&attr,&tabdsc,&sysdiskdsc,0,lnmlst)); + eqvdsc.dsc$a_pointer += eqvlen; + eqvdsc.dsc$w_length = sizeof __my_getenv_eqv - eqvlen - 1; + _cksts(sys$setddir(0,&eqvlen,&eqvdsc)); + eqvdsc.dsc$a_pointer[eqvlen] = '\0'; + return __my_getenv_eqv; + } + else { + retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst); + if (retsts != SS$_NOLOGNAM) { + if (retsts & 1) { + __my_getenv_eqv[eqvlen] = '\0'; + return __my_getenv_eqv; + } + _cksts(retsts); + } + else { + retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&(eqvdsc.dsc$w_length),0); + if (retsts != LIB$_NOSUCHSYM) { + /* We want to return only logical names or CRTL Unix emulations */ + if (retsts & 1) return Nullch; + _cksts(retsts); + } + else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */ + } + } + return NULL; + +} /* end of my_getenv() */ +/*}}}*/ + +/*{{{ void my_setenv(char *lnm, char *eqv)*/ +void +my_setenv(char *lnm,char *eqv) +/* Define a supervisor-mode logical name in the process table. + * In the future we'll add tables, attribs, and acmodes, + * probably through a different call. + */ +{ + char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; + unsigned long int retsts, usermode = PSL$C_USER; + $DESCRIPTOR(tabdsc,"LNM$PROCESS"); + struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm}, + eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; + + for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1); + lnmdsc.dsc$w_length = cp1 - lnm; + + if (!eqv || !*eqv) { /* we're deleting a logical name */ + retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */ + if (retsts != SS$_NOLOGNAM) _cksts(retsts); + if (!(retsts & 1)) { + retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */ + if (retsts != SS$_NOLOGNAM) _cksts(retsts); + } + } + else { + eqvdsc.dsc$w_length = strlen(eqv); + eqvdsc.dsc$a_pointer = eqv; + + _cksts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0)); + } + +} /* end of my_setenv() */ +/*}}}*/ + +static char *do_fileify_dirspec(char *, char *, int); +static char *do_tovmsspec(char *, char *, int); + +/*{{{int do_rmdir(char *name)*/ +int +do_rmdir(char *name) +{ + char dirfile[NAM$C_MAXRSS+1]; + int retval; + stat_t st; + + if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1; + if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1; + else retval = kill_file(dirfile); + return retval; + +} /* end of do_rmdir */ +/*}}}*/ + +/* kill_file + * Delete any file to which user has control access, regardless of whether + * delete access is explicitly allowed. + * Limitations: User must have write access to parent directory. + * Does not block signals or ASTs; if interrupted in midstream + * may leave file with an altered ACL. + * HANDLE WITH CARE! + */ +/*{{{int kill_file(char *name)*/ +int +kill_file(char *name) +{ + char vmsname[NAM$C_MAXRSS+1]; + unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE; + unsigned long int uics[2] = {0,0}, cxt = 0, aclsts, fndsts, rmsts = -1; + struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + struct myacedef { + unsigned char ace$b_length; + unsigned char ace$b_type; + unsigned short int ace$w_flags; + unsigned long int ace$l_access; + unsigned long int ace$l_ident; + } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0, + ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0}, + oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0}; + struct itmlst_3 + findlst[3] = {sizeof oldace, ACL$C_FNDACLENT, &oldace, 0, + sizeof oldace, ACL$C_READACE, &oldace, 0, 0, 0, 0, 0}, + addlst[2] = {sizeof newace, ACL$C_ADDACLENT, &newace, 0, 0, 0, 0, 0}, + dellst[2] = {sizeof newace, ACL$C_DELACLENT, &newace, 0, 0, 0, 0, 0}, + lcklst[2] = {sizeof newace, ACL$C_WLOCK_ACL, &newace, 0, 0, 0, 0, 0}, + ulklst[2] = {sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0, 0, 0, 0, 0}; + + if (!remove(name)) return 0; /* Can we just get rid of it? */ + + /* No, so we get our own UIC to use as a rights identifier, + * and the insert an ACE at the head of the ACL which allows us + * to delete the file. + */ + _cksts(lib$getjpi(&jpicode,0,0,&(oldace.ace$l_ident),0,0)); + if (do_tovmsspec(name,vmsname,0) == NULL) return -1; + fildsc.dsc$w_length = strlen(vmsname); + fildsc.dsc$a_pointer = vmsname; + cxt = 0; + newace.ace$l_ident = oldace.ace$l_ident; + if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { + errno = EVMSERR; + vaxc$errno = aclsts; + return -1; + } + /* Grab any existing ACEs with this identifier in case we fail */ + aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt); + if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY) { + /* Add the new ACE . . . */ + if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1)) + goto yourroom; + if (rmsts = remove(name)) { + /* We blew it - dir with files in it, no write priv for + * parent directory, etc. Put things back the way they were. */ + if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1)) + goto yourroom; + if (fndsts & 1) { + addlst[0].bufadr = &oldace; + if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1)) + goto yourroom; + } + } + } + + yourroom: + if (rmsts) { + fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0); + if (aclsts & 1) aclsts = fndsts; + } + if (!(aclsts & 1)) { + errno = EVMSERR; + vaxc$errno = aclsts; + return -1; + } + + return rmsts; + +} /* end of kill_file() */ +/*}}}*/ + +static void +create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) +{ + static unsigned long int mbxbufsiz; + long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM; + + if (!mbxbufsiz) { + /* + * Get the SYSGEN parameter MAXBUF, and the smaller of it and the + * preprocessor consant BUFSIZ from stdio.h as the size of the + * 'pipe' mailbox. + */ + _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0)); + if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ; + } + _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); + + _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length)); + namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0'; + +} /* end of create_mbx() */ + +/*{{{ my_popen and my_pclose*/ +struct pipe_details +{ + struct pipe_details *next; + FILE *fp; + int pid; + unsigned long int completion; +}; + +static struct pipe_details *open_pipes = NULL; +static $DESCRIPTOR(nl_desc, "NL:"); +static int waitpid_asleep = 0; + +static void +popen_completion_ast(unsigned long int unused) +{ + if (waitpid_asleep) { + waitpid_asleep = 0; + sys$wake(0,0); + } +} + +/*{{{ FILE *my_popen(char *cmd, char *mode)*/ +FILE * +my_popen(char *cmd, char *mode) +{ + char mbxname[64]; + unsigned short int chan; + unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */ + struct pipe_details *info; + struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T, + DSC$K_CLASS_S, mbxname}, + cmddsc = {0, DSC$K_DTYPE_T, + DSC$K_CLASS_S, 0}; + + + New(7001,info,1,struct pipe_details); + + info->completion=0; /* I assume this will remain 0 until terminates */ + + /* create mailbox */ + create_mbx(&chan,&namdsc); + + /* open a FILE* onto it */ + info->fp=fopen(mbxname, mode); + + /* give up other channel onto it */ + _cksts(sys$dassgn(chan)); + + if (!info->fp) + return Nullfp; + + cmddsc.dsc$w_length=strlen(cmd); + cmddsc.dsc$a_pointer=cmd; + + if (strcmp(mode,"r")==0) { + _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags, + 0 /* name */, &info->pid, &info->completion, + 0, popen_completion_ast,0,0,0,0)); + } + else { + _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, + 0 /* name */, &info->pid, &info->completion)); + } + + info->next=open_pipes; /* prepend to list */ + open_pipes=info; + + return info->fp; +} +/*}}}*/ + +/*{{{ I32 my_pclose(FILE *fp)*/ +I32 my_pclose(FILE *fp) +{ + struct pipe_details *info, *last = NULL; + unsigned long int abort = SS$_TIMEOUT, retsts; + + for (info = open_pipes; info != NULL; last = info, info = info->next) + if (info->fp == fp) break; + + if (info == NULL) + /* get here => no such pipe open */ + croak("my_pclose() - no such pipe open ???"); + + if (!info->completion) { /* Tap them gently on the shoulder . . .*/ + _cksts(sys$forcex(&info->pid,0,&abort)); + sleep(1); + } + if (!info->completion) /* We tried to be nice . . . */ + _cksts(sys$delprc(&info->pid)); + + fclose(info->fp); + /* remove from list of open pipes */ + if (last) last->next = info->next; + else open_pipes = info->next; + retsts = info->completion; + Safefree(info); + + return retsts; +} /* end of my_pclose() */ + +#ifndef HAS_WAITPID +/* sort-of waitpid; use only with popen() */ +/*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/ +unsigned long int +waitpid(unsigned long int pid, int *statusp, int flags) +{ + struct pipe_details *info; + unsigned long int abort = SS$_TIMEOUT; + + for (info = open_pipes; info != NULL; info = info->next) + if (info->pid == pid) break; + + if (info != NULL) { /* we know about this child */ + while (!info->completion) { + waitpid_asleep = 1; + sys$hiber(); + } + + *statusp = info->completion; + return pid; + } + else { /* we haven't heard of this child */ + $DESCRIPTOR(intdsc,"0 00:00:01"); + unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid; + unsigned long int interval[2]; + + _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)); + _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0)); + if (ownerpid != mypid) + croak("pid %d not a child",pid); + + _cksts(sys$bintim(&intdsc,interval)); + while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) { + _cksts(sys$schdwk(0,0,interval,0)); + _cksts(sys$hiber()); + } + _cksts(sts); + + /* There's no easy way to find the termination status a child we're + * not aware of beforehand. If we're really interested in the future, + * we can go looking for a termination mailbox, or chase after the + * accounting record for the process. + */ + *statusp = 0; + return pid; + } + +} /* end of waitpid() */ +#endif +/*}}}*/ +/*}}}*/ +/*}}}*/ + +/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */ +char * +my_gconvert(double val, int ndig, int trail, char *buf) +{ + static char __gcvtbuf[DBL_DIG+1]; + char *loc; + + loc = buf ? buf : __gcvtbuf; + if (val) { + if (!buf && ndig > DBL_DIG) ndig = DBL_DIG; + return gcvt(val,ndig,loc); + } + else { + loc[0] = '0'; loc[1] = '\0'; + return loc; + } + +} +/*}}}*/ + +/* +** The following routines are provided to make life easier when +** converting among VMS-style and Unix-style directory specifications. +** All will take input specifications in either VMS or Unix syntax. On +** failure, all return NULL. If successful, the routines listed below +** return a pointer to a static buffer containing the appropriately +** reformatted spec (and, therefore, subsequent calls to that routine +** will clobber the result), while the routines of the same names with +** a _ts suffix appended will return a pointer to a mallocd string +** containing the appropriately reformatted spec. +** In all cases, only explicit syntax is altered; no check is made that +** the resulting string is valid or that the directory in question +** actually exists. +** +** fileify_dirspec() - convert a directory spec into the name of the +** directory file (i.e. what you can stat() to see if it's a dir). +** The style (VMS or Unix) of the result is the same as the style +** of the parameter passed in. +** pathify_dirspec() - convert a directory spec into a path (i.e. +** what you prepend to a filename to indicate what directory it's in). +** The style (VMS or Unix) of the result is the same as the style +** of the parameter passed in. +** tounixpath() - convert a directory spec into a Unix-style path. +** tovmspath() - convert a directory spec into a VMS-style path. +** tounixspec() - convert any file spec into a Unix-style file spec. +** tovmsspec() - convert any file spec into a VMS-style spec. + */ + +/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/ +static char *do_fileify_dirspec(char *dir,char *buf,int ts) +{ + static char __fileify_retbuf[NAM$C_MAXRSS+1]; + unsigned long int dirlen, retlen, addmfd = 0; + char *retspec, *cp1, *cp2, *lastdir; + + if (dir == NULL) return NULL; + + dirlen = strlen(dir); + if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */ + if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ + dirlen -= 1; /* to last element */ + lastdir = strrchr(dir,'/'); + } + 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 */ + errno = ENOTDIR; /* Bzzt. */ + return NULL; + } + } + dirlen = cp2 - dir; + } + else { /* There's a type, and it's not .dir. Bzzt. */ + errno = ENOTDIR; + return NULL; + } + } + /* If we lead off with a device or rooted logical, add the MFD + if we're specifying a top-level directory. */ + if (lastdir && *dir == '/') { + addmfd = 1; + for (cp1 = lastdir - 1; cp1 > dir; cp1--) { + if (*cp1 == '/') { + addmfd = 0; + break; + } + } + } + retlen = dirlen + addmfd ? 13 : 6; + if (buf) retspec = buf; + else if (ts) New(7009,retspec,retlen+6,char); + else retspec = __fileify_retbuf; + if (addmfd) { + dirlen = lastdir - dir; + memcpy(retspec,dir,dirlen); + strcpy(&retspec[dirlen],"/000000"); + strcpy(&retspec[dirlen+7],lastdir); + } + else { + memcpy(retspec,dir,dirlen); + retspec[dirlen] = '\0'; + } + } + /* We've picked up everything up to the directory file name. + Now just add the type and version, and we're set. */ + strcat(retspec,".dir;1"); + return retspec; + } + else { /* VMS-style directory spec */ + char esa[NAM$C_MAXRSS+1], term; + unsigned long int sts, cmplen; + struct FAB dirfab = cc$rms_fab; + struct NAM savnam, dirnam = cc$rms_nam; + + dirfab.fab$b_fns = strlen(dir); + dirfab.fab$l_fna = dir; + dirfab.fab$l_nam = &dirnam; + dirnam.nam$b_ess = NAM$C_MAXRSS; + dirnam.nam$l_esa = esa; + dirnam.nam$b_nop = NAM$M_SYNCHK; + if (!(sys$parse(&dirfab)&1)) { + errno = EVMSERR; + vaxc$errno = dirfab.fab$l_sts; + return NULL; + } + savnam = dirnam; + if (sys$search(&dirfab)&1) { /* Does the file really exist? */ + /* Yes; fake the fnb bits so we'll check type below */ + dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER; + } + else { + if (dirfab.fab$l_sts != RMS$_FNF) { + errno = EVMSERR; + vaxc$errno = dirfab.fab$l_sts; + return NULL; + } + dirnam = savnam; /* No; just work with potential name */ + } + + if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */ + /* Yep; check version while we're at it, if it's there. */ + cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; + if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { + /* Something other than .DIR[;1]. Bzzt. */ + errno = ENOTDIR; + return NULL; + } + else { /* Ok, it was .DIR[;1]; copy over everything up to the */ + retlen = dirnam.nam$l_type - esa; /* file name. */ + if (buf) retspec = buf; + else if (ts) New(7010,retspec,retlen+6,char); + else retspec = __fileify_retbuf; + strncpy(retspec,esa,retlen); + retspec[retlen] = '\0'; + } + } + else { + /* They didn't explicitly specify the directory file. Ignore + any file names in the input, pull off the last element of the + directory path, and make it the file name. If you want to + pay attention to filenames without .dir in the input, just use + ".DIR;1" as a default filespec for the $PARSE */ + esa[dirnam.nam$b_esl] = '\0'; + if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>'); + if (cp1 == NULL) return NULL; /* should never happen */ + term = *cp1; + *cp1 = '\0'; + retlen = strlen(esa); + if ((cp1 = strrchr(esa,'.')) != NULL) { + /* There's more than one directory in the path. Just roll back. */ + *cp1 = term; + if (buf) retspec = buf; + else if (ts) New(7011,retspec,retlen+6,char); + else retspec = __fileify_retbuf; + strcpy(retspec,esa); + } + else { /* This is a top-level dir. Add the MFD to the path. */ + if (buf) retspec = buf; + else if (ts) New(7012,retspec,retlen+14,char); + else retspec = __fileify_retbuf; + cp1 = esa; + cp2 = retspec; + while (*cp1 != ':') *(cp2++) = *(cp1++); + strcpy(cp2,":[000000]"); + cp1 += 2; + strcpy(cp2+9,cp1); + } + } + /* Again, we've set up the string up through the filename. Add the + type and version, and we're done. */ + strcat(retspec,".DIR;1"); + return retspec; + } +} /* end of do_fileify_dirspec() */ +/*}}}*/ +/* External entry points */ +char *fileify_dirspec(char *dir, char *buf) +{ return do_fileify_dirspec(dir,buf,0); } +char *fileify_dirspec_ts(char *dir, char *buf) +{ return do_fileify_dirspec(dir,buf,1); } + +/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/ +static char *do_pathify_dirspec(char *dir,char *buf, int ts) +{ + static char __pathify_retbuf[NAM$C_MAXRSS+1]; + unsigned long int retlen; + char *retpath, *cp1, *cp2; + + if (dir == NULL) return NULL; + + if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */ + if (!(cp1 = strrchr(dir,'/'))) cp1 = dir; + if (cp2 = strchr(cp1,'.')) { + 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. */ + errno = ENOTDIR; + return NULL; + } + } + else { /* No file type present. Treat the filename as a directory. */ + retlen = strlen(dir) + 1; + } + if (buf) retpath = buf; + else if (ts) New(7013,retpath,retlen,char); + else retpath = __pathify_retbuf; + strncpy(retpath,dir,retlen-1); + if (retpath[retlen-2] != '/') { /* If the path doesn't already end */ + retpath[retlen-1] = '/'; /* with '/', add it. */ + retpath[retlen] = '\0'; + } + else retpath[retlen-1] = '\0'; + } + else { /* VMS-style directory spec */ + char esa[NAM$C_MAXRSS+1]; + unsigned long int sts, cmplen; + struct FAB dirfab = cc$rms_fab; + struct NAM savnam, dirnam = cc$rms_nam; + + dirfab.fab$b_fns = strlen(dir); + dirfab.fab$l_fna = dir; + dirfab.fab$l_nam = &dirnam; + dirnam.nam$b_ess = sizeof esa; + dirnam.nam$l_esa = esa; + dirnam.nam$b_nop = NAM$M_SYNCHK; + if (!(sys$parse(&dirfab)&1)) { + errno = EVMSERR; + vaxc$errno = dirfab.fab$l_sts; + return NULL; + } + savnam = dirnam; + if (sys$search(&dirfab)&1) { /* Does the file really exist? */ + /* Yes; fake the fnb bits so we'll check type below */ + dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER; + } + else { + if (dirfab.fab$l_sts != RMS$_FNF) { + errno = EVMSERR; + vaxc$errno = dirfab.fab$l_sts; + return NULL; + } + dirnam = savnam; /* No; just work with potential name */ + } + + if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */ + /* Yep; check version while we're at it, if it's there. */ + cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; + if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { + /* Something other than .DIR[;1]. Bzzt. */ + errno = ENOTDIR; + return NULL; + } + /* OK, the type was fine. Now pull any file name into the + directory path. */ + if (cp1 = strrchr(esa,']')) *dirnam.nam$l_type = ']'; + else { + cp1 = strrchr(esa,'>'); + *dirnam.nam$l_type = '>'; + } + *cp1 = '.'; + *(dirnam.nam$l_type + 1) = '\0'; + retlen = dirnam.nam$l_type - esa + 2; + } + else { + /* There wasn't a type on the input, so ignore any file names as + well. If you want to pay attention to filenames without .dir + in the input, just use ".DIR;1" as a default filespec for + the $PARSE and set retlen thus + retlen = (dirnam.nam$b_rsl ? dirnam.nam$b_rsl : dirnam.nam$b_esl); + */ + retlen = dirnam.nam$l_name - esa; + esa[retlen] = '\0'; + } + if (buf) retpath = buf; + else if (ts) New(7014,retpath,retlen,char); + else retpath = __pathify_retbuf; + strcpy(retpath,esa); + } + + return retpath; +} /* end of do_pathify_dirspec() */ +/*}}}*/ +/* External entry points */ +char *pathify_dirspec(char *dir, char *buf) +{ return do_pathify_dirspec(dir,buf,0); } +char *pathify_dirspec_ts(char *dir, char *buf) +{ return do_pathify_dirspec(dir,buf,1); } + +/*{{{ char *tounixspec[_ts](char *path, char *buf)*/ +static char *do_tounixspec(char *spec, char *buf, int ts) +{ + static char __tounixspec_retbuf[NAM$C_MAXRSS+1]; + char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1]; + int devlen, dirlen; + + if (spec == NULL || *spec == '\0') return NULL; + if (buf) rslt = buf; + else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char); + else rslt = __tounixspec_retbuf; + if (strchr(spec,'/') != NULL) { + strcpy(rslt,spec); + return rslt; + } + + cp1 = rslt; + cp2 = spec; + dirend = strrchr(spec,']'); + if (dirend == NULL) dirend = strrchr(spec,'>'); + if (dirend == NULL) dirend = strchr(spec,':'); + if (dirend == NULL) { + strcpy(rslt,spec); + return rslt; + } + if (*cp2 != '[') { + *(cp1++) = '/'; + } + else { /* the VMS spec begins with directories */ + cp2++; + if (*cp2 == '-') { + while (*cp2 == '-') { + *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; + cp2++; + } + if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ + if (ts) Safefree(rslt); /* filespecs like */ + errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */ + return NULL; + } + cp2++; + } + else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */ + *(cp1++) = '/'; + if (getcwd(tmp,sizeof tmp,1) == NULL) { + if (ts) Safefree(rslt); + return NULL; + } + do { + cp3 = tmp; + while (*cp3 != ':' && *cp3) cp3++; + *(cp3++) = '\0'; + if (strchr(cp3,']') != NULL) break; + } while (((cp3 = getenv(tmp)) != NULL) && strcpy(tmp,cp3)); + cp3 = tmp; + while (*cp3) *(cp1++) = *(cp3++); + *(cp1++) = '/'; + if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) { + if (ts) Safefree(rslt); + errno = ERANGE; + return NULL; + } + } + else cp2++; + } + for (; cp2 <= dirend; cp2++) { + if (*cp2 == ':') { + *(cp1++) = '/'; + if (*(cp2+1) == '[') cp2++; + } + else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/'; + else if (*cp2 == '.') { + *(cp1++) = '/'; + while (*(cp2+1) == ']' || *(cp2+1) == '>' || + *(cp2+1) == '[' || *(cp2+1) == '<') cp2++; + } + else if (*cp2 == '-') { + if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') { + while (*cp2 == '-') { + cp2++; + *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; + } + if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ + if (ts) Safefree(rslt); /* filespecs like */ + errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */ + return NULL; + } + cp2++; + } + else *(cp1++) = *cp2; + } + else *(cp1++) = *cp2; + } + while (*cp2) *(cp1++) = *(cp2++); + *cp1 = '\0'; + + return rslt; + +} /* end of do_tounixspec() */ +/*}}}*/ +/* External entry points */ +char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); } +char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); } + +/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/ +static char *do_tovmsspec(char *path, char *buf, int ts) { + static char __tovmsspec_retbuf[NAM$C_MAXRSS+1]; + char *rslt, *dirend, *cp1, *cp2; + + if (path == NULL || *path == '\0') return NULL; + if (buf) rslt = buf; + else if (ts) New(7016,rslt,strlen(path)+1,char); + else rslt = __tovmsspec_retbuf; + if (strchr(path,']') != NULL || strchr(path,'>') != NULL || + (dirend = strrchr(path,'/')) == NULL) { + strcpy(rslt,path); + return rslt; + } + cp1 = rslt; + cp2 = path; + if (*cp2 == '/') { + while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; + *(cp1++) = ':'; + *(cp1++) = '['; + cp2++; + } + else { + *(cp1++) = '['; + *(cp1++) = '.'; + } + for (; cp2 < dirend; cp2++) *(cp1++) = (*cp2 == '/') ? '.' : *cp2; + *(cp1++) = ']'; + cp2++; + while (*cp2) *(cp1++) = *(cp2++); + *cp1 = '\0'; + + return rslt; + +} /* end of do_tovmsspec() */ +/*}}}*/ +/* External entry points */ +char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); } +char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); } + +/*{{{ char *tovmspath[_ts](char *path, char *buf)*/ +static char *do_tovmspath(char *path, char *buf, int ts) { + static char __tovmspath_retbuf[NAM$C_MAXRSS+1]; + int vmslen; + char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp; + + if (path == NULL || *path == '\0') return NULL; + if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL; + if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL; + if (buf) return buf; + else if (ts) { + vmslen = strlen(vmsified); + New(7017,cp,vmslen,char); + memcpy(cp,vmsified,vmslen); + cp[vmslen] = '\0'; + return cp; + } + else { + strcpy(__tovmspath_retbuf,vmsified); + return __tovmspath_retbuf; + } + +} /* end of do_tovmspath() */ +/*}}}*/ +/* External entry points */ +char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); } +char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); } + + +/*{{{ char *tounixpath[_ts](char *path, char *buf)*/ +static char *do_tounixpath(char *path, char *buf, int ts) { + static char __tounixpath_retbuf[NAM$C_MAXRSS+1]; + int unixlen; + char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp; + + if (path == NULL || *path == '\0') return NULL; + if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL; + if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL; + if (buf) return buf; + else if (ts) { + unixlen = strlen(unixified); + New(7017,cp,unixlen,char); + memcpy(cp,unixified,unixlen); + cp[unixlen] = '\0'; + return cp; + } + else { + strcpy(__tounixpath_retbuf,unixified); + return __tounixpath_retbuf; + } + +} /* end of do_tounixpath() */ +/*}}}*/ +/* External entry points */ +char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); } +char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); } + +/* + * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com) + * + ***************************************************************************** + * * + * Copyright (C) 1989-1994 by * + * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 * + * * + * Permission is hereby granted for the reproduction of this software, * + * on condition that this copyright notice is included in the reproduction, * + * and that such reproduction is not for purposes of profit or material * + * gain. * + * * + * 27-Aug-1994 Modified for inclusion in perl5 * + * by Charles Bailey bailey@genetics.upenn.edu * + ***************************************************************************** + */ + +/* + * getredirection() is intended to aid in porting C programs + * to VMS (Vax-11 C). The native VMS environment does not support + * '>' and '<' I/O redirection, or command line wild card expansion, + * or a command line pipe mechanism using the '|' AND background + * command execution '&'. All of these capabilities are provided to any + * C program which calls this procedure as the first thing in the + * main program. + * The piping mechanism will probably work with almost any 'filter' type + * of program. With suitable modification, it may useful for other + * portability problems as well. + * + * Author: Mark Pizzolato mark@infocomm.com + */ +struct list_item + { + struct list_item *next; + char *value; + }; + +static void add_item(struct list_item **head, + struct list_item **tail, + char *value, + int *count); + +static void expand_wild_cards(char *item, + struct list_item **head, + struct list_item **tail, + int *count); + +static int background_process(int argc, char **argv); + +static void pipe_and_fork(char **cmargv); + +/*{{{ void getredirection(int *ac, char ***av)*/ +void +getredirection(int *ac, char ***av) +/* + * Process vms redirection arg's. Exit if any error is seen. + * If getredirection() processes an argument, it is erased + * from the vector. getredirection() returns a new argc and argv value. + * In the event that a background command is requested (by a trailing "&"), + * this routine creates a background subprocess, and simply exits the program. + * + * Warning: do not try to simplify the code for vms. The code + * presupposes that getredirection() is called before any data is + * read from stdin or written to stdout. + * + * Normal usage is as follows: + * + * main(argc, argv) + * int argc; + * char *argv[]; + * { + * getredirection(&argc, &argv); + * } + */ +{ + int argc = *ac; /* Argument Count */ + char **argv = *av; /* Argument Vector */ + char *ap; /* Argument pointer */ + int j; /* argv[] index */ + int item_count = 0; /* Count of Items in List */ + struct list_item *list_head = 0; /* First Item in List */ + struct list_item *list_tail; /* Last Item in List */ + char *in = NULL; /* Input File Name */ + char *out = NULL; /* Output File Name */ + char *outmode = "w"; /* Mode to Open Output File */ + char *err = NULL; /* Error File Name */ + char *errmode = "w"; /* Mode to Open Error File */ + int cmargc = 0; /* Piped Command Arg Count */ + char **cmargv = NULL;/* Piped Command Arg Vector */ + stat_t statbuf; /* fstat buffer */ + + /* + * First handle the case where the last thing on the line ends with + * a '&'. This indicates the desire for the command to be run in a + * subprocess, so we satisfy that desire. + */ + ap = argv[argc-1]; + if (0 == strcmp("&", ap)) + exit(background_process(--argc, argv)); + if ('&' == ap[strlen(ap)-1]) + { + ap[strlen(ap)-1] = '\0'; + exit(background_process(argc, argv)); + } + /* + * Now we handle the general redirection cases that involve '>', '>>', + * '<', and pipes '|'. + */ + for (j = 0; j < argc; ++j) + { + if (0 == strcmp("<", argv[j])) + { + if (j+1 >= argc) + { + errno = EINVAL; + croak("No input file"); + } + in = argv[++j]; + continue; + } + if ('<' == *(ap = argv[j])) + { + in = 1 + ap; + continue; + } + if (0 == strcmp(">", ap)) + { + if (j+1 >= argc) + { + errno = EINVAL; + croak("No input file"); + } + out = argv[++j]; + continue; + } + if ('>' == *ap) + { + if ('>' == ap[1]) + { + outmode = "a"; + if ('\0' == ap[2]) + out = argv[++j]; + else + out = 2 + ap; + } + else + out = 1 + ap; + if (j >= argc) + { + errno = EINVAL; + croak("No output file"); + } + continue; + } + if (('2' == *ap) && ('>' == ap[1])) + { + if ('>' == ap[2]) + { + errmode = "a"; + if ('\0' == ap[3]) + err = argv[++j]; + else + err = 3 + ap; + } + else + if ('\0' == ap[2]) + err = argv[++j]; + else + err = 1 + ap; + if (j >= argc) + { + errno = EINVAL; + croak("No error file"); + } + continue; + } + if (0 == strcmp("|", argv[j])) + { + if (j+1 >= argc) + { + errno = EPIPE; + croak("No command into which to pipe"); + } + cmargc = argc-(j+1); + cmargv = &argv[j+1]; + argc = j; + continue; + } + if ('|' == *(ap = argv[j])) + { + ++argv[j]; + cmargc = argc-j; + cmargv = &argv[j]; + argc = j; + continue; + } + expand_wild_cards(ap, &list_head, &list_tail, &item_count); + } + /* + * Allocate and fill in the new argument vector, Some Unix's terminate + * the list with an extra null pointer. + */ + New(7002, argv, item_count+1, char *); + *av = argv; + for (j = 0; j < item_count; ++j, list_head = list_head->next) + argv[j] = list_head->value; + *ac = item_count; + if (cmargv != NULL) + { + if (out != NULL) + { + errno = EINVAL; + croak("'|' and '>' may not both be specified on command line"); + } + pipe_and_fork(cmargv); + } + + /* Check for input from a pipe (mailbox) */ + + if (1 == isapipe(0)) + { + char mbxname[L_tmpnam]; + long int bufsize; + long int dvi_item = DVI$_DEVBUFSIZ; + $DESCRIPTOR(mbxnam, ""); + $DESCRIPTOR(mbxdevnam, ""); + + /* Input from a pipe, reopen it in binary mode to disable */ + /* carriage control processing. */ + + if (in != NULL) + { + errno = EINVAL; + croak("'|' and '<' may not both be specified on command line"); + } + fgetname(stdin, mbxname); + mbxnam.dsc$a_pointer = mbxname; + mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); + lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); + mbxdevnam.dsc$a_pointer = mbxname; + mbxdevnam.dsc$w_length = sizeof(mbxname); + dvi_item = DVI$_DEVNAM; + lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length); + mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0'; + errno = 0; + freopen(mbxname, "rb", stdin); + if (errno != 0) + { + croak("Error reopening pipe (name: %s) in binary mode",mbxname); + } + } + if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2"))) + { + croak("Can't open input file %s",in); + } + if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2"))) + { + croak("Can't open output file %s",out); + } + if ((err != NULL) && (NULL == freopen(err, errmode, stderr, "mbc=32", "mbf=2"))) + { + croak("Can't open error file %s",err); + } +#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() */ +/*}}}*/ + +static void add_item(struct list_item **head, + struct list_item **tail, + char *value, + int *count) +{ + if (*head == 0) + { + New(7003,*head,1,struct list_item); + *tail = *head; + } + else { + New(7004,(*tail)->next,1,struct list_item); + *tail = (*tail)->next; + } + (*tail)->value = value; + ++(*count); +} + +static void expand_wild_cards(char *item, + struct list_item **head, + struct list_item **tail, + int *count) +{ +int expcount = 0; +int context = 0; +int isunix = 0; +int status; +int status_value; +char *had_version; +char *had_device; +int had_directory; +char *devdir; +char vmsspec[NAM$C_MAXRSS+1]; +$DESCRIPTOR(filespec, ""); +$DESCRIPTOR(defaultspec, "SYS$DISK:[]*.*;"); +$DESCRIPTOR(resultspec, ""); +unsigned long int zero = 0; + + if (strcspn(item, "*%") == strlen(item)) + { + add_item(head, tail, item, count); + return; + } + resultspec.dsc$b_dtype = DSC$K_DTYPE_T; + resultspec.dsc$b_class = DSC$K_CLASS_D; + resultspec.dsc$a_pointer = NULL; + if (isunix = strchr(item,'/')) + filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0); + if (!isunix || !filespec.dsc$a_pointer) + filespec.dsc$a_pointer = item; + filespec.dsc$w_length = strlen(filespec.dsc$a_pointer); + /* + * Only return version specs, if the caller specified a version + */ + had_version = strchr(item, ';'); + /* + * Only return device and directory specs, if the caller specifed either. + */ + had_device = strchr(item, ':'); + had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<')); + + while (1 == (1&lib$find_file(&filespec, &resultspec, &context, + &defaultspec, 0, &status_value, &zero))) + { + char *string; + char *c; + + New(7005,string,resultspec.dsc$w_length+1,char); + strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length); + string[resultspec.dsc$w_length] = '\0'; + if (NULL == had_version) + *((char *)strrchr(string, ';')) = '\0'; + if ((!had_directory) && (had_device == NULL)) + { + if (NULL == (devdir = strrchr(string, ']'))) + devdir = strrchr(string, '>'); + strcpy(string, devdir + 1); + } + /* + * Be consistent with what the C RTL has already done to the rest of + * the argv items and lowercase all of these names. + */ + for (c = string; *c; ++c) + if (isupper(*c)) + *c = tolower(*c); + if (isunix) trim_unixpath(item,string); + add_item(head, tail, string, count); + ++expcount; + } + if (expcount == 0) + add_item(head, tail, item, count); + lib$sfree1_dd(&resultspec); + lib$find_file_end(&context); +} + +static int child_st[2];/* Event Flag set when child process completes */ + +static short child_chan;/* I/O Channel for Pipe Mailbox */ + +static exit_handler(int *status) +{ +short iosb[4]; + + 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> */ + sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0); + sys$dassgn(child_chan); + fclose(stdout); + sys$synch(0, child_st); + } + return(1); +} + +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; +} + +static struct exit_control_block + { + struct exit_control_block *flink; + int (*exit_routine)(); + int arg_count; + int *status_address; + int exit_status; + } exit_block = + { + 0, + exit_handler, + 1, + &exit_block.exit_status, + 0 + }; + +static void pipe_and_fork(char **cmargv) +{ + char subcmd[2048]; + $DESCRIPTOR(cmddsc, ""); + static char mbxname[64]; + $DESCRIPTOR(mbxdsc, mbxname); + short iosb[4]; + int status; + int pid, j; + short dvi_item = DVI$_DEVNAM; + unsigned long int zero = 0, one = 1; + + strcpy(subcmd, cmargv[0]); + for (j = 1; NULL != cmargv[j]; ++j) + { + strcat(subcmd, " \""); + strcat(subcmd, cmargv[j]); + strcat(subcmd, "\""); + } + cmddsc.dsc$a_pointer = subcmd; + cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer); + + 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 + if (0 == (1&(vaxc$errno = lib$spawn(&cmddsc, &mbxdsc, 0, &one, + 0, &pid, child_st, &zero, sig_child, + &child_chan)))) + { + errno = EVMSERR; + croak("Can't spawn subprocess"); + } +#ifdef ARGPROC_DEBUG + fprintf(stderr, "Subprocess's Pid = %08X\n", pid); +#endif + sys$dclexh(&exit_block); + if (NULL == freopen(mbxname, "wb", stdout)) + { + croak("Can't open pipe mailbox for output"); + } +} + +static int background_process(int argc, char **argv) +{ +char command[2048] = "$"; +$DESCRIPTOR(value, ""); +static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND"); +static $DESCRIPTOR(null, "NLA0:"); +static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID"); +char pidstring[80]; +$DESCRIPTOR(pidstr, ""); +int pid; +unsigned long int flags = 17, one = 1; + + strcat(command, argv[0]); + while (--argc) + { + strcat(command, " \""); + strcat(command, *(++argv)); + strcat(command, "\""); + } + value.dsc$a_pointer = command; + value.dsc$w_length = strlen(value.dsc$a_pointer); + if (0 == (1&(vaxc$errno = lib$set_symbol(&cmd, &value)))) + { + errno = EVMSERR; + croak("Can't create symbol for subprocess command"); + } + if ((0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &flags, 0, &pid)))) && + (vaxc$errno != 0x38250)) + { + errno = EVMSERR; + croak("Can't spawn subprocess"); + } + if (vaxc$errno == 0x38250) /* We must be BATCH, so retry */ + if (0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &one, 0, &pid)))) + { + errno = EVMSERR; + croak("Can't spawn subprocess"); + } +#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); + return(SS$_NORMAL); +} +/*}}}*/ +/***** End of code taken from Mark Pizzolato's argproc.c package *****/ + +/* + * flex_stat, flex_fstat + * basic stat, but gets it right when asked to stat + * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3) + */ + +static char namecache[NAM$C_MAXRSS+1]; + +static int +is_null_device(name) + const char *name; +{ + /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:". + The underscore prefix, controller letter, and unit number are + independently optional; for our purposes, the colon punctuation + is not. The colon can be trailed by optional directory and/or + filename, but two consecutive colons indicates a nodename rather + than a device. [pr] */ + if (*name == '_') ++name; + if (tolower(*name++) != 'n') return 0; + if (tolower(*name++) != 'l') return 0; + if (tolower(*name) == 'a') ++name; + if (*name == '0') ++name; + return (*name++ == ':') && (*name != ':'); +} + +/*{{{ 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)) return -1; + return flex_stat(fspec,statbuf); + +} /* end of flex_fstat() */ +/*}}}*/ + +/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/ +flex_stat(char *fspec, struct stat *statbufp) +{ + char fileified[NAM$C_MAXRSS+1]; + int retval,myretval; + struct stat tmpbuf; + + + if (statbufp == &statcache) strcpy(namecache,fspec); + if (is_null_device(fspec)) { /* Fake a stat() for the null device */ + memset(statbufp,0,sizeof *statbufp); + statbufp->st_dev = "_NLA0:"; + statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; + statbufp->st_uid = 0x00010001; + statbufp->st_gid = 0x0001; + time(&statbufp->st_mtime); + statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime; + return 0; + } + if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1; + else { + myretval = stat(fileified,&tmpbuf); + } + retval = stat(fspec,statbufp); + if (!myretval) { + if (retval == -1) { + *statbufp = tmpbuf; + retval = 0; + } + else if (!retval) { /* Dir with same name. Substitute it. */ + statbufp->st_mode &= ~S_IFDIR; + statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR; + strcpy(namecache,fileified); + } + } + return retval; + +} /* end of flex_stat() */ +/*}}}*/ + +/* trim_unixpath() + * Trim Unix-style prefix off filespec, so it looks like what a shell + * glob expansion would return (i.e. from specified prefix on, not + * full path). Note that returned filespec is Unix-style, regardless + * of whether input filespec was VMS-style or Unix-style. + * + * Returns !=0 on success, 0 on failure. + */ +/*{{{int trim_unixpath(char *template, char *fspec)*/ +int +trim_unixpath(char *template, char *fspec) +{ + char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2; + register int tmplen; + + if (strpbrk(fspec,"]>:") != NULL) { + if (do_tounixspec(fspec,unixified,0) == NULL) return 0; + else base = unixified; + } + else base = fspec; + for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */ + + /* Find prefix to template consisting of path elements without wildcards */ + if ((cp1 = strpbrk(template,"*%?")) == NULL) + for (cp1 = template; *cp1; cp1++) ; + else while (cp1 >= template && *cp1 != '/') cp1--; + if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */ + tmplen = cp1 - template; + + /* Try to find template prefix on filespec */ + if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */ + for (; cp2 - base > tmplen; base++) { + if (*base != '/') continue; + if (!memcmp(base + 1,template,tmplen)) break; + } + if (cp2 - base == tmplen) return 0; /* Not there - not good */ + base++; /* Move past leading '/' */ + /* Copy down remaining portion of filespec, including trailing NUL */ + memmove(fspec,base,cp2 - base + 1); + return 1; + +} /* end of trim_unixpath() */ +/*}}}*/ + +/* Do the permissions allow some operation? Assumes statcache already set. */ +/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a + * subset of the applicable information. + */ +/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/ +I32 +cando(I32 bit, I32 effective, struct stat *statbufp) +{ + unsigned long int objtyp = ACL$C_FILE, access, retsts; + unsigned short int retlen; + struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, namecache}; + static char usrname[L_cuserid]; + static struct dsc$descriptor_s usrdsc = + {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname}; + struct itmlst_3 armlst[2] = {sizeof access, CHP$_ACCESS, &access, &retlen, + 0, 0, 0, 0}; + + if (!usrdsc.dsc$w_length) { + cuserid(usrname); + usrdsc.dsc$w_length = strlen(usrname); + } + namdsc.dsc$w_length = strlen(namecache); + switch (bit) { + case S_IXUSR: + case S_IXGRP: + case S_IXOTH: + access = ARM$M_EXECUTE; + break; + case S_IRUSR: + case S_IRGRP: + case S_IROTH: + access = ARM$M_READ; + break; + case S_IWUSR: + case S_IWGRP: + case S_IWOTH: + access = ARM$M_READ; + break; + default: + return FALSE; + } + + retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst); + if (retsts == SS$_NORMAL) return TRUE; + if (retsts == SS$_NOPRIV) return FALSE; + _cksts(retsts); + + return FALSE; /* Should never get here */ + +} /* end of cando() */ +/*}}}*/ + +/* + * VMS readdir() routines. + * Written by Rich $alz, <rsalz@bbn.com> in August, 1990. + * This code has no copyright. + * + * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu + * Minor modifications to original routines. + */ + + /* Number of elements in vms_versions array */ +#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0]) + +/* + * Open a directory, return a handle for later use. + */ +/*{{{ DIR *opendir(char*name) */ +DIR * +opendir(char *name) +{ + DIR *dd; + char dir[NAM$C_MAXRSS+1]; + + /* Get memory for the handle, and the pattern. */ + New(7006,dd,1,DIR); + if (do_tovmspath(name,dir,0) == NULL) { + Safefree((char *)dd); + return(NULL); + } + New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char); + + /* Fill in the fields; mainly playing with the descriptor. */ + (void)sprintf(dd->pattern, "%s*.*",dir); + dd->context = 0; + dd->count = 0; + dd->vms_wantversions = 0; + dd->pat.dsc$a_pointer = dd->pattern; + dd->pat.dsc$w_length = strlen(dd->pattern); + dd->pat.dsc$b_dtype = DSC$K_DTYPE_T; + dd->pat.dsc$b_class = DSC$K_CLASS_S; + + return dd; +} /* end of opendir() */ +/*}}}*/ + +/* + * Set the flag to indicate we want versions or not. + */ +/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/ +void +vmsreaddirversions(DIR *dd, int flag) +{ + dd->vms_wantversions = flag; +} +/*}}}*/ + +/* + * Free up an opened directory. + */ +/*{{{ void closedir(DIR *dd)*/ +void +closedir(DIR *dd) +{ + (void)lib$find_file_end(&dd->context); + Safefree(dd->pattern); + Safefree((char *)dd); +} +/*}}}*/ + +/* + * Collect all the version numbers for the current file. + */ +static void +collectversions(dd) + DIR *dd; +{ + struct dsc$descriptor_s pat; + struct dsc$descriptor_s res; + struct dirent *e; + char *p, *text, buff[sizeof dd->entry.d_name]; + int i; + unsigned long context, tmpsts; + + /* Convenient shorthand. */ + e = &dd->entry; + + /* Add the version wildcard, ignoring the "*.*" put on before */ + i = strlen(dd->pattern); + New(7008,text,i + e->d_namlen + 3,char); + (void)strcpy(text, dd->pattern); + (void)sprintf(&text[i - 3], "%s;*", e->d_name); + + /* Set up the pattern descriptor. */ + pat.dsc$a_pointer = text; + pat.dsc$w_length = i + e->d_namlen - 1; + pat.dsc$b_dtype = DSC$K_DTYPE_T; + pat.dsc$b_class = DSC$K_CLASS_S; + + /* Set up result descriptor. */ + res.dsc$a_pointer = buff; + res.dsc$w_length = sizeof buff - 2; + res.dsc$b_dtype = DSC$K_DTYPE_T; + res.dsc$b_class = DSC$K_CLASS_S; + + /* Read files, collecting versions. */ + for (context = 0, e->vms_verscount = 0; + e->vms_verscount < VERSIZE(e); + e->vms_verscount++) { + tmpsts = lib$find_file(&pat, &res, &context); + if (tmpsts == RMS$_NMF || context == 0) break; + _cksts(tmpsts); + buff[sizeof buff - 1] = '\0'; + if (p = strchr(buff, ';')) + e->vms_versions[e->vms_verscount] = atoi(p + 1); + else + e->vms_versions[e->vms_verscount] = -1; + } + + _cksts(lib$find_file_end(&context)); + Safefree(text); + +} /* end of collectversions() */ + +/* + * Read the next entry from the directory. + */ +/*{{{ struct dirent *readdir(DIR *dd)*/ +struct dirent * +readdir(DIR *dd) +{ + struct dsc$descriptor_s res; + char *p, buff[sizeof dd->entry.d_name]; + int i; + unsigned long int tmpsts; + + /* Set up result descriptor, and get next file. */ + res.dsc$a_pointer = buff; + res.dsc$w_length = sizeof buff - 2; + res.dsc$b_dtype = DSC$K_DTYPE_T; + res.dsc$b_class = DSC$K_CLASS_S; + dd->count++; + tmpsts = lib$find_file(&dd->pat, &res, &dd->context); + if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */ + + /* Force the buffer to end with a NUL, and downcase name to match C convention. */ + buff[sizeof buff - 1] = '\0'; + for (p = buff; !isspace(*p); p++) *p = _tolower(*p); + *p = '\0'; + + /* Skip any directory component and just copy the name. */ + if (p = strchr(buff, ']')) (void)strcpy(dd->entry.d_name, p + 1); + else (void)strcpy(dd->entry.d_name, buff); + + /* Clobber the version. */ + if (p = strchr(dd->entry.d_name, ';')) *p = '\0'; + + dd->entry.d_namlen = strlen(dd->entry.d_name); + dd->entry.vms_verscount = 0; + if (dd->vms_wantversions) collectversions(dd); + return &dd->entry; + +} /* end of readdir() */ +/*}}}*/ + +/* + * Return something that can be used in a seekdir later. + */ +/*{{{ long telldir(DIR *dd)*/ +long +telldir(DIR *dd) +{ + return dd->count; +} +/*}}}*/ + +/* + * Return to a spot where we used to be. Brute force. + */ +/*{{{ void seekdir(DIR *dd,long count)*/ +void +seekdir(DIR *dd, long count) +{ + int vms_wantversions; + unsigned long int tmpsts; + + /* If we haven't done anything yet... */ + if (dd->count == 0) + return; + + /* Remember some state, and clear it. */ + vms_wantversions = dd->vms_wantversions; + dd->vms_wantversions = 0; + _cksts(lib$find_file_end(&dd->context)); + dd->context = 0; + + /* The increment is in readdir(). */ + for (dd->count = 0; dd->count < count; ) + (void)readdir(dd); + + dd->vms_wantversions = vms_wantversions; + +} /* end of seekdir() */ +/*}}}*/ + +/* VMS subprocess management + * + * my_vfork() - just a vfork(), after setting a flag to record that + * the current script is trying a Unix-style fork/exec. + * + * vms_do_aexec() and vms_do_exec() are called in response to the + * perl 'exec' function. If this follows a vfork call, then they + * call out the the regular perl routines in doio.c which do an + * execvp (for those who really want to try this under VMS). + * Otherwise, they do exactly what the perl docs say exec should + * do - terminate the current script and invoke a new command + * (See below for notes on command syntax.) + * + * do_aspawn() and do_spawn() implement the VMS side of the perl + * 'system' function. + * + * Note on command arguments to perl 'exec' and 'system': When handled + * in 'VMSish fashion' (i.e. not after a call to vfork) The args + * are concatenated to form a DCL command string. If the first arg + * begins with '$' (i.e. the perl script had "\$ Type" or some such), + * the the command string is hrnded off to DCL directly. Otherwise, + * the first token of the command is taken as the filespec of an image + * to run. The filespec is expanded using a default type of '.EXE' and + * the process defaults for device, directory, etc., and the resultant + * filespec is invoked using the DCL verb 'MCR', and passed the rest of + * the command string as parameters. This is perhaps a bit compicated, + * but I hope it will form a happy medium between what VMS folks expect + * from lib$spawn and what Unix folks expect from exec. + */ + +static int vfork_called; + +/*{{{int my_vfork()*/ +int +my_vfork() +{ + vfork_called = 1; + return vfork(); +} +/*}}}*/ + +static void +setup_argstr(SV *really, SV **mark, SV **sp, char **argstr) +{ + char *tmps, *junk; + register size_t cmdlen = 0; + size_t rlen; + register SV **idx; + + idx = mark; + if (really && *(tmps = SvPV(really,rlen))) { + cmdlen += rlen + 1; + idx++; + } + + for (idx++; idx <= sp; idx++) { + if (*idx) { + junk = SvPVx(*idx,rlen); + cmdlen += rlen ? rlen + 1 : 0; + } + } + New(401,*argstr,cmdlen, char); + + if (*tmps) { + strcpy(*argstr,tmps); + mark++; + } + else **argstr = '\0'; + while (++mark <= sp) { + if (*mark) { + strcat(*argstr," "); + strcat(*argstr,SvPVx(*mark,na)); + } + } + +} /* end of setup_argstr() */ + +static unsigned long int +setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img) +{ + char resspec[NAM$C_MAXRSS+1]; + $DESCRIPTOR(defdsc,".EXE"); + $DESCRIPTOR(resdsc,resspec); + struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + unsigned long int cxt = 0, flags = 1, retsts; + register char *s, *rest, *cp; + register int isdcl = 0; + + s = cmd; + while (*s && isspace(*s)) s++; + if (check_img) { + if (*s == '$') { /* Check whether this is a DCL command: leading $ and */ + isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */ + for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) { + if (*cp == ':' || *cp == '[' || *cp == '<') { + isdcl = 0; + break; + } + } + } + } + else isdcl = 1; + if (isdcl) { /* It's a DCL command, just do it. */ + cmddsc->dsc$a_pointer = cmd; + cmddsc->dsc$w_length = strlen(cmd); + } + else { /* assume first token is an image spec */ + cmd = s; + while (*s && !isspace(*s)) s++; + rest = *s ? s : 0; + imgdsc.dsc$a_pointer = cmd; + imgdsc.dsc$w_length = s - cmd; + retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags); + if ((retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; + else { + _cksts(retsts); + _cksts(lib$find_file_end(&cxt)); + s = resspec; + while (*s && !isspace(*s)) s++; + *s = '\0'; + New(402,Cmd,6 + s - resspec + (rest ? strlen(rest) : 0),char); + strcpy(Cmd,"$ MCR "); + strcat(Cmd,resspec); + if (rest) strcat(Cmd,rest); + cmddsc->dsc$a_pointer = Cmd; + cmddsc->dsc$w_length = strlen(Cmd); + } + } + + return SS$_NORMAL; +} /* end of setup_cmddsc() */ + +/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */ +bool +vms_do_aexec(SV *really,SV **mark,SV **sp) +{ + + if (sp > mark) { + if (vfork_called) { /* this follows a vfork - act Unixish */ + vfork_called = 0; + do_aexec(really,mark,sp); + } + else { /* no vfork - act VMSish */ + setup_argstr(really,mark,sp,&Argv); + return vms_do_exec(Argv); + } + } + + return FALSE; +} /* end of vms_do_aexec() */ +/*}}}*/ + +/* {{{bool vms_do_exec(char *cmd) */ +bool +vms_do_exec(char *cmd) +{ + + if (vfork_called) { /* this follows a vfork - act Unixish */ + vfork_called = 0; + do_exec(cmd); + } + else { /* no vfork - act VMSish */ + struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + + if ((vaxc$errno = setup_cmddsc(cmd,&cmddsc,1)) & 1) + vaxc$errno = lib$do_command(&cmddsc); + + errno = EVMSERR; + if (dowarn) + warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno)); + do_execfree(); + } + + return FALSE; + +} /* end of vms_do_exec() */ +/*}}}*/ + +unsigned long int do_spawn(char *); + +/* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */ +unsigned long int +do_aspawn(SV *really,SV **mark,SV **sp) +{ + + if (sp > mark) { + setup_argstr(really,mark,sp,&Argv); + return do_spawn(Argv); + } + + return SS$_ABORT; +} /* end of do_aspawn() */ +/*}}}*/ + +/* {{{unsigned long int do_spawn(char *cmd) */ +unsigned long int +do_spawn(char *cmd) +{ + struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + unsigned long int substs; + + if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1) + _cksts(lib$spawn(&cmddsc,&nl_desc,0,0,0,&substs,0,0,0,0,0)); + + if (!(substs&1)) { + vaxc$errno = substs; + errno = EVMSERR; + if (dowarn) + warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno)); + } + return substs; + +} /* end of do_spawn() */ +/*}}}*/ + +/* + * A simple fwrite replacement which outputs itmsz*nitm chars without + * introducing record boundaries every itmsz chars. + */ +/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/ +int +my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) +{ + register char *cp, *end; + + end = (char *)src + itmsz * nitm; + + while ((char *)src <= end) { + for (cp = src; cp <= end; cp++) if (!*cp) break; + if (fputs(src,dest) == EOF) return EOF; + if (cp < end) + if (fputc('\0',dest) == EOF) return EOF; + src = cp + 1; + } + + return 1; + +} /* end of my_fwrite() */ +/*}}}*/ + +#ifndef VMS_DO_SOCKETS +/***** The following two routines are temporary, and should be removed, + * along with the corresponding #defines in vmsish.h, when TCP/IP support + * has been added to the VMS port of perl5. (The temporary hacks are + * here now sho that pack can handle type N elements.) + * - C. Bailey 16-Aug-1994 + *****/ + +/*{{{ unsigned short int tmp_shortflip(unsigned short int val)*/ +unsigned short int +tmp_shortflip(unsigned short int val) +{ + return val << 8 | val >> 8; +} +/*}}}*/ + +/*{{{ unsigned long int tmp_longflip(unsigned long int val)*/ +unsigned long int +tmp_longflip(unsigned long int val) +{ + unsigned long int scratch = val; + unsigned char savbyte, *tmp; + + tmp = (unsigned char *) &scratch; + savbyte = tmp[0]; tmp[0] = tmp[3]; tmp[3] = savbyte; + savbyte = tmp[1]; tmp[1] = tmp[2]; tmp[2] = savbyte; + + return scratch; +} +/*}}}*/ +#endif diff --git a/vms/vmsish.h b/vms/vmsish.h new file mode 100644 index 0000000000..ec0dbde2eb --- /dev/null +++ b/vms/vmsish.h @@ -0,0 +1,176 @@ +/* vmsish.h + * + * VMS-specific C header file for perl5. + * + * Last revised: 09-Oct-1994 by Charles Bailey bailey@genetics.upenn.edu + */ + +#ifndef __vmsish_h_included +#define __vmsish_h_included + +#include <descrip.h> /* for dirent struct definitions */ + +/* Assorted things to look like Unix */ +#ifdef __GNUC__ +#ifndef _IOLBF /* gcc's stdio.h doesn't define this */ +#define _IOLBF 1 +#endif +#else +#include <processes.h> /* for vfork() */ +#include <unixio.h> +#endif +#include <unixlib.h> +#include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */ +#define unlink remove + +#ifdef VMS_DO_SOCKETS +#include "sockadapt.h" +#endif + +/* + * The following symbols are defined (or undefined) according to the RTL + * support VMS provides for the corresponding functions. These don't + * appear in config.h, so they're dealt with here. + */ +#define HAS_KILL +#define HAS_WAIT + +/* 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 + +/* + * 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 my_fwrite + +/* Use our own rmdir() */ +#define rmdir(name) do_rmdir(name) + +/* Assorted fiddling with sigs . . . */ +# include <signal.h> +#define ABORT() abort() + +/* 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 */ +}; + +/* VMS doesn't use a real sys_nerr, but we need this when scanning for error + * messages in text strings . . . + */ + +#define sys_nerr EVMSERR /* EVMSERR is as high as we can go. */ + +/* Look up new %ENV values on the fly */ +#define DYNAMIC_ENV_FETCH 1 +#define ENV_HV_NAME "%EnV%VmS%" + +/* Use our own stat() clones, which handle Unix-style directory names */ +#define Stat(name,bufptr) flex_stat(name,bufptr) +#define Fstat(fd,bufptr) flex_fstat(fd,bufptr) + +/* Setup for the dirent routines: + * opendir(), closedir(), readdir(), seekdir(), telldir(), and + * vmsreaddirversions(), and preprocessor stuff on which these depend: + * Written by Rich $alz, <rsalz@bbn.com> in August, 1990. + * This code has no copyright. + */ + /* Data structure returned by READDIR(). */ +struct dirent { + char d_name[256]; /* File name */ + int d_namlen; /* Length of d_name */ + int vms_verscount; /* Number of versions */ + int vms_versions[20]; /* Version numbers */ +}; + + /* Handle returned by opendir(), used by the other routines. You + * are not supposed to care what's inside this structure. */ +typedef struct _dirdesc { + long context; + int vms_wantversions; + unsigned long int count; + char *pattern; + struct dirent entry; + struct dsc$descriptor_s pat; +} DIR; + +#define rewinddir(dirp) seekdir((dirp), 0) + + +/* Prototypes for functions unique to vms.c. Don't include replacements + * for routines in the mainline source files excluded by #ifndef VMS; + * their prototypes are already in proto.h. + * + * In order to keep Gen_ShrFls.Pl happy, functions which are to be made + * available to images linked to PerlShr.Exe must be declared between the + * __VMS_PROTOTYPES__ and __VMS_SEPYTOTORP__ lines, and must be in the form + * <data type><TAB>name<WHITESPACE>_((<prototype args>)); + */ +typedef char __VMS_PROTOTYPES__; /* prototype section start marker */ +char * my_getenv _((char *)); +#ifndef HAS_WAITPID /* Not a real waitpid - use only with popen from vms.c! */ +unsigned long int waitpid _((unsigned long int, int *, int)); +#endif +char * my_gconvert _((double, int, int, char *)); +int do_rmdir _((char *)); +int kill_file _((char *)); +char * fileify_dirspec _((char *, char *)); +char * fileify_dirspec_ts _((char *, char *)); +char * pathify_dirspec _((char *, char *)); +char * pathify_dirspec_ts _((char *, char *)); +char * tounixspec _((char *, char *)); +char * tounixspec_ts _((char *, char *)); +char * tovmsspec _((char *, char *)); +char * tovmsspec_ts _((char *, char *)); +char * tounixpath _((char *, char *)); +char * tounixpath_ts _((char *, char *)); +char * tovmspath _((char *, char *)); +char * tovmspath_ts _((char *, char *)); +void getredirection _(()); +DIR * opendir _((char *)); +struct dirent * readdir _((DIR *)); +long telldir _((DIR *)); +void seekdir _((DIR *, long)); +void closedir _((DIR *)); +void vmsreaddirversions _((DIR *, int)); +void getredirection _((int *, char ***)); +int flex_fstat _((int, stat_t *)); +int flex_stat _((char *, stat_t *)); +int trim_unixpath _((char *, char*)); +struct sv; /* forward declaration for vms_do_aexec and do_aspawn */ + /* real declaration is in sv.h */ +#define bool char /* This must match handy.h */ +bool vms_do_aexec _((struct sv *, struct sv **, struct sv **)); +bool vms_do_exec _((char *)); +unsigned long int do_aspawn _((struct sv *, struct sv **, struct sv **)); +unsigned long int do_spawn _((char *)); +int my_fwrite _((void *, size_t, size_t, FILE *)); +typedef char __VMS_SEPYTOTORP__; /* prototype section end marker */ + +#ifndef VMS_DO_SOCKETS +/***** The following four #defines are temporary, and should be removed, + * along with the corresponding routines in vms.c, when TCP/IP support + * is integrated into the VMS port of perl5. (The temporary hacks are + * here for now so pack can handle type N elements.) + * - C. Bailey 26-Aug-1994 + *****/ +unsigned short int tmp_shortflip _((unsigned short int)); +unsigned long int tmp_longflip _((unsigned long int)); +#define htons(us) tmp_shortflip(us) +#define ntohs(us) tmp_shortflip(us) +#define htonl(ul) tmp_longflip(ul) +#define ntohl(ul) tmp_longflip(ul) +#endif + +#endif /* __vmsish_h_included */ diff --git a/vms/writemain.pl b/vms/writemain.pl new file mode 100644 index 0000000000..38b6670b10 --- /dev/null +++ b/vms/writemain.pl @@ -0,0 +1,52 @@ +#!./miniperl +# +# Create perlmain.c from miniperlmain.c, adding code to boot the +# extensions listed on the command line. +# + +if (-f 'miniperlmain.c') { $dir = ''; } +elsif (-f '../miniperlmain.c') { $dir = '../'; } +else { die "$0: Can't find miniperlmain.c\n"; } + +open (IN,"${dir}miniperlmain.c") + || die "$0: Can't open ${dir}miniperlmain.c: $!\n"; +open (OUT,">${dir}perlmain.c") + || die "$0: Can't open ${dir}perlmain.c: $!\n"; + +while (<IN>) { + s/INTERN\.h/EXTERN\.h/; + print OUT; + last if /Do not delete this line--writemain depends on it/; +} +$ok = !eof(IN); +close IN; + +if (!$ok) { + close OUT; + unlink "${dir}perlmain.c"; + die "$0: Can't find marker line in ${dir}miniperlmain.c - aborting\n"; +} + + +if ($#ARGV > -1) { + print OUT " char *file = __FILE__;\n"; +} + +foreach $ext (@ARGV) { + print OUT "extern void boot_${ext} _((CV* cv));\n" +} + +foreach $ext (@ARGV) { + print "Adding $ext . . .\n"; + if ($ext eq 'DynaLoader') { + # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'! + # boot_DynaLoader is called directly in DynaLoader.pm + print OUT " newXS(\"${ext}::boot_${ext}\", boot_${ext}, file);\n" + } + else { + print OUT " newXS(\"${ext}::bootstrap\", boot_${ext}, file);\n" + } +} + +print OUT "}\n"; +close OUT; diff --git a/writemain b/writemain deleted file mode 100755 index 667030939c..0000000000 --- a/writemain +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/sh -: This script takes the plain miniperlmain.c and writes out perlmain.c -: which includes all the extensions. -: The command line arguments name extensions to be used. -: E.g.: sh writemain SDBM_File POSIX > perlmain.c -: -args="$*" -if test X"$args" = "X" ; then - cat miniperlmain.c -else - sed '/Do not delete this line--writemain depends on it/q' miniperlmain.c - cat << 'EOP' - -#ifdef USE_DYNAMIC_LOADING - boot_DynamicLoader(); -#endif - -EOP - for ext in $args; do - echo " newXSUB(\"${ext}::bootstrap\", 0, boot_${ext}, file);" - done - echo '}' -fi - diff --git a/writemain.SH b/writemain.SH index ea8aeabbd2..d7511e8429 100644 --- a/writemain.SH +++ b/writemain.SH @@ -27,29 +27,68 @@ $startsh : In the following dollars and backticks do not need the extra backslash. $spitshell >>writemain <<'!NO!SUBS!' -: This script takes the plain miniperlmain.c and writes out perlmain.c -: which includes all the extensions. -: The command line arguments name extensions to be used. -: E.g.: sh writemain SDBM_File POSIX > perlmain.c -: -args="$*" -if test X"$args" = "X" ; then - cat miniperlmain.c -else - sed '/Do not delete this line--writemain depends on it/q' miniperlmain.c - cat << 'EOP' - -#ifdef USE_DYNAMIC_LOADING - boot_DynamicLoader(); -#endif +# This script takes the plain miniperlmain.c and writes out perlmain.c +# which includes all the extensions. +# The command line arguments name extensions to be used. +# E.g.: sh writemain SDBM_File POSIX > perlmain.c +# -EOP - for ext in $args; do - echo " newXSUB(\"${ext}::bootstrap\", 0, boot_${ext}, file);" +orig="$*" +args='' +: Remove any .a suffixes and any leading path components +for file in `echo $orig | sed 's/\.a//g'` ; do + case "$file" in + ext/*) file=`echo $file | sed 's:ext/\(.*\)/[^/]*:\1:'` + ;; + */*) + file=`expr X$file : 'X.*/\(.*\)'` + ;; + esac + args="$args $file" +done + + +sed '/Do not delete this line--writemain depends on it/q' miniperlmain.c +if test X"$args" != "X" ; then + echo " char *file = __FILE__;" + ai='' + + for ext in $args ; do + + : $ext will either be 'Name' or 'Name1/Name2' etc + : convert ext into cname and mname + mname=`echo $ext | sed 's!/!::!g'` + cname=`echo $mname | sed 's!:!_!g'` + + echo " { extern void boot_${cname} _((CV* cv));" + if test "$ext" = "DynaLoader"; then + : Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'! + : boot_DynaLoader is called directly in DynaLoader.pm + echo " newXS(\"${mname}::boot_${ext}\", boot_${cname}, file);" + else + echo " newXS(\"${mname}::bootstrap\", boot_${cname}, file);" + fi + # does this extension wish to supply automatic booting code? + for aifile in ext/$ext/AutoInit.* ; do + case $aifile in + *.c)echo " /* autoinit code from $aifile follows: */" + echo " {"; cat $aifile; echo " }" + ;; + *.pl) ai="$ai `cat $aifile | tr '\012' ' '`;" + ;; + esac + done + echo " }" done - echo '}' + if test "X$ai" != "X"; then + echo " autoboot_preamble = \"BEGIN { $ai }\";" + fi fi +cat << 'EOP' +} +EOP + !NO!SUBS! chmod 755 writemain $eunicefix writemain diff --git a/x2p/EXTERN.h b/x2p/EXTERN.h index 6a77ad00cb..e4abe5f87b 100644 --- a/x2p/EXTERN.h +++ b/x2p/EXTERN.h @@ -6,14 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: EXTERN.h,v $ - * Revision 4.1 92/08/07 18:29:05 lwall - * - * Revision 4.0.1.1 91/06/07 12:11:15 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:56:53 lwall - * 4.0 baseline. - * */ #undef EXT diff --git a/x2p/INTERN.h b/x2p/INTERN.h index 64c528272d..aa3af58c8d 100644 --- a/x2p/INTERN.h +++ b/x2p/INTERN.h @@ -6,14 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: INTERN.h,v $ - * Revision 4.1 92/08/07 18:29:06 lwall - * - * Revision 4.0.1.1 91/06/07 12:11:20 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:56:58 lwall - * 4.0 baseline. - * */ #undef EXT diff --git a/x2p/Makefile b/x2p/Makefile deleted file mode 100644 index 6e87e87a23..0000000000 --- a/x2p/Makefile +++ /dev/null @@ -1,134 +0,0 @@ -# $RCSfile: Makefile.SH,v 3314Revision: 4.1 3314Date: 92/08/07 18:29:07 $ -# -# $Log: Makefile.SH,v $ -# Revision 4.1 92/08/07 18:29:07 lwall -# -# Revision 4.0.1.3 92/06/08 16:11:32 lwall -# patch20: SH files didn't work well with symbolic links -# patch20: cray didn't give enough memory to /bin/sh -# patch20: makefiles now display new shift/reduce expectations -# -# Revision 4.0.1.2 91/11/05 19:19:04 lwall -# patch11: random cleanup -# -# Revision 4.0.1.1 91/06/07 12:12:14 lwall -# patch4: cflags now emits entire cc command except for the filename -# -# Revision 4.0 91/03/20 01:57:03 lwall -# 4.0 baseline. -# -# - -CC = cc -YACC = yacc -bin = /usr/local/bin -lib = /usr/local/lib -mansrc = /usr/local/man/man1 -manext = 1 -LDFLAGS = -SMALL = -LARGE = -mallocsrc = malloc.c -mallocobj = malloc.o -shellflags = - -libs = -ldbm -ldl -lm -lposix - -CCCMD = `sh $(shellflags) cflags $@` - -public = a2p s2p find2perl - -private = - -manpages = a2p.man s2p.man - -util = - -sh = Makefile.SH makedepend.SH - -h = EXTERN.h INTERN.h ../config.h handy.h hash.h a2p.h str.h util.h - -c = hash.c $(mallocsrc) str.c util.c walk.c - -obj = hash.o $(mallocobj) str.o util.o walk.o - -lintflags = -phbvxac - -addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 - -# grrr -SHELL = /bin/sh - -.c.o: - $(CCCMD) $*.c - -all: $(public) $(private) $(util) - touch all - -a2p: $(obj) a2p.o - $(CC) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p - -a2p.c: a2p.y - @ echo Expect 231 shift/reduce conflicts... - $(YACC) a2p.y - mv y.tab.c a2p.c - -a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h - $(CCCMD) $(LARGE) a2p.c - -install: a2p s2p -# won't work with csh - export PATH || exit 1 - - mv $(bin)/a2p $(bin)/a2p.old 2>/dev/null - - mv $(bin)/s2p $(bin)/s2p.old 2>/dev/null - - if test `pwd` != $(bin); then cp $(public) $(bin); fi - cd $(bin); \ -for pub in $(public); do \ -chmod +x `basename $$pub`; \ -done - - if test `pwd` != $(mansrc); then \ -for page in $(manpages); do \ -cp $$page $(mansrc)/`basename $$page .man`.$(manext); \ -done; \ -fi - -clean: - rm -f a2p *.o a2p.c - -realclean: clean - rm -f *.orig */*.orig core $(addedbyconf) a2p.c s2p find2perl all cflags - -# The following lint has practically everything turned on. Unfortunately, -# you have to wade through a lot of mumbo jumbo that can't be suppressed. -# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message -# for that spot. - -lint: - lint $(lintflags) $(defs) $(c) > a2p.fuzz - -depend: $(mallocsrc) ../makedepend - ../makedepend - -clist: - echo $(c) | tr ' ' '\012' >.clist - -hlist: - echo $(h) | tr ' ' '\012' >.hlist - -shlist: - echo $(sh) | tr ' ' '\012' >.shlist - -config.sh: ../config.sh - rm -f config.sh - ln ../config.sh . - -malloc.c: ../malloc.c - sed <../malloc.c >malloc.c \ - -e 's/"perl.h"/"..\/perl.h"/' \ - -e 's/my_exit/exit/' - -# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE -$(obj): - @ echo "You haven't done a "'"make depend" yet!'; exit 1 -makedepend: makedepend.SH - /bin/sh $(shellflags) makedepend.SH diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index f3c1a8d3d7..e24a9beb6d 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -1,46 +1,31 @@ -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac case $CONFIG in '') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln -s ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi 2>/dev/null - . ./config.sh - ;; + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; esac +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac + echo "Extracting 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 $ -# Revision 4.1 92/08/07 18:29:07 lwall -# -# Revision 4.0.1.3 92/06/08 16:11:32 lwall -# patch20: SH files didn't work well with symbolic links -# patch20: cray didn't give enough memory to /bin/sh -# patch20: makefiles now display new shift/reduce expectations -# -# Revision 4.0.1.2 91/11/05 19:19:04 lwall -# patch11: random cleanup -# -# Revision 4.0.1.1 91/06/07 12:12:14 lwall -# patch4: cflags now emits entire cc command except for the filename -# -# Revision 4.0 91/03/20 01:57:03 lwall -# 4.0 baseline. -# -# CC = $cc YACC = $yacc -bin = $bin -lib = $lib mansrc = $mansrc manext = $manext LDFLAGS = $ldflags @@ -65,7 +50,7 @@ manpages = a2p.man s2p.man util = -sh = Makefile.SH makedepend.SH +sh = Makefile.SH cflags.SH find2perl.SH s2p.SH h = EXTERN.h INTERN.h ../config.h handy.h hash.h a2p.h str.h util.h @@ -75,8 +60,6 @@ obj = hash.o $(mallocobj) str.o util.o walk.o lintflags = -phbvxac -addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 - # grrr SHELL = /bin/sh @@ -90,34 +73,19 @@ a2p: $(obj) a2p.o $(CC) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p a2p.c: a2p.y - @ echo Expect 231 shift/reduce conflicts... + @ echo Expect many shift/reduce and reduce/reduce conflicts... $(YACC) a2p.y mv y.tab.c a2p.c a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h $(CCCMD) $(LARGE) a2p.c -install: a2p s2p -# won't work with csh - export PATH || exit 1 - - mv $(bin)/a2p $(bin)/a2p.old 2>/dev/null - - mv $(bin)/s2p $(bin)/s2p.old 2>/dev/null - - if test `pwd` != $(bin); then cp $(public) $(bin); fi - cd $(bin); \ -for pub in $(public); do \ -chmod +x `basename $$pub`; \ -done - - if test `pwd` != $(mansrc); then \ -for page in $(manpages); do \ -cp $$page $(mansrc)/`basename $$page .man`.$(manext); \ -done; \ -fi - clean: rm -f a2p *.o a2p.c realclean: clean - rm -f *.orig */*.orig core $(addedbyconf) a2p.c s2p find2perl all cflags + rm -f *.orig */*.orig core $(addedbyconf) a2p.c all + rm -f Makefile cflags find2perl s2p makefile makefile.old # The following lint has practically everything turned on. Unfortunately, # you have to wade through a lot of mumbo jumbo that can't be suppressed. @@ -139,10 +107,6 @@ hlist: shlist: echo $(sh) | tr ' ' '\012' >.shlist -config.sh: ../config.sh - rm -f config.sh - ln ../config.sh . - malloc.c: ../malloc.c sed <../malloc.c >malloc.c \ -e 's/"perl.h"/"..\/perl.h"/' \ @@ -151,8 +115,7 @@ malloc.c: ../malloc.c # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE $(obj): @ echo "You haven't done a "'"make depend" yet!'; exit 1 -makedepend: makedepend.SH - /bin/sh $(shellflags) makedepend.SH +makedepend: depend !NO!SUBS! $eunicefix Makefile case `pwd` in diff --git a/x2p/a2p.c b/x2p/a2p.c deleted file mode 100644 index 41636f0c17..0000000000 --- a/x2p/a2p.c +++ /dev/null @@ -1,1607 +0,0 @@ -extern char *malloc(), *realloc(); - -# line 2 "a2p.y" -/* $RCSfile: a2p.y,v $$Revision: 4.0.1.2 $$Date: 92/06/08 16:13:03 $ - * - * Copyright (c) 1991, Larry Wall - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - * $Log: a2p.y,v $ - * Revision 4.0.1.2 92/06/08 16:13:03 lwall - * patch20: in a2p, getline should allow variable to be array element - * - * Revision 4.0.1.1 91/06/07 12:12:41 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:57:21 lwall - * 4.0 baseline. - * - */ - -#include "INTERN.h" -#include "a2p.h" - -int root; -int begins = Nullop; -int ends = Nullop; - -# define BEGIN 257 -# define END 258 -# define REGEX 259 -# define SEMINEW 260 -# define NEWLINE 261 -# define COMMENT 262 -# define FUN1 263 -# define FUNN 264 -# define GRGR 265 -# define PRINT 266 -# define PRINTF 267 -# define SPRINTF 268 -# define SPLIT 269 -# define IF 270 -# define ELSE 271 -# define WHILE 272 -# define FOR 273 -# define IN 274 -# define EXIT 275 -# define NEXT 276 -# define BREAK 277 -# define CONTINUE 278 -# define RET 279 -# define GETLINE 280 -# define DO 281 -# define SUB 282 -# define GSUB 283 -# define MATCH 284 -# define FUNCTION 285 -# define USERFUN 286 -# define DELETE 287 -# define ASGNOP 288 -# define OROR 289 -# define ANDAND 290 -# define NUMBER 291 -# define VAR 292 -# define SUBSTR 293 -# define INDEX 294 -# define MATCHOP 295 -# define RELOP 296 -# define OR 297 -# define STRING 298 -# define UMINUS 299 -# define NOT 300 -# define INCR 301 -# define DECR 302 -# define FIELD 303 -# define VFIELD 304 -#define yyclearin yychar = -1 -#define yyerrok yyerrflag = 0 -extern int yychar; -extern int yyerrflag; -#ifndef YYMAXDEPTH -#define YYMAXDEPTH 150 -#endif -#ifndef YYSTYPE -#define YYSTYPE int -#endif -YYSTYPE yylval, yyval; -# define YYERRCODE 256 - -# line 402 "a2p.y" - -#include "a2py.c" -int yyexca[] ={ --1, 1, - 0, -1, - -2, 0, - }; -# define YYNPROD 137 -# define YYLAST 3142 -int yyact[]={ - - 63, 44, 156, 32, 50, 31, 222, 73, 74, 75, - 210, 53, 45, 46, 124, 49, 86, 307, 104, 158, - 74, 75, 52, 54, 53, 302, 126, 271, 306, 265, - 106, 107, 270, 245, 51, 157, 269, 21, 56, 92, - 2, 131, 55, 20, 48, 72, 19, 90, 69, 132, - 47, 196, 241, 102, 100, 272, 195, 193, 109, 110, - 111, 112, 253, 76, 79, 252, 72, 139, 15, 77, - 237, 68, 78, 311, 236, 160, 66, 64, 309, 65, - 293, 67, 187, 174, 255, 139, 198, 184, 183, 130, - 68, 80, 179, 129, 5, 66, 64, 71, 65, 128, - 67, 68, 286, 214, 199, 212, 66, 211, 105, 103, - 99, 67, 98, 97, 96, 95, 71, 108, 94, 89, - 88, 152, 87, 4, 153, 10, 9, 200, 69, 14, - 177, 178, 239, 140, 13, 3, 136, 137, 127, 1, - 0, 0, 0, 185, 186, 0, 72, 69, 151, 0, - 0, 154, 0, 0, 0, 0, 0, 0, 69, 0, - 0, 0, 0, 204, 205, 72, 0, 106, 107, 0, - 0, 0, 0, 0, 175, 176, 72, 213, 0, 215, - 76, 0, 140, 0, 0, 0, 77, 0, 0, 78, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 230, 231, 232, 233, 234, 235, 0, - 206, 207, 0, 0, 0, 0, 244, 0, 0, 0, - 159, 106, 107, 34, 35, 0, 162, 163, 37, 39, - 170, 0, 171, 173, 248, 166, 165, 164, 167, 168, - 33, 172, 42, 43, 41, 161, 36, 169, 44, 18, - 247, 27, 44, 38, 40, 54, 53, 249, 28, 45, - 46, 29, 30, 45, 46, 54, 53, 54, 53, 0, - 282, 18, 18, 238, 284, 285, 242, 243, 289, 290, - 54, 53, 240, 91, 54, 53, 0, 299, 300, 54, - 53, 0, 304, 0, 0, 6, 7, 8, 18, 0, - 0, 298, 0, 113, 114, 115, 116, 63, 70, 18, - 32, 310, 31, 313, 312, 315, 314, 316, 0, 18, - 0, 0, 303, 0, 247, 0, 158, 70, 201, 202, - 203, 0, 133, 135, 91, 91, 308, 287, 247, 141, - 143, 144, 145, 146, 147, 149, 91, 0, 0, 91, - 0, 301, 0, 0, 0, 18, 18, 0, 0, 0, - 63, 0, 0, 32, 0, 31, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 181, 158, - 0, 0, 0, 0, 0, 0, 0, 0, 141, 0, - 174, 0, 305, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 91, 91, - 63, 0, 208, 32, 209, 31, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 158, - 0, 219, 220, 0, 221, 0, 223, 225, 226, 227, - 228, 229, 0, 174, 0, 274, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 18, 18, 0, - 246, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 63, 0, 0, 32, 0, 31, 0, 0, - 0, 0, 266, 0, 0, 0, 267, 268, 0, 0, - 0, 158, 0, 174, 0, 217, 275, 0, 276, 0, - 0, 0, 0, 0, 278, 0, 279, 0, 280, 0, - 281, 0, 0, 0, 0, 0, 0, 0, 18, 0, - 0, 0, 0, 0, 0, 0, 0, 159, 0, 0, - 34, 35, 18, 162, 163, 37, 39, 170, 0, 171, - 173, 0, 166, 165, 164, 167, 168, 33, 172, 42, - 43, 41, 0, 36, 169, 174, 0, 216, 27, 44, - 38, 40, 0, 0, 0, 28, 0, 0, 29, 30, - 45, 46, 63, 0, 0, 32, 0, 31, 0, 0, - 159, 0, 0, 34, 35, 0, 162, 163, 37, 39, - 170, 0, 171, 173, 0, 166, 165, 164, 167, 168, - 33, 172, 42, 43, 41, 0, 36, 169, 0, 0, - 0, 27, 44, 38, 40, 0, 0, 0, 28, 0, - 0, 29, 30, 45, 46, 0, 25, 0, 0, 32, - 159, 31, 0, 34, 35, 0, 162, 163, 37, 39, - 170, 0, 171, 173, 0, 166, 165, 164, 167, 168, - 33, 172, 42, 43, 41, 0, 36, 169, 0, 0, - 0, 27, 44, 38, 40, 0, 0, 0, 28, 0, - 0, 29, 30, 45, 46, 63, 0, 0, 32, 0, - 31, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 159, 0, 158, 34, 35, 0, 162, 163, - 37, 39, 170, 0, 171, 173, 0, 166, 165, 164, - 167, 168, 33, 172, 42, 43, 41, 0, 36, 169, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 0, 29, 30, 45, 46, 63, 0, 0, - 32, 0, 31, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 158, 0, 174, 0, - 197, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 63, 0, 0, 32, 138, 31, 0, 0, - 0, 0, 0, 0, 0, 34, 35, 0, 162, 163, - 37, 39, 59, 0, 58, 0, 0, 166, 165, 164, - 167, 168, 33, 0, 42, 43, 41, 0, 36, 169, - 174, 0, 155, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 0, 29, 30, 45, 46, 0, 0, 0, - 0, 0, 0, 0, 0, 24, 0, 106, 107, 34, - 35, 0, 0, 0, 37, 39, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 33, 0, 42, 43, - 41, 0, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 0, 26, 29, 30, 45, - 46, 0, 0, 0, 0, 159, 0, 0, 34, 35, - 0, 162, 163, 37, 39, 170, 0, 171, 173, 0, - 166, 165, 164, 167, 168, 33, 172, 42, 43, 41, - 63, 36, 169, 32, 0, 31, 27, 44, 38, 40, - 0, 0, 0, 28, 0, 0, 29, 30, 45, 46, - 59, 0, 58, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 159, 0, 0, - 34, 35, 0, 162, 163, 37, 39, 170, 0, 171, - 173, 0, 166, 165, 164, 167, 168, 33, 172, 42, - 43, 41, 0, 36, 169, 23, 0, 0, 27, 44, - 38, 40, 0, 0, 0, 28, 0, 0, 29, 30, - 45, 46, 0, 0, 62, 34, 35, 0, 0, 0, - 37, 39, 0, 0, 0, 81, 82, 62, 62, 85, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 62, 27, 44, 38, 40, 60, 57, 0, - 28, 0, 0, 29, 30, 45, 46, 0, 0, 0, - 62, 62, 62, 62, 62, 62, 25, 62, 0, 32, - 0, 31, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, - 62, 62, 62, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 180, 0, 0, 0, 0, 0, 0, 62, - 63, 62, 0, 32, 0, 31, 0, 62, 0, 62, - 62, 62, 62, 62, 0, 62, 0, 0, 0, 12, - 0, 0, 0, 34, 35, 0, 0, 62, 37, 39, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 33, 0, 42, 43, 41, 62, 36, 62, 0, 0, - 0, 27, 44, 38, 40, 60, 57, 0, 28, 0, - 0, 29, 30, 45, 46, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 62, 62, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 62, 62, 62, 0, 62, - 0, 62, 62, 62, 62, 62, 0, 0, 0, 0, - 0, 0, 0, 22, 0, 0, 0, 0, 0, 0, - 0, 0, 62, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 61, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 62, 62, 62, 83, 84, 0, 0, 0, - 0, 62, 62, 0, 62, 62, 62, 62, 0, 0, - 101, 0, 0, 16, 17, 24, 0, 0, 0, 34, - 35, 0, 0, 0, 37, 39, 0, 0, 118, 119, - 120, 121, 122, 123, 0, 125, 33, 0, 42, 43, - 41, 11, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 61, 26, 29, 30, 45, - 46, 0, 25, 0, 0, 32, 0, 31, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 61, 61, 61, - 61, 288, 0, 34, 35, 0, 0, 0, 37, 39, - 0, 0, 0, 0, 0, 0, 0, 61, 0, 61, - 33, 0, 42, 43, 41, 61, 36, 61, 61, 61, - 61, 61, 25, 61, 0, 32, 0, 31, 28, 0, - 0, 29, 30, 45, 46, 61, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 218, 0, 61, 0, 0, 0, 0, - 0, 0, 0, 0, 63, 263, 0, 32, 264, 31, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 61, 61, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 61, 61, 61, 0, 61, 0, 61, - 61, 61, 61, 61, 0, 0, 63, 261, 0, 32, - 262, 31, 0, 0, 0, 0, 0, 0, 0, 0, - 61, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 61, 61, 61, 0, 0, 0, 0, 0, 0, 61, - 61, 0, 61, 61, 61, 61, 63, 259, 0, 32, - 260, 31, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 24, 0, 0, 0, 34, 35, 0, 0, 0, - 37, 39, 63, 257, 0, 32, 258, 31, 0, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 26, 29, 30, 45, 46, 0, 0, 0, - 0, 24, 0, 0, 0, 34, 35, 0, 0, 0, - 37, 39, 63, 251, 0, 32, 250, 31, 0, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 26, 29, 30, 45, 46, 34, 35, 0, - 0, 0, 37, 39, 0, 0, 63, 0, 0, 32, - 0, 31, 0, 0, 33, 0, 42, 43, 41, 0, - 36, 0, 0, 0, 0, 27, 44, 38, 40, 0, - 0, 0, 28, 0, 0, 29, 30, 45, 46, 34, - 35, 0, 0, 0, 37, 39, 0, 0, 0, 0, - 0, 0, 142, 0, 0, 32, 33, 31, 42, 43, - 41, 0, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 0, 0, 29, 30, 45, - 46, 0, 0, 0, 0, 0, 0, 0, 0, 34, - 35, 0, 0, 0, 37, 39, 63, 297, 0, 32, - 0, 31, 0, 0, 0, 0, 33, 0, 42, 43, - 41, 0, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 0, 0, 29, 30, 45, - 46, 0, 0, 0, 0, 34, 35, 0, 0, 0, - 37, 39, 63, 296, 0, 32, 0, 31, 0, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 0, 29, 30, 45, 46, 0, 0, 0, - 0, 0, 0, 0, 0, 34, 35, 0, 0, 0, - 37, 39, 63, 295, 0, 32, 0, 31, 0, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 0, 29, 30, 45, 46, 106, 107, 34, - 35, 0, 0, 0, 37, 39, 63, 294, 0, 32, - 0, 31, 0, 0, 0, 0, 33, 0, 42, 43, - 41, 0, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 0, 0, 29, 30, 45, - 46, 24, 0, 0, 0, 34, 35, 0, 0, 0, - 37, 39, 63, 292, 0, 32, 0, 31, 0, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 26, 29, 30, 45, 46, 0, 0, 34, - 35, 0, 0, 0, 37, 39, 63, 291, 0, 32, - 0, 31, 0, 0, 0, 0, 33, 0, 42, 43, - 41, 0, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 0, 0, 29, 30, 45, - 46, 0, 0, 0, 0, 34, 35, 0, 0, 63, - 37, 39, 32, 0, 31, 0, 0, 0, 0, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 0, 29, 30, 45, 46, 0, 0, 0, - 0, 0, 0, 0, 0, 34, 35, 0, 0, 0, - 37, 39, 283, 63, 0, 0, 32, 0, 31, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 0, 29, 30, 45, 46, 0, 0, 34, - 35, 0, 0, 0, 37, 39, 63, 273, 0, 32, - 0, 31, 0, 0, 0, 0, 33, 0, 42, 43, - 41, 0, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 0, 0, 29, 30, 45, - 46, 0, 0, 0, 0, 34, 35, 0, 0, 0, - 37, 39, 63, 256, 0, 32, 0, 31, 0, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 0, 29, 30, 45, 46, 0, 0, 34, - 35, 0, 0, 0, 37, 39, 63, 254, 0, 32, - 0, 31, 0, 0, 0, 0, 33, 0, 42, 43, - 41, 0, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 0, 0, 29, 30, 45, - 46, 0, 34, 35, 0, 0, 0, 37, 39, 0, - 0, 0, 63, 0, 0, 32, 0, 31, 0, 33, - 0, 42, 43, 41, 0, 36, 0, 0, 0, 0, - 27, 44, 38, 40, 0, 0, 0, 28, 0, 0, - 29, 30, 45, 46, 0, 0, 0, 0, 0, 0, - 0, 0, 277, 0, 0, 63, 34, 35, 32, 194, - 31, 37, 39, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 33, 0, 42, 43, 41, 0, 36, - 0, 0, 0, 0, 27, 44, 38, 40, 0, 0, - 0, 28, 0, 0, 29, 30, 45, 46, 63, 34, - 35, 32, 192, 31, 37, 39, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 33, 0, 42, 43, - 41, 0, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 0, 0, 29, 30, 45, - 46, 0, 0, 0, 63, 34, 35, 32, 191, 31, - 37, 39, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 0, 29, 30, 45, 46, 0, 63, 34, - 35, 32, 190, 31, 37, 39, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 33, 0, 42, 43, - 41, 0, 36, 0, 0, 0, 0, 27, 44, 38, - 40, 0, 0, 0, 28, 0, 0, 29, 30, 45, - 46, 224, 0, 0, 63, 34, 35, 32, 189, 31, - 37, 39, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 33, 0, 42, 43, 41, 0, 36, 0, - 0, 0, 0, 27, 44, 38, 40, 0, 0, 0, - 28, 0, 0, 29, 30, 45, 46, 63, 34, 35, - 32, 188, 31, 37, 39, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 33, 0, 42, 43, 41, - 0, 36, 0, 0, 0, 0, 27, 44, 38, 40, - 0, 0, 0, 28, 0, 0, 29, 30, 45, 46, - 0, 34, 35, 0, 0, 0, 37, 39, 63, 182, - 0, 32, 0, 31, 0, 0, 0, 0, 33, 0, - 42, 43, 41, 0, 36, 0, 0, 0, 0, 27, - 44, 38, 40, 0, 0, 0, 28, 0, 0, 29, - 30, 45, 46, 0, 0, 0, 0, 34, 35, 0, - 0, 0, 37, 39, 63, 0, 0, 32, 0, 31, - 0, 0, 0, 0, 33, 0, 42, 43, 41, 0, - 36, 0, 0, 0, 0, 27, 44, 38, 40, 0, - 0, 0, 28, 0, 0, 29, 30, 45, 46, 0, - 0, 34, 35, 0, 0, 0, 37, 39, 0, 0, - 63, 0, 0, 32, 0, 31, 0, 0, 33, 0, - 42, 43, 41, 0, 36, 0, 0, 0, 0, 27, - 44, 38, 40, 0, 0, 0, 28, 0, 0, 29, - 30, 45, 46, 0, 0, 0, 0, 34, 35, 0, - 0, 0, 37, 39, 63, 0, 0, 32, 138, 31, - 0, 0, 0, 0, 33, 0, 42, 43, 41, 0, - 36, 0, 0, 0, 0, 27, 44, 38, 40, 0, - 0, 0, 28, 0, 0, 29, 30, 45, 46, 0, - 34, 35, 0, 0, 0, 37, 39, 63, 134, 0, - 32, 0, 31, 0, 0, 0, 0, 33, 0, 42, - 43, 41, 0, 36, 0, 0, 0, 0, 27, 44, - 38, 40, 0, 0, 0, 28, 0, 0, 29, 30, - 45, 46, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 34, 35, 0, 0, 63, 37, 39, 32, 0, - 31, 0, 0, 0, 0, 0, 0, 0, 33, 0, - 42, 43, 41, 0, 36, 0, 0, 0, 0, 27, - 44, 38, 40, 0, 0, 0, 28, 0, 0, 29, - 30, 45, 46, 150, 0, 0, 0, 34, 35, 0, - 0, 63, 37, 39, 32, 0, 31, 0, 0, 0, - 0, 0, 0, 0, 33, 0, 42, 43, 41, 0, - 36, 0, 0, 0, 0, 27, 44, 38, 40, 0, - 0, 0, 28, 0, 0, 29, 30, 45, 46, 148, - 0, 0, 0, 34, 35, 0, 0, 93, 37, 39, - 32, 0, 31, 0, 0, 0, 0, 0, 0, 0, - 33, 0, 42, 43, 41, 0, 36, 0, 0, 0, - 0, 27, 44, 38, 40, 0, 0, 0, 28, 0, - 0, 29, 30, 45, 46, 0, 0, 34, 35, 0, - 0, 0, 37, 39, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 33, 0, 42, 43, 41, 0, - 36, 0, 0, 0, 0, 27, 44, 38, 40, 0, - 0, 0, 28, 0, 0, 29, 30, 45, 46, 0, - 34, 35, 0, 0, 0, 37, 39, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 33, 0, 42, - 43, 41, 0, 36, 0, 0, 0, 0, 27, 44, - 38, 40, 0, 0, 0, 28, 0, 0, 29, 30, - 45, 46, 0, 0, 117, 0, 0, 0, 34, 35, - 0, 0, 0, 37, 39, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 33, 0, 42, 43, 41, - 0, 36, 0, 0, 0, 0, 27, 44, 38, 40, - 0, 0, 0, 28, 0, 0, 29, 30, 45, 46, - 0, 0, 0, 0, 34, 35, 0, 0, 0, 37, - 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 33, 0, 42, 43, 41, 0, 36, 0, 0, - 0, 0, 27, 44, 38, 40, 0, 0, 0, 28, - 0, 0, 29, 30, 45, 46, 0, 0, 0, 0, - 34, 35, 0, 0, 0, 37, 39, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 33, 0, 42, - 43, 41, 0, 36, 0, 0, 0, 0, 27, 44, - 38, 40, 0, 0, 0, 28, 0, 0, 29, 30, - 45, 46 }; -int yypact[]={ - - -1000, -1000, 35, 1016, -1000, -1000, -1000, -1000, -1000, -1000, - -79, -271, -1000, -1000, -227, -22, -81, -85, 880, -1000, - -1000, -1000, 53, -281, -1000, 1332, 1332, -1000, -1000, -291, - -291, 2791, 2791, -44, 82, 80, 79, 2837, 78, 75, - 74, 73, 72, 70, -37, -1000, 2791, 35, -1000, 69, - -231, -1000, 1332, -1000, -1000, -1000, -1000, 2791, 2791, 2791, - 2745, 53, -293, 1332, 2791, 2791, 2791, 2791, 2791, 2791, - -278, 2791, -254, 1332, -1000, -1000, 58, 52, 48, 0, - -1000, -1000, -1000, -46, -46, -11, 2791, 2697, 2837, 2837, - -1000, 2654, 23, 1652, 2791, 2791, 2791, 2791, 2610, 2564, - 2837, -67, -231, 2837, 697, -1000, -1000, -1000, -266, 586, - 586, -231, -231, 1080, 1080, 1080, 1080, -1000, 64, 64, - -46, -46, -46, -46, -1000, 34, -291, -266, -1000, -1000, - -1000, -1000, 2791, 1080, -1000, 2518, 47, 46, -1000, -1000, - 41, 742, 1652, 2467, 2424, 2378, 2334, 2288, 13, 2245, - 12, -42, 635, 45, -1000, -1000, -1000, 68, -1000, -1000, - -1000, 2791, 2837, 2837, -1000, -1000, 2791, -1000, 2791, -282, - 67, 65, -1000, 63, -1000, -1000, -279, 432, 370, 2791, - -1000, 1080, -1000, -1000, -1000, 1606, 1606, -1000, 2791, -286, - 2791, 2202, 2791, 2791, 2791, 2791, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -231, -231, 8, 8, 2791, 2791, - -39, 1332, 1332, -40, 532, -231, -1000, -1000, 53, 2791, - 2791, 1562, 21, 2156, 43, 2112, 1512, 1466, 1416, 1374, - -94, -231, -231, -231, -231, -231, 2791, -1000, -1000, -1000, - 2791, 2791, -5, -9, -245, -4, 2066, -1000, 320, 35, - 2791, -1000, 2023, -1000, -1000, -1000, -1000, -1000, 2791, -1000, - 2791, -1000, 2791, -1000, 2791, -1000, 2791, 2791, 1969, -1000, - -1000, 62, 1282, -1000, -1000, 1926, 1882, 39, 1836, 1792, - 1742, 1696, -231, -1000, -40, -40, 1332, -34, 532, -40, - -231, -1000, -1000, -1000, -1000, -1000, -1000, -1000, 267, -243, - -1000, -24, 532, 37, -1000, -1000, -1000, -1000, 32, -1000, - -40, -1000, -40, -1000, -40, -1000, -1000 }; -int yypgo[]={ - - 0, 139, 40, 135, 134, 4, 18, 129, 126, 125, - 124, 47, 64, 245, 46, 43, 37, 1223, 985, 39, - 123, 108, 104, 2, 35, 75, 33, 74 }; -int yyr1[]={ - - 0, 1, 4, 7, 7, 3, 3, 8, 8, 8, - 8, 8, 8, 10, 9, 9, 12, 12, 12, 12, - 16, 16, 16, 16, 15, 15, 15, 15, 14, 14, - 14, 14, 13, 13, 13, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 18, 18, 18, 18, 11, 11, 11, 19, 19, - 19, 2, 2, 20, 20, 20, 20, 5, 5, 21, - 21, 22, 22, 22, 22, 6, 6, 23, 23, 23, - 23, 26, 26, 24, 24, 24, 24, 24, 24, 24, - 24, 24, 24, 24, 24, 24, 27, 27, 27, 25, - 25, 25, 25, 25, 25, 25, 25 }; -int yyr2[]={ - - 0, 5, 13, 11, 5, 7, 1, 3, 11, 21, - 9, 2, 2, 3, 3, 7, 2, 2, 2, 2, - 7, 9, 9, 5, 7, 7, 7, 7, 7, 7, - 3, 7, 3, 5, 7, 3, 3, 3, 7, 7, - 7, 7, 7, 7, 7, 11, 5, 5, 5, 5, - 5, 5, 7, 3, 5, 7, 9, 7, 9, 3, - 7, 9, 9, 9, 5, 17, 13, 17, 17, 13, - 13, 13, 13, 13, 13, 13, 13, 17, 17, 17, - 17, 3, 9, 3, 5, 2, 2, 1, 9, 9, - 7, 5, 1, 3, 3, 3, 3, 5, 1, 3, - 3, 5, 5, 5, 5, 5, 1, 7, 5, 5, - 2, 2, 1, 2, 9, 5, 9, 5, 3, 3, - 3, 5, 3, 3, 5, 11, 3, 3, 3, 13, - 19, 13, 15, 21, 19, 13, 11 }; -int yychk[]={ - - -1000, -1, -2, -3, -20, 59, 260, 261, 262, -8, - -9, 285, 123, -4, -7, -12, 257, 258, -13, -14, - -15, -16, -17, -18, 259, 40, 300, 291, 298, 301, - 302, 45, 43, 280, 263, 264, 286, 268, 293, 269, - 294, 284, 282, 283, 292, 303, 304, -2, 123, 286, - -5, 261, 44, 290, 289, 123, 123, 296, 62, 60, - 295, -17, -18, 40, 43, 45, 42, 47, 37, 94, - 274, 63, 112, 288, 301, 302, -16, -15, -14, -12, - -12, -18, -18, -17, -17, -18, 60, 40, 40, 40, - -11, -13, -19, 40, 40, 40, 40, 40, 40, 40, - 91, -17, -5, 40, -6, -21, 261, 262, -12, -5, - -5, -5, -5, -13, -13, -13, -13, 259, -17, -17, - -17, -17, -17, -17, 292, -17, 280, -12, 41, 41, - 41, 41, 60, -13, 41, -13, -11, -11, 44, 44, - -19, -13, 40, -13, -13, -13, -13, -13, 259, -13, - 259, -11, -6, -10, -11, 125, -23, -24, 59, 260, - -25, -13, 266, 267, 277, 276, 275, 278, 279, 287, - 270, 272, 281, 273, 123, -12, -12, -6, -6, 58, - -18, -13, 41, 41, 41, -5, -5, 41, 44, 44, - 44, 44, 44, 44, 44, 44, 93, 125, 41, -22, - 59, 260, 261, 262, -5, -5, -11, -11, -13, -13, - 292, 40, 40, -5, 40, -5, 125, 125, -17, -13, - -13, -13, 292, -13, 259, -13, -13, -13, -13, -13, - -5, -5, -5, -5, -5, -5, -27, 62, 265, 124, - -27, 91, -12, -12, -23, -26, -13, -24, -6, -2, - 44, 41, 44, 41, 41, 41, 41, 41, 44, 41, - 44, 41, 44, 41, 44, 123, -13, -13, -13, 41, - 41, 272, 59, 41, 125, -13, -13, 259, -13, -13, - -13, -13, -5, 93, -5, -5, 40, -12, 59, -5, - -5, 41, 41, 41, 41, 41, 41, 41, -6, -23, - -23, -12, 59, -26, -23, 125, 271, 41, -26, 41, - -5, 41, -5, -23, -5, -23, -23 }; -int yydef[]={ - - 92, -2, 6, 1, 91, 93, 94, 95, 96, 92, - 7, 0, 98, 11, 12, 14, 0, 0, 16, 17, - 18, 19, 32, 35, 30, 0, 0, 36, 37, 0, - 0, 0, 0, 53, 59, 0, 0, 87, 0, 0, - 0, 0, 0, 0, 81, 83, 0, 5, 98, 0, - 106, 4, 0, 98, 98, 98, 98, 0, 0, 0, - 0, 33, 35, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 46, 47, 19, 18, 17, 0, - 23, 48, 49, 50, 51, 54, 0, 0, 87, 87, - 64, 85, 86, 0, 0, 0, 0, 0, 0, 0, - 87, 84, 106, 87, 0, 97, 99, 100, 15, 0, - 0, 106, 106, 24, 25, 26, 28, 29, 38, 39, - 40, 41, 42, 43, 44, 0, 57, 34, 20, 27, - 31, 52, 0, 55, 60, 0, 0, 0, 98, 98, - 0, 16, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 13, 10, 105, 0, 98, 98, - 110, 113, 87, 87, 118, 119, 120, 122, 123, 0, - 0, 0, 98, 0, 98, 21, 22, 0, 0, 0, - 58, 56, 61, 62, 63, 0, 0, 90, 0, 0, - 0, 0, 0, 0, 0, 0, 82, 8, 98, 98, - 98, 98, 98, 98, 108, 109, 115, 117, 121, 124, - 0, 0, 0, 0, 112, 106, 92, 3, 45, 88, - 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 107, 101, 102, 103, 104, 0, 126, 127, 128, - 0, 0, 0, 0, 0, 0, 113, 111, 0, 2, - 0, 66, 0, 69, 70, 71, 72, 73, 0, 74, - 0, 75, 0, 76, 0, 98, 114, 116, 0, 98, - 98, 0, 0, 98, 98, 0, 0, 0, 0, 0, - 0, 0, 106, 125, 0, 0, 0, 0, 112, 0, - 136, 65, 67, 68, 77, 78, 79, 80, 0, 129, - 131, 0, 112, 0, 135, 9, 98, 132, 0, 98, - 0, 98, 0, 130, 0, 134, 133 }; -typedef struct { char *t_name; int t_val; } yytoktype; -#ifndef YYDEBUG -# define YYDEBUG 0 /* don't allow debugging */ -#endif - -#if YYDEBUG - -yytoktype yytoks[] = -{ - "BEGIN", 257, - "END", 258, - "REGEX", 259, - "SEMINEW", 260, - "NEWLINE", 261, - "COMMENT", 262, - "FUN1", 263, - "FUNN", 264, - "GRGR", 265, - "PRINT", 266, - "PRINTF", 267, - "SPRINTF", 268, - "SPLIT", 269, - "IF", 270, - "ELSE", 271, - "WHILE", 272, - "FOR", 273, - "IN", 274, - "EXIT", 275, - "NEXT", 276, - "BREAK", 277, - "CONTINUE", 278, - "RET", 279, - "GETLINE", 280, - "DO", 281, - "SUB", 282, - "GSUB", 283, - "MATCH", 284, - "FUNCTION", 285, - "USERFUN", 286, - "DELETE", 287, - "ASGNOP", 288, - "?", 63, - ":", 58, - "OROR", 289, - "ANDAND", 290, - "NUMBER", 291, - "VAR", 292, - "SUBSTR", 293, - "INDEX", 294, - "MATCHOP", 295, - "RELOP", 296, - "<", 60, - ">", 62, - "OR", 297, - "STRING", 298, - "+", 43, - "-", 45, - "*", 42, - "/", 47, - "%", 37, - "UMINUS", 299, - "NOT", 300, - "^", 94, - "INCR", 301, - "DECR", 302, - "FIELD", 303, - "VFIELD", 304, - "-unknown-", -1 /* ends search */ -}; - -char * yyreds[] = -{ - "-no such reduction-", - "program : junk hunks", - "begin : BEGIN '{' maybe states '}' junk", - "end : END '{' maybe states '}'", - "end : end NEWLINE", - "hunks : hunks hunk junk", - "hunks : /* empty */", - "hunk : patpat", - "hunk : patpat '{' maybe states '}'", - "hunk : FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}'", - "hunk : '{' maybe states '}'", - "hunk : begin", - "hunk : end", - "arg_list : expr_list", - "patpat : cond", - "patpat : cond ',' cond", - "cond : expr", - "cond : match", - "cond : rel", - "cond : compound_cond", - "compound_cond : '(' compound_cond ')'", - "compound_cond : cond ANDAND maybe cond", - "compound_cond : cond OROR maybe cond", - "compound_cond : NOT cond", - "rel : expr RELOP expr", - "rel : expr '>' expr", - "rel : expr '<' expr", - "rel : '(' rel ')'", - "match : expr MATCHOP expr", - "match : expr MATCHOP REGEX", - "match : REGEX", - "match : '(' match ')'", - "expr : term", - "expr : expr term", - "expr : variable ASGNOP cond", - "term : variable", - "term : NUMBER", - "term : STRING", - "term : term '+' term", - "term : term '-' term", - "term : term '*' term", - "term : term '/' term", - "term : term '%' term", - "term : term '^' term", - "term : term IN VAR", - "term : term '?' term ':' term", - "term : variable INCR", - "term : variable DECR", - "term : INCR variable", - "term : DECR variable", - "term : '-' term", - "term : '+' term", - "term : '(' cond ')'", - "term : GETLINE", - "term : GETLINE variable", - "term : GETLINE '<' expr", - "term : GETLINE variable '<' expr", - "term : term 'p' GETLINE", - "term : term 'p' GETLINE variable", - "term : FUN1", - "term : FUN1 '(' ')'", - "term : FUN1 '(' expr ')'", - "term : FUNN '(' expr_list ')'", - "term : USERFUN '(' expr_list ')'", - "term : SPRINTF expr_list", - "term : SUBSTR '(' expr ',' expr ',' expr ')'", - "term : SUBSTR '(' expr ',' expr ')'", - "term : SPLIT '(' expr ',' VAR ',' expr ')'", - "term : SPLIT '(' expr ',' VAR ',' REGEX ')'", - "term : SPLIT '(' expr ',' VAR ')'", - "term : INDEX '(' expr ',' expr ')'", - "term : MATCH '(' expr ',' REGEX ')'", - "term : MATCH '(' expr ',' expr ')'", - "term : SUB '(' expr ',' expr ')'", - "term : SUB '(' REGEX ',' expr ')'", - "term : GSUB '(' expr ',' expr ')'", - "term : GSUB '(' REGEX ',' expr ')'", - "term : SUB '(' expr ',' expr ',' expr ')'", - "term : SUB '(' REGEX ',' expr ',' expr ')'", - "term : GSUB '(' expr ',' expr ',' expr ')'", - "term : GSUB '(' REGEX ',' expr ',' expr ')'", - "variable : VAR", - "variable : VAR '[' expr_list ']'", - "variable : FIELD", - "variable : VFIELD term", - "expr_list : expr", - "expr_list : clist", - "expr_list : /* empty */", - "clist : expr ',' maybe expr", - "clist : clist ',' maybe expr", - "clist : '(' clist ')'", - "junk : junk hunksep", - "junk : /* empty */", - "hunksep : ';'", - "hunksep : SEMINEW", - "hunksep : NEWLINE", - "hunksep : COMMENT", - "maybe : maybe nlstuff", - "maybe : /* empty */", - "nlstuff : NEWLINE", - "nlstuff : COMMENT", - "separator : ';' maybe", - "separator : SEMINEW maybe", - "separator : NEWLINE maybe", - "separator : COMMENT maybe", - "states : states statement", - "states : /* empty */", - "statement : simple separator maybe", - "statement : ';' maybe", - "statement : SEMINEW maybe", - "statement : compound", - "simpnull : simple", - "simpnull : /* empty */", - "simple : expr", - "simple : PRINT expr_list redir expr", - "simple : PRINT expr_list", - "simple : PRINTF expr_list redir expr", - "simple : PRINTF expr_list", - "simple : BREAK", - "simple : NEXT", - "simple : EXIT", - "simple : EXIT expr", - "simple : CONTINUE", - "simple : RET", - "simple : RET expr", - "simple : DELETE VAR '[' expr ']'", - "redir : '>'", - "redir : GRGR", - "redir : '|'", - "compound : IF '(' cond ')' maybe statement", - "compound : IF '(' cond ')' maybe statement ELSE maybe statement", - "compound : WHILE '(' cond ')' maybe statement", - "compound : DO maybe statement WHILE '(' cond ')'", - "compound : FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement", - "compound : FOR '(' simpnull ';' ';' simpnull ')' maybe statement", - "compound : FOR '(' expr ')' maybe statement", - "compound : '{' maybe states '}' maybe", -}; -#endif /* YYDEBUG */ -#line 1 "/usr/lib/yaccpar" -/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */ - -/* -** Skeleton parser driver for yacc output -*/ - -/* -** yacc user known macros and defines -*/ -#define YYERROR goto yyerrlab -#define YYACCEPT { free(yys); free(yyv); return(0); } -#define YYABORT { free(yys); free(yyv); return(1); } -#define YYBACKUP( newtoken, newvalue )\ -{\ - if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\ - {\ - yyerror( "syntax error - cannot backup" );\ - goto yyerrlab;\ - }\ - yychar = newtoken;\ - yystate = *yyps;\ - yylval = newvalue;\ - goto yynewstate;\ -} -#define YYRECOVERING() (!!yyerrflag) -#ifndef YYDEBUG -# define YYDEBUG 1 /* make debugging available */ -#endif - -/* -** user known globals -*/ -int yydebug; /* set to 1 to get debugging */ - -/* -** driver internal defines -*/ -#define YYFLAG (-1000) - -/* -** static variables used by the parser -*/ -static YYSTYPE *yyv; /* value stack */ -static int *yys; /* state stack */ - -static YYSTYPE *yypv; /* top of value stack */ -static int *yyps; /* top of state stack */ - -static int yystate; /* current state */ -static int yytmp; /* extra var (lasts between blocks) */ - -int yynerrs; /* number of errors */ - -int yyerrflag; /* error recovery flag */ -int yychar; /* current input token number */ - - -/* -** yyparse - return 0 if worked, 1 if syntax error not recovered from -*/ -int -yyparse() -{ - register YYSTYPE *yypvt; /* top of value stack for $vars */ - unsigned yymaxdepth = YYMAXDEPTH; - - /* - ** Initialize externals - yyparse may be called more than once - */ - yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE)); - yys = (int*)malloc(yymaxdepth*sizeof(int)); - if (!yyv || !yys) - { - yyerror( "out of memory" ); - return(1); - } - yypv = &yyv[-1]; - yyps = &yys[-1]; - yystate = 0; - yytmp = 0; - yynerrs = 0; - yyerrflag = 0; - yychar = -1; - - goto yystack; - { - register YYSTYPE *yy_pv; /* top of value stack */ - register int *yy_ps; /* top of state stack */ - register int yy_state; /* current state */ - register int yy_n; /* internal state number info */ - - /* - ** get globals into registers. - ** branch to here only if YYBACKUP was called. - */ - yynewstate: - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - goto yy_newstate; - - /* - ** get globals into registers. - ** either we just started, or we just finished a reduction - */ - yystack: - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - - /* - ** top of for (;;) loop while no reductions done - */ - yy_stack: - /* - ** put a state and value onto the stacks - */ -#if YYDEBUG - /* - ** if debugging, look up token value in list of value vs. - ** name pairs. 0 and negative (-1) are special values. - ** Note: linear search is used since time is not a real - ** consideration while debugging. - */ - if ( yydebug ) - { - register int yy_i; - - (void)printf( "State %d, token ", yy_state ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif /* YYDEBUG */ - if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */ - { - /* - ** reallocate and recover. Note that pointers - ** have to be reset, or bad things will happen - */ - int yyps_index = (yy_ps - yys); - int yypv_index = (yy_pv - yyv); - int yypvt_index = (yypvt - yyv); - yymaxdepth += YYMAXDEPTH; - yyv = (YYSTYPE*)realloc((char*)yyv, - yymaxdepth * sizeof(YYSTYPE)); - yys = (int*)realloc((char*)yys, - yymaxdepth * sizeof(int)); - if (!yyv || !yys) - { - yyerror( "yacc stack overflow" ); - return(1); - } - yy_ps = yys + yyps_index; - yy_pv = yyv + yypv_index; - yypvt = yyv + yypvt_index; - } - *yy_ps = yy_state; - *++yy_pv = yyval; - - /* - ** we have a new state - find out what to do - */ - yy_newstate: - if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG ) - goto yydefault; /* simple state */ -#if YYDEBUG - /* - ** if debugging, need to mark whether new token grabbed - */ - yytmp = yychar < 0; -#endif - if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) - yychar = 0; /* reached EOF */ -#if YYDEBUG - if ( yydebug && yytmp ) - { - register int yy_i; - - (void)printf( "Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif /* YYDEBUG */ - if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) ) - goto yydefault; - if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/ - { - yychar = -1; - yyval = yylval; - yy_state = yy_n; - if ( yyerrflag > 0 ) - yyerrflag--; - goto yy_stack; - } - - yydefault: - if ( ( yy_n = yydef[ yy_state ] ) == -2 ) - { -#if YYDEBUG - yytmp = yychar < 0; -#endif - if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) - yychar = 0; /* reached EOF */ -#if YYDEBUG - if ( yydebug && yytmp ) - { - register int yy_i; - - (void)printf( "Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; - yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val - == yychar ) - { - break; - } - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif /* YYDEBUG */ - /* - ** look through exception table - */ - { - register int *yyxi = yyexca; - - while ( ( *yyxi != -1 ) || - ( yyxi[1] != yy_state ) ) - { - yyxi += 2; - } - while ( ( *(yyxi += 2) >= 0 ) && - ( *yyxi != yychar ) ) - ; - if ( ( yy_n = yyxi[1] ) < 0 ) - YYACCEPT; - } - } - - /* - ** check for syntax error - */ - if ( yy_n == 0 ) /* have an error */ - { - /* no worry about speed here! */ - switch ( yyerrflag ) - { - case 0: /* new error */ - yyerror( "syntax error" ); - goto skip_init; - yyerrlab: - /* - ** get globals into registers. - ** we have a user generated syntax type error - */ - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - yynerrs++; - skip_init: - case 1: - case 2: /* incompletely recovered error */ - /* try again... */ - yyerrflag = 3; - /* - ** find state where "error" is a legal - ** shift action - */ - while ( yy_ps >= yys ) - { - yy_n = yypact[ *yy_ps ] + YYERRCODE; - if ( yy_n >= 0 && yy_n < YYLAST && - yychk[yyact[yy_n]] == YYERRCODE) { - /* - ** simulate shift of "error" - */ - yy_state = yyact[ yy_n ]; - goto yy_stack; - } - /* - ** current state has no shift on - ** "error", pop stack - */ -#if YYDEBUG -# define _POP_ "Error recovery pops state %d, uncovers state %d\n" - if ( yydebug ) - (void)printf( _POP_, *yy_ps, - yy_ps[-1] ); -# undef _POP_ -#endif - yy_ps--; - yy_pv--; - } - /* - ** there is no state on stack with "error" as - ** a valid shift. give up. - */ - YYABORT; - case 3: /* no shift yet; eat a token */ -#if YYDEBUG - /* - ** if debugging, look up token in list of - ** pairs. 0 and negative shouldn't occur, - ** but since timing doesn't matter when - ** debugging, it doesn't hurt to leave the - ** tests here. - */ - if ( yydebug ) - { - register int yy_i; - - (void)printf( "Error recovery discards " ); - if ( yychar == 0 ) - (void)printf( "token end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "token -none-\n" ); - else - { - for ( yy_i = 0; - yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val - == yychar ) - { - break; - } - } - (void)printf( "token %s\n", - yytoks[yy_i].t_name ); - } - } -#endif /* YYDEBUG */ - if ( yychar == 0 ) /* reached EOF. quit */ - YYABORT; - yychar = -1; - goto yy_newstate; - } - }/* end if ( yy_n == 0 ) */ - /* - ** reduction by production yy_n - ** put stack tops, etc. so things right after switch - */ -#if YYDEBUG - /* - ** if debugging, print the string that is the user's - ** specification of the reduction which is just about - ** to be done. - */ - if ( yydebug ) - (void)printf( "Reduce by (%d) \"%s\"\n", - yy_n, yyreds[ yy_n ] ); -#endif - yytmp = yy_n; /* value to switch over */ - yypvt = yy_pv; /* $vars top of value stack */ - /* - ** Look in goto table for next state - ** Sorry about using yy_state here as temporary - ** register variable, but why not, if it works... - ** If yyr2[ yy_n ] doesn't have the low order bit - ** set, then there is no action to be done for - ** this reduction. So, no saving & unsaving of - ** registers done. The only difference between the - ** code just after the if and the body of the if is - ** the goto yy_stack in the body. This way the test - ** can be made before the choice of what to do is needed. - */ - { - /* length of production doubled with extra bit */ - register int yy_len = yyr2[ yy_n ]; - - if ( !( yy_len & 01 ) ) - { - yy_len >>= 1; - yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ - yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + - *( yy_ps -= yy_len ) + 1; - if ( yy_state >= YYLAST || - yychk[ yy_state = - yyact[ yy_state ] ] != -yy_n ) - { - yy_state = yyact[ yypgo[ yy_n ] ]; - } - goto yy_stack; - } - yy_len >>= 1; - yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ - yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + - *( yy_ps -= yy_len ) + 1; - if ( yy_state >= YYLAST || - yychk[ yy_state = yyact[ yy_state ] ] != -yy_n ) - { - yy_state = yyact[ yypgo[ yy_n ] ]; - } - } - /* save until reenter driver code */ - yystate = yy_state; - yyps = yy_ps; - yypv = yy_pv; - } - /* - ** code supplied by user is placed in this switch - */ - switch( yytmp ) - { - -case 1: -# line 60 "a2p.y" -{ root = oper4(OPROG,yypvt[-1],begins,yypvt[-0],ends); } break; -case 2: -# line 64 "a2p.y" -{ begins = oper4(OJUNK,begins,yypvt[-3],yypvt[-2],yypvt[-0]); in_begin = FALSE; - yyval = Nullop; } break; -case 3: -# line 69 "a2p.y" -{ ends = oper3(OJUNK,ends,yypvt[-2],yypvt[-1]); yyval = Nullop; } break; -case 4: -# line 71 "a2p.y" -{ yyval = yypvt[-1]; } break; -case 5: -# line 75 "a2p.y" -{ yyval = oper3(OHUNKS,yypvt[-2],yypvt[-1],yypvt[-0]); } break; -case 6: -# line 77 "a2p.y" -{ yyval = Nullop; } break; -case 7: -# line 81 "a2p.y" -{ yyval = oper1(OHUNK,yypvt[-0]); need_entire = TRUE; } break; -case 8: -# line 83 "a2p.y" -{ yyval = oper2(OHUNK,yypvt[-4],oper2(OJUNK,yypvt[-2],yypvt[-1])); } break; -case 9: -# line 85 "a2p.y" -{ fixfargs(yypvt[-8],yypvt[-6],0); yyval = oper5(OUSERDEF,yypvt[-8],yypvt[-6],yypvt[-4],yypvt[-2],yypvt[-1]); } break; -case 10: -# line 87 "a2p.y" -{ yyval = oper2(OHUNK,Nullop,oper2(OJUNK,yypvt[-2],yypvt[-1])); } break; -case 13: -# line 93 "a2p.y" -{ yyval = rememberargs(yyval); } break; -case 14: -# line 97 "a2p.y" -{ yyval = oper1(OPAT,yypvt[-0]); } break; -case 15: -# line 99 "a2p.y" -{ yyval = oper2(ORANGE,yypvt[-2],yypvt[-0]); } break; -case 20: -# line 110 "a2p.y" -{ yyval = oper1(OCPAREN,yypvt[-1]); } break; -case 21: -# line 112 "a2p.y" -{ yyval = oper3(OCANDAND,yypvt[-3],yypvt[-1],yypvt[-0]); } break; -case 22: -# line 114 "a2p.y" -{ yyval = oper3(OCOROR,yypvt[-3],yypvt[-1],yypvt[-0]); } break; -case 23: -# line 116 "a2p.y" -{ yyval = oper1(OCNOT,yypvt[-0]); } break; -case 24: -# line 120 "a2p.y" -{ yyval = oper3(ORELOP,yypvt[-1],yypvt[-2],yypvt[-0]); } break; -case 25: -# line 122 "a2p.y" -{ yyval = oper3(ORELOP,string(">",1),yypvt[-2],yypvt[-0]); } break; -case 26: -# line 124 "a2p.y" -{ yyval = oper3(ORELOP,string("<",1),yypvt[-2],yypvt[-0]); } break; -case 27: -# line 126 "a2p.y" -{ yyval = oper1(ORPAREN,yypvt[-1]); } break; -case 28: -# line 130 "a2p.y" -{ yyval = oper3(OMATCHOP,yypvt[-1],yypvt[-2],yypvt[-0]); } break; -case 29: -# line 132 "a2p.y" -{ yyval = oper3(OMATCHOP,yypvt[-1],yypvt[-2],oper1(OREGEX,yypvt[-0])); } break; -case 30: -# line 134 "a2p.y" -{ yyval = oper1(OREGEX,yypvt[-0]); } break; -case 31: -# line 136 "a2p.y" -{ yyval = oper1(OMPAREN,yypvt[-1]); } break; -case 32: -# line 140 "a2p.y" -{ yyval = yypvt[-0]; } break; -case 33: -# line 142 "a2p.y" -{ yyval = oper2(OCONCAT,yypvt[-1],yypvt[-0]); } break; -case 34: -# line 144 "a2p.y" -{ yyval = oper3(OASSIGN,yypvt[-1],yypvt[-2],yypvt[-0]); - if ((ops[yypvt[-2]].ival & 255) == OFLD) - lval_field = TRUE; - if ((ops[yypvt[-2]].ival & 255) == OVFLD) - lval_field = TRUE; - } break; -case 35: -# line 153 "a2p.y" -{ yyval = yypvt[-0]; } break; -case 36: -# line 155 "a2p.y" -{ yyval = oper1(ONUM,yypvt[-0]); } break; -case 37: -# line 157 "a2p.y" -{ yyval = oper1(OSTR,yypvt[-0]); } break; -case 38: -# line 159 "a2p.y" -{ yyval = oper2(OADD,yypvt[-2],yypvt[-0]); } break; -case 39: -# line 161 "a2p.y" -{ yyval = oper2(OSUBTRACT,yypvt[-2],yypvt[-0]); } break; -case 40: -# line 163 "a2p.y" -{ yyval = oper2(OMULT,yypvt[-2],yypvt[-0]); } break; -case 41: -# line 165 "a2p.y" -{ yyval = oper2(ODIV,yypvt[-2],yypvt[-0]); } break; -case 42: -# line 167 "a2p.y" -{ yyval = oper2(OMOD,yypvt[-2],yypvt[-0]); } break; -case 43: -# line 169 "a2p.y" -{ yyval = oper2(OPOW,yypvt[-2],yypvt[-0]); } break; -case 44: -# line 171 "a2p.y" -{ yyval = oper2(ODEFINED,aryrefarg(yypvt[-0]),yypvt[-2]); } break; -case 45: -# line 173 "a2p.y" -{ yyval = oper3(OCOND,yypvt[-4],yypvt[-2],yypvt[-0]); } break; -case 46: -# line 175 "a2p.y" -{ yyval = oper1(OPOSTINCR,yypvt[-1]); } break; -case 47: -# line 177 "a2p.y" -{ yyval = oper1(OPOSTDECR,yypvt[-1]); } break; -case 48: -# line 179 "a2p.y" -{ yyval = oper1(OPREINCR,yypvt[-0]); } break; -case 49: -# line 181 "a2p.y" -{ yyval = oper1(OPREDECR,yypvt[-0]); } break; -case 50: -# line 183 "a2p.y" -{ yyval = oper1(OUMINUS,yypvt[-0]); } break; -case 51: -# line 185 "a2p.y" -{ yyval = oper1(OUPLUS,yypvt[-0]); } break; -case 52: -# line 187 "a2p.y" -{ yyval = oper1(OPAREN,yypvt[-1]); } break; -case 53: -# line 189 "a2p.y" -{ yyval = oper0(OGETLINE); } break; -case 54: -# line 191 "a2p.y" -{ yyval = oper1(OGETLINE,yypvt[-0]); } break; -case 55: -# line 193 "a2p.y" -{ yyval = oper3(OGETLINE,Nullop,string("<",1),yypvt[-0]); - if (ops[yypvt[-0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break; -case 56: -# line 196 "a2p.y" -{ yyval = oper3(OGETLINE,yypvt[-2],string("<",1),yypvt[-0]); - if (ops[yypvt[-0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break; -case 57: -# line 199 "a2p.y" -{ yyval = oper3(OGETLINE,Nullop,string("|",1),yypvt[-2]); - if (ops[yypvt[-2]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break; -case 58: -# line 202 "a2p.y" -{ yyval = oper3(OGETLINE,yypvt[-0],string("|",1),yypvt[-3]); - if (ops[yypvt[-3]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break; -case 59: -# line 205 "a2p.y" -{ yyval = oper0(yypvt[-0]); need_entire = do_chop = TRUE; } break; -case 60: -# line 207 "a2p.y" -{ yyval = oper1(yypvt[-2],Nullop); need_entire = do_chop = TRUE; } break; -case 61: -# line 209 "a2p.y" -{ yyval = oper1(yypvt[-3],yypvt[-1]); } break; -case 62: -# line 211 "a2p.y" -{ yyval = oper1(yypvt[-3],yypvt[-1]); } break; -case 63: -# line 213 "a2p.y" -{ yyval = oper2(OUSERFUN,yypvt[-3],yypvt[-1]); } break; -case 64: -# line 215 "a2p.y" -{ yyval = oper1(OSPRINTF,yypvt[-0]); } break; -case 65: -# line 217 "a2p.y" -{ yyval = oper3(OSUBSTR,yypvt[-5],yypvt[-3],yypvt[-1]); } break; -case 66: -# line 219 "a2p.y" -{ yyval = oper2(OSUBSTR,yypvt[-3],yypvt[-1]); } break; -case 67: -# line 221 "a2p.y" -{ yyval = oper3(OSPLIT,yypvt[-5],aryrefarg(numary(yypvt[-3])),yypvt[-1]); } break; -case 68: -# line 223 "a2p.y" -{ yyval = oper3(OSPLIT,yypvt[-5],aryrefarg(numary(yypvt[-3])),oper1(OREGEX,yypvt[-1]));} break; -case 69: -# line 225 "a2p.y" -{ yyval = oper2(OSPLIT,yypvt[-3],aryrefarg(numary(yypvt[-1]))); } break; -case 70: -# line 227 "a2p.y" -{ yyval = oper2(OINDEX,yypvt[-3],yypvt[-1]); } break; -case 71: -# line 229 "a2p.y" -{ yyval = oper2(OMATCH,yypvt[-3],oper1(OREGEX,yypvt[-1])); } break; -case 72: -# line 231 "a2p.y" -{ yyval = oper2(OMATCH,yypvt[-3],yypvt[-1]); } break; -case 73: -# line 233 "a2p.y" -{ yyval = oper2(OSUB,yypvt[-3],yypvt[-1]); } break; -case 74: -# line 235 "a2p.y" -{ yyval = oper2(OSUB,oper1(OREGEX,yypvt[-3]),yypvt[-1]); } break; -case 75: -# line 237 "a2p.y" -{ yyval = oper2(OGSUB,yypvt[-3],yypvt[-1]); } break; -case 76: -# line 239 "a2p.y" -{ yyval = oper2(OGSUB,oper1(OREGEX,yypvt[-3]),yypvt[-1]); } break; -case 77: -# line 241 "a2p.y" -{ yyval = oper3(OSUB,yypvt[-5],yypvt[-3],yypvt[-1]); } break; -case 78: -# line 243 "a2p.y" -{ yyval = oper3(OSUB,oper1(OREGEX,yypvt[-5]),yypvt[-3],yypvt[-1]); } break; -case 79: -# line 245 "a2p.y" -{ yyval = oper3(OGSUB,yypvt[-5],yypvt[-3],yypvt[-1]); } break; -case 80: -# line 247 "a2p.y" -{ yyval = oper3(OGSUB,oper1(OREGEX,yypvt[-5]),yypvt[-3],yypvt[-1]); } break; -case 81: -# line 251 "a2p.y" -{ yyval = oper1(OVAR,yypvt[-0]); } break; -case 82: -# line 253 "a2p.y" -{ yyval = oper2(OVAR,aryrefarg(yypvt[-3]),yypvt[-1]); } break; -case 83: -# line 255 "a2p.y" -{ yyval = oper1(OFLD,yypvt[-0]); } break; -case 84: -# line 257 "a2p.y" -{ yyval = oper1(OVFLD,yypvt[-0]); } break; -case 87: -# line 264 "a2p.y" -{ yyval = Nullop; } break; -case 88: -# line 268 "a2p.y" -{ yyval = oper3(OCOMMA,yypvt[-3],yypvt[-1],yypvt[-0]); } break; -case 89: -# line 270 "a2p.y" -{ yyval = oper3(OCOMMA,yypvt[-3],yypvt[-1],yypvt[-0]); } break; -case 90: -# line 272 "a2p.y" -{ yyval = yypvt[-1]; } break; -case 91: -# line 276 "a2p.y" -{ yyval = oper2(OJUNK,yypvt[-1],yypvt[-0]); } break; -case 92: -# line 278 "a2p.y" -{ yyval = Nullop; } break; -case 93: -# line 282 "a2p.y" -{ yyval = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } break; -case 94: -# line 284 "a2p.y" -{ yyval = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } break; -case 95: -# line 286 "a2p.y" -{ yyval = oper0(ONEWLINE); } break; -case 96: -# line 288 "a2p.y" -{ yyval = oper1(OCOMMENT,yypvt[-0]); } break; -case 97: -# line 292 "a2p.y" -{ yyval = oper2(OJUNK,yypvt[-1],yypvt[-0]); } break; -case 98: -# line 294 "a2p.y" -{ yyval = Nullop; } break; -case 99: -# line 298 "a2p.y" -{ yyval = oper0(ONEWLINE); } break; -case 100: -# line 300 "a2p.y" -{ yyval = oper1(OCOMMENT,yypvt[-0]); } break; -case 101: -# line 305 "a2p.y" -{ yyval = oper2(OJUNK,oper0(OSEMICOLON),yypvt[-0]); } break; -case 102: -# line 307 "a2p.y" -{ yyval = oper2(OJUNK,oper0(OSNEWLINE),yypvt[-0]); } break; -case 103: -# line 309 "a2p.y" -{ yyval = oper2(OJUNK,oper0(OSNEWLINE),yypvt[-0]); } break; -case 104: -# line 311 "a2p.y" -{ yyval = oper2(OJUNK,oper1(OSCOMMENT,yypvt[-1]),yypvt[-0]); } break; -case 105: -# line 315 "a2p.y" -{ yyval = oper2(OSTATES,yypvt[-1],yypvt[-0]); } break; -case 106: -# line 317 "a2p.y" -{ yyval = Nullop; } break; -case 107: -# line 322 "a2p.y" -{ yyval = oper2(OJUNK,oper2(OSTATE,yypvt[-2],yypvt[-1]),yypvt[-0]); } break; -case 108: -# line 324 "a2p.y" -{ yyval = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),yypvt[-0])); } break; -case 109: -# line 326 "a2p.y" -{ yyval = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),yypvt[-0])); } break; -case 112: -# line 332 "a2p.y" -{ yyval = Nullop; } break; -case 114: -# line 338 "a2p.y" -{ yyval = oper3(OPRINT,yypvt[-2],yypvt[-1],yypvt[-0]); - do_opens = TRUE; - saw_ORS = saw_OFS = TRUE; - if (!yypvt[-2]) need_entire = TRUE; - if (ops[yypvt[-0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break; -case 115: -# line 344 "a2p.y" -{ yyval = oper1(OPRINT,yypvt[-0]); - if (!yypvt[-0]) need_entire = TRUE; - saw_ORS = saw_OFS = TRUE; - } break; -case 116: -# line 349 "a2p.y" -{ yyval = oper3(OPRINTF,yypvt[-2],yypvt[-1],yypvt[-0]); - do_opens = TRUE; - if (!yypvt[-2]) need_entire = TRUE; - if (ops[yypvt[-0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } break; -case 117: -# line 354 "a2p.y" -{ yyval = oper1(OPRINTF,yypvt[-0]); - if (!yypvt[-0]) need_entire = TRUE; - } break; -case 118: -# line 358 "a2p.y" -{ yyval = oper0(OBREAK); } break; -case 119: -# line 360 "a2p.y" -{ yyval = oper0(ONEXT); } break; -case 120: -# line 362 "a2p.y" -{ yyval = oper0(OEXIT); } break; -case 121: -# line 364 "a2p.y" -{ yyval = oper1(OEXIT,yypvt[-0]); } break; -case 122: -# line 366 "a2p.y" -{ yyval = oper0(OCONTINUE); } break; -case 123: -# line 368 "a2p.y" -{ yyval = oper0(ORETURN); } break; -case 124: -# line 370 "a2p.y" -{ yyval = oper1(ORETURN,yypvt[-0]); } break; -case 125: -# line 372 "a2p.y" -{ yyval = oper2(ODELETE,aryrefarg(yypvt[-3]),yypvt[-1]); } break; -case 126: -# line 376 "a2p.y" -{ yyval = oper1(OREDIR,string(">",1)); } break; -case 127: -# line 378 "a2p.y" -{ yyval = oper1(OREDIR,string(">>",2)); } break; -case 128: -# line 380 "a2p.y" -{ yyval = oper1(OREDIR,string("|",1)); } break; -case 129: -# line 385 "a2p.y" -{ yyval = oper2(OIF,yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break; -case 130: -# line 387 "a2p.y" -{ yyval = oper3(OIF,yypvt[-6],bl(yypvt[-3],yypvt[-4]),bl(yypvt[-0],yypvt[-1])); } break; -case 131: -# line 389 "a2p.y" -{ yyval = oper2(OWHILE,yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break; -case 132: -# line 391 "a2p.y" -{ yyval = oper2(ODO,bl(yypvt[-4],yypvt[-5]),yypvt[-1]); } break; -case 133: -# line 393 "a2p.y" -{ yyval = oper4(OFOR,yypvt[-7],yypvt[-5],yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break; -case 134: -# line 395 "a2p.y" -{ yyval = oper4(OFOR,yypvt[-6],string("",0),yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break; -case 135: -# line 397 "a2p.y" -{ yyval = oper2(OFORIN,yypvt[-3],bl(yypvt[-0],yypvt[-1])); } break; -case 136: -# line 399 "a2p.y" -{ yyval = oper3(OBLOCK,oper2(OJUNK,yypvt[-3],yypvt[-2]),Nullop,yypvt[-0]); } break; - } - goto yystack; /* reset registers in driver code */ -} @@ -6,17 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: a2p.h,v $ - * Revision 4.1 92/08/07 18:29:09 lwall - * - * Revision 4.0.1.2 92/06/08 16:12:23 lwall - * patch20: hash tables now split only if the memory is available to do so - * - * Revision 4.0.1.1 91/06/07 12:12:27 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:57:07 lwall - * 4.0 baseline. - * */ #define VOIDUSED 1 @@ -229,7 +218,7 @@ union u_ops { #else #define OPSMAX 50000 #endif /* 80286 hack */ -union u_ops ops[OPSMAX]; +EXT union u_ops ops[OPSMAX]; #include <stdio.h> #include <ctype.h> @@ -309,7 +298,7 @@ EXT char fswitch INIT(0); EXT int saw_FS INIT(0); EXT int maxfld INIT(0); EXT int arymax INIT(0); -char *nameary[100]; +EXT char *nameary[100]; EXT STR *opens; diff --git a/x2p/a2p.man b/x2p/a2p.man index 4f4168b269..f74e596ed2 100644 --- a/x2p/a2p.man +++ b/x2p/a2p.man @@ -2,21 +2,6 @@ ''' $RCSfile: a2p.man,v $$Revision: 4.1 $$Date: 92/08/07 18:29:10 $ ''' ''' $Log: a2p.man,v $ -''' Revision 4.1 92/08/07 18:29:10 lwall -''' -''' Revision 4.0 91/03/20 01:57:11 lwall -''' 4.0 baseline. -''' -''' Revision 3.0 89/10/18 15:34:22 lwall -''' 3.0 baseline -''' -''' Revision 2.0.1.1 88/07/11 23:16:25 root -''' patch2: changes related to 1985 awk -''' -''' Revision 2.0 88/06/05 00:15:36 root -''' Baseline version 2.0. -''' -''' .de Sh .br .ne 5 @@ -7,17 +7,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: a2p.y,v $ - * Revision 4.1 92/08/07 18:29:12 lwall - * - * Revision 4.0.1.2 92/06/08 16:13:03 lwall - * patch20: in a2p, getline should allow variable to be array element - * - * Revision 4.0.1.1 91/06/07 12:12:41 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:57:21 lwall - * 4.0 baseline. - * */ #include "INTERN.h" diff --git a/x2p/a2py.c b/x2p/a2py.c index a092c8ab63..59c22414a5 100644 --- a/x2p/a2py.c +++ b/x2p/a2py.c @@ -6,26 +6,13 @@ * License or the Artistic License, as specified in the README file. * * $Log: a2py.c,v $ - * Revision 4.1 92/08/07 18:29:14 lwall - * - * Revision 4.0.1.2 92/06/08 16:15:16 lwall - * patch20: in a2p, now warns about spurious backslashes - * patch20: in a2p, now allows [ to be backslashed in pattern - * patch20: in a2p, now allows numbers of the form 2. - * - * Revision 4.0.1.1 91/06/07 12:12:59 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:57:26 lwall - * 4.0 baseline. - * */ #ifdef OS2 #include "../patchlevel.h" #endif #include "util.h" -char *index(); +char *strchr(); char *filename; char *myname; @@ -36,7 +23,7 @@ STR *walk(); #ifdef OS2 usage() { - printf("\nThis is the AWK to PERL translator, version 4.0, patchlevel %d\n", PATCHLEVEL); + printf("\nThis is the AWK to PERL translator, version 5.0, patchlevel %d\n", PATCHLEVEL); printf("\nUsage: %s [-D<number>] [-F<char>] [-n<fieldlist>] [-<number>] filename\n", myname); printf("\n -D<number> sets debugging flags." "\n -F<character> the awk script to translate is always invoked with" @@ -170,7 +157,7 @@ register char **env; # this emulates #! processing on NIH machines.\n\ # (remove #! line above if indigestible)\n\n"); str_cat(str, - "eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;\n"); + "eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_0-9]+=)(.*)/ && shift;\n"); str_cat(str, " # process any FOO=bar switches\n\n"); if (do_opens && opens) { @@ -211,7 +198,7 @@ yylex() retry: #ifdef YYDEBUG if (yydebug) - if (index(s,'\n')) + if (strchr(s,'\n')) fprintf(stderr,"Tokener at %s",s); else fprintf(stderr,"Tokener at %s\n",s); @@ -871,7 +858,7 @@ register char *s; else s++; } - if (index("eE",*s) && index("+-0123456789",s[1])) { + if (strchr("eE",*s) && strchr("+-0123456789",s[1])) { *d++ = *s++; if (*s == '+' || *s == '-') *d++ = *s++; diff --git a/x2p/all b/x2p/all deleted file mode 100644 index e69de29bb2..0000000000 --- a/x2p/all +++ /dev/null diff --git a/x2p/cflags b/x2p/cflags deleted file mode 100755 index ba795b376a..0000000000 --- a/x2p/cflags +++ /dev/null @@ -1,55 +0,0 @@ -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -case $CONFIG in -'') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi 2>/dev/null - . ./config.sh - ;; -esac - -also=': ' -case $# in -1) also='echo 1>&2 " CCCMD = "' -esac - -case $# in -0) set *.c; echo "The current C flags are:" ;; -esac - -set `echo "$* " | sed 's/\.[oc] / /g'` - -for file do - - case "$#" in - 1) ;; - *) echo $n " $file.c $c" ;; - esac - - : allow variables like str_cflags to be evaluated - - eval 'eval ${'"${file}_cflags"'-""}' - - : or customize here - - case "$file" in - a2p) ;; - a2py) ;; - hash) ;; - str) ;; - util) ;; - walk) ;; - *) ;; - esac - - echo "$cc -c $ccflags $optimize $large $split" - eval "$also "'"$cc -c $ccflags $optimize $large $split"' - - . ./config.sh - -done diff --git a/x2p/cflags.SH b/x2p/cflags.SH index db857c0492..e20c3a478b 100755 --- a/x2p/cflags.SH +++ b/x2p/cflags.SH @@ -1,43 +1,43 @@ case $CONFIG in '') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi - . config.sh - ;; + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac -echo "Extracting cflags (with variable substitutions)" +echo "Extracting x2p/cflags (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. -rm -f cflags $spitshell >cflags <<!GROK!THIS! !GROK!THIS! : In the following dollars and backticks do not need the extra backslash. $spitshell >>cflags <<'!NO!SUBS!' -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac case $CONFIG in '') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi 2>/dev/null - . ./config.sh - ;; + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; esac also=': ' @@ -74,12 +74,14 @@ for file do *) ;; esac + ccflags="`echo $ccflags | sed -e 's/-DEMBED//'`" + echo "$cc -c $ccflags $optimize $large $split" eval "$also "'"$cc -c $ccflags $optimize $large $split"' - . ./config.sh + . $TOP/config.sh done !NO!SUBS! -chmod +x cflags +chmod 755 cflags $eunicefix cflags diff --git a/x2p/config.sh b/x2p/config.sh deleted file mode 120000 index 3131e78bcf..0000000000 --- a/x2p/config.sh +++ /dev/null @@ -1 +0,0 @@ -../config.sh
\ No newline at end of file diff --git a/x2p/find2perl b/x2p/find2perl deleted file mode 100755 index 7bbeccd55d..0000000000 --- a/x2p/find2perl +++ /dev/null @@ -1,572 +0,0 @@ -#!/usr/local/bin/perl -# -# Modified September 26, 1993 to provide proper handling of years after 1999 -# Tom Link <tml+@pitt.edu> -# University of Pittsburgh - -eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -$bin = "/usr/local/bin"; - - -while ($ARGV[0] =~ /^[^-!(]/) { - push(@roots, shift); -} -@roots = ('.') unless @roots; -for (@roots) { $_ = "e($_); } -$roots = join(',', @roots); - -$indent = 1; - -while (@ARGV) { - $_ = shift; - s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n"; - if ($_ eq '(') { - $out .= &tab . "(\n"; - $indent++; - next; - } - elsif ($_ eq ')') { - $indent--; - $out .= &tab . ")"; - } - elsif ($_ eq '!') { - $out .= &tab . "!"; - next; - } - elsif ($_ eq 'name') { - $out .= &tab; - $pat = &fileglob_to_re(shift); - $out .= '/' . $pat . "/"; - } - elsif ($_ eq 'perm') { - $onum = shift; - die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/; - if ($onum =~ s/^-//) { - $onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ? - $out .= &tab . "((\$mode & $onum) == $onum)"; - } - else { - $onum = '0' . $onum unless $onum =~ /^0/; - $out .= &tab . "((\$mode & 0777) == $onum)"; - } - } - elsif ($_ eq 'type') { - ($filetest = shift) =~ tr/s/S/; - $out .= &tab . "-$filetest _"; - } - elsif ($_ eq 'print') { - $out .= &tab . 'print("$name\n")'; - } - elsif ($_ eq 'print0') { - $out .= &tab . 'print("$name\0")'; - } - elsif ($_ eq 'fstype') { - $out .= &tab; - $type = shift; - if ($type eq 'nfs') - { $out .= '($dev < 0)'; } - else - { $out .= '($dev >= 0)'; } - } - elsif ($_ eq 'user') { - $uname = shift; - $out .= &tab . "(\$uid == \$uid{'$uname'})"; - $inituser++; - } - elsif ($_ eq 'group') { - $gname = shift; - $out .= &tab . "(\$gid == \$gid{'$gname'})"; - $initgroup++; - } - elsif ($_ eq 'nouser') { - $out .= &tab . '!defined $uid{$uid}'; - $inituser++; - } - elsif ($_ eq 'nogroup') { - $out .= &tab . '!defined $gid{$gid}'; - $initgroup++; - } - elsif ($_ eq 'links') { - $out .= &tab . '($nlink ' . &n(shift); - } - elsif ($_ eq 'inum') { - $out .= &tab . '($ino ' . &n(shift); - } - elsif ($_ eq 'size') { - $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift); - } - elsif ($_ eq 'atime') { - $out .= &tab . '(int(-A _) ' . &n(shift); - } - elsif ($_ eq 'mtime') { - $out .= &tab . '(int(-M _) ' . &n(shift); - } - elsif ($_ eq 'ctime') { - $out .= &tab . '(int(-C _) ' . &n(shift); - } - elsif ($_ eq 'exec') { - for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { } - shift; - $_ = "@cmd"; - if (m#^(/bin/)?rm -f {}$#) { - if (!@ARGV) { - $out .= &tab . 'unlink($_)'; - } - else { - $out .= &tab . '(unlink($_) || 1)'; - } - } - elsif (m#^(/bin/)?rm {}$#) { - $out .= &tab . '(unlink($_) || warn "$name: $!\n")'; - } - else { - for (@cmd) { s/'/\\'/g; } - $" = "','"; - $out .= &tab . "&exec(0, '@cmd')"; - $" = ' '; - $initexec++; - } - } - elsif ($_ eq 'ok') { - for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { } - shift; - for (@cmd) { s/'/\\'/g; } - $" = "','"; - $out .= &tab . "&exec(1, '@cmd')"; - $" = ' '; - $initexec++; - } - elsif ($_ eq 'prune') { - $out .= &tab . '($prune = 1)'; - } - elsif ($_ eq 'xdev') { - $out .= &tab . '(($prune |= ($dev != $topdev)),1)'; - } - elsif ($_ eq 'newer') { - $out .= &tab; - $file = shift; - $newername = 'AGE_OF' . $file; - $newername =~ s/[^\w]/_/g; - $newername = '$' . $newername; - $out .= "(-M _ < $newername)"; - $initnewer .= "$newername = -M " . "e($file) . ";\n"; - } - elsif ($_ eq 'eval') { - $prog = "e(shift); - $out .= &tab . "eval $prog"; - } - elsif ($_ eq 'depth') { - $depth++; - next; - } - elsif ($_ eq 'ls') { - $out .= &tab . "&ls"; - $initls++; - } - elsif ($_ eq 'tar') { - $out .= &tab; - die "-tar must have a filename argument\n" unless @ARGV; - $file = shift; - $fh = 'FH' . $file; - $fh =~ s/[^\w]/_/g; - $out .= "&tar($fh)"; - $file = '>' . $file; - $initfile .= "open($fh, " . "e($file) . - qq{) || die "Can't open $fh: \$!\\n";\n}; - $inittar++; - $flushall = "\n&tflushall;\n"; - } - elsif (/^n?cpio$/) { - $depth++; - $out .= &tab; - die "-$_ must have a filename argument\n" unless @ARGV; - $file = shift; - $fh = 'FH' . $file; - $fh =~ s/[^\w]/_/g; - $out .= "&cpio('" . substr($_,0,1) . "', $fh)"; - $file = '>' . $file; - $initfile .= "open($fh, " . "e($file) . - qq{) || die "Can't open $fh: \$!\\n";\n}; - $initcpio++; - $flushall = "\n&flushall;\n"; - } - else { - die "Unrecognized switch: -$_\n"; - } - if (@ARGV) { - if ($ARGV[0] eq '-o') { - { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; } - $statdone = 0 if $indent == 1 && $delayedstat; - $saw_or++; - shift; - } - else { - $out .= " &&" unless $ARGV[0] eq ')'; - $out .= "\n"; - shift if $ARGV[0] eq '-a'; - } - } -} - -print <<"END"; -#!$bin/perl - -eval 'exec $bin/perl -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; - -END - -if ($initls) { - print <<'END'; -@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); -@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec); - -END -} - -if ($inituser || $initls) { - print 'while (($name, $pw, $uid) = getpwent) {', "\n"; - print ' $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser; - print ' $user{$uid} = $name unless $user{$uid};', "\n" if $initls; - print "}\n\n"; -} - -if ($initgroup || $initls) { - print 'while (($name, $pw, $gid) = getgrent) {', "\n"; - print ' $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup; - print ' $group{$gid} = $name unless $group{$gid};', "\n" if $initls; - print "}\n\n"; -} - -print $initnewer, "\n" if $initnewer; - -print $initfile, "\n" if $initfile; - -$find = $depth ? "finddepth" : "find"; -print <<"END"; -require "$find.pl"; - -# Traverse desired filesystems - -&$find($roots); -$flushall -exit; - -sub wanted { -$out; -} - -END - -if ($initexec) { - print <<'END'; -sub exec { - local($ok, @cmd) = @_; - foreach $word (@cmd) { - $word =~ s#{}#$name#g; - } - if ($ok) { - local($old) = select(STDOUT); - $| = 1; - print "@cmd"; - select($old); - return 0 unless <STDIN> =~ /^y/; - } - chdir $cwd; # sigh - system @cmd; - chdir $dir; - return !$?; -} - -END -} - -if ($initls) { - print <<'END'; -sub ls { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); - - $pname = $name; - - if (defined $blocks) { - $blocks = int(($blocks + 1) / 2); - } - else { - $blocks = int(($size + 1023) / 1024); - } - - if (-f _) { $perms = '-'; } - elsif (-d _) { $perms = 'd'; } - elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } - elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } - elsif (-p _) { $perms = 'p'; } - elsif (-S _) { $perms = 's'; } - else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } - - $tmpmode = $mode; - $tmp = $rwx[$tmpmode & 7]; - $tmpmode >>= 3; - $tmp = $rwx[$tmpmode & 7] . $tmp; - $tmpmode >>= 3; - $tmp = $rwx[$tmpmode & 7] . $tmp; - substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; - substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; - substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; - $perms .= $tmp; - - $user = $user{$uid} || $uid; - $group = $group{$gid} || $gid; - - ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); - $moname = $moname[$mon]; - if (-M _ > 365.25 / 2) { - $timeyear = $year + 1900; - } - else { - $timeyear = sprintf("%02d:%02d", $hour, $min); - } - - printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", - $ino, - $blocks, - $perms, - $nlink, - $user, - $group, - $sizemm, - $moname, - $mday, - $timeyear, - $pname; - 1; -} - -sub sizemm { - sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255); -} - -END -} - -if ($initcpio) { -print <<'END'; -sub cpio { - local($nc,$fh) = @_; - local($text); - - if ($name eq 'TRAILER!!!') { - $text = ''; - $size = 0; - } - else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); - if (-f _) { - open(IN, "./$_\0") || do { - warn "Couldn't open $name: $!\n"; - return; - }; - } - else { - $text = readlink($_); - $size = 0 unless defined $text; - } - } - - ($nm = $name) =~ s#^\./##; - $nc{$fh} = $nc; - if ($nc eq 'n') { - $cpout{$fh} .= - sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0", - 070707, - $dev & 0777777, - $ino & 0777777, - $mode & 0777777, - $uid & 0777777, - $gid & 0777777, - $nlink & 0777777, - $rdev & 0177777, - $mtime, - length($nm)+1, - $size, - $nm); - } - else { - $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1; - $cpout{$fh} .= pack("SSSSSSSSLSLa*", - 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime, - length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0")); - } - if ($text ne '') { - $cpout{$fh} .= $text; - } - elsif ($size) { - &flush($fh) while ($l = length($cpout{$fh})) >= 5120; - while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) { - &flush($fh); - $l = length($cpout{$fh}); - } - } - close IN; -} - -sub flush { - local($fh) = @_; - - while (length($cpout{$fh}) >= 5120) { - syswrite($fh,$cpout{$fh},5120); - ++$blocks{$fh}; - substr($cpout{$fh}, 0, 5120) = ''; - } -} - -sub flushall { - $name = 'TRAILER!!!'; - foreach $fh (keys %cpout) { - &cpio($nc{$fh},$fh); - $cpout{$fh} .= "0" x (5120 - length($cpout{$fh})); - &flush($fh); - print $blocks{$fh} * 10, " blocks\n"; - } -} - -END -} - -if ($inittar) { -print <<'END'; -sub tar { - local($fh) = @_; - local($linkname,$header,$l,$slop); - local($linkflag) = "\0"; - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_); - $nm = $name; - if ($nlink > 1) { - if ($linkname = $linkseen{$fh,$dev,$ino}) { - $linkflag = 1; - } - else { - $linkseen{$fh,$dev,$ino} = $nm; - } - } - if (-f _) { - open(IN, "./$_\0") || do { - warn "Couldn't open $name: $!\n"; - return; - }; - $size = 0 if $linkflag ne "\0"; - } - else { - $linkname = readlink($_); - $linkflag = 2 if defined $linkname; - $nm .= '/' if -d _; - $size = 0; - } - - $header = pack("a100a8a8a8a12a12a8a1a100", - $nm, - sprintf("%6o ", $mode & 0777), - sprintf("%6o ", $uid & 0777777), - sprintf("%6o ", $gid & 0777777), - sprintf("%11o ", $size), - sprintf("%11o ", $mtime), - " ", - $linkflag, - $linkname); - $l = length($header) % 512; - substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header)); - substr($header, 154, 1) = "\0"; # blech - $tarout{$fh} .= $header; - $tarout{$fh} .= "\0" x (512 - $l) if $l; - if ($size) { - &tflush($fh) while ($l = length($tarout{$fh})) >= 10240; - while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) { - $slop = length($tarout{$fh}) % 512; - $tarout{$fh} .= "\0" x (512 - $slop) if $slop; - &tflush($fh); - $l = length($tarout{$fh}); - } - } - close IN; -} - -sub tflush { - local($fh) = @_; - - while (length($tarout{$fh}) >= 10240) { - syswrite($fh,$tarout{$fh},10240); - ++$blocks{$fh}; - substr($tarout{$fh}, 0, 10240) = ''; - } -} - -sub tflushall { - local($len); - - foreach $fh (keys %tarout) { - $len = 10240 - length($tarout{$fh}); - $len += 10240 if $len < 1024; - $tarout{$fh} .= "\0" x $len; - &tflush($fh); - } -} - -END -} - -exit; - -############################################################################ - -sub tab { - local($tabstring); - - $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4); - if (!$statdone) { - if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) { - $delayedstat++; - } - else { - if ($saw_or) { - $tabstring .= <<'ENDOFSTAT' . $tabstring; -($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && -ENDOFSTAT - } - else { - $tabstring .= <<'ENDOFSTAT' . $tabstring; -(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && -ENDOFSTAT - } - $statdone = 1; - } - } - $tabstring =~ s/^\s+/ / if $out =~ /!$/; - $tabstring; -} - -sub fileglob_to_re { - local($tmp) = @_; - - $tmp =~ s#([./^\$()])#\\$1#g; - $tmp =~ s/([?*])/.$1/g; - "^$tmp\$"; -} - -sub n { - local($n) = @_; - - $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /; - $n =~ s/ 0*(\d)/ $1/; - $n . ')'; -} - -sub quote { - local($string) = @_; - $string =~ s/'/\\'/; - "'$string'"; -} diff --git a/x2p/find2perl.SH b/x2p/find2perl.SH index 8670173db6..8ab7f9c394 100755 --- a/x2p/find2perl.SH +++ b/x2p/find2perl.SH @@ -1,20 +1,22 @@ case $CONFIG in '') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi - . ./config.sh - ;; + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac -echo "Extracting find2perl (with variable substitutions)" +echo "Extracting x2p/find2perl (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted @@ -169,7 +171,7 @@ while (@ARGV) { $out .= &tab . '($prune = 1)'; } elsif ($_ eq 'xdev') { - $out .= &tab . '(($prune |= ($dev != $topdev)),1)'; + $out .= &tab . '!($prune |= ($dev != $topdev))'; } elsif ($_ eq 'newer') { $out .= &tab; diff --git a/x2p/handy.h b/x2p/handy.h index ee31a1c577..8995b2448b 100644 --- a/x2p/handy.h +++ b/x2p/handy.h @@ -6,17 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: handy.h,v $ - * Revision 4.1 92/08/07 18:29:19 lwall - * - * Revision 4.0.1.2 91/06/07 12:15:43 lwall - * patch4: new copyright notice - * - * Revision 4.0.1.1 91/04/12 09:29:08 lwall - * patch1: random cleanup in cpp namespace - * - * Revision 4.0 91/03/20 01:57:45 lwall - * 4.0 baseline. - * */ #define Null(type) ((type)0) diff --git a/x2p/hash.c b/x2p/hash.c index 96b854f770..b910af603e 100644 --- a/x2p/hash.c +++ b/x2p/hash.c @@ -6,14 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: hash.c,v $ - * Revision 4.1 92/08/07 18:29:20 lwall - * - * Revision 4.0.1.1 91/06/07 12:15:55 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:57:49 lwall - * 4.0 baseline. - * */ #include <stdio.h> diff --git a/x2p/hash.h b/x2p/hash.h index a977ae5cfc..5685e53259 100644 --- a/x2p/hash.h +++ b/x2p/hash.h @@ -6,14 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: hash.h,v $ - * Revision 4.1 92/08/07 18:29:21 lwall - * - * Revision 4.0.1.1 91/06/07 12:16:04 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:57:53 lwall - * 4.0 baseline. - * */ #define FILLPCT 60 /* don't make greater than 99 */ diff --git a/x2p/make.out b/x2p/make.out deleted file mode 100644 index bd2565451f..0000000000 --- a/x2p/make.out +++ /dev/null @@ -1,13 +0,0 @@ -../makedepend -make: Warning: Both `makefile' and `Makefile' exists -Current working directory /usr/src/local/lwall/perl5/x2p -echo hash.c malloc.c str.c util.c walk.c | tr ' ' '\012' >.clist -Finding dependencies for hash.o. -Finding dependencies for malloc.o. -Finding dependencies for str.o. -Finding dependencies for util.o. -Finding dependencies for walk.o. -make: Warning: Both `makefile' and `Makefile' exists -Current working directory /usr/src/local/lwall/perl5/x2p -echo Makefile.SH makedepend.SH | tr ' ' '\012' >.shlist -Updating makefile... diff --git a/x2p/makefile b/x2p/makefile deleted file mode 100644 index fc29d5de95..0000000000 --- a/x2p/makefile +++ /dev/null @@ -1,226 +0,0 @@ -# $RCSfile: Makefile.SH,v 3314Revision: 4.1 3314Date: 92/08/07 18:29:07 $ -# -# $Log: Makefile.SH,v $ -# Revision 4.1 92/08/07 18:29:07 lwall -# -# Revision 4.0.1.3 92/06/08 16:11:32 lwall -# patch20: SH files didn't work well with symbolic links -# patch20: cray didn't give enough memory to /bin/sh -# patch20: makefiles now display new shift/reduce expectations -# -# Revision 4.0.1.2 91/11/05 19:19:04 lwall -# patch11: random cleanup -# -# Revision 4.0.1.1 91/06/07 12:12:14 lwall -# patch4: cflags now emits entire cc command except for the filename -# -# Revision 4.0 91/03/20 01:57:03 lwall -# 4.0 baseline. -# -# - -CC = cc -YACC = yacc -bin = /usr/local/bin -lib = /usr/local/lib -mansrc = /usr/local/man/man1 -manext = 1 -LDFLAGS = -SMALL = -LARGE = -mallocsrc = malloc.c -mallocobj = malloc.o -shellflags = - -libs = -ldbm -ldl -lm -lposix - -CCCMD = `sh $(shellflags) cflags $@` - -public = a2p s2p find2perl - -private = - -manpages = a2p.man s2p.man - -util = - -sh = Makefile.SH makedepend.SH - -h = EXTERN.h INTERN.h ../config.h handy.h hash.h a2p.h str.h util.h - -c = hash.c $(mallocsrc) str.c util.c walk.c - -obj = hash.o $(mallocobj) str.o util.o walk.o - -lintflags = -phbvxac - -addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 - -# grrr -SHELL = /bin/sh - -.c.o: - $(CCCMD) $*.c - -all: $(public) $(private) $(util) - touch all - -a2p: $(obj) a2p.o - $(CC) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p - -a2p.c: a2p.y - @ echo Expect 231 shift/reduce conflicts... - $(YACC) a2p.y - mv y.tab.c a2p.c - -a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h - $(CCCMD) $(LARGE) a2p.c - -install: a2p s2p -# won't work with csh - export PATH || exit 1 - - mv $(bin)/a2p $(bin)/a2p.old 2>/dev/null - - mv $(bin)/s2p $(bin)/s2p.old 2>/dev/null - - if test `pwd` != $(bin); then cp $(public) $(bin); fi - cd $(bin); \ -for pub in $(public); do \ -chmod +x `basename $$pub`; \ -done - - if test `pwd` != $(mansrc); then \ -for page in $(manpages); do \ -cp $$page $(mansrc)/`basename $$page .man`.$(manext); \ -done; \ -fi - -clean: - rm -f a2p *.o a2p.c - -realclean: clean - rm -f *.orig */*.orig core $(addedbyconf) a2p.c s2p find2perl all cflags - -# The following lint has practically everything turned on. Unfortunately, -# you have to wade through a lot of mumbo jumbo that can't be suppressed. -# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message -# for that spot. - -lint: - lint $(lintflags) $(defs) $(c) > a2p.fuzz - -depend: $(mallocsrc) ../makedepend - ../makedepend - -clist: - echo $(c) | tr ' ' '\012' >.clist - -hlist: - echo $(h) | tr ' ' '\012' >.hlist - -shlist: - echo $(sh) | tr ' ' '\012' >.shlist - -config.sh: ../config.sh - rm -f config.sh - ln ../config.sh . - -malloc.c: ../malloc.c - sed <../malloc.c >malloc.c \ - -e 's/"perl.h"/"..\/perl.h"/' \ - -e 's/my_exit/exit/' - -# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE -# If this runs make out of memory, delete /usr/include lines. -hash.o: ../config.h -hash.o: /usr/include/ctype.h -hash.o: /usr/include/stdio.h -hash.o: EXTERN.h -hash.o: a2p.h -hash.o: handy.h -hash.o: hash.c -hash.o: hash.h -hash.o: str.h -hash.o: util.h -malloc.o: ../av.h -malloc.o: ../config.h -malloc.o: ../cop.h -malloc.o: ../cv.h -malloc.o: ../embed.h -malloc.o: ../form.h -malloc.o: ../gv.h -malloc.o: ../handy.h -malloc.o: ../hv.h -malloc.o: ../mg.h -malloc.o: ../op.h -malloc.o: ../opcode.h -malloc.o: ../perl.h -malloc.o: ../pp.h -malloc.o: ../proto.h -malloc.o: ../regexp.h -malloc.o: ../scope.h -malloc.o: ../sv.h -malloc.o: ../unixish.h -malloc.o: ../util.h -malloc.o: /usr/include/ctype.h -malloc.o: /usr/include/dirent.h -malloc.o: /usr/include/errno.h -malloc.o: /usr/include/machine/param.h -malloc.o: /usr/include/machine/setjmp.h -malloc.o: /usr/include/netinet/in.h -malloc.o: /usr/include/setjmp.h -malloc.o: /usr/include/stdio.h -malloc.o: /usr/include/sys/dirent.h -malloc.o: /usr/include/sys/errno.h -malloc.o: /usr/include/sys/filio.h -malloc.o: /usr/include/sys/ioccom.h -malloc.o: /usr/include/sys/ioctl.h -malloc.o: /usr/include/sys/param.h -malloc.o: /usr/include/sys/signal.h -malloc.o: /usr/include/sys/sockio.h -malloc.o: /usr/include/sys/stat.h -malloc.o: /usr/include/sys/stdtypes.h -malloc.o: /usr/include/sys/sysmacros.h -malloc.o: /usr/include/sys/time.h -malloc.o: /usr/include/sys/times.h -malloc.o: /usr/include/sys/ttold.h -malloc.o: /usr/include/sys/ttychars.h -malloc.o: /usr/include/sys/ttycom.h -malloc.o: /usr/include/sys/ttydev.h -malloc.o: /usr/include/sys/types.h -malloc.o: /usr/include/time.h -malloc.o: /usr/include/varargs.h -malloc.o: /usr/include/vm/faultcode.h -malloc.o: EXTERN.h -malloc.o: malloc.c -str.o: ../config.h -str.o: /usr/include/ctype.h -str.o: /usr/include/stdio.h -str.o: EXTERN.h -str.o: a2p.h -str.o: handy.h -str.o: hash.h -str.o: str.c -str.o: str.h -str.o: util.h -util.o: ../config.h -util.o: /usr/include/ctype.h -util.o: /usr/include/stdio.h -util.o: EXTERN.h -util.o: INTERN.h -util.o: a2p.h -util.o: handy.h -util.o: hash.h -util.o: str.h -util.o: util.c -util.o: util.h -walk.o: ../config.h -walk.o: /usr/include/ctype.h -walk.o: /usr/include/stdio.h -walk.o: EXTERN.h -walk.o: a2p.h -walk.o: handy.h -walk.o: hash.h -walk.o: str.h -walk.o: util.h -walk.o: walk.c -Makefile: Makefile.SH config.sh ; /bin/sh Makefile.SH -makedepend: makedepend.SH config.sh ; /bin/sh makedepend.SH -# WARNING: Put nothing here or make depend will gobble it up! diff --git a/x2p/malloc.c b/x2p/malloc.c index 396d31cef2..87c5068e99 100644 --- a/x2p/malloc.c +++ b/x2p/malloc.c @@ -1,31 +1,9 @@ /* $RCSfile: malloc.c,v $$Revision: 4.1 $$Date: 92/08/07 18:24:25 $ * * $Log: malloc.c,v $ - * Revision 4.1 92/08/07 18:24:25 lwall - * - * Revision 4.0.1.4 92/06/08 14:28:38 lwall - * patch20: removed implicit int declarations on functions - * patch20: hash tables now split only if the memory is available to do so - * patch20: realloc(0, size) now does malloc in case library routines call it - * - * Revision 4.0.1.3 91/11/05 17:57:40 lwall - * patch11: safe malloc code now integrated into Perl's malloc when possible - * - * Revision 4.0.1.2 91/06/07 11:20:45 lwall - * patch4: many, many itty-bitty portability fixes - * - * Revision 4.0.1.1 91/04/11 17:48:31 lwall - * patch1: Configure now figures out malloc ptr type - * - * Revision 4.0 91/03/20 01:28:52 lwall - * 4.0 baseline. - * */ #ifndef lint -/*SUPPRESS 592*/ -static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; - #ifdef DEBUGGING #define RCHECK #endif @@ -44,9 +22,6 @@ static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; #include "EXTERN.h" #include "../perl.h" -static int findbucket(); -static int morecore(); - /* I don't much care whether these are defined in sys/types.h--LAW */ #define u_char unsigned char @@ -81,6 +56,12 @@ union overhead { #define ov_rmagic ovu.ovu_rmagic }; +#ifdef debug +static void botch _((char *s)); +#endif +static void morecore _((int bucket)); +static int findbucket _((union overhead *freep, int srchlen)); + #define MAGIC 0xff /* magic # on accounting info */ #define RMAGIC 0x55555555 /* magic # on range info */ #ifdef RCHECK @@ -176,21 +157,15 @@ malloc(nbytes) } #ifdef safemalloc -#if !(defined(I286) || defined(atarist)) - DEBUG_m(fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",p+1,an++,(long)size)); -#else - DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",p+1,an++,(long)size)); -#endif + DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n", + (unsigned long)(p+1),an++,(long)size)); #endif /* safemalloc */ /* remove from linked list */ #ifdef RCHECK if (*((int*)p) & (sizeof(union overhead) - 1)) -#if !(defined(I286) || defined(atarist)) - fprintf(stderr,"Corrupt malloc ptr 0x%x at 0x%x\n",*((int*)p),p); -#else - fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",*((int*)p),p); -#endif + fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n", + (unsigned long)*((int*)p),(unsigned long)p); #endif nextf[bucket] = p->ov_next; p->ov_magic = MAGIC; @@ -214,7 +189,7 @@ malloc(nbytes) /* * Allocate more memory to the indicated bucket. */ -static +static void morecore(bucket) register int bucket; { @@ -288,11 +263,7 @@ free(mp) char *cp = (char*)mp; #ifdef safemalloc -#if !(defined(I286) || defined(atarist)) - DEBUG_m(fprintf(stderr,"0x%x: (%05d) free\n",cp,an++)); -#else - DEBUG_m(fprintf(stderr,"0x%lx: (%05d) free\n",cp,an++)); -#endif + DEBUG_m(fprintf(stderr,"0x%lx: (%05d) free\n",(unsigned long)cp,an++)); #endif /* safemalloc */ if (cp == NULL) @@ -425,17 +396,11 @@ realloc(mp, nbytes) #ifdef safemalloc #ifdef DEBUGGING -# if !(defined(I286) || defined(atarist)) - if (debug & 128) { - fprintf(stderr,"0x%x: (%05d) rfree\n",res,an++); - fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",res,an++,(long)size); - } -# else - if (debug & 128) { - fprintf(stderr,"0x%lx: (%05d) rfree\n",res,an++); - fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",res,an++,(long)size); - } -# endif + if (debug & 128) { + fprintf(stderr,"0x%lx: (%05d) rfree\n",(unsigned long)res,an++); + fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n", + (unsigned long)res,an++,(long)size); + } #endif #endif /* safemalloc */ return ((Malloc_t)res); diff --git a/x2p/s2p b/x2p/s2p deleted file mode 100755 index fa6e01791d..0000000000 --- a/x2p/s2p +++ /dev/null @@ -1,760 +0,0 @@ -#!/usr/local/bin/perl - -eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}' - if $running_under_some_shell; - -$bin = '/usr/local/bin'; - -# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $ -# -# $Log: s2p.SH,v $ -# Revision 4.1 92/08/07 18:29:23 lwall -# -# Revision 4.0.1.2 92/06/08 17:26:31 lwall -# patch20: s2p didn't output portable startup code -# patch20: added ... as variant on .. -# patch20: s2p didn't translate s/pat/\&/ or s/pat/\$/ or s/pat/\\1/ right -# -# Revision 4.0.1.1 91/06/07 12:19:18 lwall -# patch4: s2p now handles embedded newlines better and optimizes common idioms -# -# Revision 4.0 91/03/20 01:57:59 lwall -# 4.0 baseline. -# -# - -$indent = 4; -$shiftwidth = 4; -$l = '{'; $r = '}'; - -while ($ARGV[0] =~ /^-/) { - $_ = shift; - last if /^--/; - if (/^-D/) { - $debug++; - open(BODY,'>-'); - next; - } - if (/^-n/) { - $assumen++; - next; - } - if (/^-p/) { - $assumep++; - next; - } - die "I don't recognize this switch: $_\n"; -} - -unless ($debug) { - open(BODY,">/tmp/sperl$$") || - &Die("Can't open temp file: $!\n"); -} - -if (!$assumen && !$assumep) { - print BODY &q(<<'EOT'); -: while ($ARGV[0] =~ /^-/) { -: $_ = shift; -: last if /^--/; -: if (/^-n/) { -: $nflag++; -: next; -: } -: die "I don't recognize this switch: $_\\n"; -: } -: -EOT -} - -print BODY &q(<<'EOT'); -: #ifdef PRINTIT -: #ifdef ASSUMEP -: $printit++; -: #else -: $printit++ unless $nflag; -: #endif -: #endif -: <><> -: $\ = "\n"; # automatically add newline on print -: <><> -: #ifdef TOPLABEL -: LINE: -: while (chop($_ = <>)) { -: #else -: LINE: -: while (<>) { -: chop; -: #endif -EOT - -LINE: -while (<>) { - - # Wipe out surrounding whitespace. - - s/[ \t]*(.*)\n$/$1/; - - # Perhaps it's a label/comment. - - if (/^:/) { - s/^:[ \t]*//; - $label = &make_label($_); - if ($. == 1) { - $toplabel = $label; - if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) { - $_ = <>; - redo LINE; # Never referenced, so delete it if not a comment. - } - } - $_ = "$label:"; - if ($lastlinewaslabel++) { - $indent += 4; - print BODY &tab, ";\n"; - $indent -= 4; - } - if ($indent >= 2) { - $indent -= 2; - $indmod = 2; - } - next; - } else { - $lastlinewaslabel = ''; - } - - # Look for one or two address clauses - - $addr1 = ''; - $addr2 = ''; - if (s/^([0-9]+)//) { - $addr1 = "$1"; - $addr1 = "\$. == $addr1" unless /^,/; - } - elsif (s/^\$//) { - $addr1 = 'eof()'; - } - elsif (s|^/||) { - $addr1 = &fetchpat('/'); - } - if (s/^,//) { - if (s/^([0-9]+)//) { - $addr2 = "$1"; - } elsif (s/^\$//) { - $addr2 = "eof()"; - } elsif (s|^/||) { - $addr2 = &fetchpat('/'); - } else { - &Die("Invalid second address at line $.\n"); - } - if ($addr2 =~ /^\d+$/) { - $addr1 .= "..$addr2"; - } - else { - $addr1 .= "...$addr2"; - } - } - - # Now we check for metacommands {, }, and ! and worry - # about indentation. - - s/^[ \t]+//; - # a { to keep vi happy - if ($_ eq '}') { - $indent -= 4; - next; - } - if (s/^!//) { - $if = 'unless'; - $else = "$r else $l\n"; - } else { - $if = 'if'; - $else = ''; - } - if (s/^{//) { # a } to keep vi happy - $indmod = 4; - $redo = $_; - $_ = ''; - $rmaybe = ''; - } else { - $rmaybe = "\n$r"; - if ($addr2 || $addr1) { - $space = ' ' x $shiftwidth; - } else { - $space = ''; - } - $_ = &transmogrify(); - } - - # See if we can optimize to modifier form. - - if ($addr1) { - if ($_ !~ /[\n{}]/ && $rmaybe && !$change && - $_ !~ / if / && $_ !~ / unless /) { - s/;$/ $if $addr1;/; - $_ = substr($_,$shiftwidth,1000); - } else { - $_ = "$if ($addr1) $l\n$change$_$rmaybe"; - } - $change = ''; - next LINE; - } -} continue { - @lines = split(/\n/,$_); - for (@lines) { - unless (s/^ *<<--//) { - print BODY &tab; - } - print BODY $_, "\n"; - } - $indent += $indmod; - $indmod = 0; - if ($redo) { - $_ = $redo; - $redo = ''; - redo LINE; - } -} -if ($lastlinewaslabel++) { - $indent += 4; - print BODY &tab, ";\n"; - $indent -= 4; -} - -if ($appendseen || $tseen || !$assumen) { - $printit++ if $dseen || (!$assumen && !$assumep); - print BODY &q(<<'EOT'); -: #ifdef SAWNEXT -: } -: continue { -: #endif -: #ifdef PRINTIT -: #ifdef DSEEN -: #ifdef ASSUMEP -: print if $printit++; -: #else -: if ($printit) -: { print; } -: else -: { $printit++ unless $nflag; } -: #endif -: #else -: print if $printit; -: #endif -: #else -: print; -: #endif -: #ifdef TSEEN -: $tflag = 0; -: #endif -: #ifdef APPENDSEEN -: if ($atext) { chop $atext; print $atext; $atext = ''; } -: #endif -EOT - -print BODY &q(<<'EOT'); -: } -EOT -} - -close BODY; - -unless ($debug) { - open(HEAD,">/tmp/sperl2$$.c") - || &Die("Can't open temp file 2: $!\n"); - print HEAD "#define PRINTIT\n" if $printit; - print HEAD "#define APPENDSEEN\n" if $appendseen; - print HEAD "#define TSEEN\n" if $tseen; - print HEAD "#define DSEEN\n" if $dseen; - print HEAD "#define ASSUMEN\n" if $assumen; - print HEAD "#define ASSUMEP\n" if $assumep; - print HEAD "#define TOPLABEL\n" if $toplabel; - print HEAD "#define SAWNEXT\n" if $sawnext; - if ($opens) {print HEAD "$opens\n";} - open(BODY,"/tmp/sperl$$") - || &Die("Can't reopen temp file: $!\n"); - while (<BODY>) { - print HEAD $_; - } - close HEAD; - - print &q(<<"EOT"); -: #!$bin/perl -: eval 'exec $bin/perl -S \$0 \${1+"\$@"}' -: if \$running_under_some_shell; -: -EOT - open(BODY,"cc -E /tmp/sperl2$$.c |") || - &Die("Can't reopen temp file: $!\n"); - while (<BODY>) { - /^# [0-9]/ && next; - /^[ \t]*$/ && next; - s/^<><>//; - print; - } -} - -&Cleanup; -exit; - -sub Cleanup { - chdir "/tmp"; - unlink "sperl$$", "sperl2$$", "sperl2$$.c"; -} -sub Die { - &Cleanup; - die $_[0]; -} -sub tab { - "\t" x ($indent / 8) . ' ' x ($indent % 8); -} -sub make_filehandle { - local($_) = $_[0]; - local($fname) = $_; - if (!$seen{$fname}) { - $_ = "FH_" . $_ if /^\d/; - s/[^a-zA-Z0-9]/_/g; - s/^_*//; - $_ = "\U$_"; - if ($fhseen{$_}) { - for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {} - $_ .= $tmp; - } - $fhseen{$_} = 1; - $opens .= &q(<<"EOT"); -: open($_, '>$fname') || die "Can't create $fname: \$!"; -EOT - $seen{$fname} = $_; - } - $seen{$fname}; -} - -sub make_label { - local($label) = @_; - $label =~ s/[^a-zA-Z0-9]/_/g; - if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } - $label = substr($label,0,8); - - # Could be a reserved word, so capitalize it. - substr($label,0,1) =~ y/a-z/A-Z/ - if $label =~ /^[a-z]/; - - $label; -} - -sub transmogrify { - { # case - if (/^d/) { - $dseen++; - chop($_ = &q(<<'EOT')); -: <<--#ifdef PRINTIT -: $printit = 0; -: <<--#endif -: next LINE; -EOT - $sawnext++; - next; - } - - if (/^n/) { - chop($_ = &q(<<'EOT')); -: <<--#ifdef PRINTIT -: <<--#ifdef DSEEN -: <<--#ifdef ASSUMEP -: print if $printit++; -: <<--#else -: if ($printit) -: { print; } -: else -: { $printit++ unless $nflag; } -: <<--#endif -: <<--#else -: print if $printit; -: <<--#endif -: <<--#else -: print; -: <<--#endif -: <<--#ifdef APPENDSEEN -: if ($atext) {chop $atext; print $atext; $atext = '';} -: <<--#endif -: $_ = <>; -: chop; -: <<--#ifdef TSEEN -: $tflag = 0; -: <<--#endif -EOT - next; - } - - if (/^a/) { - $appendseen++; - $command = $space . "\$atext .= <<'End_Of_Text';\n<<--"; - $lastline = 0; - while (<>) { - s/^[ \t]*//; - s/^[\\]//; - unless (s|\\$||) { $lastline = 1;} - s/^([ \t]*\n)/<><>$1/; - $command .= $_; - $command .= '<<--'; - last if $lastline; - } - $_ = $command . "End_Of_Text"; - last; - } - - if (/^[ic]/) { - if (/^c/) { $change = 1; } - $addr1 = 1 if $addr1 eq ''; - $addr1 = '$iter = (' . $addr1 . ')'; - $command = $space . - " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--"; - $lastline = 0; - while (<>) { - s/^[ \t]*//; - s/^[\\]//; - unless (s/\\$//) { $lastline = 1;} - s/'/\\'/g; - s/^([ \t]*\n)/<><>$1/; - $command .= $_; - $command .= '<<--'; - last if $lastline; - } - $_ = $command . "End_Of_Text"; - if ($change) { - $dseen++; - $change = "$_\n"; - chop($_ = &q(<<"EOT")); -: <<--#ifdef PRINTIT -: $space\$printit = 0; -: <<--#endif -: ${space}next LINE; -EOT - $sawnext++; - } - last; - } - - if (/^s/) { - $delim = substr($_,1,1); - $len = length($_); - $repl = $end = 0; - $inbracket = 0; - for ($i = 2; $i < $len; $i++) { - $c = substr($_,$i,1); - if ($c eq $delim) { - if ($inbracket) { - substr($_, $i, 0) = '\\'; - $i++; - $len++; - } - else { - if ($repl) { - $end = $i; - last; - } else { - $repl = $i; - } - } - } - elsif ($c eq '\\') { - $i++; - if ($i >= $len) { - $_ .= 'n'; - $_ .= <>; - $len = length($_); - $_ = substr($_,0,--$len); - } - elsif (substr($_,$i,1) =~ /^[n]$/) { - ; - } - elsif (!$repl && - substr($_,$i,1) =~ /^[(){}\w]$/) { - $i--; - $len--; - substr($_, $i, 1) = ''; - } - elsif (!$repl && - substr($_,$i,1) =~ /^[<>]$/) { - substr($_,$i,1) = 'b'; - } - elsif ($repl && substr($_,$i,1) =~ /^\d$/) { - substr($_,$i-1,1) = '$'; - } - } - elsif ($c eq '&' && $repl) { - substr($_, $i, 0) = '$'; - $i++; - $len++; - } - elsif ($c eq '$' && $repl) { - substr($_, $i, 0) = '\\'; - $i++; - $len++; - } - elsif ($c eq '[' && !$repl) { - $i++ if substr($_,$i,1) eq '^'; - $i++ if substr($_,$i,1) eq ']'; - $inbracket = 1; - } - elsif ($c eq ']') { - $inbracket = 0; - } - elsif ($c eq "\t") { - substr($_, $i, 1) = '\\t'; - $i++; - $len++; - } - elsif (!$repl && index("()+",$c) >= 0) { - substr($_, $i, 0) = '\\'; - $i++; - $len++; - } - } - &Die("Malformed substitution at line $.\n") - unless $end; - $pat = substr($_, 0, $repl + 1); - $repl = substr($_, $repl+1, $end-$repl-1); - $end = substr($_, $end + 1, 1000); - &simplify($pat); - $dol = '$'; - $subst = "$pat$repl$delim"; - $cmd = ''; - while ($end) { - if ($end =~ s/^g//) { - $subst .= 'g'; - next; - } - if ($end =~ s/^p//) { - $cmd .= ' && (print)'; - next; - } - if ($end =~ s/^w[ \t]*//) { - $fh = &make_filehandle($end); - $cmd .= " && (print $fh \$_)"; - $end = ''; - next; - } - &Die("Unrecognized substitution command". - "($end) at line $.\n"); - } - chop ($_ = &q(<<"EOT")); -: <<--#ifdef TSEEN -: $subst && \$tflag++$cmd; -: <<--#else -: $subst$cmd; -: <<--#endif -EOT - next; - } - - if (/^p/) { - $_ = 'print;'; - next; - } - - if (/^w/) { - s/^w[ \t]*//; - $fh = &make_filehandle($_); - $_ = "print $fh \$_;"; - next; - } - - if (/^r/) { - $appendseen++; - s/^r[ \t]*//; - $file = $_; - $_ = "\$atext .= `cat $file 2>/dev/null`;"; - next; - } - - if (/^P/) { - $_ = 'print $1 if /^(.*)/;'; - next; - } - - if (/^D/) { - chop($_ = &q(<<'EOT')); -: s/^.*\n?//; -: redo LINE if $_; -: next LINE; -EOT - $sawnext++; - next; - } - - if (/^N/) { - chop($_ = &q(<<'EOT')); -: $_ .= "\n"; -: $len1 = length; -: $_ .= <>; -: chop if $len1 < length; -: <<--#ifdef TSEEN -: $tflag = 0; -: <<--#endif -EOT - next; - } - - if (/^h/) { - $_ = '$hold = $_;'; - next; - } - - if (/^H/) { - $_ = '$hold .= "\n"; $hold .= $_;'; - next; - } - - if (/^g/) { - $_ = '$_ = $hold;'; - next; - } - - if (/^G/) { - $_ = '$_ .= "\n"; $_ .= $hold;'; - next; - } - - if (/^x/) { - $_ = '($_, $hold) = ($hold, $_);'; - next; - } - - if (/^b$/) { - $_ = 'next LINE;'; - $sawnext++; - next; - } - - if (/^b/) { - s/^b[ \t]*//; - $lab = &make_label($_); - if ($lab eq $toplabel) { - $_ = 'redo LINE;'; - } else { - $_ = "goto $lab;"; - } - next; - } - - if (/^t$/) { - $_ = 'next LINE if $tflag;'; - $sawnext++; - $tseen++; - next; - } - - if (/^t/) { - s/^t[ \t]*//; - $lab = &make_label($_); - $_ = q/if ($tflag) {$tflag = 0; /; - if ($lab eq $toplabel) { - $_ .= 'redo LINE;}'; - } else { - $_ .= "goto $lab;}"; - } - $tseen++; - next; - } - - if (/^y/) { - s/abcdefghijklmnopqrstuvwxyz/a-z/g; - s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g; - s/abcdef/a-f/g; - s/ABCDEF/A-F/g; - s/0123456789/0-9/g; - s/01234567/0-7/g; - $_ .= ';'; - } - - if (/^=/) { - $_ = 'print $.;'; - next; - } - - if (/^q/) { - chop($_ = &q(<<'EOT')); -: close(ARGV); -: @ARGV = (); -: next LINE; -EOT - $sawnext++; - next; - } - } continue { - if ($space) { - s/^/$space/; - s/(\n)(.)/$1$space$2/g; - } - last; - } - $_; -} - -sub fetchpat { - local($outer) = @_; - local($addr) = $outer; - local($inbracket); - local($prefix,$delim,$ch); - - # Process pattern one potential delimiter at a time. - - DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) { - $prefix = $1; - $delim = $2; - if ($delim eq '\\') { - s/(.)//; - $ch = $1; - $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/; - $ch = 'b' if $ch =~ /^[<>]$/; - $delim .= $ch; - } - elsif ($delim eq '[') { - $inbracket = 1; - s/^\^// && ($delim .= '^'); - s/^]// && ($delim .= ']'); - } - elsif ($delim eq ']') { - $inbracket = 0; - } - elsif ($inbracket || $delim ne $outer) { - $delim = '\\' . $delim; - } - $addr .= $prefix; - $addr .= $delim; - if ($delim eq $outer && !$inbracket) { - last DELIM; - } - } - $addr =~ s/\t/\\t/g; - &simplify($addr); - $addr; -} - -sub q { - local($string) = @_; - local($*) = 1; - $string =~ s/^:\t?//g; - $string; -} - -sub simplify { - $_[0] =~ s/_a-za-z0-9/\\w/ig; - $_[0] =~ s/a-z_a-z0-9/\\w/ig; - $_[0] =~ s/a-za-z_0-9/\\w/ig; - $_[0] =~ s/a-za-z0-9_/\\w/ig; - $_[0] =~ s/_0-9a-za-z/\\w/ig; - $_[0] =~ s/0-9_a-za-z/\\w/ig; - $_[0] =~ s/0-9a-z_a-z/\\w/ig; - $_[0] =~ s/0-9a-za-z_/\\w/ig; - $_[0] =~ s/\[\\w\]/\\w/g; - $_[0] =~ s/\[^\\w\]/\\W/g; - $_[0] =~ s/\[0-9\]/\\d/g; - $_[0] =~ s/\[^0-9\]/\\D/g; - $_[0] =~ s/\\d\\d\*/\\d+/g; - $_[0] =~ s/\\D\\D\*/\\D+/g; - $_[0] =~ s/\\w\\w\*/\\w+/g; - $_[0] =~ s/\\t\\t\*/\\t+/g; - $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g; - $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g; -} - diff --git a/x2p/s2p.SH b/x2p/s2p.SH index 1f892aeb60..5819fd9a21 100755 --- a/x2p/s2p.SH +++ b/x2p/s2p.SH @@ -1,21 +1,23 @@ +case $CONFIG in +'') + if test -f config.sh; then TOP=.; + elif test -f ../config.sh; then TOP=..; + elif test -f ../../config.sh; then TOP=../..; + elif test -f ../../../config.sh; then TOP=../../..; + elif test -f ../../../../config.sh; then TOP=../../../..; + else + echo "Can't find config.sh."; exit 1 + fi + . $TOP/config.sh + ;; +esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac -case $CONFIG in -'') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln -s ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi 2>/dev/null - . ./config.sh - ;; -esac -echo "Extracting s2p (with variable substitutions)" + +echo "Extracting x2p/s2p (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted @@ -36,20 +38,6 @@ $spitshell >>s2p <<'!NO!SUBS!' # $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $ # # $Log: s2p.SH,v $ -# Revision 4.1 92/08/07 18:29:23 lwall -# -# Revision 4.0.1.2 92/06/08 17:26:31 lwall -# patch20: s2p didn't output portable startup code -# patch20: added ... as variant on .. -# patch20: s2p didn't translate s/pat/\&/ or s/pat/\$/ or s/pat/\\1/ right -# -# Revision 4.0.1.1 91/06/07 12:19:18 lwall -# patch4: s2p now handles embedded newlines better and optimizes common idioms -# -# Revision 4.0 91/03/20 01:57:59 lwall -# 4.0 baseline. -# -# $indent = 4; $shiftwidth = 4; diff --git a/x2p/s2p.man b/x2p/s2p.man index 1374dff928..ae4611613f 100644 --- a/x2p/s2p.man +++ b/x2p/s2p.man @@ -2,21 +2,6 @@ ''' $RCSfile: s2p.man,v $$Revision: 4.1 $$Date: 92/08/07 18:29:24 $ ''' ''' $Log: s2p.man,v $ -''' Revision 4.1 92/08/07 18:29:24 lwall -''' -''' Revision 4.0.1.1 91/06/07 12:19:57 lwall -''' patch4: s2p now handles embedded newlines better and optimizes common idioms -''' -''' Revision 4.0 91/03/20 01:58:07 lwall -''' 4.0 baseline. -''' -''' Revision 3.0 89/10/18 15:35:09 lwall -''' 3.0 baseline -''' -''' Revision 2.0 88/06/05 00:15:59 root -''' Baseline version 2.0. -''' -''' .de Sh .br .ne 5 @@ -6,14 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: str.c,v $ - * Revision 4.1 92/08/07 18:29:26 lwall - * - * Revision 4.0.1.1 91/06/07 12:20:08 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:58:15 lwall - * 4.0 baseline. - * */ #include "handy.h" @@ -195,7 +187,7 @@ char *keeplist; else *to++ = *from++; } - else if (index(keeplist,from[1])) + else if (strchr(keeplist,from[1])) *to++ = *from++; else from++; @@ -6,14 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: str.h,v $ - * Revision 4.1 92/08/07 18:29:27 lwall - * - * Revision 4.0.1.1 91/06/07 12:20:22 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:58:21 lwall - * 4.0 baseline. - * */ struct string { diff --git a/x2p/util.c b/x2p/util.c index 5fd96f831c..79cba699df 100644 --- a/x2p/util.c +++ b/x2p/util.c @@ -6,14 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: util.c,v $ - * Revision 4.1 92/08/07 18:29:29 lwall - * - * Revision 4.0.1.1 91/06/07 12:20:35 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:58:25 lwall - * 4.0 baseline. - * */ #include <stdio.h> @@ -31,7 +23,6 @@ static char nomem[] = "Out of memory!\n"; /* paranoid version of malloc */ -static int an = 0; char * safemalloc(size) @@ -201,6 +192,14 @@ int newlen; } /*VARARGS1*/ +croak(pat,a1,a2,a3,a4) +char *pat; +{ + fprintf(stderr,pat,a1,a2,a3,a4); + exit(1); +} + +/*VARARGS1*/ fatal(pat,a1,a2,a3,a4) char *pat; { diff --git a/x2p/util.h b/x2p/util.h index b088e4a98a..eeb128ba2c 100644 --- a/x2p/util.h +++ b/x2p/util.h @@ -6,17 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: util.h,v $ - * Revision 4.1 92/08/07 18:29:30 lwall - * - * Revision 4.0.1.2 91/11/05 19:21:20 lwall - * patch11: various portability fixes - * - * Revision 4.0.1.1 91/06/07 12:20:43 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:58:29 lwall - * 4.0 baseline. - * */ /* is the string for makedir a directory name or a filename? */ diff --git a/x2p/walk.c b/x2p/walk.c index 55ba719b23..26e89ae5bd 100644 --- a/x2p/walk.c +++ b/x2p/walk.c @@ -6,24 +6,6 @@ * License or the Artistic License, as specified in the README file. * * $Log: walk.c,v $ - * Revision 4.1 92/08/07 18:29:31 lwall - * - * Revision 4.0.1.3 92/06/08 17:33:46 lwall - * patch20: in a2p, simplified the filehandle model - * patch20: in a2p, made RS="" translate to $/ = "\n\n" - * patch20: in a2p, do {...} while ... was missing some reconstruction code - * patch20: in a2p, getline should allow variable to be array element - * - * Revision 4.0.1.2 91/11/05 19:25:09 lwall - * patch11: in a2p, split on whitespace produced extra null field - * - * Revision 4.0.1.1 91/06/07 12:22:04 lwall - * patch4: new copyright notice - * patch4: a2p didn't correctly implement -n switch - * - * Revision 4.0 91/03/20 01:58:36 lwall - * 4.0 baseline. - * */ #include "handy.h" @@ -66,7 +48,7 @@ int minprec; /* minimum precedence without parens */ int numeric = FALSE; STR *fstr; int prec = P_MAX; /* assume no parens needed */ - char *index(); + char *strchr(); if (!node) { *numericptr = 0; @@ -109,7 +91,7 @@ int minprec; /* minimum precedence without parens */ do_chop = TRUE; if (fswitch) { str_cat(str,"$FS = '"); - if (index("*+?.[]()|^$\\",fswitch)) + if (strchr("*+?.[]()|^$\\",fswitch)) str_cat(str,"\\"); sprintf(tokenbuf,"%c",fswitch); str_cat(str,tokenbuf); @@ -397,8 +379,8 @@ sub Pick {\n\ str_set(tmpstr,"gt"); else if (strEQ(t,">=")) str_set(tmpstr,"ge"); - if (!index(tmpstr->str_ptr,'\'') && !index(tmpstr->str_ptr,'"') && - !index(tmp2str->str_ptr,'\'') && !index(tmp2str->str_ptr,'"') ) + if (!strchr(tmpstr->str_ptr,'\'') && !strchr(tmpstr->str_ptr,'"') && + !strchr(tmp2str->str_ptr,'\'') && !strchr(tmp2str->str_ptr,'"') ) numeric |= 2; } if (numeric & 2) { @@ -604,7 +586,7 @@ sub Pick {\n\ if (!isalpha(*t) && !isdigit(*t)) *t = '_'; } - if (!index(tokenbuf,'_')) + if (!strchr(tokenbuf,'_')) strcpy(t,"_FH"); tmp3str = hfetch(symtab,tokenbuf); if (!tmp3str) { @@ -693,7 +675,7 @@ sub Pick {\n\ fstr = walk(1,level,ops[node+3].ival,&numarg,P_COMMA+1); if (str_len(fstr) == 3 && *fstr->str_ptr == '\'') { i = fstr->str_ptr[1] & 127; - if (index("*+?.[]()|^$\\",i)) + if (strchr("*+?.[]()|^$\\",i)) sprintf(tokenbuf,"/\\%c/",i); else if (i == ' ') sprintf(tokenbuf,"' '"); @@ -1135,7 +1117,7 @@ sub Pick {\n\ if (!isalpha(*t) && !isdigit(*t)) *t = '_'; } - if (!index(tokenbuf,'_')) + if (!strchr(tokenbuf,'_')) strcpy(t,"_FH"); str_free(tmpstr); safefree(s); @@ -1172,7 +1154,7 @@ sub Pick {\n\ if (!isalpha(*t) && !isdigit(*t)) *t = '_'; } - if (!index(tokenbuf,'_')) + if (!strchr(tokenbuf,'_')) strcpy(t,"_FH"); tmp3str = hfetch(symtab,tokenbuf); if (!tmp3str) { @@ -1448,7 +1430,7 @@ sub Pick {\n\ } str_cat(str,"; "); fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN); - if (i && (t = index(fstr->str_ptr,0377))) { + if (i && (t = strchr(fstr->str_ptr,0377))) { if (strnEQ(fstr->str_ptr,s,i)) *t = ' '; } @@ -1464,12 +1446,12 @@ sub Pick {\n\ break; case OFORIN: tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN); - d = index(tmpstr->str_ptr,'$'); + d = strchr(tmpstr->str_ptr,'$'); if (!d) fatal("Illegal for loop: %s",tmpstr->str_ptr); - s = index(d,'{'); + s = strchr(d,'{'); if (!s) - s = index(d,'['); + s = strchr(d,'['); if (!s) fatal("Illegal for loop: %s",d); *s++ = '\0'; @@ -211,7 +211,7 @@ while (<>) { s/\bSTAB_/GV_/g && study; s/\bSF_/GVf_/g && study; s/\bSPAT_/PMf_/g && study; - s/\bF_/FFt_/g && study; + #s/\bF_/FFt_/g && study; s/\bFC_/FFf_/g && study; s/\bO_/OP_/g && study; s/\bC_/COP_/g && study; |