--- /dev/null
+
+
+
+
+ The "Artistic License"
+
+ Preamble
+
+The intent of this document is to state the conditions under which a
+Package may be copied, such that the Copyright Holder maintains some
+semblance of artistic control over the development of the package,
+while giving the users of the package the right to use and distribute
+the Package in a more-or-less customary fashion, plus the right to make
+reasonable modifications.
+
+Definitions:
+
+ "Package" refers to the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection of files
+ created through textual modification.
+
+ "Standard Version" refers to such a Package if it has not been
+ modified, or has been modified in accordance with the wishes
+ of the Copyright Holder.
+
+ "Copyright Holder" is whoever is named in the copyright or
+ copyrights for the package.
+
+ "You" is you, if you're thinking about copying or distributing
+ this Package.
+
+ "Reasonable copying fee" is whatever you can justify on the
+ basis of media cost, duplication charges, time of people involved,
+ and so on. (You will not be required to justify it to the
+ Copyright Holder, but only to the computing community at large
+ as a market that must bear the fee.)
+
+ "Freely Available" means that no fee is charged for the item
+ itself, though there may be fees involved in handling the item.
+ It also means that recipients of the item may redistribute it
+ under the same conditions they received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications
+derived from the Public Domain or from the Copyright Holder. A Package
+modified in such a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided
+that you insert a prominent notice in each changed file stating how and
+when you changed that file, and provided that you do at least ONE of the
+following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or
+ an equivalent medium, or placing the modifications on a major archive
+ site such as uunet.uu.net, or by allowing the Copyright Holder to include
+ your modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict
+ with standard executables, which must also be provided, and provide
+ a separate manual page for each non-standard executable that clearly
+ documents how it differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or
+executable form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where
+ to get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of
+ the Package with your modifications.
+
+ c) accompany any non-standard executables with their corresponding
+ Standard Version executables, giving the non-standard executables
+ non-standard names, and clearly documenting the differences in manual
+ pages (or equivalent), together with instructions on where to get
+ the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this Package.
+You may not charge a fee for this Package itself. However,
+you may distribute this Package in aggregate with other (possibly
+commercial) programs as part of a larger (possibly commercial) software
+distribution provided that you do not advertise this Package as a
+product of your own.
+
+6. The scripts and library files supplied as input to or produced as
+output from the programs of this Package do not automatically fall
+under the copyright of this Package, but belong to whomever generated
+them, and may be sold commercially, and may be aggregated with this
+Package.
+
+7. C subroutines supplied by you and linked into this Package in order
+to emulate subroutines and variables of the language defined by this
+Package shall not be considered part of this Package, but are the
+equivalent of input as in Paragraph 6, provided these subroutines do
+not change the language in any way that would cause it to fail the
+regression tests for the language.
+
+8. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+ The End
--- /dev/null
+#! /bin/sh
+#
+# If these # comments don't work, trim them. Don't worry about any other
+# shell scripts, Configure will trim # comments from them for you.
+#
+# (If you are trying to port this package to a machine without sh, I would
+# suggest you cut out the prototypical config.h from the end of Configure
+# and edit it to reflect your system. Some packages may include samples
+# of config.h for certain machines, so you might look for one of those.)
+#
+# $RCSfile: Configure,v $$Revision: 4.0.1.6 $$Date: 91/11/11 16:26:51 $
+#
+# Yes, you may rip this off to use in other distribution packages.
+# (Note: this Configure script was generated automatically. Rather than
+# working with this copy of Configure, you may wish to get metaconfig.)
+
+cat >/tmp/c1$$ <<EOF
+ARGGGHHHH!!!!!
+
+Your csh still thinks true is false. Write to your vendor today and tell
+them that next year Configure ought to "rm /bin/csh" unless they fix their
+blasted shell. :-)
+
+[End of diatribe. We now return you to your regularly scheduled
+programming...]
+
+EOF
+cat >/tmp/c2$$ <<EOF
+OOPS! You naughty creature! You didn't run Configure with sh!
+I will attempt to remedy the situation by running sh for you...
+
+EOF
+
+true || cat /tmp/c1$$ /tmp/c2$$
+true || exec sh $0
+
+export PATH || cat /tmp/c2$$
+export PATH || exec sh $0
+rm -f /tmp/c1$$ /tmp/c2$$
+
+PATH=".:$PATH:/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/local:/usr/lbin:/etc:/usr/new:/usr/new/bin:/usr/nbin"
+
+if test ! -t 0; then
+ echo "Say 'sh Configure', not 'sh <Configure'"
+ exit 1
+fi
+
+(alias) >/dev/null 2>&1 && \
+ echo "(I see you are using the Korn shell. Some ksh's blow up on Configure," && \
+ echo "especially on exotic machines. If yours does, try the Bourne shell instead.)"
+
+if test ! -d ../UU; then
+ if test ! -d UU; then
+ mkdir UU
+ fi
+ cd UU
+fi
+
+case "$1" in
+-d) shift; fastread='yes';;
+esac
+
+d_eunice=''
+define=''
+eunicefix=''
+loclist=''
+expr=''
+sed=''
+echo=''
+cat=''
+rm=''
+mv=''
+cp=''
+tail=''
+tr=''
+mkdir=''
+sort=''
+uniq=''
+grep=''
+trylist=''
+test=''
+inews=''
+egrep=''
+more=''
+pg=''
+Mcc=''
+vi=''
+mailx=''
+mail=''
+cpp=''
+perl=''
+emacs=''
+ls=''
+rmail=''
+sendmail=''
+shar=''
+smail=''
+tbl=''
+troff=''
+nroff=''
+uname=''
+uuname=''
+line=''
+chgrp=''
+chmod=''
+lint=''
+sleep=''
+pr=''
+tar=''
+ln=''
+lpr=''
+lp=''
+touch=''
+make=''
+date=''
+csh=''
+bash=''
+ksh=''
+lex=''
+flex=''
+bison=''
+Log=''
+Header=''
+Id=''
+lastuname=''
+alignbytes=''
+bin=''
+installbin=''
+byteorder=''
+contains=''
+cppstdin=''
+cppminus=''
+d_bcmp=''
+d_bcopy=''
+d_bzero=''
+d_castneg=''
+castflags=''
+d_charsprf=''
+d_chsize=''
+d_crypt=''
+cryptlib=''
+d_csh=''
+d_dosuid=''
+d_dup2=''
+d_fchmod=''
+d_fchown=''
+d_fcntl=''
+d_flexfnam=''
+d_flock=''
+d_getgrps=''
+d_gethent=''
+d_getpgrp=''
+d_getpgrp2=''
+d_getprior=''
+d_htonl=''
+d_index=''
+d_killpg=''
+d_lstat=''
+d_memcmp=''
+d_memcpy=''
+d_mkdir=''
+d_msg=''
+d_msgctl=''
+d_msgget=''
+d_msgrcv=''
+d_msgsnd=''
+d_ndbm=''
+d_odbm=''
+d_open3=''
+d_readdir=''
+d_rename=''
+d_rmdir=''
+d_select=''
+d_sem=''
+d_semctl=''
+d_semget=''
+d_semop=''
+d_setegid=''
+d_seteuid=''
+d_setpgrp=''
+d_setpgrp2=''
+d_setprior=''
+d_setregid=''
+d_setresgid=''
+d_setreuid=''
+d_setresuid=''
+d_setrgid=''
+d_setruid=''
+d_shm=''
+d_shmat=''
+d_voidshmat=''
+d_shmctl=''
+d_shmdt=''
+d_shmget=''
+d_socket=''
+d_sockpair=''
+d_oldsock=''
+socketlib=''
+d_statblks=''
+d_stdstdio=''
+d_strctcpy=''
+d_strerror=''
+d_symlink=''
+d_syscall=''
+d_truncate=''
+d_vfork=''
+d_voidsig=''
+d_tosignal=''
+d_volatile=''
+d_vprintf=''
+d_charvspr=''
+d_wait4=''
+d_waitpid=''
+gidtype=''
+groupstype=''
+i_fcntl=''
+i_gdbm=''
+i_grp=''
+i_niin=''
+i_sysin=''
+i_pwd=''
+d_pwquota=''
+d_pwage=''
+d_pwchange=''
+d_pwclass=''
+d_pwexpire=''
+d_pwcomment=''
+i_sys_file=''
+i_sysioctl=''
+i_time=''
+i_sys_time=''
+i_sys_select=''
+d_systimekernel=''
+i_utime=''
+i_varargs=''
+i_vfork=''
+intsize=''
+libc=''
+nm_opts=''
+libndir=''
+i_my_dir=''
+i_ndir=''
+i_sys_ndir=''
+i_dirent=''
+i_sys_dir=''
+d_dirnamlen=''
+ndirc=''
+ndiro=''
+mallocsrc=''
+mallocobj=''
+d_mymalloc=''
+mallocptrtype=''
+mansrc=''
+manext=''
+models=''
+split=''
+small=''
+medium=''
+large=''
+huge=''
+optimize=''
+ccflags=''
+cppflags=''
+ldflags=''
+cc=''
+nativegcc=''
+libs=''
+n=''
+c=''
+package=''
+randbits=''
+scriptdir=''
+installscr=''
+sig_name=''
+spitshell=''
+shsharp=''
+sharpbang=''
+startsh=''
+stdchar=''
+uidtype=''
+usrinclude=''
+inclPath=''
+void=''
+voidhave=''
+voidwant=''
+w_localtim=''
+w_s_timevl=''
+w_s_tm=''
+yacc=''
+lib=''
+privlib=''
+installprivlib=''
+CONFIG=''
+: get the name of the package
+package=perl
+: Here we go...
+echo " "
+echo "Beginning of configuration questions for $package kit."
+: Eunice requires " " instead of "", can you believe it
+echo " "
+
+define='define'
+undef='undef'
+: change the next line if compiling for Xenix/286 on Xenix/386
+xlibpth='/usr/lib/386 /lib/386'
+
+: the hints files may add more components to libpth
+test -d /usr/cs/lib && libpth="$libpth /usr/cs/lib"
+test -d /usr/ccs/lib && libpth="$libpth /usr/ccs/lib"
+test -d /usr/lib && libpth="$libpth /usr/lib"
+test -d /usr/ucblib && libpth="$libpth /usr/ucblib"
+test -d /usr/local/lib && libpth="$libpth /usr/local/lib"
+test -d /usr/lib/large && libpth="$libpth /usr/lib/large"
+test -d /lib && libpth="$libpth /lib"
+ libpth="$libpth $xlibpth"
+test -d /lib/large && libpth="$libpth /lib/large"
+test -d /usr/lib/small && libpth="$libpth /usr/lib/small"
+test -d /lib/small && libpth="$libpth /lib/small"
+test -d /usr/lib/cmplrs/cc && libpth="$libpth /usr/lib/cmplrs/cc"
+
+smallmach='pdp11 i8086 z8000 i80286 iAPX286'
+trap 'echo " "; exit 1' 1 2 3
+
+: We must find out about Eunice early
+eunicefix=':'
+if test -f /etc/unixtovms; then
+ eunicefix=/etc/unixtovms
+fi
+if test -f /etc/unixtovms.exe; then
+ eunicefix=/etc/unixtovms.exe
+fi
+
+attrlist="DGUX M_I186 M_I286 M_I386 M_I8086 M_XENIX UTS __DGUX__"
+attrlist="$attrlist __STDC__ __m88k__ ansi bsd4_2 gcos gimpel"
+attrlist="$attrlist hp9000s300 hp9000s500 hp9000s800 hpux"
+attrlist="$attrlist i186 i386 i8086 iAPX286 ibm interdata"
+attrlist="$attrlist m68k m88k mc300 mc500 mc68000 mc68k mc700 mert"
+attrlist="$attrlist ns16000 ns32000 nsc32000 os pdp11 posix pyr sinix"
+attrlist="$attrlist sparc sun tower tower32 tower32_600 tower32_800 tss"
+attrlist="$attrlist u3b2 u3b20 u3b200 u3b5 ultrix unix vax venix xenix"
+attrlist="$attrlist z8000"
+boPATH=""
+eoPATH="/usr/ucb /bin /usr/bin /usr/local /usr/local/bin /usr/lbin /usr/plx /usr/5bin /vol/local/bin /etc /usr/lib /lib /usr/local/lib /sys5.3/bin /sys5.3/usr/bin /bsd4.3/bin /bsd4.3/usr/bin /bsd4.3/usr/ucb /bsd43/usr/bin"
+d_newshome="/usr/NeWS"
+errnolist=errnolist
+h_fcntl=false
+h_sys_file=false
+serve_shm=""
+serve_msg="$undef"
+serve_inet_udp=""
+serve_inet_tcp=""
+serve_unix_udp=""
+serve_unix_tcp=""
+d_ndir=ndir
+voidwant=1
+voidwant=7
+libswanted="c_s net_s net socket nsl_s nsl nm ndir ndbm dbm PW malloc sun m bsd BSD x posix ucb"
+inclwanted='/usr/include /usr/netinclude /usr/include/sun /usr/include/bsd /usr/include/lan /usr/ucbinclude'
+
+: Now test for existence of everything in MANIFEST
+
+echo "First let's make sure your kit is complete. Checking..."
+awk '$1 !~ /PACKINGLIST/ {print $1}' ../MANIFEST | split -200
+rm -f missing
+for filelist in x??; do
+ (cd ..; ls `cat UU/$filelist` >/dev/null 2>>UU/missing)
+done
+if test -s missing; then
+ cat missing
+ kill $$
+fi
+echo "Looks good..."
+
+: some greps do not return status, grrr.
+echo "grimblepritz" >contains.txt
+if grep blurfldyick contains.txt >/dev/null 2>&1 ; then
+ contains=contains
+elif grep grimblepritz contains.txt >/dev/null 2>&1 ; then
+ contains=grep
+else
+ contains=contains
+fi
+: the following should work in any shell
+case "$contains" in
+contains*)
+ echo " "
+ echo "AGH! Grep doesn't return a status. Attempting remedial action."
+ cat >contains <<'EOSS'
+grep "$1" "$2" >.greptmp && cat .greptmp && test -s .greptmp
+EOSS
+chmod +x contains
+esac
+
+: see if sh knows # comments
+echo " "
+echo "Checking your sh to see if it knows about # comments..."
+if sh -c '#' >/dev/null 2>&1 ; then
+ echo "Your sh handles # comments correctly."
+ shsharp=true
+ spitshell=cat
+ echo " "
+ echo "Okay, let's see if #! works on this system..."
+ if test -f /bsd43/bin/echo; then
+ echo "#!/bsd43/bin/echo hi" > spit.sh
+ else
+ echo "#!/bin/echo hi" > spit.sh
+ fi
+ $eunicefix spit.sh
+ chmod +x spit.sh
+ ./spit.sh > today
+ if $contains hi today >/dev/null 2>&1; then
+ echo "It does."
+ sharpbang='#!'
+ else
+ echo "#! /bin/echo hi" > spit.sh
+ $eunicefix spit.sh
+ chmod +x spit.sh
+ ./spit.sh > today
+ if test -s today; then
+ echo "It does."
+ sharpbang='#! '
+ else
+ echo "It doesn't."
+ sharpbang=': use '
+ fi
+ fi
+else
+ echo "Your sh doesn't grok # comments--I will strip them later on."
+ shsharp=false
+ echo "exec grep -v '^#'" >spitshell
+ chmod +x spitshell
+ $eunicefix spitshell
+ spitshell=`pwd`/spitshell
+ echo "I presume that if # doesn't work, #! won't work either!"
+ sharpbang=': use '
+fi
+
+: figure out how to guarantee sh startup
+echo " "
+echo "Checking out how to guarantee sh startup..."
+startsh=$sharpbang'/bin/sh'
+echo "Let's see if '$startsh' works..."
+cat >start.sh <<EOSS
+$startsh
+set abc
+test "$?abc" != 1
+EOSS
+
+chmod +x start.sh
+$eunicefix start.sh
+if ./start.sh; then
+ echo "Yup, it does."
+else
+ echo "Nope. You may have to fix up the shell scripts to make sure sh runs them."
+fi
+
+: first determine how to suppress newline on echo command
+echo "Checking echo to see how to suppress newlines..."
+(echo "hi there\c" ; echo " ") >echotmp
+if $contains c echotmp >/dev/null 2>&1 ; then
+ echo "...using -n."
+ n='-n'
+ c=''
+else
+ cat <<'EOM'
+...using \c
+EOM
+ n=''
+ c='\c'
+fi
+echo $n "Type carriage return to continue. Your cursor should be here-->$c"
+read ans
+
+: now set up to do reads with possible shell escape and default assignment
+cat <<EOSC >myread
+case "\$fastread" in
+yes) ans=''; echo " " ;;
+*) ans='!';;
+esac
+while expr "X\$ans" : "X!" >/dev/null; do
+ read ans
+ case "\$ans" in
+ !)
+ sh
+ echo " "
+ echo $n "\$rp $c"
+ ;;
+ !*)
+ set \`expr "X\$ans" : "X!\(.*\)\$"\`
+ sh -c "\$*"
+ echo " "
+ echo $n "\$rp $c"
+ ;;
+ esac
+done
+rp='Your answer:'
+case "\$ans" in
+'') ans="\$dflt";;
+esac
+EOSC
+
+: general instructions
+cat <<EOH
+
+This installation shell script will examine your system and ask you questions
+to determine how the $package package should be installed. If you get stuck
+on a question, you may use a ! shell escape to start a subshell or execute
+a command. Many of the questions will have default answers in square
+brackets--typing carriage return will give you the default.
+
+On some of the questions which ask for file or directory names you are
+allowed to use the ~name construct to specify the login directory belonging
+to "name", even if you don't have a shell which knows about that. Questions
+where this is allowed will be marked "(~name ok)".
+
+EOH
+rp="[Type carriage return to continue]"
+echo $n "$rp $c"
+. myread
+cat <<EOH
+
+Much effort has been expended to ensure that this shell script will run on any
+Unix system. If despite that it blows up on you, your best bet is to edit
+Configure and run it again. Also, let me (lwall@netlabs.com)
+know how I blew it. If you can't run Configure for some reason, you'll have
+to generate a config.sh file by hand.
+
+This installation script affects things in two ways: 1) it may do direct
+variable substitutions on some of the files included in this kit, and
+2) it builds a config.h file for inclusion in C programs. You may edit
+any of these files as the need arises after running this script.
+
+If you make a mistake on a question, there is no easy way to back up to it
+currently. The easiest thing to do is to edit config.sh and rerun all the
+SH files. Configure will offer to let you do this before it runs the SH files.
+
+EOH
+rp="[Type carriage return to continue]"
+echo $n "$rp $c"
+. myread
+
+: find out where common programs are
+echo " "
+echo "Locating common programs..."
+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="
+cat
+cp
+echo
+expr
+grep
+mkdir
+mv
+rm
+sed
+sort
+tr
+uniq
+"
+trylist="
+Mcc
+bison
+cpp
+csh
+egrep
+line
+nroff
+perl
+test
+uname
+yacc
+"
+pth=`echo :$boPATH:$PATH:$eoPATH: | sed -e 's/:/ /g'`
+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..."
+ans=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, $ans."
+ ans=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."
+ ;;
+/bin/test)
+ if sh -c "PATH= test true" >/dev/null 2>&1; then
+ echo "Using the test built into your sh."
+ test=test
+ fi
+ ;;
+*)
+ test=test
+ ;;
+esac
+case "$echo" in
+echo)
+ echo "Hopefully echo is built into your sh."
+ ;;
+/bin/echo)
+ echo " "
+ echo "Checking compatibility between /bin/echo and builtin echo (if any)..."
+ $echo $n "hi there$c" >Loc1.txt
+ echo $n "hi there$c" >Loc2.txt
+ if cmp Loc1.txt Loc2.txt >/dev/null 2>&1; then
+ echo "They are compatible. In fact, they may be identical."
+ else
+ case "$n" in
+ '-n') n='' c='\c' ans='\c' ;;
+ *) n='-n' c='' ans='-n' ;;
+ esac
+ cat <<FOO
+They are not compatible! You are probably running ksh on a non-USG system.
+I'll have to use /bin/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 $ans to suppress newlines now. Life is ridiculous.
+
+FOO
+ rp="Your cursor should be here-->"
+ $echo $n "$rp$c"
+ . myread
+ fi
+ ;;
+*)
+ : cross your fingers
+ echo=echo
+ ;;
+esac
+
+: set up shell script to do ~ expansion
+cat >filexp <<EOSS
+$startsh
+: expand filename
+case "\$1" in
+ ~/*|~)
+ echo \$1 | $sed "s|~|\${HOME-\$LOGDIR}|"
+ ;;
+ ~*)
+ if $test -f /bin/csh; then
+ /bin/csh -f -c "glob \$1"
+ echo ""
+ else
+ name=\`$expr x\$1 : '..\([^/]*\)'\`
+ dir=\`$sed -n -e "/^\${name}:/{s/^[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:\([^:]*\).*"'\$'"/\1/" -e p -e q -e '}' </etc/passwd\`
+ if $test ! -d "\$dir"; then
+ me=\`basename \$0\`
+ echo "\$me: can't locate home directory for: \$name" >&2
+ exit 1
+ fi
+ case "\$1" in
+ */*)
+ echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\`
+ ;;
+ *)
+ echo \$dir
+ ;;
+ esac
+ fi
+ ;;
+*)
+ echo \$1
+ ;;
+esac
+EOSS
+chmod +x filexp
+$eunicefix filexp
+
+: get old answers, if there is a config file out there
+hint=default
+if test -f ../config.sh; then
+ echo " "
+ eval "`grep lastuname ../config.sh`"
+ tmp=`(uname -a) 2>&1`
+ if test "X$tmp" = "X$lastuname"; then
+ dflt=y
+ else
+ dflt=n
+ fi
+ lastuname="$tmp"
+ rp="I see a config.sh file. Did Configure make it on THIS system? [$dflt]"
+ echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ n*) echo "OK, I'll ignore it."; mv ../config.sh ../config.sh.old;;
+ *) echo "Fetching default answers from your old config.sh file..."
+ tmp="$n"
+ ans="$c"
+ . ../config.sh
+ n="$tmp"
+ c="$ans"
+ hint=previous
+ ;;
+ esac
+else
+ lastuname=`(uname -a) 2>&1`
+fi
+if test -d ../hints && test ! -f ../config.sh; then
+ echo ' '
+ echo "First time through, eh? I have some defaults handy for the following systems:"
+ (cd ../hints; ls -C *.sh | sed 's/\.sh/ /g')
+ dflt=''
+ : Half the following guesses are probably wrong...
+ test -f /irix && dflt="$dflt sgi"
+ test -f /xenix && dflt="$dflt sco_xenix"
+ test -f /dynix && dflt="$dflt dynix"
+ test -f /dnix && dflt="$dflt dnix"
+ test -f /bin/mips && /bin/mips && dflt="$dflt mips"
+ test -d /NextApps && test -f /usr/adm/software_version && dflt="$dflt next"
+ if test -f /bin/uname || test -f /usr/bin/uname; then
+ set `uname -a | tr '[A-Z]' '[a-z]'`
+
+ test -f "../hints/$5.sh" && dflt="$dflt $5"
+
+ case "$5" in
+ 3b2) dflt="$dflt 3b2";;
+ fps*) dflt="$dflt fps";;
+ mips*) dflt="$dflt mips";;
+ [23]100) dflt="$dflt mips";;
+ next*) dflt="$dflt next" ;;
+ esac
+
+ case "$1" in
+ aix) dflt="$dflt aix_rs" ;;
+ sunos) case "$3" in
+ 3.4) dflt="$dflt sunos_3_4" ;;
+ 3.5) dflt="$dflt sunos_3_5" ;;
+ 4.0.1) dflt="$dflt sunos_4_0_1" ;;
+ 4.0.2) dflt="$dflt sunos_4_0_2" ;;
+ esac
+ ;;
+ dnix) dflt="$dflt dnix" ;;
+ genix) dflt="$dflt genix" ;;
+ hp*ux) dflt="$dflt hpux" ;;
+ next) dflt="$dflt next" ;;
+ irix) dflt="$dflt sgi" ;;
+ ultrix) case "$3" in
+ 3*) dflt="$dflt ultrix_3" ;;
+ 4*) dflt="$dflt ultrix_4" ;;
+ esac
+ ;;
+ uts) dflt="$dflt uts" ;;
+ $2) if test -f /etc/systemid; then
+ set `echo $3 | sed 's/\./ /` $4
+ if test -f ../hints/sco_$1_$2_$3.sh; then
+ dflt="$dflt sco_$1_$2_$3"
+ elif test -f ../hints/sco_$1_$2.sh; then
+ dflt="$dflt sco_$1_$2"
+ elif test -f ../hints/sco_$1.sh; then
+ dflt="$dflt sco_$1"
+ fi
+ fi
+ ;;
+ esac
+ fi
+ set X `echo $dflt | tr ' ' '\012' | sort | uniq`
+ shift
+ dflt=${1+"$@"}
+ case "$dflt" in
+ '') dflt=none;;
+ esac
+ echo '(You may give one or more space-separated answers, or "none" if appropriate.'
+ echo 'If your OS version has no hints, do not give a wrong version--say "none".)'
+ rp="Which of these apply, if any? [$dflt]"
+ echo $n "$rp $c"
+ . myread
+ for file in $ans; do
+ if test -f ../hints/$file.sh; then
+ . ../hints/$file.sh
+ cat ../hints/$file.sh >>../config.sh
+ hint=recommended
+ fi
+ done
+fi
+
+cat >whoa <<'EOF'
+eval "was=\$$2"
+dflt=y
+echo ' '
+echo "*** WHOA THERE!!! ***"
+echo " The $hint value for \$$2 on this machine was \"$was\"!"
+rp=" Keep the $hint value? [y]"
+echo $n "$rp $c"
+. myread
+case "$ans" in
+y) td=$was; tu=$was;;
+esac
+EOF
+
+setvar='td=$define; tu=$undef; set X $1; eval "was=\$$2";
+case "$val$was" in
+defineundef) . whoa; eval "$2=\$td";;
+undefdefine) . whoa; eval "$2=\$tu";;
+*) eval "$2=$val";;
+esac'
+
+: determine where manual pages go
+$cat <<EOM
+
+$package has manual pages available in source form.
+EOM
+case "$nroff" in
+'')
+ echo "However, you don't have nroff, so they're probably useless to you."
+ case "$mansrc" in
+ '')
+ mansrc="none"
+ ;;
+ esac
+esac
+echo "If you don't want the manual sources installed, answer 'none'."
+case "$mansrc" in
+'')
+ dflt=`./loc . none /usr/man/local/man1 /usr/man/man.L /usr/man/manl /usr/man/mann /usr/man/u_man/man1 /usr/man/man1`
+ ;;
+*) dflt="$mansrc"
+ ;;
+esac
+cont=true
+while $test "$cont" ; do
+ echo " "
+ rp="Where do the manual pages (source) go (~name ok)? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ 'none')
+ mansrc=''
+ cont=''
+ ;;
+ *)
+ mansrc=`./filexp "$ans"`
+ if $test -d "$mansrc"; then
+ cont=''
+ else
+ if $test "$fastread" = yes; then
+ dflt=y
+ else
+ dflt=n
+ fi
+ rp="Directory $mansrc doesn't exist. Use that name anyway? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ dflt=''
+ case "$ans" in
+ y*) cont='';;
+ esac
+ fi
+ ;;
+ esac
+done
+case "$mansrc" in
+'')
+ manext=''
+ ;;
+*l)
+ manext=l
+ ;;
+*n)
+ manext=n
+ ;;
+*o)
+ manext=l
+ ;;
+*p)
+ manext=n
+ ;;
+*C)
+ manext=C
+ ;;
+*L)
+ manext=L
+ ;;
+*)
+ manext=1
+ ;;
+esac
+
+: Sigh. Well, at least the box is fast...
+echo " "
+$echo $n "Hmm... $c"
+case "$usrinclude" in
+'') dflt='/usr/include';;
+*) dflt=$usrinclude;;
+esac
+inclPath=''
+if $test -f /bin/mips && /bin/mips; then
+ echo "Looks like a MIPS system..."
+ $cat >usrinclude.c <<'EOCP'
+#ifdef SYSTYPE_BSD43
+/bsd43
+#endif
+EOCP
+ if cc -E usrinclude.c > usrinclude.out && $contains / usrinclude.out >/dev/null 2>&1 ; then
+ echo "and you're compiling with the BSD43 compiler and libraries."
+ dflt='/bsd43/usr/include'
+ inclPath='/bsd43'
+ else
+ echo "and you're compiling with the SysV compiler and libraries."
+ fi
+else
+ echo "Doesn't look like a MIPS system."
+ echo "exit 1" >mips
+ chmod +x mips
+ $eunicefix mips
+fi
+
+cont=true
+while $test "$cont" ; do
+ echo " "
+ rp="Where are the include files you want to use? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ usrinclude="$ans"
+ if $test -d $ans; then
+ cont=''
+ else
+ if $test "$fastread" = yes; then
+ dflt=y
+ else
+ dflt=n
+ fi
+ rp="Directory $ans doesn't exist. Use that name anyway? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ dflt=''
+ case "$ans" in
+ y*) cont='';;
+ esac
+ fi
+done
+
+: make some quick guesses about what we are up against
+echo " "
+cat $usrinclude/signal.h $usrinclude/sys/signal.h >guess.txt 2>/dev/null
+if test "$usrinclude" = "/bsd43/usr/include" ; then
+ echo "Looks kind of like a SysV MIPS running BSD, but we'll see..."
+ echo exit 0 >bsd
+ echo exit 1 >usg
+ echo exit 1 >v7
+elif test `echo abc | tr a-z A-Z` = Abc ; then
+ echo "Looks kind of like a USG system, but we'll see..."
+ echo exit 1 >bsd
+ echo exit 0 >usg
+ echo exit 1 >v7
+elif $contains SIGTSTP guess.txt >/dev/null 2>&1 ; then
+ echo "Looks kind of like a BSD system, but we'll see..."
+ echo exit 0 >bsd
+ echo exit 1 >usg
+ echo exit 1 >v7
+else
+ echo "Looks kind of like a version 7 system, but we'll see..."
+ echo exit 1 >bsd
+ echo exit 1 >usg
+ 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"
+ ;;
+*)
+ echo " "
+ echo "Congratulations. You aren't running Eunice."
+ d_eunice="$undef"
+ echo "exit 1" >eunice
+ ;;
+esac
+if test -f /xenix; then
+ echo "Actually, this looks more like a XENIX system..."
+ echo "exit 0" >xenix
+else
+ echo " "
+ echo "It's not Xenix..."
+ echo "exit 1" >xenix
+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
+ echo "exit 1" >venix
+fi
+chmod +x bsd usg v7 eunice venix
+$eunicefix bsd usg v7 eunice venix
+
+: see what memory models we can support
+case "$models" in
+'')
+ : We may not use Cppsym or we get a circular dependency through cc.
+ : But this should work regardless of which cc we eventually use.
+ cat >pdp11.c <<'EOP'
+main() {
+#ifdef pdp11
+ exit(0);
+#else
+ exit(1);
+#endif
+}
+EOP
+ cc -o pdp11 pdp11.c >/dev/null 2>&1
+ if pdp11 2>/dev/null; then
+ dflt='unsplit split'
+ else
+ ans=`./loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge`
+ case "$ans" in
+ X) dflt='none';;
+ *) if $test -d /lib/small || $test -d /usr/lib/small; then
+ dflt='small'
+ else
+ dflt=''
+ fi
+ if $test -d /lib/medium || $test -d /usr/lib/medium; then
+ dflt="$dflt medium"
+ fi
+ if $test -d /lib/large || $test -d /usr/lib/large; then
+ dflt="$dflt large"
+ fi
+ if $test -d /lib/huge || $test -d /usr/lib/huge; then
+ dflt="$dflt huge"
+ fi
+ esac
+ fi
+ ;;
+*) dflt="$models" ;;
+esac
+$cat <<EOM
+
+Some systems have different model sizes. On most systems they are called
+small, medium, large, and huge. On the PDP11 they are called unsplit and
+split. If your system doesn't support different memory models, say "none".
+If you wish to force everything to one memory model, say "none" here and
+put the appropriate flags later when it asks you for other cc and ld flags.
+Venix systems may wish to put "none" and let the compiler figure things out.
+(In the following question multiple model names should be space separated.)
+
+EOM
+rp="Which models are supported? [$dflt]"
+$echo $n "$rp $c"
+. myread
+models="$ans"
+
+case "$models" in
+none)
+ small=''
+ medium=''
+ large=''
+ huge=''
+ unsplit=''
+ split=''
+ ;;
+*split)
+ case "$split" in
+ '')
+ if $contains '\-i' $mansrc/man1/ld.1 >/dev/null 2>&1 || \
+ $contains '\-i' $mansrc/man1/cc.1 >/dev/null 2>&1; then
+ dflt='-i'
+ else
+ dflt='none'
+ fi
+ ;;
+ *) dflt="$split";;
+ esac
+ rp="What flag indicates separate I and D space? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ none) ans='';;
+ esac
+ split="$ans"
+ unsplit=''
+ ;;
+*large*|*small*|*medium*|*huge*)
+ case "$models" in
+ *large*)
+ case "$large" in
+ '') dflt='-Ml';;
+ *) dflt="$large";;
+ esac
+ rp="What flag indicates large model? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ none) ans='';
+ esac
+ large="$ans"
+ ;;
+ *) large='';;
+ esac
+ case "$models" in
+ *huge*)
+ case "$huge" in
+ '') dflt='-Mh';;
+ *) dflt="$huge";;
+ esac
+ rp="What flag indicates huge model? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ none) ans='';
+ esac
+ huge="$ans"
+ ;;
+ *) huge="$large";;
+ esac
+ case "$models" in
+ *medium*)
+ case "$medium" in
+ '') dflt='-Mm';;
+ *) dflt="$medium";;
+ esac
+ rp="What flag indicates medium model? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ none) ans='';
+ esac
+ medium="$ans"
+ ;;
+ *) medium="$large";;
+ esac
+ case "$models" in
+ *small*)
+ case "$small" in
+ '') dflt='none';;
+ *) dflt="$small";;
+ esac
+ rp="What flag indicates small model? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ none) ans='';
+ esac
+ small="$ans"
+ ;;
+ *) small='';;
+ esac
+ ;;
+*)
+ echo "Unrecognized memory models--you may have to edit Makefile.SH"
+ ;;
+esac
+
+: 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' $mansrc/cc.1 >/dev/null 2>&1 ; then
+ dflt='cc -M'
+ 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. What command will force resolution on
+EOM
+ $echo $n "this system? [$dflt] $c"
+ rp="Command to resolve multiple refs? [$dflt]"
+ . myread
+ cc="$ans"
+else
+ case "$cc" in
+ '') dflt=cc;;
+ *) dflt="$cc";;
+ esac
+ rp="Use which C compiler? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ cc="$ans"
+fi
+case "$cc" in
+gcc*) cpp=`./loc gcc-cpp $cpp $pth`
+ case "$nativegcc" in
+ '') case "$ccflags" in
+ *-fpcc-struct-return*) dflt=n;;
+ *) dflt=y;;
+ esac
+ ;;
+ undef) dflt=n;;
+ *) dflt=y;;
+ esac
+ echo " "
+ rp="Are your system (especially dbm) libraries compiled with gcc? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ n*) nativegcc="$undef"; gccflags='-fpcc-struct-return';;
+ *) nativegcc="$define"; gccflags='';;
+ esac
+ case "$gccflags" in
+ *-ansi*) ;;
+ *-traditional*) ;;
+ *) gccflags="$gccflags -traditional -Dvolatile=__volatile__" ;;
+ esac
+ ;;
+esac
+
+: determine optimize, if desired, or use for debug flag also
+case "$optimize" in
+' ') dflt="none"
+ ;;
+'') dflt="-O";
+ ;;
+*) dflt="$optimize"
+ ;;
+esac
+cat <<EOH
+
+Some C compilers have problems with their optimizers, by default, $package
+compiles with the -O flag to use the optimizer. Alternately, you might
+want to use the symbolic debugger, which uses the -g flag (on traditional
+Unix systems). Either flag can be specified here. To use neither flag,
+specify the word "none".
+
+EOH
+rp="What optimizer/debugger flag should be used? [$dflt]"
+$echo $n "$rp $c"
+. myread
+optimize="$ans"
+case "$optimize" in
+'none') optimize=" "
+ ;;
+esac
+
+case "$ccflags" in
+'') case "$cc" in
+ *gcc*) dflt="$gccflags";;
+ *) dflt='';;
+ esac
+ ;;
+*-fpcc-struct-return*) dflt="$ccflags";;
+*) case "$cc" in
+ *gcc*) dflt="$ccflags $gccflags";;
+ *) dflt="$ccflags";;
+ esac
+ ;;
+esac
+for thisincl in $inclwanted; do
+ if test -d $thisincl; then
+ if test "x$thisincl" != "x$usrinclude"; then
+ case "$dflt" in
+ *$thisincl*);;
+ *) dflt="$dflt -I$thisincl";;
+ esac
+ fi
+ fi
+done
+case "$optimize" in
+-g*)
+ case "$dflt" in
+ *DEBUGGING*);;
+ *) dflt="$dflt -DDEBUGGING";;
+ esac
+ ;;
+esac
+if $contains 'LANGUAGE_C' $usrinclude/signal.h >/dev/null 2>&1; then
+ case "$dflt" in
+ *LANGUAGE_C*);;
+ *) dflt="$dflt -DLANGUAGE_C";;
+ esac
+fi
+if $contains '_NO_PROTO' $usrinclude/signal.h >/dev/null 2>&1; then
+ case "$dflt" in
+ *_NO_PROTO*);;
+ *) dflt="$dflt -D_NO_PROTO";;
+ esac
+fi
+case "$dflt" in
+'') dflt=none;;
+esac
+cat <<EOH
+
+Your C compiler may want other flags. For this question you should
+include -I/whatever and -DWHATEVER flags and any other flags used by
+the C compiler, but you should NOT include libraries or ld flags like
+-lwhatever. To use no flags, specify the word "none".
+
+EOH
+rp="Any additional cc flags? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+none) ans='';
+esac
+ccflags="$ans"
+
+: the following weeds options from ccflags that are of no interest to cpp
+cppflags="$ccflags"
+case "$cc" in
+*gcc*) cppflags="$cppflags -D__GNUC__";;
+esac
+case "$cppflags" in
+'');;
+*) set X $cppflags
+ cppflags=''
+ for flag do
+ case $flag in
+ -D*|-U*|-I*|-traditional|-ansi|-nostdinc) cppflags="$cppflags $flag";;
+ esac
+ done
+ case "$cppflags" in
+ *-*) echo "(C preprocessor flags: $cppflags)";;
+ esac
+ ;;
+esac
+
+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)? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+none) ans='';
+esac
+ldflags="$ans"
+
+echo " "
+echo "Checking for optional libraries..."
+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";;
+ *) thatlib=NONE;;
+ esac
+ xxx=`./loc lib$thislib.a X /usr/ccs/lib /usr/lib /usr/ucblib /usr/local/lib /lib`
+ if test -f $xxx; then
+ echo "Found -l$thislib."
+ case "$dflt" in
+ *"-l$thislib "*|*"-l$thatlib "*);;
+ *) dflt="$dflt -l$thislib ";;
+ esac
+ else
+ xxx=`./loc lib$thislib.a X $libpth`
+ if test -f $xxx; then
+ echo "Found $xxx."
+ case "$dflt" in
+ *"$xxx "*);;
+ *) dflt="$dflt $xxx ";;
+ esac
+ else
+ xxx=`./loc Slib$thislib.a X $xlibpth`
+ if test -f $xxx; then
+ echo "Found -l$thislib."
+ case "$dflt" in
+ *"-l$thislib "*|*"-l$thatlib "*);;
+ *) dflt="$dflt -l$thislib ";;
+ esac
+ else
+ xxx=`./loc lib$thislib.so X /usr/ccs/lib /usr/lib /usr/ucblib /usr/local/lib /lib`
+ if test -f $xxx; then
+ echo "Found -l$thislib as a shared object only."
+ case "$dflt" in
+ *"-l$thislib "*|*"-l$thatlib "*);;
+ *) dflt="$dflt -l$thislib ";;
+ esac
+ else
+ echo "No -l$thislib."
+ fi
+ fi
+ fi
+ fi
+done
+set X $dflt
+shift
+dflt="$*"
+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? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+none) ans='';
+esac
+libs="$ans"
+
+: check for size of random number generator
+echo " "
+case "$alignbytes" in
+'')
+ echo "Checking alignment constraints..."
+ $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='?'
+ 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? [$dflt]"
+$echo $n "$rp $c"
+. myread
+alignbytes="$ans"
+$rm -f try.c try
+
+: determine where public executables go
+cat <<EOF
+
+The following questions distinguish the directory in which executables
+reside from the directory in which they are installed (and from which they
+are presumably copied to the former directory by occult means). This
+distinction is often necessary under afs. On most other systems, however,
+the two directories are the same.
+
+EOF
+case "$bin" in
+'')
+ dflt=`./loc . /usr/local/bin /usr/local/bin /usr/lbin /usr/local /usr/bin /bin`
+ ;;
+*) dflt="$bin"
+ ;;
+esac
+cont=true
+while $test "$cont" ; do
+ rp="In which directory will public executables reside (~name ok)? [$dflt]"
+ $echo "In which directory will public executables reside (~name ok)?"
+ $echo $n "[$dflt] $c"
+ . myread
+ bin="$ans"
+ bin=`./filexp $bin`
+ if test -d $bin; then
+ cont=''
+ else
+ case "$fastread" in
+ yes) dflt=y;;
+ *) dflt=n;;
+ esac
+ rp="Directory $bin doesn't exist. Use that name anyway? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ dflt=''
+ case "$ans" in
+ y*) cont='';;
+ esac
+ fi
+done
+
+case "$installbin" in
+'')
+ dflt=`echo $bin | sed 's#^/afs/#/afs/.#'`
+ test -d $dflt || dflt="$bin"
+ ;;
+*) dflt="$installbin"
+ ;;
+esac
+cont=true
+while $test "$cont" ; do
+ rp="In which directory will public executables be installed (~name ok)? [$dflt]"
+ $echo "In which directory will public executables be installed (~name ok)?"
+ $echo $n "[$dflt] $c"
+ . myread
+ installbin="$ans"
+ installbin=`./filexp $installbin`
+ if test -d $installbin; then
+ cont=''
+ else
+ case "$fastread" in
+ yes) dflt=y;;
+ *) dflt=n;;
+ esac
+ rp="Directory $installbin doesn't exist. Use that name anyway? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ dflt=''
+ case "$ans" in
+ y*) cont='';;
+ esac
+ fi
+done
+
+: check for ordering of bytes in a long
+case "$byteorder" in
+'')
+cat <<'EOM'
+
+In the following, larger digits indicate more significance. A big-endian
+machine like a Pyramid or a Motorola 680?0 chip will come out to 4321. A
+little-endian machine like a Vax or an Intel 80?86 chip would be 1234. Other
+machines may have weird orders like 3412. A Cray will report 87654321. If
+the test program works the default is probably right.
+I'm now running the test program...
+EOM
+ $cat >byteorder.c <<'EOCP'
+#include <stdio.h>
+main()
+{
+ int i;
+ union {
+ unsigned long l;
+ char c[sizeof(long)];
+ } u;
+
+ if (sizeof(long) > 4)
+ u.l = (0x08070605 << 32) | 0x04030201;
+ else
+ u.l = 0x04030201;
+ for (i=0; i < sizeof(long); i++)
+ printf("%c",u.c[i]+'0');
+ printf("\n");
+}
+EOCP
+ if $cc byteorder.c -o byteorder >/dev/null 2>&1 ; then
+ dflt=`./byteorder`
+ case "$dflt" in
+ ????|????????) echo "(The test program ran ok.)";;
+ *) echo "(The test program didn't run right for some reason.)";;
+ esac
+ else
+ dflt='4321'
+ echo "(I can't seem to compile the test program. Guessing big-endian...)"
+ fi
+ ;;
+*)
+ echo " "
+ dflt="$byteorder"
+ ;;
+esac
+rp="What is the order of bytes in a long? [$dflt]"
+$echo $n "$rp $c"
+. myread
+byteorder="$ans"
+
+: check for ability to cast negative floats to unsigned
+echo " "
+echo 'Checking to see if your C compiler can cast weird floats to unsigned'
+$cat >try.c <<'EOCP'
+#include <signal.h>
+
+blech() { exit(3); }
+
+main()
+{
+ double f = -123;
+ unsigned long along;
+ unsigned int aint;
+ unsigned short ashort;
+ int result = 0;
+
+ signal(SIGFPE, blech);
+ along = (unsigned long)f;
+ aint = (unsigned int)f;
+ ashort = (unsigned short)f;
+ if (along != (unsigned long)-123)
+ result |= 1;
+ if (aint != (unsigned int)-123)
+ result |= 1;
+ if (ashort != (unsigned short)-123)
+ result |= 1;
+ f = (double)0x40000000;
+ f = f + f;
+ along = 0;
+ along = (unsigned long)f;
+ if (along != 0x80000000)
+ result |= 2;
+ f -= 1;
+ along = 0;
+ along = (unsigned long)f;
+ if (along != 0x7fffffff)
+ result |= 1;
+ f += 2;
+ along = 0;
+ along = (unsigned long)f;
+ if (along != 0x80000001)
+ result |= 2;
+ exit(result);
+}
+EOCP
+if $cc -o try $ccflags try.c >/dev/null 2>&1; then
+ ./try
+ castflags=$?
+else
+ castflags=3
+fi
+case "$castflags" in
+0) val="$define"
+ echo "Yup, it does."
+ ;;
+*) val="$undef"
+ echo "Nope, it doesn't."
+ ;;
+esac
+set d_castneg
+eval $setvar
+$rm -f try.*
+
+: see how we invoke the C preprocessor
+echo " "
+echo "Now, how can we feed standard input to your C preprocessor..."
+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=cppstdin
+
+case "$cppstdin" in
+/*cppstdin) cppstdin=cppstdin;;
+esac
+cp cppstdin UU
+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."
+elif test "$cc" = gcc && \
+ (echo "Using gcc, eh? We'll try to force gcc -E using a wrapper..."; \
+ $wrapper <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1) ; then
+ echo "Yup, we can."
+ cppstdin="$wrapper"
+ cppminus='';
+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."
+ cppstdin="$cc -E"
+ cppminus='';
+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."
+ cppstdin="$cc -E"
+ cppminus='-';
+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!"
+ cppstdin="$cpp"
+ cppminus='';
+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."
+ cppstdin="$cpp"
+ cppminus='-';
+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
+ cppstdin="$wrapper"
+ cppminus=''
+ echo "Eureka!."
+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!"
+ cppstdin="$cc -P"
+ cppminus='';
+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!"
+ cppstdin="$cc -P"
+ cppminus='-';
+else
+ dflt=blurfl
+ $echo $n "No dice. I can't find a C preprocessor. Name one: $c"
+ rp='Name a C preprocessor:'
+ . myread
+ cppstdin="$ans"
+ $cppstdin <testcpp.c >testcpp.out 2>&1
+ if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "OK, that will do."
+ else
+ echo "Sorry, I can't get that to work. Go find one and rerun Configure."
+ exit 1
+ fi
+fi
+
+: get list of predefined functions in a handy place
+echo " "
+case "$libc" in
+'') libc=unknown;;
+esac
+case "$nm_opts" in
+'') if test -f /mach_boot; then
+ nm_opts=''
+ elif test -d /usr/ccs/lib; then
+ nm_opts='-p'
+ else
+ nm_opts=''
+ fi
+ ;;
+esac
+: on mips, we DO NOT want /lib, and we want inclPath/usr/lib
+case "$libpth" in
+'') if mips; then
+ libpth='$inclPath/usr/lib /usr/local/lib'
+ nm_opts="-B"
+ else
+ libpth='/usr/ccs/lib /lib /usr/lib /usr/ucblib /usr/local/lib'
+ fi
+ ;;
+esac
+case "$libs" in
+*-lc_s*) libc=`./loc libc_s.a $libc $libpth`
+esac
+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 $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
+ libnames="$libnames $try"
+ ;;
+ *) libnames="$libnames $thislib" ;;
+ esac
+ done
+ ;;
+esac
+set /usr/ccs/lib/libc.so
+test -f $1 || set /usr/lib/libc.so
+test -f $1 || set /usr/lib/libc.so.[0-9]*
+test -f $1 || set /lib/libsys_s.a
+eval set \$$#
+if test -f "$1"; then
+ echo "Your (shared) C library seems to be in $1."
+ libc="$1"
+elif test -f "$libc"; then
+ echo "Your C library seems to be in $libc."
+elif test -f /lib/libc.a; then
+ echo "Your C library seems to be in /lib/libc.a. You're normal."
+ libc=/lib/libc.a
+else
+ if ans=`./loc libc.a blurfl/dyick $libpth`; test -f "$ans"; then
+ :
+ elif ans=`./loc libc blurfl/dyick $libpth`; test -f "$ans"; then
+ libnames="$libnames "`./loc clib blurfl/dyick $libpth`
+ elif ans=`./loc clib blurfl/dyick $libpth`; test -f "$ans"; then
+ :
+ elif ans=`./loc Slibc.a blurfl/dyick $xlibpth`; test -f "$ans"; then
+ :
+ elif ans=`./loc Mlibc.a blurfl/dyick $xlibpth`; test -f "$ans"; then
+ :
+ elif ans=`./loc Llibc.a blurfl/dyick $xlibpth`; test -f "$ans"; then
+ :
+ fi
+ if test -f "$ans"; then
+ echo "Your C library seems to be in $ans, of all places."
+ libc=$ans
+ else
+ cat <<EOM
+
+I can't seem to find your C library. I've looked in the following places:
+
+ $libpth
+
+None of these seems to contain your C library. What is the full name
+EOM
+ dflt=None
+ $echo $n "of your C library? $c"
+ rp='C library full name?'
+ . myread
+ libc="$ans"
+ fi
+fi
+echo " "
+if test $libc = "/lib/libc"; then
+ libc="$libc /lib/clib"
+fi
+cat <<END
+
+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.
+END
+dflt="$libc";
+rp="Your C library is where? [$dflt]"
+$echo $n "$rp $c"
+. myread
+libc="$ans"
+echo " "
+echo $libc $libnames | tr ' ' '\012' | sort | uniq >libnames
+$echo "Extracting names from the following files for later perusal:"
+sed 's/^/ /' libnames
+echo $n "This may take a while...$c"
+set X `cat libnames`
+shift
+nm $nm_opts $* 2>/dev/null >libc.tmp
+$sed -n -e 's/^.* [ATDS] *[_.]*//p' -e 's/^.* [ATDS] //p' <libc.tmp >libc.list
+if $contains '^printf$' libc.list >/dev/null 2>&1; then
+ echo done
+elif $sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p' \
+ <libc.tmp >libc.list; \
+ $contains '^printf$' libc.list >/dev/null 2>&1; then
+ echo done
+elif $sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p' <libc.tmp >libc.list; \
+ $contains '^printf$' libc.list >/dev/null 2>&1; then
+ echo done
+elif $sed -n -e 's/^.* D __*//p' -e 's/^.* D //p' <libc.tmp >libc.list; \
+ $contains '^printf$' libc.list >/dev/null 2>&1; then
+ echo done
+elif $sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p' \
+ <libc.tmp >libc.list; \
+ $contains '^printf$' libc.list >/dev/null 2>&1; then
+ echo done
+elif $grep '|' <libc.tmp | $sed -n -e '/|COMMON/d' -e '/|DATA/d' -e '/ file/d' \
+ -e 's/^\([^ ]*\).*/\1/p' >libc.list
+ $contains '^printf$' libc.list >/dev/null 2>&1; then
+ echo done
+elif $sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p' \
+ <libc.tmp >libc.list; \
+ $contains '^printf$' libc.list >/dev/null 2>&1; then
+ echo done
+else
+ nm -p $* 2>/dev/null >libc.tmp
+ $sed -n -e 's/^.* [AT] *_[_.]*//p' -e 's/^.* [AT] //p' <libc.tmp >libc.list
+ if $contains '^printf$' libc.list >/dev/null 2>&1; then
+ nm_opts='-p'
+ echo "done"
+ else
+ echo " "
+ echo "nm didn't seem to work right."
+ echo "Trying ar instead..."
+ 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."
+ else
+ echo "ar didn't seem to work right."
+ echo "Maybe this is a Cray...trying bld instead..."
+ 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."
+ else
+ echo "That didn't work either. Giving up."
+ exit 1
+ fi
+ fi
+ fi
+fi
+if test -f /lib/syscalls.exp; then
+ echo "Also extracting names from /lib/syscalls.exp for good ole AIX..."
+ sed -n 's/^\([^ ]*\)[ ]*syscall$/\1/p' /lib/syscalls.exp >>libc.list
+fi
+
+inlibc='echo " "; td=$define; tu=$undef;
+if $contains "^$1\$" libc.list >/dev/null 2>&1;
+then echo "$1() found";
+ eval "case \"\$$2\" in undef) . whoa; esac"; eval "$2=\$td";
+else echo "$1() not found";
+ eval "case \"\$$2\" in define) . whoa; esac"; eval "$2=\$tu"; fi'
+
+: see if bcmp exists
+set bcmp d_bcmp
+eval $inlibc
+
+: see if bcopy exists
+set bcopy d_bcopy
+eval $inlibc
+
+: see if bzero exists
+set bzero d_bzero
+eval $inlibc
+
+: see if sprintf is declared as int or pointer to char
+echo " "
+cat >ucbsprf.c <<'EOF'
+#include <stdio.h>
+main()
+{
+ int sprintf();
+ char buf[10];
+ exit((unsigned long)sprintf(buf,"%s","foo") > 10L);
+}
+EOF
+if $cc $ccflags ucbsprf.c -o ucbsprf >/dev/null 2>&1 && ./ucbsprf; then
+ echo "Your sprintf() returns (int)."
+ val="$undef"
+else
+ echo "Your sprintf() returns (char*)."
+ val="$define"
+fi
+set d_charsprf
+eval $setvar
+
+: see if vprintf exists
+echo " "
+if $contains '^vprintf$' libc.list >/dev/null 2>&1; then
+ echo 'vprintf() found.'
+ val="$define"
+ cat >vprintf.c <<'EOF'
+#include <varargs.h>
+
+main() { xxx("foo"); }
+
+xxx(va_alist)
+va_dcl
+{
+ va_list args;
+ char buf[10];
+
+ va_start(args);
+ exit((unsigned long)vsprintf(buf,"%s",args) > 10L);
+}
+EOF
+ if $cc $ccflags vprintf.c -o vprintf >/dev/null 2>&1 && ./vprintf; then
+ echo "Your vsprintf() returns (int)."
+ val2="$undef"
+ else
+ echo "Your vsprintf() returns (char*)."
+ val2="$define"
+ fi
+else
+ echo 'vprintf() not found.'
+ val="$undef"
+ val2="$undef"
+fi
+set d_vprintf
+eval $setvar
+val=$val2
+set d_charvspr
+eval $setvar
+
+: see if chsize exists
+set chsize d_chsize
+eval $inlibc
+
+: see if crypt exists
+echo " "
+if $contains '^crypt$' libc.list >/dev/null 2>&1; then
+ echo 'crypt() found.'
+ val="$define"
+ cryptlib=''
+else
+ cryptlib=`./loc Slibcrypt.a "" $xlibpth`
+ if $test -z "$cryptlib"; then
+ cryptlib=`./loc Mlibcrypt.a "" $xlibpth`
+ else
+ cryptlib=-lcrypt
+ fi
+ if $test -z "$cryptlib"; then
+ cryptlib=`./loc Llibcrypt.a "" $xlibpth`
+ else
+ cryptlib=-lcrypt
+ fi
+ if $test -z "$cryptlib"; then
+ cryptlib=`./loc libcrypt.a "" $libpth`
+ else
+ cryptlib=-lcrypt
+ fi
+ if $test -z "$cryptlib"; then
+ echo 'crypt() not found.'
+ val="$undef"
+ else
+ val="$define"
+ fi
+fi
+set d_crypt
+eval $setvar
+
+: get csh whereabouts
+case "$csh" in
+'csh') val="$undef" ;;
+*) val="$define" ;;
+esac
+set d_csh
+eval $setvar
+
+: see if readdir exists
+set readdir d_readdir
+eval $inlibc
+
+: see if there are directory access routines out there
+echo " "
+xxx=`./loc ndir.h x $usrinclude /usr/local/include $inclwanted`
+case "$xxx" in
+x)
+ xxx=`./loc sys/ndir.h x $usrinclude /usr/local/include $inclwanted`
+ ;;
+esac
+D_dirnamlen="$undef"
+I_dirent="$undef"
+I_sys_dir="$undef"
+I_my_dir="$undef"
+I_ndir="$undef"
+I_sys_ndir="$undef"
+libndir=''
+ndirc=''
+ndiro=''
+if $test -r $usrinclude/dirent.h; then
+ echo "dirent.h found."
+ if $contains 'd_namlen' $usrinclude/dirent.h >/dev/null 2>&1; then
+ D_dirnamlen="$define"
+ fi
+ I_dirent="$define"
+elif $test -r $xxx; then
+ echo "You seem to use <$xxx>,"
+ if $test "$d_readdir" = "$define"; then
+ echo "and I can get readdir() from your C library."
+ elif $test -r /usr/lib/libndir.a || $test -r /usr/local/lib/libndir.a; then
+ echo "and I'll get the routines using -lndir ."
+ libndir='-lndir'
+ else
+ ans=`./loc libndir.a x $libpth`
+ case "$ans" in
+ x)
+ echo "but I can't find the ndir library!"
+ ;;
+ *)
+ echo "and I found the directory library in $ans."
+ libndir="$ans"
+ ;;
+ esac
+ fi
+ if $contains 'd_namlen' $xxx >/dev/null 2>&1; then
+ D_dirnamlen="$define"
+ fi
+ case "$xxx" in
+ sys/)
+ I_sys_ndir="$define"
+ ;;
+ *)
+ I_ndir="$define"
+ ;;
+ esac
+else
+ : The next line used to require this to be a bsd system.
+ if $contains '^readdir$' libc.list >/dev/null 2>&1 ; then
+ echo "No ndir library found, but you have readdir() so we'll use that."
+ if $contains 'd_namlen' $usrinclude/sys/dir.h >/dev/null 2>&1; then
+ D_dirnamlen="$define"
+ fi
+ I_sys_dir="$define"
+ else
+ echo "No ndir library found--using ./$d_ndir.c."
+: This will lose since $d_ndir.h is in another directory.
+: I doubt we can rely on it being in ../$d_ndir.h .
+: At least it will fail in a conservative manner.
+ if $contains 'd_namlen' $d_ndir.h >/dev/null 2>&1; then
+ D_dirnamlen="$define"
+ fi
+ I_my_dir="$define"
+ ndirc="$d_ndir.c"
+ ndiro="$d_ndir.o"
+ fi
+fi
+val=$D_dirnamlen; set d_dirnamlen; eval $setvar
+val=$I_dirent; set i_dirent; eval $setvar
+val=$I_sys_dir; set i_sys_dir; eval $setvar
+val=$I_my_dir; set i_my_dir; eval $setvar
+val=$I_ndir; set i_ndir; eval $setvar
+val=$I_sys_ndir; set i_sys_ndir; eval $setvar
+
+: now see if they want to do setuid emulation
+case "$d_dosuid" in
+'') dflt=n;;
+*undef*) dflt=n;;
+*) dflt=y;;
+esac
+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.
+
+EOM
+rp="Do you want to do setuid/setgid emulation? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+'') $ans="$dflt";;
+esac
+case "$ans" in
+y*) d_dosuid="$define";;
+*) d_dosuid="$undef";;
+esac
+
+: see if dup2 exists
+set dup2 d_dup2
+eval $inlibc
+
+: see if fchmod exists
+set fchmod d_fchmod
+eval $inlibc
+
+: see if fchown exists
+set fchown d_fchown
+eval $inlibc
+
+: see if this is an fcntl system
+set fcntl d_fcntl
+eval $inlibc
+
+: see if we can have long filenames
+echo " "
+rm -f 123456789abcde
+if (echo hi >123456789abcdef) 2>/dev/null; then
+ : not version 8
+ if test -f 123456789abcde; then
+ echo 'You cannot have filenames longer than 14 characters. Sigh.'
+ val="$undef"
+ else
+ echo 'You can have filenames longer than 14 characters.'
+ val="$define"
+ fi
+else
+ : version 8 probably
+ echo "You can't have filenames longer than 14 chars. You can't even think about them!"
+ val="$undef"
+fi
+set d_flexfnam
+eval $setvar
+
+: see if flock exists
+set flock d_flock
+eval $inlibc
+
+: see if getgroups exists
+set getgroups d_getgrps
+eval $inlibc
+
+: see if gethostent exists
+set gethostent d_gethent
+eval $inlibc
+
+: see if getpgrp exists
+set getpgrp d_getpgrp
+eval $inlibc
+
+: see if getpgrp2 exists
+set getpgrp2 d_getpgrp2
+eval $inlibc
+
+: see if getpriority exists
+set getpriority d_getprior
+eval $inlibc
+
+: see if htonl exists
+set htonl d_htonl
+eval $inlibc
+
+: index or strcpy
+echo " "
+case "$d_index" in
+undef) dflt=n;;
+*) if $test -f /unix; then
+ dflt=n
+ else
+ dflt=y
+ fi
+ ;;
+esac
+if $contains '^index$' libc.list >/dev/null 2>&1 ; then
+ if $contains '^strchr$' libc.list >/dev/null 2>&1 ; then
+ echo "Your system has both index() and strchr(). Shall I use"
+ rp="index() rather than strchr()? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ n*) d_index="$define" ;;
+ *) d_index="$undef" ;;
+ esac
+ else
+ d_index="$undef"
+ echo "index() found."
+ fi
+else
+ if $contains '^strchr$' libc.list >/dev/null 2>&1 ; then
+ d_index="$define"
+ echo "strchr() found."
+ else
+ echo "No index() or strchr() found!"
+ d_index="$undef"
+ fi
+fi
+
+: see if killpg exists
+set killpg d_killpg
+eval $inlibc
+
+: see if lstat exists
+set lstat d_lstat
+eval $inlibc
+
+: see if memcmp exists
+set memcmp d_memcmp
+eval $inlibc
+
+: see if memcpy exists
+set memcpy d_memcpy
+eval $inlibc
+
+: see if mkdir exists
+set mkdir d_mkdir
+eval $inlibc
+
+: see if msgctl exists
+set msgctl d_msgctl
+eval $inlibc
+
+: see if msgget exists
+set msgget d_msgget
+eval $inlibc
+
+: see if msgsnd exists
+set msgsnd d_msgsnd
+eval $inlibc
+
+: see if msgrcv exists
+set msgrcv d_msgrcv
+eval $inlibc
+
+: see how much of the 'msg*(2)' library is present.
+h_msg=true
+echo " "
+case "$d_msgctl$d_msgget$d_msgsnd$d_msgrcv" in
+*undef*) h_msg=false;;
+esac
+: we could also check for sys/ipc.h ...
+if $h_msg && $test -r $usrinclude/sys/msg.h; then
+ echo "You have the full msg*(2) library."
+ val="$define"
+else
+ echo "You don't have the full msg*(2) library."
+ val="$undef"
+fi
+set d_msg
+eval $setvar
+
+: determine which malloc to compile in
+echo " "
+case "$d_mymalloc" in
+'')
+ case "$usemymalloc" in
+ '')
+ if bsd || v7; then
+ dflt='y'
+ else
+ dflt='n'
+ fi
+ ;;
+ n*) dflt=n;;
+ *) dflt=y;;
+ esac
+ ;;
+define) dflt="y"
+ ;;
+*) dflt="n"
+ ;;
+esac
+rp="Do you wish to attempt to use the malloc that comes with $package? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+'') ans=$dflt;;
+esac
+case "$ans" in
+y*) mallocsrc='malloc.c'; mallocobj='malloc.o'
+ libs=`echo $libs | sed 's/-lmalloc//'`
+ val="$define"
+ case "$mallocptrtype" in
+ '')
+ cat >usemymalloc.c <<'END'
+#ifdef __STDC__
+#include <stdlib.h>
+#else
+#include <malloc.h>
+#endif
+void *malloc();
+END
+ if $cc $ccflags -c usemymalloc.c >/dev/null 2>&1; then
+ mallocptrtype=void
+ else
+ mallocptrtype=char
+ fi
+ ;;
+ esac
+ echo " "
+ echo "Your system wants malloc to return $mallocptrtype*, it would seem."
+ ;;
+*) mallocsrc='';
+ mallocobj='';
+ mallocptrtype=void
+ val="$define"
+ ;;
+esac
+set d_mymalloc
+eval $setvar
+
+: see if ndbm is available
+echo " "
+xxx=`./loc ndbm.h x $usrinclude /usr/local/include $inclwanted`
+if test -f $xxx; then
+ val="$define"
+ echo "ndbm.h found."
+else
+ val="$undef"
+ echo "ndbm.h not found."
+fi
+set d_ndbm
+eval $setvar
+
+: see if we have the old dbm
+echo " "
+xxx=`./loc dbm.h x $usrinclude /usr/local/include $inclwanted`
+if test -f $xxx; then
+ val="$define"
+ echo "dbm.h found."
+else
+ val="$undef"
+ echo "dbm.h not found."
+fi
+set d_odbm
+eval $setvar
+
+: see whether socket exists
+echo " "
+socketlib=''
+if $contains socket libc.list >/dev/null 2>&1; then
+ echo "Looks like you have Berkeley networking support."
+ val="$define"
+ : now check for advanced features
+ if $contains setsockopt libc.list >/dev/null 2>&1; then
+ val2="$undef"
+ else
+ echo "...but it uses the old 4.1c interface, rather than 4.2"
+ val2="$define"
+ fi
+else
+ : hpux, for one, puts all the socket stuff in socklib.o
+ if $contains socklib libc.list >/dev/null 2>&1; then
+ echo "Looks like you have Berkeley networking support."
+ val="$define"
+ : we will have to assume that it supports the 4.2 BSD interface
+ val2="$undef"
+ else
+ echo "Hmmm...you don't have Berkeley networking in libc.a..."
+ : look for an optional networking library
+ if test -f /usr/lib/libnet.a; then
+ (ar t /usr/lib/libnet.a ||
+ nm -g /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."
+ socketlib="-lnet -lnsl_s"
+ val="$define"
+ : now check for advanced features
+ if $contains setsockopt libc.list >/dev/null 2>&1; then
+ val2="$undef"
+ else
+ echo "...using the old 4.1c interface, rather than 4.2"
+ val2="$define"
+ fi
+ else
+ echo "or even in libnet.a, which is peculiar."
+ val="$undef"
+ val2="$undef"
+ fi
+ else
+ echo "or anywhere else I see."
+ val="$undef"
+ val2="$undef"
+ fi
+ fi
+fi
+set d_socket
+eval $setvar
+
+if $contains socketpair libc.list >/dev/null 2>&1; then
+ val="$define"
+else
+ val="$undef"
+fi
+set d_sockpair
+eval $setvar
+val=$val2
+set d_oldsock
+eval $setvar
+
+: Locate the flags for 'open()'
+echo " "
+$cat >open3.c <<'EOCP'
+#include <sys/types.h>
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+main() {
+
+ if(O_RDONLY);
+
+#ifdef O_TRUNC
+ exit(0);
+#else
+ exit(1);
+#endif
+}
+EOCP
+: check sys/file.h first to get FREAD on Sun
+if $test -r $usrinclude/sys/file.h && \
+ $cc $cppflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then
+ h_sys_file=true;
+ echo "sys/file.h defines the O_* constants..."
+ if ./open3; then
+ echo "and you have the 3 argument form of open()."
+ val="$define"
+ else
+ echo "but not the 3 argument form of open(). Oh, well."
+ val="$undef"
+ fi
+elif $test -r $usrinclude/fcntl.h && \
+ $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then
+ h_fcntl=true;
+ echo "fcntl.h defines the O_* constants..."
+ if ./open3; then
+ echo "and you have the 3 argument form of open()."
+ val="$define"
+ else
+ echo "but not the 3 argument form of open(). Oh, well."
+ val="$undef"
+ fi
+else
+ val="$undef"
+ echo "I can't find the O_* constant definitions! You got problems."
+fi
+set d_open3
+eval $setvar
+
+: see if how pwd stuff is defined
+echo " "
+if $test -r $usrinclude/pwd.h ; then
+ i_pwd="$define"
+ echo "pwd.h found."
+ $cppstdin $cppflags $cppminus <$usrinclude/pwd.h | \
+ sed -n '/struct[ ][ ]*passwd/,/^};/p' >pwd.txt
+ if $contains 'pw_quota' pwd.txt >/dev/null 2>&1; then
+ d_pwquota="$define"
+ else
+ d_pwquota="$undef"
+ fi
+ if $contains 'pw_age' pwd.txt >/dev/null 2>&1; then
+ d_pwage="$define"
+ else
+ d_pwage="$undef"
+ fi
+ if $contains 'pw_change' pwd.txt >/dev/null 2>&1; then
+ d_pwchange="$define"
+ else
+ d_pwchange="$undef"
+ fi
+ if $contains 'pw_class' pwd.txt >/dev/null 2>&1; then
+ d_pwclass="$define"
+ else
+ d_pwclass="$undef"
+ fi
+ if $contains 'pw_expire' pwd.txt >/dev/null 2>&1; then
+ d_pwexpire="$define"
+ else
+ d_pwexpire="$undef"
+ fi
+ if $contains 'pw_comment' pwd.txt >/dev/null 2>&1; then
+ d_pwcomment="$define"
+ else
+ d_pwcomment="$undef"
+ fi
+else
+ i_pwd="$undef"
+ d_pwquota="$undef"
+ d_pwage="$undef"
+ d_pwchange="$undef"
+ d_pwclass="$undef"
+ d_pwexpire="$undef"
+ d_pwcomment="$undef"
+ echo "No pwd.h found."
+fi
+
+: see if rename exists
+set rename d_rename
+eval $inlibc
+
+: see if rmdir exists
+set rmdir d_rmdir
+eval $inlibc
+
+: see if select exists
+set select d_select
+eval $inlibc
+
+: see if semctl exists
+set semctl d_semctl
+eval $inlibc
+
+: see if semget exists
+set semget d_semget
+eval $inlibc
+
+: see if semop exists
+set semop d_semop
+eval $inlibc
+
+: see how much of the 'sem*(2)' library is present.
+h_sem=true
+echo " "
+case "$d_semctl$d_semget$d_semop" in
+*undef*) h_sem=false;;
+esac
+: we could also check for sys/ipc.h ...
+if $h_sem && $test -r $usrinclude/sys/sem.h; then
+ echo "You have the full sem*(2) library."
+ val="$define"
+else
+ echo "You don't have the full sem*(2) library."
+ val="$undef"
+fi
+set d_sem
+eval $setvar
+
+: see if setegid exists
+set setegid d_setegid
+eval $inlibc
+
+: see if seteuid exists
+set seteuid d_seteuid
+eval $inlibc
+
+: see if setpgrp exists
+set setpgrp d_setpgrp
+eval $inlibc
+
+: see if setpgrp2 exists
+set setpgrp2 d_setpgrp2
+eval $inlibc
+
+: see if setpriority exists
+set setpriority d_setprior
+eval $inlibc
+
+: see if setregid exists
+set setregid d_setregid
+eval $inlibc
+set setresgid d_setresgid
+eval $inlibc
+
+: see if setreuid exists
+set setreuid d_setreuid
+eval $inlibc
+set setresuid d_setresuid
+eval $inlibc
+
+: see if setrgid exists
+set setrgid d_setrgid
+eval $inlibc
+
+: see if setruid exists
+set setruid d_setruid
+eval $inlibc
+
+: see if shmctl exists
+set shmctl d_shmctl
+eval $inlibc
+
+: see if shmget exists
+set shmget d_shmget
+eval $inlibc
+
+: see if shmat exists
+set shmat d_shmat
+eval $inlibc
+
+d_voidshmat="$undef"
+case "$d_shmat" in
+define)
+ $cppstdin $cppflags $cppminus < $usrinclude/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
+
+: see if shmdt exists
+set shmdt d_shmdt
+eval $inlibc
+
+: see how much of the 'shm*(2)' library is present.
+h_shm=true
+echo " "
+case "$d_shmctl$d_shmget$d_shmat$d_shmdt" in
+*undef*) h_shm=false;;
+esac
+: we could also check for sys/ipc.h ...
+if $h_shm && $test -r $usrinclude/sys/shm.h; then
+ echo "You have the full shm*(2) library."
+ val="$define"
+else
+ echo "You don't have the full shm*(2) library."
+ val="$undef"
+fi
+set d_shm
+eval $setvar
+
+: see if stat knows about block sizes
+echo " "
+if $contains 'st_blocks;' $usrinclude/sys/stat.h >/dev/null 2>&1 ; then
+ if $contains 'st_blksize;' $usrinclude/sys/stat.h >/dev/null 2>&1 ; then
+ echo "Your stat knows about block sizes."
+ val="$define"
+ else
+ echo "Your stat doesn't know about block sizes."
+ val="$undef"
+ fi
+else
+ echo "Your stat doesn't know about block sizes."
+ val="$undef"
+fi
+set d_statblks
+eval $setvar
+
+: see if stdio is really std
+echo " "
+if $contains 'char.*_ptr.*;' $usrinclude/stdio.h >/dev/null 2>&1 ; then
+ if $contains '_cnt;' $usrinclude/stdio.h >/dev/null 2>&1 ; then
+ echo "Your stdio is pretty std."
+ val="$define"
+ else
+ echo "Your stdio isn't very std."
+ val="$undef"
+ fi
+else
+ echo "Your stdio isn't very std."
+ val="$undef"
+fi
+set d_stdstdio
+eval $setvar
+
+: check for structure copying
+echo " "
+echo "Checking to see if your C compiler can copy structs..."
+$cat >strctcpy.c <<'EOCP'
+main()
+{
+ struct blurfl {
+ int dyick;
+ } foo, bar;
+
+ foo = bar;
+}
+EOCP
+if $cc -c strctcpy.c >/dev/null 2>&1 ; then
+ val="$define"
+ echo "Yup, it can."
+else
+ val="$undef"
+ echo "Nope, it can't."
+fi
+set d_strctcpy
+eval $setvar
+
+: see if strerror exists
+set strerror d_strerror
+eval $inlibc
+
+: see if symlink exists
+set symlink d_symlink
+eval $inlibc
+
+: see if syscall exists
+set syscall d_syscall
+eval $inlibc
+
+: set if package uses struct tm
+w_s_tm=1
+
+: set if package uses struct timeval
+case "$d_select" in
+define) w_s_timevl=1 ;;
+esac
+
+: set if package uses localtime function
+w_localtim=1
+
+: see which of time.h, sys/time.h, and sys/select should be included.
+idefs=''
+cat <<'EOM'
+
+Testing to see which of <time.h>, <sys/time.h>, and <sys/select.h>
+should be included, because this application wants:
+
+EOM
+case "$w_s_itimer" in
+1)
+ echo " struct itimerval"
+ idefs="-DS_ITIMERVAL $idefs"
+ ;;
+esac
+case "$w_s_timevl" in
+1)
+ echo " struct timeval"
+ idefs="-DS_TIMEVAL $idefs"
+ ;;
+esac
+case "$w_s_tm" in
+1)
+ echo " struct tm"
+ idefs="-DS_TM $idefs"
+ ;;
+esac
+case "$w_localtim" in
+1)
+ echo " ctime(3) declarations"
+ idefs="-DD_CTIME $idefs"
+ ;;
+esac
+case "$idefs" in
+'')
+ echo " (something I don't know about)"
+ ;;
+esac
+echo " "
+echo "I'm now running the test program..."
+$cat >i_time.c <<'EOCP'
+#include <sys/types.h>
+#ifdef I_TIME
+#include <time.h>
+#endif
+#ifdef I_SYS_TIME
+#ifdef SYSTIMEKERNEL
+#define KERNEL
+#endif
+#include <sys/time.h>
+#endif
+#ifdef I_SYS_SELECT
+#include <sys/select.h>
+#endif
+main()
+{
+ struct tm foo;
+ struct tm *tmp;
+#ifdef S_TIMEVAL
+ struct timeval bar;
+#endif
+#ifdef S_ITIMERVAL
+ struct itimerval baz;
+#endif
+
+ if (foo.tm_sec == foo.tm_sec)
+ exit(0);
+#ifdef S_TIMEVAL
+ if (bar.tv_sec == bar.tv_sec)
+ exit(0);
+#endif
+#ifdef S_ITIMERVAL
+ if (baz.it_interval == baz.it_interval)
+ exit(0);
+#endif
+#ifdef S_TIMEVAL
+ if (bar.tv_sec == bar.tv_sec)
+ exit(0);
+#endif
+#ifdef D_CTIME
+ /* this might not do anything for us... */
+ tmp = localtime((time_t *)0);
+#endif
+ exit(1);
+}
+EOCP
+flags=''
+for i_sys_select in '' '-DI_SYS_SELECT'; do
+ for d_systimekernel in '' '-DSYSTIMEKERNEL'; do
+ for i_time in '' '-DI_TIME'; do
+ for i_systime in '-DI_SYS_TIME' ''; do
+ case "$flags" in
+ '') echo Trying $i_time $i_systime $d_systimekernel $i_sys_select
+ if $cc $ccflags $idefs \
+ $i_time $i_systime $d_systimekernel $i_sys_select \
+ i_time.c -o i_time >/dev/null 2>&1 ; then
+ set X $i_time $i_systime $d_systimekernel $i_sys_select
+ shift
+ flags="$*"
+ echo Succeeded with $flags
+ fi
+ ;;
+ esac
+ done
+ done
+ done
+done
+case "$flags" in
+*SYSTIMEKERNEL*) val="$define";;
+*) val="$undef";;
+esac
+set d_systimekernel
+eval $setvar
+case "$flags" in
+*I_TIME*) val="$define";;
+*) val="$undef";;
+esac
+set i_time
+eval $setvar
+case "$flags" in
+*I_SYS_SELECT*) val="$define";;
+*) val="$undef";;
+esac
+set i_sys_select
+eval $setvar
+case "$flags" in
+*I_SYS_TIME*) val="$define";;
+*) val="$undef";;
+esac
+set i_sys_time
+eval $setvar
+case "$flags$i_sys_time$i_time" in
+undefundef) i_sys_time="$define"; i_time="$define";
+ echo "ICK, NOTHING WORKED!!! You may have to diddle the includes.";;
+esac
+
+: see if signal is declared as pointer to function returning int or void
+echo " "
+$cppstdin $cppflags $cppminus < $usrinclude/signal.h >d_voidsig.txt
+if $contains 'int[^A-Za-z]*signal' d_voidsig.txt >/dev/null 2>&1 ; then
+ echo "You have int (*signal())() instead of void."
+ val="$undef"
+else
+ echo "You have void (*signal())() instead of int."
+ val="$define"
+fi
+set d_voidsig
+eval $setvar
+case $voidsig in
+define) d_tosignal=void;;
+*) d_tosignal=int;;
+esac
+
+: see if truncate exists
+set truncate d_truncate
+eval $inlibc
+
+: see if there is a vfork
+set vfork d_vfork
+eval $inlibc
+
+: check for volatile keyword
+echo " "
+echo 'Checking to see if your C compiler knows about "volatile"...'
+$cat >try.c <<'EOCP'
+main()
+{
+ typedef unsigned short foo_t;
+ char *volatile foo;
+ volatile int bar;
+ volatile foo_t blech;
+ foo = foo;
+}
+EOCP
+if $cc -c $ccflags try.c >/dev/null 2>&1 ; then
+ val="$define"
+ echo "Yup, it does."
+else
+ val="$undef"
+ echo "Nope, it doesn't."
+fi
+set d_volatile
+eval $setvar
+$rm -f try.*
+
+: see if there is a wait4
+set wait4 d_wait4
+eval $inlibc
+
+: see if there is a waitpid
+set waitpid d_waitpid
+eval $inlibc
+
+: see what type gids are declared as in the kernel
+case "$gidtype" in
+'')
+ if $contains 'gid_t;' $usrinclude/sys/types.h >/dev/null 2>&1 ; then
+ dflt='gid_t';
+ else
+ set `grep '_rgid;' $usrinclude/sys/user.h 2>/dev/null` unsigned short
+ case $1 in
+ unsigned) dflt="$1 $2" ;;
+ *) dflt="$1" ;;
+ esac
+ fi
+ ;;
+*) dflt="$gidtype"
+ ;;
+esac
+cont=true
+echo " "
+rp="What type are groups ids returned by getgid(), etc.? [$dflt]"
+$echo $n "$rp $c"
+. myread
+gidtype="$ans"
+
+: see what type gids are returned by getgroups
+echo " "
+case "$groupstype" in
+'')
+ if $contains 'getgroups.*short' /usr/lib/lint/llib-lc >/dev/null 2>&1; then
+ dflt='short'
+ elif $contains 'getgroups.*int' /usr/lib/lint/llib-lc >/dev/null 2>&1; then
+ dflt='int'
+ elif $contains 'getgroups.*short' /usr/include/libc.h >/dev/null 2>&1; then
+ dflt='short'
+ elif $contains 'getgroups.*int' /usr/include/libc.h >/dev/null 2>&1; then
+ dflt='int'
+ elif $contains 'getgroups.*short' /usr/lib/lint/llib-lbsd >/dev/null 2>&1; then
+ dflt='short'
+ elif $contains 'getgroups.*int' /usr/lib/lint/llib-lbsd >/dev/null 2>&1; then
+ dflt='int'
+ elif $contains 'int.*gidset' /usr/man/man2/getgroups.2 >/dev/null 2>&1; then
+ dflt='int'
+ elif $contains 'gid_t;' $usrinclude/sys/types.h >/dev/null 2>&1 ; then
+ dflt='gid_t'
+ else
+ set `grep 'groups\[NGROUPS\];' $usrinclude/sys/user.h 2>/dev/null` unsigned short
+ case $1 in
+ unsigned) dflt="$1 $2" ;;
+ *) dflt="$1" ;;
+ esac
+ fi
+ ;;
+*) dflt="$groupstype"
+ ;;
+esac
+cont=true
+echo "(The following only matters if you have getgroups().)"
+rp="What type are the group ids returned by getgroups()? [$dflt]"
+$echo $n "$rp $c"
+. myread
+groupstype="$ans"
+
+: check for length of integer
+echo " "
+case "$intsize" in
+'')
+ echo "Checking to see how big your integers are..."
+ $cat >intsize.c <<'EOCP'
+#include <stdio.h>
+main()
+{
+ printf("%d\n", sizeof(int));
+}
+EOCP
+ if $cc intsize.c -o intsize >/dev/null 2>&1 ; then
+ dflt=`./intsize`
+ else
+ dflt='4'
+ echo "(I can't seem to compile the test program. Guessing...)"
+ fi
+ ;;
+*)
+ dflt="$intsize"
+ ;;
+esac
+rp="What is the size of an integer (in bytes)? [$dflt]"
+$echo $n "$rp $c"
+. myread
+intsize="$ans"
+
+: determine where private executables go
+case "$privlib" in
+'')
+ dflt=/usr/lib/$package
+ test -d /usr/local/lib && dflt=/usr/local/lib/$package
+ ;;
+*) dflt="$privlib"
+ ;;
+esac
+$cat <<EOM
+
+The $package package has some auxiliary files that should be reside in a library
+that is accessible by everyone. Where should these "private" but accessible
+EOM
+$echo $n "files reside? (~name ok) [$dflt] $c"
+rp="Private files will reside where? [$dflt]"
+. myread
+privlib=`./filexp "$ans"`
+
+case "$installprivlib" in
+'')
+ dflt=`echo $privlib | sed 's#^/afs/#/afs/.#'`
+ test -d $dflt || dflt="$privlib"
+ ;;
+*) dflt="$installprivlib"
+ ;;
+esac
+$cat <<EOM
+
+On some systems (such as afs) you have to install the library files in a
+different directory to get them to go to the right place. Where should the
+EOM
+$echo $n "library files be installed? (~name ok) [$dflt] $c"
+rp="Install private files where? [$dflt]"
+. myread
+installprivlib=`./filexp "$ans"`
+
+: check for size of random number generator
+echo " "
+case "$randbits" in
+'')
+ echo "Checking to see how many bits your rand function produces..."
+ $cat >randbits.c <<'EOCP'
+#include <stdio.h>
+main()
+{
+ register int i;
+ register unsigned long tmp;
+ register unsigned long max = 0L;
+
+ for (i=1000; i; i--) {
+ tmp = (unsigned long)rand();
+ if (tmp > max) max = tmp;
+ }
+ for (i=0; max; i++)
+ max /= 2;
+ printf("%d\n",i);
+}
+EOCP
+ if $cc randbits.c -o randbits >/dev/null 2>&1 ; then
+ dflt=`./randbits`
+ else
+ dflt='?'
+ echo "(I can't seem to compile the test program...)"
+ fi
+ ;;
+*)
+ dflt="$randbits"
+ ;;
+esac
+rp="How many bits does your rand() function produce? [$dflt]"
+$echo $n "$rp $c"
+. myread
+randbits="$ans"
+
+: determine where publicly executable scripts go
+case "$scriptdir" in
+'')
+ dflt="$bin"
+ : guess some guesses
+ test -d /usr/share/scripts && dflt=/usr/share/scripts
+ test -d /usr/share/bin && dflt=/usr/share/bin
+ ;;
+*) dflt="$scriptdir"
+ ;;
+esac
+cont=true
+$cat <<EOM
+
+Some installations have a separate directory just for executable scripts so
+that they can mount it across multiple architectures but keep the scripts in
+one spot. You might, for example, have a subdirectory of /usr/share for this.
+Or you might just lump your scripts in with all your other executables.
+
+EOM
+while $test "$cont" ; do
+ rp="Where will publicly executable scripts reside (~name ok)? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ scriptdir="$ans"
+ scriptdir=`./filexp "$scriptdir"`
+ if test -d $scriptdir; then
+ cont=''
+ else
+ case "$fastread" in
+ yes) dflt=y;;
+ *) dflt=n;;
+ esac
+ rp="Directory $scriptdir doesn't exist. Use that name anyway? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ dflt=''
+ case "$ans" in
+ y*) cont='';;
+ esac
+ fi
+done
+
+case "$installscr" in
+'')
+ dflt=`echo $scriptdir | sed 's#^/afs/#/afs/.#'`
+ test -d $dflt || dflt="$scriptdir"
+ ;;
+*) dflt="$scriptdir"
+ ;;
+esac
+cont=true
+$cat <<EOM
+
+Some installations must install scripts in a different directory than where
+they will eventually reside. On most systems they're the same directory.
+EOM
+while $test "$cont" ; do
+ rp="Where do you install publicly executable scripts (~name ok)? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ installscr="$ans"
+ installscr=`./filexp "$installscr"`
+ if test -d $installscr; then
+ cont=''
+ else
+ case "$fastread" in
+ yes) dflt=y;;
+ *) dflt=n;;
+ esac
+ rp="Directory $installscr doesn't exist. Use that name anyway? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ dflt=''
+ case "$ans" in
+ y*) cont='';;
+ esac
+ fi
+done
+
+: generate list of signal names
+echo " "
+case "$sig_name" in
+'')
+ echo "Generating a list of signal names..."
+ set X `cat $usrinclude/signal.h $usrinclude/sys/signal.h 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$$`
+ 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 "Signals are: $sig_name"
+
+: see what type of char stdio uses.
+echo " "
+if $contains 'unsigned.*char.*\*.*_ptr.*;' $usrinclude/stdio.h >/dev/null 2>&1 ; then
+ echo "Your stdio uses unsigned chars."
+ stdchar="unsigned char"
+else
+ echo "Your stdio uses signed chars."
+ stdchar="char"
+fi
+
+: see what type uids are declared as in the kernel
+case "$uidtype" in
+'')
+ if $contains 'uid_t;' $usrinclude/sys/types.h >/dev/null 2>&1 ; then
+ dflt='uid_t';
+ else
+ set `grep '_ruid;' $usrinclude/sys/user.h 2>/dev/null` unsigned short
+ case $1 in
+ unsigned) dflt="$1 $2" ;;
+ *) dflt="$1" ;;
+ esac
+ fi
+ ;;
+*) dflt="$uidtype"
+ ;;
+esac
+cont=true
+echo " "
+rp="What type are user ids returned by getuid(), etc.? [$dflt]"
+$echo $n "$rp $c"
+. myread
+uidtype="$ans"
+
+: check for void type
+echo " "
+$cat <<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.
+
+EOM
+case "$voidhave" in
+'')
+ $cat >void.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 & 2
+ void (*foo[10])();
+#endif
+
+#if TRY & 4
+ if(goo == moo) {
+ exit(0);
+ }
+#endif
+ exit(0);
+}
+EOCP
+ if $cc -c -DTRY=$voidwant void.c >void.out 2>&1 ; then
+ voidhave=$voidwant
+ echo "It appears to support void to the level $package wants ($voidwant)."
+ if $contains warning void.out >/dev/null 2>&1; then
+ echo "However, you might get some warnings that look like this:"
+ $cat void.out
+ fi
+ else
+ echo "Hmm, your compiler has some difficulty with void. Checking further..."
+ if $cc -c -DTRY=1 void.c >/dev/null 2>&1 ; then
+ echo "It supports 1..."
+ if $cc -c -DTRY=3 void.c >/dev/null 2>&1 ; then
+ voidhave=3
+ echo "And it supports 2 but not 4."
+ else
+ echo "It doesn't support 2..."
+ if $cc -c -DTRY=5 void.c >/dev/null 2>&1 ; then
+ voidhave=5
+ echo "But it supports 4."
+ else
+ voidhave=1
+ echo "And it doesn't support 4."
+ fi
+ fi
+ else
+ echo "There is no support at all for void."
+ voidhave=0
+ fi
+ fi
+esac
+dflt="$voidhave";
+rp="Your void support flags add up to what? [$dflt]"
+$echo $n "$rp $c"
+. myread
+voidhave="$ans"
+
+: preserve RCS keywords in files with variable substitution, grrr
+Log='$Log'
+Header='$Header'
+Id='$Id'
+Author='$Author'
+Date='$Date'
+Locker='$Locker'
+RCSfile='$RCSfile'
+Revision='$Revision'
+Source='$Source'
+State='$State'
+
+
+: determine compiler compiler
+case "$yacc" in
+'') if xenix; then
+ dflt=yacc
+ else
+ dflt='yacc -Sm25000'
+ fi
+ ;;
+*) dflt="$yacc";;
+esac
+cont=true
+ echo " "
+rp="Which compiler compiler (yacc or bison -y) will you use? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+'') ans="$dflt";;
+esac
+yacc="$ans"
+
+: see if we can include fcntl.h
+echo " "
+if $h_fcntl; then
+ val="$define"
+ echo "We'll be including <fcntl.h>."
+else
+ val="$undef"
+ if $h_sys_file; then
+ echo "We don't need to <fcntl.h> if we include <sys/file.h>."
+ else
+ echo "We won't be including <fcntl.h>."
+ fi
+fi
+set i_fcntl
+eval $setvar
+
+: see if gdbm is available
+echo " "
+xxx=`./loc gdbm.h x $usrinclude /usr/local/include $inclwanted`
+if test -f $xxx; then
+ val="$define"
+ echo "gdbm.h found."
+else
+ val="$undef"
+ echo "gdbm.h not found."
+fi
+set i_gdbm
+eval $setvar
+
+: see if this is an grp system
+echo " "
+if $test -r $usrinclude/grp.h ; then
+ val="$define"
+ echo "grp.h found."
+else
+ val="$undef"
+ echo "No grp.h found."
+fi
+set i_grp
+eval $setvar
+
+: see if this is a netinet/in.h or sys/in.h system
+echo " "
+xxx=`./loc netinet/in.h x $usrinclude /usr/local/include $inclwanted`
+if test -f $xxx; then
+ val="$define"
+ val2="$undef"
+ echo "netinet/in.h found."
+else
+ val="$undef"
+ echo "No netinet/in.h found, ..."
+ xxx=`./loc sys/in.h x $usrinclude /usr/local/include $inclwanted`
+ if test -f $xxx; then
+ val2="$define"
+ echo "but I found sys/in.h instead."
+ else
+ val2="$undef"
+ echo "and I didn't find sys/in.h either."
+ fi
+fi
+set i_niin
+eval $setvar
+val=$val2
+set i_sysin
+eval $setvar
+
+: Do we need to #include <sys/file.h> ?
+echo " "
+if $h_sys_file; then
+ val="$define"
+ echo "We'll be including <sys/file.h>."
+else
+ val="$undef"
+ echo "We won't be including <sys/file.h>."
+fi
+set i_sys_file
+eval $setvar
+
+: see if ioctl defs are in sgtty/termio or sys/ioctl
+echo " "
+if $test -r $usrinclude/sys/ioctl.h ; then
+ val="$define"
+ echo "sys/ioctl.h found."
+else
+ val="$undef"
+ echo "sys/ioctl.h not found, assuming ioctl args are defined in sgtty.h."
+fi
+set i_sysioctl
+eval $setvar
+
+: see if we should include utime.h
+echo " "
+if $test -r $usrinclude/utime.h ; then
+ val="$define"
+ echo "utime.h found."
+else
+ val="$undef"
+ echo "No utime.h found, but that's ok."
+fi
+set i_utime
+eval $setvar
+
+: see if this is a varargs system
+echo " "
+if $test -r $usrinclude/varargs.h ; then
+ val="$define"
+ echo "varargs.h found."
+else
+ val="$undef"
+ echo "No varargs.h found, but that's ok (I hope)."
+fi
+set i_varargs
+eval $setvar
+
+: see if this is a vfork system
+echo " "
+if $test -r $usrinclude/vfork.h ; then
+ val="$define"
+ echo "vfork.h found."
+else
+ val="$undef"
+ echo "No vfork.h found."
+fi
+set i_vfork
+eval $setvar
+
+: end of configuration questions
+echo " "
+echo "End of configuration questions."
+echo " "
+
+: create config.sh file
+echo " "
+if test -d ../UU; then
+ cd ..
+fi
+echo "Creating config.sh..."
+test -f config.sh && cp config.sh UU/oldconfig.sh
+$spitshell <<EOT >config.sh
+$startsh
+# config.sh
+# This file was produced by running the Configure script.
+d_eunice='$d_eunice'
+define='$define'
+eunicefix='$eunicefix'
+loclist='$loclist'
+expr='$expr'
+sed='$sed'
+echo='$echo'
+cat='$cat'
+rm='$rm'
+mv='$mv'
+cp='$cp'
+tail='$tail'
+tr='$tr'
+mkdir='$mkdir'
+sort='$sort'
+uniq='$uniq'
+grep='$grep'
+trylist='$trylist'
+test='$test'
+inews='$inews'
+egrep='$egrep'
+more='$more'
+pg='$pg'
+Mcc='$Mcc'
+vi='$vi'
+mailx='$mailx'
+mail='$mail'
+cpp='$cpp'
+perl='$perl'
+emacs='$emacs'
+ls='$ls'
+rmail='$rmail'
+sendmail='$sendmail'
+shar='$shar'
+smail='$smail'
+tbl='$tbl'
+troff='$troff'
+nroff='$nroff'
+uname='$uname'
+uuname='$uuname'
+line='$line'
+chgrp='$chgrp'
+chmod='$chmod'
+lint='$lint'
+sleep='$sleep'
+pr='$pr'
+tar='$tar'
+ln='$ln'
+lpr='$lpr'
+lp='$lp'
+touch='$touch'
+make='$make'
+date='$date'
+csh='$csh'
+bash='$bash'
+ksh='$ksh'
+lex='$lex'
+flex='$flex'
+bison='$bison'
+Log='$Log'
+Header='$Header'
+Id='$Id'
+lastuname='$lastuname'
+alignbytes='$alignbytes'
+bin='$bin'
+installbin='$installbin'
+byteorder='$byteorder'
+contains='$contains'
+cppstdin='$cppstdin'
+cppminus='$cppminus'
+d_bcmp='$d_bcmp'
+d_bcopy='$d_bcopy'
+d_bzero='$d_bzero'
+d_castneg='$d_castneg'
+castflags='$castflags'
+d_charsprf='$d_charsprf'
+d_chsize='$d_chsize'
+d_crypt='$d_crypt'
+cryptlib='$cryptlib'
+d_csh='$d_csh'
+d_dosuid='$d_dosuid'
+d_dup2='$d_dup2'
+d_fchmod='$d_fchmod'
+d_fchown='$d_fchown'
+d_fcntl='$d_fcntl'
+d_flexfnam='$d_flexfnam'
+d_flock='$d_flock'
+d_getgrps='$d_getgrps'
+d_gethent='$d_gethent'
+d_getpgrp='$d_getpgrp'
+d_getpgrp2='$d_getpgrp2'
+d_getprior='$d_getprior'
+d_htonl='$d_htonl'
+d_index='$d_index'
+d_killpg='$d_killpg'
+d_lstat='$d_lstat'
+d_memcmp='$d_memcmp'
+d_memcpy='$d_memcpy'
+d_mkdir='$d_mkdir'
+d_msg='$d_msg'
+d_msgctl='$d_msgctl'
+d_msgget='$d_msgget'
+d_msgrcv='$d_msgrcv'
+d_msgsnd='$d_msgsnd'
+d_ndbm='$d_ndbm'
+d_odbm='$d_odbm'
+d_open3='$d_open3'
+d_readdir='$d_readdir'
+d_rename='$d_rename'
+d_rmdir='$d_rmdir'
+d_select='$d_select'
+d_sem='$d_sem'
+d_semctl='$d_semctl'
+d_semget='$d_semget'
+d_semop='$d_semop'
+d_setegid='$d_setegid'
+d_seteuid='$d_seteuid'
+d_setpgrp='$d_setpgrp'
+d_setpgrp2='$d_setpgrp2'
+d_setprior='$d_setprior'
+d_setregid='$d_setregid'
+d_setresgid='$d_setresgid'
+d_setreuid='$d_setreuid'
+d_setresuid='$d_setresuid'
+d_setrgid='$d_setrgid'
+d_setruid='$d_setruid'
+d_shm='$d_shm'
+d_shmat='$d_shmat'
+d_voidshmat='$d_voidshmat'
+d_shmctl='$d_shmctl'
+d_shmdt='$d_shmdt'
+d_shmget='$d_shmget'
+d_socket='$d_socket'
+d_sockpair='$d_sockpair'
+d_oldsock='$d_oldsock'
+socketlib='$socketlib'
+d_statblks='$d_statblks'
+d_stdstdio='$d_stdstdio'
+d_strctcpy='$d_strctcpy'
+d_strerror='$d_strerror'
+d_symlink='$d_symlink'
+d_syscall='$d_syscall'
+d_truncate='$d_truncate'
+d_vfork='$d_vfork'
+d_voidsig='$d_voidsig'
+d_tosignal='$d_tosignal'
+d_volatile='$d_volatile'
+d_vprintf='$d_vprintf'
+d_charvspr='$d_charvspr'
+d_wait4='$d_wait4'
+d_waitpid='$d_waitpid'
+gidtype='$gidtype'
+groupstype='$groupstype'
+i_fcntl='$i_fcntl'
+i_gdbm='$i_gdbm'
+i_grp='$i_grp'
+i_niin='$i_niin'
+i_sysin='$i_sysin'
+i_pwd='$i_pwd'
+d_pwquota='$d_pwquota'
+d_pwage='$d_pwage'
+d_pwchange='$d_pwchange'
+d_pwclass='$d_pwclass'
+d_pwexpire='$d_pwexpire'
+d_pwcomment='$d_pwcomment'
+i_sys_file='$i_sys_file'
+i_sysioctl='$i_sysioctl'
+i_time='$i_time'
+i_sys_time='$i_sys_time'
+i_sys_select='$i_sys_select'
+d_systimekernel='$d_systimekernel'
+i_utime='$i_utime'
+i_varargs='$i_varargs'
+i_vfork='$i_vfork'
+intsize='$intsize'
+libc='$libc'
+nm_opts='$nm_opts'
+libndir='$libndir'
+i_my_dir='$i_my_dir'
+i_ndir='$i_ndir'
+i_sys_ndir='$i_sys_ndir'
+i_dirent='$i_dirent'
+i_sys_dir='$i_sys_dir'
+d_dirnamlen='$d_dirnamlen'
+ndirc='$ndirc'
+ndiro='$ndiro'
+mallocsrc='$mallocsrc'
+mallocobj='$mallocobj'
+d_mymalloc='$d_mymalloc'
+mallocptrtype='$mallocptrtype'
+mansrc='$mansrc'
+manext='$manext'
+models='$models'
+split='$split'
+small='$small'
+medium='$medium'
+large='$large'
+huge='$huge'
+optimize='$optimize'
+ccflags='$ccflags'
+cppflags='$cppflags'
+ldflags='$ldflags'
+cc='$cc'
+nativegcc='$nativegcc'
+libs='$libs'
+n='$n'
+c='$c'
+package='$package'
+randbits='$randbits'
+scriptdir='$scriptdir'
+installscr='$installscr'
+sig_name='$sig_name'
+spitshell='$spitshell'
+shsharp='$shsharp'
+sharpbang='$sharpbang'
+startsh='$startsh'
+stdchar='$stdchar'
+uidtype='$uidtype'
+usrinclude='$usrinclude'
+inclPath='$inclPath'
+void='$void'
+voidhave='$voidhave'
+voidwant='$voidwant'
+w_localtim='$w_localtim'
+w_s_timevl='$w_s_timevl'
+w_s_tm='$w_s_tm'
+yacc='$yacc'
+lib='$lib'
+privlib='$privlib'
+installprivlib='$installprivlib'
+EOT
+
+test -f patchlevel.h && awk '{printf "%s=%s\n",$2,$3}' patchlevel.h >>config.sh
+echo "CONFIG=true" >>config.sh
+
+if test -f UU/oldconfig.sh; then
+ sed -n 's/^\([a-zA-Z_0-9]*\)=.*/\1/p' config.sh config.sh UU/oldconfig.sh |\
+ sort | uniq -u >UU/oldsyms
+ set X `cat UU/oldsyms`
+ shift
+ case $# in
+ 0) ;;
+ *) echo "Hmm...You had some extra variables I don't know about...I'll try to keep 'em..."
+ for sym in `cat UU/oldsyms`; do
+ echo " Propagating $hint variable "'$'"$sym..."
+ eval 'tmp="$'"${sym}"'"'
+ echo "$tmp" | \
+ sed -e "s/'/'\"'\"'/g" -e "s/^/$sym='/" -e "s/$/'/" >>config.sh
+ done
+ ;;
+ esac
+fi
+
+: Finish up
+CONFIG=true
+
+echo " "
+dflt=''
+fastread=''
+echo "If you didn't make any mistakes, then just type a carriage return here."
+rp="If you need to edit config.sh, do it as a shell escape here:"
+$echo $n "$rp $c"
+. UU/myread
+case "$ans" in
+'') ;;
+*) : in case they cannot read
+ eval $ans;;
+esac
+chmod +x doSH
+./doSH
+
+if $contains '^depend:' [Mm]akefile >/dev/null 2>&1; then
+ dflt=n
+ $cat <<EOM
+
+Now you need to generate make dependencies by running "make depend".
+You might prefer to run it in background: "make depend > makedepend.out &"
+It can take a while, so you might not want to run it right now.
+
+EOM
+ rp="Run make depend now? [$dflt]"
+ $echo $n "$rp $c"
+ . UU/myread
+ case "$ans" in
+ y*) make depend && echo "Now you must run a make."
+ ;;
+ *) echo "You must run 'make depend' then 'make'."
+ ;;
+ esac
+elif test -f [Mm]akefile; then
+ echo " "
+ echo "Now you must run a make."
+else
+ echo "Done."
+fi
+
+$rm -f kit*isdone
+$rm -rf UU
+: end of Configure
--- /dev/null
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 675 Mass Ave, Cambridge, MA 02139, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+\f
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+\f
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+\f
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+\f
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 1, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
--- /dev/null
+/* $RCSfile: EXTERN.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:10:32 $
+ *
+ * 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: EXTERN.h,v $
+ * 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
+#define EXT extern
+
+#undef INIT
+#define INIT(x)
+
+#undef DOINIT
--- /dev/null
+/* $RCSfile: INTERN.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:10:42 $
+ *
+ * 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: INTERN.h,v $
+ * 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
+#define EXT
+
+#undef INIT
+#define INIT(x) = x
+
+#define DOINIT
--- /dev/null
+Artistic The "Artistic License"
+Configure Run this first
+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 Precursor to Makefile
+PACKINGLIST Which files came from which kits
+README The Instructions
+README.uport Special instructions for Microports
+README.xenix Special instructions for Xenix
+Wishlist Some things that may or may not happen
+arg.h Public declarations for the above
+array.c Numerically subscripted arrays
+array.h Public declarations for the above
+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
+cmd.c Command interpreter
+cmd.h Public declarations for the above
+config.H Sample config.h
+config_h.SH Produces config.h
+cons.c Routines to construct cmd nodes of a parse tree
+consarg.c Routines to construct arg nodes of a parse tree
+doSH Script to run all the *.SH files
+doarg.c Scalar expression evaluation
+doio.c I/O operations
+dolist.c Array expression evaluation
+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/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/perl-mode.el Emacs major mode for perl
+emacs/perldb.el Emacs debugging
+emacs/perldb.pl Emacs debugging
+emacs/tedstuff Some optional patches
+eval.c The expression evaluator
+form.c Format processing
+form.h Public declarations for the above
+gettest A little script to test the get* routines
+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
+hash.c Associative arrays
+hash.h Public declarations for the above
+hints/3b1.sh
+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/dnix.sh
+hints/dynix.sh
+hints/fps.sh
+hints/genix.sh
+hints/greenhills.sh
+hints/hp9000_300.sh
+hints/hp9000_400.sh
+hints/hp9000_800.sh
+hints/hpux.sh
+hints/i386.sh
+hints/isc_3_2_2.sh
+hints/mips.sh
+hints/mpc.sh
+hints/ncr_tower.sh
+hints/next.sh
+hints/opus.sh
+hints/osf_1.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_3.sh
+hints/sgi.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/svr4.sh
+hints/ti1500.sh
+hints/ultrix_3.sh
+hints/ultrix_4.sh
+hints/uts.sh
+hints/vax.sh
+installperl Perl script to do "make install" dirty work
+ioctl.pl Sample ioctl.pl
+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/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/getcwd.pl a getcwd() emulator
+lib/getopt.pl Perl library supporting option parsing
+lib/getopts.pl Perl library supporting option parsing
+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/perldb.pl Perl debugging routines
+lib/pwd.pl Routines to keep track of PWD environment variable
+lib/shellwords.pl Perl library to split into words with shell quoting
+lib/stat.pl Perl library supporting stat function
+lib/syslog.pl Perl library supporting syslogging
+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
+malloc.c A version of malloc you might not want
+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
+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/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
+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.fixer A program to remove yacc stack limitations
+perly.y Yacc grammar for perl
+regcomp.c Regular expression compiler
+regcomp.h Private declarations for above
+regexec.c Regular expression evaluator
+regexp.h Public declarations for the above
+server A server to test sockets
+spat.h Search pattern declarations
+stab.c Symbol table stuff
+stab.h Public declarations for the above
+str.c String handling package
+str.h Public declarations for the above
+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/big.t See if lib/bigint.pl works
+t/op/append.t See if . works
+t/op/array.t See if array operations work
+t/op/auto.t See if autoincrement et all work
+t/op/chop.t See if chop works
+t/op/cond.t See if conditional expressions work
+t/op/dbm.t See if dbm binding works
+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/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/regexp.t See if regular expressions work
+t/op/repeat.t See if x operator works
+t/op/s.t See if substitutions work
+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/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
+toke.c The tokener
+usersub.c User supplied (possibly proprietary) subroutines
+usub/Makefile Makefile for curseperl
+usub/README Instructions for user supplied subroutines
+usub/bsdcurses.mus what used to be curses.mus
+usub/curses.mus Glue routines for BSD curses
+usub/man2mus A manual page to .mus translator
+usub/mus A .mus to .c translator
+usub/pager A sample pager in curseperl
+usub/usersub.c An initialization file to call curses glue routines
+util.c Utility routines
+util.h Public declarations for the above
+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/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
--- /dev/null
+case $CONFIG in
+'')
+ if test ! -f config.sh; then
+ ln ../config.sh . || \
+ ln ../../config.sh . || \
+ ln ../../../config.sh . || \
+ (echo "Can't find config.sh."; exit 1)
+ fi 2>/dev/null
+ . ./config.sh
+ ;;
+esac
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+
+case "$d_symlink" in
+*define*) sln='ln -s' ;;
+*) sln='ln';;
+esac
+
+case "$d_dosuid" in
+*define*) suidperl='suidperl' ;;
+*) suidperl='';;
+esac
+
+echo "Extracting Makefile (with variable substitutions)"
+cat >Makefile <<!GROK!THIS!
+# $RCSfile: Makefile.SH,v $$Revision: 4.0.1.3 $$Date: 91/11/05 15:48:11 $
+#
+# $Log: Makefile.SH,v $
+# 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.
+#
+#
+
+CC = $cc
+YACC = $yacc
+bin = $installbin
+scriptdir = $scriptdir
+privlib = $installprivlib
+mansrc = $mansrc
+manext = $manext
+LDFLAGS = $ldflags
+CLDFLAGS = $ldflags
+SMALL = $small
+LARGE = $large $split
+mallocsrc = $mallocsrc
+mallocobj = $mallocobj
+SLN = $sln
+RMS = rm -f
+
+libs = $libs $cryptlib
+
+public = perl taintperl $suidperl
+
+# To use an alternate make, set $altmake in config.sh.
+MAKE = ${altmake-make}
+
+!GROK!THIS!
+
+cat >>Makefile <<'!NO!SUBS!'
+
+CCCMD = `sh cflags $@`
+
+private =
+
+scripts = h2ph
+
+manpages = perl.man h2ph.man
+
+util =
+
+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 usersub.c
+
+c = $(c1) $(c2) $(c3)
+
+s1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c
+s2 = eval.c form.c hash.c perl.c regcomp.c regexec.c
+s3 = stab.c str.c toke.c util.c usersub.c perly.c
+
+saber = $(s1) $(s2) $(s3)
+
+obj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o
+obj2 = eval.o form.o $(mallocobj) perl.o regcomp.o regexec.o
+obj3 = stab.o str.o toke.o util.o
+
+obj = $(obj1) $(obj2) $(obj3)
+
+tobj1 = tarray.o tcmd.o tcons.o tconsarg.o tdoarg.o tdoio.o tdolist.o tdump.o
+tobj2 = teval.o tform.o thash.o $(mallocobj) tregcomp.o tregexec.o
+tobj3 = tstab.o tstr.o ttoke.o tutil.o
+
+tobj = $(tobj1) $(tobj2) $(tobj3)
+
+lintflags = -hbvxac
+
+addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
+
+# grrr
+SHELL = /bin/sh
+
+.c.o:
+ $(CCCMD) $*.c
+
+all: $(public) $(private) $(util) uperl.o $(scripts)
+ cd x2p; $(MAKE) all
+ touch all
+
+# 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: $& perly.o $(obj) hash.o usersub.o
+ $(CC) $(LARGE) $(CLDFLAGS) $(obj) hash.o perly.o usersub.o $(libs) -o perl
+
+# This command assumes that /usr/include/dbz.h and /usr/lib/dbz.o exist.
+
+dbzperl: $& perly.o $(obj) zhash.o usersub.o
+ $(CC) $(LARGE) $(CLDFLAGS) $(obj) zhash.o /usr/lib/dbz.o perly.o usersub.o $(libs) -o dbzperl
+
+zhash.o: hash.c $(h)
+ $(RMS) zhash.c
+ $(SLN) hash.c zhash.c
+ $(CCCMD) -DWANT_DBZ zhash.c
+ $(RMS) zhash.c
+
+uperl.o: $& perly.o $(obj) hash.o
+ -ld $(LARGE) $(LDFLAGS) -r $(obj) hash.o perly.o -o uperl.o
+
+saber: $(saber)
+ # load $(saber)
+ # load /lib/libm.a
+
+# 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: $& tperly.o sperl.o $(tobj) usersub.o
+ $(CC) $(LARGE) $(CLDFLAGS) sperl.o $(tobj) tperly.o usersub.o $(libs) \
+ -o suidperl
+
+# This version interprets scripts that are already set-id either via a wrapper
+# or through the kernel allowing set-id scripts (bad idea). Taintperl must
+# NOT be setuid to root or anything else. The only difference between it
+# and normal perl is the presence of the "taint" checks.
+
+taintperl: $& tperly.o tperl.o $(tobj) usersub.o
+ $(CC) $(LARGE) $(CLDFLAGS) tperl.o $(tobj) tperly.o usersub.o $(libs) \
+ -o taintperl
+
+# Replicating all this junk is yucky, but I don't see a portable way to fix it.
+
+tperly.o: perly.c perly.h $(h)
+ $(RMS) tperly.c
+ $(SLN) perly.c tperly.c
+ $(CCCMD) -DTAINT tperly.c
+ $(RMS) tperly.c
+
+tperl.o: perl.c perly.h patchlevel.h perl.h $(h)
+ $(RMS) tperl.c
+ $(SLN) perl.c tperl.c
+ $(CCCMD) -DTAINT tperl.c
+ $(RMS) tperl.c
+
+sperl.o: perl.c perly.h patchlevel.h $(h)
+ $(RMS) sperl.c
+ $(SLN) perl.c sperl.c
+ $(CCCMD) -DTAINT -DIAMSUID sperl.c
+ $(RMS) sperl.c
+
+tarray.o: array.c $(h)
+ $(RMS) tarray.c
+ $(SLN) array.c tarray.c
+ $(CCCMD) -DTAINT tarray.c
+ $(RMS) tarray.c
+
+tcmd.o: cmd.c $(h)
+ $(RMS) tcmd.c
+ $(SLN) cmd.c tcmd.c
+ $(CCCMD) -DTAINT tcmd.c
+ $(RMS) tcmd.c
+
+tcons.o: cons.c $(h) perly.h
+ $(RMS) tcons.c
+ $(SLN) cons.c tcons.c
+ $(CCCMD) -DTAINT tcons.c
+ $(RMS) tcons.c
+
+tconsarg.o: consarg.c $(h)
+ $(RMS) tconsarg.c
+ $(SLN) consarg.c tconsarg.c
+ $(CCCMD) -DTAINT tconsarg.c
+ $(RMS) tconsarg.c
+
+tdoarg.o: doarg.c $(h)
+ $(RMS) tdoarg.c
+ $(SLN) doarg.c tdoarg.c
+ $(CCCMD) -DTAINT tdoarg.c
+ $(RMS) tdoarg.c
+
+tdoio.o: doio.c $(h)
+ $(RMS) tdoio.c
+ $(SLN) doio.c tdoio.c
+ $(CCCMD) -DTAINT tdoio.c
+ $(RMS) tdoio.c
+
+tdolist.o: dolist.c $(h)
+ $(RMS) tdolist.c
+ $(SLN) dolist.c tdolist.c
+ $(CCCMD) -DTAINT tdolist.c
+ $(RMS) tdolist.c
+
+tdump.o: dump.c $(h)
+ $(RMS) tdump.c
+ $(SLN) dump.c tdump.c
+ $(CCCMD) -DTAINT tdump.c
+ $(RMS) tdump.c
+
+teval.o: eval.c $(h)
+ $(RMS) teval.c
+ $(SLN) eval.c teval.c
+ $(CCCMD) -DTAINT teval.c
+ $(RMS) teval.c
+
+tform.o: form.c $(h)
+ $(RMS) tform.c
+ $(SLN) form.c tform.c
+ $(CCCMD) -DTAINT tform.c
+ $(RMS) tform.c
+
+thash.o: hash.c $(h)
+ $(RMS) thash.c
+ $(SLN) hash.c thash.c
+ $(CCCMD) -DTAINT thash.c
+ $(RMS) thash.c
+
+tregcomp.o: regcomp.c $(h)
+ $(RMS) tregcomp.c
+ $(SLN) regcomp.c tregcomp.c
+ $(CCCMD) -DTAINT tregcomp.c
+ $(RMS) tregcomp.c
+
+tregexec.o: regexec.c $(h)
+ $(RMS) tregexec.c
+ $(SLN) regexec.c tregexec.c
+ $(CCCMD) -DTAINT tregexec.c
+ $(RMS) tregexec.c
+
+tstab.o: stab.c $(h)
+ $(RMS) tstab.c
+ $(SLN) stab.c tstab.c
+ $(CCCMD) -DTAINT tstab.c
+ $(RMS) tstab.c
+
+tstr.o: str.c $(h) perly.h
+ $(RMS) tstr.c
+ $(SLN) str.c tstr.c
+ $(CCCMD) -DTAINT tstr.c
+ $(RMS) tstr.c
+
+ttoke.o: toke.c $(h) perly.h
+ $(RMS) ttoke.c
+ $(SLN) toke.c ttoke.c
+ $(CCCMD) -DTAINT ttoke.c
+ $(RMS) ttoke.c
+
+tutil.o: util.c $(h)
+ $(RMS) tutil.c
+ $(SLN) util.c tutil.c
+ $(CCCMD) -DTAINT tutil.c
+ $(RMS) tutil.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
+
+install: all
+ ./perl installperl
+
+clean:
+ rm -f *.o all perl taintperl suidperl
+ cd x2p; $(MAKE) clean
+
+realclean: clean
+ cd x2p; $(MAKE) realclean
+ rm -f *.orig */*.orig *~ */*~ core $(addedbyconf) h2ph h2ph.man
+ rm -f perly.c perly.h t/perl Makefile config.h makedepend makedir
+ rm -f makefile x2p/Makefile x2p/makefile cflags x2p/cflags
+ 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
+ - 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
+$(obj) hash.o:
+ @ echo "You haven't done a "'"make depend" yet!'; exit 1
+makedepend: makedepend.SH
+ /bin/sh makedepend.SH
+!NO!SUBS!
+$eunicefix Makefile
+case `pwd` in
+*SH)
+ $rm -f ../Makefile
+ ln Makefile ../Makefile
+ ;;
+esac
+rm -f makefile
--- /dev/null
+After all the perl kits are run you should have the following files:
+
+Filename Kit Description
+-------- --- -----------
+Artistic 33 The "Artistic License"
+Configure:AA 6 Run this first
+Configure:AB 13
+Copying 29 The GNU General Public License
+EXTERN.h 39 Included before foreign .h files
+INTERN.h 39 Included before domestic .h files
+MANIFEST 17 This list of files
+Makefile.SH 31 Precursor to Makefile
+PACKINGLIST 25 Which files came from which kits
+README 1 The Instructions
+README.uport 1 Special instructions for Microports
+README.xenix 1 Special instructions for Xenix
+Wishlist 40 Some things that may or may not happen
+arg.h 21 Public declarations for the above
+array.c 32 Numerically subscripted arrays
+array.h 39 Public declarations for the above
+c2ph.SH 21 program to translate dbx stabs to perl
+c2ph.doc 30 documentation for c2ph
+cflags.SH 36 A script that emits C compilation flags per file
+client 39 A client to test sockets
+cmd.c 19 Command interpreter
+cmd.h 34 Public declarations for the above
+config.H 26 Sample config.h
+config_h.SH 24 Produces config.h
+cons.c 14 Routines to construct cmd nodes of a parse tree
+consarg.c 20 Routines to construct arg nodes of a parse tree
+doSH 39 Script to run all the *.SH files
+doarg.c 12 Scalar expression evaluation
+doio.c:AA 7 I/O operations
+doio.c:AB 30
+dolist.c 11 Array expression evaluation
+dump.c 29 Debugging output
+eg/ADB 40 An adb wrapper to put in your crash dir
+eg/README 1 Intro to example perl scripts
+eg/changes 38 A program to list recently changed files
+eg/down 39 A program to do things to subdirectories
+eg/dus 39 A program to do du -s on non-mounted dirs
+eg/findcp 38 A find wrapper that implements a -cp switch
+eg/findtar 39 A find wrapper that pumps out a tar file
+eg/g/gcp 36 A program to do a global rcp
+eg/g/gcp.man 28 Manual page for gcp
+eg/g/ged 39 A program to do a global edit
+eg/g/ghosts 38 A sample /etc/ghosts file
+eg/g/gsh 36 A program to do a global rsh
+eg/g/gsh.man 37 Manual page for gsh
+eg/muck 36 A program to find missing make dependencies
+eg/muck.man 39 Manual page for muck
+eg/myrup 38 A program to find lightly loaded machines
+eg/nih 39 Script to insert #! workaround
+eg/relink 11 A program to change symbolic links
+eg/rename 34 A program to rename files
+eg/rmfrom 40 A program to feed doomed filenames to
+eg/scan/scan_df 37 Scan for filesystem anomalies
+eg/scan/scan_last 38 Scan for login anomalies
+eg/scan/scan_messages 33 Scan for console message anomalies
+eg/scan/scan_passwd 39 Scan for passwd file anomalies
+eg/scan/scan_ps 39 Scan for process anomalies
+eg/scan/scan_sudo 38 Scan for sudo anomalies
+eg/scan/scan_suid 36 Scan for setuid anomalies
+eg/scan/scanner 37 An anomaly reporter
+eg/shmkill 39 A program to remove unused shared memory
+eg/sysvipc/README 1 Intro to Sys V IPC examples
+eg/sysvipc/ipcmsg 38 Example of SYS V IPC message queues
+eg/sysvipc/ipcsem 38 Example of Sys V IPC semaphores
+eg/sysvipc/ipcshm 38 Example of Sys V IPC shared memory
+eg/travesty 39 A program to print travesties of its input text
+eg/van/empty 39 A program to empty the trashcan
+eg/van/unvanish 37 A program to undo what vanish does
+eg/van/vanexp 39 A program to expire vanished files
+eg/van/vanish 37 A program to put files in a trashcan
+eg/who 39 A sample who program
+emacs/perl-mode.el 22 Emacs major mode for perl
+emacs/perldb.el 28 Emacs debugging
+emacs/perldb.pl 18 Emacs debugging
+emacs/tedstuff 30 Some optional patches
+eval.c:AA 3 The expression evaluator
+eval.c:AB 26
+form.c 16 Format processing
+form.h 38 Public declarations for the above
+gettest 39 A little script to test the get* routines
+h2ph.SH 32 A thing to turn C .h file into perl .ph files
+h2pl/README 1 How to turn .ph files into .pl files
+h2pl/cbreak.pl 39 cbreak routines using .ph
+h2pl/cbreak2.pl 39 cbreak routines using .pl
+h2pl/eg/sizeof.ph 39 Sample sizeof array initialization
+h2pl/eg/sys/errno.pl 37 Sample translated errno.pl
+h2pl/eg/sys/ioctl.pl 35 Sample translated ioctl.pl
+h2pl/eg/sysexits.pl 39 Sample translated sysexits.pl
+h2pl/getioctlsizes 39 Program to extract types from ioctl.h
+h2pl/mksizes 39 Program to make %sizeof array.
+h2pl/mkvars 39 Program to make .pl from .ph files
+h2pl/tcbreak 40 cbreak test routine using .ph
+h2pl/tcbreak2 40 cbreak test routine using .pl
+handy.h 34 Handy definitions
+hash.c 28 Associative arrays
+hash.h 37 Public declarations for the above
+hints/3b1.sh 40
+hints/3b2.sh 40
+hints/aix_rs.sh 40
+hints/aix_rt.sh 40
+hints/altos486.sh 40
+hints/apollo_C6_7.sh 26
+hints/apollo_C6_8.sh 39
+hints/aux.sh 40
+hints/dnix.sh 40
+hints/dynix.sh 40
+hints/fps.sh 40
+hints/genix.sh 40
+hints/greenhills.sh 40
+hints/hp9000_300.sh 40
+hints/hp9000_400.sh 40
+hints/hp9000_800.sh 22
+hints/hpux.sh 39
+hints/i386.sh 40
+hints/isc_3_2_2.sh 39
+hints/mips.sh 39
+hints/mpc.sh 40
+hints/ncr_tower.sh 40
+hints/next.sh 19
+hints/opus.sh 40
+hints/osf_1.sh 37
+hints/sco_2_3_0.sh 40
+hints/sco_2_3_1.sh 40
+hints/sco_2_3_2.sh 38
+hints/sco_2_3_3.sh 40
+hints/sco_3.sh 40
+hints/sgi.sh 40
+hints/stellar.sh 18
+hints/sunos_3_4.sh 24
+hints/sunos_3_5.sh 40
+hints/sunos_4_0_1.sh 40
+hints/sunos_4_0_2.sh 40
+hints/svr4.sh 40
+hints/ti1500.sh 40
+hints/ultrix_3.sh 39
+hints/ultrix_4.sh 39
+hints/uts.sh 40
+hints/vax.sh 40
+installperl 33 Perl script to do "make install" dirty work
+ioctl.pl 35 Sample ioctl.pl
+lib/abbrev.pl 39 An abbreviation table builder
+lib/assert.pl 38 assertion and panic with stack trace
+lib/bigfloat.pl 32 An arbitrary precision floating point package
+lib/bigint.pl 31 An arbitrary precision integer arithmetic package
+lib/bigrat.pl 34 An arbitrary precision rational arithmetic package
+lib/cacheout.pl 38 Manages output filehandles when you need too many
+lib/chat2.pl 31 Randal's famous expect-ish routines
+lib/complete.pl 36 A command completion subroutine
+lib/ctime.pl 37 A ctime workalike
+lib/dumpvar.pl 1 A variable dumper
+lib/exceptions.pl 37 catch and throw routines
+lib/fastcwd.pl 39 a faster but more dangerous getcwd
+lib/find.pl 36 A find emulator--used by find2perl
+lib/finddepth.pl 31 A depth-first find emulator--used by find2perl
+lib/flush.pl 39 Routines to do single flush
+lib/getcwd.pl 38 a getcwd() emulator
+lib/getopt.pl 38 Perl library supporting option parsing
+lib/getopts.pl 38 Perl library supporting option parsing
+lib/importenv.pl 20 Perl routine to get environment into variables
+lib/look.pl 38 A "look" equivalent
+lib/newgetopt.pl 32 A perl library supporting long option parsing
+lib/perldb.pl 24 Perl debugging routines
+lib/pwd.pl 38 Routines to keep track of PWD environment variable
+lib/shellwords.pl 39 Perl library to split into words with shell quoting
+lib/stat.pl 39 Perl library supporting stat function
+lib/syslog.pl 32 Perl library supporting syslogging
+lib/termcap.pl 35 Perl library supporting termcap usage
+lib/timelocal.pl 36 Perl library supporting inverse of localtime, gmtime
+lib/validate.pl 35 Perl library supporting wholesale file mode validation
+makedepend.SH 34 Precursor to makedepend
+makedir.SH 38 Precursor to makedir
+malloc.c 30 A version of malloc you might not want
+msdos/Changes.dds 37 Expanation of MS-DOS patches by Diomidis Spinellis
+msdos/Makefile 16 MS-DOS makefile
+msdos/README.msdos 1 Compiling and usage information
+msdos/Wishlist.dds 39 My wishlist
+msdos/chdir.c 37 A chdir that can change drives
+msdos/config.h 23 Definitions for msdos
+msdos/dir.h 37 MS-DOS header for directory access functions
+msdos/directory.c 35 MS-DOS directory access functions.
+msdos/eg/crlf.bat 38 Convert files from unix to MS-DOS line termination
+msdos/eg/drives.bat 38 List the system drives and their characteristics
+msdos/eg/lf.bat 38 Convert files from MS-DOS to Unix line termination
+msdos/glob.c 39 A command equivalent to csh glob
+msdos/msdos.c 33 MS-DOS ioctl, sleep, gete?[gu]if, spawn, aspawn
+msdos/popen.c 35 My_popen and my_pclose for MS-DOS
+msdos/usage.c 37 How to invoke perl under MS-DOS
+os2/Makefile 35 Makefile for OS/2
+os2/README.OS2 1 Notes for OS/2
+os2/a2p.cs 40 Compiler script for a2p
+os2/a2p.def 40 Linker defs for a2p
+os2/alarm.c 35 An implementation of alarm()
+os2/alarm.h 40 Header file for same
+os2/config.h 20 Configuration file for OS/2
+os2/dir.h 37 Directory header
+os2/director.c 33 Directory routines
+os2/eg/alarm.pl 39 Example of alarm code
+os2/eg/os2.pl 37 Sample script for OS/2
+os2/eg/syscalls.pl 39 Example of syscall on OS/2
+os2/glob.c 13 Globbing routines
+os2/makefile 35 Make file
+os2/mktemp.c 39 Mktemp() using TMP
+os2/os2.c 25 Unix compatibility functions
+os2/perl.bad 40 names of protect-only API calls for BIND
+os2/perl.cs 39 Compiler script for perl
+os2/perl.def 25 Linker defs for perl
+os2/perldb.dif 38 Changes to make the debugger work
+os2/perlglob.bad 40 names of protect-only API calls for BIND
+os2/perlglob.cs 40 Compiler script for perlglob
+os2/perlglob.def 40 Linker defs for perlglob
+os2/perlsh.cmd 39 Poor man's shell for os2
+os2/popen.c 33 Code for opening pipes
+os2/s2p.cmd 31 s2p as command file
+os2/selfrun.bat 40 A self running perl script for DOS
+os2/selfrun.cmd 40 Example of extproc feature
+os2/suffix.c 34 Code for creating backup filenames
+patchlevel.h 40 The current patch level of perl
+perl.c 15 main()
+perl.h 22 Global declarations
+perl.man:AA 9 The manual page(s)
+perl.man:AB 8
+perl.man:AC 5
+perl.man:AD 10
+perlsh 39 A poor man's perl shell
+perly.fixer 34 A program to remove yacc stack limitations
+perly.y 27 Yacc grammar for perl
+regcomp.c 18 Regular expression compiler
+regcomp.h 31 Private declarations for above
+regexec.c 23 Regular expression evaluator
+regexp.h 37 Public declarations for the above
+server 39 A server to test sockets
+spat.h 37 Search pattern declarations
+stab.c 27 Symbol table stuff
+stab.h 34 Public declarations for the above
+str.c 17 String handling package
+str.h 33 Public declarations for the above
+t/README 1 Instructions for regression tests
+t/TEST 37 The regression tester
+t/base/cond.t 23 See if conditionals work
+t/base/if.t 39 See if if works
+t/base/lex.t 38 See if lexical items work
+t/base/pat.t 39 See if pattern matching works
+t/base/term.t 10 See if various terms work
+t/cmd/elsif.t 39 See if else-if works
+t/cmd/for.t 38 See if for loops work
+t/cmd/mod.t 33 See if statement modifiers work
+t/cmd/subval.t 35 See if subroutine values work
+t/cmd/switch.t 37 See if switch optimizations work
+t/cmd/while.t 36 See if while loops work
+t/comp/cmdopt.t 36 See if command optimization works
+t/comp/cpp.t 39 See if C preprocessor works
+t/comp/decl.t 39 See if declarations work
+t/comp/multiline.t 39 See if multiline strings work
+t/comp/package.t 21 See if packages work
+t/comp/script.t 39 See if script invokation works
+t/comp/term.t 38 See if more terms work
+t/io/argv.t 38 See if ARGV stuff works
+t/io/dup.t 39 See if >& works right
+t/io/fs.t 36 See if directory manipulations work
+t/io/inplace.t 39 See if inplace editing works
+t/io/pipe.t 38 See if secure pipes work
+t/io/print.t 39 See if print commands work
+t/io/tell.t 38 See if file seeking works
+t/lib/big.t 34 See if lib/bigint.pl works
+t/op/append.t 39 See if . works
+t/op/array.t 35 See if array operations work
+t/op/auto.t 36 See if autoincrement et all work
+t/op/chop.t 39 See if chop works
+t/op/cond.t 39 See if conditional expressions work
+t/op/dbm.t 36 See if dbm binding works
+t/op/delete.t 39 See if delete works
+t/op/do.t 38 See if subroutines work
+t/op/each.t 38 See if associative iterators work
+t/op/eval.t 38 See if eval operator works
+t/op/exec.t 39 See if exec and system work
+t/op/exp.t 39 See if math functions work
+t/op/flip.t 36 See if range operator works
+t/op/fork.t 39 See if fork works
+t/op/glob.t 39 See if <*> works
+t/op/goto.t 39 See if goto works
+t/op/groups.t 38 See if $( works
+t/op/index.t 37 See if index works
+t/op/int.t 39 See if int works
+t/op/join.t 39 See if join works
+t/op/list.t 36 See if array lists work
+t/op/local.t 39 See if local works
+t/op/magic.t 38 See if magic variables work
+t/op/mkdir.t 39 See if mkdir works
+t/op/oct.t 29 See if oct and hex work
+t/op/ord.t 39 See if ord works
+t/op/pack.t 39 See if pack and unpack work
+t/op/pat.t 34 See if esoteric patterns work
+t/op/push.t 38 See if push and pop work
+t/op/range.t 38 See if .. works
+t/op/re_tests 32 Input file for op.regexp
+t/op/read.t 39 See if read() works
+t/op/readdir.t 39 See if readdir() works
+t/op/regexp.t 38 See if regular expressions work
+t/op/repeat.t 37 See if x operator works
+t/op/s.t 34 See if substitutions work
+t/op/sleep.t 40 See if sleep works
+t/op/sort.t 38 See if sort works
+t/op/split.t 14 See if split works
+t/op/sprintf.t 39 See if sprintf works
+t/op/stat.t 24 See if stat works
+t/op/study.t 15 See if study works
+t/op/substr.t 35 See if substr works
+t/op/time.t 38 See if time functions work
+t/op/undef.t 37 See if undef works
+t/op/unshift.t 39 See if unshift works
+t/op/vec.t 38 See if vectors work
+t/op/write.t 37 See if write works
+toke.c:AA 4 The tokener
+toke.c:AB 15
+usersub.c 32 User supplied (possibly proprietary) subroutines
+usub/Makefile 39 Makefile for curseperl
+usub/README 1 Instructions for user supplied subroutines
+usub/bsdcurses.mus 29 what used to be curses.mus
+usub/curses.mus 19 Glue routines for BSD curses
+usub/man2mus 37 A manual page to .mus translator
+usub/mus 36 A .mus to .c translator
+usub/pager 35 A sample pager in curseperl
+usub/usersub.c 37 An initialization file to call curses glue routines
+util.c 16 Utility routines
+util.h 30 Public declarations for the above
+x2p/EXTERN.h 39 Same as above
+x2p/INTERN.h 39 Same as above
+x2p/Makefile.SH 36 Precursor to Makefile
+x2p/a2p.h 32 Global declarations
+x2p/a2p.man 12 Manual page for awk to perl translator
+x2p/a2p.y 14 A yacc grammer for awk
+x2p/a2py.c 25 Awk compiler, sort of
+x2p/cflags.SH 27 A script that emits C compilation flags per file
+x2p/find2perl.SH 29 A find to perl translator
+x2p/handy.h 38 Handy definitions
+x2p/hash.c 33 Associative arrays again
+x2p/hash.h 37 Public declarations for the above
+x2p/s2p.SH 28 Sed to perl translator
+x2p/s2p.man 36 Manual page for sed to perl translator
+x2p/str.c 13 String handling package
+x2p/str.h 38 Public declarations for the above
+x2p/util.c 33 Utility routines
+x2p/util.h 38 Public declarations for the above
+x2p/walk.c:AA 2 Parse tree walker
+x2p/walk.c:AB 39
--- /dev/null
+built-in cpp
+perl to C translator
+multi-threading
--- /dev/null
+/* $RCSfile: arg.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 15:51:05 $
+ *
+ * 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: arg.h,v $
+ * Revision 4.0.1.2 91/11/05 15:51:05 lwall
+ * patch11: added eval {}
+ * patch11: added sort {} LIST
+ *
+ * Revision 4.0.1.1 91/06/07 10:18:30 lwall
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ * patch4: new copyright notice
+ * patch4: many, many itty-bitty portability fixes
+ *
+ * Revision 4.0 91/03/20 01:03:09 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#define O_NULL 0
+#define O_RCAT 1
+#define O_ITEM 2
+#define O_SCALAR 3
+#define O_ITEM2 4
+#define O_ITEM3 5
+#define O_CONCAT 6
+#define O_REPEAT 7
+#define O_MATCH 8
+#define O_NMATCH 9
+#define O_SUBST 10
+#define O_NSUBST 11
+#define O_ASSIGN 12
+#define O_LOCAL 13
+#define O_AASSIGN 14
+#define O_SASSIGN 15
+#define O_CHOP 16
+#define O_DEFINED 17
+#define O_UNDEF 18
+#define O_STUDY 19
+#define O_POW 20
+#define O_MULTIPLY 21
+#define O_DIVIDE 22
+#define O_MODULO 23
+#define O_ADD 24
+#define O_SUBTRACT 25
+#define O_LEFT_SHIFT 26
+#define O_RIGHT_SHIFT 27
+#define O_LT 28
+#define O_GT 29
+#define O_LE 30
+#define O_GE 31
+#define O_EQ 32
+#define O_NE 33
+#define O_NCMP 34
+#define O_BIT_AND 35
+#define O_XOR 36
+#define O_BIT_OR 37
+#define O_AND 38
+#define O_OR 39
+#define O_COND_EXPR 40
+#define O_COMMA 41
+#define O_NEGATE 42
+#define O_NOT 43
+#define O_COMPLEMENT 44
+#define O_SELECT 45
+#define O_WRITE 46
+#define O_DBMOPEN 47
+#define O_DBMCLOSE 48
+#define O_OPEN 49
+#define O_TRANS 50
+#define O_NTRANS 51
+#define O_CLOSE 52
+#define O_EACH 53
+#define O_VALUES 54
+#define O_KEYS 55
+#define O_LARRAY 56
+#define O_ARRAY 57
+#define O_AELEM 58
+#define O_DELETE 59
+#define O_LHASH 60
+#define O_HASH 61
+#define O_HELEM 62
+#define O_LAELEM 63
+#define O_LHELEM 64
+#define O_LSLICE 65
+#define O_ASLICE 66
+#define O_HSLICE 67
+#define O_LASLICE 68
+#define O_LHSLICE 69
+#define O_SPLICE 70
+#define O_PUSH 71
+#define O_POP 72
+#define O_SHIFT 73
+#define O_UNPACK 74
+#define O_SPLIT 75
+#define O_LENGTH 76
+#define O_SPRINTF 77
+#define O_SUBSTR 78
+#define O_PACK 79
+#define O_GREP 80
+#define O_JOIN 81
+#define O_SLT 82
+#define O_SGT 83
+#define O_SLE 84
+#define O_SGE 85
+#define O_SEQ 86
+#define O_SNE 87
+#define O_SCMP 88
+#define O_SUBR 89
+#define O_DBSUBR 90
+#define O_CALLER 91
+#define O_SORT 92
+#define O_REVERSE 93
+#define O_WARN 94
+#define O_DIE 95
+#define O_PRTF 96
+#define O_PRINT 97
+#define O_CHDIR 98
+#define O_EXIT 99
+#define O_RESET 100
+#define O_LIST 101
+#define O_EOF 102
+#define O_GETC 103
+#define O_TELL 104
+#define O_RECV 105
+#define O_READ 106
+#define O_SYSREAD 107
+#define O_SYSWRITE 108
+#define O_SEND 109
+#define O_SEEK 110
+#define O_RETURN 111
+#define O_REDO 112
+#define O_NEXT 113
+#define O_LAST 114
+#define O_DUMP 115
+#define O_GOTO 116
+#define O_INDEX 117
+#define O_RINDEX 118
+#define O_TIME 119
+#define O_TMS 120
+#define O_LOCALTIME 121
+#define O_GMTIME 122
+#define O_TRUNCATE 123
+#define O_LSTAT 124
+#define O_STAT 125
+#define O_CRYPT 126
+#define O_ATAN2 127
+#define O_SIN 128
+#define O_COS 129
+#define O_RAND 130
+#define O_SRAND 131
+#define O_EXP 132
+#define O_LOG 133
+#define O_SQRT 134
+#define O_INT 135
+#define O_ORD 136
+#define O_ALARM 137
+#define O_SLEEP 138
+#define O_RANGE 139
+#define O_F_OR_R 140
+#define O_FLIP 141
+#define O_FLOP 142
+#define O_FORK 143
+#define O_WAIT 144
+#define O_WAITPID 145
+#define O_SYSTEM 146
+#define O_EXEC_OP 147
+#define O_HEX 148
+#define O_OCT 149
+#define O_CHOWN 150
+#define O_KILL 151
+#define O_UNLINK 152
+#define O_CHMOD 153
+#define O_UTIME 154
+#define O_UMASK 155
+#define O_MSGGET 156
+#define O_SHMGET 157
+#define O_SEMGET 158
+#define O_MSGCTL 159
+#define O_SHMCTL 160
+#define O_SEMCTL 161
+#define O_MSGSND 162
+#define O_MSGRCV 163
+#define O_SEMOP 164
+#define O_SHMREAD 165
+#define O_SHMWRITE 166
+#define O_RENAME 167
+#define O_LINK 168
+#define O_MKDIR 169
+#define O_RMDIR 170
+#define O_GETPPID 171
+#define O_GETPGRP 172
+#define O_SETPGRP 173
+#define O_GETPRIORITY 174
+#define O_SETPRIORITY 175
+#define O_CHROOT 176
+#define O_FCNTL 177
+#define O_IOCTL 178
+#define O_FLOCK 179
+#define O_UNSHIFT 180
+#define O_REQUIRE 181
+#define O_DOFILE 182
+#define O_EVAL 183
+#define O_FTRREAD 184
+#define O_FTRWRITE 185
+#define O_FTREXEC 186
+#define O_FTEREAD 187
+#define O_FTEWRITE 188
+#define O_FTEEXEC 189
+#define O_FTIS 190
+#define O_FTEOWNED 191
+#define O_FTROWNED 192
+#define O_FTZERO 193
+#define O_FTSIZE 194
+#define O_FTMTIME 195
+#define O_FTATIME 196
+#define O_FTCTIME 197
+#define O_FTSOCK 198
+#define O_FTCHR 199
+#define O_FTBLK 200
+#define O_FTFILE 201
+#define O_FTDIR 202
+#define O_FTPIPE 203
+#define O_FTLINK 204
+#define O_SYMLINK 205
+#define O_READLINK 206
+#define O_FTSUID 207
+#define O_FTSGID 208
+#define O_FTSVTX 209
+#define O_FTTTY 210
+#define O_FTTEXT 211
+#define O_FTBINARY 212
+#define O_SOCKET 213
+#define O_BIND 214
+#define O_CONNECT 215
+#define O_LISTEN 216
+#define O_ACCEPT 217
+#define O_GHBYNAME 218
+#define O_GHBYADDR 219
+#define O_GHOSTENT 220
+#define O_GNBYNAME 221
+#define O_GNBYADDR 222
+#define O_GNETENT 223
+#define O_GPBYNAME 224
+#define O_GPBYNUMBER 225
+#define O_GPROTOENT 226
+#define O_GSBYNAME 227
+#define O_GSBYPORT 228
+#define O_GSERVENT 229
+#define O_SHOSTENT 230
+#define O_SNETENT 231
+#define O_SPROTOENT 232
+#define O_SSERVENT 233
+#define O_EHOSTENT 234
+#define O_ENETENT 235
+#define O_EPROTOENT 236
+#define O_ESERVENT 237
+#define O_SOCKPAIR 238
+#define O_SHUTDOWN 239
+#define O_GSOCKOPT 240
+#define O_SSOCKOPT 241
+#define O_GETSOCKNAME 242
+#define O_GETPEERNAME 243
+#define O_SSELECT 244
+#define O_FILENO 245
+#define O_BINMODE 246
+#define O_VEC 247
+#define O_GPWNAM 248
+#define O_GPWUID 249
+#define O_GPWENT 250
+#define O_SPWENT 251
+#define O_EPWENT 252
+#define O_GGRNAM 253
+#define O_GGRGID 254
+#define O_GGRENT 255
+#define O_SGRENT 256
+#define O_EGRENT 257
+#define O_GETLOGIN 258
+#define O_OPEN_DIR 259
+#define O_READDIR 260
+#define O_TELLDIR 261
+#define O_SEEKDIR 262
+#define O_REWINDDIR 263
+#define O_CLOSEDIR 264
+#define O_SYSCALL 265
+#define O_PIPE 266
+#define O_TRY 267
+#define O_EVALONCE 268
+#define MAXO 269
+
+#ifndef DOINIT
+extern char *opname[];
+#else
+char *opname[] = {
+ "NULL",
+ "RCAT",
+ "ITEM",
+ "SCALAR",
+ "ITEM2",
+ "ITEM3",
+ "CONCAT",
+ "REPEAT",
+ "MATCH",
+ "NMATCH",
+ "SUBST",
+ "NSUBST",
+ "ASSIGN",
+ "LOCAL",
+ "AASSIGN",
+ "SASSIGN",
+ "CHOP",
+ "DEFINED",
+ "UNDEF",
+ "STUDY",
+ "POW",
+ "MULTIPLY",
+ "DIVIDE",
+ "MODULO",
+ "ADD",
+ "SUBTRACT",
+ "LEFT_SHIFT",
+ "RIGHT_SHIFT",
+ "LT",
+ "GT",
+ "LE",
+ "GE",
+ "EQ",
+ "NE",
+ "NCMP",
+ "BIT_AND",
+ "XOR",
+ "BIT_OR",
+ "AND",
+ "OR",
+ "COND_EXPR",
+ "COMMA",
+ "NEGATE",
+ "NOT",
+ "COMPLEMENT",
+ "SELECT",
+ "WRITE",
+ "DBMOPEN",
+ "DBMCLOSE",
+ "OPEN",
+ "TRANS",
+ "NTRANS",
+ "CLOSE",
+ "EACH",
+ "VALUES",
+ "KEYS",
+ "LARRAY",
+ "ARRAY",
+ "AELEM",
+ "DELETE",
+ "LHASH",
+ "HASH",
+ "HELEM",
+ "LAELEM",
+ "LHELEM",
+ "LSLICE",
+ "ASLICE",
+ "HSLICE",
+ "LASLICE",
+ "LHSLICE",
+ "SPLICE",
+ "PUSH",
+ "POP",
+ "SHIFT",
+ "UNPACK",
+ "SPLIT",
+ "LENGTH",
+ "SPRINTF",
+ "SUBSTR",
+ "PACK",
+ "GREP",
+ "JOIN",
+ "SLT",
+ "SGT",
+ "SLE",
+ "SGE",
+ "SEQ",
+ "SNE",
+ "SCMP",
+ "SUBR",
+ "DBSUBR",
+ "CALLER",
+ "SORT",
+ "REVERSE",
+ "WARN",
+ "DIE",
+ "PRINTF",
+ "PRINT",
+ "CHDIR",
+ "EXIT",
+ "RESET",
+ "LIST",
+ "EOF",
+ "GETC",
+ "TELL",
+ "RECV",
+ "READ",
+ "SYSREAD",
+ "SYSWRITE",
+ "SEND",
+ "SEEK",
+ "RETURN",
+ "REDO",
+ "NEXT",
+ "LAST",
+ "DUMP",
+ "GOTO",/* shudder */
+ "INDEX",
+ "RINDEX",
+ "TIME",
+ "TIMES",
+ "LOCALTIME",
+ "GMTIME",
+ "TRUNCATE",
+ "LSTAT",
+ "STAT",
+ "CRYPT",
+ "ATAN2",
+ "SIN",
+ "COS",
+ "RAND",
+ "SRAND",
+ "EXP",
+ "LOG",
+ "SQRT",
+ "INT",
+ "ORD",
+ "ALARM",
+ "SLEEP",
+ "RANGE",
+ "FLIP_OR_RANGE",
+ "FLIP",
+ "FLOP",
+ "FORK",
+ "WAIT",
+ "WAITPID",
+ "SYSTEM",
+ "EXEC",
+ "HEX",
+ "OCT",
+ "CHOWN",
+ "KILL",
+ "UNLINK",
+ "CHMOD",
+ "UTIME",
+ "UMASK",
+ "MSGGET",
+ "SHMGET",
+ "SEMGET",
+ "MSGCTL",
+ "SHMCTL",
+ "SEMCTL",
+ "MSGSND",
+ "MSGRCV",
+ "SEMOP",
+ "SHMREAD",
+ "SHMWRITE",
+ "RENAME",
+ "LINK",
+ "MKDIR",
+ "RMDIR",
+ "GETPPID",
+ "GETPGRP",
+ "SETPGRP",
+ "GETPRIORITY",
+ "SETPRIORITY",
+ "CHROOT",
+ "FCNTL",
+ "SYSIOCTL",
+ "FLOCK",
+ "UNSHIFT",
+ "REQUIRE",
+ "DOFILE",
+ "EVAL",
+ "FTRREAD",
+ "FTRWRITE",
+ "FTREXEC",
+ "FTEREAD",
+ "FTEWRITE",
+ "FTEEXEC",
+ "FTIS",
+ "FTEOWNED",
+ "FTROWNED",
+ "FTZERO",
+ "FTSIZE",
+ "FTMTIME",
+ "FTATIME",
+ "FTCTIME",
+ "FTSOCK",
+ "FTCHR",
+ "FTBLK",
+ "FTFILE",
+ "FTDIR",
+ "FTPIPE",
+ "FTLINK",
+ "SYMLINK",
+ "READLINK",
+ "FTSUID",
+ "FTSGID",
+ "FTSVTX",
+ "FTTTY",
+ "FTTEXT",
+ "FTBINARY",
+ "SOCKET",
+ "BIND",
+ "CONNECT",
+ "LISTEN",
+ "ACCEPT",
+ "GHBYNAME",
+ "GHBYADDR",
+ "GHOSTENT",
+ "GNBYNAME",
+ "GNBYADDR",
+ "GNETENT",
+ "GPBYNAME",
+ "GPBYNUMBER",
+ "GPROTOENT",
+ "GSBYNAME",
+ "GSBYPORT",
+ "GSERVENT",
+ "SHOSTENT",
+ "SNETENT",
+ "SPROTOENT",
+ "SSERVENT",
+ "EHOSTENT",
+ "ENETENT",
+ "EPROTOENT",
+ "ESERVENT",
+ "SOCKPAIR",
+ "SHUTDOWN",
+ "GSOCKOPT",
+ "SSOCKOPT",
+ "GETSOCKNAME",
+ "GETPEERNAME",
+ "SSELECT",
+ "FILENO",
+ "BINMODE",
+ "VEC",
+ "GPWNAM",
+ "GPWUID",
+ "GPWENT",
+ "SPWENT",
+ "EPWENT",
+ "GGRNAM",
+ "GGRGID",
+ "GGRENT",
+ "SGRENT",
+ "EGRENT",
+ "GETLOGIN",
+ "OPENDIR",
+ "READDIR",
+ "TELLDIR",
+ "SEEKDIR",
+ "REWINDDIR",
+ "CLOSEDIR",
+ "SYSCALL",
+ "PIPE",
+ "TRY",
+ "EVALONCE",
+ "269"
+};
+#endif
+
+#define A_NULL 0
+#define A_EXPR 1
+#define A_CMD 2
+#define A_STAB 3
+#define A_LVAL 4
+#define A_SINGLE 5
+#define A_DOUBLE 6
+#define A_BACKTICK 7
+#define A_READ 8
+#define A_SPAT 9
+#define A_LEXPR 10
+#define A_ARYLEN 11
+#define A_ARYSTAB 12
+#define A_LARYLEN 13
+#define A_GLOB 14
+#define A_WORD 15
+#define A_INDREAD 16
+#define A_LARYSTAB 17
+#define A_STAR 18
+#define A_LSTAR 19
+#define A_WANTARRAY 20
+#define A_LENSTAB 21
+
+#define A_MASK 31
+#define A_DONT 32 /* or this into type to suppress evaluation */
+
+#ifndef DOINIT
+extern char *argname[];
+#else
+char *argname[] = {
+ "A_NULL",
+ "EXPR",
+ "CMD",
+ "STAB",
+ "LVAL",
+ "SINGLE",
+ "DOUBLE",
+ "BACKTICK",
+ "READ",
+ "SPAT",
+ "LEXPR",
+ "ARYLEN",
+ "ARYSTAB",
+ "LARYLEN",
+ "GLOB",
+ "WORD",
+ "INDREAD",
+ "LARYSTAB",
+ "STAR",
+ "LSTAR",
+ "WANTARRAY",
+ "LENSTAB",
+ "22"
+};
+#endif
+
+#ifndef DOINIT
+extern bool hoistable[];
+#else
+bool hoistable[] =
+ {0, /* A_NULL */
+ 0, /* EXPR */
+ 1, /* CMD */
+ 1, /* STAB */
+ 0, /* LVAL */
+ 1, /* SINGLE */
+ 0, /* DOUBLE */
+ 0, /* BACKTICK */
+ 0, /* READ */
+ 0, /* SPAT */
+ 0, /* LEXPR */
+ 1, /* ARYLEN */
+ 1, /* ARYSTAB */
+ 0, /* LARYLEN */
+ 0, /* GLOB */
+ 1, /* WORD */
+ 0, /* INDREAD */
+ 0, /* LARYSTAB */
+ 1, /* STAR */
+ 1, /* LSTAR */
+ 1, /* WANTARRAY */
+ 0, /* LENSTAB */
+ 0, /* 21 */
+};
+#endif
+
+union argptr {
+ ARG *arg_arg;
+ char *arg_cval;
+ STAB *arg_stab;
+ SPAT *arg_spat;
+ CMD *arg_cmd;
+ STR *arg_str;
+ HASH *arg_hash;
+};
+
+struct arg {
+ union argptr arg_ptr;
+ short arg_len;
+ unsigned short arg_type;
+ unsigned short arg_flags;
+};
+
+#define AF_ARYOK 1 /* op can handle multiple values here */
+#define AF_POST 2 /* post *crement this item */
+#define AF_PRE 4 /* pre *crement this item */
+#define AF_UP 8 /* increment rather than decrement */
+#define AF_COMMON 16 /* left and right have symbols in common */
+#define AF_DEPR 32 /* an older form of the construct */
+#define AF_LISTISH 64 /* turn into list if important */
+#define AF_LOCAL 128 /* list of local variables */
+
+/*
+ * Most of the ARG pointers are used as pointers to arrays of ARG. When
+ * so used, the 0th element is special, and represents the operator to
+ * use on the list of arguments following. The arg_len in the 0th element
+ * gives the maximum argument number, and the arg_str is used to store
+ * the return value in a more-or-less static location. Sorry it's not
+ * re-entrant (yet), but it sure makes it efficient. The arg_type of the
+ * 0th element is an operator (O_*) rather than an argument type (A_*).
+ */
+
+#define Nullarg Null(ARG*)
+
+#ifndef DOINIT
+EXT unsigned short opargs[MAXO+1];
+#else
+#define A(e1,e2,e3) (e1+(e2<<2)+(e3<<4))
+#define A5(e1,e2,e3,e4,e5) (e1+(e2<<2)+(e3<<4)+(e4<<6)+(e5<<8))
+unsigned short opargs[MAXO+1] = {
+ A(0,0,0), /* NULL */
+ A(1,1,0), /* RCAT */
+ A(1,0,0), /* ITEM */
+ A(1,0,0), /* SCALAR */
+ A(0,0,0), /* ITEM2 */
+ A(0,0,0), /* ITEM3 */
+ A(1,1,0), /* CONCAT */
+ A(3,1,0), /* REPEAT */
+ A(1,0,0), /* MATCH */
+ A(1,0,0), /* NMATCH */
+ A(1,0,0), /* SUBST */
+ A(1,0,0), /* NSUBST */
+ A(1,1,0), /* ASSIGN */
+ A(1,0,0), /* LOCAL */
+ A(3,3,0), /* AASSIGN */
+ A(0,0,0), /* SASSIGN */
+ A(3,0,0), /* CHOP */
+ A(1,0,0), /* DEFINED */
+ A(1,0,0), /* UNDEF */
+ A(1,0,0), /* STUDY */
+ A(1,1,0), /* POW */
+ A(1,1,0), /* MULTIPLY */
+ A(1,1,0), /* DIVIDE */
+ A(1,1,0), /* MODULO */
+ A(1,1,0), /* ADD */
+ A(1,1,0), /* SUBTRACT */
+ A(1,1,0), /* LEFT_SHIFT */
+ A(1,1,0), /* RIGHT_SHIFT */
+ A(1,1,0), /* LT */
+ A(1,1,0), /* GT */
+ A(1,1,0), /* LE */
+ A(1,1,0), /* GE */
+ A(1,1,0), /* EQ */
+ A(1,1,0), /* NE */
+ A(1,1,0), /* NCMP */
+ A(1,1,0), /* BIT_AND */
+ A(1,1,0), /* XOR */
+ A(1,1,0), /* BIT_OR */
+ A(1,0,0), /* AND */
+ A(1,0,0), /* OR */
+ A(1,0,0), /* COND_EXPR */
+ A(1,1,0), /* COMMA */
+ A(1,0,0), /* NEGATE */
+ A(1,0,0), /* NOT */
+ A(1,0,0), /* COMPLEMENT */
+ A(1,0,0), /* SELECT */
+ A(1,0,0), /* WRITE */
+ A(1,1,1), /* DBMOPEN */
+ A(1,0,0), /* DBMCLOSE */
+ A(1,1,0), /* OPEN */
+ A(1,0,0), /* TRANS */
+ A(1,0,0), /* NTRANS */
+ A(1,0,0), /* CLOSE */
+ A(0,0,0), /* EACH */
+ A(0,0,0), /* VALUES */
+ A(0,0,0), /* KEYS */
+ A(0,0,0), /* LARRAY */
+ A(0,0,0), /* ARRAY */
+ A(0,1,0), /* AELEM */
+ A(0,1,0), /* DELETE */
+ A(0,0,0), /* LHASH */
+ A(0,0,0), /* HASH */
+ A(0,1,0), /* HELEM */
+ A(0,1,0), /* LAELEM */
+ A(0,1,0), /* LHELEM */
+ A(0,3,3), /* LSLICE */
+ A(0,3,0), /* ASLICE */
+ A(0,3,0), /* HSLICE */
+ A(0,3,0), /* LASLICE */
+ A(0,3,0), /* LHSLICE */
+ A(0,3,1), /* SPLICE */
+ A(0,3,0), /* PUSH */
+ A(0,0,0), /* POP */
+ A(0,0,0), /* SHIFT */
+ A(1,1,0), /* UNPACK */
+ A(1,0,1), /* SPLIT */
+ A(1,0,0), /* LENGTH */
+ A(3,0,0), /* SPRINTF */
+ A(1,1,1), /* SUBSTR */
+ A(1,3,0), /* PACK */
+ A(0,3,0), /* GREP */
+ A(1,3,0), /* JOIN */
+ A(1,1,0), /* SLT */
+ A(1,1,0), /* SGT */
+ A(1,1,0), /* SLE */
+ A(1,1,0), /* SGE */
+ A(1,1,0), /* SEQ */
+ A(1,1,0), /* SNE */
+ A(1,1,0), /* SCMP */
+ A(0,3,0), /* SUBR */
+ A(0,3,0), /* DBSUBR */
+ A(1,0,0), /* CALLER */
+ A(1,3,0), /* SORT */
+ A(0,3,0), /* REVERSE */
+ A(0,3,0), /* WARN */
+ A(0,3,0), /* DIE */
+ A(1,3,0), /* PRINTF */
+ A(1,3,0), /* PRINT */
+ A(1,0,0), /* CHDIR */
+ A(1,0,0), /* EXIT */
+ A(1,0,0), /* RESET */
+ A(3,0,0), /* LIST */
+ A(1,0,0), /* EOF */
+ A(1,0,0), /* GETC */
+ A(1,0,0), /* TELL */
+ A5(1,1,1,1,0), /* RECV */
+ A(1,1,3), /* READ */
+ A(1,1,3), /* SYSREAD */
+ A(1,1,3), /* SYSWRITE */
+ A(1,1,3), /* SEND */
+ A(1,1,1), /* SEEK */
+ A(0,3,0), /* RETURN */
+ A(0,0,0), /* REDO */
+ A(0,0,0), /* NEXT */
+ A(0,0,0), /* LAST */
+ A(0,0,0), /* DUMP */
+ A(0,0,0), /* GOTO */
+ A(1,1,1), /* INDEX */
+ A(1,1,1), /* RINDEX */
+ A(0,0,0), /* TIME */
+ A(0,0,0), /* TIMES */
+ A(1,0,0), /* LOCALTIME */
+ A(1,0,0), /* GMTIME */
+ A(1,1,0), /* TRUNCATE */
+ A(1,0,0), /* LSTAT */
+ A(1,0,0), /* STAT */
+ A(1,1,0), /* CRYPT */
+ A(1,1,0), /* ATAN2 */
+ A(1,0,0), /* SIN */
+ A(1,0,0), /* COS */
+ A(1,0,0), /* RAND */
+ A(1,0,0), /* SRAND */
+ A(1,0,0), /* EXP */
+ A(1,0,0), /* LOG */
+ A(1,0,0), /* SQRT */
+ A(1,0,0), /* INT */
+ A(1,0,0), /* ORD */
+ A(1,0,0), /* ALARM */
+ A(1,0,0), /* SLEEP */
+ A(1,1,0), /* RANGE */
+ A(1,0,0), /* F_OR_R */
+ A(1,0,0), /* FLIP */
+ A(0,1,0), /* FLOP */
+ A(0,0,0), /* FORK */
+ A(0,0,0), /* WAIT */
+ A(1,1,0), /* WAITPID */
+ A(1,3,0), /* SYSTEM */
+ A(1,3,0), /* EXEC */
+ A(1,0,0), /* HEX */
+ A(1,0,0), /* OCT */
+ A(0,3,0), /* CHOWN */
+ A(0,3,0), /* KILL */
+ A(0,3,0), /* UNLINK */
+ A(0,3,0), /* CHMOD */
+ A(0,3,0), /* UTIME */
+ A(1,0,0), /* UMASK */
+ A(1,1,0), /* MSGGET */
+ A(1,1,1), /* SHMGET */
+ A(1,1,1), /* SEMGET */
+ A(1,1,1), /* MSGCTL */
+ A(1,1,1), /* SHMCTL */
+ A5(1,1,1,1,0), /* SEMCTL */
+ A(1,1,1), /* MSGSND */
+ A5(1,1,1,1,1), /* MSGRCV */
+ A(1,1,1), /* SEMOP */
+ A5(1,1,1,1,0), /* SHMREAD */
+ A5(1,1,1,1,0), /* SHMWRITE */
+ A(1,1,0), /* RENAME */
+ A(1,1,0), /* LINK */
+ A(1,1,0), /* MKDIR */
+ A(1,0,0), /* RMDIR */
+ A(0,0,0), /* GETPPID */
+ A(1,0,0), /* GETPGRP */
+ A(1,1,0), /* SETPGRP */
+ A(1,1,0), /* GETPRIORITY */
+ A(1,1,1), /* SETPRIORITY */
+ A(1,0,0), /* CHROOT */
+ A(1,1,1), /* FCNTL */
+ A(1,1,1), /* SYSIOCTL */
+ A(1,1,0), /* FLOCK */
+ A(0,3,0), /* UNSHIFT */
+ A(1,0,0), /* REQUIRE */
+ A(1,0,0), /* DOFILE */
+ A(1,0,0), /* EVAL */
+ A(1,0,0), /* FTRREAD */
+ A(1,0,0), /* FTRWRITE */
+ A(1,0,0), /* FTREXEC */
+ A(1,0,0), /* FTEREAD */
+ A(1,0,0), /* FTEWRITE */
+ A(1,0,0), /* FTEEXEC */
+ A(1,0,0), /* FTIS */
+ A(1,0,0), /* FTEOWNED */
+ A(1,0,0), /* FTROWNED */
+ A(1,0,0), /* FTZERO */
+ A(1,0,0), /* FTSIZE */
+ A(1,0,0), /* FTMTIME */
+ A(1,0,0), /* FTATIME */
+ A(1,0,0), /* FTCTIME */
+ A(1,0,0), /* FTSOCK */
+ A(1,0,0), /* FTCHR */
+ A(1,0,0), /* FTBLK */
+ A(1,0,0), /* FTFILE */
+ A(1,0,0), /* FTDIR */
+ A(1,0,0), /* FTPIPE */
+ A(1,0,0), /* FTLINK */
+ A(1,1,0), /* SYMLINK */
+ A(1,0,0), /* READLINK */
+ A(1,0,0), /* FTSUID */
+ A(1,0,0), /* FTSGID */
+ A(1,0,0), /* FTSVTX */
+ A(1,0,0), /* FTTTY */
+ A(1,0,0), /* FTTEXT */
+ A(1,0,0), /* FTBINARY */
+ A5(1,1,1,1,0), /* SOCKET */
+ A(1,1,0), /* BIND */
+ A(1,1,0), /* CONNECT */
+ A(1,1,0), /* LISTEN */
+ A(1,1,0), /* ACCEPT */
+ A(1,0,0), /* GHBYNAME */
+ A(1,1,0), /* GHBYADDR */
+ A(0,0,0), /* GHOSTENT */
+ A(1,0,0), /* GNBYNAME */
+ A(1,1,0), /* GNBYADDR */
+ A(0,0,0), /* GNETENT */
+ A(1,0,0), /* GPBYNAME */
+ A(1,0,0), /* GPBYNUMBER */
+ A(0,0,0), /* GPROTOENT */
+ A(1,1,0), /* GSBYNAME */
+ A(1,1,0), /* GSBYPORT */
+ A(0,0,0), /* GSERVENT */
+ A(1,0,0), /* SHOSTENT */
+ A(1,0,0), /* SNETENT */
+ A(1,0,0), /* SPROTOENT */
+ A(1,0,0), /* SSERVENT */
+ A(0,0,0), /* EHOSTENT */
+ A(0,0,0), /* ENETENT */
+ A(0,0,0), /* EPROTOENT */
+ A(0,0,0), /* ESERVENT */
+ A5(1,1,1,1,1), /* SOCKPAIR */
+ A(1,1,0), /* SHUTDOWN */
+ A(1,1,1), /* GSOCKOPT */
+ A5(1,1,1,1,0), /* SSOCKOPT */
+ A(1,0,0), /* GETSOCKNAME */
+ A(1,0,0), /* GETPEERNAME */
+ A5(1,1,1,1,0), /* SSELECT */
+ A(1,0,0), /* FILENO */
+ A(1,0,0), /* BINMODE */
+ A(1,1,1), /* VEC */
+ A(1,0,0), /* GPWNAM */
+ A(1,0,0), /* GPWUID */
+ A(0,0,0), /* GPWENT */
+ A(0,0,0), /* SPWENT */
+ A(0,0,0), /* EPWENT */
+ A(1,0,0), /* GGRNAM */
+ A(1,0,0), /* GGRGID */
+ A(0,0,0), /* GGRENT */
+ A(0,0,0), /* SGRENT */
+ A(0,0,0), /* EGRENT */
+ A(0,0,0), /* GETLOGIN */
+ A(1,1,0), /* OPENDIR */
+ A(1,0,0), /* READDIR */
+ A(1,0,0), /* TELLDIR */
+ A(1,1,0), /* SEEKDIR */
+ A(1,0,0), /* REWINDDIR */
+ A(1,0,0), /* CLOSEDIR */
+ A(1,3,0), /* SYSCALL */
+ A(1,1,0), /* PIPE */
+ A(0,0,0), /* TRY */
+ A(1,0,0), /* EVALONCE */
+ 0
+};
+#undef A
+#undef A5
+#endif
+
+int do_trans();
+int do_split();
+bool do_eof();
+long do_tell();
+bool do_seek();
+int do_tms();
+int do_time();
+int do_stat();
+STR *do_push();
+FILE *nextargv();
+STR *do_fttext();
+int do_slice();
--- /dev/null
+/* $RCSfile: array.c,v $$Revision: 4.0.1.2 $$Date: 91/11/05 16:00:14 $
+ *
+ * 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: array.c,v $
+ * 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.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+STR *
+afetch(ar,key,lval)
+register ARRAY *ar;
+int key;
+int lval;
+{
+ STR *str;
+
+ if (key < 0 || key > ar->ary_fill) {
+ if (lval && key >= 0) {
+ if (ar->ary_flags & ARF_REAL)
+ str = Str_new(5,0);
+ else
+ str = str_mortal(&str_undef);
+ (void)astore(ar,key,str);
+ return str;
+ }
+ else
+ return &str_undef;
+ }
+ if (!ar->ary_array[key]) {
+ if (lval) {
+ str = Str_new(6,0);
+ (void)astore(ar,key,str);
+ return str;
+ }
+ return &str_undef;
+ }
+ return ar->ary_array[key];
+}
+
+bool
+astore(ar,key,val)
+register ARRAY *ar;
+int key;
+STR *val;
+{
+ int retval;
+
+ if (key < 0)
+ return FALSE;
+ if (key > ar->ary_max) {
+ int newmax;
+
+ if (ar->ary_alloc != ar->ary_array) {
+ retval = ar->ary_array - ar->ary_alloc;
+ Copy(ar->ary_array, ar->ary_alloc, ar->ary_max+1, STR*);
+ Zero(ar->ary_alloc+ar->ary_max+1, retval, STR*);
+ ar->ary_max += retval;
+ ar->ary_array -= retval;
+ if (key > ar->ary_max - 10) {
+ newmax = key + ar->ary_max;
+ goto resize;
+ }
+ }
+ else {
+ if (ar->ary_alloc) {
+ newmax = key + ar->ary_max / 5;
+ resize:
+ Renew(ar->ary_alloc,newmax+1, STR*);
+ Zero(&ar->ary_alloc[ar->ary_max+1], newmax - ar->ary_max, STR*);
+ }
+ else {
+ newmax = key < 4 ? 4 : key;
+ Newz(2,ar->ary_alloc, newmax+1, STR*);
+ }
+ ar->ary_array = ar->ary_alloc;
+ ar->ary_max = newmax;
+ }
+ }
+ if (ar->ary_flags & ARF_REAL) {
+ if (ar->ary_fill < key) {
+ while (++ar->ary_fill < key) {
+ if (ar->ary_array[ar->ary_fill] != Nullstr) {
+ str_free(ar->ary_array[ar->ary_fill]);
+ ar->ary_array[ar->ary_fill] = Nullstr;
+ }
+ }
+ }
+ retval = (ar->ary_array[key] != Nullstr);
+ if (retval)
+ str_free(ar->ary_array[key]);
+ }
+ else
+ retval = 0;
+ ar->ary_array[key] = val;
+ return retval;
+}
+
+ARRAY *
+anew(stab)
+STAB *stab;
+{
+ register ARRAY *ar;
+
+ New(1,ar,1,ARRAY);
+ ar->ary_magic = Str_new(7,0);
+ ar->ary_alloc = ar->ary_array = 0;
+ str_magic(ar->ary_magic, stab, '#', Nullch, 0);
+ ar->ary_max = ar->ary_fill = -1;
+ ar->ary_flags = ARF_REAL;
+ return ar;
+}
+
+ARRAY *
+afake(stab,size,strp)
+STAB *stab;
+register int size;
+register STR **strp;
+{
+ register ARRAY *ar;
+
+ New(3,ar,1,ARRAY);
+ New(4,ar->ary_alloc,size+1,STR*);
+ Copy(strp,ar->ary_alloc,size,STR*);
+ ar->ary_array = ar->ary_alloc;
+ ar->ary_magic = Str_new(8,0);
+ str_magic(ar->ary_magic, stab, '#', Nullch, 0);
+ ar->ary_fill = size - 1;
+ ar->ary_max = size - 1;
+ ar->ary_flags = 0;
+ while (size--) {
+ if (*strp)
+ (*strp)->str_pok &= ~SP_TEMP;
+ strp++;
+ }
+ return ar;
+}
+
+void
+aclear(ar)
+register ARRAY *ar;
+{
+ register int key;
+
+ if (!ar || !(ar->ary_flags & ARF_REAL) || ar->ary_max < 0)
+ return;
+ /*SUPPRESS 560*/
+ if (key = ar->ary_array - ar->ary_alloc) {
+ ar->ary_max += key;
+ ar->ary_array -= key;
+ }
+ for (key = 0; key <= ar->ary_max; key++)
+ str_free(ar->ary_array[key]);
+ ar->ary_fill = -1;
+ Zero(ar->ary_array, ar->ary_max+1, STR*);
+}
+
+void
+afree(ar)
+register ARRAY *ar;
+{
+ register int key;
+
+ if (!ar)
+ return;
+ /*SUPPRESS 560*/
+ if (key = ar->ary_array - ar->ary_alloc) {
+ ar->ary_max += key;
+ ar->ary_array -= key;
+ }
+ if (ar->ary_flags & ARF_REAL) {
+ for (key = 0; key <= ar->ary_max; key++)
+ str_free(ar->ary_array[key]);
+ }
+ str_free(ar->ary_magic);
+ Safefree(ar->ary_alloc);
+ Safefree(ar);
+}
+
+bool
+apush(ar,val)
+register ARRAY *ar;
+STR *val;
+{
+ return astore(ar,++(ar->ary_fill),val);
+}
+
+STR *
+apop(ar)
+register ARRAY *ar;
+{
+ STR *retval;
+
+ if (ar->ary_fill < 0)
+ return Nullstr;
+ retval = ar->ary_array[ar->ary_fill];
+ ar->ary_array[ar->ary_fill--] = Nullstr;
+ return retval;
+}
+
+aunshift(ar,num)
+register ARRAY *ar;
+register int num;
+{
+ register int i;
+ register STR **sstr,**dstr;
+
+ if (num <= 0)
+ return;
+ if (ar->ary_array - ar->ary_alloc >= num) {
+ ar->ary_max += num;
+ ar->ary_fill += num;
+ while (num--)
+ *--ar->ary_array = Nullstr;
+ }
+ else {
+ (void)astore(ar,ar->ary_fill+num,(STR*)0); /* maybe extend array */
+ dstr = ar->ary_array + ar->ary_fill;
+ sstr = dstr - num;
+#ifdef BUGGY_MSC5
+ # pragma loop_opt(off) /* don't loop-optimize the following code */
+#endif /* BUGGY_MSC5 */
+ for (i = ar->ary_fill - num; i >= 0; i--) {
+ *dstr-- = *sstr--;
+#ifdef BUGGY_MSC5
+ # pragma loop_opt() /* loop-optimization back to command-line setting */
+#endif /* BUGGY_MSC5 */
+ }
+ Zero(ar->ary_array, num, STR*);
+ }
+}
+
+STR *
+ashift(ar)
+register ARRAY *ar;
+{
+ STR *retval;
+
+ if (ar->ary_fill < 0)
+ return Nullstr;
+ retval = *ar->ary_array;
+ *(ar->ary_array++) = Nullstr;
+ ar->ary_max--;
+ ar->ary_fill--;
+ return retval;
+}
+
+int
+alen(ar)
+register ARRAY *ar;
+{
+ return ar->ary_fill;
+}
+
+afill(ar, fill)
+register ARRAY *ar;
+int fill;
+{
+ if (fill < 0)
+ fill = -1;
+ if (fill <= ar->ary_max)
+ ar->ary_fill = fill;
+ else
+ (void)astore(ar,fill,Nullstr);
+}
--- /dev/null
+/* $RCSfile: array.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:19:20 $
+ *
+ * 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: array.h,v $
+ * 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 atbl {
+ STR **ary_array;
+ STR **ary_alloc;
+ STR *ary_magic;
+ int ary_max;
+ int ary_fill;
+ char ary_flags;
+};
+
+#define ARF_REAL 1 /* free old entries */
+
+STR *afetch();
+bool astore();
+STR *apop();
+STR *ashift();
+void afree();
+void aclear();
+bool apush();
+int alen();
+ARRAY *anew();
+ARRAY *afake();
--- /dev/null
+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
+ ;;
+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 c2ph (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 >c2ph <<!GROK!THIS!
+#!$bin/perl
+#
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>c2ph <<'!NO!SUBS!'
+#
+# c2ph (aka pstruct)
+# Tom Christiansen, <tchrist@convex.com>
+#
+# As pstruct, dump C structures as generated from 'cc -g -S' stabs.
+# As c2ph, do this PLUS generate perl code for getting at the structures.
+#
+# See the usage message for more. If this isn't enough, read the code.
+#
+
+$RCSID = '$RCSfile: c2ph.SH,v $$Revision: 4.0.1.1 $$Date: 91/11/05 16:02:29 $';
+
+
+######################################################################
+
+# 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;
+}
+!NO!SUBS!
+$eunicefix c2ph
+rm -f pstruct
+ln c2ph pstruct
--- /dev/null
+Article 484 of comp.lang.perl:
+Xref: netlabs comp.lang.perl:484 comp.lang.c:983 alt.sources:134
+Path: netlabs!psinntp!iggy.GW.Vitalink.COM!lll-winken!sun-barr!cronkite.Central.Sun.COM!spdev!texsun!convex!tchrist
+From: tchrist@convex.com (Tom Christiansen)
+Newsgroups: comp.lang.perl,comp.lang.c,alt.sources
+Subject: pstruct -- a C structure formatter; AKA c2ph, a C to perl header translator
+Keywords: C perl tranlator
+Message-ID: <1991Jul25.081021.8104@convex.com>
+Date: 25 Jul 91 08:10:21 GMT
+Sender: usenet@convex.com (news access account)
+Followup-To: comp.lang.perl
+Organization: CONVEX Computer Corporation, Richardson, Tx., USA
+Lines: 1208
+Nntp-Posting-Host: pixel.convex.com
+
+Once upon a time, I wrote a program called pstruct. It was a perl
+program that tried to parse out C structures and display their member
+offsets for you. This was especially useful for people looking at
+binary dumps or poking around the kernel.
+
+Pstruct was not a pretty program. Neither was it particularly robust.
+The problem, you see, was that the C compiler was much better at parsing
+C than I could ever hope to be.
+
+So I got smart: I decided to be lazy and let the C compiler parse the C,
+which would spit out debugger stabs for me to read. These were much
+easier to parse. It's still not a pretty program, but at least it's more
+robust.
+
+Pstruct takes any .c or .h files, or preferably .s ones, since that's
+the format it is going to massage them into anyway, and spits out
+listings like this:
+
+struct tty {
+ int tty.t_locker 000 4
+ int tty.t_mutex_index 004 4
+ struct tty * tty.t_tp_virt 008 4
+ struct clist tty.t_rawq 00c 20
+ int tty.t_rawq.c_cc 00c 4
+ int tty.t_rawq.c_cmax 010 4
+ int tty.t_rawq.c_cfx 014 4
+ int tty.t_rawq.c_clx 018 4
+ struct tty * tty.t_rawq.c_tp_cpu 01c 4
+ struct tty * tty.t_rawq.c_tp_iop 020 4
+ unsigned char * tty.t_rawq.c_buf_cpu 024 4
+ unsigned char * tty.t_rawq.c_buf_iop 028 4
+ struct clist tty.t_canq 02c 20
+ int tty.t_canq.c_cc 02c 4
+ int tty.t_canq.c_cmax 030 4
+ int tty.t_canq.c_cfx 034 4
+ int tty.t_canq.c_clx 038 4
+ struct tty * tty.t_canq.c_tp_cpu 03c 4
+ struct tty * tty.t_canq.c_tp_iop 040 4
+ unsigned char * tty.t_canq.c_buf_cpu 044 4
+ unsigned char * tty.t_canq.c_buf_iop 048 4
+ struct clist tty.t_outq 04c 20
+ int tty.t_outq.c_cc 04c 4
+ int tty.t_outq.c_cmax 050 4
+ int tty.t_outq.c_cfx 054 4
+ int tty.t_outq.c_clx 058 4
+ struct tty * tty.t_outq.c_tp_cpu 05c 4
+ struct tty * tty.t_outq.c_tp_iop 060 4
+ unsigned char * tty.t_outq.c_buf_cpu 064 4
+ unsigned char * tty.t_outq.c_buf_iop 068 4
+ (*int)() tty.t_oproc_cpu 06c 4
+ (*int)() tty.t_oproc_iop 070 4
+ (*int)() tty.t_stopproc_cpu 074 4
+ (*int)() tty.t_stopproc_iop 078 4
+ struct thread * tty.t_rsel 07c 4
+
+ etc.
+
+
+Actually, this was generated by a particular set of options. You can control
+the formatting of each column, whether you prefer wide or fat, hex or decimal,
+leading zeroes or whatever.
+
+All you need to be able to use this is a C compiler than generates
+BSD/GCC-style stabs. The -g option on native BSD compilers and GCC
+should get this for you.
+
+To learn more, just type a bogus option, like -\?, and a long usage message
+will be provided. There are a fair number of possibilities.
+
+If you're only a C programmer, than this is the end of the message for you.
+You can quit right now, and if you care to, save off the source and run it
+when you feel like it. Or not.
+
+
+
+But if you're a perl programmer, then for you I have something much more
+wondrous than just a structure offset printer.
+
+You see, if you call pstruct by its other incybernation, c2ph, you have a code
+generator that translates C code into perl code! Well, structure and union
+declarations at least, but that's quite a bit.
+
+Prior to this point, anyone programming in perl who wanted to interact
+with C programs, like the kernel, was forced to guess the layouts of the C
+strutures, and then hardwire these into his program. Of course, when you
+took your wonderfully to a system where the sgtty structure was laid out
+differently, you program broke. Which is a shame.
+
+We've had Larry's h2ph translator, which helped, but that only works on
+cpp symbols, not real C, which was also very much needed. What I offer
+you is a symbolic way of getting at all the C structures. I've couched
+them in terms of packages and functions. Consider the following program:
+
+ #!/usr/local/bin/perl
+
+ require 'syscall.ph';
+ require 'sys/time.ph';
+ require 'sys/resource.ph';
+
+ $ru = "\0" x &rusage'sizeof();
+
+ syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
+
+ @ru = unpack($t = &rusage'typedef(), $ru);
+
+ $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
+
+ $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
+
+ printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
+
+
+As you see, the name of the package is the name of the structure. Regular
+fields are just their own names. Plus the follwoing accessor functions are
+provided for your convenience:
+
+ struct This takes no arguments, and is merely the number of first-level
+ elements in the structure. You would use this for indexing
+ into arrays of structures, perhaps like this
+
+
+ $usec = $u[ &user'u_utimer
+ + (&ITIMER_VIRTUAL * &itimerval'struct)
+ + &itimerval'it_value
+ + &timeval'tv_usec
+ ];
+
+ sizeof Returns the bytes in the structure, or the member if
+ you pass it an argument, such as
+
+ &rusage'sizeof(&rusage'ru_utime)
+
+ typedef This is the perl format definition for passing to pack and
+ unpack. If you ask for the typedef of a nothing, you get
+ the whole structure, otherwise you get that of the member
+ you ask for. Padding is taken care of, as is the magic to
+ guarantee that a union is unpacked into all its aliases.
+ Bitfields are not quite yet supported however.
+
+ offsetof This function is the byte offset into the array of that
+ member. You may wish to use this for indexing directly
+ into the packed structure with vec() if you're too lazy
+ to unpack it.
+
+ typeof Not to be confused with the typedef accessor function, this
+ one returns the C type of that field. This would allow
+ you to print out a nice structured pretty print of some
+ structure without knoning anything about it beforehand.
+ No args to this one is a noop. Someday I'll post such
+ a thing to dump out your u structure for you.
+
+
+The way I see this being used is like basically this:
+
+ % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
+ % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
+ % install
+
+It's a little tricker with c2ph because you have to get the includes right.
+I can't know this for your system, but it's not usually too terribly difficult.
+
+The code isn't pretty as I mentioned -- I never thought it would be a 1000-
+line program when I started, or I might not have begun. :-) But I would have
+been less cavalier in how the parts of the program communicated with each
+other, etc. It might also have helped if I didn't have to divine the makeup
+of the stabs on the fly, and then account for micro differences between my
+compiler and gcc.
+
+Anyway, here it is. Should run on perl v4 or greater. Maybe less.
+
+
+--tom
+
+
--- /dev/null
+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
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting cflags (with variable substitutions)"
+: This section of the file will have variable substitutions done on it.
+: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
+: Protect any dollar signs and backticks that you do not want interpreted
+: by putting a backslash in front. You may delete these comments.
+$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
+ ;;
+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
+ array) ;;
+ cmd) ;;
+ cons) ;;
+ consarg) ;;
+ doarg) ;;
+ doio) ;;
+ dolist) ;;
+ dump) ;;
+ eval) ;;
+ form) ;;
+ hash) ;;
+ malloc) ;;
+ perl) ;;
+ perly) ;;
+ regcomp) ;;
+ regexec) ;;
+ stab) ;;
+ str) ;;
+ toke) ;;
+ usersub) ;;
+ util) ;;
+ tarray) ;;
+ tcmd) ;;
+ tcons) ;;
+ tconsarg) ;;
+ tdoarg) ;;
+ tdoio) ;;
+ tdolist) ;;
+ tdump) ;;
+ teval) ;;
+ tform) ;;
+ thash) ;;
+ tmalloc) ;;
+ tperl) ;;
+ tperly) ;;
+ tregcomp) ;;
+ tregexec) ;;
+ tstab) ;;
+ tstr) ;;
+ ttoke) ;;
+ tusersub) ;;
+ tutil) ;;
+ *) ;;
+ esac
+
+ echo "$cc -c $ccflags $optimize $large $split"
+ eval "$also "'"$cc -c $ccflags $optimize $large $split"'
+
+ . ./config.sh
+
+done
+!NO!SUBS!
+chmod +x cflags
+$eunicefix cflags
--- /dev/null
+#!./perl
+
+$pat = 'S n C4 x8';
+$inet = 2;
+$echo = 7;
+$smtp = 25;
+$nntp = 119;
+$test = 2345;
+
+$SIG{'INT'} = 'dokill';
+
+$this = pack($pat,$inet,0, 128,149,13,43);
+$that = pack($pat,$inet,$test,127,0,0,1);
+
+if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; }
+if (bind(S,$this)) { print "bind ok\n"; } else { die $!; }
+if (connect(S,$that)) { print "connect ok\n"; } else { die $!; }
+
+select(S); $| = 1; select(stdout);
+
+if ($child = fork) {
+ while (<STDIN>) {
+ print S;
+ }
+ sleep 3;
+ do dokill();
+}
+else {
+ while (<S>) {
+ print;
+ }
+}
+
+sub dokill { kill 9,$child if $child; }
--- /dev/null
+/* $RCSfile: cmd.c,v $$Revision: 4.0.1.4 $$Date: 91/11/11 16:29:33 $
+ *
+ * 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: cmd.c,v $
+ * 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.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef I_VARARGS
+# include <varargs.h>
+#endif
+
+static STR str_chop;
+
+void grow_dlevel();
+
+/* do longjmps() clobber register variables? */
+
+#if defined(cray) || defined(STANDARD_C)
+#define JMPCLOBBER
+#endif
+
+/* This is the main command loop. We try to spend as much time in this loop
+ * as possible, so lots of optimizations do their activities in here. This
+ * means things get a little sloppy.
+ */
+
+int
+cmd_exec(cmdparm,gimme,sp)
+CMD *VOLATILE cmdparm;
+VOLATILE int gimme;
+VOLATILE int sp;
+{
+ register CMD *cmd = cmdparm;
+ SPAT *VOLATILE oldspat;
+ VOLATILE int firstsave = savestack->ary_fill;
+ VOLATILE int oldsave;
+ VOLATILE int aryoptsave;
+#ifdef DEBUGGING
+ VOLATILE int olddlevel;
+ VOLATILE int entdlevel;
+#endif
+ register STR *retstr = &str_undef;
+ register char *tmps;
+ register int cmdflags;
+ register int match;
+ register char *go_to = goto_targ;
+ register int newsp = -2;
+ register STR **st = stack->ary_array;
+ FILE *VOLATILE fp;
+ ARRAY *VOLATILE ar;
+
+ lastsize = 0;
+#ifdef DEBUGGING
+ entdlevel = dlevel;
+#endif
+tail_recursion_entry:
+#ifdef DEBUGGING
+ dlevel = entdlevel;
+#endif
+#ifdef TAINT
+ tainted = 0; /* Each statement is presumed innocent */
+#endif
+ if (cmd == Nullcmd) {
+ if (gimme == G_ARRAY && newsp > -2)
+ return newsp;
+ else {
+ st[++sp] = retstr;
+ return sp;
+ }
+ }
+ cmdflags = cmd->c_flags; /* hopefully load register */
+ if (go_to) {
+ if (cmd->c_label && strEQ(go_to,cmd->c_label))
+ goto_targ = go_to = Nullch; /* here at last */
+ else {
+ switch (cmd->c_type) {
+ case C_IF:
+ oldspat = curspat;
+ oldsave = savestack->ary_fill;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ retstr = &str_yes;
+ newsp = -2;
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ grow_dlevel();
+ }
+#endif
+ newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ retstr = st[newsp];
+ }
+ if (!goto_targ)
+ go_to = Nullch;
+ curspat = oldspat;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ cmd = cmd->ucmd.ccmd.cc_alt;
+ goto tail_recursion_entry;
+ case C_ELSE:
+ oldspat = curspat;
+ oldsave = savestack->ary_fill;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ retstr = &str_undef;
+ newsp = -2;
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 'e';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ grow_dlevel();
+ }
+#endif
+ newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ retstr = st[newsp];
+ }
+ if (!goto_targ)
+ go_to = Nullch;
+ curspat = oldspat;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ break;
+ case C_BLOCK:
+ case C_WHILE:
+ if (!(cmdflags & CF_ONCE)) {
+ cmdflags |= CF_ONCE;
+ if (++loop_ptr >= loop_max) {
+ loop_max += 128;
+ Renew(loop_stack, loop_max, struct loop);
+ }
+ loop_stack[loop_ptr].loop_label = cmd->c_label;
+ loop_stack[loop_ptr].loop_sp = sp;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d %s)\n",
+ loop_ptr, cmd->c_label ? cmd->c_label : "");
+ }
+#endif
+ }
+#ifdef JMPCLOBBER
+ cmdparm = cmd;
+#endif
+ match = setjmp(loop_stack[loop_ptr].loop_env);
+ if (match) {
+ st = stack->ary_array; /* possibly reallocated */
+#ifdef JMPCLOBBER
+ cmd = cmdparm;
+ cmdflags = cmd->c_flags|CF_ONCE;
+#endif
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
+ switch (match) {
+ default:
+ fatal("longjmp returned bad value (%d)",match);
+ case O_LAST: /* not done unless go_to found */
+ go_to = Nullch;
+ if (lastretstr) {
+ retstr = lastretstr;
+ newsp = -2;
+ }
+ else {
+ newsp = sp + lastsize;
+ retstr = st[newsp];
+ }
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ curspat = oldspat;
+ goto next_cmd;
+ case O_NEXT: /* not done unless go_to found */
+ go_to = Nullch;
+#ifdef JMPCLOBBER
+ newsp = -2;
+ retstr = &str_undef;
+#endif
+ goto next_iter;
+ case O_REDO: /* not done unless go_to found */
+ go_to = Nullch;
+#ifdef JMPCLOBBER
+ newsp = -2;
+ retstr = &str_undef;
+#endif
+ goto doit;
+ }
+ }
+ oldspat = curspat;
+ oldsave = savestack->ary_fill;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ grow_dlevel();
+ }
+#endif
+ newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ if (newsp >= 0)
+ retstr = st[newsp];
+ }
+ if (!goto_targ) {
+ go_to = Nullch;
+ goto next_iter;
+ }
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ if (cmd->ucmd.ccmd.cc_alt) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 'a';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ grow_dlevel();
+ }
+#endif
+ newsp = cmd_exec(cmd->ucmd.ccmd.cc_alt,gimme && (cmdflags & CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ if (newsp >= 0)
+ retstr = st[newsp];
+ }
+ if (goto_targ)
+ break;
+ go_to = Nullch;
+ goto finish_while;
+ }
+ cmd = cmd->c_next;
+ if (cmd && cmd->c_head == cmd)
+ /* reached end of while loop */
+ return sp; /* targ isn't in this block */
+ if (cmdflags & CF_ONCE) {
+#ifdef DEBUGGING
+ if (debug & 4) {
+ tmps = loop_stack[loop_ptr].loop_label;
+ deb("(Popping label #%d %s)\n",loop_ptr,
+ tmps ? tmps : "" );
+ }
+#endif
+ loop_ptr--;
+ }
+ goto tail_recursion_entry;
+ }
+ }
+
+until_loop:
+
+ /* Set line number so run-time errors can be located */
+
+ curcmd = cmd;
+
+#ifdef DEBUGGING
+ if (debug) {
+ if (debug & 2) {
+ deb("%s (%lx) r%lx t%lx a%lx n%lx cs%lx\n",
+ cmdname[cmd->c_type],cmd,cmd->c_expr,
+ cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt,cmd->c_next,
+ curspat);
+ }
+ debname[dlevel] = cmdname[cmd->c_type][0];
+ debdelim[dlevel] = '!';
+ if (++dlevel >= dlmax)
+ grow_dlevel();
+ }
+#endif
+
+ /* Here is some common optimization */
+
+ if (cmdflags & CF_COND) {
+ switch (cmdflags & CF_OPTIMIZE) {
+
+ case CFT_FALSE:
+ retstr = cmd->c_short;
+ newsp = -2;
+ match = FALSE;
+ if (cmdflags & CF_NESURE)
+ goto maybe;
+ break;
+ case CFT_TRUE:
+ retstr = cmd->c_short;
+ newsp = -2;
+ match = TRUE;
+ if (cmdflags & CF_EQSURE)
+ goto flipmaybe;
+ break;
+
+ case CFT_REG:
+ retstr = STAB_STR(cmd->c_stab);
+ newsp = -2;
+ match = str_true(retstr); /* => retstr = retstr, c2 should fix */
+ if (cmdflags & (match ? CF_EQSURE : CF_NESURE))
+ goto flipmaybe;
+ break;
+
+ case CFT_ANCHOR: /* /^pat/ optimization */
+ if (multiline) {
+ if (*cmd->c_short->str_ptr && !(cmdflags & CF_EQSURE))
+ goto scanner; /* just unanchor it */
+ else
+ break; /* must evaluate */
+ }
+ match = 0;
+ goto strop;
+
+ case CFT_STROP: /* string op optimization */
+ match = 1;
+ strop:
+ retstr = STAB_STR(cmd->c_stab);
+ newsp = -2;
+#ifndef I286
+ if (*cmd->c_short->str_ptr == *str_get(retstr) &&
+ (match ? retstr->str_cur == cmd->c_slen - 1 :
+ retstr->str_cur >= cmd->c_slen) &&
+ bcmp(cmd->c_short->str_ptr, str_get(retstr),
+ cmd->c_slen) == 0 ) {
+ if (cmdflags & CF_EQSURE) {
+ if (sawampersand && (cmdflags & CF_OPTIMIZE) != CFT_STROP) {
+ curspat = Nullspat;
+ if (leftstab)
+ str_nset(stab_val(leftstab),"",0);
+ if (amperstab)
+ str_sset(stab_val(amperstab),cmd->c_short);
+ if (rightstab)
+ str_nset(stab_val(rightstab),
+ retstr->str_ptr + cmd->c_slen,
+ retstr->str_cur - cmd->c_slen);
+ }
+ if (cmd->c_spat)
+ lastspat = cmd->c_spat;
+ match = !(cmdflags & CF_FIRSTNEG);
+ retstr = match ? &str_yes : &str_no;
+ goto flipmaybe;
+ }
+ }
+ else if (cmdflags & CF_NESURE) {
+ match = cmdflags & CF_FIRSTNEG;
+ retstr = match ? &str_yes : &str_no;
+ goto flipmaybe;
+ }
+#else
+ {
+ char *zap1, *zap2, zap1c, zap2c;
+ int zaplen;
+ int lenok;
+
+ zap1 = cmd->c_short->str_ptr;
+ zap2 = str_get(retstr);
+ zap1c = *zap1;
+ zap2c = *zap2;
+ zaplen = cmd->c_slen;
+ if (match)
+ lenok = (retstr->str_cur == cmd->c_slen - 1);
+ else
+ lenok = (retstr->str_cur >= cmd->c_slen);
+ if ((zap1c == zap2c) && lenok && (bcmp(zap1, zap2, zaplen) == 0)) {
+ if (cmdflags & CF_EQSURE) {
+ if (sawampersand &&
+ (cmdflags & CF_OPTIMIZE) != CFT_STROP) {
+ curspat = Nullspat;
+ if (leftstab)
+ str_nset(stab_val(leftstab),"",0);
+ if (amperstab)
+ str_sset(stab_val(amperstab),cmd->c_short);
+ if (rightstab)
+ str_nset(stab_val(rightstab),
+ retstr->str_ptr + cmd->c_slen,
+ retstr->str_cur - cmd->c_slen);
+ }
+ if (cmd->c_spat)
+ lastspat = cmd->c_spat;
+ match = !(cmdflags & CF_FIRSTNEG);
+ retstr = match ? &str_yes : &str_no;
+ goto flipmaybe;
+ }
+ }
+ else if (cmdflags & CF_NESURE) {
+ match = cmdflags & CF_FIRSTNEG;
+ retstr = match ? &str_yes : &str_no;
+ goto flipmaybe;
+ }
+ }
+#endif
+ break; /* must evaluate */
+
+ case CFT_SCAN: /* non-anchored search */
+ scanner:
+ retstr = STAB_STR(cmd->c_stab);
+ newsp = -2;
+ if (retstr->str_pok & SP_STUDIED)
+ if (screamfirst[cmd->c_short->str_rare] >= 0)
+ tmps = screaminstr(retstr, cmd->c_short);
+ else
+ tmps = Nullch;
+ else {
+ tmps = str_get(retstr); /* make sure it's pok */
+#ifndef lint
+ tmps = fbminstr((unsigned char*)tmps,
+ (unsigned char*)tmps + retstr->str_cur, cmd->c_short);
+#endif
+ }
+ if (tmps) {
+ if (cmdflags & CF_EQSURE) {
+ ++cmd->c_short->str_u.str_useful;
+ if (sawampersand) {
+ curspat = Nullspat;
+ if (leftstab)
+ str_nset(stab_val(leftstab),retstr->str_ptr,
+ tmps - retstr->str_ptr);
+ if (amperstab)
+ str_nset(stab_val(amperstab),
+ tmps, cmd->c_short->str_cur);
+ if (rightstab)
+ str_nset(stab_val(rightstab),
+ tmps + cmd->c_short->str_cur,
+ retstr->str_cur - (tmps - retstr->str_ptr) -
+ cmd->c_short->str_cur);
+ }
+ lastspat = cmd->c_spat;
+ match = !(cmdflags & CF_FIRSTNEG);
+ retstr = match ? &str_yes : &str_no;
+ goto flipmaybe;
+ }
+ else
+ hint = tmps;
+ }
+ else {
+ if (cmdflags & CF_NESURE) {
+ ++cmd->c_short->str_u.str_useful;
+ match = cmdflags & CF_FIRSTNEG;
+ retstr = match ? &str_yes : &str_no;
+ goto flipmaybe;
+ }
+ }
+ if (--cmd->c_short->str_u.str_useful < 0) {
+ cmdflags &= ~CF_OPTIMIZE;
+ cmdflags |= CFT_EVAL; /* never try this optimization again */
+ cmd->c_flags = (cmdflags & ~CF_ONCE);
+ }
+ break; /* must evaluate */
+
+ case CFT_NUMOP: /* numeric op optimization */
+ retstr = STAB_STR(cmd->c_stab);
+ newsp = -2;
+ switch (cmd->c_slen) {
+ case O_EQ:
+ if (dowarn) {
+ if ((!retstr->str_nok && !looks_like_number(retstr)))
+ warn("Possible use of == on string value");
+ }
+ match = (str_gnum(retstr) == cmd->c_short->str_u.str_nval);
+ break;
+ case O_NE:
+ match = (str_gnum(retstr) != cmd->c_short->str_u.str_nval);
+ break;
+ case O_LT:
+ match = (str_gnum(retstr) < cmd->c_short->str_u.str_nval);
+ break;
+ case O_LE:
+ match = (str_gnum(retstr) <= cmd->c_short->str_u.str_nval);
+ break;
+ case O_GT:
+ match = (str_gnum(retstr) > cmd->c_short->str_u.str_nval);
+ break;
+ case O_GE:
+ match = (str_gnum(retstr) >= cmd->c_short->str_u.str_nval);
+ break;
+ }
+ if (match) {
+ if (cmdflags & CF_EQSURE) {
+ retstr = &str_yes;
+ goto flipmaybe;
+ }
+ }
+ else if (cmdflags & CF_NESURE) {
+ retstr = &str_no;
+ goto flipmaybe;
+ }
+ break; /* must evaluate */
+
+ case CFT_INDGETS: /* while (<$foo>) */
+ last_in_stab = stabent(str_get(STAB_STR(cmd->c_stab)),TRUE);
+ if (!stab_io(last_in_stab))
+ stab_io(last_in_stab) = stio_new();
+ goto dogets;
+ case CFT_GETS: /* really a while (<file>) */
+ last_in_stab = cmd->c_stab;
+ dogets:
+ fp = stab_io(last_in_stab)->ifp;
+ retstr = stab_val(defstab);
+ newsp = -2;
+ keepgoing:
+ if (fp && str_gets(retstr, fp, 0)) {
+ if (*retstr->str_ptr == '0' && retstr->str_cur == 1)
+ match = FALSE;
+ else
+ match = TRUE;
+ stab_io(last_in_stab)->lines++;
+ }
+ else if (stab_io(last_in_stab)->flags & IOF_ARGV) {
+ if (!fp)
+ goto doeval; /* first time through */
+ fp = nextargv(last_in_stab);
+ if (fp)
+ goto keepgoing;
+ (void)do_close(last_in_stab,FALSE);
+ stab_io(last_in_stab)->flags |= IOF_START;
+ retstr = &str_undef;
+ match = FALSE;
+ }
+ else {
+ retstr = &str_undef;
+ match = FALSE;
+ }
+ goto flipmaybe;
+ case CFT_EVAL:
+ break;
+ case CFT_UNFLIP:
+ while (tmps_max > tmps_base) { /* clean up after last eval */
+ str_free(tmps_list[tmps_max]);
+ tmps_list[tmps_max--] = Nullstr;
+ }
+ newsp = eval(cmd->c_expr,gimme && (cmdflags & CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ retstr = st[newsp];
+ match = str_true(retstr);
+ if (cmd->c_expr->arg_type == O_FLIP) /* undid itself? */
+ cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd);
+ goto maybe;
+ case CFT_CHOP:
+ retstr = stab_val(cmd->c_stab);
+ newsp = -2;
+ match = (retstr->str_cur != 0);
+ tmps = str_get(retstr);
+ tmps += retstr->str_cur - match;
+ str_nset(&str_chop,tmps,match);
+ *tmps = '\0';
+ retstr->str_nok = 0;
+ retstr->str_cur = tmps - retstr->str_ptr;
+ STABSET(retstr);
+ retstr = &str_chop;
+ goto flipmaybe;
+ case CFT_ARRAY:
+ match = cmd->c_short->str_u.str_useful; /* just to get register */
+
+ if (match < 0) { /* first time through here? */
+ ar = stab_array(cmd->c_expr[1].arg_ptr.arg_stab);
+ aryoptsave = savestack->ary_fill;
+ savesptr(&stab_val(cmd->c_stab));
+ savelong(&cmd->c_short->str_u.str_useful);
+ }
+ else {
+ ar = stab_xarray(cmd->c_expr[1].arg_ptr.arg_stab);
+ if (cmd->c_type != C_WHILE && savestack->ary_fill > firstsave)
+ restorelist(firstsave);
+ }
+
+ if (match >= ar->ary_fill) { /* we're in LAST, probably */
+ if (match < 0 && /* er, probably not... */
+ savestack->ary_fill > aryoptsave)
+ restorelist(aryoptsave);
+ retstr = &str_undef;
+ cmd->c_short->str_u.str_useful = -1; /* actually redundant */
+ match = FALSE;
+ }
+ else {
+ match++;
+ if (!(retstr = ar->ary_array[match]))
+ retstr = afetch(ar,match,TRUE);
+ stab_val(cmd->c_stab) = retstr;
+ cmd->c_short->str_u.str_useful = match;
+ match = TRUE;
+ }
+ newsp = -2;
+ goto maybe;
+ case CFT_D1:
+ break;
+ case CFT_D0:
+ if (DBsingle->str_u.str_nval != 0)
+ break;
+ if (DBsignal->str_u.str_nval != 0)
+ break;
+ if (DBtrace->str_u.str_nval != 0)
+ break;
+ goto next_cmd;
+ }
+
+ /* we have tried to make this normal case as abnormal as possible */
+
+ doeval:
+ if (gimme == G_ARRAY) {
+ lastretstr = Nullstr;
+ lastspbase = sp;
+ lastsize = newsp - sp;
+ if (lastsize < 0)
+ lastsize = 0;
+ }
+ else
+ lastretstr = retstr;
+ while (tmps_max > tmps_base) { /* clean up after last eval */
+ str_free(tmps_list[tmps_max]);
+ tmps_list[tmps_max--] = Nullstr;
+ }
+ newsp = eval(cmd->c_expr,
+ gimme && (cmdflags & CF_TERM) && cmd->c_type == C_EXPR &&
+ !cmd->ucmd.acmd.ac_expr,
+ sp);
+ st = stack->ary_array; /* possibly reallocated */
+ retstr = st[newsp];
+ if (newsp > sp && retstr)
+ match = str_true(retstr);
+ else
+ match = FALSE;
+ goto maybe;
+
+ /* if flipflop was true, flop it */
+
+ flipmaybe:
+ if (match && cmdflags & CF_FLIP) {
+ while (tmps_max > tmps_base) { /* clean up after last eval */
+ str_free(tmps_list[tmps_max]);
+ tmps_list[tmps_max--] = Nullstr;
+ }
+ if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */
+ newsp = eval(cmd->c_expr,G_SCALAR,sp);/*let eval undo it*/
+ cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd);
+ }
+ else {
+ newsp = eval(cmd->c_expr,G_SCALAR,sp);/* let eval do it */
+ if (cmd->c_expr->arg_type == O_FLOP) /* still toggled? */
+ cmdflags = copyopt(cmd,cmd->c_expr[4].arg_ptr.arg_cmd);
+ }
+ }
+ else if (cmdflags & CF_FLIP) {
+ if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */
+ match = TRUE; /* force on */
+ }
+ }
+
+ /* at this point, match says whether our expression was true */
+
+ maybe:
+ if (cmdflags & CF_INVERT)
+ match = !match;
+ if (!match)
+ goto next_cmd;
+ }
+#ifdef TAINT
+ tainted = 0; /* modifier doesn't affect regular expression */
+#endif
+
+ /* now to do the actual command, if any */
+
+ switch (cmd->c_type) {
+ case C_NULL:
+ fatal("panic: cmd_exec");
+ case C_EXPR: /* evaluated for side effects */
+ if (cmd->ucmd.acmd.ac_expr) { /* more to do? */
+ if (gimme == G_ARRAY) {
+ lastretstr = Nullstr;
+ lastspbase = sp;
+ lastsize = newsp - sp;
+ if (lastsize < 0)
+ lastsize = 0;
+ }
+ else
+ lastretstr = retstr;
+ while (tmps_max > tmps_base) { /* clean up after last eval */
+ str_free(tmps_list[tmps_max]);
+ tmps_list[tmps_max--] = Nullstr;
+ }
+ newsp = eval(cmd->ucmd.acmd.ac_expr,gimme && (cmdflags&CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ retstr = st[newsp];
+ }
+ break;
+ case C_NSWITCH:
+ {
+ double value = str_gnum(STAB_STR(cmd->c_stab));
+
+ match = (int)value;
+ if (value < 0.0) {
+ if (((double)match) > value)
+ --match; /* was fractional--truncate other way */
+ }
+ }
+ goto doswitch;
+ case C_CSWITCH:
+ match = *(str_get(STAB_STR(cmd->c_stab))) & 255;
+ doswitch:
+ match -= cmd->ucmd.scmd.sc_offset;
+ if (match < 0)
+ match = 0;
+ else if (match > cmd->ucmd.scmd.sc_max)
+ match = cmd->ucmd.scmd.sc_max;
+ cmd = cmd->ucmd.scmd.sc_next[match];
+ goto tail_recursion_entry;
+ case C_NEXT:
+ cmd = cmd->ucmd.ccmd.cc_alt;
+ goto tail_recursion_entry;
+ case C_ELSIF:
+ fatal("panic: ELSIF");
+ case C_IF:
+ oldspat = curspat;
+ oldsave = savestack->ary_fill;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ retstr = &str_yes;
+ newsp = -2;
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ grow_dlevel();
+ }
+#endif
+ newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ retstr = st[newsp];
+ }
+ curspat = oldspat;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ cmd = cmd->ucmd.ccmd.cc_alt;
+ goto tail_recursion_entry;
+ case C_ELSE:
+ oldspat = curspat;
+ oldsave = savestack->ary_fill;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ retstr = &str_undef;
+ newsp = -2;
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 'e';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ grow_dlevel();
+ }
+#endif
+ newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ retstr = st[newsp];
+ }
+ curspat = oldspat;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ break;
+ case C_BLOCK:
+ case C_WHILE:
+ if (!(cmdflags & CF_ONCE)) { /* first time through here? */
+ cmdflags |= CF_ONCE;
+ if (++loop_ptr >= loop_max) {
+ loop_max += 128;
+ Renew(loop_stack, loop_max, struct loop);
+ }
+ loop_stack[loop_ptr].loop_label = cmd->c_label;
+ loop_stack[loop_ptr].loop_sp = sp;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d %s)\n",
+ loop_ptr, cmd->c_label ? cmd->c_label : "");
+ }
+#endif
+ }
+#ifdef JMPCLOBBER
+ cmdparm = cmd;
+#endif
+ match = setjmp(loop_stack[loop_ptr].loop_env);
+ if (match) {
+ st = stack->ary_array; /* possibly reallocated */
+#ifdef JMPCLOBBER
+ cmd = cmdparm;
+ cmdflags = cmd->c_flags|CF_ONCE;
+ go_to = goto_targ;
+#endif
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
+ switch (match) {
+ default:
+ fatal("longjmp returned bad value (%d)",match);
+ case O_LAST:
+ if (lastretstr) {
+ retstr = lastretstr;
+ newsp = -2;
+ }
+ else {
+ newsp = sp + lastsize;
+ retstr = st[newsp];
+ }
+ curspat = oldspat;
+ goto next_cmd;
+ case O_NEXT:
+#ifdef JMPCLOBBER
+ newsp = -2;
+ retstr = &str_undef;
+#endif
+ goto next_iter;
+ case O_REDO:
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+#ifdef JMPCLOBBER
+ newsp = -2;
+ retstr = &str_undef;
+#endif
+ goto doit;
+ }
+ }
+ oldspat = curspat;
+ oldsave = savestack->ary_fill;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ doit:
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ grow_dlevel();
+ }
+#endif
+ newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ retstr = st[newsp];
+ }
+ /* actually, this spot is rarely reached anymore since the above
+ * cmd_exec() returns through longjmp(). Hooray for structure.
+ */
+ next_iter:
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ if (cmd->ucmd.ccmd.cc_alt) {
+#ifdef DEBUGGING
+ if (debug) {
+ debname[dlevel] = 'a';
+ debdelim[dlevel] = '_';
+ if (++dlevel >= dlmax)
+ grow_dlevel();
+ }
+#endif
+ newsp = cmd_exec(cmd->ucmd.ccmd.cc_alt,gimme && (cmdflags & CF_TERM),sp);
+ st = stack->ary_array; /* possibly reallocated */
+ retstr = st[newsp];
+ }
+ finish_while:
+ curspat = oldspat;
+ if (savestack->ary_fill > oldsave) {
+ if (cmdflags & CF_TERM) {
+ for (match = sp + 1; match <= newsp; match++)
+ st[match] = str_mortal(st[match]);
+ retstr = st[newsp];
+ }
+ restorelist(oldsave);
+ }
+#ifdef DEBUGGING
+ dlevel = olddlevel - 1;
+#endif
+ if (cmd->c_type != C_BLOCK)
+ goto until_loop; /* go back and evaluate conditional again */
+ }
+ if (cmdflags & CF_LOOP) {
+ cmdflags |= CF_COND; /* now test the condition */
+#ifdef DEBUGGING
+ dlevel = entdlevel;
+#endif
+ goto until_loop;
+ }
+ next_cmd:
+ if (cmdflags & CF_ONCE) {
+#ifdef DEBUGGING
+ if (debug & 4) {
+ tmps = loop_stack[loop_ptr].loop_label;
+ deb("(Popping label #%d %s)\n",loop_ptr, tmps ? tmps : "");
+ }
+#endif
+ loop_ptr--;
+ if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY &&
+ savestack->ary_fill > aryoptsave)
+ restorelist(aryoptsave);
+ }
+ cmd = cmd->c_next;
+ goto tail_recursion_entry;
+}
+
+#ifdef DEBUGGING
+# ifndef I_VARARGS
+/*VARARGS1*/
+deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
+char *pat;
+{
+ register int i;
+
+ fprintf(stderr,"%-4ld",(long)curcmd->c_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
+/*VARARGS1*/
+deb(va_alist)
+va_dcl
+{
+ va_list args;
+ char *pat;
+ register int i;
+
+ va_start(args);
+ fprintf(stderr,"%-4ld",(long)curcmd->c_line);
+ for (i=0; i<dlevel; i++)
+ fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
+
+ pat = va_arg(args, char *);
+ (void) vfprintf(stderr,pat,args);
+ va_end( args );
+}
+# endif
+#endif
+
+copyopt(cmd,which)
+register CMD *cmd;
+register CMD *which;
+{
+ cmd->c_flags &= CF_ONCE|CF_COND|CF_LOOP;
+ cmd->c_flags |= which->c_flags;
+ cmd->c_short = which->c_short;
+ cmd->c_slen = which->c_slen;
+ cmd->c_stab = which->c_stab;
+ return cmd->c_flags;
+}
+
+ARRAY *
+saveary(stab)
+STAB *stab;
+{
+ register STR *str;
+
+ str = Str_new(10,0);
+ str->str_state = SS_SARY;
+ str->str_u.str_stab = stab;
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_ptr = Nullch;
+ str->str_len = 0;
+ }
+ str->str_ptr = (char*)stab_array(stab);
+ (void)apush(savestack,str); /* save array ptr */
+ stab_xarray(stab) = Null(ARRAY*);
+ return stab_xarray(aadd(stab));
+}
+
+HASH *
+savehash(stab)
+STAB *stab;
+{
+ register STR *str;
+
+ str = Str_new(11,0);
+ str->str_state = SS_SHASH;
+ str->str_u.str_stab = stab;
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_ptr = Nullch;
+ str->str_len = 0;
+ }
+ str->str_ptr = (char*)stab_hash(stab);
+ (void)apush(savestack,str); /* save hash ptr */
+ stab_xhash(stab) = Null(HASH*);
+ return stab_xhash(hadd(stab));
+}
+
+void
+saveitem(item)
+register STR *item;
+{
+ register STR *str;
+
+ (void)apush(savestack,item); /* remember the pointer */
+ str = Str_new(12,0);
+ str_sset(str,item);
+ (void)apush(savestack,str); /* remember the value */
+}
+
+void
+saveint(intp)
+int *intp;
+{
+ register STR *str;
+
+ str = Str_new(13,0);
+ str->str_state = SS_SINT;
+ str->str_u.str_useful = (long)*intp; /* remember value */
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_len = 0;
+ }
+ str->str_ptr = (char*)intp; /* remember pointer */
+ (void)apush(savestack,str);
+}
+
+void
+savelong(longp)
+long *longp;
+{
+ register STR *str;
+
+ str = Str_new(14,0);
+ str->str_state = SS_SLONG;
+ str->str_u.str_useful = *longp; /* remember value */
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_len = 0;
+ }
+ str->str_ptr = (char*)longp; /* remember pointer */
+ (void)apush(savestack,str);
+}
+
+void
+savesptr(sptr)
+STR **sptr;
+{
+ register STR *str;
+
+ str = Str_new(15,0);
+ str->str_state = SS_SSTRP;
+ str->str_magic = *sptr; /* remember value */
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_len = 0;
+ }
+ str->str_ptr = (char*)sptr; /* remember pointer */
+ (void)apush(savestack,str);
+}
+
+void
+savenostab(stab)
+STAB *stab;
+{
+ register STR *str;
+
+ str = Str_new(16,0);
+ str->str_state = SS_SNSTAB;
+ str->str_magic = (STR*)stab; /* remember which stab to free */
+ (void)apush(savestack,str);
+}
+
+void
+savehptr(hptr)
+HASH **hptr;
+{
+ register STR *str;
+
+ str = Str_new(17,0);
+ str->str_state = SS_SHPTR;
+ str->str_u.str_hash = *hptr; /* remember value */
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_len = 0;
+ }
+ str->str_ptr = (char*)hptr; /* remember pointer */
+ (void)apush(savestack,str);
+}
+
+void
+saveaptr(aptr)
+ARRAY **aptr;
+{
+ register STR *str;
+
+ str = Str_new(17,0);
+ str->str_state = SS_SAPTR;
+ str->str_u.str_array = *aptr; /* remember value */
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_len = 0;
+ }
+ str->str_ptr = (char*)aptr; /* remember pointer */
+ (void)apush(savestack,str);
+}
+
+void
+savelist(sarg,maxsarg)
+register STR **sarg;
+int maxsarg;
+{
+ register STR *str;
+ register int i;
+
+ for (i = 1; i <= maxsarg; i++) {
+ (void)apush(savestack,sarg[i]); /* remember the pointer */
+ str = Str_new(18,0);
+ str_sset(str,sarg[i]);
+ (void)apush(savestack,str); /* remember the value */
+ sarg[i]->str_u.str_useful = -1;
+ }
+}
+
+void
+restorelist(base)
+int base;
+{
+ register STR *str;
+ register STR *value;
+ register STAB *stab;
+
+ if (base < -1)
+ fatal("panic: corrupt saved stack index");
+ while (savestack->ary_fill > base) {
+ value = apop(savestack);
+ switch (value->str_state) {
+ case SS_NORM: /* normal string */
+ case SS_INCR:
+ str = apop(savestack);
+ str_replace(str,value);
+ STABSET(str);
+ break;
+ case SS_SARY: /* array reference */
+ stab = value->str_u.str_stab;
+ afree(stab_xarray(stab));
+ stab_xarray(stab) = (ARRAY*)value->str_ptr;
+ value->str_ptr = Nullch;
+ str_free(value);
+ break;
+ case SS_SHASH: /* hash reference */
+ stab = value->str_u.str_stab;
+ (void)hfree(stab_xhash(stab), FALSE);
+ stab_xhash(stab) = (HASH*)value->str_ptr;
+ value->str_ptr = Nullch;
+ str_free(value);
+ break;
+ case SS_SINT: /* int reference */
+ *((int*)value->str_ptr) = (int)value->str_u.str_useful;
+ value->str_ptr = Nullch;
+ str_free(value);
+ break;
+ case SS_SLONG: /* long reference */
+ *((long*)value->str_ptr) = value->str_u.str_useful;
+ value->str_ptr = Nullch;
+ str_free(value);
+ break;
+ case SS_SSTRP: /* STR* reference */
+ *((STR**)value->str_ptr) = value->str_magic;
+ value->str_magic = Nullstr;
+ value->str_ptr = Nullch;
+ str_free(value);
+ break;
+ case SS_SHPTR: /* HASH* reference */
+ *((HASH**)value->str_ptr) = value->str_u.str_hash;
+ value->str_ptr = Nullch;
+ str_free(value);
+ break;
+ case SS_SAPTR: /* ARRAY* reference */
+ *((ARRAY**)value->str_ptr) = value->str_u.str_array;
+ value->str_ptr = Nullch;
+ str_free(value);
+ break;
+ case SS_SNSTAB:
+ stab = (STAB*)value->str_magic;
+ value->str_magic = Nullstr;
+ (void)stab_clear(stab);
+ str_free(value);
+ break;
+ case SS_SCSV: /* callsave structure */
+ {
+ CSV *csv = (CSV*) value->str_ptr;
+
+ curcmd = csv->curcmd;
+ curcsv = csv->curcsv;
+ csv->sub->depth = csv->depth;
+ if (csv->hasargs) { /* put back old @_ */
+ afree(csv->argarray);
+ stab_xarray(defstab) = csv->savearray;
+ }
+ str_free(value);
+ }
+ break;
+ default:
+ fatal("panic: restorelist inconsistency");
+ }
+ }
+}
+
+#ifdef DEBUGGING
+void
+grow_dlevel()
+{
+ dlmax += 128;
+ Renew(debname, dlmax, char);
+ Renew(debdelim, dlmax, char);
+}
+#endif
--- /dev/null
+/* $RCSfile: cmd.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:28:50 $
+ *
+ * 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: cmd.h,v $
+ * 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.
+ *
+ */
+
+#define C_NULL 0
+#define C_IF 1
+#define C_ELSE 2
+#define C_WHILE 3
+#define C_BLOCK 4
+#define C_EXPR 5
+#define C_NEXT 6
+#define C_ELSIF 7 /* temporary--turns into an IF + ELSE */
+#define C_CSWITCH 8 /* created by switch optimization in block_head() */
+#define C_NSWITCH 9 /* likewise */
+
+#ifdef DEBUGGING
+#ifndef DOINIT
+extern char *cmdname[];
+#else
+char *cmdname[] = {
+ "NULL",
+ "IF",
+ "ELSE",
+ "WHILE",
+ "BLOCK",
+ "EXPR",
+ "NEXT",
+ "ELSIF",
+ "CSWITCH",
+ "NSWITCH",
+ "10"
+};
+#endif
+#endif /* DEBUGGING */
+
+#define CF_OPTIMIZE 077 /* type of optimization */
+#define CF_FIRSTNEG 0100/* conditional is ($register NE 'string') */
+#define CF_NESURE 0200 /* if short doesn't match we're sure */
+#define CF_EQSURE 0400 /* if short does match we're sure */
+#define CF_COND 01000 /* test c_expr as conditional first, if not null. */
+ /* Set for everything except do {} while currently */
+#define CF_LOOP 02000 /* loop on the c_expr conditional (loop modifiers) */
+#define CF_INVERT 04000 /* it's an "unless" or an "until" */
+#define CF_ONCE 010000 /* we've already pushed the label on the stack */
+#define CF_FLIP 020000 /* on a match do flipflop */
+#define CF_TERM 040000 /* value of this cmd might be returned */
+#define CF_DBSUB 0100000 /* this is an inserted cmd for debugging */
+
+#define CFT_FALSE 0 /* c_expr is always false */
+#define CFT_TRUE 1 /* c_expr is always true */
+#define CFT_REG 2 /* c_expr is a simple register */
+#define CFT_ANCHOR 3 /* c_expr is an anchored search /^.../ */
+#define CFT_STROP 4 /* c_expr is a string comparison */
+#define CFT_SCAN 5 /* c_expr is an unanchored search /.../ */
+#define CFT_GETS 6 /* c_expr is <filehandle> */
+#define CFT_EVAL 7 /* c_expr is not optimized, so call eval() */
+#define CFT_UNFLIP 8 /* 2nd half of range not optimized */
+#define CFT_CHOP 9 /* c_expr is a chop on a register */
+#define CFT_ARRAY 10 /* this is a foreach loop */
+#define CFT_INDGETS 11 /* c_expr is <$variable> */
+#define CFT_NUMOP 12 /* c_expr is a numeric comparison */
+#define CFT_CCLASS 13 /* c_expr must start with one of these characters */
+#define CFT_D0 14 /* no special breakpoint at this line */
+#define CFT_D1 15 /* possible special breakpoint at this line */
+
+#ifdef DEBUGGING
+#ifndef DOINIT
+extern char *cmdopt[];
+#else
+char *cmdopt[] = {
+ "FALSE",
+ "TRUE",
+ "REG",
+ "ANCHOR",
+ "STROP",
+ "SCAN",
+ "GETS",
+ "EVAL",
+ "UNFLIP",
+ "CHOP",
+ "ARRAY",
+ "INDGETS",
+ "NUMOP",
+ "CCLASS",
+ "14"
+};
+#endif
+#endif /* DEBUGGING */
+
+struct acmd {
+ STAB *ac_stab; /* a symbol table entry */
+ ARG *ac_expr; /* any associated expression */
+};
+
+struct ccmd {
+ CMD *cc_true; /* normal code to do on if and while */
+ CMD *cc_alt; /* else cmd ptr or continue code */
+};
+
+struct scmd {
+ CMD **sc_next; /* array of pointers to commands */
+ short sc_offset; /* first value - 1 */
+ short sc_max; /* last value + 1 */
+};
+
+struct cmd {
+ CMD *c_next; /* the next command at this level */
+ ARG *c_expr; /* conditional expression */
+ CMD *c_head; /* head of this command list */
+ STR *c_short; /* string to match as shortcut */
+ STAB *c_stab; /* a symbol table entry, mostly for fp */
+ SPAT *c_spat; /* pattern used by optimization */
+ char *c_label; /* label for this construct */
+ union ucmd {
+ struct acmd acmd; /* normal command */
+ struct ccmd ccmd; /* compound command */
+ struct scmd scmd; /* switch command */
+ } ucmd;
+ short c_slen; /* len of c_short, if not null */
+ VOLATILE short c_flags; /* optimization flags--see above */
+ HASH *c_stash; /* package line was compiled in */
+ STAB *c_filestab; /* file the following line # is from */
+ line_t c_line; /* line # of this command */
+ char c_type; /* what this command does */
+};
+
+#define Nullcmd Null(CMD*)
+#define Nullcsv Null(CSV*)
+
+EXT CMD * VOLATILE main_root INIT(Nullcmd);
+EXT CMD * VOLATILE eval_root INIT(Nullcmd);
+
+EXT CMD compiling;
+EXT CMD * VOLATILE curcmd INIT(&compiling);
+EXT CSV * VOLATILE curcsv INIT(Nullcsv);
+
+struct callsave {
+ SUBR *sub;
+ STAB *stab;
+ CSV *curcsv;
+ CMD *curcmd;
+ ARRAY *savearray;
+ ARRAY *argarray;
+ long depth;
+ int wantarray;
+ char hasargs;
+};
+
+struct compcmd {
+ CMD *comp_true;
+ CMD *comp_alt;
+};
+
+void opt_arg();
+ARG* evalstatic();
+int cmd_exec();
--- /dev/null
+#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.
+ */
+
+
+/* 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 "/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 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().
+ */
+#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
+ */
+/*#undef 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.
+ */
+/*#undef index strchr /* cultural */
+/*#undef rindex strrchr /* differences? */
+
+/* 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.
+ */
+#define HAS_MEMCPY /**/
+
+/* 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 stat symbolic links.
+ */
+#define HAS_MSGCTL /**/
+
+/* HAS_MSGGET
+ * This symbol, if defined, indicates that the msgget() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_MSGGET /**/
+
+/* HAS_MSGRCV
+ * This symbol, if defined, indicates that the msgrcv() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_MSGRCV /**/
+
+/* HAS_MSGSND
+ * This symbol, if defined, indicates that the msgsnd() routine is
+ * available to stat symbolic links.
+ */
+#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_RMDIR
+ * This symbol, if defined, indicates that the rmdir routine is available
+ * to remove directories. Otherwise you should fork off a new process to
+ * exec /bin/rmdir.
+ */
+#define HAS_RMDIR /**/
+
+/* HAS_SELECT
+ * This symbol, if defined, indicates that the select() 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 stat symbolic links.
+ */
+#define HAS_SEMCTL /**/
+
+/* HAS_SEMGET
+ * This symbol, if defined, indicates that the semget() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_SEMGET /**/
+
+/* HAS_SEMOP
+ * This symbol, if defined, indicates that the semop() routine is
+ * available to stat symbolic links.
+ */
+#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 stat symbolic links.
+ */
+/* 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 stat symbolic links.
+ */
+#define HAS_SHMCTL /**/
+
+/* HAS_SHMDT
+ * This symbol, if defined, indicates that the shmdt() routine is
+ * available to stat symbolic links.
+ */
+#define HAS_SHMDT /**/
+
+/* HAS_SHMGET
+ * This symbol, if defined, indicates that the shmget() routine is
+ * available to stat symbolic links.
+ */
+#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_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 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 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 /**/
+
+/* MALLOCPTRTYPE
+ * This symbol defines the kind of ptr returned by malloc and realloc.
+ */
+#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 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/local/lib/perl" /**/
+
+#endif
--- /dev/null
+: make config.h.SH
+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)
+ echo "Using config.sh from above..."
+ fi 2>/dev/null
+ . ./config.sh
+ ;;
+esac
+echo "Extracting config.h (with variable substitutions)"
+sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
+#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.
+ */
+#$d_eunice EUNICE /**/
+#$d_eunice VMS /**/
+
+/* ALIGNBYTES
+ * This symbol contains the number of bytes required to align a double.
+ * Usual values are 2, 4, and 8.
+ */
+#define ALIGNBYTES $alignbytes /**/
+
+/* 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 0x$byteorder /**/
+
+/* 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 "$cppstdin"
+#define CPPMINUS "$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.
+ */
+#$d_bcmp 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().
+ */
+#$d_bcopy 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.
+ */
+#$d_bzero 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
+ */
+#$d_castneg CASTNEGFLOAT /**/
+#define CASTFLAGS $castflags /**/
+
+/* 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.
+ */
+#$d_charsprf 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.
+ */
+#$d_chsize HAS_CHSIZE /**/
+
+/* HAS_CRYPT
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+#$d_crypt HAS_CRYPT /**/
+
+/* CSH
+ * This symbol, if defined, indicates that the C-shell exists.
+ * If defined, contains the full pathname of csh.
+ */
+#$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.
+ */
+#$d_dosuid DOSUID /**/
+
+/* HAS_DUP2
+ * This symbol, if defined, indicates that the dup2 routine is available
+ * to dup file descriptors. Otherwise you should use dup().
+ */
+#$d_dup2 HAS_DUP2 /**/
+
+/* HAS_FCHMOD
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+#$d_fchmod HAS_FCHMOD /**/
+
+/* HAS_FCHOWN
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+#$d_fchown HAS_FCHOWN /**/
+
+/* HAS_FCNTL
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
+ */
+#$d_fcntl HAS_FCNTL /**/
+
+/* FLEXFILENAMES
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+#$d_flexfnam FLEXFILENAMES /**/
+
+/* HAS_FLOCK
+ * This symbol, if defined, indicates that the flock() routine is
+ * available to do file locking.
+ */
+#$d_flock HAS_FLOCK /**/
+
+/* HAS_GETGROUPS
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+#$d_getgrps HAS_GETGROUPS /**/
+
+/* HAS_GETHOSTENT
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to lookup host names in some data base or other.
+ */
+#$d_gethent HAS_GETHOSTENT /**/
+
+/* HAS_GETPGRP
+ * This symbol, if defined, indicates that the getpgrp() routine is
+ * available to get the current process group.
+ */
+#$d_getpgrp HAS_GETPGRP /**/
+
+/* HAS_GETPGRP2
+ * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
+ * routine is available to get the current process group.
+ */
+#$d_getpgrp2 HAS_GETPGRP2 /**/
+
+/* HAS_GETPRIORITY
+ * This symbol, if defined, indicates that the getpriority() routine is
+ * available to get a process's priority.
+ */
+#$d_getprior 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.
+ */
+#$d_htonl HAS_HTONS /**/
+#$d_htonl HAS_HTONL /**/
+#$d_htonl HAS_NTOHS /**/
+#$d_htonl 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.
+ */
+#$d_index index strchr /* cultural */
+#$d_index rindex strrchr /* differences? */
+
+/* HAS_KILLPG
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+#$d_killpg HAS_KILLPG /**/
+
+/* HAS_LSTAT
+ * This symbol, if defined, indicates that the lstat() routine is
+ * available to stat symbolic links.
+ */
+#$d_lstat 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.
+ */
+#$d_memcmp 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.
+ */
+#$d_memcpy HAS_MEMCPY /**/
+
+/* HAS_MKDIR
+ * This symbol, if defined, indicates that the mkdir routine is available
+ * to create directories. Otherwise you should fork off a new process to
+ * exec /bin/mkdir.
+ */
+#$d_mkdir HAS_MKDIR /**/
+
+/* HAS_MSG
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported.
+ */
+#$d_msg HAS_MSG /**/
+
+/* HAS_MSGCTL
+ * This symbol, if defined, indicates that the msgctl() routine is
+ * available to stat symbolic links.
+ */
+#$d_msgctl HAS_MSGCTL /**/
+
+/* HAS_MSGGET
+ * This symbol, if defined, indicates that the msgget() routine is
+ * available to stat symbolic links.
+ */
+#$d_msgget HAS_MSGGET /**/
+
+/* HAS_MSGRCV
+ * This symbol, if defined, indicates that the msgrcv() routine is
+ * available to stat symbolic links.
+ */
+#$d_msgrcv HAS_MSGRCV /**/
+
+/* HAS_MSGSND
+ * This symbol, if defined, indicates that the msgsnd() routine is
+ * available to stat symbolic links.
+ */
+#$d_msgsnd HAS_MSGSND /**/
+
+/* HAS_NDBM
+ * This symbol, if defined, indicates that ndbm.h exists and should
+ * be included.
+ */
+#$d_ndbm HAS_NDBM /**/
+
+/* HAS_ODBM
+ * This symbol, if defined, indicates that dbm.h exists and should
+ * be included.
+ */
+#$d_odbm HAS_ODBM /**/
+
+/* HAS_OPEN3
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+#$d_open3 HAS_OPEN3 /**/
+
+/* HAS_READDIR
+ * This symbol, if defined, indicates that the readdir routine is available
+ * from the C library to read directories.
+ */
+#$d_readdir 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.
+ */
+#$d_rename HAS_RENAME /**/
+
+/* HAS_RMDIR
+ * This symbol, if defined, indicates that the rmdir routine is available
+ * to remove directories. Otherwise you should fork off a new process to
+ * exec /bin/rmdir.
+ */
+#$d_rmdir HAS_RMDIR /**/
+
+/* HAS_SELECT
+ * This symbol, if defined, indicates that the select() subroutine
+ * exists.
+ */
+#$d_select HAS_SELECT /**/
+
+/* HAS_SEM
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+#$d_sem HAS_SEM /**/
+
+/* HAS_SEMCTL
+ * This symbol, if defined, indicates that the semctl() routine is
+ * available to stat symbolic links.
+ */
+#$d_semctl HAS_SEMCTL /**/
+
+/* HAS_SEMGET
+ * This symbol, if defined, indicates that the semget() routine is
+ * available to stat symbolic links.
+ */
+#$d_semget HAS_SEMGET /**/
+
+/* HAS_SEMOP
+ * This symbol, if defined, indicates that the semop() routine is
+ * available to stat symbolic links.
+ */
+#$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.
+ */
+#$d_setegid HAS_SETEGID /**/
+
+/* HAS_SETEUID
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+#$d_seteuid HAS_SETEUID /**/
+
+/* HAS_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.
+ */
+#$d_setpgrp2 HAS_SETPGRP2 /**/
+
+/* HAS_SETPRIORITY
+ * This symbol, if defined, indicates that the setpriority() routine is
+ * available to set a process's priority.
+ */
+#$d_setprior HAS_SETPRIORITY /**/
+
+/* HAS_SETREGID
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current 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.
+ */
+#$d_setregid HAS_SETREGID /**/
+#$d_setresgid HAS_SETRESGID /**/
+
+/* HAS_SETREUID
+ * This symbol, if defined, indicates that the setreuid routine is
+ * available to change the real and effective uid of the current 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.
+ */
+#$d_setreuid HAS_SETREUID /**/
+#$d_setresuid HAS_SETRESUID /**/
+
+/* HAS_SETRGID
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+#$d_setrgid HAS_SETRGID /**/
+
+/* HAS_SETRUID
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+#$d_setruid HAS_SETRUID /**/
+
+/* HAS_SHM
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+#$d_shm HAS_SHM /**/
+
+/* HAS_SHMAT
+ * This symbol, if defined, indicates that the shmat() routine is
+ * available to stat symbolic links.
+ */
+/* VOID_SHMAT
+ * This symbol, if defined, indicates that the shmat() routine
+ * returns a pointer of type void*.
+ */
+#$d_shmat HAS_SHMAT /**/
+
+#$d_voidshmat VOIDSHMAT /**/
+
+/* HAS_SHMCTL
+ * This symbol, if defined, indicates that the shmctl() routine is
+ * available to stat symbolic links.
+ */
+#$d_shmctl HAS_SHMCTL /**/
+
+/* HAS_SHMDT
+ * This symbol, if defined, indicates that the shmdt() routine is
+ * available to stat symbolic links.
+ */
+#$d_shmdt HAS_SHMDT /**/
+
+/* HAS_SHMGET
+ * This symbol, if defined, indicates that the shmget() routine is
+ * available to stat symbolic links.
+ */
+#$d_shmget 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.
+ */
+#$d_socket HAS_SOCKET /**/
+
+#$d_sockpair HAS_SOCKETPAIR /**/
+
+#$d_oldsock OLDSOCKET /**/
+
+/* STATBLOCKS
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+#$d_statblks STATBLOCKS /**/
+
+/* STDSTDIO
+ * This symbol is defined if this system has a FILE structure declaring
+ * _ptr and _cnt in stdio.h.
+ */
+#$d_stdstdio 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.
+ */
+#$d_strctcpy STRUCTCOPY /**/
+
+/* HAS_STRERROR
+ * This symbol, if defined, indicates that the strerror() routine is
+ * available to translate error numbers to strings.
+ */
+#$d_strerror HAS_STRERROR /**/
+
+/* HAS_SYMLINK
+ * This symbol, if defined, indicates that the symlink routine is available
+ * to create symbolic links.
+ */
+#$d_symlink HAS_SYMLINK /**/
+
+/* HAS_SYSCALL
+ * This symbol, if defined, indicates that the syscall routine is available
+ * to call arbitrary system calls. If undefined, that's tough.
+ */
+#$d_syscall HAS_SYSCALL /**/
+
+/* HAS_TRUNCATE
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+#$d_truncate HAS_TRUNCATE /**/
+
+/* 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
+ * 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)".
+ */
+#$d_voidsig VOIDSIG /**/
+#$define TO_SIGNAL $d_tosignal /**/
+
+/* HASVOLATILE
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+#$d_volatile 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.
+ */
+#$d_vprintf HAS_VPRINTF /**/
+#$d_charvspr CHARVSPRINTF /**/
+
+/* HAS_WAIT4
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+#$d_wait4 HAS_WAIT4 /**/
+
+/* HAS_WAITPID
+ * This symbol, if defined, indicates that waitpid() exists.
+ */
+#$d_waitpid 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 $gidtype /**/
+
+/* GROUPSTYPE
+ * This symbol has a value like gid_t, int, ushort, or whatever type is
+ * used in the return value of getgroups().
+ */
+#define GROUPSTYPE $groupstype /**/
+
+/* 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_gdbm I_GDBM /**/
+
+/* I_GRP
+ * This symbol, if defined, indicates to the C program that it should
+ * include grp.h.
+ */
+#$i_grp 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.
+ */
+#$i_niin I_NETINET_IN /**/
+#$i_sysin 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.
+ */
+#$i_pwd I_PWD /**/
+#$d_pwquota PWQUOTA /**/
+#$d_pwage PWAGE /**/
+#$d_pwchange PWCHANGE /**/
+#$d_pwclass PWCLASS /**/
+#$d_pwexpire PWEXPIRE /**/
+#$d_pwcomment PWCOMMENT /**/
+
+/* I_SYS_FILE
+ * This manifest constant tells the C program to include <sys/file.h>.
+ */
+#$i_sys_file I_SYS_FILE /**/
+
+/* I_SYSIOCTL
+ * This symbol, if defined, indicates that sys/ioctl.h exists and should
+ * be included.
+ */
+#$i_sysioctl 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>.
+ */
+#$i_time I_TIME /**/
+#$i_sys_time I_SYS_TIME /**/
+#$d_systimekernel SYSTIMEKERNEL /**/
+#$i_sys_select I_SYS_SELECT /**/
+
+/* I_UTIME
+ * This symbol, if defined, indicates to the C program that it should
+ * include utime.h.
+ */
+#$i_utime I_UTIME /**/
+
+/* I_VARARGS
+ * This symbol, if defined, indicates to the C program that it should
+ * include varargs.h.
+ */
+#$i_varargs I_VARARGS /**/
+
+/* I_VFORK
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+#$i_vfork I_VFORK /**/
+
+/* INTSIZE
+ * This symbol contains the size of an int, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define INTSIZE $intsize /**/
+
+/* 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.
+ */
+#$i_dirent I_DIRENT /**/
+#$i_sys_dir I_SYS_DIR /**/
+#$i_ndir I_NDIR /**/
+#$i_sys_ndir I_SYS_NDIR /**/
+#$i_my_dir I_MY_DIR /**/
+#$d_dirnamlen 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.
+ */
+#$d_mymalloc MYMALLOC /**/
+
+#define MALLOCPTRTYPE $mallocptrtype /**/
+
+
+/* RANDBITS
+ * This symbol contains the number of bits of random number the rand()
+ * function produces. Usual values are 15, 16, and 31.
+ */
+#define RANDBITS $randbits /**/
+
+/* 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 "$scriptdir" /**/
+
+/* SIG_NAME
+ * This symbol contains an list of signal names in order.
+ */
+#define SIG_NAME "`echo $sig_name | sed 's/ /","/g'`" /**/
+
+/* STDCHAR
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+#define STDCHAR $stdchar /**/
+
+/* 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 $uidtype /**/
+
+/* 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 $voidwant
+#endif
+#define VOIDHAVE $voidhave
+#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 "$privlib" /**/
+
+#endif
+!GROK!THIS!
--- /dev/null
+/* $RCSfile: cons.c,v $$Revision: 4.0.1.2 $$Date: 91/11/05 16:15:13 $
+ *
+ * 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: cons.c,v $
+ * Revision 4.0.1.2 91/11/05 16:15:13 lwall
+ * patch11: debugger got confused over nested subroutine definitions
+ * patch11: prepared for ctype implementations that don't define isascii()
+ *
+ * Revision 4.0.1.1 91/06/07 10:31:15 lwall
+ * patch4: new copyright notice
+ * patch4: added global modifier for pattern matches
+ *
+ * Revision 4.0 91/03/20 01:05:51 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "perly.h"
+
+extern char *tokename[];
+extern int yychar;
+
+static int cmd_tosave();
+static int arg_tosave();
+static int spat_tosave();
+
+static bool saw_return;
+
+SUBR *
+make_sub(name,cmd)
+char *name;
+CMD *cmd;
+{
+ register SUBR *sub;
+ STAB *stab = stabent(name,TRUE);
+
+ Newz(101,sub,1,SUBR);
+ if (stab_sub(stab)) {
+ if (dowarn) {
+ CMD *oldcurcmd = curcmd;
+
+ if (cmd)
+ curcmd = cmd;
+ warn("Subroutine %s redefined",name);
+ curcmd = oldcurcmd;
+ }
+ if (stab_sub(stab)->cmd) {
+ cmd_free(stab_sub(stab)->cmd);
+ stab_sub(stab)->cmd = Nullcmd;
+ afree(stab_sub(stab)->tosave);
+ }
+ Safefree(stab_sub(stab));
+ }
+ stab_sub(stab) = sub;
+ sub->filestab = curcmd->c_filestab;
+ saw_return = FALSE;
+ tosave = anew(Nullstab);
+ tosave->ary_fill = 0; /* make 1 based */
+ (void)cmd_tosave(cmd,FALSE); /* this builds the tosave array */
+ sub->tosave = tosave;
+ if (saw_return) {
+ struct compcmd mycompblock;
+
+ mycompblock.comp_true = cmd;
+ mycompblock.comp_alt = Nullcmd;
+ cmd = add_label(savestr("_SUB_"),make_ccmd(C_BLOCK,Nullarg,mycompblock));
+ saw_return = FALSE;
+ cmd->c_flags |= CF_TERM;
+ }
+ sub->cmd = cmd;
+ if (perldb) {
+ STR *str;
+ STR *tmpstr = str_mortal(&str_undef);
+
+ sprintf(buf,"%s:%ld",stab_val(curcmd->c_filestab)->str_ptr, subline);
+ str = str_make(buf,0);
+ str_cat(str,"-");
+ sprintf(buf,"%ld",(long)curcmd->c_line);
+ str_cat(str,buf);
+ name = str_get(subname);
+ stab_fullname(tmpstr,stab);
+ hstore(stab_xhash(DBsub), tmpstr->str_ptr, tmpstr->str_cur, str, 0);
+ }
+ return sub;
+}
+
+SUBR *
+make_usub(name, ix, subaddr, filename)
+char *name;
+int ix;
+int (*subaddr)();
+char *filename;
+{
+ register SUBR *sub;
+ STAB *stab = stabent(name,allstabs);
+
+ if (!stab) /* unused function */
+ return Null(SUBR*);
+ Newz(101,sub,1,SUBR);
+ if (stab_sub(stab)) {
+ if (dowarn)
+ warn("Subroutine %s redefined",name);
+ if (stab_sub(stab)->cmd) {
+ cmd_free(stab_sub(stab)->cmd);
+ stab_sub(stab)->cmd = Nullcmd;
+ afree(stab_sub(stab)->tosave);
+ }
+ Safefree(stab_sub(stab));
+ }
+ stab_sub(stab) = sub;
+ sub->filestab = fstab(filename);
+ sub->usersub = subaddr;
+ sub->userindex = ix;
+ return sub;
+}
+
+make_form(stab,fcmd)
+STAB *stab;
+FCMD *fcmd;
+{
+ if (stab_form(stab)) {
+ FCMD *tmpfcmd;
+ FCMD *nextfcmd;
+
+ for (tmpfcmd = stab_form(stab); tmpfcmd; tmpfcmd = nextfcmd) {
+ nextfcmd = tmpfcmd->f_next;
+ if (tmpfcmd->f_expr)
+ arg_free(tmpfcmd->f_expr);
+ if (tmpfcmd->f_unparsed)
+ str_free(tmpfcmd->f_unparsed);
+ if (tmpfcmd->f_pre)
+ Safefree(tmpfcmd->f_pre);
+ Safefree(tmpfcmd);
+ }
+ }
+ stab_form(stab) = fcmd;
+}
+
+CMD *
+block_head(tail)
+register CMD *tail;
+{
+ CMD *head;
+ register int opt;
+ register int last_opt = 0;
+ register STAB *last_stab = Nullstab;
+ register int count = 0;
+ register CMD *switchbeg = Nullcmd;
+
+ if (tail == Nullcmd) {
+ return tail;
+ }
+ head = tail->c_head;
+
+ for (tail = head; tail; tail = tail->c_next) {
+
+ /* save one measly dereference at runtime */
+ if (tail->c_type == C_IF) {
+ if (!(tail->ucmd.ccmd.cc_alt = tail->ucmd.ccmd.cc_alt->c_next))
+ tail->c_flags |= CF_TERM;
+ }
+ else if (tail->c_type == C_EXPR) {
+ ARG *arg;
+
+ if (tail->ucmd.acmd.ac_expr)
+ arg = tail->ucmd.acmd.ac_expr;
+ else
+ arg = tail->c_expr;
+ if (arg) {
+ if (arg->arg_type == O_RETURN)
+ tail->c_flags |= CF_TERM;
+ else if (arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD)
+ tail->c_flags |= CF_TERM;
+ }
+ }
+ if (!tail->c_next)
+ tail->c_flags |= CF_TERM;
+
+ if (tail->c_expr && (tail->c_flags & CF_OPTIMIZE) == CFT_FALSE)
+ opt_arg(tail,1, tail->c_type == C_EXPR);
+
+ /* now do a little optimization on case-ish structures */
+ switch(tail->c_flags & (CF_OPTIMIZE|CF_FIRSTNEG|CF_INVERT)) {
+ case CFT_ANCHOR:
+ if (stabent("*",FALSE)) { /* bad assumption here!!! */
+ opt = 0;
+ break;
+ }
+ /* FALL THROUGH */
+ case CFT_STROP:
+ opt = (tail->c_flags & CF_NESURE) ? CFT_STROP : 0;
+ break;
+ case CFT_CCLASS:
+ opt = CFT_STROP;
+ break;
+ case CFT_NUMOP:
+ opt = (tail->c_slen == O_NE ? 0 : CFT_NUMOP);
+ if ((tail->c_flags&(CF_NESURE|CF_EQSURE)) != (CF_NESURE|CF_EQSURE))
+ opt = 0;
+ break;
+ default:
+ opt = 0;
+ }
+ if (opt && opt == last_opt && tail->c_stab == last_stab)
+ count++;
+ else {
+ if (count >= 3) { /* is this the breakeven point? */
+ if (last_opt == CFT_NUMOP)
+ make_nswitch(switchbeg,count);
+ else
+ make_cswitch(switchbeg,count);
+ }
+ if (opt) {
+ count = 1;
+ switchbeg = tail;
+ }
+ else
+ count = 0;
+ }
+ last_opt = opt;
+ last_stab = tail->c_stab;
+ }
+ if (count >= 3) { /* is this the breakeven point? */
+ if (last_opt == CFT_NUMOP)
+ make_nswitch(switchbeg,count);
+ else
+ make_cswitch(switchbeg,count);
+ }
+ return head;
+}
+
+/* We've spotted a sequence of CMDs that all test the value of the same
+ * spat. Thus we can insert a SWITCH in front and jump directly
+ * to the correct one.
+ */
+make_cswitch(head,count)
+register CMD *head;
+int count;
+{
+ register CMD *cur;
+ register CMD **loc;
+ register int i;
+ register int min = 255;
+ register int max = 0;
+
+ /* make a new head in the exact same spot */
+ New(102,cur, 1, CMD);
+#ifdef STRUCTCOPY
+ *cur = *head;
+#else
+ Copy(head,cur,1,CMD);
+#endif
+ Zero(head,1,CMD);
+ head->c_type = C_CSWITCH;
+ head->c_next = cur; /* insert new cmd at front of list */
+ head->c_stab = cur->c_stab;
+
+ Newz(103,loc,258,CMD*);
+ loc++; /* lie a little */
+ while (count--) {
+ if ((cur->c_flags & CF_OPTIMIZE) == CFT_CCLASS) {
+ for (i = 0; i <= 255; i++) {
+ if (!loc[i] && cur->c_short->str_ptr[i>>3] & (1 << (i&7))) {
+ loc[i] = cur;
+ if (i < min)
+ min = i;
+ if (i > max)
+ max = i;
+ }
+ }
+ }
+ else {
+ i = *cur->c_short->str_ptr & 255;
+ if (!loc[i]) {
+ loc[i] = cur;
+ if (i < min)
+ min = i;
+ if (i > max)
+ max = i;
+ }
+ }
+ cur = cur->c_next;
+ }
+ max++;
+ if (min > 0)
+ Copy(&loc[min],&loc[0], max - min, CMD*);
+ loc--;
+ min--;
+ max -= min;
+ for (i = 0; i <= max; i++)
+ if (!loc[i])
+ loc[i] = cur;
+ Renew(loc,max+1,CMD*); /* chop it down to size */
+ head->ucmd.scmd.sc_offset = min;
+ head->ucmd.scmd.sc_max = max;
+ head->ucmd.scmd.sc_next = loc;
+}
+
+make_nswitch(head,count)
+register CMD *head;
+int count;
+{
+ register CMD *cur = head;
+ register CMD **loc;
+ register int i;
+ register int min = 32767;
+ register int max = -32768;
+ int origcount = count;
+ double value; /* or your money back! */
+ short changed; /* so triple your money back! */
+
+ while (count--) {
+ i = (int)str_gnum(cur->c_short);
+ value = (double)i;
+ if (value != cur->c_short->str_u.str_nval)
+ return; /* fractional values--just forget it */
+ changed = i;
+ if (changed != i)
+ return; /* too big for a short */
+ if (cur->c_slen == O_LE)
+ i++;
+ else if (cur->c_slen == O_GE) /* we only do < or > here */
+ i--;
+ if (i < min)
+ min = i;
+ if (i > max)
+ max = i;
+ cur = cur->c_next;
+ }
+ count = origcount;
+ if (max - min > count * 2 + 10) /* too sparse? */
+ return;
+
+ /* now make a new head in the exact same spot */
+ New(104,cur, 1, CMD);
+#ifdef STRUCTCOPY
+ *cur = *head;
+#else
+ Copy(head,cur,1,CMD);
+#endif
+ Zero(head,1,CMD);
+ head->c_type = C_NSWITCH;
+ head->c_next = cur; /* insert new cmd at front of list */
+ head->c_stab = cur->c_stab;
+
+ Newz(105,loc, max - min + 3, CMD*);
+ loc++;
+ max -= min;
+ max++;
+ while (count--) {
+ i = (int)str_gnum(cur->c_short);
+ i -= min;
+ switch(cur->c_slen) {
+ case O_LE:
+ i++;
+ case O_LT:
+ for (i--; i >= -1; i--)
+ if (!loc[i])
+ loc[i] = cur;
+ break;
+ case O_GE:
+ i--;
+ case O_GT:
+ for (i++; i <= max; i++)
+ if (!loc[i])
+ loc[i] = cur;
+ break;
+ case O_EQ:
+ if (!loc[i])
+ loc[i] = cur;
+ break;
+ }
+ cur = cur->c_next;
+ }
+ loc--;
+ min--;
+ max++;
+ for (i = 0; i <= max; i++)
+ if (!loc[i])
+ loc[i] = cur;
+ head->ucmd.scmd.sc_offset = min;
+ head->ucmd.scmd.sc_max = max;
+ head->ucmd.scmd.sc_next = loc;
+}
+
+CMD *
+append_line(head,tail)
+register CMD *head;
+register CMD *tail;
+{
+ if (tail == Nullcmd)
+ return head;
+ if (!tail->c_head) /* make sure tail is well formed */
+ tail->c_head = tail;
+ if (head != Nullcmd) {
+ tail = tail->c_head; /* get to start of tail list */
+ if (!head->c_head)
+ head->c_head = head; /* start a new head list */
+ while (head->c_next) {
+ head->c_next->c_head = head->c_head;
+ head = head->c_next; /* get to end of head list */
+ }
+ head->c_next = tail; /* link to end of old list */
+ tail->c_head = head->c_head; /* propagate head pointer */
+ }
+ while (tail->c_next) {
+ tail->c_next->c_head = tail->c_head;
+ tail = tail->c_next;
+ }
+ return tail;
+}
+
+CMD *
+dodb(cur)
+CMD *cur;
+{
+ register CMD *cmd;
+ register CMD *head = cur->c_head;
+ STR *str;
+
+ if (!head)
+ head = cur;
+ if (!head->c_line)
+ return cur;
+ str = afetch(stab_xarray(curcmd->c_filestab),(int)head->c_line,FALSE);
+ if (str == &str_undef || str->str_nok)
+ return cur;
+ str->str_u.str_nval = (double)head->c_line;
+ str->str_nok = 1;
+ Newz(106,cmd,1,CMD);
+ str_magic(str, curcmd->c_filestab, 0, Nullch, 0);
+ str->str_magic->str_u.str_cmd = cmd;
+ cmd->c_type = C_EXPR;
+ cmd->ucmd.acmd.ac_stab = Nullstab;
+ cmd->ucmd.acmd.ac_expr = Nullarg;
+ cmd->c_expr = make_op(O_SUBR, 2,
+ stab2arg(A_WORD,DBstab),
+ Nullarg,
+ Nullarg);
+ cmd->c_flags |= CF_COND|CF_DBSUB|CFT_D0;
+ cmd->c_line = head->c_line;
+ cmd->c_label = head->c_label;
+ cmd->c_filestab = curcmd->c_filestab;
+ cmd->c_stash = curstash;
+ return append_line(cmd, cur);
+}
+
+CMD *
+make_acmd(type,stab,cond,arg)
+int type;
+STAB *stab;
+ARG *cond;
+ARG *arg;
+{
+ register CMD *cmd;
+
+ Newz(107,cmd,1,CMD);
+ cmd->c_type = type;
+ cmd->ucmd.acmd.ac_stab = stab;
+ cmd->ucmd.acmd.ac_expr = arg;
+ cmd->c_expr = cond;
+ if (cond)
+ cmd->c_flags |= CF_COND;
+ if (cmdline == NOLINE)
+ cmd->c_line = curcmd->c_line;
+ else {
+ cmd->c_line = cmdline;
+ cmdline = NOLINE;
+ }
+ cmd->c_filestab = curcmd->c_filestab;
+ cmd->c_stash = curstash;
+ if (perldb)
+ cmd = dodb(cmd);
+ return cmd;
+}
+
+CMD *
+make_ccmd(type,arg,cblock)
+int type;
+ARG *arg;
+struct compcmd cblock;
+{
+ register CMD *cmd;
+
+ Newz(108,cmd, 1, CMD);
+ cmd->c_type = type;
+ cmd->c_expr = arg;
+ cmd->ucmd.ccmd.cc_true = cblock.comp_true;
+ cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
+ if (arg)
+ cmd->c_flags |= CF_COND;
+ if (cmdline == NOLINE)
+ cmd->c_line = curcmd->c_line;
+ else {
+ cmd->c_line = cmdline;
+ cmdline = NOLINE;
+ }
+ cmd->c_filestab = curcmd->c_filestab;
+ cmd->c_stash = curstash;
+ if (perldb)
+ cmd = dodb(cmd);
+ return cmd;
+}
+
+CMD *
+make_icmd(type,arg,cblock)
+int type;
+ARG *arg;
+struct compcmd cblock;
+{
+ register CMD *cmd;
+ register CMD *alt;
+ register CMD *cur;
+ register CMD *head;
+ struct compcmd ncblock;
+
+ Newz(109,cmd, 1, CMD);
+ head = cmd;
+ cmd->c_type = type;
+ cmd->c_expr = arg;
+ cmd->ucmd.ccmd.cc_true = cblock.comp_true;
+ cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
+ if (arg)
+ cmd->c_flags |= CF_COND;
+ if (cmdline == NOLINE)
+ cmd->c_line = curcmd->c_line;
+ else {
+ cmd->c_line = cmdline;
+ cmdline = NOLINE;
+ }
+ cmd->c_filestab = curcmd->c_filestab;
+ cmd->c_stash = curstash;
+ cur = cmd;
+ alt = cblock.comp_alt;
+ while (alt && alt->c_type == C_ELSIF) {
+ cur = alt;
+ alt = alt->ucmd.ccmd.cc_alt;
+ }
+ if (alt) { /* a real life ELSE at the end? */
+ ncblock.comp_true = alt;
+ ncblock.comp_alt = Nullcmd;
+ alt = append_line(cur,make_ccmd(C_ELSE,Nullarg,ncblock));
+ cur->ucmd.ccmd.cc_alt = alt;
+ }
+ else
+ alt = cur; /* no ELSE, so cur is proxy ELSE */
+
+ cur = cmd;
+ while (cmd) { /* now point everyone at the ELSE */
+ cur = cmd;
+ cmd = cur->ucmd.ccmd.cc_alt;
+ cur->c_head = head;
+ if (cur->c_type == C_ELSIF)
+ cur->c_type = C_IF;
+ if (cur->c_type == C_IF)
+ cur->ucmd.ccmd.cc_alt = alt;
+ if (cur == alt)
+ break;
+ cur->c_next = cmd;
+ }
+ if (perldb)
+ cur = dodb(cur);
+ return cur;
+}
+
+void
+opt_arg(cmd,fliporflop,acmd)
+register CMD *cmd;
+int fliporflop;
+int acmd;
+{
+ register ARG *arg;
+ int opt = CFT_EVAL;
+ int sure = 0;
+ ARG *arg2;
+ int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */
+ int flp = fliporflop;
+
+ if (!cmd)
+ return;
+ if (!(arg = cmd->c_expr)) {
+ cmd->c_flags &= ~CF_COND;
+ return;
+ }
+
+ /* Can we turn && and || into if and unless? */
+
+ if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM) &&
+ (arg->arg_type == O_AND || arg->arg_type == O_OR) ) {
+ dehoist(arg,1);
+ arg[2].arg_type &= A_MASK; /* don't suppress eval */
+ dehoist(arg,2);
+ cmd->ucmd.acmd.ac_expr = arg[2].arg_ptr.arg_arg;
+ cmd->c_expr = arg[1].arg_ptr.arg_arg;
+ if (arg->arg_type == O_OR)
+ cmd->c_flags ^= CF_INVERT; /* || is like unless */
+ arg->arg_len = 0;
+ free_arg(arg);
+ arg = cmd->c_expr;
+ }
+
+ /* Turn "if (!expr)" into "unless (expr)" */
+
+ if (!(cmd->c_flags & CF_TERM)) { /* unless return value wanted */
+ while (arg->arg_type == O_NOT) {
+ dehoist(arg,1);
+ cmd->c_flags ^= CF_INVERT; /* flip sense of cmd */
+ cmd->c_expr = arg[1].arg_ptr.arg_arg; /* hoist the rest of expr */
+ free_arg(arg);
+ arg = cmd->c_expr; /* here we go again */
+ }
+ }
+
+ if (!arg->arg_len) { /* sanity check */
+ cmd->c_flags |= opt;
+ return;
+ }
+
+ /* for "cond .. cond" we set up for the initial check */
+
+ if (arg->arg_type == O_FLIP)
+ context |= 4;
+
+ /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */
+
+ morecontext:
+ if (arg->arg_type == O_AND)
+ context |= 1;
+ else if (arg->arg_type == O_OR)
+ context |= 2;
+ if (context && (arg[flp].arg_type & A_MASK) == A_EXPR) {
+ arg = arg[flp].arg_ptr.arg_arg;
+ flp = 1;
+ if (arg->arg_type == O_AND || arg->arg_type == O_OR)
+ goto morecontext;
+ }
+ if ((context & 3) == 3)
+ return;
+
+ if (arg[flp].arg_flags & (AF_PRE|AF_POST)) {
+ cmd->c_flags |= opt;
+ if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM)
+ && cmd->c_expr->arg_type == O_ITEM) {
+ arg[flp].arg_flags &= ~AF_POST; /* prefer ++$foo to $foo++ */
+ arg[flp].arg_flags |= AF_PRE; /* if value not wanted */
+ }
+ return; /* side effect, can't optimize */
+ }
+
+ if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP ||
+ arg->arg_type == O_AND || arg->arg_type == O_OR) {
+ if ((arg[flp].arg_type & A_MASK) == A_SINGLE) {
+ opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE);
+ cmd->c_short = str_smake(arg[flp].arg_ptr.arg_str);
+ goto literal;
+ }
+ else if ((arg[flp].arg_type & A_MASK) == A_STAB ||
+ (arg[flp].arg_type & A_MASK) == A_LVAL) {
+ cmd->c_stab = arg[flp].arg_ptr.arg_stab;
+ if (!context)
+ arg[flp].arg_ptr.arg_stab = Nullstab;
+ opt = CFT_REG;
+ literal:
+ if (!context) { /* no && or ||? */
+ arg_free(arg);
+ cmd->c_expr = Nullarg;
+ }
+ if (!(context & 1))
+ cmd->c_flags |= CF_EQSURE;
+ if (!(context & 2))
+ cmd->c_flags |= CF_NESURE;
+ }
+ }
+ else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST ||
+ arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) {
+ if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
+ (arg[2].arg_type & A_MASK) == A_SPAT &&
+ arg[2].arg_ptr.arg_spat->spat_short &&
+ (arg->arg_type == O_SUBST || arg->arg_type == O_NSUBST ||
+ (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_GLOBAL) == 0 )) {
+ cmd->c_stab = arg[1].arg_ptr.arg_stab;
+ cmd->c_short = str_smake(arg[2].arg_ptr.arg_spat->spat_short);
+ cmd->c_slen = arg[2].arg_ptr.arg_spat->spat_slen;
+ if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ALL &&
+ !(arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ONCE) &&
+ (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) )
+ sure |= CF_EQSURE; /* (SUBST must be forced even */
+ /* if we know it will work.) */
+ if (arg->arg_type != O_SUBST) {
+ arg[2].arg_ptr.arg_spat->spat_short = Nullstr;
+ arg[2].arg_ptr.arg_spat->spat_slen = 0; /* only one chk */
+ }
+ sure |= CF_NESURE; /* normally only sure if it fails */
+ if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST)
+ cmd->c_flags |= CF_FIRSTNEG;
+ if (context & 1) { /* only sure if thing is false */
+ if (cmd->c_flags & CF_FIRSTNEG)
+ sure &= ~CF_NESURE;
+ else
+ sure &= ~CF_EQSURE;
+ }
+ else if (context & 2) { /* only sure if thing is true */
+ if (cmd->c_flags & CF_FIRSTNEG)
+ sure &= ~CF_EQSURE;
+ else
+ sure &= ~CF_NESURE;
+ }
+ if (sure & (CF_EQSURE|CF_NESURE)) { /* if we know anything*/
+ if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST)
+ opt = CFT_SCAN;
+ else
+ opt = CFT_ANCHOR;
+ if (sure == (CF_EQSURE|CF_NESURE) /* really sure? */
+ && arg->arg_type == O_MATCH
+ && context & 4
+ && fliporflop == 1) {
+ spat_free(arg[2].arg_ptr.arg_spat);
+ arg[2].arg_ptr.arg_spat = Nullspat; /* don't do twice */
+ }
+ else
+ cmd->c_spat = arg[2].arg_ptr.arg_spat;
+ cmd->c_flags |= sure;
+ }
+ }
+ }
+ else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE ||
+ arg->arg_type == O_SLT || arg->arg_type == O_SGT) {
+ if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
+ if (arg[2].arg_type == A_SINGLE) {
+ /*SUPPRESS 594*/
+ char *junk = str_get(arg[2].arg_ptr.arg_str);
+
+ cmd->c_stab = arg[1].arg_ptr.arg_stab;
+ cmd->c_short = str_smake(arg[2].arg_ptr.arg_str);
+ cmd->c_slen = cmd->c_short->str_cur+1;
+ switch (arg->arg_type) {
+ case O_SLT: case O_SGT:
+ sure |= CF_EQSURE;
+ cmd->c_flags |= CF_FIRSTNEG;
+ break;
+ case O_SNE:
+ cmd->c_flags |= CF_FIRSTNEG;
+ /* FALL THROUGH */
+ case O_SEQ:
+ sure |= CF_NESURE|CF_EQSURE;
+ break;
+ }
+ if (context & 1) { /* only sure if thing is false */
+ if (cmd->c_flags & CF_FIRSTNEG)
+ sure &= ~CF_NESURE;
+ else
+ sure &= ~CF_EQSURE;
+ }
+ else if (context & 2) { /* only sure if thing is true */
+ if (cmd->c_flags & CF_FIRSTNEG)
+ sure &= ~CF_EQSURE;
+ else
+ sure &= ~CF_NESURE;
+ }
+ if (sure & (CF_EQSURE|CF_NESURE)) {
+ opt = CFT_STROP;
+ cmd->c_flags |= sure;
+ }
+ }
+ }
+ }
+ else if (arg->arg_type == O_EQ || arg->arg_type == O_NE ||
+ arg->arg_type == O_LE || arg->arg_type == O_GE ||
+ arg->arg_type == O_LT || arg->arg_type == O_GT) {
+ if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
+ if (arg[2].arg_type == A_SINGLE) {
+ cmd->c_stab = arg[1].arg_ptr.arg_stab;
+ if (dowarn) {
+ STR *str = arg[2].arg_ptr.arg_str;
+
+ if ((!str->str_nok && !looks_like_number(str)))
+ warn("Possible use of == on string value");
+ }
+ cmd->c_short = str_nmake(str_gnum(arg[2].arg_ptr.arg_str));
+ cmd->c_slen = arg->arg_type;
+ sure |= CF_NESURE|CF_EQSURE;
+ if (context & 1) { /* only sure if thing is false */
+ sure &= ~CF_EQSURE;
+ }
+ else if (context & 2) { /* only sure if thing is true */
+ sure &= ~CF_NESURE;
+ }
+ if (sure & (CF_EQSURE|CF_NESURE)) {
+ opt = CFT_NUMOP;
+ cmd->c_flags |= sure;
+ }
+ }
+ }
+ }
+ else if (arg->arg_type == O_ASSIGN &&
+ (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
+ arg[1].arg_ptr.arg_stab == defstab &&
+ arg[2].arg_type == A_EXPR ) {
+ arg2 = arg[2].arg_ptr.arg_arg;
+ if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) {
+ opt = CFT_GETS;
+ cmd->c_stab = arg2[1].arg_ptr.arg_stab;
+ if (!(stab_io(arg2[1].arg_ptr.arg_stab)->flags & IOF_ARGV)) {
+ free_arg(arg2);
+ arg[2].arg_ptr.arg_arg = Nullarg;
+ free_arg(arg);
+ cmd->c_expr = Nullarg;
+ }
+ }
+ }
+ else if (arg->arg_type == O_CHOP &&
+ (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) {
+ opt = CFT_CHOP;
+ cmd->c_stab = arg[1].arg_ptr.arg_stab;
+ free_arg(arg);
+ cmd->c_expr = Nullarg;
+ }
+ if (context & 4)
+ opt |= CF_FLIP;
+ cmd->c_flags |= opt;
+
+ if (cmd->c_flags & CF_FLIP) {
+ if (fliporflop == 1) {
+ arg = cmd->c_expr; /* get back to O_FLIP arg */
+ New(110,arg[3].arg_ptr.arg_cmd, 1, CMD);
+ Copy(cmd, arg[3].arg_ptr.arg_cmd, 1, CMD);
+ New(111,arg[4].arg_ptr.arg_cmd,1,CMD);
+ Copy(cmd, arg[4].arg_ptr.arg_cmd, 1, CMD);
+ opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd);
+ arg->arg_len = 2; /* this is a lie */
+ }
+ else {
+ if ((opt & CF_OPTIMIZE) == CFT_EVAL)
+ cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP;
+ }
+ }
+}
+
+CMD *
+add_label(lbl,cmd)
+char *lbl;
+register CMD *cmd;
+{
+ if (cmd)
+ cmd->c_label = lbl;
+ return cmd;
+}
+
+CMD *
+addcond(cmd, arg)
+register CMD *cmd;
+register ARG *arg;
+{
+ cmd->c_expr = arg;
+ cmd->c_flags |= CF_COND;
+ return cmd;
+}
+
+CMD *
+addloop(cmd, arg)
+register CMD *cmd;
+register ARG *arg;
+{
+ void while_io();
+
+ cmd->c_expr = arg;
+ cmd->c_flags |= CF_COND|CF_LOOP;
+
+ if (!(cmd->c_flags & CF_INVERT))
+ while_io(cmd); /* add $_ =, if necessary */
+
+ if (cmd->c_type == C_BLOCK)
+ cmd->c_flags &= ~CF_COND;
+ else {
+ arg = cmd->ucmd.acmd.ac_expr;
+ if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD)
+ cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */
+ if (arg && (arg->arg_flags & AF_DEPR) &&
+ (arg->arg_type == O_SUBR || arg->arg_type == O_DBSUBR) )
+ cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */
+ }
+ return cmd;
+}
+
+CMD *
+invert(cmd)
+CMD *cmd;
+{
+ register CMD *targ = cmd;
+ if (targ->c_head)
+ targ = targ->c_head;
+ if (targ->c_flags & CF_DBSUB)
+ targ = targ->c_next;
+ targ->c_flags ^= CF_INVERT;
+ return cmd;
+}
+
+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++;
+ strncpy(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr);
+ tmp2buf[bufptr - oldoldbufptr] = '\0';
+ sprintf(tname,"next 2 tokens \"%s\"",tmp2buf);
+ }
+ else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
+ oldbufptr != bufptr) {
+ while (isSPACE(*oldbufptr))
+ oldbufptr++;
+ strncpy(tmp2buf, oldbufptr, bufptr - oldbufptr);
+ tmp2buf[bufptr - oldbufptr] = '\0';
+ sprintf(tname,"next token \"%s\"",tmp2buf);
+ }
+ else if (yychar > 256)
+ tname = "next token ???";
+ else if (!yychar)
+ (void)strcpy(tname,"at EOF");
+ else if (yychar < 32)
+ (void)sprintf(tname,"next char ^%c",yychar+64);
+ else if (yychar == 127)
+ (void)strcpy(tname,"at EOF");
+ else
+ (void)sprintf(tname,"next char %c",yychar);
+ (void)sprintf(buf, "%s in file %s at line %d, %s\n",
+ s,stab_val(curcmd->c_filestab)->str_ptr,curcmd->c_line,tname);
+ if (curcmd->c_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);
+ if (in_eval)
+ str_cat(stab_val(stabent("@",TRUE)),buf);
+ else
+ fputs(buf,stderr);
+ if (++error_count >= 10)
+ fatal("%s has too many errors.\n",
+ stab_val(curcmd->c_filestab)->str_ptr);
+}
+
+void
+while_io(cmd)
+register CMD *cmd;
+{
+ register ARG *arg = cmd->c_expr;
+ STAB *asgnstab;
+
+ /* hoist "while (<channel>)" up into command block */
+
+ if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) {
+ cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
+ cmd->c_flags |= CFT_GETS; /* and set it to do the input */
+ cmd->c_stab = arg[1].arg_ptr.arg_stab;
+ if (stab_io(arg[1].arg_ptr.arg_stab)->flags & IOF_ARGV) {
+ cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */
+ stab2arg(A_LVAL,defstab), arg, Nullarg));
+ }
+ else {
+ free_arg(arg);
+ cmd->c_expr = Nullarg;
+ }
+ }
+ else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) {
+ cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
+ cmd->c_flags |= CFT_INDGETS; /* and set it to do the input */
+ cmd->c_stab = arg[1].arg_ptr.arg_stab;
+ free_arg(arg);
+ cmd->c_expr = Nullarg;
+ }
+ else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) {
+ if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY)
+ asgnstab = cmd->c_stab;
+ else
+ asgnstab = defstab;
+ cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$foo =" */
+ stab2arg(A_LVAL,asgnstab), arg, Nullarg));
+ cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
+ }
+}
+
+CMD *
+wopt(cmd)
+register CMD *cmd;
+{
+ register CMD *tail;
+ CMD *newtail;
+ register int i;
+
+ if (cmd->c_expr && (cmd->c_flags & CF_OPTIMIZE) == CFT_FALSE)
+ opt_arg(cmd,1, cmd->c_type == C_EXPR);
+
+ while_io(cmd); /* add $_ =, if necessary */
+
+ /* First find the end of the true list */
+
+ tail = cmd->ucmd.ccmd.cc_true;
+ if (tail == Nullcmd)
+ return cmd;
+ New(112,newtail, 1, CMD); /* guaranteed continue */
+ for (;;) {
+ /* optimize "next" to point directly to continue block */
+ if (tail->c_type == C_EXPR &&
+ tail->ucmd.acmd.ac_expr &&
+ tail->ucmd.acmd.ac_expr->arg_type == O_NEXT &&
+ (tail->ucmd.acmd.ac_expr->arg_len == 0 ||
+ (cmd->c_label &&
+ strEQ(cmd->c_label,
+ tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) )))
+ {
+ arg_free(tail->ucmd.acmd.ac_expr);
+ tail->ucmd.acmd.ac_expr = Nullarg;
+ tail->c_type = C_NEXT;
+ if (cmd->ucmd.ccmd.cc_alt != Nullcmd)
+ tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt;
+ else
+ tail->ucmd.ccmd.cc_alt = newtail;
+ tail->ucmd.ccmd.cc_true = Nullcmd;
+ }
+ else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) {
+ if (cmd->ucmd.ccmd.cc_alt != Nullcmd)
+ tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt;
+ else
+ tail->ucmd.ccmd.cc_alt = newtail;
+ }
+ else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) {
+ if (cmd->ucmd.ccmd.cc_alt != Nullcmd) {
+ for (i = tail->ucmd.scmd.sc_max; i >= 0; i--)
+ if (!tail->ucmd.scmd.sc_next[i])
+ tail->ucmd.scmd.sc_next[i] = cmd->ucmd.ccmd.cc_alt;
+ }
+ else {
+ for (i = tail->ucmd.scmd.sc_max; i >= 0; i--)
+ if (!tail->ucmd.scmd.sc_next[i])
+ tail->ucmd.scmd.sc_next[i] = newtail;
+ }
+ }
+
+ if (!tail->c_next)
+ break;
+ tail = tail->c_next;
+ }
+
+ /* if there's a continue block, link it to true block and find end */
+
+ if (cmd->ucmd.ccmd.cc_alt != Nullcmd) {
+ tail->c_next = cmd->ucmd.ccmd.cc_alt;
+ tail = tail->c_next;
+ for (;;) {
+ /* optimize "next" to point directly to continue block */
+ if (tail->c_type == C_EXPR &&
+ tail->ucmd.acmd.ac_expr &&
+ tail->ucmd.acmd.ac_expr->arg_type == O_NEXT &&
+ (tail->ucmd.acmd.ac_expr->arg_len == 0 ||
+ (cmd->c_label &&
+ strEQ(cmd->c_label,
+ tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) )))
+ {
+ arg_free(tail->ucmd.acmd.ac_expr);
+ tail->ucmd.acmd.ac_expr = Nullarg;
+ tail->c_type = C_NEXT;
+ tail->ucmd.ccmd.cc_alt = newtail;
+ tail->ucmd.ccmd.cc_true = Nullcmd;
+ }
+ else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) {
+ tail->ucmd.ccmd.cc_alt = newtail;
+ }
+ else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) {
+ for (i = tail->ucmd.scmd.sc_max; i >= 0; i--)
+ if (!tail->ucmd.scmd.sc_next[i])
+ tail->ucmd.scmd.sc_next[i] = newtail;
+ }
+
+ if (!tail->c_next)
+ break;
+ tail = tail->c_next;
+ }
+ /*SUPPRESS 530*/
+ for ( ; tail->c_next; tail = tail->c_next) ;
+ }
+
+ /* Here's the real trick: link the end of the list back to the beginning,
+ * inserting a "last" block to break out of the loop. This saves one or
+ * two procedure calls every time through the loop, because of how cmd_exec
+ * does tail recursion.
+ */
+
+ tail->c_next = newtail;
+ tail = newtail;
+ if (!cmd->ucmd.ccmd.cc_alt)
+ cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */
+
+#ifndef lint
+ (void)bcopy((char *)cmd, (char *)tail, sizeof(CMD));
+#endif
+ tail->c_type = C_EXPR;
+ tail->c_flags ^= CF_INVERT; /* turn into "last unless" */
+ tail->c_next = tail->ucmd.ccmd.cc_true; /* loop directly back to top */
+ tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg);
+ tail->ucmd.acmd.ac_stab = Nullstab;
+ return cmd;
+}
+
+CMD *
+over(eachstab,cmd)
+STAB *eachstab;
+register CMD *cmd;
+{
+ /* hoist "for $foo (@bar)" up into command block */
+
+ cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
+ cmd->c_flags |= CFT_ARRAY; /* and set it to do the iteration */
+ cmd->c_stab = eachstab;
+ cmd->c_short = Str_new(23,0); /* just to save a field in struct cmd */
+ cmd->c_short->str_u.str_useful = -1;
+
+ return cmd;
+}
+
+cmd_free(cmd)
+register CMD *cmd;
+{
+ register CMD *tofree;
+ register CMD *head = cmd;
+
+ while (cmd) {
+ if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */
+ if (cmd->c_label) {
+ Safefree(cmd->c_label);
+ cmd->c_label = Nullch;
+ }
+ if (cmd->c_short) {
+ str_free(cmd->c_short);
+ cmd->c_short = Nullstr;
+ }
+ if (cmd->c_expr) {
+ arg_free(cmd->c_expr);
+ cmd->c_expr = Nullarg;
+ }
+ }
+ switch (cmd->c_type) {
+ case C_WHILE:
+ case C_BLOCK:
+ case C_ELSE:
+ case C_IF:
+ if (cmd->ucmd.ccmd.cc_true) {
+ cmd_free(cmd->ucmd.ccmd.cc_true);
+ cmd->ucmd.ccmd.cc_true = Nullcmd;
+ }
+ break;
+ case C_EXPR:
+ if (cmd->ucmd.acmd.ac_expr) {
+ arg_free(cmd->ucmd.acmd.ac_expr);
+ cmd->ucmd.acmd.ac_expr = Nullarg;
+ }
+ break;
+ }
+ tofree = cmd;
+ cmd = cmd->c_next;
+ if (tofree != head) /* to get Saber to shut up */
+ Safefree(tofree);
+ if (cmd && cmd == head) /* reached end of while loop */
+ break;
+ }
+ Safefree(head);
+}
+
+arg_free(arg)
+register ARG *arg;
+{
+ register int i;
+
+ for (i = 1; i <= arg->arg_len; i++) {
+ switch (arg[i].arg_type & A_MASK) {
+ case A_NULL:
+ if (arg->arg_type == O_TRANS) {
+ Safefree(arg[i].arg_ptr.arg_cval);
+ arg[i].arg_ptr.arg_cval = Nullch;
+ }
+ break;
+ case A_LEXPR:
+ if (arg->arg_type == O_AASSIGN &&
+ arg[i].arg_ptr.arg_arg->arg_type == O_LARRAY) {
+ char *name =
+ stab_name(arg[i].arg_ptr.arg_arg[1].arg_ptr.arg_stab);
+
+ if (strnEQ("_GEN_",name, 5)) /* array for foreach */
+ hdelete(defstash,name,strlen(name));
+ }
+ /* FALL THROUGH */
+ case A_EXPR:
+ arg_free(arg[i].arg_ptr.arg_arg);
+ arg[i].arg_ptr.arg_arg = Nullarg;
+ break;
+ case A_CMD:
+ cmd_free(arg[i].arg_ptr.arg_cmd);
+ arg[i].arg_ptr.arg_cmd = Nullcmd;
+ break;
+ case A_WORD:
+ case A_STAB:
+ case A_LVAL:
+ case A_READ:
+ case A_GLOB:
+ case A_ARYLEN:
+ case A_LARYLEN:
+ case A_ARYSTAB:
+ case A_LARYSTAB:
+ break;
+ case A_SINGLE:
+ case A_DOUBLE:
+ case A_BACKTICK:
+ str_free(arg[i].arg_ptr.arg_str);
+ arg[i].arg_ptr.arg_str = Nullstr;
+ break;
+ case A_SPAT:
+ spat_free(arg[i].arg_ptr.arg_spat);
+ arg[i].arg_ptr.arg_spat = Nullspat;
+ break;
+ }
+ }
+ free_arg(arg);
+}
+
+spat_free(spat)
+register SPAT *spat;
+{
+ register SPAT *sp;
+ HENT *entry;
+
+ if (spat->spat_runtime) {
+ arg_free(spat->spat_runtime);
+ spat->spat_runtime = Nullarg;
+ }
+ if (spat->spat_repl) {
+ arg_free(spat->spat_repl);
+ spat->spat_repl = Nullarg;
+ }
+ if (spat->spat_short) {
+ str_free(spat->spat_short);
+ spat->spat_short = Nullstr;
+ }
+ if (spat->spat_regexp) {
+ regfree(spat->spat_regexp);
+ spat->spat_regexp = Null(REGEXP*);
+ }
+
+ /* now unlink from spat list */
+
+ for (entry = defstash->tbl_array['_']; entry; entry = entry->hent_next) {
+ register HASH *stash;
+ STAB *stab = (STAB*)entry->hent_val;
+
+ if (!stab)
+ continue;
+ stash = stab_hash(stab);
+ if (!stash || stash->tbl_spatroot == Null(SPAT*))
+ continue;
+ if (stash->tbl_spatroot == spat)
+ stash->tbl_spatroot = spat->spat_next;
+ else {
+ for (sp = stash->tbl_spatroot;
+ sp && sp->spat_next != spat;
+ sp = sp->spat_next)
+ /*SUPPRESS 530*/
+ ;
+ if (sp)
+ sp->spat_next = spat->spat_next;
+ }
+ }
+ Safefree(spat);
+}
+
+/* Recursively descend a command sequence and push the address of any string
+ * that needs saving on recursion onto the tosave array.
+ */
+
+static int
+cmd_tosave(cmd,willsave)
+register CMD *cmd;
+int willsave; /* willsave passes down the tree */
+{
+ register CMD *head = cmd;
+ int shouldsave = FALSE; /* shouldsave passes up the tree */
+ int tmpsave;
+ register CMD *lastcmd = Nullcmd;
+
+ while (cmd) {
+ if (cmd->c_expr)
+ shouldsave |= arg_tosave(cmd->c_expr,willsave);
+ switch (cmd->c_type) {
+ case C_WHILE:
+ if (cmd->ucmd.ccmd.cc_true) {
+ tmpsave = cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave);
+
+ /* Here we check to see if the temporary array generated for
+ * a foreach needs to be localized because of recursion.
+ */
+ if (tmpsave && (cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY) {
+ if (lastcmd &&
+ lastcmd->c_type == C_EXPR &&
+ lastcmd->c_expr) {
+ ARG *arg = lastcmd->c_expr;
+
+ if (arg->arg_type == O_ASSIGN &&
+ arg[1].arg_type == A_LEXPR &&
+ arg[1].arg_ptr.arg_arg->arg_type == O_LARRAY &&
+ strnEQ("_GEN_",
+ stab_name(
+ arg[1].arg_ptr.arg_arg[1].arg_ptr.arg_stab),
+ 5)) { /* array generated for foreach */
+ (void)localize(arg);
+ }
+ }
+
+ /* in any event, save the iterator */
+
+ (void)apush(tosave,cmd->c_short);
+ }
+ shouldsave |= tmpsave;
+ }
+ break;
+ case C_BLOCK:
+ case C_ELSE:
+ case C_IF:
+ if (cmd->ucmd.ccmd.cc_true)
+ shouldsave |= cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave);
+ break;
+ case C_EXPR:
+ if (cmd->ucmd.acmd.ac_expr)
+ shouldsave |= arg_tosave(cmd->ucmd.acmd.ac_expr,willsave);
+ break;
+ }
+ lastcmd = cmd;
+ cmd = cmd->c_next;
+ if (cmd && cmd == head) /* reached end of while loop */
+ break;
+ }
+ return shouldsave;
+}
+
+static int
+arg_tosave(arg,willsave)
+register ARG *arg;
+int willsave;
+{
+ register int i;
+ int shouldsave = FALSE;
+
+ for (i = arg->arg_len; i >= 1; i--) {
+ switch (arg[i].arg_type & A_MASK) {
+ case A_NULL:
+ break;
+ case A_LEXPR:
+ case A_EXPR:
+ shouldsave |= arg_tosave(arg[i].arg_ptr.arg_arg,shouldsave);
+ break;
+ case A_CMD:
+ shouldsave |= cmd_tosave(arg[i].arg_ptr.arg_cmd,shouldsave);
+ break;
+ case A_WORD:
+ case A_STAB:
+ case A_LVAL:
+ case A_READ:
+ case A_GLOB:
+ case A_ARYLEN:
+ case A_SINGLE:
+ case A_DOUBLE:
+ case A_BACKTICK:
+ break;
+ case A_SPAT:
+ shouldsave |= spat_tosave(arg[i].arg_ptr.arg_spat);
+ break;
+ }
+ }
+ switch (arg->arg_type) {
+ case O_RETURN:
+ saw_return = TRUE;
+ break;
+ case O_EVAL:
+ case O_SUBR:
+ shouldsave = TRUE;
+ break;
+ }
+ if (willsave)
+ (void)apush(tosave,arg->arg_ptr.arg_str);
+ return shouldsave;
+}
+
+static int
+spat_tosave(spat)
+register SPAT *spat;
+{
+ int shouldsave = FALSE;
+
+ if (spat->spat_runtime)
+ shouldsave |= arg_tosave(spat->spat_runtime,FALSE);
+ if (spat->spat_repl) {
+ shouldsave |= arg_tosave(spat->spat_repl,FALSE);
+ }
+
+ return shouldsave;
+}
+
--- /dev/null
+/* $RCSfile: consarg.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 16:21:16 $
+ *
+ * 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: consarg.c,v $
+ * Revision 4.0.1.3 91/11/05 16:21:16 lwall
+ * patch11: random cleanup
+ * patch11: added eval {}
+ * patch11: added sort {} LIST
+ * patch11: "foo" x -1 dumped core
+ * patch11: substr() and vec() weren't allowed in an lvalue list
+ *
+ * Revision 4.0.1.2 91/06/07 10:33:12 lwall
+ * patch4: new copyright notice
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ *
+ * Revision 4.0.1.1 91/04/11 17:38:34 lwall
+ * patch1: fixed "Bad free" error
+ *
+ * Revision 4.0 91/03/20 01:06:15 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+static int nothing_in_common();
+static int arg_common();
+static int spat_common();
+
+ARG *
+make_split(stab,arg,limarg)
+register STAB *stab;
+register ARG *arg;
+ARG *limarg;
+{
+ register SPAT *spat;
+
+ if (arg->arg_type != O_MATCH) {
+ Newz(201,spat,1,SPAT);
+ spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
+ curstash->tbl_spatroot = spat;
+
+ spat->spat_runtime = arg;
+ arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
+ }
+ Renew(arg,4,ARG);
+ arg->arg_len = 3;
+ if (limarg) {
+ if (limarg->arg_type == O_ITEM) {
+ Copy(limarg+1,arg+3,1,ARG);
+ limarg[1].arg_type = A_NULL;
+ arg_free(limarg);
+ }
+ else {
+ arg[3].arg_flags = 0;
+ arg[3].arg_type = A_EXPR;
+ arg[3].arg_ptr.arg_arg = limarg;
+ }
+ }
+ else {
+ arg[3].arg_flags = 0;
+ arg[3].arg_type = A_NULL;
+ arg[3].arg_ptr.arg_arg = Nullarg;
+ }
+ arg->arg_type = O_SPLIT;
+ spat = arg[2].arg_ptr.arg_spat;
+ spat->spat_repl = stab2arg(A_STAB,aadd(stab));
+ if (spat->spat_short) { /* exact match can bypass regexec() */
+ if (!((spat->spat_flags & SPAT_SCANFIRST) &&
+ (spat->spat_flags & SPAT_ALL) )) {
+ str_free(spat->spat_short);
+ spat->spat_short = Nullstr;
+ }
+ }
+ return arg;
+}
+
+ARG *
+mod_match(type,left,pat)
+register ARG *left;
+register ARG *pat;
+{
+
+ register SPAT *spat;
+ register ARG *newarg;
+
+ if (!pat)
+ return Nullarg;
+
+ if ((pat->arg_type == O_MATCH ||
+ pat->arg_type == O_SUBST ||
+ pat->arg_type == O_TRANS ||
+ pat->arg_type == O_SPLIT
+ ) &&
+ pat[1].arg_ptr.arg_stab == defstab ) {
+ switch (pat->arg_type) {
+ case O_MATCH:
+ newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH,
+ pat->arg_len,
+ left,Nullarg,Nullarg);
+ break;
+ case O_SUBST:
+ newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST,
+ pat->arg_len,
+ left,Nullarg,Nullarg));
+ break;
+ case O_TRANS:
+ newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS,
+ pat->arg_len,
+ left,Nullarg,Nullarg));
+ break;
+ case O_SPLIT:
+ newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT,
+ pat->arg_len,
+ left,Nullarg,Nullarg);
+ break;
+ }
+ if (pat->arg_len >= 2) {
+ newarg[2].arg_type = pat[2].arg_type;
+ newarg[2].arg_ptr = pat[2].arg_ptr;
+ newarg[2].arg_len = pat[2].arg_len;
+ newarg[2].arg_flags = pat[2].arg_flags;
+ if (pat->arg_len >= 3) {
+ newarg[3].arg_type = pat[3].arg_type;
+ newarg[3].arg_ptr = pat[3].arg_ptr;
+ newarg[3].arg_len = pat[3].arg_len;
+ newarg[3].arg_flags = pat[3].arg_flags;
+ }
+ }
+ free_arg(pat);
+ }
+ else {
+ Newz(202,spat,1,SPAT);
+ spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
+ curstash->tbl_spatroot = spat;
+
+ spat->spat_runtime = pat;
+ newarg = make_op(type,2,left,Nullarg,Nullarg);
+ newarg[2].arg_type = A_SPAT | A_DONT;
+ newarg[2].arg_ptr.arg_spat = spat;
+ }
+
+ return newarg;
+}
+
+ARG *
+make_op(type,newlen,arg1,arg2,arg3)
+int type;
+int newlen;
+ARG *arg1;
+ARG *arg2;
+ARG *arg3;
+{
+ register ARG *arg;
+ register ARG *chld;
+ register unsigned doarg;
+ register int i;
+ extern ARG *arg4; /* should be normal arguments, really */
+ extern ARG *arg5;
+
+ arg = op_new(newlen);
+ arg->arg_type = type;
+ /*SUPPRESS 560*/
+ if (chld = arg1) {
+ if (chld->arg_type == O_ITEM &&
+ (hoistable[ i = (chld[1].arg_type&A_MASK)] || i == A_LVAL ||
+ (i == A_LEXPR &&
+ (chld[1].arg_ptr.arg_arg->arg_type == O_LIST ||
+ chld[1].arg_ptr.arg_arg->arg_type == O_ARRAY ||
+ chld[1].arg_ptr.arg_arg->arg_type == O_HASH ))))
+ {
+ arg[1].arg_type = chld[1].arg_type;
+ arg[1].arg_ptr = chld[1].arg_ptr;
+ arg[1].arg_flags |= chld[1].arg_flags;
+ arg[1].arg_len = chld[1].arg_len;
+ free_arg(chld);
+ }
+ else {
+ arg[1].arg_type = A_EXPR;
+ arg[1].arg_ptr.arg_arg = chld;
+ }
+ }
+ /*SUPPRESS 560*/
+ if (chld = arg2) {
+ if (chld->arg_type == O_ITEM &&
+ (hoistable[chld[1].arg_type&A_MASK] ||
+ (type == O_ASSIGN &&
+ ((chld[1].arg_type == A_READ && !(arg[1].arg_type & A_DONT))
+ ||
+ (chld[1].arg_type == A_INDREAD && !(arg[1].arg_type & A_DONT))
+ ||
+ (chld[1].arg_type == A_GLOB && !(arg[1].arg_type & A_DONT))
+ ) ) ) ) {
+ arg[2].arg_type = chld[1].arg_type;
+ arg[2].arg_ptr = chld[1].arg_ptr;
+ arg[2].arg_len = chld[1].arg_len;
+ free_arg(chld);
+ }
+ else {
+ arg[2].arg_type = A_EXPR;
+ arg[2].arg_ptr.arg_arg = chld;
+ }
+ }
+ /*SUPPRESS 560*/
+ if (chld = arg3) {
+ if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
+ arg[3].arg_type = chld[1].arg_type;
+ arg[3].arg_ptr = chld[1].arg_ptr;
+ arg[3].arg_len = chld[1].arg_len;
+ free_arg(chld);
+ }
+ else {
+ arg[3].arg_type = A_EXPR;
+ arg[3].arg_ptr.arg_arg = chld;
+ }
+ }
+ if (newlen >= 4 && (chld = arg4)) {
+ if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
+ arg[4].arg_type = chld[1].arg_type;
+ arg[4].arg_ptr = chld[1].arg_ptr;
+ arg[4].arg_len = chld[1].arg_len;
+ free_arg(chld);
+ }
+ else {
+ arg[4].arg_type = A_EXPR;
+ arg[4].arg_ptr.arg_arg = chld;
+ }
+ }
+ if (newlen >= 5 && (chld = arg5)) {
+ if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) {
+ arg[5].arg_type = chld[1].arg_type;
+ arg[5].arg_ptr = chld[1].arg_ptr;
+ arg[5].arg_len = chld[1].arg_len;
+ free_arg(chld);
+ }
+ else {
+ arg[5].arg_type = A_EXPR;
+ arg[5].arg_ptr.arg_arg = chld;
+ }
+ }
+ doarg = opargs[type];
+ for (i = 1; i <= newlen; ++i) {
+ if (!(doarg & 1))
+ arg[i].arg_type |= A_DONT;
+ if (doarg & 2)
+ arg[i].arg_flags |= AF_ARYOK;
+ doarg >>= 2;
+ }
+#ifdef DEBUGGING
+ if (debug & 16) {
+ fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]);
+ if (arg1)
+ fprintf(stderr,",%s=%lx",
+ argname[arg[1].arg_type&A_MASK],arg[1].arg_ptr.arg_arg);
+ if (arg2)
+ fprintf(stderr,",%s=%lx",
+ argname[arg[2].arg_type&A_MASK],arg[2].arg_ptr.arg_arg);
+ if (arg3)
+ fprintf(stderr,",%s=%lx",
+ argname[arg[3].arg_type&A_MASK],arg[3].arg_ptr.arg_arg);
+ if (newlen >= 4)
+ fprintf(stderr,",%s=%lx",
+ argname[arg[4].arg_type&A_MASK],arg[4].arg_ptr.arg_arg);
+ if (newlen >= 5)
+ fprintf(stderr,",%s=%lx",
+ argname[arg[5].arg_type&A_MASK],arg[5].arg_ptr.arg_arg);
+ fprintf(stderr,")\n");
+ }
+#endif
+ arg = evalstatic(arg); /* see if we can consolidate anything */
+ return arg;
+}
+
+ARG *
+evalstatic(arg)
+register ARG *arg;
+{
+ static STR *str = Nullstr;
+ register STR *s1;
+ register STR *s2;
+ double value; /* must not be register */
+ register char *tmps;
+ int i;
+ unsigned long tmplong;
+ long tmp2;
+ double exp(), log(), sqrt(), modf();
+ char *crypt();
+ double sin(), cos(), atan2(), pow();
+
+ if (!arg || !arg->arg_len)
+ return arg;
+
+ if (!str)
+ str = Str_new(20,0);
+
+ if (arg[1].arg_type == A_SINGLE)
+ s1 = arg[1].arg_ptr.arg_str;
+ else
+ s1 = Nullstr;
+ if (arg->arg_len >= 2 && arg[2].arg_type == A_SINGLE)
+ s2 = arg[2].arg_ptr.arg_str;
+ else
+ s2 = Nullstr;
+
+#define CHECK1 if (!s1) return arg
+#define CHECK2 if (!s2) return arg
+#define CHECK12 if (!s1 || !s2) return arg
+
+ switch (arg->arg_type) {
+ default:
+ return arg;
+ case O_SORT:
+ if (arg[1].arg_type == A_CMD)
+ arg[1].arg_type |= A_DONT;
+ return arg;
+ case O_EVAL:
+ if (arg[1].arg_type == A_CMD) {
+ arg->arg_type = O_TRY;
+ arg[1].arg_type |= A_DONT;
+ return arg;
+ }
+ CHECK1;
+ arg->arg_type = O_EVALONCE;
+ return arg;
+ case O_AELEM:
+ CHECK2;
+ i = (int)str_gnum(s2);
+ if (i < 32767 && i >= 0) {
+ arg->arg_type = O_ITEM;
+ arg->arg_len = 1;
+ arg[1].arg_type = A_ARYSTAB; /* $abc[123] is hoistable now */
+ arg[1].arg_len = i;
+ str_free(s2);
+ Renew(arg, 2, ARG);
+ }
+ return arg;
+ case O_CONCAT:
+ CHECK12;
+ str_sset(str,s1);
+ str_scat(str,s2);
+ break;
+ case O_REPEAT:
+ CHECK12;
+ i = (int)str_gnum(s2);
+ tmps = str_get(s1);
+ str_nset(str,"",0);
+ if (i > 0) {
+ STR_GROW(str, i * s1->str_cur + 1);
+ repeatcpy(str->str_ptr, tmps, s1->str_cur, i);
+ str->str_cur = i * s1->str_cur;
+ str->str_ptr[str->str_cur] = '\0';
+ }
+ break;
+ case O_MULTIPLY:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,value * str_gnum(s2));
+ break;
+ case O_DIVIDE:
+ CHECK12;
+ value = str_gnum(s2);
+ if (value == 0.0)
+ yyerror("Illegal division by constant zero");
+ else
+#ifdef SLOPPYDIVIDE
+ /* insure that 20./5. == 4. */
+ {
+ double x;
+ int k;
+ x = str_gnum(s1);
+ if ((double)(int)x == x &&
+ (double)(int)value == value &&
+ (k = (int)x/(int)value)*(int)value == (int)x) {
+ value = k;
+ } else {
+ value = x/value;
+ }
+ str_numset(str,value);
+ }
+#else
+ str_numset(str,str_gnum(s1) / value);
+#endif
+ break;
+ case O_MODULO:
+ CHECK12;
+ tmplong = (unsigned long)str_gnum(s2);
+ if (tmplong == 0L) {
+ yyerror("Illegal modulus of constant zero");
+ return arg;
+ }
+ tmp2 = (long)str_gnum(s1);
+#ifndef lint
+ if (tmp2 >= 0)
+ str_numset(str,(double)(tmp2 % tmplong));
+ else
+ str_numset(str,(double)((tmplong-((-tmp2 - 1) % tmplong)) - 1));
+#else
+ tmp2 = tmp2;
+#endif
+ break;
+ case O_ADD:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,value + str_gnum(s2));
+ break;
+ case O_SUBTRACT:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,value - str_gnum(s2));
+ break;
+ case O_LEFT_SHIFT:
+ CHECK12;
+ value = str_gnum(s1);
+ i = (int)str_gnum(s2);
+#ifndef lint
+ str_numset(str,(double)(((long)value) << i));
+#endif
+ break;
+ case O_RIGHT_SHIFT:
+ CHECK12;
+ value = str_gnum(s1);
+ i = (int)str_gnum(s2);
+#ifndef lint
+ str_numset(str,(double)(((long)value) >> i));
+#endif
+ break;
+ case O_LT:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,(value < str_gnum(s2)) ? 1.0 : 0.0);
+ break;
+ case O_GT:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,(value > str_gnum(s2)) ? 1.0 : 0.0);
+ break;
+ case O_LE:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,(value <= str_gnum(s2)) ? 1.0 : 0.0);
+ break;
+ case O_GE:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,(value >= str_gnum(s2)) ? 1.0 : 0.0);
+ break;
+ case O_EQ:
+ CHECK12;
+ if (dowarn) {
+ if ((!s1->str_nok && !looks_like_number(s1)) ||
+ (!s2->str_nok && !looks_like_number(s2)) )
+ warn("Possible use of == on string value");
+ }
+ value = str_gnum(s1);
+ str_numset(str,(value == str_gnum(s2)) ? 1.0 : 0.0);
+ break;
+ case O_NE:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,(value != str_gnum(s2)) ? 1.0 : 0.0);
+ break;
+ case O_NCMP:
+ CHECK12;
+ value = str_gnum(s1);
+ value -= str_gnum(s2);
+ if (value > 0.0)
+ value = 1.0;
+ else if (value < 0.0)
+ value = -1.0;
+ str_numset(str,value);
+ break;
+ case O_BIT_AND:
+ CHECK12;
+ value = str_gnum(s1);
+#ifndef lint
+ str_numset(str,(double)(U_L(value) & U_L(str_gnum(s2))));
+#endif
+ break;
+ case O_XOR:
+ CHECK12;
+ value = str_gnum(s1);
+#ifndef lint
+ str_numset(str,(double)(U_L(value) ^ U_L(str_gnum(s2))));
+#endif
+ break;
+ case O_BIT_OR:
+ CHECK12;
+ value = str_gnum(s1);
+#ifndef lint
+ str_numset(str,(double)(U_L(value) | U_L(str_gnum(s2))));
+#endif
+ break;
+ case O_AND:
+ CHECK12;
+ if (str_true(s1))
+ str_sset(str,s2);
+ else
+ str_sset(str,s1);
+ break;
+ case O_OR:
+ CHECK12;
+ if (str_true(s1))
+ str_sset(str,s1);
+ else
+ str_sset(str,s2);
+ break;
+ case O_COND_EXPR:
+ CHECK12;
+ if ((arg[3].arg_type & A_MASK) != A_SINGLE)
+ return arg;
+ if (str_true(s1))
+ str_sset(str,s2);
+ else
+ str_sset(str,arg[3].arg_ptr.arg_str);
+ str_free(arg[3].arg_ptr.arg_str);
+ Renew(arg, 3, ARG);
+ break;
+ case O_NEGATE:
+ CHECK1;
+ str_numset(str,(double)(-str_gnum(s1)));
+ break;
+ case O_NOT:
+ CHECK1;
+#ifdef NOTNOT
+ { char xxx = str_true(s1); str_numset(str,(double)!xxx); }
+#else
+ str_numset(str,(double)(!str_true(s1)));
+#endif
+ break;
+ case O_COMPLEMENT:
+ CHECK1;
+#ifndef lint
+ str_numset(str,(double)(~U_L(str_gnum(s1))));
+#endif
+ break;
+ case O_SIN:
+ CHECK1;
+ str_numset(str,sin(str_gnum(s1)));
+ break;
+ case O_COS:
+ CHECK1;
+ str_numset(str,cos(str_gnum(s1)));
+ break;
+ case O_ATAN2:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,atan2(value, str_gnum(s2)));
+ break;
+ case O_POW:
+ CHECK12;
+ value = str_gnum(s1);
+ str_numset(str,pow(value, str_gnum(s2)));
+ break;
+ case O_LENGTH:
+ if (arg[1].arg_type == A_STAB) {
+ arg->arg_type = O_ITEM;
+ arg[1].arg_type = A_LENSTAB;
+ return arg;
+ }
+ CHECK1;
+ str_numset(str, (double)str_len(s1));
+ break;
+ case O_SLT:
+ CHECK12;
+ str_numset(str,(double)(str_cmp(s1,s2) < 0));
+ break;
+ case O_SGT:
+ CHECK12;
+ str_numset(str,(double)(str_cmp(s1,s2) > 0));
+ break;
+ case O_SLE:
+ CHECK12;
+ str_numset(str,(double)(str_cmp(s1,s2) <= 0));
+ break;
+ case O_SGE:
+ CHECK12;
+ str_numset(str,(double)(str_cmp(s1,s2) >= 0));
+ break;
+ case O_SEQ:
+ CHECK12;
+ str_numset(str,(double)(str_eq(s1,s2)));
+ break;
+ case O_SNE:
+ CHECK12;
+ str_numset(str,(double)(!str_eq(s1,s2)));
+ break;
+ case O_SCMP:
+ CHECK12;
+ str_numset(str,(double)(str_cmp(s1,s2)));
+ break;
+ case O_CRYPT:
+ CHECK12;
+#ifdef HAS_CRYPT
+ tmps = str_get(s1);
+ str_set(str,crypt(tmps,str_get(s2)));
+#else
+ yyerror(
+ "The crypt() function is unimplemented due to excessive paranoia.");
+#endif
+ break;
+ case O_EXP:
+ CHECK1;
+ str_numset(str,exp(str_gnum(s1)));
+ break;
+ case O_LOG:
+ CHECK1;
+ str_numset(str,log(str_gnum(s1)));
+ break;
+ case O_SQRT:
+ CHECK1;
+ str_numset(str,sqrt(str_gnum(s1)));
+ break;
+ case O_INT:
+ CHECK1;
+ value = str_gnum(s1);
+ if (value >= 0.0)
+ (void)modf(value,&value);
+ else {
+ (void)modf(-value,&value);
+ value = -value;
+ }
+ str_numset(str,value);
+ break;
+ case O_ORD:
+ CHECK1;
+#ifndef I286
+ str_numset(str,(double)(*str_get(s1)));
+#else
+ {
+ int zapc;
+ char *zaps;
+
+ zaps = str_get(s1);
+ zapc = (int) *zaps;
+ str_numset(str,(double)(zapc));
+ }
+#endif
+ break;
+ }
+ arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */
+ str_free(s1);
+ arg[1].arg_ptr.arg_str = str;
+ if (s2) {
+ str_free(s2);
+ arg[2].arg_ptr.arg_str = Nullstr;
+ arg[2].arg_type = A_NULL;
+ }
+ str = Nullstr;
+
+ return arg;
+}
+
+ARG *
+l(arg)
+register ARG *arg;
+{
+ register int i;
+ register ARG *arg1;
+ register ARG *arg2;
+ SPAT *spat;
+ int arghog = 0;
+
+ i = arg[1].arg_type & A_MASK;
+
+ arg->arg_flags |= AF_COMMON; /* assume something in common */
+ /* which forces us to copy things */
+
+ if (i == A_ARYLEN) {
+ arg[1].arg_type = A_LARYLEN;
+ return arg;
+ }
+ if (i == A_ARYSTAB) {
+ arg[1].arg_type = A_LARYSTAB;
+ return arg;
+ }
+
+ /* see if it's an array reference */
+
+ if (i == A_EXPR || i == A_LEXPR) {
+ arg1 = arg[1].arg_ptr.arg_arg;
+
+ if (arg1->arg_type == O_LIST || arg1->arg_type == O_ITEM) {
+ /* assign to list */
+ if (arg->arg_len > 1) {
+ dehoist(arg,2);
+ arg2 = arg[2].arg_ptr.arg_arg;
+ if (nothing_in_common(arg1,arg2))
+ arg->arg_flags &= ~AF_COMMON;
+ if (arg->arg_type == O_ASSIGN) {
+ if (arg1->arg_flags & AF_LOCAL)
+ arg->arg_flags |= AF_LOCAL;
+ arg[1].arg_flags |= AF_ARYOK;
+ arg[2].arg_flags |= AF_ARYOK;
+ }
+ }
+ else if (arg->arg_type != O_CHOP)
+ arg->arg_type = O_ASSIGN; /* possible local(); */
+ for (i = arg1->arg_len; i >= 1; i--) {
+ switch (arg1[i].arg_type) {
+ case A_STAR: case A_LSTAR:
+ arg1[i].arg_type = A_LSTAR;
+ break;
+ case A_STAB: case A_LVAL:
+ arg1[i].arg_type = A_LVAL;
+ break;
+ case A_ARYLEN: case A_LARYLEN:
+ arg1[i].arg_type = A_LARYLEN;
+ break;
+ case A_ARYSTAB: case A_LARYSTAB:
+ arg1[i].arg_type = A_LARYSTAB;
+ break;
+ case A_EXPR: case A_LEXPR:
+ arg1[i].arg_type = A_LEXPR;
+ switch(arg1[i].arg_ptr.arg_arg->arg_type) {
+ case O_ARRAY: case O_LARRAY:
+ arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY;
+ arghog = 1;
+ break;
+ case O_AELEM: case O_LAELEM:
+ arg1[i].arg_ptr.arg_arg->arg_type = O_LAELEM;
+ break;
+ case O_HASH: case O_LHASH:
+ arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH;
+ arghog = 1;
+ break;
+ case O_HELEM: case O_LHELEM:
+ arg1[i].arg_ptr.arg_arg->arg_type = O_LHELEM;
+ break;
+ case O_ASLICE: case O_LASLICE:
+ arg1[i].arg_ptr.arg_arg->arg_type = O_LASLICE;
+ break;
+ case O_HSLICE: case O_LHSLICE:
+ arg1[i].arg_ptr.arg_arg->arg_type = O_LHSLICE;
+ break;
+ case O_SUBSTR: case O_VEC:
+ (void)l(arg1[i].arg_ptr.arg_arg);
+ Renewc(arg1[i].arg_ptr.arg_arg->arg_ptr.arg_str, 1,
+ struct lstring, STR);
+ /* grow string struct to hold an lstring struct */
+ break;
+ default:
+ goto ill_item;
+ }
+ break;
+ default:
+ ill_item:
+ (void)sprintf(tokenbuf, "Illegal item (%s) as lvalue",
+ argname[arg1[i].arg_type&A_MASK]);
+ yyerror(tokenbuf);
+ }
+ }
+ if (arg->arg_len > 1) {
+ if (arg2->arg_type == O_SPLIT && !arg2[3].arg_type && !arghog) {
+ arg2[3].arg_type = A_SINGLE;
+ arg2[3].arg_ptr.arg_str =
+ str_nmake((double)arg1->arg_len + 1); /* limit split len*/
+ }
+ }
+ }
+ else if (arg1->arg_type == O_AELEM || arg1->arg_type == O_LAELEM)
+ if (arg->arg_type == O_DEFINED)
+ arg1->arg_type = O_AELEM;
+ else
+ arg1->arg_type = O_LAELEM;
+ else if (arg1->arg_type == O_ARRAY || arg1->arg_type == O_LARRAY) {
+ arg1->arg_type = O_LARRAY;
+ if (arg->arg_len > 1) {
+ dehoist(arg,2);
+ arg2 = arg[2].arg_ptr.arg_arg;
+ if (arg2->arg_type == O_SPLIT) { /* use split's builtin =?*/
+ spat = arg2[2].arg_ptr.arg_spat;
+ if (!(spat->spat_flags & SPAT_ONCE) &&
+ nothing_in_common(arg1,spat->spat_repl)) {
+ spat->spat_repl[1].arg_ptr.arg_stab =
+ arg1[1].arg_ptr.arg_stab;
+ arg1[1].arg_ptr.arg_stab = Nullstab;
+ spat->spat_flags |= SPAT_ONCE;
+ arg_free(arg1); /* recursive */
+ arg[1].arg_ptr.arg_arg = Nullarg;
+ free_arg(arg); /* non-recursive */
+ return arg2; /* split has builtin assign */
+ }
+ }
+ else if (nothing_in_common(arg1,arg2))
+ arg->arg_flags &= ~AF_COMMON;
+ if (arg->arg_type == O_ASSIGN) {
+ arg[1].arg_flags |= AF_ARYOK;
+ arg[2].arg_flags |= AF_ARYOK;
+ }
+ }
+ else if (arg->arg_type == O_ASSIGN)
+ arg[1].arg_flags |= AF_ARYOK;
+ }
+ else if (arg1->arg_type == O_HELEM || arg1->arg_type == O_LHELEM)
+ if (arg->arg_type == O_DEFINED)
+ arg1->arg_type = O_HELEM; /* avoid creating one */
+ else
+ arg1->arg_type = O_LHELEM;
+ else if (arg1->arg_type == O_HASH || arg1->arg_type == O_LHASH) {
+ arg1->arg_type = O_LHASH;
+ if (arg->arg_len > 1) {
+ dehoist(arg,2);
+ arg2 = arg[2].arg_ptr.arg_arg;
+ if (nothing_in_common(arg1,arg2))
+ arg->arg_flags &= ~AF_COMMON;
+ if (arg->arg_type == O_ASSIGN) {
+ arg[1].arg_flags |= AF_ARYOK;
+ arg[2].arg_flags |= AF_ARYOK;
+ }
+ }
+ else if (arg->arg_type == O_ASSIGN)
+ arg[1].arg_flags |= AF_ARYOK;
+ }
+ else if (arg1->arg_type == O_ASLICE) {
+ arg1->arg_type = O_LASLICE;
+ if (arg->arg_type == O_ASSIGN) {
+ dehoist(arg,2);
+ arg[1].arg_flags |= AF_ARYOK;
+ arg[2].arg_flags |= AF_ARYOK;
+ }
+ }
+ else if (arg1->arg_type == O_HSLICE) {
+ arg1->arg_type = O_LHSLICE;
+ if (arg->arg_type == O_ASSIGN) {
+ dehoist(arg,2);
+ arg[1].arg_flags |= AF_ARYOK;
+ arg[2].arg_flags |= AF_ARYOK;
+ }
+ }
+ else if ((arg->arg_type == O_DEFINED || arg->arg_type == O_UNDEF) &&
+ (arg1->arg_type == (perldb ? O_DBSUBR : O_SUBR)) ) {
+ arg[1].arg_type |= A_DONT;
+ }
+ else if (arg1->arg_type == O_SUBSTR || arg1->arg_type == O_VEC) {
+ (void)l(arg1);
+ Renewc(arg1->arg_ptr.arg_str, 1, struct lstring, STR);
+ /* grow string struct to hold an lstring struct */
+ }
+ else if (arg1->arg_type == O_ASSIGN)
+ /*SUPPRESS 530*/
+ ;
+ else {
+ (void)sprintf(tokenbuf,
+ "Illegal expression (%s) as lvalue",opname[arg1->arg_type]);
+ yyerror(tokenbuf);
+ }
+ arg[1].arg_type = A_LEXPR | (arg[1].arg_type & A_DONT);
+ if (arg->arg_type == O_ASSIGN && (arg1[1].arg_flags & AF_ARYOK)) {
+ arg[1].arg_flags |= AF_ARYOK;
+ if (arg->arg_len > 1)
+ arg[2].arg_flags |= AF_ARYOK;
+ }
+#ifdef DEBUGGING
+ if (debug & 16)
+ fprintf(stderr,"lval LEXPR\n");
+#endif
+ return arg;
+ }
+ if (i == A_STAR || i == A_LSTAR) {
+ arg[1].arg_type = A_LSTAR | (arg[1].arg_type & A_DONT);
+ return arg;
+ }
+
+ /* not an array reference, should be a register name */
+
+ if (i != A_STAB && i != A_LVAL) {
+ (void)sprintf(tokenbuf,
+ "Illegal item (%s) as lvalue",argname[arg[1].arg_type&A_MASK]);
+ yyerror(tokenbuf);
+ }
+ arg[1].arg_type = A_LVAL | (arg[1].arg_type & A_DONT);
+#ifdef DEBUGGING
+ if (debug & 16)
+ fprintf(stderr,"lval LVAL\n");
+#endif
+ return arg;
+}
+
+ARG *
+fixl(type,arg)
+int type;
+ARG *arg;
+{
+ if (type == O_DEFINED || type == O_UNDEF) {
+ if (arg->arg_type != O_ITEM)
+ arg = hide_ary(arg);
+ if (arg->arg_type == O_ITEM) {
+ type = arg[1].arg_type & A_MASK;
+ if (type == A_EXPR || type == A_LEXPR)
+ arg[1].arg_type = A_LEXPR|A_DONT;
+ }
+ }
+ return arg;
+}
+
+dehoist(arg,i)
+ARG *arg;
+{
+ ARG *tmparg;
+
+ if (arg[i].arg_type != A_EXPR) { /* dehoist */
+ tmparg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg);
+ tmparg[1] = arg[i];
+ arg[i].arg_ptr.arg_arg = tmparg;
+ arg[i].arg_type = A_EXPR;
+ }
+}
+
+ARG *
+addflags(i,flags,arg)
+register ARG *arg;
+{
+ arg[i].arg_flags |= flags;
+ return arg;
+}
+
+ARG *
+hide_ary(arg)
+ARG *arg;
+{
+ if (arg->arg_type == O_ARRAY || arg->arg_type == O_HASH)
+ return make_op(O_ITEM,1,arg,Nullarg,Nullarg);
+ return arg;
+}
+
+/* maybe do a join on multiple array dimensions */
+
+ARG *
+jmaybe(arg)
+register ARG *arg;
+{
+ if (arg && arg->arg_type == O_COMMA) {
+ arg = listish(arg);
+ arg = make_op(O_JOIN, 2,
+ stab2arg(A_STAB,stabent(";",TRUE)),
+ make_list(arg),
+ Nullarg);
+ }
+ return arg;
+}
+
+ARG *
+make_list(arg)
+register ARG *arg;
+{
+ register int i;
+ register ARG *node;
+ register ARG *nxtnode;
+ register int j;
+ STR *tmpstr;
+
+ if (!arg) {
+ arg = op_new(0);
+ arg->arg_type = O_LIST;
+ }
+ if (arg->arg_type != O_COMMA) {
+ if (arg->arg_type != O_ARRAY)
+ arg->arg_flags |= AF_LISTISH; /* see listish() below */
+ arg->arg_flags |= AF_LISTISH; /* see listish() below */
+ return arg;
+ }
+ for (i = 2, node = arg; ; i++) {
+ if (node->arg_len < 2)
+ break;
+ if (node[1].arg_type != A_EXPR)
+ break;
+ node = node[1].arg_ptr.arg_arg;
+ if (node->arg_type != O_COMMA)
+ break;
+ }
+ if (i > 2) {
+ node = arg;
+ arg = op_new(i);
+ tmpstr = arg->arg_ptr.arg_str;
+#ifdef STRUCTCOPY
+ *arg = *node; /* copy everything except the STR */
+#else
+ (void)bcopy((char *)node, (char *)arg, sizeof(ARG));
+#endif
+ arg->arg_ptr.arg_str = tmpstr;
+ for (j = i; ; ) {
+#ifdef STRUCTCOPY
+ arg[j] = node[2];
+#else
+ (void)bcopy((char *)(node+2), (char *)(arg+j), sizeof(ARG));
+#endif
+ arg[j].arg_flags |= AF_ARYOK;
+ --j; /* Bug in Xenix compiler */
+ if (j < 2) {
+#ifdef STRUCTCOPY
+ arg[1] = node[1];
+#else
+ (void)bcopy((char *)(node+1), (char *)(arg+1), sizeof(ARG));
+#endif
+ free_arg(node);
+ break;
+ }
+ nxtnode = node[1].arg_ptr.arg_arg;
+ free_arg(node);
+ node = nxtnode;
+ }
+ }
+ arg[1].arg_flags |= AF_ARYOK;
+ arg[2].arg_flags |= AF_ARYOK;
+ arg->arg_type = O_LIST;
+ arg->arg_len = i;
+ return arg;
+}
+
+/* turn a single item into a list */
+
+ARG *
+listish(arg)
+ARG *arg;
+{
+ if (arg && arg->arg_flags & AF_LISTISH)
+ arg = make_op(O_LIST,1,arg,Nullarg,Nullarg);
+ return arg;
+}
+
+ARG *
+maybelistish(optype, arg)
+int optype;
+ARG *arg;
+{
+ ARG *tmparg = arg;
+
+ if (optype == O_RETURN && arg->arg_type == O_ITEM &&
+ arg[1].arg_type == A_EXPR && (tmparg = arg[1].arg_ptr.arg_arg) &&
+ ((tmparg->arg_flags & AF_LISTISH) || (tmparg->arg_type == O_ARRAY) )) {
+ tmparg = listish(tmparg);
+ free_arg(arg);
+ arg = tmparg;
+ }
+ else if (optype == O_PRTF ||
+ (arg->arg_type == O_ASLICE || arg->arg_type == O_HSLICE ||
+ arg->arg_type == O_F_OR_R) )
+ arg = listish(arg);
+ return arg;
+}
+
+/* mark list of local variables */
+
+ARG *
+localize(arg)
+ARG *arg;
+{
+ arg->arg_flags |= AF_LOCAL;
+ return arg;
+}
+
+ARG *
+rcatmaybe(arg)
+ARG *arg;
+{
+ ARG *arg2;
+
+ if (arg->arg_type == O_CONCAT && arg[2].arg_type == A_EXPR) {
+ arg2 = arg[2].arg_ptr.arg_arg;
+ if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) {
+ arg->arg_type = O_RCAT;
+ arg[2].arg_type = arg2[1].arg_type;
+ arg[2].arg_ptr = arg2[1].arg_ptr;
+ free_arg(arg2);
+ }
+ }
+ return arg;
+}
+
+ARG *
+stab2arg(atype,stab)
+int atype;
+register STAB *stab;
+{
+ register ARG *arg;
+
+ arg = op_new(1);
+ arg->arg_type = O_ITEM;
+ arg[1].arg_type = atype;
+ arg[1].arg_ptr.arg_stab = stab;
+ return arg;
+}
+
+ARG *
+cval_to_arg(cval)
+register char *cval;
+{
+ register ARG *arg;
+
+ arg = op_new(1);
+ arg->arg_type = O_ITEM;
+ arg[1].arg_type = A_SINGLE;
+ arg[1].arg_ptr.arg_str = str_make(cval,0);
+ Safefree(cval);
+ return arg;
+}
+
+ARG *
+op_new(numargs)
+int numargs;
+{
+ register ARG *arg;
+
+ Newz(203,arg, numargs + 1, ARG);
+ arg->arg_ptr.arg_str = Str_new(21,0);
+ arg->arg_len = numargs;
+ return arg;
+}
+
+void
+free_arg(arg)
+ARG *arg;
+{
+ str_free(arg->arg_ptr.arg_str);
+ Safefree(arg);
+}
+
+ARG *
+make_match(type,expr,spat)
+int type;
+ARG *expr;
+SPAT *spat;
+{
+ register ARG *arg;
+
+ arg = make_op(type,2,expr,Nullarg,Nullarg);
+
+ arg[2].arg_type = A_SPAT|A_DONT;
+ arg[2].arg_ptr.arg_spat = spat;
+#ifdef DEBUGGING
+ if (debug & 16)
+ fprintf(stderr,"make_match SPAT=%lx\n",(long)spat);
+#endif
+
+ if (type == O_SUBST || type == O_NSUBST) {
+ if (arg[1].arg_type != A_STAB) {
+ yyerror("Illegal lvalue");
+ }
+ arg[1].arg_type = A_LVAL;
+ }
+ return arg;
+}
+
+ARG *
+cmd_to_arg(cmd)
+CMD *cmd;
+{
+ register ARG *arg;
+
+ arg = op_new(1);
+ arg->arg_type = O_ITEM;
+ arg[1].arg_type = A_CMD;
+ arg[1].arg_ptr.arg_cmd = cmd;
+ return arg;
+}
+
+/* Check two expressions to see if there is any identifier in common */
+
+static int
+nothing_in_common(arg1,arg2)
+ARG *arg1;
+ARG *arg2;
+{
+ static int thisexpr = 0; /* I don't care if this wraps */
+
+ thisexpr++;
+ if (arg_common(arg1,thisexpr,1))
+ return 0; /* hit eval or do {} */
+ stab_lastexpr(defstab) = thisexpr; /* pretend to hit @_ */
+ if (arg_common(arg2,thisexpr,0))
+ return 0; /* hit identifier again */
+ return 1;
+}
+
+/* Recursively descend an expression and mark any identifier or check
+ * it to see if it was marked already.
+ */
+
+static int
+arg_common(arg,exprnum,marking)
+register ARG *arg;
+int exprnum;
+int marking;
+{
+ register int i;
+
+ if (!arg)
+ return 0;
+ for (i = arg->arg_len; i >= 1; i--) {
+ switch (arg[i].arg_type & A_MASK) {
+ case A_NULL:
+ break;
+ case A_LEXPR:
+ case A_EXPR:
+ if (arg_common(arg[i].arg_ptr.arg_arg,exprnum,marking))
+ return 1;
+ break;
+ case A_CMD:
+ return 1; /* assume hanky panky */
+ case A_STAR:
+ case A_LSTAR:
+ case A_STAB:
+ case A_LVAL:
+ case A_ARYLEN:
+ case A_LARYLEN:
+ if (marking)
+ stab_lastexpr(arg[i].arg_ptr.arg_stab) = exprnum;
+ else if (stab_lastexpr(arg[i].arg_ptr.arg_stab) == exprnum)
+ return 1;
+ break;
+ case A_DOUBLE:
+ case A_BACKTICK:
+ {
+ register char *s = arg[i].arg_ptr.arg_str->str_ptr;
+ register char *send = s + arg[i].arg_ptr.arg_str->str_cur;
+ register STAB *stab;
+
+ while (*s) {
+ if (*s == '$' && s[1]) {
+ s = scanident(s,send,tokenbuf);
+ stab = stabent(tokenbuf,TRUE);
+ if (marking)
+ stab_lastexpr(stab) = exprnum;
+ else if (stab_lastexpr(stab) == exprnum)
+ return 1;
+ continue;
+ }
+ else if (*s == '\\' && s[1])
+ s++;
+ s++;
+ }
+ }
+ break;
+ case A_SPAT:
+ if (spat_common(arg[i].arg_ptr.arg_spat,exprnum,marking))
+ return 1;
+ break;
+ case A_READ:
+ case A_INDREAD:
+ case A_GLOB:
+ case A_WORD:
+ case A_SINGLE:
+ break;
+ }
+ }
+ switch (arg->arg_type) {
+ case O_ARRAY:
+ case O_LARRAY:
+ if ((arg[1].arg_type & A_MASK) == A_STAB)
+ (void)aadd(arg[1].arg_ptr.arg_stab);
+ break;
+ case O_HASH:
+ case O_LHASH:
+ if ((arg[1].arg_type & A_MASK) == A_STAB)
+ (void)hadd(arg[1].arg_ptr.arg_stab);
+ break;
+ case O_EVAL:
+ case O_SUBR:
+ case O_DBSUBR:
+ return 1;
+ }
+ return 0;
+}
+
+static int
+spat_common(spat,exprnum,marking)
+register SPAT *spat;
+int exprnum;
+int marking;
+{
+ if (spat->spat_runtime)
+ if (arg_common(spat->spat_runtime,exprnum,marking))
+ return 1;
+ if (spat->spat_repl) {
+ if (arg_common(spat->spat_repl,exprnum,marking))
+ return 1;
+ }
+ return 0;
+}
--- /dev/null
+#!/bin/sh
+
+: if this fails, just run all the .SH files by hand
+. ./config.sh
+
+rm -f x2p/config.sh
+cp cppstdin x2p
+
+echo " "
+echo "Doing variable substitutions on .SH files..."
+set x `awk '{print $1}' <MANIFEST | grep '\.SH'`
+shift
+case $# in
+0) set x *.SH; shift;;
+esac
+if test ! -f $1; then
+ shift
+fi
+for file in $*; do
+ set X
+ shift
+ chmod +x $file
+ case "$file" in
+ */*)
+ dir=`expr X$file : 'X\(.*\)/'`
+ file=`expr X$file : 'X.*/\(.*\)'`
+ (cd $dir && . ./$file)
+ ;;
+ *)
+ . ./$file
+ ;;
+ esac
+done
+if test -f config.h.SH; then
+ if test ! -f config.h; then
+ : oops, they left it out of MANIFEST, probably, so do it anyway.
+ . ./config.h.SH
+ fi
+fi
+exit 0
--- /dev/null
+/* $RCSfile: doarg.c,v $$Revision: 4.0.1.5 $$Date: 91/11/11 16:31:58 $
+ *
+ * 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: doarg.c,v $
+ * 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.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+#include <signal.h>
+#endif
+
+extern unsigned char fold[];
+
+#ifdef BUGGY_MSC
+ #pragma function(memcmp)
+#endif /* BUGGY_MSC */
+
+int
+do_subst(str,arg,sp)
+STR *str;
+ARG *arg;
+int sp;
+{
+ register SPAT *spat;
+ SPAT *rspat;
+ register STR *dstr;
+ register char *s = str_get(str);
+ char *strend = s + str->str_cur;
+ register char *m;
+ char *c;
+ register char *d;
+ int clen;
+ int iters = 0;
+ int maxiters = (strend - s) + 10;
+ register int i;
+ bool once;
+ char *orig;
+ int safebase;
+
+ rspat = spat = arg[2].arg_ptr.arg_spat;
+ if (!spat || !s)
+ fatal("panic: do_subst");
+ else if (spat->spat_runtime) {
+ nointrp = "|)";
+ (void)eval(spat->spat_runtime,G_SCALAR,sp);
+ m = str_get(dstr = stack->ary_array[sp+1]);
+ nointrp = "";
+ if (spat->spat_regexp) {
+ regfree(spat->spat_regexp);
+ spat->spat_regexp = Null(REGEXP*); /* required if regcomp pukes */
+ }
+ spat->spat_regexp = regcomp(m,m+dstr->str_cur,
+ spat->spat_flags & SPAT_FOLD);
+ if (spat->spat_flags & SPAT_KEEP) {
+ scanconst(spat, m, dstr->str_cur);
+ arg_free(spat->spat_runtime); /* it won't change, so */
+ spat->spat_runtime = Nullarg; /* no point compiling again */
+ hoistmust(spat);
+ if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
+ curcmd->c_flags &= ~CF_OPTIMIZE;
+ opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
+ }
+ }
+ }
+#ifdef DEBUGGING
+ if (debug & 8) {
+ deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
+ }
+#endif
+ safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) &&
+ !sawampersand);
+ if (!spat->spat_regexp->prelen && lastspat)
+ spat = lastspat;
+ orig = m = s;
+ if (hint) {
+ if (hint < s || hint > strend)
+ fatal("panic: hint in do_match");
+ s = hint;
+ hint = Nullch;
+ if (spat->spat_regexp->regback >= 0) {
+ s -= spat->spat_regexp->regback;
+ if (s < m)
+ s = m;
+ }
+ else
+ s = m;
+ }
+ else if (spat->spat_short) {
+ if (spat->spat_flags & SPAT_SCANFIRST) {
+ if (str->str_pok & SP_STUDIED) {
+ if (screamfirst[spat->spat_short->str_rare] < 0)
+ goto nope;
+ else if (!(s = screaminstr(str,spat->spat_short)))
+ goto nope;
+ }
+#ifndef lint
+ else if (!(s = fbminstr((unsigned char*)s, (unsigned char*)strend,
+ spat->spat_short)))
+ goto nope;
+#endif
+ if (s && spat->spat_regexp->regback >= 0) {
+ ++spat->spat_short->str_u.str_useful;
+ s -= spat->spat_regexp->regback;
+ if (s < m)
+ s = m;
+ }
+ else
+ s = m;
+ }
+ else if (!multiline && (*spat->spat_short->str_ptr != *s ||
+ bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) ))
+ goto nope;
+ if (--spat->spat_short->str_u.str_useful < 0) {
+ str_free(spat->spat_short);
+ spat->spat_short = Nullstr; /* opt is being useless */
+ }
+ }
+ once = !(rspat->spat_flags & SPAT_GLOBAL);
+ if (rspat->spat_flags & SPAT_CONST) { /* known replacement string? */
+ if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
+ dstr = rspat->spat_repl[1].arg_ptr.arg_str;
+ else { /* constant over loop, anyway */
+ (void)eval(rspat->spat_repl,G_SCALAR,sp);
+ dstr = stack->ary_array[sp+1];
+ }
+ c = str_get(dstr);
+ clen = dstr->str_cur;
+ if (clen <= spat->spat_regexp->minlen) {
+ /* can do inplace substitution */
+ if (regexec(spat->spat_regexp, s, strend, orig, 0,
+ str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) {
+ if (spat->spat_regexp->subbase) /* oops, no we can't */
+ goto long_way;
+ d = s;
+ lastspat = spat;
+ str->str_pok = SP_VALID; /* disable possible screamer */
+ if (once) {
+ m = spat->spat_regexp->startp[0];
+ d = spat->spat_regexp->endp[0];
+ s = orig;
+ if (m - s > strend - d) { /* faster to shorten from end */
+ if (clen) {
+ (void)bcopy(c, m, clen);
+ m += clen;
+ }
+ i = strend - d;
+ if (i > 0) {
+ (void)bcopy(d, m, i);
+ m += i;
+ }
+ *m = '\0';
+ str->str_cur = m - s;
+ STABSET(str);
+ str_numset(arg->arg_ptr.arg_str, 1.0);
+ stack->ary_array[++sp] = arg->arg_ptr.arg_str;
+ return sp;
+ }
+ /*SUPPRESS 560*/
+ else if (i = m - s) { /* faster from front */
+ d -= clen;
+ m = d;
+ str_chop(str,d-i);
+ s += i;
+ while (i--)
+ *--d = *--s;
+ if (clen)
+ (void)bcopy(c, m, clen);
+ STABSET(str);
+ str_numset(arg->arg_ptr.arg_str, 1.0);
+ stack->ary_array[++sp] = arg->arg_ptr.arg_str;
+ return sp;
+ }
+ else if (clen) {
+ d -= clen;
+ str_chop(str,d);
+ (void)bcopy(c,d,clen);
+ STABSET(str);
+ str_numset(arg->arg_ptr.arg_str, 1.0);
+ stack->ary_array[++sp] = arg->arg_ptr.arg_str;
+ return sp;
+ }
+ else {
+ str_chop(str,d);
+ STABSET(str);
+ str_numset(arg->arg_ptr.arg_str, 1.0);
+ stack->ary_array[++sp] = arg->arg_ptr.arg_str;
+ return sp;
+ }
+ /* NOTREACHED */
+ }
+ do {
+ if (iters++ > maxiters)
+ fatal("Substitution loop");
+ m = spat->spat_regexp->startp[0];
+ /*SUPPRESS 560*/
+ if (i = m - s) {
+ if (s != d)
+ (void)bcopy(s,d,i);
+ d += i;
+ }
+ if (clen) {
+ (void)bcopy(c,d,clen);
+ d += clen;
+ }
+ s = spat->spat_regexp->endp[0];
+ } while (regexec(spat->spat_regexp, s, strend, orig, s == m,
+ Nullstr, TRUE)); /* (don't match same null twice) */
+ if (s != d) {
+ i = strend - s;
+ str->str_cur = d - str->str_ptr + i;
+ (void)bcopy(s,d,i+1); /* include the Null */
+ }
+ STABSET(str);
+ str_numset(arg->arg_ptr.arg_str, (double)iters);
+ stack->ary_array[++sp] = arg->arg_ptr.arg_str;
+ return sp;
+ }
+ str_numset(arg->arg_ptr.arg_str, 0.0);
+ stack->ary_array[++sp] = arg->arg_ptr.arg_str;
+ return sp;
+ }
+ }
+ else
+ c = Nullch;
+ if (regexec(spat->spat_regexp, s, strend, orig, 0,
+ str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) {
+ long_way:
+ dstr = Str_new(25,str_len(str));
+ str_nset(dstr,m,s-m);
+ if (spat->spat_regexp->subbase)
+ curspat = spat;
+ lastspat = spat;
+ do {
+ if (iters++ > maxiters)
+ fatal("Substitution loop");
+ if (spat->spat_regexp->subbase
+ && spat->spat_regexp->subbase != orig) {
+ m = s;
+ s = orig;
+ orig = spat->spat_regexp->subbase;
+ s = orig + (m - s);
+ strend = s + (strend - m);
+ }
+ m = spat->spat_regexp->startp[0];
+ str_ncat(dstr,s,m-s);
+ s = spat->spat_regexp->endp[0];
+ if (c) {
+ if (clen)
+ str_ncat(dstr,c,clen);
+ }
+ else {
+ char *mysubbase = spat->spat_regexp->subbase;
+
+ spat->spat_regexp->subbase = Nullch; /* so recursion works */
+ (void)eval(rspat->spat_repl,G_SCALAR,sp);
+ str_scat(dstr,stack->ary_array[sp+1]);
+ if (spat->spat_regexp->subbase)
+ Safefree(spat->spat_regexp->subbase);
+ spat->spat_regexp->subbase = mysubbase;
+ }
+ if (once)
+ break;
+ } while (regexec(spat->spat_regexp, s, strend, orig, s == m, Nullstr,
+ safebase));
+ str_ncat(dstr,s,strend - s);
+ str_replace(str,dstr);
+ STABSET(str);
+ str_numset(arg->arg_ptr.arg_str, (double)iters);
+ stack->ary_array[++sp] = arg->arg_ptr.arg_str;
+ return sp;
+ }
+ str_numset(arg->arg_ptr.arg_str, 0.0);
+ stack->ary_array[++sp] = arg->arg_ptr.arg_str;
+ return sp;
+
+nope:
+ ++spat->spat_short->str_u.str_useful;
+ str_numset(arg->arg_ptr.arg_str, 0.0);
+ stack->ary_array[++sp] = arg->arg_ptr.arg_str;
+ return sp;
+}
+#ifdef BUGGY_MSC
+ #pragma intrinsic(memcmp)
+#endif /* BUGGY_MSC */
+
+int
+do_trans(str,arg)
+STR *str;
+ARG *arg;
+{
+ register short *tbl;
+ register char *s;
+ register int matches = 0;
+ register int ch;
+ register char *send;
+ register char *d;
+ register int squash = arg[2].arg_len & 1;
+
+ tbl = (short*) arg[2].arg_ptr.arg_cval;
+ s = str_get(str);
+ send = s + str->str_cur;
+ if (!tbl || !s)
+ fatal("panic: do_trans");
+#ifdef DEBUGGING
+ if (debug & 8) {
+ deb("2.TBL\n");
+ }
+#endif
+ if (!arg[2].arg_len) {
+ while (s < send) {
+ if ((ch = tbl[*s & 0377]) >= 0) {
+ matches++;
+ *s = ch;
+ }
+ s++;
+ }
+ }
+ else {
+ d = s;
+ while (s < send) {
+ if ((ch = tbl[*s & 0377]) >= 0) {
+ *d = ch;
+ if (matches++ && squash) {
+ if (d[-1] == *d)
+ matches--;
+ else
+ d++;
+ }
+ else
+ d++;
+ }
+ else if (ch == -1) /* -1 is unmapped character */
+ *d++ = *s; /* -2 is delete character */
+ s++;
+ }
+ matches += send - d; /* account for disappeared chars */
+ *d = '\0';
+ str->str_cur = d - str->str_ptr;
+ }
+ STABSET(str);
+ return matches;
+}
+
+void
+do_join(str,arglast)
+register STR *str;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int items = arglast[2] - sp;
+ register char *delim = str_get(st[sp]);
+ int delimlen = st[sp]->str_cur;
+
+ st += ++sp;
+ if (items-- > 0)
+ str_sset(str, *st++);
+ else
+ str_set(str,"");
+ if (delimlen) {
+ for (; items > 0; items--,st++) {
+ str_ncat(str,delim,delimlen);
+ str_scat(str,*st);
+ }
+ }
+ else {
+ for (; items > 0; items--,st++)
+ str_scat(str,*st);
+ }
+ STABSET(str);
+}
+
+void
+do_pack(str,arglast)
+register STR *str;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int items;
+ register char *pat = str_get(st[sp]);
+ register char *patend = pat + st[sp]->str_cur;
+ register int len;
+ int datumtype;
+ STR *fromstr;
+ /*SUPPRESS 442*/
+ static char *null10 = "\0\0\0\0\0\0\0\0\0\0";
+ static char *space10 = " ";
+
+ /* These must not be in registers: */
+ char achar;
+ short ashort;
+ int aint;
+ unsigned int auint;
+ long along;
+ unsigned long aulong;
+#ifdef QUAD
+ quad aquad;
+ unsigned quad auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+
+ items = arglast[2] - sp;
+ st += ++sp;
+ str_nset(str,"",0);
+ while (pat < patend) {
+#define NEXTFROM (items-- > 0 ? *st++ : &str_no)
+ datumtype = *pat++;
+ if (*pat == '*') {
+ len = index("@Xxu",datumtype) ? 0 : items;
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = 1;
+ switch(datumtype) {
+ default:
+ break;
+ case '%':
+ fatal("% may only be used in unpack");
+ case '@':
+ len -= str->str_cur;
+ if (len > 0)
+ goto grow;
+ len = -len;
+ if (len > 0)
+ goto shrink;
+ break;
+ case 'X':
+ shrink:
+ if (str->str_cur < len)
+ fatal("X outside of string");
+ str->str_cur -= len;
+ str->str_ptr[str->str_cur] = '\0';
+ break;
+ case 'x':
+ grow:
+ while (len >= 10) {
+ str_ncat(str,null10,10);
+ len -= 10;
+ }
+ str_ncat(str,null10,len);
+ break;
+ case 'A':
+ case 'a':
+ fromstr = NEXTFROM;
+ aptr = str_get(fromstr);
+ if (pat[-1] == '*')
+ len = fromstr->str_cur;
+ if (fromstr->str_cur > len)
+ str_ncat(str,aptr,len);
+ else {
+ str_ncat(str,aptr,fromstr->str_cur);
+ len -= fromstr->str_cur;
+ if (datumtype == 'A') {
+ while (len >= 10) {
+ str_ncat(str,space10,10);
+ len -= 10;
+ }
+ str_ncat(str,space10,len);
+ }
+ else {
+ while (len >= 10) {
+ str_ncat(str,null10,10);
+ len -= 10;
+ }
+ str_ncat(str,null10,len);
+ }
+ }
+ break;
+ case 'B':
+ case 'b':
+ {
+ char *savepat = pat;
+ int saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = str_get(fromstr);
+ if (pat[-1] == '*')
+ len = fromstr->str_cur;
+ pat = aptr;
+ aint = str->str_cur;
+ str->str_cur += (len+7)/8;
+ STR_GROW(str, str->str_cur + 1);
+ aptr = str->str_ptr + aint;
+ if (len > fromstr->str_cur)
+ len = fromstr->str_cur;
+ aint = len;
+ items = 0;
+ if (datumtype == 'B') {
+ for (len = 0; len++ < aint;) {
+ items |= *pat++ & 1;
+ if (len & 7)
+ items <<= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (*pat++ & 1)
+ items |= 128;
+ if (len & 7)
+ items >>= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 7) {
+ if (datumtype == 'B')
+ items <<= 7 - (aint & 7);
+ else
+ items >>= 7 - (aint & 7);
+ *aptr++ = items & 0xff;
+ }
+ pat = str->str_ptr + str->str_cur;
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'H':
+ case 'h':
+ {
+ char *savepat = pat;
+ int saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = str_get(fromstr);
+ if (pat[-1] == '*')
+ len = fromstr->str_cur;
+ pat = aptr;
+ aint = str->str_cur;
+ str->str_cur += (len+1)/2;
+ STR_GROW(str, str->str_cur + 1);
+ aptr = str->str_ptr + aint;
+ if (len > fromstr->str_cur)
+ len = fromstr->str_cur;
+ aint = len;
+ items = 0;
+ if (datumtype == 'H') {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*pat))
+ items |= ((*pat++ & 15) + 9) & 15;
+ else
+ items |= *pat++ & 15;
+ if (len & 1)
+ items <<= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*pat))
+ items |= (((*pat++ & 15) + 9) & 15) << 4;
+ else
+ items |= (*pat++ & 15) << 4;
+ if (len & 1)
+ items >>= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 1)
+ *aptr++ = items & 0xff;
+ pat = str->str_ptr + str->str_cur;
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'C':
+ case 'c':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = (int)str_gnum(fromstr);
+ achar = aint;
+ str_ncat(str,&achar,sizeof(char));
+ }
+ break;
+ /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ afloat = (float)str_gnum(fromstr);
+ str_ncat(str, (char *)&afloat, sizeof (float));
+ }
+ break;
+ case 'd':
+ case 'D':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ adouble = (double)str_gnum(fromstr);
+ str_ncat(str, (char *)&adouble, sizeof (double));
+ }
+ break;
+ case 'n':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (short)str_gnum(fromstr);
+#ifdef HAS_HTONS
+ ashort = htons(ashort);
+#endif
+ str_ncat(str,(char*)&ashort,sizeof(short));
+ }
+ break;
+ case 'v':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (short)str_gnum(fromstr);
+#ifdef HAS_HTOVS
+ ashort = htovs(ashort);
+#endif
+ str_ncat(str,(char*)&ashort,sizeof(short));
+ }
+ break;
+ case 'S':
+ case 's':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (short)str_gnum(fromstr);
+ str_ncat(str,(char*)&ashort,sizeof(short));
+ }
+ break;
+ case 'I':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auint = U_I(str_gnum(fromstr));
+ str_ncat(str,(char*)&auint,sizeof(unsigned int));
+ }
+ break;
+ case 'i':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = (int)str_gnum(fromstr);
+ str_ncat(str,(char*)&aint,sizeof(int));
+ }
+ break;
+ case 'N':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(str_gnum(fromstr));
+#ifdef HAS_HTONL
+ aulong = htonl(aulong);
+#endif
+ str_ncat(str,(char*)&aulong,sizeof(unsigned long));
+ }
+ break;
+ case 'V':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(str_gnum(fromstr));
+#ifdef HAS_HTOVL
+ aulong = htovl(aulong);
+#endif
+ str_ncat(str,(char*)&aulong,sizeof(unsigned long));
+ }
+ break;
+ case 'L':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(str_gnum(fromstr));
+ str_ncat(str,(char*)&aulong,sizeof(unsigned long));
+ }
+ break;
+ case 'l':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = (long)str_gnum(fromstr);
+ str_ncat(str,(char*)&along,sizeof(long));
+ }
+ break;
+#ifdef QUAD
+ case 'Q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auquad = (unsigned quad)str_gnum(fromstr);
+ str_ncat(str,(char*)&auquad,sizeof(unsigned quad));
+ }
+ break;
+ case 'q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aquad = (quad)str_gnum(fromstr);
+ str_ncat(str,(char*)&aquad,sizeof(quad));
+ }
+ break;
+#endif /* QUAD */
+ case 'p':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aptr = str_get(fromstr);
+ str_ncat(str,(char*)&aptr,sizeof(char*));
+ }
+ break;
+ case 'u':
+ fromstr = NEXTFROM;
+ aptr = str_get(fromstr);
+ aint = fromstr->str_cur;
+ STR_GROW(str,aint * 4 / 3);
+ if (len <= 1)
+ len = 45;
+ else
+ len = len / 3 * 3;
+ while (aint > 0) {
+ int todo;
+
+ if (aint > len)
+ todo = len;
+ else
+ todo = aint;
+ doencodes(str, aptr, todo);
+ aint -= todo;
+ aptr += todo;
+ }
+ break;
+ }
+ }
+ STABSET(str);
+}
+#undef NEXTFROM
+
+doencodes(str, s, len)
+register STR *str;
+register char *s;
+register int len;
+{
+ char hunk[5];
+
+ *hunk = len + ' ';
+ str_ncat(str, hunk, 1);
+ hunk[4] = '\0';
+ while (len > 0) {
+ hunk[0] = ' ' + (077 & (*s >> 2));
+ hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
+ hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
+ hunk[3] = ' ' + (077 & (s[2] & 077));
+ str_ncat(str, hunk, 4);
+ s += 3;
+ len -= 3;
+ }
+ for (s = str->str_ptr; *s; s++) {
+ if (*s == ' ')
+ *s = '`';
+ }
+ str_ncat(str, "\n", 1);
+}
+
+void
+do_sprintf(str,len,sarg)
+register STR *str;
+register int len;
+register STR **sarg;
+{
+ register char *s;
+ register char *t;
+ register char *f;
+ bool dolong;
+#ifdef QUAD
+ bool doquad;
+#endif /* QUAD */
+ char ch;
+ static STR *sargnull = &str_no;
+ register char *send;
+ register STR *arg;
+ char *xs;
+ int xlen;
+ int pre;
+ int post;
+ double value;
+
+ str_set(str,"");
+ len--; /* don't count pattern string */
+ t = s = str_get(*sarg);
+ send = s + (*sarg)->str_cur;
+ sarg++;
+ for ( ; ; len--) {
+
+ /*SUPPRESS 560*/
+ if (len <= 0 || !(arg = *sarg++))
+ arg = sargnull;
+
+ /*SUPPRESS 530*/
+ for ( ; t < send && *t != '%'; t++) ;
+ if (t >= send)
+ break; /* end of format string, ignore extra args */
+ f = t;
+ *buf = '\0';
+ xs = buf;
+#ifdef QUAD
+ doquad =
+#endif /* QUAD */
+ dolong = FALSE;
+ pre = post = 0;
+ for (t++; t < send; t++) {
+ switch (*t) {
+ default:
+ ch = *(++t);
+ *t = '\0';
+ (void)sprintf(xs,f);
+ len++, sarg--;
+ xlen = strlen(xs);
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ case '.': case '#': case '-': case '+': case ' ':
+ continue;
+ case 'l':
+#ifdef QUAD
+ if (dolong) {
+ dolong = FALSE;
+ doquad = TRUE;
+ } else
+#endif
+ dolong = TRUE;
+ continue;
+ case 'c':
+ ch = *(++t);
+ *t = '\0';
+ xlen = (int)str_gnum(arg);
+ if (strEQ(f,"%c")) { /* some printfs fail on null chars */
+ *xs = xlen;
+ xs[1] = '\0';
+ xlen = 1;
+ }
+ else {
+ (void)sprintf(xs,f,xlen);
+ xlen = strlen(xs);
+ }
+ break;
+ case 'D':
+ dolong = TRUE;
+ /* FALL THROUGH */
+ case 'd':
+ ch = *(++t);
+ *t = '\0';
+#ifdef QUAD
+ if (doquad)
+ (void)sprintf(buf,s,(quad)str_gnum(arg));
+ else
+#endif
+ if (dolong)
+ (void)sprintf(xs,f,(long)str_gnum(arg));
+ else
+ (void)sprintf(xs,f,(int)str_gnum(arg));
+ xlen = strlen(xs);
+ break;
+ case 'X': case 'O':
+ dolong = TRUE;
+ /* FALL THROUGH */
+ case 'x': case 'o': case 'u':
+ ch = *(++t);
+ *t = '\0';
+ value = str_gnum(arg);
+#ifdef QUAD
+ if (doquad)
+ (void)sprintf(buf,s,(unsigned quad)value);
+ else
+#endif
+ if (dolong)
+ (void)sprintf(xs,f,U_L(value));
+ else
+ (void)sprintf(xs,f,U_I(value));
+ xlen = strlen(xs);
+ break;
+ case 'E': case 'e': case 'f': case 'G': case 'g':
+ ch = *(++t);
+ *t = '\0';
+ (void)sprintf(xs,f,str_gnum(arg));
+ xlen = strlen(xs);
+ break;
+ case 's':
+ ch = *(++t);
+ *t = '\0';
+ xs = str_get(arg);
+ xlen = arg->str_cur;
+ if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xs[3] == '\0'
+ && xlen == sizeof(STBP)) {
+ STR *tmpstr = Str_new(24,0);
+
+ stab_fullname(tmpstr, ((STAB*)arg)); /* a stab value! */
+ sprintf(tokenbuf,"*%s",tmpstr->str_ptr);
+ /* reformat to non-binary */
+ xs = tokenbuf;
+ xlen = strlen(tokenbuf);
+ str_free(tmpstr);
+ }
+ if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
+ break; /* so handle simple cases */
+ }
+ else if (f[1] == '-') {
+ char *mp = index(f, '.');
+ int min = atoi(f+2);
+
+ if (xlen < min)
+ post = min - xlen;
+ else if (mp) {
+ int max = atoi(mp+1);
+
+ if (xlen > max)
+ xlen = max;
+ }
+ break;
+ }
+ else if (isDIGIT(f[1])) {
+ char *mp = index(f, '.');
+ int min = atoi(f+1);
+
+ if (xlen < min)
+ pre = min - xlen;
+ else if (mp) {
+ int max = atoi(mp+1);
+
+ if (xlen > max)
+ xlen = max;
+ }
+ break;
+ }
+ strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
+ *t = ch;
+ (void)sprintf(buf,tokenbuf+64,xs);
+ xs = buf;
+ xlen = strlen(xs);
+ break;
+ }
+ /* end of switch, copy results */
+ *t = ch;
+ STR_GROW(str, str->str_cur + (f - s) + xlen + 1 + pre + post);
+ str_ncat(str, s, f - s);
+ if (pre) {
+ repeatcpy(str->str_ptr + str->str_cur, " ", 1, pre);
+ str->str_cur += pre;
+ }
+ str_ncat(str, xs, xlen);
+ if (post) {
+ repeatcpy(str->str_ptr + str->str_cur, " ", 1, post);
+ str->str_cur += post;
+ }
+ s = t;
+ break; /* break from for loop */
+ }
+ }
+ str_ncat(str, s, t - s);
+ STABSET(str);
+}
+
+STR *
+do_push(ary,arglast)
+register ARRAY *ary;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int items = arglast[2] - sp;
+ register STR *str = &str_undef;
+
+ for (st += ++sp; items > 0; items--,st++) {
+ str = Str_new(26,0);
+ if (*st)
+ str_sset(str,*st);
+ (void)apush(ary,str);
+ }
+ return str;
+}
+
+void
+do_unshift(ary,arglast)
+register ARRAY *ary;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int items = arglast[2] - sp;
+ register STR *str;
+ register int i;
+
+ aunshift(ary,items);
+ i = 0;
+ for (st += ++sp; i < items; i++,st++) {
+ str = Str_new(27,0);
+ str_sset(str,*st);
+ (void)astore(ary,i,str);
+ }
+}
+
+int
+do_subr(arg,gimme,arglast)
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int items = arglast[2] - sp;
+ register SUBR *sub;
+ STR *str;
+ STAB *stab;
+ int oldsave = savestack->ary_fill;
+ int oldtmps_base = tmps_base;
+ int hasargs = ((arg[2].arg_type & A_MASK) != A_NULL);
+ register CSV *csv;
+
+ if ((arg[1].arg_type & A_MASK) == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else {
+ STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
+
+ if (tmpstr)
+ stab = stabent(str_get(tmpstr),TRUE);
+ else
+ stab = Nullstab;
+ }
+ if (!stab)
+ fatal("Undefined subroutine called");
+ if (!(sub = stab_sub(stab))) {
+ STR *tmpstr = arg[0].arg_ptr.arg_str;
+
+ stab_fullname(tmpstr, stab);
+ fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr);
+ }
+ if (arg->arg_type == O_DBSUBR && !sub->usersub) {
+ str = stab_val(DBsub);
+ saveitem(str);
+ stab_fullname(str,stab);
+ sub = stab_sub(DBsub);
+ if (!sub)
+ fatal("No DBsub routine");
+ }
+ str = Str_new(15, sizeof(CSV));
+ str->str_state = SS_SCSV;
+ (void)apush(savestack,str);
+ csv = (CSV*)str->str_ptr;
+ csv->sub = sub;
+ csv->stab = stab;
+ csv->curcsv = curcsv;
+ csv->curcmd = curcmd;
+ csv->depth = sub->depth;
+ csv->wantarray = gimme;
+ csv->hasargs = hasargs;
+ curcsv = csv;
+ if (sub->usersub) {
+ csv->hasargs = 0;
+ csv->savearray = Null(ARRAY*);;
+ csv->argarray = Null(ARRAY*);
+ st[sp] = arg->arg_ptr.arg_str;
+ if (!hasargs)
+ items = 0;
+ return (*sub->usersub)(sub->userindex,sp,items);
+ }
+ if (hasargs) {
+ csv->savearray = stab_xarray(defstab);
+ csv->argarray = afake(defstab, items, &st[sp+1]);
+ stab_xarray(defstab) = csv->argarray;
+ }
+ sub->depth++;
+ if (sub->depth >= 2) { /* save temporaries on recursion? */
+ if (sub->depth == 100 && dowarn)
+ warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
+ savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
+ }
+ tmps_base = tmps_max;
+ sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */
+ st = stack->ary_array;
+
+ tmps_base = oldtmps_base;
+ for (items = arglast[0] + 1; items <= sp; items++)
+ st[items] = str_mortal(st[items]);
+ /* in case restore wipes old str */
+ restorelist(oldsave);
+ return sp;
+}
+
+int
+do_assign(arg,gimme,arglast)
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+
+ register STR **st = stack->ary_array;
+ STR **firstrelem = st + arglast[1] + 1;
+ STR **firstlelem = st + arglast[0] + 1;
+ STR **lastrelem = st + arglast[2];
+ STR **lastlelem = st + arglast[1];
+ register STR **relem;
+ register STR **lelem;
+
+ register STR *str;
+ register ARRAY *ary;
+ register int makelocal;
+ HASH *hash;
+ int i;
+
+ makelocal = (arg->arg_flags & AF_LOCAL) != 0;
+ localizing = makelocal;
+ 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 (arg->arg_flags & AF_COMMON) {
+ for (relem = firstrelem; relem <= lastrelem; relem++) {
+ /*SUPPRESS 560*/
+ if (str = *relem)
+ *relem = str_mortal(str);
+ }
+ }
+ relem = firstrelem;
+ lelem = firstlelem;
+ ary = Null(ARRAY*);
+ hash = Null(HASH*);
+ while (lelem <= lastlelem) {
+ str = *lelem++;
+ if (str->str_state >= SS_HASH) {
+ if (str->str_state == SS_ARY) {
+ if (makelocal)
+ ary = saveary(str->str_u.str_stab);
+ else {
+ ary = stab_array(str->str_u.str_stab);
+ ary->ary_fill = -1;
+ }
+ i = 0;
+ while (relem <= lastrelem) { /* gobble up all the rest */
+ str = Str_new(28,0);
+ if (*relem)
+ str_sset(str,*relem);
+ *(relem++) = str;
+ (void)astore(ary,i++,str);
+ }
+ }
+ else if (str->str_state == SS_HASH) {
+ char *tmps;
+ STR *tmpstr;
+ int magic = 0;
+ STAB *tmpstab = str->str_u.str_stab;
+
+ if (makelocal)
+ hash = savehash(str->str_u.str_stab);
+ else {
+ hash = stab_hash(str->str_u.str_stab);
+ if (tmpstab == envstab) {
+ magic = 'E';
+ environ[0] = Nullch;
+ }
+ else if (tmpstab == sigstab) {
+ magic = 'S';
+#ifndef NSIG
+#define NSIG 32
+#endif
+ for (i = 1; i < NSIG; i++)
+ signal(i, SIG_DFL); /* crunch, crunch, crunch */
+ }
+#ifdef SOME_DBM
+ else if (hash->tbl_dbm)
+ magic = 'D';
+#endif
+ hclear(hash, magic == 'D'); /* wipe any dbm file too */
+
+ }
+ while (relem < lastrelem) { /* gobble up all the rest */
+ if (*relem)
+ str = *(relem++);
+ else
+ str = &str_no, relem++;
+ tmps = str_get(str);
+ tmpstr = Str_new(29,0);
+ if (*relem)
+ str_sset(tmpstr,*relem); /* value */
+ *(relem++) = tmpstr;
+ (void)hstore(hash,tmps,str->str_cur,tmpstr,0);
+ if (magic) {
+ str_magic(tmpstr, tmpstab, magic, tmps, str->str_cur);
+ stabset(tmpstr->str_magic, tmpstr);
+ }
+ }
+ }
+ else
+ fatal("panic: do_assign");
+ }
+ else {
+ if (makelocal)
+ saveitem(str);
+ if (relem <= lastrelem) {
+ str_sset(str, *relem);
+ *(relem++) = str;
+ }
+ else {
+ str_sset(str, &str_undef);
+ if (gimme == G_ARRAY) {
+ i = ++lastrelem - firstrelem;
+ relem++; /* tacky, I suppose */
+ astore(stack,i,str);
+ if (st != stack->ary_array) {
+ st = stack->ary_array;
+ firstrelem = st + arglast[1] + 1;
+ firstlelem = st + arglast[0] + 1;
+ lastlelem = st + arglast[1];
+ lastrelem = st + i;
+ relem = lastrelem + 1;
+ }
+ }
+ }
+ STABSET(str);
+ }
+ }
+ if (delaymagic > 1) {
+ if (delaymagic & DM_REUID) {
+#ifdef HAS_SETREUID
+ setreuid(uid,euid);
+#else
+ if (uid != euid || setuid(uid) < 0)
+ fatal("No setreuid available");
+#endif
+ }
+ if (delaymagic & DM_REGID) {
+#ifdef HAS_SETREGID
+ setregid(gid,egid);
+#else
+ if (gid != egid || setgid(gid) < 0)
+ fatal("No setregid available");
+#endif
+ }
+ }
+ delaymagic = 0;
+ localizing = FALSE;
+ if (gimme == G_ARRAY) {
+ i = lastrelem - firstrelem + 1;
+ if (ary || hash)
+ Copy(firstrelem, firstlelem, i, STR*);
+ return arglast[0] + i;
+ }
+ else {
+ str_numset(arg->arg_ptr.arg_str,(double)(arglast[2] - arglast[1]));
+ *firstlelem = arg->arg_ptr.arg_str;
+ return arglast[0] + 1;
+ }
+}
+
+int /*SUPPRESS 590*/
+do_study(str,arg,gimme,arglast)
+STR *str;
+ARG *arg;
+int gimme;
+int *arglast;
+{
+ register unsigned char *s;
+ register int pos = str->str_cur;
+ register int ch;
+ register int *sfirst;
+ register int *snext;
+ static int maxscream = -1;
+ static STR *lastscream = Nullstr;
+ int retval;
+ int retarg = arglast[0] + 1;
+
+#ifndef lint
+ s = (unsigned char*)(str_get(str));
+#else
+ s = Null(unsigned char*);
+#endif
+ if (lastscream)
+ lastscream->str_pok &= ~SP_STUDIED;
+ lastscream = str;
+ if (pos <= 0) {
+ retval = 0;
+ goto ret;
+ }
+ if (pos > maxscream) {
+ if (maxscream < 0) {
+ maxscream = pos + 80;
+ New(301,screamfirst, 256, int);
+ New(302,screamnext, maxscream, int);
+ }
+ else {
+ maxscream = pos + pos / 4;
+ Renew(screamnext, maxscream, int);
+ }
+ }
+
+ sfirst = screamfirst;
+ snext = screamnext;
+
+ if (!sfirst || !snext)
+ fatal("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;
+ }
+
+ str->str_pok |= SP_STUDIED;
+ retval = 1;
+ ret:
+ str_numset(arg->arg_ptr.arg_str,(double)retval);
+ stack->ary_array[retarg] = arg->arg_ptr.arg_str;
+ return retarg;
+}
+
+int /*SUPPRESS 590*/
+do_defined(str,arg,gimme,arglast)
+STR *str;
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register int type;
+ register int retarg = arglast[0] + 1;
+ int retval;
+ ARRAY *ary;
+ HASH *hash;
+
+ if ((arg[1].arg_type & A_MASK) != A_LEXPR)
+ fatal("Illegal argument to defined()");
+ arg = arg[1].arg_ptr.arg_arg;
+ type = arg->arg_type;
+
+ if (type == O_SUBR || type == O_DBSUBR) {
+ if ((arg[1].arg_type & A_MASK) == A_WORD)
+ retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0;
+ else {
+ STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
+
+ retval = tmpstr && stab_sub(stabent(str_get(tmpstr),TRUE)) != 0;
+ }
+ }
+ else if (type == O_ARRAY || type == O_LARRAY ||
+ type == O_ASLICE || type == O_LASLICE )
+ retval = ((ary = stab_xarray(arg[1].arg_ptr.arg_stab)) != 0
+ && ary->ary_max >= 0 );
+ else if (type == O_HASH || type == O_LHASH ||
+ type == O_HSLICE || type == O_LHSLICE )
+ retval = ((hash = stab_xhash(arg[1].arg_ptr.arg_stab)) != 0
+ && hash->tbl_array);
+ else
+ retval = FALSE;
+ str_numset(str,(double)retval);
+ stack->ary_array[retarg] = str;
+ return retarg;
+}
+
+int /*SUPPRESS 590*/
+do_undef(str,arg,gimme,arglast)
+STR *str;
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register int type;
+ register STAB *stab;
+ int retarg = arglast[0] + 1;
+
+ if ((arg[1].arg_type & A_MASK) != A_LEXPR)
+ fatal("Illegal argument to undef()");
+ arg = arg[1].arg_ptr.arg_arg;
+ type = arg->arg_type;
+
+ if (type == O_ARRAY || type == O_LARRAY) {
+ stab = arg[1].arg_ptr.arg_stab;
+ afree(stab_xarray(stab));
+ stab_xarray(stab) = anew(stab); /* so "@array" still works */
+ }
+ else if (type == O_HASH || type == O_LHASH) {
+ stab = arg[1].arg_ptr.arg_stab;
+ if (stab == envstab)
+ environ[0] = Nullch;
+ else if (stab == sigstab) {
+ int i;
+
+ for (i = 1; i < NSIG; i++)
+ signal(i, SIG_DFL); /* munch, munch, munch */
+ }
+ (void)hfree(stab_xhash(stab), TRUE);
+ stab_xhash(stab) = Null(HASH*);
+ }
+ else if (type == O_SUBR || type == O_DBSUBR) {
+ stab = arg[1].arg_ptr.arg_stab;
+ if ((arg[1].arg_type & A_MASK) != A_WORD) {
+ STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
+
+ if (tmpstr)
+ stab = stabent(str_get(tmpstr),TRUE);
+ else
+ stab = Nullstab;
+ }
+ if (stab && stab_sub(stab)) {
+ cmd_free(stab_sub(stab)->cmd);
+ stab_sub(stab)->cmd = Nullcmd;
+ afree(stab_sub(stab)->tosave);
+ Safefree(stab_sub(stab));
+ stab_sub(stab) = Null(SUBR*);
+ }
+ }
+ else
+ fatal("Can't undefine that kind of object");
+ str_numset(str,0.0);
+ stack->ary_array[retarg] = str;
+ return retarg;
+}
+
+int
+do_vec(lvalue,astr,arglast)
+int lvalue;
+STR *astr;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ int sp = arglast[0];
+ register STR *str = st[++sp];
+ register int offset = (int)str_gnum(st[++sp]);
+ register int size = (int)str_gnum(st[++sp]);
+ unsigned char *s = (unsigned char*)str_get(str);
+ unsigned long retnum;
+ int len;
+
+ sp = arglast[1];
+ offset *= size; /* turn into bit offset */
+ len = (offset + size + 7) / 8;
+ if (offset < 0 || size < 1)
+ retnum = 0;
+ else if (!lvalue && len > str->str_cur)
+ retnum = 0;
+ else {
+ if (len > str->str_cur) {
+ STR_GROW(str,len);
+ (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur);
+ str->str_cur = len;
+ }
+ s = (unsigned char*)str_get(str);
+ if (size < 8)
+ retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
+ else {
+ offset >>= 3;
+ if (size == 8)
+ retnum = s[offset];
+ else if (size == 16)
+ retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
+ else if (size == 32)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8) + s[offset+3];
+ }
+
+ if (lvalue) { /* it's an lvalue! */
+ struct lstring *lstr = (struct lstring*)astr;
+
+ astr->str_magic = str;
+ st[sp]->str_rare = 'v';
+ lstr->lstr_offset = offset;
+ lstr->lstr_len = size;
+ }
+ }
+
+ str_numset(astr,(double)retnum);
+ st[sp] = astr;
+ return sp;
+}
+
+void
+do_vecset(mstr,str)
+STR *mstr;
+STR *str;
+{
+ struct lstring *lstr = (struct lstring*)str;
+ register int offset;
+ register int size;
+ register unsigned char *s = (unsigned char*)mstr->str_ptr;
+ register unsigned long lval = U_L(str_gnum(str));
+ int mask;
+
+ mstr->str_rare = 0;
+ str->str_magic = Nullstr;
+ offset = lstr->lstr_offset;
+ size = lstr->lstr_len;
+ if (size < 8) {
+ mask = (1 << size) - 1;
+ size = offset & 7;
+ lval &= mask;
+ offset >>= 3;
+ s[offset] &= ~(mask << size);
+ s[offset] |= lval << size;
+ }
+ else {
+ if (size == 8)
+ s[offset] = lval & 255;
+ else if (size == 16) {
+ s[offset] = (lval >> 8) & 255;
+ s[offset+1] = lval & 255;
+ }
+ else if (size == 32) {
+ s[offset] = (lval >> 24) & 255;
+ s[offset+1] = (lval >> 16) & 255;
+ s[offset+2] = (lval >> 8) & 255;
+ s[offset+3] = lval & 255;
+ }
+ }
+}
+
+do_chop(astr,str)
+register STR *astr;
+register STR *str;
+{
+ register char *tmps;
+ register int i;
+ ARRAY *ary;
+ HASH *hash;
+ HENT *entry;
+
+ if (!str)
+ return;
+ if (str->str_state == SS_ARY) {
+ ary = stab_array(str->str_u.str_stab);
+ for (i = 0; i <= ary->ary_fill; i++)
+ do_chop(astr,ary->ary_array[i]);
+ return;
+ }
+ if (str->str_state == SS_HASH) {
+ hash = stab_hash(str->str_u.str_stab);
+ (void)hiterinit(hash);
+ /*SUPPRESS 560*/
+ while (entry = hiternext(hash))
+ do_chop(astr,hiterval(hash,entry));
+ return;
+ }
+ tmps = str_get(str);
+ if (tmps && str->str_cur) {
+ tmps += str->str_cur - 1;
+ str_nset(astr,tmps,1); /* remember last char */
+ *tmps = '\0'; /* wipe it out */
+ str->str_cur = tmps - str->str_ptr;
+ str->str_nok = 0;
+ STABSET(str);
+ }
+ else
+ str_nset(astr,"",0);
+}
+
+do_vop(optype,str,left,right)
+STR *str;
+STR *left;
+STR *right;
+{
+ register char *s;
+ register char *l = str_get(left);
+ register char *r = str_get(right);
+ register int len;
+
+ len = left->str_cur;
+ if (len > right->str_cur)
+ len = right->str_cur;
+ if (str->str_cur > len)
+ str->str_cur = len;
+ else if (str->str_cur < len) {
+ STR_GROW(str,len);
+ (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur);
+ str->str_cur = len;
+ }
+ str->str_pok = 1;
+ str->str_nok = 0;
+ s = str->str_ptr;
+ if (!s) {
+ str_nset(str,"",0);
+ s = str->str_ptr;
+ }
+ switch (optype) {
+ case O_BIT_AND:
+ while (len--)
+ *s++ = *l++ & *r++;
+ break;
+ case O_XOR:
+ while (len--)
+ *s++ = *l++ ^ *r++;
+ goto mop_up;
+ case O_BIT_OR:
+ while (len--)
+ *s++ = *l++ | *r++;
+ mop_up:
+ len = str->str_cur;
+ if (right->str_cur > len)
+ str_ncat(str,right->str_ptr+len,right->str_cur - len);
+ else if (left->str_cur > len)
+ str_ncat(str,left->str_ptr+len,left->str_cur - len);
+ break;
+ }
+}
+
+int
+do_syscall(arglast)
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int items = arglast[2] - sp;
+ unsigned long arg[8];
+ register int i = 0;
+ int retval = -1;
+
+#ifdef HAS_SYSCALL
+#ifdef TAINT
+ for (st += ++sp; items--; st++)
+ tainted |= (*st)->str_tainted;
+ st = stack->ary_array;
+ sp = arglast[1];
+ items = arglast[2] - sp;
+#endif
+#ifdef TAINT
+ taintproper("Insecure dependency in syscall");
+#endif
+ /* 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 (items--) {
+ if (st[++sp]->str_nok || !i)
+ arg[i++] = (unsigned long)str_gnum(st[sp]);
+#ifndef lint
+ else
+ arg[i++] = (unsigned long)st[sp]->str_ptr;
+#endif /* lint */
+ }
+ sp = arglast[1];
+ items = arglast[2] - sp;
+ switch (items) {
+ case 0:
+ fatal("Too few args to syscall");
+ case 1:
+ retval = syscall(arg[0]);
+ break;
+ case 2:
+ retval = syscall(arg[0],arg[1]);
+ break;
+ case 3:
+ retval = syscall(arg[0],arg[1],arg[2]);
+ break;
+ case 4:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3]);
+ break;
+ case 5:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4]);
+ break;
+ case 6:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5]);
+ break;
+ case 7:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6]);
+ break;
+ case 8:
+ retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
+ arg[7]);
+ break;
+ }
+ return retval;
+#else
+ fatal("syscall() unimplemented");
+#endif
+}
+
+
--- /dev/null
+/* $RCSfile: doio.c,v $$Revision: 4.0.1.4 $$Date: 91/11/05 16:51:43 $
+ *
+ * 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: doio.c,v $
+ * 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.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef HAS_SOCKET
+#include <sys/socket.h>
+#include <netdb.h>
+#endif
+
+#ifdef HAS_SELECT
+#ifdef I_SYS_SELECT
+#ifndef I_SYS_TIME
+#include <sys/select.h>
+#endif
+#endif
+#endif
+
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+#include <sys/ipc.h>
+#ifdef HAS_MSG
+#include <sys/msg.h>
+#endif
+#ifdef HAS_SEM
+#include <sys/sem.h>
+#endif
+#ifdef HAS_SHM
+#include <sys/shm.h>
+#endif
+#endif
+
+#ifdef I_PWD
+#include <pwd.h>
+#endif
+#ifdef I_GRP
+#include <grp.h>
+#endif
+#ifdef I_UTIME
+#include <utime.h>
+#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+int laststatval = -1;
+int laststype = O_STAT;
+
+bool
+do_open(stab,name,len)
+STAB *stab;
+register char *name;
+int len;
+{
+ FILE *fp;
+ register STIO *stio = stab_io(stab);
+ char *myname = savestr(name);
+ int result;
+ int fd;
+ int writing = 0;
+ char mode[3]; /* stdio file mode ("r\0" or "r+\0") */
+ FILE *saveifp = Nullfp;
+ FILE *saveofp = Nullfp;
+ char savetype = ' ';
+
+ name = myname;
+ forkprocess = 1; /* assume true if no fork */
+ while (len && isSPACE(name[len-1]))
+ name[--len] = '\0';
+ if (!stio)
+ stio = stab_io(stab) = stio_new();
+ else if (stio->ifp) {
+ fd = fileno(stio->ifp);
+ if (stio->type == '-')
+ result = 0;
+ else if (fd <= maxsysfd) {
+ saveifp = stio->ifp;
+ saveofp = stio->ofp;
+ savetype = stio->type;
+ result = 0;
+ }
+ else if (stio->type == '|')
+ result = mypclose(stio->ifp);
+ else if (stio->ifp != stio->ofp) {
+ if (stio->ofp) {
+ result = fclose(stio->ofp);
+ fclose(stio->ifp); /* clear stdio, fd already closed */
+ }
+ else
+ result = fclose(stio->ifp);
+ }
+ else
+ result = fclose(stio->ifp);
+ if (result == EOF && fd > maxsysfd)
+ fprintf(stderr,"Warning: unable to close filehandle %s properly.\n",
+ stab_name(stab));
+ stio->ofp = stio->ifp = Nullfp;
+ }
+ if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
+ mode[1] = *name++;
+ mode[2] = '\0';
+ --len;
+ writing = 1;
+ }
+ else {
+ mode[1] = '\0';
+ }
+ stio->type = *name;
+ if (*name == '|') {
+ /*SUPPRESS 530*/
+ for (name++; isSPACE(*name); name++) ;
+#ifdef TAINT
+ taintenv();
+ taintproper("Insecure dependency in piped open");
+#endif
+ fp = mypopen(name,"w");
+ writing = 1;
+ }
+ else if (*name == '>') {
+#ifdef TAINT
+ taintproper("Insecure dependency in open");
+#endif
+ name++;
+ if (*name == '>') {
+ mode[0] = stio->type = 'a';
+ name++;
+ }
+ else
+ mode[0] = 'w';
+ writing = 1;
+ if (*name == '&') {
+ duplicity:
+ name++;
+ while (isSPACE(*name))
+ name++;
+ if (isDIGIT(*name))
+ fd = atoi(name);
+ else {
+ stab = stabent(name,FALSE);
+ if (!stab || !stab_io(stab)) {
+#ifdef EINVAL
+ errno = EINVAL;
+#endif
+ goto say_false;
+ }
+ if (stab_io(stab) && stab_io(stab)->ifp) {
+ fd = fileno(stab_io(stab)->ifp);
+ if (stab_io(stab)->type == 's')
+ stio->type = 's';
+ }
+ else
+ fd = -1;
+ }
+ if (!(fp = fdopen(fd = dup(fd),mode))) {
+ close(fd);
+ }
+ }
+ else {
+ while (isSPACE(*name))
+ name++;
+ if (strEQ(name,"-")) {
+ fp = stdout;
+ stio->type = '-';
+ }
+ else {
+ fp = fopen(name,mode);
+ }
+ }
+ }
+ else {
+ if (*name == '<') {
+ mode[0] = 'r';
+ name++;
+ while (isSPACE(*name))
+ name++;
+ if (*name == '&')
+ goto duplicity;
+ if (strEQ(name,"-")) {
+ fp = stdin;
+ stio->type = '-';
+ }
+ else
+ fp = fopen(name,mode);
+ }
+ else if (name[len-1] == '|') {
+#ifdef TAINT
+ taintenv();
+ taintproper("Insecure dependency in piped open");
+#endif
+ name[--len] = '\0';
+ while (len && isSPACE(name[len-1]))
+ name[--len] = '\0';
+ /*SUPPRESS 530*/
+ for (; isSPACE(*name); name++) ;
+ fp = mypopen(name,"r");
+ stio->type = '|';
+ }
+ else {
+ stio->type = '<';
+ /*SUPPRESS 530*/
+ for (; isSPACE(*name); name++) ;
+ if (strEQ(name,"-")) {
+ fp = stdin;
+ stio->type = '-';
+ }
+ else
+ fp = fopen(name,"r");
+ }
+ }
+ Safefree(myname);
+ if (!fp)
+ goto say_false;
+ if (stio->type &&
+ stio->type != '|' && stio->type != '-') {
+ if (fstat(fileno(fp),&statbuf) < 0) {
+ (void)fclose(fp);
+ goto say_false;
+ }
+ if (S_ISSOCK(statbuf.st_mode))
+ stio->type = 's'; /* in case a socket was passed in to us */
+#ifdef HAS_SOCKET
+ else if (
+#ifdef S_IFMT
+ !(statbuf.st_mode & S_IFMT)
+#else
+ !statbuf.st_mode
+#endif
+ ) {
+ if (getsockname(fileno(fp), tokenbuf, 0) >= 0 || errno != ENOTSOCK)
+ stio->type = 's'; /* some OS's return 0 on fstat()ed socket */
+ /* but some return 0 for streams too, sigh */
+ }
+#endif
+ }
+ if (saveifp) { /* must use old fp? */
+ fd = fileno(saveifp);
+ if (saveofp) {
+ fflush(saveofp); /* emulate fclose() */
+ if (saveofp != saveifp) { /* was a socket? */
+ fclose(saveofp);
+ if (fd > 2)
+ Safefree(saveofp);
+ }
+ }
+ if (fd != fileno(fp)) {
+ dup2(fileno(fp), fd);
+ fclose(fp);
+ }
+ fp = saveifp;
+ }
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fd = fileno(fp);
+ fcntl(fd,F_SETFD,fd > maxsysfd);
+#endif
+ stio->ifp = fp;
+ if (writing) {
+ if (stio->type == 's'
+ || (stio->type == '>' && S_ISCHR(statbuf.st_mode)) ) {
+ if (!(stio->ofp = fdopen(fileno(fp),"w"))) {
+ fclose(fp);
+ stio->ifp = Nullfp;
+ goto say_false;
+ }
+ }
+ else
+ stio->ofp = fp;
+ }
+ return TRUE;
+
+say_false:
+ stio->ifp = saveifp;
+ stio->ofp = saveofp;
+ stio->type = savetype;
+ return FALSE;
+}
+
+FILE *
+nextargv(stab)
+register STAB *stab;
+{
+ register STR *str;
+#ifndef FLEXFILENAMES
+ int filedev;
+ int fileino;
+#endif
+ int fileuid;
+ int filegid;
+ static int filemode = 0;
+ static int lastfd;
+ static char *oldname;
+
+ if (!argvoutstab)
+ argvoutstab = stabent("ARGVOUT",TRUE);
+ if (filemode & (S_ISUID|S_ISGID)) {
+ fflush(stab_io(argvoutstab)->ifp); /* chmod must follow last write */
+#ifdef HAS_FCHMOD
+ (void)fchmod(lastfd,filemode);
+#else
+ (void)chmod(oldname,filemode);
+#endif
+ }
+ filemode = 0;
+ while (alen(stab_xarray(stab)) >= 0) {
+ str = ashift(stab_xarray(stab));
+ str_sset(stab_val(stab),str);
+ STABSET(stab_val(stab));
+ oldname = str_get(stab_val(stab));
+ if (do_open(stab,oldname,stab_val(stab)->str_cur)) {
+ if (inplace) {
+#ifdef TAINT
+ taintproper("Insecure dependency in inplace open");
+#endif
+ if (strEQ(oldname,"-")) {
+ str_free(str);
+ defoutstab = stabent("STDOUT",TRUE);
+ return stab_io(stab)->ifp;
+ }
+#ifndef FLEXFILENAMES
+ filedev = statbuf.st_dev;
+ fileino = statbuf.st_ino;
+#endif
+ filemode = statbuf.st_mode;
+ fileuid = statbuf.st_uid;
+ filegid = statbuf.st_gid;
+ if (!S_ISREG(filemode)) {
+ warn("Can't do inplace edit: %s is not a regular file",
+ oldname );
+ do_close(stab,FALSE);
+ str_free(str);
+ continue;
+ }
+ if (*inplace) {
+#ifdef SUFFIX
+ add_suffix(str,inplace);
+#else
+ str_cat(str,inplace);
+#endif
+#ifndef FLEXFILENAMES
+ if (stat(str->str_ptr,&statbuf) >= 0
+ && statbuf.st_dev == filedev
+ && statbuf.st_ino == fileino ) {
+ warn("Can't do inplace edit: %s > 14 characters",
+ str->str_ptr );
+ do_close(stab,FALSE);
+ str_free(str);
+ continue;
+ }
+#endif
+#ifdef HAS_RENAME
+#ifndef MSDOS
+ if (rename(oldname,str->str_ptr) < 0) {
+ warn("Can't rename %s to %s: %s, skipping file",
+ oldname, str->str_ptr, strerror(errno) );
+ do_close(stab,FALSE);
+ str_free(str);
+ continue;
+ }
+#else
+ do_close(stab,FALSE);
+ (void)unlink(str->str_ptr);
+ (void)rename(oldname,str->str_ptr);
+ do_open(stab,str->str_ptr,stab_val(stab)->str_cur);
+#endif /* MSDOS */
+#else
+ (void)UNLINK(str->str_ptr);
+ if (link(oldname,str->str_ptr) < 0) {
+ warn("Can't rename %s to %s: %s, skipping file",
+ oldname, str->str_ptr, strerror(errno) );
+ do_close(stab,FALSE);
+ str_free(str);
+ continue;
+ }
+ (void)UNLINK(oldname);
+#endif
+ }
+ else {
+#ifndef MSDOS
+ if (UNLINK(oldname) < 0) {
+ warn("Can't rename %s to %s: %s, skipping file",
+ oldname, str->str_ptr, strerror(errno) );
+ do_close(stab,FALSE);
+ str_free(str);
+ continue;
+ }
+#else
+ fatal("Can't do inplace edit without backup");
+#endif
+ }
+
+ str_nset(str,">",1);
+ str_cat(str,oldname);
+ errno = 0; /* in case sprintf set errno */
+ if (!do_open(argvoutstab,str->str_ptr,str->str_cur)) {
+ warn("Can't do inplace edit on %s: %s",
+ oldname, strerror(errno) );
+ do_close(stab,FALSE);
+ str_free(str);
+ continue;
+ }
+ defoutstab = argvoutstab;
+ lastfd = fileno(stab_io(argvoutstab)->ifp);
+ (void)fstat(lastfd,&statbuf);
+#ifdef HAS_FCHMOD
+ (void)fchmod(lastfd,filemode);
+#else
+ (void)chmod(oldname,filemode);
+#endif
+ if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
+#ifdef HAS_FCHOWN
+ (void)fchown(lastfd,fileuid,filegid);
+#else
+#ifdef HAS_CHOWN
+ (void)chown(oldname,fileuid,filegid);
+#endif
+#endif
+ }
+ }
+ str_free(str);
+ return stab_io(stab)->ifp;
+ }
+ else
+ fprintf(stderr,"Can't open %s: %s\n",str_get(str), strerror(errno));
+ str_free(str);
+ }
+ if (inplace) {
+ (void)do_close(argvoutstab,FALSE);
+ defoutstab = stabent("STDOUT",TRUE);
+ }
+ return Nullfp;
+}
+
+#ifdef HAS_PIPE
+void
+do_pipe(str, rstab, wstab)
+STR *str;
+STAB *rstab;
+STAB *wstab;
+{
+ register STIO *rstio;
+ register STIO *wstio;
+ int fd[2];
+
+ if (!rstab)
+ goto badexit;
+ if (!wstab)
+ goto badexit;
+
+ rstio = stab_io(rstab);
+ wstio = stab_io(wstab);
+
+ if (!rstio)
+ rstio = stab_io(rstab) = stio_new();
+ else if (rstio->ifp)
+ do_close(rstab,FALSE);
+ if (!wstio)
+ wstio = stab_io(wstab) = stio_new();
+ else if (wstio->ifp)
+ do_close(wstab,FALSE);
+
+ if (pipe(fd) < 0)
+ goto badexit;
+ rstio->ifp = fdopen(fd[0], "r");
+ wstio->ofp = fdopen(fd[1], "w");
+ wstio->ifp = wstio->ofp;
+ rstio->type = '<';
+ wstio->type = '>';
+ if (!rstio->ifp || !wstio->ofp) {
+ if (rstio->ifp) fclose(rstio->ifp);
+ else close(fd[0]);
+ if (wstio->ofp) fclose(wstio->ofp);
+ else close(fd[1]);
+ goto badexit;
+ }
+
+ str_sset(str,&str_yes);
+ return;
+
+badexit:
+ str_sset(str,&str_undef);
+ return;
+}
+#endif
+
+bool
+do_close(stab,explicit)
+STAB *stab;
+bool explicit;
+{
+ bool retval = FALSE;
+ register STIO *stio;
+ int status;
+
+ if (!stab)
+ stab = argvstab;
+ if (!stab) {
+ errno = EBADF;
+ return FALSE;
+ }
+ stio = stab_io(stab);
+ if (!stio) { /* never opened */
+ if (dowarn && explicit)
+ warn("Close on unopened file <%s>",stab_name(stab));
+ return FALSE;
+ }
+ if (stio->ifp) {
+ if (stio->type == '|') {
+ status = mypclose(stio->ifp);
+ retval = (status == 0);
+ statusvalue = (unsigned short)status & 0xffff;
+ }
+ else if (stio->type == '-')
+ retval = TRUE;
+ else {
+ if (stio->ofp && stio->ofp != stio->ifp) { /* a socket */
+ retval = (fclose(stio->ofp) != EOF);
+ fclose(stio->ifp); /* clear stdio, fd already closed */
+ }
+ else
+ retval = (fclose(stio->ifp) != EOF);
+ }
+ stio->ofp = stio->ifp = Nullfp;
+ }
+ if (explicit)
+ stio->lines = 0;
+ stio->type = ' ';
+ return retval;
+}
+
+bool
+do_eof(stab)
+STAB *stab;
+{
+ register STIO *stio;
+ int ch;
+
+ if (!stab) { /* eof() */
+ if (argvstab)
+ stio = stab_io(argvstab);
+ else
+ return TRUE;
+ }
+ else
+ stio = stab_io(stab);
+
+ if (!stio)
+ return TRUE;
+
+ while (stio->ifp) {
+
+#ifdef STDSTDIO /* (the code works without this) */
+ if (stio->ifp->_cnt > 0) /* cheat a little, since */
+ return FALSE; /* this is the most usual case */
+#endif
+
+ ch = getc(stio->ifp);
+ if (ch != EOF) {
+ (void)ungetc(ch, stio->ifp);
+ return FALSE;
+ }
+#ifdef STDSTDIO
+ if (stio->ifp->_cnt < -1)
+ stio->ifp->_cnt = -1;
+#endif
+ if (!stab) { /* not necessarily a real EOF yet? */
+ if (!nextargv(argvstab)) /* get another fp handy */
+ return TRUE;
+ }
+ else
+ return TRUE; /* normal fp, definitely end of file */
+ }
+ return TRUE;
+}
+
+long
+do_tell(stab)
+STAB *stab;
+{
+ register STIO *stio;
+
+ if (!stab)
+ goto phooey;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto phooey;
+
+ if (feof(stio->ifp))
+ (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */
+
+ return ftell(stio->ifp);
+
+phooey:
+ if (dowarn)
+ warn("tell() on unopened file");
+ errno = EBADF;
+ return -1L;
+}
+
+bool
+do_seek(stab, pos, whence)
+STAB *stab;
+long pos;
+int whence;
+{
+ register STIO *stio;
+
+ if (!stab)
+ goto nuts;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto nuts;
+
+ if (feof(stio->ifp))
+ (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */
+
+ return fseek(stio->ifp, pos, whence) >= 0;
+
+nuts:
+ if (dowarn)
+ warn("seek() on unopened file");
+ errno = EBADF;
+ return FALSE;
+}
+
+int
+do_ctl(optype,stab,func,argstr)
+int optype;
+STAB *stab;
+int func;
+STR *argstr;
+{
+ register STIO *stio;
+ register char *s;
+ int retval;
+
+ if (!stab || !argstr || !(stio = stab_io(stab)) || !stio->ifp) {
+ errno = EBADF; /* well, sort of... */
+ return -1;
+ }
+
+ if (argstr->str_pok || !argstr->str_nok) {
+ if (!argstr->str_pok)
+ s = str_get(argstr);
+
+#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 (argstr->str_cur < retval) {
+ Str_Grow(argstr,retval+1);
+ argstr->str_cur = retval;
+ }
+
+ s = argstr->str_ptr;
+ s[argstr->str_cur] = 17; /* a little sanity check here */
+ }
+ else {
+ retval = (int)str_gnum(argstr);
+#ifdef MSDOS
+ s = (char*)(long)retval; /* ouch */
+#else
+ s = (char*)retval; /* ouch */
+#endif
+ }
+
+#ifndef lint
+ if (optype == O_IOCTL)
+ retval = ioctl(fileno(stio->ifp), func, s);
+ else
+#ifdef MSDOS
+ fatal("fcntl is not implemented");
+#else
+#ifdef HAS_FCNTL
+ retval = fcntl(fileno(stio->ifp), func, s);
+#else
+ fatal("fcntl is not implemented");
+#endif
+#endif
+#else /* lint */
+ retval = 0;
+#endif /* lint */
+
+ if (argstr->str_pok) {
+ if (s[argstr->str_cur] != 17)
+ fatal("Return value overflowed string");
+ s[argstr->str_cur] = 0; /* put our null back */
+ }
+ return retval;
+}
+
+int
+do_stat(str,arg,gimme,arglast)
+STR *str;
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ register int sp = arglast[0] + 1;
+ int max = 13;
+
+ if ((arg[1].arg_type & A_MASK) == A_WORD) {
+ tmpstab = arg[1].arg_ptr.arg_stab;
+ if (tmpstab != defstab) {
+ laststype = O_STAT;
+ statstab = tmpstab;
+ str_set(statname,"");
+ if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
+ fstat(fileno(stab_io(tmpstab)->ifp),&statcache) < 0) {
+ max = 0;
+ laststatval = -1;
+ }
+ }
+ else if (laststatval < 0)
+ max = 0;
+ }
+ else {
+ str_set(statname,str_get(ary->ary_array[sp]));
+ statstab = Nullstab;
+#ifdef HAS_LSTAT
+ laststype = arg->arg_type;
+ if (arg->arg_type == O_LSTAT)
+ laststatval = lstat(str_get(statname),&statcache);
+ else
+#endif
+ laststatval = stat(str_get(statname),&statcache);
+ if (laststatval < 0)
+ max = 0;
+ }
+
+ if (gimme != G_ARRAY) {
+ if (max)
+ str_sset(str,&str_yes);
+ else
+ str_sset(str,&str_undef);
+ STABSET(str);
+ ary->ary_array[sp] = str;
+ return sp;
+ }
+ sp--;
+ if (max) {
+#ifndef lint
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_dev)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_ino)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_mode)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_nlink)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_uid)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_gid)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_rdev)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_size)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_atime)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_mtime)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_ctime)));
+#ifdef STATBLOCKS
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_blksize)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_nmake((double)statcache.st_blocks)));
+#else
+ (void)astore(ary,++sp,
+ str_2mortal(str_make("",0)));
+ (void)astore(ary,++sp,
+ str_2mortal(str_make("",0)));
+#endif
+#else /* lint */
+ (void)astore(ary,++sp,str_nmake(0.0));
+#endif /* lint */
+ }
+ return sp;
+}
+
+#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
+ /* code courtesy of William Kucharski */
+#define HAS_CHSIZE
+
+int chsize(fd, length)
+int fd; /* file descriptor */
+off_t length; /* length to set file to */
+{
+ extern long lseek();
+ struct flock fl;
+ struct stat filebuf;
+
+ if (fstat(fd, &filebuf) < 0)
+ return -1;
+
+ if (filebuf.st_size < length) {
+
+ /* extend file length */
+
+ if ((lseek(fd, (length - 1), 0)) < 0)
+ return -1;
+
+ /* write a "0" byte */
+
+ if ((write(fd, "", 1)) != 1)
+ return -1;
+ }
+ else {
+ /* truncate length */
+
+ fl.l_whence = 0;
+ fl.l_len = 0;
+ fl.l_start = length;
+ fl.l_type = F_WRLCK; /* write lock on file space */
+
+ /*
+ * This relies on the UNDOCUMENTED F_FREESP argument to
+ * fcntl(2), which truncates the file so that it ends at the
+ * position indicated by fl.l_start.
+ *
+ * Will minor miracles never cease?
+ */
+
+ if (fcntl(fd, F_FREESP, &fl) < 0)
+ return -1;
+
+ }
+
+ return 0;
+}
+#endif /* F_FREESP */
+
+int /*SUPPRESS 590*/
+do_truncate(str,arg,gimme,arglast)
+STR *str;
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ register int sp = arglast[0] + 1;
+ off_t len = (off_t)str_gnum(ary->ary_array[sp+1]);
+ int result = 1;
+ STAB *tmpstab;
+
+#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE)
+#ifdef HAS_TRUNCATE
+ if ((arg[1].arg_type & A_MASK) == A_WORD) {
+ tmpstab = arg[1].arg_ptr.arg_stab;
+ if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
+ ftruncate(fileno(stab_io(tmpstab)->ifp), len) < 0)
+ result = 0;
+ }
+ else if (truncate(str_get(ary->ary_array[sp]), len) < 0)
+ result = 0;
+#else
+ if ((arg[1].arg_type & A_MASK) == A_WORD) {
+ tmpstab = arg[1].arg_ptr.arg_stab;
+ if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp ||
+ chsize(fileno(stab_io(tmpstab)->ifp), len) < 0)
+ result = 0;
+ }
+ else {
+ int tmpfd;
+
+ if ((tmpfd = open(str_get(ary->ary_array[sp]), 0)) < 0)
+ result = 0;
+ else {
+ if (chsize(tmpfd, len) < 0)
+ result = 0;
+ close(tmpfd);
+ }
+ }
+#endif
+
+ if (result)
+ str_sset(str,&str_yes);
+ else
+ str_sset(str,&str_undef);
+ STABSET(str);
+ ary->ary_array[sp] = str;
+ return sp;
+#else
+ fatal("truncate not implemented");
+#endif
+}
+
+int
+looks_like_number(str)
+STR *str;
+{
+ register char *s;
+ register char *send;
+
+ if (!str->str_pok)
+ return TRUE;
+ s = str->str_ptr;
+ send = s + str->str_cur;
+ while (isSPACE(*s))
+ s++;
+ if (s >= send)
+ return FALSE;
+ if (*s == '+' || *s == '-')
+ s++;
+ while (isDIGIT(*s))
+ s++;
+ if (s == send)
+ return TRUE;
+ if (*s == '.')
+ s++;
+ else if (s == str->str_ptr)
+ return FALSE;
+ while (isDIGIT(*s))
+ s++;
+ if (s == send)
+ return TRUE;
+ if (*s == 'e' || *s == 'E') {
+ s++;
+ if (*s == '+' || *s == '-')
+ s++;
+ while (isDIGIT(*s))
+ s++;
+ }
+ while (isSPACE(*s))
+ s++;
+ if (s >= send)
+ return TRUE;
+ return FALSE;
+}
+
+bool
+do_print(str,fp)
+register STR *str;
+FILE *fp;
+{
+ register char *tmps;
+
+ if (!fp) {
+ if (dowarn)
+ warn("print to unopened file");
+ errno = EBADF;
+ return FALSE;
+ }
+ if (!str)
+ return TRUE;
+ if (ofmt &&
+ ((str->str_nok && str->str_u.str_nval != 0.0)
+ || (looks_like_number(str) && str_gnum(str) != 0.0) ) ) {
+ fprintf(fp, ofmt, str->str_u.str_nval);
+ return !ferror(fp);
+ }
+ else {
+ tmps = str_get(str);
+ if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'B' && tmps[3] == '\0'
+ && str->str_cur == sizeof(STBP) && strlen(tmps) < str->str_cur) {
+ STR *tmpstr = str_mortal(&str_undef);
+ stab_fullname(tmpstr,((STAB*)str));/* a stab value, be nice */
+ str = tmpstr;
+ tmps = str->str_ptr;
+ putc('*',fp);
+ }
+ if (str->str_cur && (fwrite(tmps,1,str->str_cur,fp) == 0 || ferror(fp)))
+ return FALSE;
+ }
+ return TRUE;
+}
+
+bool
+do_aprint(arg,fp,arglast)
+register ARG *arg;
+register FILE *fp;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int retval;
+ register int items = arglast[2] - sp;
+
+ if (!fp) {
+ if (dowarn)
+ warn("print to unopened file");
+ errno = EBADF;
+ return FALSE;
+ }
+ st += ++sp;
+ if (arg->arg_type == O_PRTF) {
+ do_sprintf(arg->arg_ptr.arg_str,items,st);
+ retval = do_print(arg->arg_ptr.arg_str,fp);
+ }
+ else {
+ retval = (items <= 0);
+ for (; items > 0; items--,st++) {
+ if (retval && ofslen) {
+ if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
+ retval = FALSE;
+ break;
+ }
+ }
+ if (!(retval = do_print(*st, fp)))
+ break;
+ }
+ if (retval && orslen)
+ if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp))
+ retval = FALSE;
+ }
+ return retval;
+}
+
+int
+mystat(arg,str)
+ARG *arg;
+STR *str;
+{
+ STIO *stio;
+
+ if (arg[1].arg_type & A_DONT) {
+ stio = stab_io(arg[1].arg_ptr.arg_stab);
+ if (stio && stio->ifp) {
+ statstab = arg[1].arg_ptr.arg_stab;
+ str_set(statname,"");
+ laststype = O_STAT;
+ return (laststatval = fstat(fileno(stio->ifp), &statcache));
+ }
+ else {
+ if (arg[1].arg_ptr.arg_stab == defstab)
+ return laststatval;
+ if (dowarn)
+ warn("Stat on unopened file <%s>",
+ stab_name(arg[1].arg_ptr.arg_stab));
+ statstab = Nullstab;
+ str_set(statname,"");
+ return (laststatval = -1);
+ }
+ }
+ else {
+ statstab = Nullstab;
+ str_set(statname,str_get(str));
+ laststype = O_STAT;
+ return (laststatval = stat(str_get(str),&statcache));
+ }
+}
+
+int
+mylstat(arg,str)
+ARG *arg;
+STR *str;
+{
+ if (arg[1].arg_type & A_DONT) {
+ if (arg[1].arg_ptr.arg_stab == defstab) {
+ if (laststype != O_LSTAT)
+ fatal("The stat preceding -l _ wasn't an lstat");
+ return laststatval;
+ }
+ fatal("You can't use -l on a filehandle");
+ }
+
+ laststype = O_LSTAT;
+ statstab = Nullstab;
+ str_set(statname,str_get(str));
+#ifdef HAS_LSTAT
+ return (laststatval = lstat(str_get(str),&statcache));
+#else
+ return (laststatval = stat(str_get(str),&statcache));
+#endif
+}
+
+STR *
+do_fttext(arg,str)
+register ARG *arg;
+STR *str;
+{
+ int i;
+ int len;
+ int odd = 0;
+ STDCHAR tbuf[512];
+ register STDCHAR *s;
+ register STIO *stio;
+
+ if (arg[1].arg_type & A_DONT) {
+ if (arg[1].arg_ptr.arg_stab == defstab) {
+ if (statstab)
+ stio = stab_io(statstab);
+ else {
+ str = statname;
+ goto really_filename;
+ }
+ }
+ else {
+ statstab = arg[1].arg_ptr.arg_stab;
+ str_set(statname,"");
+ stio = stab_io(statstab);
+ }
+ if (stio && stio->ifp) {
+#ifdef STDSTDIO
+ fstat(fileno(stio->ifp),&statcache);
+ if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
+ return arg->arg_type == O_FTTEXT ? &str_no : &str_yes;
+ if (stio->ifp->_cnt <= 0) {
+ i = getc(stio->ifp);
+ if (i != EOF)
+ (void)ungetc(i,stio->ifp);
+ }
+ if (stio->ifp->_cnt <= 0) /* null file is anything */
+ return &str_yes;
+ len = stio->ifp->_cnt + (stio->ifp->_ptr - stio->ifp->_base);
+ s = stio->ifp->_base;
+#else
+ fatal("-T and -B not implemented on filehandles");
+#endif
+ }
+ else {
+ if (dowarn)
+ warn("Test on unopened file <%s>",
+ stab_name(arg[1].arg_ptr.arg_stab));
+ errno = EBADF;
+ return &str_undef;
+ }
+ }
+ else {
+ statstab = Nullstab;
+ str_set(statname,str_get(str));
+ really_filename:
+ i = open(str_get(str),0);
+ if (i < 0)
+ return &str_undef;
+ fstat(i,&statcache);
+ len = read(i,tbuf,512);
+ (void)close(i);
+ if (len <= 0) {
+ if (S_ISDIR(statcache.st_mode) && arg->arg_type == O_FTTEXT)
+ return &str_no; /* special case NFS directories */
+ return &str_yes; /* 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) == (arg->arg_type == O_FTTEXT)) /* allow 10% odd */
+ return &str_no;
+ else
+ return &str_yes;
+}
+
+bool
+do_aexec(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;
+
+ if (items) {
+ New(401,argv, items+1, char*);
+ a = argv;
+ for (st += ++sp; items > 0; items--,st++) {
+ if (*st)
+ *a++ = str_get(*st);
+ else
+ *a++ = "";
+ }
+ *a = Nullch;
+#ifdef TAINT
+ if (*argv[0] != '/') /* will execvp use PATH? */
+ taintenv(); /* testing IFS here is overkill, probably */
+#endif
+ if (really && *(tmps = str_get(really)))
+ execvp(tmps,argv);
+ else
+ execvp(argv[0],argv);
+ Safefree(argv);
+ }
+ return FALSE;
+}
+
+static char **Argv = Null(char **);
+static char *Cmd = Nullch;
+
+void
+do_execfree()
+{
+ if (Argv) {
+ Safefree(Argv);
+ Argv = Null(char **);
+ }
+ if (Cmd) {
+ Safefree(Cmd);
+ Cmd = Nullch;
+ }
+}
+
+bool
+do_exec(cmd)
+char *cmd;
+{
+ register char **a;
+ register char *s;
+ char flags[10];
+
+ /* save an extra exec if possible */
+
+#ifdef CSH
+ if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) {
+ strcpy(flags,"-c");
+ s = cmd+cshlen+3;
+ if (*s == 'f') {
+ s++;
+ strcat(flags,"f");
+ }
+ if (*s == ' ')
+ s++;
+ if (*s++ == '\'') {
+ char *ncmd = s;
+
+ while (*s)
+ s++;
+ if (s[-1] == '\n')
+ *--s = '\0';
+ if (s[-1] == '\'') {
+ *--s = '\0';
+ execl(cshname,"csh", flags,ncmd,(char*)0);
+ *s = '\'';
+ return FALSE;
+ }
+ }
+ }
+#endif /* CSH */
+
+ /* see if there are shell metacharacters in it */
+
+ /*SUPPRESS 530*/
+ for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
+ if (*s == '=')
+ goto doshell;
+ for (s = cmd; *s; s++) {
+ if (*s != ' ' && !isALPHA(*s) && index("$&*(){}[]'\";\\|?<>~`\n",*s)) {
+ if (*s == '\n' && !s[1]) {
+ *s = '\0';
+ break;
+ }
+ doshell:
+ execl("/bin/sh","sh","-c",cmd,(char*)0);
+ return FALSE;
+ }
+ }
+ New(402,Argv, (s - cmd) / 2 + 2, char*);
+ Cmd = nsavestr(cmd, s-cmd);
+ a = Argv;
+ for (s = Cmd; *s;) {
+ while (*s && isSPACE(*s)) s++;
+ if (*s)
+ *(a++) = s;
+ while (*s && !isSPACE(*s)) s++;
+ if (*s)
+ *s++ = '\0';
+ }
+ *a = Nullch;
+ if (Argv[0]) {
+ execvp(Argv[0],Argv);
+ if (errno == ENOEXEC) { /* for system V NIH syndrome */
+ do_execfree();
+ goto doshell;
+ }
+ }
+ do_execfree();
+ return FALSE;
+}
+
+#ifdef HAS_SOCKET
+int
+do_socket(stab, arglast)
+STAB *stab;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register STIO *stio;
+ int domain, type, protocol, fd;
+
+ if (!stab) {
+ errno = EBADF;
+ return FALSE;
+ }
+
+ stio = stab_io(stab);
+ if (!stio)
+ stio = stab_io(stab) = stio_new();
+ else if (stio->ifp)
+ do_close(stab,FALSE);
+
+ domain = (int)str_gnum(st[++sp]);
+ type = (int)str_gnum(st[++sp]);
+ protocol = (int)str_gnum(st[++sp]);
+#ifdef TAINT
+ taintproper("Insecure dependency in socket");
+#endif
+ fd = socket(domain,type,protocol);
+ if (fd < 0)
+ return FALSE;
+ stio->ifp = fdopen(fd, "r"); /* stdio gets confused about sockets */
+ stio->ofp = fdopen(fd, "w");
+ stio->type = 's';
+ if (!stio->ifp || !stio->ofp) {
+ if (stio->ifp) fclose(stio->ifp);
+ if (stio->ofp) fclose(stio->ofp);
+ if (!stio->ifp && !stio->ofp) close(fd);
+ return FALSE;
+ }
+
+ return TRUE;
+}
+
+int
+do_bind(stab, arglast)
+STAB *stab;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register STIO *stio;
+ char *addr;
+
+ if (!stab)
+ goto nuts;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto nuts;
+
+ addr = str_get(st[++sp]);
+#ifdef TAINT
+ taintproper("Insecure dependency in bind");
+#endif
+ return bind(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0;
+
+nuts:
+ if (dowarn)
+ warn("bind() on closed fd");
+ errno = EBADF;
+ return FALSE;
+
+}
+
+int
+do_connect(stab, arglast)
+STAB *stab;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register STIO *stio;
+ char *addr;
+
+ if (!stab)
+ goto nuts;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto nuts;
+
+ addr = str_get(st[++sp]);
+#ifdef TAINT
+ taintproper("Insecure dependency in connect");
+#endif
+ return connect(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0;
+
+nuts:
+ if (dowarn)
+ warn("connect() on closed fd");
+ errno = EBADF;
+ return FALSE;
+
+}
+
+int
+do_listen(stab, arglast)
+STAB *stab;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register STIO *stio;
+ int backlog;
+
+ if (!stab)
+ goto nuts;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto nuts;
+
+ backlog = (int)str_gnum(st[++sp]);
+ return listen(fileno(stio->ifp), backlog) >= 0;
+
+nuts:
+ if (dowarn)
+ warn("listen() on closed fd");
+ errno = EBADF;
+ return FALSE;
+}
+
+void
+do_accept(str, nstab, gstab)
+STR *str;
+STAB *nstab;
+STAB *gstab;
+{
+ register STIO *nstio;
+ register STIO *gstio;
+ int len = sizeof buf;
+ int fd;
+
+ if (!nstab)
+ goto badexit;
+ if (!gstab)
+ goto nuts;
+
+ gstio = stab_io(gstab);
+ nstio = stab_io(nstab);
+
+ if (!gstio || !gstio->ifp)
+ goto nuts;
+ if (!nstio)
+ nstio = stab_io(nstab) = stio_new();
+ else if (nstio->ifp)
+ do_close(nstab,FALSE);
+
+ fd = accept(fileno(gstio->ifp),(struct sockaddr *)buf,&len);
+ if (fd < 0)
+ goto badexit;
+ nstio->ifp = fdopen(fd, "r");
+ nstio->ofp = fdopen(fd, "w");
+ nstio->type = 's';
+ if (!nstio->ifp || !nstio->ofp) {
+ if (nstio->ifp) fclose(nstio->ifp);
+ if (nstio->ofp) fclose(nstio->ofp);
+ if (!nstio->ifp && !nstio->ofp) close(fd);
+ goto badexit;
+ }
+
+ str_nset(str, buf, len);
+ return;
+
+nuts:
+ if (dowarn)
+ warn("accept() on closed fd");
+ errno = EBADF;
+badexit:
+ str_sset(str,&str_undef);
+ return;
+}
+
+int
+do_shutdown(stab, arglast)
+STAB *stab;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register STIO *stio;
+ int how;
+
+ if (!stab)
+ goto nuts;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto nuts;
+
+ how = (int)str_gnum(st[++sp]);
+ return shutdown(fileno(stio->ifp), how) >= 0;
+
+nuts:
+ if (dowarn)
+ warn("shutdown() on closed fd");
+ errno = EBADF;
+ return FALSE;
+
+}
+
+int
+do_sopt(optype, stab, arglast)
+int optype;
+STAB *stab;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register STIO *stio;
+ int fd;
+ int lvl;
+ int optname;
+
+ if (!stab)
+ goto nuts;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto nuts;
+
+ fd = fileno(stio->ifp);
+ lvl = (int)str_gnum(st[sp+1]);
+ optname = (int)str_gnum(st[sp+2]);
+ switch (optype) {
+ case O_GSOCKOPT:
+ st[sp] = str_2mortal(Str_new(22,257));
+ st[sp]->str_cur = 256;
+ st[sp]->str_pok = 1;
+ if (getsockopt(fd, lvl, optname, st[sp]->str_ptr, &st[sp]->str_cur) < 0)
+ goto nuts;
+ break;
+ case O_SSOCKOPT:
+ st[sp] = st[sp+3];
+ if (setsockopt(fd, lvl, optname, st[sp]->str_ptr, st[sp]->str_cur) < 0)
+ goto nuts;
+ st[sp] = &str_yes;
+ break;
+ }
+
+ return sp;
+
+nuts:
+ if (dowarn)
+ warn("[gs]etsockopt() on closed fd");
+ st[sp] = &str_undef;
+ errno = EBADF;
+ return sp;
+
+}
+
+int
+do_getsockname(optype, stab, arglast)
+int optype;
+STAB *stab;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register STIO *stio;
+ int fd;
+
+ if (!stab)
+ goto nuts;
+
+ stio = stab_io(stab);
+ if (!stio || !stio->ifp)
+ goto nuts;
+
+ st[sp] = str_2mortal(Str_new(22,257));
+ st[sp]->str_cur = 256;
+ st[sp]->str_pok = 1;
+ fd = fileno(stio->ifp);
+ switch (optype) {
+ case O_GETSOCKNAME:
+ if (getsockname(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0)
+ goto nuts2;
+ break;
+ case O_GETPEERNAME:
+ if (getpeername(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0)
+ goto nuts2;
+ break;
+ }
+
+ return sp;
+
+nuts:
+ if (dowarn)
+ warn("get{sock,peer}name() on closed fd");
+ errno = EBADF;
+nuts2:
+ st[sp] = &str_undef;
+ return sp;
+
+}
+
+int
+do_ghent(which,gimme,arglast)
+int which;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ register int sp = arglast[0];
+ register char **elem;
+ register STR *str;
+ struct hostent *gethostbyname();
+ struct hostent *gethostbyaddr();
+#ifdef HAS_GETHOSTENT
+ struct hostent *gethostent();
+#endif
+ struct hostent *hent;
+ unsigned long len;
+
+ if (gimme != G_ARRAY) {
+ astore(ary, ++sp, str_mortal(&str_undef));
+ return sp;
+ }
+
+ if (which == O_GHBYNAME) {
+ char *name = str_get(ary->ary_array[sp+1]);
+
+ hent = gethostbyname(name);
+ }
+ else if (which == O_GHBYADDR) {
+ STR *addrstr = ary->ary_array[sp+1];
+ int addrtype = (int)str_gnum(ary->ary_array[sp+2]);
+ char *addr = str_get(addrstr);
+
+ hent = gethostbyaddr(addr,addrstr->str_cur,addrtype);
+ }
+ else
+#ifdef HAS_GETHOSTENT
+ hent = gethostent();
+#else
+ fatal("gethostent not implemented");
+#endif
+ if (hent) {
+#ifndef lint
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, hent->h_name);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ for (elem = hent->h_aliases; *elem; elem++) {
+ str_cat(str, *elem);
+ if (elem[1])
+ str_ncat(str," ",1);
+ }
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_numset(str, (double)hent->h_addrtype);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ len = hent->h_length;
+ str_numset(str, (double)len);
+#ifdef h_addr
+ for (elem = hent->h_addr_list; *elem; elem++) {
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_nset(str, *elem, len);
+ }
+#else
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_nset(str, hent->h_addr, len);
+#endif /* h_addr */
+#else /* lint */
+ elem = Nullch;
+ elem = elem;
+ (void)astore(ary, ++sp, str_mortal(&str_no));
+#endif /* lint */
+ }
+
+ return sp;
+}
+
+int
+do_gnent(which,gimme,arglast)
+int which;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ register int sp = arglast[0];
+ register char **elem;
+ register STR *str;
+ struct netent *getnetbyname();
+ struct netent *getnetbyaddr();
+ struct netent *getnetent();
+ struct netent *nent;
+
+ if (gimme != G_ARRAY) {
+ astore(ary, ++sp, str_mortal(&str_undef));
+ return sp;
+ }
+
+ if (which == O_GNBYNAME) {
+ char *name = str_get(ary->ary_array[sp+1]);
+
+ nent = getnetbyname(name);
+ }
+ else if (which == O_GNBYADDR) {
+ unsigned long addr = U_L(str_gnum(ary->ary_array[sp+1]));
+ int addrtype = (int)str_gnum(ary->ary_array[sp+2]);
+
+ nent = getnetbyaddr((long)addr,addrtype);
+ }
+ else
+ nent = getnetent();
+
+ if (nent) {
+#ifndef lint
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, nent->n_name);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ for (elem = nent->n_aliases; *elem; elem++) {
+ str_cat(str, *elem);
+ if (elem[1])
+ str_ncat(str," ",1);
+ }
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_numset(str, (double)nent->n_addrtype);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_numset(str, (double)nent->n_net);
+#else /* lint */
+ elem = Nullch;
+ elem = elem;
+ (void)astore(ary, ++sp, str_mortal(&str_no));
+#endif /* lint */
+ }
+
+ return sp;
+}
+
+int
+do_gpent(which,gimme,arglast)
+int which;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ register int sp = arglast[0];
+ register char **elem;
+ register STR *str;
+ struct protoent *getprotobyname();
+ struct protoent *getprotobynumber();
+ struct protoent *getprotoent();
+ struct protoent *pent;
+
+ if (gimme != G_ARRAY) {
+ astore(ary, ++sp, str_mortal(&str_undef));
+ return sp;
+ }
+
+ if (which == O_GPBYNAME) {
+ char *name = str_get(ary->ary_array[sp+1]);
+
+ pent = getprotobyname(name);
+ }
+ else if (which == O_GPBYNUMBER) {
+ int proto = (int)str_gnum(ary->ary_array[sp+1]);
+
+ pent = getprotobynumber(proto);
+ }
+ else
+ pent = getprotoent();
+
+ if (pent) {
+#ifndef lint
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, pent->p_name);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ for (elem = pent->p_aliases; *elem; elem++) {
+ str_cat(str, *elem);
+ if (elem[1])
+ str_ncat(str," ",1);
+ }
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_numset(str, (double)pent->p_proto);
+#else /* lint */
+ elem = Nullch;
+ elem = elem;
+ (void)astore(ary, ++sp, str_mortal(&str_no));
+#endif /* lint */
+ }
+
+ return sp;
+}
+
+int
+do_gsent(which,gimme,arglast)
+int which;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ register int sp = arglast[0];
+ register char **elem;
+ register STR *str;
+ struct servent *getservbyname();
+ struct servent *getservbynumber();
+ struct servent *getservent();
+ struct servent *sent;
+
+ if (gimme != G_ARRAY) {
+ astore(ary, ++sp, str_mortal(&str_undef));
+ return sp;
+ }
+
+ if (which == O_GSBYNAME) {
+ char *name = str_get(ary->ary_array[sp+1]);
+ char *proto = str_get(ary->ary_array[sp+2]);
+
+ if (proto && !*proto)
+ proto = Nullch;
+
+ sent = getservbyname(name,proto);
+ }
+ else if (which == O_GSBYPORT) {
+ int port = (int)str_gnum(ary->ary_array[sp+1]);
+ char *proto = str_get(ary->ary_array[sp+2]);
+
+ sent = getservbyport(port,proto);
+ }
+ else
+ sent = getservent();
+ if (sent) {
+#ifndef lint
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, sent->s_name);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ for (elem = sent->s_aliases; *elem; elem++) {
+ str_cat(str, *elem);
+ if (elem[1])
+ str_ncat(str," ",1);
+ }
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+#ifdef HAS_NTOHS
+ str_numset(str, (double)ntohs(sent->s_port));
+#else
+ str_numset(str, (double)(sent->s_port));
+#endif
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, sent->s_proto);
+#else /* lint */
+ elem = Nullch;
+ elem = elem;
+ (void)astore(ary, ++sp, str_mortal(&str_no));
+#endif /* lint */
+ }
+
+ return sp;
+}
+
+#endif /* HAS_SOCKET */
+
+#ifdef HAS_SELECT
+int
+do_select(gimme,arglast)
+int gimme;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ register int i;
+ register int j;
+ register char *s;
+ register STR *str;
+ double value;
+ int maxlen = 0;
+ int nfound;
+ struct timeval timebuf;
+ struct timeval *tbuf = &timebuf;
+ int growsize;
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ int masksize;
+ int offset;
+ char *fd_sets[4];
+ int k;
+
+#if BYTEORDER & 0xf0000
+#define ORDERBYTE (0x88888888 - BYTEORDER)
+#else
+#define ORDERBYTE (0x4444 - BYTEORDER)
+#endif
+
+#endif
+
+ for (i = 1; i <= 3; i++) {
+ j = st[sp+i]->str_cur;
+ 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
+
+ for (i = 1; i <= 3; i++) {
+ str = st[sp+i];
+ j = str->str_len;
+ if (j < growsize) {
+ if (str->str_pok) {
+ Str_Grow(str,growsize);
+ s = str_get(str) + j;
+ while (++j <= growsize) {
+ *s++ = '\0';
+ }
+ }
+ else if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_ptr = Nullch;
+ }
+ }
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ s = str->str_ptr;
+ if (s) {
+ 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];
+ }
+ }
+#endif
+ }
+ str = st[sp+4];
+ if (str->str_nok || str->str_pok) {
+ value = str_gnum(str);
+ 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*);
+
+#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+ nfound = select(
+ maxlen * 8,
+ st[sp+1]->str_ptr,
+ st[sp+2]->str_ptr,
+ st[sp+3]->str_ptr,
+ tbuf);
+#else
+ nfound = select(
+ maxlen * 8,
+ fd_sets[1],
+ fd_sets[2],
+ fd_sets[3],
+ tbuf);
+ for (i = 1; i <= 3; i++) {
+ if (fd_sets[i]) {
+ str = st[sp+i];
+ s = str->str_ptr;
+ 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];
+ }
+ }
+ }
+#endif
+
+ st[++sp] = str_mortal(&str_no);
+ str_numset(st[sp], (double)nfound);
+ if (gimme == G_ARRAY && tbuf) {
+ value = (double)(timebuf.tv_sec) +
+ (double)(timebuf.tv_usec) / 1000000.0;
+ st[++sp] = str_mortal(&str_no);
+ str_numset(st[sp], value);
+ }
+ return sp;
+}
+#endif /* SELECT */
+
+#ifdef HAS_SOCKET
+int
+do_spair(stab1, stab2, arglast)
+STAB *stab1;
+STAB *stab2;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[2];
+ register STIO *stio1;
+ register STIO *stio2;
+ int domain, type, protocol, fd[2];
+
+ if (!stab1 || !stab2)
+ return FALSE;
+
+ stio1 = stab_io(stab1);
+ stio2 = stab_io(stab2);
+ if (!stio1)
+ stio1 = stab_io(stab1) = stio_new();
+ else if (stio1->ifp)
+ do_close(stab1,FALSE);
+ if (!stio2)
+ stio2 = stab_io(stab2) = stio_new();
+ else if (stio2->ifp)
+ do_close(stab2,FALSE);
+
+ domain = (int)str_gnum(st[++sp]);
+ type = (int)str_gnum(st[++sp]);
+ protocol = (int)str_gnum(st[++sp]);
+#ifdef TAINT
+ taintproper("Insecure dependency in socketpair");
+#endif
+#ifdef HAS_SOCKETPAIR
+ if (socketpair(domain,type,protocol,fd) < 0)
+ return FALSE;
+#else
+ fatal("Socketpair unimplemented");
+#endif
+ stio1->ifp = fdopen(fd[0], "r");
+ stio1->ofp = fdopen(fd[0], "w");
+ stio1->type = 's';
+ stio2->ifp = fdopen(fd[1], "r");
+ stio2->ofp = fdopen(fd[1], "w");
+ stio2->type = 's';
+ if (!stio1->ifp || !stio1->ofp || !stio2->ifp || !stio2->ofp) {
+ if (stio1->ifp) fclose(stio1->ifp);
+ if (stio1->ofp) fclose(stio1->ofp);
+ if (!stio1->ifp && !stio1->ofp) close(fd[0]);
+ if (stio2->ifp) fclose(stio2->ifp);
+ if (stio2->ofp) fclose(stio2->ofp);
+ if (!stio2->ifp && !stio2->ofp) close(fd[1]);
+ return FALSE;
+ }
+
+ return TRUE;
+}
+
+#endif /* HAS_SOCKET */
+
+int
+do_gpwent(which,gimme,arglast)
+int which;
+int gimme;
+int *arglast;
+{
+#ifdef I_PWD
+ register ARRAY *ary = stack;
+ register int sp = arglast[0];
+ register STR *str;
+ struct passwd *getpwnam();
+ struct passwd *getpwuid();
+ struct passwd *getpwent();
+ struct passwd *pwent;
+
+ if (gimme != G_ARRAY) {
+ astore(ary, ++sp, str_mortal(&str_undef));
+ return sp;
+ }
+
+ if (which == O_GPWNAM) {
+ char *name = str_get(ary->ary_array[sp+1]);
+
+ pwent = getpwnam(name);
+ }
+ else if (which == O_GPWUID) {
+ int uid = (int)str_gnum(ary->ary_array[sp+1]);
+
+ pwent = getpwuid(uid);
+ }
+ else
+ pwent = getpwent();
+
+ if (pwent) {
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, pwent->pw_name);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, pwent->pw_passwd);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_numset(str, (double)pwent->pw_uid);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_numset(str, (double)pwent->pw_gid);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+#ifdef PWCHANGE
+ str_numset(str, (double)pwent->pw_change);
+#else
+#ifdef PWQUOTA
+ str_numset(str, (double)pwent->pw_quota);
+#else
+#ifdef PWAGE
+ str_set(str, pwent->pw_age);
+#endif
+#endif
+#endif
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+#ifdef PWCLASS
+ str_set(str,pwent->pw_class);
+#else
+#ifdef PWCOMMENT
+ str_set(str, pwent->pw_comment);
+#endif
+#endif
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, pwent->pw_gecos);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, pwent->pw_dir);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, pwent->pw_shell);
+#ifdef PWEXPIRE
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_numset(str, (double)pwent->pw_expire);
+#endif
+ }
+
+ return sp;
+#else
+ fatal("password routines not implemented");
+#endif
+}
+
+int
+do_ggrent(which,gimme,arglast)
+int which;
+int gimme;
+int *arglast;
+{
+#ifdef I_GRP
+ register ARRAY *ary = stack;
+ register int sp = arglast[0];
+ register char **elem;
+ register STR *str;
+ struct group *getgrnam();
+ struct group *getgrgid();
+ struct group *getgrent();
+ struct group *grent;
+
+ if (gimme != G_ARRAY) {
+ astore(ary, ++sp, str_mortal(&str_undef));
+ return sp;
+ }
+
+ if (which == O_GGRNAM) {
+ char *name = str_get(ary->ary_array[sp+1]);
+
+ grent = getgrnam(name);
+ }
+ else if (which == O_GGRGID) {
+ int gid = (int)str_gnum(ary->ary_array[sp+1]);
+
+ grent = getgrgid(gid);
+ }
+ else
+ grent = getgrent();
+
+ if (grent) {
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, grent->gr_name);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_set(str, grent->gr_passwd);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_numset(str, (double)grent->gr_gid);
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ for (elem = grent->gr_mem; *elem; elem++) {
+ str_cat(str, *elem);
+ if (elem[1])
+ str_ncat(str," ",1);
+ }
+ }
+
+ return sp;
+#else
+ fatal("group routines not implemented");
+#endif
+}
+
+int
+do_dirop(optype,stab,gimme,arglast)
+int optype;
+STAB *stab;
+int gimme;
+int *arglast;
+{
+#if defined(DIRENT) && defined(HAS_READDIR)
+ register ARRAY *ary = stack;
+ register STR **st = ary->ary_array;
+ register int sp = arglast[1];
+ register STIO *stio;
+ long along;
+#ifndef telldir
+ long telldir();
+#endif
+#ifndef apollo
+ struct DIRENT *readdir();
+#endif
+ register struct DIRENT *dp;
+
+ if (!stab)
+ goto nope;
+ if (!(stio = stab_io(stab)))
+ stio = stab_io(stab) = stio_new();
+ if (!stio->dirp && optype != O_OPEN_DIR)
+ goto nope;
+ st[sp] = &str_yes;
+ switch (optype) {
+ case O_OPEN_DIR:
+ if (stio->dirp)
+ closedir(stio->dirp);
+ if (!(stio->dirp = opendir(str_get(st[sp+1]))))
+ goto nope;
+ break;
+ case O_READDIR:
+ if (gimme == G_ARRAY) {
+ --sp;
+ /*SUPPRESS 560*/
+ while (dp = readdir(stio->dirp)) {
+#ifdef DIRNAMLEN
+ (void)astore(ary,++sp,
+ str_2mortal(str_make(dp->d_name,dp->d_namlen)));
+#else
+ (void)astore(ary,++sp,
+ str_2mortal(str_make(dp->d_name,0)));
+#endif
+ }
+ }
+ else {
+ if (!(dp = readdir(stio->dirp)))
+ goto nope;
+ st[sp] = str_mortal(&str_undef);
+#ifdef DIRNAMLEN
+ str_nset(st[sp], dp->d_name, dp->d_namlen);
+#else
+ str_set(st[sp], dp->d_name);
+#endif
+ }
+ break;
+#if MACH
+ case O_TELLDIR:
+ case O_SEEKDIR:
+ goto nope;
+#else
+ case O_TELLDIR:
+ st[sp] = str_mortal(&str_undef);
+ str_numset(st[sp], (double)telldir(stio->dirp));
+ break;
+ case O_SEEKDIR:
+ st[sp] = str_mortal(&str_undef);
+ along = (long)str_gnum(st[sp+1]);
+ (void)seekdir(stio->dirp,along);
+ break;
+#endif
+ case O_REWINDDIR:
+ st[sp] = str_mortal(&str_undef);
+ (void)rewinddir(stio->dirp);
+ break;
+ case O_CLOSEDIR:
+ st[sp] = str_mortal(&str_undef);
+ (void)closedir(stio->dirp);
+ stio->dirp = 0;
+ break;
+ }
+ return sp;
+
+nope:
+ st[sp] = &str_undef;
+ if (!errno)
+ errno = EBADF;
+ return sp;
+
+#else
+ fatal("Unimplemented directory operation");
+#endif
+}
+
+apply(type,arglast)
+int type;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int items = arglast[2] - sp;
+ register int val;
+ register int val2;
+ register int tot = 0;
+ char *s;
+
+#ifdef TAINT
+ for (st += ++sp; items--; st++)
+ tainted |= (*st)->str_tainted;
+ st = stack->ary_array;
+ sp = arglast[1];
+ items = arglast[2] - sp;
+#endif
+ switch (type) {
+ case O_CHMOD:
+#ifdef TAINT
+ taintproper("Insecure dependency in chmod");
+#endif
+ if (--items > 0) {
+ tot = items;
+ val = (int)str_gnum(st[++sp]);
+ while (items--) {
+ if (chmod(str_get(st[++sp]),val))
+ tot--;
+ }
+ }
+ break;
+#ifdef HAS_CHOWN
+ case O_CHOWN:
+#ifdef TAINT
+ taintproper("Insecure dependency in chown");
+#endif
+ if (items > 2) {
+ items -= 2;
+ tot = items;
+ val = (int)str_gnum(st[++sp]);
+ val2 = (int)str_gnum(st[++sp]);
+ while (items--) {
+ if (chown(str_get(st[++sp]),val,val2))
+ tot--;
+ }
+ }
+ break;
+#endif
+#ifdef HAS_KILL
+ case O_KILL:
+#ifdef TAINT
+ taintproper("Insecure dependency in kill");
+#endif
+ if (--items > 0) {
+ tot = items;
+ s = str_get(st[++sp]);
+ if (isUPPER(*s)) {
+ if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
+ s += 3;
+ if (!(val = whichsig(s)))
+ fatal("Unrecognized signal name \"%s\"",s);
+ }
+ else
+ val = (int)str_gnum(st[sp]);
+ if (val < 0) {
+ val = -val;
+ while (items--) {
+ int proc = (int)str_gnum(st[++sp]);
+#ifdef HAS_KILLPG
+ if (killpg(proc,val)) /* BSD */
+#else
+ if (kill(-proc,val)) /* SYSV */
+#endif
+ tot--;
+ }
+ }
+ else {
+ while (items--) {
+ if (kill((int)(str_gnum(st[++sp])),val))
+ tot--;
+ }
+ }
+ }
+ break;
+#endif
+ case O_UNLINK:
+#ifdef TAINT
+ taintproper("Insecure dependency in unlink");
+#endif
+ tot = items;
+ while (items--) {
+ s = str_get(st[++sp]);
+ if (euid || unsafe) {
+ if (UNLINK(s))
+ tot--;
+ }
+ else { /* don't let root wipe out directories without -U */
+#ifdef HAS_LSTAT
+ if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
+#else
+ if (stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
+#endif
+ tot--;
+ else {
+ if (UNLINK(s))
+ tot--;
+ }
+ }
+ }
+ break;
+ case O_UTIME:
+#ifdef TAINT
+ taintproper("Insecure dependency in utime");
+#endif
+ if (items > 2) {
+#ifdef I_UTIME
+ struct utimbuf utbuf;
+#else
+ struct {
+ long actime;
+ long modtime;
+ } utbuf;
+#endif
+
+ Zero(&utbuf, sizeof utbuf, char);
+ utbuf.actime = (long)str_gnum(st[++sp]); /* time accessed */
+ utbuf.modtime = (long)str_gnum(st[++sp]); /* time modified */
+ items -= 2;
+#ifndef lint
+ tot = items;
+ while (items--) {
+ if (utime(str_get(st[++sp]),&utbuf))
+ tot--;
+ }
+#endif
+ }
+ else
+ items = 0;
+ break;
+ }
+ return tot;
+}
+
+/* Do the permissions allow some operation? Assumes statcache already set. */
+
+int
+cando(bit, effective, statbufp)
+int bit;
+int effective;
+register struct stat *statbufp;
+{
+#ifdef MSDOS
+ /* [Comments and code from Len Reed]
+ * MS-DOS "user" is similar to UNIX's "superuser," but can't write
+ * to write-protected files. The execute permission bit is set
+ * by the Miscrosoft C library stat() function for the following:
+ * .exe files
+ * .com files
+ * .bat files
+ * directories
+ * All files and directories are readable.
+ * Directories and special files, e.g. "CON", cannot be
+ * write-protected.
+ * [Comment by Tom Dinger -- a directory can have the write-protect
+ * bit set in the file system, but DOS permits changes to
+ * the directory anyway. In addition, all bets are off
+ * here for networked software, such as Novell and
+ * Sun's PC-NFS.]
+ */
+
+ return (bit & statbufp->st_mode) ? TRUE : FALSE;
+
+#else /* ! MSDOS */
+ if ((effective ? euid : uid) == 0) { /* root is special */
+ if (bit == S_IXUSR) {
+ if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
+ return TRUE;
+ }
+ else
+ return TRUE; /* root reads and writes anything */
+ return FALSE;
+ }
+ if (statbufp->st_uid == (effective ? euid : uid) ) {
+ if (statbufp->st_mode & bit)
+ return TRUE; /* ok as "user" */
+ }
+ else if (ingroup((int)statbufp->st_gid,effective)) {
+ if (statbufp->st_mode & bit >> 3)
+ return TRUE; /* ok as "group" */
+ }
+ else if (statbufp->st_mode & bit >> 6)
+ return TRUE; /* ok as "other" */
+ return FALSE;
+#endif /* ! MSDOS */
+}
+
+int
+ingroup(testgid,effective)
+int testgid;
+int effective;
+{
+ if (testgid == (effective ? egid : gid))
+ return TRUE;
+#ifdef HAS_GETGROUPS
+#ifndef NGROUPS
+#define NGROUPS 32
+#endif
+ {
+ GROUPSTYPE gary[NGROUPS];
+ int anum;
+
+ anum = getgroups(NGROUPS,gary);
+ while (--anum >= 0)
+ if (gary[anum] == testgid)
+ return TRUE;
+ }
+#endif
+ return FALSE;
+}
+
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+
+int
+do_ipcget(optype, arglast)
+int optype;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ key_t key;
+ int n, flags;
+
+ key = (key_t)str_gnum(st[++sp]);
+ n = (optype == O_MSGGET) ? 0 : (int)str_gnum(st[++sp]);
+ flags = (int)str_gnum(st[++sp]);
+ errno = 0;
+ switch (optype)
+ {
+#ifdef HAS_MSG
+ case O_MSGGET:
+ return msgget(key, flags);
+#endif
+#ifdef HAS_SEM
+ case O_SEMGET:
+ return semget(key, n, flags);
+#endif
+#ifdef HAS_SHM
+ case O_SHMGET:
+ return shmget(key, n, flags);
+#endif
+#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
+ default:
+ fatal("%s not implemented", opname[optype]);
+#endif
+ }
+ return -1; /* should never happen */
+}
+
+int
+do_ipcctl(optype, arglast)
+int optype;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *astr;
+ char *a;
+ int id, n, cmd, infosize, getinfo, ret;
+
+ id = (int)str_gnum(st[++sp]);
+ n = (optype == O_SEMCTL) ? (int)str_gnum(st[++sp]) : 0;
+ cmd = (int)str_gnum(st[++sp]);
+ astr = st[++sp];
+
+ infosize = 0;
+ getinfo = (cmd == IPC_STAT);
+
+ switch (optype)
+ {
+#ifdef HAS_MSG
+ case O_MSGCTL:
+ if (cmd == IPC_STAT || cmd == IPC_SET)
+ infosize = sizeof(struct msqid_ds);
+ break;
+#endif
+#ifdef HAS_SHM
+ case O_SHMCTL:
+ if (cmd == IPC_STAT || cmd == IPC_SET)
+ infosize = sizeof(struct shmid_ds);
+ break;
+#endif
+#ifdef HAS_SEM
+ case O_SEMCTL:
+ if (cmd == IPC_STAT || cmd == IPC_SET)
+ infosize = sizeof(struct semid_ds);
+ else if (cmd == GETALL || cmd == SETALL)
+ {
+ struct semid_ds semds;
+ if (semctl(id, 0, IPC_STAT, &semds) == -1)
+ return -1;
+ getinfo = (cmd == GETALL);
+ infosize = semds.sem_nsems * sizeof(short);
+ /* "short" is technically wrong but much more portable
+ than guessing about u_?short(_t)? */
+ }
+ break;
+#endif
+#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
+ default:
+ fatal("%s not implemented", opname[optype]);
+#endif
+ }
+
+ if (infosize)
+ {
+ if (getinfo)
+ {
+ STR_GROW(astr, infosize+1);
+ a = str_get(astr);
+ }
+ else
+ {
+ a = str_get(astr);
+ if (astr->str_cur != infosize)
+ {
+ errno = EINVAL;
+ return -1;
+ }
+ }
+ }
+ else
+ {
+ int i = (int)str_gnum(astr);
+ a = (char *)i; /* ouch */
+ }
+ errno = 0;
+ switch (optype)
+ {
+#ifdef HAS_MSG
+ case O_MSGCTL:
+ ret = msgctl(id, cmd, a);
+ break;
+#endif
+#ifdef HAS_SEM
+ case O_SEMCTL:
+ ret = semctl(id, n, cmd, a);
+ break;
+#endif
+#ifdef HAS_SHM
+ case O_SHMCTL:
+ ret = shmctl(id, cmd, a);
+ break;
+#endif
+ }
+ if (getinfo && ret >= 0) {
+ astr->str_cur = infosize;
+ astr->str_ptr[infosize] = '\0';
+ }
+ return ret;
+}
+
+int
+do_msgsnd(arglast)
+int *arglast;
+{
+#ifdef HAS_MSG
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *mstr;
+ char *mbuf;
+ int id, msize, flags;
+
+ id = (int)str_gnum(st[++sp]);
+ mstr = st[++sp];
+ flags = (int)str_gnum(st[++sp]);
+ mbuf = str_get(mstr);
+ if ((msize = mstr->str_cur - sizeof(long)) < 0) {
+ errno = EINVAL;
+ return -1;
+ }
+ errno = 0;
+ return msgsnd(id, mbuf, msize, flags);
+#else
+ fatal("msgsnd not implemented");
+#endif
+}
+
+int
+do_msgrcv(arglast)
+int *arglast;
+{
+#ifdef HAS_MSG
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *mstr;
+ char *mbuf;
+ long mtype;
+ int id, msize, flags, ret;
+
+ id = (int)str_gnum(st[++sp]);
+ mstr = st[++sp];
+ msize = (int)str_gnum(st[++sp]);
+ mtype = (long)str_gnum(st[++sp]);
+ flags = (int)str_gnum(st[++sp]);
+ mbuf = str_get(mstr);
+ if (mstr->str_cur < sizeof(long)+msize+1) {
+ STR_GROW(mstr, sizeof(long)+msize+1);
+ mbuf = str_get(mstr);
+ }
+ errno = 0;
+ ret = msgrcv(id, mbuf, msize, mtype, flags);
+ if (ret >= 0) {
+ mstr->str_cur = sizeof(long)+ret;
+ mstr->str_ptr[sizeof(long)+ret] = '\0';
+ }
+ return ret;
+#else
+ fatal("msgrcv not implemented");
+#endif
+}
+
+int
+do_semop(arglast)
+int *arglast;
+{
+#ifdef HAS_SEM
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *opstr;
+ char *opbuf;
+ int id, opsize;
+
+ id = (int)str_gnum(st[++sp]);
+ opstr = st[++sp];
+ opbuf = str_get(opstr);
+ opsize = opstr->str_cur;
+ if (opsize < sizeof(struct sembuf)
+ || (opsize % sizeof(struct sembuf)) != 0) {
+ errno = EINVAL;
+ return -1;
+ }
+ errno = 0;
+ return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
+#else
+ fatal("semop not implemented");
+#endif
+}
+
+int
+do_shmio(optype, arglast)
+int optype;
+int *arglast;
+{
+#ifdef HAS_SHM
+ register STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ STR *mstr;
+ char *mbuf, *shm;
+ int id, mpos, msize;
+ struct shmid_ds shmds;
+#ifndef VOIDSHMAT
+ extern char *shmat();
+#endif
+
+ id = (int)str_gnum(st[++sp]);
+ mstr = st[++sp];
+ mpos = (int)str_gnum(st[++sp]);
+ msize = (int)str_gnum(st[++sp]);
+ errno = 0;
+ if (shmctl(id, IPC_STAT, &shmds) == -1)
+ return -1;
+ if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
+ errno = EFAULT; /* can't do as caller requested */
+ return -1;
+ }
+ shm = (char*)shmat(id, (char*)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
+ if (shm == (char *)-1) /* I hate System V IPC, I really do */
+ return -1;
+ mbuf = str_get(mstr);
+ if (optype == O_SHMREAD) {
+ if (mstr->str_cur < msize) {
+ STR_GROW(mstr, msize+1);
+ mbuf = str_get(mstr);
+ }
+ bcopy(shm + mpos, mbuf, msize);
+ mstr->str_cur = msize;
+ mstr->str_ptr[msize] = '\0';
+ }
+ else {
+ int n;
+
+ if ((n = mstr->str_cur) > msize)
+ n = msize;
+ bcopy(mbuf, shm + mpos, n);
+ if (n < msize)
+ bzero(shm + mpos + n, msize - n);
+ }
+ return shmdt(shm);
+#else
+ fatal("shm I/O not implemented");
+#endif
+}
+
+#endif /* SYSV IPC */
--- /dev/null
+/* $RCSfile: dolist.c,v $$Revision: 4.0.1.4 $$Date: 91/11/11 16:33:19 $
+ *
+ * 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: dolist.c,v $
+ * Revision 4.0.1.4 91/11/11 16:33:19 lwall
+ * patch19: added little-endian pack/unpack options
+ * patch19: sort $subname was busted by changes in 4.018
+ *
+ * Revision 4.0.1.3 91/11/05 17:07:02 lwall
+ * patch11: prepared for ctype implementations that don't define isascii()
+ * patch11: /$foo/o optimizer could access deallocated data
+ * patch11: certain optimizations of //g in array context returned too many values
+ * patch11: regexp with no parens in array context returned wacky $`, $& and $'
+ * patch11: $' not set right on some //g
+ * patch11: added some support for 64-bit integers
+ * patch11: grep of a split lost its values
+ * patch11: added sort {} LIST
+ * patch11: multiple reallocations now avoided in 1 .. 100000
+ *
+ * Revision 4.0.1.2 91/06/10 01:22:15 lwall
+ * patch10: //g only worked first time through
+ *
+ * Revision 4.0.1.1 91/06/07 10:58:28 lwall
+ * patch4: new copyright notice
+ * patch4: added global modifier for pattern matches
+ * 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: $` was busted inside s///
+ * patch4: caller($arg) didn't work except under debugger
+ *
+ * Revision 4.0 91/03/20 01:08:03 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+
+#ifdef BUGGY_MSC
+ #pragma function(memcmp)
+#endif /* BUGGY_MSC */
+
+int
+do_match(str,arg,gimme,arglast)
+STR *str;
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register SPAT *spat = arg[2].arg_ptr.arg_spat;
+ register char *t;
+ register int sp = arglast[0] + 1;
+ STR *srchstr = st[sp];
+ register char *s = str_get(st[sp]);
+ char *strend = s + st[sp]->str_cur;
+ STR *tmpstr;
+ char *myhint = hint;
+ int global;
+ int safebase;
+
+ hint = Nullch;
+ if (!spat) {
+ if (gimme == G_ARRAY)
+ return --sp;
+ str_set(str,Yes);
+ STABSET(str);
+ st[sp] = str;
+ return sp;
+ }
+ global = spat->spat_flags & SPAT_GLOBAL;
+ safebase = (gimme == G_ARRAY) || global;
+ if (!s)
+ fatal("panic: do_match");
+ if (spat->spat_flags & SPAT_USED) {
+#ifdef DEBUGGING
+ if (debug & 8)
+ deb("2.SPAT USED\n");
+#endif
+ if (gimme == G_ARRAY)
+ return --sp;
+ str_set(str,No);
+ STABSET(str);
+ st[sp] = str;
+ return sp;
+ }
+ --sp;
+ if (spat->spat_runtime) {
+ nointrp = "|)";
+ sp = eval(spat->spat_runtime,G_SCALAR,sp);
+ st = stack->ary_array;
+ t = str_get(tmpstr = st[sp--]);
+ nointrp = "";
+#ifdef DEBUGGING
+ if (debug & 8)
+ deb("2.SPAT /%s/\n",t);
+#endif
+ if (spat->spat_regexp) {
+ regfree(spat->spat_regexp);
+ spat->spat_regexp = Null(REGEXP*); /* crucial if regcomp aborts */
+ }
+ spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
+ spat->spat_flags & SPAT_FOLD);
+ if (!spat->spat_regexp->prelen && lastspat)
+ spat = lastspat;
+ if (spat->spat_flags & SPAT_KEEP) {
+ scanconst(spat,spat->spat_regexp->precomp, spat->spat_regexp->prelen);
+ if (spat->spat_runtime)
+ arg_free(spat->spat_runtime); /* it won't change, so */
+ spat->spat_runtime = Nullarg; /* no point compiling again */
+ hoistmust(spat);
+ if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
+ curcmd->c_flags &= ~CF_OPTIMIZE;
+ opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
+ }
+ }
+ if (global) {
+ if (spat->spat_regexp->startp[0]) {
+ s = spat->spat_regexp->endp[0];
+ }
+ }
+ else if (!spat->spat_regexp->nparens)
+ gimme = G_SCALAR; /* accidental array context? */
+ if (regexec(spat->spat_regexp, s, strend, s, 0,
+ srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
+ safebase)) {
+ if (spat->spat_regexp->subbase || global)
+ curspat = spat;
+ lastspat = spat;
+ goto gotcha;
+ }
+ else {
+ if (gimme == G_ARRAY)
+ return sp;
+ str_sset(str,&str_no);
+ STABSET(str);
+ st[++sp] = str;
+ return sp;
+ }
+ }
+ else {
+#ifdef DEBUGGING
+ if (debug & 8) {
+ char ch;
+
+ if (spat->spat_flags & SPAT_ONCE)
+ ch = '?';
+ else
+ ch = '/';
+ deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
+ }
+#endif
+ if (!spat->spat_regexp->prelen && lastspat)
+ spat = lastspat;
+ t = s;
+ play_it_again:
+ if (global && spat->spat_regexp->startp[0])
+ t = s = spat->spat_regexp->endp[0];
+ if (myhint) {
+ if (myhint < s || myhint > strend)
+ fatal("panic: hint in do_match");
+ s = myhint;
+ if (spat->spat_regexp->regback >= 0) {
+ s -= spat->spat_regexp->regback;
+ if (s < t)
+ s = t;
+ }
+ else
+ s = t;
+ }
+ else if (spat->spat_short) {
+ if (spat->spat_flags & SPAT_SCANFIRST) {
+ if (srchstr->str_pok & SP_STUDIED) {
+ if (screamfirst[spat->spat_short->str_rare] < 0)
+ goto nope;
+ else if (!(s = screaminstr(srchstr,spat->spat_short)))
+ goto nope;
+ else if (spat->spat_flags & SPAT_ALL)
+ goto yup;
+ }
+#ifndef lint
+ else if (!(s = fbminstr((unsigned char*)s,
+ (unsigned char*)strend, spat->spat_short)))
+ goto nope;
+#endif
+ else if (spat->spat_flags & SPAT_ALL)
+ goto yup;
+ if (s && spat->spat_regexp->regback >= 0) {
+ ++spat->spat_short->str_u.str_useful;
+ s -= spat->spat_regexp->regback;
+ if (s < t)
+ s = t;
+ }
+ else
+ s = t;
+ }
+ else if (!multiline && (*spat->spat_short->str_ptr != *s ||
+ bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) ))
+ goto nope;
+ if (--spat->spat_short->str_u.str_useful < 0) {
+ str_free(spat->spat_short);
+ spat->spat_short = Nullstr; /* opt is being useless */
+ }
+ }
+ if (!spat->spat_regexp->nparens && !global) {
+ gimme = G_SCALAR; /* accidental array context? */
+ safebase = FALSE;
+ }
+ if (regexec(spat->spat_regexp, s, strend, t, 0,
+ srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
+ safebase)) {
+ if (spat->spat_regexp->subbase || global)
+ curspat = spat;
+ lastspat = spat;
+ if (spat->spat_flags & SPAT_ONCE)
+ spat->spat_flags |= SPAT_USED;
+ goto gotcha;
+ }
+ else {
+ if (global)
+ spat->spat_regexp->startp[0] = Nullch;
+ if (gimme == G_ARRAY)
+ return sp;
+ str_sset(str,&str_no);
+ STABSET(str);
+ st[++sp] = str;
+ return sp;
+ }
+ }
+ /*NOTREACHED*/
+
+ gotcha:
+ if (gimme == G_ARRAY) {
+ int iters, i, len;
+
+ iters = spat->spat_regexp->nparens;
+ if (global && !iters)
+ i = 1;
+ else
+ i = 0;
+ if (sp + iters + i >= stack->ary_max) {
+ astore(stack,sp + iters + i, Nullstr);
+ st = stack->ary_array; /* possibly realloced */
+ }
+
+ for (i = !i; i <= iters; i++) {
+ st[++sp] = str_mortal(&str_no);
+ /*SUPPRESS 560*/
+ if (s = spat->spat_regexp->startp[i]) {
+ len = spat->spat_regexp->endp[i] - s;
+ if (len > 0)
+ str_nset(st[sp],s,len);
+ }
+ }
+ if (global)
+ goto play_it_again;
+ return sp;
+ }
+ else {
+ str_sset(str,&str_yes);
+ STABSET(str);
+ st[++sp] = str;
+ return sp;
+ }
+
+yup:
+ ++spat->spat_short->str_u.str_useful;
+ lastspat = spat;
+ if (spat->spat_flags & SPAT_ONCE)
+ spat->spat_flags |= SPAT_USED;
+ if (global) {
+ spat->spat_regexp->subbeg = t;
+ spat->spat_regexp->subend = strend;
+ spat->spat_regexp->startp[0] = s;
+ spat->spat_regexp->endp[0] = s + spat->spat_short->str_cur;
+ curspat = spat;
+ goto gotcha;
+ }
+ if (sawampersand) {
+ char *tmps;
+
+ if (spat->spat_regexp->subbase)
+ Safefree(spat->spat_regexp->subbase);
+ tmps = spat->spat_regexp->subbase = nsavestr(t,strend-t);
+ spat->spat_regexp->subbeg = tmps;
+ spat->spat_regexp->subend = tmps + (strend-t);
+ tmps = spat->spat_regexp->startp[0] = tmps + (s - t);
+ spat->spat_regexp->endp[0] = tmps + spat->spat_short->str_cur;
+ curspat = spat;
+ }
+ str_sset(str,&str_yes);
+ STABSET(str);
+ st[++sp] = str;
+ return sp;
+
+nope:
+ spat->spat_regexp->startp[0] = Nullch;
+ ++spat->spat_short->str_u.str_useful;
+ if (global)
+ spat->spat_regexp->startp[0] = Nullch;
+ if (gimme == G_ARRAY)
+ return sp;
+ str_sset(str,&str_no);
+ STABSET(str);
+ st[++sp] = str;
+ return sp;
+}
+
+#ifdef BUGGY_MSC
+ #pragma intrinsic(memcmp)
+#endif /* BUGGY_MSC */
+
+int
+do_split(str,spat,limit,gimme,arglast)
+STR *str;
+register SPAT *spat;
+register int limit;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ STR **st = ary->ary_array;
+ register int sp = arglast[0] + 1;
+ register char *s = str_get(st[sp]);
+ char *strend = s + st[sp--]->str_cur;
+ register STR *dstr;
+ register char *m;
+ int iters = 0;
+ int maxiters = (strend - s) + 10;
+ int i;
+ char *orig;
+ int origlimit = limit;
+ int realarray = 0;
+
+ if (!spat || !s)
+ fatal("panic: do_split");
+ else if (spat->spat_runtime) {
+ nointrp = "|)";
+ sp = eval(spat->spat_runtime,G_SCALAR,sp);
+ st = stack->ary_array;
+ m = str_get(dstr = st[sp--]);
+ nointrp = "";
+ if (*m == ' ' && dstr->str_cur == 1) {
+ str_set(dstr,"\\s+");
+ m = dstr->str_ptr;
+ spat->spat_flags |= SPAT_SKIPWHITE;
+ }
+ if (spat->spat_regexp) {
+ regfree(spat->spat_regexp);
+ spat->spat_regexp = Null(REGEXP*); /* avoid possible double free */
+ }
+ spat->spat_regexp = regcomp(m,m+dstr->str_cur,
+ spat->spat_flags & SPAT_FOLD);
+ if (spat->spat_flags & SPAT_KEEP ||
+ (spat->spat_runtime->arg_type == O_ITEM &&
+ (spat->spat_runtime[1].arg_type & A_MASK) == A_SINGLE) ) {
+ arg_free(spat->spat_runtime); /* it won't change, so */
+ spat->spat_runtime = Nullarg; /* no point compiling again */
+ }
+ }
+#ifdef DEBUGGING
+ if (debug & 8) {
+ deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
+ }
+#endif
+ ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab);
+ if (ary && (gimme != G_ARRAY || (spat->spat_flags & SPAT_ONCE))) {
+ realarray = 1;
+ if (!(ary->ary_flags & ARF_REAL)) {
+ ary->ary_flags |= ARF_REAL;
+ for (i = ary->ary_fill; i >= 0; i--)
+ ary->ary_array[i] = Nullstr; /* don't free mere refs */
+ }
+ ary->ary_fill = -1;
+ sp = -1; /* temporarily switch stacks */
+ }
+ else
+ ary = stack;
+ orig = s;
+ if (spat->spat_flags & SPAT_SKIPWHITE) {
+ while (isSPACE(*s))
+ s++;
+ }
+ if (!limit)
+ limit = maxiters + 2;
+ if (strEQ("\\s+",spat->spat_regexp->precomp)) {
+ while (--limit) {
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && !isSPACE(*m); m++) ;
+ if (m >= strend)
+ break;
+ dstr = Str_new(30,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ /*SUPPRESS 530*/
+ for (s = m + 1; s < strend && isSPACE(*s); s++) ;
+ }
+ }
+ else if (strEQ("^",spat->spat_regexp->precomp)) {
+ while (--limit) {
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != '\n'; m++) ;
+ m++;
+ if (m >= strend)
+ break;
+ dstr = Str_new(30,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ s = m;
+ }
+ }
+ else if (spat->spat_short) {
+ i = spat->spat_short->str_cur;
+ if (i == 1) {
+ int fold = (spat->spat_flags & SPAT_FOLD);
+
+ i = *spat->spat_short->str_ptr;
+ if (fold && isUPPER(i))
+ i = tolower(i);
+ while (--limit) {
+ if (fold) {
+ for ( m = s;
+ m < strend && *m != i &&
+ (!isUPPER(*m) || tolower(*m) != i);
+ m++) /*SUPPRESS 530*/
+ ;
+ }
+ else /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != i; m++) ;
+ if (m >= strend)
+ break;
+ dstr = Str_new(30,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ s = m + 1;
+ }
+ }
+ else {
+#ifndef lint
+ while (s < strend && --limit &&
+ (m=fbminstr((unsigned char*)s, (unsigned char*)strend,
+ spat->spat_short)) )
+#endif
+ {
+ dstr = Str_new(31,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ s = m + i;
+ }
+ }
+ }
+ else {
+ maxiters += (strend - s) * spat->spat_regexp->nparens;
+ while (s < strend && --limit &&
+ regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) {
+ if (spat->spat_regexp->subbase
+ && spat->spat_regexp->subbase != orig) {
+ m = s;
+ s = orig;
+ orig = spat->spat_regexp->subbase;
+ s = orig + (m - s);
+ strend = s + (strend - m);
+ }
+ m = spat->spat_regexp->startp[0];
+ dstr = Str_new(32,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ if (spat->spat_regexp->nparens) {
+ for (i = 1; i <= spat->spat_regexp->nparens; i++) {
+ s = spat->spat_regexp->startp[i];
+ m = spat->spat_regexp->endp[i];
+ dstr = Str_new(33,m-s);
+ str_nset(dstr,s,m-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ }
+ }
+ s = spat->spat_regexp->endp[0];
+ }
+ }
+ if (realarray)
+ iters = sp + 1;
+ else
+ iters = sp - arglast[0];
+ if (iters > maxiters)
+ fatal("Split loop");
+ if (s < strend || origlimit) { /* keep field after final delim? */
+ dstr = Str_new(34,strend-s);
+ str_nset(dstr,s,strend-s);
+ if (!realarray)
+ str_2mortal(dstr);
+ (void)astore(ary, ++sp, dstr);
+ iters++;
+ }
+ else {
+#ifndef I286x
+ while (iters > 0 && ary->ary_array[sp]->str_cur == 0)
+ iters--,sp--;
+#else
+ char *zaps;
+ int zapb;
+
+ if (iters > 0) {
+ zaps = str_get(afetch(ary,sp,FALSE));
+ zapb = (int) *zaps;
+ }
+
+ while (iters > 0 && (!zapb)) {
+ iters--,sp--;
+ if (iters > 0) {
+ zaps = str_get(afetch(ary,iters-1,FALSE));
+ zapb = (int) *zaps;
+ }
+ }
+#endif
+ }
+ if (realarray) {
+ ary->ary_fill = sp;
+ if (gimme == G_ARRAY) {
+ sp++;
+ astore(stack, arglast[0] + 1 + sp, Nullstr);
+ Copy(ary->ary_array, stack->ary_array + arglast[0] + 1, sp, STR*);
+ return arglast[0] + sp;
+ }
+ }
+ else {
+ if (gimme == G_ARRAY)
+ return sp;
+ }
+ sp = arglast[0] + 1;
+ str_numset(str,(double)iters);
+ STABSET(str);
+ st[sp] = str;
+ return sp;
+}
+
+int
+do_unpack(str,gimme,arglast)
+STR *str;
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register int sp = arglast[0] + 1;
+ register char *pat = str_get(st[sp++]);
+ register char *s = str_get(st[sp]);
+ char *strend = s + st[sp--]->str_cur;
+ char *strbeg = s;
+ register char *patend = pat + st[sp]->str_cur;
+ int datumtype;
+ register int len;
+ register int bits;
+
+ /* These must not be in registers: */
+ short ashort;
+ int aint;
+ long along;
+#ifdef QUAD
+ quad aquad;
+#endif
+ unsigned short aushort;
+ unsigned int auint;
+ unsigned long aulong;
+#ifdef QUAD
+ unsigned quad auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+ int checksum = 0;
+ unsigned long culong;
+ double cdouble;
+
+ if (gimme != G_ARRAY) { /* arrange to do first one only */
+ /*SUPPRESS 530*/
+ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
+ if (index("aAbBhH", *patend) || *pat == '%') {
+ patend++;
+ while (isDIGIT(*patend) || *patend == '*')
+ patend++;
+ }
+ else
+ patend++;
+ }
+ sp--;
+ while (pat < patend) {
+ reparse:
+ datumtype = *pat++;
+ if (pat >= patend)
+ len = 1;
+ else if (*pat == '*') {
+ len = strend - strbeg; /* long enough */
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = (datumtype != '@');
+ switch(datumtype) {
+ default:
+ break;
+ case '%':
+ if (len == 1 && pat[-1] != '1')
+ len = 16;
+ checksum = len;
+ culong = 0;
+ cdouble = 0;
+ if (pat < patend)
+ goto reparse;
+ break;
+ case '@':
+ if (len > strend - s)
+ fatal("@ outside of string");
+ s = strbeg + len;
+ break;
+ case 'X':
+ if (len > s - strbeg)
+ fatal("X outside of string");
+ s -= len;
+ break;
+ case 'x':
+ if (len > strend - s)
+ fatal("x outside of string");
+ s += len;
+ break;
+ case 'A':
+ case 'a':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum)
+ goto uchar_checksum;
+ str = Str_new(35,len);
+ str_nset(str,s,len);
+ s += len;
+ if (datumtype == 'A') {
+ aptr = s; /* borrow register */
+ s = str->str_ptr + len - 1;
+ while (s >= str->str_ptr && (!*s || isSPACE(*s)))
+ s--;
+ *++s = '\0';
+ str->str_cur = s - str->str_ptr;
+ s = aptr; /* unborrow register */
+ }
+ (void)astore(stack, ++sp, str_2mortal(str));
+ break;
+ case 'B':
+ case 'b':
+ if (pat[-1] == '*' || len > (strend - s) * 8)
+ len = (strend - s) * 8;
+ str = Str_new(35, len + 1);
+ str->str_cur = len;
+ str->str_pok = 1;
+ aptr = pat; /* borrow register */
+ pat = str->str_ptr;
+ if (datumtype == 'b') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7) /*SUPPRESS 595*/
+ bits >>= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + (bits & 1);
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7)
+ bits <<= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + ((bits & 128) != 0);
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ (void)astore(stack, ++sp, str_2mortal(str));
+ break;
+ case 'H':
+ case 'h':
+ if (pat[-1] == '*' || len > (strend - s) * 2)
+ len = (strend - s) * 2;
+ str = Str_new(35, len + 1);
+ str->str_cur = len;
+ str->str_pok = 1;
+ aptr = pat; /* borrow register */
+ pat = str->str_ptr;
+ if (datumtype == 'h') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits >>= 4;
+ else
+ bits = *s++;
+ *pat++ = hexdigit[bits & 15];
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits <<= 4;
+ else
+ bits = *s++;
+ *pat++ = hexdigit[(bits >> 4) & 15];
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ (void)astore(stack, ++sp, str_2mortal(str));
+ break;
+ case 'c':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ culong += aint;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ str = Str_new(36,0);
+ str_numset(str,(double)aint);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 'C':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ uchar_checksum:
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ culong += auint;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ str = Str_new(37,0);
+ str_numset(str,(double)auint);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 's':
+ along = (strend - s) / sizeof(short);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ bcopy(s,(char*)&ashort,sizeof(short));
+ s += sizeof(short);
+ culong += ashort;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ bcopy(s,(char*)&ashort,sizeof(short));
+ s += sizeof(short);
+ str = Str_new(38,0);
+ str_numset(str,(double)ashort);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 'v':
+ case 'n':
+ case 'S':
+ along = (strend - s) / sizeof(unsigned short);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ bcopy(s,(char*)&aushort,sizeof(unsigned short));
+ s += sizeof(unsigned short);
+#ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = ntohs(aushort);
+#endif
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ culong += aushort;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ bcopy(s,(char*)&aushort,sizeof(unsigned short));
+ s += sizeof(unsigned short);
+ str = Str_new(39,0);
+#ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = ntohs(aushort);
+#endif
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ str_numset(str,(double)aushort);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 'i':
+ along = (strend - s) / sizeof(int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ bcopy(s,(char*)&aint,sizeof(int));
+ s += sizeof(int);
+ if (checksum > 32)
+ cdouble += (double)aint;
+ else
+ culong += aint;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ bcopy(s,(char*)&aint,sizeof(int));
+ s += sizeof(int);
+ str = Str_new(40,0);
+ str_numset(str,(double)aint);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 'I':
+ along = (strend - s) / sizeof(unsigned int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ bcopy(s,(char*)&auint,sizeof(unsigned int));
+ s += sizeof(unsigned int);
+ if (checksum > 32)
+ cdouble += (double)auint;
+ else
+ culong += auint;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ bcopy(s,(char*)&auint,sizeof(unsigned int));
+ s += sizeof(unsigned int);
+ str = Str_new(41,0);
+ str_numset(str,(double)auint);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 'l':
+ along = (strend - s) / sizeof(long);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ bcopy(s,(char*)&along,sizeof(long));
+ s += sizeof(long);
+ if (checksum > 32)
+ cdouble += (double)along;
+ else
+ culong += along;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ bcopy(s,(char*)&along,sizeof(long));
+ s += sizeof(long);
+ str = Str_new(42,0);
+ str_numset(str,(double)along);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 'V':
+ case 'N':
+ case 'L':
+ along = (strend - s) / sizeof(unsigned long);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ bcopy(s,(char*)&aulong,sizeof(unsigned long));
+ s += sizeof(unsigned long);
+#ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = ntohl(aulong);
+#endif
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+#endif
+ if (checksum > 32)
+ cdouble += (double)aulong;
+ else
+ culong += aulong;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ bcopy(s,(char*)&aulong,sizeof(unsigned long));
+ s += sizeof(unsigned long);
+ str = Str_new(43,0);
+#ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = ntohl(aulong);
+#endif
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+#endif
+ str_numset(str,(double)aulong);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 'p':
+ along = (strend - s) / sizeof(char*);
+ if (len > along)
+ len = along;
+ while (len-- > 0) {
+ if (sizeof(char*) > strend - s)
+ break;
+ else {
+ bcopy(s,(char*)&aptr,sizeof(char*));
+ s += sizeof(char*);
+ }
+ str = Str_new(44,0);
+ if (aptr)
+ str_set(str,aptr);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ break;
+#ifdef QUAD
+ case 'q':
+ while (len-- > 0) {
+ if (s + sizeof(quad) > strend)
+ aquad = 0;
+ else {
+ bcopy(s,(char*)&aquad,sizeof(quad));
+ s += sizeof(quad);
+ }
+ str = Str_new(42,0);
+ str_numset(str,(double)aquad);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ break;
+ case 'Q':
+ while (len-- > 0) {
+ if (s + sizeof(unsigned quad) > strend)
+ auquad = 0;
+ else {
+ bcopy(s,(char*)&auquad,sizeof(unsigned quad));
+ s += sizeof(unsigned quad);
+ }
+ str = Str_new(43,0);
+ str_numset(str,(double)auquad);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ break;
+#endif
+ /* float and double added gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ along = (strend - s) / sizeof(float);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ bcopy(s, (char *)&afloat, sizeof(float));
+ s += sizeof(float);
+ cdouble += afloat;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ bcopy(s, (char *)&afloat, sizeof(float));
+ s += sizeof(float);
+ str = Str_new(47, 0);
+ str_numset(str, (double)afloat);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 'd':
+ case 'D':
+ along = (strend - s) / sizeof(double);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ bcopy(s, (char *)&adouble, sizeof(double));
+ s += sizeof(double);
+ cdouble += adouble;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ bcopy(s, (char *)&adouble, sizeof(double));
+ s += sizeof(double);
+ str = Str_new(48, 0);
+ str_numset(str, (double)adouble);
+ (void)astore(stack, ++sp, str_2mortal(str));
+ }
+ }
+ break;
+ case 'u':
+ along = (strend - s) * 3 / 4;
+ str = Str_new(42,along);
+ while (s < strend && *s > ' ' && *s < 'a') {
+ int a,b,c,d;
+ char hunk[4];
+
+ hunk[3] = '\0';
+ len = (*s++ - ' ') & 077;
+ while (len > 0) {
+ if (s < strend && *s >= ' ')
+ a = (*s++ - ' ') & 077;
+ else
+ a = 0;
+ if (s < strend && *s >= ' ')
+ b = (*s++ - ' ') & 077;
+ else
+ b = 0;
+ if (s < strend && *s >= ' ')
+ c = (*s++ - ' ') & 077;
+ else
+ c = 0;
+ if (s < strend && *s >= ' ')
+ d = (*s++ - ' ') & 077;
+ else
+ d = 0;
+ hunk[0] = a << 2 | b >> 4;
+ hunk[1] = b << 4 | c >> 2;
+ hunk[2] = c << 6 | d;
+ str_ncat(str,hunk, len > 3 ? 3 : len);
+ len -= 3;
+ }
+ if (*s == '\n')
+ s++;
+ else if (s[1] == '\n') /* possible checksum byte */
+ s += 2;
+ }
+ (void)astore(stack, ++sp, str_2mortal(str));
+ break;
+ }
+ if (checksum) {
+ str = Str_new(42,0);
+ if (index("fFdD", datumtype) ||
+ (checksum > 32 && index("iIlLN", datumtype)) ) {
+ double modf();
+ double trouble;
+
+ adouble = 1.0;
+ while (checksum >= 16) {
+ checksum -= 16;
+ adouble *= 65536.0;
+ }
+ while (checksum >= 4) {
+ checksum -= 4;
+ adouble *= 16.0;
+ }
+ while (checksum--)
+ adouble *= 2.0;
+ along = (1 << checksum) - 1;
+ while (cdouble < 0.0)
+ cdouble += adouble;
+ cdouble = modf(cdouble / adouble, &trouble) * adouble;
+ str_numset(str,cdouble);
+ }
+ else {
+ if (checksum < 32) {
+ along = (1 << checksum) - 1;
+ culong &= (unsigned long)along;
+ }
+ str_numset(str,(double)culong);
+ }
+ (void)astore(stack, ++sp, str_2mortal(str));
+ checksum = 0;
+ }
+ }
+ return sp;
+}
+
+int
+do_slice(stab,str,numarray,lval,gimme,arglast)
+STAB *stab;
+STR *str;
+int numarray;
+int lval;
+int gimme;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ register int max = arglast[2];
+ register char *tmps;
+ register int len;
+ register int magic = 0;
+ register ARRAY *ary;
+ register HASH *hash;
+ int oldarybase = arybase;
+
+ if (numarray) {
+ if (numarray == 2) { /* a slice of a LIST */
+ ary = stack;
+ ary->ary_fill = arglast[3];
+ arybase -= max + 1;
+ st[sp] = str; /* make stack size available */
+ str_numset(str,(double)(sp - 1));
+ }
+ else
+ ary = stab_array(stab); /* a slice of an array */
+ }
+ else {
+ if (lval) {
+ if (stab == envstab)
+ magic = 'E';
+ else if (stab == sigstab)
+ magic = 'S';
+#ifdef SOME_DBM
+ else if (stab_hash(stab)->tbl_dbm)
+ magic = 'D';
+#endif /* SOME_DBM */
+ }
+ hash = stab_hash(stab); /* a slice of an associative array */
+ }
+
+ if (gimme == G_ARRAY) {
+ if (numarray) {
+ while (sp < max) {
+ if (st[++sp]) {
+ st[sp-1] = afetch(ary,
+ ((int)str_gnum(st[sp])) - arybase, lval);
+ }
+ else
+ st[sp-1] = &str_undef;
+ }
+ }
+ else {
+ while (sp < max) {
+ if (st[++sp]) {
+ tmps = str_get(st[sp]);
+ len = st[sp]->str_cur;
+ st[sp-1] = hfetch(hash,tmps,len, lval);
+ if (magic)
+ str_magic(st[sp-1],stab,magic,tmps,len);
+ }
+ else
+ st[sp-1] = &str_undef;
+ }
+ }
+ sp--;
+ }
+ else {
+ if (numarray) {
+ if (st[max])
+ st[sp] = afetch(ary,
+ ((int)str_gnum(st[max])) - arybase, lval);
+ else
+ st[sp] = &str_undef;
+ }
+ else {
+ if (st[max]) {
+ tmps = str_get(st[max]);
+ len = st[max]->str_cur;
+ st[sp] = hfetch(hash,tmps,len, lval);
+ if (magic)
+ str_magic(st[sp],stab,magic,tmps,len);
+ }
+ else
+ st[sp] = &str_undef;
+ }
+ }
+ arybase = oldarybase;
+ return sp;
+}
+
+int
+do_splice(ary,gimme,arglast)
+register ARRAY *ary;
+int gimme;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ register int sp = arglast[1];
+ int max = arglast[2] + 1;
+ register STR **src;
+ register STR **dst;
+ register int i;
+ register int offset;
+ register int length;
+ int newlen;
+ int after;
+ int diff;
+ STR **tmparyval;
+
+ if (++sp < max) {
+ offset = ((int)str_gnum(st[sp])) - arybase;
+ if (offset < 0)
+ offset += ary->ary_fill + 1;
+ if (++sp < max) {
+ length = (int)str_gnum(st[sp++]);
+ if (length < 0)
+ length = 0;
+ }
+ else
+ length = ary->ary_max + 1; /* close enough to infinity */
+ }
+ else {
+ offset = 0;
+ length = ary->ary_max + 1;
+ }
+ if (offset < 0) {
+ length += offset;
+ offset = 0;
+ if (length < 0)
+ length = 0;
+ }
+ if (offset > ary->ary_fill + 1)
+ offset = ary->ary_fill + 1;
+ after = ary->ary_fill + 1 - (offset + length);
+ if (after < 0) { /* not that much array */
+ length += after; /* offset+length now in array */
+ after = 0;
+ if (!ary->ary_alloc) {
+ afill(ary,0);
+ afill(ary,-1);
+ }
+ }
+
+ /* At this point, sp .. max-1 is our new LIST */
+
+ newlen = max - sp;
+ diff = newlen - length;
+
+ if (diff < 0) { /* shrinking the area */
+ if (newlen) {
+ New(451, tmparyval, newlen, STR*); /* so remember insertion */
+ Copy(st+sp, tmparyval, newlen, STR*);
+ }
+
+ sp = arglast[0] + 1;
+ if (gimme == G_ARRAY) { /* copy return vals to stack */
+ if (sp + length >= stack->ary_max) {
+ astore(stack,sp + length, Nullstr);
+ st = stack->ary_array;
+ }
+ Copy(ary->ary_array+offset, st+sp, length, STR*);
+ if (ary->ary_flags & ARF_REAL) {
+ for (i = length, dst = st+sp; i; i--)
+ str_2mortal(*dst++); /* free them eventualy */
+ }
+ sp += length - 1;
+ }
+ else {
+ st[sp] = ary->ary_array[offset+length-1];
+ if (ary->ary_flags & ARF_REAL)
+ str_2mortal(st[sp]);
+ }
+ ary->ary_fill += diff;
+
+ /* pull up or down? */
+
+ if (offset < after) { /* easier to pull up */
+ if (offset) { /* esp. if nothing to pull */
+ src = &ary->ary_array[offset-1];
+ dst = src - diff; /* diff is negative */
+ for (i = offset; i > 0; i--) /* can't trust Copy */
+ *dst-- = *src--;
+ }
+ Zero(ary->ary_array, -diff, STR*);
+ ary->ary_array -= diff; /* diff is negative */
+ ary->ary_max += diff;
+ }
+ else {
+ if (after) { /* anything to pull down? */
+ src = ary->ary_array + offset + length;
+ dst = src + diff; /* diff is negative */
+ Copy(src, dst, after, STR*);
+ }
+ Zero(&ary->ary_array[ary->ary_fill+1], -diff, STR*);
+ /* avoid later double free */
+ }
+ if (newlen) {
+ for (src = tmparyval, dst = ary->ary_array + offset;
+ newlen; newlen--) {
+ *dst = Str_new(46,0);
+ str_sset(*dst++,*src++);
+ }
+ Safefree(tmparyval);
+ }
+ }
+ else { /* no, expanding (or same) */
+ if (length) {
+ New(452, tmparyval, length, STR*); /* so remember deletion */
+ Copy(ary->ary_array+offset, tmparyval, length, STR*);
+ }
+
+ if (diff > 0) { /* expanding */
+
+ /* push up or down? */
+
+ if (offset < after && diff <= ary->ary_array - ary->ary_alloc) {
+ if (offset) {
+ src = ary->ary_array;
+ dst = src - diff;
+ Copy(src, dst, offset, STR*);
+ }
+ ary->ary_array -= diff; /* diff is positive */
+ ary->ary_max += diff;
+ ary->ary_fill += diff;
+ }
+ else {
+ if (ary->ary_fill + diff >= ary->ary_max) /* oh, well */
+ astore(ary, ary->ary_fill + diff, Nullstr);
+ else
+ ary->ary_fill += diff;
+ if (after) {
+ dst = ary->ary_array + ary->ary_fill;
+ src = dst - diff;
+ for (i = after; i; i--) {
+ if (*dst) /* str was hanging around */
+ str_free(*dst); /* after $#foo */
+ *dst-- = *src;
+ *src-- = Nullstr;
+ }
+ }
+ }
+ }
+
+ for (src = st+sp, dst = ary->ary_array + offset; newlen; newlen--) {
+ *dst = Str_new(46,0);
+ str_sset(*dst++,*src++);
+ }
+ sp = arglast[0] + 1;
+ if (gimme == G_ARRAY) { /* copy return vals to stack */
+ if (length) {
+ Copy(tmparyval, st+sp, length, STR*);
+ if (ary->ary_flags & ARF_REAL) {
+ for (i = length, dst = st+sp; i; i--)
+ str_2mortal(*dst++); /* free them eventualy */
+ }
+ Safefree(tmparyval);
+ }
+ sp += length - 1;
+ }
+ else if (length) {
+ st[sp] = tmparyval[length-1];
+ if (ary->ary_flags & ARF_REAL)
+ str_2mortal(st[sp]);
+ Safefree(tmparyval);
+ }
+ else
+ st[sp] = &str_undef;
+ }
+ return sp;
+}
+
+int
+do_grep(arg,str,gimme,arglast)
+register ARG *arg;
+STR *str;
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register int dst = arglast[1];
+ register int src = dst + 1;
+ register int sp = arglast[2];
+ register int i = sp - arglast[1];
+ int oldsave = savestack->ary_fill;
+ SPAT *oldspat = curspat;
+ int oldtmps_base = tmps_base;
+
+ savesptr(&stab_val(defstab));
+ tmps_base = tmps_max;
+ if ((arg[1].arg_type & A_MASK) != A_EXPR) {
+ arg[1].arg_type &= A_MASK;
+ dehoist(arg,1);
+ arg[1].arg_type |= A_DONT;
+ }
+ arg = arg[1].arg_ptr.arg_arg;
+ while (i-- > 0) {
+ if (st[src]) {
+ st[src]->str_pok &= ~SP_TEMP;
+ stab_val(defstab) = st[src];
+ }
+ else
+ stab_val(defstab) = str_mortal(&str_undef);
+ (void)eval(arg,G_SCALAR,sp);
+ st = stack->ary_array;
+ if (str_true(st[sp+1]))
+ st[dst++] = st[src];
+ src++;
+ curspat = oldspat;
+ }
+ restorelist(oldsave);
+ tmps_base = oldtmps_base;
+ if (gimme != G_ARRAY) {
+ str_numset(str,(double)(dst - arglast[1]));
+ STABSET(str);
+ st[arglast[0]+1] = str;
+ return arglast[0]+1;
+ }
+ return arglast[0] + (dst - arglast[1]);
+}
+
+int
+do_reverse(arglast)
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register STR **up = &st[arglast[1]];
+ register STR **down = &st[arglast[2]];
+ register int i = arglast[2] - arglast[1];
+
+ while (i-- > 0) {
+ *up++ = *down;
+ if (i-- > 0)
+ *down-- = *up;
+ }
+ i = arglast[2] - arglast[1];
+ Copy(down+1,up,i/2,STR*);
+ return arglast[2] - 1;
+}
+
+int
+do_sreverse(str,arglast)
+STR *str;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register char *up;
+ register char *down;
+ register int tmp;
+
+ str_sset(str,st[arglast[2]]);
+ up = str_get(str);
+ if (str->str_cur > 1) {
+ down = str->str_ptr + str->str_cur - 1;
+ while (down > up) {
+ tmp = *up;
+ *up++ = *down;
+ *down-- = tmp;
+ }
+ }
+ STABSET(str);
+ st[arglast[0]+1] = str;
+ return arglast[0]+1;
+}
+
+static CMD *sortcmd;
+static HASH *sortstash = Null(HASH*);
+static STAB *firststab = Nullstab;
+static STAB *secondstab = Nullstab;
+
+int
+do_sort(str,arg,gimme,arglast)
+STR *str;
+ARG *arg;
+int gimme;
+int *arglast;
+{
+ register STR **st = stack->ary_array;
+ int sp = arglast[1];
+ register STR **up;
+ register int max = arglast[2] - sp;
+ register int i;
+ int sortcmp();
+ int sortsub();
+ STR *oldfirst;
+ STR *oldsecond;
+ ARRAY *oldstack;
+ HASH *stash;
+ STR *sortsubvar;
+ static ARRAY *sortstack = Null(ARRAY*);
+
+ if (gimme != G_ARRAY) {
+ str_sset(str,&str_undef);
+ STABSET(str);
+ st[sp] = str;
+ return sp;
+ }
+ up = &st[sp];
+ sortsubvar = *up;
+ st += sp; /* temporarily make st point to args */
+ for (i = 1; i <= max; i++) {
+ /*SUPPRESS 560*/
+ if (*up = st[i]) {
+ if (!(*up)->str_pok)
+ (void)str_2ptr(*up);
+ else
+ (*up)->str_pok &= ~SP_TEMP;
+ up++;
+ }
+ }
+ st -= sp;
+ max = up - &st[sp];
+ sp--;
+ if (max > 1) {
+ STAB *stab;
+
+ if (arg[1].arg_type == (A_CMD|A_DONT)) {
+ sortcmd = arg[1].arg_ptr.arg_cmd;
+ stash = curcmd->c_stash;
+ }
+ else {
+ if ((arg[1].arg_type & A_MASK) == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sortsubvar),TRUE);
+
+ if (stab) {
+ if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd))
+ fatal("Undefined subroutine \"%s\" in sort",
+ stab_name(stab));
+ stash = stab_stash(stab);
+ }
+ else
+ sortcmd = Nullcmd;
+ }
+
+ if (sortcmd) {
+ int oldtmps_base = tmps_base;
+
+ if (!sortstack) {
+ sortstack = anew(Nullstab);
+ astore(sortstack, 0, Nullstr);
+ aclear(sortstack);
+ sortstack->ary_flags = 0;
+ }
+ oldstack = stack;
+ stack = sortstack;
+ tmps_base = tmps_max;
+ if (sortstash != stash) {
+ firststab = stabent("a",TRUE);
+ secondstab = stabent("b",TRUE);
+ sortstash = stash;
+ }
+ oldfirst = stab_val(firststab);
+ oldsecond = stab_val(secondstab);
+#ifndef lint
+ qsort((char*)(st+sp+1),max,sizeof(STR*),sortsub);
+#else
+ qsort(Nullch,max,sizeof(STR*),sortsub);
+#endif
+ stab_val(firststab) = oldfirst;
+ stab_val(secondstab) = oldsecond;
+ tmps_base = oldtmps_base;
+ stack = oldstack;
+ }
+#ifndef lint
+ else
+ qsort((char*)(st+sp+1),max,sizeof(STR*),sortcmp);
+#endif
+ }
+ return sp+max;
+}
+
+int
+sortsub(str1,str2)
+STR **str1;
+STR **str2;
+{
+ stab_val(firststab) = *str1;
+ stab_val(secondstab) = *str2;
+ cmd_exec(sortcmd,G_SCALAR,-1);
+ return (int)str_gnum(*stack->ary_array);
+}
+
+sortcmp(strp1,strp2)
+STR **strp1;
+STR **strp2;
+{
+ register STR *str1 = *strp1;
+ register STR *str2 = *strp2;
+ int retval;
+
+ if (str1->str_cur < str2->str_cur) {
+ /*SUPPRESS 560*/
+ if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
+ return retval;
+ else
+ return -1;
+ }
+ /*SUPPRESS 560*/
+ else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
+ return retval;
+ else if (str1->str_cur == str2->str_cur)
+ return 0;
+ else
+ return 1;
+}
+
+int
+do_range(gimme,arglast)
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ register int i;
+ register ARRAY *ary = stack;
+ register STR *str;
+ int max;
+
+ if (gimme != G_ARRAY)
+ fatal("panic: do_range");
+
+ if (st[sp+1]->str_nok || !st[sp+1]->str_pok ||
+ (looks_like_number(st[sp+1]) && *st[sp+1]->str_ptr != '0') ) {
+ i = (int)str_gnum(st[sp+1]);
+ max = (int)str_gnum(st[sp+2]);
+ if (max > i)
+ (void)astore(ary, sp + max - i + 1, Nullstr);
+ while (i <= max) {
+ (void)astore(ary, ++sp, str = str_mortal(&str_no));
+ str_numset(str,(double)i++);
+ }
+ }
+ else {
+ STR *final = str_mortal(st[sp+2]);
+ char *tmps = str_get(final);
+
+ str = str_mortal(st[sp+1]);
+ while (!str->str_nok && str->str_cur <= final->str_cur &&
+ strNE(str->str_ptr,tmps) ) {
+ (void)astore(ary, ++sp, str);
+ str = str_2mortal(str_smake(str));
+ str_inc(str);
+ }
+ if (strEQ(str->str_ptr,tmps))
+ (void)astore(ary, ++sp, str);
+ }
+ return sp;
+}
+
+int
+do_repeatary(arglast)
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ register int items = arglast[1] - sp;
+ register int count = (int) str_gnum(st[arglast[2]]);
+ register int i;
+ int max;
+
+ max = items * count;
+ if (max > 0 && sp + max > stack->ary_max) {
+ astore(stack, sp + max, Nullstr);
+ st = stack->ary_array;
+ }
+ if (count > 1) {
+ for (i = arglast[1]; i > sp; i--)
+ st[i]->str_pok &= ~SP_TEMP;
+ repeatcpy((char*)&st[arglast[1]+1], (char*)&st[sp+1],
+ items * sizeof(STR*), count);
+ }
+ sp += max;
+
+ return sp;
+}
+
+int
+do_caller(arg,maxarg,gimme,arglast)
+ARG *arg;
+int maxarg;
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ register CSV *csv = curcsv;
+ STR *str;
+ int count = 0;
+
+ if (!csv)
+ fatal("There is no caller");
+ if (maxarg)
+ count = (int) str_gnum(st[sp+1]);
+ for (;;) {
+ if (!csv)
+ return sp;
+ if (DBsub && csv->curcsv && csv->curcsv->sub == stab_sub(DBsub))
+ count++;
+ if (!count--)
+ break;
+ csv = csv->curcsv;
+ }
+ if (gimme != G_ARRAY) {
+ STR *str = arg->arg_ptr.arg_str;
+ str_set(str,csv->curcmd->c_stash->tbl_name);
+ STABSET(str);
+ st[++sp] = str;
+ return sp;
+ }
+
+#ifndef lint
+ (void)astore(stack,++sp,
+ str_2mortal(str_make(csv->curcmd->c_stash->tbl_name,0)) );
+ (void)astore(stack,++sp,
+ str_2mortal(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) );
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake((double)csv->curcmd->c_line)) );
+ if (!maxarg)
+ return sp;
+ str = Str_new(49,0);
+ stab_fullname(str, csv->stab);
+ (void)astore(stack,++sp, str_2mortal(str));
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake((double)csv->hasargs)) );
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake((double)csv->wantarray)) );
+ if (csv->hasargs) {
+ ARRAY *ary = csv->argarray;
+
+ if (!dbargs)
+ dbargs = stab_xarray(aadd(stabent("DB'args", TRUE)));
+ if (dbargs->ary_max < ary->ary_fill)
+ astore(dbargs,ary->ary_fill,Nullstr);
+ Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
+ dbargs->ary_fill = ary->ary_fill;
+ }
+#else
+ (void)astore(stack,++sp,
+ str_2mortal(str_make("",0)));
+#endif
+ return sp;
+}
+
+int
+do_tms(str,gimme,arglast)
+STR *str;
+int gimme;
+int *arglast;
+{
+#ifdef MSDOS
+ return -1;
+#else
+ STR **st = stack->ary_array;
+ register int sp = arglast[0];
+
+ if (gimme != G_ARRAY) {
+ str_sset(str,&str_undef);
+ STABSET(str);
+ st[++sp] = str;
+ return sp;
+ }
+ (void)times(×buf);
+
+#ifndef HZ
+#define HZ 60
+#endif
+
+#ifndef lint
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(((double)timesbuf.tms_utime)/HZ)));
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(((double)timesbuf.tms_stime)/HZ)));
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(((double)timesbuf.tms_cutime)/HZ)));
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(((double)timesbuf.tms_cstime)/HZ)));
+#else
+ (void)astore(stack,++sp,
+ str_2mortal(str_nmake(0.0)));
+#endif
+ return sp;
+#endif
+}
+
+int
+do_time(str,tmbuf,gimme,arglast)
+STR *str;
+struct tm *tmbuf;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ STR **st = ary->ary_array;
+ register int sp = arglast[0];
+
+ if (!tmbuf || gimme != G_ARRAY) {
+ str_sset(str,&str_undef);
+ STABSET(str);
+ st[++sp] = str;
+ return sp;
+ }
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_sec)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_min)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_hour)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mday)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mon)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_year)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_wday)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_yday)));
+ (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_isdst)));
+ return sp;
+}
+
+int
+do_kv(str,hash,kv,gimme,arglast)
+STR *str;
+HASH *hash;
+int kv;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ STR **st = ary->ary_array;
+ register int sp = arglast[0];
+ int i;
+ register HENT *entry;
+ char *tmps;
+ STR *tmpstr;
+ int dokeys = (kv == O_KEYS || kv == O_HASH);
+ int dovalues = (kv == O_VALUES || kv == O_HASH);
+
+ if (gimme != G_ARRAY) {
+ str_sset(str,&str_undef);
+ STABSET(str);
+ st[++sp] = str;
+ return sp;
+ }
+ (void)hiterinit(hash);
+ /*SUPPRESS 560*/
+ while (entry = hiternext(hash)) {
+ if (dokeys) {
+ tmps = hiterkey(entry,&i);
+ if (!i)
+ tmps = "";
+ (void)astore(ary,++sp,str_2mortal(str_make(tmps,i)));
+ }
+ if (dovalues) {
+ tmpstr = Str_new(45,0);
+#ifdef DEBUGGING
+ if (debug & 8192) {
+ sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
+ hash->tbl_max+1,entry->hent_hash & hash->tbl_max);
+ str_set(tmpstr,buf);
+ }
+ else
+#endif
+ str_sset(tmpstr,hiterval(hash,entry));
+ (void)astore(ary,++sp,str_2mortal(tmpstr));
+ }
+ }
+ return sp;
+}
+
+int
+do_each(str,hash,gimme,arglast)
+STR *str;
+HASH *hash;
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ register int sp = arglast[0];
+ static STR *mystrk = Nullstr;
+ HENT *entry = hiternext(hash);
+ int i;
+ char *tmps;
+
+ if (mystrk) {
+ str_free(mystrk);
+ mystrk = Nullstr;
+ }
+
+ if (entry) {
+ if (gimme == G_ARRAY) {
+ tmps = hiterkey(entry, &i);
+ if (!i)
+ tmps = "";
+ st[++sp] = mystrk = str_make(tmps,i);
+ }
+ st[++sp] = str;
+ str_sset(str,hiterval(hash,entry));
+ STABSET(str);
+ return sp;
+ }
+ else
+ return sp;
+}
--- /dev/null
+/* $RCSfile: dump.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:58:44 $
+ *
+ * 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: dump.c,v $
+ * 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.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef DEBUGGING
+static int dumplvl = 0;
+
+dump_all()
+{
+ register int i;
+ register STAB *stab;
+ register HENT *entry;
+ STR *str = str_mortal(&str_undef);
+
+ dump_cmd(main_root,Nullcmd);
+ for (i = 0; i <= 127; i++) {
+ for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
+ stab = (STAB*)entry->hent_val;
+ if (stab_sub(stab)) {
+ stab_fullname(str,stab);
+ dump("\nSUB %s = ", str->str_ptr);
+ dump_cmd(stab_sub(stab)->cmd,Nullcmd);
+ }
+ }
+ }
+}
+
+dump_cmd(cmd,alt)
+register CMD *cmd;
+register CMD *alt;
+{
+ fprintf(stderr,"{\n");
+ while (cmd) {
+ dumplvl++;
+ dump("C_TYPE = %s\n",cmdname[cmd->c_type]);
+ dump("C_ADDR = 0x%lx\n",cmd);
+ dump("C_NEXT = 0x%lx\n",cmd->c_next);
+ if (cmd->c_line)
+ dump("C_LINE = %d (0x%lx)\n",cmd->c_line,cmd);
+ if (cmd->c_label)
+ dump("C_LABEL = \"%s\"\n",cmd->c_label);
+ dump("C_OPT = CFT_%s\n",cmdopt[cmd->c_flags & CF_OPTIMIZE]);
+ *buf = '\0';
+ if (cmd->c_flags & CF_FIRSTNEG)
+ (void)strcat(buf,"FIRSTNEG,");
+ if (cmd->c_flags & CF_NESURE)
+ (void)strcat(buf,"NESURE,");
+ if (cmd->c_flags & CF_EQSURE)
+ (void)strcat(buf,"EQSURE,");
+ if (cmd->c_flags & CF_COND)
+ (void)strcat(buf,"COND,");
+ if (cmd->c_flags & CF_LOOP)
+ (void)strcat(buf,"LOOP,");
+ if (cmd->c_flags & CF_INVERT)
+ (void)strcat(buf,"INVERT,");
+ if (cmd->c_flags & CF_ONCE)
+ (void)strcat(buf,"ONCE,");
+ if (cmd->c_flags & CF_FLIP)
+ (void)strcat(buf,"FLIP,");
+ if (cmd->c_flags & CF_TERM)
+ (void)strcat(buf,"TERM,");
+ if (*buf)
+ buf[strlen(buf)-1] = '\0';
+ dump("C_FLAGS = (%s)\n",buf);
+ if (cmd->c_short) {
+ dump("C_SHORT = \"%s\"\n",str_peek(cmd->c_short));
+ dump("C_SLEN = \"%d\"\n",cmd->c_slen);
+ }
+ if (cmd->c_stab) {
+ dump("C_STAB = ");
+ dump_stab(cmd->c_stab);
+ }
+ if (cmd->c_spat) {
+ dump("C_SPAT = ");
+ dump_spat(cmd->c_spat);
+ }
+ if (cmd->c_expr) {
+ dump("C_EXPR = ");
+ dump_arg(cmd->c_expr);
+ } else
+ dump("C_EXPR = NULL\n");
+ switch (cmd->c_type) {
+ case C_NEXT:
+ case C_WHILE:
+ case C_BLOCK:
+ case C_ELSE:
+ case C_IF:
+ if (cmd->ucmd.ccmd.cc_true) {
+ dump("CC_TRUE = ");
+ dump_cmd(cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt);
+ }
+ else
+ dump("CC_TRUE = NULL\n");
+ if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt) {
+ dump("CC_ENDELSE = 0x%lx\n",cmd->ucmd.ccmd.cc_alt);
+ }
+ else if (cmd->c_type == C_NEXT && cmd->ucmd.ccmd.cc_alt) {
+ dump("CC_NEXT = 0x%lx\n",cmd->ucmd.ccmd.cc_alt);
+ }
+ else
+ dump("CC_ALT = NULL\n");
+ break;
+ case C_EXPR:
+ if (cmd->ucmd.acmd.ac_stab) {
+ dump("AC_STAB = ");
+ dump_stab(cmd->ucmd.acmd.ac_stab);
+ } else
+ dump("AC_STAB = NULL\n");
+ if (cmd->ucmd.acmd.ac_expr) {
+ dump("AC_EXPR = ");
+ dump_arg(cmd->ucmd.acmd.ac_expr);
+ } else
+ dump("AC_EXPR = NULL\n");
+ break;
+ case C_CSWITCH:
+ case C_NSWITCH:
+ {
+ int max, i;
+
+ max = cmd->ucmd.scmd.sc_max;
+ dump("SC_MIN = (%d)\n",cmd->ucmd.scmd.sc_offset + 1);
+ dump("SC_MAX = (%d)\n", max + cmd->ucmd.scmd.sc_offset - 1);
+ dump("SC_NEXT[LT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[0]);
+ for (i = 1; i < max; i++)
+ dump("SC_NEXT[%d] = 0x%lx\n", i + cmd->ucmd.scmd.sc_offset,
+ cmd->ucmd.scmd.sc_next[i]);
+ dump("SC_NEXT[GT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[max]);
+ }
+ break;
+ }
+ cmd = cmd->c_next;
+ if (cmd && cmd->c_head == cmd) { /* reached end of while loop */
+ dump("C_NEXT = HEAD\n");
+ dumplvl--;
+ dump("}\n");
+ break;
+ }
+ dumplvl--;
+ dump("}\n");
+ if (cmd)
+ if (cmd == alt)
+ dump("CONT 0x%lx {\n",cmd);
+ else
+ dump("{\n");
+ }
+}
+
+dump_arg(arg)
+register ARG *arg;
+{
+ register int i;
+
+ fprintf(stderr,"{\n");
+ dumplvl++;
+ dump("OP_TYPE = %s\n",opname[arg->arg_type]);
+ dump("OP_LEN = %d\n",arg->arg_len);
+ if (arg->arg_flags) {
+ dump_flags(buf,arg->arg_flags);
+ dump("OP_FLAGS = (%s)\n",buf);
+ }
+ for (i = 1; i <= arg->arg_len; i++) {
+ dump("[%d]ARG_TYPE = %s%s\n",i,argname[arg[i].arg_type & A_MASK],
+ arg[i].arg_type & A_DONT ? " (unevaluated)" : "");
+ if (arg[i].arg_len)
+ dump("[%d]ARG_LEN = %d\n",i,arg[i].arg_len);
+ if (arg[i].arg_flags) {
+ dump_flags(buf,arg[i].arg_flags);
+ dump("[%d]ARG_FLAGS = (%s)\n",i,buf);
+ }
+ switch (arg[i].arg_type & A_MASK) {
+ case A_NULL:
+ if (arg->arg_type == O_TRANS) {
+ short *tbl = (short*)arg[2].arg_ptr.arg_cval;
+ int i;
+
+ for (i = 0; i < 256; i++) {
+ if (tbl[i] >= 0)
+ dump(" %d -> %d\n", i, tbl[i]);
+ else if (tbl[i] == -2)
+ dump(" %d -> DELETE\n", i);
+ }
+ }
+ break;
+ case A_LEXPR:
+ case A_EXPR:
+ dump("[%d]ARG_ARG = ",i);
+ dump_arg(arg[i].arg_ptr.arg_arg);
+ break;
+ case A_CMD:
+ dump("[%d]ARG_CMD = ",i);
+ dump_cmd(arg[i].arg_ptr.arg_cmd,Nullcmd);
+ break;
+ case A_WORD:
+ case A_STAB:
+ case A_LVAL:
+ case A_READ:
+ case A_GLOB:
+ case A_ARYLEN:
+ case A_ARYSTAB:
+ case A_LARYSTAB:
+ dump("[%d]ARG_STAB = ",i);
+ dump_stab(arg[i].arg_ptr.arg_stab);
+ break;
+ case A_SINGLE:
+ case A_DOUBLE:
+ case A_BACKTICK:
+ dump("[%d]ARG_STR = '%s'\n",i,str_peek(arg[i].arg_ptr.arg_str));
+ break;
+ case A_SPAT:
+ dump("[%d]ARG_SPAT = ",i);
+ dump_spat(arg[i].arg_ptr.arg_spat);
+ break;
+ }
+ }
+ dumplvl--;
+ dump("}\n");
+}
+
+dump_flags(b,flags)
+char *b;
+unsigned int flags;
+{
+ *b = '\0';
+ if (flags & AF_ARYOK)
+ (void)strcat(b,"ARYOK,");
+ if (flags & AF_POST)
+ (void)strcat(b,"POST,");
+ if (flags & AF_PRE)
+ (void)strcat(b,"PRE,");
+ if (flags & AF_UP)
+ (void)strcat(b,"UP,");
+ if (flags & AF_COMMON)
+ (void)strcat(b,"COMMON,");
+ if (flags & AF_DEPR)
+ (void)strcat(b,"DEPR,");
+ if (flags & AF_LISTISH)
+ (void)strcat(b,"LISTISH,");
+ if (flags & AF_LOCAL)
+ (void)strcat(b,"LOCAL,");
+ if (*b)
+ b[strlen(b)-1] = '\0';
+}
+
+dump_stab(stab)
+register STAB *stab;
+{
+ STR *str;
+
+ if (!stab) {
+ fprintf(stderr,"{}\n");
+ return;
+ }
+ str = str_mortal(&str_undef);
+ dumplvl++;
+ fprintf(stderr,"{\n");
+ stab_fullname(str,stab);
+ dump("STAB_NAME = %s\n", str->str_ptr);
+ dumplvl--;
+ dump("}\n");
+}
+
+dump_spat(spat)
+register SPAT *spat;
+{
+ char ch;
+
+ if (!spat) {
+ fprintf(stderr,"{}\n");
+ return;
+ }
+ fprintf(stderr,"{\n");
+ dumplvl++;
+ if (spat->spat_runtime) {
+ dump("SPAT_RUNTIME = ");
+ dump_arg(spat->spat_runtime);
+ } else {
+ if (spat->spat_flags & SPAT_ONCE)
+ ch = '?';
+ else
+ ch = '/';
+ dump("SPAT_PRE %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
+ }
+ if (spat->spat_repl) {
+ dump("SPAT_REPL = ");
+ dump_arg(spat->spat_repl);
+ }
+ if (spat->spat_short) {
+ dump("SPAT_SHORT = \"%s\"\n",str_peek(spat->spat_short));
+ }
+ dumplvl--;
+ dump("}\n");
+}
+
+/* VARARGS1 */
+dump(arg1,arg2,arg3,arg4,arg5)
+char *arg1;
+long arg2, arg3, arg4, arg5;
+{
+ int i;
+
+ for (i = dumplvl*4; i; i--)
+ (void)putc(' ',stderr);
+ fprintf(stderr,arg1, arg2, arg3, arg4, arg5);
+}
+#endif
+
+#ifdef DEBUG
+char *
+showinput()
+{
+ register char *s = str_get(linestr);
+ int fd;
+ static char cmd[] =
+ {05,030,05,03,040,03,022,031,020,024,040,04,017,016,024,01,023,013,040,
+ 074,057,024,015,020,057,056,006,017,017,0};
+
+ if (rsfp != stdin || strnEQ(s,"#!",2))
+ return s;
+ for (; *s; s++) {
+ if (*s & 0200) {
+ fd = creat("/tmp/.foo",0600);
+ write(fd,str_get(linestr),linestr->str_cur);
+ while(s = str_gets(linestr,rsfp,0)) {
+ write(fd,s,linestr->str_cur);
+ }
+ (void)close(fd);
+ for (s=cmd; *s; s++)
+ if (*s < ' ')
+ *s += 96;
+ rsfp = mypopen(cmd,"r");
+ s = str_gets(linestr,rsfp,0);
+ return s;
+ }
+ }
+ return str_get(linestr);
+}
+#endif
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: ADB,v 4.0 91/03/20 01:08:34 lwall Locked $
+
+# This script is only useful when used in your crash directory.
+
+$num = shift;
+exec 'adb', '-k', "vmunix.$num", "vmcore.$num";
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: changes,v 4.0 91/03/20 01:08:56 lwall Locked $
+
+($dir, $days) = @ARGV;
+$dir = '/' if $dir eq '';
+$days = '14' if $days eq '';
+
+# Masscomps do things differently from Suns
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+open(Find, "find $dir -mtime -$days -print |") ||
+ die "changes: can't run find";
+#else
+open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") ||
+ die "changes: can't run find";
+#endif
+
+while (<Find>) {
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+ $x = `/bin/ls -ild $_`;
+ $_ = $x;
+ ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
+ = split(' ');
+#else
+ ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
+ = split(' ');
+#endif
+
+ printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n",
+ $perm,$links,$owner,$group,$size,$month,$day,$name);
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+$| = 1;
+if ($#ARGV >= 0) {
+ $cmd = join(' ',@ARGV);
+}
+else {
+ print "Command: ";
+ $cmd = <stdin>;
+ chop($cmd);
+ while ($cmd =~ s/\\$//) {
+ print "+ ";
+ $cmd .= <stdin>;
+ chop($cmd);
+ }
+}
+$cwd = `pwd`; chop($cwd);
+
+open(FIND,'find . -type d -print|') || die "Can't run find";
+
+while (<FIND>) {
+ chop;
+ unless (chdir $_) {
+ print stderr "Can't cd to $_\n";
+ next;
+ }
+ print "\t--> ",$_,"\n";
+ system $cmd;
+ chdir $cwd;
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: dus,v 4.0 91/03/20 01:09:20 lwall Locked $
+
+# This script does a du -s on any directories in the current directory that
+# are not mount points for another filesystem.
+
+($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('.');
+
+open(ls,'ls -F1|');
+
+while (<ls>) {
+ chop;
+ next unless s|/$||;
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($_);
+ next unless $dev == $mydev;
+ push(@ary,$_);
+}
+
+exec 'du', '-s', @ary;
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: findcp,v 4.0 91/03/20 01:09:37 lwall Locked $
+
+# This is a wrapper around the find command that pretends find has a switch
+# of the form -cp host:destination. It presumes your find implements -ls.
+# It uses tar to do the actual copy. If your tar knows about the I switch
+# you may prefer to use findtar, since this one has to do the tar in batches.
+
+sub copy {
+ `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`;
+}
+
+$sourcedir = $ARGV[0];
+if ($sourcedir =~ /^\//) {
+ $ARGV[0] = '.';
+ unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; }
+}
+
+$args = join(' ',@ARGV);
+if ($args =~ s/-cp *([^ ]+)/-ls/) {
+ $dest = $1;
+ if ($dest =~ /(.*):(.*)/) {
+ $desthost = $1;
+ $destdir = $2;
+ }
+ else {
+ die "Malformed destination--should be host:directory";
+ }
+}
+else {
+ die("No destination specified");
+}
+
+open(find,"find $args |") || die "Can't run find for you: $!";
+
+while (<find>) {
+ @x = split(' ');
+ if ($x[2] =~ /^d/) { next;}
+ chop($filename = $x[10]);
+ if (length($list) > 5000) {
+ do copy();
+ $list = '';
+ }
+ else {
+ $list .= ' ';
+ }
+ $list .= $filename;
+}
+
+if ($list) {
+ do copy();
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: findtar,v 4.0 91/03/20 01:09:48 lwall Locked $
+
+# findtar takes find-style arguments and spits out a tarfile on stdout.
+# It won't work unless your find supports -ls and your tar the I flag.
+
+$args = join(' ',@ARGV);
+open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you.";
+
+open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!";
+
+while (<find>) {
+ @x = split(' ');
+ if ($x[2] =~ /^d/) { print tar '-d ';}
+ print tar $x[10],"\n";
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: gcp,v 4.0 91/03/20 01:10:05 lwall Locked $
+
+# Here is a script to do global rcps. See man page.
+
+$#ARGV >= 1 || die "Not enough arguments.\n";
+
+if ($ARGV[0] eq '-r') {
+ $rcp = 'rcp -r';
+ shift;
+} else {
+ $rcp = 'rcp';
+}
+$args = $rcp;
+$dest = $ARGV[$#ARGV];
+
+$SIG{'QUIT'} = 'CLEANUP';
+$SIG{'INT'} = 'CONT';
+
+while ($arg = shift) {
+ if ($arg =~ /^([-a-zA-Z0-9_+]+):/) {
+ if ($systype && $systype ne $1) {
+ die "Can't mix system type specifers ($systype vs $1).\n";
+ }
+ $#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n";
+ $systype = $1;
+ $args .= " $arg";
+ } else {
+ if ($#ARGV >= 0) {
+ if ($arg =~ /^[\/~]/) {
+ $arg =~ /^(.*)\// && ($dir = $1);
+ } else {
+ if (!$pwd) {
+ chop($pwd = `pwd`);
+ }
+ $dir = $pwd;
+ }
+ }
+ if ($olddir && $dir ne $olddir && $dest =~ /:$/) {
+ $args .= " $dest$olddir; $rcp";
+ }
+ $olddir = $dir;
+ $args .= " $arg";
+ }
+}
+
+die "No system type specified.\n" unless $systype;
+
+$args =~ s/:$/:$olddir/;
+
+chop($thishost = `hostname`);
+
+$one_of_these = ":$systype:";
+if ($systype =~ s/\+/[+]/g) {
+ $one_of_these =~ s/\+/:/g;
+}
+$one_of_these =~ s/-/:-/g;
+
+@ARGV = ();
+push(@ARGV,'.grem') if -f '.grem';
+push(@ARGV,'.ghosts') if -f '.ghosts';
+push(@ARGV,'/etc/ghosts');
+
+$remainder = '';
+
+line: while (<>) {
+ s/[ \t]*\n//;
+ if (!$_ || /^#/) {
+ next line;
+ }
+ if (/^([a-zA-Z_0-9]+)=(.+)/) {
+ $name = $1; $repl = $2;
+ $repl =~ s/\+/:/g;
+ $repl =~ s/-/:-/g;
+ $one_of_these =~ s/:$name:/:$repl:/;
+ $repl =~ s/:/:-/g;
+ $one_of_these =~ s/:-$name:/:-$repl:/g;
+ next line;
+ }
+ @gh = split(' ');
+ $host = $gh[0];
+ next line if $host eq $thishost; # should handle aliases too
+ $wanted = 0;
+ foreach $class (@gh) {
+ $wanted++ if index($one_of_these,":$class:") >= 0;
+ $wanted = -9999 if index($one_of_these,":-$class:") >= 0;
+ }
+ if ($wanted > 0) {
+ ($cmd = $args) =~ s/[ \t]$systype:/ $host:/g;
+ print "$cmd\n";
+ $result = `$cmd 2>&1`;
+ $remainder .= "$host+" if
+ $result =~ /Connection timed out|Permission denied/;
+ print $result;
+ }
+}
+
+if ($remainder) {
+ chop($remainder);
+ open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n");
+ print grem 'rem=', $remainder, "\n";
+ close(grem);
+ print 'rem=', $remainder, "\n";
+}
+
+sub CLEANUP {
+ exit;
+}
+
+sub CONT {
+ print "Continuing...\n"; # Just ignore the signal that kills rcp
+ $remainder .= "$host+";
+}
--- /dev/null
+.\" $Header: gcp.man,v 4.0 91/03/20 01:10:13 lwall Locked $
+.TH GCP 1C "13 May 1988"
+.SH NAME
+gcp \- global file copy
+.SH SYNOPSIS
+.B gcp
+file1 file2
+.br
+.B gcp
+[
+.B \-r
+] file ... directory
+.SH DESCRIPTION
+.I gcp
+works just like rcp(1C) except that you may specify a set of hosts to copy files
+from or to.
+The host sets are defined in the file /etc/ghosts.
+(An individual host name can be used as a set containing one member.)
+You can give a command like
+
+ gcp /etc/motd sun:
+
+to copy your /etc/motd file to /etc/motd on all the Suns.
+If, on the other hand, you say
+
+ gcp /a/foo /b/bar sun:/tmp
+
+then your files will be copied to /tmp on all the Suns.
+The general rule is that if you don't specify the destination directory,
+files go to the same directory they are in currently.
+.P
+You may specify the union of two or more sets by using + as follows:
+
+ gcp /a/foo /b/bar 750+mc:
+
+which will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy
+/b/bar to /b/bar on all 750's and Masscomps.
+.P
+Commonly used sets should be defined in /etc/ghosts.
+For example, you could add a line that says
+
+ pep=manny+moe+jack
+
+Another way to do that would be to add the word "pep" after each of the host
+entries:
+
+ manny sun3 pep
+.br
+ moe sun3 pep
+.br
+ jack sun3 pep
+
+Hosts and sets of host can also be excluded:
+
+ foo=sun-sun2
+
+Any host so excluded will never be included, even if a subsequent set on the
+line includes it:
+
+ foo=abc+def
+.br
+ bar=xyz-abc+foo
+
+comes out to xyz+def.
+
+You can define private host sets by creating .ghosts in your current directory
+with entries just like /etc/ghosts.
+Also, if there is a file .grem, it defines "rem" to be the remaining hosts
+from the last gsh or gcp that didn't succeed everywhere.
+.PP
+Interrupting with a SIGINT will cause the rcp to the current host to be skipped
+and execution resumed with the next host.
+To stop completely, send a SIGQUIT.
+.SH SEE ALSO
+rcp(1C)
+.SH BUGS
+All the bugs of rcp, since it calls rcp.
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: ged,v 4.0 91/03/20 01:10:22 lwall Locked $
+
+# Does inplace edits on a set of files on a set of machines.
+#
+# Typical invokation:
+#
+# ged vax+sun /etc/passwd
+# s/Freddy/Freddie/;
+# ^D
+#
+
+$class = shift;
+$files = join(' ',@ARGV);
+
+die "Usage: ged class files <perlcmds\n" unless $files;
+
+exec "gsh", $class, "-d", "perl -pi.bak - $files";
+
+die "Couldn't execute gsh for some reason, stopped";
--- /dev/null
+# This first section gives alternate sets defined in terms of the sets given
+# by the second section. The order is important--all references must be
+# forward references.
+
+Nnd=sun-nd
+all=sun+mc+vax
+baseline=sun+mc
+sun=sun2+sun3
+vax=750+8600
+pep=manny+moe+jack
+
+# This second section defines the basic sets. Each host should have a line
+# that specifies which sets it is a member of. Extra sets should be separated
+# by white space. (The first section isn't strictly necessary, since all sets
+# could be defined in the second section, but then it wouldn't be so readable.)
+
+basvax 8600 src
+cdb0 sun3 sys
+cdb1 sun3 sys
+cdb2 sun3 sys
+chief sun3 src
+tis0 sun3
+manny sun3 sys
+moe sun3 sys
+jack sun3 sys
+disney sun3 sys
+huey sun3 nd
+dewey sun3 nd
+louie sun3 nd
+bizet sun2 src sys
+gif0 mc src
+mc0 mc
+dtv0 mc
--- /dev/null
+#! /usr/bin/perl
+
+# $Header: gsh,v 4.0 91/03/20 01:10:40 lwall Locked $
+
+# Do rsh globally--see man page
+
+$SIG{'QUIT'} = 'quit'; # install signal handler for SIGQUIT
+
+sub getswitches {
+ while ($ARGV[0] =~ /^-/) { # parse switches
+ $ARGV[0] =~ /^-h/ && ($showhost++,$silent++,shift(@ARGV),next);
+ $ARGV[0] =~ /^-s/ && ($silent++,shift(@ARGV),next);
+ $ARGV[0] =~ /^-d/ && ($dodist++,shift(@ARGV),next);
+ $ARGV[0] =~ /^-n/ && ($n=' -n',shift(@ARGV),next);
+ $ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift(@ARGV),shift(@ARGV),
+ next);
+ last;
+ }
+}
+
+do getswitches(); # get any switches before class
+$systype = shift; # get name representing set of hosts
+do getswitches(); # same switches allowed after class
+
+if ($dodist) { # distribute input over all rshes?
+ `cat >/tmp/gsh$$`; # get input into a handy place
+ $dist = " </tmp/gsh$$"; # each rsh takes input from there
+}
+
+$cmd = join(' ',@ARGV); # remaining args constitute the command
+$cmd =~ s/'/'"'"'/g; # quote any embedded single quotes
+
+$one_of_these = ":$systype:"; # prepare to expand "macros"
+$one_of_these =~ s/\+/:/g; # we hope to end up with list of
+$one_of_these =~ s/-/:-/g; # colon separated attributes
+
+@ARGV = ();
+push(@ARGV,'.grem') if -f '.grem';
+push(@ARGV,'.ghosts') if -f '.ghosts';
+push(@ARGV,'/etc/ghosts');
+
+$remainder = '';
+
+line: while (<>) { # for each line of ghosts
+
+ s/[ \t]*\n//; # trim trailing whitespace
+ if (!$_ || /^#/) { # skip blank line or comment
+ next line;
+ }
+
+ if (/^(\w+)=(.+)/) { # a macro line?
+ $name = $1; $repl = $2;
+ $repl =~ s/\+/:/g;
+ $repl =~ s/-/:-/g;
+ $one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list
+ $repl =~ s/:/:-/g;
+ $one_of_these =~ s/:-$name:/:-$repl:/;
+ next line;
+ }
+
+ # we have a normal line
+
+ @attr = split(' '); # a list of attributes to match against
+ # which we put into an array
+ $host = $attr[0]; # the first attribute is the host name
+ if ($showhost) {
+ $showhost = "$host:\t";
+ }
+
+ $wanted = 0;
+ foreach $attr (@attr) { # iterate over attribute array
+ $wanted++ if index($one_of_these,":$attr:") >= 0;
+ $wanted = -9999 if index($one_of_these,":-$attr:") >= 0;
+ }
+ if ($wanted > 0) {
+ print "rsh $host$l$n '$cmd'\n" unless $silent;
+ $SIG{'INT'} = 'DEFAULT';
+ if (open(PIPE,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh
+ $SIG{'INT'} = 'cont';
+ for ($iter=0; <PIPE>; $iter++) {
+ unless ($iter) {
+ $remainder .= "$host+"
+ if /Connection timed out|Permission denied/;
+ }
+ print $showhost,$_;
+ }
+ close(PIPE);
+ } else {
+ print "(Can't execute rsh: $!)\n";
+ $SIG{'INT'} = 'cont';
+ }
+ }
+}
+
+unlink "/tmp/gsh$$" if $dodist;
+
+if ($remainder) {
+ chop($remainder);
+ open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n");
+ print grem 'rem=', $remainder, "\n";
+ close(grem);
+ print 'rem=', $remainder, "\n";
+}
+
+# here are a couple of subroutines that serve as signal handlers
+
+sub cont {
+ print "\rContinuing...\n";
+ $remainder .= "$host+";
+}
+
+sub quit {
+ $| = 1;
+ print "\r";
+ $SIG{'INT'} = '';
+ kill 2, $$;
+}
--- /dev/null
+.\" $Header: gsh.man,v 4.0 91/03/20 01:10:46 lwall Locked $
+.TH GSH 8 "13 May 1988"
+.SH NAME
+gsh \- global shell
+.SH SYNOPSIS
+.B gsh
+[options]
+.I host
+[options]
+.I command
+.SH DESCRIPTION
+.I gsh
+works just like rsh(1C) except that you may specify a set of hosts to execute
+the command on.
+The host sets are defined in the file /etc/ghosts.
+(An individual host name can be used as a set containing one member.)
+You can give a command like
+
+ gsh sun /etc/mungmotd
+
+to run /etc/mungmotd on all your Suns.
+.P
+You may specify the union of two or more sets by using + as follows:
+
+ gsh 750+mc /etc/mungmotd
+
+which will run mungmotd on all 750's and Masscomps.
+.P
+Commonly used sets should be defined in /etc/ghosts.
+For example, you could add a line that says
+
+ pep=manny+moe+jack
+
+Another way to do that would be to add the word "pep" after each of the host
+entries:
+
+ manny sun3 pep
+.br
+ moe sun3 pep
+.br
+ jack sun3 pep
+
+Hosts and sets of host can also be excluded:
+
+ foo=sun-sun2
+
+Any host so excluded will never be included, even if a subsequent set on the
+line includes it:
+
+ foo=abc+def
+ bar=xyz-abc+foo
+
+comes out to xyz+def.
+
+You can define private host sets by creating .ghosts in your current directory
+with entries just like /etc/ghosts.
+Also, if there is a file .grem, it defines "rem" to be the remaining hosts
+from the last gsh or gcp that didn't succeed everywhere.
+
+Options include all those defined by rsh, as well as
+
+.IP "\-d" 8
+Causes gsh to collect input till end of file, and then distribute that input
+to each invokation of rsh.
+.IP "\-h" 8
+Rather than print out the command followed by the output, merely prepends the
+host name to each line of output.
+.IP "\-s" 8
+Do work silently.
+.PP
+Interrupting with a SIGINT will cause the rsh to the current host to be skipped
+and execution resumed with the next host.
+To stop completely, send a SIGQUIT.
+.SH SEE ALSO
+rsh(1C)
+.SH BUGS
+All the bugs of rsh, since it calls rsh.
+
+Also, will not properly return data from the remote execution that contains
+null characters.
--- /dev/null
+#!../perl
+
+$M = '-M';
+$M = '-m' if -d '/usr/uts' && -f '/etc/master';
+
+do 'getopt.pl';
+do Getopt('f');
+
+if ($opt_f) {
+ $makefile = $opt_f;
+}
+elsif (-f 'makefile') {
+ $makefile = 'makefile';
+}
+elsif (-f 'Makefile') {
+ $makefile = 'Makefile';
+}
+else {
+ die "No makefile\n";
+}
+
+$MF = 'mf00';
+
+while(($key,$val) = each(ENV)) {
+ $mac{$key} = $val;
+}
+
+do scan($makefile);
+
+$co = $action{'.c.o'};
+$co = ' ' unless $co;
+
+$missing = "Missing dependencies:\n";
+foreach $key (sort keys(o)) {
+ if ($oc{$key}) {
+ $src = $oc{$key};
+ $action = $action{$key};
+ }
+ else {
+ $action = '';
+ }
+ if (!$action) {
+ if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) {
+ $src = $c;
+ $action = $co;
+ }
+ else {
+ print "No source found for $key $c\n";
+ next;
+ }
+ }
+ $I = '';
+ $D = '';
+ $I .= $1 while $action =~ s/(-I\S+\s*)//;
+ $D .= $1 . ' ' while $action =~ s/(-D\w+)//;
+ if ($opt_v) {
+ $cmd = "Checking $key: cc $M $D $I $src";
+ $cmd =~ s/\s\s+/ /g;
+ print stderr $cmd,"\n";
+ }
+ open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!";
+ while (<CPP>) {
+ ($name,$dep) = split;
+ $dep =~ s|^\./||;
+ (print $missing,"$key: $dep\n"),($missing='')
+ unless ($dep{"$key: $dep"} += 2) > 2;
+ }
+}
+
+$extra = "\nExtraneous dependencies:\n";
+foreach $key (sort keys(dep)) {
+ if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) {
+ print $extra,$key,"\n";
+ $extra = '';
+ }
+}
+
+sub scan {
+ local($makefile) = @_;
+ local($MF) = $MF;
+ print stderr "Analyzing $makefile.\n" if $opt_v;
+ $MF++;
+ open($MF,$makefile) || die "Can't open $makefile: $!";
+ while (<$MF>) {
+ chop;
+ chop($_ = $_ . <$MF>) while s/\\$//;
+ next if /^#/;
+ next if /^$/;
+ s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
+ s/\$\((\w+)\)/$mac{$1}/eg;
+ $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/;
+ if (/^include\s+(.*)/) {
+ do scan($1);
+ print stderr "Continuing $makefile.\n" if $opt_v;
+ next;
+ }
+ if (/^([^:]+):\s*(.*)/) {
+ $left = $1;
+ $right = $2;
+ if ($right =~ /^([^;]*);(.*)/) {
+ $right = $1;
+ $action = $2;
+ }
+ else {
+ $action = '';
+ }
+ while (<$MF>) {
+ last unless /^\t/;
+ chop;
+ chop($_ = $_ . <$MF>) while s/\\$//;
+ next if /^#/;
+ last if /^$/;
+ s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
+ s/\$\((\w+)\)/$mac{$1}/eg;
+ $action .= $_;
+ }
+ foreach $targ (split(' ',$left)) {
+ $targ =~ s|^\./||;
+ foreach $src (split(' ',$right)) {
+ $src =~ s|^\./||;
+ $deplist{$targ} .= ' ' . $src;
+ $dep{"$targ: $src"} = 1;
+ $o{$src} = 1 if $src =~ /\.o$/;
+ $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/;
+ }
+ $action{$targ} .= $action;
+ }
+ redo if $_;
+ }
+ }
+ close($MF);
+}
+
+sub subst {
+ local($foo,$from,$to) = @_;
+ $foo = $mac{$foo};
+ $from =~ s/\./[.]/;
+ y/a/a/;
+ $foo =~ s/\b$from\b/$to/g;
+ $foo;
+}
--- /dev/null
+.\" $Header: muck.man,v 4.0 91/03/20 01:11:04 lwall Locked $
+.TH MUCK 1 "10 Jan 1989"
+.SH NAME
+muck \- make usage checker
+.SH SYNOPSIS
+.B muck
+[options]
+.SH DESCRIPTION
+.I muck
+looks at your current makefile and complains if you've left out any dependencies
+between .o and .h files.
+It also complains about extraneous dependencies.
+.PP
+You can use the -f FILENAME option to specify an alternate name for your
+makefile.
+The -v option is a little more verbose about what muck is mucking around
+with at the moment.
+.SH SEE ALSO
+make(1)
+.SH BUGS
+Only knows about .h, .c and .o files.
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: myrup,v 4.0 91/03/20 01:11:16 lwall Locked $
+
+# This was a customization of ruptime requested by someone here who wanted
+# to be able to find the least loaded machine easily. It uses the
+# /etc/ghosts file that's defined for gsh and gcp to prune down the
+# number of entries to those hosts we have administrative control over.
+
+print "node load (u)\n------- --------\n";
+
+open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!";
+line: while (<ghosts>) {
+ next line if /^#/;
+ next line if /^$/;
+ next line if /=/;
+ ($host) = split;
+ $wanted{$host} = 1;
+}
+
+open(ruptime,'ruptime|') || die "Can't run ruptime: $!";
+open(sort,'|sort +1n');
+
+while (<ruptime>) {
+ ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/);
+ if ($wanted{$host} && $upness eq 'up') {
+ printf sort "%s\t%s (%d)\n", $host, $load, $users;
+ }
+}
--- /dev/null
+eval "exec /usr/bin/perl -Spi.bak $0 $*"
+ if $running_under_some_shell;
+
+# $Header: nih,v 4.0 91/03/20 01:11:29 lwall Locked $
+
+# This script makes #! scripts directly executable on machines that don't
+# support #!. It edits in place any scripts mentioned on the command line.
+
+s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;|
+ if $. == 1;
--- /dev/null
+#!/usr/bin/perl
+'di';
+'ig00';
+#
+# $Header: relink,v 4.0 91/03/20 01:11:40 lwall Locked $
+#
+# $Log: relink,v $
+# 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) {
+ @ARGV = <STDIN>;
+ chop(@ARGV);
+}
+for (@ARGV) {
+ next unless -l; # symbolic link?
+ $name = $_;
+ $_ = readlink($_);
+ $was = $_;
+ eval $op;
+ die $@ if $@;
+ if ($was ne $_) {
+ unlink($name);
+ symlink($_, $name);
+ }
+}
+##############################################################################
+
+ # 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
+';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############
+.TH RELINK 1 "July 30, 1990"
+.AT 3
+.SH LINK
+relink \- relinks multiple symbolic links
+.SH SYNOPSIS
+.B relink perlexpr [symlinknames]
+.SH DESCRIPTION
+.I Relink
+relinks the symbolic links given according to the rule specified as the
+first argument.
+The argument is a Perl expression which is expected to modify the $_
+string in Perl for at least some of the names specified.
+For each symbolic link named on the command line, the Perl expression
+will be executed on the contents of the symbolic link with that name.
+If a given symbolic link's contents is not modified by the expression,
+it will not be changed.
+If a name given on the command line is not a symbolic link, it will be ignored.
+If no names are given on the command line, names will be read
+via standard input.
+.PP
+For example, to relink all symbolic links in the current directory
+pointing to somewhere in X11R3 so that they point to X11R4, you might say
+.nf
+
+ relink 's/X11R3/X11R4/' *
+
+.fi
+To change all occurences of links in the system from /usr/spool to /var/spool,
+you'd say
+.nf
+
+ find / -type l -print | relink 's#/usr/spool#/var/spool#'
+
+.fi
+.SH ENVIRONMENT
+No environment variables are used.
+.SH FILES
+.SH AUTHOR
+Larry Wall
+.SH "SEE ALSO"
+ln(1)
+.br
+perl(1)
+.SH DIAGNOSTICS
+If you give an invalid Perl expression you'll get a syntax error.
+.SH BUGS
+.ex
--- /dev/null
+#!/usr/bin/perl
+'di';
+'ig00';
+#
+# $Header: rename,v 4.0 91/03/20 01:11:53 lwall Locked $
+#
+# $Log: rename,v $
+# 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) {
+ @ARGV = <STDIN>;
+ chop(@ARGV);
+}
+for (@ARGV) {
+ $was = $_;
+ eval $op;
+ die $@ if $@;
+ rename($was,$_) unless $was eq $_;
+}
+##############################################################################
+
+ # 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
+';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############
+.TH RENAME 1 "July 30, 1990"
+.AT 3
+.SH NAME
+rename \- renames multiple files
+.SH SYNOPSIS
+.B rename perlexpr [files]
+.SH DESCRIPTION
+.I Rename
+renames the filenames supplied according to the rule specified as the
+first argument.
+The argument is a Perl expression which is expected to modify the $_
+string in Perl for at least some of the filenames specified.
+If a given filename is not modified by the expression, it will not be
+renamed.
+If no filenames are given on the command line, filenames will be read
+via standard input.
+.PP
+For example, to rename all files matching *.bak to strip the extension,
+you might say
+.nf
+
+ rename 's/\e.bak$//' *.bak
+
+.fi
+To translate uppercase names to lower, you'd use
+.nf
+
+ rename 'y/A-Z/a-z/' *
+
+.fi
+.SH ENVIRONMENT
+No environment variables are used.
+.SH FILES
+.SH AUTHOR
+Larry Wall
+.SH "SEE ALSO"
+mv(1)
+.br
+perl(1)
+.SH DIAGNOSTICS
+If you give an invalid Perl expression you'll get a syntax error.
+.SH BUGS
+.I Rename
+does not check for the existence of target filenames, so use with care.
+.ex
--- /dev/null
+#!/usr/bin/perl -n
+
+# $Header: rmfrom,v 4.0 91/03/20 01:12:02 lwall Locked $
+
+# A handy (but dangerous) script to put after a find ... -print.
+
+chop; unlink;
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_df,v 4.0 91/03/20 01:12:28 lwall Locked $
+
+# This report points out filesystems that are in danger of overflowing.
+
+(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
+`df >newdf`;
+open(Df, 'olddf');
+
+while (<Df>) {
+ ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
+ next if $fs =~ /:/;
+ next if $fs eq '';
+ $oldused{$fs} = $used;
+}
+
+open(Df, 'newdf') || die "scan_df: can't open newdf";
+
+while (<Df>) {
+ ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
+ next if $fs =~ /:/;
+ next if $fs eq '';
+ $oldused = $oldused{$fs};
+ next if ($oldused == $used && $capacity < 99); # inactive filesystem
+ if ($capacity >= 90) {
+#if defined(mc300) || defined(mc500) || defined(mc700)
+ $_ = substr($_,0,13) . ' ' . substr($_,13,1000);
+ $kbytes /= 2; # translate blocks to K
+ $used /= 2;
+ $oldused /= 2;
+ $avail /= 2;
+#endif
+ $diff = int($used - $oldused);
+ if ($avail < $diff * 2) { # mark specially if in danger
+ $mounted_on .= ' *';
+ }
+ next if $diff < 50 && $mounted_on eq '/';
+ $fs =~ s|/dev/||;
+ if ($diff >= 0) {
+ $diff = '(+' . $diff . ')';
+ }
+ else {
+ $diff = '(' . $diff . ')';
+ }
+ printf "%-8s%8d%8d %-8s%8d%7s %s\n",
+ $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on;
+ }
+}
+
+rename('newdf','olddf');
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_last,v 4.0 91/03/20 01:12:45 lwall Locked $
+
+# This reports who was logged on at weird hours
+
+($dy, $mo, $lastdt) = split(/ +/,`date`);
+
+open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last";
+
+while (<Last>) {
+#if defined(mc300) || defined(mc500) || defined(mc700)
+ $_ = substr($_,0,19) . substr($_,23,100);
+#endif
+ next if /^$/;
+ (print),next if m|^/|;
+ $login = substr($_,0,8);
+ $tty = substr($_,10,7);
+ $from = substr($_,19,15);
+ $day = substr($_,36,3);
+ $mo = substr($_,40,3);
+ $dt = substr($_,44,2);
+ $hr = substr($_,47,2);
+ $min = substr($_,50,2);
+ $dash = substr($_,53,1);
+ $tohr = substr($_,55,2);
+ $tomin = substr($_,58,2);
+ $durhr = substr($_,63,2);
+ $durmin = substr($_,66,2);
+
+ next unless $hr;
+ next if $login eq 'reboot ';
+ next if $login eq 'shutdown';
+
+ if ($dt != $lastdt) {
+ if ($lastdt < $dt) {
+ $seen += $dt - $lastdt;
+ }
+ else {
+ $seen++;
+ }
+ $lastdt = $dt;
+ }
+
+ $inat = $hr + $min / 60;
+ if ($tohr =~ /^[a-z]/) {
+ $outat = 12; # something innocuous
+ } else {
+ $outat = $tohr + $tomin / 60;
+ }
+
+ last if $seen + ($inat < 8) > 1;
+
+ if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) {
+ print;
+ }
+}
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_messages,v 4.0 91/03/20 01:13:01 lwall Locked $
+
+# This prints out extraordinary console messages. You'll need to customize.
+
+chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
+
+$maxpos = `cat oldmsgs 2>&1`;
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+open(Msgs, '/dev/null') || die "scan_messages: can't open messages";
+#else
+open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages";
+#endif
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat(Msgs);
+
+if ($size < $maxpos) { # Did somebody truncate messages file?
+ $maxpos = 0;
+}
+
+seek(Msgs,$maxpos,0); # Start where we left off last time.
+
+while (<Msgs>) {
+ s/\[(\d+)\]/#/ && s/$1/#/g;
+#ifdef vax
+ $_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//;
+ next if /root@.*:/;
+ next if /^vmunix: 4.3 BSD UNIX/;
+ next if /^vmunix: Copyright/;
+ next if /^vmunix: avail mem =/;
+ next if /^vmunix: SBIA0 at /;
+ next if /^vmunix: disk ra81 is/;
+ next if /^vmunix: dmf. at uba/;
+ next if /^vmunix: dmf.:.*asynch/;
+ next if /^vmunix: ex. at uba/;
+ next if /^vmunix: ex.: HW/;
+ next if /^vmunix: il. at uba/;
+ next if /^vmunix: il.: hardware/;
+ next if /^vmunix: ra. at uba/;
+ next if /^vmunix: ra.: media/;
+ next if /^vmunix: real mem/;
+ next if /^vmunix: syncing disks/;
+ next if /^vmunix: tms/;
+ next if /^vmunix: tmscp. at uba/;
+ next if /^vmunix: uba. at /;
+ next if /^vmunix: uda. at /;
+ next if /^vmunix: uda.: unit . ONLIN/;
+ next if /^vmunix: .*buffers containing/;
+ next if /^syslogd: .*newslog/;
+#endif
+ next if /unknown service/;
+ next if /^\.\.\.$/;
+ if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) {
+ $pfx = '';
+ next;
+ }
+ next if /^[ \t]*$/;
+ next if /^[ 0-9]*done$/;
+ if (/^A/) {
+ next if /^Accounting [sr]/;
+ }
+ elsif (/^C/) {
+ next if /^Called from/;
+ next if /^Copyright/;
+ }
+ elsif (/^E/) {
+ next if /^End traceback/;
+ next if /^Ethernet address =/;
+ }
+ elsif (/^K/) {
+ next if /^KERNEL MODE/;
+ }
+ elsif (/^R/) {
+ next if /^Rebooting Unix/;
+ }
+ elsif (/^S/) {
+ next if /^Sun UNIX 4\.2 Release/;
+ }
+ elsif (/^W/) {
+ next if /^WARNING: clock gained/;
+ }
+ elsif (/^a/) {
+ next if /^arg /;
+ next if /^avail mem =/;
+ }
+ elsif (/^b/) {
+ next if /^bwtwo[0-9] at /;
+ }
+ elsif (/^c/) {
+ next if /^cgone[0-9] at /;
+ next if /^cdp[0-9] at /;
+ next if /^csr /;
+ }
+ elsif (/^d/) {
+ next if /^dcpa: init/;
+ next if /^done$/;
+ next if /^dts/;
+ next if /^dump i\/o error/;
+ next if /^dumping to dev/;
+ next if /^dump succeeded/;
+ $pfx = '*' if /^dev = /;
+ }
+ elsif (/^e/) {
+ next if /^end \*\*/;
+ next if /^error in copy/;
+ }
+ elsif (/^f/) {
+ next if /^found /;
+ }
+ elsif (/^i/) {
+ next if /^ib[0-9] at /;
+ next if /^ie[0-9] at /;
+ }
+ elsif (/^l/) {
+ next if /^le[0-9] at /;
+ }
+ elsif (/^m/) {
+ next if /^mem = /;
+ next if /^mt[0-9] at /;
+ next if /^mti[0-9] at /;
+ $pfx = '*' if /^mode = /;
+ }
+ elsif (/^n/) {
+ next if /^not found /;
+ }
+ elsif (/^p/) {
+ next if /^page map /;
+ next if /^pi[0-9] at /;
+ $pfx = '*' if /^panic/;
+ }
+ elsif (/^q/) {
+ next if /^qqq /;
+ }
+ elsif (/^r/) {
+ next if /^read /;
+ next if /^revarp: Requesting/;
+ next if /^root [od]/;
+ }
+ elsif (/^s/) {
+ next if /^sc[0-9] at /;
+ next if /^sd[0-9] at /;
+ next if /^sd[0-9]: </;
+ next if /^si[0-9] at /;
+ next if /^si_getstatus/;
+ next if /^sk[0-9] at /;
+ next if /^skioctl/;
+ next if /^skopen/;
+ next if /^skprobe/;
+ next if /^skread/;
+ next if /^skwrite/;
+ next if /^sky[0-9] at /;
+ next if /^st[0-9] at /;
+ next if /^st0:.*load/;
+ next if /^stat1 = /;
+ next if /^syncing disks/;
+ next if /^syslogd: going down on signal 15/;
+ }
+ elsif (/^t/) {
+ next if /^timeout [0-9]/;
+ next if /^tm[0-9] at /;
+ next if /^tod[0-9] at /;
+ next if /^tv [0-9]/;
+ $pfx = '*' if /^trap address/;
+ }
+ elsif (/^u/) {
+ next if /^unit nsk/;
+ next if /^use one of/;
+ $pfx = '' if /^using/;
+ next if /^using [0-9]+ buffers/;
+ }
+ elsif (/^x/) {
+ next if /^xy[0-9] at /;
+ next if /^write [0-9]/;
+ next if /^xy[0-9]: </;
+ next if /^xyc[0-9] at /;
+ }
+ elsif (/^y/) {
+ next if /^yyy [0-9]/;
+ }
+ elsif (/^z/) {
+ next if /^zs[0-9] at /;
+ }
+ $pfx = '*' if /^[a-z]+:$/;
+ s/pid [0-9]+: //;
+ if (/last message repeated ([0-9]+) time/) {
+ $seen{$last} += $1;
+ next;
+ }
+ s/^/$pfx/ if $pfx;
+ unless ($seen{$_}++) {
+ push(@seen,$_);
+ }
+ $last = $_;
+}
+$max = tell(Msgs);
+
+open(tmp,'|sort >oldmsgs.tmp') || die "Can't create tmp file: $!\n";
+while ($_ = pop(@seen)) {
+ print tmp $_;
+}
+close(tmp);
+open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file: $!\n";
+while (<tmp>) {
+ if (/^nd:/) {
+ next if $seen{$_} < 20;
+ }
+ if (/NFS/) {
+ next if $seen{$_} < 20;
+ }
+ if (/no carrier/) {
+ next if $seen{$_} < 20;
+ }
+ if (/silo overflow/) {
+ next if $seen{$_} < 20;
+ }
+ print $seen{$_},":\t",$_;
+}
+
+print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`;
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: scan_passwd,v 4.0 91/03/20 01:13:18 lwall Locked $
+
+# This scans passwd file for security holes.
+
+open(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n";
+# $dotriv = (`date` =~ /^Mon/);
+$dotriv = 1;
+
+while (<Pass>) {
+ ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/);
+ if ($shell eq '') {
+ print "Short: $_";
+ }
+ next if /^[+]/;
+ if ($pass eq '') {
+ if (index(":sync:lpq:+:", ":$login:") < 0) {
+ print "No pass: $login\t$gcos\n";
+ }
+ }
+ elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) {
+ print "Trivial: $login\t$gcos\n";
+ }
+ if ($uid == 0) {
+ if ($login !~ /^.?root$/ && $pass ne '*') {
+ print "Extra root: $_";
+ }
+ }
+}
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_ps,v 4.0 91/03/20 01:13:29 lwall Locked $
+
+# This looks for looping processes.
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps";
+
+while (<Ps>) {
+ next if /rwhod/;
+ print if index(' T', substr($_,62,1)) < 0;
+}
+#else
+open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps";
+
+while (<Ps>) {
+ next if /dataserver/;
+ next if /nfsd/;
+ next if /update/;
+ next if /ypserv/;
+ next if /rwhod/;
+ next if /routed/;
+ next if /pagedaemon/;
+#ifdef vax
+ ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split;
+#else
+ ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split;
+#endif
+ print if length($time) > 4;
+}
+#endif
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_sudo,v 4.0 91/03/20 01:13:44 lwall Locked $
+
+# Analyze the sudo log.
+
+chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
+
+if (open(Oldsudo,'oldsudo')) {
+ $maxpos = <Oldsudo>;
+ close Oldsudo;
+}
+else {
+ $maxpos = 0;
+ `echo 0 >oldsudo`;
+}
+
+unless (open(Sudo, '/usr/adm/sudo.log')) {
+ print "Somebody removed sudo.log!!!\n" if $maxpos;
+ exit 0;
+}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat(Sudo);
+
+if ($size < $maxpos) {
+ $maxpos = 0;
+ print "Somebody reset sudo.log!!!\n";
+}
+
+seek(Sudo,$maxpos,0);
+
+while (<Sudo>) {
+ s/^.* :[ \t]+//;
+ s/ipcrm.*/ipcrm/;
+ s/kill.*/kill/;
+ unless ($seen{$_}++) {
+ push(@seen,$_);
+ }
+ $last = $_;
+}
+$max = tell(Sudo);
+
+open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n";
+while ($_ = pop(@seen)) {
+ print tmp $_;
+}
+close(tmp);
+open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n";
+while (<tmp>) {
+ print $seen{$_},":\t",$_;
+}
+
+print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`;
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_suid,v 4.0 91/03/20 01:14:00 lwall Locked $
+
+# Look for new setuid root files.
+
+chdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n";
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('oldsuid');
+if ($nlink) {
+ $lasttime = $mtime;
+ $tmp = $ctime - $atime;
+ if ($tmp <= 0 || $tmp >= 10) {
+ print "WARNING: somebody has read oldsuid!\n";
+ }
+ $tmp = $ctime - $mtime;
+ if ($tmp <= 0 || $tmp >= 10) {
+ print "WARNING: somebody has modified oldsuid!!!\n";
+ }
+} else {
+ $lasttime = time - 60 * 60 * 24; # one day ago
+}
+$thistime = time;
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+open(Find, 'find / -perm -04000 -print |') ||
+ die "scan_find: can't run find";
+#else
+open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') ||
+ die "scan_find: can't run find";
+#endif
+
+open(suid, '>newsuid.tmp');
+
+while (<Find>) {
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+ $x = `/bin/ls -il $_`;
+ $_ = $x;
+ s/^ *//;
+ ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
+ = split;
+#else
+ s/^ *//;
+ ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
+ = split;
+#endif
+
+ if ($perm =~ /[sS]/ && $owner eq 'root') {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($name);
+ $foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n",
+ $perm,$links,$owner,$group,$size,$month,$day,$name,$inode);
+ print suid $foo;
+ if ($ctime > $lasttime) {
+ if ($ctime > $thistime) {
+ print "Future file: $foo";
+ }
+ else {
+ $ct .= $foo;
+ }
+ }
+ }
+}
+close(suid);
+
+print `sort +7 -8 newsuid.tmp >newsuid 2>&1`;
+$foo = `/bin/diff oldsuid newsuid 2>&1`;
+print "Differences in suid info:\n",$foo if $foo;
+print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`;
+print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`;
+print `rm -f newsuid.tmp 2>&1`;
+
+@ct = split(/\n/,$ct);
+$ct = '';
+$* = 1;
+while ($#ct >= 0) {
+ $tmp = shift(@ct);
+ unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; }
+}
+
+print "Inode changed since last time:\n",$ct if $ct;
+
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: scanner,v 4.0 91/03/20 01:14:11 lwall Locked $
+
+# This runs all the scan_* routines on all the machines in /etc/ghosts.
+# We run this every morning at about 6 am:
+
+# !/bin/sh
+# cd /usr/adm/private
+# decrypt scanner | perl >scan.out 2>&1
+# mail admin <scan.out
+
+# Note that the scan_* files should be encrypted with the key "-inquire", and
+# scanner should be encrypted somehow so that people can't find that key.
+# I leave it up to you to figure out how to unencrypt it before executing.
+
+$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.';
+
+$| = 1; # command buffering on stdout
+
+print "Subject: bizarre happenings\n\n";
+
+(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n";
+
+if ($#ARGV >= 0) {
+ @scanlist = @ARGV;
+} else {
+ @scanlist = split(/[ \t\n]+/,`echo scan_*`);
+}
+
+scan: while ($scan = shift(@scanlist)) {
+ print "\n********** $scan **********\n";
+ $showhost++;
+
+ $systype = 'all';
+
+ open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file';
+
+ $one_of_these = ":$systype:";
+ if ($systype =~ s/\+/[+]/g) {
+ $one_of_these =~ s/\+/:/g;
+ }
+
+ line: while (<ghosts>) {
+ s/[ \t]*\n//;
+ if (!$_ || /^#/) {
+ next line;
+ }
+ if (/^([a-zA-Z_0-9]+)=(.+)/) {
+ $name = $1; $repl = $2;
+ $repl =~ s/\+/:/g;
+ $one_of_these =~ s/:$name:/:$repl:/;
+ next line;
+ }
+ @gh = split;
+ $host = $gh[0];
+ if ($showhost) { $showhost = "$host:\t"; }
+ class: while ($class = pop(gh)) {
+ if (index($one_of_these,":$class:") >=0) {
+ $iter = 0;
+ `exec crypt -inquire <$scan >.x 2>/dev/null`;
+ unless (open(scan,'.x')) {
+ print "Can't run $scan: $!\n";
+ next scan;
+ }
+ $cmd = <scan>;
+ unless ($cmd =~ s/#!(.*)\n/$1/) {
+ $cmd = '/usr/bin/perl';
+ }
+ close(scan);
+ if (open(PIPE,"exec rsh $host '$cmd' <.x|")) {
+ sleep(5);
+ unlink '.x';
+ while (<PIPE>) {
+ last if $iter++ > 1000; # must be looping
+ next if /^[0-9.]+u [0-9.]+s/;
+ print $showhost,$_;
+ }
+ close(PIPE);
+ } else {
+ print "(Can't execute rsh: $!)\n";
+ }
+ last class;
+ }
+ }
+ }
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: shmkill,v 4.0 91/03/20 01:14:20 lwall Locked $
+
+# A script to call from crontab periodically when people are leaving shared
+# memory sitting around unattached.
+
+open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!";
+
+while (<ipcs>) {
+ $tmp = index($_,'NATTCH');
+ $pos = $tmp if $tmp >= 0;
+ if (/^m/) {
+ ($m,$id,$key,$mode,$owner,$group,$attach) = split;
+ if ($attach != substr($_,$pos,6)) {
+ die "Different ipcs format--can't parse!\n";
+ }
+ if ($attach == 0) {
+ push(@goners,'-m',$id);
+ }
+ }
+}
+
+exec 'ipcrm', @goners if $#goners >= 0;
--- /dev/null
+#!/usr/bin/perl
+eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
+ if 0;
+
+require 'sys/ipc.ph';
+require 'sys/msg.ph';
+
+$| = 1;
+
+$mode = shift;
+die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
+$send = ($mode eq "s");
+
+$id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644);
+die "Can't get message queue: $!\n" unless defined($id);
+print "message queue id: $id\n";
+
+if ($send) {
+ while (<STDIN>) {
+ chop;
+ unless (msgsnd($id, pack("LA*", $., $_), 0)) {
+ die "Can't send message: $!\n";
+ }
+ }
+}
+else {
+ $SIG{'INT'} = $SIG{'QUIT'} = "leave";
+ for (;;) {
+ unless (msgrcv($id, $_, 512, 0, 0)) {
+ die "Can't receive message: $!\n";
+ }
+ ($type, $message) = unpack("La*", $_);
+ printf "[%d] %s\n", $type, $message;
+ }
+}
+
+&leave;
+
+sub leave {
+ if (!$send) {
+ $x = msgctl($id, &IPC_RMID, 0);
+ if (!defined($x) || $x < 0) {
+ die "Can't remove message queue: $!\n";
+ }
+ }
+ exit;
+}
--- /dev/null
+#!/usr/bin/perl
+eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
+ if 0;
+
+require 'sys/ipc.ph';
+require 'sys/msg.ph';
+
+$| = 1;
+
+$mode = shift;
+die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
+$signal = ($mode eq "s");
+
+$id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644);
+die "Can't get semaphore: $!\n" unless defined($id);
+print "semaphore id: $id\n";
+
+if ($signal) {
+ while (<STDIN>) {
+ print "Signalling\n";
+ unless (semop($id, 0, pack("sss", 0, 1, 0))) {
+ die "Can't signal semaphore: $!\n";
+ }
+ }
+}
+else {
+ $SIG{'INT'} = $SIG{'QUIT'} = "leave";
+ for (;;) {
+ unless (semop($id, 0, pack("sss", 0, -1, 0))) {
+ die "Can't wait for semaphore: $!\n";
+ }
+ print "Unblocked\n";
+ }
+}
+
+&leave;
+
+sub leave {
+ if (!$signal) {
+ $x = semctl($id, 0, &IPC_RMID, 0);
+ if (!defined($x) || $x < 0) {
+ die "Can't remove semaphore: $!\n";
+ }
+ }
+ exit;
+}
--- /dev/null
+#!/usr/bin/perl
+eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
+ if 0;
+
+require 'sys/ipc.ph';
+require 'sys/shm.ph';
+
+$| = 1;
+
+$mode = shift;
+die "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/;
+$send = ($mode eq "s");
+
+$SIZE = 32;
+$id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644);
+die "Can't get shared memory: $!\n" unless defined($id);
+print "shared memory id: $id\n";
+
+if ($send) {
+ while (<STDIN>) {
+ chop;
+ unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) {
+ die "Can't write to shared memory: $!\n";
+ }
+ }
+}
+else {
+ $SIG{'INT'} = $SIG{'QUIT'} = "leave";
+ for (;;) {
+ $_ = <STDIN>;
+ unless (shmread($id, $_, 0, $SIZE)) {
+ die "Can't read shared memory: $!\n";
+ }
+ $len = unpack("L", $_);
+ $message = substr($_, length(pack("L",0)), $len);
+ printf "[%d] %s\n", $len, $message;
+ }
+}
+
+&leave;
+
+sub leave {
+ if (!$send) {
+ $x = shmctl($id, &IPC_RMID, 0);
+ if (!defined($x) || $x < 0) {
+ die "Can't remove shared memory: $!\n";
+ }
+ }
+ exit;
+}
--- /dev/null
+#!/usr/bin/perl
+
+while (<>) {
+ next if /^\./;
+ next if /^From / .. /^$/;
+ next if /^Path: / .. /^$/;
+ s/^\W+//;
+ push(@ary,split(' '));
+ while ($#ary > 1) {
+ $a = $p;
+ $p = $n;
+ $w = shift(@ary);
+ $n = $num{$w};
+ if ($n eq '') {
+ push(@word,$w);
+ $n = pack('S',$#word);
+ $num{$w} = $n;
+ }
+ $lookup{$a . $p} .= $n;
+ }
+}
+
+for (;;) {
+ $n = $lookup{$a . $p};
+ ($foo,$n) = each(lookup) if $n eq '';
+ $n = substr($n,int(rand(length($n))) & 0177776,2);
+ $a = $p;
+ $p = $n;
+ ($w) = unpack('S',$n);
+ $w = $word[$w];
+ $col += length($w) + 1;
+ if ($col >= 65) {
+ $col = 0;
+ print "\n";
+ }
+ else {
+ print ' ';
+ }
+ print $w;
+ if ($w =~ /\.$/) {
+ if (rand() < .1) {
+ print "\n";
+ $col = 80;
+ }
+ }
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: empty,v 4.0 91/03/20 01:15:25 lwall Locked $
+
+# This script empties a trashcan.
+
+$recursive = shift if $ARGV[0] eq '-r';
+
+@ARGV = '.' if $#ARGV < 0;
+
+chop($pwd = `pwd`);
+
+dir: foreach $dir (@ARGV) {
+ unless (chdir $dir) {
+ print stderr "Can't find directory $dir: $!\n";
+ next dir;
+ }
+ if ($recursive) {
+ do cmd('find . -name .deleted -exec /bin/rm -rf {} ;');
+ }
+ else {
+ if (-d '.deleted') {
+ do cmd('rm -rf .deleted');
+ }
+ else {
+ if ($dir eq '.' && $pwd =~ m|/\.deleted$|) {
+ chdir '..';
+ do cmd('rm -rf .deleted');
+ }
+ else {
+ print stderr "No trashcan found in directory $dir\n";
+ }
+ }
+ }
+}
+continue {
+ chdir $pwd;
+}
+
+# force direct execution with no shell
+
+sub cmd {
+ system split(' ',join(' ',@_));
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: unvanish,v 4.0 91/03/20 01:15:38 lwall Locked $
+
+sub it {
+ if ($olddir ne '.') {
+ chop($pwd = `pwd`) if $pwd eq '';
+ (chdir $olddir) || die "Directory $olddir is not accesible";
+ }
+ unless ($olddir eq '.deleted') {
+ if (-d '.deleted') {
+ chdir '.deleted' || die "Directory .deleted is not accesible";
+ }
+ else {
+ chop($pwd = `pwd`) if $pwd eq '';
+ die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/;
+ }
+ }
+ print `mv $startfiles$filelist..$force`;
+ if ($olddir ne '.') {
+ (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
+ }
+}
+
+if ($#ARGV < 0) {
+ open(lastcmd,'.deleted/.lastcmd') ||
+ open(lastcmd,'.lastcmd') ||
+ die "No previous vanish in this dir";
+ $ARGV = <lastcmd>;
+ close(lastcmd);
+ @ARGV = split(/[\n ]+/,$ARGV);
+}
+
+while ($ARGV[0] =~ /^-/) {
+ $_ = shift;
+ /^-f/ && ($force = ' >/dev/null 2>&1');
+ /^-i/ && ($interactive = 1);
+ if (/^-+$/) {
+ $startfiles = '- ';
+ last;
+ }
+}
+
+while ($file = shift) {
+ if ($file =~ s|^(.*)/||) {
+ $dir = $1;
+ }
+ else {
+ $dir = '.';
+ }
+
+ if ($dir ne $olddir) {
+ do it() if $olddir;
+ $olddir = $dir;
+ }
+
+ if ($interactive) {
+ print "unvanish: restore $dir/$file? ";
+ next unless <stdin> =~ /^y/i;
+ }
+
+ $filelist .= $file; $filelist .= ' ';
+
+}
+
+do it() if $olddir;
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: vanexp,v 4.0 91/03/20 01:15:54 lwall Locked $
+
+# This is for running from a find at night to expire old .deleteds
+
+$can = $ARGV[0];
+
+exit 1 unless $can =~ /.deleted$/;
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($can);
+
+exit 0 unless $size;
+
+if (time - $mtime > 2 * 24 * 60 * 60) {
+ `/bin/rm -rf $can`;
+}
+else {
+ `find $can -ctime +2 -exec rm -f {} \;`;
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: vanish,v 4.0 91/03/20 01:16:05 lwall Locked $
+
+sub it {
+ if ($olddir ne '.') {
+ chop($pwd = `pwd`) if $pwd eq '';
+ (chdir $olddir) || die "Directory $olddir is not accesible";
+ }
+ if (!-d .deleted) {
+ print `mkdir .deleted; chmod 775 .deleted`;
+ die "You can't remove files from $olddir" if $?;
+ }
+ $filelist =~ s/ $//;
+ $filelist =~ s/#/\\#/g;
+ if ($filelist !~ /^[ \t]*$/) {
+ open(lastcmd,'>.deleted/.lastcmd');
+ print lastcmd $filelist,"\n";
+ close(lastcmd);
+ print `/bin/mv $startfiles$filelist .deleted$force`;
+ }
+ if ($olddir ne '.') {
+ (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
+ }
+}
+
+while ($ARGV[0] =~ /^-/) {
+ $_ = shift;
+ /^-f/ && ($force = ' >/dev/null 2>&1');
+ /^-i/ && ($interactive = 1);
+ if (/^-+$/) {
+ $startfiles = '- ';
+ last;
+ }
+}
+
+chop($pwd = `pwd`);
+
+while ($file = shift) {
+ if ($file =~ s|^(.*)/||) {
+ $dir = $1;
+ }
+ else {
+ $dir = '.';
+ }
+
+ if ($interactive) {
+ print "vanish: remove $dir/$file? ";
+ next unless <stdin> =~ /^y/i;
+ }
+
+ if ($file eq '.deleted') {
+ print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n";
+ next;
+ }
+
+ if ($dir ne $olddir) {
+ do it() if $olddir;
+ $olddir = $dir;
+ }
+
+ $filelist .= $file; $filelist .= ' ';
+}
+
+do it() if $olddir;
--- /dev/null
+;; Perl code editing commands for GNU Emacs
+;; Copyright (C) 1990 William F. Mann
+;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the
+;; Free Software Foundation, under terms of its General Public License.
+
+;; This file may be made part of GNU Emacs at the option of the FSF, or
+;; of the perl distribution at the option of Larry Wall.
+
+;; This code is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY. No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing. Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; this code, but only under the conditions described in the
+;; GNU Emacs General Public License. A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities. It should be in a
+;; file named COPYING. Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode")
+;; to your .emacs file and change the first line of your perl script to:
+;; #!/usr/bin/perl -- # -*-Perl-*-
+;; With argments to perl:
+;; #!/usr/bin/perl -P- # -*-Perl-*-
+;; To handle files included with do 'filename.pl';, add something like
+;; (setq auto-mode-alist (append (list (cons "\\.pl$" 'perl-mode))
+;; auto-mode-alist))
+;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode.
+
+;; This code is based on the 18.53 version c-mode.el, with extensive
+;; rewriting. Most of the features of c-mode survived intact.
+
+;; I added a new feature which adds functionality to TAB; it is controlled
+;; by the variable perl-tab-to-comment. With it enabled, TAB does the
+;; first thing it can from the following list: change the indentation;
+;; move past leading white space; delete an empty comment; reindent a
+;; comment; move to end of line; create an empty comment; tell you that
+;; the line ends in a quoted string, or has a # which should be a \#.
+
+;; If your machine is slow, you may want to remove some of the bindings
+;; to electric-perl-terminator. I changed the indenting defaults to be
+;; what Larry Wall uses in perl/lib, but left in all the options.
+
+;; I also tuned a few things: comments and labels starting in column
+;; zero are left there by indent-perl-exp; perl-beginning-of-function
+;; goes back to the first open brace/paren in column zero, the open brace
+;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp
+;; (meta-^q) indents from the current line through the close of the next
+;; brace/paren, so you don't need to start exactly at a brace or paren.
+
+;; It may be good style to put a set of redundant braces around your
+;; main program. This will let you reindent it with meta-^q.
+
+;; Known problems (these are all caused by limitations in the elisp
+;; parsing routine (parse-partial-sexp), which was not designed for such
+;; a rich language; writing a more suitable parser would be a big job):
+;; 1) Regular expression delimitors do not act as quotes, so special
+;; characters such as `'"#:;[](){} may need to be backslashed
+;; in regular expressions and in both parts of s/// and tr///.
+;; 2) The globbing syntax <pattern> is not recognized, so special
+;; characters in the pattern string must be backslashed.
+;; 3) The q, qq, and << quoting operators are not recognized; see below.
+;; 4) \ (backslash) always quotes the next character, so '\' is
+;; treated as the start of a string. Use "\\" as a work-around.
+;; 5) To make variables such a $' and $#array work, perl-mode treats
+;; $ just like backslash, so '$' is the same as problem 5.
+;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an
+;; unmatched }. See below.
+;; 7) When ' (quote) is used as a package name separator, perl-mode
+;; doesn't understand, and thinks it is seeing a quoted string.
+
+;; Here are some ugly tricks to bypass some of these problems: the perl
+;; expression /`/ (that's a back-tick) usually evaluates harmlessly,
+;; but will trick perl-mode into starting a quoted string, which
+;; can be ended with another /`/. Assuming you have no embedded
+;; back-ticks, this can used to help solve problem 3:
+;;
+;; /`/; $ugly = q?"'$?; /`/;
+;;
+;; To solve problem 6, add a /{/; before each use of ${var}:
+;; /{/; while (<${glob_me}>) ...
+;;
+;; Problem 7 is even worse, but this 'fix' does work :-(
+;; $DB'stop#'
+;; [$DB'line#'
+;; ] =~ s/;9$//;
+
+
+(defvar perl-mode-abbrev-table nil
+ "Abbrev table in use in perl-mode buffers.")
+(define-abbrev-table 'perl-mode-abbrev-table ())
+
+(defvar perl-mode-map ()
+ "Keymap used in Perl mode.")
+(if perl-mode-map
+ ()
+ (setq perl-mode-map (make-sparse-keymap))
+ (define-key perl-mode-map "{" 'electric-perl-terminator)
+ (define-key perl-mode-map "}" 'electric-perl-terminator)
+ (define-key perl-mode-map ";" 'electric-perl-terminator)
+ (define-key perl-mode-map ":" 'electric-perl-terminator)
+ (define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function)
+ (define-key perl-mode-map "\e\C-e" 'perl-end-of-function)
+ (define-key perl-mode-map "\e\C-h" 'mark-perl-function)
+ (define-key perl-mode-map "\e\C-q" 'indent-perl-exp)
+ (define-key perl-mode-map "\177" 'backward-delete-char-untabify)
+ (define-key perl-mode-map "\t" 'perl-indent-command))
+
+(autoload 'c-macro-expand "cmacexp"
+ "Display the result of expanding all C macros occurring in the region.
+The expansion is entirely correct because it uses the C preprocessor."
+ t)
+
+(defvar perl-mode-syntax-table nil
+ "Syntax table in use in perl-mode buffers.")
+
+(if perl-mode-syntax-table
+ ()
+ (setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table)))
+ (modify-syntax-entry ?\n ">" perl-mode-syntax-table)
+ (modify-syntax-entry ?# "<" perl-mode-syntax-table)
+ (modify-syntax-entry ?$ "/" perl-mode-syntax-table)
+ (modify-syntax-entry ?% "." perl-mode-syntax-table)
+ (modify-syntax-entry ?& "." perl-mode-syntax-table)
+ (modify-syntax-entry ?\' "\"" perl-mode-syntax-table)
+ (modify-syntax-entry ?* "." perl-mode-syntax-table)
+ (modify-syntax-entry ?+ "." perl-mode-syntax-table)
+ (modify-syntax-entry ?- "." perl-mode-syntax-table)
+ (modify-syntax-entry ?/ "." perl-mode-syntax-table)
+ (modify-syntax-entry ?< "." perl-mode-syntax-table)
+ (modify-syntax-entry ?= "." perl-mode-syntax-table)
+ (modify-syntax-entry ?> "." perl-mode-syntax-table)
+ (modify-syntax-entry ?\\ "\\" perl-mode-syntax-table)
+ (modify-syntax-entry ?` "\"" perl-mode-syntax-table)
+ (modify-syntax-entry ?| "." perl-mode-syntax-table)
+)
+
+(defconst perl-indent-level 4
+ "*Indentation of Perl statements with respect to containing block.")
+(defconst perl-continued-statement-offset 4
+ "*Extra indent for lines not starting new statements.")
+(defconst perl-continued-brace-offset -4
+ "*Extra indent for substatements that start with open-braces.
+This is in addition to perl-continued-statement-offset.")
+(defconst perl-brace-offset 0
+ "*Extra indentation for braces, compared with other text in same context.")
+(defconst perl-brace-imaginary-offset 0
+ "*Imagined indentation of an open brace that actually follows a statement.")
+(defconst perl-label-offset -2
+ "*Offset of Perl label lines relative to usual indentation.")
+
+(defconst perl-tab-always-indent t
+ "*Non-nil means TAB in Perl mode should always indent the current line,
+regardless of where in the line point is when the TAB command is used.")
+
+(defconst perl-tab-to-comment t
+ "*Non-nil means that for lines which don't need indenting, TAB will
+either indent an existing comment, move to end-of-line, or if at end-of-line
+already, create a new comment.")
+
+(defconst perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:"
+ "*Lines starting with this regular expression will not be auto-indented.")
+\f
+(defun perl-mode ()
+ "Major mode for editing Perl code.
+Expression and list commands understand all Perl brackets.
+Tab indents for Perl code.
+Comments are delimited with # ... \\n.
+Paragraphs are separated by blank lines only.
+Delete converts tabs to spaces as it moves back.
+\\{perl-mode-map}
+Variables controlling indentation style:
+ perl-tab-always-indent
+ Non-nil means TAB in Perl mode should always indent the current line,
+ regardless of where in the line point is when the TAB command is used.
+ perl-tab-to-comment
+ Non-nil means that for lines which don't need indenting, TAB will
+ either delete an empty comment, indent an existing comment, move
+ to end-of-line, or if at end-of-line already, create a new comment.
+ perl-nochange
+ Lines starting with this regular expression will not be auto-indented.
+ perl-indent-level
+ Indentation of Perl statements within surrounding block.
+ The surrounding block's indentation is the indentation
+ of the line on which the open-brace appears.
+ perl-continued-statement-offset
+ Extra indentation given to a substatement, such as the
+ then-clause of an if or body of a while.
+ perl-continued-brace-offset
+ Extra indentation given to a brace that starts a substatement.
+ This is in addition to perl-continued-statement-offset.
+ perl-brace-offset
+ Extra indentation for line if it starts with an open brace.
+ perl-brace-imaginary-offset
+ An open brace following other text is treated as if it were
+ this far to the right of the start of its line.
+ perl-label-offset
+ Extra indentation for line that is a label.
+
+Various indentation styles: K&R BSD BLK GNU LW
+ perl-indent-level 5 8 0 2 4
+ perl-continued-statement-offset 5 8 4 2 4
+ perl-continued-brace-offset 0 0 0 0 -4
+ perl-brace-offset -5 -8 0 0 0
+ perl-brace-imaginary-offset 0 0 4 0 0
+ perl-label-offset -5 -8 -2 -2 -2
+
+Turning on Perl mode calls the value of the variable perl-mode-hook with no
+args, if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map perl-mode-map)
+ (setq major-mode 'perl-mode)
+ (setq mode-name "Perl")
+ (setq local-abbrev-table perl-mode-abbrev-table)
+ (set-syntax-table perl-mode-syntax-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'paragraph-ignore-fill-prefix)
+ (setq paragraph-ignore-fill-prefix t)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'perl-indent-line)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline t)
+ (make-local-variable 'comment-start)
+ (setq comment-start "# ")
+ (make-local-variable 'comment-end)
+ (setq comment-end "")
+ (make-local-variable 'comment-column)
+ (setq comment-column 32)
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *")
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'perl-comment-indent)
+ (make-local-variable 'parse-sexp-ignore-comments)
+ (setq parse-sexp-ignore-comments nil)
+ (run-hooks 'perl-mode-hook))
+\f
+;; This is used by indent-for-comment
+;; to decide how much to indent a comment in Perl code
+;; based on its context.
+(defun perl-comment-indent ()
+ (if (and (bolp) (not (eolp)))
+ 0 ;Existing comment at bol stays there.
+ (save-excursion
+ (skip-chars-backward " \t")
+ (max (1+ (current-column)) ;Else indent at comment column
+ comment-column)))) ; except leave at least one space.
+
+(defun electric-perl-terminator (arg)
+ "Insert character. If at end-of-line, and not in a comment or a quote,
+correct the line's indentation."
+ (interactive "P")
+ (let ((insertpos (point)))
+ (and (not arg) ; decide whether to indent
+ (eolp)
+ (save-excursion
+ (beginning-of-line)
+ (and (not ; eliminate comments quickly
+ (re-search-forward comment-start-skip insertpos t))
+ (or (/= last-command-char ?:)
+ ;; Colon is special only after a label ....
+ (looking-at "\\s-*\\(\\w\\|\\s_\\)+$"))
+ (let ((pps (parse-partial-sexp
+ (perl-beginning-of-function) insertpos)))
+ (not (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))
+ (progn ; must insert, indent, delete
+ (insert-char last-command-char 1)
+ (perl-indent-line)
+ (delete-char -1))))
+ (self-insert-command (prefix-numeric-value arg)))
+
+;; not used anymore, but may be useful someday:
+;;(defun perl-inside-parens-p ()
+;; (condition-case ()
+;; (save-excursion
+;; (save-restriction
+;; (narrow-to-region (point)
+;; (perl-beginning-of-function))
+;; (goto-char (point-max))
+;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\()))
+;; (error nil)))
+\f
+(defun perl-indent-command (&optional arg)
+ "Indent current line as Perl code, or optionally, insert a tab character.
+
+With an argument, indent the current line, regardless of other options.
+
+If perl-tab-always-indent is nil and point is not in the indentation
+area at the beginning of the line, simply insert a tab.
+
+Otherwise, indent the current line. If point was within the indentation
+area it is moved to the end of the indentation area. If the line was
+already indented properly and point was not within the indentation area,
+and if perl-tab-to-comment is non-nil (the default), then do the first
+possible action from the following list:
+
+ 1) delete an empty comment
+ 2) move forward to start of comment, indenting if necessary
+ 3) move forward to end of line
+ 4) create an empty comment
+ 5) move backward to start of comment, indenting if necessary."
+ (interactive "P")
+ (if arg ; If arg, just indent this line
+ (perl-indent-line "\f")
+ (if (and (not perl-tab-always-indent)
+ (<= (current-column) (current-indentation)))
+ (insert-tab)
+ (let (bof lsexp delta (oldpnt (point)))
+ (beginning-of-line)
+ (setq lsexp (point))
+ (setq bof (perl-beginning-of-function))
+ (goto-char oldpnt)
+ (setq delta (perl-indent-line "\f\\|;?#" bof))
+ (and perl-tab-to-comment
+ (= oldpnt (point)) ; done if point moved
+ (if (listp delta) ; if line starts in a quoted string
+ (setq lsexp (or (nth 2 delta) bof))
+ (= delta 0)) ; done if indenting occurred
+ (let (eol state)
+ (end-of-line)
+ (setq eol (point))
+ (if (= (char-after bof) ?=)
+ (if (= oldpnt eol)
+ (message "In a format statement"))
+ (setq state (parse-partial-sexp lsexp eol))
+ (if (nth 3 state)
+ (if (= oldpnt eol) ; already at eol in a string
+ (message "In a string which starts with a %c."
+ (nth 3 state)))
+ (if (not (nth 4 state))
+ (if (= oldpnt eol) ; no comment, create one?
+ (indent-for-comment))
+ (beginning-of-line)
+ (if (re-search-forward comment-start-skip eol 'move)
+ (if (eolp)
+ (progn ; kill existing comment
+ (goto-char (match-beginning 0))
+ (skip-chars-backward " \t")
+ (kill-region (point) eol))
+ (if (or (< oldpnt (point)) (= oldpnt eol))
+ (indent-for-comment) ; indent existing comment
+ (end-of-line)))
+ (if (/= oldpnt eol)
+ (end-of-line)
+ (message "Use backslash to quote # characters.")
+ (ding t))))))))))))
+
+(defun perl-indent-line (&optional nochange parse-start)
+ "Indent current line as Perl code. Return the amount the indentation
+changed by, or (parse-state) if line starts in a quoted string."
+ (let ((case-fold-search nil)
+ (pos (- (point-max) (point)))
+ (bof (or parse-start (save-excursion (perl-beginning-of-function))))
+ beg indent shift-amt)
+ (beginning-of-line)
+ (setq beg (point))
+ (setq shift-amt
+ (cond ((= (char-after bof) ?=) 0)
+ ((listp (setq indent (calculate-perl-indent bof))) indent)
+ ((looking-at (or nochange perl-nochange)) 0)
+ (t
+ (skip-chars-forward " \t\f")
+ (cond ((looking-at "\\(\\w\\|\\s_\\)+:")
+ (setq indent (max 1 (+ indent perl-label-offset))))
+ ((= (following-char) ?})
+ (setq indent (- indent perl-indent-level)))
+ ((= (following-char) ?{)
+ (setq indent (+ indent perl-brace-offset))))
+ (- indent (current-column)))))
+ (skip-chars-forward " \t\f")
+ (if (and (numberp shift-amt) (/= 0 shift-amt))
+ (progn (delete-region beg (point))
+ (indent-to indent)))
+ ;; If initial point was within line's indentation,
+ ;; position after the indentation. Else stay at same point in text.
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))
+ shift-amt))
+
+(defun calculate-perl-indent (&optional parse-start)
+ "Return appropriate indentation for current line as Perl code.
+In usual case returns an integer: the column to indent to.
+Returns (parse-state) if line starts inside a string."
+ (save-excursion
+ (beginning-of-line)
+ (let ((indent-point (point))
+ (case-fold-search nil)
+ (colon-line-end 0)
+ state containing-sexp)
+ (if parse-start ;used to avoid searching
+ (goto-char parse-start)
+ (perl-beginning-of-function))
+ (while (< (point) indent-point) ;repeat until right sexp
+ (setq parse-start (point))
+ (setq state (parse-partial-sexp (point) indent-point 0))
+; state = (depth_in_parens innermost_containing_list last_complete_sexp
+; string_terminator_or_nil inside_commentp following_quotep
+; minimum_paren-depth_this_scan)
+; Parsing stops if depth in parentheses becomes equal to third arg.
+ (setq containing-sexp (nth 1 state)))
+ (cond ((nth 3 state) state) ; In a quoted string?
+ ((null containing-sexp) ; Line is at top level.
+ (skip-chars-forward " \t\f")
+ (if (= (following-char) ?{)
+ 0 ; move to beginning of line if it starts a function body
+ ;; indent a little if this is a continuation line
+ (perl-backward-to-noncomment)
+ (if (or (bobp)
+ (memq (preceding-char) '(?\; ?\})))
+ 0 perl-continued-statement-offset)))
+ ((/= (char-after containing-sexp) ?{)
+ ;; line is expression, not statement:
+ ;; indent to just after the surrounding open.
+ (goto-char (1+ containing-sexp))
+ (current-column))
+ (t
+ ;; Statement level. Is it a continuation or a new statement?
+ ;; Find previous non-comment character.
+ (perl-backward-to-noncomment)
+ ;; Back up over label lines, since they don't
+ ;; affect whether our line is a continuation.
+ (while (or (eq (preceding-char) ?\,)
+ (and (eq (preceding-char) ?:)
+ (memq (char-syntax (char-after (- (point) 2)))
+ '(?w ?_))))
+ (if (eq (preceding-char) ?\,)
+ (perl-backward-to-start-of-continued-exp containing-sexp))
+ (beginning-of-line)
+ (perl-backward-to-noncomment))
+ ;; Now we get the answer.
+ (if (not (memq (preceding-char) '(?\; ?\} ?\{)))
+ ;; This line is continuation of preceding line's statement;
+ ;; indent perl-continued-statement-offset more than the
+ ;; previous line of the statement.
+ (progn
+ (perl-backward-to-start-of-continued-exp containing-sexp)
+ (+ perl-continued-statement-offset (current-column)
+ (if (save-excursion (goto-char indent-point)
+ (looking-at "[ \t]*{"))
+ perl-continued-brace-offset 0)))
+ ;; This line starts a new statement.
+ ;; Position at last unclosed open.
+ (goto-char containing-sexp)
+ (or
+ ;; If open paren is in col 0, close brace is special
+ (and (bolp)
+ (save-excursion (goto-char indent-point)
+ (looking-at "[ \t]*}"))
+ perl-indent-level)
+ ;; Is line first statement after an open-brace?
+ ;; If no, find that first statement and indent like it.
+ (save-excursion
+ (forward-char 1)
+ ;; Skip over comments and labels following openbrace.
+ (while (progn
+ (skip-chars-forward " \t\f\n")
+ (cond ((looking-at ";?#")
+ (forward-line 1) t)
+ ((looking-at "\\(\\w\\|\\s_\\)+:")
+ (save-excursion
+ (end-of-line)
+ (setq colon-line-end (point)))
+ (search-forward ":")))))
+ ;; The first following code counts
+ ;; if it is before the line we want to indent.
+ (and (< (point) indent-point)
+ (if (> colon-line-end (point))
+ (- (current-indentation) perl-label-offset)
+ (current-column))))
+ ;; If no previous statement,
+ ;; indent it relative to line brace is on.
+ ;; For open paren in column zero, don't let statement
+ ;; start there too. If perl-indent-level is zero,
+ ;; use perl-brace-offset + perl-continued-statement-offset
+ ;; For open-braces not the first thing in a line,
+ ;; add in perl-brace-imaginary-offset.
+ (+ (if (and (bolp) (zerop perl-indent-level))
+ (+ perl-brace-offset perl-continued-statement-offset)
+ perl-indent-level)
+ ;; Move back over whitespace before the openbrace.
+ ;; If openbrace is not first nonwhite thing on the line,
+ ;; add the perl-brace-imaginary-offset.
+ (progn (skip-chars-backward " \t")
+ (if (bolp) 0 perl-brace-imaginary-offset))
+ ;; If the openbrace is preceded by a parenthesized exp,
+ ;; move to the beginning of that;
+ ;; possibly a different line
+ (progn
+ (if (eq (preceding-char) ?\))
+ (forward-sexp -1))
+ ;; Get initial indentation of the line we are on.
+ (current-indentation))))))))))
+
+(defun perl-backward-to-noncomment ()
+ "Move point backward to after the first non-white-space, skipping comments."
+ (interactive)
+ (let (opoint stop)
+ (while (not stop)
+ (setq opoint (point))
+ (beginning-of-line)
+ (if (re-search-forward comment-start-skip opoint 'move 1)
+ (progn (goto-char (match-end 1))
+ (skip-chars-forward ";")))
+ (skip-chars-backward " \t\f")
+ (setq stop (or (bobp)
+ (not (bolp))
+ (forward-char -1))))))
+
+(defun perl-backward-to-start-of-continued-exp (lim)
+ (if (= (preceding-char) ?\))
+ (forward-sexp -1))
+ (beginning-of-line)
+ (if (<= (point) lim)
+ (goto-char (1+ lim)))
+ (skip-chars-forward " \t\f"))
+\f
+;; note: this may be slower than the c-mode version, but I can understand it.
+(defun indent-perl-exp ()
+ "Indent each line of the Perl grouping following point."
+ (interactive)
+ (let* ((case-fold-search nil)
+ (oldpnt (point-marker))
+ (bof-mark (save-excursion
+ (end-of-line 2)
+ (perl-beginning-of-function)
+ (point-marker)))
+ eol last-mark lsexp-mark delta)
+ (if (= (char-after (marker-position bof-mark)) ?=)
+ (message "Can't indent a format statement")
+ (message "Indenting Perl expression...")
+ (save-excursion (end-of-line) (setq eol (point)))
+ (save-excursion ; locate matching close paren
+ (while (and (not (eobp)) (<= (point) eol))
+ (parse-partial-sexp (point) (point-max) 0))
+ (setq last-mark (point-marker)))
+ (setq lsexp-mark bof-mark)
+ (beginning-of-line)
+ (while (< (point) (marker-position last-mark))
+ (setq delta (perl-indent-line nil (marker-position bof-mark)))
+ (if (numberp delta) ; unquoted start-of-line?
+ (progn
+ (if (eolp)
+ (delete-horizontal-space))
+ (setq lsexp-mark (point-marker))))
+ (end-of-line)
+ (setq eol (point))
+ (if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol))
+ (progn ; line ends in a comment
+ (beginning-of-line)
+ (if (or (not (looking-at "\\s-*;?#"))
+ (listp delta)
+ (and (/= 0 delta)
+ (= (- (current-indentation) delta) comment-column)))
+ (if (re-search-forward comment-start-skip eol t)
+ (indent-for-comment))))) ; indent existing comment
+ (forward-line 1))
+ (goto-char (marker-position oldpnt))
+ (message "Indenting Perl expression...done"))))
+\f
+(defun perl-beginning-of-function (&optional arg)
+ "Move backward to next beginning-of-function, or as far as possible.
+With argument, repeat that many times; negative args move forward.
+Returns new value of point in all cases."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (if (< arg 0) (forward-char 1))
+ (and (/= arg 0)
+ (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*=\\|^\\."
+ nil 'move arg)
+ (goto-char (1- (match-end 0))))
+ (point))
+
+;; note: this routine is adapted directly from emacs lisp.el, end-of-defun;
+;; no bugs have been removed :-)
+(defun perl-end-of-function (&optional arg)
+ "Move forward to next end-of-function.
+The end of a function is found by moving forward from the beginning of one.
+With argument, repeat that many times; negative args move backward."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (let ((first t))
+ (while (and (> arg 0) (< (point) (point-max)))
+ (let ((pos (point)) npos)
+ (while (progn
+ (if (and first
+ (progn
+ (forward-char 1)
+ (perl-beginning-of-function 1)
+ (not (bobp))))
+ nil
+ (or (bobp) (forward-char -1))
+ (perl-beginning-of-function -1))
+ (setq first nil)
+ (forward-list 1)
+ (skip-chars-forward " \t")
+ (if (looking-at "[#\n]")
+ (forward-line 1))
+ (<= (point) pos))))
+ (setq arg (1- arg)))
+ (while (< arg 0)
+ (let ((pos (point)))
+ (perl-beginning-of-function 1)
+ (forward-sexp 1)
+ (forward-line 1)
+ (if (>= (point) pos)
+ (if (progn (perl-beginning-of-function 2) (not (bobp)))
+ (progn
+ (forward-list 1)
+ (skip-chars-forward " \t")
+ (if (looking-at "[#\n]")
+ (forward-line 1)))
+ (goto-char (point-min)))))
+ (setq arg (1+ arg)))))
+
+(defun mark-perl-function ()
+ "Put mark at end of Perl function, point at beginning."
+ (interactive)
+ (push-mark (point))
+ (perl-end-of-function)
+ (push-mark (point))
+ (perl-beginning-of-function)
+ (backward-paragraph))
+
+;;;;;;;; That's all, folks! ;;;;;;;;;
--- /dev/null
+;; Run perl -d under Emacs
+;; Based on gdb.el, as written by W. Schelter, and modified by rms.
+;; Modified for Perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990.
+
+;; This file is part of GNU Emacs.
+;; Copyright (C) 1988,1990 Free Software Foundation, Inc.
+
+;; GNU Emacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility
+;; to anyone for the consequences of using it or for whether it serves
+;; any particular purpose or works at all, unless he says so in writing.
+;; Refer to the GNU Emacs General Public License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute GNU
+;; Emacs, but only under the conditions described in the GNU Emacs
+;; General Public License. A copy of this license is supposed to have
+;; been given to you along with GNU Emacs so you can know your rights and
+;; responsibilities. It should be in a file named COPYING. Among other
+;; things, the copyright notice and this notice must be preserved on all
+;; copies.
+
+;; Description of perl -d interface:
+
+;; A facility is provided for the simultaneous display of the source code
+;; in one window, while using perldb to step through a function in the
+;; other. A small arrow in the source window, indicates the current
+;; line.
+
+;; Starting up:
+
+;; In order to use this facility, invoke the command PERLDB to obtain a
+;; shell window with the appropriate command bindings. You will be asked
+;; for the name of a file to run and additional command line arguments.
+;; Perldb will be invoked on this file, in a window named *perldb-foo*
+;; if the file is foo.
+
+;; M-s steps by one line, and redisplays the source file and line.
+
+;; You may easily create additional commands and bindings to interact
+;; with the display. For example to put the perl debugger command n on \M-n
+;; (def-perldb n "\M-n")
+
+;; This causes the emacs command perldb-next to be defined, and runs
+;; perldb-display-frame after the command.
+
+;; perldb-display-frame is the basic display function. It tries to display
+;; in the other window, the file and line corresponding to the current
+;; position in the perldb window. For example after a perldb-step, it would
+;; display the line corresponding to the position for the last step. Or
+;; if you have done a backtrace in the perldb buffer, and move the cursor
+;; into one of the frames, it would display the position corresponding to
+;; that frame.
+
+;; perldb-display-frame is invoked automatically when a filename-and-line-number
+;; appears in the output.
+
+
+(require 'shell)
+
+(defvar perldb-prompt-pattern "^ DB<[0-9]+> "
+ "A regexp to recognize the prompt for perldb.")
+
+(defvar perldb-mode-map nil
+ "Keymap for perldb-mode.")
+
+(if perldb-mode-map
+ nil
+ (setq perldb-mode-map (copy-keymap shell-mode-map))
+ (define-key perldb-mode-map "\C-l" 'perldb-refresh))
+
+(define-key ctl-x-map " " 'perldb-break)
+(define-key ctl-x-map "&" 'send-perldb-command)
+
+;;Of course you may use `def-perldb' with any other perldb command, including
+;;user defined ones.
+
+(defmacro def-perldb (name key &optional doc)
+ (let* ((fun (intern (concat "perldb-" name))))
+ (` (progn
+ (defun (, fun) (arg)
+ (, (or doc ""))
+ (interactive "p")
+ (perldb-call (if (not (= 1 arg))
+ (concat (, name) arg)
+ (, name))))
+ (define-key perldb-mode-map (, key) (quote (, fun)))))))
+
+(def-perldb "s" "\M-s" "Step one source line with display")
+(def-perldb "n" "\M-n" "Step one source line (skip functions)")
+(def-perldb "c" "\M-c" "Continue with display")
+(def-perldb "r" "\C-c\C-r" "Return from current subroutine")
+(def-perldb "A" "\C-c\C-a" "Delete all actions")
+\f
+(defun perldb-mode ()
+ "Major mode for interacting with an inferior Perl debugger process.
+The following commands are available:
+
+\\{perldb-mode-map}
+
+\\[perldb-display-frame] displays in the other window
+the last line referred to in the perldb buffer.
+
+\\[perldb-s],\\[perldb-n], and \\[perldb-n] in the perldb window,
+call perldb to step, next or continue and then update the other window
+with the current file and position.
+
+If you are in a source file, you may select a point to break
+at, by doing \\[perldb-break].
+
+Commands:
+Many commands are inherited from shell mode.
+Additionally we have:
+
+\\[perldb-display-frame] display frames file in other window
+\\[perldb-s] advance one line in program
+\\[perldb-n] advance one line in program (skip over calls).
+\\[send-perldb-command] used for special printing of an arg at the current point.
+C-x SPACE sets break point at current line."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'perldb-mode)
+ (setq mode-name "Inferior Perl")
+ (setq mode-line-process '(": %s"))
+ (use-local-map perldb-mode-map)
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
+ (make-local-variable 'perldb-last-frame)
+ (setq perldb-last-frame nil)
+ (make-local-variable 'perldb-last-frame-displayed-p)
+ (setq perldb-last-frame-displayed-p t)
+ (make-local-variable 'perldb-delete-prompt-marker)
+ (setq perldb-delete-prompt-marker nil)
+ (make-local-variable 'perldb-filter-accumulator)
+ (setq perldb-filter-accumulator nil)
+ (make-local-variable 'shell-prompt-pattern)
+ (setq shell-prompt-pattern perldb-prompt-pattern)
+ (run-hooks 'shell-mode-hook 'perldb-mode-hook))
+
+(defvar current-perldb-buffer nil)
+
+(defvar perldb-command-name "perl"
+ "Pathname for executing perl -d.")
+
+(defun end-of-quoted-arg (argstr start end)
+ (let* ((chr (substring argstr start (1+ start)))
+ (idx (string-match (concat "[^\\]" chr) argstr (1+ start))))
+ (and idx (1+ idx))
+ )
+)
+
+(defun parse-args-helper (arglist argstr start end)
+ (while (and (< start end) (string-match "[ \t\n\f\r\b]"
+ (substring argstr start (1+ start))))
+ (setq start (1+ start)))
+ (cond
+ ((= start end) arglist)
+ ((string-match "[\"']" (substring argstr start (1+ start)))
+ (let ((next (end-of-quoted-arg argstr start end)))
+ (parse-args-helper (cons (substring argstr (1+ start) next) arglist)
+ argstr (1+ next) end)))
+ (t (let ((next (string-match "[ \t\n\f\b\r]" argstr start)))
+ (if next
+ (parse-args-helper (cons (substring argstr start next) arglist)
+ argstr (1+ next) end)
+ (cons (substring argstr start) arglist))))
+ )
+ )
+
+(defun parse-args (args)
+ "Extract arguments from a string ARGS.
+White space separates arguments, with single or double quotes
+used to protect spaces. A list of strings is returned, e.g.,
+(parse-args \"foo bar 'two args'\") => (\"foo\" \"bar\" \"two args\")."
+ (nreverse (parse-args-helper '() args 0 (length args)))
+)
+
+(defun perldb (path args)
+ "Run perldb on program FILE in buffer *perldb-FILE*.
+The default directory for the current buffer becomes the initial
+working directory, by analogy with gdb . If you wish to change this, use
+the Perl command `chdir(DIR)'."
+ (interactive "FRun perl -d on file: \nsCommand line arguments: ")
+ (setq path (expand-file-name path))
+ (let ((file (file-name-nondirectory path))
+ (dir default-directory))
+ (switch-to-buffer (concat "*perldb-" file "*"))
+ (setq default-directory dir)
+ (or (bolp) (newline))
+ (insert "Current directory is " default-directory "\n")
+ (apply 'make-shell
+ (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs"
+ (parse-args args))
+ (perldb-mode)
+ (set-process-filter (get-buffer-process (current-buffer)) 'perldb-filter)
+ (set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel)
+ (perldb-set-buffer)))
+
+(defun perldb-set-buffer ()
+ (cond ((eq major-mode 'perldb-mode)
+ (setq current-perldb-buffer (current-buffer)))))
+\f
+;; This function is responsible for inserting output from Perl
+;; into the buffer.
+;; Aside from inserting the text, it notices and deletes
+;; each filename-and-line-number;
+;; that Perl prints to identify the selected frame.
+;; It records the filename and line number, and maybe displays that file.
+(defun perldb-filter (proc string)
+ (let ((inhibit-quit t))
+ (if perldb-filter-accumulator
+ (perldb-filter-accumulate-marker proc
+ (concat perldb-filter-accumulator string))
+ (perldb-filter-scan-input proc string))))
+
+(defun perldb-filter-accumulate-marker (proc string)
+ (setq perldb-filter-accumulator nil)
+ (if (> (length string) 1)
+ (if (= (aref string 1) ?\032)
+ (let ((end (string-match "\n" string)))
+ (if end
+ (progn
+ (let* ((first-colon (string-match ":" string 2))
+ (second-colon
+ (string-match ":" string (1+ first-colon))))
+ (setq perldb-last-frame
+ (cons (substring string 2 first-colon)
+ (string-to-int
+ (substring string (1+ first-colon)
+ second-colon)))))
+ (setq perldb-last-frame-displayed-p nil)
+ (perldb-filter-scan-input proc
+ (substring string (1+ end))))
+ (setq perldb-filter-accumulator string)))
+ (perldb-filter-insert proc "\032")
+ (perldb-filter-scan-input proc (substring string 1)))
+ (setq perldb-filter-accumulator string)))
+
+(defun perldb-filter-scan-input (proc string)
+ (if (equal string "")
+ (setq perldb-filter-accumulator nil)
+ (let ((start (string-match "\032" string)))
+ (if start
+ (progn (perldb-filter-insert proc (substring string 0 start))
+ (perldb-filter-accumulate-marker proc
+ (substring string start)))
+ (perldb-filter-insert proc string)))))
+
+(defun perldb-filter-insert (proc string)
+ (let ((moving (= (point) (process-mark proc)))
+ (output-after-point (< (point) (process-mark proc)))
+ (old-buffer (current-buffer))
+ start)
+ (set-buffer (process-buffer proc))
+ (unwind-protect
+ (save-excursion
+ ;; Insert the text, moving the process-marker.
+ (goto-char (process-mark proc))
+ (setq start (point))
+ (insert string)
+ (set-marker (process-mark proc) (point))
+ (perldb-maybe-delete-prompt)
+ ;; Check for a filename-and-line number.
+ (perldb-display-frame
+ ;; Don't display the specified file
+ ;; unless (1) point is at or after the position where output appears
+ ;; and (2) this buffer is on the screen.
+ (or output-after-point
+ (not (get-buffer-window (current-buffer))))
+ ;; Display a file only when a new filename-and-line-number appears.
+ t))
+ (set-buffer old-buffer))
+ (if moving (goto-char (process-mark proc)))))
+
+(defun perldb-sentinel (proc msg)
+ (cond ((null (buffer-name (process-buffer proc)))
+ ;; buffer killed
+ ;; Stop displaying an arrow in a source file.
+ (setq overlay-arrow-position nil)
+ (set-process-buffer proc nil))
+ ((memq (process-status proc) '(signal exit))
+ ;; Stop displaying an arrow in a source file.
+ (setq overlay-arrow-position nil)
+ ;; Fix the mode line.
+ (setq mode-line-process
+ (concat ": "
+ (symbol-name (process-status proc))))
+ (let* ((obuf (current-buffer)))
+ ;; save-excursion isn't the right thing if
+ ;; process-buffer is current-buffer
+ (unwind-protect
+ (progn
+ ;; Write something in *compilation* and hack its mode line,
+ (set-buffer (process-buffer proc))
+ ;; Force mode line redisplay soon
+ (set-buffer-modified-p (buffer-modified-p))
+ (if (eobp)
+ (insert ?\n mode-name " " msg)
+ (save-excursion
+ (goto-char (point-max))
+ (insert ?\n mode-name " " msg)))
+ ;; If buffer and mode line will show that the process
+ ;; is dead, we can delete it now. Otherwise it
+ ;; will stay around until M-x list-processes.
+ (delete-process proc))
+ ;; Restore old buffer, but don't restore old point
+ ;; if obuf is the perldb buffer.
+ (set-buffer obuf))))))
+
+
+(defun perldb-refresh ()
+ "Fix up a possibly garbled display, and redraw the arrow."
+ (interactive)
+ (redraw-display)
+ (perldb-display-frame))
+
+(defun perldb-display-frame (&optional nodisplay noauto)
+ "Find, obey and delete the last filename-and-line marker from PERLDB.
+The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
+Obeying it means displaying in another window the specified file and line."
+ (interactive)
+ (perldb-set-buffer)
+ (and perldb-last-frame (not nodisplay)
+ (or (not perldb-last-frame-displayed-p) (not noauto))
+ (progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame))
+ (setq perldb-last-frame-displayed-p t))))
+
+;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
+;; and that its line LINE is visible.
+;; Put the overlay-arrow on the line LINE in that buffer.
+
+(defun perldb-display-line (true-file line)
+ (let* ((buffer (find-file-noselect true-file))
+ (window (display-buffer buffer t))
+ (pos))
+ (save-excursion
+ (set-buffer buffer)
+ (save-restriction
+ (widen)
+ (goto-line line)
+ (setq pos (point))
+ (setq overlay-arrow-string "=>")
+ (or overlay-arrow-position
+ (setq overlay-arrow-position (make-marker)))
+ (set-marker overlay-arrow-position (point) (current-buffer)))
+ (cond ((or (< pos (point-min)) (> pos (point-max)))
+ (widen)
+ (goto-char pos))))
+ (set-window-point window overlay-arrow-position)))
+\f
+(defun perldb-call (command)
+ "Invoke perldb COMMAND displaying source in other window."
+ (interactive)
+ (goto-char (point-max))
+ (setq perldb-delete-prompt-marker (point-marker))
+ (perldb-set-buffer)
+ (send-string (get-buffer-process current-perldb-buffer)
+ (concat command "\n")))
+
+(defun perldb-maybe-delete-prompt ()
+ (if (and perldb-delete-prompt-marker
+ (> (point-max) (marker-position perldb-delete-prompt-marker)))
+ (let (start)
+ (goto-char perldb-delete-prompt-marker)
+ (setq start (point))
+ (beginning-of-line)
+ (delete-region (point) start)
+ (setq perldb-delete-prompt-marker nil))))
+
+(defun perldb-break ()
+ "Set PERLDB breakpoint at this source line."
+ (interactive)
+ (let ((line (save-restriction
+ (widen)
+ (1+ (count-lines 1 (point))))))
+ (send-string (get-buffer-process current-perldb-buffer)
+ (concat "b " line "\n"))))
+
+(defun perldb-read-token()
+ "Return a string containing the token found in the buffer at point.
+A token can be a number or an identifier. If the token is a name prefaced
+by `$', `@', or `%', the leading character is included in the token."
+ (save-excursion
+ (let (begin)
+ (or (looking-at "[$@%]")
+ (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move))
+ (setq begin (point))
+ (or (looking-at "[$@%]") (setq begin (+ begin 1)))
+ (forward-char 1)
+ (buffer-substring begin
+ (if (re-search-forward "[^a-zA-Z_0-9]"
+ (point-max) 'move)
+ (- (point) 1)
+ (point)))
+)))
+
+(defvar perldb-commands nil
+ "List of strings or functions used by send-perldb-command.
+It is for customization by the user.")
+
+(defun send-perldb-command (arg)
+ "Issue a Perl debugger command selected by the prefix arg. A numeric
+arg selects the ARG'th member COMMAND of the list perldb-commands.
+The token under the cursor is passed to the command. If COMMAND is a
+string, (format COMMAND TOKEN) is inserted at the end of the perldb
+buffer, otherwise (funcall COMMAND TOKEN) is inserted. If there is
+no such COMMAND, then the token itself is inserted. For example,
+\"p %s\" is a possible string to be a member of perldb-commands,
+or \"p $ENV{%s}\"."
+ (interactive "P")
+ (let (comm token)
+ (if arg (setq comm (nth arg perldb-commands)))
+ (setq token (perldb-read-token))
+ (if (eq (current-buffer) current-perldb-buffer)
+ (set-mark (point)))
+ (cond (comm
+ (setq comm
+ (if (stringp comm) (format comm token) (funcall comm token))))
+ (t (setq comm token)))
+ (switch-to-buffer-other-window current-perldb-buffer)
+ (goto-char (dot-max))
+ (insert-string comm)))
--- /dev/null
+package DB;
+
+# modified Perl debugger, to be run from Emacs in perldb-mode
+# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
+
+$header = '$Header: perldb.pl,v 4.0 91/03/20 01:18:58 lwall Locked $';
+#
+# 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
+# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
+#
+# $Log: perldb.pl,v $
+# 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
+select(OUT);
+$| = 1; # for DB'OUT
+select(STDOUT);
+$| = 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\nEnter h for help.\n\n";
+
+sub DB {
+ &save;
+ ($package, $filename, $line) = caller;
+ $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
+ "package $package;"; # this won't let them modify, alas
+ local(*dbline) = "_<$filename";
+ $max = $#dbline;
+ if (($stop,$action) = split(/\0/,$dbline{$line})) {
+ if ($stop eq '1') {
+ $signal |= 1;
+ }
+ else {
+ $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
+ $dbline{$line} =~ s/;9($|\0)/$1/;
+ }
+ }
+ 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;
+ if ($single || $signal) {
+ $evalarg = $pre, &eval if $pre;
+ print OUT $#stack . " levels deep in subroutine calls!\n"
+ if $single & 4;
+ $start = $line;
+ while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) {
+ $single = 0;
+ $signal = 0;
+ $cmd eq '' && exit 0;
+ chop($cmd);
+ $cmd =~ s/\\$// && do {
+ print OUT " cont: ";
+ $cmd .= &gets;
+ redo;
+ };
+ $cmd =~ /^q$/ && exit 0;
+ $cmd =~ /^$/ && ($cmd = $laststep);
+ push(@hist,$cmd) if length($cmd) > 1;
+ ($i) = split(/\s+/,$cmd);
+ eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
+ $cmd =~ /^h$/ && do {
+ print OUT "
+T Stack trace.
+s Single step.
+n Next, steps over subroutine calls.
+r Return from current subroutine.
+c [line] Continue; optionally inserts a one-time-only breakpoint
+ at the specified line.
+<CR> Repeat last n or s.
+l min+incr List incr+1 lines starting at min.
+l min-max List lines.
+l line List line;
+l List next window.
+- List previous window.
+w line List window around line.
+l subname List subroutine.
+f filename Switch to filename.
+/pattern/ Search forwards for pattern; final / is optional.
+?pattern? Search backwards for pattern.
+L List breakpoints and actions.
+S List subroutine names.
+t Toggle trace mode.
+b [line] [condition]
+ Set breakpoint; line defaults to the current execution line;
+ condition breaks if it evaluates to true, defaults to \'1\'.
+b subname [condition]
+ Set breakpoint at first line of subroutine.
+d [line] Delete breakpoint.
+D Delete all breakpoints.
+a [line] command
+ Set an action to be done before the line is executed.
+ Sequence is: check for breakpoint, print line if necessary,
+ do action, prompt user if breakpoint or step, evaluate line.
+A Delete all actions.
+V [pkg [vars]] List some (default all) variables in package (default current).
+X [vars] Same as \"V currentpackage [vars]\".
+< command Define command before prompt.
+| command Define command after prompt.
+! number Redo command (default previous command).
+! -number Redo number\'th to last command.
+H -number Display last number commands (default all).
+q or ^D Quit.
+p expr Same as \"print DB'OUT expr\" in current package.
+= [alias value] Define a command alias, or list current aliases.
+command Execute as a perl statement in current package.
+
+";
+ next; };
+ $cmd =~ /^t$/ && do {
+ $trace = !$trace;
+ print OUT "Trace = ".($trace?"on":"off")."\n";
+ next; };
+ $cmd =~ /^S$/ && do {
+ foreach $subname (sort(keys %sub)) {
+ print OUT $subname,"\n";
+ }
+ next; };
+ $cmd =~ s/^X\b/V $package/;
+ $cmd =~ /^V$/ && do {
+ $cmd = 'V $package'; };
+ $cmd =~ /^V\s*(\S+)\s*(.*)/ && do {
+ $packname = $1;
+ @vars = split(' ',$2);
+ do 'dumpvar.pl' unless defined &main'dumpvar;
+ if (defined &main'dumpvar) {
+ &main'dumpvar($packname,@vars);
+ }
+ else {
+ print DB'OUT "dumpvar.pl not available.\n";
+ }
+ next; };
+ $cmd =~ /^f\s*(.*)/ && do {
+ $file = $1;
+ if (!$file) {
+ print OUT "The old f command is now the r command.\n";
+ print OUT "The new f command switches filenames.\n";
+ next;
+ }
+ if (!defined $_main{'_<' . $file}) {
+ if (($try) = grep(m#^_<.*$file#, keys %_main)) {
+ $file = substr($try,2);
+ print "\n$file:\n";
+ }
+ }
+ if (!defined $_main{'_<' . $file}) {
+ print OUT "There's no code here anything matching $file.\n";
+ next;
+ }
+ elsif ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } };
+ $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
+ $subname = $1;
+ $subname = "main'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($file,$subrange) = split(/:/,$sub{$subname});
+ if ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ }
+ if ($subrange) {
+ if (eval($subrange) < -$window) {
+ $subrange =~ s/-.*/+/;
+ }
+ $cmd = "l $subrange";
+ } else {
+ print OUT "Subroutine $1 not found.\n";
+ next;
+ } };
+ $cmd =~ /^w\s*(\d*)$/ && do {
+ $incr = $window - 1;
+ $start = $1 if $1;
+ $start -= $preview;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^-$/ && do {
+ $incr = $window - 1;
+ $cmd = 'l ' . ($start-$window*2) . '+'; };
+ $cmd =~ /^l$/ && do {
+ $incr = $window - 1;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
+ $start = $1 if $1;
+ $incr = $2;
+ $incr = $window - 1 unless $incr;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
+ $end = (!$2) ? $max : ($4 ? $4 : $2);
+ $end = $max if $end > $max;
+ $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;
+ next; };
+ $cmd =~ /^D$/ && do {
+ print OUT "Deleting all breakpoints...\n";
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ($dbline{$i} =~ s/^\0?$//) {
+ delete $dbline{$i};
+ }
+ }
+ }
+ next; };
+ $cmd =~ /^L$/ && do {
+ for ($i = 1; $i <= $max; $i++) {
+ if (defined $dbline{$i}) {
+ print OUT "$i:\t", $dbline[$i];
+ ($stop,$action) = split(/\0/, $dbline{$i});
+ print OUT " break if (", $stop, ")\n"
+ if $stop;
+ print OUT " action: ", $action, "\n"
+ if $action;
+ last if $signal;
+ }
+ }
+ next; };
+ $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
+ $subname = $1;
+ $cond = $2 || '1';
+ $subname = "$package'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($filename,$i) = split(/[:-]/, $sub{$subname});
+ if ($i) {
+ *dbline = "_<$filename";
+ ++$i while $dbline[$i] == 0 && $i < $#dbline;
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ } else {
+ print OUT "Subroutine $subname not found.\n";
+ }
+ next; };
+ $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
+ $i = ($1?$1:$line);
+ $cond = $2 || '1';
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i not breakable.\n";
+ } else {
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ next; };
+ $cmd =~ /^d\s*(\d+)?/ && do {
+ $i = ($1?$1:$line);
+ $dbline{$i} =~ s/^[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ next; };
+ $cmd =~ /^A$/ && do {
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ }
+ next; };
+ $cmd =~ /^<\s*(.*)/ && do {
+ $pre = do action($1);
+ next; };
+ $cmd =~ /^>\s*(.*)/ && do {
+ $post = do action($1);
+ next; };
+ $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
+ $i = $1;
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i may not have an action.\n";
+ } else {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ $dbline{$i} .= "\0" . do action($3);
+ }
+ next; };
+ $cmd =~ /^n$/ && do {
+ $single = 2;
+ $laststep = $cmd;
+ last; };
+ $cmd =~ /^s$/ && do {
+ $single = 1;
+ $laststep = $cmd;
+ last; };
+ $cmd =~ /^c\s*(\d*)\s*$/ && do {
+ $i = $1;
+ if ($i) {
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i not breakable.\n";
+ next;
+ }
+ $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
+ }
+ for ($i=0; $i <= $#stack; ) {
+ $stack[$i++] &= ~1;
+ }
+ last; };
+ $cmd =~ /^r$/ && do {
+ $stack[$#stack] |= 2;
+ last; };
+ $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) {
+ 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 OUT $sub[$i];
+ }
+ next; };
+ $cmd =~ /^\/(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])/$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ eval '
+ for (;;) {
+ ++$start;
+ $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;
+ }
+ } ';
+ print OUT "/$pat/: not found\n" if ($start == $end);
+ next; };
+ $cmd =~ /^\?(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])\?$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ eval '
+ for (;;) {
+ --$start;
+ $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;
+ }
+ } ';
+ print OUT "?$pat?: not found\n" if ($start == $end);
+ next; };
+ $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
+ pop(@hist) if length($cmd) > 1;
+ $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
+ $cmd = $hist[$i] . "\n";
+ print OUT $cmd;
+ redo; };
+ $cmd =~ /^!(.+)$/ && do {
+ $pat = "^$1";
+ pop(@hist) if length($cmd) > 1;
+ for ($i = $#hist; $i; --$i) {
+ last if $hist[$i] =~ $pat;
+ }
+ if (!$i) {
+ print OUT "No such command!\n\n";
+ next;
+ }
+ $cmd = $hist[$i] . "\n";
+ print OUT $cmd;
+ redo; };
+ $cmd =~ /^H\s*(-(\d+))?/ && do {
+ $end = $2?($#hist-$2):0;
+ $hist = 0 if $hist < 0;
+ for ($i=$#hist; $i>$end; $i--) {
+ print OUT "$i: ",$hist[$i],"\n"
+ unless $hist[$i] =~ /^.?$/;
+ };
+ next; };
+ $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
+ $cmd =~ /^=/ && do {
+ if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
+ $alias{$k}="s~$k~$v~";
+ print OUT "$k = $v\n";
+ } elsif ($cmd =~ /^=\s*$/) {
+ foreach $k (sort keys(%alias)) {
+ if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
+ print OUT "$k = $v\n";
+ } else {
+ print OUT "$k\t$alias{$k}\n";
+ };
+ };
+ };
+ next; };
+ $evalarg = $cmd; &eval;
+ print OUT "\n";
+ }
+ if ($post) {
+ $evalarg = $post; &eval;
+ }
+ }
+ ($@, $!, $[, $,, $/, $\) = @saved;
+}
+
+sub save {
+ @saved = ($@, $!, $[, $,, $/, $\);
+ $[ = 0; $, = ""; $/ = "\n"; $\ = "";
+}
+
+# The following takes its argument via $evalarg to preserve current @_
+
+sub eval {
+ eval "$usercontext $evalarg; &DB'save";
+ print OUT $@;
+}
+
+sub action {
+ local($action) = @_;
+ while ($action =~ s/\\$//) {
+ print OUT "+ ";
+ $action .= &gets;
+ }
+ $action;
+}
+
+sub gets {
+ local($.);
+ <IN>;
+}
+
+sub catch {
+ $signal = 1;
+}
+
+sub sub {
+ push(@stack, $single);
+ $single &= 1;
+ $single |= 4 if $#stack == $deep;
+ if (wantarray) {
+ @i = &$sub;
+ $single |= pop(@stack);
+ @i;
+ }
+ else {
+ $i = &$sub;
+ $single |= pop(@stack);
+ $i;
+ }
+}
+
+$single = 1; # so it stops on first executable statement
+@hist = ('?');
+$SIG{'INT'} = "DB'catch";
+$deep = 100; # warning if stack gets this deep
+$window = 10;
+$preview = 3;
+
+@stack = (0);
+@ARGS = @ARGV;
+for (@args) {
+ s/'/\\'/g;
+ s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+}
+
+if (-f '.perldb') {
+ do './.perldb';
+}
+elsif (-f "$ENV{'LOGDIR'}/.perldb") {
+ do "$ENV{'LOGDIR'}/.perldb";
+}
+elsif (-f "$ENV{'HOME'}/.perldb") {
+ do "$ENV{'HOME'}/.perldb";
+}
+
+1;
--- /dev/null
+Article 4417 of comp.lang.perl:
+Path: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf
+From: ted@evi.com (Ted Stefanik)
+Newsgroups: comp.lang.perl
+Subject: Correction to Perl fatal error marking in GNU Emacs
+Message-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU>
+Date: 27 Feb 91 06:58:53 GMT
+Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System)
+Reply-To: ted@evi.com (Ted Stefanik)
+Organization: The Internet
+Lines: 282
+
+Reading my own message, it occurred to me that I didn't quite satisfy the
+request of stef@zweig.sun (Stephane Payrard):
+
+| Does anyone has extended perdb/perdb.el to position the
+| point to the first syntax error? It would be cool.
+
+What I posted is a way to use the "M-x compile" command to test perl scripts.
+(Needless to say, the script cannot be not interactive; you can't provide input
+to a *compilation* buffer). When creating new Perl programs, I use "M-x
+compile" until I'm sure that they are syntatically correct; if syntax errors
+occur, C-x` takes me to each in sequence. After I'm sure the syntax is
+correct, I start worrying about semantics, and switch to "M-x perldb" if
+necessary.
+
+Therefore, the stuff I posted works great with "M-x compile", but not at all
+with "M-x perldb".
+
+Next, let me update what I posted. I found that perl's die() command doesn't
+print the same format error message as perl does when it dies with a syntax
+error. If you put the following in your ".emacs" file, it causes C-x` to
+recognize both kinds of errors:
+
+(load-library "compile")
+(setq compilation-error-regexp
+ "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)")
+
+Last, so I don't look like a total fool, let me propose a way to satisfy
+Stephane Payrard's original request (repeated again):
+
+| Does anyone has extended perdb/perdb.el to position the
+| point to the first syntax error? It would be cool.
+
+I'm not satisfied with just the "first syntax error". Perl's parser is better
+than most about not getting out of sync; therefore, if it reports multiple
+errors, you can usually be assured they are all real errors.
+
+So... I hacked in the "next-error" function from "compile.el" to form
+"perldb-next-error". You can apply the patches at the end of this message
+to add "perldb-next-error" to your "perldb.el".
+
+Notes:
+ 1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift
+ of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS).
+
+ 2) "next-error" is meant to work on a single *compilation* buffer; any new
+ "M-x compile" or "M-x grep" command will clear the old *compilation*
+ buffer and reset the compilation-error parser to start at the top of the
+ *compilation* buffer.
+
+ "perldb-next-error", on the other hand, has to deal with multiple
+ *perldb-<foo>* buffers, each of which keep growing. "perldb-next-error"
+ correctly handles the constantly growing *perldb-<foo>* buffers by
+ keeping track of the last reported error in the "current-perldb-buffer".
+
+ Sadly however, when you invoke a new "M-x perldb" on a different Perl
+ script, "perldb-next-error" will start parsing the new *perldb-<bar>*
+ buffer at the top (even if it was previously parsed), and will completely
+ lose the marker of the last reported error in *perldb-<foo>*.
+
+ 3) "perldb-next-error" still uses "compilation-error-regexp" to find
+ fatal errors. Therefore, both the "M-x compile"/C-x` scheme and
+ the "M-x perldb"/C-x~ scheme can be used to find fatal errors that
+ match the common "compilation-error-regexp". You *will* want to install
+ that "compilation-error-regexp" stuff into your .emacs file.
+
+ 4) The patch was developed and tested with GNU Emacs 18.55.
+
+ 5) Since the patch was ripped off from compile.el, the code is (of
+ course) subject to the GNU copyleft.
+
+*** perldb.el.orig Wed Feb 27 00:44:27 1991
+--- perldb.el Wed Feb 27 00:44:30 1991
+***************
+*** 199,205 ****
+
+ (defun perldb-set-buffer ()
+ (cond ((eq major-mode 'perldb-mode)
+! (setq current-perldb-buffer (current-buffer)))))
+ \f
+ ;; This function is responsible for inserting output from Perl
+ ;; into the buffer.
+--- 199,211 ----
+
+ (defun perldb-set-buffer ()
+ (cond ((eq major-mode 'perldb-mode)
+! (cond ((not (eq current-perldb-buffer (current-buffer)))
+! (perldb-forget-errors)
+! (setq perldb-parsing-end 2)) ;; 2 to defeat grep defeater
+! (t
+! (if (> perldb-parsing-end (point-max))
+! (setq perldb-parsing-end (max (point-max) 2)))))
+! (setq current-perldb-buffer (current-buffer)))))
+ \f
+ ;; This function is responsible for inserting output from Perl
+ ;; into the buffer.
+***************
+*** 291,297 ****
+ ;; process-buffer is current-buffer
+ (unwind-protect
+ (progn
+! ;; Write something in *compilation* and hack its mode line,
+ (set-buffer (process-buffer proc))
+ ;; Force mode line redisplay soon
+ (set-buffer-modified-p (buffer-modified-p))
+--- 297,303 ----
+ ;; process-buffer is current-buffer
+ (unwind-protect
+ (progn
+! ;; Write something in *perldb-<foo>* and hack its mode line,
+ (set-buffer (process-buffer proc))
+ ;; Force mode line redisplay soon
+ (set-buffer-modified-p (buffer-modified-p))
+***************
+*** 421,423 ****
+--- 427,593 ----
+ (switch-to-buffer-other-window current-perldb-buffer)
+ (goto-char (dot-max))
+ (insert-string comm)))
++ \f
++ (defvar perldb-error-list nil
++ "List of error message descriptors for visiting erring functions.
++ Each error descriptor is a list of length two.
++ Its car is a marker pointing to an error message.
++ Its cadr is a marker pointing to the text of the line the message is about,
++ or nil if that is not interesting.
++ The value may be t instead of a list;
++ this means that the buffer of error messages should be reparsed
++ the next time the list of errors is wanted.")
++
++ (defvar perldb-parsing-end nil
++ "Position of end of buffer when last error messages parsed.")
++
++ (defvar perldb-error-message "No more fatal Perl errors"
++ "Message to print when no more matches for compilation-error-regexp are found")
++
++ (defun perldb-next-error (&optional argp)
++ "Visit next perldb error message and corresponding source code.
++ This operates on the output from the \\[perldb] command.
++ If all preparsed error messages have been processed,
++ the error message buffer is checked for new ones.
++ A non-nil argument (prefix arg, if interactive)
++ means reparse the error message buffer and start at the first error."
++ (interactive "P")
++ (if (or (eq perldb-error-list t)
++ argp)
++ (progn (perldb-forget-errors)
++ (setq perldb-parsing-end 2))) ;; 2 to defeat grep defeater
++ (if perldb-error-list
++ nil
++ (save-excursion
++ (switch-to-buffer current-perldb-buffer)
++ (perldb-parse-errors)))
++ (let ((next-error (car perldb-error-list)))
++ (if (null next-error)
++ (error (concat perldb-error-message
++ (if (and (get-buffer-process current-perldb-buffer)
++ (eq (process-status
++ (get-buffer-process
++ current-perldb-buffer))
++ 'run))
++ " yet" ""))))
++ (setq perldb-error-list (cdr perldb-error-list))
++ (if (null (car (cdr next-error)))
++ nil
++ (switch-to-buffer (marker-buffer (car (cdr next-error))))
++ (goto-char (car (cdr next-error)))
++ (set-marker (car (cdr next-error)) nil))
++ (let* ((pop-up-windows t)
++ (w (display-buffer (marker-buffer (car next-error)))))
++ (set-window-point w (car next-error))
++ (set-window-start w (car next-error)))
++ (set-marker (car next-error) nil)))
++
++ ;; Set perldb-error-list to nil, and
++ ;; unchain the markers that point to the error messages and their text,
++ ;; so that they no longer slow down gap motion.
++ ;; This would happen anyway at the next garbage collection,
++ ;; but it is better to do it right away.
++ (defun perldb-forget-errors ()
++ (if (eq perldb-error-list t)
++ (setq perldb-error-list nil))
++ (while perldb-error-list
++ (let ((next-error (car perldb-error-list)))
++ (set-marker (car next-error) nil)
++ (if (car (cdr next-error))
++ (set-marker (car (cdr next-error)) nil)))
++ (setq perldb-error-list (cdr perldb-error-list))))
++
++ (defun perldb-parse-errors ()
++ "Parse the current buffer as error messages.
++ This makes a list of error descriptors, perldb-error-list.
++ For each source-file, line-number pair in the buffer,
++ the source file is read in, and the text location is saved in perldb-error-list.
++ The function next-error, assigned to \\[next-error], takes the next error off the list
++ and visits its location."
++ (setq perldb-error-list nil)
++ (message "Parsing error messages...")
++ (let (text-buffer
++ last-filename last-linenum)
++ ;; Don't reparse messages already seen at last parse.
++ (goto-char perldb-parsing-end)
++ ;; Don't parse the first two lines as error messages.
++ ;; This matters for grep.
++ (if (bobp)
++ (forward-line 2))
++ (while (re-search-forward compilation-error-regexp nil t)
++ (let (linenum filename
++ error-marker text-marker)
++ ;; Extract file name and line number from error message.
++ (save-restriction
++ (narrow-to-region (match-beginning 0) (match-end 0))
++ (goto-char (point-max))
++ (skip-chars-backward "[0-9]")
++ ;; If it's a lint message, use the last file(linenum) on the line.
++ ;; Normally we use the first on the line.
++ (if (= (preceding-char) ?\()
++ (progn
++ (narrow-to-region (point-min) (1+ (buffer-size)))
++ (end-of-line)
++ (re-search-backward compilation-error-regexp)
++ (skip-chars-backward "^ \t\n")
++ (narrow-to-region (point) (match-end 0))
++ (goto-char (point-max))
++ (skip-chars-backward "[0-9]")))
++ ;; Are we looking at a "filename-first" or "line-number-first" form?
++ (if (looking-at "[0-9]")
++ (progn
++ (setq linenum (read (current-buffer)))
++ (goto-char (point-min)))
++ ;; Line number at start, file name at end.
++ (progn
++ (goto-char (point-min))
++ (setq linenum (read (current-buffer)))
++ (goto-char (point-max))
++ (skip-chars-backward "^ \t\n")))
++ (setq filename (perldb-grab-filename)))
++ ;; Locate the erring file and line.
++ (if (and (equal filename last-filename)
++ (= linenum last-linenum))
++ nil
++ (beginning-of-line 1)
++ (setq error-marker (point-marker))
++ ;; text-buffer gets the buffer containing this error's file.
++ (if (not (equal filename last-filename))
++ (setq text-buffer
++ (and (file-exists-p (setq last-filename filename))
++ (find-file-noselect filename))
++ last-linenum 0))
++ (if text-buffer
++ ;; Go to that buffer and find the erring line.
++ (save-excursion
++ (set-buffer text-buffer)
++ (if (zerop last-linenum)
++ (progn
++ (goto-char 1)
++ (setq last-linenum 1)))
++ (forward-line (- linenum last-linenum))
++ (setq last-linenum linenum)
++ (setq text-marker (point-marker))
++ (setq perldb-error-list
++ (cons (list error-marker text-marker)
++ perldb-error-list)))))
++ (forward-line 1)))
++ (setq perldb-parsing-end (point-max)))
++ (message "Parsing error messages...done")
++ (setq perldb-error-list (nreverse perldb-error-list)))
++
++ (defun perldb-grab-filename ()
++ "Return a string which is a filename, starting at point.
++ Ignore quotes and parentheses around it, as well as trailing colons."
++ (if (eq (following-char) ?\")
++ (save-restriction
++ (narrow-to-region (point)
++ (progn (forward-sexp 1) (point)))
++ (goto-char (point-min))
++ (read (current-buffer)))
++ (buffer-substring (point)
++ (progn
++ (skip-chars-forward "^ :,\n\t(")
++ (point)))))
++
++ (define-key ctl-x-map "~" 'perldb-next-error)
+
+
--- /dev/null
+/* $RCSfile: form.c,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:18:43 $
+ *
+ * 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: form.c,v $
+ * Revision 4.0.1.2 91/11/05 17:18:43 lwall
+ * patch11: formats didn't fill their fields as well as they could
+ * patch11: ^ fields chopped hyphens on line break
+ * patch11: # fields could write outside allocated memory
+ *
+ * Revision 4.0.1.1 91/06/07 11:07:59 lwall
+ * patch4: new copyright notice
+ * patch4: default top-of-form format is now FILEHANDLE_TOP
+ *
+ * Revision 4.0 91/03/20 01:19:23 lwall
+ * 4.0 baseline.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+/* Forms stuff */
+
+void
+form_parseargs(fcmd)
+register FCMD *fcmd;
+{
+ register int i;
+ register ARG *arg;
+ register int items;
+ STR *str;
+ ARG *parselist();
+ line_t oldline = curcmd->c_line;
+ int oldsave = savestack->ary_fill;
+
+ str = fcmd->f_unparsed;
+ curcmd->c_line = fcmd->f_line;
+ fcmd->f_unparsed = Nullstr;
+ (void)savehptr(&curstash);
+ curstash = str->str_u.str_hash;
+ arg = parselist(str);
+ restorelist(oldsave);
+
+ items = arg->arg_len - 1; /* ignore $$ on end */
+ for (i = 1; i <= items; i++) {
+ if (!fcmd || fcmd->f_type == F_NULL)
+ fatal("Too many field values");
+ dehoist(arg,i);
+ fcmd->f_expr = make_op(O_ITEM,1,
+ arg[i].arg_ptr.arg_arg,Nullarg,Nullarg);
+ if (fcmd->f_flags & FC_CHOP) {
+ if ((fcmd->f_expr[1].arg_type & A_MASK) == A_STAB)
+ fcmd->f_expr[1].arg_type = A_LVAL;
+ else if ((fcmd->f_expr[1].arg_type & A_MASK) == A_EXPR)
+ fcmd->f_expr[1].arg_type = A_LEXPR;
+ else
+ fatal("^ field requires scalar lvalue");
+ }
+ fcmd = fcmd->f_next;
+ }
+ if (fcmd && fcmd->f_type)
+ fatal("Not enough field values");
+ curcmd->c_line = oldline;
+ Safefree(arg);
+ str_free(str);
+}
+
+int newsize;
+
+#define CHKLEN(allow) \
+newsize = (d - orec->o_str) + (allow); \
+if (newsize >= curlen) { \
+ curlen = d - orec->o_str; \
+ GROWSTR(&orec->o_str,&orec->o_len,orec->o_len + (allow)); \
+ d = orec->o_str + curlen; /* in case it moves */ \
+ curlen = orec->o_len - 2; \
+}
+
+format(orec,fcmd,sp)
+register struct outrec *orec;
+register FCMD *fcmd;
+int sp;
+{
+ register char *d = orec->o_str;
+ register char *s;
+ register int curlen = orec->o_len - 2;
+ register int size;
+ FCMD *nextfcmd;
+ FCMD *linebeg = fcmd;
+ char tmpchar;
+ char *t;
+ CMD mycmd;
+ STR *str;
+ char *chophere;
+
+ mycmd.c_type = C_NULL;
+ orec->o_lines = 0;
+ for (; fcmd; fcmd = nextfcmd) {
+ nextfcmd = fcmd->f_next;
+ CHKLEN(fcmd->f_presize);
+ /*SUPPRESS 560*/
+ if (s = fcmd->f_pre) {
+ while (*s) {
+ if (*s == '\n') {
+ while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t'))
+ d--;
+ if (fcmd->f_flags & FC_NOBLANK) {
+ if (d == orec->o_str || d[-1] == '\n') {
+ orec->o_lines--; /* don't print blank line */
+ linebeg = fcmd->f_next;
+ break;
+ }
+ else if (fcmd->f_flags & FC_REPEAT)
+ nextfcmd = linebeg;
+ else
+ linebeg = fcmd->f_next;
+ }
+ else
+ linebeg = fcmd->f_next;
+ }
+ *d++ = *s++;
+ }
+ }
+ if (fcmd->f_unparsed)
+ form_parseargs(fcmd);
+ switch (fcmd->f_type) {
+ case F_NULL:
+ orec->o_lines++;
+ break;
+ case F_LEFT:
+ (void)eval(fcmd->f_expr,G_SCALAR,sp);
+ str = stack->ary_array[sp+1];
+ s = str_get(str);
+ size = fcmd->f_size;
+ CHKLEN(size);
+ chophere = Nullch;
+ while (size && *s && *s != '\n') {
+ if (*s == '\t')
+ *s = ' ';
+ size--;
+ if (*s && index(chopset,(*d++ = *s++)))
+ chophere = s;
+ if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
+ *s = ' ';
+ }
+ if (size || !*s)
+ chophere = s;
+ else if (chophere && chophere < s && *s && index(chopset,*s))
+ chophere = s;
+ if (fcmd->f_flags & FC_CHOP) {
+ if (!chophere)
+ chophere = s;
+ size += (s - chophere);
+ d -= (s - chophere);
+ if (fcmd->f_flags & FC_MORE &&
+ *chophere && strNE(chophere,"\n")) {
+ while (size < 3) {
+ d--;
+ size++;
+ }
+ while (d[-1] == ' ' && size < fcmd->f_size) {
+ d--;
+ size++;
+ }
+ *d++ = '.';
+ *d++ = '.';
+ *d++ = '.';
+ size -= 3;
+ }
+ while (*chophere && index(chopset,*chophere)
+ && isSPACE(*chophere))
+ chophere++;
+ str_chop(str,chophere);
+ }
+ if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
+ size = 0; /* no spaces before newline */
+ while (size) {
+ size--;
+ *d++ = ' ';
+ }
+ break;
+ case F_RIGHT:
+ (void)eval(fcmd->f_expr,G_SCALAR,sp);
+ str = stack->ary_array[sp+1];
+ t = s = str_get(str);
+ size = fcmd->f_size;
+ CHKLEN(size);
+ chophere = Nullch;
+ while (size && *s && *s != '\n') {
+ if (*s == '\t')
+ *s = ' ';
+ size--;
+ if (*s && index(chopset,*s++))
+ chophere = s;
+ if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
+ *s = ' ';
+ }
+ if (size || !*s)
+ chophere = s;
+ else if (chophere && chophere < s && *s && index(chopset,*s))
+ chophere = s;
+ if (fcmd->f_flags & FC_CHOP) {
+ if (!chophere)
+ chophere = s;
+ size += (s - chophere);
+ s = chophere;
+ while (*chophere && index(chopset,*chophere)
+ && isSPACE(*chophere))
+ chophere++;
+ }
+ tmpchar = *s;
+ *s = '\0';
+ while (size) {
+ size--;
+ *d++ = ' ';
+ }
+ size = s - t;
+ (void)bcopy(t,d,size);
+ d += size;
+ *s = tmpchar;
+ if (fcmd->f_flags & FC_CHOP)
+ str_chop(str,chophere);
+ break;
+ case F_CENTER: {
+ int halfsize;
+
+ (void)eval(fcmd->f_expr,G_SCALAR,sp);
+ str = stack->ary_array[sp+1];
+ t = s = str_get(str);
+ size = fcmd->f_size;
+ CHKLEN(size);
+ chophere = Nullch;
+ while (size && *s && *s != '\n') {
+ if (*s == '\t')
+ *s = ' ';
+ size--;
+ if (*s && index(chopset,*s++))
+ chophere = s;
+ if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
+ *s = ' ';
+ }
+ if (size || !*s)
+ chophere = s;
+ else if (chophere && chophere < s && *s && index(chopset,*s))
+ chophere = s;
+ if (fcmd->f_flags & FC_CHOP) {
+ if (!chophere)
+ chophere = s;
+ size += (s - chophere);
+ s = chophere;
+ while (*chophere && index(chopset,*chophere)
+ && isSPACE(*chophere))
+ chophere++;
+ }
+ tmpchar = *s;
+ *s = '\0';
+ halfsize = size / 2;
+ while (size > halfsize) {
+ size--;
+ *d++ = ' ';
+ }
+ size = s - t;
+ (void)bcopy(t,d,size);
+ d += size;
+ *s = tmpchar;
+ if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
+ size = 0; /* no spaces before newline */
+ else
+ size = halfsize;
+ while (size) {
+ size--;
+ *d++ = ' ';
+ }
+ if (fcmd->f_flags & FC_CHOP)
+ str_chop(str,chophere);
+ break;
+ }
+ case F_LINES:
+ (void)eval(fcmd->f_expr,G_SCALAR,sp);
+ str = stack->ary_array[sp+1];
+ s = str_get(str);
+ size = str_len(str);
+ CHKLEN(size+1);
+ orec->o_lines += countlines(s,size) - 1;
+ (void)bcopy(s,d,size);
+ d += size;
+ if (size && s[size-1] != '\n') {
+ *d++ = '\n';
+ orec->o_lines++;
+ }
+ linebeg = fcmd->f_next;
+ break;
+ case F_DECIMAL: {
+ double value;
+
+ (void)eval(fcmd->f_expr,G_SCALAR,sp);
+ str = stack->ary_array[sp+1];
+ size = fcmd->f_size;
+ CHKLEN(size+1);
+ /* If the field is marked with ^ and the value is undefined,
+ blank it out. */
+ if ((fcmd->f_flags & FC_CHOP) && !str->str_pok && !str->str_nok) {
+ while (size) {
+ size--;
+ *d++ = ' ';
+ }
+ break;
+ }
+ value = str_gnum(str);
+ if (fcmd->f_flags & FC_DP) {
+ sprintf(d, "%#*.*f", size, fcmd->f_decimals, value);
+ } else {
+ sprintf(d, "%*.0f", size, value);
+ }
+ d += size;
+ break;
+ }
+ }
+ }
+ CHKLEN(1);
+ *d++ = '\0';
+}
+
+countlines(s,size)
+register char *s;
+register int size;
+{
+ register int count = 0;
+
+ while (size--) {
+ if (*s++ == '\n')
+ count++;
+ }
+ return count;
+}
+
+do_write(orec,stab,sp)
+struct outrec *orec;
+STAB *stab;
+int sp;
+{
+ register STIO *stio = stab_io(stab);
+ FILE *ofp = stio->ofp;
+
+#ifdef DEBUGGING
+ if (debug & 256)
+ fprintf(stderr,"left=%ld, todo=%ld\n",
+ (long)stio->lines_left, (long)orec->o_lines);
+#endif
+ if (stio->lines_left < orec->o_lines) {
+ if (!stio->top_stab) {
+ STAB *topstab;
+ char tmpbuf[256];
+
+ if (!stio->top_name) {
+ if (!stio->fmt_name)
+ stio->fmt_name = savestr(stab_name(stab));
+ sprintf(tmpbuf, "%s_TOP", stio->fmt_name);
+ topstab = stabent(tmpbuf,FALSE);
+ if (topstab && stab_form(topstab))
+ stio->top_name = savestr(tmpbuf);
+ else
+ stio->top_name = savestr("top");
+ }
+ topstab = stabent(stio->top_name,FALSE);
+ if (!topstab || !stab_form(topstab)) {
+ stio->lines_left = 100000000;
+ goto forget_top;
+ }
+ stio->top_stab = topstab;
+ }
+ if (stio->lines_left >= 0 && stio->page > 0)
+ (void)putc('\f',ofp);
+ stio->lines_left = stio->page_len;
+ stio->page++;
+ format(&toprec,stab_form(stio->top_stab),sp);
+ fputs(toprec.o_str,ofp);
+ stio->lines_left -= toprec.o_lines;
+ }
+ forget_top:
+ fputs(orec->o_str,ofp);
+ stio->lines_left -= orec->o_lines;
+}
--- /dev/null
+/* $RCSfile: form.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:08:20 $
+ *
+ * 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: form.h,v $
+ * 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 F_NULL 0
+#define F_LEFT 1
+#define F_RIGHT 2
+#define F_CENTER 3
+#define F_LINES 4
+#define F_DECIMAL 5
+
+struct formcmd {
+ struct formcmd *f_next;
+ ARG *f_expr;
+ STR *f_unparsed;
+ line_t f_line;
+ char *f_pre;
+ short f_presize;
+ short f_size;
+ short f_decimals;
+ char f_type;
+ char f_flags;
+};
+
+#define FC_CHOP 1
+#define FC_NOBLANK 2
+#define FC_MORE 4
+#define FC_REPEAT 8
+#define FC_DP 16
+
+#define Nullfcmd Null(FCMD*)
+
+EXT char *chopset INIT(" \n-");
--- /dev/null
+#!./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";
+ }
+
--- /dev/null
+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
+: 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 h2ph (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 >h2ph <<!GROK!THIS!
+#!$bin/perl
+'di';
+'ig00';
+
+\$perlincl = '$installprivlib';
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>h2ph <<'!NO!SUBS!'
+
+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
+!NO!SUBS!
+chmod 755 h2ph
+$eunicefix h2ph
+rm -f h2ph.man
+ln h2ph h2ph.man
--- /dev/null
+$sgttyb_t = 'C4 S';
+
+sub cbreak {
+ &set_cbreak(1);
+}
+
+sub cooked {
+ &set_cbreak(0);
+}
+
+sub set_cbreak {
+ local($on) = @_;
+
+ require 'sizeof.ph';
+ require 'sys/ioctl.ph';
+
+ ioctl(STDIN,&TIOCGETP,$sgttyb)
+ || die "Can't ioctl TIOCGETP: $!";
+
+ @ary = unpack($sgttyb_t,$sgttyb);
+ if ($on) {
+ $ary[4] |= &CBREAK;
+ $ary[4] &= ~&ECHO;
+ } else {
+ $ary[4] &= ~&CBREAK;
+ $ary[4] |= &ECHO;
+ }
+ $sgttyb = pack($sgttyb_t,@ary);
+ ioctl(STDIN,&TIOCSETP,$sgttyb)
+ || die "Can't ioctl TIOCSETP: $!";
+
+}
+
+1;
--- /dev/null
+$sgttyb_t = 'C4 S';
+
+sub cbreak {
+ &set_cbreak(1);
+}
+
+sub cooked {
+ &set_cbreak(0);
+}
+
+sub set_cbreak {
+ local($on) = @_;
+
+ require 'sys/ioctl.pl';
+
+ ioctl(STDIN,$TIOCGETP,$sgttyb)
+ || die "Can't ioctl TIOCGETP: $!";
+
+ @ary = unpack($sgttyb_t,$sgttyb);
+ if ($on) {
+ $ary[4] |= $CBREAK;
+ $ary[4] &= ~$ECHO;
+ } else {
+ $ary[4] &= ~$CBREAK;
+ $ary[4] |= $ECHO;
+ }
+ $sgttyb = pack($sgttyb_t,@ary);
+ ioctl(STDIN,$TIOCSETP,$sgttyb)
+ || die "Can't ioctl TIOCSETP: $!";
+
+}
+
+1;
--- /dev/null
+$sizeof{'char'} = 1;
+$sizeof{'int'} = 4;
+$sizeof{'long'} = 4;
+$sizeof{'struct arpreq'} = 36;
+$sizeof{'struct ifconf'} = 8;
+$sizeof{'struct ifreq'} = 32;
+$sizeof{'struct ltchars'} = 6;
+$sizeof{'struct pcntl'} = 116;
+$sizeof{'struct rtentry'} = 52;
+$sizeof{'struct sgttyb'} = 6;
+$sizeof{'struct tchars'} = 6;
+$sizeof{'struct ttychars'} = 14;
+$sizeof{'struct winsize'} = 8;
+$sizeof{'struct termios'} = 132;
--- /dev/null
+$EPERM = 0x1;
+$ENOENT = 0x2;
+$ESRCH = 0x3;
+$EINTR = 0x4;
+$EIO = 0x5;
+$ENXIO = 0x6;
+$E2BIG = 0x7;
+$ENOEXEC = 0x8;
+$EBADF = 0x9;
+$ECHILD = 0xA;
+$EAGAIN = 0xB;
+$ENOMEM = 0xC;
+$EACCES = 0xD;
+$EFAULT = 0xE;
+$ENOTBLK = 0xF;
+$EBUSY = 0x10;
+$EEXIST = 0x11;
+$EXDEV = 0x12;
+$ENODEV = 0x13;
+$ENOTDIR = 0x14;
+$EISDIR = 0x15;
+$EINVAL = 0x16;
+$ENFILE = 0x17;
+$EMFILE = 0x18;
+$ENOTTY = 0x19;
+$ETXTBSY = 0x1A;
+$EFBIG = 0x1B;
+$ENOSPC = 0x1C;
+$ESPIPE = 0x1D;
+$EROFS = 0x1E;
+$EMLINK = 0x1F;
+$EPIPE = 0x20;
+$EDOM = 0x21;
+$ERANGE = 0x22;
+$EWOULDBLOCK = 0x23;
+$EINPROGRESS = 0x24;
+$EALREADY = 0x25;
+$ENOTSOCK = 0x26;
+$EDESTADDRREQ = 0x27;
+$EMSGSIZE = 0x28;
+$EPROTOTYPE = 0x29;
+$ENOPROTOOPT = 0x2A;
+$EPROTONOSUPPORT = 0x2B;
+$ESOCKTNOSUPPORT = 0x2C;
+$EOPNOTSUPP = 0x2D;
+$EPFNOSUPPORT = 0x2E;
+$EAFNOSUPPORT = 0x2F;
+$EADDRINUSE = 0x30;
+$EADDRNOTAVAIL = 0x31;
+$ENETDOWN = 0x32;
+$ENETUNREACH = 0x33;
+$ENETRESET = 0x34;
+$ECONNABORTED = 0x35;
+$ECONNRESET = 0x36;
+$ENOBUFS = 0x37;
+$EISCONN = 0x38;
+$ENOTCONN = 0x39;
+$ESHUTDOWN = 0x3A;
+$ETOOMANYREFS = 0x3B;
+$ETIMEDOUT = 0x3C;
+$ECONNREFUSED = 0x3D;
+$ELOOP = 0x3E;
+$ENAMETOOLONG = 0x3F;
+$EHOSTDOWN = 0x40;
+$EHOSTUNREACH = 0x41;
+$ENOTEMPTY = 0x42;
+$EPROCLIM = 0x43;
+$EUSERS = 0x44;
+$EDQUOT = 0x45;
+$ESTALE = 0x46;
+$EREMOTE = 0x47;
+$EDEADLK = 0x48;
+$ENOLCK = 0x49;
+$MTH_UNDEF_SQRT = 0x12C;
+$MTH_OVF_EXP = 0x12D;
+$MTH_UNDEF_LOG = 0x12E;
+$MTH_NEG_BASE = 0x12F;
+$MTH_ZERO_BASE = 0x130;
+$MTH_OVF_POW = 0x131;
+$MTH_LRG_SIN = 0x132;
+$MTH_LRG_COS = 0x133;
+$MTH_LRG_TAN = 0x134;
+$MTH_LRG_COT = 0x135;
+$MTH_OVF_TAN = 0x136;
+$MTH_OVF_COT = 0x137;
+$MTH_UNDEF_ASIN = 0x138;
+$MTH_UNDEF_ACOS = 0x139;
+$MTH_UNDEF_ATAN2 = 0x13A;
+$MTH_OVF_SINH = 0x13B;
+$MTH_OVF_COSH = 0x13C;
+$MTH_UNDEF_ZLOG = 0x13D;
+$MTH_UNDEF_ZDIV = 0x13E;
--- /dev/null
+$_IOCTL_ = 0x1;
+$TIOCGSIZE = 0x40087468;
+$TIOCSSIZE = 0x80087467;
+$IOCPARM_MASK = 0x7F;
+$IOC_VOID = 0x20000000;
+$IOC_OUT = 0x40000000;
+$IOC_IN = 0x80000000;
+$IOC_INOUT = 0xC0000000;
+$TIOCGETD = 0x40047400;
+$TIOCSETD = 0x80047401;
+$TIOCHPCL = 0x20007402;
+$TIOCMODG = 0x40047403;
+$TIOCMODS = 0x80047404;
+$TIOCM_LE = 0x1;
+$TIOCM_DTR = 0x2;
+$TIOCM_RTS = 0x4;
+$TIOCM_ST = 0x8;
+$TIOCM_SR = 0x10;
+$TIOCM_CTS = 0x20;
+$TIOCM_CAR = 0x40;
+$TIOCM_CD = 0x40;
+$TIOCM_RNG = 0x80;
+$TIOCM_RI = 0x80;
+$TIOCM_DSR = 0x100;
+$TIOCGETP = 0x40067408;
+$TIOCSETP = 0x80067409;
+$TIOCSETN = 0x8006740A;
+$TIOCEXCL = 0x2000740D;
+$TIOCNXCL = 0x2000740E;
+$TIOCFLUSH = 0x80047410;
+$TIOCSETC = 0x80067411;
+$TIOCGETC = 0x40067412;
+$TIOCSET = 0x80047413;
+$TIOCBIS = 0x80047414;
+$TIOCBIC = 0x80047415;
+$TIOCGET = 0x40047416;
+$TANDEM = 0x1;
+$CBREAK = 0x2;
+$LCASE = 0x4;
+$ECHO = 0x8;
+$CRMOD = 0x10;
+$RAW = 0x20;
+$ODDP = 0x40;
+$EVENP = 0x80;
+$ANYP = 0xC0;
+$NLDELAY = 0x300;
+$NL0 = 0x0;
+$NL1 = 0x100;
+$NL2 = 0x200;
+$NL3 = 0x300;
+$TBDELAY = 0xC00;
+$TAB0 = 0x0;
+$TAB1 = 0x400;
+$TAB2 = 0x800;
+$XTABS = 0xC00;
+$CRDELAY = 0x3000;
+$CR0 = 0x0;
+$CR1 = 0x1000;
+$CR2 = 0x2000;
+$CR3 = 0x3000;
+$VTDELAY = 0x4000;
+$FF0 = 0x0;
+$FF1 = 0x4000;
+$BSDELAY = 0x8000;
+$BS0 = 0x0;
+$BS1 = 0x8000;
+$ALLDELAY = 0xFF00;
+$CRTBS = 0x10000;
+$PRTERA = 0x20000;
+$CRTERA = 0x40000;
+$TILDE = 0x80000;
+$MDMBUF = 0x100000;
+$LITOUT = 0x200000;
+$TOSTOP = 0x400000;
+$FLUSHO = 0x800000;
+$NOHANG = 0x1000000;
+$L001000 = 0x2000000;
+$CRTKIL = 0x4000000;
+$L004000 = 0x8000000;
+$CTLECH = 0x10000000;
+$PENDIN = 0x20000000;
+$DECCTQ = 0x40000000;
+$NOFLSH = 0x80000000;
+$TIOCCSET = 0x800E7417;
+$TIOCCGET = 0x400E7418;
+$TIOCLBIS = 0x8004747F;
+$TIOCLBIC = 0x8004747E;
+$TIOCLSET = 0x8004747D;
+$TIOCLGET = 0x4004747C;
+$LCRTBS = 0x1;
+$LPRTERA = 0x2;
+$LCRTERA = 0x4;
+$LTILDE = 0x8;
+$LMDMBUF = 0x10;
+$LLITOUT = 0x20;
+$LTOSTOP = 0x40;
+$LFLUSHO = 0x80;
+$LNOHANG = 0x100;
+$LCRTKIL = 0x400;
+$LCTLECH = 0x1000;
+$LPENDIN = 0x2000;
+$LDECCTQ = 0x4000;
+$LNOFLSH = 0x8000;
+$TIOCSBRK = 0x2000747B;
+$TIOCCBRK = 0x2000747A;
+$TIOCSDTR = 0x20007479;
+$TIOCCDTR = 0x20007478;
+$TIOCGPGRP = 0x40047477;
+$TIOCSPGRP = 0x80047476;
+$TIOCSLTC = 0x80067475;
+$TIOCGLTC = 0x40067474;
+$TIOCOUTQ = 0x40047473;
+$TIOCSTI = 0x80017472;
+$TIOCNOTTY = 0x20007471;
+$TIOCPKT = 0x80047470;
+$TIOCPKT_DATA = 0x0;
+$TIOCPKT_FLUSHREAD = 0x1;
+$TIOCPKT_FLUSHWRITE = 0x2;
+$TIOCPKT_STOP = 0x4;
+$TIOCPKT_START = 0x8;
+$TIOCPKT_NOSTOP = 0x10;
+$TIOCPKT_DOSTOP = 0x20;
+$TIOCSTOP = 0x2000746F;
+$TIOCSTART = 0x2000746E;
+$TIOCREMOTE = 0x20007469;
+$TIOCGWINSZ = 0x40087468;
+$TIOCSWINSZ = 0x80087467;
+$TIOCRESET = 0x20007466;
+$OTTYDISC = 0x0;
+$NETLDISC = 0x1;
+$NTTYDISC = 0x2;
+$FIOCLEX = 0x20006601;
+$FIONCLEX = 0x20006602;
+$FIONREAD = 0x4004667F;
+$FIONBIO = 0x8004667E;
+$FIOASYNC = 0x8004667D;
+$FIOSETOWN = 0x8004667C;
+$FIOGETOWN = 0x4004667B;
+$STPUTTABLE = 0x8004667A;
+$STGETTABLE = 0x80046679;
+$SIOCSHIWAT = 0x80047300;
+$SIOCGHIWAT = 0x40047301;
+$SIOCSLOWAT = 0x80047302;
+$SIOCGLOWAT = 0x40047303;
+$SIOCATMARK = 0x40047307;
+$SIOCSPGRP = 0x80047308;
+$SIOCGPGRP = 0x40047309;
+$SIOCADDRT = 0x8034720A;
+$SIOCDELRT = 0x8034720B;
+$SIOCSIFADDR = 0x8020690C;
+$SIOCGIFADDR = 0xC020690D;
+$SIOCSIFDSTADDR = 0x8020690E;
+$SIOCGIFDSTADDR = 0xC020690F;
+$SIOCSIFFLAGS = 0x80206910;
+$SIOCGIFFLAGS = 0xC0206911;
+$SIOCGIFBRDADDR = 0xC0206912;
+$SIOCSIFBRDADDR = 0x80206913;
+$SIOCGIFCONF = 0xC0086914;
+$SIOCGIFNETMASK = 0xC0206915;
+$SIOCSIFNETMASK = 0x80206916;
+$SIOCGIFMETRIC = 0xC0206917;
+$SIOCSIFMETRIC = 0x80206918;
+$SIOCSARP = 0x8024691E;
+$SIOCGARP = 0xC024691F;
+$SIOCDARP = 0x80246920;
+$PIXCONTINUE = 0x80747000;
+$PIXSTEP = 0x80747001;
+$PIXTERMINATE = 0x20007002;
+$PIGETFLAGS = 0x40747003;
+$PIXINHERIT = 0x80747004;
+$PIXDETACH = 0x20007005;
+$PIXGETSUBCODE = 0xC0747006;
+$PIXRDREGS = 0xC0747007;
+$PIXWRREGS = 0xC0747008;
+$PIXRDVREGS = 0xC0747009;
+$PIXWRVREGS = 0xC074700A;
+$PIXRDVSTATE = 0xC074700B;
+$PIXWRVSTATE = 0xC074700C;
+$PIXRDCREGS = 0xC074700D;
+$PIXWRCREGS = 0xC074700E;
+$PIRDSDRS = 0xC074700F;
+$PIXGETSIGACTION = 0xC0747010;
+$PIGETU = 0xC0747011;
+$PISETRWTID = 0xC0747012;
+$PIXGETTHCOUNT = 0xC0747013;
+$PIXRUN = 0x20007014;
--- /dev/null
+$EX_OK = 0x0;
+$EX__BASE = 0x40;
+$EX_USAGE = 0x40;
+$EX_DATAERR = 0x41;
+$EX_NOINPUT = 0x42;
+$EX_NOUSER = 0x43;
+$EX_NOHOST = 0x44;
+$EX_UNAVAILABLE = 0x45;
+$EX_SOFTWARE = 0x46;
+$EX_OSERR = 0x47;
+$EX_OSFILE = 0x48;
+$EX_CANTCREAT = 0x49;
+$EX_IOERR = 0x4A;
+$EX_TEMPFAIL = 0x4B;
+$EX_PROTOCOL = 0x4C;
+$EX_NOPERM = 0x4D;
--- /dev/null
+#!/usr/bin/perl
+
+open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed";
+
+while (<IOCTLS>) {
+ if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\('?\w+'?,\s*\w+,\s*([^)]+)/) {
+ $need{$2}++;
+ }
+}
+
+foreach $key ( sort keys %need ) {
+ print $key,"\n";
+}
--- /dev/null
+#!/usr/local/bin/perl
+
+($iam = $0) =~ s%.*/%%;
+$tmp = "$iam.$$";
+open (CODE,">$tmp.c") || die "$iam: cannot create $tmp.c: $!\n";
+
+$mask = q/printf ("$sizeof{'%s'} = %d;\n"/;
+
+# write C program
+select(CODE);
+
+print <<EO_C_PROGRAM;
+#include <sys/param.h>
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <net/if_arp.h>
+#include <net/if.h>
+#include <net/route.h>
+#include <sys/ioctl.h>
+
+main() {
+EO_C_PROGRAM
+
+while ( <> ) {
+ chop;
+ printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_;
+}
+
+print "\n}\n";
+
+close CODE;
+
+# compile C program
+
+select(STDOUT);
+
+system "cc $tmp.c -o $tmp";
+die "couldn't compile $tmp.c" if $?;
+system "./$tmp";
+die "couldn't run $tmp" if $?;
+
+unlink "$tmp.c", $tmp;
--- /dev/null
+#!/usr/bin/perl
+
+require 'sizeof.ph';
+
+$LIB = '/usr/local/lib/perl';
+
+foreach $include (@ARGV) {
+ printf STDERR "including %s\n", $include;
+ do $include;
+ warn "sourcing $include: $@\n" if ($@);
+ if (!open (INCLUDE,"$LIB/$include")) {
+ warn "can't open $LIB/$include: $!\n";
+ next;
+ }
+ while (<INCLUDE>) {
+ chop;
+ if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) {
+ $var = $1;
+ $val = eval "&$var;";
+ if ($@) {
+ warn "$@: $_";
+ print <<EOT;
+warn "\$$var isn't correctly set" if defined \$_main{'$var'};
+EOT
+ next;
+ }
+ ( $nval = sprintf ("%x",$val ) ) =~ tr/a-z/A-Z/;
+ printf "\$%s = 0x%s;\n", $var, $nval;
+ }
+ }
+}
--- /dev/null
+#!/usr/bin/perl
+
+require 'cbreak.pl';
+
+&cbreak;
+
+$| = 1;
+
+print "gimme a char: ";
+
+$c = getc;
+
+print "$c\n";
+
+printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
+
+&cooked;
--- /dev/null
+#!/usr/bin/perl
+
+require 'cbreak2.pl';
+
+&cbreak;
+
+$| = 1;
+
+print "gimme a char: ";
+
+$c = getc;
+
+print "$c\n";
+
+printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
+
+&cooked;
--- /dev/null
+/* $RCSfile: handy.h,v $$Revision: 4.0.1.3 $$Date: 91/11/05 22:54:26 $
+ *
+ * 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: handy.h,v $
+ * 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.
+ *
+ */
+
+#ifdef NULL
+#undef NULL
+#endif
+#ifndef I286
+# define NULL 0
+#else
+# define NULL 0L
+#endif
+#define Null(type) ((type)NULL)
+#define Nullch Null(char*)
+#define Nullfp Null(FILE*)
+
+#ifdef UTS
+#define bool int
+#else
+#define bool char
+#endif
+
+#ifdef TRUE
+#undef TRUE
+#endif
+#ifdef FALSE
+#undef FALSE
+#endif
+#define TRUE (1)
+#define FALSE (0)
+
+#define Ctl(ch) (ch & 037)
+
+#define strNE(s1,s2) (strcmp(s1,s2))
+#define strEQ(s1,s2) (!strcmp(s1,s2))
+#define strLT(s1,s2) (strcmp(s1,s2) < 0)
+#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
+#define strGT(s1,s2) (strcmp(s1,s2) > 0)
+#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
+#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
+#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
+
+#if defined(CTYPE256) || !defined(isascii)
+#define isALNUM(c) (isalpha(c) || isdigit(c) || c == '_')
+#define isALPHA(c) isalpha(c)
+#define isSPACE(c) isspace(c)
+#define isDIGIT(c) isdigit(c)
+#define isUPPER(c) isupper(c)
+#define isLOWER(c) islower(c)
+#else
+#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_'))
+#define isALPHA(c) (isascii(c) && isalpha(c))
+#define isSPACE(c) (isascii(c) && isspace(c))
+#define isDIGIT(c) (isascii(c) && isdigit(c))
+#define isUPPER(c) (isascii(c) && isupper(c))
+#define isLOWER(c) (isascii(c) && islower(c))
+#endif
+
+#define MEM_SIZE unsigned int
+
+/* Line numbers are unsigned, 16 bits. */
+typedef unsigned short line_t;
+#ifdef lint
+#define NOLINE ((line_t)0)
+#else
+#define NOLINE ((line_t) 65535)
+#endif
+
+#ifndef lint
+#ifndef LEAKTEST
+#ifndef safemalloc
+char *safemalloc();
+char *saferealloc();
+void safefree();
+#endif
+#ifndef MSDOS
+#define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
+#define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
+#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \
+ bzero((char*)(v), (n) * sizeof(t))
+#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
+#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
+#else
+#define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t))))
+#define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t))))
+#define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \
+ bzero((char*)(v), (n) * sizeof(t))
+#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
+#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
+#endif /* MSDOS */
+#define Safefree(d) safefree((char*)d)
+#define Str_new(x,len) str_new(len)
+#else /* LEAKTEST */
+char *safexmalloc();
+char *safexrealloc();
+void safexfree();
+#define New(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t))))
+#define Newc(x,v,n,t,c) (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t))))
+#define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \
+ bzero((char*)(v), (n) * sizeof(t))
+#define Renew(v,n,t) (v = (t*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
+#define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
+#define Safefree(d) safexfree((char*)d)
+#define Str_new(x,len) str_new(x,len)
+#define MAXXCOUNT 1200
+long xcount[MAXXCOUNT];
+long lastxcount[MAXXCOUNT];
+#endif /* LEAKTEST */
+#define Copy(s,d,n,t) (void)bcopy((char*)(s),(char*)(d), (n) * sizeof(t))
+#define Zero(d,n,t) (void)bzero((char*)(d), (n) * sizeof(t))
+#else /* lint */
+#define New(x,v,n,s) (v = Null(s *))
+#define Newc(x,v,n,s,c) (v = Null(s *))
+#define Newz(x,v,n,s) (v = Null(s *))
+#define Renew(v,n,s) (v = Null(s *))
+#define Copy(s,d,n,t)
+#define Zero(d,n,t)
+#define Safefree(d) d = d
+#endif /* lint */
--- /dev/null
+/* $RCSfile: hash.c,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:24:13 $
+ *
+ * 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: hash.c,v $
+ * 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.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+static char coeff[] = {
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
+
+static void hfreeentries();
+
+STR *
+hfetch(tb,key,klen,lval)
+register HASH *tb;
+char *key;
+unsigned int klen;
+int lval;
+{
+ register char *s;
+ register int i;
+ register int hash;
+ register HENT *entry;
+ register int maxi;
+ STR *str;
+#ifdef SOME_DBM
+ datum dkey,dcontent;
+#endif
+
+ if (!tb)
+ return &str_undef;
+ if (!tb->tbl_array) {
+ if (lval)
+ Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*);
+ else
+ return &str_undef;
+ }
+
+ /* The hash function we use on symbols has to be equal to the first
+ * character when taken modulo 128, so that str_reset() can be implemented
+ * efficiently. We throw in the second character and the last character
+ * (times 128) so that long chains of identifiers starting with the
+ * same letter don't have to be strEQ'ed within hfetch(), since it
+ * compares hash values before trying strEQ().
+ */
+ if (!tb->tbl_coeffsize)
+ hash = *key + 128 * key[1] + 128 * key[klen-1]; /* assuming klen > 0 */
+ else { /* use normal coefficients */
+ if (klen < tb->tbl_coeffsize)
+ maxi = klen;
+ else
+ maxi = tb->tbl_coeffsize;
+ for (s=key, i=0, hash = 0;
+ i < maxi; /*SUPPRESS 8*/
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+ }
+
+ entry = tb->tbl_array[hash & tb->tbl_max];
+ for (; entry; entry = entry->hent_next) {
+ if (entry->hent_hash != hash) /* strings can't be equal */
+ continue;
+ if (entry->hent_klen != klen)
+ continue;
+ if (bcmp(entry->hent_key,key,klen)) /* is this it? */
+ continue;
+ return entry->hent_val;
+ }
+#ifdef SOME_DBM
+ if (tb->tbl_dbm) {
+ dkey.dptr = key;
+ dkey.dsize = klen;
+#ifdef HAS_GDBM
+ dcontent = gdbm_fetch(tb->tbl_dbm,dkey);
+#else
+ dcontent = dbm_fetch(tb->tbl_dbm,dkey);
+#endif
+ if (dcontent.dptr) { /* found one */
+ str = Str_new(60,dcontent.dsize);
+ str_nset(str,dcontent.dptr,dcontent.dsize);
+ hstore(tb,key,klen,str,hash); /* cache it */
+ return str;
+ }
+ }
+#endif
+ if (lval) { /* gonna assign to this, so it better be there */
+ str = Str_new(61,0);
+ hstore(tb,key,klen,str,hash);
+ return str;
+ }
+ return &str_undef;
+}
+
+bool
+hstore(tb,key,klen,val,hash)
+register HASH *tb;
+char *key;
+unsigned int klen;
+STR *val;
+register int hash;
+{
+ register char *s;
+ register int i;
+ register HENT *entry;
+ register HENT **oentry;
+ register int maxi;
+
+ if (!tb)
+ return FALSE;
+
+ if (hash)
+ /*SUPPRESS 530*/
+ ;
+ else if (!tb->tbl_coeffsize)
+ hash = *key + 128 * key[1] + 128 * key[klen-1];
+ else { /* use normal coefficients */
+ if (klen < tb->tbl_coeffsize)
+ maxi = klen;
+ else
+ maxi = tb->tbl_coeffsize;
+ for (s=key, i=0, hash = 0;
+ i < maxi; /*SUPPRESS 8*/
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+ }
+
+ if (!tb->tbl_array)
+ Newz(505,tb->tbl_array, tb->tbl_max + 1, HENT*);
+
+ oentry = &(tb->tbl_array[hash & tb->tbl_max]);
+ i = 1;
+
+ for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
+ if (entry->hent_hash != hash) /* strings can't be equal */
+ continue;
+ if (entry->hent_klen != klen)
+ continue;
+ if (bcmp(entry->hent_key,key,klen)) /* is this it? */
+ continue;
+ Safefree(entry->hent_val);
+ entry->hent_val = val;
+ return TRUE;
+ }
+ New(501,entry, 1, HENT);
+
+ entry->hent_klen = klen;
+ entry->hent_key = nsavestr(key,klen);
+ entry->hent_val = val;
+ entry->hent_hash = hash;
+ entry->hent_next = *oentry;
+ *oentry = entry;
+
+ /* hdbmstore not necessary here because it's called from stabset() */
+
+ if (i) { /* initial entry? */
+ tb->tbl_fill++;
+#ifdef SOME_DBM
+ if (tb->tbl_dbm && tb->tbl_max >= DBM_CACHE_MAX)
+ return FALSE;
+#endif
+ if (tb->tbl_fill > tb->tbl_dosplit)
+ hsplit(tb);
+ }
+#ifdef SOME_DBM
+ else if (tb->tbl_dbm) { /* is this just a cache for dbm file? */
+ void hentdelayfree();
+
+ entry = tb->tbl_array[hash & tb->tbl_max];
+ oentry = &entry->hent_next;
+ entry = *oentry;
+ while (entry) { /* trim chain down to 1 entry */
+ *oentry = entry->hent_next;
+ hentdelayfree(entry); /* no doubt they'll want this next. */
+ entry = *oentry;
+ }
+ }
+#endif
+
+ return FALSE;
+}
+
+STR *
+hdelete(tb,key,klen)
+register HASH *tb;
+char *key;
+unsigned int klen;
+{
+ register char *s;
+ register int i;
+ register int hash;
+ register HENT *entry;
+ register HENT **oentry;
+ STR *str;
+ int maxi;
+#ifdef SOME_DBM
+ datum dkey;
+#endif
+
+ if (!tb || !tb->tbl_array)
+ return Nullstr;
+ if (!tb->tbl_coeffsize)
+ hash = *key + 128 * key[1] + 128 * key[klen-1];
+ else { /* use normal coefficients */
+ if (klen < tb->tbl_coeffsize)
+ maxi = klen;
+ else
+ maxi = tb->tbl_coeffsize;
+ for (s=key, i=0, hash = 0;
+ i < maxi; /*SUPPRESS 8*/
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+ }
+
+ oentry = &(tb->tbl_array[hash & tb->tbl_max]);
+ entry = *oentry;
+ i = 1;
+ for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) {
+ if (entry->hent_hash != hash) /* strings can't be equal */
+ continue;
+ if (entry->hent_klen != klen)
+ continue;
+ if (bcmp(entry->hent_key,key,klen)) /* is this it? */
+ continue;
+ *oentry = entry->hent_next;
+ str = str_mortal(entry->hent_val);
+ hentfree(entry);
+ if (i)
+ tb->tbl_fill--;
+#ifdef SOME_DBM
+ do_dbm_delete:
+ if (tb->tbl_dbm) {
+ dkey.dptr = key;
+ dkey.dsize = klen;
+#ifdef HAS_GDBM
+ gdbm_delete(tb->tbl_dbm,dkey);
+#else
+ dbm_delete(tb->tbl_dbm,dkey);
+#endif
+ }
+#endif
+ return str;
+ }
+#ifdef SOME_DBM
+ str = Nullstr;
+ goto do_dbm_delete;
+#else
+ return Nullstr;
+#endif
+}
+
+hsplit(tb)
+HASH *tb;
+{
+ int oldsize = tb->tbl_max + 1;
+ register int newsize = oldsize * 2;
+ register int i;
+ register HENT **a;
+ register HENT **b;
+ register HENT *entry;
+ register HENT **oentry;
+
+ a = tb->tbl_array;
+ Renew(a, newsize, HENT*);
+ Zero(&a[oldsize], oldsize, HENT*); /* zero 2nd half*/
+ tb->tbl_max = --newsize;
+ tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
+ tb->tbl_array = a;
+
+ for (i=0; i<oldsize; i++,a++) {
+ if (!*a) /* non-existent */
+ continue;
+ b = a+oldsize;
+ for (oentry = a, entry = *a; entry; entry = *oentry) {
+ if ((entry->hent_hash & newsize) != i) {
+ *oentry = entry->hent_next;
+ entry->hent_next = *b;
+ if (!*b)
+ tb->tbl_fill++;
+ *b = entry;
+ continue;
+ }
+ else
+ oentry = &entry->hent_next;
+ }
+ if (!*a) /* everything moved */
+ tb->tbl_fill--;
+ }
+}
+
+HASH *
+hnew(lookat)
+unsigned int lookat;
+{
+ register HASH *tb;
+
+ Newz(502,tb, 1, HASH);
+ if (lookat) {
+ tb->tbl_coeffsize = lookat;
+ tb->tbl_max = 7; /* it's a normal associative array */
+ tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
+ }
+ else {
+ tb->tbl_max = 127; /* it's a symbol table */
+ tb->tbl_dosplit = 128; /* so never split */
+ }
+ tb->tbl_fill = 0;
+#ifdef SOME_DBM
+ tb->tbl_dbm = 0;
+#endif
+ (void)hiterinit(tb); /* so each() will start off right */
+ return tb;
+}
+
+void
+hentfree(hent)
+register HENT *hent;
+{
+ if (!hent)
+ return;
+ str_free(hent->hent_val);
+ Safefree(hent->hent_key);
+ Safefree(hent);
+}
+
+void
+hentdelayfree(hent)
+register HENT *hent;
+{
+ if (!hent)
+ return;
+ str_2mortal(hent->hent_val); /* free between statements */
+ Safefree(hent->hent_key);
+ Safefree(hent);
+}
+
+void
+hclear(tb,dodbm)
+register HASH *tb;
+int dodbm;
+{
+ if (!tb)
+ return;
+ hfreeentries(tb,dodbm);
+ tb->tbl_fill = 0;
+#ifndef lint
+ if (tb->tbl_array)
+ (void)bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*));
+#endif
+}
+
+static void
+hfreeentries(tb,dodbm)
+register HASH *tb;
+int dodbm;
+{
+ register HENT *hent;
+ register HENT *ohent = Null(HENT*);
+#ifdef SOME_DBM
+ datum dkey;
+ datum nextdkey;
+#ifdef HAS_GDBM
+ GDBM_FILE old_dbm;
+#else
+#ifdef HAS_NDBM
+ DBM *old_dbm;
+#else
+ int old_dbm;
+#endif
+#endif
+#endif
+
+ if (!tb || !tb->tbl_array)
+ return;
+#ifdef SOME_DBM
+ if ((old_dbm = tb->tbl_dbm) && dodbm) {
+#ifdef HAS_GDBM
+ while (dkey = gdbm_firstkey(tb->tbl_dbm), dkey.dptr) {
+#else
+ while (dkey = dbm_firstkey(tb->tbl_dbm), dkey.dptr) {
+#endif
+ do {
+#ifdef HAS_GDBM
+ nextdkey = gdbm_nextkey(tb->tbl_dbm, dkey);
+#else
+#ifdef HAS_NDBM
+#ifdef _CX_UX
+ nextdkey = dbm_nextkey(tb->tbl_dbm, dkey);
+#else
+ nextdkey = dbm_nextkey(tb->tbl_dbm);
+#endif
+#else
+ nextdkey = nextkey(dkey);
+#endif
+#endif
+#ifdef HAS_GDBM
+ gdbm_delete(tb->tbl_dbm,dkey);
+#else
+ dbm_delete(tb->tbl_dbm,dkey);
+#endif
+ dkey = nextdkey;
+ } while (dkey.dptr); /* one way or another, this works */
+ }
+ }
+ tb->tbl_dbm = 0; /* now clear just cache */
+#endif
+ (void)hiterinit(tb);
+ /*SUPPRESS 560*/
+ while (hent = hiternext(tb)) { /* concise but not very efficient */
+ hentfree(ohent);
+ ohent = hent;
+ }
+ hentfree(ohent);
+#ifdef SOME_DBM
+ tb->tbl_dbm = old_dbm;
+#endif
+}
+
+void
+hfree(tb,dodbm)
+register HASH *tb;
+int dodbm;
+{
+ if (!tb)
+ return;
+ hfreeentries(tb,dodbm);
+ Safefree(tb->tbl_array);
+ Safefree(tb);
+}
+
+int
+hiterinit(tb)
+register HASH *tb;
+{
+ tb->tbl_riter = -1;
+ tb->tbl_eiter = Null(HENT*);
+ return tb->tbl_fill;
+}
+
+HENT *
+hiternext(tb)
+register HASH *tb;
+{
+ register HENT *entry;
+#ifdef SOME_DBM
+ datum key;
+#endif
+
+ entry = tb->tbl_eiter;
+#ifdef SOME_DBM
+ if (tb->tbl_dbm) {
+ if (entry) {
+#ifdef HAS_GDBM
+ key.dptr = entry->hent_key;
+ key.dsize = entry->hent_klen;
+ key = gdbm_nextkey(tb->tbl_dbm, key);
+#else
+#ifdef HAS_NDBM
+#ifdef _CX_UX
+ key.dptr = entry->hent_key;
+ key.dsize = entry->hent_klen;
+ key = dbm_nextkey(tb->tbl_dbm, key);
+#else
+ key = dbm_nextkey(tb->tbl_dbm);
+#endif /* _CX_UX */
+#else
+ key.dptr = entry->hent_key;
+ key.dsize = entry->hent_klen;
+ key = nextkey(key);
+#endif
+#endif
+ }
+ else {
+ Newz(504,entry, 1, HENT);
+ tb->tbl_eiter = entry;
+#ifdef HAS_GDBM
+ key = gdbm_firstkey(tb->tbl_dbm);
+#else
+ key = dbm_firstkey(tb->tbl_dbm);
+#endif
+ }
+ entry->hent_key = key.dptr;
+ entry->hent_klen = key.dsize;
+ if (!key.dptr) {
+ if (entry->hent_val)
+ str_free(entry->hent_val);
+ Safefree(entry);
+ tb->tbl_eiter = Null(HENT*);
+ return Null(HENT*);
+ }
+ return entry;
+ }
+#endif
+ if (!tb->tbl_array)
+ Newz(506,tb->tbl_array, tb->tbl_max + 1, HENT*);
+ do {
+ if (entry)
+ entry = entry->hent_next;
+ if (!entry) {
+ tb->tbl_riter++;
+ if (tb->tbl_riter > tb->tbl_max) {
+ tb->tbl_riter = -1;
+ break;
+ }
+ entry = tb->tbl_array[tb->tbl_riter];
+ }
+ } while (!entry);
+
+ tb->tbl_eiter = entry;
+ return entry;
+}
+
+char *
+hiterkey(entry,retlen)
+register HENT *entry;
+int *retlen;
+{
+ *retlen = entry->hent_klen;
+ return entry->hent_key;
+}
+
+STR *
+hiterval(tb,entry)
+register HASH *tb;
+register HENT *entry;
+{
+#ifdef SOME_DBM
+ datum key, content;
+
+ if (tb->tbl_dbm) {
+ key.dptr = entry->hent_key;
+ key.dsize = entry->hent_klen;
+#ifdef HAS_GDBM
+ content = gdbm_fetch(tb->tbl_dbm,key);
+#else
+ content = dbm_fetch(tb->tbl_dbm,key);
+#endif
+ if (!entry->hent_val)
+ entry->hent_val = Str_new(62,0);
+ str_nset(entry->hent_val,content.dptr,content.dsize);
+ }
+#endif
+ return entry->hent_val;
+}
+
+#ifdef SOME_DBM
+
+#ifndef O_CREAT
+# ifdef I_FCNTL
+# include <fcntl.h>
+# endif
+# ifdef I_SYS_FILE
+# include <sys/file.h>
+# endif
+#endif
+
+#ifndef O_RDONLY
+#define O_RDONLY 0
+#endif
+#ifndef O_RDWR
+#define O_RDWR 2
+#endif
+#ifndef O_CREAT
+#define O_CREAT 01000
+#endif
+
+#ifdef HAS_ODBM
+static int dbmrefcnt = 0;
+#endif
+
+bool
+hdbmopen(tb,fname,mode)
+register HASH *tb;
+char *fname;
+int mode;
+{
+ if (!tb)
+ return FALSE;
+#ifdef HAS_ODBM
+ if (tb->tbl_dbm) /* never really closed it */
+ return TRUE;
+#endif
+ if (tb->tbl_dbm) {
+ hdbmclose(tb);
+ tb->tbl_dbm = 0;
+ }
+ hclear(tb, FALSE); /* clear cache */
+#ifdef HAS_GDBM
+ if (mode >= 0)
+ tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRCREAT,mode, (void *) NULL);
+ if (!tb->tbl_dbm)
+ tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRITER, mode, (void *) NULL);
+ if (!tb->tbl_dbm)
+ tb->tbl_dbm = gdbm_open(fname, 0, GDBM_READER, mode, (void *) NULL);
+#else
+#ifdef HAS_NDBM
+ if (mode >= 0)
+ tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode);
+ if (!tb->tbl_dbm)
+ tb->tbl_dbm = dbm_open(fname, O_RDWR, mode);
+ if (!tb->tbl_dbm)
+ tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode);
+#else
+ if (dbmrefcnt++)
+ fatal("Old dbm can only open one database");
+ sprintf(buf,"%s.dir",fname);
+ if (stat(buf, &statbuf) < 0) {
+ if (mode < 0 || close(creat(buf,mode)) < 0)
+ return FALSE;
+ sprintf(buf,"%s.pag",fname);
+ if (close(creat(buf,mode)) < 0)
+ return FALSE;
+ }
+ tb->tbl_dbm = dbminit(fname) >= 0;
+#endif
+#endif
+ if (!tb->tbl_array && tb->tbl_dbm != 0)
+ Newz(507,tb->tbl_array, tb->tbl_max + 1, HENT*);
+ return tb->tbl_dbm != 0;
+}
+
+void
+hdbmclose(tb)
+register HASH *tb;
+{
+ if (tb && tb->tbl_dbm) {
+#ifdef HAS_GDBM
+ gdbm_close(tb->tbl_dbm);
+ tb->tbl_dbm = 0;
+#else
+#ifdef HAS_NDBM
+ dbm_close(tb->tbl_dbm);
+ tb->tbl_dbm = 0;
+#else
+ /* dbmrefcnt--; */ /* doesn't work, rats */
+#endif
+#endif
+ }
+ else if (dowarn)
+ warn("Close on unopened dbm file");
+}
+
+bool
+hdbmstore(tb,key,klen,str)
+register HASH *tb;
+char *key;
+unsigned int klen;
+register STR *str;
+{
+ datum dkey, dcontent;
+ int error;
+
+ if (!tb || !tb->tbl_dbm)
+ return FALSE;
+ dkey.dptr = key;
+ dkey.dsize = klen;
+ dcontent.dptr = str_get(str);
+ dcontent.dsize = str->str_cur;
+#ifdef HAS_GDBM
+ error = gdbm_store(tb->tbl_dbm, dkey, dcontent, GDBM_REPLACE);
+#else
+ error = dbm_store(tb->tbl_dbm, dkey, dcontent, DBM_REPLACE);
+#endif
+ if (error) {
+ if (errno == EPERM)
+ fatal("No write permission to dbm file");
+ warn("dbm store returned %d, errno %d, key \"%s\"",error,errno,key);
+#ifdef HAS_NDBM
+ dbm_clearerr(tb->tbl_dbm);
+#endif
+ }
+ return !error;
+}
+#endif /* SOME_DBM */
--- /dev/null
+/* $RCSfile: hash.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:24:31 $
+ *
+ * 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: hash.h,v $
+ * 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.
+ *
+ */
+
+#define FILLPCT 80 /* don't make greater than 99 */
+#define DBM_CACHE_MAX 63 /* cache 64 entries for dbm file */
+ /* (resident array acts as a write-thru cache)*/
+
+#define COEFFSIZE (16 * 8) /* size of coeff array */
+
+typedef struct hentry HENT;
+
+struct hentry {
+ HENT *hent_next;
+ char *hent_key;
+ STR *hent_val;
+ int hent_hash;
+ int hent_klen;
+};
+
+struct htbl {
+ HENT **tbl_array;
+ int tbl_max; /* subscript of last element of tbl_array */
+ int tbl_dosplit; /* how full to get before splitting */
+ int tbl_fill; /* how full tbl_array currently is */
+ int tbl_riter; /* current root of iterator */
+ HENT *tbl_eiter; /* current entry of iterator */
+ SPAT *tbl_spatroot; /* list of spats for this package */
+ char *tbl_name; /* name, if a symbol table */
+#ifdef SOME_DBM
+#ifdef HAS_GDBM
+ GDBM_FILE tbl_dbm;
+#else
+#ifdef HAS_NDBM
+ DBM *tbl_dbm;
+#else
+ int tbl_dbm;
+#endif
+#endif
+#endif
+ unsigned char tbl_coeffsize; /* is 0 for symbol tables */
+};
+
+STR *hfetch();
+bool hstore();
+STR *hdelete();
+HASH *hnew();
+void hclear();
+void hentfree();
+void hfree();
+int hiterinit();
+HENT *hiternext();
+char *hiterkey();
+STR *hiterval();
+bool hdbmopen();
+void hdbmclose();
+bool hdbmstore();
--- /dev/null
+d_voidsig='undef'
+d_tosignal='int';
+echo "If you're going to use shared libraries, don't include -lmalloc, and"
+echo "change cc to '/bin/ccc' when editing config.sh at the end."
--- /dev/null
+optimize='-g'
--- /dev/null
+eval_cflags='optimize=""'
+toke_cflags='optimize=""'
+teval_cflags='optimize=""'
+ttoke_cflags='optimize=""'
+ccflags="$ccflags -D_NO_PROTO"
+cppstdin='/lib/cpp -D_AIX -D_IBMR2'
+cppminus=''
--- /dev/null
+ccflags="$ccflags -a -DCRIPPLED_CC"
--- /dev/null
+: have heard of problems with -lc_s on Altos 486
+set `echo " $libswanted " | sed "s/ c_s / /"`
+libswanted="$*"
--- /dev/null
+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."
--- /dev/null
+optimize=''
+ccflags='-DDEBUGGING -A cpu,mathchip -W0,-opt,2'
+
+cat <<'EOF'
+Some tests may fail unless you use 'chacl -B'. Also, op/stat
+test 2 may fail occasionally because Apollo doesn't guarantee
+that mtime will be equal to ctime on a newly created unmodified
+file. Finally, the sleep test will sometimes fail. See the
+sleep(3) man page to learn why.
+
+And a note on ccflags:
+
+ Lastly, while -A cpu,mathchip generates optimal code for your DN3500
+ running sr10.3, be aware that you should be using -A cpu,mathlib_sr10
+ if your perl must also run on any machines running sr10.0, sr10.1, or
+ sr10.2. The -A cpu,mathchip option generates code that doesn't work on
+ pre-sr10.3 nodes. See the cc(1) man page for more details.
+ -- Steve Vinoski
+
+EOF
--- /dev/null
+optimize='-O'
+ccflags="$ccflags -B/usr/lib/big/ -DPARAM_NEEDS_TYPES"
--- /dev/null
+optimize='-g'
--- /dev/null
+d_castneg=undef
--- /dev/null
+ccflags="$ccflags -J -DBADSWITCH"
--- /dev/null
+i_varargs=undef
--- /dev/null
+ccflags="$ccflags -X18"
--- /dev/null
+optimize='+O1'
+ccflags="$ccflags -Wc,-Nw500"
--- /dev/null
+optimize='+O1'
+ccflags="$ccflags -Wc,-Nw500"
--- /dev/null
+libswanted=`echo $libswanted | sed -e 's/malloc //' -e 's/BSD //`
+optimize='+O1'
--- /dev/null
+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
--- /dev/null
+ldflags='-L/usr/ucblib'
--- /dev/null
+set `echo $libswanted | sed -e 's/ x / /' -e 's/ PW / /' -e s/ malloc / /`
+libswanted="inet malloc $*"
+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."
--- /dev/null
+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'
+case $PATH in
+*bsd*:/bin:*) cat <<END
+NOTE: Some people have reported having much better luck with Mips CC than
+with the BSD cc. Put /bin first in your PATH if you have difficulties.
+END
+;;
+esac
--- /dev/null
+ccflags="$ccflags -X18"
--- /dev/null
+ccflags="$ccflags -W2,-Sl,2000"
+d_mkdir=$undef
--- /dev/null
+: Just disable defaulting to -fpcc-struct-return, since gcc is native compiler.
+nativegcc='define'
+groupstype="int"
+usemymalloc="n"
--- /dev/null
+ccflags="$ccflags -X18"
--- /dev/null
+ccflags="$ccflags -D_BSD"
--- /dev/null
+yacc='/usr/bin/yacc -Sm25000'
+i_dirent=undef
--- /dev/null
+yacc='/usr/bin/yacc -Sm25000'
+i_dirent=undef
--- /dev/null
+yacc='/usr/bin/yacc -Sm25000'
+libswanted=`echo $libswanted | sed 's/ x / /'`
--- /dev/null
+yacc='/usr/bin/yacc -Sm25000'
+libswanted=`echo $libswanted | sed 's/ x / /'`
+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."
--- /dev/null
+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=''
+i_varargs=undef
+d_rename='undef'
--- /dev/null
+optimize='-O1'
+usemymalloc='y'
+mallocsrc='malloc.c'
+mallocobj='malloc.o'
+d_voidsig=define
+d_vfork=undef
--- /dev/null
+optimize="-O0"
+ccflags="$ccflags -nw"
--- /dev/null
+usemymalloc=n
+mallocsrc=''
+mallocobj=''
--- /dev/null
+usemymalloc=n
+mallocsrc=''
+mallocobj=''
--- /dev/null
+ccflags="$ccflags -DFPUTS_BOTCH"
--- /dev/null
+ccflags="$ccflags -DFPUTS_BOTCH"
--- /dev/null
+cc='/bin/cc'
+test -f $cc || cc='/usr/ccs/bin/cc'
+ldflags='-L/usr/ucblib'
+mansrc='/usr/share/man/man1'
+ccflags='-I/usr/include -I/usr/ucbinclude'
+libswanted=`echo $libswanted | sed 's/ ucb/ c ucb/'`
--- /dev/null
+d_mymalloc='undef'
--- /dev/null
+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
--- /dev/null
+ccflags="$ccflags -DLANGUAGE_C -Olimit 2900"
+tmp=`(uname -a) 2>/dev/null`
+case "$tmp" in
+*RISC*) cat <<EOF
+Note that there is a bug in some versions of NFS on the DECStation that
+may cause utime() to work incorrectly. If so, regression test io/fs
+may fail if run under NFS. Ignore the failure.
+EOF
+ case "$tmp" in
+ *4.2*) d_volatile=undef;;
+ esac
+;;
+esac
+case "$tmp" in
+*4.1*)
+ eval_cflags='optimize="-g"'
+ teval_cflags='optimize="-g"'
+ toke_cflags='optimize="-g"'
+ ttoke_cflags='optimize="-g"'
+ ;;
+esac
+
--- /dev/null
+ccflags="$ccflags -DCRIPPLED_CC"
+d_lstat=$define
--- /dev/null
+teval_cflags='case $cc in *gcc);; *) optimize="-O";; esac'
--- /dev/null
+#!./perl
+
+while (@ARGV) {
+ $nonono = 1 if $ARGV[0] eq '-n';
+ $versiononly = 1 if $ARGV[0] eq '-v';
+ shift;
+}
+
+umask 022;
+
+@scripts = ('cppstdin', 'h2ph', 'c2ph', 'pstruct', 'x2p/s2p', 'x2p/find2perl');
+@manpages = ('perl.man', 'h2ph.man', 'x2p/a2p.man', 'x2p/s2p.man');
+
+$version = sprintf("%5.3f", $]);
+$release = substr($version,0,3);
+$patchlevel = substr($version,3,2);
+
+# Read in the config file.
+
+open(CONFIG, "config.sh") || die "You haven't run Configure yet!\n";
+while (<CONFIG>) {
+ if (s/^(\w+=)/\$$1/) {
+ $accum =~ s/'undef'/undef/g;
+ eval $accum;
+ $accum = '';
+ }
+ $accum .= $_;
+}
+
+# Do some quick sanity checks.
+
+if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; }
+
+ $installbin || die "No installbin directory in config.sh\n";
+-d $installbin || die "$installbin is not a directory\n";
+-w $installbin || die "$installbin is not writable by you\n"
+ unless $installbin =~ m#^/afs/#;
+
+-x 'perl' || die "perl isn't executable!\n";
+-x 'taintperl' || die "taintperl isn't executable!\n";
+-x 'suidperl' || die "suidperl isn't executable!\n" if $d_dosuid;
+
+-x 't/TEST' || warn "WARNING: You've never run 'make test'!!!",
+ " (Installing anyway.)\n";
+
+# First we install the version-numbered executables.
+
+$ver = sprintf("%5.3f", $]);
+
+&unlink("$installbin/perl$ver");
+&cmd("cp perl $installbin/perl$ver");
+
+&unlink("$installbin/tperl$ver");
+&cmd("cp taintperl $installbin/tperl$ver");
+&chmod(0755, "$installbin/tperl$ver"); # force non-suid for security
+
+&unlink("$installbin/sperl$ver");
+if ($d_dosuid) {
+ &cmd("cp suidperl $installbin/sperl$ver");
+ &chmod(04711, "$installbin/sperl$ver");
+}
+
+exit 0 if $versiononly;
+
+# Make links to ordinary names if installbin directory isn't current directory.
+
+($bdev,$bino) = stat($installbin);
+($ddev,$dino) = stat('.');
+
+if ($bdev != $ddev || $bino != $dino) {
+ &unlink("$installbin/perl", "$installbin/taintperl", "$installbin/suidperl");
+ &link("$installbin/perl$ver", "$installbin/perl");
+ &link("$installbin/tperl$ver", "$installbin/taintperl");
+ &link("$installbin/sperl$ver", "$installbin/suidperl") if $d_dosuid;
+}
+
+($bdev,$bino) = stat($installbin);
+($ddev,$dino) = stat('x2p');
+
+if ($bdev != $ddev || $bino != $dino) {
+ &unlink("$installbin/a2p");
+ &cmd("cp x2p/a2p $installbin/a2p");
+}
+
+# Make some enemies in the name of standardization. :-)
+
+($udev,$uino) = stat("/usr/bin");
+
+if (-w _ && ($udev != $ddev || $uino != $dino) && !$nonono) {
+ &unlink("/usr/bin/perl");
+ eval 'symlink("$installbin/perl", "/usr/bin/perl")' ||
+ eval 'link("$installbin/perl", "/usr/bin/perl")' ||
+ &cmd("cp $installbin/perl /usr/bin");
+}
+
+# Install scripts.
+
+&makedir($installscr);
+
+for (@scripts) {
+ &cmd("cp $_ $installscr");
+ s#.*/##; &chmod(0755, "$installscr/$_");
+}
+
+# Install man pages.
+
+if ($mansrc ne '') {
+ &makedir($mansrc);
+
+ ($mdev,$mino) = stat($mansrc);
+ if ($mdev != $ddev || $mino != $dino) {
+ for (@manpages) {
+ ($new = $_) =~ s/man$/$manext/;
+ $new =~ s#.*/##;
+ print STDERR " Installing $mansrc/$new\n";
+ next if $nonono;
+ open(MI,$_);
+ open(MO,">$mansrc/$new");
+ print MO ".ds RP Release $release Patchlevel $patchlevel\n";
+ while (<MI>) {
+ print MO;
+ }
+ close MI;
+ close MO;
+ }
+ }
+}
+
+# Install library files.
+
+&makedir($installprivlib);
+if (chdir "lib") {
+
+ ($pdev,$pino) = stat($installprivlib);
+ ($ldev,$lino) = stat('.');
+
+ if ($pdev != $ldev || $pino != $lino) {
+ foreach $file (<*.pl>) {
+ system "cmp", "-s", $file, "$privlib/$file";
+ if ($?) {
+ &unlink("$installprivlib/$file");
+ &cmd("cp $file $installprivlib");
+ }
+ }
+ }
+ chdir ".." || die "Can't cd back to source directory: $!\n";
+}
+else {
+ warn "Can't cd to lib to install lib files: $!\n";
+}
+
+&chmod(0755, "usub/mus");
+
+print STDERR " Installation complete\n";
+
+exit 0;
+
+###############################################################################
+
+sub unlink {
+ local(@names) = @_;
+
+ foreach $name (@names) {
+ next unless -e $name;
+ print STDERR " unlink $name\n";
+ unlink($name) || warn "Couldn't unlink $name: $!\n" unless $nonono;
+ }
+}
+
+sub cmd {
+ local($cmd) = @_;
+ print STDERR " $cmd\n";
+ unless ($nonono) {
+ system $cmd;
+ warn "Command failed!!!\n" if $?;
+ }
+}
+
+sub link {
+ local($from,$to) = @_;
+
+ print STDERR " ln $from $to\n";
+ link($from,$to) || warn "Couldn't link $from to $to: $!\n" unless $nonono;
+}
+
+sub chmod {
+ local($mode,$name) = @_;
+
+ printf STDERR " chmod %o %s\n", $mode, $name;
+ chmod($mode,$name) || warn "Couldn't chmod $mode $name: $!\n"
+ unless $nonono;
+}
+
+sub makedir {
+ local($dir) = @_;
+ unless (-d $dir) {
+ local($shortdir) = $dir;
+
+ $shortdir =~ s#(.*)/.*#$1#;
+ &makedir($shortdir);
+
+ print STDERR " mkdir $dir\n";
+ mkdir($dir, 0777) || warn "Couldn't create $dir: $!\n" unless $nonono;
+ }
+}
--- /dev/null
+$TIOCGSIZE = 0x40087468;
+$TIOCSSIZE = 0x80087467;
+$IOCPARM_MASK = 0x1fff;
+$IOCPARM_MAX = 0x200;
+$IOC_VOID = 0x20000000;
+$IOC_OUT = 0x40000000;
+$IOC_IN = 0x80000000;
+$IOC_INOUT = 0xC0000000;
+$IOC_DIRMASK = 0xe0000000;
+$TIOCGETD = 0x40047400;
+$TIOCSETD = 0x80047401;
+$TIOCHPCL = 0x20007402;
+$TIOCMODG = 0x40047403;
+$TIOCMODS = 0x80047404;
+$TIOCM_LE = 0001;
+$TIOCM_DTR = 0002;
+$TIOCM_RTS = 0004;
+$TIOCM_ST = 0010;
+$TIOCM_SR = 0020;
+$TIOCM_CTS = 0040;
+$TIOCM_CAR = 0100;
+$TIOCM_CD = 0x40;
+$TIOCM_RNG = 0200;
+$TIOCM_RI = 0x80;
+$TIOCM_DSR = 0400;
+$TIOCGETP = 0x40067408;
+$TIOCSETP = 0x80067409;
+$TIOCSETN = 0x8006740A;
+$TIOCEXCL = 0x2000740D;
+$TIOCNXCL = 0x2000740E;
+$TIOCFLUSH = 0x80047410;
+$TIOCSETC = 0x80067411;
+$TIOCGETC = 0x40067412;
+$TANDEM = 0x00000001;
+$CBREAK = 0x00000002;
+$LCASE = 0x00000004;
+$ECHO = 0x00000008;
+$CRMOD = 0x00000010;
+$RAW = 0x00000020;
+$ODDP = 0x00000040;
+$EVENP = 0x00000080;
+$ANYP = 0x000000c0;
+$NLDELAY = 0x00000300;
+$NL0 = 0x00000000;
+$NL1 = 0x00000100;
+$NL2 = 0x00000200;
+$NL3 = 0x00000300;
+$TBDELAY = 0x00000c00;
+$TAB0 = 0x00000000;
+$TAB1 = 0x00000400;
+$TAB2 = 0x00000800;
+$XTABS = 0x00000c00;
+$CRDELAY = 0x00003000;
+$CR0 = 0x00000000;
+$CR1 = 0x00001000;
+$CR2 = 0x00002000;
+$CR3 = 0x00003000;
+$VTDELAY = 0x00004000;
+$FF0 = 0x00000000;
+$FF1 = 0x00004000;
+$BSDELAY = 0x00008000;
+$BS0 = 0x00000000;
+$BS1 = 0x00008000;
+$ALLDELAY = 0xFF00;
+$CRTBS = 0x00010000;
+$PRTERA = 0x00020000;
+$CRTERA = 0x00040000;
+$TILDE = 0x00080000;
+$MDMBUF = 0x00100000;
+$LITOUT = 0x00200000;
+$TOSTOP = 0x00400000;
+$FLUSHO = 0x00800000;
+$NOHANG = 0x01000000;
+$L001000 = 0x02000000;
+$CRTKIL = 0x04000000;
+$PASS8 = 0x08000000;
+$CTLECH = 0x10000000;
+$PENDIN = 0x20000000;
+$DECCTQ = 0x40000000;
+$NOFLSH = 0x80000000;
+$TIOCLBIS = 0x8004747F;
+$TIOCLBIC = 0x8004747E;
+$TIOCLSET = 0x8004747D;
+$TIOCLGET = 0x4004747C;
+$LCRTBS = 0x1;
+$LPRTERA = 0x2;
+$LCRTERA = 0x4;
+$LTILDE = 0x8;
+$LMDMBUF = 0x10;
+$LLITOUT = 0x20;
+$LTOSTOP = 0x40;
+$LFLUSHO = 0x80;
+$LNOHANG = 0x100;
+$LCRTKIL = 0x400;
+$LPASS8 = 0x800;
+$LCTLECH = 0x1000;
+$LPENDIN = 0x2000;
+$LDECCTQ = 0x4000;
+$LNOFLSH = 0xFFFF8000;
+$TIOCSBRK = 0x2000747B;
+$TIOCCBRK = 0x2000747A;
+$TIOCSDTR = 0x20007479;
+$TIOCCDTR = 0x20007478;
+$TIOCGPGRP = 0x40047477;
+$TIOCSPGRP = 0x80047476;
+$TIOCSLTC = 0x80067475;
+$TIOCGLTC = 0x40067474;
+$TIOCOUTQ = 0x40047473;
+$TIOCSTI = 0x80017472;
+$TIOCNOTTY = 0x20007471;
+$TIOCPKT = 0x80047470;
+$TIOCPKT_DATA = 0x00;
+$TIOCPKT_FLUSHREAD = 0x01;
+$TIOCPKT_FLUSHWRITE = 0x02;
+$TIOCPKT_STOP = 0x04;
+$TIOCPKT_START = 0x08;
+$TIOCPKT_NOSTOP = 0x10;
+$TIOCPKT_DOSTOP = 0x20;
+$TIOCSTOP = 0x2000746F;
+$TIOCSTART = 0x2000746E;
+$TIOCMSET = 0x8004746D;
+$TIOCMBIS = 0x8004746C;
+$TIOCMBIC = 0x8004746B;
+$TIOCMGET = 0x4004746A;
+$TIOCREMOTE = 0x80047469;
+$TIOCGWINSZ = 0x40087468;
+$TIOCSWINSZ = 0x80087467;
+$TIOCUCNTL = 0x80047466;
+$TIOCSSOFTC = 0x80047465;
+$TIOCGSOFTC = 0x40047464;
+$TIOCSCARR = 0x80047463;
+$TIOCWCARR = 0x20007462;
+$OTTYDISC = 0;
+$NETLDISC = 1;
+$NTTYDISC = 2;
+$TABLDISC = 3;
+$SLIPDISC = 4;
+$FIOCLEX = 0x20006601;
+$FIONCLEX = 0x20006602;
+$FIONREAD = 0x4004667F;
+$FIONBIO = 0x8004667E;
+$FIOASYNC = 0x8004667D;
+$FIOSETOWN = 0x8004667C;
+$FIOGETOWN = 0x4004667B;
+$SIOCSHIWAT = 0x80047300;
+$SIOCGHIWAT = 0x40047301;
+$SIOCSLOWAT = 0x80047302;
+$SIOCGLOWAT = 0x40047303;
+$SIOCATMARK = 0x40047307;
+$SIOCSPGRP = 0x80047308;
+$SIOCGPGRP = 0x40047309;
+$SIOCADDRT = 0x8030720A;
+$SIOCDELRT = 0x8030720B;
+$SIOCSIFADDR = 0x8020690C;
+$SIOCGIFADDR = 0xC020690D;
+$SIOCSIFDSTADDR = 0x8020690E;
+$SIOCGIFDSTADDR = 0xC020690F;
+$SIOCSIFFLAGS = 0x80206910;
+$SIOCGIFFLAGS = 0xC0206911;
+$SIOCGIFBRDADDR = 0xC0206912;
+$SIOCSIFBRDADDR = 0x80206913;
+$SIOCGIFCONF = 0xC0086914;
+$SIOCGIFNETMASK = 0xC0206915;
+$SIOCSIFNETMASK = 0x80206916;
+$SIOCGIFMETRIC = 0xC0206917;
+$SIOCSIFMETRIC = 0x80206918;
+$SIOCSARP = 0x8024691E;
+$SIOCGARP = 0xC024691F;
+$SIOCDARP = 0x80246920;
--- /dev/null
+;# Usage:
+;# %foo = ();
+;# &abbrev(*foo,LIST);
+;# ...
+;# $long = $foo{$short};
+
+package abbrev;
+
+sub main'abbrev {
+ local(*domain) = @_;
+ shift(@_);
+ @cmp = @_;
+ local($[) = 0;
+ foreach $name (@_) {
+ @extra = split(//,$name);
+ $abbrev = shift(@extra);
+ $len = 1;
+ foreach $cmp (@cmp) {
+ next if $cmp eq $name;
+ while (substr($cmp,0,$len) eq $abbrev) {
+ $abbrev .= shift(@extra);
+ ++$len;
+ }
+ }
+ $domain{$abbrev} = $name;
+ while ($#extra >= 0) {
+ $abbrev .= shift(@extra);
+ $domain{$abbrev} = $name;
+ }
+ }
+}
+
+1;
--- /dev/null
+# assert.pl
+# tchrist@convex.com (Tom Christiansen)
+#
+# Usage:
+#
+# &assert('@x > @y');
+# &assert('$var > 10', $var, $othervar, @various_info);
+#
+# That is, if the first expression evals false, we blow up. The
+# rest of the args, if any, are nice to know because they will
+# be printed out by &panic, which is just the stack-backtrace
+# routine shamelessly borrowed from the perl debugger.
+
+sub assert {
+ &panic("ASSERTION BOTCHED: $_[0]",$@) unless eval $_[0];
+}
+
+sub panic {
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ # stack traceback gratefully borrowed from perl debugger
+
+ 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");
+ }
+ for ($i=0; $i <= $#sub; $i++) {
+ print $sub[$i];
+ }
+ exit 1;
+}
+
+1;
--- /dev/null
+package bigfloat;
+require "bigint.pl";
+
+# Arbitrary length float math package
+#
+# number format
+# canonical strings have the form /[+-]\d+E[+-]\d+/
+# Input values can have inbedded whitespace
+# Error returns
+# 'NaN' An input parameter was "Not a Number" or
+# divide by zero or sqrt of negative number
+# Division is computed to
+# max($div_scale,length(dividend).length(divisor))
+# digits by default.
+# Also used for default sqrt scale
+
+$div_scale = 40;
+
+# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
+
+$rnd_mode = 'even';
+
+# bigfloat routines
+#
+# fadd(NSTR, NSTR) return NSTR addition
+# fsub(NSTR, NSTR) return NSTR subtraction
+# fmul(NSTR, NSTR) return NSTR multiplication
+# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places
+# fneg(NSTR) return NSTR negation
+# fabs(NSTR) return NSTR absolute value
+# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0
+# fround(NSTR, SCALE) return NSTR round to SCALE digits
+# ffround(NSTR, SCALE) return NSTR round at SCALEth place
+# fnorm(NSTR) return (NSTR) normalize
+# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places
+\f
+# Convert a number to canonical string form.
+# Takes something that looks like a number and converts it to
+# the form /^[+-]\d+E[+-]\d+$/.
+sub main'fnorm { #(string) return fnum_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$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 main'fneg { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[0]);
+ substr($_,0,1) =~ tr/+-/-+/ if ($_ ne '+0E+0'); # flip sign
+ $_;
+}
+
+# absolute value
+sub main'fabs { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[0]);
+ substr($_,0,1) = '+' unless $_ eq 'NaN'; # mash sign
+ $_;
+}
+
+# multiplication
+sub main'fmul { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ &norm(&'bmul($xm,$ym),$xe+$ye);
+ }
+}
+\f
+# addition
+sub main'fadd { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
+ &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
+ }
+}
+
+# subtraction
+sub main'fsub { #(fnum_str, fnum_str) return fnum_str
+ &'fadd($_[0],&'fneg($_[1]));
+}
+
+# division
+# args are dividend, divisor, scale (optional)
+# result has at most max(scale, length(dividend), length(divisor)) digits
+sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
+{
+ local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]);
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if (length($xm)-1 > $scale);
+ $scale = length($ym)-1 if (length($ym)-1 > $scale);
+ $scale = $scale + length($ym) - length($xm);
+ &norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym),
+ $xe-$ye-$scale);
+ }
+}
+\f
+# round int $q based on fraction $r/$base using $rnd_mode
+sub round { #(int_str, int_str, int_str) return int_str
+ local($q,$r,$base) = @_;
+ if ($q eq 'NaN' || $r eq 'NaN') {
+ 'NaN';
+ } elsif ($rnd_mode eq 'trunc') {
+ $q; # just truncate
+ } else {
+ local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
+ if ( $cmp < 0 ||
+ ($cmp == 0 &&
+ ( $rnd_mode eq 'zero' ||
+ ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) ||
+ ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) ||
+ ($rnd_mode eq 'even' && $q =~ /[24680]$/) ||
+ ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) {
+ $q; # round down
+ } else {
+ &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1'));
+ # round up
+ }
+ }
+}
+
+# round the mantissa of $x to $scale digits
+sub main'fround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[0]),$_[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,0,$scale+1),
+ "+0".substr($xm,$scale+1,1),"+10"),
+ $xe+length($xm)-$scale-1);
+ }
+ }
+}
+\f
+# round $x at the 10 to the $scale digit place
+sub main'ffround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[0]),$_[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,0,$trunc),
+ "+0".substr($xm,$trunc,1),"+10"), $scale);
+ }
+ }
+ }
+}
+
+# compare 2 values returns one of undef, <0, =0, >0
+# returns undef if either or both input value are not numbers
+sub main'fcmp #(fnum_str, fnum_str) return cond_code
+{
+ local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+ if ($x eq "NaN" || $y eq "NaN") {
+ undef;
+ } elsif ($x eq $y) {
+ 0;
+ } elsif (ord($x) != ord($y)) {
+ (ord($y) - ord($x)); # based on signs
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ if ($xe ne $ye) {
+ ($xe - $ye) * (substr($x,0,1).'1');
+ } else {
+ &bigint'cmp($xm,$ym); # based on value
+ }
+ }
+}
+\f
+# square root by Newtons method.
+sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
+ local($x, $scale) = (&'fnorm($_[0]), $_[1]);
+ if ($x eq 'NaN' || $x =~ /^-/) {
+ 'NaN';
+ } elsif ($x eq '+0E+0') {
+ '+0E+0';
+ } else {
+ local($xm, $xe) = split('E',$x);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if ($scale < length($xm)-1);
+ local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
+ while ($gs < 2*$scale) {
+ $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
+ $gs *= 2;
+ }
+ &'fround($guess, $scale);
+ }
+}
+
+1;
--- /dev/null
+package bigint;
+
+# arbitrary size integer math package
+#
+# by Mark Biggar
+#
+# Canonical Big integer value are strings of the form
+# /^[+-]\d+$/ with leading zeros suppressed
+# Input values to these routines may be strings of the form
+# /^\s*[+-]?[\d\s]+$/.
+# Examples:
+# '+0' canonical zero value
+# ' -123 123 123' canonical value '-123123123'
+# '1 23 456 7890' canonical value '+1234567890'
+# Output values always always in canonical form
+#
+# Actual math is done in an internal format consisting of an array
+# whose first element is the sign (/^[+-]$/) and whose remaining
+# elements are base 100000 digits with the least significant digit first.
+# The string 'NaN' is used to represent the result when input arguments
+# are not numbers, as well as the result of dividing by zero
+#
+# routines provided are:
+#
+# bneg(BINT) return BINT negation
+# babs(BINT) return BINT absolute value
+# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0)
+# badd(BINT,BINT) return BINT addition
+# bsub(BINT,BINT) return BINT subtraction
+# bmul(BINT,BINT) return BINT multiplication
+# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar
+# bmod(BINT,BINT) return BINT modulus
+# bgcd(BINT,BINT) return BINT greatest common divisor
+# bnorm(BINT) return BINT normalization
+#
+\f
+# normalize string form of number. Strip leading zeros. Strip any
+# white space and add a sign, if missing.
+# Strings that are not numbers result the value 'NaN'.
+sub main'bnorm { #(num_str) return num_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number
+ substr($_,0,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,0,1),length($d)-2);
+ substr($d,0,1) = '';
+ ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
+}
+
+# Convert a number from internal base 100000 format to string format.
+# This routine scribbles all over input array.
+sub external { #(int_num_array) return num_str
+ $es = shift;
+ grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad
+ &'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize
+}
+
+# Negate input value.
+sub main'bneg { #(num_str) return num_str
+ local($_) = &'bnorm(@_);
+ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
+ s/^H/N/;
+ $_;
+}
+
+# Returns the absolute value of the input.
+sub main'babs { #(num_str) return num_str
+ &abs(&'bnorm(@_));
+}
+
+sub abs { # post-normalized abs for internal use
+ local($_) = @_;
+ s/^-/+/;
+ $_;
+}
+\f
+# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+sub main'bcmp { #(num_str, num_str) return cond_code
+ local($x,$y) = (&'bnorm($_[0]),&'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 main'badd { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x); # convert to internal form
+ @y = &internal($y);
+ local($sx, $sy) = (shift @x, shift @y); # get signs
+ if ($sx eq $sy) {
+ &external($sx, &add(*x, *y)); # if same sign add
+ } else {
+ ($x, $y) = (&abs($x),&abs($y)); # make abs
+ if (&cmp($y,$x) > 0) {
+ &external($sy, &sub(*y, *x));
+ } else {
+ &external($sx, &sub(*x, *y));
+ }
+ }
+ }
+}
+
+sub main'bsub { #(num_str, num_str) return num_str
+ &'badd($_[0],&'bneg($_[1]));
+}
+
+# GCD -- Euclids algorithm Knuth Vol 2 pg 296
+sub main'bgcd { #(num_str, num_str) return num_str
+ local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ }
+ elsif ($y eq 'NaN') {
+ 'NaN';
+ }
+ else {
+ ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0';
+ $x;
+ }
+}
+\f
+# routine to add two base 100000 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 -= 100000 if $car = (($x += shift @y + $car) >= 100000);
+ }
+ for $y (@y) {
+ last unless $car;
+ $y -= 100000 if $car = (($y += $car) >= 100000);
+ }
+ (@x, @y, $car);
+}
+
+# subtract base 100000 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 += 100000 if $bar = (($sx -= shift @sy + $bar) < 0);
+ }
+ @sx;
+}
+
+# multiply two numbers -- stolen from Knuth Vol 2 pg 233
+sub main'bmul { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x);
+ @y = &internal($y);
+ local($signr) = (shift @x ne shift @y) ? '-' : '+';
+ @prod = ();
+ for $x (@x) {
+ ($car, $cty) = (0, 0);
+ for $y (@y) {
+ $prod = $x * $y + $prod[$cty] + $car;
+ $prod[$cty++] =
+ $prod - ($car = int($prod * (1/100000))) * 100000;
+ }
+ $prod[$cty] += $car if $car;
+ $x = shift @prod;
+ }
+ &external($signr, @x, @prod);
+ }
+}
+
+# modulus
+sub main'bmod { #(num_str, num_str) return num_str
+ (&'bdiv(@_))[1];
+}
+\f
+sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
+ local (*x, *y); ($x, $y) = (&'bnorm($_[0]), &'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[0];
+ $sr = (shift @x ne shift @y) ? '-' : '+';
+ $car = $bar = $prd = 0;
+ if (($dd = int(100000/($y[$#y]+1))) != 1) {
+ for $x (@x) {
+ $x = $x * $dd + $car;
+ $x -= ($car = int($x * (1/100000))) * 100000;
+ }
+ push(@x, $car); $car = 0;
+ for $y (@y) {
+ $y = $y * $dd + $car;
+ $y -= ($car = int($y * (1/100000))) * 100000;
+ }
+ }
+ else {
+ push(@x, 0);
+ }
+ @q = (); ($v2,$v1) = @y[$#y-1,$#y];
+ while ($#x > $#y) {
+ ($u2,$u1,$u0) = @x[($#x-2)..$#x];
+ $q = (($u0 == $v1) ? 99999 : int(($u0*100000+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*100000+$u1-$q*$v1)*100000+$u2);
+ if ($q) {
+ ($car, $bar) = (0,0);
+ for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
+ $prd = $q * $y[$y] + $car;
+ $prd -= ($car = int($prd * (1/100000))) * 100000;
+ $x[$x] += 100000 if ($bar = (($x[$x] -= $prd + $bar) < 0));
+ }
+ if ($x[$#x] < $car + $bar) {
+ $car = 0; --$q;
+ for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
+ $x[$x] -= 100000
+ if ($car = (($x[$x] += $y[$y] + $car) > 100000));
+ }
+ }
+ }
+ pop(@x); unshift(@q, $q);
+ }
+ if (wantarray) {
+ @d = ();
+ if ($dd != 1) {
+ $car = 0;
+ for $x (reverse @x) {
+ $prd = $car * 100000 + $x;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ unshift(@d, $tmp);
+ }
+ }
+ else {
+ @d = @x;
+ }
+ (&external($sr, @q), &external($srem, @d, 0));
+ } else {
+ &external($sr, @q);
+ }
+}
+1;
--- /dev/null
+package bigrat;
+require "bigint.pl";
+
+# Arbitrary size rational math package
+#
+# Input values to these routines consist of strings of the form
+# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|.
+# Examples:
+# "+0/1" canonical zero value
+# "3" canonical value "+3/1"
+# " -123/123 123" canonical value "-1/1001"
+# "123 456/7890" canonical value "+20576/1315"
+# Output values always include a sign and no leading zeros or
+# white space.
+# This package makes use of the bigint package.
+# The string 'NaN' is used to represent the result when input arguments
+# that are not numbers, as well as the result of dividing by zero and
+# the sqrt of a negative number.
+# Extreamly naive algorthims are used.
+#
+# Routines provided are:
+#
+# rneg(RAT) return RAT negation
+# rabs(RAT) return RAT absolute value
+# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0)
+# radd(RAT,RAT) return RAT addition
+# rsub(RAT,RAT) return RAT subtraction
+# rmul(RAT,RAT) return RAT multiplication
+# rdiv(RAT,RAT) return RAT division
+# rmod(RAT) return (RAT,RAT) integer and fractional parts
+# rnorm(RAT) return RAT normalization
+# rsqrt(RAT, cycles) return RAT square root
+\f
+# Convert a number to the canonical string form m|^[+-]\d+/\d+|.
+sub main'rnorm { #(string) return rat_num
+ local($_) = @_;
+ s/\s+//g;
+ if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) {
+ &norm($1, $3 ? $3 : '+1');
+ } else {
+ 'NaN';
+ }
+}
+
+# Normalize by reducing to lowest terms
+sub norm { #(bint, bint) return rat_num
+ local($num,$dom) = @_;
+ if ($num eq 'NaN') {
+ 'NaN';
+ } elsif ($dom eq 'NaN') {
+ 'NaN';
+ } elsif ($dom =~ /^[+-]?0+$/) {
+ 'NaN';
+ } else {
+ local($gcd) = &'bgcd($num,$dom);
+ if ($gcd ne '+1') {
+ $num = &'bdiv($num,$gcd);
+ $dom = &'bdiv($dom,$gcd);
+ } else {
+ $num = &'bnorm($num);
+ $dom = &'bnorm($dom);
+ }
+ substr($dom,0,1) = '';
+ "$num/$dom";
+ }
+}
+
+# negation
+sub main'rneg { #(rat_num) return rat_num
+ local($_) = &'rnorm($_[0]);
+ tr/-+/+-/ if ($_ ne '+0/1');
+ $_;
+}
+
+# absolute value
+sub main'rabs { #(rat_num) return $rat_num
+ local($_) = &'rnorm($_[0]);
+ substr($_,0,1) = '+' unless $_ eq 'NaN';
+ $_;
+}
+
+# multipication
+sub main'rmul { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
+}
+
+# division
+sub main'rdiv { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
+}
+\f
+# addition
+sub main'radd { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+}
+
+# subtraction
+sub main'rsub { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+}
+
+# comparison
+sub main'rcmp { #(rat_num, rat_num) return cond_code
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($yn,$yd) = split('/',&'rnorm($_[1]));
+ &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
+}
+
+# int and frac parts
+sub main'rmod { #(rat_num) return (rat_num,rat_num)
+ local($xn,$xd) = split('/',&'rnorm($_[0]));
+ local($i,$f) = &'bdiv($xn,$xd);
+ if (wantarray) {
+ ("$i/1", "$f/$xd");
+ } else {
+ "$i/1";
+ }
+}
+
+# square root by Newtons method.
+# cycles specifies the number of iterations default: 5
+sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
+ local($x, $scale) = (&'rnorm($_[0]), $_[1]);
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($x =~ /^-/) {
+ 'NaN';
+ } else {
+ local($gscale, $guess) = (0, '+1/1');
+ $scale = 5 if (!$scale);
+ while ($gscale++ < $scale) {
+ $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2");
+ }
+ "$guess"; # quotes necessary due to perl bug
+ }
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+# Open in their package.
+
+sub cacheout'open {
+ open($_[0], $_[1]);
+}
+
+# But only this sub name is visible to them.
+
+sub cacheout {
+ package cacheout;
+
+ ($file) = @_;
+ if (!$isopen{$file}) {
+ if (++$numopen > $maxopen) {
+ local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
+ splice(@lru, $maxopen / 3);
+ $numopen -= @lru;
+ for (@lru) { close $_; delete $isopen{$_}; }
+ }
+ &open($file, ($saw{$file}++ ? '>>' : '>') . $file)
+ || die "Can't create $file: $!\n";
+ }
+ $isopen{$file} = ++$seq;
+}
+
+package cacheout;
+
+$seq = 0;
+$numopen = 0;
+
+if (open(PARAM,'/usr/include/sys/param.h')) {
+ local($.);
+ while (<PARAM>) {
+ $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
+ }
+ close PARAM;
+}
+$maxopen = 16 unless $maxopen;
+
+1;
--- /dev/null
+## chat.pl: chat with a server
+## V2.01.alpha.7 91/06/16
+## Randal L. Schwartz
+
+package chat;
+
+$sockaddr = 'S n a4 x8';
+chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
+$thisproc = pack($sockaddr, 2, 0, $thisaddr);
+
+# *S = symbol for current I/O, gets assigned *chatsymbol....
+$next = "chatsymbol000000"; # next one
+$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
+
+
+## $handle = &chat'open_port("server.address",$port_number);
+## opens a named or numbered TCP server
+
+sub open_port { ## public
+ local($server, $port) = @_;
+
+ local($serveraddr,$serverproc);
+
+ *S = ++$next;
+ if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
+ $serveraddr = pack('C4', $1, $2, $3, $4);
+ } else {
+ local(@x) = gethostbyname($server);
+ return undef unless @x;
+ $serveraddr = $x[4];
+ }
+ $serverproc = pack($sockaddr, 2, $port, $serveraddr);
+ unless (socket(S, 2, 1, 6)) {
+ # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
+ # but who the heck would change these anyway? (:-)
+ ($!) = ($!, close(S)); # close S while saving $!
+ return undef;
+ }
+ unless (bind(S, $thisproc)) {
+ ($!) = ($!, close(S)); # close S while saving $!
+ return undef;
+ }
+ unless (connect(S, $serverproc)) {
+ ($!) = ($!, close(S)); # close S while saving $!
+ return undef;
+ }
+ select((select(S), $| = 1)[0]);
+ $next; # return symbol for switcharound
+}
+
+## ($host, $port, $handle) = &chat'open_listen([$port_number]);
+## opens a TCP port on the current machine, ready to be listened to
+## if $port_number is absent or zero, pick a default port number
+## process must be uid 0 to listen to a low port number
+
+sub open_listen { ## public
+
+ *S = ++$next;
+ local($thisport) = shift || 0;
+ local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
+ local(*NS) = "__" . time;
+ unless (socket(NS, 2, 1, 6)) {
+ # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
+ # but who the heck would change these anyway? (:-)
+ ($!) = ($!, close(NS));
+ return undef;
+ }
+ unless (bind(NS, $thisproc_local)) {
+ ($!) = ($!, close(NS));
+ return undef;
+ }
+ unless (listen(NS, 1)) {
+ ($!) = ($!, close(NS));
+ return undef;
+ }
+ select((select(NS), $| = 1)[0]);
+ local($family, $port, @myaddr) =
+ unpack("S n C C C C x8", getsockname(NS));
+ $S{"needs_accept"} = *NS; # so expect will open it
+ (@myaddr, $port, $next); # returning this
+}
+
+## $handle = &chat'open_proc("command","arg1","arg2",...);
+## opens a /bin/sh on a pseudo-tty
+
+sub open_proc { ## public
+ local(@cmd) = @_;
+
+ *S = ++$next;
+ local(*TTY) = "__TTY" . time;
+ local($pty,$tty) = &_getpty(S,TTY);
+ die "Cannot find a new pty" unless defined $pty;
+ local($pid) = fork;
+ die "Cannot fork: $!" unless defined $pid;
+ unless ($pid) {
+ close STDIN; close STDOUT; close STDERR;
+ setpgrp(0,$$);
+ if (open(DEVTTY, "/dev/tty")) {
+ ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
+ close DEVTTY;
+ }
+ open(STDIN,"<&TTY");
+ open(STDOUT,">&TTY");
+ open(STDERR,">&STDOUT");
+ die "Oops" unless fileno(STDERR) == 2; # sanity
+ close(S);
+ exec @cmd;
+ die "Cannot exec @cmd: $!";
+ }
+ close(TTY);
+ $next; # return symbol for switcharound
+}
+
+# $S is the read-ahead buffer
+
+## $return = &chat'expect([$handle,] $timeout_time,
+## $pat1, $body1, $pat2, $body2, ... )
+## $handle is from previous &chat'open_*().
+## $timeout_time is the time (either relative to the current time, or
+## absolute, ala time(2)) at which a timeout event occurs.
+## $pat1, $pat2, and so on are regexs which are matched against the input
+## stream. If a match is found, the entire matched string is consumed,
+## and the corresponding body eval string is evaled.
+##
+## Each pat is a regular-expression (probably enclosed in single-quotes
+## in the invocation). ^ and $ will work, respecting the current value of $*.
+## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
+## If pat is 'EOF', the body is executed if the process exits before
+## the other patterns are seen.
+##
+## Pats are scanned in the order given, so later pats can contain
+## general defaults that won't be examined unless the earlier pats
+## have failed.
+##
+## The result of eval'ing body is returned as the result of
+## the invocation. Recursive invocations are not thought
+## through, and may work only accidentally. :-)
+##
+## undef is returned if either a timeout or an eof occurs and no
+## corresponding body has been defined.
+## I/O errors of any sort are treated as eof.
+
+$nextsubname = "expectloop000000"; # used for subroutines
+
+sub expect { ## public
+ if ($_[0] =~ /$nextpat/) {
+ *S = shift;
+ }
+ local($endtime) = shift;
+
+ local($timeout,$eof) = (1,1);
+ local($caller) = caller;
+ local($rmask, $nfound, $timeleft, $thisbuf);
+ local($cases, $pattern, $action, $subname);
+ $endtime += time if $endtime < 600_000_000;
+
+ if (defined $S{"needs_accept"}) { # is it a listen socket?
+ local(*NS) = $S{"needs_accept"};
+ delete $S{"needs_accept"};
+ $S{"needs_close"} = *NS;
+ unless(accept(S,NS)) {
+ ($!) = ($!, close(S), close(NS));
+ return undef;
+ }
+ select((select(S), $| = 1)[0]);
+ }
+
+ # now see whether we need to create a new sub:
+
+ unless ($subname = $expect_subname{$caller,@_}) {
+ # nope. make a new one:
+ $expect_subname{$caller,@_} = $subname = $nextsubname++;
+
+ $cases .= <<"EDQ"; # header is funny to make everything elsif's
+sub $subname {
+ LOOP: {
+ if (0) { ; }
+EDQ
+ while (@_) {
+ ($pattern,$action) = splice(@_,0,2);
+ if ($pattern =~ /^eof$/i) {
+ $cases .= <<"EDQ";
+ elsif (\$eof) {
+ package $caller;
+ $action;
+ }
+EDQ
+ $eof = 0;
+ } elsif ($pattern =~ /^timeout$/i) {
+ $cases .= <<"EDQ";
+ elsif (\$timeout) {
+ package $caller;
+ $action;
+ }
+EDQ
+ $timeout = 0;
+ } else {
+ $pattern =~ s#/#\\/#g;
+ $cases .= <<"EDQ";
+ elsif (\$S =~ /$pattern/) {
+ \$S = \$';
+ package $caller;
+ $action;
+ }
+EDQ
+ }
+ }
+ $cases .= <<"EDQ" if $eof;
+ elsif (\$eof) {
+ undef;
+ }
+EDQ
+ $cases .= <<"EDQ" if $timeout;
+ elsif (\$timeout) {
+ undef;
+ }
+EDQ
+ $cases .= <<'ESQ';
+ else {
+ $rmask = "";
+ vec($rmask,fileno(S),1) = 1;
+ ($nfound, $rmask) =
+ select($rmask, undef, undef, $endtime - time);
+ if ($nfound) {
+ $nread = sysread(S, $thisbuf, 1024);
+ if ($nread > 0) {
+ $S .= $thisbuf;
+ } else {
+ $eof++, redo LOOP; # any error is also eof
+ }
+ } else {
+ $timeout++, redo LOOP; # timeout
+ }
+ redo LOOP;
+ }
+ }
+}
+ESQ
+ eval $cases; die "$cases:\n$@" if $@;
+ }
+ $eof = $timeout = 0;
+ do $subname();
+}
+
+## &chat'print([$handle,] @data)
+## $handle is from previous &chat'open().
+## like print $handle @data
+
+sub print { ## public
+ if ($_[0] =~ /$nextpat/) {
+ *S = shift;
+ }
+ print S @_;
+}
+
+## &chat'close([$handle,])
+## $handle is from previous &chat'open().
+## like close $handle
+
+sub close { ## public
+ if ($_[0] =~ /$nextpat/) {
+ *S = shift;
+ }
+ close(S);
+ if (defined $S{"needs_close"}) { # is it a listen socket?
+ local(*NS) = $S{"needs_close"};
+ delete $S{"needs_close"};
+ close(NS);
+ }
+}
+
+## @ready_handles = &chat'select($timeout, @handles)
+## select()'s the handles with a timeout value of $timeout seconds.
+## Returns an array of handles that are ready for I/O.
+## Both user handles and chat handles are supported (but beware of
+## stdio's buffering for user handles).
+
+sub select { ## public
+ local($timeout) = shift;
+ local(@handles) = @_;
+ local(%handlename) = ();
+ local(%ready) = ();
+ local($caller) = caller;
+ local($rmask) = "";
+ for (@handles) {
+ if (/$nextpat/o) { # one of ours... see if ready
+ local(*SYM) = $_;
+ if (length($SYM)) {
+ $timeout = 0; # we have a winner
+ $ready{$_}++;
+ }
+ $handlename{fileno($_)} = $_;
+ } else {
+ $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
+ }
+ }
+ for (sort keys %handlename) {
+ vec($rmask, $_, 1) = 1;
+ }
+ select($rmask, undef, undef, $timeout);
+ for (sort keys %handlename) {
+ $ready{$handlename{$_}}++ if vec($rmask,$_,1);
+ }
+ sort keys %ready;
+}
+
+# ($pty,$tty) = $chat'_getpty(PTY,TTY):
+# internal procedure to get the next available pty.
+# opens pty on handle PTY, and matching tty on handle TTY.
+# returns undef if can't find a pty.
+
+sub _getpty { ## private
+ local($_PTY,$_TTY) = @_;
+ $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
+ $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
+ local($pty,$tty);
+ for $bank (112..127) {
+ next unless -e sprintf("/dev/pty%c0", $bank);
+ for $unit (48..57) {
+ $pty = sprintf("/dev/pty%c%c", $bank, $unit);
+ open($_PTY,"+>$pty") || next;
+ select((select($_PTY), $| = 1)[0]);
+ ($tty = $pty) =~ s/pty/tty/;
+ open($_TTY,"+>$tty") || next;
+ select((select($_TTY), $| = 1)[0]);
+ system "stty nl>$tty";
+ return ($pty,$tty);
+ }
+ }
+ undef;
+}
+
+1;
--- /dev/null
+;#
+;# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91
+;#
+;# Author: Wayne Thompson
+;#
+;# Description:
+;# This routine provides word completion.
+;# (TAB) attempts word completion.
+;# (^D) prints completion list.
+;# (These may be changed by setting $Complete'complete, etc.)
+;#
+;# Diagnostics:
+;# Bell when word completion fails.
+;#
+;# Dependencies:
+;# The tty driver is put into raw mode.
+;#
+;# Bugs:
+;#
+;# Usage:
+;# $input = &Complete('prompt_string', *completion_list);
+;# or
+;# $input = &Complete('prompt_string', @completion_list);
+;#
+
+CONFIG: {
+ package Complete;
+
+ $complete = "\004";
+ $kill = "\025";
+ $erase1 = "\177";
+ $erase2 = "\010";
+}
+
+sub Complete {
+ package Complete;
+
+ local($[) = 0;
+ if ($_[1] =~ /^StB\0/) {
+ ($prompt, *_) = @_;
+ }
+ else {
+ $prompt = shift(@_);
+ }
+ @cmp_lst = sort(@_);
+
+ system('stty raw -echo');
+ LOOP: {
+ print($prompt, $return);
+ while (($_ = getc(STDIN)) ne "\r") {
+ CASE: {
+ # (TAB) attempt completion
+ $_ eq "\t" && do {
+ @match = grep(/^$return/, @cmp_lst);
+ $l = length($test = shift(@match));
+ unless ($#match < 0) {
+ foreach $cmp (@match) {
+ until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
+ $l--;
+ }
+ }
+ print("\a");
+ }
+ print($test = substr($test, $r, $l - $r));
+ $r = length($return .= $test);
+ last CASE;
+ };
+
+ # (^D) completion list
+ $_ eq $complete && do {
+ print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
+ redo LOOP;
+ };
+
+ # (^U) kill
+ $_ eq $kill && do {
+ if ($r) {
+ undef($r, $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;
--- /dev/null
+;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function.
+;#
+;# Waldemar Kebsch, Federal Republic of Germany, November 1988
+;# kebsch.pad@nixpbe.UUCP
+;# Modified March 1990, Feb 1991 to properly handle timezones
+;# $Id: ctime.pl,v 1.8 91/02/04 18:28:12 hakanson Exp $
+;# Marion Hakanson (hakanson@cse.ogi.edu)
+;# Oregon Graduate Institute of Science and Technology
+;#
+;# usage:
+;#
+;# #include <ctime.pl> # see the -P and -I option in perl.man
+;# $Date = &ctime(time);
+
+CONFIG: {
+ package ctime;
+
+ @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
+ @MoY = ('Jan','Feb','Mar','Apr','May','Jun',
+ 'Jul','Aug','Sep','Oct','Nov','Dec');
+}
+
+sub ctime {
+ package ctime;
+
+ local($time) = @_;
+ local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
+
+ # Determine what time zone is in effect.
+ # Use GMT if TZ is defined as null, local time if TZ undefined.
+ # There's no portable way to find the system default timezone.
+
+ $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '';
+ ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
+ ($TZ eq 'GMT') ? gmtime($time) : localtime($time);
+
+ # Hack to deal with 'PST8PDT' format of TZ
+ # Note that this can't deal with all the esoteric forms, but it
+ # does recognize the most common: [:]STDoff[DST[off][,rule]]
+
+ if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){
+ $TZ = $isdst ? $4 : $1;
+ }
+ $TZ .= ' ' unless $TZ eq '';
+
+ $year += ($year < 70) ? 2000 : 1900;
+ sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n",
+ $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year);
+}
+1;
--- /dev/null
+# exceptions.pl
+# tchrist@convex.com
+#
+# Here's a little code I use for exception handling. It's really just
+# glorfied eval/die. The way to use use it is when you might otherwise
+# exit, use &throw to raise an exception. The first enclosing &catch
+# handler looks at the exception and decides whether it can catch this kind
+# (catch takes a list of regexps to catch), and if so, it returns the one it
+# caught. If it *can't* catch it, then it will reraise the exception
+# for someone else to possibly see, or to die otherwise.
+#
+# I use oddly named variables in order to make darn sure I don't conflict
+# with my caller. I also hide in my own package, and eval the code in his.
+#
+# The EXCEPTION: prefix is so you can tell whether it's a user-raised
+# exception or a perl-raised one (eval error).
+#
+# --tom
+#
+# examples:
+# if (&catch('/$user_input/', 'regexp', 'syntax error') {
+# warn "oops try again";
+# redo;
+# }
+#
+# if ($error = &catch('&subroutine()')) { # catches anything
+#
+# &throw('bad input') if /^$/;
+
+sub catch {
+ package exception;
+ local($__code__, @__exceptions__) = @_;
+ local($__package__) = caller;
+ local($__exception__);
+
+ eval "package $__package__; $__code__";
+ if ($__exception__ = &'thrown) {
+ for (@__exceptions__) {
+ return $__exception__ if /$__exception__/;
+ }
+ &'throw($__exception__);
+ }
+}
+
+sub throw {
+ local($exception) = @_;
+ die "EXCEPTION: $exception\n";
+}
+
+sub thrown {
+ $@ =~ /^(EXCEPTION: )+(.+)/ && $2;
+}
+
+1;
--- /dev/null
+# By John Bazik
+#
+# Usage: $cwd = &fastcwd;
+#
+# This is a faster version of getcwd. It's also more dangerous because
+# you might chdir out of a directory that you can't chdir back into.
+
+sub fastcwd {
+ local($odev, $oino, $cdev, $cino, $tdev, $tino);
+ local(@path, $path);
+ local(*DIR);
+
+ ($cdev, $cino) = stat('.');
+ for (;;) {
+ ($odev, $oino) = ($cdev, $cino);
+ chdir('..');
+ ($cdev, $cino) = stat('.');
+ last if $odev == $cdev && $oino == $cino;
+ opendir(DIR, '.');
+ for (;;) {
+ $_ = readdir(DIR);
+ next if $_ eq '.';
+ next if $_ eq '..';
+
+ last unless $_;
+ ($tdev, $tino) = lstat($_);
+ last unless $tdev != $odev || $tino != $oino;
+ }
+ closedir(DIR);
+ unshift(@path, $_);
+ }
+ chdir($path = '/' . join('/', @path));
+ $path;
+}
+1;
--- /dev/null
+# Usage:
+# require "find.pl";
+#
+# &find('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+
+sub find {
+ chop($cwd = `pwd`);
+ foreach $topdir (@_) {
+ (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+ || (warn("Can't stat $topdir: $!\n"), next);
+ if (-d _) {
+ if (chdir($topdir)) {
+ ($dir,$_) = ($topdir,'.');
+ $name = $topdir;
+ &wanted;
+ $topdir =~ s,/$,, ;
+ &finddir($topdir,$topnlink);
+ }
+ else {
+ warn "Can't cd to $topdir: $!\n";
+ }
+ }
+ else {
+ unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ ($dir,$_) = ('.', $topdir);
+ }
+ chdir $dir && &wanted;
+ }
+ chdir $cwd;
+ }
+}
+
+sub finddir {
+ local($dir,$nlink) = @_;
+ local($dev,$ino,$mode,$subcount);
+ local($name);
+
+ # Get the list of files in the current directory.
+
+ opendir(DIR,'.') || warn "Can't open $dir: $!\n";
+ local(@filenames) = readdir(DIR);
+ closedir(DIR);
+
+ if ($nlink == 2) { # This dir has no subdirectories.
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $name = "$dir/$_";
+ $nlink = 0;
+ &wanted;
+ }
+ }
+ else { # This dir has subdirectories.
+ $subcount = $nlink - 2;
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $nlink = $prune = 0;
+ $name = "$dir/$_";
+ &wanted;
+ 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 $_) {
+ &finddir($name,$nlink);
+ chdir '..';
+ }
+ --$subcount;
+ }
+ }
+ }
+ }
+}
+1;
--- /dev/null
+# Usage:
+# require "finddepth.pl";
+#
+# &finddepth('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+
+sub finddepth {
+ chop($cwd = `pwd`);
+ foreach $topdir (@_) {
+ (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+ || (warn("Can't stat $topdir: $!\n"), next);
+ if (-d _) {
+ if (chdir($topdir)) {
+ $topdir =~ s,/$,, ;
+ &finddepthdir($topdir,$topnlink);
+ ($dir,$_) = ($topdir,'.');
+ $name = $topdir;
+ &wanted;
+ }
+ else {
+ warn "Can't cd to $topdir: $!\n";
+ }
+ }
+ else {
+ unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ ($dir,$_) = ('.', $topdir);
+ }
+ chdir $dir && &wanted;
+ }
+ chdir $cwd;
+ }
+}
+
+sub finddepthdir {
+ local($dir,$nlink) = @_;
+ local($dev,$ino,$mode,$subcount);
+ local($name);
+
+ # Get the list of files in the current directory.
+
+ opendir(DIR,'.') || warn "Can't open $dir: $!\n";
+ local(@filenames) = readdir(DIR);
+ closedir(DIR);
+
+ if ($nlink == 2) { # This dir has no subdirectories.
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $name = "$dir/$_";
+ $nlink = 0;
+ &wanted;
+ }
+ }
+ else { # This dir has subdirectories.
+ $subcount = $nlink - 2;
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $nlink = $prune = 0;
+ $name = "$dir/$_";
+ if ($subcount > 0) { # Seen all the subdirs?
+
+ # Get link count and check for directoriness.
+
+ ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+
+ if (-d _) {
+
+ # It really is a directory, so do it recursively.
+
+ if (!$prune && chdir $_) {
+ &finddepthdir($name,$nlink);
+ chdir '..';
+ }
+ --$subcount;
+ }
+ }
+ &wanted;
+ }
+ }
+}
+1;
--- /dev/null
+;# Usage: &flush(FILEHANDLE)
+;# flushes the named filehandle
+
+;# Usage: &printflush(FILEHANDLE, "prompt: ")
+;# prints arguments and flushes filehandle
+
+sub flush {
+ local($old) = select(shift);
+ $| = 1;
+ print "";
+ $| = 0;
+ select($old);
+}
+
+sub printflush {
+ local($old) = select(shift);
+ $| = 1;
+ print @_;
+ $| = 0;
+ select($old);
+}
+
+1;
--- /dev/null
+# By Brandon S. Allbery
+#
+# Usage: $cwd = &getcwd;
+
+sub getcwd
+{
+ local($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat('.'))
+ {
+ warn "stat(.): $!";
+ return '';
+ }
+ $cwd = '';
+ do
+ {
+ $dotdots .= '/' if $dotdots;
+ $dotdots .= '..';
+ @pst = @cst;
+ unless (opendir(getcwd'PARENT, $dotdots)) #'))
+ {
+ warn "opendir($dotdots): $!";
+ return '';
+ }
+ unless (@cst = stat($dotdots))
+ {
+ warn "stat($dotdots): $!";
+ closedir(getcwd'PARENT); #');
+ return '';
+ }
+ if ($pst[$[] == $cst[$[] && $pst[$[ + 1] == $cst[$[ + 1])
+ {
+ $dir = '';
+ }
+ else
+ {
+ do
+ {
+ unless ($dir = readdir(getcwd'PARENT)) #'))
+ {
+ warn "readdir($dotdots): $!";
+ closedir(getcwd'PARENT); #');
+ return '';
+ }
+ unless (@tst = stat("$dotdots/$dir"))
+ {
+ warn "stat($dotdots/$dir): $!";
+ closedir(getcwd'PARENT); #');
+ return '';
+ }
+ }
+ while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] ||
+ $tst[$[ + 1] != $pst[$[ + 1]);
+ }
+ $cwd = "$dir/$cwd";
+ closedir(getcwd'PARENT); #');
+ } while ($dir);
+ chop($cwd);
+ $cwd;
+}
+
+1;
--- /dev/null
+;# $RCSfile: getopt.pl,v $$Revision: 4.0.1.1 $$Date: 91/11/05 17:53:01 $
+
+;# Process single-character switches with switch clustering. Pass one argument
+;# which is a string containing all switches that take an argument. For each
+;# switch found, sets $opt_x (where x is the switch name) to the value of the
+;# argument, or 1 if no argument. Switches which take an argument don't care
+;# whether there is a space between the switch and the argument.
+
+;# Usage:
+;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
+
+sub Getopt {
+ local($argumentative) = @_;
+ local($_,$first,$rest);
+ local($[) = 0;
+
+ while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ if (index($argumentative,$first) >= $[) {
+ if ($rest ne '') {
+ shift(@ARGV);
+ }
+ else {
+ shift(@ARGV);
+ $rest = shift(@ARGV);
+ }
+ eval "\$opt_$first = \$rest;";
+ }
+ else {
+ eval "\$opt_$first = 1;";
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+}
+
+1;
--- /dev/null
+;# getopts.pl - a better getopt.pl
+
+;# Usage:
+;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
+;# # side effect.
+
+sub Getopts {
+ local($argumentative) = @_;
+ local(@args,$_,$first,$rest);
+ local($errs) = 0;
+ local($[) = 0;
+
+ @args = split( / */, $argumentative );
+ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ $pos = index($argumentative,$first);
+ if($pos >= $[) {
+ if($args[$pos+1] eq ':') {
+ shift(@ARGV);
+ if($rest eq '') {
+ $rest = shift(@ARGV);
+ }
+ eval "\$opt_$first = \$rest;";
+ }
+ else {
+ eval "\$opt_$first = 1";
+ if($rest eq '') {
+ shift(@ARGV);
+ }
+ else {
+ $ARGV[0] = "-$rest";
+ }
+ }
+ }
+ else {
+ print STDERR "Unknown option: $first\n";
+ ++$errs;
+ if($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ $errs == 0;
+}
+
+1;
--- /dev/null
+;# $Header: importenv.pl,v 4.0 91/03/20 01:25:28 lwall Locked $
+
+;# This file, when interpreted, pulls the environment into normal variables.
+;# Usage:
+;# require 'importenv.pl';
+;# or
+;# #include <importenv.pl>
+
+local($tmp,$key) = '';
+
+foreach $key (keys(ENV)) {
+ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
+}
+eval $tmp;
+
+1;
--- /dev/null
+;# 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 =~ y/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;
+ y/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;
--- /dev/null
+# newgetopt.pl -- new options parsing
+
+# SCCS Status : @(#)@ newgetopt.pl 1.8
+# Author : Johan Vromans
+# Created On : Tue Sep 11 15:00:12 1990
+# Last Modified By: Johan Vromans
+# Last Modified On: Thu Sep 26 20:10:41 1991
+# Update Count : 35
+# Status : Okay
+
+# This package implements a new getopt function. This function adheres
+# to the new syntax (long option names, no bundling).
+#
+# Arguments to the function are:
+#
+# - a list of possible options. These should designate valid perl
+# identifiers, optionally followed by an argument specifier ("="
+# for mandatory arguments or ":" for optional arguments) and an
+# argument type specifier: "n" or "i" for integer numbers, "f" for
+# real (fix) numbers or "s" for strings.
+#
+# - 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.
+# Likewise, a double occurrence (e.g. "--") signals end of
+# the options list.
+# The default value for the starter is "-".
+#
+# Upon return, the option variables, prefixed with "opt_", are defined
+# and set to the respective option arguments, if any.
+# Options that do not take an argument are set to 1. Note that an
+# option with an optional argument will be defined, but set to '' if
+# no actual argument has been supplied.
+# A return status of 0 (false) indicates that the function detected
+# one or more errors.
+#
+# Special care is taken to give a correct treatment to optional arguments.
+#
+# E.g. 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 = '--'
+#
+
+# HISTORY
+# 20-Sep-1990 Johan Vromans
+# Set options w/o argument to 1.
+# Correct the dreadful semicolon/require bug.
+
+
+package newgetopt;
+
+$debug = 0; # for debugging
+
+sub main'NGetOpt {
+ local (@optionlist) = @_;
+ local ($[) = 0;
+ local ($genprefix) = "-";
+ local ($error) = 0;
+ local ($opt, $optx, $arg, $type, $mand, @hits);
+
+ # See if the first element of the optionlist contains option
+ # starter characters.
+ $genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
+
+ # Turn into regexp.
+ $genprefix =~ s/(\W)/\\\1/g;
+ $genprefix = "[" . $genprefix . "]";
+
+ # Verify correctness of optionlist.
+ @hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
+ if ( $#hits >= 0 ) {
+ foreach $opt ( @hits ) {
+ print STDERR ("Error in option spec: \"", $opt, "\"\n");
+ $error++;
+ }
+ return 0;
+ }
+
+ # Process argument list
+
+ while ( $#main'ARGV >= 0 ) { #'){
+
+ # >>> See also the continue block <<<
+
+ # Get next argument
+ $opt = shift (@main'ARGV); #');
+ print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+ $arg = undef;
+
+ # Check for exhausted list.
+ if ( $opt =~ /^$genprefix/o ) {
+ # Double occurrence is terminator
+ return ($error == 0) if $opt eq "$+$+";
+ $opt = $'; # option name (w/o prefix)
+ }
+ else {
+ # Apparently not an option - push back and exit.
+ unshift (@main'ARGV, $opt); #');
+ return ($error == 0);
+ }
+
+ # Grep in option list. Hide regexp chars from option.
+ ($optx = $opt) =~ s/(\W)/\\\1/g;
+ @hits = grep (/^$optx([=:].+)?$/, @optionlist);
+ if ( $#hits != 0 ) {
+ print STDERR ("Unknown option: ", $opt, "\n");
+ $error++;
+ next;
+ }
+
+ # Determine argument status.
+ undef $type;
+ $type = $+ if $hits[0] =~ /[=:].+$/;
+ print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
+
+ # If it is an option w/o argument, we're almost finished with it.
+ if ( ! defined $type ) {
+ $arg = 1; # supply explicit value
+ next;
+ }
+
+ # Get mandatory status and type info.
+ ($mand, $type) = $type =~ /^(.)(.)$/;
+
+ # Check if the argument list is exhausted.
+ if ( $#main'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 = shift (@main'ARGV); #');
+
+ # Check if it is a valid argument. A mandatory string takes
+ # anything.
+ if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
+
+ # Check for option list terminator.
+ if ( $arg eq "$+$+" ) {
+ # Complain if an argument is required.
+ if ($mand eq "=") {
+ print STDERR ("Option ", $opt, " requires an argument\n");
+ $error++;
+ }
+ # Push back so the outer loop will terminate.
+ unshift (@main'ARGV, $arg); #');
+ $arg = ""; # don't assign it
+ next;
+ }
+
+ # Maybe the optional argument is the next option?
+ if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
+ # Yep. Push back.
+ unshift (@main'ARGV, $arg); #');
+ $arg = ""; # don't assign it
+ next;
+ }
+ }
+
+ if ( $type eq "n" || $type eq "i" ) { # numeric/integer
+ if ( $arg !~ /^-?[0-9]+$/ ) {
+ print STDERR ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (numeric required)\n");
+ $error++;
+ }
+ next;
+ }
+
+ if ( $type eq "f" ) { # fixed real number, int is also ok
+ if ( $arg !~ /^-?[0-9.]+$/ ) {
+ print STDERR ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number required)\n");
+ $error++;
+ }
+ next;
+ }
+
+ if ( $type eq "s" ) { # string
+ next;
+ }
+
+ }
+ continue {
+ print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
+ eval ("\$main'opt_$opt = \$arg");
+ }
+
+ return ($error == 0);
+}
+1;
--- /dev/null
+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.pl,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:55:58 $';
+#
+# 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
+# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
+#
+# $Log: perldb.pl,v $
+# 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.
+#
+#
+
+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);
+$| = 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;
+ ($package, $filename, $line) = caller;
+ $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
+ "package $package;"; # this won't let them modify, alas
+ local($^P) = 0; # don't debug our own evals
+ local(*dbline) = "_<$filename";
+ $max = $#dbline;
+ if (($stop,$action) = split(/\0/,$dbline{$line})) {
+ if ($stop eq '1') {
+ $signal |= 1;
+ }
+ else {
+ $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
+ $dbline{$line} =~ s/;9($|\0)/$1/;
+ }
+ }
+ 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;
+ if ($single || $signal) {
+ $evalarg = $pre, &eval if $pre;
+ print OUT $#stack . " levels deep in subroutine calls!\n"
+ if $single & 4;
+ $start = $line;
+ CMD:
+ while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) {
+ {
+ $single = 0;
+ $signal = 0;
+ $cmd eq '' && exit 0;
+ chop($cmd);
+ $cmd =~ s/\\$// && do {
+ print OUT " cont: ";
+ $cmd .= &gets;
+ redo CMD;
+ };
+ $cmd =~ /^q$/ && exit 0;
+ $cmd =~ /^$/ && ($cmd = $laststep);
+ push(@hist,$cmd) if length($cmd) > 1;
+ ($i) = split(/\s+/,$cmd);
+ eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
+ $cmd =~ /^h$/ && do {
+ print OUT "
+T Stack trace.
+s Single step.
+n Next, steps over subroutine calls.
+r Return from current subroutine.
+c [line] Continue; optionally inserts a one-time-only breakpoint
+ at the specified line.
+<CR> Repeat last n or s.
+l min+incr List incr+1 lines starting at min.
+l min-max List lines.
+l line List line;
+l List next window.
+- List previous window.
+w line List window around line.
+l subname List subroutine.
+f filename Switch to filename.
+/pattern/ Search forwards for pattern; final / is optional.
+?pattern? Search backwards for pattern.
+L List breakpoints and actions.
+S List subroutine names.
+t Toggle trace mode.
+b [line] [condition]
+ Set breakpoint; line defaults to the current execution line;
+ condition breaks if it evaluates to true, defaults to \'1\'.
+b subname [condition]
+ Set breakpoint at first line of subroutine.
+d [line] Delete breakpoint.
+D Delete all breakpoints.
+a [line] command
+ Set an action to be done before the line is executed.
+ Sequence is: check for breakpoint, print line if necessary,
+ do action, prompt user if breakpoint or step, evaluate line.
+A Delete all actions.
+V [pkg [vars]] List some (default all) variables in package (default current).
+X [vars] Same as \"V currentpackage [vars]\".
+< command Define command before prompt.
+> command Define command after prompt.
+! number Redo command (default previous command).
+! -number Redo number\'th to last command.
+H -number Display last number commands (default all).
+q or ^D Quit.
+p expr Same as \"print DB'OUT expr\" in current package.
+= [alias value] Define a command alias, or list current aliases.
+command Execute as a perl statement in current package.
+
+";
+ next CMD; };
+ $cmd =~ /^t$/ && do {
+ $trace = !$trace;
+ print OUT "Trace = ".($trace?"on":"off")."\n";
+ next CMD; };
+ $cmd =~ /^S$/ && do {
+ foreach $subname (sort(keys %sub)) {
+ print OUT $subname,"\n";
+ }
+ next CMD; };
+ $cmd =~ s/^X\b/V $package/;
+ $cmd =~ /^V$/ && do {
+ $cmd = 'V $package'; };
+ $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
+ $packname = $1;
+ @vars = split(' ',$2);
+ do 'dumpvar.pl' unless defined &main'dumpvar;
+ if (defined &main'dumpvar) {
+ &main'dumpvar($packname,@vars);
+ }
+ else {
+ print DB'OUT "dumpvar.pl not available.\n";
+ }
+ next CMD; };
+ $cmd =~ /^f\b\s*(.*)/ && do {
+ $file = $1;
+ if (!$file) {
+ print OUT "The old f command is now the r command.\n";
+ print OUT "The new f command switches filenames.\n";
+ next CMD;
+ }
+ if (!defined $_main{'_<' . $file}) {
+ if (($try) = grep(m#^_<.*$file#, keys %_main)) {
+ $file = substr($try,2);
+ print "\n$file:\n";
+ }
+ }
+ if (!defined $_main{'_<' . $file}) {
+ print OUT "There's no code here anything matching $file.\n";
+ next CMD;
+ }
+ elsif ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } };
+ $cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do {
+ $subname = $1;
+ $subname = "main'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($file,$subrange) = split(/:/,$sub{$subname});
+ if ($file ne $filename) {
+ *dbline = "_<$file";
+ $max = $#dbline;
+ $filename = $file;
+ }
+ if ($subrange) {
+ if (eval($subrange) < -$window) {
+ $subrange =~ s/-.*/+/;
+ }
+ $cmd = "l $subrange";
+ } else {
+ print OUT "Subroutine $1 not found.\n";
+ next CMD;
+ } };
+ $cmd =~ /^w\b\s*(\d*)$/ && do {
+ $incr = $window - 1;
+ $start = $1 if $1;
+ $start -= $preview;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^-$/ && do {
+ $incr = $window - 1;
+ $cmd = 'l ' . ($start-$window*2) . '+'; };
+ $cmd =~ /^l$/ && do {
+ $incr = $window - 1;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
+ $start = $1 if $1;
+ $incr = $2;
+ $incr = $window - 1 unless $incr;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
+ $end = (!$2) ? $max : ($4 ? $4 : $2);
+ $end = $max if $end > $max;
+ $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;
+ next CMD; };
+ $cmd =~ /^D$/ && do {
+ print OUT "Deleting all breakpoints...\n";
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ($dbline{$i} =~ s/^\0?$//) {
+ delete $dbline{$i};
+ }
+ }
+ }
+ next CMD; };
+ $cmd =~ /^L$/ && do {
+ for ($i = 1; $i <= $max; $i++) {
+ if (defined $dbline{$i}) {
+ print OUT "$i:\t", $dbline[$i];
+ ($stop,$action) = split(/\0/, $dbline{$i});
+ print OUT " break if (", $stop, ")\n"
+ if $stop;
+ print OUT " action: ", $action, "\n"
+ if $action;
+ last if $signal;
+ }
+ }
+ next CMD; };
+ $cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
+ $subname = $1;
+ $cond = $2 || '1';
+ $subname = "$package'" . $subname unless $subname =~ /'/;
+ $subname = "main" . $subname if substr($subname,0,1) eq "'";
+ ($filename,$i) = split(/[:-]/, $sub{$subname});
+ if ($i) {
+ *dbline = "_<$filename";
+ ++$i while $dbline[$i] == 0 && $i < $#dbline;
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ } else {
+ print OUT "Subroutine $subname not found.\n";
+ }
+ next CMD; };
+ $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
+ $i = ($1?$1:$line);
+ $cond = $2 || '1';
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i not breakable.\n";
+ } else {
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ next CMD; };
+ $cmd =~ /^d\b\s*(\d+)?/ && do {
+ $i = ($1?$1:$line);
+ $dbline{$i} =~ s/^[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ next CMD; };
+ $cmd =~ /^A$/ && do {
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ }
+ next CMD; };
+ $cmd =~ /^<\s*(.*)/ && do {
+ $pre = do action($1);
+ next CMD; };
+ $cmd =~ /^>\s*(.*)/ && do {
+ $post = do action($1);
+ next CMD; };
+ $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
+ $i = $1;
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i may not have an action.\n";
+ } else {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ $dbline{$i} .= "\0" . do action($3);
+ }
+ next CMD; };
+ $cmd =~ /^n$/ && do {
+ $single = 2;
+ $laststep = $cmd;
+ last CMD; };
+ $cmd =~ /^s$/ && do {
+ $single = 1;
+ $laststep = $cmd;
+ last CMD; };
+ $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
+ $i = $1;
+ if ($i) {
+ if ($dbline[$i] == 0) {
+ print OUT "Line $i not breakable.\n";
+ next CMD;
+ }
+ $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
+ }
+ for ($i=0; $i <= $#stack; ) {
+ $stack[$i++] &= ~1;
+ }
+ last CMD; };
+ $cmd =~ /^r$/ && do {
+ $stack[$#stack] |= 2;
+ last CMD; };
+ $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) {
+ 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 OUT $sub[$i];
+ }
+ next CMD; };
+ $cmd =~ /^\/(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])/$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ eval '
+ for (;;) {
+ ++$start;
+ $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;
+ }
+ } ';
+ print OUT "/$pat/: not found\n" if ($start == $end);
+ next CMD; };
+ $cmd =~ /^\?(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])\?$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\n$inpat\n";
+ if ($@ ne "") {
+ print OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ eval '
+ for (;;) {
+ --$start;
+ $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;
+ }
+ } ';
+ print OUT "?$pat?: not found\n" if ($start == $end);
+ next CMD; };
+ $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
+ pop(@hist) if length($cmd) > 1;
+ $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
+ $cmd = $hist[$i] . "\n";
+ print OUT $cmd;
+ redo CMD; };
+ $cmd =~ /^!(.+)$/ && do {
+ $pat = "^$1";
+ pop(@hist) if length($cmd) > 1;
+ for ($i = $#hist; $i; --$i) {
+ last if $hist[$i] =~ $pat;
+ }
+ if (!$i) {
+ print OUT "No such command!\n\n";
+ next CMD;
+ }
+ $cmd = $hist[$i] . "\n";
+ print OUT $cmd;
+ redo CMD; };
+ $cmd =~ /^H\b\s*(-(\d+))?/ && do {
+ $end = $2?($#hist-$2):0;
+ $hist = 0 if $hist < 0;
+ for ($i=$#hist; $i>$end; $i--) {
+ print OUT "$i: ",$hist[$i],"\n"
+ unless $hist[$i] =~ /^.?$/;
+ };
+ next CMD; };
+ $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
+ $cmd =~ /^=/ && do {
+ if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
+ $alias{$k}="s~$k~$v~";
+ print OUT "$k = $v\n";
+ } elsif ($cmd =~ /^=\s*$/) {
+ foreach $k (sort keys(%alias)) {
+ if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
+ print OUT "$k = $v\n";
+ } else {
+ print OUT "$k\t$alias{$k}\n";
+ };
+ };
+ };
+ next CMD; };
+ }
+ $evalarg = $cmd; &eval;
+ print OUT "\n";
+ }
+ if ($post) {
+ $evalarg = $post; &eval;
+ }
+ }
+ ($@, $!, $[, $,, $/, $\) = @saved;
+}
+
+sub save {
+ @saved = ($@, $!, $[, $,, $/, $\);
+ $[ = 0; $, = ""; $/ = "\n"; $\ = "";
+}
+
+# The following takes its argument via $evalarg to preserve current @_
+
+sub eval {
+ eval "$usercontext $evalarg; &DB'save";
+ print OUT $@;
+}
+
+sub action {
+ local($action) = @_;
+ while ($action =~ s/\\$//) {
+ print OUT "+ ";
+ $action .= &gets;
+ }
+ $action;
+}
+
+sub gets {
+ local($.);
+ <IN>;
+}
+
+sub catch {
+ $signal = 1;
+}
+
+sub sub {
+ push(@stack, $single);
+ $single &= 1;
+ $single |= 4 if $#stack == $deep;
+ if (wantarray) {
+ @i = &$sub;
+ $single |= pop(@stack);
+ @i;
+ }
+ else {
+ $i = &$sub;
+ $single |= pop(@stack);
+ $i;
+ }
+}
+
+$single = 1; # so it stops on first executable statement
+@hist = ('?');
+$SIG{'INT'} = "DB'catch";
+$deep = 100; # warning if stack gets this deep
+$window = 10;
+$preview = 3;
+
+@stack = (0);
+@ARGS = @ARGV;
+for (@args) {
+ s/'/\\'/g;
+ s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+}
+
+if (-f '.perldb') {
+ do './.perldb';
+}
+elsif (-f "$ENV{'LOGDIR'}/.perldb") {
+ do "$ENV{'LOGDIR'}/.perldb";
+}
+elsif (-f "$ENV{'HOME'}/.perldb") {
+ do "$ENV{'HOME'}/.perldb";
+}
+
+1;
--- /dev/null
+;# pwd.pl - keeps track of current working directory in PWD environment var
+;#
+;# $Header: pwd.pl,v 4.0 91/03/20 01:26:03 lwall Locked $
+;#
+;# $Log: pwd.pl,v $
+;# 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";
+;# &initpwd;
+;# ...
+;# &chdir($newdir);
+
+package pwd;
+
+sub main'initpwd {
+ if ($ENV{'PWD'}) {
+ local($dd,$di) = stat('.');
+ local($pd,$pi) = stat($ENV{'PWD'});
+ return if $di == $pi && $dd == $pd;
+ }
+ chop($ENV{'PWD'} = `pwd`);
+}
+
+sub main'chdir {
+ local($newdir) = shift;
+ if (chdir $newdir) {
+ if ($newdir =~ m#^/#) {
+ $ENV{'PWD'} = $newdir;
+ }
+ else {
+ local(@curdir) = split(m#/#,$ENV{'PWD'});
+ @curdir = '' unless @curdir;
+ foreach $component (split(m#/#, $newdir)) {
+ next if $component eq '.';
+ pop(@curdir),next if $component eq '..';
+ push(@curdir,$component);
+ }
+ $ENV{'PWD'} = join('/',@curdir) || '/';
+ }
+ }
+ else {
+ 0;
+ }
+}
+
+1;
--- /dev/null
+#; shellwords.pl
+#;
+#; Usage:
+#; require 'shellwords.pl';
+#; @words = &shellwords($line);
+#; or
+#; @words = &shellwords(@lines);
+#; or
+#; @words = &shellwords; # defaults to $_ (and clobbers it)
+
+sub shellwords {
+ package shellwords;
+ local($_) = join('', @_) if @_;
+ local(@words,$snippet,$field);
+
+ s/^\s+//;
+ while ($_ ne '') {
+ $field = '';
+ for (;;) {
+ if (s/^"(([^"\\]+|\\[\\"])*)"//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (s/^'(([^'\\]+|\\[\\'])*)'//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (s/^\\(.)//) {
+ $snippet = $1;
+ }
+ elsif (s/^([^\s\\'"]+)//) {
+ $snippet = $1;
+ }
+ else {
+ s/^\s+//;
+ last;
+ }
+ $field .= $snippet;
+ }
+ push(@words, $field);
+ }
+ @words;
+}
+1;
--- /dev/null
+;# $Header: stat.pl,v 4.0 91/03/20 01:26:16 lwall Locked $
+
+;# Usage:
+;# require 'stat.pl';
+;# @ary = stat(foo);
+;# $st_dev = @ary[$ST_DEV];
+;#
+$ST_DEV = 0 + $[;
+$ST_INO = 1 + $[;
+$ST_MODE = 2 + $[;
+$ST_NLINK = 3 + $[;
+$ST_UID = 4 + $[;
+$ST_GID = 5 + $[;
+$ST_RDEV = 6 + $[;
+$ST_SIZE = 7 + $[;
+$ST_ATIME = 8 + $[;
+$ST_MTIME = 9 + $[;
+$ST_CTIME = 10 + $[;
+$ST_BLKSIZE = 11 + $[;
+$ST_BLOCKS = 12 + $[;
+
+;# Usage:
+;# require 'stat.pl';
+;# do Stat('foo'); # sets st_* as a side effect
+;#
+sub Stat {
+ ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size,
+ $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_));
+}
+
+1;
--- /dev/null
+#
+# syslog.pl
+#
+# $Log: syslog.pl,v $
+# 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)
+#
+# call syslog() with a string priority and a list of printf() args
+# like syslog(3)
+#
+# usage: require 'syslog.pl';
+#
+# then (put these all in a script to test function)
+#
+#
+# do openlog($program,'cons,pid','user');
+# do syslog('info','this is another test');
+# do syslog('mail|warning','this is a better test: %d', time);
+# do closelog();
+#
+# do syslog('debug','this is the last test');
+# do openlog("$program $$",'ndelay','user');
+# do syslog('notice','fooprogram: this is really done');
+#
+# $! = 55;
+# do syslog('info','problem was %m'); # %m == $! in syslog(3)
+
+package syslog;
+
+$host = 'localhost' unless $host; # set $syslog'host to change
+
+require 'syslog.ph';
+
+$maskpri = &LOG_UPTO(&LOG_DEBUG);
+
+sub main'openlog {
+ ($ident, $logopt, $facility) = @_; # package vars
+ $lo_pid = $logopt =~ /\bpid\b/;
+ $lo_ndelay = $logopt =~ /\bndelay\b/;
+ $lo_cons = $logopt =~ /\bcons\b/;
+ $lo_nowait = $logopt =~ /\bnowait\b/;
+ &connect if $lo_ndelay;
+}
+
+sub main'closelog {
+ $facility = $ident = '';
+ &disconnect;
+}
+
+sub main'setlogmask {
+ local($oldmask) = $maskpri;
+ $maskpri = shift;
+ $oldmask;
+}
+
+sub main'syslog {
+ local($priority) = shift;
+ local($mask) = shift;
+ local($message, $whoami);
+ local(@words, $num, $numpri, $numfac, $sum);
+ local($facility) = $facility; # may need to change temporarily.
+
+ die "syslog: expected both priority and mask" unless $mask && $priority;
+
+ @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
+ undef $numpri;
+ undef $numfac;
+ foreach (@words) {
+ $num = &xlate($_); # Translate word to number.
+ if (/^kern$/ || $num < 0) {
+ die "syslog: invalid level/facility: $_\n";
+ }
+ elsif ($num <= &LOG_PRIMASK) {
+ die "syslog: too many levels given: $_\n" if defined($numpri);
+ $numpri = $num;
+ return 0 unless &LOG_MASK($numpri) & $maskpri;
+ }
+ else {
+ die "syslog: too many facilities given: $_\n" if defined($numfac);
+ $facility = $_;
+ $numfac = $num;
+ }
+ }
+
+ die "syslog: level must be given\n" unless defined($numpri);
+
+ if (!defined($numfac)) { # Facility not specified in this call.
+ $facility = 'user' unless $facility;
+ $numfac = &xlate($facility);
+ }
+
+ &connect unless $connected;
+
+ $whoami = $ident;
+
+ if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
+ $whoami = $1;
+ $mask = $2;
+ }
+
+ unless ($whoami) {
+ ($whoami = getlogin) ||
+ ($whoami = getpwuid($<)) ||
+ ($whoami = 'syslog');
+ }
+
+ $whoami .= "[$$]" if $lo_pid;
+
+ $mask =~ s/%m/$!/g;
+ $mask .= "\n" unless $mask =~ /\n$/;
+ $message = sprintf ($mask, @_);
+
+ $sum = $numpri + $numfac;
+ unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
+ if ($lo_cons) {
+ if ($pid = fork) {
+ unless ($lo_nowait) {
+ do {$died = wait;} until $died == $pid || $died < 0;
+ }
+ }
+ else {
+ open(CONS,">/dev/console");
+ print CONS "<$facility.$priority>$whoami: $message\r";
+ exit if defined $pid; # if fork failed, we're parent
+ close CONS;
+ }
+ }
+ }
+}
+
+sub xlate {
+ local($name) = @_;
+ $name =~ 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);
+ die "Can't lookup $myname\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ else {
+ @bytes = (0,0,0,0);
+ }
+ $this = pack($pat, $af_inet, 0, @bytes);
+
+ if ($host =~ /^\d+\./) {
+ @bytes = split(/\./,$host);
+ }
+ else {
+ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host);
+ die "Can't lookup $host\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ $that = pack($pat,$af_inet,$syslog,@bytes);
+
+ socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
+ bind(SYSLOG,$this) || die "bind: $!\n";
+ connect(SYSLOG,$that) || die "connect: $!\n";
+
+ local($old) = select(SYSLOG); $| = 1; select($old);
+ $connected = 1;
+}
+
+sub disconnect {
+ close SYSLOG;
+ $connected = 0;
+}
+
+1;
--- /dev/null
+;# $Header: termcap.pl,v 4.0 91/03/20 01:26:33 lwall Locked $
+;#
+;# Usage:
+;# require 'ioctl.pl';
+;# ioctl(TTY,$TIOCGETP,$foo);
+;# ($ispeed,$ospeed) = unpack('cc',$foo);
+;# require 'termcap.pl';
+;# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
+;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
+;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
+;#
+sub Tgetent {
+ local($TERM) = @_;
+ local($TERMCAP,$_,$entry,$loop,$field);
+
+ warn "Tgetent: no ospeed set" unless $ospeed;
+ foreach $key (keys(TC)) {
+ delete $TC{$key};
+ }
+ $TERM = $ENV{'TERM'} unless $TERM;
+ $TERMCAP = $ENV{'TERMCAP'};
+ $TERMCAP = '/etc/termcap' unless $TERMCAP;
+ if ($TERMCAP !~ m:^/:) {
+ if (index($TERMCAP,"|$TERM|") < $[) {
+ $TERMCAP = '/etc/termcap';
+ }
+ }
+ if ($TERMCAP =~ m:^/:) {
+ $entry = '';
+ do {
+ $loop = "
+ open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
+ while (<TERMCAP>) {
+ next if /^#/;
+ next if /^\t/;
+ if (/\\|$TERM[:\\|]/) {
+ chop;
+ while (chop eq '\\\\') {
+ \$_ .= <TERMCAP>;
+ chop;
+ }
+ \$_ .= ':';
+ last;
+ }
+ }
+ close TERMCAP;
+ \$entry .= \$_;
+ ";
+ eval $loop;
+ } while s/:tc=([^:]+):/:/ && ($TERM = $1);
+ $TERMCAP = $entry;
+ }
+
+ foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
+ if ($field =~ /^\w\w$/) {
+ $TC{$field} = 1;
+ }
+ elsif ($field =~ /^(\w\w)#(.*)/) {
+ $TC{$1} = $2 if $TC{$1} eq '';
+ }
+ elsif ($field =~ /^(\w\w)=(.*)/) {
+ $entry = $1;
+ $_ = $2;
+ s/\\E/\033/g;
+ s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
+ s/\\n/\n/g;
+ s/\\r/\r/g;
+ s/\\t/\t/g;
+ s/\\b/\b/g;
+ s/\\f/\f/g;
+ s/\\\^/\377/g;
+ s/\^\?/\177/g;
+ s/\^(.)/pack('c',ord($1) & 31)/eg;
+ s/\\(.)/$1/g;
+ s/\377/^/g;
+ $TC{$entry} = $_ if $TC{$entry} eq '';
+ }
+ }
+ $TC{'pc'} = "\0" if $TC{'pc'} eq '';
+ $TC{'bc'} = "\b" if $TC{'bc'} eq '';
+}
+
+@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
+
+sub Tputs {
+ local($string,$affcnt,$FH) = @_;
+ local($ms);
+ if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
+ $ms = $1;
+ $ms *= $affcnt if $2;
+ $string = $3;
+ $decr = $Tputs[$ospeed];
+ if ($decr > .1) {
+ $ms += $decr / 2;
+ $string .= $TC{'pc'} x ($ms / $decr);
+ }
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+sub Tgoto {
+ local($string) = shift(@_);
+ local($result) = '';
+ local($after) = '';
+ local($code,$tmp) = @_;
+ local(@tmp);
+ @tmp = ($tmp,$code);
+ local($online) = 0;
+ while ($string =~ /^([^%]*)%(.)(.*)/) {
+ $result .= $1;
+ $code = $2;
+ $string = $3;
+ if ($code eq 'd') {
+ $result .= sprintf("%d",shift(@tmp));
+ }
+ elsif ($code eq '.') {
+ $tmp = shift(@tmp);
+ if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
+ if ($online) {
+ ++$tmp, $after .= $TC{'up'} if $TC{'up'};
+ }
+ else {
+ ++$tmp, $after .= $TC{'bc'};
+ }
+ }
+ $result .= sprintf("%c",$tmp);
+ $online = !$online;
+ }
+ elsif ($code eq '+') {
+ $result .= sprintf("%c",shift(@tmp)+ord($string));
+ $string = substr($string,1,99);
+ $online = !$online;
+ }
+ elsif ($code eq 'r') {
+ ($code,$tmp) = @tmp;
+ @tmp = ($tmp,$code);
+ $online = !$online;
+ }
+ elsif ($code eq '>') {
+ ($code,$tmp,$string) = unpack("CCa99",$string);
+ if ($tmp[$[] > $code) {
+ $tmp[$[] += $tmp;
+ }
+ }
+ elsif ($code eq '2') {
+ $result .= sprintf("%02d",shift(@tmp));
+ $online = !$online;
+ }
+ elsif ($code eq '3') {
+ $result .= sprintf("%03d",shift(@tmp));
+ $online = !$online;
+ }
+ elsif ($code eq 'i') {
+ ($code,$tmp) = @tmp;
+ @tmp = ($code+1,$tmp+1);
+ }
+ else {
+ return "OOPS";
+ }
+ }
+ $result . $string . $after;
+}
+
+1;
--- /dev/null
+;# timelocal.pl
+;#
+;# Usage:
+;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year,$junk,$junk,$isdst);
+;# $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.
+
+CONFIG: {
+ package timelocal;
+
+ @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;
+}
+
+sub timegm {
+ package timelocal;
+
+ $ym = pack(C2, @_[5,4]);
+ $cheat = $cheat{$ym} || &cheat;
+ $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS;
+}
+
+sub timelocal {
+ package timelocal;
+
+ $ym = pack(C2, @_[5,4]);
+ $cheat = $cheat{$ym} || &cheat;
+ $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS
+ + $tzmin * $MIN - 60 * 60 * ($_[8] != 0);
+}
+
+package timelocal;
+
+sub cheat {
+ $year = $_[5];
+ $month = $_[4];
+ $guess = $^T;
+ @g = gmtime($guess);
+ while ($diff = $year - $g[5]) {
+ $guess += $diff * (364 * $DAYS);
+ @g = gmtime($guess);
+ }
+ while ($diff = $month - $g[4]) {
+ $guess += $diff * (28 * $DAYS);
+ @g = gmtime($guess);
+ }
+ $g[3]--;
+ $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS;
+ $cheat{$ym} = $guess;
+}
--- /dev/null
+;# $Header: validate.pl,v 4.0 91/03/20 01:26:56 lwall Locked $
+
+;# The validate routine takes a single multiline string consisting of
+;# lines containing a filename plus a file test to try on it. (The
+;# file test may also be a 'cd', causing subsequent relative filenames
+;# to be interpreted relative to that directory.) After the file test
+;# you may put '|| die' to make it a fatal error if the file test fails.
+;# The default is '|| warn'. The file test may optionally have a ! prepended
+;# to test for the opposite condition. If you do a cd and then list some
+;# relative filenames, you may want to indent them slightly for readability.
+;# If you supply your own "die" or "warn" message, you can use $file to
+;# interpolate the filename.
+
+;# Filetests may be bunched: -rwx tests for all of -r, -w and -x.
+;# Only the first failed test of the bunch will produce a warning.
+
+;# The routine returns the number of warnings issued.
+
+;# Usage:
+;# require "validate.pl";
+;# $warnings += do validate('
+;# /vmunix -e || die
+;# /boot -e || die
+;# /bin cd
+;# csh -ex
+;# csh !-ug
+;# sh -ex
+;# sh !-ug
+;# /usr -d || warn "What happened to $file?\n"
+;# ');
+
+sub validate {
+ local($file,$test,$warnings,$oldwarnings);
+ foreach $check (split(/\n/,$_[0])) {
+ next if $check =~ /^#/;
+ next if $check =~ /^$/;
+ ($file,$test) = split(' ',$check,2);
+ if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
+ $testlist = $2;
+ @testlist = split(//,$testlist);
+ }
+ else {
+ @testlist = ('Z');
+ }
+ $oldwarnings = $warnings;
+ foreach $one (@testlist) {
+ $this = $test;
+ $this =~ s/(-\w\b)/$1 \$file/g;
+ $this =~ s/-Z/-$one/;
+ $this .= ' || warn' unless $this =~ /\|\|/;
+ $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/;
+ $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
+ eval $this;
+ last if $warnings > $oldwarnings;
+ }
+ }
+ $warnings;
+}
+
+sub valmess {
+ local($disposition,$this) = @_;
+ $file = $cwd . '/' . $file unless $file =~ m|^/|;
+ if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
+ $neg = $1;
+ $tmp = $2;
+ $tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
+ $tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
+ $tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
+ $tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
+ $tmp eq 'R' && ($mess = "$file is not readable by you.");
+ $tmp eq 'W' && ($mess = "$file is not writable by you.");
+ $tmp eq 'X' && ($mess = "$file is not executable by you.");
+ $tmp eq 'O' && ($mess = "$file is not owned by you.");
+ $tmp eq 'e' && ($mess = "$file does not exist.");
+ $tmp eq 'z' && ($mess = "$file does not have zero size.");
+ $tmp eq 's' && ($mess = "$file does not have non-zero size.");
+ $tmp eq 'f' && ($mess = "$file is not a plain file.");
+ $tmp eq 'd' && ($mess = "$file is not a directory.");
+ $tmp eq 'l' && ($mess = "$file is not a symbolic link.");
+ $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
+ $tmp eq 'S' && ($mess = "$file is not a socket.");
+ $tmp eq 'b' && ($mess = "$file is not a block special file.");
+ $tmp eq 'c' && ($mess = "$file is not a character special file.");
+ $tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
+ $tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
+ $tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
+ $tmp eq 'T' && ($mess = "$file is not a text file.");
+ $tmp eq 'B' && ($mess = "$file is not a binary file.");
+ if ($neg eq '!') {
+ $mess =~ s/ is not / should not be / ||
+ $mess =~ s/ does not / should not / ||
+ $mess =~ s/ not / /;
+ }
+ print stderr $mess,"\n";
+ }
+ else {
+ $this =~ s/\$file/'$file'/g;
+ print stderr "Can't do $this.\n";
+ }
+ if ($disposition eq 'die') { exit 1; }
+ ++$warnings;
+}
+
+1;
--- /dev/null
+case $CONFIG in
+'')
+ if test ! -f config.sh; then
+ ln ../config.sh . || \
+ ln ../../config.sh . || \
+ ln ../../../config.sh . || \
+ (echo "Can't find config.sh."; exit 1)
+ fi 2>/dev/null
+ . ./config.sh
+ ;;
+esac
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting makedepend (with variable substitutions)"
+$spitshell >makedepend <<!GROK!THIS!
+$startsh
+# $RCSfile: makedepend.SH,v $$Revision: 4.0.1.3 $$Date: 91/11/05 17:56:33 $
+#
+# $Log: makedepend.SH,v $
+# 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!'
+
+$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
+
+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 .c` ;;
+ esac
+ $echo "Finding dependencies for $filebase.o."
+ $sed -n <$file >$file.c \
+ -e "/^${filebase}_init(/q" \
+ -e '/^#/{' \
+ -e 's|/\*.*$||' \
+ -e 's|\\$||' \
+ -e p \
+ -e '}'
+ $cppstdin -I/usr/local/include -I. $cppflags $cppminus <$file.c | sed -e 's#\.[0-9][0-9]*\.c#'"$file.c#" | \
+ $sed \
+ -e 's/^[ ]*#[ ]*line/#/' \
+ -e '/^# *[0-9][0-9]* *"/!d' \
+ -e 's/^.*"\(.*\)".*$/'$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 -f .deptmp `sed 's/\.c/.c.c/' .clist` .shlist .clist .hlist .hsed
+
+!NO!SUBS!
+$eunicefix makedepend
+chmod +x makedepend
+case `pwd` in
+*SH)
+ $rm -f ../makedepend
+ ln makedepend ../makedepend
+ ;;
+esac
--- /dev/null
+case $CONFIG in
+'')
+ if test ! -f config.sh; then
+ ln ../config.sh . || \
+ ln ../../config.sh . || \
+ ln ../../../config.sh . || \
+ (echo "Can't find config.sh."; exit 1)
+ fi 2>/dev/null
+ . ./config.sh
+ ;;
+esac
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting makedir (with variable substitutions)"
+$spitshell >makedir <<!GROK!THIS!
+$startsh
+# $Header: makedir.SH,v 4.0 91/03/20 01:27:13 lwall Locked $
+#
+# $Log: makedir.SH,v $
+# 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)
+ $echo "makedir pathname filenameflag"
+ exit 1
+ ;;
+esac
+
+: guarantee one slash before 1st component
+case \$1 in
+ /*) ;;
+ *) set ./\$1 \$2 ;;
+esac
+
+: strip last component if it is to be a filename
+case X\$2 in
+ X1) set \`$echo \$1 | $sed 's:\(.*\)/[^/]*\$:\1:'\` ;;
+ *) set \$1 ;;
+esac
+
+: return reasonable status if nothing to be created
+if $test -d "\$1" ; then
+ exit 0
+fi
+
+list=''
+while true ; do
+ case \$1 in
+ */*)
+ list="\$1 \$list"
+ set \`echo \$1 | $sed 's:\(.*\)/:\1 :'\`
+ ;;
+ *)
+ break
+ ;;
+ esac
+done
+
+set \$list
+
+for dir do
+ $mkdir \$dir >/dev/null 2>&1
+done
+!GROK!THIS!
+$eunicefix makedir
+chmod +x makedir
--- /dev/null
+/* $RCSfile: malloc.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 17:57:40 $
+ *
+ * $Log: malloc.c,v $
+ * 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
+/*
+ * malloc.c (Caltech) 2/21/82
+ * Chris Kingsley, kingsley@cit-20.
+ *
+ * This is a very fast storage allocator. It allocates blocks of a small
+ * number of different sizes, and keeps free lists of each size. Blocks that
+ * don't exactly fit are passed up to the next larger size. In this
+ * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
+ * This is designed for use in a program that uses vast quantities of memory,
+ * but bombs when it runs out.
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+static findbucket(), morecore();
+
+/* I don't much care whether these are defined in sys/types.h--LAW */
+
+#define u_char unsigned char
+#define u_int unsigned int
+#define u_short unsigned short
+
+/*
+ * The overhead on a block is at least 4 bytes. When free, this space
+ * contains a pointer to the next free block, and the bottom two bits must
+ * be zero. When in use, the first byte is set to MAGIC, and the second
+ * byte is the size index. The remaining bytes are for alignment.
+ * If range checking is enabled and the size of the block fits
+ * in two bytes, then the top two bytes hold the size of the requested block
+ * plus the range checking words, and the header word MINUS ONE.
+ */
+union overhead {
+ union overhead *ov_next; /* when free */
+#if ALIGNBYTES > 4
+ double strut; /* alignment problems */
+#endif
+ struct {
+ u_char ovu_magic; /* magic number */
+ u_char ovu_index; /* bucket # */
+#ifdef RCHECK
+ u_short ovu_size; /* actual block size */
+ u_int ovu_rmagic; /* range magic number */
+#endif
+ } ovu;
+#define ov_magic ovu.ovu_magic
+#define ov_index ovu.ovu_index
+#define ov_size ovu.ovu_size
+#define ov_rmagic ovu.ovu_rmagic
+};
+
+#define MAGIC 0xff /* magic # on accounting info */
+#define OLDMAGIC 0x7f /* same after a free() */
+#define RMAGIC 0x55555555 /* magic # on range info */
+#ifdef RCHECK
+#define RSLOP sizeof (u_int)
+#else
+#define RSLOP 0
+#endif
+
+/*
+ * nextf[i] is the pointer to the next free block of size 2^(i+3). The
+ * smallest allocatable block is 8 bytes. The overhead information
+ * precedes the data area returned to the user.
+ */
+#define NBUCKETS 30
+static union overhead *nextf[NBUCKETS];
+extern char *sbrk();
+
+#ifdef MSTATS
+/*
+ * nmalloc[i] is the difference between the number of mallocs and frees
+ * for a given block size.
+ */
+static u_int nmalloc[NBUCKETS];
+#include <stdio.h>
+#endif
+
+#ifdef debug
+#define ASSERT(p) if (!(p)) botch("p"); else
+static
+botch(s)
+ char *s;
+{
+
+ printf("assertion botched: %s\n", s);
+ abort();
+}
+#else
+#define ASSERT(p)
+#endif
+
+#ifdef safemalloc
+static int an = 0;
+#endif
+
+MALLOCPTRTYPE *
+malloc(nbytes)
+ register unsigned nbytes;
+{
+ register union overhead *p;
+ register int bucket = 0;
+ register unsigned shiftr;
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+ int size = nbytes;
+#endif
+
+#ifdef MSDOS
+ if (nbytes > 0xffff) {
+ fprintf(stderr, "Allocation too large: %lx\n", nbytes);
+ exit(1);
+ }
+#endif /* MSDOS */
+#ifdef DEBUGGING
+ if ((long)nbytes < 0)
+ fatal("panic: malloc");
+#endif
+#endif /* safemalloc */
+
+ /*
+ * Convert amount of memory requested into
+ * closest block size stored in hash buckets
+ * which satisfies request. Account for
+ * space used per block for accounting.
+ */
+ nbytes += sizeof (union overhead) + RSLOP;
+ nbytes = (nbytes + 3) &~ 3;
+ shiftr = (nbytes - 1) >> 2;
+ /* apart from this loop, this is O(1) */
+ while (shiftr >>= 1)
+ bucket++;
+ /*
+ * If nothing in hash bucket right now,
+ * request more memory from the system.
+ */
+ if (nextf[bucket] == NULL)
+ morecore(bucket);
+ if ((p = (union overhead *)nextf[bucket]) == NULL) {
+#ifdef safemalloc
+ fputs("Out of memory!\n", stderr);
+ exit(1);
+#else
+ return (NULL);
+#endif
+ }
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+# ifndef I286
+ if (debug & 128)
+ fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",p+1,an++,size);
+# else
+ if (debug & 128)
+ fprintf(stderr,"0x%lx: (%05d) malloc %d bytes\n",p+1,an++,size);
+# endif
+#endif
+#endif /* safemalloc */
+
+ /* remove from linked list */
+#ifdef RCHECK
+ if (*((int*)p) & (sizeof(union overhead) - 1))
+#ifndef I286
+ 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
+#endif
+ nextf[bucket] = p->ov_next;
+ p->ov_magic = MAGIC;
+ p->ov_index= bucket;
+#ifdef MSTATS
+ nmalloc[bucket]++;
+#endif
+#ifdef RCHECK
+ /*
+ * Record allocated size of block and
+ * bound space with magic numbers.
+ */
+ if (nbytes <= 0x10000)
+ p->ov_size = nbytes - 1;
+ p->ov_rmagic = RMAGIC;
+ *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
+#endif
+ return ((MALLOCPTRTYPE *)(p + 1));
+}
+
+/*
+ * Allocate more memory to the indicated bucket.
+ */
+static
+morecore(bucket)
+ register int bucket;
+{
+ register union overhead *op;
+ register int rnu; /* 2^rnu bytes will be requested */
+ register int nblks; /* become nblks blocks of the desired size */
+ register int siz;
+
+ if (nextf[bucket])
+ return;
+ /*
+ * Insure memory is allocated
+ * on a page boundary. Should
+ * make getpageize call?
+ */
+ op = (union overhead *)sbrk(0);
+#ifndef I286
+ if ((int)op & 0x3ff)
+ (void)sbrk(1024 - ((int)op & 0x3ff));
+#else
+ /* The sbrk(0) call on the I286 always returns the next segment */
+#endif
+
+#ifndef I286
+ /* take 2k unless the block is bigger than that */
+ rnu = (bucket <= 8) ? 11 : bucket + 3;
+#else
+ /* take 16k unless the block is bigger than that
+ (80286s like large segments!) */
+ rnu = (bucket <= 11) ? 14 : bucket + 3;
+#endif
+ nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */
+ if (rnu < bucket)
+ rnu = bucket;
+ op = (union overhead *)sbrk(1 << rnu);
+ /* no more room! */
+ if ((int)op == -1)
+ return;
+ /*
+ * Round up to minimum allocation size boundary
+ * and deduct from block count to reflect.
+ */
+#ifndef I286
+ if ((int)op & 7) {
+ op = (union overhead *)(((int)op + 8) &~ 7);
+ nblks--;
+ }
+#else
+ /* Again, this should always be ok on an 80286 */
+#endif
+ /*
+ * Add new memory allocated to that on
+ * free list for this hash bucket.
+ */
+ nextf[bucket] = op;
+ siz = 1 << (bucket + 3);
+ while (--nblks > 0) {
+ op->ov_next = (union overhead *)((caddr_t)op + siz);
+ op = (union overhead *)((caddr_t)op + siz);
+ }
+}
+
+void
+free(mp)
+ MALLOCPTRTYPE *mp;
+{
+ register int size;
+ register union overhead *op;
+ char *cp = (char*)mp;
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+# ifndef I286
+ if (debug & 128)
+ fprintf(stderr,"0x%x: (%05d) free\n",cp,an++);
+# else
+ if (debug & 128)
+ fprintf(stderr,"0x%lx: (%05d) free\n",cp,an++);
+# endif
+#endif
+#endif /* safemalloc */
+
+ if (cp == NULL)
+ return;
+ op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
+#ifdef debug
+ ASSERT(op->ov_magic == MAGIC); /* make sure it was in use */
+#else
+ if (op->ov_magic != MAGIC) {
+ warn("%s free() ignored",
+ op->ov_magic == OLDMAGIC ? "Duplicate" : "Bad");
+ return; /* sanity */
+ }
+ op->ov_magic = OLDMAGIC;
+#endif
+#ifdef RCHECK
+ ASSERT(op->ov_rmagic == RMAGIC);
+ if (op->ov_index <= 13)
+ ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC);
+#endif
+ ASSERT(op->ov_index < NBUCKETS);
+ size = op->ov_index;
+ op->ov_next = nextf[size];
+ nextf[size] = op;
+#ifdef MSTATS
+ nmalloc[size]--;
+#endif
+}
+
+/*
+ * When a program attempts "storage compaction" as mentioned in the
+ * old malloc man page, it realloc's an already freed block. Usually
+ * this is the last block it freed; occasionally it might be farther
+ * back. We have to search all the free lists for the block in order
+ * to determine its bucket: 1st we make one pass thru the lists
+ * checking only the first block in each; if that fails we search
+ * ``reall_srchlen'' blocks in each list for a match (the variable
+ * is extern so the caller can modify it). If that fails we just copy
+ * however many bytes was given to realloc() and hope it's not huge.
+ */
+int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */
+
+MALLOCPTRTYPE *
+realloc(mp, nbytes)
+ MALLOCPTRTYPE *mp;
+ unsigned nbytes;
+{
+ register u_int onb;
+ union overhead *op;
+ char *res;
+ register int i;
+ int was_alloced = 0;
+ char *cp = (char*)mp;
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+ int size = nbytes;
+#endif
+
+#ifdef MSDOS
+ if (nbytes > 0xffff) {
+ fprintf(stderr, "Reallocation too large: %lx\n", size);
+ exit(1);
+ }
+#endif /* MSDOS */
+ if (!cp)
+ fatal("Null realloc");
+#ifdef DEBUGGING
+ if ((long)nbytes < 0)
+ fatal("panic: realloc");
+#endif
+#endif /* safemalloc */
+
+ if (cp == NULL)
+ return (malloc(nbytes));
+ op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
+ if (op->ov_magic == MAGIC) {
+ was_alloced++;
+ i = op->ov_index;
+ } else {
+ /*
+ * Already free, doing "compaction".
+ *
+ * Search for the old block of memory on the
+ * free list. First, check the most common
+ * case (last element free'd), then (this failing)
+ * the last ``reall_srchlen'' items free'd.
+ * If all lookups fail, then assume the size of
+ * the memory block being realloc'd is the
+ * smallest possible.
+ */
+ if ((i = findbucket(op, 1)) < 0 &&
+ (i = findbucket(op, reall_srchlen)) < 0)
+ i = 0;
+ }
+ onb = (1 << (i + 3)) - sizeof (*op) - RSLOP;
+ /* avoid the copy if same size block */
+ if (was_alloced &&
+ nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) {
+#ifdef RCHECK
+ /*
+ * Record new allocated size of block and
+ * bound space with magic numbers.
+ */
+ if (op->ov_index <= 13) {
+ /*
+ * Convert amount of memory requested into
+ * closest block size stored in hash buckets
+ * which satisfies request. Account for
+ * space used per block for accounting.
+ */
+ nbytes += sizeof (union overhead) + RSLOP;
+ nbytes = (nbytes + 3) &~ 3;
+ op->ov_size = nbytes - 1;
+ *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
+ }
+#endif
+ res = cp;
+ }
+ else {
+ if ((res = (char*)malloc(nbytes)) == NULL)
+ return (NULL);
+ if (cp != res) /* common optimization */
+ bcopy(cp, res, (int)(nbytes < onb ? nbytes : onb));
+ if (was_alloced)
+ free(cp);
+ }
+
+#ifdef safemalloc
+#ifdef DEBUGGING
+# ifndef I286
+ if (debug & 128) {
+ fprintf(stderr,"0x%x: (%05d) rfree\n",res,an++);
+ fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",res,an++,size);
+ }
+# else
+ if (debug & 128) {
+ fprintf(stderr,"0x%lx: (%05d) rfree\n",res,an++);
+ fprintf(stderr,"0x%lx: (%05d) realloc %d bytes\n",res,an++,size);
+ }
+# endif
+#endif
+#endif /* safemalloc */
+ return ((MALLOCPTRTYPE*)res);
+}
+
+/*
+ * Search ``srchlen'' elements of each free list for a block whose
+ * header starts at ``freep''. If srchlen is -1 search the whole list.
+ * Return bucket number, or -1 if not found.
+ */
+static
+findbucket(freep, srchlen)
+ union overhead *freep;
+ int srchlen;
+{
+ register union overhead *p;
+ register int i, j;
+
+ for (i = 0; i < NBUCKETS; i++) {
+ j = 0;
+ for (p = nextf[i]; p && j != srchlen; p = p->ov_next) {
+ if (p == freep)
+ return (i);
+ j++;
+ }
+ }
+ return (-1);
+}
+
+#ifdef MSTATS
+/*
+ * mstats - print out statistics about malloc
+ *
+ * Prints two lines of numbers, one showing the length of the free list
+ * for each size category, the second showing the number of mallocs -
+ * frees for each size category.
+ */
+mstats(s)
+ char *s;
+{
+ register int i, j;
+ register union overhead *p;
+ int totfree = 0,
+ totused = 0;
+
+ fprintf(stderr, "Memory allocation statistics %s\nfree:\t", s);
+ for (i = 0; i < NBUCKETS; i++) {
+ for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
+ ;
+ fprintf(stderr, " %d", j);
+ totfree += j * (1 << (i + 3));
+ }
+ fprintf(stderr, "\nused:\t");
+ for (i = 0; i < NBUCKETS; i++) {
+ fprintf(stderr, " %d", nmalloc[i]);
+ totused += nmalloc[i] * (1 << (i + 3));
+ }
+ fprintf(stderr, "\n\tTotal in use: %d, total free: %d\n",
+ totused, totfree);
+}
+#endif
+#endif /* lint */
--- /dev/null
+#
+# 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
+
+# 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
+
+# Files in the OS/2 distribution
+DOSFILES=config.h director.c makefile os2.c popen.c suffix.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, no DEBUGGING, symbols stripped.
+CBASE=-AL -Zi -G2 -Gs
+CPLAIN=$(CBASE) -Oilt
+CFLAGS=$(CBASE) -Ox
+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 \c600\lib\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) /B3 \c600\binp\c3l $(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) /B3 \c600\binp\c3l $(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
--- /dev/null
+(-W1 -Od -Ocgelt a2p.y{a2py.c})
+(-W1 -Od -Ocgelt hash.c str.c util.c walk.c)
+
+setargv.obj
+..\os2\a2p.def
+a2p.exe
+
+-AL -LB -S0x9000
--- /dev/null
+NAME AWK2PERL WINDOWCOMPAT NEWFILES
+DESCRIPTION 'AWK to PERL translator - for MS-DOS and OS/2'
--- /dev/null
+/*
+ * 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
--- /dev/null
+#define SIGALRM SIGUSR1
+unsigned alarm(unsigned);
--- /dev/null
+/* config.h
+ * This file was hand tailored for compiling under MS-DOS and MSC 5.1.
+ * Diomidis Spinellis, March 1990.
+ *
+ * Then it got mangled again for compiling under OS/2 and MSC 6.0.
+ * Raymond Chen, June 1990.
+ */
+#define OS2 /**/
+
+/* OS/2 supports some additional things MS-DOS doesn't.
+ */
+#ifdef OS2
+#define PIPE
+#define GETPPID
+#define HAS_GETPRIORITY
+#define HAS_SETPRIORITY
+#define KILL
+#endif /* OS2 */
+
+/* SUFFIX:
+ * This symbol, if defined, indicates that the function add_suffix has
+ * been supplied in a system-dependent .c file. This function is
+ * recommended for operating systems whose filenaming conventions
+ * do not permit arbitrary strings as filenames.
+ */
+#define SUFFIX /**/
+
+/* 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 /**/
+
+/* BIN:
+ * This symbol holds the name of the directory in which the user wants
+ * to put publicly executable images for the package in question. It
+ * is most often a local directory such as /usr/local/bin.
+ */
+#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...
+ */
+/* CHECK */
+#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 -{" 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 */
+#define CPPSTDIN "cc -{"
+#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 /**/
+
+/* 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_CRYPT:
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+/* TODO */
+/*#define HAS_CRYPT /**/
+
+/* 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 /**/
+
+/* 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 /**/
+
+/* I_FCNTL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include fcntl.h.
+ */
+/*#define I_FCNTL /**/
+
+/* 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_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? */
+
+/* I_SYSIOCTL:
+ * This symbol, if defined, indicates that sys/ioctl.h exists and should
+ * be included.
+ */
+/*#define I_SYSIOCTL /**/
+
+/* 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_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.
+ */
+#define HAS_MEMCPY /**/
+
+/* 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_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_READDIR:
+ * This symbol, if defined, indicates that the readdir routine is available
+ * from the C library to create 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_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_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_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.
+ */
+/*#define HAS_SETREGID /**/
+
+/* HAS_SETREUID:
+ * This symbol, if defined, indicates that the setreuid routine is available
+ * to change the real and effective uid of the current program.
+ */
+/*#define HAS_SETREUID /**/
+
+/* 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_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.
+ */
+/*#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_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 /**/
+
+/* s_tm:
+ * This symbol is defined if this system declares "struct tm" in
+ * in <sys/time.h> rather than <time.h>. We can't just say
+ * -I/usr/include/sys because some systems have both time files, and
+ * the -I trick gets the wrong one.
+ */
+/* I_SYS_TIME:
+ * This symbol is defined if this system has the file <sys/time.h>.
+ */
+/*
+ * I_TIME:
+ * This symbol is defined if time this system has the file <time.h>.
+ */
+/*#undef s_tm /**/
+/*#define I_SYS_TIME /**/
+#define I_TIME
+
+/* VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include varargs.h.
+ */
+#define VARARGS /**/
+
+/* vfork:
+ * This symbol, if defined, remaps the vfork routine to fork if the
+ * vfork() routine isn't supported here.
+ */
+/*#undef vfork fork /**/
+
+/* 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_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 /**/
+
+/* GIDTYPE:
+ * This symbol has a value like gid_t, int, ushort, or whatever type is
+ * used to declare group ids in the kernel.
+ */
+/* TODO */
+#define GIDTYPE int /**/
+
+/* I_DIRENT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include dirent.h.
+ */
+/* DIRNAMLEN:
+ * This symbol, if defined, indicates to the C program that the length
+ * of directory entry names is provided by a d_namlen field. Otherwise
+ * you need to do strlen() on the d_name field.
+ */
+/*#undef I_DIRENT /**/
+#define DIRNAMLEN /**/
+
+/* I_FCNTL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include fcntl.h.
+ */
+/*#define I_FCNTL /**/
+
+/* I_GRP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include grp.h.
+ */
+/*#define I_GRP /**/
+
+/* 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.
+ */
+/*#define I_PWD /**/
+/*#define PWQUOTA /**/
+/*#undef PWAGE /**/
+
+/* I_SYS_DIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include sys/dir.h.
+ */
+#define I_SYS_DIR /**/
+
+/* I_SYSIOCTL:
+ * This symbol, if defined, indicates that sys/ioctl.h exists and should
+ * be included.
+ */
+/*#define I_SYSIOCTL /**/
+
+/* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include varargs.h.
+ */
+#define I_VARARGS /**/
+
+/* INTSIZE:
+ * This symbol contains the size of an int, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define INTSIZE 2 /**/
+
+/* 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 /**/
+
+/* SIG_NAME:
+ * This symbol contains an list of signal names in order.
+ */
+#ifdef OS2
+#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 */
+#else
+#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","USR1","USR2" /**/
+#endif /* OS2 */
+
+/* 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 /**/
+
+/* 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
+ *
+ * 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 7
+#endif
+#define VOIDFLAGS 7
+#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+#define void int /* is void to be avoided? */
+#define M_VOID /* Xenix strikes again */
+#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" /**/
+
+/*
+ * BUGGY_MSC:
+ * This symbol is defined if you are the unfortunate owner of a buggy
+ * Microsoft C compiler and want to use intrinsic functions. Versions
+ * up to 5.1 are known conform to this definition.
+ */
+/*#define BUGGY_MSC /**/
+
+/*
+ * 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
+#define CASTNEGFLOAT
--- /dev/null
+/*
+ * @(#) 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);
--- /dev/null
+/*
+ * @(#)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
--- /dev/null
+sub handler {
+ local($sig) = @_;
+ print "Caught a SIG$sig -- shutting down\n";
+ exit(0);
+}
+
+$SIG{'INT'} = 'handler';
+$SIG{'QUIT'} = 'handler';
+$SIG{'ALRM'} = 'handler';
+
+print "Starting execution ...\n";
+alarm(10);
+
+while ( <> ) {
+}
+print "Normal exit.\n";
--- /dev/null
+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.
+
--- /dev/null
+# 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;
--- /dev/null
+/*
+ * Globbing for OS/2. 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(IsFileSystemFAT(argv[i]) ? strlwr(argv[i]) : argv[i], stdout);
+ putchar(0);
+ }
+}
--- /dev/null
+#
+# 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
--- /dev/null
+/* MKTEMP.C using TMP environment variable */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <io.h>
+
+void Mktemp(char *file)
+{
+ char fname[32], *tmp;
+
+ tmp = getenv("TMP");
+
+ if ( tmp != NULL )
+ {
+ strcpy(fname, file);
+ strcpy(file, tmp);
+
+ if ( file[strlen(file) - 1] != '\\' )
+ strcat(file, "\\");
+
+ strcat(file, fname);
+ }
+
+ mktemp(file);
+}
+
+/* End of MKTEMP.C */
--- /dev/null
+/* $RCSfile: os2.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:23:06 $
+ *
+ * (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.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; }
+
+
+/* extendd chdir() */
+
+int chdir(char *path)
+{
+ if ( path[0] != 0 && path[1] == ':' )
+ DosSelectDisk(toupper(path[0]) - '@');
+
+ 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;
+}
+
+
+/* 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 [-acdnpsSvw] [-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"
+#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 -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");
+}
--- /dev/null
+DOSMAKEPIPE
+DOSCWAIT
+DOSKILLPROCESS
+DOSFLAGPROCESS
+DOSSETPRTY
+DOSGETPRTY
+DOSQFSATTACH
+DOSCREATETHREAD
--- /dev/null
+(-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 perly.c regcomp.c regexec.c stab.c str.c util.c
+)
+(-W1 -Od -Olt -B2C2L -B3C3L -DDEBUGGING eval.c{evalargs.xc} toke.c)
+(-W1 -Od -Olt -I. -Ios2
+os2\os2.c os2\popen.c os2\mktemp.c os2\director.c os2\suffix.c os2\alarm.c
+)
+
+; link with this library if you have GNU gdbm for OS/2
+; remember to enable the NDBM symbol in config.h before compiling
+lgdbm.lib
+setargv.obj
+os2\perl.def
+os2\perl.bad
+perl.exe
+
+-AL -LB -S0x8000
--- /dev/null
+NAME PERL WINDOWCOMPAT NEWFILES
+DESCRIPTION 'PERL 3.0 - for MS-DOS and OS/2'
--- /dev/null
+*** lib/perldb.pl Tue Oct 23 23:14:20 1990
+--- os2/perldb.pl Tue Nov 06 21:13:42 1990
+***************
+*** 36,43 ****
+ #
+ #
+
+! 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);
+--- 36,43 ----
+ #
+ #
+
+! open(IN, "<con") || open(IN, "<&STDIN"); # so we don't dingle stdin
+! open(OUT,">con") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
+ select(OUT);
+ $| = 1; # for DB'OUT
+ select(STDOUT);
+***************
+*** 517,530 ****
+ s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+ }
+
+! if (-f '.perldb') {
+! do './.perldb';
+ }
+! elsif (-f "$ENV{'LOGDIR'}/.perldb") {
+! do "$ENV{'LOGDIR'}/.perldb";
+ }
+! elsif (-f "$ENV{'HOME'}/.perldb") {
+! do "$ENV{'HOME'}/.perldb";
+ }
+
+ 1;
+--- 517,530 ----
+ s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+ }
+
+! if (-f 'perldb.ini') {
+! do './perldb.ini';
+ }
+! elsif (-f "$ENV{'INIT'}/perldb.ini") {
+! do "$ENV{'INIT'}/perldb.ini";
+ }
+! elsif (-f "$ENV{'HOME'}/perldb.ini") {
+! do "$ENV{'HOME'}/perldb.ini";
+ }
+
+ 1;
--- /dev/null
+DOSQFSATTACH
--- /dev/null
+os2\glob.c
+(-DPERLGLOB os2\director.c)
+
+setargv.obj
+os2\perlglob.def
+os2\perlglob.bad
+perlglob.exe
+
+-AS -LB -S0x1000
--- /dev/null
+NAME PERLGLOB WINDOWCOMPAT NEWFILES
+DESCRIPTION 'Filename globbing for PERL - for MS-DOS and OS/2'
--- /dev/null
+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 = $/; $/ = '';
+}
--- /dev/null
+/* 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 (DosMakePipe((PHFILE) &p[0], (PHFILE) &p[1], 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 = DosMakePipe((PHFILE) &filedes[0], (PHFILE) &filedes[1], 4096) )
+ 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];
+ 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, "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;
+}
--- /dev/null
+extproc perl -Sx
+#!perl
+
+$bin = 'c:/bin';
+
+# $Header: s2p.cmd,v 4.0 91/03/20 01:37:09 lwall Locked $
+#
+# $Log: s2p.cmd,v $
+# 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;
+}
--- /dev/null
+@echo off
+perl -x %0.bat
+goto exit
+#!perl
+
+printf "
+This is a self-running perl script for DOS.
+
+"
+
+__END__
+:exit
--- /dev/null
+extproc perl -x
+#!perl
+
+printf "
+This is a self-running perl script using the
+extproc feature of the OS/2 command processor.
+"
--- /dev/null
+/*
+ * 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 */
--- /dev/null
+#define PATCHLEVEL 19
--- /dev/null
+char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.6 $$Date: 91/11/11 16:38:45 $\nPatch level: ###\n";
+/*
+ * 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: perl.c,v $
+ * 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 eval {}
+ * patch11: eval 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 eval
+ *
+ * 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*/
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "perly.h"
+#ifdef MSDOS
+#include "patchlev.h"
+#else
+#include "patchlevel.h"
+#endif
+
+char *getenv();
+
+#ifdef IAMSUID
+#ifndef DOSUID
+#define DOSUID
+#endif
+#endif
+
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef DOSUID
+#undef DOSUID
+#endif
+#endif
+
+static char* moreswitches();
+static char* cddir;
+static bool minus_c;
+static char patchlevel[6];
+static char *nrs = "\n";
+static int nrschar = '\n'; /* final char of rs, or 0777 if none */
+static int nrslen = 1;
+
+main(argc,argv,env)
+register int argc;
+register char **argv;
+register char **env;
+{
+ register STR *str;
+ register char *s;
+ char *scriptname;
+ char *getenv();
+ bool dosearch = FALSE;
+#ifdef DOSUID
+ char *validarg = "";
+#endif
+
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef IAMSUID
+#undef IAMSUID
+ fatal("suidperl is no longer needed since the kernel can now execute\n\
+setuid perl scripts securely.\n");
+#endif
+#endif
+
+ origargv = argv;
+ origargc = argc;
+ origenviron = environ;
+ uid = (int)getuid();
+ euid = (int)geteuid();
+ gid = (int)getgid();
+ egid = (int)getegid();
+ sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
+#ifdef MSDOS
+ /*
+ * There is no way we can refer to them from Perl so close them to save
+ * space. The other alternative would be to provide STDAUX and STDPRN
+ * filehandles.
+ */
+ (void)fclose(stdaux);
+ (void)fclose(stdprn);
+#endif
+ if (do_undump) {
+ origfilename = savestr(argv[0]);
+ do_undump = 0;
+ loop_ptr = -1; /* start label stack again */
+ goto just_doit;
+ }
+ (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
+ linestr = Str_new(65,80);
+ str_nset(linestr,"",0);
+ str = str_make("",0); /* first used for -I flags */
+ curstash = defstash = hnew(0);
+ curstname = str_make("main",4);
+ stab_xhash(stabent("_main",TRUE)) = defstash;
+ defstash->tbl_name = "main";
+ incstab = hadd(aadd(stabent("INC",TRUE)));
+ incstab->str_pok |= SP_MULTI;
+ for (argc--,argv++; argc > 0; argc--,argv++) {
+ if (argv[0][0] != '-' || !argv[0][1])
+ break;
+#ifdef DOSUID
+ if (*validarg)
+ validarg = " PHOOEY ";
+ else
+ validarg = argv[0];
+#endif
+ s = argv[0]+1;
+ reswitch:
+ switch (*s) {
+ case '0':
+ case 'a':
+ case 'c':
+ case 'd':
+ case 'D':
+ case 'i':
+ case 'l':
+ case 'n':
+ case 'p':
+ case 'u':
+ case 'U':
+ case 'v':
+ case 'w':
+ if (s = moreswitches(s))
+ goto reswitch;
+ break;
+
+ case 'e':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -e allowed in setuid scripts");
+#endif
+ if (!e_fp) {
+ e_tmpname = savestr(TMPPATH);
+ (void)mktemp(e_tmpname);
+ e_fp = fopen(e_tmpname,"w");
+ if (!e_fp)
+ fatal("Cannot open temporary file");
+ }
+ if (argv[1]) {
+ fputs(argv[1],e_fp);
+ argc--,argv++;
+ }
+ (void)putc('\n', e_fp);
+ break;
+ case 'I':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -I allowed in setuid scripts");
+#endif
+ str_cat(str,"-");
+ str_cat(str,s);
+ str_cat(str," ");
+ if (*++s) {
+ (void)apush(stab_array(incstab),str_make(s,0));
+ }
+ else if (argv[1]) {
+ (void)apush(stab_array(incstab),str_make(argv[1],0));
+ str_cat(str,argv[1]);
+ argc--,argv++;
+ str_cat(str," ");
+ }
+ break;
+ case 'P':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -P allowed in setuid scripts");
+#endif
+ preprocess = TRUE;
+ s++;
+ goto reswitch;
+ case 's':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -s allowed in setuid scripts");
+#endif
+ doswitches = TRUE;
+ s++;
+ goto reswitch;
+ case 'S':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -S allowed in setuid scripts");
+#endif
+ dosearch = TRUE;
+ s++;
+ goto reswitch;
+ case 'x':
+ doextract = TRUE;
+ s++;
+ if (*s)
+ cddir = savestr(s);
+ break;
+ case '-':
+ argc--,argv++;
+ goto switch_end;
+ case 0:
+ break;
+ default:
+ fatal("Unrecognized switch: -%s",s);
+ }
+ }
+ switch_end:
+ scriptname = argv[0];
+ if (e_fp) {
+ (void)fclose(e_fp);
+ argc++,argv--;
+ scriptname = e_tmpname;
+ }
+
+#ifdef MSDOS
+#define PERLLIB_SEP ';'
+#else
+#define PERLLIB_SEP ':'
+#endif
+#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
+ {
+ char * s2 = getenv("PERLLIB");
+
+ if ( s2 ) {
+ /* Break at all separators */
+ while ( *s2 ) {
+ /* First, skip any consecutive separators */
+ while ( *s2 == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* (void)apush(stab_array(incstab),str_make(".",1)); */
+ s2++;
+ }
+ if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
+ (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
+ s2 = s+1;
+ } else {
+ (void)apush(stab_array(incstab),str_make(s2,0));
+ break;
+ }
+ }
+ }
+ }
+#endif /* TAINT */
+
+#ifndef PRIVLIB
+#define PRIVLIB "/usr/local/lib/perl"
+#endif
+ (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
+ (void)apush(stab_array(incstab),str_make(".",1));
+
+ str_set(&str_no,No);
+ str_set(&str_yes,Yes);
+
+ /* open script */
+
+ if (scriptname == Nullch)
+#ifdef MSDOS
+ {
+ if ( isatty(fileno(stdin)) )
+ moreswitches("v");
+ scriptname = "-";
+ }
+#else
+ scriptname = "-";
+#endif
+ if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
+ char *xfound = Nullch, *xfailed = Nullch;
+ int len;
+
+ bufend = s + strlen(s);
+ while (*s) {
+#ifndef MSDOS
+ s = cpytill(tokenbuf,s,bufend,':',&len);
+#else
+ for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
+ tokenbuf[len] = '\0';
+#endif
+ if (*s)
+ s++;
+#ifndef MSDOS
+ if (len && tokenbuf[len-1] != '/')
+#else
+ if (len && tokenbuf[len-1] != '\\')
+#endif
+ (void)strcat(tokenbuf+len,"/");
+ (void)strcat(tokenbuf+len,scriptname);
+#ifdef DEBUGGING
+ if (debug & 1)
+ fprintf(stderr,"Looking for %s\n",tokenbuf);
+#endif
+ if (stat(tokenbuf,&statbuf) < 0) /* not there? */
+ continue;
+ if (S_ISREG(statbuf.st_mode)
+ && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
+ xfound = tokenbuf; /* bingo! */
+ break;
+ }
+ if (!xfailed)
+ xfailed = savestr(tokenbuf);
+ }
+ if (!xfound)
+ fatal("Can't execute %s", xfailed ? xfailed : scriptname );
+ if (xfailed)
+ Safefree(xfailed);
+ scriptname = savestr(xfound);
+ }
+
+ fdpid = anew(Nullstab); /* for remembering popen pids by fd */
+ pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
+
+ origfilename = savestr(scriptname);
+ curcmd->c_filestab = fstab(origfilename);
+ if (strEQ(origfilename,"-"))
+ scriptname = "";
+ if (preprocess) {
+ char *cpp = CPPSTDIN;
+
+ if (strEQ(cpp,"cppstdin"))
+ sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
+ else
+ sprintf(tokenbuf, "%s", cpp);
+ str_cat(str,"-I");
+ str_cat(str,PRIVLIB);
+ (void)sprintf(buf, "\
+%ssed %s -e '/^[^#]/b' \
+ -e '/^#[ ]*include[ ]/b' \
+ -e '/^#[ ]*define[ ]/b' \
+ -e '/^#[ ]*if[ ]/b' \
+ -e '/^#[ ]*ifdef[ ]/b' \
+ -e '/^#[ ]*ifndef[ ]/b' \
+ -e '/^#[ ]*else/b' \
+ -e '/^#[ ]*elif[ ]/b' \
+ -e '/^#[ ]*undef[ ]/b' \
+ -e '/^#[ ]*endif/b' \
+ -e 's/^[ ]*#.*//' \
+ %s | %s -C %s %s",
+#ifdef MSDOS
+ "",
+#else
+ "/bin/",
+#endif
+ (doextract ? "-e '1,/^#/d\n'" : ""),
+ scriptname, tokenbuf, str_get(str), CPPMINUS);
+#ifdef DEBUGGING
+ if (debug & 64) {
+ fputs(buf,stderr);
+ fputs("\n",stderr);
+ }
+#endif
+ doextract = FALSE;
+#ifdef IAMSUID /* actually, this is caught earlier */
+ if (euid != uid && !euid) /* if running suidperl */
+#ifdef HAS_SETEUID
+ (void)seteuid(uid); /* musn't stay setuid root */
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid(-1, uid);
+#else
+ setuid(uid);
+#endif
+#endif
+#endif /* IAMSUID */
+ rsfp = mypopen(buf,"r");
+ }
+ else if (!*scriptname) {
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("Can't take set-id script from stdin");
+#endif
+ rsfp = stdin;
+ }
+ else
+ rsfp = fopen(scriptname,"r");
+ if ((FILE*)rsfp == Nullfp) {
+#ifdef DOSUID
+#ifndef IAMSUID /* in case script is not readable before setuid */
+ if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
+ statbuf.st_mode & (S_ISUID|S_ISGID)) {
+ (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
+ execv(buf, origargv); /* try again */
+ fatal("Can't do setuid\n");
+ }
+#endif
+#endif
+ fatal("Can't open perl script \"%s\": %s\n",
+ stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
+ }
+ str_free(str); /* free -I directories */
+ str = Nullstr;
+
+ /* do we need to emulate setuid on scripts? */
+
+ /* This code is for those BSD systems that have setuid #! scripts disabled
+ * in the kernel because of a security problem. Merely defining DOSUID
+ * in perl will not fix that problem, but if you have disabled setuid
+ * scripts in the kernel, this will attempt to emulate setuid and setgid
+ * on scripts that have those now-otherwise-useless bits set. The setuid
+ * root version must be called suidperl or sperlN.NNN. If regular perl
+ * discovers that it has opened a setuid script, it calls suidperl with
+ * the same argv that it had. If suidperl finds that the script it has
+ * just opened is NOT setuid root, it sets the effective uid back to the
+ * uid. We don't just make perl setuid root because that loses the
+ * effective uid we had before invoking perl, if it was different from the
+ * uid.
+ *
+ * DOSUID must be defined in both perl and suidperl, and IAMSUID must
+ * be defined in suidperl only. suidperl must be setuid root. The
+ * Configure script will set this up for you if you want it.
+ *
+ * There is also the possibility of have a script which is running
+ * set-id due to a C wrapper. We want to do the TAINT checks
+ * on these set-id scripts, but don't want to have the overhead of
+ * them in normal perl, and can't use suidperl because it will lose
+ * the effective uid info, so we have an additional non-setuid root
+ * version called taintperl or tperlN.NNN that just does the TAINT checks.
+ */
+
+#ifdef DOSUID
+ if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
+ fatal("Can't stat script \"%s\"",origfilename);
+ if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
+ int len;
+
+#ifdef IAMSUID
+#ifndef HAS_SETREUID
+ /* On this access check to make sure the directories are readable,
+ * there is actually a small window that the user could use to make
+ * filename point to an accessible directory. So there is a faint
+ * chance that someone could execute a setuid script down in a
+ * non-accessible directory. I don't know what to do about that.
+ * But I don't think it's too important. The manual lies when
+ * it says access() is useful in setuid programs.
+ */
+ if (access(stab_val(curcmd->c_filestab)->str_ptr,1)) /*double check*/
+ fatal("Permission denied");
+#else
+ /* If we can swap euid and uid, then we can determine access rights
+ * with a simple stat of the file, and then compare device and
+ * inode to make sure we did stat() on the same file we opened.
+ * Then we just have to make sure he or she can execute it.
+ */
+ {
+ struct stat tmpstatbuf;
+
+ if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
+ fatal("Can't swap uid and euid"); /* really paranoid */
+ if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
+ fatal("Permission denied"); /* testing full pathname here */
+ if (tmpstatbuf.st_dev != statbuf.st_dev ||
+ tmpstatbuf.st_ino != statbuf.st_ino) {
+ (void)fclose(rsfp);
+ if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */
+ fprintf(rsfp,
+"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
+(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
+ uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
+ statbuf.st_dev, statbuf.st_ino,
+ stab_val(curcmd->c_filestab)->str_ptr,
+ statbuf.st_uid, statbuf.st_gid);
+ (void)mypclose(rsfp);
+ }
+ fatal("Permission denied\n");
+ }
+ if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
+ fatal("Can't reswap uid and euid");
+ if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
+ fatal("Permission denied\n");
+ }
+#endif /* HAS_SETREUID */
+#endif /* IAMSUID */
+
+ if (!S_ISREG(statbuf.st_mode))
+ fatal("Permission denied");
+ if (statbuf.st_mode & S_IWOTH)
+ fatal("Setuid/gid script is writable by world");
+ doswitches = FALSE; /* -s is insecure in suid */
+ curcmd->c_line++;
+ if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
+ strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
+ fatal("No #! line");
+ s = tokenbuf+2;
+ if (*s == ' ') s++;
+ while (!isSPACE(*s)) s++;
+ if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
+ fatal("Not a perl script");
+ while (*s == ' ' || *s == '\t') s++;
+ /*
+ * #! arg must be what we saw above. They can invoke it by
+ * mentioning suidperl explicitly, but they may not add any strange
+ * arguments beyond what #! says if they do invoke suidperl that way.
+ */
+ len = strlen(validarg);
+ if (strEQ(validarg," PHOOEY ") ||
+ strnNE(s,validarg,len) || !isSPACE(s[len]))
+ fatal("Args must match #! line");
+
+#ifndef IAMSUID
+ if (euid != uid && (statbuf.st_mode & S_ISUID) &&
+ euid == statbuf.st_uid)
+ if (!do_undump)
+ fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
+#endif /* IAMSUID */
+
+ if (euid) { /* oops, we're not the setuid root perl */
+ (void)fclose(rsfp);
+#ifndef IAMSUID
+ (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
+ execv(buf, origargv); /* try again */
+#endif
+ fatal("Can't do setuid\n");
+ }
+
+ if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
+#ifdef HAS_SETEGID
+ (void)setegid(statbuf.st_gid);
+#else
+#ifdef HAS_SETREGID
+ (void)setregid((GIDTYPE)-1,statbuf.st_gid);
+#else
+ setgid(statbuf.st_gid);
+#endif
+#endif
+ if (statbuf.st_mode & S_ISUID) {
+ if (statbuf.st_uid != euid)
+#ifdef HAS_SETEUID
+ (void)seteuid(statbuf.st_uid); /* all that for this */
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
+#else
+ setuid(statbuf.st_uid);
+#endif
+#endif
+ }
+ else if (uid) /* oops, mustn't run as root */
+#ifdef HAS_SETEUID
+ (void)seteuid((UIDTYPE)uid);
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
+#else
+ setuid((UIDTYPE)uid);
+#endif
+#endif
+ uid = (int)getuid();
+ euid = (int)geteuid();
+ gid = (int)getgid();
+ egid = (int)getegid();
+ if (!cando(S_IXUSR,TRUE,&statbuf))
+ fatal("Permission denied\n"); /* they can't do this */
+ }
+#ifdef IAMSUID
+ else if (preprocess)
+ fatal("-P not allowed for setuid/setgid script\n");
+ else
+ fatal("Script is not setuid/setgid in suidperl\n");
+#else
+#ifndef TAINT /* we aren't taintperl or suidperl */
+ /* script has a wrapper--can't run suidperl or we lose euid */
+ else if (euid != uid || egid != gid) {
+ (void)fclose(rsfp);
+ (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
+ execv(buf, origargv); /* try again */
+ fatal("Can't run setuid script with taint checks");
+ }
+#endif /* TAINT */
+#endif /* IAMSUID */
+#else /* !DOSUID */
+#ifndef TAINT /* we aren't taintperl or suidperl */
+ 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 */
+ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
+ ||
+ (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
+ )
+ if (!do_undump)
+ fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
+#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
+ /* not set-id, must be wrapped */
+ (void)fclose(rsfp);
+ (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
+ execv(buf, origargv); /* try again */
+ fatal("Can't run setuid script with taint checks");
+ }
+#endif /* TAINT */
+#endif /* DOSUID */
+
+#if !defined(IAMSUID) && !defined(TAINT)
+
+ /* skip forward in input to the real script? */
+
+ while (doextract) {
+ if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
+ fatal("No Perl script found in input\n");
+ if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
+ ungetc('\n',rsfp); /* to keep line count right */
+ doextract = FALSE;
+ if (s = instr(s,"perl -")) {
+ s += 6;
+ /*SUPPRESS 530*/
+ while (s = moreswitches(s)) ;
+ }
+ if (cddir && chdir(cddir) < 0)
+ fatal("Can't chdir to %s",cddir);
+ }
+ }
+#endif /* !defined(IAMSUID) && !defined(TAINT) */
+
+ defstab = stabent("_",TRUE);
+
+ subname = str_make("main",4);
+ if (perldb) {
+ debstash = hnew(0);
+ stab_xhash(stabent("_DB",TRUE)) = debstash;
+ curstash = debstash;
+ dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
+ tmpstab->str_pok |= SP_MULTI;
+ dbargs->ary_flags = 0;
+ DBstab = stabent("DB",TRUE);
+ DBstab->str_pok |= SP_MULTI;
+ DBline = stabent("dbline",TRUE);
+ DBline->str_pok |= SP_MULTI;
+ DBsub = hadd(tmpstab = stabent("sub",TRUE));
+ tmpstab->str_pok |= SP_MULTI;
+ DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
+ tmpstab->str_pok |= SP_MULTI;
+ DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
+ tmpstab->str_pok |= SP_MULTI;
+ DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
+ tmpstab->str_pok |= SP_MULTI;
+ curstash = defstash;
+ }
+
+ /* init tokener */
+
+ bufend = bufptr = str_get(linestr);
+
+ savestack = anew(Nullstab); /* for saving non-local values */
+ stack = anew(Nullstab); /* for saving non-local values */
+ stack->ary_flags = 0; /* not a real array */
+ afill(stack,63); afill(stack,-1); /* preextend stack */
+ afill(savestack,63); afill(savestack,-1);
+
+ /* now parse the script */
+
+ error_count = 0;
+ if (yyparse() || error_count) {
+ if (minus_c)
+ fatal("%s had compilation errors.\n", origfilename);
+ else {
+ fatal("Execution of %s aborted due to compilation errors.\n",
+ origfilename);
+ }
+ }
+
+ New(50,loop_stack,128,struct loop);
+#ifdef DEBUGGING
+ if (debug) {
+ New(51,debname,128,char);
+ New(52,debdelim,128,char);
+ }
+#endif
+ curstash = defstash;
+
+ preprocess = FALSE;
+ if (e_fp) {
+ e_fp = Nullfp;
+ (void)UNLINK(e_tmpname);
+ }
+
+ /* initialize everything that won't change if we undump */
+
+ if (sigstab = stabent("SIG",allstabs)) {
+ sigstab->str_pok |= SP_MULTI;
+ (void)hadd(sigstab);
+ }
+
+ magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
+ userinit(); /* in case linked C routines want magical variables */
+
+ amperstab = stabent("&",allstabs);
+ leftstab = stabent("`",allstabs);
+ rightstab = stabent("'",allstabs);
+ sawampersand = (amperstab || leftstab || rightstab);
+ if (tmpstab = stabent(":",allstabs))
+ str_set(STAB_STR(tmpstab),chopset);
+ if (tmpstab = stabent("\024",allstabs))
+ time(&basetime);
+
+ /* these aren't necessarily magical */
+ if (tmpstab = stabent(";",allstabs))
+ str_set(STAB_STR(tmpstab),"\034");
+ if (tmpstab = stabent("]",allstabs)) {
+ str = STAB_STR(tmpstab);
+ str_set(str,rcsid);
+ str->str_u.str_nval = atof(patchlevel);
+ str->str_nok = 1;
+ }
+ str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
+
+ stdinstab = stabent("STDIN",TRUE);
+ stdinstab->str_pok |= SP_MULTI;
+ stab_io(stdinstab) = stio_new();
+ stab_io(stdinstab)->ifp = stdin;
+ tmpstab = stabent("stdin",TRUE);
+ stab_io(tmpstab) = stab_io(stdinstab);
+ tmpstab->str_pok |= SP_MULTI;
+
+ tmpstab = stabent("STDOUT",TRUE);
+ tmpstab->str_pok |= SP_MULTI;
+ stab_io(tmpstab) = stio_new();
+ stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
+ defoutstab = tmpstab;
+ tmpstab = stabent("stdout",TRUE);
+ stab_io(tmpstab) = stab_io(defoutstab);
+ tmpstab->str_pok |= SP_MULTI;
+
+ curoutstab = stabent("STDERR",TRUE);
+ curoutstab->str_pok |= SP_MULTI;
+ stab_io(curoutstab) = stio_new();
+ stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
+ tmpstab = stabent("stderr",TRUE);
+ stab_io(tmpstab) = stab_io(curoutstab);
+ tmpstab->str_pok |= SP_MULTI;
+ curoutstab = defoutstab; /* switch back to STDOUT */
+
+ statname = Str_new(66,0); /* last filename we did stat on */
+
+ /* now that script is parsed, we can modify record separator */
+
+ rs = nrs;
+ rslen = nrslen;
+ rschar = nrschar;
+ str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
+
+ if (do_undump)
+ my_unexec();
+
+ just_doit: /* come here if running an undumped a.out */
+ argc--,argv++; /* skip name of script */
+ if (doswitches) {
+ for (; argc > 0 && **argv == '-'; argc--,argv++) {
+ if (argv[0][1] == '-') {
+ argc--,argv++;
+ break;
+ }
+ if (s = index(argv[0], '=')) {
+ *s++ = '\0';
+ str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
+ }
+ else
+ str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
+ }
+ }
+#ifdef TAINT
+ tainted = 1;
+#endif
+ if (tmpstab = stabent("0",allstabs)) {
+ str_set(stab_val(tmpstab),origfilename);
+ magicname("0", Nullch, 0);
+ }
+ if (tmpstab = stabent("\030",allstabs))
+ str_set(stab_val(tmpstab),origargv[0]);
+ if (argvstab = stabent("ARGV",allstabs)) {
+ argvstab->str_pok |= SP_MULTI;
+ (void)aadd(argvstab);
+ aclear(stab_array(argvstab));
+ for (; argc > 0; argc--,argv++) {
+ (void)apush(stab_array(argvstab),str_make(argv[0],0));
+ }
+ }
+#ifdef TAINT
+ (void) stabent("ENV",TRUE); /* must test PATH and IFS */
+#endif
+ if (envstab = stabent("ENV",allstabs)) {
+ envstab->str_pok |= SP_MULTI;
+ (void)hadd(envstab);
+ hclear(stab_hash(envstab), FALSE);
+ if (env != environ)
+ environ[0] = Nullch;
+ for (; *env; env++) {
+ if (!(s = index(*env,'=')))
+ continue;
+ *s++ = '\0';
+ str = str_make(s--,0);
+ str_magic(str, envstab, 'E', *env, s - *env);
+ (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
+ *s = '=';
+ }
+ }
+#ifdef TAINT
+ tainted = 0;
+#endif
+ if (tmpstab = stabent("$",allstabs))
+ str_numset(STAB_STR(tmpstab),(double)getpid());
+
+ if (dowarn) {
+ stab_check('A','Z');
+ stab_check('a','z');
+ }
+
+ if (setjmp(top_env)) /* sets goto_targ on longjump */
+ loop_ptr = -1; /* start label stack again */
+
+#ifdef DEBUGGING
+ if (debug & 1024)
+ dump_all();
+ if (debug)
+ fprintf(stderr,"\nEXECUTING...\n\n");
+#endif
+
+ if (minus_c) {
+ fprintf(stderr,"%s syntax OK\n", origfilename);
+ exit(0);
+ }
+
+ /* do it */
+
+ (void) cmd_exec(main_root,G_SCALAR,-1);
+
+ if (goto_targ)
+ fatal("Can't find label \"%s\"--aborting",goto_targ);
+ exit(0);
+ /* NOTREACHED */
+}
+
+void
+magicalize(list)
+register char *list;
+{
+ char sym[2];
+
+ sym[1] = '\0';
+ while (*sym = *list++)
+ magicname(sym, Nullch, 0);
+}
+
+void
+magicname(sym,name,namlen)
+char *sym;
+char *name;
+int namlen;
+{
+ register STAB *stab;
+
+ if (stab = stabent(sym,allstabs)) {
+ stab_flags(stab) = SF_VMAGIC;
+ str_magic(stab_val(stab), stab, 0, name, namlen);
+ }
+}
+
+void
+savelines(array, str)
+ARRAY *array;
+STR *str;
+{
+ register char *s = str->str_ptr;
+ register char *send = str->str_ptr + str->str_cur;
+ register char *t;
+ register int line = 1;
+
+ while (s && s < send) {
+ STR *tmpstr = Str_new(85,0);
+
+ t = index(s, '\n');
+ if (t)
+ t++;
+ else
+ t = send;
+
+ str_nset(tmpstr, s, t - s);
+ astore(array, line++, tmpstr);
+ s = t;
+ }
+}
+
+/* this routine is in perl.c by virtue of being sort of an alternate main() */
+
+int
+do_eval(str,optype,stash,savecmd,gimme,arglast)
+STR *str;
+int optype;
+HASH *stash;
+int savecmd;
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+ int retval;
+ CMD *myroot = Nullcmd;
+ ARRAY *ar;
+ int i;
+ CMD * VOLATILE oldcurcmd = curcmd;
+ VOLATILE int oldtmps_base = tmps_base;
+ VOLATILE int oldsave = savestack->ary_fill;
+ VOLATILE int oldperldb = perldb;
+ SPAT * VOLATILE oldspat = curspat;
+ SPAT * VOLATILE oldlspat = lastspat;
+ static char *last_eval = Nullch;
+ static long last_elen = 0;
+ static CMD *last_root = Nullcmd;
+ VOLATILE int sp = arglast[0];
+ char *specfilename;
+ char *tmpfilename;
+ int parsing = 1;
+
+ tmps_base = tmps_max;
+ if (curstash != stash) {
+ (void)savehptr(&curstash);
+ curstash = stash;
+ }
+ str_set(stab_val(stabent("@",TRUE)),"");
+ if (curcmd->c_line == 0) /* don't debug debugger... */
+ perldb = FALSE;
+ curcmd = &compiling;
+ if (optype == O_EVAL) { /* normal eval */
+ curcmd->c_filestab = fstab("(eval)");
+ curcmd->c_line = 1;
+ str_sset(linestr,str);
+ str_cat(linestr,";\n"); /* be kind to them */
+ if (perldb)
+ savelines(stab_xarray(curcmd->c_filestab), linestr);
+ }
+ else {
+ if (last_root && !in_eval) {
+ Safefree(last_eval);
+ last_eval = Nullch;
+ cmd_free(last_root);
+ last_root = Nullcmd;
+ }
+ specfilename = str_get(str);
+ str_set(linestr,"");
+ if (optype == O_REQUIRE && &str_undef !=
+ hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
+ curcmd = oldcurcmd;
+ tmps_base = oldtmps_base;
+ st[++sp] = &str_yes;
+ perldb = oldperldb;
+ return sp;
+ }
+ tmpfilename = savestr(specfilename);
+ if (index("/.", *tmpfilename))
+ rsfp = fopen(tmpfilename,"r");
+ else {
+ ar = stab_array(incstab);
+ for (i = 0; i <= ar->ary_fill; i++) {
+ (void)sprintf(buf, "%s/%s",
+ str_get(afetch(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->c_filestab = fstab(tmpfilename);
+ Safefree(tmpfilename);
+ tmpfilename = Nullch;
+ if (!rsfp) {
+ curcmd = oldcurcmd;
+ tmps_base = oldtmps_base;
+ if (optype == O_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] = &str_undef;
+ perldb = oldperldb;
+ return sp;
+ }
+ curcmd->c_line = 0;
+ }
+ in_eval++;
+ oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
+ bufend = bufptr + linestr->str_cur;
+ if (++loop_ptr >= loop_max) {
+ loop_max += 128;
+ Renew(loop_stack, loop_max, struct loop);
+ }
+ loop_stack[loop_ptr].loop_label = "_EVAL_";
+ loop_stack[loop_ptr].loop_sp = sp;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
+ }
+#endif
+ eval_root = Nullcmd;
+ if (setjmp(loop_stack[loop_ptr].loop_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;
+ cmd_free(last_root);
+ }
+ last_root = Nullcmd;
+ 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 cmd_exec does another eval! */
+
+ if (retval) {
+ st = stack->ary_array;
+ sp = arglast[0];
+ if (gimme != G_ARRAY)
+ st[++sp] = &str_undef;
+ if (parsing) {
+#ifndef MANGLEDPARSE
+#ifdef DEBUGGING
+ if (debug & 128)
+ fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
+#endif
+ cmd_free(eval_root);
+#endif
+ if ((CMD*)eval_root == last_root)
+ last_root = Nullcmd;
+ eval_root = myroot = Nullcmd;
+ }
+ if (rsfp) {
+ fclose(rsfp);
+ rsfp = 0;
+ }
+ }
+ else {
+ parsing = 0;
+ sp = cmd_exec(eval_root,gimme,sp);
+ st = stack->ary_array;
+ for (i = arglast[0] + 1; i <= sp; i++)
+ st[i] = str_mortal(st[i]);
+ /* if we don't save result, free zaps it */
+ if (savecmd)
+ eval_root = myroot;
+ else if (in_eval != 1 && myroot != last_root)
+ cmd_free(myroot);
+ }
+
+ perldb = oldperldb;
+ in_eval--;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ char *tmps = loop_stack[loop_ptr].loop_label;
+ deb("(Popping label #%d %s)\n",loop_ptr,
+ tmps ? tmps : "" );
+ }
+#endif
+ loop_ptr--;
+ tmps_base = oldtmps_base;
+ curspat = oldspat;
+ lastspat = oldlspat;
+ if (savestack->ary_fill > oldsave) /* let them use local() */
+ restorelist(oldsave);
+
+ if (optype != O_EVAL) {
+ if (retval) {
+ if (optype == O_REQUIRE)
+ fatal("%s", str_get(stab_val(stabent("@",TRUE))));
+ }
+ else {
+ curcmd = oldcurcmd;
+ if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
+ (void)hstore(stab_hash(incstab), specfilename,
+ strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
+ 0 );
+ }
+ else if (optype == O_REQUIRE)
+ fatal("%s did not return a true value", specfilename);
+ }
+ }
+ curcmd = oldcurcmd;
+ return sp;
+}
+
+int
+do_try(cmd,gimme,arglast)
+CMD *cmd;
+int gimme;
+int *arglast;
+{
+ STR **st = stack->ary_array;
+
+ CMD * VOLATILE oldcurcmd = curcmd;
+ VOLATILE int oldtmps_base = tmps_base;
+ VOLATILE int oldsave = savestack->ary_fill;
+ SPAT * VOLATILE oldspat = curspat;
+ SPAT * VOLATILE oldlspat = lastspat;
+ VOLATILE int sp = arglast[0];
+
+ tmps_base = tmps_max;
+ str_set(stab_val(stabent("@",TRUE)),"");
+ in_eval++;
+ if (++loop_ptr >= loop_max) {
+ loop_max += 128;
+ Renew(loop_stack, loop_max, struct loop);
+ }
+ loop_stack[loop_ptr].loop_label = "_EVAL_";
+ loop_stack[loop_ptr].loop_sp = sp;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
+ }
+#endif
+ if (setjmp(loop_stack[loop_ptr].loop_env)) {
+ st = stack->ary_array;
+ sp = arglast[0];
+ if (gimme != G_ARRAY)
+ st[++sp] = &str_undef;
+ }
+ else {
+ sp = cmd_exec(cmd,gimme,sp);
+ st = stack->ary_array;
+/* for (i = arglast[0] + 1; i <= sp; i++)
+ st[i] = str_mortal(st[i]); not needed, I think */
+ /* if we don't save result, free zaps it */
+ }
+
+ in_eval--;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ char *tmps = loop_stack[loop_ptr].loop_label;
+ deb("(Popping label #%d %s)\n",loop_ptr,
+ tmps ? tmps : "" );
+ }
+#endif
+ loop_ptr--;
+ tmps_base = oldtmps_base;
+ curspat = oldspat;
+ lastspat = oldlspat;
+ curcmd = oldcurcmd;
+ if (savestack->ary_fill > oldsave) /* let them use local() */
+ restorelist(oldsave);
+
+ return sp;
+}
+
+/* This routine handles any switches that can be given during run */
+
+static char *
+moreswitches(s)
+char *s;
+{
+ int numlen;
+
+ switch (*s) {
+ case '0':
+ nrschar = scanoct(s, 4, &numlen);
+ nrs = nsavestr("\n",1);
+ *nrs = nrschar;
+ if (nrschar > 0377) {
+ nrslen = 0;
+ nrs = "";
+ }
+ else if (!nrschar && numlen >= 2) {
+ nrslen = 2;
+ nrs = "\n\n";
+ nrschar = '\n';
+ }
+ return s + numlen;
+ case 'a':
+ minus_a = TRUE;
+ s++;
+ return s;
+ case 'c':
+ minus_c = TRUE;
+ s++;
+ return s;
+ case 'd':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -d allowed in setuid scripts");
+#endif
+ perldb = TRUE;
+ s++;
+ return s;
+ case 'D':
+#ifdef DEBUGGING
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -D allowed in setuid scripts");
+#endif
+ debug = atoi(s+1) | 32768;
+#else
+ warn("Recompile perl with -DDEBUGGING to use -D switch\n");
+#endif
+ /*SUPPRESS 530*/
+ for (s++; isDIGIT(*s); s++) ;
+ return s;
+ case 'i':
+ inplace = savestr(s+1);
+ /*SUPPRESS 530*/
+ for (s = inplace; *s && !isSPACE(*s); s++) ;
+ *s = '\0';
+ break;
+ case 'I':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -I allowed in setuid scripts");
+#endif
+ if (*++s) {
+ (void)apush(stab_array(incstab),str_make(s,0));
+ }
+ else
+ fatal("No space allowed after -I");
+ break;
+ case 'l':
+ minus_l = TRUE;
+ s++;
+ if (isDIGIT(*s)) {
+ ors = savestr("\n");
+ orslen = 1;
+ *ors = scanoct(s, 3 + (*s == '0'), &numlen);
+ s += numlen;
+ }
+ else {
+ ors = nsavestr(nrs,nrslen);
+ orslen = nrslen;
+ }
+ return s;
+ case 'n':
+ minus_n = TRUE;
+ s++;
+ return s;
+ case 'p':
+ minus_p = TRUE;
+ s++;
+ return s;
+ case 'u':
+ do_undump = TRUE;
+ s++;
+ return s;
+ case 'U':
+ unsafe = TRUE;
+ s++;
+ return s;
+ case 'v':
+ fputs("\nThis is perl, version 4.0\n\n",stdout);
+ fputs(rcsid,stdout);
+ fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
+#ifdef MSDOS
+ fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
+ stdout);
+#ifdef OS2
+ fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n",
+ stdout);
+#endif
+#endif
+ fputs("\n\
+Perl may be copied only under the terms of either the Artistic License or the\n\
+GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
+#ifdef MSDOS
+ usage(origargv[0]);
+#endif
+ exit(0);
+ case 'w':
+ dowarn = TRUE;
+ s++;
+ return s;
+ case ' ':
+ case '\n':
+ case '\t':
+ break;
+ default:
+ fatal("Switch meaningless after -x: -%s",s);
+ }
+ return Nullch;
+}
+
+/* compliments of Tom Christiansen */
+
+/* unexec() can be found in the Gnu emacs distribution */
+
+my_unexec()
+{
+#ifdef UNEXEC
+ int status;
+ extern int etext;
+ static char dumpname[BUFSIZ];
+ static char perlpath[256];
+
+ sprintf (dumpname, "%s.perldump", origfilename);
+ sprintf (perlpath, "%s/perl", BIN);
+
+ status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
+ if (status)
+ fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
+ exit(status);
+#else
+#ifdef MSDOS
+ abort(); /* nothing else to do */
+#else /* ! MSDOS */
+# ifndef SIGABRT
+# define SIGABRT SIGILL
+# endif
+# ifndef SIGILL
+# define SIGILL 6 /* blech */
+# endif
+ kill(getpid(),SIGABRT); /* for use with undump */
+#endif /* ! MSDOS */
+#endif
+}
+
--- /dev/null
+/* $RCSfile: perl.h,v $$Revision: 4.0.1.5 $$Date: 91/11/11 16:41:07 $
+ *
+ * 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: perl.h,v $
+ * 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.
+ *
+ */
+
+#define VOIDWANT 1
+#include "config.h"
+
+#ifdef MYMALLOC
+# ifdef HIDEMYMALLOC
+# define malloc Mymalloc
+# define realloc Myremalloc
+# define free Myfree
+# endif
+# define safemalloc malloc
+# define saferealloc realloc
+# define safefree free
+#endif
+
+/* work around some libPW problems */
+#define fatal Myfatal
+#ifdef DOINIT
+char Error[1];
+#endif
+
+#ifdef MSDOS
+/* This stuff now in the MS-DOS config.h file. */
+#else /* !MSDOS */
+
+/*
+ * The following symbols are defined if your operating system supports
+ * functions by that name. All Unixes I know of support them, thus they
+ * are not checked by the configuration script, but are directly defined
+ * here.
+ */
+#define HAS_ALARM
+#define HAS_CHOWN
+#define HAS_CHROOT
+#define HAS_FORK
+#define HAS_GETLOGIN
+#define HAS_GETPPID
+#define HAS_KILL
+#define HAS_LINK
+#define HAS_PIPE
+#define HAS_WAIT
+#define HAS_UMASK
+/*
+ * The following symbols are defined if your operating system supports
+ * password and group functions in general. All Unix systems do.
+ */
+#define HAS_GROUP
+#define HAS_PASSWD
+
+#endif /* !MSDOS */
+
+#if defined(__STDC__) || defined(_AIX) || defined(__stdc__)
+# define STANDARD_C 1
+#endif
+
+#if defined(HASVOLATILE) || defined(STANDARD_C)
+#define VOLATILE volatile
+#else
+#define VOLATILE
+#endif
+
+#ifdef IAMSUID
+# ifndef TAINT
+# define TAINT
+# endif
+#endif
+
+#ifndef HAS_VFORK
+# define vfork fork
+#endif
+
+#ifdef HAS_GETPGRP2
+# ifndef HAS_GETPGRP
+# define HAS_GETPGRP
+# endif
+# define getpgrp getpgrp2
+#endif
+
+#ifdef HAS_SETPGRP2
+# ifndef HAS_SETPGRP
+# define HAS_SETPGRP
+# endif
+# define setpgrp setpgrp2
+#endif
+
+#include <stdio.h>
+#include <ctype.h>
+#include <setjmp.h>
+#ifndef MSDOS
+#ifdef PARAM_NEEDS_TYPES
+#include <sys/types.h>
+#endif
+#include <sys/param.h>
+#endif
+#ifdef STANDARD_C
+/* Use all the "standard" definitions */
+#include <stdlib.h>
+#include <string.h>
+#endif /* STANDARD_C */
+
+#if defined(HAS_MEMCMP) && defined(mips) && BYTEORDER == 0x1234
+#undef HAS_MEMCMP
+#endif
+
+#ifdef HAS_MEMCPY
+
+# ifndef STANDARD_C
+# ifndef memcpy
+extern char * memcpy(), *memset();
+extern int memcmp();
+# endif /* ndef memcpy */
+# endif /* ndef STANDARD_C */
+
+# ifndef bcopy
+# define bcopy(s1,s2,l) memcpy(s2,s1,l)
+# endif
+# ifndef bzero
+# define bzero(s,l) memset(s,0,l)
+# endif
+#endif /* HAS_MEMCPY */
+
+#ifndef HAS_BCMP /* prefer bcmp slightly 'cuz it doesn't order */
+# ifndef bcmp
+# define bcmp(s1,s2,l) memcmp(s1,s2,l)
+# endif
+#endif
+
+#ifndef _TYPES_ /* If types.h defines this it's easy. */
+#ifndef major /* Does everyone's types.h define this? */
+#include <sys/types.h>
+#endif
+#endif
+
+#ifdef I_NETINET_IN
+#include <netinet/in.h>
+#endif
+
+#include <sys/stat.h>
+#ifdef uts
+#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)
+#define S_ISLNK(P) (((P)&S_IFMT)==S_IFLNK)
+#endif
+
+#ifdef I_TIME
+# include <time.h>
+#endif
+
+#ifdef I_SYS_TIME
+# ifdef SYSTIMEKERNEL
+# define KERNEL
+# endif
+# include <sys/time.h>
+# ifdef SYSTIMEKERNEL
+# undef KERNEL
+# endif
+#endif
+
+#ifndef MSDOS
+#include <sys/times.h>
+#endif
+
+#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR))
+#undef HAS_STRERROR
+#endif
+
+#include <errno.h>
+#ifndef MSDOS
+#ifndef errno
+extern int errno; /* ANSI allows errno to be an lvalue expr */
+#endif
+#endif
+
+#ifndef strerror
+#ifdef HAS_STRERROR
+char *strerror();
+#else
+extern int sys_nerr;
+extern char *sys_errlist[];
+#define strerror(e) ((e) < 0 || (e) >= sys_nerr ? "(unknown)" : sys_errlist[e])
+#endif
+#endif
+
+#ifdef I_SYSIOCTL
+#ifndef _IOCTL_
+#include <sys/ioctl.h>
+#endif
+#endif
+
+#if defined(mc300) || defined(mc500) || defined(mc700) /* MASSCOMP */
+#ifdef HAS_SOCKETPAIR
+#undef HAS_SOCKETPAIR
+#endif
+#ifdef HAS_NDBM
+#undef HAS_NDBM
+#endif
+#endif
+
+#ifdef WANT_DBZ
+#include <dbz.h>
+#define SOME_DBM
+#define dbm_fetch(db,dkey) fetch(dkey)
+#define dbm_delete(db,dkey) fatal("dbz doesn't implement delete")
+#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent)
+#define dbm_close(db) dbmclose()
+#define dbm_firstkey(db) (fatal("dbz doesn't implement traversal"),fetch())
+#define nextkey() (fatal("dbz doesn't implement traversal"),fetch())
+#define dbm_nextkey(db) (fatal("dbz doesn't implement traversal"),fetch())
+#ifdef HAS_NDBM
+#undef HAS_NDBM
+#endif
+#ifndef HAS_ODBM
+#define HAS_ODBM
+#endif
+#else
+#ifdef HAS_GDBM
+#ifdef I_GDBM
+#include <gdbm.h>
+#endif
+#define SOME_DBM
+#ifdef HAS_NDBM
+#undef HAS_NDBM
+#endif
+#ifdef HAS_ODBM
+#undef HAS_ODBM
+#endif
+#else
+#ifdef HAS_NDBM
+#include <ndbm.h>
+#define SOME_DBM
+#ifdef HAS_ODBM
+#undef HAS_ODBM
+#endif
+#else
+#ifdef HAS_ODBM
+#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 /* HAS_ODBM */
+#endif /* HAS_NDBM */
+#endif /* HAS_GDBM */
+#endif /* WANT_DBZ */
+#ifdef SOME_DBM
+EXT char *dbmkey;
+EXT int dbmlen;
+#endif
+
+#if INTSIZE == 2
+#define htoni htons
+#define ntohi ntohs
+#else
+#define htoni htonl
+#define ntohi ntohl
+#endif
+
+#if defined(I_DIRENT)
+# include <dirent.h>
+# define DIRENT dirent
+#else
+# ifdef I_SYS_NDIR
+# include <sys/ndir.h>
+# define DIRENT direct
+# else
+# ifdef I_SYS_DIR
+# ifdef hp9000s500
+# include <ndir.h> /* may be wrong in the future */
+# else
+# include <sys/dir.h>
+# endif
+# define DIRENT direct
+# endif
+# endif
+#endif
+
+#ifdef FPUTS_BOTCH
+/* work around botch in SunOS 4.0.1 and 4.0.2 */
+# ifndef fputs
+# define fputs(str,fp) fprintf(fp,"%s",str)
+# endif
+#endif
+
+/*
+ * The following gobbledygook brought to you on behalf of __STDC__.
+ * (I could just use #ifndef __STDC__, but this is more bulletproof
+ * in the face of half-implementations.)
+ */
+
+#ifndef S_IFMT
+# ifdef _S_IFMT
+# define S_IFMT _S_IFMT
+# else
+# define S_IFMT 0170000
+# endif
+#endif
+
+#ifndef S_ISDIR
+# define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR)
+#endif
+
+#ifndef S_ISCHR
+# define S_ISCHR(m) ((m & S_IFMT) == S_IFCHR)
+#endif
+
+#ifndef S_ISBLK
+# ifdef S_IFBLK
+# define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK)
+# else
+# define S_ISBLK(m) (0)
+# endif
+#endif
+
+#ifndef S_ISREG
+# define S_ISREG(m) ((m & S_IFMT) == S_IFREG)
+#endif
+
+#ifndef S_ISFIFO
+# ifdef S_IFIFO
+# define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO)
+# else
+# define S_ISFIFO(m) (0)
+# endif
+#endif
+
+#ifndef S_ISLNK
+# ifdef _S_ISLNK
+# define S_ISLNK(m) _S_ISLNK(m)
+# else
+# ifdef _S_IFLNK
+# define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK)
+# else
+# ifdef S_IFLNK
+# define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK)
+# else
+# define S_ISLNK(m) (0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef S_ISSOCK
+# ifdef _S_ISSOCK
+# define S_ISSOCK(m) _S_ISSOCK(m)
+# else
+# ifdef _S_IFSOCK
+# define S_ISSOCK(m) ((m & S_IFMT) == _S_IFSOCK)
+# else
+# ifdef S_IFSOCK
+# define S_ISSOCK(m) ((m & S_IFMT) == S_IFSOCK)
+# else
+# define S_ISSOCK(m) (0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef S_IRUSR
+# ifdef S_IREAD
+# define S_IRUSR S_IREAD
+# define S_IWUSR S_IWRITE
+# define S_IXUSR S_IEXEC
+# else
+# define S_IRUSR 0400
+# define S_IWUSR 0200
+# define S_IXUSR 0100
+# endif
+# define S_IRGRP (S_IRUSR>>3)
+# define S_IWGRP (S_IWUSR>>3)
+# define S_IXGRP (S_IXUSR>>3)
+# define S_IROTH (S_IRUSR>>6)
+# define S_IWOTH (S_IWUSR>>6)
+# define S_IXOTH (S_IXUSR>>6)
+#endif
+
+#ifndef S_ISUID
+# define S_ISUID 04000
+#endif
+
+#ifndef S_ISGID
+# define S_ISGID 02000
+#endif
+
+#ifdef f_next
+#undef f_next
+#endif
+
+#if defined(cray) || defined(gould)
+# define SLOPPYDIVIDE
+#endif
+
+#if defined(cray) || defined(convex) || defined (uts) || BYTEORDER > 0xffff
+# define QUAD
+#endif
+
+#ifdef QUAD
+# ifdef cray
+# define quad int
+# else
+# if defined(convex) || defined (uts)
+# define quad long long
+# else
+# define quad long
+# endif
+# endif
+#endif
+
+typedef unsigned int STRLEN;
+
+typedef struct arg ARG;
+typedef struct cmd CMD;
+typedef struct formcmd FCMD;
+typedef struct scanpat SPAT;
+typedef struct stio STIO;
+typedef struct sub SUBR;
+typedef struct string STR;
+typedef struct atbl ARRAY;
+typedef struct htbl HASH;
+typedef struct regexp REGEXP;
+typedef struct stabptrs STBP;
+typedef struct stab STAB;
+typedef struct callsave CSV;
+
+#include "handy.h"
+#include "regexp.h"
+#include "str.h"
+#include "util.h"
+#include "form.h"
+#include "stab.h"
+#include "spat.h"
+#include "arg.h"
+#include "cmd.h"
+#include "array.h"
+#include "hash.h"
+
+#if defined(iAPX286) || defined(M_I286) || defined(I80286)
+# define I286
+#endif
+
+#ifndef STANDARD_C
+#ifdef CHARSPRINTF
+ char *sprintf();
+#else
+ int sprintf();
+#endif
+#endif
+
+EXT char *Yes INIT("1");
+EXT char *No INIT("");
+
+/* "gimme" values */
+
+/* Note: cmd.c assumes that it can use && to produce one of these values! */
+#define G_SCALAR 0
+#define G_ARRAY 1
+
+#ifdef CRIPPLED_CC
+int str_true();
+#else /* !CRIPPLED_CC */
+#define str_true(str) (Str = (str), \
+ (Str->str_pok ? \
+ ((*Str->str_ptr > '0' || \
+ Str->str_cur > 1 || \
+ (Str->str_cur && *Str->str_ptr != '0')) ? 1 : 0) \
+ : \
+ (Str->str_nok ? (Str->str_u.str_nval != 0.0) : 0 ) ))
+#endif /* CRIPPLED_CC */
+
+#ifdef DEBUGGING
+#define str_peek(str) (Str = (str), \
+ (Str->str_pok ? \
+ Str->str_ptr : \
+ (Str->str_nok ? \
+ (sprintf(tokenbuf,"num(%g)",Str->str_u.str_nval), \
+ (char*)tokenbuf) : \
+ "" )))
+#endif
+
+#ifdef CRIPPLED_CC
+char *str_get();
+#else
+#ifdef TAINT
+#define str_get(str) (Str = (str), tainted |= Str->str_tainted, \
+ (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
+#else
+#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
+#endif /* TAINT */
+#endif /* CRIPPLED_CC */
+
+#ifdef CRIPPLED_CC
+double str_gnum();
+#else /* !CRIPPLED_CC */
+#ifdef TAINT
+#define str_gnum(str) (Str = (str), tainted |= Str->str_tainted, \
+ (Str->str_nok ? Str->str_u.str_nval : str_2num(Str)))
+#else /* !TAINT */
+#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_u.str_nval : str_2num(Str)))
+#endif /* TAINT*/
+#endif /* CRIPPLED_CC */
+EXT STR *Str;
+
+#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
+
+#ifndef MSDOS
+#define STR_GROW(str,len) if ((str)->str_len < (len)) str_grow(str,len)
+#define Str_Grow str_grow
+#else
+/* extra parentheses intentionally NOT placed around "len"! */
+#define STR_GROW(str,len) if ((str)->str_len < (unsigned long)len) \
+ str_grow(str,(unsigned long)len)
+#define Str_Grow(str,len) str_grow(str,(unsigned long)(len))
+#endif /* MSDOS */
+
+#ifndef BYTEORDER
+#define BYTEORDER 0x1234
+#endif
+
+#if defined(htonl) && !defined(HAS_HTONL)
+#define HAS_HTONL
+#endif
+#if defined(htons) && !defined(HAS_HTONS)
+#define HAS_HTONS
+#endif
+#if defined(ntohl) && !defined(HAS_NTOHL)
+#define HAS_NTOHL
+#endif
+#if defined(ntohs) && !defined(HAS_NTOHS)
+#define HAS_NTOHS
+#endif
+#ifndef HAS_HTONL
+#if (BYTEORDER & 0xffff) != 0x4321
+#define HAS_HTONS
+#define HAS_HTONL
+#define HAS_NTOHS
+#define HAS_NTOHL
+#define MYSWAP
+#define htons my_swap
+#define htonl my_htonl
+#define ntohs my_swap
+#define ntohl my_ntohl
+#endif
+#else
+#if (BYTEORDER & 0xffff) == 0x4321
+#undef HAS_HTONS
+#undef HAS_HTONL
+#undef HAS_NTOHS
+#undef HAS_NTOHL
+#endif
+#endif
+
+/*
+ * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
+ * -DWS
+ */
+#if BYTEORDER != 0x1234
+# define HAS_VTOHL
+# define HAS_VTOHS
+# define HAS_HTOVL
+# define HAS_HTOVS
+# if BYTEORDER == 0x4321
+# define vtohl(x) ((((x)&0xFF)<<24) \
+ +(((x)>>24)&0xFF) \
+ +(((x)&0x0000FF00)<<8) \
+ +(((x)&0x00FF0000)>>8) )
+# define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF))
+# define htovl(x) vtohl(x)
+# define htovs(x) vtohs(x)
+# endif
+ /* otherwise default to functions in util.c */
+#endif
+
+#ifdef CASTNEGFLOAT
+#define U_S(what) ((unsigned short)(what))
+#define U_I(what) ((unsigned int)(what))
+#define U_L(what) ((unsigned long)(what))
+#else
+unsigned long castulong();
+#define U_S(what) ((unsigned int)castulong(what))
+#define U_I(what) ((unsigned int)castulong(what))
+#define U_L(what) (castulong(what))
+#endif
+
+CMD *add_label();
+CMD *block_head();
+CMD *append_line();
+CMD *make_acmd();
+CMD *make_ccmd();
+CMD *make_icmd();
+CMD *invert();
+CMD *addcond();
+CMD *addloop();
+CMD *wopt();
+CMD *over();
+
+STAB *stabent();
+STAB *genstab();
+
+ARG *stab2arg();
+ARG *op_new();
+ARG *make_op();
+ARG *make_match();
+ARG *make_split();
+ARG *rcatmaybe();
+ARG *listish();
+ARG *maybelistish();
+ARG *localize();
+ARG *fixeval();
+ARG *jmaybe();
+ARG *l();
+ARG *fixl();
+ARG *mod_match();
+ARG *make_list();
+ARG *cmd_to_arg();
+ARG *addflags();
+ARG *hide_ary();
+ARG *cval_to_arg();
+
+STR *str_new();
+STR *stab_str();
+
+int do_each();
+int do_subr();
+int do_match();
+int do_unpack();
+int eval(); /* this evaluates expressions */
+int do_eval(); /* this evaluates eval operator */
+int do_assign();
+
+SUBR *make_sub();
+
+FCMD *load_format();
+
+char *scanpat();
+char *scansubst();
+char *scantrans();
+char *scanstr();
+char *scanident();
+char *str_append_till();
+char *str_gets();
+char *str_grow();
+
+bool do_open();
+bool do_close();
+bool do_print();
+bool do_aprint();
+bool do_exec();
+bool do_aexec();
+
+int do_subst();
+int cando();
+int ingroup();
+
+void str_replace();
+void str_inc();
+void str_dec();
+void str_free();
+void stab_clear();
+void do_join();
+void do_sprintf();
+void do_accept();
+void do_pipe();
+void do_vecset();
+void do_unshift();
+void do_execfree();
+void magicalize();
+void magicname();
+void savelist();
+void saveitem();
+void saveint();
+void savelong();
+void savesptr();
+void savehptr();
+void restorelist();
+void repeatcpy();
+HASH *savehash();
+ARRAY *saveary();
+
+EXT char **origargv;
+EXT int origargc;
+EXT char **origenviron;
+extern char **environ;
+
+EXT long subline INIT(0);
+EXT STR *subname INIT(Nullstr);
+EXT int arybase INIT(0);
+
+struct outrec {
+ long o_lines;
+ char *o_str;
+ int o_len;
+};
+
+EXT struct outrec outrec;
+EXT struct outrec toprec;
+
+EXT STAB *stdinstab INIT(Nullstab);
+EXT STAB *last_in_stab INIT(Nullstab);
+EXT STAB *defstab INIT(Nullstab);
+EXT STAB *argvstab INIT(Nullstab);
+EXT STAB *envstab INIT(Nullstab);
+EXT STAB *sigstab INIT(Nullstab);
+EXT STAB *defoutstab INIT(Nullstab);
+EXT STAB *curoutstab INIT(Nullstab);
+EXT STAB *argvoutstab INIT(Nullstab);
+EXT STAB *incstab INIT(Nullstab);
+EXT STAB *leftstab INIT(Nullstab);
+EXT STAB *amperstab INIT(Nullstab);
+EXT STAB *rightstab INIT(Nullstab);
+EXT STAB *DBstab INIT(Nullstab);
+EXT STAB *DBline INIT(Nullstab);
+EXT STAB *DBsub INIT(Nullstab);
+
+EXT HASH *defstash; /* main symbol table */
+EXT HASH *curstash; /* symbol table for current package */
+EXT HASH *debstash; /* symbol table for perldb package */
+
+EXT STR *curstname; /* name of current package */
+
+EXT STR *freestrroot INIT(Nullstr);
+EXT STR *lastretstr INIT(Nullstr);
+EXT STR *DBsingle INIT(Nullstr);
+EXT STR *DBtrace INIT(Nullstr);
+EXT STR *DBsignal INIT(Nullstr);
+
+EXT int lastspbase;
+EXT int lastsize;
+
+EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEFx");
+EXT char *origfilename;
+EXT FILE * VOLATILE rsfp;
+EXT char buf[1024];
+EXT char *bufptr;
+EXT char *oldbufptr;
+EXT char *oldoldbufptr;
+EXT char *bufend;
+
+EXT STR *linestr INIT(Nullstr);
+
+EXT char *rs INIT("\n");
+EXT int rschar INIT('\n'); /* final char of rs, or 0777 if none */
+EXT int rslen INIT(1);
+EXT char *ofs INIT(Nullch);
+EXT int ofslen INIT(0);
+EXT char *ors INIT(Nullch);
+EXT int orslen INIT(0);
+EXT char *ofmt INIT(Nullch);
+EXT char *inplace INIT(Nullch);
+EXT char *nointrp INIT("");
+
+EXT bool preprocess INIT(FALSE);
+EXT bool minus_n INIT(FALSE);
+EXT bool minus_p INIT(FALSE);
+EXT bool minus_l INIT(FALSE);
+EXT bool minus_a INIT(FALSE);
+EXT bool doswitches INIT(FALSE);
+EXT bool dowarn INIT(FALSE);
+EXT bool doextract INIT(FALSE);
+EXT bool allstabs INIT(FALSE); /* init all customary symbols in symbol table?*/
+EXT bool sawampersand INIT(FALSE); /* must save all match strings */
+EXT bool sawstudy INIT(FALSE); /* do fbminstr on all strings */
+EXT bool sawi INIT(FALSE); /* study must assume case insensitive */
+EXT bool sawvec INIT(FALSE);
+EXT bool localizing INIT(FALSE); /* are we processing a local() list? */
+
+#ifndef MAXSYSFD
+# define MAXSYSFD 2
+#endif
+EXT int maxsysfd INIT(MAXSYSFD); /* top fd to pass to subprocesses */
+
+#ifdef CSH
+char *cshname INIT(CSH);
+int cshlen INIT(0);
+#endif /* CSH */
+
+#ifdef TAINT
+EXT bool tainted INIT(FALSE); /* using variables controlled by $< */
+#endif
+
+#ifndef MSDOS
+#define TMPPATH "/tmp/perl-eXXXXXX"
+#else
+#define TMPPATH "plXXXXXX"
+#endif /* MSDOS */
+EXT char *e_tmpname;
+EXT FILE *e_fp INIT(Nullfp);
+
+EXT char tokenbuf[256];
+EXT int expectterm INIT(TRUE); /* how to interpret ambiguous tokens */
+EXT VOLATILE int in_eval INIT(FALSE); /* trap fatal errors? */
+EXT int multiline INIT(0); /* $*--do strings hold >1 line? */
+EXT int forkprocess; /* so do_open |- can return proc# */
+EXT int do_undump INIT(0); /* -u or dump seen? */
+EXT int error_count INIT(0); /* how many errors so far, max 10 */
+EXT int multi_start INIT(0); /* 1st line of multi-line string */
+EXT int multi_end INIT(0); /* last line of multi-line string */
+EXT int multi_open INIT(0); /* delimiter of said string */
+EXT int multi_close INIT(0); /* delimiter of said string */
+
+FILE *popen();
+/* char *str_get(); */
+STR *interp();
+void free_arg();
+STIO *stio_new();
+void hoistmust();
+void scanconst();
+
+EXT struct stat statbuf;
+EXT struct stat statcache;
+STAB *statstab INIT(Nullstab);
+STR *statname;
+#ifndef MSDOS
+EXT struct tms timesbuf;
+#endif
+EXT int uid;
+EXT int euid;
+EXT int gid;
+EXT int egid;
+UIDTYPE getuid();
+UIDTYPE geteuid();
+GIDTYPE getgid();
+GIDTYPE getegid();
+EXT int unsafe;
+
+#ifdef DEBUGGING
+EXT VOLATILE int debug INIT(0);
+EXT int dlevel INIT(0);
+EXT int dlmax INIT(128);
+EXT char *debname;
+EXT char *debdelim;
+#define YYDEBUG 1
+#endif
+EXT int perldb INIT(0);
+#define YYMAXDEPTH 300
+
+EXT line_t cmdline INIT(NOLINE);
+
+EXT STR str_undef;
+EXT STR str_no;
+EXT STR str_yes;
+
+/* runtime control stuff */
+
+EXT struct loop {
+ char *loop_label; /* what the loop was called, if anything */
+ int loop_sp; /* stack pointer to copy stuff down to */
+ jmp_buf loop_env;
+} *loop_stack;
+
+EXT int loop_ptr INIT(-1);
+EXT int loop_max INIT(128);
+
+EXT jmp_buf top_env;
+
+EXT char * VOLATILE goto_targ INIT(Nullch); /* cmd_exec gets strange when set */
+
+struct ufuncs {
+ int (*uf_val)();
+ int (*uf_set)();
+ int uf_index;
+};
+
+EXT ARRAY *stack; /* THE STACK */
+
+EXT ARRAY * VOLATILE savestack; /* to save non-local values on */
+
+EXT ARRAY *tosave; /* strings to save on recursive subroutine */
+
+EXT ARRAY *lineary; /* lines of script for debugger */
+EXT ARRAY *dbargs; /* args to call listed by caller function */
+
+EXT ARRAY *fdpid; /* keep fd-to-pid mappings for mypopen */
+EXT HASH *pidstatus; /* keep pid-to-status mappings for waitpid */
+
+EXT int *di; /* for tmp use in debuggers */
+EXT char *dc;
+EXT short *ds;
+
+/* Fix these up for __STDC__ */
+EXT long basetime INIT(0);
+char *mktemp();
+#ifndef STANDARD_C
+/* All of these are in stdlib.h or time.h for ANSI C */
+double atof();
+long time();
+struct tm *gmtime(), *localtime();
+char *index(), *rindex();
+char *strcpy(), *strcat();
+#endif /* ! STANDARD_C */
+
+#ifdef EUNICE
+#define UNLINK unlnk
+int unlnk();
+#else
+#define UNLINK unlink
+#endif
+
+#ifndef HAS_SETREUID
+#ifdef HAS_SETRESUID
+#define setreuid(r,e) setresuid(r,e,-1)
+#define HAS_SETREUID
+#endif
+#endif
+#ifndef HAS_SETREGID
+#ifdef HAS_SETRESGID
+#define setregid(r,e) setresgid(r,e,-1)
+#define HAS_SETREGID
+#endif
+#endif
--- /dev/null
+.rn '' }`
+''' $RCSfile: perl.man,v $$Revision: 4.0.1.5 $$Date: 91/11/11 16:42:00 $
+'''
+''' $Log: perl.man,v $
+''' 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.
+.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 \-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 5
+ 12345
+ 12345.67
+ .23E-10
+ 0xffff # hex
+ 0377 # octal
+
+.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 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
+
+ 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.
+It really does shift array ARGV and put the current filename into
+variable ARGV.
+It also uses filehandle ARGV internally.
+You can modify @ARGV before the first <> as long as you leave the first
+filename at the beginning of the array.
+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.
+.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 expression (simple statement) must be terminated with a semicolon.
+Note that this is like C, but unlike Pascal (and
+.IR awk ).
+.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..
+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 become false on the same evaluation it became true, but it still returns
+true once.)
+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 scalar .\|. operator is primarily intended for doing line number ranges
+after
+the fashion of \fIsed\fR or \fIawk\fR.
+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.
+ \-w File is writable by effective uid.
+ \-x File is executable by effective uid.
+ \-o File is owned by effective uid.
+ \-R File is readable by real uid.
+ \-W File is writable by real uid.
+ \-X File is executable by real uid.
+ \-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
+.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.
+.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 "accept(NEWSOCKET,GENERICSOCKET)" 8 2
+Does the same thing that the accept system call does.
+Returns true 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 "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.
+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
+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 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() call.
+Returns the child pid to the parent process and 0 to the child process.
+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.
+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
+The $members value returned by getgr.\|.\|. is a space separated list
+of the login names of the members of the group.
+.Sp
+The @addrs value returned by the gethost.\|.\|. functions 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.
+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; $* = 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 string.
+ 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",
+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.
+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.
+.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.
+.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 with the value specified.
+(Note that a subroutine can automatically return
+the value of the last expression evaluated.
+That's the preferred method\*(--use of an explicit
+.I return
+is a bit slower.)
+.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 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,SIZE,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.
+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 /\eb$word\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 "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 .
+.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
+.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 number of elements
+in the new array.
+.nf
+
+ unshift(ARGV, \'\-e\') unless $ARGV[0] =~ /^\-/;
+
+.fi
+.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.
+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 dynamicallly 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.
+(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 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 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 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 $^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 $^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
+.I Perl
+uses PATH in executing subprocesses, and in finding the script if \-S
+is used.
+HOME or LOGDIR are used if chdir has no argument.
+.PP
+Apart from these,
+.I perl
+uses no 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
+.IR perl .
+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*",<>) % 32767;
+
+.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.
+.PP
+.I Perl
+actually stands for Pathologically Eclectic Rubbish Lister, but don't tell
+anyone I said that.
+.rn }` ''
--- /dev/null
+#!/usr/bin/perl
+
+# Poor man's perl shell.
+
+# Simply type two carriage returns every time you want to evaluate.
+# Note that it must be a complete perl statement--don't type double
+# carriage return in the middle of a loop.
+
+$/ = ''; # set paragraph mode
+$SHlinesep = "\n";
+while ($SHcmd = <>) {
+ $/ = $SHlinesep;
+ eval $SHcmd; print $@ || "\n";
+ $SHlinesep = $/; $/ = '';
+}
--- /dev/null
+#!/bin/sh
+
+# Hacks to make it work with Interactive's SysVr3 Version 2.2
+# doughera@lafvax.lafayette.edu (Andy Dougherty) 3/23/91
+#
+# Additional information to make the BSD section work with SunOS 4.0.2
+# tdinger@East.Sun.COM (Tom Dinger) 4/15/1991
+
+input=$1
+output=$2
+tmp=/tmp/f$$
+
+plan="unknown"
+
+# 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
+
+set `wc -l $tmp`
+if test "$1" = "5"; then
+ plan="bsd43"
+fi
+
+if test "$plan" = "unknown"; then
+ # Test for ISC 2.2 version.
+egrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];
+int[ ]*yys\[ *YYMAXDEPTH *\] *;
+yyps *= *&yys\[ *-1 *\];
+yypv *= *&yyv\[ *-1 *\];
+if *\( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
+
+ set `wc -l $tmp`
+ if test "$1" = "5"; then
+ plan="isc"
+ fi
+fi
+
+case "$plan" in
+ ##################################################################
+ # The SunOS 4.0.2 version has the comparison fixed already.
+ # Also added are out of memory checks (makes porting the generated
+ # code easier) For most systems, it can't hurt. -- TD
+ "bsd43")
+ echo "Patching perly.c to allow dynamic yacc stack allocation"
+ echo "Assuming bsd4.3 yaccpar"
+ cat >$tmp <<'END'
+/YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];/c\
+int yymaxdepth = YYMAXDEPTH;\
+YYSTYPE *yyv; /* where the values are stored */\
+short *yys;\
+short *maxyyps;
+
+/short[ ]*yys\[ *YYMAXDEPTH *\] *;/d
+
+/yyps *= *&yys\[ *-1 *\];/d
+
+/yypv *= *&yyv\[ *-1 *\];/c\
+\ if (!yyv) {\
+\ yyv = (YYSTYPE*) malloc(yymaxdepth * sizeof(YYSTYPE));\
+\ yys = (short*) malloc(yymaxdepth * sizeof(short));\
+\ if ( !yyv || !yys ) {\
+\ yyerror( "out of memory" );\
+\ return(1);\
+\ }\
+\ maxyyps = &yys[yymaxdepth];\
+\ }\
+\ yyps = &yys[-1];\
+\ yypv = &yyv[-1];
+
+
+/if *( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *)/c\
+\ if( ++yyps >= maxyyps ) {\
+\ int tv = yypv - yyv;\
+\ int ts = yyps - yys;\
+\
+\ yymaxdepth *= 2;\
+\ yyv = (YYSTYPE*)realloc((char*)yyv,\
+\ yymaxdepth*sizeof(YYSTYPE));\
+\ yys = (short*)realloc((char*)yys,\
+\ yymaxdepth*sizeof(short));\
+\ if ( !yyv || !yys ) {\
+\ yyerror( "yacc stack overflow" );\
+\ return(1);\
+\ }\
+\ yyps = yys + ts;\
+\ yypv = yyv + tv;\
+\ maxyyps = &yys[yymaxdepth];\
+\ }
+
+/yacc stack overflow.*}/d
+/yacc stack overflow/,/}/d
+END
+ sed -f $tmp <$input >$output ;;
+
+ #######################################################
+ "isc") # Interactive Systems 2.2 version
+ echo "Patching perly.c to allow dynamic yacc stack allocation"
+ echo "Assuming Interactive SysVr3 2.2 yaccpar"
+ # Easier to simply put whole script here than to modify the
+ # bsd script with sed.
+ # Main changes: yaccpar sometimes uses yy_ps and yy_pv
+ # which are local register variables.
+ # if(++yyps > YYMAXDEPTH) had opening brace on next line.
+ # I've kept that brace in along with a call to yyerror if
+ # realloc fails. (Actually, I just don't know how to do
+ # multi-line matches in sed.)
+ cat > $tmp << 'END'
+/YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];/c\
+int yymaxdepth = YYMAXDEPTH;\
+YYSTYPE *yyv; /* where the values are stored */\
+int *yys;\
+int *maxyyps;
+
+/int[ ]*yys\[ *YYMAXDEPTH *\] *;/d
+
+/yyps *= *&yys\[ *-1 *\];/d
+
+/yypv *= *&yyv\[ *-1 *\];/c\
+\ if (!yyv) {\
+\ yyv = (YYSTYPE*) malloc(yymaxdepth * sizeof(YYSTYPE));\
+\ yys = (int*) malloc(yymaxdepth * sizeof(int));\
+\ maxyyps = &yys[yymaxdepth];\
+\ }\
+\ yyps = &yys[-1];\
+\ yypv = &yyv[-1];
+
+/if *( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *)/c\
+\ if( ++yy_ps >= maxyyps ) {\
+\ int tv = yy_pv - yyv;\
+\ int ts = yy_ps - yys;\
+\
+\ yymaxdepth *= 2;\
+\ yyv = (YYSTYPE*)realloc((char*)yyv,\
+\ yymaxdepth*sizeof(YYSTYPE));\
+\ yys = (int*)realloc((char*)yys,\
+\ yymaxdepth*sizeof(int));\
+\ yy_ps = yyps = yys + ts;\
+\ yy_pv = yypv = yyv + tv;\
+\ maxyyps = &yys[yymaxdepth];\
+\ }\
+\ if (yyv == NULL || yys == NULL)
+END
+ sed -f $tmp < $input > $output ;;
+
+ ######################################################
+ # Plan still unknown
+ *) mv $input $output;
+esac
+
+rm -rf $tmp $input
--- /dev/null
+/* $RCSfile: perly.y,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:17:38 $
+ *
+ * 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: perly.y,v $
+ * 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.
+ *
+ */
+
+%{
+#include "INTERN.h"
+#include "perl.h"
+
+/*SUPPRESS 530*/
+/*SUPPRESS 593*/
+/*SUPPRESS 595*/
+
+STAB *scrstab;
+ARG *arg4; /* rarely used arguments to make_op() */
+ARG *arg5;
+
+%}
+
+%start prog
+
+%union {
+ int ival;
+ char *cval;
+ ARG *arg;
+ CMD *cmdval;
+ struct compcmd compval;
+ STAB *stabval;
+ FCMD *formval;
+}
+
+%token <ival> '{' ')'
+
+%token <cval> WORD
+%token <ival> APPEND OPEN SSELECT LOOPEX
+%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
+%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
+%token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
+%token <ival> FUNC0 FUNC1 FUNC2 FUNC2x FUNC3 FUNC4 FUNC5 HSHFUN HSHFUN3
+%token <ival> FLIST2 SUB FILETEST LOCAL DELETE
+%token <ival> RELOP EQOP MULOP ADDOP PACKAGE AMPER
+%token <formval> FORMLIST
+%token <stabval> REG ARYLEN ARY HSH STAR
+%token <arg> SUBST PATTERN
+%token <arg> RSTRING TRANS
+
+%type <ival> prog decl format remember crp
+%type <cmdval> block lineseq line loop cond sideff nexpr else
+%type <arg> expr sexpr cexpr csexpr term handle aryword hshword
+%type <arg> texpr listop bareword
+%type <cval> label
+%type <compval> compblock
+
+%nonassoc <ival> LISTOP
+%left ','
+%right '='
+%right '?' ':'
+%nonassoc DOTDOT
+%left OROR
+%left ANDAND
+%left '|' '^'
+%left '&'
+%nonassoc EQOP
+%nonassoc RELOP
+%nonassoc <ival> UNIOP
+%nonassoc FILETEST
+%left LS RS
+%left ADDOP
+%left MULOP
+%left MATCH NMATCH
+%right '!' '~' UMINUS
+%right POW
+%nonassoc INC DEC
+%left '('
+
+%% /* RULES */
+
+prog : /* NULL */
+ {
+#if defined(YYDEBUG) && defined(DEBUGGING)
+ yydebug = (debug & 1);
+#endif
+ }
+ /*CONTINUED*/ lineseq
+ { if (in_eval)
+ eval_root = block_head($2);
+ else
+ main_root = block_head($2); }
+ ;
+
+compblock: block CONTINUE block
+ { $$.comp_true = $1; $$.comp_alt = $3; }
+ | block else
+ { $$.comp_true = $1; $$.comp_alt = $2; }
+ ;
+
+else : /* NULL */
+ { $$ = Nullcmd; }
+ | ELSE block
+ { $$ = $2; }
+ | ELSIF '(' expr ')' compblock
+ { cmdline = $1;
+ $$ = make_ccmd(C_ELSIF,$3,$5); }
+ ;
+
+block : '{' remember lineseq '}'
+ { $$ = block_head($3);
+ if (cmdline > $1)
+ cmdline = $1;
+ if (savestack->ary_fill > $2)
+ restorelist($2); }
+ ;
+
+remember: /* NULL */ /* in case they push a package name */
+ { $$ = savestack->ary_fill; }
+ ;
+
+lineseq : /* NULL */
+ { $$ = Nullcmd; }
+ | lineseq line
+ { $$ = append_line($1,$2); }
+ ;
+
+line : decl
+ { $$ = Nullcmd; }
+ | label cond
+ { $$ = add_label($1,$2); }
+ | loop /* loops add their own labels */
+ | label ';'
+ { if ($1 != Nullch) {
+ $$ = add_label($1, make_acmd(C_EXPR, Nullstab,
+ Nullarg, Nullarg) );
+ }
+ else {
+ $$ = Nullcmd;
+ cmdline = NOLINE;
+ } }
+ | label sideff ';'
+ { $$ = add_label($1,$2); }
+ ;
+
+sideff : error
+ { $$ = Nullcmd; }
+ | expr
+ { $$ = make_acmd(C_EXPR, Nullstab, $1, Nullarg); }
+ | expr IF expr
+ { $$ = addcond(
+ make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); }
+ | expr UNLESS expr
+ { $$ = addcond(invert(
+ make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); }
+ | expr WHILE expr
+ { $$ = addloop(
+ make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); }
+ | expr UNTIL expr
+ { $$ = addloop(invert(
+ make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); }
+ ;
+
+cond : IF '(' expr ')' compblock
+ { cmdline = $1;
+ $$ = make_icmd(C_IF,$3,$5); }
+ | UNLESS '(' expr ')' compblock
+ { cmdline = $1;
+ $$ = invert(make_icmd(C_IF,$3,$5)); }
+ | IF block compblock
+ { cmdline = $1;
+ $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); }
+ | UNLESS block compblock
+ { cmdline = $1;
+ $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); }
+ ;
+
+loop : label WHILE '(' texpr ')' compblock
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
+ make_ccmd(C_WHILE,$4,$6) )); }
+ | label UNTIL '(' expr ')' compblock
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
+ invert(make_ccmd(C_WHILE,$4,$6)) )); }
+ | label WHILE block compblock
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
+ make_ccmd(C_WHILE, cmd_to_arg($3),$4) )); }
+ | label UNTIL block compblock
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
+ invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); }
+ | label FOR REG '(' expr crp compblock
+ { cmdline = $2;
+ /*
+ * The following gobbledygook catches EXPRs that
+ * aren't explicit array refs and translates
+ * foreach VAR (EXPR) {
+ * into
+ * @ary = EXPR;
+ * foreach VAR (@ary) {
+ * where @ary is a hidden array made by genstab().
+ * (Note that @ary may become a local array if
+ * it is determined that it might be called
+ * recursively. See cmd_tosave().)
+ */
+ if ($5->arg_type != O_ARRAY) {
+ scrstab = aadd(genstab());
+ $$ = append_line(
+ make_acmd(C_EXPR, Nullstab,
+ l(make_op(O_ASSIGN,2,
+ listish(make_op(O_ARRAY, 1,
+ stab2arg(A_STAB,scrstab),
+ Nullarg,Nullarg )),
+ listish(make_list($5)),
+ Nullarg)),
+ Nullarg),
+ wopt(over($3,add_label($1,
+ make_ccmd(C_WHILE,
+ make_op(O_ARRAY, 1,
+ stab2arg(A_STAB,scrstab),
+ Nullarg,Nullarg ),
+ $7)))));
+ $$->c_line = $2;
+ $$->c_head->c_line = $2;
+ }
+ else {
+ $$ = wopt(over($3,add_label($1,
+ make_ccmd(C_WHILE,$5,$7) )));
+ }
+ }
+ | label FOR '(' expr crp compblock
+ { cmdline = $2;
+ if ($4->arg_type != O_ARRAY) {
+ scrstab = aadd(genstab());
+ $$ = append_line(
+ make_acmd(C_EXPR, Nullstab,
+ l(make_op(O_ASSIGN,2,
+ listish(make_op(O_ARRAY, 1,
+ stab2arg(A_STAB,scrstab),
+ Nullarg,Nullarg )),
+ listish(make_list($4)),
+ Nullarg)),
+ Nullarg),
+ wopt(over(defstab,add_label($1,
+ make_ccmd(C_WHILE,
+ make_op(O_ARRAY, 1,
+ stab2arg(A_STAB,scrstab),
+ Nullarg,Nullarg ),
+ $6)))));
+ $$->c_line = $2;
+ $$->c_head->c_line = $2;
+ }
+ else { /* lisp, anyone? */
+ $$ = wopt(over(defstab,add_label($1,
+ make_ccmd(C_WHILE,$4,$6) )));
+ }
+ }
+ | label FOR '(' nexpr ';' texpr ';' nexpr ')' block
+ /* basically fake up an initialize-while lineseq */
+ { yyval.compval.comp_true = $10;
+ yyval.compval.comp_alt = $8;
+ cmdline = $2;
+ $$ = append_line($4,wopt(add_label($1,
+ make_ccmd(C_WHILE,$6,yyval.compval) ))); }
+ | label compblock /* a block is a loop that happens once */
+ { $$ = add_label($1,make_ccmd(C_BLOCK,Nullarg,$2)); }
+ ;
+
+nexpr : /* NULL */
+ { $$ = Nullcmd; }
+ | sideff
+ ;
+
+texpr : /* NULL means true */
+ { (void)scanstr("1"); $$ = yylval.arg; }
+ | expr
+ ;
+
+label : /* empty */
+ { $$ = Nullch; }
+ | WORD ':'
+ ;
+
+decl : format
+ { $$ = 0; }
+ | subrout
+ { $$ = 0; }
+ | package
+ { $$ = 0; }
+ ;
+
+format : FORMAT WORD '=' FORMLIST
+ { if (strEQ($2,"stdout"))
+ make_form(stabent("STDOUT",TRUE),$4);
+ else if (strEQ($2,"stderr"))
+ make_form(stabent("STDERR",TRUE),$4);
+ else
+ make_form(stabent($2,TRUE),$4);
+ Safefree($2); $2 = Nullch; }
+ | FORMAT '=' FORMLIST
+ { make_form(stabent("STDOUT",TRUE),$3); }
+ ;
+
+subrout : SUB WORD block
+ { make_sub($2,$3);
+ cmdline = NOLINE;
+ if (savestack->ary_fill > $1)
+ restorelist($1); }
+ ;
+
+package : PACKAGE WORD ';'
+ { char tmpbuf[256];
+ STAB *tmpstab;
+
+ savehptr(&curstash);
+ saveitem(curstname);
+ str_set(curstname,$2);
+ sprintf(tmpbuf,"'_%s",$2);
+ tmpstab = stabent(tmpbuf,TRUE);
+ if (!stab_xhash(tmpstab))
+ stab_xhash(tmpstab) = hnew(0);
+ curstash = stab_xhash(tmpstab);
+ if (!curstash->tbl_name)
+ curstash->tbl_name = savestr($2);
+ curstash->tbl_coeffsize = 0;
+ Safefree($2); $2 = Nullch;
+ cmdline = NOLINE;
+ }
+ ;
+
+cexpr : ',' expr
+ { $$ = $2; }
+ ;
+
+expr : expr ',' sexpr
+ { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg); }
+ | sexpr
+ ;
+
+csexpr : ',' sexpr
+ { $$ = $2; }
+ ;
+
+sexpr : sexpr '=' sexpr
+ { $1 = listish($1);
+ if ($1->arg_type == O_ASSIGN && $1->arg_len == 1)
+ $1->arg_type = O_ITEM; /* a local() */
+ if ($1->arg_type == O_LIST)
+ $3 = listish($3);
+ $$ = l(make_op(O_ASSIGN, 2, $1, $3, Nullarg)); }
+ | sexpr POW '=' sexpr
+ { $$ = l(make_op(O_POW, 2, $1, $4, Nullarg)); }
+ | sexpr MULOP '=' sexpr
+ { $$ = l(make_op($2, 2, $1, $4, Nullarg)); }
+ | sexpr ADDOP '=' sexpr
+ { $$ = rcatmaybe(l(make_op($2, 2, $1, $4, Nullarg)));}
+ | sexpr LS '=' sexpr
+ { $$ = l(make_op(O_LEFT_SHIFT, 2, $1, $4, Nullarg)); }
+ | sexpr RS '=' sexpr
+ { $$ = l(make_op(O_RIGHT_SHIFT, 2, $1, $4, Nullarg)); }
+ | sexpr '&' '=' sexpr
+ { $$ = l(make_op(O_BIT_AND, 2, $1, $4, Nullarg)); }
+ | sexpr '^' '=' sexpr
+ { $$ = l(make_op(O_XOR, 2, $1, $4, Nullarg)); }
+ | sexpr '|' '=' sexpr
+ { $$ = l(make_op(O_BIT_OR, 2, $1, $4, Nullarg)); }
+
+
+ | sexpr POW sexpr
+ { $$ = make_op(O_POW, 2, $1, $3, Nullarg); }
+ | sexpr MULOP sexpr
+ { if ($2 == O_REPEAT)
+ $1 = listish($1);
+ $$ = make_op($2, 2, $1, $3, Nullarg);
+ if ($2 == O_REPEAT) {
+ if ($$[1].arg_type != A_EXPR ||
+ $$[1].arg_ptr.arg_arg->arg_type != O_LIST)
+ $$[1].arg_flags &= ~AF_ARYOK;
+ } }
+ | sexpr ADDOP sexpr
+ { $$ = make_op($2, 2, $1, $3, Nullarg); }
+ | sexpr LS sexpr
+ { $$ = make_op(O_LEFT_SHIFT, 2, $1, $3, Nullarg); }
+ | sexpr RS sexpr
+ { $$ = make_op(O_RIGHT_SHIFT, 2, $1, $3, Nullarg); }
+ | sexpr RELOP sexpr
+ { $$ = make_op($2, 2, $1, $3, Nullarg); }
+ | sexpr EQOP sexpr
+ { $$ = make_op($2, 2, $1, $3, Nullarg); }
+ | sexpr '&' sexpr
+ { $$ = make_op(O_BIT_AND, 2, $1, $3, Nullarg); }
+ | sexpr '^' sexpr
+ { $$ = make_op(O_XOR, 2, $1, $3, Nullarg); }
+ | sexpr '|' sexpr
+ { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg); }
+ | sexpr DOTDOT sexpr
+ { arg4 = Nullarg;
+ $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg); }
+ | sexpr ANDAND sexpr
+ { $$ = make_op(O_AND, 2, $1, $3, Nullarg); }
+ | sexpr OROR sexpr
+ { $$ = make_op(O_OR, 2, $1, $3, Nullarg); }
+ | sexpr '?' sexpr ':' sexpr
+ { $$ = make_op(O_COND_EXPR, 3, $1, $3, $5); }
+ | sexpr MATCH sexpr
+ { $$ = mod_match(O_MATCH, $1, $3); }
+ | sexpr NMATCH sexpr
+ { $$ = mod_match(O_NMATCH, $1, $3); }
+ | term
+ { $$ = $1; }
+ ;
+
+term : '-' term %prec UMINUS
+ { $$ = make_op(O_NEGATE, 1, $2, Nullarg, Nullarg); }
+ | '+' term %prec UMINUS
+ { $$ = $2; }
+ | '!' term
+ { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg); }
+ | '~' term
+ { $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg);}
+ | term INC
+ { $$ = addflags(1, AF_POST|AF_UP,
+ l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); }
+ | term DEC
+ { $$ = addflags(1, AF_POST,
+ l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); }
+ | INC term
+ { $$ = addflags(1, AF_PRE|AF_UP,
+ l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); }
+ | DEC term
+ { $$ = addflags(1, AF_PRE,
+ l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); }
+ | FILETEST WORD
+ { opargs[$1] = 0; /* force it special */
+ $$ = make_op($1, 1,
+ stab2arg(A_STAB,stabent($2,TRUE)),
+ Nullarg, Nullarg);
+ }
+ | FILETEST sexpr
+ { opargs[$1] = 1;
+ $$ = make_op($1, 1, $2, Nullarg, Nullarg); }
+ | FILETEST
+ { opargs[$1] = ($1 != O_FTTTY);
+ $$ = make_op($1, 1,
+ stab2arg(A_STAB,
+ $1 == O_FTTTY?stabent("STDIN",TRUE):defstab),
+ Nullarg, Nullarg); }
+ | LOCAL '(' expr crp
+ { $$ = l(localize(make_op(O_ASSIGN, 1,
+ localize(listish(make_list($3))),
+ Nullarg,Nullarg))); }
+ | '(' expr crp
+ { $$ = make_list($2); }
+ | '(' ')'
+ { $$ = make_list(Nullarg); }
+ | DO sexpr %prec FILETEST
+ { $$ = make_op(O_DOFILE,2,$2,Nullarg,Nullarg);
+ allstabs = TRUE;}
+ | DO block %prec '('
+ { $$ = cmd_to_arg($2); }
+ | REG %prec '('
+ { $$ = stab2arg(A_STAB,$1); }
+ | STAR %prec '('
+ { $$ = stab2arg(A_STAR,$1); }
+ | REG '[' expr ']' %prec '('
+ { $$ = make_op(O_AELEM, 2,
+ stab2arg(A_STAB,aadd($1)), $3, Nullarg); }
+ | HSH %prec '('
+ { $$ = make_op(O_HASH, 1,
+ stab2arg(A_STAB,$1),
+ Nullarg, Nullarg); }
+ | ARY %prec '('
+ { $$ = make_op(O_ARRAY, 1,
+ stab2arg(A_STAB,$1),
+ Nullarg, Nullarg); }
+ | REG '{' expr '}' %prec '('
+ { $$ = make_op(O_HELEM, 2,
+ stab2arg(A_STAB,hadd($1)),
+ jmaybe($3),
+ Nullarg); }
+ | '(' expr crp '[' expr ']' %prec '('
+ { $$ = make_op(O_LSLICE, 3,
+ Nullarg,
+ listish(make_list($5)),
+ listish(make_list($2))); }
+ | '(' ')' '[' expr ']' %prec '('
+ { $$ = make_op(O_LSLICE, 3,
+ Nullarg,
+ listish(make_list($4)),
+ Nullarg); }
+ | ARY '[' expr ']' %prec '('
+ { $$ = make_op(O_ASLICE, 2,
+ stab2arg(A_STAB,aadd($1)),
+ listish(make_list($3)),
+ Nullarg); }
+ | ARY '{' expr '}' %prec '('
+ { $$ = make_op(O_HSLICE, 2,
+ stab2arg(A_STAB,hadd($1)),
+ listish(make_list($3)),
+ Nullarg); }
+ | DELETE REG '{' expr '}' %prec '('
+ { $$ = make_op(O_DELETE, 2,
+ stab2arg(A_STAB,hadd($2)),
+ jmaybe($4),
+ Nullarg); }
+ | ARYLEN %prec '('
+ { $$ = stab2arg(A_ARYLEN,$1); }
+ | RSTRING %prec '('
+ { $$ = $1; }
+ | PATTERN %prec '('
+ { $$ = $1; }
+ | SUBST %prec '('
+ { $$ = $1; }
+ | TRANS %prec '('
+ { $$ = $1; }
+ | DO WORD '(' expr crp
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_WORD,stabent($2,MULTI)),
+ make_list($4),
+ Nullarg); Safefree($2); $2 = Nullch;
+ $$->arg_flags |= AF_DEPR; }
+ | AMPER WORD '(' expr crp
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_WORD,stabent($2,MULTI)),
+ make_list($4),
+ Nullarg); Safefree($2); $2 = Nullch; }
+ | DO WORD '(' ')'
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_WORD,stabent($2,MULTI)),
+ make_list(Nullarg),
+ Nullarg);
+ $$->arg_flags |= AF_DEPR; }
+ | AMPER WORD '(' ')'
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_WORD,stabent($2,MULTI)),
+ make_list(Nullarg),
+ Nullarg); }
+ | AMPER WORD
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_WORD,stabent($2,MULTI)),
+ Nullarg,
+ Nullarg); }
+ | DO REG '(' expr crp
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_STAB,$2),
+ make_list($4),
+ Nullarg);
+ $$->arg_flags |= AF_DEPR; }
+ | AMPER REG '(' expr crp
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_STAB,$2),
+ make_list($4),
+ Nullarg); }
+ | DO REG '(' ')'
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_STAB,$2),
+ make_list(Nullarg),
+ Nullarg);
+ $$->arg_flags |= AF_DEPR; }
+ | AMPER REG '(' ')'
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_STAB,$2),
+ make_list(Nullarg),
+ Nullarg); }
+ | AMPER REG
+ { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
+ stab2arg(A_STAB,$2),
+ Nullarg,
+ Nullarg); }
+ | LOOPEX
+ { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); }
+ | LOOPEX WORD
+ { $$ = make_op($1,1,cval_to_arg($2),
+ Nullarg,Nullarg); }
+ | UNIOP
+ { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); }
+ | UNIOP block
+ { $$ = make_op($1,1,cmd_to_arg($2),Nullarg,Nullarg); }
+ | UNIOP sexpr
+ { $$ = make_op($1,1,$2,Nullarg,Nullarg); }
+ | SSELECT
+ { $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);}
+ | SSELECT WORD
+ { $$ = make_op(O_SELECT, 1,
+ stab2arg(A_WORD,stabent($2,TRUE)),
+ Nullarg,
+ Nullarg);
+ Safefree($2); $2 = Nullch; }
+ | SSELECT '(' handle ')'
+ { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg); }
+ | SSELECT '(' sexpr csexpr csexpr csexpr ')'
+ { arg4 = $6;
+ $$ = make_op(O_SSELECT, 4, $3, $4, $5); }
+ | OPEN WORD %prec '('
+ { $$ = make_op(O_OPEN, 2,
+ stab2arg(A_WORD,stabent($2,TRUE)),
+ stab2arg(A_STAB,stabent($2,TRUE)),
+ Nullarg); }
+ | OPEN '(' WORD ')'
+ { $$ = make_op(O_OPEN, 2,
+ stab2arg(A_WORD,stabent($3,TRUE)),
+ stab2arg(A_STAB,stabent($3,TRUE)),
+ Nullarg); }
+ | OPEN '(' handle cexpr ')'
+ { $$ = make_op(O_OPEN, 2,
+ $3,
+ $4, Nullarg); }
+ | FILOP '(' handle ')'
+ { $$ = make_op($1, 1,
+ $3,
+ Nullarg, Nullarg); }
+ | FILOP WORD
+ { $$ = make_op($1, 1,
+ stab2arg(A_WORD,stabent($2,TRUE)),
+ Nullarg, Nullarg);
+ Safefree($2); $2 = Nullch; }
+ | FILOP REG
+ { $$ = make_op($1, 1,
+ stab2arg(A_STAB,$2),
+ Nullarg, Nullarg); }
+ | FILOP '(' ')'
+ { $$ = make_op($1, 1,
+ stab2arg(A_WORD,Nullstab),
+ Nullarg, Nullarg); }
+ | FILOP %prec '('
+ { $$ = make_op($1, 0,
+ Nullarg, Nullarg, Nullarg); }
+ | FILOP2 '(' handle cexpr ')'
+ { $$ = make_op($1, 2, $3, $4, Nullarg); }
+ | FILOP3 '(' handle csexpr cexpr ')'
+ { $$ = make_op($1, 3, $3, $4, make_list($5)); }
+ | FILOP22 '(' handle ',' handle ')'
+ { $$ = make_op($1, 2, $3, $5, Nullarg); }
+ | FILOP4 '(' handle csexpr csexpr cexpr ')'
+ { arg4 = $6; $$ = make_op($1, 4, $3, $4, $5); }
+ | FILOP25 '(' handle ',' handle csexpr csexpr cexpr ')'
+ { arg4 = $7; arg5 = $8;
+ $$ = make_op($1, 5, $3, $5, $6); }
+ | PUSH '(' aryword ',' expr crp
+ { $$ = make_op($1, 2,
+ $3,
+ make_list($5),
+ Nullarg); }
+ | POP aryword %prec '('
+ { $$ = make_op(O_POP, 1, $2, Nullarg, Nullarg); }
+ | POP '(' aryword ')'
+ { $$ = make_op(O_POP, 1, $3, Nullarg, Nullarg); }
+ | SHIFT aryword %prec '('
+ { $$ = make_op(O_SHIFT, 1, $2, Nullarg, Nullarg); }
+ | SHIFT '(' aryword ')'
+ { $$ = make_op(O_SHIFT, 1, $3, Nullarg, Nullarg); }
+ | SHIFT %prec '('
+ { $$ = make_op(O_SHIFT, 1,
+ stab2arg(A_STAB,
+ aadd(stabent(subline ? "_" : "ARGV", TRUE))),
+ Nullarg, Nullarg); }
+ | SPLIT %prec '('
+ { static char p[]="/\\s+/";
+ char *oldend = bufend;
+ ARG *oldarg = yylval.arg;
+
+ bufend=p+5;
+ (void)scanpat(p);
+ bufend=oldend;
+ $$ = make_split(defstab,yylval.arg,Nullarg);
+ yylval.arg = oldarg; }
+ | SPLIT '(' sexpr csexpr csexpr ')'
+ { $$ = mod_match(O_MATCH, $4,
+ make_split(defstab,$3,$5));}
+ | SPLIT '(' sexpr csexpr ')'
+ { $$ = mod_match(O_MATCH, $4,
+ make_split(defstab,$3,Nullarg) ); }
+ | SPLIT '(' sexpr ')'
+ { $$ = mod_match(O_MATCH,
+ stab2arg(A_STAB,defstab),
+ make_split(defstab,$3,Nullarg) ); }
+ | FLIST2 '(' sexpr cexpr ')'
+ { $$ = make_op($1, 2,
+ $3,
+ listish(make_list($4)),
+ Nullarg); }
+ | FLIST '(' expr crp
+ { $$ = make_op($1, 1,
+ make_list($3),
+ Nullarg,
+ Nullarg); }
+ | LVALFUN sexpr %prec '('
+ { $$ = l(make_op($1, 1, fixl($1,$2),
+ Nullarg, Nullarg)); }
+ | LVALFUN
+ { $$ = l(make_op($1, 1,
+ stab2arg(A_STAB,defstab),
+ Nullarg, Nullarg)); }
+ | FUNC0
+ { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); }
+ | FUNC0 '(' ')'
+ { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); }
+ | FUNC1 '(' ')'
+ { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); }
+ | FUNC1 '(' expr ')'
+ { $$ = make_op($1, 1, $3, Nullarg, Nullarg); }
+ | FUNC2 '(' sexpr cexpr ')'
+ { $$ = make_op($1, 2, $3, $4, Nullarg);
+ if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE)
+ fbmcompile($$[2].arg_ptr.arg_str,0); }
+ | FUNC2x '(' sexpr csexpr ')'
+ { $$ = make_op($1, 2, $3, $4, Nullarg);
+ if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE)
+ fbmcompile($$[2].arg_ptr.arg_str,0); }
+ | FUNC2x '(' sexpr csexpr cexpr ')'
+ { $$ = make_op($1, 3, $3, $4, $5);
+ if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE)
+ fbmcompile($$[2].arg_ptr.arg_str,0); }
+ | FUNC3 '(' sexpr csexpr cexpr ')'
+ { $$ = make_op($1, 3, $3, $4, $5); }
+ | FUNC4 '(' sexpr csexpr csexpr cexpr ')'
+ { arg4 = $6;
+ $$ = make_op($1, 4, $3, $4, $5); }
+ | FUNC5 '(' sexpr csexpr csexpr csexpr cexpr ')'
+ { arg4 = $6; arg5 = $7;
+ $$ = make_op($1, 5, $3, $4, $5); }
+ | HSHFUN '(' hshword ')'
+ { $$ = make_op($1, 1,
+ $3,
+ Nullarg,
+ Nullarg); }
+ | HSHFUN hshword
+ { $$ = make_op($1, 1,
+ $2,
+ Nullarg,
+ Nullarg); }
+ | HSHFUN3 '(' hshword csexpr cexpr ')'
+ { $$ = make_op($1, 3, $3, $4, $5); }
+ | bareword
+ | listop
+ ;
+
+listop : LISTOP
+ { $$ = make_op($1,2,
+ stab2arg(A_WORD,Nullstab),
+ stab2arg(A_STAB,defstab),
+ Nullarg); }
+ | LISTOP expr
+ { $$ = make_op($1,2,
+ stab2arg(A_WORD,Nullstab),
+ maybelistish($1,make_list($2)),
+ Nullarg); }
+ | LISTOP WORD
+ { $$ = make_op($1,2,
+ stab2arg(A_WORD,stabent($2,TRUE)),
+ stab2arg(A_STAB,defstab),
+ Nullarg); }
+ | LISTOP WORD expr
+ { $$ = make_op($1,2,
+ stab2arg(A_WORD,stabent($2,TRUE)),
+ maybelistish($1,make_list($3)),
+ Nullarg); Safefree($2); $2 = Nullch; }
+ | LISTOP REG expr
+ { $$ = make_op($1,2,
+ stab2arg(A_STAB,$2),
+ maybelistish($1,make_list($3)),
+ Nullarg); }
+ | LISTOP block expr
+ { $$ = make_op($1,2,
+ cmd_to_arg($2),
+ maybelistish($1,make_list($3)),
+ Nullarg); }
+ ;
+
+handle : WORD
+ { $$ = stab2arg(A_WORD,stabent($1,TRUE));
+ Safefree($1); $1 = Nullch;}
+ | sexpr
+ ;
+
+aryword : WORD
+ { $$ = stab2arg(A_WORD,aadd(stabent($1,TRUE)));
+ Safefree($1); $1 = Nullch; }
+ | ARY
+ { $$ = stab2arg(A_STAB,$1); }
+ ;
+
+hshword : WORD
+ { $$ = stab2arg(A_WORD,hadd(stabent($1,TRUE)));
+ Safefree($1); $1 = Nullch; }
+ | HSH
+ { $$ = stab2arg(A_STAB,$1); }
+ ;
+
+crp : ',' ')'
+ { $$ = 1; }
+ | ')'
+ { $$ = 0; }
+ ;
+
+/*
+ * NOTE: The following entry must stay at the end of the file so that
+ * reduce/reduce conflicts resolve to it only if it's the only option.
+ */
+
+bareword: WORD
+ { char *s;
+ $$ = op_new(1);
+ $$->arg_type = O_ITEM;
+ $$[1].arg_type = A_SINGLE;
+ $$[1].arg_ptr.arg_str = str_make($1,0);
+ for (s = $1; *s && isLOWER(*s); s++) ;
+ if (dowarn && !*s)
+ warn(
+ "\"%s\" may clash with future reserved word",
+ $1 );
+ }
+ ;
+%% /* PROGRAM */
--- /dev/null
+/* NOTE: this is derived from Henry Spencer's regexp code, and should not
+ * confused with the original package (see point 3 below). Thanks, Henry!
+ */
+
+/* Additional note: this code is very heavily munged from Henry's version
+ * in places. In some spots I've traded clarity for efficiency, so don't
+ * blame Henry for some of the lack of readability.
+ */
+
+/* $RCSfile: regcomp.c,v $$Revision: 4.0.1.4 $$Date: 91/11/05 22:55:14 $
+ *
+ * $Log: regcomp.c,v $
+ * 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
+ *
+ * Copyright (c) 1986 by University of Toronto.
+ * Written by Henry Spencer. Not derived from licensed software.
+ *
+ * Permission is granted to anyone to use this software for any
+ * purpose on any computer system, and to redistribute it freely,
+ * subject to the following restrictions:
+ *
+ * 1. The author is not responsible for the consequences of use of
+ * this software, no matter how awful, even if they arise
+ * from defects in it.
+ *
+ * 2. The origin of this software must not be misrepresented, either
+ * by explicit claim or by omission.
+ *
+ * 3. Altered versions must be plainly marked as such, and must not
+ * be misrepresented as being the original software.
+ *
+ *
+ **** Alterations to Henry's code are...
+ ****
+ **** Copyright (c) 1991, Larry Wall
+ ****
+ **** You may distribute under the terms of either the GNU General Public
+ **** License or the Artistic License, as specified in the README file.
+
+ *
+ * Beware that some of this code is subtly aware of the way operator
+ * precedence is structured in regular expressions. Serious changes in
+ * regular-expression syntax might require a total rethink.
+ */
+#include "EXTERN.h"
+#include "perl.h"
+#include "INTERN.h"
+#include "regcomp.h"
+
+#ifdef MSDOS
+# if defined(BUGGY_MSC6)
+ /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
+ # pragma optimize("a",off)
+ /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
+ # pragma optimize("w",on )
+# endif /* BUGGY_MSC6 */
+#endif /* MSDOS */
+
+#ifndef STATIC
+#define STATIC static
+#endif
+
+#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
+#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
+ ((*s) == '{' && regcurly(s)))
+#define META "^$.[()|?+*\\"
+
+#ifdef SPSTART
+#undef SPSTART /* dratted cpp namespace... */
+#endif
+/*
+ * 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. */
+
+/*
+ * Global work variables for regcomp().
+ */
+static char *regprecomp; /* uncompiled string. */
+static char *regparse; /* Input-scan pointer. */
+static char *regxend; /* End of input for compile */
+static int regnpar; /* () count. */
+static char *regcode; /* Code-emit pointer; ®dummy = don't. */
+static long regsize; /* Code size. */
+static int regfold;
+static int regsawbracket; /* Did we do {d,d} trick? */
+static int regsawback; /* Did we see \1, ...? */
+
+/*
+ * Forward declarations for regcomp()'s friends.
+ */
+STATIC int 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();
+
+/*
+ - regcomp - compile a regular expression into internal code
+ *
+ * We can't allocate space until we know how big the compiled form will be,
+ * but we can't compile it (and thus know how big it is) until we've got a
+ * place to put the code. So we cheat: we compile it twice, once with code
+ * generation turned off and size counting turned on, and once "for real".
+ * This also means that we don't allocate space until we are sure that the
+ * thing really will compile successfully, and we never have to move the
+ * code and thus invalidate pointers into it. (Note that it has to be in
+ * one piece because free() must be able to free it all.) [NB: not true in perl]
+ *
+ * Beware that the optimization-preparation code in here knows about some
+ * of the structure of the compiled regexp. [I'll say.]
+ */
+regexp *
+regcomp(exp,xend,fold)
+char *exp;
+char *xend;
+int fold;
+{
+ register regexp *r;
+ register char *scan;
+ register STR *longish;
+ STR *longest;
+ register int len;
+ register char *first;
+ int flags;
+ int backish;
+ int backest;
+ int curback;
+ int minlen;
+#ifndef safemalloc
+ extern char *safemalloc();
+#endif
+ extern char *savestr();
+ int sawplus = 0;
+ int sawopen = 0;
+
+ if (exp == NULL)
+ fatal("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);
+ }
+
+ /* 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)
+ bcopy(regprecomp,exp,xend-exp);
+ 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 = Nullstr; /* Worst-case defaults. */
+ r->reganch = 0;
+ r->regmust = Nullstr;
+ 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 =
+ str_make(OPERAND(first)+1,*OPERAND(first));
+ if (r->regstart->str_cur > !(sawstudy|fold))
+ fbmcompile(r->regstart,fold);
+ }
+ else if ((exp = index(simple,OP(first))) && exp > simple)
+ r->regstclass = first;
+ else if (OP(first) == BOUND || OP(first) == NBOUND)
+ r->regstclass = first;
+ else if (OP(first) == BOL ||
+ (OP(first) == STAR && OP(NEXTOPER(first)) == ANY) ) {
+ /* kinda turn .* into ^.* */
+ 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 */
+
+#ifdef DEBUGGING
+ if (debug & 512)
+ fprintf(stderr,"first %d next %d offset %d\n",
+ OP(first), OP(NEXTOPER(first)), first - scan);
+#endif
+ /*
+ * 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 = str_make("",0);
+ longest = str_make("",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) == EXACTLY) {
+ char *t;
+
+ first = scan;
+ while (OP(t = regnext(scan)) == CLOSE)
+ scan = t;
+ minlen += *OPERAND(first);
+ if (curback - backish == len) {
+ str_ncat(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);
+ str_nset(longish, OPERAND(first)+1,len);
+ backish = curback;
+ curback += len;
+ first = regnext(scan);
+ }
+ else
+ curback += *OPERAND(first);
+ }
+ else if (index(varies,OP(scan))) {
+ curback = -30000;
+ len = 0;
+ if (longish->str_cur > longest->str_cur) {
+ str_sset(longest,longish);
+ backest = backish;
+ }
+ str_nset(longish,"",0);
+ if (OP(scan) == PLUS &&
+ index(simple,OP(NEXTOPER(scan))))
+ minlen++;
+ else if (OP(scan) == CURLY &&
+ index(simple,OP(NEXTOPER(scan)+4)))
+ minlen += ARG1(scan);
+ }
+ else if (index(simple,OP(scan))) {
+ curback++;
+ minlen++;
+ len = 0;
+ if (longish->str_cur > longest->str_cur) {
+ str_sset(longest,longish);
+ backest = backish;
+ }
+ str_nset(longish,"",0);
+ }
+ scan = regnext(scan);
+ }
+
+ /* Prefer earlier on tie, unless we can tail match latter */
+
+ if (longish->str_cur + (OP(first) == EOL) > longest->str_cur) {
+ str_sset(longest,longish);
+ backest = backish;
+ }
+ else
+ str_nset(longish,"",0);
+ if (longest->str_cur
+ &&
+ (!r->regstart
+ ||
+ !fbminstr((unsigned char*) r->regstart->str_ptr,
+ (unsigned char *) r->regstart->str_ptr
+ + r->regstart->str_cur,
+ longest)
+ )
+ )
+ {
+ r->regmust = longest;
+ if (backest < 0)
+ backest = -1;
+ r->regback = backest;
+ if (longest->str_cur
+ > !(sawstudy || fold || OP(first) == EOL) )
+ fbmcompile(r->regmust,fold);
+ r->regmust->str_u.str_useful = 100;
+ if (OP(first) == EOL && longish->str_cur)
+ r->regmust->str_pok |= SP_TAIL;
+ }
+ else {
+ str_free(longest);
+ longest = Nullstr;
+ }
+ str_free(longish);
+ }
+
+ r->do_folding = fold;
+ r->nparens = regnpar - 1;
+ r->minlen = minlen;
+ Newz(1002, r->startp, regnpar, char*);
+ Newz(1002, r->endp, regnpar, char*);
+#ifdef DEBUGGING
+ if (debug & 512)
+ regdump(r);
+#endif
+ return(r);
+}
+
+/*
+ - reg - regular expression, i.e. main body or parenthesized thing
+ *
+ * Caller must absorb opening parenthesis.
+ *
+ * Combining parenthesis handling with the base level of regular expression
+ * is a trifle forced, but the need to tie the tails of the branches to what
+ * follows makes it hard to avoid.
+ */
+static char *
+reg(paren, flagp)
+int paren; /* Parenthesized? */
+int *flagp;
+{
+ register char *ret;
+ register char *br;
+ register char *ender;
+ register int parno;
+ int 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. */
+ 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 == '|') {
+ 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 */
+ }
+
+ return(ret);
+}
+
+/*
+ - regbranch - one alternative of an | operator
+ *
+ * Implements the concatenation operator.
+ */
+static char *
+regbranch(flagp)
+int *flagp;
+{
+ register char *ret;
+ register char *chain;
+ register char *latest;
+ int 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;
+ }
+ if (chain == NULL) /* Loop ran zero times. */
+ (void) regnode(NOTHING);
+
+ return(ret);
+}
+
+/*
+ - regpiece - something followed by possible [*+?]
+ *
+ * Note that the branching code sequences used for ? and the general cases
+ * of * and + are somewhat optimized: they use the same NOTHING node as
+ * both the endmarker for their branch list and the body of the last branch.
+ * It might seem that this node could be dispensed with entirely, but the
+ * endmarker role is not redundant.
+ */
+static char *
+regpiece(flagp)
+int *flagp;
+{
+ register char *ret;
+ register char op;
+ register char *next;
+ int flags;
+ char *origparse = regparse;
+ int orignpar = regnpar;
+ char *max;
+ int 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++;
+ }
+ if (*next == '}') { /* got one */
+ if (!max)
+ max = next;
+ regparse++;
+ iter = atoi(regparse);
+ if (flags&SIMPLE) { /* we can do it right after all */
+ int tmp;
+
+ reginsert(CURLY, ret);
+ if (iter > 0)
+ *flagp = (WORST|HASWIDTH);
+ if (*max == ',')
+ max++;
+ else
+ max = regparse;
+ tmp = atoi(max);
+ if (tmp && tmp < iter)
+ fatal("Can't do {n,m} with n > m");
+ if (regcode != ®dummy) {
+#ifdef REGALIGN
+ *(unsigned short *)(ret+3) = iter;
+ *(unsigned short *)(ret+5) = tmp;
+#else
+ ret[3] = iter >> 8; ret[4] = iter & 0377;
+ ret[5] = tmp >> 8; ret[6] = tmp & 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)
+ fatal("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
+ fatal("Can't do {n,0}");
+ }
+ else
+ fatal("Can't do {0}");
+ }
+ }
+
+ if (!ISMULT1(op)) {
+ *flagp = flags;
+ return(ret);
+ }
+
+ 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");
+
+ return(ret);
+}
+
+/*
+ - regatom - the lowest level
+ *
+ * Optimization: gobbles an entire sequence of ordinary characters so that
+ * it can turn them into a single node, which is smaller to store and
+ * faster to run. Backslashed characters are exceptions, each becoming a
+ * separate node; the code is simpler that way and it's not worth fixing.
+ *
+ * [Yes, it is worth fixing, some scripts can run twice the speed.]
+ */
+static char *
+regatom(flagp)
+int *flagp;
+{
+ register char *ret;
+ int 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;
+ regparse++;
+ break;
+ case 'W':
+ ret = regnode(NALNUM);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'b':
+ ret = regnode(BOUND);
+ *flagp |= SIMPLE;
+ regparse++;
+ break;
+ case 'B':
+ ret = regnode(NBOUND);
+ *flagp |= SIMPLE;
+ regparse++;
+ break;
+ case 's':
+ ret = regnode(SPACE);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'S':
+ ret = regnode(NSPACE);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'd':
+ ret = regnode(DIGIT);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'D':
+ ret = regnode(NDIGIT);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ 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':
+ {
+ int num = atoi(regparse);
+
+ if (num > 9 && num >= regnpar)
+ goto defchar;
+ else {
+ regsawback = 1;
+ ret = reganode(REF, num);
+ while (isDIGIT(*regparse))
+ regparse++;
+ *flagp |= SIMPLE;
+ }
+ }
+ break;
+ case '\0':
+ if (regparse >= regxend)
+ FAIL("trailing \\ in regexp");
+ /* FALL THROUGH */
+ default:
+ goto defchar;
+ }
+ break;
+ default: {
+ register int len;
+ register char ender;
+ register char *p;
+ char *oldp;
+ int 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 = scanhex(++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 = scanoct(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');
+ }
+ break;
+ }
+
+ return(ret);
+}
+
+static void
+regset(bits,def,c)
+char *bits;
+int def;
+register int c;
+{
+ 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 int class;
+ register int lastclass;
+ register int range = 0;
+ register char *ret;
+ register int def;
+ int numlen;
+
+ ret = regnode(ANYOF);
+ if (*regparse == '^') { /* Complement of range. */
+ 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 = 'a'; class <= 'z'; class++)
+ regset(bits,def,class);
+ for (class = 'A'; class <= 'Z'; class++)
+ regset(bits,def,class);
+ for (class = '0'; class <= '9'; class++)
+ regset(bits,def,class);
+ regset(bits,def,'_');
+ lastclass = 1234;
+ continue;
+ case 's':
+ regset(bits,def,' ');
+ regset(bits,def,'\t');
+ regset(bits,def,'\r');
+ regset(bits,def,'\f');
+ regset(bits,def,'\n');
+ lastclass = 1234;
+ continue;
+ case 'd':
+ for (class = '0'; class <= '9'; 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 = scanhex(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 = scanoct(--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;
+ }
+ if (*regparse != ']')
+ FAIL("unmatched [] in regexp");
+ regparse++;
+ return ret;
+}
+
+/*
+ - regnode - emit a node
+ */
+static char * /* Location. */
+regnode(op)
+char op;
+{
+ register char *ret;
+ register char *ptr;
+
+ ret = regcode;
+ if (ret == ®dummy) {
+#ifdef REGALIGN
+ if (!(regsize & 1))
+ regsize++;
+#endif
+ regsize += 3;
+ return(ret);
+ }
+
+#ifdef REGALIGN
+#ifndef lint
+ if (!((long)ret & 1))
+ *ret++ = 127;
+#endif
+#endif
+ ptr = ret;
+ *ptr++ = op;
+ *ptr++ = '\0'; /* Null "next" pointer. */
+ *ptr++ = '\0';
+ regcode = ptr;
+
+ return(ret);
+}
+
+/*
+ - reganode - emit a node with an argument
+ */
+static char * /* Location. */
+reganode(op, arg)
+char op;
+unsigned short arg;
+{
+ register char *ret;
+ register char *ptr;
+
+ ret = regcode;
+ if (ret == ®dummy) {
+#ifdef REGALIGN
+ if (!(regsize & 1))
+ regsize++;
+#endif
+ regsize += 5;
+ return(ret);
+ }
+
+#ifdef REGALIGN
+#ifndef lint
+ if (!((long)ret & 1))
+ *ret++ = 127;
+#endif
+#endif
+ ptr = ret;
+ *ptr++ = op;
+ *ptr++ = '\0'; /* Null "next" pointer. */
+ *ptr++ = '\0';
+#ifdef REGALIGN
+ *(unsigned short *)(ret+3) = arg;
+#else
+ ret[3] = arg >> 8; ret[4] = arg & 0377;
+#endif
+ ptr += 2;
+ regcode = ptr;
+
+ return(ret);
+}
+
+/*
+ - regc - emit (if appropriate) a byte of code
+ */
+static void
+regc(b)
+char b;
+{
+ if (regcode != ®dummy)
+ *regcode++ = b;
+ else
+ regsize++;
+}
+
+/*
+ - reginsert - insert an operator in front of already-emitted operand
+ *
+ * Means relocating the operand.
+ */
+static void
+reginsert(op, opnd)
+char op;
+char *opnd;
+{
+ register char *src;
+ register char *dst;
+ register char *place;
+ register offset = (op == CURLY ? 4 : 0);
+
+ if (regcode == ®dummy) {
+#ifdef REGALIGN
+ regsize += 4 + offset;
+#else
+ regsize += 3 + offset;
+#endif
+ return;
+ }
+
+ src = regcode;
+#ifdef REGALIGN
+ regcode += 4 + offset;
+#else
+ regcode += 3 + offset;
+#endif
+ 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';
+}
+
+/*
+ - 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 int 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;
+#ifndef lint
+ *(short*)(scan+1) = offset;
+#else
+ offset = offset;
+#endif
+#else
+ 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
+ */
+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);
+}
+
+/*
+ - regcurly - a little FSA that accepts {\d+,?\d*}
+ */
+STATIC int
+regcurly(s)
+register char *s;
+{
+ if (*s++ != '{')
+ return FALSE;
+ if (!isDIGIT(*s))
+ return FALSE;
+ while (isDIGIT(*s))
+ s++;
+ if (*s == ',')
+ s++;
+ while (isDIGIT(*s))
+ s++;
+ if (*s != '}')
+ return FALSE;
+ return TRUE;
+}
+
+#ifdef DEBUGGING
+
+/*
+ - regdump - dump a regexp onto stderr in vaguely comprehensible form
+ */
+void
+regdump(r)
+regexp *r;
+{
+ 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... */
+#ifdef REGALIGN
+ 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)putchar(*s);
+ s++;
+ }
+ s++;
+ }
+ (void)putchar('\n');
+ }
+
+ /* Header fields of interest. */
+ if (r->regstart)
+ fprintf(stderr,"start `%s' ", r->regstart->str_ptr);
+ 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 ", r->regmust->str_ptr,
+ r->regback);
+ fprintf(stderr, "minlen %d ", r->minlen);
+ fprintf(stderr,"\n");
+}
+
+/*
+ - 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);
+}
+#endif /* DEBUGGING */
+
+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) {
+ str_free(r->regmust);
+ r->regmust = Nullstr;
+ }
+ if (r->regstart) {
+ str_free(r->regstart);
+ r->regstart = Nullstr;
+ }
+ Safefree(r->startp);
+ Safefree(r->endp);
+ Safefree(r);
+}
--- /dev/null
+/* $RCSfile: regcomp.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:49:40 $
+ *
+ * $Log: regcomp.h,v $
+ * 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.
+ *
+ */
+
+/*
+ * The "internal use only" fields in regexp.h are present to pass info from
+ * compile to execute that permits the execute phase to run lots faster on
+ * simple cases. They are:
+ *
+ * regstart str that must begin a match; Nullch if none obvious
+ * reganch is the match anchored (at beginning-of-line only)?
+ * regmust string (pointer into program) that match must include, or NULL
+ * [regmust changed to STR* for bminstr()--law]
+ * regmlen length of regmust string
+ * [regmlen not used currently]
+ *
+ * Regstart and reganch permit very fast decisions on suitable starting points
+ * for a match, cutting down the work a lot. Regmust permits fast rejection
+ * of lines that cannot possibly match. The regmust tests are costly enough
+ * that regcomp() supplies a regmust only if the r.e. contains something
+ * potentially expensive (at present, the only such thing detected is * or +
+ * at the start of the r.e., which can involve a lot of backup). Regmlen is
+ * supplied because the test in regexec() needs it and regcomp() is computing
+ * it anyway.
+ * [regmust is now supplied always. The tests that use regmust have a
+ * heuristic that disables the test if it usually matches.]
+ *
+ * [In fact, we now use regmust in many cases to locate where the search
+ * starts in the string, so if regback is >= 0, the regmust search is never
+ * wasted effort. The regback variable says how many characters back from
+ * where regmust matched is the earliest possible start of the match.
+ * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.]
+ */
+
+/*
+ * Structure for regexp "program". This is essentially a linear encoding
+ * of a nondeterministic finite-state machine (aka syntax charts or
+ * "railroad normal form" in parsing technology). Each node is an opcode
+ * plus a "next" pointer, possibly plus an operand. "Next" pointers of
+ * all nodes except BRANCH implement concatenation; a "next" pointer with
+ * a BRANCH on both ends of it is connecting two alternatives. (Here we
+ * have one of the subtle syntax dependencies: an individual BRANCH (as
+ * opposed to a collection of them) is never concatenated with anything
+ * because of operator precedence.) The operand of some types of node is
+ * a literal string; for others, it is a node leading into a sub-FSM. In
+ * particular, the operand of a BRANCH node is the first node of the branch.
+ * (NB this is *not* a tree structure: the tail of the branch connects
+ * to the thing following the set of BRANCHes.) The opcodes are:
+ */
+
+/* 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 /* str Match character in (or not in) this class. */
+#define CURLY 5 /* str 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 /* str 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. */
+
+/*
+ * Opcode notes:
+ *
+ * BRANCH The set of branches constituting a single choice are hooked
+ * together with their "next" pointers, since precedence prevents
+ * anything being concatenated to any individual branch. The
+ * "next" pointer of the last BRANCH in a choice points to the
+ * thing following the whole choice. This is also where the
+ * final "next" pointer of each individual branch points; each
+ * branch starts with the operand node of a BRANCH node.
+ *
+ * BACK Normal "next" pointers all implicitly point forward; BACK
+ * exists to make loop structures possible.
+ *
+ * STAR,PLUS '?', and complex '*' and '+', are implemented as circular
+ * BRANCH structures using BACK. Simple cases (one character
+ * per match) are implemented with STAR and PLUS for speed
+ * and to minimize recursive plunges.
+ *
+ * OPEN,CLOSE ...are numbered at compile time.
+ */
+
+#ifndef DOINIT
+extern char regarglen[];
+#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};
+#endif
+
+/* The following have no fixed length. */
+#ifndef DOINIT
+extern char varies[];
+#else
+char varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,REF,0};
+#endif
+
+/* The following always have a length of 1. */
+#ifndef DOINIT
+extern char simple[];
+#else
+char simple[] = {ANY,ANYOF,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0};
+#endif
+
+EXT char regdummy;
+
+/*
+ * A node is one char of opcode followed by two chars of "next" pointer.
+ * "Next" pointers are stored as two 8-bit pieces, high order first. The
+ * value is a positive offset from the opcode of the node containing it.
+ * An operand, if any, simply follows the node. (Note that much of the
+ * code generation knows about this implicit relationship.)
+ *
+ * Using two bytes for the "next" pointer is vast overkill for most things,
+ * but allows patterns to get big without disasters.
+ *
+ * [If REGALIGN is defined, the "next" pointer is always aligned on an even
+ * boundary, and reads the offset directly as a short. Also, there is no
+ * special test to reverse the sign of BACK pointers since the offset is
+ * stored negative.]
+ */
+
+#ifndef gould
+#ifndef cray
+#ifndef eta10
+#define REGALIGN
+#endif
+#endif
+#endif
+
+#define OP(p) (*(p))
+
+#ifndef lint
+#ifdef REGALIGN
+#define NEXT(p) (*(short*)(p+1))
+#define ARG1(p) (*(unsigned short*)(p+3))
+#define ARG2(p) (*(unsigned short*)(p+5))
+#else
+#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377))
+#define ARG1(p) (((*((p)+3)&0377)<<8) + (*((p)+4)&0377))
+#define ARG2(p) (((*((p)+5)&0377)<<8) + (*((p)+6)&0377))
+#endif
+#else /* lint */
+#define NEXT(p) 0
+#endif /* lint */
+
+#define OPERAND(p) ((p) + 3)
+
+#ifdef REGALIGN
+#define NEXTOPER(p) ((p) + 4)
+#else
+#define NEXTOPER(p) ((p) + 3)
+#endif
+
+#define MAGIC 0234
+
+/*
+ * Utility definitions.
+ */
+#ifndef lint
+#ifndef CHARBITS
+#define UCHARAT(p) ((int)*(unsigned char *)(p))
+#else
+#define UCHARAT(p) ((int)*(p)&CHARBITS)
+#endif
+#else /* lint */
+#define UCHARAT(p) regdummy
+#endif /* lint */
+
+#define FAIL(m) fatal("/%s/: %s",regprecomp,m)
+
+char *regnext();
+#ifdef DEBUGGING
+void regdump();
+char *regprop();
+#endif
+
--- /dev/null
+/* NOTE: this is derived from Henry Spencer's regexp code, and should not
+ * confused with the original package (see point 3 below). Thanks, Henry!
+ */
+
+/* Additional note: this code is very heavily munged from Henry's version
+ * in places. In some spots I've traded clarity for efficiency, so don't
+ * blame Henry for some of the lack of readability.
+ */
+
+/* $RCSfile: regexec.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:23:55 $
+ *
+ * $Log: regexec.c,v $
+ * 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
+ *
+ * Copyright (c) 1986 by University of Toronto.
+ * Written by Henry Spencer. Not derived from licensed software.
+ *
+ * Permission is granted to anyone to use this software for any
+ * purpose on any computer system, and to redistribute it freely,
+ * subject to the following restrictions:
+ *
+ * 1. The author is not responsible for the consequences of use of
+ * this software, no matter how awful, even if they arise
+ * from defects in it.
+ *
+ * 2. The origin of this software must not be misrepresented, either
+ * by explicit claim or by omission.
+ *
+ * 3. Altered versions must be plainly marked as such, and must not
+ * be misrepresented as being the original software.
+ *
+ **** Alterations to Henry's code are...
+ ****
+ **** Copyright (c) 1991, Larry Wall
+ ****
+ **** You may distribute under the terms of either the GNU General Public
+ **** License or the Artistic License, as specified in the README file.
+ *
+ * Beware that some of this code is subtly aware of the way operator
+ * precedence is structured in regular expressions. Serious changes in
+ * regular-expression syntax might require a total rethink.
+ */
+#include "EXTERN.h"
+#include "perl.h"
+#include "regcomp.h"
+
+#ifndef STATIC
+#define STATIC static
+#endif
+
+#ifdef DEBUGGING
+int regnarrate = 0;
+#endif
+
+/*
+ * regexec and friends
+ */
+
+/*
+ * Global work variables for regexec().
+ */
+static char *regprecomp;
+static char *reginput; /* String-input pointer. */
+static char regprev; /* char before regbol, \n if none */
+static char *regbol; /* Beginning of input, for ^ check. */
+static char *regeol; /* End of input, for $ check. */
+static char **regstartp; /* Pointer to startp array. */
+static char **regendp; /* Ditto for endp. */
+static char *reglastparen; /* Similarly for lastparen. */
+static char *regtill;
+
+static int regmyp_size = 0;
+static char **regmystartp = Null(char**);
+static char **regmyendp = Null(char**);
+
+/*
+ * Forwards.
+ */
+STATIC int regtry();
+STATIC int regmatch();
+STATIC int regrepeat();
+
+extern int multiline;
+
+/*
+ - regexec - match a regexp against a string
+ */
+int
+regexec(prog, stringarg, strend, strbeg, minend, screamer, safebase)
+register regexp *prog;
+char *stringarg;
+register char *strend; /* pointer to null at end of string */
+char *strbeg; /* real beginning of string */
+int minend; /* end of match must be at least minend after stringarg */
+STR *screamer;
+int safebase; /* no need to remember string in subbase */
+{
+ register char *s;
+ register int i;
+ register char *c;
+ register char *string = stringarg;
+ register int tmp;
+ int minlen = 0; /* must match at least this many chars */
+ int dontbother = 0; /* how many characters not to try at end */
+
+ /* Be paranoid... */
+ if (prog == NULL || string == NULL) {
+ fatal("NULL regexp parameter");
+ return(0);
+ }
+
+ if (string == strbeg) /* is ^ valid at stringarg? */
+ regprev = '\n';
+ else {
+ regprev = stringarg[-1];
+ if (!multiline && regprev == '\n')
+ regprev = '\0'; /* force ^ to NOT match */
+ }
+ regprecomp = prog->precomp;
+ /* Check validity of program. */
+ if (UCHARAT(prog->program) != MAGIC) {
+ FAIL("corrupted regexp program");
+ }
+
+ if (prog->do_folding) {
+ safebase = FALSE;
+ i = strend - string;
+ New(1101,c,i+1,char);
+ (void)bcopy(string, c, i+1);
+ string = c;
+ strend = string + i;
+ for (s = string; s < strend; s++)
+ if (isUPPER(*s))
+ *s = tolower(*s);
+ }
+
+ /* If there is a "must appear" string, look for it. */
+ s = string;
+ if (prog->regmust != Nullstr &&
+ (!(prog->reganch & ROPT_ANCH)
+ || (multiline && prog->regback >= 0)) ) {
+ if (stringarg == strbeg && screamer) {
+ if (screamfirst[prog->regmust->str_rare] >= 0)
+ s = screaminstr(screamer,prog->regmust);
+ else
+ s = Nullch;
+ }
+#ifndef lint
+ else
+ s = fbminstr((unsigned char*)s, (unsigned char*)strend,
+ prog->regmust);
+#endif
+ if (!s) {
+ ++prog->regmust->str_u.str_useful; /* hooray */
+ goto phooey; /* not present */
+ }
+ else if (prog->regback >= 0) {
+ s -= prog->regback;
+ if (s < string)
+ s = string;
+ minlen = prog->regback + prog->regmust->str_cur;
+ }
+ else if (--prog->regmust->str_u.str_useful < 0) { /* boo */
+ str_free(prog->regmust);
+ prog->regmust = Nullstr; /* disable regmust */
+ s = string;
+ }
+ else {
+ s = string;
+ minlen = prog->regmust->str_cur;
+ }
+ }
+
+ /* Mark beginning of line for ^ . */
+ regbol = string;
+
+ /* 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;
+
+ /* 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, string))
+ 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;
+ }
+ }
+ }
+ goto phooey;
+ }
+
+ /* Messy cases: unanchored match. */
+ if (prog->regstart) {
+ if (prog->reganch & ROPT_SKIP) { /* we have /x+whatever/ */
+ /* it must be a one character string */
+ i = prog->regstart->str_ptr[0];
+ while (s < strend) {
+ if (*s == i) {
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ while (s < strend && *s == i)
+ s++;
+ }
+ s++;
+ }
+ }
+ else if (prog->regstart->str_pok == 3) {
+ /* We know what string it must start with. */
+#ifndef lint
+ while ((s = fbminstr((unsigned char*)s,
+ (unsigned char*)strend, prog->regstart)) != NULL)
+#else
+ while (s = Nullch)
+#endif
+ {
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ }
+ else {
+ c = prog->regstart->str_ptr;
+ while ((s = ninstr(s, strend,
+ c, c + prog->regstart->str_cur )) != NULL) {
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ }
+ goto phooey;
+ }
+ /*SUPPRESS 560*/
+ if (c = prog->regstclass) {
+ int 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);
+ }
+ 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);
+ }
+ 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;
+ }
+ }
+ 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:
+ if ((!safebase && (prog->nparens || sawampersand)) || prog->do_folding){
+ strend += dontbother; /* uncheat */
+ if (safebase) /* no need for $digit later */
+ s = strbeg;
+ else if (strbeg != prog->subbase) {
+ i = strend - string + (stringarg - strbeg);
+ 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
+ s = prog->subbase;
+ 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);
+ }
+ }
+ if (prog->do_folding)
+ Safefree(string);
+ }
+ return(1);
+
+ phooey:
+ if (prog->do_folding)
+ Safefree(string);
+ return(0);
+}
+
+/*
+ - regtry - try match at specific point
+ */
+static int /* 0 failure, 1 success */
+regtry(prog, string)
+regexp *prog;
+char *string;
+{
+ register int 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;
+ }
+ }
+ if (regmatch(prog->program + 1) && reginput >= regtill) {
+ prog->startp[0] = string;
+ prog->endp[0] = reginput;
+ return(1);
+ } else
+ return(0);
+}
+
+/*
+ - regmatch - main matching routine
+ *
+ * Conceptually the strategy is simple: check to see whether the current
+ * node matches, call self recursively to see whether the rest matches,
+ * and then act accordingly. In practice we make some effort to avoid
+ * recursion, in particular by going through "ordinary" nodes (that don't
+ * need to know whether the rest of the match failed) by a loop instead of
+ * by recursion.
+ */
+/* [lwall] I've hoisted the register declarations to the outer block in order to
+ * maybe save a little bit of pushing and popping on the stack. It also takes
+ * advantage of machines that use a register save mask on subroutine entry.
+ */
+static int /* 0 failure, 1 success */
+regmatch(prog)
+char *prog;
+{
+ register char *scan; /* Current node. */
+ char *next; /* Next node. */
+ register int nextchar;
+ register int n; /* no or next */
+ register int 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) {
+#ifdef DEBUGGING
+ if (regnarrate)
+ fprintf(stderr, "%s...\n", regprop(scan));
+#endif
+
+#ifdef REGALIGN
+ next = scan + NEXT(scan);
+ if (next == scan)
+ next = NULL;
+#else
+ 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;
+
+ 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);
+#ifdef REGALIGN
+ /*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;
+ 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 = 0;
+ scan = NEXTOPER(scan);
+ goto repeat;
+ case PLUS:
+ /*
+ * Lookahead to avoid useless match attempts
+ * when we know what character comes next.
+ */
+ ln = 1;
+ n = 0;
+ scan = NEXTOPER(scan);
+ repeat:
+ if (OP(next) == EXACTLY)
+ nextchar = *(OPERAND(next)+1);
+ else
+ nextchar = -1000;
+ reginput = locinput;
+ 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");
+ }
+
+ 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
+}
+
+/*
+ - regrepeat - repeatedly match something simple, report how many
+ */
+/*
+ * [This routine now assumes that it will only match on things of length 1.
+ * That was true before, but now we assume scan - reginput is the count,
+ * rather than incrementing count on every character.]
+ */
+static int
+regrepeat(p, max)
+char *p;
+int max;
+{
+ register char *scan;
+ register char *opnd;
+ register int c;
+ register char *loceol = regeol;
+
+ scan = reginput;
+ if (max && 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 */
+ }
+
+ c = scan - reginput;
+ reginput = scan;
+
+ return(c);
+}
+
+/*
+ - regnext - dig the "next" pointer out of a node
+ *
+ * [Note, when REGALIGN is defined there are two places in regmatch()
+ * that bypass this code for speed.]
+ */
+char *
+regnext(p)
+register char *p;
+{
+ register int offset;
+
+ if (p == ®dummy)
+ return(NULL);
+
+ offset = NEXT(p);
+ if (offset == 0)
+ return(NULL);
+
+#ifdef REGALIGN
+ return(p+offset);
+#else
+ if (OP(p) == BACK)
+ return(p-offset);
+ else
+ return(p+offset);
+#endif
+}
--- /dev/null
+/*
+ * Definitions etc. for regexp(3) routines.
+ *
+ * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof],
+ * not the System V one.
+ */
+
+/* $RCSfile: regexp.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:24:31 $
+ *
+ * $Log: regexp.h,v $
+ * 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;
+ char **endp;
+ STR *regstart; /* Internal use only. */
+ char *regstclass;
+ STR *regmust; /* Internal use only. */
+ int regback; /* Can regmust locate first try? */
+ int minlen; /* mininum possible length of $& */
+ int prelen; /* length of precomp */
+ 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 */
+ 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;
+
+#define ROPT_ANCH 1
+#define ROPT_SKIP 2
+#define ROPT_IMPLICIT 4
+
+regexp *regcomp();
+int regexec();
--- /dev/null
+#!./perl
+
+$pat = 'S n C4 x8';
+$inet = 2;
+$echo = 7;
+$smtp = 25;
+$nntp = 119;
+
+$this = pack($pat,$inet,2345, 0,0,0,0);
+select(NS); $| = 1; select(stdout);
+
+if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; }
+if (bind(S,$this)) { print "bind ok\n"; } else { die $!; }
+if (listen(S,5)) { print "listen ok\n"; } else { die $!; }
+for (;;) {
+ print "Listening again\n";
+ if ($addr = accept(NS,S)) { print "accept ok\n"; } else { die $!; }
+
+ @ary = unpack($pat,$addr);
+ $, = ' ';
+ print @ary; print "\n";
+
+ while (<NS>) {
+ print;
+ print NS;
+ }
+}
--- /dev/null
+/* $RCSfile: spat.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:51:59 $
+ *
+ * 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: spat.h,v $
+ * Revision 4.0.1.1 91/06/07 11:51:59 lwall
+ * patch4: new copyright notice
+ * patch4: added global modifier for pattern matches
+ *
+ * Revision 4.0 91/03/20 01:39:36 lwall
+ * 4.0 baseline.
+ *
+ */
+
+struct scanpat {
+ SPAT *spat_next; /* list of all scanpats */
+ REGEXP *spat_regexp; /* compiled expression */
+ ARG *spat_repl; /* replacement string for subst */
+ ARG *spat_runtime; /* compile pattern at runtime */
+ STR *spat_short; /* for a fast bypass of execute() */
+ short spat_flags;
+ char spat_slen;
+};
+
+#define SPAT_USED 1 /* spat has been used once already */
+#define SPAT_ONCE 2 /* use pattern only once per reset */
+#define SPAT_SCANFIRST 4 /* initial constant not anchored */
+#define SPAT_ALL 8 /* initial constant is whole pat */
+#define SPAT_SKIPWHITE 16 /* skip leading whitespace for split */
+#define SPAT_FOLD 32 /* case insensitivity */
+#define SPAT_CONST 64 /* subst replacement is constant */
+#define SPAT_KEEP 128 /* keep 1st runtime pattern forever */
+#define SPAT_GLOBAL 256 /* pattern had a g modifier */
+
+EXT SPAT *curspat; /* what to do \ interps from */
+EXT SPAT *lastspat; /* what to use in place of null pattern */
+
+EXT char *hint INIT(Nullch); /* hint from cmd_exec to do_match et al */
+
+#define Nullspat Null(SPAT*)
--- /dev/null
+/* $RCSfile: stab.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:36:15 $
+ *
+ * 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: stab.h,v $
+ * 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 stabptrs {
+ char stbp_magic[4];
+ STR *stbp_val; /* scalar value */
+ struct stio *stbp_io; /* filehandle value */
+ FCMD *stbp_form; /* format value */
+ ARRAY *stbp_array; /* array value */
+ HASH *stbp_hash; /* associative array value */
+ HASH *stbp_stash; /* symbol table for this stab */
+ SUBR *stbp_sub; /* subroutine value */
+ int stbp_lastexpr; /* used by nothing_in_common() */
+ line_t stbp_line; /* line first declared at (for -w) */
+ char stbp_flags;
+};
+
+#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
+#define MICROPORT
+#endif
+
+#define stab_magic(stab) (((STBP*)(stab->str_ptr))->stbp_magic)
+#define stab_val(stab) (((STBP*)(stab->str_ptr))->stbp_val)
+#define stab_io(stab) (((STBP*)(stab->str_ptr))->stbp_io)
+#define stab_form(stab) (((STBP*)(stab->str_ptr))->stbp_form)
+#define stab_xarray(stab) (((STBP*)(stab->str_ptr))->stbp_array)
+#ifdef MICROPORT /* Microport 2.4 hack */
+ARRAY *stab_array();
+#else
+#define stab_array(stab) (((STBP*)(stab->str_ptr))->stbp_array ? \
+ ((STBP*)(stab->str_ptr))->stbp_array : \
+ ((STBP*)(aadd(stab)->str_ptr))->stbp_array)
+#endif
+#define stab_xhash(stab) (((STBP*)(stab->str_ptr))->stbp_hash)
+#ifdef MICROPORT /* Microport 2.4 hack */
+HASH *stab_hash();
+#else
+#define stab_hash(stab) (((STBP*)(stab->str_ptr))->stbp_hash ? \
+ ((STBP*)(stab->str_ptr))->stbp_hash : \
+ ((STBP*)(hadd(stab)->str_ptr))->stbp_hash)
+#endif /* Microport 2.4 hack */
+#define stab_stash(stab) (((STBP*)(stab->str_ptr))->stbp_stash)
+#define stab_sub(stab) (((STBP*)(stab->str_ptr))->stbp_sub)
+#define stab_lastexpr(stab) (((STBP*)(stab->str_ptr))->stbp_lastexpr)
+#define stab_line(stab) (((STBP*)(stab->str_ptr))->stbp_line)
+#define stab_flags(stab) (((STBP*)(stab->str_ptr))->stbp_flags)
+#define stab_name(stab) (stab->str_magic->str_ptr)
+
+#define SF_VMAGIC 1 /* call routine to dereference STR val */
+#define SF_MULTI 2 /* seen more than once */
+
+struct stio {
+ FILE *ifp; /* ifp and ofp are normally the same */
+ FILE *ofp; /* but sockets need separate streams */
+#ifdef HAS_READDIR
+ DIR *dirp; /* for opendir, readdir, etc */
+#endif
+ long lines; /* $. */
+ long page; /* $% */
+ long page_len; /* $= */
+ long lines_left; /* $- */
+ char *top_name; /* $^ */
+ STAB *top_stab; /* $^ */
+ char *fmt_name; /* $~ */
+ STAB *fmt_stab; /* $~ */
+ short subprocess; /* -| or |- */
+ char type;
+ char flags;
+};
+
+#define IOF_ARGV 1 /* this fp iterates over ARGV */
+#define IOF_START 2 /* check for null ARGV and substitute '-' */
+#define IOF_FLUSH 4 /* this fp wants a flush after write op */
+
+struct sub {
+ CMD *cmd;
+ int (*usersub)();
+ int userindex;
+ STAB *filestab;
+ long depth; /* >= 2 indicates recursive call */
+ ARRAY *tosave;
+};
+
+#define Nullstab Null(STAB*)
+
+STRLEN stab_len();
+
+#define STAB_STR(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_str(stab_val(tmpstab)->str_magic) : stab_val(tmpstab))
+#define STAB_LEN(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_len(stab_val(tmpstab)->str_magic) : str_len(stab_val(tmpstab)))
+#define STAB_GET(s) (tmpstab = (s), str_get(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
+#define STAB_GNUM(s) (tmpstab = (s), str_gnum(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
+
+EXT STAB *tmpstab;
+
+EXT STAB *stab_index[128];
+
+EXT unsigned short statusvalue;
+
+EXT int delaymagic INIT(0);
+#define DM_DELAY 1
+#define DM_REUID 2
+#define DM_REGID 4
+
+STAB *aadd();
+STAB *hadd();
+STAB *fstab();
--- /dev/null
+/* $RCSfile: str.c,v $$Revision: 4.0.1.4 $$Date: 91/11/05 18:40:51 $
+ *
+ * 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: str.c,v $
+ * 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.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "perly.h"
+
+#ifndef str_get
+char *
+str_get(str)
+STR *str;
+{
+#ifdef TAINT
+ tainted |= str->str_tainted;
+#endif
+ return str->str_pok ? str->str_ptr : str_2ptr(str);
+}
+#endif
+
+/* dlb ... guess we have a "crippled cc".
+ * dlb the following functions are usually macros.
+ */
+#ifndef str_true
+str_true(Str)
+STR *Str;
+{
+ if (Str->str_pok) {
+ if (*Str->str_ptr > '0' ||
+ Str->str_cur > 1 ||
+ (Str->str_cur && *Str->str_ptr != '0'))
+ return 1;
+ return 0;
+ }
+ if (Str->str_nok)
+ return (Str->str_u.str_nval != 0.0);
+ return 0;
+}
+#endif /* str_true */
+
+#ifndef str_gnum
+double str_gnum(Str)
+STR *Str;
+{
+#ifdef TAINT
+ tainted |= Str->str_tainted;
+#endif /* TAINT*/
+ if (Str->str_nok)
+ return Str->str_u.str_nval;
+ return str_2num(Str);
+}
+#endif /* str_gnum */
+/* dlb ... end of crutch */
+
+char *
+str_grow(str,newlen)
+register STR *str;
+#ifndef MSDOS
+register int newlen;
+#else
+unsigned long newlen;
+#endif
+{
+ register char *s = str->str_ptr;
+
+#ifdef MSDOS
+ if (newlen >= 0x10000) {
+ fprintf(stderr, "Allocation too large: %lx\n", newlen);
+ exit(1);
+ }
+#endif /* MSDOS */
+ if (str->str_state == SS_INCR) { /* data before str_ptr? */
+ str->str_len += str->str_u.str_useful;
+ str->str_ptr -= str->str_u.str_useful;
+ str->str_u.str_useful = 0L;
+ bcopy(s, str->str_ptr, str->str_cur+1);
+ s = str->str_ptr;
+ str->str_state = SS_NORM; /* normal again */
+ if (newlen > str->str_len)
+ newlen += 10 * (newlen - str->str_cur); /* avoid copy each time */
+ }
+ if (newlen > str->str_len) { /* need more room? */
+ if (str->str_len)
+ Renew(s,newlen,char);
+ else
+ New(703,s,newlen,char);
+ str->str_ptr = s;
+ str->str_len = newlen;
+ }
+ return s;
+}
+
+str_numset(str,num)
+register STR *str;
+double num;
+{
+ if (str->str_pok) {
+ str->str_pok = 0; /* invalidate pointer */
+ if (str->str_state == SS_INCR)
+ Str_Grow(str,0);
+ }
+ str->str_u.str_nval = num;
+ str->str_state = SS_NORM;
+ str->str_nok = 1; /* validate number */
+#ifdef TAINT
+ str->str_tainted = tainted;
+#endif
+}
+
+char *
+str_2ptr(str)
+register STR *str;
+{
+ register char *s;
+ int olderrno;
+
+ if (!str)
+ return "";
+ if (str->str_nok) {
+ STR_GROW(str, 30);
+ s = str->str_ptr;
+ olderrno = errno; /* some Xenix systems wipe out errno here */
+#if defined(scs) && defined(ns32000)
+ gcvt(str->str_u.str_nval,20,s);
+#else
+#ifdef apollo
+ if (str->str_u.str_nval == 0.0)
+ (void)strcpy(s,"0");
+ else
+#endif /*apollo*/
+ (void)sprintf(s,"%.20g",str->str_u.str_nval);
+#endif /*scs*/
+ errno = olderrno;
+ while (*s) s++;
+#ifdef hcx
+ if (s[-1] == '.')
+ s--;
+#endif
+ }
+ else {
+ if (str == &str_undef)
+ return No;
+ if (dowarn)
+ warn("Use of uninitialized variable");
+ STR_GROW(str, 30);
+ s = str->str_ptr;
+ }
+ *s = '\0';
+ str->str_cur = s - str->str_ptr;
+ str->str_pok = 1;
+#ifdef DEBUGGING
+ if (debug & 32)
+ fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr);
+#endif
+ return str->str_ptr;
+}
+
+double
+str_2num(str)
+register STR *str;
+{
+ if (!str)
+ return 0.0;
+ if (str->str_state == SS_INCR)
+ Str_Grow(str,0); /* just force copy down */
+ str->str_state = SS_NORM;
+ if (str->str_len && str->str_pok)
+ str->str_u.str_nval = atof(str->str_ptr);
+ else {
+ if (str == &str_undef)
+ return 0.0;
+ if (dowarn)
+ warn("Use of uninitialized variable");
+ str->str_u.str_nval = 0.0;
+ }
+ str->str_nok = 1;
+#ifdef DEBUGGING
+ if (debug & 32)
+ fprintf(stderr,"0x%lx num(%g)\n",str,str->str_u.str_nval);
+#endif
+ return str->str_u.str_nval;
+}
+
+/* Note: str_sset() should not be called with a source string that needs
+ * be reused, since it may destroy the source string if it is marked
+ * as temporary.
+ */
+
+str_sset(dstr,sstr)
+STR *dstr;
+register STR *sstr;
+{
+#ifdef TAINT
+ if (sstr)
+ tainted |= sstr->str_tainted;
+#endif
+ if (sstr == dstr || dstr == &str_undef)
+ return;
+ if (!sstr)
+ dstr->str_pok = dstr->str_nok = 0;
+ else if (sstr->str_pok) {
+
+ /*
+ * Check to see if we can just swipe the string. If so, it's a
+ * possible small lose on short strings, but a big win on long ones.
+ * It might even be a win on short strings if dstr->str_ptr
+ * has to be allocated and sstr->str_ptr has to be freed.
+ */
+
+ if (sstr->str_pok & SP_TEMP) { /* slated for free anyway? */
+ if (dstr->str_ptr) {
+ if (dstr->str_state == SS_INCR)
+ dstr->str_ptr -= dstr->str_u.str_useful;
+ Safefree(dstr->str_ptr);
+ }
+ dstr->str_ptr = sstr->str_ptr;
+ dstr->str_len = sstr->str_len;
+ dstr->str_cur = sstr->str_cur;
+ dstr->str_state = sstr->str_state;
+ dstr->str_pok = sstr->str_pok & ~SP_TEMP;
+#ifdef TAINT
+ dstr->str_tainted = sstr->str_tainted;
+#endif
+ sstr->str_ptr = Nullch;
+ sstr->str_len = 0;
+ sstr->str_pok = 0; /* wipe out any weird flags */
+ sstr->str_state = 0; /* so sstr frees uneventfully */
+ }
+ else { /* have to copy actual string */
+ if (dstr->str_ptr) {
+ if (dstr->str_state == SS_INCR) {
+ Str_Grow(dstr,0);
+ }
+ }
+ str_nset(dstr,sstr->str_ptr,sstr->str_cur);
+ }
+ /*SUPPRESS 560*/
+ if (dstr->str_nok = sstr->str_nok)
+ dstr->str_u.str_nval = sstr->str_u.str_nval;
+ else {
+#ifdef STRUCTCOPY
+ dstr->str_u = sstr->str_u;
+#else
+ dstr->str_u.str_nval = sstr->str_u.str_nval;
+#endif
+ if (dstr->str_cur == sizeof(STBP)) {
+ char *tmps = dstr->str_ptr;
+
+ if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) {
+ if (!dstr->str_magic) {
+ dstr->str_magic = str_smake(sstr->str_magic);
+ dstr->str_magic->str_rare = 'X';
+ }
+ }
+ }
+ }
+ }
+ else if (sstr->str_nok)
+ str_numset(dstr,sstr->str_u.str_nval);
+ else {
+ if (dstr->str_state == SS_INCR)
+ Str_Grow(dstr,0); /* just force copy down */
+
+#ifdef STRUCTCOPY
+ dstr->str_u = sstr->str_u;
+#else
+ dstr->str_u.str_nval = sstr->str_u.str_nval;
+#endif
+ dstr->str_pok = dstr->str_nok = 0;
+ }
+}
+
+str_nset(str,ptr,len)
+register STR *str;
+register char *ptr;
+register STRLEN len;
+{
+ if (str == &str_undef)
+ return;
+ STR_GROW(str, len + 1);
+ if (ptr)
+ (void)bcopy(ptr,str->str_ptr,len);
+ str->str_cur = len;
+ *(str->str_ptr+str->str_cur) = '\0';
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+#ifdef TAINT
+ str->str_tainted = tainted;
+#endif
+}
+
+str_set(str,ptr)
+register STR *str;
+register char *ptr;
+{
+ register STRLEN len;
+
+ if (str == &str_undef)
+ return;
+ if (!ptr)
+ ptr = "";
+ len = strlen(ptr);
+ STR_GROW(str, len + 1);
+ (void)bcopy(ptr,str->str_ptr,len+1);
+ str->str_cur = len;
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+#ifdef TAINT
+ str->str_tainted = tainted;
+#endif
+}
+
+str_chop(str,ptr) /* like set but assuming ptr is in str */
+register STR *str;
+register char *ptr;
+{
+ register STRLEN delta;
+
+ if (!ptr || !(str->str_pok))
+ return;
+ delta = ptr - str->str_ptr;
+ str->str_len -= delta;
+ str->str_cur -= delta;
+ str->str_ptr += delta;
+ if (str->str_state == SS_INCR)
+ str->str_u.str_useful += delta;
+ else {
+ str->str_u.str_useful = delta;
+ str->str_state = SS_INCR;
+ }
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer (and unstudy str) */
+}
+
+str_ncat(str,ptr,len)
+register STR *str;
+register char *ptr;
+register STRLEN len;
+{
+ if (str == &str_undef)
+ return;
+ if (!(str->str_pok))
+ (void)str_2ptr(str);
+ STR_GROW(str, str->str_cur + len + 1);
+ (void)bcopy(ptr,str->str_ptr+str->str_cur,len);
+ str->str_cur += len;
+ *(str->str_ptr+str->str_cur) = '\0';
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+#ifdef TAINT
+ str->str_tainted |= tainted;
+#endif
+}
+
+str_scat(dstr,sstr)
+STR *dstr;
+register STR *sstr;
+{
+ if (!sstr)
+ return;
+#ifdef TAINT
+ tainted |= sstr->str_tainted;
+#endif
+ if (!(sstr->str_pok))
+ (void)str_2ptr(sstr);
+ if (sstr)
+ str_ncat(dstr,sstr->str_ptr,sstr->str_cur);
+}
+
+str_cat(str,ptr)
+register STR *str;
+register char *ptr;
+{
+ register STRLEN len;
+
+ if (str == &str_undef)
+ return;
+ if (!ptr)
+ return;
+ if (!(str->str_pok))
+ (void)str_2ptr(str);
+ len = strlen(ptr);
+ STR_GROW(str, str->str_cur + len + 1);
+ (void)bcopy(ptr,str->str_ptr+str->str_cur,len+1);
+ str->str_cur += len;
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+#ifdef TAINT
+ str->str_tainted |= tainted;
+#endif
+}
+
+char *
+str_append_till(str,from,fromend,delim,keeplist)
+register STR *str;
+register char *from;
+register char *fromend;
+register int delim;
+char *keeplist;
+{
+ register char *to;
+ register STRLEN len;
+
+ if (str == &str_undef)
+ return Nullch;
+ if (!from)
+ return Nullch;
+ len = fromend - from;
+ STR_GROW(str, str->str_cur + len + 1);
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+ to = str->str_ptr+str->str_cur;
+ for (; from < fromend; from++,to++) {
+ if (*from == '\\' && from+1 < fromend && delim != '\\') {
+ if (!keeplist) {
+ if (from[1] == delim || from[1] == '\\')
+ from++;
+ else
+ *to++ = *from++;
+ }
+ else if (from[1] && index(keeplist,from[1]))
+ *to++ = *from++;
+ else
+ from++;
+ }
+ else if (*from == delim)
+ break;
+ *to = *from;
+ }
+ *to = '\0';
+ str->str_cur = to - str->str_ptr;
+ return from;
+}
+
+STR *
+#ifdef LEAKTEST
+str_new(x,len)
+int x;
+#else
+str_new(len)
+#endif
+STRLEN len;
+{
+ register STR *str;
+
+ if (freestrroot) {
+ str = freestrroot;
+ freestrroot = str->str_magic;
+ str->str_magic = Nullstr;
+ str->str_state = SS_NORM;
+ }
+ else {
+ Newz(700+x,str,1,STR);
+ }
+ if (len)
+ STR_GROW(str, len + 1);
+ return str;
+}
+
+void
+str_magic(str, stab, how, name, namlen)
+register STR *str;
+STAB *stab;
+int how;
+char *name;
+STRLEN namlen;
+{
+ if (str == &str_undef || str->str_magic)
+ return;
+ str->str_magic = Str_new(75,namlen);
+ str = str->str_magic;
+ str->str_u.str_stab = stab;
+ str->str_rare = how;
+ if (name)
+ str_nset(str,name,namlen);
+}
+
+void
+str_insert(bigstr,offset,len,little,littlelen)
+STR *bigstr;
+STRLEN offset;
+STRLEN len;
+char *little;
+STRLEN littlelen;
+{
+ register char *big;
+ register char *mid;
+ register char *midend;
+ register char *bigend;
+ register int i;
+
+ if (bigstr == &str_undef)
+ return;
+ bigstr->str_nok = 0;
+ bigstr->str_pok = SP_VALID; /* disable possible screamer */
+
+ i = littlelen - len;
+ if (i > 0) { /* string might grow */
+ STR_GROW(bigstr, bigstr->str_cur + i + 1);
+ big = bigstr->str_ptr;
+ mid = big + offset + len;
+ midend = bigend = big + bigstr->str_cur;
+ bigend += i;
+ *bigend = '\0';
+ while (midend > mid) /* shove everything down */
+ *--bigend = *--midend;
+ (void)bcopy(little,big+offset,littlelen);
+ bigstr->str_cur += i;
+ STABSET(bigstr);
+ return;
+ }
+ else if (i == 0) {
+ (void)bcopy(little,bigstr->str_ptr+offset,len);
+ STABSET(bigstr);
+ return;
+ }
+
+ big = bigstr->str_ptr;
+ mid = big + offset;
+ midend = mid + len;
+ bigend = big + bigstr->str_cur;
+
+ if (midend > bigend)
+ fatal("panic: str_insert");
+
+ if (mid - big > bigend - midend) { /* faster to shorten from end */
+ if (littlelen) {
+ (void)bcopy(little, mid, littlelen);
+ mid += littlelen;
+ }
+ i = bigend - midend;
+ if (i > 0) {
+ (void)bcopy(midend, mid, i);
+ mid += i;
+ }
+ *mid = '\0';
+ bigstr->str_cur = mid - big;
+ }
+ /*SUPPRESS 560*/
+ else if (i = mid - big) { /* faster from front */
+ midend -= littlelen;
+ mid = midend;
+ str_chop(bigstr,midend-i);
+ big += i;
+ while (i--)
+ *--midend = *--big;
+ if (littlelen)
+ (void)bcopy(little, mid, littlelen);
+ }
+ else if (littlelen) {
+ midend -= littlelen;
+ str_chop(bigstr,midend);
+ (void)bcopy(little,midend,littlelen);
+ }
+ else {
+ str_chop(bigstr,midend);
+ }
+ STABSET(bigstr);
+}
+
+/* make str point to what nstr did */
+
+void
+str_replace(str,nstr)
+register STR *str;
+register STR *nstr;
+{
+ if (str == &str_undef)
+ return;
+ if (str->str_state == SS_INCR)
+ Str_Grow(str,0); /* just force copy down */
+ if (nstr->str_state == SS_INCR)
+ Str_Grow(nstr,0);
+ if (str->str_ptr)
+ Safefree(str->str_ptr);
+ str->str_ptr = nstr->str_ptr;
+ str->str_len = nstr->str_len;
+ str->str_cur = nstr->str_cur;
+ str->str_pok = nstr->str_pok;
+ str->str_nok = nstr->str_nok;
+#ifdef STRUCTCOPY
+ str->str_u = nstr->str_u;
+#else
+ str->str_u.str_nval = nstr->str_u.str_nval;
+#endif
+#ifdef TAINT
+ str->str_tainted = nstr->str_tainted;
+#endif
+ if (nstr->str_magic)
+ str_free(nstr->str_magic);
+ Safefree(nstr);
+}
+
+void
+str_free(str)
+register STR *str;
+{
+ if (!str || str == &str_undef)
+ return;
+ if (str->str_state) {
+ if (str->str_state == SS_FREE) /* already freed */
+ return;
+ if (str->str_state == SS_INCR && !(str->str_pok & 2)) {
+ str->str_ptr -= str->str_u.str_useful;
+ str->str_len += str->str_u.str_useful;
+ }
+ }
+ if (str->str_magic)
+ str_free(str->str_magic);
+ str->str_magic = freestrroot;
+#ifdef LEAKTEST
+ if (str->str_len) {
+ Safefree(str->str_ptr);
+ str->str_ptr = Nullch;
+ }
+ if ((str->str_pok & SP_INTRP) && str->str_u.str_args)
+ arg_free(str->str_u.str_args);
+ Safefree(str);
+#else /* LEAKTEST */
+ if (str->str_len) {
+ if (str->str_len > 127) { /* next user not likely to want more */
+ Safefree(str->str_ptr); /* so give it back to malloc */
+ str->str_ptr = Nullch;
+ str->str_len = 0;
+ }
+ else
+ str->str_ptr[0] = '\0';
+ }
+ if ((str->str_pok & SP_INTRP) && str->str_u.str_args)
+ arg_free(str->str_u.str_args);
+ str->str_cur = 0;
+ str->str_nok = 0;
+ str->str_pok = 0;
+ str->str_state = SS_FREE;
+#ifdef TAINT
+ str->str_tainted = 0;
+#endif
+ freestrroot = str;
+#endif /* LEAKTEST */
+}
+
+STRLEN
+str_len(str)
+register STR *str;
+{
+ if (!str)
+ return 0;
+ if (!(str->str_pok))
+ (void)str_2ptr(str);
+ if (str->str_ptr)
+ return str->str_cur;
+ else
+ return 0;
+}
+
+str_eq(str1,str2)
+register STR *str1;
+register STR *str2;
+{
+ if (!str1 || str1 == &str_undef)
+ return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur);
+ if (!str2 || str2 == &str_undef)
+ return !str1->str_cur;
+
+ if (!str1->str_pok)
+ (void)str_2ptr(str1);
+ if (!str2->str_pok)
+ (void)str_2ptr(str2);
+
+ if (str1->str_cur != str2->str_cur)
+ return 0;
+
+ return !bcmp(str1->str_ptr, str2->str_ptr, str1->str_cur);
+}
+
+str_cmp(str1,str2)
+register STR *str1;
+register STR *str2;
+{
+ int retval;
+
+ if (!str1 || str1 == &str_undef)
+ return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur)?0:-1;
+ if (!str2 || str2 == &str_undef)
+ return str1->str_cur != 0;
+
+ if (!str1->str_pok)
+ (void)str_2ptr(str1);
+ if (!str2->str_pok)
+ (void)str_2ptr(str2);
+
+ if (str1->str_cur < str2->str_cur) {
+ /*SUPPRESS 560*/
+ if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
+ return retval < 0 ? -1 : 1;
+ else
+ return -1;
+ }
+ /*SUPPRESS 560*/
+ else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
+ return retval < 0 ? -1 : 1;
+ else if (str1->str_cur == str2->str_cur)
+ return 0;
+ else
+ return 1;
+}
+
+char *
+str_gets(str,fp,append)
+register STR *str;
+register FILE *fp;
+int append;
+{
+ register char *bp; /* we're going to steal some values */
+ register int cnt; /* from the stdio struct and put EVERYTHING */
+ register STDCHAR *ptr; /* in the innermost loop into registers */
+ register int newline = rschar;/* (assuming >= 6 registers) */
+ int i;
+ STRLEN bpx;
+ int shortbuffered;
+
+ if (str == &str_undef)
+ return Nullch;
+#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */
+ cnt = fp->_cnt; /* get count into register */
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+ if (str->str_len - append <= cnt + 1) { /* make sure we have the room */
+ if (cnt > 80 && str->str_len > append) {
+ shortbuffered = cnt - str->str_len + append + 1;
+ cnt -= shortbuffered;
+ }
+ else {
+ shortbuffered = 0;
+ STR_GROW(str, append+cnt+2);/* (remembering cnt can be -1) */
+ }
+ }
+ else
+ shortbuffered = 0;
+ bp = str->str_ptr + append; /* move these two too to registers */
+ ptr = fp->_ptr;
+ for (;;) {
+ screamer:
+ while (--cnt >= 0) { /* this */ /* eat */
+ if ((*bp++ = *ptr++) == newline) /* really */ /* dust */
+ goto thats_all_folks; /* screams */ /* sed :-) */
+ }
+
+ if (shortbuffered) { /* oh well, must extend */
+ cnt = shortbuffered;
+ shortbuffered = 0;
+ bpx = bp - str->str_ptr; /* prepare for possible relocation */
+ str->str_cur = bpx;
+ STR_GROW(str, str->str_len + append + cnt + 2);
+ bp = str->str_ptr + bpx; /* reconstitute our pointer */
+ continue;
+ }
+
+ fp->_cnt = cnt; /* deregisterize cnt and ptr */
+ fp->_ptr = ptr;
+ i = _filbuf(fp); /* get more characters */
+ cnt = fp->_cnt;
+ ptr = fp->_ptr; /* reregisterize cnt and ptr */
+
+ bpx = bp - str->str_ptr; /* prepare for possible relocation */
+ str->str_cur = bpx;
+ STR_GROW(str, bpx + cnt + 2);
+ bp = str->str_ptr + bpx; /* reconstitute our pointer */
+
+ if (i == newline) { /* all done for now? */
+ *bp++ = i;
+ goto thats_all_folks;
+ }
+ else if (i == EOF) /* all done for ever? */
+ goto thats_really_all_folks;
+ *bp++ = i; /* now go back to screaming loop */
+ }
+
+thats_all_folks:
+ if (rslen > 1 && (bp - str->str_ptr < rslen || bcmp(bp - rslen, rs, rslen)))
+ goto screamer; /* go back to the fray */
+thats_really_all_folks:
+ if (shortbuffered)
+ cnt += shortbuffered;
+ fp->_cnt = cnt; /* put these back or we're in trouble */
+ fp->_ptr = ptr;
+ *bp = '\0';
+ str->str_cur = bp - str->str_ptr; /* set length */
+
+#else /* !STDSTDIO */ /* The big, slow, and stupid way */
+
+ {
+ static char buf[8192];
+ char * bpe = buf + sizeof(buf) - 3;
+
+screamer:
+ bp = buf;
+ while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) ;
+
+ *bp = '\0';
+ if (append)
+ str_cat(str, buf);
+ else
+ str_set(str, buf);
+ if (i != EOF /* joy */
+ &&
+ (i != newline
+ ||
+ (rslen > 1
+ &&
+ (str->str_cur < rslen
+ ||
+ bcmp(str->str_ptr + str->str_cur - rslen, rs, rslen)
+ )
+ )
+ )
+ )
+ {
+ append = -1;
+ goto screamer;
+ }
+ }
+
+#endif /* STDSTDIO */
+
+ return str->str_cur - append ? str->str_ptr : Nullch;
+}
+
+ARG *
+parselist(str)
+STR *str;
+{
+ register CMD *cmd;
+ register ARG *arg;
+ CMD *oldcurcmd = curcmd;
+ int oldperldb = perldb;
+ int retval;
+
+ perldb = 0;
+ str_sset(linestr,str);
+ in_eval++;
+ oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
+ bufend = bufptr + linestr->str_cur;
+ if (++loop_ptr >= loop_max) {
+ loop_max += 128;
+ Renew(loop_stack, loop_max, struct loop);
+ }
+ loop_stack[loop_ptr].loop_label = "_EVAL_";
+ loop_stack[loop_ptr].loop_sp = 0;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
+ }
+#endif
+ if (setjmp(loop_stack[loop_ptr].loop_env)) {
+ in_eval--;
+ loop_ptr--;
+ perldb = oldperldb;
+ fatal("%s\n",stab_val(stabent("@",TRUE))->str_ptr);
+ }
+#ifdef DEBUGGING
+ if (debug & 4) {
+ char *tmps = loop_stack[loop_ptr].loop_label;
+ deb("(Popping label #%d %s)\n",loop_ptr,
+ tmps ? tmps : "" );
+ }
+#endif
+ loop_ptr--;
+ error_count = 0;
+ curcmd = &compiling;
+ curcmd->c_line = oldcurcmd->c_line;
+ retval = yyparse();
+ curcmd = oldcurcmd;
+ perldb = oldperldb;
+ in_eval--;
+ if (retval || error_count)
+ fatal("Invalid component in string or format");
+ cmd = eval_root;
+ arg = cmd->c_expr;
+ if (cmd->c_type != C_EXPR || cmd->c_next || arg->arg_type != O_LIST)
+ fatal("panic: error in parselist %d %x %d", cmd->c_type,
+ cmd->c_next, arg ? arg->arg_type : -1);
+ Safefree(cmd);
+ eval_root = Nullcmd;
+ return arg;
+}
+
+void
+intrpcompile(src)
+STR *src;
+{
+ register char *s = str_get(src);
+ register char *send = s + src->str_cur;
+ register STR *str;
+ register char *t;
+ STR *toparse;
+ STRLEN len;
+ register int brackets;
+ register char *d;
+ STAB *stab;
+ char *checkpoint;
+ int sawcase = 0;
+
+ toparse = Str_new(76,0);
+ str = Str_new(77,0);
+
+ str_nset(str,"",0);
+ str_nset(toparse,"",0);
+ t = s;
+ while (s < send) {
+ if (*s == '\\' && s[1] && index("$@[{\\]}lLuUE",s[1])) {
+ str_ncat(str, t, s - t);
+ ++s;
+ if (isALPHA(*s)) {
+ str_ncat(str, "$c", 2);
+ sawcase = (*s != 'E');
+ }
+ else {
+ if (*nointrp) { /* in a regular expression */
+ if (*s == '@') /* always strip \@ */ /*SUPPRESS 530*/
+ ;
+ else if (*s == '$') {
+ if (s+1 >= send || index(nointrp, s[1]))
+ str_ncat(str,s-1,1); /* only strip \$ for vars */
+ }
+ else /* don't strip \\, \[, \{ etc. */
+ str_ncat(str,s-1,1);
+ }
+ str_ncat(str, "$b", 2);
+ }
+ str_ncat(str, s, 1);
+ ++s;
+ t = s;
+ }
+ else if (*s == '$' && s+1 < send && *nointrp && index(nointrp,s[1])) {
+ str_ncat(str, t, s - t);
+ str_ncat(str, "$b", 2);
+ str_ncat(str, s, 2);
+ s += 2;
+ t = s;
+ }
+ else if ((*s == '@' || *s == '$') && s+1 < send) {
+ str_ncat(str,t,s-t);
+ t = s;
+ if (*s == '$' && s[1] == '#' && (isALPHA(s[2]) || s[2] == '_'))
+ s++;
+ s = scanident(s,send,tokenbuf);
+ if (*t == '@' &&
+ (!(stab = stabent(tokenbuf,FALSE)) ||
+ (*s == '{' ? !stab_xhash(stab) : !stab_xarray(stab)) )) {
+ str_ncat(str,"@",1);
+ s = ++t;
+ continue; /* grandfather @ from old scripts */
+ }
+ str_ncat(str,"$a",2);
+ str_ncat(toparse,",",1);
+ if (t[1] != '{' && (*s == '[' || *s == '{' /* }} */ ) &&
+ (stab = stabent(tokenbuf,FALSE)) &&
+ ((*s == '[') ? (stab_xarray(stab) != 0) : (stab_xhash(stab) != 0)) ) {
+ brackets = 0;
+ checkpoint = s;
+ do {
+ switch (*s) {
+ case '[':
+ if (s[-1] != '$')
+ brackets++;
+ break;
+ case '{':
+ brackets++;
+ break;
+ case ']':
+ if (s[-1] != '$')
+ brackets--;
+ break;
+ case '}':
+ brackets--;
+ break;
+ case '\'':
+ case '"':
+ if (s[-1] != '$') {
+ /*SUPPRESS 68*/
+ s = cpytill(tokenbuf,s+1,send,*s,&len);
+ if (s >= send)
+ fatal("Unterminated string");
+ }
+ break;
+ }
+ s++;
+ } while (brackets > 0 && s < send);
+ if (s > send)
+ fatal("Unmatched brackets in string");
+ if (*nointrp) { /* we're in a regular expression */
+ d = checkpoint;
+ if (*d == '{' && s[-1] == '}') { /* maybe {n,m} */
+ ++d;
+ if (isDIGIT(*d)) { /* matches /^{\d,?\d*}$/ */
+ if (*++d == ',')
+ ++d;
+ while (isDIGIT(*d))
+ d++;
+ if (d == s - 1)
+ s = checkpoint; /* Is {n,m}! Backoff! */
+ }
+ }
+ else if (*d == '[' && s[-1] == ']') { /* char class? */
+ int weight = 2; /* let's weigh the evidence */
+ char seen[256];
+ unsigned char un_char = 0, last_un_char;
+
+ Zero(seen,256,char);
+ *--s = '\0';
+ if (d[1] == '^')
+ weight += 150;
+ else if (d[1] == '$')
+ weight -= 3;
+ if (isDIGIT(d[1])) {
+ if (d[2]) {
+ if (isDIGIT(d[2]) && !d[3])
+ weight -= 10;
+ }
+ else
+ weight -= 100;
+ }
+ for (d++; d < s; d++) {
+ last_un_char = un_char;
+ un_char = (unsigned char)*d;
+ switch (*d) {
+ case '&':
+ case '$':
+ weight -= seen[un_char] * 10;
+ if (isALNUM(d[1])) {
+ d = scanident(d,s,tokenbuf);
+ if (stabent(tokenbuf,FALSE))
+ weight -= 100;
+ else
+ weight -= 10;
+ }
+ else if (*d == '$' && d[1] &&
+ index("[#!%*<>()-=",d[1])) {
+ if (!d[2] || /*{*/ index("])} =",d[2]))
+ weight -= 10;
+ else
+ weight -= 1;
+ }
+ break;
+ case '\\':
+ un_char = 254;
+ if (d[1]) {
+ if (index("wds",d[1]))
+ weight += 100;
+ else if (seen['\''] || seen['"'])
+ weight += 1;
+ else if (index("rnftb",d[1]))
+ weight += 40;
+ else if (isDIGIT(d[1])) {
+ weight += 40;
+ while (d[1] && isDIGIT(d[1]))
+ d++;
+ }
+ }
+ else
+ weight += 100;
+ break;
+ case '-':
+ if (last_un_char < (unsigned char) d[1]
+ || d[1] == '\\') {
+ if (index("aA01! ",last_un_char))
+ weight += 30;
+ if (index("zZ79~",d[1]))
+ weight += 30;
+ }
+ else
+ weight -= 1;
+ default:
+ if (isALPHA(*d) && d[1] && isALPHA(d[1])) {
+ bufptr = d;
+ if (yylex() != WORD)
+ weight -= 150;
+ d = bufptr;
+ }
+ if (un_char == last_un_char + 1)
+ weight += 5;
+ weight -= seen[un_char];
+ break;
+ }
+ seen[un_char]++;
+ }
+#ifdef DEBUGGING
+ if (debug & 512)
+ fprintf(stderr,"[%s] weight %d\n",
+ checkpoint+1,weight);
+#endif
+ *s++ = ']';
+ if (weight >= 0) /* probably a character class */
+ s = checkpoint;
+ }
+ }
+ }
+ if (*t == '@')
+ str_ncat(toparse, "join($\",", 8);
+ if (t[1] == '{' && s[-1] == '}') {
+ str_ncat(toparse, t, 1);
+ str_ncat(toparse, t+2, s - t - 3);
+ }
+ else
+ str_ncat(toparse, t, s - t);
+ if (*t == '@')
+ str_ncat(toparse, ")", 1);
+ t = s;
+ }
+ else
+ s++;
+ }
+ str_ncat(str,t,s-t);
+ if (sawcase)
+ str_ncat(str, "$cE", 3);
+ if (toparse->str_ptr && *toparse->str_ptr == ',') {
+ *toparse->str_ptr = '(';
+ str_ncat(toparse,",$$);",5);
+ str->str_u.str_args = parselist(toparse);
+ str->str_u.str_args->arg_len--; /* ignore $$ reference */
+ }
+ else
+ str->str_u.str_args = Nullarg;
+ str_free(toparse);
+ str->str_pok |= SP_INTRP;
+ str->str_nok = 0;
+ str_replace(src,str);
+}
+
+STR *
+interp(str,src,sp)
+register STR *str;
+STR *src;
+int sp;
+{
+ register char *s;
+ register char *t;
+ register char *send;
+ register STR **elem;
+ int docase = 0;
+ int l = 0;
+ int u = 0;
+ int L = 0;
+ int U = 0;
+
+ if (str == &str_undef)
+ return Nullstr;
+ if (!(src->str_pok & SP_INTRP)) {
+ int oldsave = savestack->ary_fill;
+
+ (void)savehptr(&curstash);
+ curstash = curcmd->c_stash; /* so stabent knows right package */
+ intrpcompile(src);
+ restorelist(oldsave);
+ }
+ s = src->str_ptr; /* assumed valid since str_pok set */
+ t = s;
+ send = s + src->str_cur;
+
+ if (src->str_u.str_args) {
+ (void)eval(src->str_u.str_args,G_ARRAY,sp);
+ /* Assuming we have correct # of args */
+ elem = stack->ary_array + sp;
+ }
+
+ str_nset(str,"",0);
+ while (s < send) {
+ if (*s == '$' && s+1 < send) {
+ if (s-t > 0)
+ str_ncat(str,t,s-t);
+ switch(*++s) {
+ default:
+ fatal("panic: unknown interp cookie\n");
+ break;
+ case 'a':
+ str_scat(str,*++elem);
+ break;
+ case 'b':
+ str_ncat(str,++s,1);
+ break;
+ case 'c':
+ if (docase && str->str_cur >= docase) {
+ char *b = str->str_ptr + --docase;
+
+ if (L)
+ lcase(b, str->str_ptr + str->str_cur);
+ else if (U)
+ ucase(b, str->str_ptr + str->str_cur);
+
+ if (u) /* note that l & u are independent of L & U */
+ ucase(b, b+1);
+ else if (l)
+ lcase(b, b+1);
+ l = u = 0;
+ }
+ docase = str->str_cur + 1;
+ switch (*++s) {
+ case 'u':
+ u = 1;
+ l = 0;
+ break;
+ case 'U':
+ U = 1;
+ L = 0;
+ break;
+ case 'l':
+ l = 1;
+ u = 0;
+ break;
+ case 'L':
+ L = 1;
+ U = 0;
+ break;
+ case 'E':
+ docase = L = U = l = u = 0;
+ break;
+ }
+ break;
+ }
+ t = ++s;
+ }
+ else
+ s++;
+ }
+ if (s-t > 0)
+ str_ncat(str,t,s-t);
+ return str;
+}
+
+ucase(s,send)
+register char *s;
+register char *send;
+{
+ while (s < send) {
+ if (isLOWER(*s))
+ *s = toupper(*s);
+ s++;
+ }
+}
+
+lcase(s,send)
+register char *s;
+register char *send;
+{
+ while (s < send) {
+ if (isUPPER(*s))
+ *s = tolower(*s);
+ s++;
+ }
+}
+
+void
+str_inc(str)
+register STR *str;
+{
+ register char *d;
+
+ if (!str || str == &str_undef)
+ return;
+ if (str->str_nok) {
+ str->str_u.str_nval += 1.0;
+ str->str_pok = 0;
+ return;
+ }
+ if (!str->str_pok || !*str->str_ptr) {
+ str->str_u.str_nval = 1.0;
+ str->str_nok = 1;
+ str->str_pok = 0;
+ return;
+ }
+ d = str->str_ptr;
+ while (isALPHA(*d)) d++;
+ while (isDIGIT(*d)) d++;
+ if (*d) {
+ str_numset(str,atof(str->str_ptr) + 1.0); /* punt */
+ return;
+ }
+ d--;
+ while (d >= str->str_ptr) {
+ if (isDIGIT(*d)) {
+ if (++*d <= '9')
+ return;
+ *(d--) = '0';
+ }
+ else {
+ ++*d;
+ if (isALPHA(*d))
+ return;
+ *(d--) -= 'z' - 'a' + 1;
+ }
+ }
+ /* oh,oh, the number grew */
+ STR_GROW(str, str->str_cur + 2);
+ str->str_cur++;
+ for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--)
+ *d = d[-1];
+ if (isDIGIT(d[1]))
+ *d = '1';
+ else
+ *d = d[1];
+}
+
+void
+str_dec(str)
+register STR *str;
+{
+ if (!str || str == &str_undef)
+ return;
+ if (str->str_nok) {
+ str->str_u.str_nval -= 1.0;
+ str->str_pok = 0;
+ return;
+ }
+ if (!str->str_pok) {
+ str->str_u.str_nval = -1.0;
+ str->str_nok = 1;
+ return;
+ }
+ str_numset(str,atof(str->str_ptr) - 1.0);
+}
+
+/* Make a string that will exist for the duration of the expression
+ * evaluation. Actually, it may have to last longer than that, but
+ * hopefully cmd_exec won't free it until it has been assigned to a
+ * permanent location. */
+
+static long tmps_size = -1;
+
+STR *
+str_mortal(oldstr)
+STR *oldstr;
+{
+ register STR *str = Str_new(78,0);
+
+ str_sset(str,oldstr);
+ if (++tmps_max > tmps_size) {
+ tmps_size = tmps_max;
+ if (!(tmps_size & 127)) {
+ if (tmps_size)
+ Renew(tmps_list, tmps_size + 128, STR*);
+ else
+ New(702,tmps_list, 128, STR*);
+ }
+ }
+ tmps_list[tmps_max] = str;
+ if (str->str_pok)
+ str->str_pok |= SP_TEMP;
+ return str;
+}
+
+/* same thing without the copying */
+
+STR *
+str_2mortal(str)
+register STR *str;
+{
+ if (str == &str_undef)
+ return str;
+ if (++tmps_max > tmps_size) {
+ tmps_size = tmps_max;
+ if (!(tmps_size & 127)) {
+ if (tmps_size)
+ Renew(tmps_list, tmps_size + 128, STR*);
+ else
+ New(704,tmps_list, 128, STR*);
+ }
+ }
+ tmps_list[tmps_max] = str;
+ if (str->str_pok)
+ str->str_pok |= SP_TEMP;
+ return str;
+}
+
+STR *
+str_make(s,len)
+char *s;
+STRLEN len;
+{
+ register STR *str = Str_new(79,0);
+
+ if (!len)
+ len = strlen(s);
+ str_nset(str,s,len);
+ return str;
+}
+
+STR *
+str_nmake(n)
+double n;
+{
+ register STR *str = Str_new(80,0);
+
+ str_numset(str,n);
+ return str;
+}
+
+/* make an exact duplicate of old */
+
+STR *
+str_smake(old)
+register STR *old;
+{
+ register STR *new = Str_new(81,0);
+
+ if (!old)
+ return Nullstr;
+ if (old->str_state == SS_FREE) {
+ warn("semi-panic: attempt to dup freed string");
+ return Nullstr;
+ }
+ if (old->str_state == SS_INCR && !(old->str_pok & 2))
+ Str_Grow(old,0);
+ if (new->str_ptr)
+ Safefree(new->str_ptr);
+ Copy(old,new,1,STR);
+ if (old->str_ptr) {
+ new->str_ptr = nsavestr(old->str_ptr,old->str_len);
+ new->str_pok &= ~SP_TEMP;
+ }
+ return new;
+}
+
+str_reset(s,stash)
+register char *s;
+HASH *stash;
+{
+ register HENT *entry;
+ register STAB *stab;
+ register STR *str;
+ register int i;
+ register SPAT *spat;
+ register int max;
+
+ if (!*s) { /* reset ?? searches */
+ for (spat = stash->tbl_spatroot;
+ spat != Nullspat;
+ spat = spat->spat_next) {
+ spat->spat_flags &= ~SPAT_USED;
+ }
+ return;
+ }
+
+ /* reset variables */
+
+ if (!stash->tbl_array)
+ return;
+ while (*s) {
+ i = *s;
+ if (s[1] == '-') {
+ s += 2;
+ }
+ max = *s++;
+ for ( ; i <= max; i++) {
+ for (entry = stash->tbl_array[i];
+ entry;
+ entry = entry->hent_next) {
+ stab = (STAB*)entry->hent_val;
+ str = stab_val(stab);
+ str->str_cur = 0;
+ str->str_nok = 0;
+#ifdef TAINT
+ str->str_tainted = tainted;
+#endif
+ if (str->str_ptr != Nullch)
+ str->str_ptr[0] = '\0';
+ if (stab_xarray(stab)) {
+ aclear(stab_xarray(stab));
+ }
+ if (stab_xhash(stab)) {
+ hclear(stab_xhash(stab), FALSE);
+ if (stab == envstab)
+ environ[0] = Nullch;
+ }
+ }
+ }
+ }
+}
+
+#ifdef TAINT
+taintproper(s)
+char *s;
+{
+#ifdef DEBUGGING
+ if (debug & 2048)
+ fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid);
+#endif
+ if (tainted && (!euid || euid != uid || egid != gid)) {
+ if (!unsafe)
+ fatal("%s", s);
+ else if (dowarn)
+ warn("%s", s);
+ }
+}
+
+taintenv()
+{
+ register STR *envstr;
+
+ envstr = hfetch(stab_hash(envstab),"PATH",4,FALSE);
+ if (envstr == &str_undef || envstr->str_tainted) {
+ tainted = 1;
+ if (envstr->str_tainted == 2)
+ taintproper("Insecure directory in PATH");
+ else
+ taintproper("Insecure PATH");
+ }
+ envstr = hfetch(stab_hash(envstab),"IFS",3,FALSE);
+ if (envstr != &str_undef && envstr->str_tainted) {
+ tainted = 1;
+ taintproper("Insecure IFS");
+ }
+}
+#endif /* TAINT */
--- /dev/null
+/* $RCSfile: str.h,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:41:47 $
+ *
+ * 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: str.h,v $
+ * 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.
+ *
+ */
+
+struct string {
+ char * str_ptr; /* pointer to malloced string */
+ STRLEN str_len; /* allocated size */
+ union {
+ double str_nval; /* numeric value, if any */
+ STAB *str_stab; /* magic stab for magic "key" string */
+ long str_useful; /* is this search optimization effective? */
+ ARG *str_args; /* list of args for interpreted string */
+ HASH *str_hash; /* string represents an assoc array (stab?) */
+ ARRAY *str_array; /* string represents an array */
+ CMD *str_cmd; /* command for this source line */
+ } str_u;
+ STRLEN str_cur; /* length of str_ptr as a C string */
+ STR *str_magic; /* while free, link to next free str */
+ /* while in use, ptr to "key" for magic items */
+ unsigned char str_pok; /* state of str_ptr */
+ unsigned char str_nok; /* state of str_nval */
+ unsigned char str_rare; /* used by search strings */
+ unsigned char str_state; /* one of SS_* below */
+ /* also used by search strings for backoff */
+#ifdef TAINT
+ bool str_tainted; /* 1 if possibly under control of $< */
+#endif
+};
+
+struct stab { /* should be identical, except for str_ptr */
+ STBP * str_ptr; /* pointer to malloced string */
+ STRLEN str_len; /* allocated size */
+ union {
+ double str_nval; /* numeric value, if any */
+ STAB *str_stab; /* magic stab for magic "key" string */
+ long str_useful; /* is this search optimization effective? */
+ ARG *str_args; /* list of args for interpreted string */
+ HASH *str_hash; /* string represents an assoc array (stab?) */
+ ARRAY *str_array; /* string represents an array */
+ CMD *str_cmd; /* command for this source line */
+ } str_u;
+ STRLEN str_cur; /* length of str_ptr as a C string */
+ STR *str_magic; /* while free, link to next free str */
+ /* while in use, ptr to "key" for magic items */
+ unsigned char str_pok; /* state of str_ptr */
+ unsigned char str_nok; /* state of str_nval */
+ unsigned char str_rare; /* used by search strings */
+ unsigned char str_state; /* one of SS_* below */
+ /* also used by search strings for backoff */
+#ifdef TAINT
+ bool str_tainted; /* 1 if possibly under control of $< */
+#endif
+};
+
+/* some extra info tacked to some lvalue strings */
+
+struct lstring {
+ struct string lstr;
+ STRLEN lstr_offset;
+ STRLEN lstr_len;
+};
+
+/* These are the values of str_pok: */
+#define SP_VALID 1 /* str_ptr is valid */
+#define SP_FBM 2 /* string was compiled for fbm search */
+#define SP_STUDIED 4 /* string was studied */
+#define SP_CASEFOLD 8 /* case insensitive fbm search */
+#define SP_INTRP 16 /* string was compiled for interping */
+#define SP_TAIL 32 /* fbm string is tail anchored: /foo$/ */
+#define SP_MULTI 64 /* symbol table entry probably isn't a typo */
+#define SP_TEMP 128 /* string slated to die, so can be plundered */
+
+#define Nullstr Null(STR*)
+
+/* These are the values of str_state: */
+#define SS_NORM 0 /* normal string */
+#define SS_INCR 1 /* normal string, incremented ptr */
+#define SS_SARY 2 /* array on save stack */
+#define SS_SHASH 3 /* associative array on save stack */
+#define SS_SINT 4 /* integer on save stack */
+#define SS_SLONG 5 /* long on save stack */
+#define SS_SSTRP 6 /* STR* on save stack */
+#define SS_SHPTR 7 /* HASH* on save stack */
+#define SS_SNSTAB 8 /* non-stab on save stack */
+#define SS_SCSV 9 /* callsave structure on save stack */
+#define SS_SAPTR 10 /* ARRAY* on save stack */
+#define SS_HASH 253 /* carrying an hash */
+#define SS_ARY 254 /* carrying an array */
+#define SS_FREE 255 /* in free list */
+/* str_state may have any value 0-255 when used to hold fbm pattern, in which */
+/* case it indicates offset to rarest character in screaminstr key */
+
+/* the following macro updates any magic values this str is associated with */
+
+#ifdef TAINT
+#define STABSET(x) \
+ (x)->str_tainted |= tainted; \
+ if ((x)->str_magic) \
+ stabset((x)->str_magic,(x))
+#else
+#define STABSET(x) \
+ if ((x)->str_magic) \
+ stabset((x)->str_magic,(x))
+#endif
+
+#define STR_SSET(dst,src) if (dst != src) str_sset(dst,src)
+
+EXT STR **tmps_list;
+EXT int tmps_max INIT(-1);
+EXT int tmps_base INIT(-1);
+
+char *str_2ptr();
+double str_2num();
+STR *str_mortal();
+STR *str_2mortal();
+STR *str_make();
+STR *str_nmake();
+STR *str_smake();
+int str_cmp();
+int str_eq();
+void str_magic();
+void str_insert();
+STRLEN str_len();
+
+#define MULTI (3)
--- /dev/null
+#!./perl
+
+# $RCSfile: TEST,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:59:30 $
+
+# 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,"../config.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);
--- /dev/null
+#!./perl
+
+# $Header: cond.t,v 4.0 91/03/20 01:48:54 lwall Locked $
+
+# make sure conditional operators work
+
+print "1..4\n";
+
+$x = '0';
+
+$x eq $x && (print "ok 1\n");
+$x ne $x && (print "not ok 1\n");
+$x eq $x || (print "not ok 2\n");
+$x ne $x || (print "ok 2\n");
+
+$x == $x && (print "ok 3\n");
+$x != $x && (print "not ok 3\n");
+$x == $x || (print "not ok 4\n");
+$x != $x || (print "ok 4\n");
--- /dev/null
+#!./perl
+
+# $Header: if.t,v 4.0 91/03/20 01:49:03 lwall Locked $
+
+print "1..2\n";
+
+# first test to see if we can run the tests.
+
+$x = 'test';
+if ($x eq $x) { print "ok 1\n"; } else { print "not ok 1\n";}
+if ($x ne $x) { print "not ok 2\n"; } else { print "ok 2\n";}
--- /dev/null
+#!./perl
+
+# $Header: lex.t,v 4.0 91/03/20 01:49:08 lwall Locked $
+
+print "1..18\n";
+
+$ # this is the register <space>
+= 'x';
+
+print "#1 :$ : eq :x:\n";
+if ($ eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$x = $#; # this is the register $#
+
+if ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$x = $#x;
+
+if ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";}
+
+$x = '\\'; # ';
+
+if (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";}
+
+eval 'while (0) {
+ print "foo\n";
+}
+/^/ && (print "ok 5\n");
+';
+
+eval '$foo{1} / 1;';
+if (!$@) {print "ok 6\n";} else {print "not ok 6\n";}
+
+eval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
+
+$foo = int($foo * 100 + .5);
+if ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7 :$foo:\n";}
+
+print <<'EOF';
+ok 8
+EOF
+
+$foo = 'ok 9';
+print <<EOF;
+$foo
+EOF
+
+eval <<\EOE, print $@;
+print <<'EOF';
+ok 10
+EOF
+
+$foo = 'ok 11';
+print <<EOF;
+$foo
+EOF
+EOE
+
+print <<`EOS` . <<\EOF;
+echo ok 12
+EOS
+ok 13
+EOF
+
+print qq/ok 14\n/;
+print qq(ok 15\n);
+
+print qq
+ok 16\n
+;
+
+print q<ok 17
+>;
+
+print <<; # Yow!
+ok 18
+
+# previous line intentionally left blank.
--- /dev/null
+#!./perl
+
+# $Header: pat.t,v 4.0 91/03/20 01:49:12 lwall Locked $
+
+print "1..2\n";
+
+# first test to see if we can run the tests.
+
+$_ = 'test';
+if (/^test/) { print "ok 1\n"; } else { print "not ok 1\n";}
+if (/^foo/) { print "not ok 2\n"; } else { print "ok 2\n";}
--- /dev/null
+#!./perl
+
+# $Header: term.t,v 4.0 91/03/20 01:49:17 lwall Locked $
+
+print "1..6\n";
+
+# check "" interpretation
+
+$x = "\n";
+if ($x lt ' ') {print "ok 1\n";} else {print "not ok 1\n";}
+
+# check `` processing
+
+$x = `echo hi there`;
+if ($x eq "hi there\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+# check $#array
+
+$x[0] = 'foo';
+$x[1] = 'foo';
+$tmp = $#x;
+print "#3\t:$tmp: == :1:\n";
+if ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";}
+
+# check numeric literal
+
+$x = 1;
+if ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";}
+
+# check <> pseudoliteral
+
+open(try, "/dev/null") || (die "Can't open /dev/null.");
+if (<try> eq '') {
+ print "ok 5\n";
+}
+else {
+ print "not ok 5\n";
+ die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null';
+}
+
+open(try, "../Makefile") || (die "Can't open ../Makefile.");
+if (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";}
--- /dev/null
+#!./perl
+
+# $Header: elsif.t,v 4.0 91/03/20 01:49:21 lwall Locked $
+
+sub foo {
+ if ($_[0] == 1) {
+ 1;
+ }
+ elsif ($_[0] == 2) {
+ 2;
+ }
+ elsif ($_[0] == 3) {
+ 3;
+ }
+ else {
+ 4;
+ }
+}
+
+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";}
--- /dev/null
+#!./perl
+
+# $Header: for.t,v 4.0 91/03/20 01:49:26 lwall Locked $
+
+print "1..7\n";
+
+for ($i = 0; $i <= 10; $i++) {
+ $x[$i] = $i;
+}
+$y = $x[10];
+print "#1 :$y: eq :10:\n";
+$y = join(' ', @x);
+print "#1 :$y: eq :0 1 2 3 4 5 6 7 8 9 10:\n";
+if (join(' ', @x) eq '0 1 2 3 4 5 6 7 8 9 10') {
+ print "ok 1\n";
+} else {
+ print "not ok 1\n";
+}
+
+$i = $c = 0;
+for (;;) {
+ $c++;
+ last if $i++ > 10;
+}
+if ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$foo = 3210;
+@ary = (1,2,3,4,5);
+foreach $foo (@ary) {
+ $foo *= 2;
+}
+if (join('',@ary) eq '246810') {print "ok 3\n";} else {print "not ok 3\n";}
+
+for (@ary) {
+ s/(.*)/ok $1\n/;
+}
+
+print $ary[1];
+
+# test for internal scratch array generation
+# this also tests that $foo was restored to 3210 after test 3
+for (split(' ','a b c d e')) {
+ $foo .= $_;
+}
+if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";}
+
+foreach $foo (("ok 6\n","ok 7\n")) {
+ print $foo;
+}
--- /dev/null
+#!./perl
+
+# $Header: mod.t,v 4.0 91/03/20 01:49:33 lwall Locked $
+
+print "1..7\n";
+
+print "ok 1\n" if 1;
+print "not ok 1\n" unless 1;
+
+print "ok 2\n" unless 0;
+print "not ok 2\n" if 0;
+
+1 && (print "not ok 3\n") if 0;
+1 && (print "ok 3\n") if 1;
+0 || (print "not ok 4\n") if 0;
+0 || (print "ok 4\n") if 1;
+
+$x = 0;
+do {$x[$x] = $x;} while ($x++) < 10;
+if (join(' ',@x) eq '0 1 2 3 4 5 6 7 8 9 10') {
+ print "ok 5\n";
+} else {
+ print "not ok 5\n";
+}
+
+$x = 15;
+$x = 10 while $x < 10;
+if ($x == 15) {print "ok 6\n";} else {print "not ok 6\n";}
+
+open(foo,'TEST') || open(foo,'t/TEST');
+$x = 0;
+$x++ while <foo>;
+print $x > 50 && $x < 1000 ? "ok 7\n" : "not ok 7\n";
--- /dev/null
+#!./perl
+
+# $RCSfile: subval.t,v $$Revision: 4.0.1.1 $$Date: 91/11/05 18:42:31 $
+
+sub foo1 {
+ 'true1';
+ if ($_[0]) { 'true2'; }
+}
+
+sub foo2 {
+ 'true1';
+ if ($_[0]) { return 'true2'; } else { return 'true3'; }
+ 'true0';
+}
+
+sub foo3 {
+ 'true1';
+ unless ($_[0]) { 'true2'; }
+}
+
+sub foo4 {
+ 'true1';
+ unless ($_[0]) { 'true2'; } else { 'true3'; }
+}
+
+sub foo5 {
+ 'true1';
+ 'true2' if $_[0];
+}
+
+sub foo6 {
+ 'true1';
+ 'true2' unless $_[0];
+}
+
+print "1..34\n";
+
+if (do foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
+if (do foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";}
+if (do foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";}
+if (do foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";}
+
+if (do foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";}
+if (do foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";}
+if (do foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";}
+if (do foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";}
+
+if (do foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";}
+if (do foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";}
+if (do foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";}
+if (do foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\n";}
+
+# Now test to see that recursion works using a Fibonacci number generator
+
+sub fib {
+ local($arg) = @_;
+ local($foo);
+ $level++;
+ if ($arg <= 2) {
+ $foo = 1;
+ }
+ else {
+ $foo = do fib($arg-1) + do fib($arg-2);
+ }
+ $level--;
+ $foo;
+}
+
+@good = (0,1,1,2,3,5,8,13,21,34,55,89);
+
+for ($i = 1; $i <= 10; $i++) {
+ $foo = $i + 12;
+ if (do fib($i) == $good[$i]) {
+ print "ok $foo\n";
+ }
+ else {
+ print "not ok $foo\n";
+ }
+}
+
+sub ary1 {
+ (1,2,3);
+}
+
+print &ary1 eq 3 ? "ok 23\n" : "not ok 23\n";
+
+print join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n";
+
+sub ary2 {
+ do {
+ return (1,2,3);
+ (3,2,1);
+ };
+ 0;
+}
+
+print &ary2 eq 3 ? "ok 25\n" : "not ok 25\n";
+
+$x = join(':',&ary2);
+print $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n";
+
+sub somesub {
+ local($num,$P,$F,$L) = @_;
+ ($p,$f,$l) = caller;
+ print "$p:$f:$l" eq "$P:$F:$L" ? "ok $num\n" : "not ok $num $p:$f:$l ne $P:$F:$L\n";
+}
+
+&somesub(27, 'main', __FILE__, __LINE__);
+
+package foo;
+&main'somesub(28, 'foo', __FILE__, __LINE__);
+
+package main;
+$i = 28;
+open(FOO,">Cmd_subval.tmp");
+print FOO "blah blah\n";
+close FOO;
+
+&file_main(*F);
+close F;
+&info_main;
+
+&file_package(*F);
+close F;
+&info_package;
+
+unlink 'Cmd_subval.tmp';
+
+sub file_main {
+ local(*F) = @_;
+
+ open(F, 'Cmd_subval.tmp') || die "can't open\n";
+ $i++;
+ eof F ? print "not ok $i\n" : print "ok $i\n";
+}
+
+sub info_main {
+ local(*F);
+
+ open(F, 'Cmd_subval.tmp') || die "test: can't open\n";
+ $i++;
+ eof F ? print "not ok $i\n" : print "ok $i\n";
+ &iseof(*F);
+ close F;
+}
+
+sub iseof {
+ local(*UNIQ) = @_;
+
+ $i++;
+ eof UNIQ ? print "(not ok $i)\n" : print "ok $i\n";
+}
+
+{package foo;
+
+ sub main'file_package {
+ local(*F) = @_;
+
+ open(F, 'Cmd_subval.tmp') || die "can't open\n";
+ $main'i++;
+ eof F ? print "not ok $main'i\n" : print "ok $main'i\n";
+ }
+
+ sub main'info_package {
+ local(*F);
+
+ open(F, 'Cmd_subval.tmp') || die "can't open\n";
+ $main'i++;
+ eof F ? print "not ok $main'i\n" : print "ok $main'i\n";
+ &iseof(*F);
+ }
+
+ sub iseof {
+ local(*UNIQ) = @_;
+
+ $main'i++;
+ eof UNIQ ? print "not ok $main'i\n" : print "ok $main'i\n";
+ }
+}
--- /dev/null
+#!./perl
+
+# $Header: switch.t,v 4.0 91/03/20 01:49:44 lwall Locked $
+
+print "1..18\n";
+
+sub foo1 {
+ $_ = shift(@_);
+ $a = 0;
+ until ($a++) {
+ next if $_ eq 1;
+ next if $_ eq 2;
+ next if $_ eq 3;
+ next if $_ eq 4;
+ return 20;
+ }
+ continue {
+ return $_;
+ }
+}
+
+print do foo1(0) == 20 ? "ok 1\n" : "not ok 1\n";
+print do foo1(1) == 1 ? "ok 2\n" : "not ok 2\n";
+print do foo1(2) == 2 ? "ok 3\n" : "not ok 3\n";
+print do foo1(3) == 3 ? "ok 4\n" : "not ok 4\n";
+print do foo1(4) == 4 ? "ok 5\n" : "not ok 5\n";
+print do foo1(5) == 20 ? "ok 6\n" : "not ok 6\n";
+
+sub foo2 {
+ $_ = shift(@_);
+ {
+ last if $_ == 1;
+ last if $_ == 2;
+ last if $_ == 3;
+ last if $_ == 4;
+ }
+ continue {
+ return 20;
+ }
+ return $_;
+}
+
+print do foo2(0) == 20 ? "ok 7\n" : "not ok 1\n";
+print do foo2(1) == 1 ? "ok 8\n" : "not ok 8\n";
+print do foo2(2) == 2 ? "ok 9\n" : "not ok 9\n";
+print do foo2(3) == 3 ? "ok 10\n" : "not ok 10\n";
+print do foo2(4) == 4 ? "ok 11\n" : "not ok 11\n";
+print do foo2(5) == 20 ? "ok 12\n" : "not ok 12\n";
+
+sub foo3 {
+ $_ = shift(@_);
+ if (/^1/) {
+ return 1;
+ }
+ elsif (/^2/) {
+ return 2;
+ }
+ elsif (/^3/) {
+ return 3;
+ }
+ elsif (/^4/) {
+ return 4;
+ }
+ else {
+ return 20;
+ }
+ return 40;
+}
+
+print do foo3(0) == 20 ? "ok 13\n" : "not ok 13\n";
+print do foo3(1) == 1 ? "ok 14\n" : "not ok 14\n";
+print do foo3(2) == 2 ? "ok 15\n" : "not ok 15\n";
+print do foo3(3) == 3 ? "ok 16\n" : "not ok 16\n";
+print do foo3(4) == 4 ? "ok 17\n" : "not ok 17\n";
+print do foo3(5) == 20 ? "ok 18\n" : "not ok 18\n";
--- /dev/null
+#!./perl
+
+# $Header: while.t,v 4.0 91/03/20 01:49:51 lwall Locked $
+
+print "1..10\n";
+
+open (tmp,'>Cmd.while.tmp') || die "Can't create Cmd.while.tmp.";
+print tmp "tvi925\n";
+print tmp "tvi920\n";
+print tmp "vt100\n";
+print tmp "Amiga\n";
+print tmp "paper\n";
+close tmp;
+
+# test "last" command
+
+open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
+while (<fh>) {
+ last if /vt100/;
+}
+if (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1 $_\n";}
+
+# test "next" command
+
+$bad = '';
+open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
+while (<fh>) {
+ next if /vt100/;
+ $bad = 1 if /vt100/;
+}
+if (!eof || /vt100/ || $bad) {print "not ok 2\n";} else {print "ok 2\n";}
+
+# test "redo" command
+
+$bad = '';
+open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
+while (<fh>) {
+ if (s/vt100/VT100/g) {
+ s/VT100/Vt100/g;
+ redo;
+ }
+ $bad = 1 if /vt100/;
+ $bad = 1 if /VT100/;
+}
+if (!eof || $bad) {print "not ok 3\n";} else {print "ok 3\n";}
+
+# now do the same with a label and a continue block
+
+# test "last" command
+
+$badcont = '';
+open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
+line: while (<fh>) {
+ if (/vt100/) {last line;}
+} continue {
+ $badcont = 1 if /vt100/;
+}
+if (!eof && /vt100/) {print "ok 4\n";} else {print "not ok 4\n";}
+if (!$badcont) {print "ok 5\n";} else {print "not ok 5\n";}
+
+# test "next" command
+
+$bad = '';
+$badcont = 1;
+open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
+entry: while (<fh>) {
+ next entry if /vt100/;
+ $bad = 1 if /vt100/;
+} continue {
+ $badcont = '' if /vt100/;
+}
+if (!eof || /vt100/ || $bad) {print "not ok 6\n";} else {print "ok 6\n";}
+if (!$badcont) {print "ok 7\n";} else {print "not ok 7\n";}
+
+# test "redo" command
+
+$bad = '';
+$badcont = '';
+open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
+loop: while (<fh>) {
+ if (s/vt100/VT100/g) {
+ s/VT100/Vt100/g;
+ redo loop;
+ }
+ $bad = 1 if /vt100/;
+ $bad = 1 if /VT100/;
+} continue {
+ $badcont = 1 if /vt100/;
+}
+if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";}
+if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";}
+
+`/bin/rm -f Cmd.while.tmp`;
+
+#$x = 0;
+#while (1) {
+# if ($x > 1) {last;}
+# next;
+#} continue {
+# if ($x++ > 10) {last;}
+# next;
+#}
+#
+#if ($x < 10) {print "ok 10\n";} else {print "not ok 10\n";}
+
+$i = 9;
+{
+ $i++;
+}
+print "ok $i\n";
--- /dev/null
+#!./perl
+
+# $Header: cmdopt.t,v 4.0 91/03/20 01:49:58 lwall Locked $
+
+print "1..40\n";
+
+# test the optimization of constants
+
+if (1) { print "ok 1\n";} else { print "not ok 1\n";}
+unless (0) { print "ok 2\n";} else { print "not ok 2\n";}
+
+if (0) { print "not ok 3\n";} else { print "ok 3\n";}
+unless (1) { print "not ok 4\n";} else { print "ok 4\n";}
+
+unless (!1) { print "ok 5\n";} else { print "not ok 5\n";}
+if (!0) { print "ok 6\n";} else { print "not ok 6\n";}
+
+unless (!0) { print "not ok 7\n";} else { print "ok 7\n";}
+if (!1) { print "not ok 8\n";} else { print "ok 8\n";}
+
+$x = 1;
+if (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";}
+if (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";}
+$x = '';
+if (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";}
+if (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";}
+
+$x = 1;
+if (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";}
+if (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";}
+$x = '';
+if (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";}
+if (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";}
+
+
+# test the optimization of registers
+
+$x = 1;
+if ($x) { print "ok 17\n";} else { print "not ok 17\n";}
+unless ($x) { print "not ok 18\n";} else { print "ok 18\n";}
+
+$x = '';
+if ($x) { print "not ok 19\n";} else { print "ok 19\n";}
+unless ($x) { print "ok 20\n";} else { print "not ok 20\n";}
+
+# test optimization of string operations
+
+$a = 'a';
+if ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";}
+if ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";}
+
+if ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";}
+if ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";}
+# test interaction of logicals and other operations
+
+$a = 'a';
+$x = 1;
+if ($a eq 'a' && $x) { print "ok 25\n";} else { print "not ok 25\n";}
+if ($a ne 'a' && $x) { print "not ok 26\n";} else { print "ok 26\n";}
+$x = '';
+if ($a eq 'a' && $x) { print "not ok 27\n";} else { print "ok 27\n";}
+if ($a ne 'a' && $x) { print "not ok 28\n";} else { print "ok 28\n";}
+
+$x = 1;
+if ($a eq 'a' || $x) { print "ok 29\n";} else { print "not ok 29\n";}
+if ($a ne 'a' || $x) { print "ok 30\n";} else { print "not ok 30\n";}
+$x = '';
+if ($a eq 'a' || $x) { print "ok 31\n";} else { print "not ok 31\n";}
+if ($a ne 'a' || $x) { print "not ok 32\n";} else { print "ok 32\n";}
+
+$x = 1;
+if ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";}
+if ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";}
+$x = '';
+if ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";}
+ if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";}
+
+$x = 1;
+if ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";}
+if ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";}
+$x = '';
+if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";}
+if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";}
--- /dev/null
+#!./perl -P
+
+# $Header: cpp.t,v 4.0 91/03/20 01:50:05 lwall Locked $
+
+print "1..3\n";
+
+#this is a comment
+#define MESS "ok 1\n"
+print MESS;
+
+#If you capitalize, it's a comment.
+#ifdef MESS
+ print "ok 2\n";
+#else
+ print "not ok 2\n";
+#endif
+
+open(TRY,">Comp.cpp.tmp") || die "Can't open temp perl file.";
+
+($prog = <<'END') =~ s/X//g;
+X$ok = "not ok 3\n";
+X#include "Comp.cpp.inc"
+X#ifdef OK
+X$ok = OK;
+X#endif
+Xprint $ok;
+END
+print TRY $prog;
+close TRY;
+
+open(TRY,">Comp.cpp.inc") || (die "Can't open temp include file.");
+print TRY '#define OK "ok 3\n"' . "\n";
+close TRY;
+
+$pwd=`pwd`;
+$pwd =~ s/\n//;
+$x = `./perl -P Comp.cpp.tmp`;
+print $x;
+unlink "Comp.cpp.tmp", "Comp.cpp.inc";
--- /dev/null
+#!./perl
+
+# $Header: decl.t,v 4.0 91/03/20 01:50:09 lwall Locked $
+
+# check to see if subroutine declarations work everwhere
+
+sub one {
+ print "ok 1\n";
+}
+format one =
+ok 5
+.
+
+print "1..7\n";
+
+do one();
+do two();
+
+sub two {
+ print "ok 2\n";
+}
+format two =
+@<<<
+$foo
+.
+
+if ($x eq $x) {
+ sub three {
+ print "ok 3\n";
+ }
+ do three();
+}
+
+do four();
+$~ = 'one';
+write;
+$~ = 'two';
+$foo = "ok 6";
+write;
+$~ = 'three';
+write;
+
+format three =
+ok 7
+.
+
+sub four {
+ print "ok 4\n";
+}
--- /dev/null
+#!./perl
+
+# $Header: multiline.t,v 4.0 91/03/20 01:50:15 lwall Locked $
+
+print "1..5\n";
+
+open(try,'>Comp.try') || (die "Can't open temp file.");
+
+$x = 'now is the time
+for all good men
+to come to.
+';
+
+$y = 'now is the time' . "\n" .
+'for all good men' . "\n" .
+'to come to.' . "\n";
+
+if ($x eq $y) {print "ok 1\n";} else {print "not ok 1\n";}
+
+print try $x;
+close try;
+
+open(try,'Comp.try') || (die "Can't reopen temp file.");
+$count = 0;
+$z = '';
+while (<try>) {
+ $z .= $_;
+ $count = $count + 1;
+}
+
+if ($z eq $y) {print "ok 2\n";} else {print "not ok 2\n";}
+
+if ($count == 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`;
+
+if ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";}
--- /dev/null
+#!./perl
+
+print "1..7\n";
+
+$blurfl = 123;
+$foo = 3;
+
+package XYZ;
+
+$bar = 4;
+
+{
+ package ABC;
+ $blurfl = 5;
+ $main'a = $'b;
+}
+
+$ABC'dyick = 6;
+
+$xyz = 2;
+
+$main = join(':', sort(keys _main));
+$XYZ = join(':', sort(keys _XYZ));
+$ABC = join(':', sort(keys _ABC));
+
+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\n";
+print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n";
+package ABC;
+print $blurfl == 5 ? "ok 4\n" : "not ok 4\n";
+eval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";';
+eval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";';
+print $blurfl == 5 ? "ok 7\n" : "not ok 7\n";
--- /dev/null
+#!./perl
+
+# $Header: script.t,v 4.0 91/03/20 01:50:26 lwall Locked $
+
+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";}
+
+open(try,">Comp.script") || (die "Can't open temp file.");
+print try 'print "ok\n";'; print try "\n";
+close try;
+
+$x = `./perl Comp.script`;
+
+if ($x 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`;
--- /dev/null
+#!./perl
+
+# $Header: term.t,v 4.0 91/03/20 01:50:36 lwall Locked $
+
+# tests that aren't important enough for base.term
+
+print "1..14\n";
+
+$x = "\\n";
+print "#1\t:$x: eq " . ':\n:' . "\n";
+if ($x eq '\n') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$x = "#2\t:$x: eq :\\n:\n";
+print $x;
+unless (index($x,'\\\\')>0) {print "ok 2\n";} else {print "not ok 2\n";}
+
+if (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";}
+
+$one = 'a';
+
+if (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";}
+if (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";}
+if (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";}
+if (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";}
+if (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";}
+if (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";}
+if (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";}
+
+if ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";}
+
+@foo = (1,2,3);
+if ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";}
+if ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";}
+$" = '::';
+if ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";}
--- /dev/null
+#!./perl
+
+# $Header: argv.t,v 4.0 91/03/20 01:50:46 lwall Locked $
+
+print "1..5\n";
+
+open(try, '>Io.argv.tmp') || (die "Can't open temp file.");
+print try "a line\n";
+close try;
+
+$x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`;
+
+if ($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()) {
+ if ($. == 3) {print "ok 4\n";} else {print "not ok 4\n";}
+ }
+}
+
+if ($y eq "1a line\n2a line\n3a line\n")
+ {print "ok 5\n";}
+else
+ {print "not ok 5\n";}
+
+`/bin/rm -f Io.argv.tmp`;
--- /dev/null
+#!./perl
+
+# $Header: dup.t,v 4.0 91/03/20 01:50:49 lwall Locked $
+
+print "1..6\n";
+
+print "ok 1\n";
+
+open(dupout,">&STDOUT");
+open(duperr,">&STDERR");
+
+open(STDOUT,">Io.dup") || die "Can't open stdout";
+open(STDERR,">&STDOUT") || die "Can't open stderr";
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+print STDOUT "ok 2\n";
+print STDERR "ok 3\n";
+system 'echo ok 4';
+system 'echo ok 5 1>&2';
+
+close(STDOUT);
+close(STDERR);
+
+open(STDOUT,">&dupout");
+open(STDERR,">&duperr");
+
+system 'cat Io.dup';
+unlink 'Io.dup';
+
+print STDOUT "ok 6\n";
--- /dev/null
+#!./perl
+
+# $Header: fs.t,v 4.0 91/03/20 01:50:55 lwall Locked $
+
+print "1..22\n";
+
+$wd = `pwd`;
+chop($wd);
+
+`rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`;
+chdir './tmp';
+`/bin/rm -rf a b c x`;
+
+umask(022);
+
+if (umask(0) == 022) {print "ok 1\n";} else {print "not ok 1\n";}
+open(fh,'>x') || die "Can't create x";
+close(fh);
+open(fh,'>a') || die "Can't create a";
+close(fh);
+
+if (link('a','b')) {print "ok 2\n";} else {print "not ok 2\n";}
+
+if (link('b','c')) {print "ok 3\n";} else {print "not ok 3\n";}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('c');
+
+if ($nlink == 3) {print "ok 4\n";} else {print "not ok 4\n";}
+if (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";}
+
+if ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('c');
+if (($mode & 0777) == 0777) {print "ok 7\n";} else {print "not ok 7\n";}
+
+if ((chmod 0700,'c','x') == 2) {print "ok 8\n";} else {print "not ok 8\n";}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('c');
+if (($mode & 0777) == 0700) {print "ok 9\n";} else {print "not ok 9\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('x');
+if (($mode & 0777) == 0700) {print "ok 10\n";} else {print "not ok 10\n";}
+
+if ((unlink 'b','x') == 2) {print "ok 11\n";} else {print "not ok 11\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('b');
+if ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('x');
+if ($ino == 0) {print "ok 13\n";} else {print "not ok 13\n";}
+
+if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('a');
+if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";}
+$foo = (utime 500000000,500000001,'b');
+if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('b');
+if ($ino) {print "ok 17\n";} else {print "not ok 17\n";}
+if (($atime == 500000000 && $mtime == 500000001) || $wd =~ m#/afs/#)
+ {print "ok 18\n";}
+else
+ {print "not ok 18 $atime $mtime\n";}
+
+if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('b');
+if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";}
+unlink 'c';
+
+chdir $wd || die "Can't cd back to $wd";
+
+unlink 'c';
+if (`ls -l perl 2>/dev/null` =~ /^l.*->/) { # we have symbolic links
+ if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";}
+ $foo = `grep perl c`;
+ if ($foo) {print "ok 22\n";} else {print "not ok 22\n";}
+}
+else {
+ print "ok 21\nok 22\n";
+}
--- /dev/null
+#!./perl
+
+$^I = '.bak';
+
+# $Header: inplace.t,v 4.0 91/03/20 01:50:59 lwall Locked $
+
+print "1..2\n";
+
+@ARGV = ('.a','.b','.c');
+`echo foo | tee .a .b .c`;
+while (<>) {
+ s/foo/bar/;
+}
+continue {
+ print;
+}
+
+if (`cat .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";}
+if (`cat .a.bak .b.bak .c.bak` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+unlink '.a', '.b', '.c', '.a.bak', '.b.bak', '.c.bak';
--- /dev/null
+#!./perl
+
+# $Header: pipe.t,v 4.0 91/03/20 01:51:02 lwall Locked $
+
+$| = 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;
+
+if (open(PIPE, "-|")) {
+ while(<PIPE>) {
+ s/^not //;
+ print;
+ }
+}
+else {
+ print STDOUT "not ok 3\n";
+ exec 'echo', 'not ok 4';
+}
+
+pipe(READER,WRITER) || die "Can't open pipe";
+
+if ($pid = fork) {
+ close WRITER;
+ while(<READER>) {
+ s/^not //;
+ y/A-Z/a-z/;
+ print;
+ }
+}
+else {
+ die "Couldn't fork" unless defined $pid;
+ close READER;
+ print WRITER "not ok 5\n";
+ open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
+ close WRITER;
+ exec 'echo', 'not ok 6';
+}
+
+
+pipe(READER,WRITER) || die "Can't open pipe";
+close READER;
+
+$SIG{'PIPE'} = 'broken_pipe';
+
+sub broken_pipe {
+ print "ok 7\n";
+}
+
+print WRITER "not ok 7\n";
+close WRITER;
+
+print "ok 8\n";
--- /dev/null
+#!./perl
+
+# $Header: print.t,v 4.0 91/03/20 01:51:08 lwall Locked $
+
+print "1..16\n";
+
+$foo = 'STDOUT';
+print $foo "ok 1\n";
+
+print "ok 2\n","ok 3\n","ok 4\n";
+print STDOUT "ok 5\n";
+
+open(foo,">-");
+print foo "ok 6\n";
+
+printf "ok %d\n",7;
+printf("ok %d\n",8);
+
+@a = ("ok %d%c",9,ord("\n"));
+printf @a;
+
+$a[1] = 10;
+printf STDOUT @a;
+
+$, = ' ';
+$\ = "\n";
+
+print "ok","11";
+
+@x = ("ok","12\nok","13\nok");
+@y = ("15\nok","16");
+print @x,"14\nok",@y;
--- /dev/null
+#!./perl
+
+# $Header: tell.t,v 4.0 91/03/20 01:51:14 lwall Locked $
+
+print "1..13\n";
+
+$TST = 'tst';
+
+open($TST, '../Makefile') || (die "Can't open ../Makefile");
+
+if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
+
+$firstline = <$TST>;
+$secondpos = tell;
+
+$x = 0;
+while (<tst>) {
+ if (eof) {$x++;}
+}
+if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
+
+$lastpos = tell;
+
+unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
+
+if (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
+
+if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
+
+if ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
+
+if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
+
+if (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
+
+if (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; }
+
+if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
+
+if (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
+
+if ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
+
+unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
--- /dev/null
+#!./perl
+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__
+&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
--- /dev/null
+#!./perl
+
+# $Header: append.t,v 4.0 91/03/20 01:51:23 lwall Locked $
+
+print "1..3\n";
+
+$a = 'ab' . 'c'; # compile time
+$b = 'def';
+
+$c = $a . $b;
+print "#1\t:$c: eq :abcdef:\n";
+if ($c eq 'abcdef') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$c .= 'xyz';
+print "#2\t:$c: eq :abcdefxyz:\n";
+if ($c eq 'abcdefxyz') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$_ = $a;
+$_ .= $b;
+print "#3\t:$_: eq :abcdef:\n";
+if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";}
--- /dev/null
+#!./perl
+
+# $Header: array.t,v 4.0 91/03/20 01:51:31 lwall Locked $
+
+print "1..36\n";
+
+@ary = (1,2,3,4,5);
+if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$tmp = $ary[$#ary]; --$#ary;
+if ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";}
+if ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";}
+if (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$[ = 1;
+@ary = (1,2,3,4,5);
+if (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";}
+
+$tmp = $ary[$#ary]; --$#ary;
+if ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";}
+if ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";}
+if (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";}
+
+if ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";}
+
+$#ary += 1; # see if we can recover element 5
+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";}
+
+$[ = 0;
+@foo = ();
+$r = join(',', $#foo, @foo);
+if ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";}
+$foo[0] = '0';
+$r = join(',', $#foo, @foo);
+if ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";}
+$foo[2] = '2';
+$r = join(',', $#foo, @foo);
+if ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";}
+@bar = ();
+$bar[0] = '0';
+$bar[1] = '1';
+$r = join(',', $#bar, @bar);
+if ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";}
+@bar = ();
+$r = join(',', $#bar, @bar);
+if ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";}
+$bar[0] = '0';
+$r = join(',', $#bar, @bar);
+if ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";}
+$bar[2] = '2';
+$r = join(',', $#bar, @bar);
+if ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";}
+reset 'b';
+@bar = ();
+$bar[0] = '0';
+$r = join(',', $#bar, @bar);
+if ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";}
+$bar[2] = '2';
+$r = join(',', $#bar, @bar);
+if ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";}
+
+$foo = 'now is the time';
+if (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) {
+ if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') {
+ print "ok 21\n";
+ }
+ else {
+ print "not ok 21\n";
+ }
+}
+else {
+ print "not ok 21\n";
+}
+
+$foo = 'lskjdf';
+if ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) {
+ print "not ok 22 $cnt $F1:$F2:$Etc\n";
+}
+else {
+ print "ok 22\n";
+}
+
+%foo = ('blurfl','dyick','foo','bar','etc.','etc.');
+%bar = %foo;
+print $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n";
+%bar = ();
+print $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n";
+(%bar,$a,$b) = (%foo,'how','now');
+print $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n";
+print $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n";
+@bar{keys %foo} = values %foo;
+print $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n";
+print $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n";
+
+@foo = grep(/e/,split(' ','now is the time for all good men to come to'));
+print join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n";
+
+@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
+print join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n";
+
+$foo = join('',('a','b','c','d','e','f')[0..5]);
+print $foo eq 'abcdef' ? "ok 31\n" : "not ok 31\n";
+
+$foo = join('',('a','b','c','d','e','f')[0..1]);
+print $foo eq 'ab' ? "ok 32\n" : "not ok 32\n";
+
+$foo = join('',('a','b','c','d','e','f')[6]);
+print $foo eq '' ? "ok 33\n" : "not ok 33\n";
+
+@foo = ('a','b','c','d','e','f')[0,2,4];
+@bar = ('a','b','c','d','e','f')[1,3,5];
+$foo = join('',(@foo,@bar)[0..5]);
+print $foo eq 'acebdf' ? "ok 34\n" : "not ok 34\n";
+
+$foo = ('a','b','c','d','e','f')[0,2,4];
+print $foo eq 'e' ? "ok 35\n" : "not ok 35\n";
+
+$foo = ('a','b','c','d','e','f')[1];
+print $foo eq 'b' ? "ok 36\n" : "not ok 36\n";
--- /dev/null
+#!./perl
+
+# $Header: auto.t,v 4.0 91/03/20 01:51:35 lwall Locked $
+
+print "1..34\n";
+
+$x = 10000;
+if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";}
+if (0 + $x-- - 1 == 10000) { print "ok 2\n";} else {print "not ok 2\n";}
+if (1 * $x == 10000) { print "ok 3\n";} else {print "not ok 3\n";}
+if (0 + $x-- - 0 == 10000) { print "ok 4\n";} else {print "not ok 4\n";}
+if (1 + $x == 10000) { print "ok 5\n";} else {print "not ok 5\n";}
+if (1 + $x++ == 10000) { print "ok 6\n";} else {print "not ok 6\n";}
+if (0 + $x == 10000) { print "ok 7\n";} else {print "not ok 7\n";}
+if (0 + --$x + 1 == 10000) { print "ok 8\n";} else {print "not ok 8\n";}
+if (0 + ++$x + 0 == 10000) { print "ok 9\n";} else {print "not ok 9\n";}
+if ($x == 10000) { print "ok 10\n";} else {print "not ok 10\n";}
+
+$x[0] = 10000;
+if (0 + ++$x[0] - 1 == 10000) { print "ok 11\n";} else {print "not ok 11\n";}
+if (0 + $x[0]-- - 1 == 10000) { print "ok 12\n";} else {print "not ok 12\n";}
+if (1 * $x[0] == 10000) { print "ok 13\n";} else {print "not ok 13\n";}
+if (0 + $x[0]-- - 0 == 10000) { print "ok 14\n";} else {print "not ok 14\n";}
+if (1 + $x[0] == 10000) { print "ok 15\n";} else {print "not ok 15\n";}
+if (1 + $x[0]++ == 10000) { print "ok 16\n";} else {print "not ok 16\n";}
+if (0 + $x[0] == 10000) { print "ok 17\n";} else {print "not ok 17\n";}
+if (0 + --$x[0] + 1 == 10000) { print "ok 18\n";} else {print "not ok 18\n";}
+if (0 + ++$x[0] + 0 == 10000) { print "ok 19\n";} else {print "not ok 19\n";}
+if ($x[0] == 10000) { print "ok 20\n";} else {print "not ok 20\n";}
+
+$x{0} = 10000;
+if (0 + ++$x{0} - 1 == 10000) { print "ok 21\n";} else {print "not ok 21\n";}
+if (0 + $x{0}-- - 1 == 10000) { print "ok 22\n";} else {print "not ok 22\n";}
+if (1 * $x{0} == 10000) { print "ok 23\n";} else {print "not ok 23\n";}
+if (0 + $x{0}-- - 0 == 10000) { print "ok 24\n";} else {print "not ok 24\n";}
+if (1 + $x{0} == 10000) { print "ok 25\n";} else {print "not ok 25\n";}
+if (1 + $x{0}++ == 10000) { print "ok 26\n";} else {print "not ok 26\n";}
+if (0 + $x{0} == 10000) { print "ok 27\n";} else {print "not ok 27\n";}
+if (0 + --$x{0} + 1 == 10000) { print "ok 28\n";} else {print "not ok 28\n";}
+if (0 + ++$x{0} + 0 == 10000) { print "ok 29\n";} else {print "not ok 29\n";}
+if ($x{0} == 10000) { print "ok 30\n";} else {print "not ok 30\n";}
+
+# test magical autoincrement
+
+if (++($foo = '99') eq '100') {print "ok 31\n";} else {print "not ok 31\n";}
+if (++($foo = 'a0') eq 'a1') {print "ok 32\n";} else {print "not ok 32\n";}
+if (++($foo = 'Az') eq 'Ba') {print "ok 33\n";} else {print "not ok 33\n";}
+if (++($foo = 'zz') eq 'aaa') {print "ok 34\n";} else {print "not ok 34\n";}
--- /dev/null
+#!./perl
+
+# $Header: chop.t,v 4.0 91/03/20 01:51:42 lwall Locked $
+
+print "1..4\n";
+
+# optimized
+
+$_ = 'abc';
+$c = do foo();
+if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1 $c$_\n";}
+
+# unoptimized
+
+$_ = 'abc';
+$c = chop($_);
+if ($c . $_ eq 'cab') {print "ok 2\n";} else {print "not ok 2\n";}
+
+sub foo {
+ chop;
+}
+
+@foo = ("hi \n","there\n","!\n");
+@bar = @foo;
+chop(@bar);
+print join('',@bar) eq 'hi there!' ? "ok 3\n" : "not ok 3\n";
+
+$foo = "\n";
+chop($foo,@foo);
+print join('',$foo,@foo) eq 'hi there!' ? "ok 4\n" : "not ok 4\n";
--- /dev/null
+#!./perl
+
+# $Header: cond.t,v 4.0 91/03/20 01:51:47 lwall Locked $
+
+print "1..4\n";
+
+print 1 ? "ok 1\n" : "not ok 1\n"; # compile time
+print 0 ? "not ok 2\n" : "ok 2\n";
+
+$x = 1;
+print $x ? "ok 3\n" : "not ok 3\n"; # run time
+print !$x ? "not ok 4\n" : "ok 4\n";
--- /dev/null
+#!./perl
+
+# $Header: dbm.t,v 4.0 91/03/20 01:51:52 lwall Locked $
+
+if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') {
+ print "1..0\n";
+ exit;
+}
+
+print "1..12\n";
+
+unlink <Op.dbmx.*>;
+umask(0);
+print (dbmopen(h,'Op.dbmx',0640) ? "ok 1\n" : "not ok 1\n");
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('Op.dbmx.pag');
+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'};
+
+dbmclose(h);
+print (dbmopen(h,'Op.dbmx',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('Op.dbmx.pag');
+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', 'Op.dbmx.pag';
--- /dev/null
+#!./perl
+
+# $Header: delete.t,v 4.0 91/03/20 01:51:56 lwall Locked $
+
+print "1..6\n";
+
+$foo{1} = 'a';
+$foo{2} = 'b';
+$foo{3} = 'c';
+
+$foo = delete $foo{2};
+
+if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
+if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";}
+if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";}
+if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$foo = join('',values(foo));
+if ($foo eq 'ac' || $foo eq 'ca') {print "ok 5\n";} else {print "not ok 5\n";}
+
+foreach $key (keys foo) {
+ delete $foo{$key};
+}
+
+$foo{'foo'} = 'x';
+$foo{'bar'} = 'y';
+
+$foo = join('',values(foo));
+if ($foo eq 'xy' || $foo eq 'yx') {print "ok 6\n";} else {print "not ok 6\n";}
--- /dev/null
+#!./perl
+
+# $Header: do.t,v 4.0 91/03/20 01:52:08 lwall Locked $
+
+sub foo1
+{
+ print $_[0];
+ 'value';
+}
+
+sub foo2
+{
+ shift(_);
+ print $_[0];
+ $x = 'value';
+ $x;
+}
+
+print "1..15\n";
+
+$_[0] = "not ok 1\n";
+$result = do foo1("ok 1\n");
+print "#2\t:$result: eq :value:\n";
+if ($result EQ 'value') { print "ok 2\n"; } else { print "not ok 2\n"; }
+if ($_[0] EQ "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; }
+
+$_[0] = "not ok 4\n";
+$result = do foo2("not ok 4\n","ok 4\n","not ok 4\n");
+print "#5\t:$result: eq :value:\n";
+if ($result EQ 'value') { print "ok 5\n"; } else { print "not ok 5\n"; }
+if ($_[0] EQ "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; }
+
+$result = do{print "ok 7\n"; 'value';};
+print "#8\t:$result: eq :value:\n";
+if ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; }
+
+sub blather {
+ print @_;
+}
+
+do blather("ok 9\n","ok 10\n");
+@x = ("ok 11\n", "ok 12\n");
+@y = ("ok 14\n", "ok 15\n");
+do blather(@x,"ok 13\n",@y);
--- /dev/null
+#!./perl
+
+# $Header: each.t,v 4.0 91/03/20 01:52:14 lwall Locked $
+
+print "1..3\n";
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+$h{'b'} = 'B';
+$h{'c'} = 'C';
+$h{'d'} = 'D';
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'G';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+@keys = keys %h;
+@values = values %h;
+
+if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";}
+
+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 2\n";} else {print "not ok 2\n";}
+
+@keys = ('blurfl', keys(%h), 'dyick');
+if ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";}
--- /dev/null
+#!./perl
+
+# $RCSfile: eval.t,v $$Revision: 4.0.1.1 $$Date: 91/11/05 18:43:19 $
+
+print "1..16\n";
+
+eval 'print "ok 1\n";';
+
+if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
+
+eval "\$foo\n = # this is a comment\n'ok 3';";
+print $foo,"\n";
+
+eval "\$foo\n = # this is a comment\n'ok 4\n';";
+print $foo;
+
+print eval '
+$foo ='; # this tests for a call through yyerror()
+if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
+
+print eval '$foo = /'; # this tests for a call through fatal()
+if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
+
+print eval '"ok 7\n";';
+
+# calculate a factorial with recursive evals
+
+$foo = 5;
+$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
+$ans = eval $fact;
+if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
+
+$foo = 5;
+$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
+$ans = eval $fact;
+if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
+
+open(try,'>Op.eval');
+print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
+close try;
+
+do 'Op.eval'; print $@;
+
+# Test the singlequoted eval optimizer
+
+$i = 11;
+for (1..3) {
+ eval 'print "ok ", $i++, "\n"';
+}
+
+eval {
+ print "ok 14\n";
+ die "ok 16\n";
+ 1;
+} || print "ok 15\n$@";
+
+
--- /dev/null
+#!./perl
+
+# $Header: exec.t,v 4.0 91/03/20 01:52:25 lwall Locked $
+
+$| = 1; # flush stdout
+print "1..8\n";
+
+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";
--- /dev/null
+#!./perl
+
+# $Header: exp.t,v 4.0 91/03/20 01:52:31 lwall Locked $
+
+print "1..6\n";
+
+# compile time evaluation
+
+$s = sqrt(2);
+if (substr($s,0,5) eq '1.414') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$s = exp(1);
+if (substr($s,0,7) eq '2.71828') {print "ok 2\n";} else {print "not ok 2\n";}
+
+if (exp(log(1)) == 1) {print "ok 3\n";} else {print "not ok 3\n";}
+
+# run time evaluation
+
+$x1 = 1;
+$x2 = 2;
+$s = sqrt($x2);
+if (substr($s,0,5) eq '1.414') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$s = exp($x1);
+if (substr($s,0,7) eq '2.71828') {print "ok 5\n";} else {print "not ok 5\n";}
+
+if (exp(log($x1)) == 1) {print "ok 6\n";} else {print "not ok 6\n";}
--- /dev/null
+#!./perl
+
+# $Header: flip.t,v 4.0 91/03/20 01:52:36 lwall Locked $
+
+print "1..8\n";
+
+@a = (1,2,3,4,5,6,7,8,9,10,11,12);
+
+while ($_ = shift(a)) {
+ if ($x = /4/../8/) { $z = $x; print "ok ", $x + 0, "\n"; }
+ $y .= /1/../2/;
+}
+
+if ($z eq '5E0') {print "ok 6\n";} else {print "not ok 6\n";}
+
+if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";}
+
+@a = ('a','b','c','d','e','f','g');
+
+open(of,'../Makefile');
+while (<of>) {
+ (3 .. 5) && $foo .= $_;
+}
+$x = ($foo =~ y/\n/\n/);
+
+if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";}
--- /dev/null
+#!./perl
+
+# $Header: fork.t,v 4.0 91/03/20 01:52:43 lwall Locked $
+
+$| = 1;
+print "1..2\n";
+
+if ($cid = fork) {
+ sleep 2;
+ if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";}
+}
+else {
+ $| = 1;
+ print "ok 1\n";
+ sleep 10;
+}
--- /dev/null
+#!./perl
+
+# $Header: glob.t,v 4.0 91/03/20 01:52:49 lwall Locked $
+
+print "1..4\n";
+
+@ops = <op/*>;
+$list = join(' ',@ops);
+
+chop($otherway = `echo op/*`);
+
+print $list eq $otherway ? "ok 1\n" : "not ok 1\n$list\n$otherway\n";
+
+print $/ eq "\n" ? "ok 2\n" : "not ok 2\n";
+
+while (<jskdfjskdfj* op/* jskdjfjkosvk*>) {
+ $not = "not " unless $_ eq shift @ops;
+ $not = "not at all " if $/ eq "\0";
+}
+print "${not}ok 3\n";
+
+print $/ eq "\n" ? "ok 4\n" : "not ok 4\n";
--- /dev/null
+#!./perl
+
+# $Header: goto.t,v 4.0 91/03/20 01:52:52 lwall Locked $
+
+print "1..3\n";
+
+while (0) {
+ $foo = 1;
+ label1:
+ $foo = 2;
+ goto label2;
+} continue {
+ $foo = 0;
+ goto label4;
+ label3:
+ $foo = 4;
+ goto label4;
+}
+goto label1;
+
+$foo = 3;
+
+label2:
+print "#1\t:$foo: == 2\n";
+if ($foo == 2) {print "ok 1\n";} else {print "not ok 1\n";}
+goto label3;
+
+label4:
+print "#2\t:$foo: == 4\n";
+if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$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";}
--- /dev/null
+#!./perl
+
+if (! -x '/usr/ucb/groups') {
+ print "1..0\n";
+ exit 0;
+}
+
+print "1..2\n";
+
+$pwgid = $( + 0;
+($pwgnam) = getgrgid($pwgid);
+@basegroup{$pwgid,$pwgnam} = (1,1);
+
+$seen{$pwgid}++;
+
+for (split(' ', $()) {
+ next if $seen{$_}++;
+ ($group) = getgrgid($_);
+ if (defined $group) {
+ push(@gr, $group);
+ }
+ else {
+ push(@gr, $_);
+ }
+}
+
+$gr1 = join(' ', sort @gr);
+
+$gr2 = join(' ', grep(!$basegroup{$_}, sort split(' ',`/usr/ucb/groups`)));
+
+if ($gr1 eq $gr2) {
+ print "ok 1\n";
+}
+else {
+ print "#gr1 is <$gr1>\n";
+ print "#gr2 is <$gr2>\n";
+ print "not ok 1\n";
+}
+
+# multiple 0's indicate GROUPSTYPE is currently long but should be short
+
+if ($pwgid == 0 || $seen{0} < 2) {
+ print "ok 2\n";
+}
+else {
+ print "not ok 2 (groupstype should be type short, not long)\n";
+}
--- /dev/null
+#!./perl
+
+# $Header: index.t,v 4.0 91/03/20 01:53:05 lwall Locked $
+
+print "1..20\n";
+
+
+$foo = 'Now is the time for all good men to come to the aid of their country.';
+
+$first = substr($foo,0,index($foo,'the'));
+print ($first eq "Now is " ? "ok 1\n" : "not ok 1\n");
+
+$last = substr($foo,rindex($foo,'the'),100);
+print ($last eq "their country." ? "ok 2\n" : "not ok 2\n");
+
+$last = substr($foo,index($foo,'Now'),2);
+print ($last eq "No" ? "ok 3\n" : "not ok 3\n");
+
+$last = substr($foo,rindex($foo,'Now'),2);
+print ($last eq "No" ? "ok 4\n" : "not ok 4\n");
+
+$last = substr($foo,index($foo,'.'),100);
+print ($last eq "." ? "ok 5\n" : "not ok 5\n");
+
+$last = substr($foo,rindex($foo,'.'),100);
+print ($last eq "." ? "ok 6\n" : "not ok 6\n");
+
+print index("ababa","a",-1) == 0 ? "ok 7\n" : "not ok 7\n";
+print index("ababa","a",0) == 0 ? "ok 8\n" : "not ok 8\n";
+print index("ababa","a",1) == 2 ? "ok 9\n" : "not ok 9\n";
+print index("ababa","a",2) == 2 ? "ok 10\n" : "not ok 10\n";
+print index("ababa","a",3) == 4 ? "ok 11\n" : "not ok 11\n";
+print index("ababa","a",4) == 4 ? "ok 12\n" : "not ok 12\n";
+print index("ababa","a",5) == -1 ? "ok 13\n" : "not ok 13\n";
+
+print rindex("ababa","a",-1) == -1 ? "ok 14\n" : "not ok 14\n";
+print rindex("ababa","a",0) == 0 ? "ok 15\n" : "not ok 15\n";
+print rindex("ababa","a",1) == 0 ? "ok 16\n" : "not ok 16\n";
+print rindex("ababa","a",2) == 2 ? "ok 17\n" : "not ok 17\n";
+print rindex("ababa","a",3) == 2 ? "ok 18\n" : "not ok 18\n";
+print rindex("ababa","a",4) == 4 ? "ok 19\n" : "not ok 19\n";
+print rindex("ababa","a",5) == 4 ? "ok 20\n" : "not ok 20\n";
--- /dev/null
+#!./perl
+
+# $Header: int.t,v 4.0 91/03/20 01:53:08 lwall Locked $
+
+print "1..4\n";
+
+# compile time evaluation
+
+if (int(1.234) == 1) {print "ok 1\n";} else {print "not ok 1\n";}
+
+if (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";}
+
+# run time evaluation
+
+$x = 1.234;
+if (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";}
+if (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";}
--- /dev/null
+#!./perl
+
+# $Header: join.t,v 4.0 91/03/20 01:53:17 lwall Locked $
+
+print "1..3\n";
+
+@x = (1, 2, 3);
+if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
+
+if (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";}
+
+if (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";}
--- /dev/null
+#!./perl
+
+# $Header: list.t,v 4.0 91/03/20 01:53:24 lwall Locked $
+
+print "1..27\n";
+
+@foo = (1, 2, 3, 4);
+if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";}
+
+$_ = join(':',@foo);
+if ($_ eq '1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
+
+($a,$b,$c,$d) = (1,2,3,4);
+if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 3\n";} else {print "not ok 3\n";}
+
+($c,$b,$a) = split(/ /,"111 222 333");
+if ("$a;$b;$c" eq '333;222;111') {print "ok 4\n";} else {print "not ok 4\n";}
+
+($a,$b,$c) = ($c,$b,$a);
+if ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5 $a;$b;$c\n";}
+
+($a, $b) = ($b, $a);
+if ("$a;$b;$c" eq '222;111;333') {print "ok 6\n";} else {print "not ok 6\n";}
+
+($a, $b[1], $c{2}, $d) = (1, 2, 3, 4);
+if ($a eq 1) {print "ok 7\n";} else {print "not ok 7\n";}
+if ($b[1] eq 2) {print "ok 8\n";} else {print "not ok 8\n";}
+if ($c{2} eq 3) {print "ok 9\n";} else {print "not ok 9\n";}
+if ($d eq 4) {print "ok 10\n";} else {print "not ok 10\n";}
+
+@foo = (1,2,3,4,5,6,7,8);
+($a, $b, $c, $d) = @foo;
+print "#11 $a;$b;$c;$d eq 1;2;3;4\n";
+if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";}
+
+@foo = @bar = (1);
+if (join(':',@foo,@bar) eq '1:1') {print "ok 12\n";} else {print "not ok 12\n";}
+
+@foo = ();
+@foo = 1+2+3;
+if (join(':',@foo) eq '6') {print "ok 13\n";} else {print "not ok 13\n";}
+
+for ($x = 0; $x < 3; $x++) {
+ ($a, $b, $c) =
+ $x == 0?
+ ('ok ', 14, "\n"):
+ $x == 1?
+ ('ok ', 15, "\n"):
+ # default
+ ('ok ', 16, "\n");
+
+ print $a,$b,$c;
+}
+
+@a = ($x == 12345 || (1,2,3));
+if (join('',@a) eq '123') {print "ok 17\n";} else {print "not ok 17\n";}
+
+@a = ($x == $x || (4,5,6));
+if (join('',@a) eq '1') {print "ok 18\n";} else {print "not ok 18\n";}
+
+if (join('',1,2,(3,4,5)) eq '12345'){print "ok 19\n";}else{print "not ok 19\n";}
+if (join('',(1,2,3,4,5)) eq '12345'){print "ok 20\n";}else{print "not ok 20\n";}
+if (join('',(1,2,3,4),5) eq '12345'){print "ok 21\n";}else{print "not ok 21\n";}
+if (join('',1,(2,3,4),5) eq '12345'){print "ok 22\n";}else{print "not ok 22\n";}
+if (join('',1,2,(3,4),5) eq '12345'){print "ok 23\n";}else{print "not ok 23\n";}
+if (join('',1,2,3,(4),5) eq '12345'){print "ok 24\n";}else{print "not ok 24\n";}
+
+for ($x = 0; $x < 3; $x++) {
+ ($a, $b, $c) = do {
+ if ($x == 0) {
+ ('ok ', 25, "\n");
+ }
+ elsif ($x == 1) {
+ ('ok ', 26, "\n");
+ }
+ else {
+ ('ok ', 27, "\n");
+ }
+ };
+
+ print $a,$b,$c;
+}
+
--- /dev/null
+#!./perl
+
+# $Header: local.t,v 4.0 91/03/20 01:53:29 lwall Locked $
+
+print "1..20\n";
+
+sub foo {
+ local($a, $b) = @_;
+ local($c, $d);
+ $c = "ok 3\n";
+ $d = "ok 4\n";
+ { local($a,$c) = ("ok 9\n", "ok 10\n"); ($x, $y) = ($a, $c); }
+ print $a, $b;
+ $c . $d;
+}
+
+$a = "ok 5\n";
+$b = "ok 6\n";
+$c = "ok 7\n";
+$d = "ok 8\n";
+
+print do foo("ok 1\n","ok 2\n");
+
+print $a,$b,$c,$d,$x,$y;
+
+# same thing, only with arrays and associative arrays
+
+sub foo2 {
+ local($a, @b) = @_;
+ local(@c, %d);
+ @c = "ok 13\n";
+ $d{''} = "ok 14\n";
+ { local($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); }
+ print $a, @b;
+ $c[0] . $d{''};
+}
+
+$a = "ok 15\n";
+@b = "ok 16\n";
+@c = "ok 17\n";
+$d{''} = "ok 18\n";
+
+print do foo2("ok 11\n","ok 12\n");
+
+print $a,@b,@c,%d,$x,$y;
--- /dev/null
+#!./perl
+
+# $Header: magic.t,v 4.0 91/03/20 01:53:35 lwall Locked $
+
+$| = 1; # command buffering
+
+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;
+open(foo,'ajslkdfpqjsjfk');
+if ($! == 2) {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.
+
+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);
+
+print join(':',@val1) eq join(':',@val2) ? "ok 5\n" : "not ok 5\n";
--- /dev/null
+#!./perl
+
+# $Header: mkdir.t,v 4.0 91/03/20 01:53:39 lwall Locked $
+
+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");
+print ($! =~ /such|exist/ ? "ok 7\n" : "not ok 7\n");
--- /dev/null
+#!./perl
+
+# $Header: oct.t,v 4.0 91/03/20 01:53:43 lwall Locked $
+
+print "1..3\n";
+
+if (oct('01234') == 01234) {print "ok 1\n";} else {print "not ok 1\n";}
+if (oct('0x1234') == 0x1234) {print "ok 2\n";} else {print "not ok 2\n";}
+if (hex('01234') == 0x1234) {print "ok 3\n";} else {print "not ok 3\n";}
--- /dev/null
+#!./perl
+
+# $Header: ord.t,v 4.0 91/03/20 01:53:50 lwall Locked $
+
+print "1..2\n";
+
+# compile time evaluation
+
+if (ord('A') == 65) {print "ok 1\n";} else {print "not ok 1\n";}
+
+# run time evaluation
+
+$x = 'ABC';
+if (ord($x) == 65) {print "ok 2\n";} else {print "not ok 2\n";}
--- /dev/null
+#!./perl
+
+# $Header: pack.t,v 4.0 91/03/20 01:53:57 lwall Locked $
+
+print "1..3\n";
+
+$format = "c2x5CCxsdila6";
+# Need the expression in here to force ary[5] to be numeric. This avoids
+# test2 failing because ary2 goes str->numeric->str and ary doesn't.
+@ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef");
+$foo = pack($format,@ary);
+@ary2 = unpack($format,$foo);
+
+print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n");
+
+$out1=join(':',@ary);
+$out2=join(':',@ary2);
+print ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n");
+
+print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n");
--- /dev/null
+#!./perl
+
+# $RCSfile: pat.t,v $$Revision: 4.0.1.2 $$Date: 91/06/10 01:29:34 $
+
+print "1..51\n";
+
+$x = "abc\ndef\n";
+
+if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
+if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$* = 1;
+if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
+$* = 0;
+
+$_ = '123';
+if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
+
+if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
+if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
+
+if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
+if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
+
+if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
+if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
+
+if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
+if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
+
+$_ = 'aaabbbccc';
+if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
+ print "ok 13\n";
+} else {
+ print "not ok 13\n";
+}
+if (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
+ print "ok 14\n";
+} else {
+ print "not ok 14\n";
+}
+
+if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
+
+$_ = 'aaabccc';
+if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
+if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
+
+$_ = 'aaaccc';
+if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
+if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
+
+$_ = 'abcdef';
+if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
+if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
+
+if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
+
+if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
+
+$* = 1; # test 3 only tested the optimized version--this one is for real
+if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
+$* = 0;
+
+$XXX{123} = 123;
+$XXX{234} = 234;
+$XXX{345} = 345;
+
+@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27');
+while ($_ = shift(XXX)) {
+ ?(.*)? && (print $1,"\n");
+ /not/ && reset;
+ /not ok 26/ && reset 'X';
+}
+
+while (($key,$val) = each(XXX)) {
+ print "not ok 27\n";
+ exit;
+}
+
+print "ok 27\n";
+
+'cde' =~ /[^ab]*/;
+'xyz' =~ //;
+if ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";}
+
+$foo = '[^ab]*';
+'cde' =~ /$foo/;
+'xyz' =~ //;
+if ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";}
+
+$foo = '[^ab]*';
+'cde' =~ /$foo/;
+'xyz' =~ /$null/;
+if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";}
+
+$_ = 'abcdefghi';
+/def/; # optimized up to cmd
+if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";}
+
+/cde/ + 0; # optimized only to spat
+if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";}
+
+/[d][e][f]/; # not optimized
+if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";}
+
+$_ = 'now is the {time for all} good men to come to.';
+/ {([^}]*)}/;
+if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";}
+
+$_ = 'xxx {3,4} yyy zzz';
+print /( {3,4})/ ? "ok 35\n" : "not ok 35\n";
+print $1 eq ' ' ? "ok 36\n" : "not ok 36\n";
+print /( {4,})/ ? "not ok 37\n" : "ok 37\n";
+print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n";
+print $1 eq ' y' ? "ok 39\n" : "not ok 39\n";
+print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n";
+print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n";
+print /x {3,4}/ ? "not ok 42\n" : "ok 42\n";
+print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n";
+
+$_ = "now is the time for all good men to come to.";
+@words = /(\w+)/g;
+print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
+ ? "ok 44\n"
+ : "not ok 44\n";
+
+@words = ();
+while (/\w+/g) {
+ push(@words, $&);
+}
+print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
+ ? "ok 45\n"
+ : "not ok 45\n";
+
+@words = ();
+while (/to/g) {
+ push(@words, $&);
+}
+print join(':',@words) eq "to:to"
+ ? "ok 46\n"
+ : "not ok 46 @words\n";
+
+@words = /to/g;
+print join(':',@words) eq "to:to"
+ ? "ok 47\n"
+ : "not ok 47 @words\n";
+
+$_ = "abcdefghi";
+
+$pat1 = 'def';
+$pat2 = '^def';
+$pat3 = '.def.';
+$pat4 = 'abc';
+$pat5 = '^abc';
+$pat6 = 'abc$';
+$pat7 = 'ghi';
+$pat8 = '\w*ghi';
+$pat9 = 'ghi$';
+
+$t1=$t2=$t3=$t4=$t5=$t6=$t7=$t8=$t9=0;
+
+for $iter (1..5) {
+ $t1++ if /$pat1/o;
+ $t2++ if /$pat2/o;
+ $t3++ if /$pat3/o;
+ $t4++ if /$pat4/o;
+ $t5++ if /$pat5/o;
+ $t6++ if /$pat6/o;
+ $t7++ if /$pat7/o;
+ $t8++ if /$pat8/o;
+ $t9++ if /$pat9/o;
+}
+
+$x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9";
+print $x eq '505550555' ? "ok 48\n" : "not ok 48 $x\n";
+
+$xyz = 'xyz';
+print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n";
+
+# perl 4.009 says "unmatched ()"
+eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"';
+print $@ eq "" ? "ok 50\n" : "not ok 50\n";
+print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n";
--- /dev/null
+#!./perl
+
+# $Header: push.t,v 4.0 91/03/20 01:54:07 lwall Locked $
+
+@tests = split(/\n/, <<EOF);
+0 3, 0 1 2, 3 4 5 6 7
+0 0 a b c, , a b c 0 1 2 3 4 5 6 7
+8 0 a b c, , 0 1 2 3 4 5 6 7 a b c
+7 0 6.5, , 0 1 2 3 4 5 6 6.5 7
+1 0 a b c d e f g h i j,, 0 a b c d e f g h i j 1 2 3 4 5 6 7
+0 1 a, 0, a 1 2 3 4 5 6 7
+1 6 x y z, 1 2 3 4 5 6, 0 x y z 7
+0 7 x y z, 0 1 2 3 4 5 6, x y z 7
+1 7 x y z, 1 2 3 4 5 6 7, 0 x y z
+4, 4 5 6 7, 0 1 2 3
+-4, 4 5 6 7, 0 1 2 3
+EOF
+
+print "1..", 2 + @tests, "\n";
+die "blech" unless @tests;
+
+@x = (1,2,3);
+push(@x,@x);
+if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
+push(x,4);
+if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$test = 3;
+foreach $line (@tests) {
+ ($list,$get,$leave) = split(/,\t*/,$line);
+ @list = split(' ',$list);
+ @get = split(' ',$get);
+ @leave = split(' ',$leave);
+ @x = (0,1,2,3,4,5,6,7);
+ @got = splice(@x,@list);
+ if (join(':',@got) eq join(':',@get) &&
+ join(':',@x) eq join(':',@leave)) {
+ print "ok ",$test++,"\n";
+ }
+ else {
+ print "not ok ",$test++," got: @got == @get left: @x == @leave\n";
+ }
+}
+
--- /dev/null
+#!./perl
+
+# $Header: range.t,v 4.0 91/03/20 01:54:11 lwall Locked $
+
+print "1..8\n";
+
+print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n";
+
+@foo = (1,2,3,4,5,6,7,8,9);
+@foo[2..4] = ('c','d','e');
+
+print join(':',@foo[$foo[0]..5]) eq '2:c:d:e:6' ? "ok 2\n" : "not ok 2\n";
+
+@bar[2..4] = ('c','d','e');
+print join(':',@bar[1..5]) eq ':c:d:e:' ? "ok 3\n" : "not ok 3\n";
+
+($a,@bcd[0..2],$e) = ('a','b','c','d','e');
+print join(':',$a,@bcd[0..2],$e) eq 'a:b:c:d:e' ? "ok 4\n" : "not ok 4\n";
+
+$x = 0;
+for (1..100) {
+ $x += $_;
+}
+print $x == 5050 ? "ok 5\n" : "not ok 5 $x\n";
+
+$x = 0;
+for ((100,2..99,1)) {
+ $x += $_;
+}
+print $x == 5050 ? "ok 6\n" : "not ok 6 $x\n";
+
+$x = join('','a'..'z');
+print $x eq 'abcdefghijklmnopqrstuvwxyz' ? "ok 7\n" : "not ok 7 $x\n";
+
+@x = 'A'..'ZZ';
+print @x == 27 * 26 ? "ok 8\n" : "not ok 8\n";
--- /dev/null
+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 - -
+(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*?'i - c - -
+'(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
--- /dev/null
+#!./perl
+
+# $Header: read.t,v 4.0 91/03/20 01:54:16 lwall Locked $
+
+print "1..4\n";
+
+
+open(FOO,'op/read.t') || open(FOO,'t/op/read.t') || die "Can't open op.read";
+seek(FOO,4,0);
+$got = read(FOO,$buf,4);
+
+print ($got == 4 ? "ok 1\n" : "not ok 1\n");
+print ($buf eq "perl" ? "ok 2\n" : "not ok 2 :$buf:\n");
+
+seek(FOO,20000,0);
+$got = read(FOO,$buf,4);
+
+print ($got == 0 ? "ok 3\n" : "not ok 3\n");
+print ($buf eq "" ? "ok 4\n" : "not ok 4\n");
--- /dev/null
+#!./perl
+
+eval 'opendir(NOSUCH, "no/such/directory");';
+if ($@) { print "1..0\n"; exit; }
+
+print "1..3\n";
+
+if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; }
+@D = grep(/^[^\.]/, readdir(OP));
+closedir(OP);
+
+if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; }
+
+@R = sort @D;
+@G = <op/*>;
+while (@R && @G && "op/".$R[0] eq $G[0]) {
+ shift(@R);
+ shift(@G);
+}
+if (@R == 0 && @G == 0) { print "ok 3\n"; } else { print "not ok 3\n"; }
--- /dev/null
+#!./perl
+
+# $RCSfile: regexp.t,v $$Revision: 4.0.1.1 $$Date: 91/06/10 01:30:29 $
+
+open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
+ || die "Can't open re_tests";
+while (<TESTS>) { }
+$numtests = $.;
+close(TESTS);
+
+print "1..$numtests\n";
+open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
+ || die "Can't open re_tests";
+$| = 1;
+while (<TESTS>) {
+ ($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_);
+ $input = join(':',$pat,$subject,$result,$repl,$expect);
+ $pat = "'$pat'" unless $pat =~ /^'/;
+ eval "\$match = (\$subject =~ m$pat); \$got = \"$repl\";";
+ if ($result eq 'c') {
+ if ($@ ne '') {print "ok $.\n";} else {print "not ok $.\n";}
+ }
+ elsif ($result eq 'n') {
+ if (!$match) {print "ok $.\n";} else {print "not ok $. $input => $got\n";}
+ }
+ else {
+ if ($match && $got eq $expect) {
+ print "ok $.\n";
+ }
+ else {
+ print "not ok $. $input => $got\n";
+ }
+ }
+}
+close(TESTS);
--- /dev/null
+#!./perl
+
+# $Header: repeat.t,v 4.0 91/03/20 01:54:26 lwall Locked $
+
+print "1..19\n";
+
+# compile time
+
+if ('-' x 5 eq '-----') {print "ok 1\n";} else {print "not ok 1\n";}
+if ('-' x 1 eq '-') {print "ok 2\n";} else {print "not ok 2\n";}
+if ('-' x 0 eq '') {print "ok 3\n";} else {print "not ok 3\n";}
+
+if ('ab' x 3 eq 'ababab') {print "ok 4\n";} else {print "not ok 4\n";}
+
+# run time
+
+$a = '-';
+if ($a x 5 eq '-----') {print "ok 5\n";} else {print "not ok 5\n";}
+if ($a x 1 eq '-') {print "ok 6\n";} else {print "not ok 6\n";}
+if ($a x 0 eq '') {print "ok 7\n";} else {print "not ok 7\n";}
+
+$a = 'ab';
+if ($a x 3 eq 'ababab') {print "ok 8\n";} else {print "not ok 8\n";}
+
+$a = 'xyz';
+$a x= 2;
+if ($a eq 'xyzxyz') {print "ok 9\n";} else {print "not ok 9\n";}
+$a x= 1;
+if ($a eq 'xyzxyz') {print "ok 10\n";} else {print "not ok 10\n";}
+$a x= 0;
+if ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";}
+
+@x = (1,2,3);
+
+print join('', @x x 4) eq '3333' ? "ok 12\n" : "not ok 12\n";
+print join('', (@x) x 4) eq '123123123123' ? "ok 13\n" : "not ok 13\n";
+print join('', (@x,()) x 4) eq '123123123123' ? "ok 14\n" : "not ok 14\n";
+print join('', (@x,1) x 4) eq '1231123112311231' ? "ok 15\n" : "not ok 15\n";
+print join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n";
+print join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n";
+print join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n";
+print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n";
--- /dev/null
+#!./perl
+
+# $Header: s.t,v 4.0 91/03/20 01:54:30 lwall Locked $
+
+print "1..51\n";
+
+$x = 'foo';
+$_ = "x";
+s/x/\$x/;
+print "#1\t:$_: eq :\$x:\n";
+if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$_ = "x";
+s/x/$x/;
+print "#2\t:$_: eq :foo:\n";
+if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$_ = "x";
+s/x/\$x $x/;
+print "#3\t:$_: eq :\$x foo:\n";
+if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";}
+
+$b = 'cd';
+($a = 'abcdef') =~ s'(b${b}e)'\n$1';
+print "#4\t:$1: eq :bcde:\n";
+print "#4\t:$a: eq :a\\n\$1f:\n";
+if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$a = 'abacada';
+if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx')
+ {print "ok 5\n";} else {print "not ok 5\n";}
+
+if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx')
+ {print "ok 6\n";} else {print "not ok 6 $a\n";}
+
+if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx')
+ {print "ok 7\n";} else {print "not ok 7 $a\n";}
+
+$_ = 'ABACADA';
+if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";}
+
+$_ = '\\' x 4;
+if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";}
+s/\\/\\\\/g;
+if ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10 $_\n";}
+
+$_ = '\/' x 4;
+if (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\n";}
+s/\//\/\//g;
+if ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";}
+if (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";}
+
+$_ = 'aaaXXXXbbb';
+s/^a//;
+print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n";
+
+$_ = 'aaaXXXXbbb';
+s/a//;
+print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n";
+
+$_ = 'aaaXXXXbbb';
+s/^a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n";
+
+$_ = 'aaaXXXXbbb';
+s/a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n";
+
+$_ = 'aaaXXXXbbb';
+s/aa//;
+print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n";
+
+$_ = 'aaaXXXXbbb';
+s/aa/b/;
+print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n";
+
+$_ = 'aaaXXXXbbb';
+s/b$//;
+print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n";
+
+$_ = 'aaaXXXXbbb';
+s/b//;
+print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n";
+
+$_ = 'aaaXXXXbbb';
+s/bb//;
+print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n";
+
+$_ = 'aaaXXXXbbb';
+s/aX/y/;
+print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n";
+
+$_ = 'aaaXXXXbbb';
+s/Xb/z/;
+print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n";
+
+$_ = 'aaaXXXXbbb';
+s/aaX.*Xbb//;
+print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n";
+
+$_ = 'aaaXXXXbbb';
+s/bb/x/;
+print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n";
+
+# now for some unoptimized versions of the same.
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/^a//;
+print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/a//;
+print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/^a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aa//;
+print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aa/b/;
+print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/b$//;
+print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/b//;
+print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/bb//;
+print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aX/y/;
+print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/Xb/z/;
+print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aaX.*Xbb//;
+print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/bb/x/;
+print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n";
+
+$_ = 'abc123xyz';
+s/\d+/$&*2/e; # yields 'abc246xyz'
+print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n";
+s/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz'
+print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n";
+s/\w/$& x 2/eg; # yields 'aabbcc 224466xxyyzz'
+print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n";
+
+$_ = "aaaaa";
+print y/a/b/ == 5 ? "ok 43\n" : "not ok 43\n";
+print y/a/b/ == 0 ? "ok 44\n" : "not ok 44\n";
+print y/b// == 5 ? "ok 45\n" : "not ok 45\n";
+print y/b/c/s == 5 ? "ok 46\n" : "not ok 46\n";
+print y/c// == 1 ? "ok 47\n" : "not ok 47\n";
+print y/c//d == 1 ? "ok 48\n" : "not ok 48\n";
+print $_ eq "" ? "ok 49\n" : "not ok 49\n";
+
+$_ = "Now is the %#*! time for all good men...";
+print (($x=(y/a-zA-Z //cd)) == 7 ? "ok 50\n" : "not ok 50\n");
+print y/ / /s == 8 ? "ok 51\n" : "not ok 51\n";
+
--- /dev/null
+#!./perl
+
+# $Header: sleep.t,v 4.0 91/03/20 01:54:34 lwall Locked $
+
+print "1..1\n";
+
+$x = sleep 2;
+if ($x >= 2 && $x <= 10) {print "ok 1\n";} else {print "not ok 1 $x\n";}
--- /dev/null
+#!./perl
+
+# $RCSfile: sort.t,v $$Revision: 4.0.1.2 $$Date: 91/11/11 16:43:47 $
+
+print "1..10\n";
+
+sub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; }
+
+@harry = ('dog','cat','x','Cain','Abel');
+@george = ('gone','chased','yz','Punished','Axed');
+
+$x = join('', sort @harry);
+print ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n");
+
+$x = join('', sort reverse @harry);
+print ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n");
+
+$x = join('', sort @george, 'to', @harry);
+print ($x eq 'AbelAxedCainPunishedcatchaseddoggonetoxyz'?"ok 3\n":"not ok 3\n");
+
+@a = ();
+@b = reverse @a;
+print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n");
+
+@a = (1);
+@b = reverse @a;
+print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n");
+
+@a = (1,2);
+@b = reverse @a;
+print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n");
+
+@a = (1,2,3);
+@b = reverse @a;
+print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n");
+
+@a = (1,2,3,4);
+@b = reverse @a;
+print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n");
+
+@a = (10,2,3,4);
+@b = sort {$a <=> $b;} @a;
+print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n");
+
+$sub = 'reverse';
+$x = join('', sort $sub @harry);
+print ($x eq 'xdogcatCainAbel' ? "ok 10\n" : "not ok 10\n");
+
--- /dev/null
+#!./perl
+
+# $Header: split.t,v 4.0 91/03/20 01:54:42 lwall Locked $
+
+print "1..12\n";
+
+$FS = ':';
+
+$_ = 'a:b:c';
+
+($a,$b,$c) = split($FS,$_);
+
+if (join(';',$a,$b,$c) eq 'a;b;c') {print "ok 1\n";} else {print "not ok 1\n";}
+
+@ary = split(/:b:/);
+if (join("$_",@ary) eq 'aa:b:cc') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$_ = "abc\n";
+@xyz = (@ary = split(//));
+if (join(".",@ary) eq "a.b.c.\n") {print "ok 3\n";} else {print "not ok 3\n";}
+
+$_ = "a:b:c::::";
+@ary = split(/:/);
+if (join(".",@ary) eq "a.b.c") {print "ok 4\n";} else {print "not ok 4\n";}
+
+$_ = join(':',split(' '," a b\tc \t d "));
+if ($_ eq 'a:b:c:d') {print "ok 5\n";} else {print "not ok 5 #$_#\n";}
+
+$_ = join(':',split(/ */,"foo bar bie\tdoll"));
+if ($_ eq "f:o:o:b:a:r:b:i:e:\t:d:o:l:l")
+ {print "ok 6\n";} else {print "not ok 6\n";}
+
+$_ = join(':', 'foo', split(/ /,'a b c'), 'bar');
+if ($_ eq "foo:a:b::c:bar") {print "ok 7\n";} else {print "not ok 7 $_\n";}
+
+# Can we say how many fields to split to?
+$_ = join(':', split(' ','1 2 3 4 5 6', 3));
+print $_ eq '1:2:3 4 5 6' ? "ok 8\n" : "not ok 8 $_\n";
+
+# Can we do it as a variable?
+$x = 4;
+$_ = join(':', split(' ','1 2 3 4 5 6', $x));
+print $_ eq '1:2:3:4 5 6' ? "ok 9\n" : "not ok 9 $_\n";
+
+# Does the 999 suppress null field chopping?
+$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999));
+print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n";
+
+# Does assignment to a list imply split to one more field than that?
+$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?
+($a,$b) = split(' ','1 2 3 4 5 6', 2);
+$_ = join(':',$a,$b);
+print $_ eq '1:2 3 4 5 6' ? "ok 12\n" : "not ok 12 $_\n";
+
--- /dev/null
+#!./perl
+
+# $Header: sprintf.t,v 4.0 91/03/20 01:54:46 lwall Locked $
+
+print "1..1\n";
+
+$x = sprintf("%3s %-4s%%foo %5d%c%3.1f","hi",123,456,65,3.0999);
+if ($x eq ' hi 123 %foo 456A3.1') {print "ok 1\n";} else {print "not ok 1 '$x'\n";}
--- /dev/null
+#!./perl
+
+# $RCSfile: stat.t,v $$Revision: 4.0.1.3 $$Date: 91/11/11 16:44:49 $
+
+print "1..56\n";
+
+chop($cwd = `pwd`);
+
+$DEV = `ls -l /dev`;
+
+unlink "Op.stat.tmp";
+open(FOO, ">Op.stat.tmp");
+
+$junk = `ls Op.stat.tmp`; # hack to make Apollo update link count
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat(FOO);
+if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";}
+if ($mtime && $mtime == $ctime) {print "ok 2\n";} else {print "not ok 2\n";}
+
+print FOO "Now is the time for all good men to come to.\n";
+close(FOO);
+
+sleep 2;
+
+`rm -f Op.stat.tmp2; ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`;
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('Op.stat.tmp');
+
+if ($nlink == 2) {print "ok 3\n";} else {print "not ok 3\n";}
+if (($mtime && $mtime != $ctime) || $cwd =~ m#/afs/#) {
+ print "ok 4\n";
+}
+else {
+ print "not ok 4\n";
+}
+print "#4 :$mtime: != :$ctime:\n";
+
+`rm -f Op.stat.tmp`;
+`touch Op.stat.tmp`;
+
+if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";}
+if (! -s 'Op.stat.tmp') {print "ok 6\n";} else {print "not ok 6\n";}
+
+`echo hi >Op.stat.tmp`;
+if (! -z 'Op.stat.tmp') {print "ok 7\n";} else {print "not ok 7\n";}
+if (-s 'Op.stat.tmp') {print "ok 8\n";} else {print "not ok 8\n";}
+
+unlink 'Op.stat.tmp';
+$olduid = $>; # can't test -r if uid == 0
+`echo hi >Op.stat.tmp`;
+chmod 0,'Op.stat.tmp';
+eval '$> = 1;'; # so switch uid (may not be implemented)
+if (!$> || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";}
+if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";}
+eval '$> = $olduid;'; # switch uid back (may not be implemented)
+print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid);
+if (! -x 'Op.stat.tmp') {print "ok 11\n";} else {print "not ok 11\n";}
+
+foreach ((12,13,14,15,16,17)) {
+ print "ok $_\n"; #deleted tests
+}
+
+chmod 0700,'Op.stat.tmp';
+if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";}
+if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";}
+if (-x 'Op.stat.tmp') {print "ok 20\n";} else {print "not ok 20\n";}
+
+if (-f 'Op.stat.tmp') {print "ok 21\n";} else {print "not ok 21\n";}
+if (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";}
+
+if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";}
+if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";}
+
+if (`ls -l perl` =~ /^l.*->/) {
+ if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";}
+}
+else {
+ print "ok 25\n";
+}
+
+if (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";}
+
+if (-e 'Op.stat.tmp') {print "ok 27\n";} else {print "not ok 27\n";}
+`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/)
+ {print "ok 29\n";}
+elsif (-c "/dev/$1")
+ {print "ok 29\n";}
+else
+ {print "not ok 29\n";}
+if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";}
+
+if ($DEV !~ /\ns.* (\S+)\n/)
+ {print "ok 31\n";}
+elsif (-S "/dev/$1")
+ {print "ok 31\n";}
+else
+ {print "not ok 31\n";}
+if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";}
+
+if ($DEV !~ /\nb.* (\S+)\n/)
+ {print "ok 33\n";}
+elsif (-b "/dev/$1")
+ {print "ok 33\n";}
+else
+ {print "not ok 33\n";}
+if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";}
+
+$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;
+ last if $uid && $uid < $cnt;
+}
+chdir $cwd || die "Can't cd back to $cwd";
+
+# 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";}
+
+# These aren't strictly "stat" calls, but so what?
+
+if (-T 'op/stat.t') {print "ok 41\n";} else {print "not ok 41\n";}
+if (! -B 'op/stat.t') {print "ok 42\n";} else {print "not ok 42\n";}
+
+if (-B './perl') {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; };
+if ($@ =~ /not implemented/) {
+ print "# $@";
+ for (45 .. 54) {
+ print "ok $_\n";
+ }
+}
+else {
+ if (-T FOO) {print "ok 45\n";} else {print "not ok 45\n";}
+ if (! -B FOO) {print "ok 46\n";} else {print "not ok 46\n";}
+ $_ = <FOO>;
+ if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";}
+ if (-T FOO) {print "ok 48\n";} else {print "not ok 48\n";}
+ if (! -B FOO) {print "ok 49\n";} else {print "not ok 49\n";}
+ close(FOO);
+
+ open(FOO,'op/stat.t');
+ $_ = <FOO>;
+ if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
+ if (-T FOO) {print "ok 51\n";} else {print "not ok 51\n";}
+ if (! -B FOO) {print "ok 52\n";} else {print "not ok 52\n";}
+ seek(FOO,0,0);
+ if (-T FOO) {print "ok 53\n";} else {print "not ok 53\n";}
+ if (! -B FOO) {print "ok 54\n";} else {print "not ok 54\n";}
+}
+close(FOO);
+
+if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";}
+if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";}
--- /dev/null
+#!./perl
+
+# $Header: study.t,v 4.0 91/03/20 01:54:59 lwall Locked $
+
+print "1..24\n";
+
+$x = "abc\ndef\n";
+study($x);
+
+if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
+if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$* = 1;
+if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
+$* = 0;
+
+$_ = '123';
+study;
+if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
+
+if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
+if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
+
+if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
+if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
+
+study($x);
+if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
+if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
+
+if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
+if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
+
+$_ = 'aaabbbccc';
+study;
+if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
+ print "ok 13\n";
+} else {
+ print "not ok 13\n";
+}
+if (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
+ print "ok 14\n";
+} else {
+ print "not ok 14\n";
+}
+
+if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
+
+$_ = 'aaabccc';
+study;
+if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
+if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
+
+$_ = 'aaaccc';
+study;
+if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
+if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
+
+$_ = 'abcdef';
+study;
+if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
+if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
+
+if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
+
+if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
+
+$* = 1; # test 3 only tested the optimized version--this one is for real
+if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
--- /dev/null
+#!./perl
+
+# $Header: substr.t,v 4.0 91/03/20 01:55:05 lwall Locked $
+
+print "1..22\n";
+
+$a = 'abcdefxyz';
+
+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,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n");
+
+$[ = 1;
+
+print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n");
+print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n");
+print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n");
+print (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n");
+print (substr($a,7,-1) eq '' ? "ok 11\n" : "not ok 11\n");
+print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n");
+
+$[ = 0;
+
+substr($a,3,3) = 'XYZ';
+print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n";
+substr($a,0,2) = '';
+print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n";
+y/a/a/;
+substr($a,0,0) = 'ab';
+print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n";
+substr($a,0,0) = '12345678';
+print $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n";
+substr($a,-3,3) = 'def';
+print $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n";
+substr($a,-3,3) = '<';
+print $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n";
+substr($a,-1,1) = '12345678';
+print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n";
+
+$a = 'abcdefxyz';
+
+print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n");
+print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n");
+print (substr($a,999) eq '' ? "ok 22\n" : "not ok 22\n");
--- /dev/null
+#!./perl
+
+# $Header: time.t,v 4.0 91/03/20 01:55:09 lwall Locked $
+
+print "1..5\n";
+
+($beguser,$begsys) = times;
+
+$beg = time;
+
+while (($now = time) == $beg) {}
+
+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;
+ last if time - $beg > 20;
+}
+
+if ($i >= 200000) {print "ok 2\n";} else {print "not ok 2\n";}
+
+($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg);
+($xsec,$foo) = localtime($now);
+$localyday = $yday;
+
+if ($sec != $xsec && $mday && $year)
+ {print "ok 3\n";}
+else
+ {print "not ok 3\n";}
+
+($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg);
+($xsec,$foo) = localtime($now);
+
+if ($sec != $xsec && $mday && $year)
+ {print "ok 4\n";}
+else
+ {print "not ok 4\n";}
+
+if (index(" :0:1:-1:365:366:-365:-366:",':' . ($localyday - $yday) . ':') > 0)
+ {print "ok 5\n";}
+else
+ {print "not ok 5\n";}
--- /dev/null
+#!./perl
+
+# $Header: undef.t,v 4.0 91/03/20 01:55:16 lwall Locked $
+
+print "1..21\n";
+
+print defined($a) ? "not ok 1\n" : "ok 1\n";
+
+$a = 1+1;
+print defined($a) ? "ok 2\n" : "not ok 2\n";
+
+undef $a;
+print defined($a) ? "not ok 3\n" : "ok 3\n";
+
+$a = "hi";
+print defined($a) ? "ok 4\n" : "not ok 4\n";
+
+$a = $b;
+print defined($a) ? "not ok 5\n" : "ok 5\n";
+
+@ary = ("1arg");
+$a = pop(@ary);
+print defined($a) ? "ok 6\n" : "not ok 6\n";
+$a = pop(@ary);
+print defined($a) ? "not ok 7\n" : "ok 7\n";
+
+@ary = ("1arg");
+$a = shift(@ary);
+print defined($a) ? "ok 8\n" : "not ok 8\n";
+$a = shift(@ary);
+print defined($a) ? "not ok 9\n" : "ok 9\n";
+
+$ary{'foo'} = 'hi';
+print defined($ary{'foo'}) ? "ok 10\n" : "not ok 10\n";
+print defined($ary{'bar'}) ? "not ok 11\n" : "ok 11\n";
+undef $ary{'foo'};
+print defined($ary{'foo'}) ? "not ok 12\n" : "ok 12\n";
+
+print defined(@ary) ? "ok 13\n" : "not ok 13\n";
+print defined(%ary) ? "ok 14\n" : "not ok 14\n";
+undef @ary;
+print defined(@ary) ? "not ok 15\n" : "ok 15\n";
+undef %ary;
+print defined(%ary) ? "not ok 16\n" : "ok 16\n";
+@ary = (1);
+print defined @ary ? "ok 17\n" : "not ok 17\n";
+%ary = (1,1);
+print defined %ary ? "ok 18\n" : "not ok 18\n";
+
+sub foo { print "ok 19\n"; }
+
+&foo || print "not ok 19\n";
+
+print defined &foo ? "ok 20\n" : "not ok 20\n";
+undef &foo;
+print defined(&foo) ? "not ok 21\n" : "ok 21\n";
--- /dev/null
+#!./perl
+
+# $Header: unshift.t,v 4.0 91/03/20 01:55:21 lwall Locked $
+
+print "1..2\n";
+
+@a = (1,2,3);
+$cnt1 = unshift(a,0);
+
+if (join(' ',@a) eq '0 1 2 3') {print "ok 1\n";} else {print "not ok 1\n";}
+$cnt2 = unshift(a,3,2,1);
+if (join(' ',@a) eq '3 2 1 0 1 2 3') {print "ok 2\n";} else {print "not ok 2\n";}
+
+
--- /dev/null
+#!./perl
+
+# $Header: vec.t,v 4.0 91/03/20 01:55:28 lwall Locked $
+
+print "1..13\n";
+
+print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n";
+print length($foo) == 0 ? "ok 2\n" : "not ok 2\n";
+vec($foo,0,1) = 1;
+print length($foo) == 1 ? "ok 3\n" : "not ok 3\n";
+print ord($foo) == 1 ? "ok 4\n" : "not ok 4\n";
+print vec($foo,0,1) == 1 ? "ok 5\n" : "not ok 5\n";
+
+print vec($foo,20,1) == 0 ? "ok 6\n" : "not ok 6\n";
+vec($foo,20,1) = 1;
+print vec($foo,20,1) == 1 ? "ok 7\n" : "not ok 7\n";
+print length($foo) == 3 ? "ok 8\n" : "not ok 8\n";
+print vec($foo,1,8) == 0 ? "ok 9\n" : "not ok 9\n";
+vec($foo,1,8) = 0xf1;
+print vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n";
+print ((ord(substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n");
+print vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n";
+print vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n";
+
--- /dev/null
+#!./perl
+
+# $Header: write.t,v 4.0 91/03/20 01:55:34 lwall Locked $
+
+print "1..3\n";
+
+format OUT =
+the quick brown @<<
+$fox
+jumped
+@*
+$multiline
+^<<<<<<<<<
+$foo
+^<<<<<<<<<
+$foo
+^<<<<<<...
+$foo
+now @<<the@>>>> for all@|||||men to come @<<<<
+'i' . 's', "time\n", $good, 'to'
+.
+
+open(OUT, '>Op.write.tmp') || die "Can't create Op.write.tmp";
+
+$fox = 'foxiness';
+$good = 'good';
+$multiline = "forescore\nand\nseven years\n";
+$foo = 'when in the course of human events it becomes necessary';
+write(OUT);
+close OUT;
+
+$right =
+"the quick brown fox
+jumped
+forescore
+and
+seven years
+when in
+the course
+of huma...
+now is the time for all good men to come to\n";
+
+if (`cat Op.write.tmp` eq $right)
+ { print "ok 1\n"; unlink 'Op.write.tmp'; }
+else
+ { print "not ok 1\n"; }
+
+format OUT2 =
+the quick brown @<<
+$fox
+jumped
+@*
+$multiline
+^<<<<<<<<< ~~
+$foo
+now @<<the@>>>> for all@|||||men to come @<<<<
+'i' . 's', "time\n", $good, 'to'
+.
+
+open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp";
+
+$fox = 'foxiness';
+$good = 'good';
+$multiline = "forescore\nand\nseven years\n";
+$foo = 'when in the course of human events it becomes necessary';
+write(OUT2);
+close OUT2;
+
+$right =
+"the quick brown fox
+jumped
+forescore
+and
+seven years
+when in
+the course
+of human
+events it
+becomes
+necessary
+now is the time for all good men to come to\n";
+
+if (`cat Op.write.tmp` eq $right)
+ { print "ok 2\n"; unlink 'Op.write.tmp'; }
+else
+ { print "not ok 2\n"; }
+
+eval <<'EOFORMAT';
+format OUT2 =
+the brown quick @<<
+$fox
+jumped
+@*
+$multiline
+^<<<<<<<<< ~~
+$foo
+now @<<the@>>>> for all@|||||men to come @<<<<
+'i' . 's', "time\n", $good, 'to'
+.
+EOFORMAT
+
+open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp";
+
+$fox = 'foxiness';
+$good = 'good';
+$multiline = "forescore\nand\nseven years\n";
+$foo = 'when in the course of human events it becomes necessary';
+write(OUT2);
+close OUT2;
+
+$right =
+"the brown quick fox
+jumped
+forescore
+and
+seven years
+when in
+the course
+of human
+events it
+becomes
+necessary
+now is the time for all good men to come to\n";
+
+if (`cat Op.write.tmp` eq $right)
+ { print "ok 3\n"; unlink 'Op.write.tmp'; }
+else
+ { print "not ok 3\n"; }
+
--- /dev/null
+/* $RCSfile: toke.c,v $$Revision: 4.0.1.5 $$Date: 91/11/11 16:45:51 $
+ *
+ * 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: toke.c,v $
+ * 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.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "perly.h"
+
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+#ifdef f_next
+#undef f_next
+#endif
+
+/* which backslash sequences to keep in m// or s// */
+
+static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}";
+
+char *reparse; /* if non-null, scanident found ${foo[$bar]} */
+
+void checkcomma();
+
+#ifdef CLINE
+#undef CLINE
+#endif
+#define CLINE (cmdline = (curcmd->c_line < cmdline ? curcmd->c_line : cmdline))
+
+#define META(c) ((c) | 128)
+
+#define RETURN(retval) return (bufptr = s,(int)retval)
+#define OPERATOR(retval) return (expectterm = TRUE,bufptr = s,(int)retval)
+#define TERM(retval) return (CLINE, expectterm = FALSE,bufptr = s,(int)retval)
+#define LOOPX(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)LOOPEX)
+#define FTST(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)FILETEST)
+#define FUN0(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC0)
+#define FUN1(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC1)
+#define FUN2(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2)
+#define FUN2x(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2x)
+#define FUN3(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC3)
+#define FUN4(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC4)
+#define FUN5(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC5)
+#define FL(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST)
+#define FL2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST2)
+#define HFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)HSHFUN)
+#define HFUN3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)HSHFUN3)
+#define LFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LVALFUN)
+#define AOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)ADDOP)
+#define MOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)MULOP)
+#define EOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)EQOP)
+#define ROP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)RELOP)
+#define FOP(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP)
+#define FOP2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP2)
+#define FOP3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP3)
+#define FOP4(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP4)
+#define FOP22(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP22)
+#define FOP25(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP25)
+
+/* This bit of chicanery makes a unary function followed by
+ * a parenthesis into a function with one argument, highest precedence.
+ */
+#define UNI(f) return(yylval.ival = f,expectterm = TRUE,bufptr = s, \
+ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
+
+/* This does similarly for list operators, merely by pretending that the
+ * paren came before the listop rather than after.
+ */
+#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \
+ (*s = (char) META('('), bufptr = oldbufptr, '(') : \
+ (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
+/* grandfather return to old style */
+#define OLDLOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP)
+
+char *
+skipspace(s)
+register char *s;
+{
+ while (s < bufend && isSPACE(*s))
+ s++;
+ return s;
+}
+
+#ifdef CRIPPLED_CC
+
+#undef UNI
+#undef LOP
+#define UNI(f) return uni(f,s)
+#define LOP(f) return lop(f,s)
+
+int
+uni(f,s)
+int f;
+char *s;
+{
+ yylval.ival = f;
+ expectterm = TRUE;
+ bufptr = s;
+ if (*s == '(')
+ return FUNC1;
+ s = skipspace(s);
+ if (*s == '(')
+ return FUNC1;
+ else
+ return UNIOP;
+}
+
+int
+lop(f,s)
+int f;
+char *s;
+{
+ CLINE;
+ if (*s != '(')
+ s = skipspace(s);
+ if (*s == '(') {
+ *s = META('(');
+ bufptr = oldbufptr;
+ return '(';
+ }
+ else {
+ yylval.ival=f;
+ expectterm = TRUE;
+ bufptr = s;
+ return LISTOP;
+ }
+}
+
+#endif /* CRIPPLED_CC */
+
+yylex()
+{
+ register char *s = bufptr;
+ register char *d;
+ register int tmp;
+ static bool in_format = FALSE;
+ static bool firstline = TRUE;
+ extern int yychar; /* last token */
+
+ oldoldbufptr = oldbufptr;
+ oldbufptr = s;
+
+ retry:
+#ifdef YYDEBUG
+ if (debug & 1)
+ if (index(s,'\n'))
+ fprintf(stderr,"Tokener at %s",s);
+ else
+ fprintf(stderr,"Tokener at %s\n",s);
+#endif
+#ifdef BADSWITCH
+ if (*s & 128) {
+ if ((*s & 127) == '(') {
+ *s++ = '(';
+ oldbufptr = s;
+ }
+ else
+ warn("Unrecognized character \\%03o ignored", *s++ & 255);
+ goto retry;
+ }
+#endif
+ switch (*s) {
+ default:
+ if ((*s & 127) == '(') {
+ *s++ = '(';
+ oldbufptr = s;
+ }
+ else
+ warn("Unrecognized character \\%03o ignored", *s++ & 255);
+ goto retry;
+ case 4:
+ case 26:
+ goto fake_eof; /* emulate EOF on ^D or ^Z */
+ case 0:
+ if (!rsfp)
+ RETURN(0);
+ if (s++ < bufend)
+ goto retry; /* ignore stray nulls */
+ if (firstline) {
+ firstline = FALSE;
+ if (minus_n || minus_p || perldb) {
+ str_set(linestr,"");
+ if (perldb) {
+ char *getenv();
+ char *pdb = getenv("PERLDB");
+
+ str_cat(linestr, pdb ? pdb : "require 'perldb.pl'");
+ str_cat(linestr, ";");
+ }
+ if (minus_n || minus_p) {
+ str_cat(linestr,"line: while (<>) {");
+ if (minus_l)
+ str_cat(linestr,"chop;");
+ if (minus_a)
+ str_cat(linestr,"@F=split(' ');");
+ }
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ goto retry;
+ }
+ }
+ if (in_format) {
+ bufptr = bufend;
+ yylval.formval = load_format();
+ in_format = FALSE;
+ oldoldbufptr = oldbufptr = s = str_get(linestr) + 1;
+ bufend = linestr->str_ptr + linestr->str_cur;
+ OPERATOR(FORMLIST);
+ }
+ curcmd->c_line++;
+#ifdef CRYPTSCRIPT
+ cryptswitch();
+#endif /* CRYPTSCRIPT */
+ do {
+ if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
+ fake_eof:
+ if (rsfp) {
+ if (preprocess)
+ (void)mypclose(rsfp);
+ else if ((FILE*)rsfp == stdin)
+ clearerr(stdin);
+ else
+ (void)fclose(rsfp);
+ rsfp = Nullfp;
+ }
+ if (minus_n || minus_p) {
+ str_set(linestr,minus_p ? ";}continue{print" : "");
+ str_cat(linestr,";}");
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ minus_n = minus_p = 0;
+ goto retry;
+ }
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
+ str_set(linestr,"");
+ RETURN(';'); /* not infinite loop because rsfp is NULL now */
+ }
+ if (doextract && *linestr->str_ptr == '#')
+ doextract = FALSE;
+ } while (doextract);
+ oldoldbufptr = oldbufptr = bufptr = s;
+ if (perldb) {
+ STR *str = Str_new(85,0);
+
+ str_sset(str,linestr);
+ astore(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str);
+ }
+#ifdef DEBUG
+ if (firstline) {
+ char *showinput();
+ s = showinput();
+ }
+#endif
+ bufend = linestr->str_ptr + linestr->str_cur;
+ if (curcmd->c_line == 1) {
+ if (*s == '#' && s[1] == '!') {
+ if (!in_eval && !instr(s,"perl") && instr(origargv[0],"perl")) {
+ char **newargv;
+ char *cmd;
+
+ s += 2;
+ if (*s == ' ')
+ s++;
+ cmd = s;
+ while (s < bufend && !isSPACE(*s))
+ s++;
+ *s++ = '\0';
+ while (s < bufend && isSPACE(*s))
+ s++;
+ if (s < bufend) {
+ Newz(899,newargv,origargc+3,char*);
+ newargv[1] = s;
+ while (s < bufend && !isSPACE(*s))
+ s++;
+ *s = '\0';
+ Copy(origargv+1, newargv+2, origargc+1, char*);
+ }
+ else
+ newargv = origargv;
+ newargv[0] = cmd;
+ execv(cmd,newargv);
+ fatal("Can't exec %s", cmd);
+ }
+ }
+ else {
+ while (s < bufend && isSPACE(*s))
+ s++;
+ if (*s == ':') /* for csh's that have to exec sh scripts */
+ s++;
+ }
+ }
+ goto retry;
+ case ' ': case '\t': case '\f': case '\r': case 013:
+ s++;
+ goto retry;
+ case '#':
+ if (preprocess && s == str_get(linestr) &&
+ s[1] == ' ' && (isDIGIT(s[2]) || strnEQ(s+2,"line ",5)) ) {
+ while (*s && !isDIGIT(*s))
+ s++;
+ curcmd->c_line = atoi(s)-1;
+ while (isDIGIT(*s))
+ s++;
+ d = bufend;
+ while (s < d && isSPACE(*s)) s++;
+ s[strlen(s)-1] = '\0'; /* wipe out newline */
+ if (*s == '"') {
+ s++;
+ s[strlen(s)-1] = '\0'; /* wipe out trailing quote */
+ }
+ if (*s)
+ curcmd->c_filestab = fstab(s);
+ else
+ curcmd->c_filestab = fstab(origfilename);
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
+ }
+ /* FALL THROUGH */
+ case '\n':
+ if (in_eval && !rsfp) {
+ d = bufend;
+ while (s < d && *s != '\n')
+ s++;
+ if (s < d)
+ s++;
+ if (in_format) {
+ bufptr = s;
+ yylval.formval = load_format();
+ in_format = FALSE;
+ oldoldbufptr = oldbufptr = s = bufptr + 1;
+ TERM(FORMLIST);
+ }
+ curcmd->c_line++;
+ }
+ else {
+ *s = '\0';
+ bufend = s;
+ }
+ goto retry;
+ case '-':
+ if (s[1] && isALPHA(s[1]) && !isALPHA(s[2])) {
+ s++;
+ switch (*s++) {
+ case 'r': FTST(O_FTEREAD);
+ case 'w': FTST(O_FTEWRITE);
+ case 'x': FTST(O_FTEEXEC);
+ case 'o': FTST(O_FTEOWNED);
+ case 'R': FTST(O_FTRREAD);
+ case 'W': FTST(O_FTRWRITE);
+ case 'X': FTST(O_FTREXEC);
+ case 'O': FTST(O_FTROWNED);
+ case 'e': FTST(O_FTIS);
+ case 'z': FTST(O_FTZERO);
+ case 's': FTST(O_FTSIZE);
+ case 'f': FTST(O_FTFILE);
+ case 'd': FTST(O_FTDIR);
+ case 'l': FTST(O_FTLINK);
+ case 'p': FTST(O_FTPIPE);
+ case 'S': FTST(O_FTSOCK);
+ case 'u': FTST(O_FTSUID);
+ case 'g': FTST(O_FTSGID);
+ case 'k': FTST(O_FTSVTX);
+ case 'b': FTST(O_FTBLK);
+ case 'c': FTST(O_FTCHR);
+ case 't': FTST(O_FTTTY);
+ case 'T': FTST(O_FTTEXT);
+ case 'B': FTST(O_FTBINARY);
+ case 'M': stabent("\024",TRUE); FTST(O_FTMTIME);
+ case 'A': stabent("\024",TRUE); FTST(O_FTATIME);
+ case 'C': stabent("\024",TRUE); FTST(O_FTCTIME);
+ default:
+ s -= 2;
+ break;
+ }
+ }
+ tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ RETURN(DEC);
+ }
+ if (expectterm)
+ OPERATOR('-');
+ else
+ AOP(O_SUBTRACT);
+ case '+':
+ tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ RETURN(INC);
+ }
+ if (expectterm)
+ OPERATOR('+');
+ else
+ AOP(O_ADD);
+
+ case '*':
+ if (expectterm) {
+ s = scanident(s,bufend,tokenbuf);
+ yylval.stabval = stabent(tokenbuf,TRUE);
+ TERM(STAR);
+ }
+ tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ OPERATOR(POW);
+ }
+ MOP(O_MULTIPLY);
+ case '%':
+ if (expectterm) {
+ s = scanident(s,bufend,tokenbuf);
+ yylval.stabval = hadd(stabent(tokenbuf,TRUE));
+ TERM(HSH);
+ }
+ s++;
+ MOP(O_MODULO);
+
+ case '^':
+ case '~':
+ case '(':
+ case ',':
+ case ':':
+ case '[':
+ tmp = *s++;
+ OPERATOR(tmp);
+ case '{':
+ tmp = *s++;
+ yylval.ival = curcmd->c_line;
+ if (isSPACE(*s) || *s == '#')
+ cmdline = NOLINE; /* invalidate current command line number */
+ OPERATOR(tmp);
+ case ';':
+ if (curcmd->c_line < cmdline)
+ cmdline = curcmd->c_line;
+ tmp = *s++;
+ OPERATOR(tmp);
+ case ')':
+ case ']':
+ tmp = *s++;
+ TERM(tmp);
+ case '}':
+ tmp = *s++;
+ RETURN(tmp);
+ case '&':
+ s++;
+ tmp = *s++;
+ if (tmp == '&')
+ OPERATOR(ANDAND);
+ s--;
+ if (expectterm) {
+ d = bufend;
+ while (s < d && isSPACE(*s))
+ s++;
+ if (isALPHA(*s) || *s == '_' || *s == '\'')
+ *(--s) = '\\'; /* force next ident to WORD */
+ OPERATOR(AMPER);
+ }
+ OPERATOR('&');
+ case '|':
+ s++;
+ tmp = *s++;
+ if (tmp == '|')
+ OPERATOR(OROR);
+ s--;
+ OPERATOR('|');
+ case '=':
+ s++;
+ tmp = *s++;
+ if (tmp == '=')
+ EOP(O_EQ);
+ if (tmp == '~')
+ OPERATOR(MATCH);
+ s--;
+ OPERATOR('=');
+ case '!':
+ s++;
+ tmp = *s++;
+ if (tmp == '=')
+ EOP(O_NE);
+ if (tmp == '~')
+ OPERATOR(NMATCH);
+ s--;
+ OPERATOR('!');
+ case '<':
+ if (expectterm) {
+ s = scanstr(s);
+ TERM(RSTRING);
+ }
+ s++;
+ tmp = *s++;
+ if (tmp == '<')
+ OPERATOR(LS);
+ if (tmp == '=') {
+ tmp = *s++;
+ if (tmp == '>')
+ EOP(O_NCMP);
+ s--;
+ ROP(O_LE);
+ }
+ s--;
+ ROP(O_LT);
+ case '>':
+ s++;
+ tmp = *s++;
+ if (tmp == '>')
+ OPERATOR(RS);
+ if (tmp == '=')
+ ROP(O_GE);
+ s--;
+ ROP(O_GT);
+
+#define SNARFWORD \
+ d = tokenbuf; \
+ while (isALNUM(*s) || *s == '\'') \
+ *d++ = *s++; \
+ while (d[-1] == '\'') \
+ d--,s--; \
+ *d = '\0'; \
+ d = tokenbuf;
+
+ case '$':
+ if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_')) {
+ s++;
+ s = scanident(s,bufend,tokenbuf);
+ yylval.stabval = aadd(stabent(tokenbuf,TRUE));
+ TERM(ARYLEN);
+ }
+ d = s;
+ s = scanident(s,bufend,tokenbuf);
+ if (reparse) { /* turn ${foo[bar]} into ($foo[bar]) */
+ do_reparse:
+ s[-1] = ')';
+ s = d;
+ s[1] = s[0];
+ s[0] = '(';
+ goto retry;
+ }
+ yylval.stabval = stabent(tokenbuf,TRUE);
+ TERM(REG);
+
+ case '@':
+ d = s;
+ s = scanident(s,bufend,tokenbuf);
+ if (reparse)
+ goto do_reparse;
+ yylval.stabval = aadd(stabent(tokenbuf,TRUE));
+ TERM(ARY);
+
+ case '/': /* may either be division or pattern */
+ case '?': /* may either be conditional or pattern */
+ if (expectterm) {
+ s = scanpat(s);
+ TERM(PATTERN);
+ }
+ tmp = *s++;
+ if (tmp == '/')
+ MOP(O_DIVIDE);
+ OPERATOR(tmp);
+
+ case '.':
+ if (!expectterm || !isDIGIT(s[1])) {
+ tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ OPERATOR(DOTDOT);
+ }
+ AOP(O_CONCAT);
+ }
+ /* FALL THROUGH */
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ case '\'': case '"': case '`':
+ s = scanstr(s);
+ TERM(RSTRING);
+
+ case '\\': /* some magic to force next word to be a WORD */
+ s++; /* used by do and sub to force a separate namespace */
+ /* FALL THROUGH */
+ case '_':
+ SNARFWORD;
+ if (d[1] == '_') {
+ if (strEQ(d,"__LINE__") || strEQ(d,"__FILE__")) {
+ ARG *arg = op_new(1);
+
+ yylval.arg = arg;
+ arg->arg_type = O_ITEM;
+ if (d[2] == 'L')
+ (void)sprintf(tokenbuf,"%ld",(long)curcmd->c_line);
+ else
+ strcpy(tokenbuf, stab_val(curcmd->c_filestab)->str_ptr);
+ arg[1].arg_type = A_SINGLE;
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
+ TERM(RSTRING);
+ }
+ else if (strEQ(d,"__END__")) {
+#ifndef TAINT
+ STAB *stab;
+ int fd;
+
+ /*SUPPRESS 560*/
+ if (stab = stabent("DATA",FALSE)) {
+ stab->str_pok |= SP_MULTI;
+ stab_io(stab) = stio_new();
+ stab_io(stab)->ifp = rsfp;
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fd = fileno(rsfp);
+ fcntl(fd,F_SETFD,fd >= 3);
+#endif
+ if (preprocess)
+ stab_io(stab)->type = '|';
+ else if ((FILE*)rsfp == stdin)
+ stab_io(stab)->type = '-';
+ else
+ stab_io(stab)->type = '<';
+ rsfp = Nullfp;
+ }
+#endif
+ goto fake_eof;
+ }
+ }
+ break;
+ case 'a': case 'A':
+ SNARFWORD;
+ if (strEQ(d,"alarm"))
+ UNI(O_ALARM);
+ if (strEQ(d,"accept"))
+ FOP22(O_ACCEPT);
+ if (strEQ(d,"atan2"))
+ FUN2(O_ATAN2);
+ break;
+ case 'b': case 'B':
+ SNARFWORD;
+ if (strEQ(d,"bind"))
+ FOP2(O_BIND);
+ if (strEQ(d,"binmode"))
+ FOP(O_BINMODE);
+ break;
+ case 'c': case 'C':
+ SNARFWORD;
+ if (strEQ(d,"chop"))
+ LFUN(O_CHOP);
+ if (strEQ(d,"continue"))
+ OPERATOR(CONTINUE);
+ if (strEQ(d,"chdir")) {
+ (void)stabent("ENV",TRUE); /* may use HOME */
+ UNI(O_CHDIR);
+ }
+ if (strEQ(d,"close"))
+ FOP(O_CLOSE);
+ if (strEQ(d,"closedir"))
+ FOP(O_CLOSEDIR);
+ if (strEQ(d,"cmp"))
+ EOP(O_SCMP);
+ if (strEQ(d,"caller"))
+ UNI(O_CALLER);
+ if (strEQ(d,"crypt")) {
+#ifdef FCRYPT
+ static int cryptseen = 0;
+
+ if (!cryptseen++)
+ init_des();
+#endif
+ FUN2(O_CRYPT);
+ }
+ if (strEQ(d,"chmod"))
+ LOP(O_CHMOD);
+ if (strEQ(d,"chown"))
+ LOP(O_CHOWN);
+ if (strEQ(d,"connect"))
+ FOP2(O_CONNECT);
+ if (strEQ(d,"cos"))
+ UNI(O_COS);
+ if (strEQ(d,"chroot"))
+ UNI(O_CHROOT);
+ break;
+ case 'd': case 'D':
+ SNARFWORD;
+ if (strEQ(d,"do")) {
+ d = bufend;
+ while (s < d && isSPACE(*s))
+ s++;
+ if (isALPHA(*s) || *s == '_')
+ *(--s) = '\\'; /* force next ident to WORD */
+ OPERATOR(DO);
+ }
+ if (strEQ(d,"die"))
+ LOP(O_DIE);
+ if (strEQ(d,"defined"))
+ LFUN(O_DEFINED);
+ if (strEQ(d,"delete"))
+ OPERATOR(DELETE);
+ if (strEQ(d,"dbmopen"))
+ HFUN3(O_DBMOPEN);
+ if (strEQ(d,"dbmclose"))
+ HFUN(O_DBMCLOSE);
+ if (strEQ(d,"dump"))
+ LOOPX(O_DUMP);
+ break;
+ case 'e': case 'E':
+ SNARFWORD;
+ if (strEQ(d,"else"))
+ OPERATOR(ELSE);
+ if (strEQ(d,"elsif")) {
+ yylval.ival = curcmd->c_line;
+ OPERATOR(ELSIF);
+ }
+ if (strEQ(d,"eq") || strEQ(d,"EQ"))
+ EOP(O_SEQ);
+ if (strEQ(d,"exit"))
+ UNI(O_EXIT);
+ if (strEQ(d,"eval")) {
+ allstabs = TRUE; /* must initialize everything since */
+ UNI(O_EVAL); /* we don't know what will be used */
+ }
+ if (strEQ(d,"eof"))
+ FOP(O_EOF);
+ if (strEQ(d,"exp"))
+ UNI(O_EXP);
+ if (strEQ(d,"each"))
+ HFUN(O_EACH);
+ if (strEQ(d,"exec")) {
+ set_csh();
+ LOP(O_EXEC_OP);
+ }
+ if (strEQ(d,"endhostent"))
+ FUN0(O_EHOSTENT);
+ if (strEQ(d,"endnetent"))
+ FUN0(O_ENETENT);
+ if (strEQ(d,"endservent"))
+ FUN0(O_ESERVENT);
+ if (strEQ(d,"endprotoent"))
+ FUN0(O_EPROTOENT);
+ if (strEQ(d,"endpwent"))
+ FUN0(O_EPWENT);
+ if (strEQ(d,"endgrent"))
+ FUN0(O_EGRENT);
+ break;
+ case 'f': case 'F':
+ SNARFWORD;
+ if (strEQ(d,"for") || strEQ(d,"foreach")) {
+ yylval.ival = curcmd->c_line;
+ OPERATOR(FOR);
+ }
+ if (strEQ(d,"format")) {
+ d = bufend;
+ while (s < d && isSPACE(*s))
+ s++;
+ if (isALPHA(*s) || *s == '_')
+ *(--s) = '\\'; /* force next ident to WORD */
+ in_format = TRUE;
+ allstabs = TRUE; /* must initialize everything since */
+ OPERATOR(FORMAT); /* we don't know what will be used */
+ }
+ if (strEQ(d,"fork"))
+ FUN0(O_FORK);
+ if (strEQ(d,"fcntl"))
+ FOP3(O_FCNTL);
+ if (strEQ(d,"fileno"))
+ FOP(O_FILENO);
+ if (strEQ(d,"flock"))
+ FOP2(O_FLOCK);
+ break;
+ case 'g': case 'G':
+ SNARFWORD;
+ if (strEQ(d,"gt") || strEQ(d,"GT"))
+ ROP(O_SGT);
+ if (strEQ(d,"ge") || strEQ(d,"GE"))
+ ROP(O_SGE);
+ if (strEQ(d,"grep"))
+ FL2(O_GREP);
+ if (strEQ(d,"goto"))
+ LOOPX(O_GOTO);
+ if (strEQ(d,"gmtime"))
+ UNI(O_GMTIME);
+ if (strEQ(d,"getc"))
+ FOP(O_GETC);
+ if (strnEQ(d,"get",3)) {
+ d += 3;
+ if (*d == 'p') {
+ if (strEQ(d,"ppid"))
+ FUN0(O_GETPPID);
+ if (strEQ(d,"pgrp"))
+ UNI(O_GETPGRP);
+ if (strEQ(d,"priority"))
+ FUN2(O_GETPRIORITY);
+ if (strEQ(d,"protobyname"))
+ UNI(O_GPBYNAME);
+ if (strEQ(d,"protobynumber"))
+ FUN1(O_GPBYNUMBER);
+ if (strEQ(d,"protoent"))
+ FUN0(O_GPROTOENT);
+ if (strEQ(d,"pwent"))
+ FUN0(O_GPWENT);
+ if (strEQ(d,"pwnam"))
+ FUN1(O_GPWNAM);
+ if (strEQ(d,"pwuid"))
+ FUN1(O_GPWUID);
+ if (strEQ(d,"peername"))
+ FOP(O_GETPEERNAME);
+ }
+ else if (*d == 'h') {
+ if (strEQ(d,"hostbyname"))
+ UNI(O_GHBYNAME);
+ if (strEQ(d,"hostbyaddr"))
+ FUN2(O_GHBYADDR);
+ if (strEQ(d,"hostent"))
+ FUN0(O_GHOSTENT);
+ }
+ else if (*d == 'n') {
+ if (strEQ(d,"netbyname"))
+ UNI(O_GNBYNAME);
+ if (strEQ(d,"netbyaddr"))
+ FUN2(O_GNBYADDR);
+ if (strEQ(d,"netent"))
+ FUN0(O_GNETENT);
+ }
+ else if (*d == 's') {
+ if (strEQ(d,"servbyname"))
+ FUN2(O_GSBYNAME);
+ if (strEQ(d,"servbyport"))
+ FUN2(O_GSBYPORT);
+ if (strEQ(d,"servent"))
+ FUN0(O_GSERVENT);
+ if (strEQ(d,"sockname"))
+ FOP(O_GETSOCKNAME);
+ if (strEQ(d,"sockopt"))
+ FOP3(O_GSOCKOPT);
+ }
+ else if (*d == 'g') {
+ if (strEQ(d,"grent"))
+ FUN0(O_GGRENT);
+ if (strEQ(d,"grnam"))
+ FUN1(O_GGRNAM);
+ if (strEQ(d,"grgid"))
+ FUN1(O_GGRGID);
+ }
+ else if (*d == 'l') {
+ if (strEQ(d,"login"))
+ FUN0(O_GETLOGIN);
+ }
+ d -= 3;
+ }
+ break;
+ case 'h': case 'H':
+ SNARFWORD;
+ if (strEQ(d,"hex"))
+ UNI(O_HEX);
+ break;
+ case 'i': case 'I':
+ SNARFWORD;
+ if (strEQ(d,"if")) {
+ yylval.ival = curcmd->c_line;
+ OPERATOR(IF);
+ }
+ if (strEQ(d,"index"))
+ FUN2x(O_INDEX);
+ if (strEQ(d,"int"))
+ UNI(O_INT);
+ if (strEQ(d,"ioctl"))
+ FOP3(O_IOCTL);
+ break;
+ case 'j': case 'J':
+ SNARFWORD;
+ if (strEQ(d,"join"))
+ FL2(O_JOIN);
+ break;
+ case 'k': case 'K':
+ SNARFWORD;
+ if (strEQ(d,"keys"))
+ HFUN(O_KEYS);
+ if (strEQ(d,"kill"))
+ LOP(O_KILL);
+ break;
+ case 'l': case 'L':
+ SNARFWORD;
+ if (strEQ(d,"last"))
+ LOOPX(O_LAST);
+ if (strEQ(d,"local"))
+ OPERATOR(LOCAL);
+ if (strEQ(d,"length"))
+ UNI(O_LENGTH);
+ if (strEQ(d,"lt") || strEQ(d,"LT"))
+ ROP(O_SLT);
+ if (strEQ(d,"le") || strEQ(d,"LE"))
+ ROP(O_SLE);
+ if (strEQ(d,"localtime"))
+ UNI(O_LOCALTIME);
+ if (strEQ(d,"log"))
+ UNI(O_LOG);
+ if (strEQ(d,"link"))
+ FUN2(O_LINK);
+ if (strEQ(d,"listen"))
+ FOP2(O_LISTEN);
+ if (strEQ(d,"lstat"))
+ FOP(O_LSTAT);
+ break;
+ case 'm': case 'M':
+ if (s[1] == '\'') {
+ d = "m";
+ s++;
+ }
+ else {
+ SNARFWORD;
+ }
+ if (strEQ(d,"m")) {
+ s = scanpat(s-1);
+ if (yylval.arg)
+ TERM(PATTERN);
+ else
+ RETURN(1); /* force error */
+ }
+ switch (d[1]) {
+ case 'k':
+ if (strEQ(d,"mkdir"))
+ FUN2(O_MKDIR);
+ break;
+ case 's':
+ if (strEQ(d,"msgctl"))
+ FUN3(O_MSGCTL);
+ if (strEQ(d,"msgget"))
+ FUN2(O_MSGGET);
+ if (strEQ(d,"msgrcv"))
+ FUN5(O_MSGRCV);
+ if (strEQ(d,"msgsnd"))
+ FUN3(O_MSGSND);
+ break;
+ }
+ break;
+ case 'n': case 'N':
+ SNARFWORD;
+ if (strEQ(d,"next"))
+ LOOPX(O_NEXT);
+ if (strEQ(d,"ne") || strEQ(d,"NE"))
+ EOP(O_SNE);
+ break;
+ case 'o': case 'O':
+ SNARFWORD;
+ if (strEQ(d,"open"))
+ OPERATOR(OPEN);
+ if (strEQ(d,"ord"))
+ UNI(O_ORD);
+ if (strEQ(d,"oct"))
+ UNI(O_OCT);
+ if (strEQ(d,"opendir"))
+ FOP2(O_OPEN_DIR);
+ break;
+ case 'p': case 'P':
+ SNARFWORD;
+ if (strEQ(d,"print")) {
+ checkcomma(s,"filehandle");
+ LOP(O_PRINT);
+ }
+ if (strEQ(d,"printf")) {
+ checkcomma(s,"filehandle");
+ LOP(O_PRTF);
+ }
+ if (strEQ(d,"push")) {
+ yylval.ival = O_PUSH;
+ OPERATOR(PUSH);
+ }
+ if (strEQ(d,"pop"))
+ OPERATOR(POP);
+ if (strEQ(d,"pack"))
+ FL2(O_PACK);
+ if (strEQ(d,"package"))
+ OPERATOR(PACKAGE);
+ if (strEQ(d,"pipe"))
+ FOP22(O_PIPE);
+ break;
+ case 'q': case 'Q':
+ SNARFWORD;
+ if (strEQ(d,"q")) {
+ s = scanstr(s-1);
+ TERM(RSTRING);
+ }
+ if (strEQ(d,"qq")) {
+ s = scanstr(s-2);
+ TERM(RSTRING);
+ }
+ if (strEQ(d,"qx")) {
+ s = scanstr(s-2);
+ TERM(RSTRING);
+ }
+ break;
+ case 'r': case 'R':
+ SNARFWORD;
+ if (strEQ(d,"return"))
+ OLDLOP(O_RETURN);
+ if (strEQ(d,"require")) {
+ allstabs = TRUE; /* must initialize everything since */
+ UNI(O_REQUIRE); /* we don't know what will be used */
+ }
+ if (strEQ(d,"reset"))
+ UNI(O_RESET);
+ if (strEQ(d,"redo"))
+ LOOPX(O_REDO);
+ if (strEQ(d,"rename"))
+ FUN2(O_RENAME);
+ if (strEQ(d,"rand"))
+ UNI(O_RAND);
+ if (strEQ(d,"rmdir"))
+ UNI(O_RMDIR);
+ if (strEQ(d,"rindex"))
+ FUN2x(O_RINDEX);
+ if (strEQ(d,"read"))
+ FOP3(O_READ);
+ if (strEQ(d,"readdir"))
+ FOP(O_READDIR);
+ if (strEQ(d,"rewinddir"))
+ FOP(O_REWINDDIR);
+ if (strEQ(d,"recv"))
+ FOP4(O_RECV);
+ if (strEQ(d,"reverse"))
+ LOP(O_REVERSE);
+ if (strEQ(d,"readlink"))
+ UNI(O_READLINK);
+ break;
+ case 's': case 'S':
+ if (s[1] == '\'') {
+ d = "s";
+ s++;
+ }
+ else {
+ SNARFWORD;
+ }
+ if (strEQ(d,"s")) {
+ s = scansubst(s);
+ if (yylval.arg)
+ TERM(SUBST);
+ else
+ RETURN(1); /* force error */
+ }
+ switch (d[1]) {
+ case 'a':
+ case 'b':
+ break;
+ case 'c':
+ if (strEQ(d,"scalar"))
+ UNI(O_SCALAR);
+ break;
+ case 'd':
+ break;
+ case 'e':
+ if (strEQ(d,"select"))
+ OPERATOR(SSELECT);
+ if (strEQ(d,"seek"))
+ FOP3(O_SEEK);
+ if (strEQ(d,"semctl"))
+ FUN4(O_SEMCTL);
+ if (strEQ(d,"semget"))
+ FUN3(O_SEMGET);
+ if (strEQ(d,"semop"))
+ FUN2(O_SEMOP);
+ if (strEQ(d,"send"))
+ FOP3(O_SEND);
+ if (strEQ(d,"setpgrp"))
+ FUN2(O_SETPGRP);
+ if (strEQ(d,"setpriority"))
+ FUN3(O_SETPRIORITY);
+ if (strEQ(d,"sethostent"))
+ FUN1(O_SHOSTENT);
+ if (strEQ(d,"setnetent"))
+ FUN1(O_SNETENT);
+ if (strEQ(d,"setservent"))
+ FUN1(O_SSERVENT);
+ if (strEQ(d,"setprotoent"))
+ FUN1(O_SPROTOENT);
+ if (strEQ(d,"setpwent"))
+ FUN0(O_SPWENT);
+ if (strEQ(d,"setgrent"))
+ FUN0(O_SGRENT);
+ if (strEQ(d,"seekdir"))
+ FOP2(O_SEEKDIR);
+ if (strEQ(d,"setsockopt"))
+ FOP4(O_SSOCKOPT);
+ break;
+ case 'f':
+ case 'g':
+ break;
+ case 'h':
+ if (strEQ(d,"shift"))
+ TERM(SHIFT);
+ if (strEQ(d,"shmctl"))
+ FUN3(O_SHMCTL);
+ if (strEQ(d,"shmget"))
+ FUN3(O_SHMGET);
+ if (strEQ(d,"shmread"))
+ FUN4(O_SHMREAD);
+ if (strEQ(d,"shmwrite"))
+ FUN4(O_SHMWRITE);
+ if (strEQ(d,"shutdown"))
+ FOP2(O_SHUTDOWN);
+ break;
+ case 'i':
+ if (strEQ(d,"sin"))
+ UNI(O_SIN);
+ break;
+ case 'j':
+ case 'k':
+ break;
+ case 'l':
+ if (strEQ(d,"sleep"))
+ UNI(O_SLEEP);
+ break;
+ case 'm':
+ case 'n':
+ break;
+ case 'o':
+ if (strEQ(d,"socket"))
+ FOP4(O_SOCKET);
+ if (strEQ(d,"socketpair"))
+ FOP25(O_SOCKPAIR);
+ if (strEQ(d,"sort")) {
+ checkcomma(s,"subroutine name");
+ d = bufend;
+ while (s < d && isSPACE(*s)) s++;
+ if (*s == ';' || *s == ')') /* probably a close */
+ fatal("sort is now a reserved word");
+ if (isALPHA(*s) || *s == '_') {
+ /*SUPPRESS 530*/
+ for (d = s; isALNUM(*d); d++) ;
+ strncpy(tokenbuf,s,d-s);
+ if (strNE(tokenbuf,"keys") &&
+ strNE(tokenbuf,"values") &&
+ strNE(tokenbuf,"split") &&
+ strNE(tokenbuf,"grep") &&
+ strNE(tokenbuf,"readdir") &&
+ strNE(tokenbuf,"unpack") &&
+ strNE(tokenbuf,"do") &&
+ strNE(tokenbuf,"eval") &&
+ (d >= bufend || isSPACE(*d)) )
+ *(--s) = '\\'; /* force next ident to WORD */
+ }
+ LOP(O_SORT);
+ }
+ break;
+ case 'p':
+ if (strEQ(d,"split"))
+ TERM(SPLIT);
+ if (strEQ(d,"sprintf"))
+ FL(O_SPRINTF);
+ if (strEQ(d,"splice")) {
+ yylval.ival = O_SPLICE;
+ OPERATOR(PUSH);
+ }
+ break;
+ case 'q':
+ if (strEQ(d,"sqrt"))
+ UNI(O_SQRT);
+ break;
+ case 'r':
+ if (strEQ(d,"srand"))
+ UNI(O_SRAND);
+ break;
+ case 's':
+ break;
+ case 't':
+ if (strEQ(d,"stat"))
+ FOP(O_STAT);
+ if (strEQ(d,"study")) {
+ sawstudy++;
+ LFUN(O_STUDY);
+ }
+ break;
+ case 'u':
+ if (strEQ(d,"substr"))
+ FUN2x(O_SUBSTR);
+ if (strEQ(d,"sub")) {
+ yylval.ival = savestack->ary_fill; /* restore stuff on reduce */
+ savelong(&subline);
+ saveitem(subname);
+
+ subline = curcmd->c_line;
+ d = bufend;
+ while (s < d && isSPACE(*s))
+ s++;
+ if (isALPHA(*s) || *s == '_' || *s == '\'') {
+ str_sset(subname,curstname);
+ str_ncat(subname,"'",1);
+ for (d = s+1; isALNUM(*d) || *d == '\''; d++)
+ /*SUPPRESS 530*/
+ ;
+ if (d[-1] == '\'')
+ d--;
+ str_ncat(subname,s,d-s);
+ *(--s) = '\\'; /* force next ident to WORD */
+ }
+ else
+ str_set(subname,"?");
+ OPERATOR(SUB);
+ }
+ break;
+ case 'v':
+ case 'w':
+ case 'x':
+ break;
+ case 'y':
+ if (strEQ(d,"system")) {
+ set_csh();
+ LOP(O_SYSTEM);
+ }
+ if (strEQ(d,"symlink"))
+ FUN2(O_SYMLINK);
+ if (strEQ(d,"syscall"))
+ LOP(O_SYSCALL);
+ if (strEQ(d,"sysread"))
+ FOP3(O_SYSREAD);
+ if (strEQ(d,"syswrite"))
+ FOP3(O_SYSWRITE);
+ break;
+ case 'z':
+ break;
+ }
+ break;
+ case 't': case 'T':
+ SNARFWORD;
+ if (strEQ(d,"tr")) {
+ s = scantrans(s);
+ if (yylval.arg)
+ TERM(TRANS);
+ else
+ RETURN(1); /* force error */
+ }
+ if (strEQ(d,"tell"))
+ FOP(O_TELL);
+ if (strEQ(d,"telldir"))
+ FOP(O_TELLDIR);
+ if (strEQ(d,"time"))
+ FUN0(O_TIME);
+ if (strEQ(d,"times"))
+ FUN0(O_TMS);
+ if (strEQ(d,"truncate"))
+ FOP2(O_TRUNCATE);
+ break;
+ case 'u': case 'U':
+ SNARFWORD;
+ if (strEQ(d,"using"))
+ OPERATOR(USING);
+ if (strEQ(d,"until")) {
+ yylval.ival = curcmd->c_line;
+ OPERATOR(UNTIL);
+ }
+ if (strEQ(d,"unless")) {
+ yylval.ival = curcmd->c_line;
+ OPERATOR(UNLESS);
+ }
+ if (strEQ(d,"unlink"))
+ LOP(O_UNLINK);
+ if (strEQ(d,"undef"))
+ LFUN(O_UNDEF);
+ if (strEQ(d,"unpack"))
+ FUN2(O_UNPACK);
+ if (strEQ(d,"utime"))
+ LOP(O_UTIME);
+ if (strEQ(d,"umask"))
+ UNI(O_UMASK);
+ if (strEQ(d,"unshift")) {
+ yylval.ival = O_UNSHIFT;
+ OPERATOR(PUSH);
+ }
+ break;
+ case 'v': case 'V':
+ SNARFWORD;
+ if (strEQ(d,"values"))
+ HFUN(O_VALUES);
+ if (strEQ(d,"vec")) {
+ sawvec = TRUE;
+ FUN3(O_VEC);
+ }
+ break;
+ case 'w': case 'W':
+ SNARFWORD;
+ if (strEQ(d,"while")) {
+ yylval.ival = curcmd->c_line;
+ OPERATOR(WHILE);
+ }
+ if (strEQ(d,"warn"))
+ LOP(O_WARN);
+ if (strEQ(d,"wait"))
+ FUN0(O_WAIT);
+ if (strEQ(d,"waitpid"))
+ FUN2(O_WAITPID);
+ if (strEQ(d,"wantarray")) {
+ yylval.arg = op_new(1);
+ yylval.arg->arg_type = O_ITEM;
+ yylval.arg[1].arg_type = A_WANTARRAY;
+ TERM(RSTRING);
+ }
+ if (strEQ(d,"write"))
+ FOP(O_WRITE);
+ break;
+ case 'x': case 'X':
+ SNARFWORD;
+ if (!expectterm && strEQ(d,"x"))
+ MOP(O_REPEAT);
+ break;
+ case 'y': case 'Y':
+ if (s[1] == '\'') {
+ d = "y";
+ s++;
+ }
+ else {
+ SNARFWORD;
+ }
+ if (strEQ(d,"y")) {
+ s = scantrans(s);
+ TERM(TRANS);
+ }
+ break;
+ case 'z': case 'Z':
+ SNARFWORD;
+ break;
+ }
+ yylval.cval = savestr(d);
+ expectterm = FALSE;
+ if (oldoldbufptr && oldoldbufptr < bufptr) {
+ while (isSPACE(*oldoldbufptr))
+ oldoldbufptr++;
+ if (*oldoldbufptr == 'p' && strnEQ(oldoldbufptr,"print",5))
+ expectterm = TRUE;
+ else if (*oldoldbufptr == 's' && strnEQ(oldoldbufptr,"sort",4))
+ expectterm = TRUE;
+ }
+ return (CLINE, bufptr = s, (int)WORD);
+}
+
+void
+checkcomma(s,what)
+register char *s;
+char *what;
+{
+ char *someword;
+
+ if (*s == '(')
+ s++;
+ while (s < bufend && isSPACE(*s))
+ s++;
+ if (isALPHA(*s) || *s == '_') {
+ someword = s++;
+ while (isALNUM(*s))
+ s++;
+ while (s < bufend && isSPACE(*s))
+ s++;
+ if (*s == ',') {
+ *s = '\0';
+ someword = instr(
+ "tell eof times getlogin wait length shift umask getppid \
+ cos exp int log rand sin sqrt ord wantarray",
+ someword);
+ *s = ',';
+ if (someword)
+ return;
+ fatal("No comma allowed after %s", what);
+ }
+ }
+}
+
+char *
+scanident(s,send,dest)
+register char *s;
+register char *send;
+char *dest;
+{
+ register char *d;
+ int brackets = 0;
+
+ reparse = Nullch;
+ s++;
+ d = dest;
+ if (isDIGIT(*s)) {
+ while (isDIGIT(*s))
+ *d++ = *s++;
+ }
+ else {
+ while (isALNUM(*s) || *s == '\'')
+ *d++ = *s++;
+ }
+ while (d > dest+1 && d[-1] == '\'')
+ d--,s--;
+ *d = '\0';
+ d = dest;
+ if (!*d) {
+ *d = *s++;
+ if (*d == '{' /* } */ ) {
+ d = dest;
+ brackets++;
+ while (s < send && brackets) {
+ if (!reparse && (d == dest || (*s && isALNUM(*s) ))) {
+ *d++ = *s++;
+ continue;
+ }
+ else if (!reparse)
+ reparse = s;
+ switch (*s++) {
+ /* { */
+ case '}':
+ brackets--;
+ if (reparse && reparse == s - 1)
+ reparse = Nullch;
+ break;
+ case '{': /* } */
+ brackets++;
+ break;
+ }
+ }
+ *d = '\0';
+ d = dest;
+ }
+ else
+ d[1] = '\0';
+ }
+ if (*d == '^' && (isUPPER(*s) || index("[\\]^_?", *s))) {
+#ifdef DEBUGGING
+ if (*s == 'D')
+ debug |= 32768;
+#endif
+ *d = *s++ ^ 64;
+ }
+ return s;
+}
+
+void
+scanconst(spat,string,len)
+SPAT *spat;
+char *string;
+int len;
+{
+ register STR *tmpstr;
+ register char *t;
+ register char *d;
+ register char *e;
+ char *origstring = string;
+ static char *vert = "|";
+
+ if (ninstr(string, string+len, vert, vert+1))
+ return;
+ if (*string == '^')
+ string++, len--;
+ tmpstr = Str_new(86,len);
+ str_nset(tmpstr,string,len);
+ t = str_get(tmpstr);
+ e = t + len;
+ tmpstr->str_u.str_useful = 100;
+ for (d=t; d < e; ) {
+ switch (*d) {
+ case '{':
+ if (isDIGIT(d[1]))
+ e = d;
+ else
+ goto defchar;
+ break;
+ case '.': case '[': case '$': case '(': case ')': case '|': case '+':
+ case '^':
+ e = d;
+ break;
+ case '\\':
+ if (d[1] && index("wWbB0123456789sSdDlLuUExc",d[1])) {
+ e = d;
+ break;
+ }
+ (void)bcopy(d+1,d,e-d);
+ e--;
+ switch(*d) {
+ case 'n':
+ *d = '\n';
+ break;
+ case 't':
+ *d = '\t';
+ break;
+ case 'f':
+ *d = '\f';
+ break;
+ case 'r':
+ *d = '\r';
+ break;
+ case 'e':
+ *d = '\033';
+ break;
+ case 'a':
+ *d = '\007';
+ break;
+ }
+ /* FALL THROUGH */
+ default:
+ defchar:
+ if (d[1] == '*' || (d[1] == '{' && d[2] == '0') || d[1] == '?') {
+ e = d;
+ break;
+ }
+ d++;
+ }
+ }
+ if (d == t) {
+ str_free(tmpstr);
+ return;
+ }
+ *d = '\0';
+ tmpstr->str_cur = d - t;
+ if (d == t+len)
+ spat->spat_flags |= SPAT_ALL;
+ if (*origstring != '^')
+ spat->spat_flags |= SPAT_SCANFIRST;
+ spat->spat_short = tmpstr;
+ spat->spat_slen = d - t;
+}
+
+char *
+scanpat(s)
+register char *s;
+{
+ register SPAT *spat;
+ register char *d;
+ register char *e;
+ int len;
+ SPAT savespat;
+ STR *str = Str_new(93,0);
+ char delim;
+
+ Newz(801,spat,1,SPAT);
+ spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
+ curstash->tbl_spatroot = spat;
+
+ switch (*s++) {
+ case 'm':
+ s++;
+ break;
+ case '/':
+ break;
+ case '?':
+ spat->spat_flags |= SPAT_ONCE;
+ break;
+ default:
+ fatal("panic: scanpat");
+ }
+ s = str_append_till(str,s,bufend,s[-1],patleave);
+ if (s >= bufend) {
+ str_free(str);
+ yyerror("Search pattern not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
+ delim = *s++;
+ while (*s == 'i' || *s == 'o' || *s == 'g') {
+ if (*s == 'i') {
+ s++;
+ sawi = TRUE;
+ spat->spat_flags |= SPAT_FOLD;
+ }
+ if (*s == 'o') {
+ s++;
+ spat->spat_flags |= SPAT_KEEP;
+ }
+ if (*s == 'g') {
+ s++;
+ spat->spat_flags |= SPAT_GLOBAL;
+ }
+ }
+ len = str->str_cur;
+ e = str->str_ptr + len;
+ if (delim == '\'')
+ d = e;
+ else
+ d = str->str_ptr;
+ for (; d < e; d++) {
+ if (*d == '\\')
+ d++;
+ else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') ||
+ (*d == '@')) {
+ register ARG *arg;
+
+ spat->spat_runtime = arg = op_new(1);
+ arg->arg_type = O_ITEM;
+ arg[1].arg_type = A_DOUBLE;
+ arg[1].arg_ptr.arg_str = str_smake(str);
+ d = scanident(d,bufend,buf);
+ (void)stabent(buf,TRUE); /* make sure it's created */
+ for (; d < e; d++) {
+ if (*d == '\\')
+ d++;
+ else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') {
+ d = scanident(d,bufend,buf);
+ (void)stabent(buf,TRUE);
+ }
+ else if (*d == '@') {
+ d = scanident(d,bufend,buf);
+ if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
+ strEQ(buf,"SIG") || strEQ(buf,"INC"))
+ (void)stabent(buf,TRUE);
+ }
+ }
+ goto got_pat; /* skip compiling for now */
+ }
+ }
+ if (spat->spat_flags & SPAT_FOLD)
+#ifdef STRUCTCOPY
+ savespat = *spat;
+#else
+ (void)bcopy((char *)spat, (char *)&savespat, sizeof(SPAT));
+#endif
+ scanconst(spat,str->str_ptr,len);
+ if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) {
+ fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
+ spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
+ spat->spat_flags & SPAT_FOLD);
+ /* Note that this regexp can still be used if someone says
+ * something like /a/ && s//b/; so we can't delete it.
+ */
+ }
+ else {
+ if (spat->spat_flags & SPAT_FOLD)
+#ifdef STRUCTCOPY
+ *spat = savespat;
+#else
+ (void)bcopy((char *)&savespat, (char *)spat, sizeof(SPAT));
+#endif
+ if (spat->spat_short)
+ fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
+ spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
+ spat->spat_flags & SPAT_FOLD);
+ hoistmust(spat);
+ }
+ got_pat:
+ str_free(str);
+ yylval.arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
+ return s;
+}
+
+char *
+scansubst(s)
+register char *s;
+{
+ register SPAT *spat;
+ register char *d;
+ register char *e;
+ int len;
+ STR *str = Str_new(93,0);
+
+ Newz(802,spat,1,SPAT);
+ spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
+ curstash->tbl_spatroot = spat;
+
+ s = str_append_till(str,s+1,bufend,*s,patleave);
+ if (s >= bufend) {
+ str_free(str);
+ yyerror("Substitution pattern not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
+ len = str->str_cur;
+ e = str->str_ptr + len;
+ for (d = str->str_ptr; d < e; d++) {
+ if (*d == '\\')
+ d++;
+ else if ((*d == '$' && d[1] && d[1] != '|' && /*(*/ d[1] != ')') ||
+ *d == '@' ) {
+ register ARG *arg;
+
+ spat->spat_runtime = arg = op_new(1);
+ arg->arg_type = O_ITEM;
+ arg[1].arg_type = A_DOUBLE;
+ arg[1].arg_ptr.arg_str = str_smake(str);
+ d = scanident(d,e,buf);
+ (void)stabent(buf,TRUE); /* make sure it's created */
+ for (; *d; d++) {
+ if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+ d = scanident(d,e,buf);
+ (void)stabent(buf,TRUE);
+ }
+ else if (*d == '@' && d[-1] != '\\') {
+ d = scanident(d,e,buf);
+ if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
+ strEQ(buf,"SIG") || strEQ(buf,"INC"))
+ (void)stabent(buf,TRUE);
+ }
+ }
+ goto get_repl; /* skip compiling for now */
+ }
+ }
+ scanconst(spat,str->str_ptr,len);
+get_repl:
+ s = scanstr(s);
+ if (s >= bufend) {
+ str_free(str);
+ yyerror("Substitution replacement not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
+ spat->spat_repl = yylval.arg;
+ if ((spat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
+ spat->spat_flags |= SPAT_CONST;
+ else if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) {
+ STR *tmpstr;
+ register char *t;
+
+ spat->spat_flags |= SPAT_CONST;
+ tmpstr = spat->spat_repl[1].arg_ptr.arg_str;
+ e = tmpstr->str_ptr + tmpstr->str_cur;
+ for (t = tmpstr->str_ptr; t < e; t++) {
+ if (*t == '$' && t[1] && (index("`'&+0123456789",t[1]) ||
+ (t[1] == '{' /*}*/ && isDIGIT(t[2])) ))
+ spat->spat_flags &= ~SPAT_CONST;
+ }
+ }
+ while (*s == 'g' || *s == 'i' || *s == 'e' || *s == 'o') {
+ if (*s == 'e') {
+ s++;
+ if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE)
+ spat->spat_repl[1].arg_type = A_SINGLE;
+ spat->spat_repl = make_op(
+ (spat->spat_repl[1].arg_type == A_SINGLE ? O_EVALONCE : O_EVAL),
+ 2,
+ spat->spat_repl,
+ Nullarg,
+ Nullarg);
+ spat->spat_flags &= ~SPAT_CONST;
+ }
+ if (*s == 'g') {
+ s++;
+ spat->spat_flags |= SPAT_GLOBAL;
+ }
+ if (*s == 'i') {
+ s++;
+ sawi = TRUE;
+ spat->spat_flags |= SPAT_FOLD;
+ if (!(spat->spat_flags & SPAT_SCANFIRST)) {
+ str_free(spat->spat_short); /* anchored opt doesn't do */
+ spat->spat_short = Nullstr; /* case insensitive match */
+ spat->spat_slen = 0;
+ }
+ }
+ if (*s == 'o') {
+ s++;
+ spat->spat_flags |= SPAT_KEEP;
+ }
+ }
+ if (spat->spat_short && (spat->spat_flags & SPAT_SCANFIRST))
+ fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
+ if (!spat->spat_runtime) {
+ spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
+ spat->spat_flags & SPAT_FOLD);
+ hoistmust(spat);
+ }
+ yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat);
+ str_free(str);
+ return s;
+}
+
+void
+hoistmust(spat)
+register SPAT *spat;
+{
+ if (!spat->spat_short && spat->spat_regexp->regstart &&
+ (!spat->spat_regexp->regmust || spat->spat_regexp->reganch & ROPT_ANCH)
+ ) {
+ if (!(spat->spat_regexp->reganch & ROPT_ANCH))
+ spat->spat_flags |= SPAT_SCANFIRST;
+ else if (spat->spat_flags & SPAT_FOLD)
+ return;
+ spat->spat_short = str_smake(spat->spat_regexp->regstart);
+ }
+ else if (spat->spat_regexp->regmust) {/* is there a better short-circuit? */
+ if (spat->spat_short &&
+ str_eq(spat->spat_short,spat->spat_regexp->regmust))
+ {
+ if (spat->spat_flags & SPAT_SCANFIRST) {
+ str_free(spat->spat_short);
+ spat->spat_short = Nullstr;
+ }
+ else {
+ str_free(spat->spat_regexp->regmust);
+ spat->spat_regexp->regmust = Nullstr;
+ return;
+ }
+ }
+ if (!spat->spat_short || /* promote the better string */
+ ((spat->spat_flags & SPAT_SCANFIRST) &&
+ (spat->spat_short->str_cur < spat->spat_regexp->regmust->str_cur) )){
+ str_free(spat->spat_short); /* ok if null */
+ spat->spat_short = spat->spat_regexp->regmust;
+ spat->spat_regexp->regmust = Nullstr;
+ spat->spat_flags |= SPAT_SCANFIRST;
+ }
+ }
+}
+
+char *
+expand_charset(s,len,retlen)
+register char *s;
+int len;
+int *retlen;
+{
+ char t[520];
+ register char *d = t;
+ register int i;
+ register char *send = s + len;
+
+ while (s < send && d - t <= 256) {
+ if (s[1] == '-' && s+2 < send) {
+ for (i = (s[0] & 0377); i <= (s[2] & 0377); i++)
+ *d++ = i;
+ s += 3;
+ }
+ else
+ *d++ = *s++;
+ }
+ *d = '\0';
+ *retlen = d - t;
+ return nsavestr(t,d-t);
+}
+
+char *
+scantrans(s)
+register char *s;
+{
+ ARG *arg =
+ l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg));
+ register char *t;
+ register char *r;
+ register short *tbl;
+ register int i;
+ register int j;
+ int tlen, rlen;
+ int squash;
+ int delete;
+ int complement;
+
+ New(803,tbl,256,short);
+ arg[2].arg_type = A_NULL;
+ arg[2].arg_ptr.arg_cval = (char*) tbl;
+ s = scanstr(s);
+ if (s >= bufend) {
+ yyerror("Translation pattern not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
+ t = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr,
+ yylval.arg[1].arg_ptr.arg_str->str_cur,&tlen);
+ arg_free(yylval.arg);
+ s = scanstr(s-1);
+ if (s >= bufend) {
+ yyerror("Translation replacement not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
+ complement = delete = squash = 0;
+ while (*s == 'c' || *s == 'd' || *s == 's') {
+ if (*s == 'c')
+ complement = 1;
+ else if (*s == 'd')
+ delete = 2;
+ else
+ squash = 1;
+ s++;
+ }
+ r = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr,
+ yylval.arg[1].arg_ptr.arg_str->str_cur,&rlen);
+ arg_free(yylval.arg);
+ arg[2].arg_len = delete|squash;
+ yylval.arg = arg;
+ if (!rlen && !delete) {
+ Safefree(r);
+ r = t; rlen = tlen;
+ }
+ if (complement) {
+ Zero(tbl, 256, short);
+ for (i = 0; i < tlen; i++)
+ tbl[t[i] & 0377] = -1;
+ for (i = 0, j = 0; i < 256; i++) {
+ if (!tbl[i]) {
+ if (j >= rlen) {
+ if (delete)
+ tbl[i] = -2;
+ else
+ tbl[i] = r[j-1];
+ }
+ else
+ tbl[i] = r[j++];
+ }
+ }
+ }
+ else {
+ for (i = 0; i < 256; i++)
+ tbl[i] = -1;
+ for (i = 0, j = 0; i < tlen; i++,j++) {
+ if (j >= rlen) {
+ if (delete) {
+ if (tbl[t[i] & 0377] == -1)
+ tbl[t[i] & 0377] = -2;
+ continue;
+ }
+ --j;
+ }
+ if (tbl[t[i] & 0377] == -1)
+ tbl[t[i] & 0377] = r[j] & 0377;
+ }
+ }
+ if (r != t)
+ Safefree(r);
+ Safefree(t);
+ return s;
+}
+
+char *
+scanstr(s)
+register char *s;
+{
+ register char term;
+ register char *d;
+ register ARG *arg;
+ register char *send;
+ register bool makesingle = FALSE;
+ register STAB *stab;
+ bool alwaysdollar = FALSE;
+ bool hereis = FALSE;
+ STR *herewas;
+ STR *str;
+ char *leave = "\\$@nrtfbeacx0123456789[{]}lLuUE"; /* which backslash sequences to keep */
+ int len;
+
+ arg = op_new(1);
+ yylval.arg = arg;
+ arg->arg_type = O_ITEM;
+
+ switch (*s) {
+ default: /* a substitution replacement */
+ arg[1].arg_type = A_DOUBLE;
+ makesingle = TRUE; /* maybe disable runtime scanning */
+ term = *s;
+ if (term == '\'')
+ leave = Nullch;
+ goto snarf_it;
+ case '0':
+ {
+ unsigned long i;
+ int shift;
+
+ arg[1].arg_type = A_SINGLE;
+ if (s[1] == 'x') {
+ shift = 4;
+ s += 2;
+ }
+ else if (s[1] == '.')
+ goto decimal;
+ else
+ shift = 3;
+ i = 0;
+ for (;;) {
+ switch (*s) {
+ default:
+ goto out;
+ case '_':
+ s++;
+ break;
+ case '8': case '9':
+ if (shift != 4)
+ yyerror("Illegal octal digit");
+ /* FALL THROUGH */
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7':
+ i <<= shift;
+ i += *s++ & 15;
+ break;
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ if (shift != 4)
+ goto out;
+ i <<= 4;
+ i += (*s++ & 7) + 9;
+ break;
+ }
+ }
+ out:
+ str = Str_new(92,0);
+ str_numset(str,(double)i);
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_ptr = Nullch;
+ str->str_len = str->str_cur = 0;
+ }
+ arg[1].arg_ptr.arg_str = str;
+ }
+ break;
+ case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9': case '.':
+ decimal:
+ arg[1].arg_type = A_SINGLE;
+ d = tokenbuf;
+ while (isDIGIT(*s) || *s == '_') {
+ if (*s == '_')
+ s++;
+ else
+ *d++ = *s++;
+ }
+ if (*s == '.' && s[1] && index("0123456789eE ;",s[1])) {
+ *d++ = *s++;
+ while (isDIGIT(*s) || *s == '_') {
+ if (*s == '_')
+ s++;
+ else
+ *d++ = *s++;
+ }
+ }
+ if (*s && index("eE",*s) && index("+-0123456789",s[1])) {
+ *d++ = *s++;
+ if (*s == '+' || *s == '-')
+ *d++ = *s++;
+ while (isDIGIT(*s))
+ *d++ = *s++;
+ }
+ *d = '\0';
+ str = Str_new(92,0);
+ str_numset(str,atof(tokenbuf));
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_ptr = Nullch;
+ str->str_len = str->str_cur = 0;
+ }
+ arg[1].arg_ptr.arg_str = str;
+ break;
+ case '<':
+ if (*++s == '<') {
+ hereis = TRUE;
+ d = tokenbuf;
+ if (!rsfp)
+ *d++ = '\n';
+ if (*++s && index("`'\"",*s)) {
+ term = *s++;
+ s = cpytill(d,s,bufend,term,&len);
+ if (s < bufend)
+ s++;
+ d += len;
+ }
+ else {
+ if (*s == '\\')
+ s++, term = '\'';
+ else
+ term = '"';
+ while (isALNUM(*s))
+ *d++ = *s++;
+ } /* assuming tokenbuf won't clobber */
+ *d++ = '\n';
+ *d = '\0';
+ len = d - tokenbuf;
+ d = "\n";
+ if (rsfp || !(d=ninstr(s,bufend,d,d+1)))
+ herewas = str_make(s,bufend-s);
+ else
+ s--, herewas = str_make(s,d-s);
+ s += herewas->str_cur;
+ if (term == '\'')
+ goto do_single;
+ if (term == '`')
+ goto do_back;
+ goto do_double;
+ }
+ d = tokenbuf;
+ s = cpytill(d,s,bufend,'>',&len);
+ if (s < bufend)
+ s++;
+ if (*d == '$') d++;
+ while (*d && (isALNUM(*d) || *d == '\''))
+ d++;
+ if (d - tokenbuf != len) {
+ d = tokenbuf;
+ arg[1].arg_type = A_GLOB;
+ d = nsavestr(d,len);
+ arg[1].arg_ptr.arg_stab = stab = genstab();
+ stab_io(stab) = stio_new();
+ stab_val(stab) = str_make(d,len);
+ Safefree(d);
+ set_csh();
+ }
+ else {
+ d = tokenbuf;
+ if (!len)
+ (void)strcpy(d,"ARGV");
+ if (*d == '$') {
+ arg[1].arg_type = A_INDREAD;
+ arg[1].arg_ptr.arg_stab = stabent(d+1,TRUE);
+ }
+ else {
+ arg[1].arg_type = A_READ;
+ arg[1].arg_ptr.arg_stab = stabent(d,TRUE);
+ if (!stab_io(arg[1].arg_ptr.arg_stab))
+ stab_io(arg[1].arg_ptr.arg_stab) = stio_new();
+ if (strEQ(d,"ARGV")) {
+ (void)aadd(arg[1].arg_ptr.arg_stab);
+ stab_io(arg[1].arg_ptr.arg_stab)->flags |=
+ IOF_ARGV|IOF_START;
+ }
+ }
+ }
+ break;
+
+ case 'q':
+ s++;
+ if (*s == 'q') {
+ s++;
+ goto do_double;
+ }
+ if (*s == 'x') {
+ s++;
+ goto do_back;
+ }
+ /* FALL THROUGH */
+ case '\'':
+ do_single:
+ term = *s;
+ arg[1].arg_type = A_SINGLE;
+ leave = Nullch;
+ goto snarf_it;
+
+ case '"':
+ do_double:
+ term = *s;
+ arg[1].arg_type = A_DOUBLE;
+ makesingle = TRUE; /* maybe disable runtime scanning */
+ alwaysdollar = TRUE; /* treat $) and $| as variables */
+ goto snarf_it;
+ case '`':
+ do_back:
+ term = *s;
+ arg[1].arg_type = A_BACKTICK;
+ set_csh();
+ alwaysdollar = TRUE; /* treat $) and $| as variables */
+ snarf_it:
+ {
+ STR *tmpstr;
+ char *tmps;
+
+ CLINE;
+ multi_start = curcmd->c_line;
+ if (hereis)
+ multi_open = multi_close = '<';
+ else {
+ multi_open = term;
+ if (term && (tmps = index("([{< )]}> )]}>",term)))
+ term = tmps[5];
+ multi_close = term;
+ }
+ tmpstr = Str_new(87,80);
+ if (hereis) {
+ term = *tokenbuf;
+ if (!rsfp) {
+ d = s;
+ while (s < bufend &&
+ (*s != term || bcmp(s,tokenbuf,len) != 0) ) {
+ if (*s++ == '\n')
+ curcmd->c_line++;
+ }
+ if (s >= bufend) {
+ curcmd->c_line = multi_start;
+ fatal("EOF in string");
+ }
+ str_nset(tmpstr,d+1,s-d);
+ s += len - 1;
+ str_ncat(herewas,s,bufend-s);
+ str_replace(linestr,herewas);
+ oldoldbufptr = oldbufptr = bufptr = s = str_get(linestr);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ hereis = FALSE;
+ }
+ else
+ str_nset(tmpstr,"",0); /* avoid "uninitialized" warning */
+ }
+ else
+ s = str_append_till(tmpstr,s+1,bufend,term,leave);
+ while (s >= bufend) { /* multiple line string? */
+ if (!rsfp ||
+ !(oldoldbufptr = oldbufptr = s = str_gets(linestr, rsfp, 0))) {
+ curcmd->c_line = multi_start;
+ fatal("EOF in string");
+ }
+ curcmd->c_line++;
+ if (perldb) {
+ STR *str = Str_new(88,0);
+
+ str_sset(str,linestr);
+ astore(stab_xarray(curcmd->c_filestab),
+ (int)curcmd->c_line,str);
+ }
+ bufend = linestr->str_ptr + linestr->str_cur;
+ if (hereis) {
+ if (*s == term && bcmp(s,tokenbuf,len) == 0) {
+ s = bufend - 1;
+ *s = ' ';
+ str_scat(linestr,herewas);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ }
+ else {
+ s = bufend;
+ str_scat(tmpstr,linestr);
+ }
+ }
+ else
+ s = str_append_till(tmpstr,s,bufend,term,leave);
+ }
+ multi_end = curcmd->c_line;
+ s++;
+ if (tmpstr->str_cur + 5 < tmpstr->str_len) {
+ tmpstr->str_len = tmpstr->str_cur + 1;
+ Renew(tmpstr->str_ptr, tmpstr->str_len, char);
+ }
+ if ((arg[1].arg_type & A_MASK) == A_SINGLE) {
+ arg[1].arg_ptr.arg_str = tmpstr;
+ break;
+ }
+ tmps = s;
+ s = tmpstr->str_ptr;
+ send = s + tmpstr->str_cur;
+ while (s < send) { /* see if we can make SINGLE */
+ if (*s == '\\' && s[1] && isDIGIT(s[1]) && !isDIGIT(s[2]) &&
+ !alwaysdollar && s[1] != '0')
+ *s = '$'; /* grandfather \digit in subst */
+ if ((*s == '$' || *s == '@') && s+1 < send &&
+ (alwaysdollar || (s[1] != ')' && s[1] != '|'))) {
+ makesingle = FALSE; /* force interpretation */
+ }
+ else if (*s == '\\' && s+1 < send) {
+ if (index("lLuUE",s[1]))
+ makesingle = FALSE;
+ s++;
+ }
+ s++;
+ }
+ s = d = tmpstr->str_ptr; /* assuming shrinkage only */
+ while (s < send) {
+ if ((*s == '$' && s+1 < send &&
+ (alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) ||
+ (*s == '@' && s+1 < send) ) {
+ if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_'))
+ *d++ = *s++;
+ len = scanident(s,send,tokenbuf) - s;
+ if (*s == '$' || strEQ(tokenbuf,"ARGV")
+ || strEQ(tokenbuf,"ENV")
+ || strEQ(tokenbuf,"SIG")
+ || strEQ(tokenbuf,"INC") )
+ (void)stabent(tokenbuf,TRUE); /* make sure it exists */
+ while (len--)
+ *d++ = *s++;
+ continue;
+ }
+ else if (*s == '\\' && s+1 < send) {
+ s++;
+ switch (*s) {
+ default:
+ if (!makesingle && (!leave || (*s && index(leave,*s))))
+ *d++ = '\\';
+ *d++ = *s++;
+ continue;
+ case '0': case '1': case '2': case '3':
+ case '4': case '5': case '6': case '7':
+ *d++ = scanoct(s, 3, &len);
+ s += len;
+ continue;
+ case 'x':
+ *d++ = scanhex(++s, 2, &len);
+ s += len;
+ continue;
+ case 'c':
+ s++;
+ *d = *s++;
+ if (isLOWER(*d))
+ *d = toupper(*d);
+ *d++ ^= 64;
+ continue;
+ case 'b':
+ *d++ = '\b';
+ break;
+ case 'n':
+ *d++ = '\n';
+ break;
+ case 'r':
+ *d++ = '\r';
+ break;
+ case 'f':
+ *d++ = '\f';
+ break;
+ case 't':
+ *d++ = '\t';
+ break;
+ case 'e':
+ *d++ = '\033';
+ break;
+ case 'a':
+ *d++ = '\007';
+ break;
+ }
+ s++;
+ continue;
+ }
+ *d++ = *s++;
+ }
+ *d = '\0';
+
+ if ((arg[1].arg_type & A_MASK) == A_DOUBLE && makesingle)
+ arg[1].arg_type = A_SINGLE; /* now we can optimize on it */
+
+ tmpstr->str_cur = d - tmpstr->str_ptr;
+ arg[1].arg_ptr.arg_str = tmpstr;
+ s = tmps;
+ break;
+ }
+ }
+ if (hereis)
+ str_free(herewas);
+ return s;
+}
+
+FCMD *
+load_format()
+{
+ FCMD froot;
+ FCMD *flinebeg;
+ char *eol;
+ register FCMD *fprev = &froot;
+ register FCMD *fcmd;
+ register char *s;
+ register char *t;
+ register STR *str;
+ bool noblank;
+ bool repeater;
+
+ Zero(&froot, 1, FCMD);
+ s = bufptr;
+ while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) {
+ curcmd->c_line++;
+ if (in_eval && !rsfp) {
+ eol = index(s,'\n');
+ if (!eol++)
+ eol = bufend;
+ }
+ else
+ eol = bufend = linestr->str_ptr + linestr->str_cur;
+ if (perldb) {
+ STR *tmpstr = Str_new(89,0);
+
+ str_nset(tmpstr, s, eol-s);
+ astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr);
+ }
+ if (*s == '.') {
+ /*SUPPRESS 530*/
+ for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
+ if (*t == '\n') {
+ bufptr = s;
+ return froot.f_next;
+ }
+ }
+ if (*s == '#') {
+ s = eol;
+ continue;
+ }
+ flinebeg = Nullfcmd;
+ noblank = FALSE;
+ repeater = FALSE;
+ while (s < eol) {
+ Newz(804,fcmd,1,FCMD);
+ fprev->f_next = fcmd;
+ fprev = fcmd;
+ for (t=s; t < eol && *t != '@' && *t != '^'; t++) {
+ if (*t == '~') {
+ noblank = TRUE;
+ *t = ' ';
+ if (t[1] == '~') {
+ repeater = TRUE;
+ t[1] = ' ';
+ }
+ }
+ }
+ fcmd->f_pre = nsavestr(s, t-s);
+ fcmd->f_presize = t-s;
+ s = t;
+ if (s >= eol) {
+ if (noblank)
+ fcmd->f_flags |= FC_NOBLANK;
+ if (repeater)
+ fcmd->f_flags |= FC_REPEAT;
+ break;
+ }
+ if (!flinebeg)
+ flinebeg = fcmd; /* start values here */
+ if (*s++ == '^')
+ fcmd->f_flags |= FC_CHOP; /* for doing text filling */
+ switch (*s) {
+ case '*':
+ fcmd->f_type = F_LINES;
+ *s = '\0';
+ break;
+ case '<':
+ fcmd->f_type = F_LEFT;
+ while (*s == '<')
+ s++;
+ break;
+ case '>':
+ fcmd->f_type = F_RIGHT;
+ while (*s == '>')
+ s++;
+ break;
+ case '|':
+ fcmd->f_type = F_CENTER;
+ while (*s == '|')
+ s++;
+ break;
+ case '#':
+ case '.':
+ /* Catch the special case @... and handle it as a string
+ field. */
+ if (*s == '.' && s[1] == '.') {
+ goto default_format;
+ }
+ fcmd->f_type = F_DECIMAL;
+ {
+ char *p;
+
+ /* Read a format in the form @####.####, where either group
+ of ### may be empty, or the final .### may be missing. */
+ while (*s == '#')
+ s++;
+ if (*s == '.') {
+ s++;
+ p = s;
+ while (*s == '#')
+ s++;
+ fcmd->f_decimals = s-p;
+ fcmd->f_flags |= FC_DP;
+ } else {
+ fcmd->f_decimals = 0;
+ }
+ }
+ break;
+ default:
+ default_format:
+ fcmd->f_type = F_LEFT;
+ break;
+ }
+ if (fcmd->f_flags & FC_CHOP && *s == '.') {
+ fcmd->f_flags |= FC_MORE;
+ while (*s == '.')
+ s++;
+ }
+ fcmd->f_size = s-t;
+ }
+ if (flinebeg) {
+ again:
+ if (s >= bufend &&
+ (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) )
+ goto badform;
+ curcmd->c_line++;
+ if (in_eval && !rsfp) {
+ eol = index(s,'\n');
+ if (!eol++)
+ eol = bufend;
+ }
+ else
+ eol = bufend = linestr->str_ptr + linestr->str_cur;
+ if (perldb) {
+ STR *tmpstr = Str_new(90,0);
+
+ str_nset(tmpstr, s, eol-s);
+ astore(stab_xarray(curcmd->c_filestab),
+ (int)curcmd->c_line,tmpstr);
+ }
+ if (strnEQ(s,".\n",2)) {
+ bufptr = s;
+ yyerror("Missing values line");
+ return froot.f_next;
+ }
+ if (*s == '#') {
+ s = eol;
+ goto again;
+ }
+ str = flinebeg->f_unparsed = Str_new(91,eol - s);
+ str->str_u.str_hash = curstash;
+ str_nset(str,"(",1);
+ flinebeg->f_line = curcmd->c_line;
+ eol[-1] = '\0';
+ if (!flinebeg->f_next->f_type || index(s, ',')) {
+ eol[-1] = '\n';
+ str_ncat(str, s, eol - s - 1);
+ str_ncat(str,",$$);",5);
+ s = eol;
+ }
+ else {
+ eol[-1] = '\n';
+ while (s < eol && isSPACE(*s))
+ s++;
+ t = s;
+ while (s < eol) {
+ switch (*s) {
+ case ' ': case '\t': case '\n': case ';':
+ str_ncat(str, t, s - t);
+ str_ncat(str, "," ,1);
+ while (s < eol && (isSPACE(*s) || *s == ';'))
+ s++;
+ t = s;
+ break;
+ case '$':
+ str_ncat(str, t, s - t);
+ t = s;
+ s = scanident(s,eol,tokenbuf);
+ str_ncat(str, t, s - t);
+ t = s;
+ if (s < eol && *s && index("$'\"",*s))
+ str_ncat(str, ",", 1);
+ break;
+ case '"': case '\'':
+ str_ncat(str, t, s - t);
+ t = s;
+ s++;
+ while (s < eol && (*s != *t || s[-1] == '\\'))
+ s++;
+ if (s < eol)
+ s++;
+ str_ncat(str, t, s - t);
+ t = s;
+ if (s < eol && *s && index("$'\"",*s))
+ str_ncat(str, ",", 1);
+ break;
+ default:
+ yyerror("Please use commas to separate fields");
+ }
+ }
+ str_ncat(str,"$$);",4);
+ }
+ }
+ }
+ badform:
+ bufptr = str_get(linestr);
+ yyerror("Format not terminated");
+ return froot.f_next;
+}
+
+set_csh()
+{
+#ifdef CSH
+ if (!cshlen)
+ cshlen = strlen(cshname);
+#endif
+}
--- /dev/null
+/* $RCSfile: usersub.c,v $$Revision: 4.0.1.1 $$Date: 91/11/11 16:47:17 $
+ *
+ * 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.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"
+
+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
+
+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 *
+mypfiopen(fil,func) /* open a pipe to function call for input */
+FILE *fil;
+VOID (*func)();
+{
+ int p[2];
+ STR *str;
+
+ if (pipe(p) < 0) {
+ fclose( fil );
+ fatal("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 );
+ fatal("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);
+ str = afetch(fdpid,p[0],TRUE);
+ str->str_u.str_useful = pipepid;
+ return fdopen(p[0], "r");
+}
+
+cryptswitch()
+{
+ int ch;
+#ifdef STDSTDIO
+ /* 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 ) fatal("can't debug an encrypted script");
+ rsfp = mypfiopen( rsfp, cryptfilter );
+ preprocess = 1; /* force call to pclose when done */
+ }
+ else
+ fatal( "bad encryption format" );
+ }
+ else
+ ungetc(ch,rsfp);
+}
+#endif /* !MSDOS */
+
+#endif /* CRYPTSCRIPT */
--- /dev/null
+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
--- /dev/null
+/* $RCSfile: bsdcurses.mus,v $$Revision: 4.0.1.1 $$Date: 91/11/05 19:04:53 $
+ *
+ * $Log: bsdcurses.mus,v $
+ * 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 - 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 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 char* getcap
+I char* str
+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
+
+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;
+}
--- /dev/null
+/* $RCSfile: curses.mus,v $$Revision: 4.0.1.1 $$Date: 91/11/05 19:06:19 $
+ *
+ * $Log: curses.mus,v $
+ * 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;
+ 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
+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 - 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;
+
+#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;
+}
--- /dev/null
+#!/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;
+ }
+}
--- /dev/null
+#!/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;
+ }
+}
--- /dev/null
+#!./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;
+}
--- /dev/null
+/* $RCSfile: usersub.c,v $$Revision: 4.0.1.1 $$Date: 91/11/05 19:07:24 $
+ *
+ * $Log: usersub.c,v $
+ * 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()
+{
+ init_curses();
+}
+
+/* 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);
+}
--- /dev/null
+/* $RCSfile: EXTERN.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:11:15 $
+ *
+ * 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: EXTERN.h,v $
+ * 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
+#define EXT extern
+
+#undef INIT
+#define INIT(x)
+
+#undef DOINIT
--- /dev/null
+/* $RCSfile: INTERN.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:11:20 $
+ *
+ * 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: INTERN.h,v $
+ * 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
+#define EXT
+
+#undef INIT
+#define INIT(x) = x
+
+#define DOINIT
--- /dev/null
+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 x2p/Makefile (with variable substitutions)"
+cat >Makefile <<!GROK!THIS!
+# $RCSfile: Makefile.SH,v $$Revision: 4.0.1.2 $$Date: 91/11/05 19:19:04 $
+#
+# $Log: Makefile.SH,v $
+# 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
+SMALL = $small
+LARGE = $large $split
+mallocsrc = $mallocsrc
+mallocobj = $mallocobj
+
+libs = $libs
+!GROK!THIS!
+
+cat >>Makefile <<'!NO!SUBS!'
+
+CCCMD = `sh 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 226 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
+
+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 's/"perl.h"/"..\/perl.h"/' ../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 makedepend.SH
+!NO!SUBS!
+$eunicefix Makefile
+case `pwd` in
+*SH)
+ $rm -f ../Makefile
+ ln Makefile ../Makefile
+ ;;
+esac
+rm -f makefile
--- /dev/null
+/* $RCSfile: a2p.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:12:27 $
+ *
+ * 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.h,v $
+ * 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
+#include "../config.h"
+
+#ifndef HAS_BCOPY
+# define bcopy(s1,s2,l) memcpy(s2,s1,l)
+#endif
+#ifndef HAS_BZERO
+# define bzero(s,l) memset(s,0,l)
+#endif
+
+#include "handy.h"
+#define Nullop 0
+
+#define OPROG 1
+#define OJUNK 2
+#define OHUNKS 3
+#define ORANGE 4
+#define OPAT 5
+#define OHUNK 6
+#define OPPAREN 7
+#define OPANDAND 8
+#define OPOROR 9
+#define OPNOT 10
+#define OCPAREN 11
+#define OCANDAND 12
+#define OCOROR 13
+#define OCNOT 14
+#define ORELOP 15
+#define ORPAREN 16
+#define OMATCHOP 17
+#define OMPAREN 18
+#define OCONCAT 19
+#define OASSIGN 20
+#define OADD 21
+#define OSUBTRACT 22
+#define OMULT 23
+#define ODIV 24
+#define OMOD 25
+#define OPOSTINCR 26
+#define OPOSTDECR 27
+#define OPREINCR 28
+#define OPREDECR 29
+#define OUMINUS 30
+#define OUPLUS 31
+#define OPAREN 32
+#define OGETLINE 33
+#define OSPRINTF 34
+#define OSUBSTR 35
+#define OSTRING 36
+#define OSPLIT 37
+#define OSNEWLINE 38
+#define OINDEX 39
+#define ONUM 40
+#define OSTR 41
+#define OVAR 42
+#define OFLD 43
+#define ONEWLINE 44
+#define OCOMMENT 45
+#define OCOMMA 46
+#define OSEMICOLON 47
+#define OSCOMMENT 48
+#define OSTATES 49
+#define OSTATE 50
+#define OPRINT 51
+#define OPRINTF 52
+#define OBREAK 53
+#define ONEXT 54
+#define OEXIT 55
+#define OCONTINUE 56
+#define OREDIR 57
+#define OIF 58
+#define OWHILE 59
+#define OFOR 60
+#define OFORIN 61
+#define OVFLD 62
+#define OBLOCK 63
+#define OREGEX 64
+#define OLENGTH 65
+#define OLOG 66
+#define OEXP 67
+#define OSQRT 68
+#define OINT 69
+#define ODO 70
+#define OPOW 71
+#define OSUB 72
+#define OGSUB 73
+#define OMATCH 74
+#define OUSERFUN 75
+#define OUSERDEF 76
+#define OCLOSE 77
+#define OATAN2 78
+#define OSIN 79
+#define OCOS 80
+#define ORAND 81
+#define OSRAND 82
+#define ODELETE 83
+#define OSYSTEM 84
+#define OCOND 85
+#define ORETURN 86
+#define ODEFINED 87
+#define OSTAR 88
+
+#ifdef DOINIT
+char *opname[] = {
+ "0",
+ "PROG",
+ "JUNK",
+ "HUNKS",
+ "RANGE",
+ "PAT",
+ "HUNK",
+ "PPAREN",
+ "PANDAND",
+ "POROR",
+ "PNOT",
+ "CPAREN",
+ "CANDAND",
+ "COROR",
+ "CNOT",
+ "RELOP",
+ "RPAREN",
+ "MATCHOP",
+ "MPAREN",
+ "CONCAT",
+ "ASSIGN",
+ "ADD",
+ "SUBTRACT",
+ "MULT",
+ "DIV",
+ "MOD",
+ "POSTINCR",
+ "POSTDECR",
+ "PREINCR",
+ "PREDECR",
+ "UMINUS",
+ "UPLUS",
+ "PAREN",
+ "GETLINE",
+ "SPRINTF",
+ "SUBSTR",
+ "STRING",
+ "SPLIT",
+ "SNEWLINE",
+ "INDEX",
+ "NUM",
+ "STR",
+ "VAR",
+ "FLD",
+ "NEWLINE",
+ "COMMENT",
+ "COMMA",
+ "SEMICOLON",
+ "SCOMMENT",
+ "STATES",
+ "STATE",
+ "PRINT",
+ "PRINTF",
+ "BREAK",
+ "NEXT",
+ "EXIT",
+ "CONTINUE",
+ "REDIR",
+ "IF",
+ "WHILE",
+ "FOR",
+ "FORIN",
+ "VFLD",
+ "BLOCK",
+ "REGEX",
+ "LENGTH",
+ "LOG",
+ "EXP",
+ "SQRT",
+ "INT",
+ "DO",
+ "POW",
+ "SUB",
+ "GSUB",
+ "MATCH",
+ "USERFUN",
+ "USERDEF",
+ "CLOSE",
+ "ATAN2",
+ "SIN",
+ "COS",
+ "RAND",
+ "SRAND",
+ "DELETE",
+ "SYSTEM",
+ "COND",
+ "RETURN",
+ "DEFINED",
+ "STAR",
+ "89"
+};
+#else
+extern char *opname[];
+#endif
+
+EXT int mop INIT(1);
+
+union u_ops {
+ int ival;
+ char *cval;
+};
+#if defined(iAPX286) || defined(M_I286) || defined(I80286) /* 80286 hack */
+#define OPSMAX (64000/sizeof(union u_ops)) /* approx. max segment size */
+#else
+#define OPSMAX 50000
+#endif /* 80286 hack */
+union u_ops ops[OPSMAX];
+
+#include <stdio.h>
+#include <ctype.h>
+
+typedef struct string STR;
+typedef struct htbl HASH;
+
+#include "str.h"
+#include "hash.h"
+
+/* A string is TRUE if not "" or "0". */
+#define True(val) (tmps = (val), (*tmps && !(*tmps == '0' && !tmps[1])))
+EXT char *Yes INIT("1");
+EXT char *No INIT("");
+
+#define str_true(str) (Str = (str), (Str->str_pok ? True(Str->str_ptr) : (Str->str_nok ? (Str->str_nval != 0.0) : 0 )))
+
+#define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),buf) : "" )))
+#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
+#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_nval : str_2num(Str)))
+EXT STR *Str;
+
+#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
+
+STR *str_new();
+
+char *scanpat();
+char *scannum();
+
+void str_free();
+
+EXT int line INIT(0);
+
+EXT FILE *rsfp;
+EXT char buf[2048];
+EXT char *bufptr INIT(buf);
+
+EXT STR *linestr INIT(Nullstr);
+
+EXT char tokenbuf[2048];
+EXT int expectterm INIT(TRUE);
+
+#ifdef DEBUGGING
+EXT int debug INIT(0);
+EXT int dlevel INIT(0);
+#define YYDEBUG 1
+extern int yydebug;
+#endif
+
+EXT STR *freestrroot INIT(Nullstr);
+
+EXT STR str_no;
+EXT STR str_yes;
+
+EXT bool do_split INIT(FALSE);
+EXT bool split_to_array INIT(FALSE);
+EXT bool set_array_base INIT(FALSE);
+EXT bool saw_RS INIT(FALSE);
+EXT bool saw_OFS INIT(FALSE);
+EXT bool saw_ORS INIT(FALSE);
+EXT bool saw_line_op INIT(FALSE);
+EXT bool in_begin INIT(TRUE);
+EXT bool do_opens INIT(FALSE);
+EXT bool do_fancy_opens INIT(FALSE);
+EXT bool lval_field INIT(FALSE);
+EXT bool do_chop INIT(FALSE);
+EXT bool need_entire INIT(FALSE);
+EXT bool absmaxfld INIT(FALSE);
+EXT bool saw_altinput INIT(FALSE);
+
+EXT char const_FS INIT(0);
+EXT char *namelist INIT(Nullch);
+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 STR *opens;
+
+EXT HASH *symtab;
+EXT HASH *curarghash;
+
+#define P_MIN 0
+#define P_LISTOP 5
+#define P_COMMA 10
+#define P_ASSIGN 15
+#define P_COND 20
+#define P_DOTDOT 25
+#define P_OROR 30
+#define P_ANDAND 35
+#define P_OR 40
+#define P_AND 45
+#define P_EQ 50
+#define P_REL 55
+#define P_UNI 60
+#define P_FILETEST 65
+#define P_SHIFT 70
+#define P_ADD 75
+#define P_MUL 80
+#define P_MATCH 85
+#define P_UNARY 90
+#define P_POW 95
+#define P_AUTO 100
+#define P_MAX 999
--- /dev/null
+.rn '' }`
+''' $Header: a2p.man,v 4.0 91/03/20 01:57:11 lwall Locked $
+'''
+''' $Log: a2p.man,v $
+''' 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
+.PP
+\fB\\$1\fR
+.PP
+..
+.de Sp
+.if t .sp .5v
+.if n .sp
+..
+.de Ip
+.br
+.ie \\n.$>=3 .ne \\$3
+.el .ne 3
+.IP "\\$1" \\$2
+..
+'''
+''' Set up \*(-- to give an unbreakable dash;
+''' string Tr holds user defined translation string.
+''' Bell System Logo is used as a dummy character.
+'''
+.tr \(*W-|\(bv\*(Tr
+.ie n \{\
+.ds -- \(*W-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
+.ds L" ""
+.ds R" ""
+.ds L' '
+.ds R' '
+'br\}
+.el\{\
+.ds -- \(em\|
+.tr \*(Tr
+.ds L" ``
+.ds R" ''
+.ds L' `
+.ds R' '
+'br\}
+.TH A2P 1 LOCAL
+.SH NAME
+a2p - Awk to Perl translator
+.SH SYNOPSIS
+.B a2p [options] filename
+.SH DESCRIPTION
+.I A2p
+takes an awk script specified on the command line (or from standard input)
+and produces a comparable
+.I perl
+script on the standard output.
+.Sh "Options"
+Options include:
+.TP 5
+.B \-D<number>
+sets debugging flags.
+.TP 5
+.B \-F<character>
+tells a2p that this awk script is always invoked with this -F switch.
+.TP 5
+.B \-n<fieldlist>
+specifies the names of the input fields if input does not have to be split into
+an array.
+If you were translating an awk script that processes the password file, you
+might say:
+.sp
+ a2p -7 -nlogin.password.uid.gid.gcos.shell.home
+.sp
+Any delimiter can be used to separate the field names.
+.TP 5
+.B \-<number>
+causes a2p to assume that input will always have that many fields.
+.Sh "Considerations"
+A2p cannot do as good a job translating as a human would, but it usually
+does pretty well.
+There are some areas where you may want to examine the perl script produced
+and tweak it some.
+Here are some of them, in no particular order.
+.PP
+There is an awk idiom of putting int() around a string expression to force
+numeric interpretation, even though the argument is always integer anyway.
+This is generally unneeded in perl, but a2p can't tell if the argument
+is always going to be integer, so it leaves it in.
+You may wish to remove it.
+.PP
+Perl differentiates numeric comparison from string comparison.
+Awk has one operator for both that decides at run time which comparison
+to do.
+A2p does not try to do a complete job of awk emulation at this point.
+Instead it guesses which one you want.
+It's almost always right, but it can be spoofed.
+All such guesses are marked with the comment \*(L"#???\*(R".
+You should go through and check them.
+You might want to run at least once with the \-w switch to perl, which
+will warn you if you use == where you should have used eq.
+.PP
+Perl does not attempt to emulate the behavior of awk in which nonexistent
+array elements spring into existence simply by being referenced.
+If somehow you are relying on this mechanism to create null entries for
+a subsequent for...in, they won't be there in perl.
+.PP
+If a2p makes a split line that assigns to a list of variables that looks
+like (Fld1, Fld2, Fld3...) you may want
+to rerun a2p using the \-n option mentioned above.
+This will let you name the fields throughout the script.
+If it splits to an array instead, the script is probably referring to the number
+of fields somewhere.
+.PP
+The exit statement in awk doesn't necessarily exit; it goes to the END
+block if there is one.
+Awk scripts that do contortions within the END block to bypass the block under
+such circumstances can be simplified by removing the conditional
+in the END block and just exiting directly from the perl script.
+.PP
+Perl has two kinds of array, numerically-indexed and associative.
+Awk arrays are usually translated to associative arrays, but if you happen
+to know that the index is always going to be numeric you could change
+the {...} to [...].
+Iteration over an associative array is done using the keys() function, but
+iteration over a numeric array is NOT.
+You might need to modify any loop that is iterating over the array in question.
+.PP
+Awk starts by assuming OFMT has the value %.6g.
+Perl starts by assuming its equivalent, $#, to have the value %.20g.
+You'll want to set $# explicitly if you use the default value of OFMT.
+.PP
+Near the top of the line loop will be the split operation that is implicit in
+the awk script.
+There are times when you can move this down past some conditionals that
+test the entire record so that the split is not done as often.
+.PP
+For aesthetic reasons you may wish to change the array base $[ from 1 back
+to perl's default of 0, but remember to change all array subscripts AND
+all substr() and index() operations to match.
+.PP
+Cute comments that say "# Here is a workaround because awk is dumb" are passed
+through unmodified.
+.PP
+Awk scripts are often embedded in a shell script that pipes stuff into and
+out of awk.
+Often the shell script wrapper can be incorporated into the perl script, since
+perl can start up pipes into and out of itself, and can do other things that
+awk can't do by itself.
+.PP
+Scripts that refer to the special variables RSTART and RLENGTH can often
+be simplified by referring to the variables $`, $& and $', as long as they
+are within the scope of the pattern match that sets them.
+.PP
+The produced perl script may have subroutines defined to deal with awk's
+semantics regarding getline and print.
+Since a2p usually picks correctness over efficiency.
+it is almost always possible to rewrite such code to be more efficient by
+discarding the semantic sugar.
+.PP
+For efficiency, you may wish to remove the keyword from any return statement
+that is the last statement executed in a subroutine.
+A2p catches the most common case, but doesn't analyze embedded blocks for
+subtler cases.
+.PP
+ARGV[0] translates to $ARGV0, but ARGV[n] translates to $ARGV[$n].
+A loop that tries to iterate over ARGV[0] won't find it.
+.SH ENVIRONMENT
+A2p uses no environment variables.
+.SH AUTHOR
+Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
+.SH FILES
+.SH SEE ALSO
+perl The perl compiler/interpreter
+.br
+s2p sed to perl translator
+.SH DIAGNOSTICS
+.SH BUGS
+It would be possible to emulate awk's behavior in selecting string versus
+numeric operations at run time by inspection of the operands, but it would
+be gross and inefficient.
+Besides, a2p almost always guesses right.
+.PP
+Storage for the awk syntax tree is currently static, and can run out.
+.rn }` ''
--- /dev/null
+%{
+/* $RCSfile: a2p.y,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:12:41 $
+ *
+ * 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.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;
+
+%}
+%token BEGIN END
+%token REGEX
+%token SEMINEW NEWLINE COMMENT
+%token FUN1 FUNN GRGR
+%token PRINT PRINTF SPRINTF SPLIT
+%token IF ELSE WHILE FOR IN
+%token EXIT NEXT BREAK CONTINUE RET
+%token GETLINE DO SUB GSUB MATCH
+%token FUNCTION USERFUN DELETE
+
+%right ASGNOP
+%right '?' ':'
+%left OROR
+%left ANDAND
+%left IN
+%left NUMBER VAR SUBSTR INDEX
+%left MATCHOP
+%left RELOP '<' '>'
+%left OR
+%left STRING
+%left '+' '-'
+%left '*' '/' '%'
+%right UMINUS
+%left NOT
+%right '^'
+%left INCR DECR
+%left FIELD VFIELD
+
+%%
+
+program : junk hunks
+ { root = oper4(OPROG,$1,begins,$2,ends); }
+ ;
+
+begin : BEGIN '{' maybe states '}' junk
+ { begins = oper4(OJUNK,begins,$3,$4,$6); in_begin = FALSE;
+ $$ = Nullop; }
+ ;
+
+end : END '{' maybe states '}'
+ { ends = oper3(OJUNK,ends,$3,$4); $$ = Nullop; }
+ | end NEWLINE
+ { $$ = $1; }
+ ;
+
+hunks : hunks hunk junk
+ { $$ = oper3(OHUNKS,$1,$2,$3); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+hunk : patpat
+ { $$ = oper1(OHUNK,$1); need_entire = TRUE; }
+ | patpat '{' maybe states '}'
+ { $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); }
+ | FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}'
+ { fixfargs($2,$4,0); $$ = oper5(OUSERDEF,$2,$4,$6,$8,$9); }
+ | '{' maybe states '}'
+ { $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); }
+ | begin
+ | end
+ ;
+
+arg_list: expr_list
+ { $$ = rememberargs($$); }
+ ;
+
+patpat : cond
+ { $$ = oper1(OPAT,$1); }
+ | cond ',' cond
+ { $$ = oper2(ORANGE,$1,$3); }
+ ;
+
+cond : expr
+ | match
+ | rel
+ | compound_cond
+ ;
+
+compound_cond
+ : '(' compound_cond ')'
+ { $$ = oper1(OCPAREN,$2); }
+ | cond ANDAND maybe cond
+ { $$ = oper3(OCANDAND,$1,$3,$4); }
+ | cond OROR maybe cond
+ { $$ = oper3(OCOROR,$1,$3,$4); }
+ | NOT cond
+ { $$ = oper1(OCNOT,$2); }
+ ;
+
+rel : expr RELOP expr
+ { $$ = oper3(ORELOP,$2,$1,$3); }
+ | expr '>' expr
+ { $$ = oper3(ORELOP,string(">",1),$1,$3); }
+ | expr '<' expr
+ { $$ = oper3(ORELOP,string("<",1),$1,$3); }
+ | '(' rel ')'
+ { $$ = oper1(ORPAREN,$2); }
+ ;
+
+match : expr MATCHOP expr
+ { $$ = oper3(OMATCHOP,$2,$1,$3); }
+ | expr MATCHOP REGEX
+ { $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); }
+ | REGEX %prec MATCHOP
+ { $$ = oper1(OREGEX,$1); }
+ | '(' match ')'
+ { $$ = oper1(OMPAREN,$2); }
+ ;
+
+expr : term
+ { $$ = $1; }
+ | expr term
+ { $$ = oper2(OCONCAT,$1,$2); }
+ | variable ASGNOP cond
+ { $$ = oper3(OASSIGN,$2,$1,$3);
+ if ((ops[$1].ival & 255) == OFLD)
+ lval_field = TRUE;
+ if ((ops[$1].ival & 255) == OVFLD)
+ lval_field = TRUE;
+ }
+ ;
+
+term : variable
+ { $$ = $1; }
+ | NUMBER
+ { $$ = oper1(ONUM,$1); }
+ | STRING
+ { $$ = oper1(OSTR,$1); }
+ | term '+' term
+ { $$ = oper2(OADD,$1,$3); }
+ | term '-' term
+ { $$ = oper2(OSUBTRACT,$1,$3); }
+ | term '*' term
+ { $$ = oper2(OMULT,$1,$3); }
+ | term '/' term
+ { $$ = oper2(ODIV,$1,$3); }
+ | term '%' term
+ { $$ = oper2(OMOD,$1,$3); }
+ | term '^' term
+ { $$ = oper2(OPOW,$1,$3); }
+ | term IN VAR
+ { $$ = oper2(ODEFINED,aryrefarg($3),$1); }
+ | term '?' term ':' term
+ { $$ = oper3(OCOND,$1,$3,$5); }
+ | variable INCR
+ { $$ = oper1(OPOSTINCR,$1); }
+ | variable DECR
+ { $$ = oper1(OPOSTDECR,$1); }
+ | INCR variable
+ { $$ = oper1(OPREINCR,$2); }
+ | DECR variable
+ { $$ = oper1(OPREDECR,$2); }
+ | '-' term %prec UMINUS
+ { $$ = oper1(OUMINUS,$2); }
+ | '+' term %prec UMINUS
+ { $$ = oper1(OUPLUS,$2); }
+ | '(' cond ')'
+ { $$ = oper1(OPAREN,$2); }
+ | GETLINE
+ { $$ = oper0(OGETLINE); }
+ | GETLINE VAR
+ { $$ = oper1(OGETLINE,$2); }
+ | GETLINE '<' expr
+ { $$ = oper3(OGETLINE,Nullop,string("<",1),$3);
+ if (ops[$3].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | GETLINE VAR '<' expr
+ { $$ = oper3(OGETLINE,$2,string("<",1),$4);
+ if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | term 'p' GETLINE
+ { $$ = oper3(OGETLINE,Nullop,string("|",1),$1);
+ if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | term 'p' GETLINE VAR
+ { $$ = oper3(OGETLINE,$4,string("|",1),$1);
+ if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | FUN1
+ { $$ = oper0($1); need_entire = do_chop = TRUE; }
+ | FUN1 '(' ')'
+ { $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; }
+ | FUN1 '(' expr ')'
+ { $$ = oper1($1,$3); }
+ | FUNN '(' expr_list ')'
+ { $$ = oper1($1,$3); }
+ | USERFUN '(' expr_list ')'
+ { $$ = oper2(OUSERFUN,$1,$3); }
+ | SPRINTF expr_list
+ { $$ = oper1(OSPRINTF,$2); }
+ | SUBSTR '(' expr ',' expr ',' expr ')'
+ { $$ = oper3(OSUBSTR,$3,$5,$7); }
+ | SUBSTR '(' expr ',' expr ')'
+ { $$ = oper2(OSUBSTR,$3,$5); }
+ | SPLIT '(' expr ',' VAR ',' expr ')'
+ { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),$7); }
+ | SPLIT '(' expr ',' VAR ',' REGEX ')'
+ { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),oper1(OREGEX,$7));}
+ | SPLIT '(' expr ',' VAR ')'
+ { $$ = oper2(OSPLIT,$3,aryrefarg(numary($5))); }
+ | INDEX '(' expr ',' expr ')'
+ { $$ = oper2(OINDEX,$3,$5); }
+ | MATCH '(' expr ',' REGEX ')'
+ { $$ = oper2(OMATCH,$3,oper1(OREGEX,$5)); }
+ | MATCH '(' expr ',' expr ')'
+ { $$ = oper2(OMATCH,$3,$5); }
+ | SUB '(' expr ',' expr ')'
+ { $$ = oper2(OSUB,$3,$5); }
+ | SUB '(' REGEX ',' expr ')'
+ { $$ = oper2(OSUB,oper1(OREGEX,$3),$5); }
+ | GSUB '(' expr ',' expr ')'
+ { $$ = oper2(OGSUB,$3,$5); }
+ | GSUB '(' REGEX ',' expr ')'
+ { $$ = oper2(OGSUB,oper1(OREGEX,$3),$5); }
+ | SUB '(' expr ',' expr ',' expr ')'
+ { $$ = oper3(OSUB,$3,$5,$7); }
+ | SUB '(' REGEX ',' expr ',' expr ')'
+ { $$ = oper3(OSUB,oper1(OREGEX,$3),$5,$7); }
+ | GSUB '(' expr ',' expr ',' expr ')'
+ { $$ = oper3(OGSUB,$3,$5,$7); }
+ | GSUB '(' REGEX ',' expr ',' expr ')'
+ { $$ = oper3(OGSUB,oper1(OREGEX,$3),$5,$7); }
+ ;
+
+variable: VAR
+ { $$ = oper1(OVAR,$1); }
+ | VAR '[' expr_list ']'
+ { $$ = oper2(OVAR,aryrefarg($1),$3); }
+ | FIELD
+ { $$ = oper1(OFLD,$1); }
+ | VFIELD term
+ { $$ = oper1(OVFLD,$2); }
+ ;
+
+expr_list
+ : expr
+ | clist
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+clist : expr ',' maybe expr
+ { $$ = oper3(OCOMMA,$1,$3,$4); }
+ | clist ',' maybe expr
+ { $$ = oper3(OCOMMA,$1,$3,$4); }
+ | '(' clist ')' /* these parens are invisible */
+ { $$ = $2; }
+ ;
+
+junk : junk hunksep
+ { $$ = oper2(OJUNK,$1,$2); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+hunksep : ';'
+ { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
+ | SEMINEW
+ { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
+ | NEWLINE
+ { $$ = oper0(ONEWLINE); }
+ | COMMENT
+ { $$ = oper1(OCOMMENT,$1); }
+ ;
+
+maybe : maybe nlstuff
+ { $$ = oper2(OJUNK,$1,$2); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+nlstuff : NEWLINE
+ { $$ = oper0(ONEWLINE); }
+ | COMMENT
+ { $$ = oper1(OCOMMENT,$1); }
+ ;
+
+separator
+ : ';' maybe
+ { $$ = oper2(OJUNK,oper0(OSEMICOLON),$2); }
+ | SEMINEW maybe
+ { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
+ | NEWLINE maybe
+ { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
+ | COMMENT maybe
+ { $$ = oper2(OJUNK,oper1(OSCOMMENT,$1),$2); }
+ ;
+
+states : states statement
+ { $$ = oper2(OSTATES,$1,$2); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+statement
+ : simple separator maybe
+ { $$ = oper2(OJUNK,oper2(OSTATE,$1,$2),$3); }
+ | ';' maybe
+ { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),$2)); }
+ | SEMINEW maybe
+ { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),$2)); }
+ | compound
+ ;
+
+simpnull: simple
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+simple
+ : expr
+ | PRINT expr_list redir expr
+ { $$ = oper3(OPRINT,$2,$3,$4);
+ do_opens = TRUE;
+ saw_ORS = saw_OFS = TRUE;
+ if (!$2) need_entire = TRUE;
+ if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | PRINT expr_list
+ { $$ = oper1(OPRINT,$2);
+ if (!$2) need_entire = TRUE;
+ saw_ORS = saw_OFS = TRUE;
+ }
+ | PRINTF expr_list redir expr
+ { $$ = oper3(OPRINTF,$2,$3,$4);
+ do_opens = TRUE;
+ if (!$2) need_entire = TRUE;
+ if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | PRINTF expr_list
+ { $$ = oper1(OPRINTF,$2);
+ if (!$2) need_entire = TRUE;
+ }
+ | BREAK
+ { $$ = oper0(OBREAK); }
+ | NEXT
+ { $$ = oper0(ONEXT); }
+ | EXIT
+ { $$ = oper0(OEXIT); }
+ | EXIT expr
+ { $$ = oper1(OEXIT,$2); }
+ | CONTINUE
+ { $$ = oper0(OCONTINUE); }
+ | RET
+ { $$ = oper0(ORETURN); }
+ | RET expr
+ { $$ = oper1(ORETURN,$2); }
+ | DELETE VAR '[' expr ']'
+ { $$ = oper2(ODELETE,aryrefarg($2),$4); }
+ ;
+
+redir : '>' %prec FIELD
+ { $$ = oper1(OREDIR,string(">",1)); }
+ | GRGR
+ { $$ = oper1(OREDIR,string(">>",2)); }
+ | '|'
+ { $$ = oper1(OREDIR,string("|",1)); }
+ ;
+
+compound
+ : IF '(' cond ')' maybe statement
+ { $$ = oper2(OIF,$3,bl($6,$5)); }
+ | IF '(' cond ')' maybe statement ELSE maybe statement
+ { $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); }
+ | WHILE '(' cond ')' maybe statement
+ { $$ = oper2(OWHILE,$3,bl($6,$5)); }
+ | DO maybe statement WHILE '(' cond ')'
+ { $$ = oper2(ODO,bl($3,$2),$6); }
+ | FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement
+ { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); }
+ | FOR '(' simpnull ';' ';' simpnull ')' maybe statement
+ { $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); }
+ | FOR '(' expr ')' maybe statement
+ { $$ = oper2(OFORIN,$3,bl($6,$5)); }
+ | '{' maybe states '}' maybe
+ { $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); }
+ ;
+
+%%
+#include "a2py.c"
--- /dev/null
+/* $RCSfile: a2py.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:12:59 $
+ *
+ * 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: a2py.c,v $
+ * 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 MSDOS
+#include "../patchlev.h"
+#endif
+#include "util.h"
+char *index();
+
+char *filename;
+char *myname;
+
+int checkers = 0;
+STR *walk();
+
+#ifdef MSDOS
+usage()
+{
+ printf("\nThis is the AWK to PERL translator, version 3.0, patchlevel %d\n", PATCHLEVEL);
+ printf("\nUsage: %s [-D<number>] [-F<char>] [-n<fieldlist>] [-<number>] filename\n", myname);
+ printf("\n -D<number> sets debugging flags."
+ "\n -F<character> the awk script to translate is always invoked with"
+ "\n this -F switch."
+ "\n -n<fieldlist> specifies the names of the input fields if input does"
+ "\n not have to be split into an array."
+ "\n -<number> causes a2p to assume that input will always have that"
+ "\n many fields.\n");
+ exit(1);
+}
+#endif
+main(argc,argv,env)
+register int argc;
+register char **argv;
+register char **env;
+{
+ register STR *str;
+ register char *s;
+ int i;
+ STR *tmpstr;
+
+ myname = argv[0];
+ linestr = str_new(80);
+ str = str_new(0); /* first used for -I flags */
+ for (argc--,argv++; argc; argc--,argv++) {
+ if (argv[0][0] != '-' || !argv[0][1])
+ break;
+ reswitch:
+ switch (argv[0][1]) {
+#ifdef DEBUGGING
+ case 'D':
+ debug = atoi(argv[0]+2);
+#ifdef YYDEBUG
+ yydebug = (debug & 1);
+#endif
+ break;
+#endif
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ maxfld = atoi(argv[0]+1);
+ absmaxfld = TRUE;
+ break;
+ case 'F':
+ fswitch = argv[0][2];
+ break;
+ case 'n':
+ namelist = savestr(argv[0]+2);
+ break;
+ case '-':
+ argc--,argv++;
+ goto switch_end;
+ case 0:
+ break;
+ default:
+ fatal("Unrecognized switch: %s\n",argv[0]);
+#ifdef MSDOS
+ usage();
+#endif
+ }
+ }
+ switch_end:
+
+ /* open script */
+
+ if (argv[0] == Nullch) {
+#ifdef MSDOS
+ if ( isatty(fileno(stdin)) )
+ usage();
+#endif
+ argv[0] = "-";
+ }
+ filename = savestr(argv[0]);
+
+ filename = savestr(argv[0]);
+ if (strEQ(filename,"-"))
+ argv[0] = "";
+ if (!*argv[0])
+ rsfp = stdin;
+ else
+ rsfp = fopen(argv[0],"r");
+ if (rsfp == Nullfp)
+ fatal("Awk script \"%s\" doesn't seem to exist.\n",filename);
+
+ /* init tokener */
+
+ bufptr = str_get(linestr);
+ symtab = hnew();
+ curarghash = hnew();
+
+ /* now parse the report spec */
+
+ if (yyparse())
+ fatal("Translation aborted due to syntax errors.\n");
+
+#ifdef DEBUGGING
+ if (debug & 2) {
+ int type, len;
+
+ for (i=1; i<mop;) {
+ type = ops[i].ival;
+ len = type >> 8;
+ type &= 255;
+ printf("%d\t%d\t%d\t%-10s",i++,type,len,opname[type]);
+ if (type == OSTRING)
+ printf("\t\"%s\"\n",ops[i].cval),i++;
+ else {
+ while (len--) {
+ printf("\t%d",ops[i].ival),i++;
+ }
+ putchar('\n');
+ }
+ }
+ }
+ if (debug & 8)
+ dump(root);
+#endif
+
+ /* first pass to look for numeric variables */
+
+ prewalk(0,0,root,&i);
+
+ /* second pass to produce new program */
+
+ tmpstr = walk(0,0,root,&i,P_MIN);
+ str = str_make("#!");
+ str_cat(str, BIN);
+ str_cat(str, "/perl\neval \"exec ");
+ str_cat(str, BIN);
+ str_cat(str, "/perl -S $0 $*\"\n\
+ if $running_under_some_shell;\n\
+ # this emulates #! processing on NIH machines.\n\
+ # (remove #! line above if indigestible)\n\n");
+ str_cat(str,
+ "eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;\n");
+ str_cat(str,
+ " # process any FOO=bar switches\n\n");
+ if (do_opens && opens) {
+ str_scat(str,opens);
+ str_free(opens);
+ str_cat(str,"\n");
+ }
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+#ifdef DEBUGGING
+ if (!(debug & 16))
+#endif
+ fixup(str);
+ putlines(str);
+ if (checkers) {
+ fprintf(stderr,
+ "Please check my work on the %d line%s I've marked with \"#???\".\n",
+ checkers, checkers == 1 ? "" : "s" );
+ fprintf(stderr,
+ "The operation I've selected may be wrong for the operand types.\n");
+ }
+ exit(0);
+}
+
+#define RETURN(retval) return (bufptr = s,retval)
+#define XTERM(retval) return (expectterm = TRUE,bufptr = s,retval)
+#define XOP(retval) return (expectterm = FALSE,bufptr = s,retval)
+#define ID(x) return (yylval=string(x,0),expectterm = FALSE,bufptr = s,idtype)
+
+int idtype;
+
+yylex()
+{
+ register char *s = bufptr;
+ register char *d;
+ register int tmp;
+
+ retry:
+#ifdef YYDEBUG
+ if (yydebug)
+ if (index(s,'\n'))
+ fprintf(stderr,"Tokener at %s",s);
+ else
+ fprintf(stderr,"Tokener at %s\n",s);
+#endif
+ switch (*s) {
+ default:
+ fprintf(stderr,
+ "Unrecognized character %c in file %s line %d--ignoring.\n",
+ *s++,filename,line);
+ goto retry;
+ case '\\':
+ case 0:
+ s = str_get(linestr);
+ *s = '\0';
+ if (!rsfp)
+ RETURN(0);
+ line++;
+ if ((s = str_gets(linestr, rsfp)) == Nullch) {
+ if (rsfp != stdin)
+ fclose(rsfp);
+ rsfp = Nullfp;
+ s = str_get(linestr);
+ RETURN(0);
+ }
+ goto retry;
+ case ' ': case '\t':
+ s++;
+ goto retry;
+ case '\n':
+ *s = '\0';
+ XTERM(NEWLINE);
+ case '#':
+ yylval = string(s,0);
+ *s = '\0';
+ XTERM(COMMENT);
+ case ';':
+ tmp = *s++;
+ if (*s == '\n') {
+ s++;
+ XTERM(SEMINEW);
+ }
+ XTERM(tmp);
+ case '(':
+ tmp = *s++;
+ XTERM(tmp);
+ case '{':
+ case '[':
+ case ')':
+ case ']':
+ case '?':
+ case ':':
+ tmp = *s++;
+ XOP(tmp);
+ case 127:
+ s++;
+ XTERM('}');
+ case '}':
+ for (d = s + 1; isspace(*d); d++) ;
+ if (!*d)
+ s = d - 1;
+ *s = 127;
+ XTERM(';');
+ case ',':
+ tmp = *s++;
+ XTERM(tmp);
+ case '~':
+ s++;
+ yylval = string("~",1);
+ XTERM(MATCHOP);
+ case '+':
+ case '-':
+ if (s[1] == *s) {
+ s++;
+ if (*s++ == '+')
+ XTERM(INCR);
+ else
+ XTERM(DECR);
+ }
+ /* FALL THROUGH */
+ case '*':
+ case '%':
+ case '^':
+ tmp = *s++;
+ if (*s == '=') {
+ if (tmp == '^')
+ yylval = string("**=",3);
+ else
+ yylval = string(s-1,2);
+ s++;
+ XTERM(ASGNOP);
+ }
+ XTERM(tmp);
+ case '&':
+ s++;
+ tmp = *s++;
+ if (tmp == '&')
+ XTERM(ANDAND);
+ s--;
+ XTERM('&');
+ case '|':
+ s++;
+ tmp = *s++;
+ if (tmp == '|')
+ XTERM(OROR);
+ s--;
+ while (*s == ' ' || *s == '\t')
+ s++;
+ if (strnEQ(s,"getline",7))
+ XTERM('p');
+ else
+ XTERM('|');
+ case '=':
+ s++;
+ tmp = *s++;
+ if (tmp == '=') {
+ yylval = string("==",2);
+ XTERM(RELOP);
+ }
+ s--;
+ yylval = string("=",1);
+ XTERM(ASGNOP);
+ case '!':
+ s++;
+ tmp = *s++;
+ if (tmp == '=') {
+ yylval = string("!=",2);
+ XTERM(RELOP);
+ }
+ if (tmp == '~') {
+ yylval = string("!~",2);
+ XTERM(MATCHOP);
+ }
+ s--;
+ XTERM(NOT);
+ case '<':
+ s++;
+ tmp = *s++;
+ if (tmp == '=') {
+ yylval = string("<=",2);
+ XTERM(RELOP);
+ }
+ s--;
+ XTERM('<');
+ case '>':
+ s++;
+ tmp = *s++;
+ if (tmp == '>') {
+ yylval = string(">>",2);
+ XTERM(GRGR);
+ }
+ if (tmp == '=') {
+ yylval = string(">=",2);
+ XTERM(RELOP);
+ }
+ s--;
+ XTERM('>');
+
+#define SNARFWORD \
+ d = tokenbuf; \
+ while (isalpha(*s) || isdigit(*s) || *s == '_') \
+ *d++ = *s++; \
+ *d = '\0'; \
+ d = tokenbuf; \
+ if (*s == '(') \
+ idtype = USERFUN; \
+ else \
+ idtype = VAR;
+
+ case '$':
+ s++;
+ if (*s == '0') {
+ s++;
+ do_chop = TRUE;
+ need_entire = TRUE;
+ idtype = VAR;
+ ID("0");
+ }
+ do_split = TRUE;
+ if (isdigit(*s)) {
+ for (d = s; isdigit(*s); s++) ;
+ yylval = string(d,s-d);
+ tmp = atoi(d);
+ if (tmp > maxfld)
+ maxfld = tmp;
+ XOP(FIELD);
+ }
+ split_to_array = set_array_base = TRUE;
+ XOP(VFIELD);
+
+ case '/': /* may either be division or pattern */
+ if (expectterm) {
+ s = scanpat(s);
+ XTERM(REGEX);
+ }
+ tmp = *s++;
+ if (*s == '=') {
+ yylval = string("/=",2);
+ s++;
+ XTERM(ASGNOP);
+ }
+ XTERM(tmp);
+
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': case '.':
+ s = scannum(s);
+ XOP(NUMBER);
+ case '"':
+ s++;
+ s = cpy2(tokenbuf,s,s[-1]);
+ if (!*s)
+ fatal("String not terminated:\n%s",str_get(linestr));
+ s++;
+ yylval = string(tokenbuf,0);
+ XOP(STRING);
+
+ case 'a': case 'A':
+ SNARFWORD;
+ if (strEQ(d,"ARGC"))
+ set_array_base = TRUE;
+ if (strEQ(d,"ARGV")) {
+ yylval=numary(string("ARGV",0));
+ XOP(VAR);
+ }
+ if (strEQ(d,"atan2")) {
+ yylval = OATAN2;
+ XTERM(FUNN);
+ }
+ ID(d);
+ case 'b': case 'B':
+ SNARFWORD;
+ if (strEQ(d,"break"))
+ XTERM(BREAK);
+ if (strEQ(d,"BEGIN"))
+ XTERM(BEGIN);
+ ID(d);
+ case 'c': case 'C':
+ SNARFWORD;
+ if (strEQ(d,"continue"))
+ XTERM(CONTINUE);
+ if (strEQ(d,"cos")) {
+ yylval = OCOS;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"close")) {
+ do_fancy_opens = 1;
+ yylval = OCLOSE;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"chdir"))
+ *d = toupper(*d);
+ else if (strEQ(d,"crypt"))
+ *d = toupper(*d);
+ else if (strEQ(d,"chop"))
+ *d = toupper(*d);
+ else if (strEQ(d,"chmod"))
+ *d = toupper(*d);
+ else if (strEQ(d,"chown"))
+ *d = toupper(*d);
+ ID(d);
+ case 'd': case 'D':
+ SNARFWORD;
+ if (strEQ(d,"do"))
+ XTERM(DO);
+ if (strEQ(d,"delete"))
+ XTERM(DELETE);
+ if (strEQ(d,"die"))
+ *d = toupper(*d);
+ ID(d);
+ case 'e': case 'E':
+ SNARFWORD;
+ if (strEQ(d,"END"))
+ XTERM(END);
+ if (strEQ(d,"else"))
+ XTERM(ELSE);
+ if (strEQ(d,"exit")) {
+ saw_line_op = TRUE;
+ XTERM(EXIT);
+ }
+ if (strEQ(d,"exp")) {
+ yylval = OEXP;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"elsif"))
+ *d = toupper(*d);
+ else if (strEQ(d,"eq"))
+ *d = toupper(*d);
+ else if (strEQ(d,"eval"))
+ *d = toupper(*d);
+ else if (strEQ(d,"eof"))
+ *d = toupper(*d);
+ else if (strEQ(d,"each"))
+ *d = toupper(*d);
+ else if (strEQ(d,"exec"))
+ *d = toupper(*d);
+ ID(d);
+ case 'f': case 'F':
+ SNARFWORD;
+ if (strEQ(d,"FS")) {
+ saw_FS++;
+ if (saw_FS == 1 && in_begin) {
+ for (d = s; *d && isspace(*d); d++) ;
+ if (*d == '=') {
+ for (d++; *d && isspace(*d); d++) ;
+ if (*d == '"' && d[2] == '"')
+ const_FS = d[1];
+ }
+ }
+ ID(tokenbuf);
+ }
+ if (strEQ(d,"for"))
+ XTERM(FOR);
+ else if (strEQ(d,"function"))
+ XTERM(FUNCTION);
+ if (strEQ(d,"FILENAME"))
+ d = "ARGV";
+ if (strEQ(d,"foreach"))
+ *d = toupper(*d);
+ else if (strEQ(d,"format"))
+ *d = toupper(*d);
+ else if (strEQ(d,"fork"))
+ *d = toupper(*d);
+ else if (strEQ(d,"fh"))
+ *d = toupper(*d);
+ ID(d);
+ case 'g': case 'G':
+ SNARFWORD;
+ if (strEQ(d,"getline"))
+ XTERM(GETLINE);
+ if (strEQ(d,"gsub"))
+ XTERM(GSUB);
+ if (strEQ(d,"ge"))
+ *d = toupper(*d);
+ else if (strEQ(d,"gt"))
+ *d = toupper(*d);
+ else if (strEQ(d,"goto"))
+ *d = toupper(*d);
+ else if (strEQ(d,"gmtime"))
+ *d = toupper(*d);
+ ID(d);
+ case 'h': case 'H':
+ SNARFWORD;
+ if (strEQ(d,"hex"))
+ *d = toupper(*d);
+ ID(d);
+ case 'i': case 'I':
+ SNARFWORD;
+ if (strEQ(d,"if"))
+ XTERM(IF);
+ if (strEQ(d,"in"))
+ XTERM(IN);
+ if (strEQ(d,"index")) {
+ set_array_base = TRUE;
+ XTERM(INDEX);
+ }
+ if (strEQ(d,"int")) {
+ yylval = OINT;
+ XTERM(FUN1);
+ }
+ ID(d);
+ case 'j': case 'J':
+ SNARFWORD;
+ if (strEQ(d,"join"))
+ *d = toupper(*d);
+ ID(d);
+ case 'k': case 'K':
+ SNARFWORD;
+ if (strEQ(d,"keys"))
+ *d = toupper(*d);
+ else if (strEQ(d,"kill"))
+ *d = toupper(*d);
+ ID(d);
+ case 'l': case 'L':
+ SNARFWORD;
+ if (strEQ(d,"length")) {
+ yylval = OLENGTH;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"log")) {
+ yylval = OLOG;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"last"))
+ *d = toupper(*d);
+ else if (strEQ(d,"local"))
+ *d = toupper(*d);
+ else if (strEQ(d,"lt"))
+ *d = toupper(*d);
+ else if (strEQ(d,"le"))
+ *d = toupper(*d);
+ else if (strEQ(d,"locatime"))
+ *d = toupper(*d);
+ else if (strEQ(d,"link"))
+ *d = toupper(*d);
+ ID(d);
+ case 'm': case 'M':
+ SNARFWORD;
+ if (strEQ(d,"match")) {
+ set_array_base = TRUE;
+ XTERM(MATCH);
+ }
+ if (strEQ(d,"m"))
+ *d = toupper(*d);
+ ID(d);
+ case 'n': case 'N':
+ SNARFWORD;
+ if (strEQ(d,"NF"))
+ do_chop = do_split = split_to_array = set_array_base = TRUE;
+ if (strEQ(d,"next")) {
+ saw_line_op = TRUE;
+ XTERM(NEXT);
+ }
+ if (strEQ(d,"ne"))
+ *d = toupper(*d);
+ ID(d);
+ case 'o': case 'O':
+ SNARFWORD;
+ if (strEQ(d,"ORS")) {
+ saw_ORS = TRUE;
+ d = "\\";
+ }
+ if (strEQ(d,"OFS")) {
+ saw_OFS = TRUE;
+ d = ",";
+ }
+ if (strEQ(d,"OFMT")) {
+ d = "#";
+ }
+ if (strEQ(d,"open"))
+ *d = toupper(*d);
+ else if (strEQ(d,"ord"))
+ *d = toupper(*d);
+ else if (strEQ(d,"oct"))
+ *d = toupper(*d);
+ ID(d);
+ case 'p': case 'P':
+ SNARFWORD;
+ if (strEQ(d,"print")) {
+ XTERM(PRINT);
+ }
+ if (strEQ(d,"printf")) {
+ XTERM(PRINTF);
+ }
+ if (strEQ(d,"push"))
+ *d = toupper(*d);
+ else if (strEQ(d,"pop"))
+ *d = toupper(*d);
+ ID(d);
+ case 'q': case 'Q':
+ SNARFWORD;
+ ID(d);
+ case 'r': case 'R':
+ SNARFWORD;
+ if (strEQ(d,"RS")) {
+ d = "/";
+ saw_RS = TRUE;
+ }
+ if (strEQ(d,"rand")) {
+ yylval = ORAND;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"return"))
+ XTERM(RET);
+ if (strEQ(d,"reset"))
+ *d = toupper(*d);
+ else if (strEQ(d,"redo"))
+ *d = toupper(*d);
+ else if (strEQ(d,"rename"))
+ *d = toupper(*d);
+ ID(d);
+ case 's': case 'S':
+ SNARFWORD;
+ if (strEQ(d,"split")) {
+ set_array_base = TRUE;
+ XOP(SPLIT);
+ }
+ if (strEQ(d,"substr")) {
+ set_array_base = TRUE;
+ XTERM(SUBSTR);
+ }
+ if (strEQ(d,"sub"))
+ XTERM(SUB);
+ if (strEQ(d,"sprintf"))
+ XTERM(SPRINTF);
+ if (strEQ(d,"sqrt")) {
+ yylval = OSQRT;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"SUBSEP")) {
+ d = ";";
+ }
+ if (strEQ(d,"sin")) {
+ yylval = OSIN;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"srand")) {
+ yylval = OSRAND;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"system")) {
+ yylval = OSYSTEM;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"s"))
+ *d = toupper(*d);
+ else if (strEQ(d,"shift"))
+ *d = toupper(*d);
+ else if (strEQ(d,"select"))
+ *d = toupper(*d);
+ else if (strEQ(d,"seek"))
+ *d = toupper(*d);
+ else if (strEQ(d,"stat"))
+ *d = toupper(*d);
+ else if (strEQ(d,"study"))
+ *d = toupper(*d);
+ else if (strEQ(d,"sleep"))
+ *d = toupper(*d);
+ else if (strEQ(d,"symlink"))
+ *d = toupper(*d);
+ else if (strEQ(d,"sort"))
+ *d = toupper(*d);
+ ID(d);
+ case 't': case 'T':
+ SNARFWORD;
+ if (strEQ(d,"tr"))
+ *d = toupper(*d);
+ else if (strEQ(d,"tell"))
+ *d = toupper(*d);
+ else if (strEQ(d,"time"))
+ *d = toupper(*d);
+ else if (strEQ(d,"times"))
+ *d = toupper(*d);
+ ID(d);
+ case 'u': case 'U':
+ SNARFWORD;
+ if (strEQ(d,"until"))
+ *d = toupper(*d);
+ else if (strEQ(d,"unless"))
+ *d = toupper(*d);
+ else if (strEQ(d,"umask"))
+ *d = toupper(*d);
+ else if (strEQ(d,"unshift"))
+ *d = toupper(*d);
+ else if (strEQ(d,"unlink"))
+ *d = toupper(*d);
+ else if (strEQ(d,"utime"))
+ *d = toupper(*d);
+ ID(d);
+ case 'v': case 'V':
+ SNARFWORD;
+ if (strEQ(d,"values"))
+ *d = toupper(*d);
+ ID(d);
+ case 'w': case 'W':
+ SNARFWORD;
+ if (strEQ(d,"while"))
+ XTERM(WHILE);
+ if (strEQ(d,"write"))
+ *d = toupper(*d);
+ else if (strEQ(d,"wait"))
+ *d = toupper(*d);
+ ID(d);
+ case 'x': case 'X':
+ SNARFWORD;
+ if (strEQ(d,"x"))
+ *d = toupper(*d);
+ ID(d);
+ case 'y': case 'Y':
+ SNARFWORD;
+ if (strEQ(d,"y"))
+ *d = toupper(*d);
+ ID(d);
+ case 'z': case 'Z':
+ SNARFWORD;
+ ID(d);
+ }
+}
+
+char *
+scanpat(s)
+register char *s;
+{
+ register char *d;
+
+ switch (*s++) {
+ case '/':
+ break;
+ default:
+ fatal("Search pattern not found:\n%s",str_get(linestr));
+ }
+
+ d = tokenbuf;
+ for (; *s; s++,d++) {
+ if (*s == '\\') {
+ if (s[1] == '/')
+ *d++ = *s++;
+ else if (s[1] == '\\')
+ *d++ = *s++;
+ }
+ else if (*s == '[') {
+ *d++ = *s++;
+ do {
+ if (*s == '\\' && s[1])
+ *d++ = *s++;
+ if (*s == '/' || (*s == '-' && s[1] == ']'))
+ *d++ = '\\';
+ *d++ = *s++;
+ } while (*s && *s != ']');
+ }
+ else if (*s == '/')
+ break;
+ *d = *s;
+ }
+ *d = '\0';
+
+ if (!*s)
+ fatal("Search pattern not terminated:\n%s",str_get(linestr));
+ s++;
+ yylval = string(tokenbuf,0);
+ return s;
+}
+
+yyerror(s)
+char *s;
+{
+ fprintf(stderr,"%s in file %s at line %d\n",
+ s,filename,line);
+}
+
+char *
+scannum(s)
+register char *s;
+{
+ register char *d;
+
+ switch (*s) {
+ case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9': case '0' : case '.':
+ d = tokenbuf;
+ while (isdigit(*s)) {
+ *d++ = *s++;
+ }
+ if (*s == '.' && index("0123456789eE",s[1])) {
+ *d++ = *s++;
+ while (isdigit(*s)) {
+ *d++ = *s++;
+ }
+ }
+ if (index("eE",*s) && index("+-0123456789",s[1])) {
+ *d++ = *s++;
+ if (*s == '+' || *s == '-')
+ *d++ = *s++;
+ while (isdigit(*s))
+ *d++ = *s++;
+ }
+ *d = '\0';
+ yylval = string(tokenbuf,0);
+ break;
+ }
+ return s;
+}
+
+string(ptr,len)
+char *ptr;
+{
+ int retval = mop;
+
+ ops[mop++].ival = OSTRING + (1<<8);
+ if (!len)
+ len = strlen(ptr);
+ ops[mop].cval = safemalloc(len+1);
+ strncpy(ops[mop].cval,ptr,len);
+ ops[mop++].cval[len] = '\0';
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+oper0(type)
+int type;
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+oper1(type,arg1)
+int type;
+int arg1;
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (1<<8);
+ ops[mop++].ival = arg1;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+oper2(type,arg1,arg2)
+int type;
+int arg1;
+int arg2;
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (2<<8);
+ ops[mop++].ival = arg1;
+ ops[mop++].ival = arg2;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+oper3(type,arg1,arg2,arg3)
+int type;
+int arg1;
+int arg2;
+int arg3;
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (3<<8);
+ ops[mop++].ival = arg1;
+ ops[mop++].ival = arg2;
+ ops[mop++].ival = arg3;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+oper4(type,arg1,arg2,arg3,arg4)
+int type;
+int arg1;
+int arg2;
+int arg3;
+int arg4;
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (4<<8);
+ ops[mop++].ival = arg1;
+ ops[mop++].ival = arg2;
+ ops[mop++].ival = arg3;
+ ops[mop++].ival = arg4;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+oper5(type,arg1,arg2,arg3,arg4,arg5)
+int type;
+int arg1;
+int arg2;
+int arg3;
+int arg4;
+int arg5;
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (5<<8);
+ ops[mop++].ival = arg1;
+ ops[mop++].ival = arg2;
+ ops[mop++].ival = arg3;
+ ops[mop++].ival = arg4;
+ ops[mop++].ival = arg5;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+int depth = 0;
+
+dump(branch)
+int branch;
+{
+ register int type;
+ register int len;
+ register int i;
+
+ type = ops[branch].ival;
+ len = type >> 8;
+ type &= 255;
+ for (i=depth; i; i--)
+ printf(" ");
+ if (type == OSTRING) {
+ printf("%-5d\"%s\"\n",branch,ops[branch+1].cval);
+ }
+ else {
+ printf("(%-5d%s %d\n",branch,opname[type],len);
+ depth++;
+ for (i=1; i<=len; i++)
+ dump(ops[branch+i].ival);
+ depth--;
+ for (i=depth; i; i--)
+ printf(" ");
+ printf(")\n");
+ }
+}
+
+bl(arg,maybe)
+int arg;
+int maybe;
+{
+ if (!arg)
+ return 0;
+ else if ((ops[arg].ival & 255) != OBLOCK)
+ return oper2(OBLOCK,arg,maybe);
+ else if ((ops[arg].ival >> 8) < 2)
+ return oper2(OBLOCK,ops[arg+1].ival,maybe);
+ else
+ return arg;
+}
+
+fixup(str)
+STR *str;
+{
+ register char *s;
+ register char *t;
+
+ for (s = str->str_ptr; *s; s++) {
+ if (*s == ';' && s[1] == ' ' && s[2] == '\n') {
+ strcpy(s+1,s+2);
+ s++;
+ }
+ else if (*s == '\n') {
+ for (t = s+1; isspace(*t & 127); t++) ;
+ t--;
+ while (isspace(*t & 127) && *t != '\n') t--;
+ if (*t == '\n' && t-s > 1) {
+ if (s[-1] == '{')
+ s--;
+ strcpy(s+1,t);
+ }
+ s++;
+ }
+ }
+}
+
+putlines(str)
+STR *str;
+{
+ register char *d, *s, *t, *e;
+ register int pos, newpos;
+
+ d = tokenbuf;
+ pos = 0;
+ for (s = str->str_ptr; *s; s++) {
+ *d++ = *s;
+ pos++;
+ if (*s == '\n') {
+ *d = '\0';
+ d = tokenbuf;
+ pos = 0;
+ putone();
+ }
+ else if (*s == '\t')
+ pos += 7;
+ if (pos > 78) { /* split a long line? */
+ *d-- = '\0';
+ newpos = 0;
+ for (t = tokenbuf; isspace(*t & 127); t++) {
+ if (*t == '\t')
+ newpos += 8;
+ else
+ newpos += 1;
+ }
+ e = d;
+ while (d > tokenbuf && (*d != ' ' || d[-1] != ';'))
+ d--;
+ if (d < t+10) {
+ d = e;
+ while (d > tokenbuf &&
+ (*d != ' ' || d[-1] != '|' || d[-2] != '|') )
+ d--;
+ }
+ if (d < t+10) {
+ d = e;
+ while (d > tokenbuf &&
+ (*d != ' ' || d[-1] != '&' || d[-2] != '&') )
+ d--;
+ }
+ if (d < t+10) {
+ d = e;
+ while (d > tokenbuf && (*d != ' ' || d[-1] != ','))
+ d--;
+ }
+ if (d < t+10) {
+ d = e;
+ while (d > tokenbuf && *d != ' ')
+ d--;
+ }
+ if (d > t+3) {
+ char save[2048];
+ strcpy(save, d);
+ *d = '\n';
+ d[1] = '\0';
+ putone();
+ putchar('\n');
+ if (d[-1] != ';' && !(newpos % 4)) {
+ *t++ = ' ';
+ *t++ = ' ';
+ newpos += 2;
+ }
+ strcpy(t,save+1);
+ newpos += strlen(t);
+ d = t + strlen(t);
+ pos = newpos;
+ }
+ else
+ d = e + 1;
+ }
+ }
+}
+
+putone()
+{
+ register char *t;
+
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (*t == 127) {
+ *t = ' ';
+ strcpy(t+strlen(t)-1, "\t#???\n");
+ checkers++;
+ }
+ }
+ t = tokenbuf;
+ if (*t == '#') {
+ if (strnEQ(t,"#!/bin/awk",10) || strnEQ(t,"#! /bin/awk",11))
+ return;
+ if (strnEQ(t,"#!/usr/bin/awk",14) || strnEQ(t,"#! /usr/bin/awk",15))
+ return;
+ }
+ fputs(tokenbuf,stdout);
+}
+
+numary(arg)
+int arg;
+{
+ STR *key;
+ int dummy;
+
+ key = walk(0,0,arg,&dummy,P_MIN);
+ str_cat(key,"[]");
+ hstore(symtab,key->str_ptr,str_make("1"));
+ str_free(key);
+ set_array_base = TRUE;
+ return arg;
+}
+
+rememberargs(arg)
+int arg;
+{
+ int type;
+ STR *str;
+
+ if (!arg)
+ return arg;
+ type = ops[arg].ival & 255;
+ if (type == OCOMMA) {
+ rememberargs(ops[arg+1].ival);
+ rememberargs(ops[arg+3].ival);
+ }
+ else if (type == OVAR) {
+ str = str_new(0);
+ hstore(curarghash,ops[ops[arg+1].ival+1].cval,str);
+ }
+ else
+ fatal("panic: unknown argument type %d, line %d\n",type,line);
+ return arg;
+}
+
+aryrefarg(arg)
+int arg;
+{
+ int type = ops[arg].ival & 255;
+ STR *str;
+
+ if (type != OSTRING)
+ fatal("panic: aryrefarg %d, line %d\n",type,line);
+ str = hfetch(curarghash,ops[arg+1].cval);
+ if (str)
+ str_set(str,"*");
+ return arg;
+}
+
+fixfargs(name,arg,prevargs)
+int name;
+int arg;
+int prevargs;
+{
+ int type;
+ STR *str;
+ int numargs;
+
+ if (!arg)
+ return prevargs;
+ type = ops[arg].ival & 255;
+ if (type == OCOMMA) {
+ numargs = fixfargs(name,ops[arg+1].ival,prevargs);
+ numargs = fixfargs(name,ops[arg+3].ival,numargs);
+ }
+ else if (type == OVAR) {
+ str = hfetch(curarghash,ops[ops[arg+1].ival+1].cval);
+ if (strEQ(str_get(str),"*")) {
+ char tmpbuf[128];
+
+ str_set(str,""); /* in case another routine has this */
+ ops[arg].ival &= ~255;
+ ops[arg].ival |= OSTAR;
+ sprintf(tmpbuf,"%s:%d",ops[name+1].cval,prevargs);
+ fprintf(stderr,"Adding %s\n",tmpbuf);
+ str = str_new(0);
+ str_set(str,"*");
+ hstore(curarghash,tmpbuf,str);
+ }
+ numargs = prevargs + 1;
+ }
+ else
+ fatal("panic: unknown argument type %d, arg %d, line %d\n",
+ type,prevargs+1,line);
+ return numargs;
+}
+
+fixrargs(name,arg,prevargs)
+char *name;
+int arg;
+int prevargs;
+{
+ int type;
+ STR *str;
+ int numargs;
+
+ if (!arg)
+ return prevargs;
+ type = ops[arg].ival & 255;
+ if (type == OCOMMA) {
+ numargs = fixrargs(name,ops[arg+1].ival,prevargs);
+ numargs = fixrargs(name,ops[arg+3].ival,numargs);
+ }
+ else {
+ char tmpbuf[128];
+
+ sprintf(tmpbuf,"%s:%d",name,prevargs);
+ str = hfetch(curarghash,tmpbuf);
+ fprintf(stderr,"Looking for %s\n",tmpbuf);
+ if (str && strEQ(str->str_ptr,"*")) {
+ if (type == OVAR || type == OSTAR) {
+ ops[arg].ival &= ~255;
+ ops[arg].ival |= OSTAR;
+ }
+ else
+ fatal("Can't pass expression by reference as arg %d of %s\n",
+ prevargs+1, name);
+ }
+ numargs = prevargs + 1;
+ }
+ return numargs;
+}
+
--- /dev/null
+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
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting cflags (with variable substitutions)"
+: This section of the file will have variable substitutions done on it.
+: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
+: Protect any dollar signs and backticks that you do not want interpreted
+: by putting a backslash in front. You may delete these comments.
+$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
+ ;;
+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
+!NO!SUBS!
+chmod +x cflags
+$eunicefix cflags
--- /dev/null
+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
+ ;;
+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)"
+: 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 >find2perl <<!GROK!THIS!
+#!$bin/perl
+
+\$bin = "$bin";
+
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>find2perl <<'!NO!SUBS!'
+
+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
+
+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 = '19' . $year;
+ }
+ 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)/) {
+ $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'";
+}
+!NO!SUBS!
+chmod 755 find2perl
+$eunicefix find2perl
--- /dev/null
+/* $RCSfile: handy.h,v $$Revision: 4.0.1.2 $$Date: 91/06/07 12:15:43 $
+ *
+ * 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: handy.h,v $
+ * 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)
+#define Nullch Null(char*)
+#define Nullfp Null(FILE*)
+
+#define bool char
+#ifdef TRUE
+#undef TRUE
+#endif
+#ifdef FALSE
+#undef FALSE
+#endif
+#define TRUE (1)
+#define FALSE (0)
+
+#define Ctl(ch) (ch & 037)
+
+#define strNE(s1,s2) (strcmp(s1,s2))
+#define strEQ(s1,s2) (!strcmp(s1,s2))
+#define strLT(s1,s2) (strcmp(s1,s2) < 0)
+#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
+#define strGT(s1,s2) (strcmp(s1,s2) > 0)
+#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
+#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
+#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
--- /dev/null
+/* $RCSfile: hash.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:15:55 $
+ *
+ * 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: hash.c,v $
+ * 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>
+#include "EXTERN.h"
+#include "handy.h"
+#include "util.h"
+#include "a2p.h"
+
+STR *
+hfetch(tb,key)
+register HASH *tb;
+char *key;
+{
+ register char *s;
+ register int i;
+ register int hash;
+ register HENT *entry;
+
+ if (!tb)
+ return Nullstr;
+ for (s=key, i=0, hash = 0;
+ /* while */ *s;
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+ entry = tb->tbl_array[hash & tb->tbl_max];
+ for (; entry; entry = entry->hent_next) {
+ if (entry->hent_hash != hash) /* strings can't be equal */
+ continue;
+ if (strNE(entry->hent_key,key)) /* is this it? */
+ continue;
+ return entry->hent_val;
+ }
+ return Nullstr;
+}
+
+bool
+hstore(tb,key,val)
+register HASH *tb;
+char *key;
+STR *val;
+{
+ register char *s;
+ register int i;
+ register int hash;
+ register HENT *entry;
+ register HENT **oentry;
+
+ if (!tb)
+ return FALSE;
+ for (s=key, i=0, hash = 0;
+ /* while */ *s;
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+
+ oentry = &(tb->tbl_array[hash & tb->tbl_max]);
+ i = 1;
+
+ for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
+ if (entry->hent_hash != hash) /* strings can't be equal */
+ continue;
+ if (strNE(entry->hent_key,key)) /* is this it? */
+ continue;
+ /*NOSTRICT*/
+ safefree((char*)entry->hent_val);
+ entry->hent_val = val;
+ return TRUE;
+ }
+ /*NOSTRICT*/
+ entry = (HENT*) safemalloc(sizeof(HENT));
+
+ entry->hent_key = savestr(key);
+ entry->hent_val = val;
+ entry->hent_hash = hash;
+ entry->hent_next = *oentry;
+ *oentry = entry;
+
+ if (i) { /* initial entry? */
+ tb->tbl_fill++;
+ if ((tb->tbl_fill * 100 / (tb->tbl_max + 1)) > FILLPCT)
+ hsplit(tb);
+ }
+
+ return FALSE;
+}
+
+#ifdef NOTUSED
+bool
+hdelete(tb,key)
+register HASH *tb;
+char *key;
+{
+ register char *s;
+ register int i;
+ register int hash;
+ register HENT *entry;
+ register HENT **oentry;
+
+ if (!tb)
+ return FALSE;
+ for (s=key, i=0, hash = 0;
+ /* while */ *s;
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+
+ oentry = &(tb->tbl_array[hash & tb->tbl_max]);
+ entry = *oentry;
+ i = 1;
+ for (; entry; i=0, oentry = &entry->hent_next, entry = entry->hent_next) {
+ if (entry->hent_hash != hash) /* strings can't be equal */
+ continue;
+ if (strNE(entry->hent_key,key)) /* is this it? */
+ continue;
+ safefree((char*)entry->hent_val);
+ safefree(entry->hent_key);
+ *oentry = entry->hent_next;
+ safefree((char*)entry);
+ if (i)
+ tb->tbl_fill--;
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif
+
+hsplit(tb)
+HASH *tb;
+{
+ int oldsize = tb->tbl_max + 1;
+ register int newsize = oldsize * 2;
+ register int i;
+ register HENT **a;
+ register HENT **b;
+ register HENT *entry;
+ register HENT **oentry;
+
+ a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*));
+ bzero((char*)&a[oldsize], oldsize * sizeof(HENT*)); /* zero second half */
+ tb->tbl_max = --newsize;
+ tb->tbl_array = a;
+
+ for (i=0; i<oldsize; i++,a++) {
+ if (!*a) /* non-existent */
+ continue;
+ b = a+oldsize;
+ for (oentry = a, entry = *a; entry; entry = *oentry) {
+ if ((entry->hent_hash & newsize) != i) {
+ *oentry = entry->hent_next;
+ entry->hent_next = *b;
+ if (!*b)
+ tb->tbl_fill++;
+ *b = entry;
+ continue;
+ }
+ else
+ oentry = &entry->hent_next;
+ }
+ if (!*a) /* everything moved */
+ tb->tbl_fill--;
+ }
+}
+
+HASH *
+hnew()
+{
+ register HASH *tb = (HASH*)safemalloc(sizeof(HASH));
+
+ tb->tbl_array = (HENT**) safemalloc(8 * sizeof(HENT*));
+ tb->tbl_fill = 0;
+ tb->tbl_max = 7;
+ hiterinit(tb); /* so each() will start off right */
+ bzero((char*)tb->tbl_array, 8 * sizeof(HENT*));
+ return tb;
+}
+
+#ifdef NOTUSED
+hshow(tb)
+register HASH *tb;
+{
+ fprintf(stderr,"%5d %4d (%2d%%)\n",
+ tb->tbl_max+1,
+ tb->tbl_fill,
+ tb->tbl_fill * 100 / (tb->tbl_max+1));
+}
+#endif
+
+hiterinit(tb)
+register HASH *tb;
+{
+ tb->tbl_riter = -1;
+ tb->tbl_eiter = Null(HENT*);
+ return tb->tbl_fill;
+}
+
+HENT *
+hiternext(tb)
+register HASH *tb;
+{
+ register HENT *entry;
+
+ entry = tb->tbl_eiter;
+ do {
+ if (entry)
+ entry = entry->hent_next;
+ if (!entry) {
+ tb->tbl_riter++;
+ if (tb->tbl_riter > tb->tbl_max) {
+ tb->tbl_riter = -1;
+ break;
+ }
+ entry = tb->tbl_array[tb->tbl_riter];
+ }
+ } while (!entry);
+
+ tb->tbl_eiter = entry;
+ return entry;
+}
+
+char *
+hiterkey(entry)
+register HENT *entry;
+{
+ return entry->hent_key;
+}
+
+STR *
+hiterval(entry)
+register HENT *entry;
+{
+ return entry->hent_val;
+}
--- /dev/null
+/* $RCSfile: hash.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:16:04 $
+ *
+ * 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: hash.h,v $
+ * 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 */
+
+#ifdef DOINIT
+char coeff[] = {
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
+#else
+extern char coeff[];
+#endif
+
+typedef struct hentry HENT;
+
+struct hentry {
+ HENT *hent_next;
+ char *hent_key;
+ STR *hent_val;
+ int hent_hash;
+};
+
+struct htbl {
+ HENT **tbl_array;
+ int tbl_max;
+ int tbl_fill;
+ int tbl_riter; /* current root of iterator */
+ HENT *tbl_eiter; /* current entry of iterator */
+};
+
+STR *hfetch();
+bool hstore();
+bool hdelete();
+HASH *hnew();
+int hiterinit();
+HENT *hiternext();
+char *hiterkey();
+STR *hiterval();
--- /dev/null
+: 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)"
+: 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 >s2p <<!GROK!THIS!
+#!$bin/perl
+
+\$bin = '$bin';
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>s2p <<'!NO!SUBS!'
+
+# $RCSfile: s2p.SH,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:18 $
+#
+# $Log: s2p.SH,v $
+# 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");
+ }
+ $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 ($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 = '$';
+ $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 ($_ = &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;
+}
+
+!NO!SUBS!
+chmod 755 s2p
+$eunicefix s2p
--- /dev/null
+.rn '' }`
+''' $RCSfile: s2p.man,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:57 $
+'''
+''' $Log: s2p.man,v $
+''' 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
+.PP
+\fB\\$1\fR
+.PP
+..
+.de Sp
+.if t .sp .5v
+.if n .sp
+..
+.de Ip
+.br
+.ie \\n.$>=3 .ne \\$3
+.el .ne 3
+.IP "\\$1" \\$2
+..
+'''
+''' Set up \*(-- to give an unbreakable dash;
+''' string Tr holds user defined translation string.
+''' Bell System Logo is used as a dummy character.
+'''
+.tr \(*W-|\(bv\*(Tr
+.ie n \{\
+.ds -- \(*W-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
+.ds L" ""
+.ds R" ""
+.ds L' '
+.ds R' '
+'br\}
+.el\{\
+.ds -- \(em\|
+.tr \*(Tr
+.ds L" ``
+.ds R" ''
+.ds L' `
+.ds R' '
+'br\}
+.TH S2P 1 NEW
+.SH NAME
+s2p - Sed to Perl translator
+.SH SYNOPSIS
+.B s2p [options] filename
+.SH DESCRIPTION
+.I S2p
+takes a sed script specified on the command line (or from standard input)
+and produces a comparable
+.I perl
+script on the standard output.
+.Sh "Options"
+Options include:
+.TP 5
+.B \-D<number>
+sets debugging flags.
+.TP 5
+.B \-n
+specifies that this sed script was always invoked with a sed -n.
+Otherwise a switch parser is prepended to the front of the script.
+.TP 5
+.B \-p
+specifies that this sed script was never invoked with a sed -n.
+Otherwise a switch parser is prepended to the front of the script.
+.Sh "Considerations"
+The perl script produced looks very sed-ish, and there may very well be
+better ways to express what you want to do in perl.
+For instance, s2p does not make any use of the split operator, but you might
+want to.
+.PP
+The perl script you end up with may be either faster or slower than the original
+sed script.
+If you're only interested in speed you'll just have to try it both ways.
+Of course, if you want to do something sed doesn't do, you have no choice.
+It's often possible to speed up the perl script by various methods, such
+as deleting all references to $\e and chop.
+.SH ENVIRONMENT
+S2p uses no environment variables.
+.SH AUTHOR
+Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
+.SH FILES
+.SH SEE ALSO
+perl The perl compiler/interpreter
+.br
+a2p awk to perl translator
+.SH DIAGNOSTICS
+.SH BUGS
+.rn }` ''
--- /dev/null
+/* $RCSfile: str.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20:08 $
+ *
+ * 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: str.c,v $
+ * 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"
+#include "EXTERN.h"
+#include "util.h"
+#include "a2p.h"
+
+str_numset(str,num)
+register STR *str;
+double num;
+{
+ str->str_nval = num;
+ str->str_pok = 0; /* invalidate pointer */
+ str->str_nok = 1; /* validate number */
+}
+
+char *
+str_2ptr(str)
+register STR *str;
+{
+ register char *s;
+
+ if (!str)
+ return "";
+ GROWSTR(&(str->str_ptr), &(str->str_len), 24);
+ s = str->str_ptr;
+ if (str->str_nok) {
+ sprintf(s,"%.20g",str->str_nval);
+ while (*s) s++;
+ }
+ *s = '\0';
+ str->str_cur = s - str->str_ptr;
+ str->str_pok = 1;
+#ifdef DEBUGGING
+ if (debug & 32)
+ fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr);
+#endif
+ return str->str_ptr;
+}
+
+double
+str_2num(str)
+register STR *str;
+{
+ if (!str)
+ return 0.0;
+ if (str->str_len && str->str_pok)
+ str->str_nval = atof(str->str_ptr);
+ else
+ str->str_nval = 0.0;
+ str->str_nok = 1;
+#ifdef DEBUGGING
+ if (debug & 32)
+ fprintf(stderr,"0x%lx num(%g)\n",str,str->str_nval);
+#endif
+ return str->str_nval;
+}
+
+str_sset(dstr,sstr)
+STR *dstr;
+register STR *sstr;
+{
+ if (!sstr)
+ str_nset(dstr,No,0);
+ else if (sstr->str_nok)
+ str_numset(dstr,sstr->str_nval);
+ else if (sstr->str_pok)
+ str_nset(dstr,sstr->str_ptr,sstr->str_cur);
+ else
+ str_nset(dstr,"",0);
+}
+
+str_nset(str,ptr,len)
+register STR *str;
+register char *ptr;
+register int len;
+{
+ GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+ bcopy(ptr,str->str_ptr,len);
+ str->str_cur = len;
+ *(str->str_ptr+str->str_cur) = '\0';
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+str_set(str,ptr)
+register STR *str;
+register char *ptr;
+{
+ register int len;
+
+ if (!ptr)
+ ptr = "";
+ len = strlen(ptr);
+ GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+ bcopy(ptr,str->str_ptr,len+1);
+ str->str_cur = len;
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+str_chop(str,ptr) /* like set but assuming ptr is in str */
+register STR *str;
+register char *ptr;
+{
+ if (!(str->str_pok))
+ str_2ptr(str);
+ str->str_cur -= (ptr - str->str_ptr);
+ bcopy(ptr,str->str_ptr, str->str_cur + 1);
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+str_ncat(str,ptr,len)
+register STR *str;
+register char *ptr;
+register int len;
+{
+ if (!(str->str_pok))
+ str_2ptr(str);
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
+ bcopy(ptr,str->str_ptr+str->str_cur,len);
+ str->str_cur += len;
+ *(str->str_ptr+str->str_cur) = '\0';
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+str_scat(dstr,sstr)
+STR *dstr;
+register STR *sstr;
+{
+ if (!(sstr->str_pok))
+ str_2ptr(sstr);
+ if (sstr)
+ str_ncat(dstr,sstr->str_ptr,sstr->str_cur);
+}
+
+str_cat(str,ptr)
+register STR *str;
+register char *ptr;
+{
+ register int len;
+
+ if (!ptr)
+ return;
+ if (!(str->str_pok))
+ str_2ptr(str);
+ len = strlen(ptr);
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
+ bcopy(ptr,str->str_ptr+str->str_cur,len+1);
+ str->str_cur += len;
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+char *
+str_append_till(str,from,delim,keeplist)
+register STR *str;
+register char *from;
+register int delim;
+char *keeplist;
+{
+ register char *to;
+ register int len;
+
+ if (!from)
+ return Nullch;
+ len = strlen(from);
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+ to = str->str_ptr+str->str_cur;
+ for (; *from; from++,to++) {
+ if (*from == '\\' && from[1] && delim != '\\') {
+ if (!keeplist) {
+ if (from[1] == delim || from[1] == '\\')
+ from++;
+ else
+ *to++ = *from++;
+ }
+ else if (index(keeplist,from[1]))
+ *to++ = *from++;
+ else
+ from++;
+ }
+ else if (*from == delim)
+ break;
+ *to = *from;
+ }
+ *to = '\0';
+ str->str_cur = to - str->str_ptr;
+ return from;
+}
+
+STR *
+str_new(len)
+int len;
+{
+ register STR *str;
+
+ if (freestrroot) {
+ str = freestrroot;
+ freestrroot = str->str_link.str_next;
+ }
+ else {
+ str = (STR *) safemalloc(sizeof(STR));
+ bzero((char*)str,sizeof(STR));
+ }
+ if (len)
+ GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+ return str;
+}
+
+void
+str_grow(str,len)
+register STR *str;
+int len;
+{
+ if (len && str)
+ GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+}
+
+/* make str point to what nstr did */
+
+void
+str_replace(str,nstr)
+register STR *str;
+register STR *nstr;
+{
+ safefree(str->str_ptr);
+ str->str_ptr = nstr->str_ptr;
+ str->str_len = nstr->str_len;
+ str->str_cur = nstr->str_cur;
+ str->str_pok = nstr->str_pok;
+ if (str->str_nok = nstr->str_nok)
+ str->str_nval = nstr->str_nval;
+ safefree((char*)nstr);
+}
+
+void
+str_free(str)
+register STR *str;
+{
+ if (!str)
+ return;
+ if (str->str_len)
+ str->str_ptr[0] = '\0';
+ str->str_cur = 0;
+ str->str_nok = 0;
+ str->str_pok = 0;
+ str->str_link.str_next = freestrroot;
+ freestrroot = str;
+}
+
+str_len(str)
+register STR *str;
+{
+ if (!str)
+ return 0;
+ if (!(str->str_pok))
+ str_2ptr(str);
+ if (str->str_len)
+ return str->str_cur;
+ else
+ return 0;
+}
+
+char *
+str_gets(str,fp)
+register STR *str;
+register FILE *fp;
+{
+#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */
+
+ register char *bp; /* we're going to steal some values */
+ register int cnt; /* from the stdio struct and put EVERYTHING */
+ register STDCHAR *ptr; /* in the innermost loop into registers */
+ register char newline = '\n'; /* (assuming at least 6 registers) */
+ int i;
+ int bpx;
+
+ cnt = fp->_cnt; /* get count into register */
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+ if (str->str_len <= cnt) /* make sure we have the room */
+ GROWSTR(&(str->str_ptr), &(str->str_len), cnt+1);
+ bp = str->str_ptr; /* move these two too to registers */
+ ptr = fp->_ptr;
+ for (;;) {
+ while (--cnt >= 0) {
+ if ((*bp++ = *ptr++) == newline)
+ if (bp <= str->str_ptr || bp[-2] != '\\')
+ goto thats_all_folks;
+ else {
+ line++;
+ bp -= 2;
+ }
+ }
+
+ fp->_cnt = cnt; /* deregisterize cnt and ptr */
+ fp->_ptr = ptr;
+ i = _filbuf(fp); /* get more characters */
+ cnt = fp->_cnt;
+ ptr = fp->_ptr; /* reregisterize cnt and ptr */
+
+ bpx = bp - str->str_ptr; /* prepare for possible relocation */
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + cnt + 1);
+ bp = str->str_ptr + bpx; /* reconstitute our pointer */
+
+ if (i == newline) { /* all done for now? */
+ *bp++ = i;
+ goto thats_all_folks;
+ }
+ else if (i == EOF) /* all done for ever? */
+ goto thats_all_folks;
+ *bp++ = i; /* now go back to screaming loop */
+ }
+
+thats_all_folks:
+ fp->_cnt = cnt; /* put these back or we're in trouble */
+ fp->_ptr = ptr;
+ *bp = '\0';
+ str->str_cur = bp - str->str_ptr; /* set length */
+
+#else /* !STDSTDIO */ /* The big, slow, and stupid way */
+
+ static char buf[4192];
+
+ if (fgets(buf, sizeof buf, fp) != Nullch)
+ str_set(str, buf);
+ else
+ str_set(str, No);
+
+#endif /* STDSTDIO */
+
+ return str->str_cur ? str->str_ptr : Nullch;
+}
+
+void
+str_inc(str)
+register STR *str;
+{
+ register char *d;
+
+ if (!str)
+ return;
+ if (str->str_nok) {
+ str->str_nval += 1.0;
+ str->str_pok = 0;
+ return;
+ }
+ if (!str->str_pok) {
+ str->str_nval = 1.0;
+ str->str_nok = 1;
+ return;
+ }
+ for (d = str->str_ptr; *d && *d != '.'; d++) ;
+ d--;
+ if (!isdigit(*str->str_ptr) || !isdigit(*d) ) {
+ str_numset(str,atof(str->str_ptr) + 1.0); /* punt */
+ return;
+ }
+ while (d >= str->str_ptr) {
+ if (++*d <= '9')
+ return;
+ *(d--) = '0';
+ }
+ /* oh,oh, the number grew */
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + 2);
+ str->str_cur++;
+ for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--)
+ *d = d[-1];
+ *d = '1';
+}
+
+void
+str_dec(str)
+register STR *str;
+{
+ register char *d;
+
+ if (!str)
+ return;
+ if (str->str_nok) {
+ str->str_nval -= 1.0;
+ str->str_pok = 0;
+ return;
+ }
+ if (!str->str_pok) {
+ str->str_nval = -1.0;
+ str->str_nok = 1;
+ return;
+ }
+ for (d = str->str_ptr; *d && *d != '.'; d++) ;
+ d--;
+ if (!isdigit(*str->str_ptr) || !isdigit(*d) || (*d == '0' && d == str->str_ptr)) {
+ str_numset(str,atof(str->str_ptr) - 1.0); /* punt */
+ return;
+ }
+ while (d >= str->str_ptr) {
+ if (--*d >= '0')
+ return;
+ *(d--) = '9';
+ }
+}
+
+/* make a string that will exist for the duration of the expression eval */
+
+STR *
+str_mortal(oldstr)
+STR *oldstr;
+{
+ register STR *str = str_new(0);
+ static long tmps_size = -1;
+
+ str_sset(str,oldstr);
+ if (++tmps_max > tmps_size) {
+ tmps_size = tmps_max;
+ if (!(tmps_size & 127)) {
+ if (tmps_size)
+ tmps_list = (STR**)saferealloc((char*)tmps_list,
+ (tmps_size + 128) * sizeof(STR*) );
+ else
+ tmps_list = (STR**)safemalloc(128 * sizeof(char*));
+ }
+ }
+ tmps_list[tmps_max] = str;
+ return str;
+}
+
+STR *
+str_make(s)
+char *s;
+{
+ register STR *str = str_new(0);
+
+ str_set(str,s);
+ return str;
+}
+
+STR *
+str_nmake(n)
+double n;
+{
+ register STR *str = str_new(0);
+
+ str_numset(str,n);
+ return str;
+}
--- /dev/null
+/* $RCSfile: str.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20:22 $
+ *
+ * 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: str.h,v $
+ * 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 {
+ char * str_ptr; /* pointer to malloced string */
+ double str_nval; /* numeric value, if any */
+ int str_len; /* allocated size */
+ int str_cur; /* length of str_ptr as a C string */
+ union {
+ STR *str_next; /* while free, link to next free str */
+ } str_link;
+ char str_pok; /* state of str_ptr */
+ char str_nok; /* state of str_nval */
+};
+
+#define Nullstr Null(STR*)
+
+/* the following macro updates any magic values this str is associated with */
+
+#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x))
+
+EXT STR **tmps_list;
+EXT long tmps_max INIT(-1);
+
+char *str_2ptr();
+double str_2num();
+STR *str_mortal();
+STR *str_make();
+STR *str_nmake();
+char *str_gets();
--- /dev/null
+/* $RCSfile: util.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:20:35 $
+ *
+ * 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: util.c,v $
+ * 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>
+
+#include "handy.h"
+#include "EXTERN.h"
+#include "a2p.h"
+#include "INTERN.h"
+#include "util.h"
+
+#define FLUSH
+#define MEM_SIZE unsigned int
+
+static char nomem[] = "Out of memory!\n";
+
+/* paranoid version of malloc */
+
+static int an = 0;
+
+char *
+safemalloc(size)
+MEM_SIZE size;
+{
+ char *ptr;
+ char *malloc();
+
+ ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
+#ifdef DEBUGGING
+ if (debug & 128)
+ fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size);
+#endif
+ if (ptr != Nullch)
+ return ptr;
+ else {
+ fputs(nomem,stdout) FLUSH;
+ exit(1);
+ }
+ /*NOTREACHED*/
+}
+
+/* paranoid version of realloc */
+
+char *
+saferealloc(where,size)
+char *where;
+MEM_SIZE size;
+{
+ char *ptr;
+ char *realloc();
+
+ ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
+#ifdef DEBUGGING
+ if (debug & 128) {
+ fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
+ fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size);
+ }
+#endif
+ if (ptr != Nullch)
+ return ptr;
+ else {
+ fputs(nomem,stdout) FLUSH;
+ exit(1);
+ }
+ /*NOTREACHED*/
+}
+
+/* safe version of free */
+
+safefree(where)
+char *where;
+{
+#ifdef DEBUGGING
+ if (debug & 128)
+ fprintf(stderr,"0x%x: (%05d) free\n",where,an++);
+#endif
+ free(where);
+}
+
+/* safe version of string copy */
+
+char *
+safecpy(to,from,len)
+char *to;
+register char *from;
+register int len;
+{
+ register char *dest = to;
+
+ if (from != Nullch)
+ for (len--; len && (*dest++ = *from++); len--) ;
+ *dest = '\0';
+ return to;
+}
+
+/* copy a string up to some (non-backslashed) delimiter, if any */
+
+char *
+cpytill(to,from,delim)
+register char *to, *from;
+register int delim;
+{
+ for (; *from; from++,to++) {
+ if (*from == '\\') {
+ if (from[1] == delim)
+ from++;
+ else if (from[1] == '\\')
+ *to++ = *from++;
+ }
+ else if (*from == delim)
+ break;
+ *to = *from;
+ }
+ *to = '\0';
+ return from;
+}
+
+
+char *
+cpy2(to,from,delim)
+register char *to, *from;
+register int delim;
+{
+ for (; *from; from++,to++) {
+ if (*from == '\\')
+ *to++ = *from++;
+ else if (*from == '$')
+ *to++ = '\\';
+ else if (*from == delim)
+ break;
+ *to = *from;
+ }
+ *to = '\0';
+ return from;
+}
+
+/* return ptr to little string in big string, NULL if not found */
+
+char *
+instr(big, little)
+char *big, *little;
+
+{
+ register char *t, *s, *x;
+
+ for (t = big; *t; t++) {
+ for (x=t,s=little; *s; x++,s++) {
+ if (!*x)
+ return Nullch;
+ if (*s != *x)
+ break;
+ }
+ if (!*s)
+ return t;
+ }
+ return Nullch;
+}
+
+/* copy a string to a safe spot */
+
+char *
+savestr(str)
+char *str;
+{
+ register char *newaddr = safemalloc((MEM_SIZE)(strlen(str)+1));
+
+ (void)strcpy(newaddr,str);
+ return newaddr;
+}
+
+/* grow a static string to at least a certain length */
+
+void
+growstr(strptr,curlen,newlen)
+char **strptr;
+int *curlen;
+int newlen;
+{
+ if (newlen > *curlen) { /* need more room? */
+ if (*curlen)
+ *strptr = saferealloc(*strptr,(MEM_SIZE)newlen);
+ else
+ *strptr = safemalloc((MEM_SIZE)newlen);
+ *curlen = newlen;
+ }
+}
+
+/*VARARGS1*/
+fatal(pat,a1,a2,a3,a4)
+char *pat;
+{
+ fprintf(stderr,pat,a1,a2,a3,a4);
+ exit(1);
+}
+
+/*VARARGS1*/
+warn(pat,a1,a2,a3,a4)
+char *pat;
+{
+ fprintf(stderr,pat,a1,a2,a3,a4);
+}
+
+static bool firstsetenv = TRUE;
+extern char **environ;
+
+void
+setenv(nam,val)
+char *nam, *val;
+{
+ register int i=envix(nam); /* where does it go? */
+
+ if (!environ[i]) { /* does not exist yet */
+ if (firstsetenv) { /* need we copy environment? */
+ int j;
+#ifndef lint
+ char **tmpenv = (char**) /* point our wand at memory */
+ safemalloc((i+2) * sizeof(char*));
+#else
+ char **tmpenv = Null(char **);
+#endif /* lint */
+
+ firstsetenv = FALSE;
+ for (j=0; j<i; j++) /* copy environment */
+ tmpenv[j] = environ[j];
+ environ = tmpenv; /* tell exec where it is now */
+ }
+#ifndef lint
+ else
+ environ = (char**) saferealloc((char*) environ,
+ (i+2) * sizeof(char*));
+ /* just expand it a bit */
+#endif /* lint */
+ environ[i+1] = Nullch; /* make sure it's null terminated */
+ }
+ environ[i] = safemalloc(strlen(nam) + strlen(val) + 2);
+ /* this may or may not be in */
+ /* the old environ structure */
+ sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
+}
+
+int
+envix(nam)
+char *nam;
+{
+ register int i, len = strlen(nam);
+
+ for (i = 0; environ[i]; i++) {
+ if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+ break; /* strnEQ must come first to avoid */
+ } /* potential SEGV's */
+ return i;
+}
--- /dev/null
+/* $RCSfile: util.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 19:21:20 $
+ *
+ * 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: util.h,v $
+ * 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? */
+
+#define fatal Myfatal
+
+#define MD_DIR 0
+#define MD_FILE 1
+
+void util_init();
+int doshell();
+char *safemalloc();
+char *saferealloc();
+char *safecpy();
+char *safecat();
+char *cpytill();
+char *cpy2();
+char *instr();
+#ifdef SETUIDGID
+ int eaccess();
+#endif
+char *getwd();
+void cat();
+void prexit();
+char *get_a_line();
+char *savestr();
+int makedir();
+void setenv();
+int envix();
+void notincl();
+char *getval();
+void growstr();
+void setdef();
--- /dev/null
+/* $RCSfile: walk.c,v $$Revision: 4.0.1.2 $$Date: 91/11/05 19:25:09 $
+ *
+ * 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: walk.c,v $
+ * 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"
+#include "EXTERN.h"
+#include "util.h"
+#include "a2p.h"
+
+bool exitval = FALSE;
+bool realexit = FALSE;
+bool saw_getline = FALSE;
+bool subretnum = FALSE;
+bool saw_FNR = FALSE;
+bool saw_argv0 = FALSE;
+bool saw_fh = FALSE;
+int maxtmp = 0;
+char *lparen;
+char *rparen;
+char *limit;
+STR *subs;
+STR *curargs = Nullstr;
+
+STR *
+walk(useval,level,node,numericptr,minprec)
+int useval;
+int level;
+register int node;
+int *numericptr;
+int minprec; /* minimum precedence without parens */
+{
+ register int len;
+ register STR *str;
+ register int type;
+ register int i;
+ register STR *tmpstr;
+ STR *tmp2str;
+ STR *tmp3str;
+ char *t;
+ char *d, *s;
+ int numarg;
+ int numeric = FALSE;
+ STR *fstr;
+ int prec = P_MAX; /* assume no parens needed */
+ char *index();
+
+ if (!node) {
+ *numericptr = 0;
+ return str_make("");
+ }
+ type = ops[node].ival;
+ len = type >> 8;
+ type &= 255;
+ switch (type) {
+ case OPROG:
+ arymax = 0;
+ if (namelist) {
+ while (isalpha(*namelist)) {
+ for (d = tokenbuf,s=namelist;
+ isalpha(*s) || isdigit(*s) || *s == '_';
+ *d++ = *s++) ;
+ *d = '\0';
+ while (*s && !isalpha(*s)) s++;
+ namelist = s;
+ nameary[++arymax] = savestr(tokenbuf);
+ }
+ }
+ if (maxfld < arymax)
+ maxfld = arymax;
+ opens = str_new(0);
+ subs = str_new(0);
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ if (do_split && need_entire && !absmaxfld)
+ split_to_array = TRUE;
+ if (do_split && split_to_array)
+ set_array_base = TRUE;
+ if (set_array_base) {
+ str_cat(str,"$[ = 1;\t\t\t# set array base to 1\n");
+ }
+ if (fswitch && !const_FS)
+ const_FS = fswitch;
+ if (saw_FS > 1 || saw_RS)
+ const_FS = 0;
+ if (saw_ORS && need_entire)
+ do_chop = TRUE;
+ if (fswitch) {
+ str_cat(str,"$FS = '");
+ if (index("*+?.[]()|^$\\",fswitch))
+ str_cat(str,"\\");
+ sprintf(tokenbuf,"%c",fswitch);
+ str_cat(str,tokenbuf);
+ str_cat(str,"';\t\t# field separator from -F switch\n");
+ }
+ else if (saw_FS && !const_FS) {
+ str_cat(str,"$FS = ' ';\t\t# set field separator\n");
+ }
+ if (saw_OFS) {
+ str_cat(str,"$, = ' ';\t\t# set output field separator\n");
+ }
+ if (saw_ORS) {
+ str_cat(str,"$\\ = \"\\n\";\t\t# set output record separator\n");
+ }
+ if (saw_argv0) {
+ str_cat(str,"$ARGV0 = $0;\t\t# remember what we ran as\n");
+ }
+ if (str->str_cur > 20)
+ str_cat(str,"\n");
+ if (ops[node+2].ival) {
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,"\n\n");
+ }
+ fstr = walk(0,level+1,ops[node+3].ival,&numarg,P_MIN);
+ if (*fstr->str_ptr) {
+ if (saw_line_op)
+ str_cat(str,"line: ");
+ str_cat(str,"while (<>) {\n");
+ tab(str,++level);
+ if (saw_FS && !const_FS)
+ do_chop = TRUE;
+ if (do_chop) {
+ str_cat(str,"chop;\t# strip record separator\n");
+ tab(str,level);
+ }
+ if (do_split)
+ emit_split(str,level);
+ str_scat(str,fstr);
+ str_free(fstr);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ if (saw_FNR)
+ str_cat(str,"continue {\n $FNRbase = $. if eof;\n}\n");
+ }
+ else
+ str_cat(str,"while (<>) { } # (no line actions)\n");
+ if (ops[node+4].ival) {
+ realexit = TRUE;
+ str_cat(str,"\n");
+ tab(str,level);
+ str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,"\n");
+ }
+ if (exitval)
+ str_cat(str,"exit $ExitValue;\n");
+ if (subs->str_ptr) {
+ str_cat(str,"\n");
+ str_scat(str,subs);
+ }
+ if (saw_getline) {
+ for (len = 0; len < 4; len++) {
+ if (saw_getline & (1 << len)) {
+ sprintf(tokenbuf,"\nsub Getline%d {\n",len);
+ str_cat(str, tokenbuf);
+ if (len & 2) {
+ if (do_fancy_opens)
+ str_cat(str," &Pick('',@_);\n");
+ else
+ str_cat(str," ($fh) = @_;\n");
+ }
+ else {
+ if (saw_FNR)
+ str_cat(str," $FNRbase = $. if eof;\n");
+ }
+ if (len & 1)
+ str_cat(str," local($_);\n");
+ if (len & 2)
+ str_cat(str,
+ " if ($getline_ok = (($_ = <$fh>) ne ''))");
+ else
+ str_cat(str,
+ " if ($getline_ok = (($_ = <>) ne ''))");
+ str_cat(str, " {\n");
+ level += 2;
+ tab(str,level);
+ i = 0;
+ if (do_chop) {
+ i++;
+ str_cat(str,"chop;\t# strip record separator\n");
+ tab(str,level);
+ }
+ if (do_split && !(len & 1)) {
+ i++;
+ emit_split(str,level);
+ }
+ if (!i)
+ str_cat(str,";\n");
+ fixtab(str,--level);
+ str_cat(str,"}\n $_;\n}\n");
+ --level;
+ }
+ }
+ }
+ if (do_fancy_opens) {
+ str_cat(str,"\n\
+sub Pick {\n\
+ local($mode,$name,$pipe) = @_;\n\
+ $fh = $opened{$name};\n\
+ if (!$fh) {\n\
+ $fh = $opened{$name} = 'fh_' . ($nextfh++ + 0);\n\
+ open($fh,$mode.$name.$pipe);\n\
+ }\n\
+}\n\
+");
+ }
+ break;
+ case OHUNKS:
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ if (len == 3) {
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ else {
+ }
+ break;
+ case ORANGE:
+ prec = P_DOTDOT;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
+ str_cat(str," .. ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OPAT:
+ goto def;
+ case OREGEX:
+ str = str_new(0);
+ str_set(str,"/");
+ tmpstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ /* translate \nnn to [\nnn] */
+ for (s = tmpstr->str_ptr, d = tokenbuf; *s; s++, d++) {
+ if (*s == '\\' && isdigit(s[1]) && isdigit(s[2]) && isdigit(s[3])){
+ *d++ = '[';
+ *d++ = *s++;
+ *d++ = *s++;
+ *d++ = *s++;
+ *d++ = *s;
+ *d = ']';
+ }
+ else
+ *d = *s;
+ }
+ *d = '\0';
+ for (d=tokenbuf; *d; d++)
+ *d += 128;
+ str_cat(str,tokenbuf);
+ str_free(tmpstr);
+ str_cat(str,"/");
+ break;
+ case OHUNK:
+ if (len == 1) {
+ str = str_new(0);
+ str = walk(0,level,oper1(OPRINT,0),&numarg,P_MIN);
+ str_cat(str," if ");
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,";");
+ }
+ else {
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ if (*tmpstr->str_ptr) {
+ str = str_new(0);
+ str_set(str,"if (");
+ str_scat(str,tmpstr);
+ str_cat(str,") {\n");
+ tab(str,++level);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ tab(str,level);
+ }
+ else {
+ str = walk(0,level,ops[node+2].ival,&numarg,P_MIN);
+ }
+ }
+ break;
+ case OPPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,")");
+ break;
+ case OPANDAND:
+ prec = P_ANDAND;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," && ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OPOROR:
+ prec = P_OROR;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," || ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OPNOT:
+ prec = P_UNARY;
+ str = str_new(0);
+ str_set(str,"!");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec));
+ str_free(fstr);
+ break;
+ case OCOND:
+ prec = P_COND;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," ? ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_cat(str," : ");
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OCPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ numeric |= numarg;
+ str_cat(str,")");
+ break;
+ case OCANDAND:
+ prec = P_ANDAND;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ numeric = 1;
+ str_cat(str," && ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OCOROR:
+ prec = P_OROR;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ numeric = 1;
+ str_cat(str," || ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OCNOT:
+ prec = P_UNARY;
+ str = str_new(0);
+ str_set(str,"!");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case ORELOP:
+ prec = P_REL;
+ str = walk(1,level,ops[node+2].ival,&numarg,prec+1);
+ numeric |= numarg;
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ tmp2str = walk(1,level,ops[node+3].ival,&numarg,prec+1);
+ numeric |= numarg;
+ if (!numeric ||
+ (!numarg && (*tmp2str->str_ptr == '"' || *tmp2str->str_ptr == '\''))) {
+ t = tmpstr->str_ptr;
+ if (strEQ(t,"=="))
+ str_set(tmpstr,"eq");
+ else if (strEQ(t,"!="))
+ str_set(tmpstr,"ne");
+ else if (strEQ(t,"<"))
+ str_set(tmpstr,"lt");
+ else if (strEQ(t,"<="))
+ str_set(tmpstr,"le");
+ else if (strEQ(t,">"))
+ str_set(tmpstr,"gt");
+ else if (strEQ(t,">="))
+ str_set(tmpstr,"ge");
+ if (!index(tmpstr->str_ptr,'\'') && !index(tmpstr->str_ptr,'"') &&
+ !index(tmp2str->str_ptr,'\'') && !index(tmp2str->str_ptr,'"') )
+ numeric |= 2;
+ }
+ if (numeric & 2) {
+ if (numeric & 1) /* numeric is very good guess */
+ str_cat(str," ");
+ else
+ str_cat(str,"\377");
+ numeric = 1;
+ }
+ else
+ str_cat(str," ");
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ str_cat(str," ");
+ str_scat(str,tmp2str);
+ str_free(tmp2str);
+ numeric = 1;
+ break;
+ case ORPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ numeric |= numarg;
+ str_cat(str,")");
+ break;
+ case OMATCHOP:
+ prec = P_MATCH;
+ str = walk(1,level,ops[node+2].ival,&numarg,prec+1);
+ str_cat(str," ");
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ if (strEQ(tmpstr->str_ptr,"~"))
+ str_cat(str,"=~");
+ else {
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ }
+ str_cat(str," ");
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OMPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,
+ fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ numeric |= numarg;
+ str_cat(str,")");
+ break;
+ case OCONCAT:
+ prec = P_ADD;
+ type = ops[ops[node+1].ival].ival & 255;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+(type != OCONCAT));
+ str_cat(str," . ");
+ type = ops[ops[node+2].ival].ival & 255;
+ str_scat(str,
+ fstr=walk(1,level,ops[node+2].ival,&numarg,prec+(type != OCONCAT)));
+ str_free(fstr);
+ break;
+ case OASSIGN:
+ prec = P_ASSIGN;
+ str = walk(0,level,ops[node+2].ival,&numarg,prec+1);
+ str_cat(str," ");
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ str_scat(str,tmpstr);
+ if (str_len(tmpstr) > 1)
+ numeric = 1;
+ str_free(tmpstr);
+ str_cat(str," ");
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec));
+ str_free(fstr);
+ numeric |= numarg;
+ break;
+ case OADD:
+ prec = P_ADD;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," + ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OSUBTRACT:
+ prec = P_ADD;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," - ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OMULT:
+ prec = P_MUL;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," * ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case ODIV:
+ prec = P_MUL;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," / ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OPOW:
+ prec = P_POW;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
+ str_cat(str," ** ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OMOD:
+ prec = P_MUL;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," % ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OPOSTINCR:
+ prec = P_AUTO;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
+ str_cat(str,"++");
+ numeric = 1;
+ break;
+ case OPOSTDECR:
+ prec = P_AUTO;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
+ str_cat(str,"--");
+ numeric = 1;
+ break;
+ case OPREINCR:
+ prec = P_AUTO;
+ str = str_new(0);
+ str_set(str,"++");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OPREDECR:
+ prec = P_AUTO;
+ str = str_new(0);
+ str_set(str,"--");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OUMINUS:
+ prec = P_UNARY;
+ str = str_new(0);
+ str_set(str,"-");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OUPLUS:
+ numeric = 1;
+ goto def;
+ case OPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,
+ fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,")");
+ numeric |= numarg;
+ break;
+ case OGETLINE:
+ str = str_new(0);
+ if (useval)
+ str_cat(str,"(");
+ if (len > 0) {
+ str_cat(str,"$");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ if (!*fstr->str_ptr) {
+ str_cat(str,"_");
+ len = 2; /* a legal fiction */
+ }
+ str_free(fstr);
+ }
+ else
+ str_cat(str,"$_");
+ if (len > 1) {
+ tmpstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN);
+ fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ if (!do_fancy_opens) {
+ t = tmpstr->str_ptr;
+ if (*t == '"' || *t == '\'')
+ t = cpytill(tokenbuf,t+1,*t);
+ else
+ fatal("Internal error: OGETLINE %s", t);
+ d = savestr(t);
+ s = savestr(tokenbuf);
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (islower(*t))
+ *t = toupper(*t);
+ if (!isalpha(*t) && !isdigit(*t))
+ *t = '_';
+ }
+ if (!index(tokenbuf,'_'))
+ strcpy(t,"_FH");
+ tmp3str = hfetch(symtab,tokenbuf);
+ if (!tmp3str) {
+ do_opens = TRUE;
+ str_cat(opens,"open(");
+ str_cat(opens,tokenbuf);
+ str_cat(opens,", ");
+ d[1] = '\0';
+ str_cat(opens,d);
+ str_cat(opens,tmpstr->str_ptr+1);
+ opens->str_cur--;
+ if (*fstr->str_ptr == '|')
+ str_cat(opens,"|");
+ str_cat(opens,d);
+ if (*fstr->str_ptr == '|')
+ str_cat(opens,") || die 'Cannot pipe from \"");
+ else
+ str_cat(opens,") || die 'Cannot open file \"");
+ if (*d == '"')
+ str_cat(opens,"'.\"");
+ str_cat(opens,s);
+ if (*d == '"')
+ str_cat(opens,"\".'");
+ str_cat(opens,"\".';\n");
+ hstore(symtab,tokenbuf,str_make("x"));
+ }
+ safefree(s);
+ safefree(d);
+ str_set(tmpstr,"'");
+ str_cat(tmpstr,tokenbuf);
+ str_cat(tmpstr,"'");
+ }
+ if (*fstr->str_ptr == '|')
+ str_cat(tmpstr,", '|'");
+ str_free(fstr);
+ }
+ else
+ tmpstr = str_make("");
+ sprintf(tokenbuf," = &Getline%d(%s)",len,tmpstr->str_ptr);
+ str_cat(str,tokenbuf);
+ str_free(tmpstr);
+ if (useval)
+ str_cat(str,",$getline_ok)");
+ saw_getline |= 1 << len;
+ break;
+ case OSPRINTF:
+ str = str_new(0);
+ str_set(str,"sprintf(");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,")");
+ break;
+ case OSUBSTR:
+ str = str_new(0);
+ str_set(str,"substr(");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,", ");
+ if (len == 3) {
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ }
+ else
+ str_cat(str,"999999");
+ str_cat(str,")");
+ break;
+ case OSTRING:
+ str = str_new(0);
+ str_set(str,ops[node+1].cval);
+ break;
+ case OSPLIT:
+ str = str_new(0);
+ limit = ", 9999)";
+ numeric = 1;
+ tmpstr = walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ if (useval)
+ str_set(str,"(@");
+ else
+ str_set(str,"@");
+ str_scat(str,tmpstr);
+ str_cat(str," = split(");
+ if (len == 3) {
+ fstr = walk(1,level,ops[node+3].ival,&numarg,P_COMMA+1);
+ if (str_len(fstr) == 3 && *fstr->str_ptr == '\'') {
+ i = fstr->str_ptr[1] & 127;
+ if (index("*+?.[]()|^$\\",i))
+ sprintf(tokenbuf,"/\\%c/",i);
+ else if (i == ' ')
+ sprintf(tokenbuf,"' '");
+ else
+ sprintf(tokenbuf,"/%c/",i);
+ str_cat(str,tokenbuf);
+ }
+ else
+ str_scat(str,fstr);
+ str_free(fstr);
+ }
+ else if (const_FS) {
+ sprintf(tokenbuf,"/[%c\\n]/",const_FS);
+ str_cat(str,tokenbuf);
+ }
+ else if (saw_FS)
+ str_cat(str,"$FS");
+ else {
+ str_cat(str,"' '");
+ limit = ")";
+ }
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,limit);
+ if (useval) {
+ str_cat(str,")");
+ }
+ str_free(tmpstr);
+ break;
+ case OINDEX:
+ str = str_new(0);
+ str_set(str,"index(");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,")");
+ numeric = 1;
+ break;
+ case OMATCH:
+ str = str_new(0);
+ prec = P_ANDAND;
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MATCH+1));
+ str_free(fstr);
+ str_cat(str," =~ ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MATCH+1));
+ str_free(fstr);
+ str_cat(str," && ($RLENGTH = length($&), $RSTART = length($`)+1)");
+ numeric = 1;
+ break;
+ case OUSERDEF:
+ str = str_new(0);
+ subretnum = FALSE;
+ fstr=walk(1,level-1,ops[node+2].ival,&numarg,P_MIN);
+ curargs = str_new(0);
+ str_sset(curargs,fstr);
+ str_cat(curargs,",");
+ tmp2str=walk(1,level,ops[node+5].ival,&numarg,P_MIN);
+ str_free(curargs);
+ curargs = Nullstr;
+ level--;
+ subretnum |= numarg;
+ s = Nullch;
+ t = tmp2str->str_ptr;
+ while (t = instr(t,"return "))
+ s = t++;
+ if (s) {
+ i = 0;
+ for (t = s+7; *t; t++) {
+ if (*t == ';' || *t == '}')
+ i++;
+ }
+ if (i == 1) {
+ strcpy(s,s+7);
+ tmp2str->str_cur -= 7;
+ }
+ }
+ str_set(str,"\n");
+ tab(str,level);
+ str_cat(str,"sub ");
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_cat(str," {\n");
+ tab(str,++level);
+ if (fstr->str_cur) {
+ str_cat(str,"local(");
+ str_scat(str,fstr);
+ str_cat(str,") = @_;");
+ }
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ fixtab(str,level);
+ str_scat(str,fstr=walk(1,level,ops[node+4].ival,&numarg,P_MIN));
+ str_free(fstr);
+ fixtab(str,level);
+ str_scat(str,tmp2str);
+ str_free(tmp2str);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ tab(str,level);
+ str_scat(subs,str);
+ str_set(str,"");
+ str_cat(tmpstr,"(");
+ tmp2str = str_new(0);
+ if (subretnum)
+ str_set(tmp2str,"1");
+ hstore(symtab,tmpstr->str_ptr,tmp2str);
+ str_free(tmpstr);
+ level++;
+ break;
+ case ORETURN:
+ str = str_new(0);
+ if (len > 0) {
+ str_cat(str,"return ");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_UNI+1));
+ str_free(fstr);
+ if (numarg)
+ subretnum = TRUE;
+ }
+ else
+ str_cat(str,"return");
+ break;
+ case OUSERFUN:
+ str = str_new(0);
+ str_set(str,"&");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,"(");
+ tmpstr = hfetch(symtab,str->str_ptr+3);
+ if (tmpstr && tmpstr->str_ptr)
+ numeric |= atoi(tmpstr->str_ptr);
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,")");
+ break;
+ case OGSUB:
+ case OSUB:
+ if (type == OGSUB)
+ s = "g";
+ else
+ s = "";
+ str = str_new(0);
+ tmpstr = str_new(0);
+ i = 0;
+ if (len == 3) {
+ tmpstr = walk(1,level,ops[node+3].ival,&numarg,P_MATCH+1);
+ if (strNE(tmpstr->str_ptr,"$_")) {
+ str_cat(tmpstr, " =~ s");
+ i++;
+ }
+ else
+ str_set(tmpstr, "s");
+ }
+ else
+ str_set(tmpstr, "s");
+ type = ops[ops[node+2].ival].ival;
+ len = type >> 8;
+ type &= 255;
+ tmp3str = str_new(0);
+ if (type == OSTR) {
+ tmp2str=walk(1,level,ops[ops[node+2].ival+1].ival,&numarg,P_MIN);
+ for (t = tmp2str->str_ptr, d=tokenbuf; *t; d++,t++) {
+ if (*t == '&')
+ *d++ = '$' + 128;
+ else if (*t == '$')
+ *d++ = '\\' + 128;
+ *d = *t + 128;
+ }
+ *d = '\0';
+ str_set(tmp2str,tokenbuf);
+ }
+ else {
+ tmp2str=walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ str_set(tmp3str,"($s_ = '\"'.(");
+ str_scat(tmp3str,tmp2str);
+ str_cat(tmp3str,").'\"') =~ s/&/\\$&/g, ");
+ str_set(tmp2str,"eval $s_");
+ s = (*s == 'g' ? "ge" : "e");
+ i++;
+ }
+ type = ops[ops[node+1].ival].ival;
+ len = type >> 8;
+ type &= 255;
+ fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ if (type == OREGEX) {
+ if (useval && i)
+ str_cat(str,"(");
+ str_scat(str,tmp3str);
+ str_scat(str,tmpstr);
+ str_scat(str,fstr);
+ str_scat(str,tmp2str);
+ str_cat(str,"/");
+ str_cat(str,s);
+ }
+ else if ((type == OFLD && !split_to_array) || (type == OVAR && len == 1)) {
+ if (useval && i)
+ str_cat(str,"(");
+ str_scat(str,tmp3str);
+ str_scat(str,tmpstr);
+ str_cat(str,"/");
+ str_scat(str,fstr);
+ str_cat(str,"/");
+ str_scat(str,tmp2str);
+ str_cat(str,"/");
+ str_cat(str,s);
+ }
+ else {
+ i++;
+ if (useval)
+ str_cat(str,"(");
+ str_cat(str,"$s = ");
+ str_scat(str,fstr);
+ str_cat(str,", ");
+ str_scat(str,tmp3str);
+ str_scat(str,tmpstr);
+ str_cat(str,"/$s/");
+ str_scat(str,tmp2str);
+ str_cat(str,"/");
+ str_cat(str,s);
+ }
+ if (useval && i)
+ str_cat(str,")");
+ str_free(fstr);
+ str_free(tmpstr);
+ str_free(tmp2str);
+ str_free(tmp3str);
+ numeric = 1;
+ break;
+ case ONUM:
+ str = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ numeric = 1;
+ break;
+ case OSTR:
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ s = "'";
+ for (t = tmpstr->str_ptr, d=tokenbuf; *t; d++,t++) {
+ if (*t == '\'')
+ s = "\"";
+ else if (*t == '\\') {
+ s = "\"";
+ *d++ = *t++ + 128;
+ switch (*t) {
+ case '\\': case '"': case 'n': case 't': case '$':
+ break;
+ default: /* hide this from perl */
+ *d++ = '\\' + 128;
+ }
+ }
+ *d = *t + 128;
+ }
+ *d = '\0';
+ str = str_new(0);
+ str_set(str,s);
+ str_cat(str,tokenbuf);
+ str_free(tmpstr);
+ str_cat(str,s);
+ break;
+ case ODEFINED:
+ prec = P_UNI;
+ str = str_new(0);
+ str_set(str,"defined $");
+ goto addvar;
+ case ODELETE:
+ str = str_new(0);
+ str_set(str,"delete $");
+ goto addvar;
+ case OSTAR:
+ str = str_new(0);
+ str_set(str,"*");
+ goto addvar;
+ case OVAR:
+ str = str_new(0);
+ str_set(str,"$");
+ addvar:
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ if (len == 1) {
+ tmp2str = hfetch(symtab,tmpstr->str_ptr);
+ if (tmp2str && atoi(tmp2str->str_ptr))
+ numeric = 2;
+ if (strEQ(str->str_ptr,"$FNR")) {
+ numeric = 1;
+ saw_FNR++;
+ str_set(str,"($.-$FNRbase)");
+ }
+ else if (strEQ(str->str_ptr,"$NR")) {
+ numeric = 1;
+ str_set(str,"$.");
+ }
+ else if (strEQ(str->str_ptr,"$NF")) {
+ numeric = 1;
+ str_set(str,"$#Fld");
+ }
+ else if (strEQ(str->str_ptr,"$0"))
+ str_set(str,"$_");
+ else if (strEQ(str->str_ptr,"$ARGC"))
+ str_set(str,"($#ARGV+1)");
+ }
+ else {
+#ifdef NOTDEF
+ if (curargs) {
+ sprintf(tokenbuf,"$%s,",tmpstr->str_ptr);
+ ??? if (instr(curargs->str_ptr,tokenbuf))
+ str_cat(str,"\377"); /* can't translate yet */
+ }
+#endif
+ str_cat(tmpstr,"[]");
+ tmp2str = hfetch(symtab,tmpstr->str_ptr);
+ if (tmp2str && atoi(tmp2str->str_ptr))
+ str_cat(str,"[");
+ else
+ str_cat(str,"{");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ if (strEQ(str->str_ptr,"$ARGV[0")) {
+ str_set(str,"$ARGV0");
+ saw_argv0++;
+ }
+ else {
+ if (tmp2str && atoi(tmp2str->str_ptr))
+ strcpy(tokenbuf,"]");
+ else
+ strcpy(tokenbuf,"}");
+ *tokenbuf += 128;
+ str_cat(str,tokenbuf);
+ }
+ }
+ str_free(tmpstr);
+ break;
+ case OFLD:
+ str = str_new(0);
+ if (split_to_array) {
+ str_set(str,"$Fld");
+ str_cat(str,"[");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,"]");
+ }
+ else {
+ i = atoi(walk(1,level,ops[node+1].ival,&numarg,P_MIN)->str_ptr);
+ if (i <= arymax)
+ sprintf(tokenbuf,"$%s",nameary[i]);
+ else
+ sprintf(tokenbuf,"$Fld%d",i);
+ str_set(str,tokenbuf);
+ }
+ break;
+ case OVFLD:
+ str = str_new(0);
+ str_set(str,"$Fld[");
+ i = ops[node+1].ival;
+ if ((ops[i].ival & 255) == OPAREN)
+ i = ops[i+1].ival;
+ tmpstr=walk(1,level,i,&numarg,P_MIN);
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ str_cat(str,"]");
+ break;
+ case OJUNK:
+ goto def;
+ case OSNEWLINE:
+ str = str_new(2);
+ str_set(str,";\n");
+ tab(str,level);
+ break;
+ case ONEWLINE:
+ str = str_new(1);
+ str_set(str,"\n");
+ tab(str,level);
+ break;
+ case OSCOMMENT:
+ str = str_new(0);
+ str_set(str,";");
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ for (s = tmpstr->str_ptr; *s && *s != '\n'; s++)
+ *s += 128;
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ tab(str,level);
+ break;
+ case OCOMMENT:
+ str = str_new(0);
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ for (s = tmpstr->str_ptr; *s && *s != '\n'; s++)
+ *s += 128;
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ tab(str,level);
+ break;
+ case OCOMMA:
+ prec = P_COMMA;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OSEMICOLON:
+ str = str_new(1);
+ str_set(str,";\n");
+ tab(str,level);
+ break;
+ case OSTATES:
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ break;
+ case OSTATE:
+ str = str_new(0);
+ if (len >= 1) {
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ if (len >= 2) {
+ tmpstr = walk(0,level,ops[node+2].ival,&numarg,P_MIN);
+ if (*tmpstr->str_ptr == ';') {
+ addsemi(str);
+ str_cat(str,tmpstr->str_ptr+1);
+ }
+ str_free(tmpstr);
+ }
+ }
+ break;
+ case OCLOSE:
+ str = str_make("close(");
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ if (!do_fancy_opens) {
+ t = tmpstr->str_ptr;
+ if (*t == '"' || *t == '\'')
+ t = cpytill(tokenbuf,t+1,*t);
+ else
+ fatal("Internal error: OCLOSE %s",t);
+ s = savestr(tokenbuf);
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (islower(*t))
+ *t = toupper(*t);
+ if (!isalpha(*t) && !isdigit(*t))
+ *t = '_';
+ }
+ if (!index(tokenbuf,'_'))
+ strcpy(t,"_FH");
+ str_free(tmpstr);
+ safefree(s);
+ str_set(str,"close ");
+ str_cat(str,tokenbuf);
+ }
+ else {
+ sprintf(tokenbuf,"$fh = delete $opened{%s} && close($fh)",
+ tmpstr->str_ptr);
+ str_free(tmpstr);
+ str_set(str,tokenbuf);
+ }
+ break;
+ case OPRINTF:
+ case OPRINT:
+ lparen = ""; /* set to parens if necessary */
+ rparen = "";
+ str = str_new(0);
+ if (len == 3) { /* output redirection */
+ tmpstr = walk(1,level,ops[node+3].ival,&numarg,P_MIN);
+ tmp2str = walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ if (!do_fancy_opens) {
+ t = tmpstr->str_ptr;
+ if (*t == '"' || *t == '\'')
+ t = cpytill(tokenbuf,t+1,*t);
+ else
+ fatal("Internal error: OPRINT");
+ d = savestr(t);
+ s = savestr(tokenbuf);
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (islower(*t))
+ *t = toupper(*t);
+ if (!isalpha(*t) && !isdigit(*t))
+ *t = '_';
+ }
+ if (!index(tokenbuf,'_'))
+ strcpy(t,"_FH");
+ tmp3str = hfetch(symtab,tokenbuf);
+ if (!tmp3str) {
+ str_cat(opens,"open(");
+ str_cat(opens,tokenbuf);
+ str_cat(opens,", ");
+ d[1] = '\0';
+ str_cat(opens,d);
+ str_scat(opens,tmp2str);
+ str_cat(opens,tmpstr->str_ptr+1);
+ if (*tmp2str->str_ptr == '|')
+ str_cat(opens,") || die 'Cannot pipe to \"");
+ else
+ str_cat(opens,") || die 'Cannot create file \"");
+ if (*d == '"')
+ str_cat(opens,"'.\"");
+ str_cat(opens,s);
+ if (*d == '"')
+ str_cat(opens,"\".'");
+ str_cat(opens,"\".';\n");
+ hstore(symtab,tokenbuf,str_make("x"));
+ }
+ str_free(tmpstr);
+ str_free(tmp2str);
+ safefree(s);
+ safefree(d);
+ }
+ else {
+ sprintf(tokenbuf,"&Pick('%s', %s) &&\n",
+ tmp2str->str_ptr, tmpstr->str_ptr);
+ str_cat(str,tokenbuf);
+ tab(str,level+1);
+ strcpy(tokenbuf,"$fh");
+ str_free(tmpstr);
+ str_free(tmp2str);
+ lparen = "(";
+ rparen = ")";
+ }
+ }
+ else
+ strcpy(tokenbuf,"");
+ str_cat(str,lparen); /* may be null */
+ if (type == OPRINTF)
+ str_cat(str,"printf");
+ else
+ str_cat(str,"print");
+ saw_fh = 0;
+ if (len == 3 || do_fancy_opens) {
+ if (*tokenbuf) {
+ str_cat(str," ");
+ saw_fh = 1;
+ }
+ str_cat(str,tokenbuf);
+ }
+ tmpstr = walk(1+(type==OPRINT),level,ops[node+1].ival,&numarg,P_MIN);
+ if (!*tmpstr->str_ptr && lval_field) {
+ t = saw_OFS ? "$," : "' '";
+ if (split_to_array) {
+ sprintf(tokenbuf,"join(%s,@Fld)",t);
+ str_cat(tmpstr,tokenbuf);
+ }
+ else {
+ for (i = 1; i < maxfld; i++) {
+ if (i <= arymax)
+ sprintf(tokenbuf,"$%s, ",nameary[i]);
+ else
+ sprintf(tokenbuf,"$Fld%d, ",i);
+ str_cat(tmpstr,tokenbuf);
+ }
+ if (maxfld <= arymax)
+ sprintf(tokenbuf,"$%s",nameary[maxfld]);
+ else
+ sprintf(tokenbuf,"$Fld%d",maxfld);
+ str_cat(tmpstr,tokenbuf);
+ }
+ }
+ if (*tmpstr->str_ptr) {
+ str_cat(str," ");
+ if (!saw_fh && *tmpstr->str_ptr == '(') {
+ str_cat(str,"(");
+ str_scat(str,tmpstr);
+ str_cat(str,")");
+ }
+ else
+ str_scat(str,tmpstr);
+ }
+ else {
+ str_cat(str," $_");
+ }
+ str_cat(str,rparen); /* may be null */
+ str_free(tmpstr);
+ break;
+ case ORAND:
+ str = str_make("rand(1)");
+ break;
+ case OSRAND:
+ str = str_make("srand(");
+ goto maybe0;
+ case OATAN2:
+ str = str_make("atan2(");
+ goto maybe0;
+ case OSIN:
+ str = str_make("sin(");
+ goto maybe0;
+ case OCOS:
+ str = str_make("cos(");
+ goto maybe0;
+ case OSYSTEM:
+ str = str_make("system(");
+ goto maybe0;
+ case OLENGTH:
+ str = str_make("length(");
+ goto maybe0;
+ case OLOG:
+ str = str_make("log(");
+ goto maybe0;
+ case OEXP:
+ str = str_make("exp(");
+ goto maybe0;
+ case OSQRT:
+ str = str_make("sqrt(");
+ goto maybe0;
+ case OINT:
+ str = str_make("int(");
+ maybe0:
+ numeric = 1;
+ if (len > 0)
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ else
+ tmpstr = str_new(0);;
+ if (!tmpstr->str_ptr || !*tmpstr->str_ptr) {
+ if (lval_field) {
+ t = saw_OFS ? "$," : "' '";
+ if (split_to_array) {
+ sprintf(tokenbuf,"join(%s,@Fld)",t);
+ str_cat(tmpstr,tokenbuf);
+ }
+ else {
+ sprintf(tokenbuf,"join(%s, ",t);
+ str_cat(tmpstr,tokenbuf);
+ for (i = 1; i < maxfld; i++) {
+ if (i <= arymax)
+ sprintf(tokenbuf,"$%s,",nameary[i]);
+ else
+ sprintf(tokenbuf,"$Fld%d,",i);
+ str_cat(tmpstr,tokenbuf);
+ }
+ if (maxfld <= arymax)
+ sprintf(tokenbuf,"$%s)",nameary[maxfld]);
+ else
+ sprintf(tokenbuf,"$Fld%d)",maxfld);
+ str_cat(tmpstr,tokenbuf);
+ }
+ }
+ else
+ str_cat(tmpstr,"$_");
+ }
+ if (strEQ(tmpstr->str_ptr,"$_")) {
+ if (type == OLENGTH && !do_chop) {
+ str = str_make("(length(");
+ str_cat(tmpstr,") - 1");
+ }
+ }
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ str_cat(str,")");
+ break;
+ case OBREAK:
+ str = str_new(0);
+ str_set(str,"last");
+ break;
+ case ONEXT:
+ str = str_new(0);
+ str_set(str,"next line");
+ break;
+ case OEXIT:
+ str = str_new(0);
+ if (realexit) {
+ prec = P_UNI;
+ str_set(str,"exit");
+ if (len == 1) {
+ str_cat(str," ");
+ exitval = TRUE;
+ str_scat(str,
+ fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1));
+ str_free(fstr);
+ }
+ }
+ else {
+ if (len == 1) {
+ str_set(str,"$ExitValue = ");
+ exitval = TRUE;
+ str_scat(str,
+ fstr=walk(1,level,ops[node+1].ival,&numarg,P_ASSIGN));
+ str_free(fstr);
+ str_cat(str,"; ");
+ }
+ str_cat(str,"last line");
+ }
+ break;
+ case OCONTINUE:
+ str = str_new(0);
+ str_set(str,"next");
+ break;
+ case OREDIR:
+ goto def;
+ case OIF:
+ str = str_new(0);
+ str_set(str,"if (");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,") ");
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ if (len == 3) {
+ i = ops[node+3].ival;
+ if (i) {
+ if ((ops[i].ival & 255) == OBLOCK) {
+ i = ops[i+1].ival;
+ if (i) {
+ if ((ops[i].ival & 255) != OIF)
+ i = 0;
+ }
+ }
+ else
+ i = 0;
+ }
+ if (i) {
+ str_cat(str,"els");
+ str_scat(str,fstr=walk(0,level,i,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ else {
+ str_cat(str,"else ");
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ }
+ break;
+ case OWHILE:
+ str = str_new(0);
+ str_set(str,"while (");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,") ");
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ break;
+ case OFOR:
+ str = str_new(0);
+ str_set(str,"for (");
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ i = numarg;
+ if (i) {
+ t = s = tmpstr->str_ptr;
+ while (isalpha(*t) || isdigit(*t) || *t == '$' || *t == '_')
+ t++;
+ i = t - s;
+ if (i < 2)
+ i = 0;
+ }
+ str_cat(str,"; ");
+ fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ if (i && (t = index(fstr->str_ptr,0377))) {
+ if (strnEQ(fstr->str_ptr,s,i))
+ *t = ' ';
+ }
+ str_scat(str,fstr);
+ str_free(fstr);
+ str_free(tmpstr);
+ str_cat(str,"; ");
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,") ");
+ str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg,P_MIN));
+ str_free(fstr);
+ break;
+ case OFORIN:
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ d = index(tmpstr->str_ptr,'$');
+ if (!d)
+ fatal("Illegal for loop: %s",tmpstr->str_ptr);
+ s = index(d,'{');
+ if (!s)
+ s = index(d,'[');
+ if (!s)
+ fatal("Illegal for loop: %s",d);
+ *s++ = '\0';
+ for (t = s; i = *t; t++) {
+ i &= 127;
+ if (i == '}' || i == ']')
+ break;
+ }
+ if (*t)
+ *t = '\0';
+ str = str_new(0);
+ str_set(str,d+1);
+ str_cat(str,"[]");
+ tmp2str = hfetch(symtab,str->str_ptr);
+ if (tmp2str && atoi(tmp2str->str_ptr)) {
+ sprintf(tokenbuf,
+ "foreach %s ($[ .. $#%s) ",
+ s,
+ d+1);
+ }
+ else {
+ sprintf(tokenbuf,
+ "foreach %s (keys %%%s) ",
+ s,
+ d+1);
+ }
+ str_set(str,tokenbuf);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_free(tmpstr);
+ break;
+ case OBLOCK:
+ str = str_new(0);
+ str_set(str,"{");
+ if (len >= 2 && ops[node+2].ival) {
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ fixtab(str,++level);
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ addsemi(str);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ tab(str,level);
+ if (len >= 3) {
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ break;
+ default:
+ def:
+ if (len) {
+ if (len > 5)
+ fatal("Garbage length in walk");
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ for (i = 2; i<= len; i++) {
+ str_scat(str,fstr=walk(0,level,ops[node+i].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ }
+ else {
+ str = Nullstr;
+ }
+ break;
+ }
+ if (!str)
+ str = str_new(0);
+
+ if (useval && prec < minprec) { /* need parens? */
+ fstr = str_new(str->str_cur+2);
+ str_nset(fstr,"(",1);
+ str_scat(fstr,str);
+ str_ncat(fstr,")",1);
+ str_free(str);
+ str = fstr;
+ }
+
+ *numericptr = numeric;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ printf("%3d %5d %15s %d %4d ",level,node,opname[type],len,str->str_cur);
+ for (t = str->str_ptr; *t && t - str->str_ptr < 40; t++)
+ if (*t == '\n')
+ printf("\\n");
+ else if (*t == '\t')
+ printf("\\t");
+ else
+ putchar(*t);
+ putchar('\n');
+ }
+#endif
+ return str;
+}
+
+tab(str,lvl)
+register STR *str;
+register int lvl;
+{
+ while (lvl > 1) {
+ str_cat(str,"\t");
+ lvl -= 2;
+ }
+ if (lvl)
+ str_cat(str," ");
+}
+
+fixtab(str,lvl)
+register STR *str;
+register int lvl;
+{
+ register char *s;
+
+ /* strip trailing white space */
+
+ s = str->str_ptr+str->str_cur - 1;
+ while (s >= str->str_ptr && (*s == ' ' || *s == '\t' || *s == '\n'))
+ s--;
+ s[1] = '\0';
+ str->str_cur = s + 1 - str->str_ptr;
+ if (s >= str->str_ptr && *s != '\n')
+ str_cat(str,"\n");
+
+ tab(str,lvl);
+}
+
+addsemi(str)
+register STR *str;
+{
+ register char *s;
+
+ s = str->str_ptr+str->str_cur - 1;
+ while (s >= str->str_ptr && (*s == ' ' || *s == '\t' || *s == '\n'))
+ s--;
+ if (s >= str->str_ptr && *s != ';' && *s != '}')
+ str_cat(str,";");
+}
+
+emit_split(str,level)
+register STR *str;
+int level;
+{
+ register int i;
+
+ if (split_to_array)
+ str_cat(str,"@Fld");
+ else {
+ str_cat(str,"(");
+ for (i = 1; i < maxfld; i++) {
+ if (i <= arymax)
+ sprintf(tokenbuf,"$%s,",nameary[i]);
+ else
+ sprintf(tokenbuf,"$Fld%d,",i);
+ str_cat(str,tokenbuf);
+ }
+ if (maxfld <= arymax)
+ sprintf(tokenbuf,"$%s)",nameary[maxfld]);
+ else
+ sprintf(tokenbuf,"$Fld%d)",maxfld);
+ str_cat(str,tokenbuf);
+ }
+ if (const_FS) {
+ sprintf(tokenbuf," = split(/[%c\\n]/, $_, 9999);\n",const_FS);
+ str_cat(str,tokenbuf);
+ }
+ else if (saw_FS)
+ str_cat(str," = split($FS, $_, 9999);\n");
+ else
+ str_cat(str," = split(' ', $_, 9999);\n");
+ tab(str,level);
+}
+
+prewalk(numit,level,node,numericptr)
+int numit;
+int level;
+register int node;
+int *numericptr;
+{
+ register int len;
+ register int type;
+ register int i;
+ char *t;
+ char *d, *s;
+ int numarg;
+ int numeric = FALSE;
+ STR *tmpstr;
+ STR *tmp2str;
+
+ if (!node) {
+ *numericptr = 0;
+ return 0;
+ }
+ type = ops[node].ival;
+ len = type >> 8;
+ type &= 255;
+ switch (type) {
+ case OPROG:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ if (ops[node+2].ival) {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ ++level;
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ --level;
+ if (ops[node+3].ival) {
+ prewalk(0,level,ops[node+4].ival,&numarg);
+ }
+ break;
+ case OHUNKS:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ if (len == 3) {
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ }
+ break;
+ case ORANGE:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ break;
+ case OPAT:
+ goto def;
+ case OREGEX:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OHUNK:
+ if (len == 1) {
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ }
+ else {
+ i = prewalk(0,level,ops[node+1].ival,&numarg);
+ if (i) {
+ ++level;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ --level;
+ }
+ else {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ }
+ break;
+ case OPPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OPANDAND:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OPOROR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OPNOT:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OCPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric |= numarg;
+ break;
+ case OCANDAND:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OCOROR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OCNOT:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case ORELOP:
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ numeric |= numarg;
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ numeric |= numarg;
+ numeric = 1;
+ break;
+ case ORPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric |= numarg;
+ break;
+ case OMATCHOP:
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ numeric = 1;
+ break;
+ case OMPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric |= numarg;
+ break;
+ case OCONCAT:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OASSIGN:
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ if (numarg || strlen(ops[ops[node+1].ival+1].cval) > 1) {
+ numericize(ops[node+2].ival);
+ if (!numarg)
+ numericize(ops[node+3].ival);
+ }
+ numeric |= numarg;
+ break;
+ case OADD:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OSUBTRACT:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OMULT:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case ODIV:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPOW:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OMOD:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPOSTINCR:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPOSTDECR:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPREINCR:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPREDECR:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OUMINUS:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OUPLUS:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric |= numarg;
+ break;
+ case OGETLINE:
+ break;
+ case OSPRINTF:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OSUBSTR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ if (len == 3) {
+ prewalk(1,level,ops[node+3].ival,&numarg);
+ }
+ break;
+ case OSTRING:
+ break;
+ case OSPLIT:
+ numeric = 1;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ if (len == 3)
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OINDEX:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OMATCH:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OUSERDEF:
+ subretnum = FALSE;
+ --level;
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ ++level;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+4].ival,&numarg);
+ prewalk(0,level,ops[node+5].ival,&numarg);
+ --level;
+ str_cat(tmpstr,"(");
+ tmp2str = str_new(0);
+ if (subretnum || numarg)
+ str_set(tmp2str,"1");
+ hstore(symtab,tmpstr->str_ptr,tmp2str);
+ str_free(tmpstr);
+ level++;
+ break;
+ case ORETURN:
+ if (len > 0) {
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ if (numarg)
+ subretnum = TRUE;
+ }
+ break;
+ case OUSERFUN:
+ tmp2str = str_new(0);
+ str_scat(tmp2str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ fixrargs(tmpstr->str_ptr,ops[node+2].ival,0);
+ str_free(tmpstr);
+ str_cat(tmp2str,"(");
+ tmpstr = hfetch(symtab,tmp2str->str_ptr);
+ if (tmpstr && tmpstr->str_ptr)
+ numeric |= atoi(tmpstr->str_ptr);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ str_free(tmp2str);
+ break;
+ case OGSUB:
+ case OSUB:
+ if (len >= 3)
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ prewalk(0,level,ops[ops[node+2].ival+1].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case ONUM:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OSTR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case ODEFINED:
+ case ODELETE:
+ case OSTAR:
+ case OVAR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ if (len == 1) {
+ if (numit)
+ numericize(node);
+ }
+ else {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ break;
+ case OFLD:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OVFLD:
+ i = ops[node+1].ival;
+ prewalk(0,level,i,&numarg);
+ break;
+ case OJUNK:
+ goto def;
+ case OSNEWLINE:
+ break;
+ case ONEWLINE:
+ break;
+ case OSCOMMENT:
+ break;
+ case OCOMMENT:
+ break;
+ case OCOMMA:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ break;
+ case OSEMICOLON:
+ break;
+ case OSTATES:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OSTATE:
+ if (len >= 1) {
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ if (len >= 2) {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ }
+ break;
+ case OCLOSE:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OPRINTF:
+ case OPRINT:
+ if (len == 3) { /* output redirection */
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ prewalk(0+(type==OPRINT),level,ops[node+1].ival,&numarg);
+ break;
+ case ORAND:
+ break;
+ case OSRAND:
+ goto maybe0;
+ case OATAN2:
+ goto maybe0;
+ case OSIN:
+ goto maybe0;
+ case OCOS:
+ goto maybe0;
+ case OSYSTEM:
+ goto maybe0;
+ case OLENGTH:
+ goto maybe0;
+ case OLOG:
+ goto maybe0;
+ case OEXP:
+ goto maybe0;
+ case OSQRT:
+ goto maybe0;
+ case OINT:
+ maybe0:
+ numeric = 1;
+ if (len > 0)
+ prewalk(type != OLENGTH && type != OSYSTEM,
+ level,ops[node+1].ival,&numarg);
+ break;
+ case OBREAK:
+ break;
+ case ONEXT:
+ break;
+ case OEXIT:
+ if (len == 1) {
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ }
+ break;
+ case OCONTINUE:
+ break;
+ case OREDIR:
+ goto def;
+ case OIF:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ if (len == 3) {
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ }
+ break;
+ case OWHILE:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OFOR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ prewalk(0,level,ops[node+4].ival,&numarg);
+ break;
+ case OFORIN:
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OBLOCK:
+ if (len == 2) {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ ++level;
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ --level;
+ break;
+ default:
+ def:
+ if (len) {
+ if (len > 5)
+ fatal("Garbage length in prewalk");
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ for (i = 2; i<= len; i++) {
+ prewalk(0,level,ops[node+i].ival,&numarg);
+ }
+ }
+ break;
+ }
+ *numericptr = numeric;
+ return 1;
+}
+
+numericize(node)
+register int node;
+{
+ register int len;
+ register int type;
+ register int i;
+ STR *tmpstr;
+ STR *tmp2str;
+ int numarg;
+
+ type = ops[node].ival;
+ len = type >> 8;
+ type &= 255;
+ if (type == OVAR && len == 1) {
+ tmpstr=walk(0,0,ops[node+1].ival,&numarg,P_MIN);
+ tmp2str = str_make("1");
+ hstore(symtab,tmpstr->str_ptr,tmp2str);
+ }
+}
projects / unix-history / commitdiff