--- /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.)
+#
+# $Header: Configure,v 1.0 87/12/18 15:05:56 root Exp $
+#
+# 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.)
+
+: sanity checks
+PATH='.:/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/local:/usr/lbin:/etc'
+export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0; kill $$)
+
+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
+
+d_eunice=''
+eunicefix=''
+define=''
+loclist=''
+expr=''
+sed=''
+echo=''
+cat=''
+rm=''
+mv=''
+cp=''
+tail=''
+tr=''
+mkdir=''
+sort=''
+uniq=''
+grep=''
+trylist=''
+test=''
+inews=''
+egrep=''
+more=''
+pg=''
+Mcc=''
+vi=''
+mailx=''
+mail=''
+Log=''
+Header=''
+bin=''
+cc=''
+contains=''
+cpp=''
+d_charsprf=''
+d_index=''
+d_strctcpy=''
+d_vfork=''
+libc=''
+libnm=''
+mansrc=''
+manext=''
+models=''
+split=''
+small=''
+medium=''
+large=''
+huge=''
+ccflags=''
+ldflags=''
+n=''
+c=''
+package=''
+spitshell=''
+shsharp=''
+sharpbang=''
+startsh=''
+voidflags=''
+defvoidused=''
+CONFIG=''
+
+: set package name
+package=perl
+
+echo " "
+echo "Beginning of configuration questions for $package kit."
+: Eunice requires " " instead of "", can you believe it
+echo " "
+
+define='define'
+undef='/*undef'
+libpth='/usr/lib /usr/local/lib /lib'
+smallmach='pdp11 i8086 z8000 i80286 iAPX286'
+rmlist='kit[1-9]isdone kit[1-9][0-9]isdone'
+trap 'echo " "; rm -f $rmlist; exit 1' 1 2 3
+attrlist="mc68000 sun gcos unix ibm gimpel interdata tss os mert pyr"
+attrlist="$attrlist vax pdp11 i8086 z8000 u3b2 u3b5 u3b20 u3b200"
+attrlist="$attrlist ns32000 ns16000 iAPX286"
+pth="/usr/ucb /bin /usr/bin /usr/local /usr/local/bin /usr/lbin /etc /usr/lib"
+defvoidused=7
+
+: some greps do not return status, grrr.
+echo "grimblepritz" >grimble
+if grep blurfldyick grimble >/dev/null 2>&1 ; then
+ contains=contains
+elif grep grimblepritz grimble >/dev/null 2>&1 ; then
+ contains=grep
+else
+ contains=contains
+fi
+rm -f grimble
+: 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 755 contains
+esac
+
+: 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
+rm -f .echotmp
+
+: now set up to do reads with possible shell escape and default assignment
+cat <<EOSC >myread
+ans='!'
+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@sdcrdcf.UUCP) 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
+
+: get old answers, if there is a config file out there
+if test -f ../config.sh; then
+ echo " "
+ dflt=y
+ 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.";;
+ *) echo "Fetching default answers from your old config.sh file..."
+ tmp="$n"
+ ans="$c"
+ . ../config.sh
+ n="$tmp"
+ c="$ans"
+ ;;
+ esac
+fi
+
+: 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
+ fi
+ ;;
+ esac
+done
+echo \$dflt
+exit 1
+EOSC
+chmod 755 loc
+$eunicefix loc
+loclist="
+expr
+sed
+echo
+cat
+rm
+mv
+cp
+tr
+mkdir
+sort
+uniq
+grep
+"
+trylist="
+test
+egrep
+Mcc
+"
+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)
+ echo " "
+ dflt=n
+ rp="Is your "'"'"test"'"'" built into sh? [$dflt] (OK to guess)"
+ echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ y*) test=test ;;
+ esac
+ ;;
+*)
+ 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" >foo1
+ echo $n "hi there$c" >foo2
+ if cmp foo1 foo2 >/dev/null 2>&1; then
+ echo "They are compatible. In fact, they may be identical."
+ else
+ case "$n" in
+ '-n') n='' c='\c' 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
+ $rm -f foo1 foo2
+ ;;
+*)
+ : cross your fingers
+ echo=echo
+ ;;
+esac
+rmlist="$rmlist loc"
+
+: get list of predefined functions in a handy place
+echo " "
+if test -f /lib/libc.a; then
+ echo "Your C library is in /lib/libc.a. You're normal."
+ libc=/lib/libc.a
+else
+ ans=`loc libc.a blurfl/dyick $libpth`
+ if test -f $ans; then
+ echo "Your C library is in $ans, of all places."
+ libc=ans
+ else
+ if test -f "$libc"; then
+ echo "Your C library is in $libc, like you said before."
+ 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
+fi
+echo " "
+$echo $n "Extracting names from $libc for later perusal...$c"
+if ar t $libc > libc.list; then
+ echo "done"
+else
+ echo " "
+ echo "The archiver doesn't think $libc is a reasonable library."
+ echo "Trying nm instead..."
+ if nm -g $libc > libc.list; then
+ echo "Done. Maybe this is Unicos, or an Apollo?"
+ else
+ echo "That didn't work either. Giving up."
+ exit 1
+ fi
+fi
+rmlist="$rmlist libc.list"
+
+: make some quick guesses about what we are up against
+echo " "
+$echo $n "Hmm... $c"
+if $contains SIGTSTP /usr/include/signal.h >/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
+elif $contains fcntl libc.list >/dev/null 2>&1 ; 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
+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
+if $contains vmssystem libc.list >/dev/null 2>&1 ; then
+ 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
+ eunicefix=unixtovms
+ d_eunice="$define"
+: it so happens the Eunice I know will not run shell scripts in Unix format
+else
+ echo " "
+ echo "Congratulations. You aren't running Eunice."
+ eunicefix=':'
+ d_eunice="$undef"
+ echo "exit 1" >eunice
+fi
+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 755 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 755 bsd usg v7 eunice venix xenix
+$eunicefix bsd usg v7 eunice venix xenix
+rmlist="$rmlist bsd usg v7 eunice venix xenix"
+
+: 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..."
+ echo "#!/bin/echo hi" > try
+ $eunicefix try
+ chmod 755 try
+ try > today
+ if test -s today; then
+ echo "It does."
+ sharpbang='#!'
+ else
+ echo "#! /bin/echo hi" > try
+ $eunicefix try
+ chmod 755 try
+ try > 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 755 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 >try <<EOSS
+$startsh
+set abc
+test "$?abc" != 1
+EOSS
+
+chmod 755 try
+$eunicefix try
+if try; then
+ echo "Yup, it does."
+else
+ echo "Nope. You may have to fix up the shell scripts to make sure sh runs them."
+fi
+rm -f try today
+
+: see if sprintf is declared as int or pointer to char
+echo " "
+if $contains 'char.*sprintf' /usr/include/stdio.h >/dev/null 2>&1 ; then
+ echo "Your sprintf() returns (char*)."
+ d_charsprf="$define"
+else
+ echo "Your sprintf() returns (int)."
+ d_charsprf="$undef"
+fi
+
+: index or strcpy
+echo " "
+dflt=y
+if $contains index libc.list >/dev/null 2>&1 ; then
+ echo "Your system appears to use index() and rindex() rather than strchr()"
+ $echo $n "and strrchr(). Is this correct? [$dflt] $c"
+ rp='index() rather than strchr()? [$dflt]'
+ . myread
+ case "$ans" in
+ n*|f*) d_index="$define" ;;
+ *) d_index="$undef" ;;
+ esac
+else
+ echo "Your system appears to use strchr() and strrchr() rather than index()"
+ $echo $n "and rindex(). Is this correct? [$dflt] $c"
+ rp='strchr() rather than index()? [$dflt]'
+ . myread
+ case "$ans" in
+ n*|f*) d_index="$undef" ;;
+ *) d_index="$define" ;;
+ esac
+fi
+
+: check for structure copying
+echo " "
+echo "Checking to see if your C compiler can copy structs..."
+$cat >try.c <<'EOCP'
+main()
+{
+ struct blurfl {
+ int dyick;
+ } foo, bar;
+
+ foo = bar;
+}
+EOCP
+if cc -c try.c >/dev/null 2>&1 ; then
+ d_strctcpy="$define"
+ echo "Yup, it can."
+else
+ d_strctcpy="$undef"
+ echo "Nope, it can't."
+fi
+$rm -f try.*
+
+: see if there is a vfork
+echo " "
+if $contains vfork libc.list >/dev/null 2>&1 ; then
+ echo "vfork() found."
+ d_vfork="$undef"
+else
+ echo "No vfork() found--will use fork() instead."
+ d_vfork="$define"
+fi
+
+: 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 "$voidflags" in
+'')
+ $cat >try.c <<'EOCP'
+#if TRY & 1
+void main() {
+#else
+main() {
+#endif
+ extern void *moo();
+ void (*goo)();
+#if TRY & 2
+ void (*foo[10])();
+#endif
+
+#if TRY & 4
+ if(goo == moo) {
+ exit(0);
+ }
+#endif
+ exit(0);
+}
+EOCP
+ if cc -S -DTRY=7 try.c >.out 2>&1 ; then
+ voidflags=7
+ echo "It appears to support void fully."
+ if $contains warning .out >/dev/null 2>&1; then
+ echo "However, you might get some warnings that look like this:"
+ $cat .out
+ fi
+ else
+ echo "Hmm, you compiler has some difficulty with void. Checking further..."
+ if cc -S -DTRY=1 try.c >/dev/null 2>&1 ; then
+ echo "It supports 1..."
+ if cc -S -DTRY=3 try.c >/dev/null 2>&1 ; then
+ voidflags=3
+ echo "And it supports 2 but not 4."
+ else
+ echo "It doesn't support 2..."
+ if cc -S -DTRY=3 try.c >/dev/null 2>&1 ; then
+ voidflags=5
+ echo "But it supports 4."
+ else
+ voidflags=1
+ echo "And it doesn't support 4."
+ fi
+ fi
+ else
+ echo "There is no support at all for void."
+ voidflags=0
+ fi
+ fi
+esac
+dflt="$voidflags";
+rp="Your void support flags add up to what? [$dflt]"
+$echo $n "$rp $c"
+. myread
+voidflags="$ans"
+$rm -f try.* .out
+
+: preserve RCS keywords in files with variable substitution, grrr
+Log='$Log'
+Header='$Header'
+
+: 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 755 filexp
+$eunicefix filexp
+
+: determine where public executables go
+case "$bin" in
+'')
+ dflt=`loc . /bin /usr/local/bin /usr/lbin /usr/local /usr/bin`
+ ;;
+*) dflt="$bin"
+ ;;
+esac
+cont=true
+while $test "$cont" ; do
+ echo " "
+ rp="Where do you want to put the public executables? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ bin="$ans"
+ bin=`filexp $bin`
+ if test -d $bin; then
+ cont=''
+ else
+ dflt=n
+ 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
+
+: determine where manual pages go
+case "$mansrc" in
+'')
+ dflt=`loc . /usr/man/man1 /usr/man/mann /usr/man/local/man1 /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? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ mansrc=`filexp "$ans"`
+ if test -d $mansrc; then
+ cont=''
+ else
+ dflt=n
+ rp="Directory $mansrc doesn't exist. Use that name anyway? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ dflt=''
+ case "$ans" in
+ y*) cont='';;
+ esac
+ fi
+done
+case "$mansrc" in
+*l)
+ manext=l
+ ;;
+*n)
+ manext=n
+ ;;
+*)
+ manext=1
+ ;;
+esac
+
+: see how we invoke the C preprocessor
+echo " "
+echo "Checking to see how your C preprocessor is invoked..."
+cat <<'EOT' >testcpp.c
+#define ABC abc
+#define XYZ xyz
+ABC.XYZ
+EOT
+echo 'Maybe "cc -E" will work...'
+cc -E testcpp.c >testcpp.out 2>&1
+if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yup, it does."
+ cpp='cc -E'
+else
+ echo 'Nope...maybe "cc -P" will work...'
+ cc -P testcpp.c >testcpp.out 2>&1
+ if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yup, that does."
+ cpp='cc -P'
+ else
+ echo 'Nixed again...maybe "/lib/cpp" will work...'
+ /lib/cpp testcpp.c >testcpp.out 2>&1
+ if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Hooray, it works! I was beginning to wonder."
+ cpp='/lib/cpp'
+ else
+ echo 'Hmm...maybe you already told me...'
+ case "$cpp" in
+ '') ;;
+ *) $cpp testcpp.c >testcpp.out 2>&1;;
+ esac
+ if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Hooray, you did! I was beginning to wonder."
+ else
+ dflt=blurfl
+ $echo $n "Nope. I can't find a C preprocessor. Name one: $c"
+ rp='Name a C preprocessor:'
+ . myread
+ cpp="$ans"
+ $cpp 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."
+ exit 1
+ fi
+ fi
+ fi
+ fi
+fi
+rm -f testcpp.c testcpp.out
+
+: get C preprocessor symbols handy
+echo " "
+echo $attrlist | $tr '[ ]' '[\012]' >Cppsym.know
+$cat <<EOSS >Cppsym
+$startsh
+case "\$1" in
+-l) list=true
+ shift
+ ;;
+esac
+unknown=''
+case "\$list\$#" in
+1|2)
+ for sym do
+ if $contains "^\$1$" Cppsym.true >/dev/null 2>&1; then
+ exit 0
+ elif $contains "^\$1$" Cppsym.know >/dev/null 2>&1; then
+ :
+ else
+ unknown="\$unknown \$sym"
+ fi
+ done
+ set X \$unknown
+ shift
+ ;;
+esac
+case \$# in
+0) exit 1;;
+esac
+echo \$* | $tr '[ ]' '[\012]' | $sed -e 's/\(.*\)/\\
+#ifdef \1\\
+exit 0; _ _ _ _\1\\ \1\\
+#endif\\
+/' >/tmp/Cppsym\$\$
+echo exit 1 >>/tmp/Cppsym\$\$
+$cpp /tmp/Cppsym\$\$ >/tmp/Cppsym2\$\$
+case "\$list" in
+true) awk '\$6 != "" {print substr(\$6,2,100)}' </tmp/Cppsym2\$\$ ;;
+*)
+ sh /tmp/Cppsym2\$\$
+ status=\$?
+ ;;
+esac
+$rm -f /tmp/Cppsym\$\$ /tmp/Cppsym2\$\$
+exit \$status
+EOSS
+chmod 755 Cppsym
+$eunicefix Cppsym
+echo "Your C preprocessor defines the following symbols:"
+Cppsym -l $attrlist >Cppsym.true
+cat Cppsym.true
+rmlist="$rmlist Cppsym Cppsym.know Cppsym.true"
+
+: see what memory models we can support
+case "$models" in
+'')
+ if Cppsym pdp11; 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/ld.1 >/dev/null 2>&1 || \
+ $contains '-i' $mansrc/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 "$model" 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 "$model" 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 "$model" 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 "$model" 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
+
+case "$ccflags" in
+'') dflt='none';;
+*) dflt="$ccflags";;
+esac
+echo " "
+rp="Any additional cc flags? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+none) ans='';
+esac
+ccflags="$ans"
+
+case "$ldflags" in
+'') if venix; then
+ dflt='-i -z'
+ else
+ dflt='none'
+ fi
+ ;;
+*) dflt="$ldflags";;
+esac
+echo " "
+rp="Any additional ld flags? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+none) ans='';
+esac
+ldflags="$ans"
+
+: 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!) What command will force resolution on
+EOM
+ $echo $n "this system? [$dflt] $c"
+ rp="Command to resolve multiple refs? [$dflt]"
+ . myread
+ cc="$ans"
+else
+ echo "Not a USG system--assuming cc can resolve multiple definitions."
+ cc=cc
+fi
+
+: see if we should include -lnm
+echo " "
+if $test -r /usr/lib/libnm.a || $test -r /usr/local/lib/libnm.a ; then
+ echo "New math library found."
+ libnm='-lnm'
+else
+ ans=`loc libtermlib.a x $libpth`
+ case "$ans" in
+ x)
+ echo "No nm library found--the normal math library will have to do."
+ libnm=''
+ ;;
+ *)
+ echo "New math library found in $ans."
+ libnm="$ans"
+ ;;
+ esac
+fi
+
+echo " "
+echo "End of configuration questions."
+echo " "
+
+: create config.sh file
+echo " "
+if test -d ../UU; then
+ cd ..
+fi
+echo "Creating config.sh..."
+$spitshell <<EOT >config.sh
+$startsh
+# config.sh
+# This file was produced by running the Configure script.
+
+d_eunice='$d_eunice'
+eunicefix='$eunicefix'
+define='$define'
+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'
+Log='$Log'
+Header='$Header'
+bin='$bin'
+cc='$cc'
+contains='$contains'
+cpp='$cpp'
+d_charsprf='$d_charsprf'
+d_index='$d_index'
+d_strctcpy='$d_strctcpy'
+d_vfork='$d_vfork'
+libc='$libc'
+libnm='$libnm'
+mansrc='$mansrc'
+manext='$manext'
+models='$models'
+split='$split'
+small='$small'
+medium='$medium'
+large='$large'
+huge='$huge'
+ccflags='$ccflags'
+ldflags='$ldflags'
+n='$n'
+c='$c'
+package='$package'
+spitshell='$spitshell'
+shsharp='$shsharp'
+sharpbang='$sharpbang'
+startsh='$startsh'
+voidflags='$voidflags'
+defvoidused='$defvoidused'
+CONFIG=true
+EOT
+
+CONFIG=true
+
+echo " "
+dflt=''
+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
+
+echo " "
+echo "Doing variable substitutions on .SH files..."
+set `$grep '\.SH' <MANIFEST | awk '{print $1}'`
+for file in $*; do
+ 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
+
+if $contains '^depend:' Makefile >/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 Makefile; then
+ echo " "
+ echo "Now you must run a make."
+else
+ echo "Done."
+fi
+
+$rm -f kit*isdone
+cd UU && $rm -f $rmlist
+: end of Configure
--- /dev/null
+/* $Header: EXTERN.h,v 1.0 87/12/18 13:02:26 root Exp $
+ *
+ * $Log: EXTERN.h,v $
+ * Revision 1.0 87/12/18 13:02:26 root
+ * Initial revision
+ *
+ */
+
+#undef EXT
+#define EXT extern
+
+#undef INIT
+#define INIT(x)
+
+#undef DOINIT
--- /dev/null
+/* $Header: INTERN.h,v 1.0 87/12/18 13:02:39 root Exp $
+ *
+ * $Log: INTERN.h,v $
+ * Revision 1.0 87/12/18 13:02:39 root
+ * Initial revision
+ *
+ */
+
+#undef EXT
+#define EXT
+
+#undef INIT
+#define INIT(x) = x
+
+#define DOINIT
--- /dev/null
+After all the perl kits are run you should have the following files:
+
+Filename Kit Description
+-------- --- -----------
+Configure 6 Run this first
+EXTERN.h 10 Included before foreign .h files
+INTERN.h 10 Included before domestic .h files
+MANIFEST 8 This list of files
+Makefile.SH 4 Precursor to Makefile
+README 1 The Instructions
+Wishlist 10 Some things that may or may not happen
+arg.c 3 Expression evaluation
+arg.h 8 Public declarations for the above
+array.c 6 Numerically subscripted arrays
+array.h 10 Public declarations for the above
+cmd.c 7 Command interpreter
+cmd.h 9 Public declarations for the above
+config.H 9 Sample config.h
+config.h.SH 9 Produces config.h.
+dump.c 8 Debugging output
+form.c 8 Format processing
+form.h 10 Public declarations for the above
+handy.h 10 Handy definitions
+hash.c 9 Associative arrays
+hash.h 10 Public declarations for the above
+makedepend.SH 9 Precursor to makedepend
+makedir.SH 10 Precursor to makedir
+malloc.c 7 A version of malloc you might not want
+patchlevel.h 1 The current patch level of perl
+perl.h 9 Global declarations
+perl.man.1 5 The manual page(s), first half
+perl.man.2 4 The manual page(s), second half
+perl.y 5 Yacc grammar for perl
+perly.c 2 The perl compiler
+search.c 6 String matching
+search.h 10 Public declarations for the above
+spat.h 10 Search pattern declarations
+stab.c 8 Symbol table stuff
+stab.h 10 Public declarations for the above
+str.c 4 String handling package
+str.h 10 Public declarations for the above
+t/README 10 Instructions for regression tests
+t/TEST 10 The regression tester
+t/base.cond 10 See if conditionals work
+t/base.if 10 See if if works
+t/base.lex 10 See if lexical items work
+t/base.pat 10 See if pattern matching works
+t/base.term 10 See if various terms work
+t/cmd.elsif 10 See if else-if works
+t/cmd.for 10 See if for loops work
+t/cmd.mod 10 See if statement modifiers work
+t/cmd.subval 10 See if subroutine values work
+t/cmd.while 7 See if while loops work
+t/comp.cmdopt 9 See if command optimization works
+t/comp.cpp 10 See if C preprocessor works
+t/comp.decl 10 See if declarations work
+t/comp.multiline 10 See if multiline strings work
+t/comp.script 10 See if script invokation works
+t/comp.term 10 See if more terms work
+t/io.argv 10 See if ARGV stuff works
+t/io.fs 5 See if directory manipulations work
+t/io.inplace 10 See if inplace editing works
+t/io.print 10 See if print commands work
+t/io.tell 10 See if file seeking works
+t/op.append 10 See if . works
+t/op.auto 9 See if autoincrement et all work
+t/op.chop 10 See if chop works
+t/op.cond 10 See if conditional expressions work
+t/op.crypt 10 See if crypt works
+t/op.do 10 See if subroutines work
+t/op.each 10 See if associative iterators work
+t/op.exec 10 See if exec and system work
+t/op.exp 10 See if math functions work
+t/op.flip 10 See if range operator works
+t/op.fork 10 See if fork works
+t/op.goto 10 See if goto works
+t/op.int 10 See if int works
+t/op.join 10 See if join works
+t/op.list 10 See if array lists work
+t/op.magic 10 See if magic variables work
+t/op.oct 10 See if oct and hex work
+t/op.ord 10 See if ord works
+t/op.pat 9 See if esoteric patterns work
+t/op.push 7 See if push and pop work
+t/op.repeat 10 See if x operator works
+t/op.sleep 6 See if sleep works
+t/op.split 10 See if split works
+t/op.sprintf 10 See if sprintf work
+t/op.stat 10 See if stat work
+t/op.subst 10 See if substitutions work
+t/op.time 10 See if time functions work
+t/op.unshift 10 See if unshift works
+util.c 9 Utility routines
+util.h 10 Public declarations for the above
+version.c 10 Prints version of perl
+x2p/EXTERN.h 10 Same as above
+x2p/INTERN.h 10 Same as above
+x2p/Makefile.SH 9 Precursor to Makefile
+x2p/a2p.h 8 Global declarations
+x2p/a2p.man 8 Manual page for awk to perl translator
+x2p/a2p.y 8 A yacc grammer for awk
+x2p/a2py.c 7 Awk compiler, sort of
+x2p/handy.h 10 Handy definitions
+x2p/hash.c 9 Associative arrays again
+x2p/hash.h 10 Public declarations for the above
+x2p/s2p 1 Sed to perl translator
+x2p/s2p.man 10 Manual page for sed to perl translator
+x2p/str.c 7 String handling package
+x2p/str.h 10 Public declarations for the above
+x2p/util.c 9 Utility routines
+x2p/util.h 10 Public declarations for the above
+x2p/walk.c 1 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
+ . config.sh
+ ;;
+esac
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting Makefile (with variable substitutions)"
+cat >Makefile <<!GROK!THIS!
+# $Header: Makefile.SH,v 1.0 87/12/18 16:11:50 root Exp $
+#
+# $Log: Makefile.SH,v $
+# Revision 1.0 87/12/18 16:11:50 root
+# Initial revision
+#
+# Revision 1.0 87/12/18 16:01:07 root
+# Initial revision
+#
+#
+
+CC = $cc
+bin = $bin
+lib = $lib
+mansrc = $mansrc
+manext = $manext
+CFLAGS = $ccflags -O
+LDFLAGS = $ldflags
+SMALL = $small
+LARGE = $large $split
+
+libs = $libnm -lm
+!GROK!THIS!
+
+cat >>Makefile <<'!NO!SUBS!'
+
+public = perl
+
+private =
+
+manpages = perl.man
+
+util =
+
+sh = Makefile.SH makedepend.SH
+
+h1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h form.h handy.h
+h2 = hash.h perl.h search.h spat.h stab.h str.h util.h
+
+h = $(h1) $(h2)
+
+c1 = arg.c array.c cmd.c dump.c form.c hash.c malloc.c
+c2 = search.c stab.c str.c util.c version.c
+
+c = $(c1) $(c2)
+
+obj1 = arg.o array.o cmd.o dump.o form.o hash.o malloc.o
+obj2 = search.o stab.o str.o util.o version.o
+
+obj = $(obj1) $(obj2)
+
+lintflags = -phbvxac
+
+addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
+
+# grrr
+SHELL = /bin/sh
+
+.c.o:
+ $(CC) -c $(CFLAGS) $(LARGE) $*.c
+
+all: $(public) $(private) $(util)
+ touch all
+
+perl: $(obj) perl.o
+ $(CC) $(LDFLAGS) $(LARGE) $(obj) perl.o $(libs) -o perl
+
+perl.c: perl.y
+ @ echo Expect 2 shift/reduce errors...
+ yacc perl.y
+ mv y.tab.c perl.c
+
+perl.o: perl.c perly.c perl.h EXTERN.h search.h util.h INTERN.h handy.h
+ $(CC) -c $(CFLAGS) $(LARGE) perl.c
+
+# if a .h file depends on another .h file...
+$(h):
+ touch $@
+
+perl.man: perl.man.1 perl.man.2
+ cat perl.man.1 perl.man.2 >perl.man
+
+install: perl perl.man
+# won't work with csh
+ export PATH || exit 1
+ - mv $(bin)/perl $(bin)/perl.old
+ - if test `pwd` != $(bin); then cp $(public) $(bin); fi
+ cd $(bin); \
+for pub in $(public); do \
+chmod 755 `basename $$pub`; \
+done
+ - test $(bin) = /bin || rm -f /bin/perl
+ - test $(bin) = /bin || ln -s $(bin)/perl /bin || cp $(bin)/perl /bin
+# chmod 755 makedir
+# - makedir `filexp $(lib)`
+# - \
+#if test `pwd` != `filexp $(lib)`; then \
+#cp $(private) `filexp $(lib)`; \
+#fi
+# cd `filexp $(lib)`; \
+#for priv in $(private); do \
+#chmod 755 `basename $$priv`; \
+#done
+ - if test `pwd` != $(mansrc); then \
+for page in $(manpages); do \
+cp $$page $(mansrc)/`basename $$page .man`.$(manext); \
+done; \
+fi
+
+clean:
+ rm -f *.o
+
+realclean:
+ rm -f perl *.orig */*.orig *.o core $(addedbyconf)
+
+# 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) > perl.fuzz
+
+depend: makedepend
+ makedepend
+
+test: perl
+ chmod 755 t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.*
+ cd t && (rm -f perl; ln -s ../perl . || ln ../perl .) && TEST
+
+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):
+ @ 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
--- /dev/null
+
+ Perl Kit, Version 1.0
+
+ Copyright (c) 1987, Larry Wall
+
+You may copy the perl kit in whole or in part as long as you don't try to
+make money off it, or pretend that you wrote it.
+--------------------------------------------------------------------------
+
+Perl is a language that combines some of the features of C, sed, awk and shell.
+See the manual page for more hype.
+
+Perl will probably not run on machines with a small address space.
+
+Please read all the directions below before you proceed any further, and
+then follow them carefully. Failure to do so may void your warranty. :-)
+
+After you have unpacked your kit, you should have all the files listed
+in MANIFEST.
+
+Installation
+
+1) Run Configure. This will figure out various things about your system.
+ Some things Configure will figure out for itself, other things it will
+ ask you about. It will then proceed to make config.h, config.sh, and
+ Makefile.
+
+ You might possibly have to trim # comments from the front of Configure
+ if your sh doesn't handle them, but all other # comments will be taken
+ care of.
+
+ (If you don't have sh, you'll have to copy the sample file config.H to
+ config.h and edit the config.h to reflect your system's peculiarities.)
+
+2) Glance through config.h to make sure system dependencies are correct.
+ Most of them should have been taken care of by running the Configure script.
+
+ If you have any additional changes to make to the C definitions, they
+ can be done in the Makefile, or in config.h. Bear in mind that they will
+ get undone next time you run Configure.
+
+3) make depend
+
+ This will look for all the includes and modify Makefile accordingly.
+ Configure will offer to do this for you.
+
+4) make
+
+ This will attempt to make perl in the current directory.
+
+5) make test
+
+ This will run the regression tests on the perl you just made.
+ If it doesn't say "All tests successful" then something went wrong.
+ See the README in the t subdirectory.
+
+6) make install
+
+ This will put perl into a public directory (normally /usr/local/bin).
+ It will also try to put the man pages in a reasonable place. It will not
+ nroff the man page, however. You may need to be root to do this. If
+ you are not root, you must own the directories in question and you should
+ ignore any messages about chown not working.
+
+7) Read the manual entry before running perl.
+
+8) Go down to the x2p directory and do a "make depend, a "make" and a
+ "make install" to create the awk to perl and sed to perl translators.
+
+9) IMPORTANT! Help save the world! Communicate any problems and suggested
+ patches to me, lwall@jpl-devvax.jpl.nasa.gov (Larry Wall), so we can
+ keep the world in sync. If you have a problem, there's someone else
+ out there who either has had or will have the same problem.
+
+ If possible, send in patches such that the patch program will apply them.
+ Context diffs are the best, then normal diffs. Don't send ed scripts--
+ I've probably changed my copy since the version you have.
+
+ Watch for perl patches in comp.sources.bugs. Patches will generally be
+ in a form usable by the patch program. If you are just now bringing up
+ perl and aren't sure how many patches there are, write to me and I'll
+ send any you don't have. Your current patch level is shown in patchlevel.h.
+
--- /dev/null
+date support
+case statement
+ioctl() support
+random numbers
+directory reading via <>
--- /dev/null
+/* $Header: arg.c,v 1.0 87/12/18 13:04:33 root Exp $
+ *
+ * $Log: arg.c,v $
+ * Revision 1.0 87/12/18 13:04:33 root
+ * Initial revision
+ *
+ */
+
+#include <signal.h>
+#include "handy.h"
+#include "EXTERN.h"
+#include "search.h"
+#include "util.h"
+#include "perl.h"
+
+ARG *debarg;
+
+bool
+do_match(s,arg)
+register char *s;
+register ARG *arg;
+{
+ register SPAT *spat = arg[2].arg_ptr.arg_spat;
+ register char *d;
+ register char *t;
+
+ if (!spat || !s)
+ fatal("panic: do_match\n");
+ if (spat->spat_flags & SPAT_USED) {
+#ifdef DEBUGGING
+ if (debug & 8)
+ deb("2.SPAT USED\n");
+#endif
+ return FALSE;
+ }
+ if (spat->spat_runtime) {
+ t = str_get(eval(spat->spat_runtime,Null(STR***)));
+#ifdef DEBUGGING
+ if (debug & 8)
+ deb("2.SPAT /%s/\n",t);
+#endif
+ if (d = compile(&spat->spat_compex,t,TRUE,FALSE)) {
+#ifdef DEBUGGING
+ deb("/%s/: %s\n", t, d);
+#endif
+ return FALSE;
+ }
+ if (spat->spat_compex.complen <= 1 && curspat)
+ spat = curspat;
+ if (execute(&spat->spat_compex, s, TRUE, 0)) {
+ if (spat->spat_compex.numsubs)
+ curspat = spat;
+ return TRUE;
+ }
+ else
+ return FALSE;
+ }
+ else {
+#ifdef DEBUGGING
+ if (debug & 8) {
+ char ch;
+
+ if (spat->spat_flags & SPAT_USE_ONCE)
+ ch = '?';
+ else
+ ch = '/';
+ deb("2.SPAT %c%s%c\n",ch,spat->spat_compex.precomp,ch);
+ }
+#endif
+ if (spat->spat_compex.complen <= 1 && curspat)
+ spat = curspat;
+ if (spat->spat_first) {
+ if (spat->spat_flags & SPAT_SCANFIRST) {
+ str_free(spat->spat_first);
+ spat->spat_first = Nullstr; /* disable optimization */
+ }
+ else if (*spat->spat_first->str_ptr != *s ||
+ strnNE(spat->spat_first->str_ptr, s, spat->spat_flen) )
+ return FALSE;
+ }
+ if (execute(&spat->spat_compex, s, TRUE, 0)) {
+ if (spat->spat_compex.numsubs)
+ curspat = spat;
+ if (spat->spat_flags & SPAT_USE_ONCE)
+ spat->spat_flags |= SPAT_USED;
+ return TRUE;
+ }
+ else
+ return FALSE;
+ }
+ /*NOTREACHED*/
+}
+
+int
+do_subst(str,arg)
+STR *str;
+register ARG *arg;
+{
+ register SPAT *spat;
+ register STR *dstr;
+ register char *s;
+ register char *m;
+
+ spat = arg[2].arg_ptr.arg_spat;
+ s = str_get(str);
+ if (!spat || !s)
+ fatal("panic: do_subst\n");
+ else if (spat->spat_runtime) {
+ char *d;
+
+ m = str_get(eval(spat->spat_runtime,Null(STR***)));
+ if (d = compile(&spat->spat_compex,m,TRUE,FALSE)) {
+#ifdef DEBUGGING
+ deb("/%s/: %s\n", m, d);
+#endif
+ return 0;
+ }
+ }
+#ifdef DEBUGGING
+ if (debug & 8) {
+ deb("2.SPAT /%s/\n",spat->spat_compex.precomp);
+ }
+#endif
+ if (spat->spat_compex.complen <= 1 && curspat)
+ spat = curspat;
+ if (spat->spat_first) {
+ if (spat->spat_flags & SPAT_SCANFIRST) {
+ str_free(spat->spat_first);
+ spat->spat_first = Nullstr; /* disable optimization */
+ }
+ else if (*spat->spat_first->str_ptr != *s ||
+ strnNE(spat->spat_first->str_ptr, s, spat->spat_flen) )
+ return 0;
+ }
+ if (m = execute(&spat->spat_compex, s, TRUE, 1)) {
+ int iters = 0;
+
+ dstr = str_new(str_len(str));
+ if (spat->spat_compex.numsubs)
+ curspat = spat;
+ do {
+ if (iters++ > 10000)
+ fatal("Substitution loop?\n");
+ if (spat->spat_compex.numsubs)
+ s = spat->spat_compex.subbase;
+ str_ncat(dstr,s,m-s);
+ s = spat->spat_compex.subend[0];
+ str_scat(dstr,eval(spat->spat_repl,Null(STR***)));
+ if (spat->spat_flags & SPAT_USE_ONCE)
+ break;
+ } while (m = execute(&spat->spat_compex, s, FALSE, 1));
+ str_cat(dstr,s);
+ str_replace(str,dstr);
+ STABSET(str);
+ return iters;
+ }
+ return 0;
+}
+
+int
+do_trans(str,arg)
+STR *str;
+register ARG *arg;
+{
+ register char *tbl;
+ register char *s;
+ register int matches = 0;
+ register int ch;
+
+ tbl = arg[2].arg_ptr.arg_cval;
+ s = str_get(str);
+ if (!tbl || !s)
+ fatal("panic: do_trans\n");
+#ifdef DEBUGGING
+ if (debug & 8) {
+ deb("2.TBL\n");
+ }
+#endif
+ while (*s) {
+ if (ch = tbl[*s & 0377]) {
+ matches++;
+ *s = ch;
+ }
+ s++;
+ }
+ STABSET(str);
+ return matches;
+}
+
+int
+do_split(s,spat,retary)
+register char *s;
+register SPAT *spat;
+STR ***retary;
+{
+ register STR *dstr;
+ register char *m;
+ register ARRAY *ary;
+ static ARRAY *myarray = Null(ARRAY*);
+ int iters = 0;
+ STR **sarg;
+ register char *e;
+ int i;
+
+ if (!spat || !s)
+ fatal("panic: do_split\n");
+ else if (spat->spat_runtime) {
+ char *d;
+
+ m = str_get(eval(spat->spat_runtime,Null(STR***)));
+ if (d = compile(&spat->spat_compex,m,TRUE,FALSE)) {
+#ifdef DEBUGGING
+ deb("/%s/: %s\n", m, d);
+#endif
+ return FALSE;
+ }
+ }
+#ifdef DEBUGGING
+ if (debug & 8) {
+ deb("2.SPAT /%s/\n",spat->spat_compex.precomp);
+ }
+#endif
+ if (retary)
+ ary = myarray;
+ else
+ ary = spat->spat_repl[1].arg_ptr.arg_stab->stab_array;
+ if (!ary)
+ myarray = ary = anew();
+ ary->ary_fill = -1;
+ while (*s && (m = execute(&spat->spat_compex, s, (iters == 0), 1))) {
+ if (spat->spat_compex.numsubs)
+ s = spat->spat_compex.subbase;
+ dstr = str_new(m-s);
+ str_nset(dstr,s,m-s);
+ astore(ary, iters++, dstr);
+ if (iters > 10000)
+ fatal("Substitution loop?\n");
+ s = spat->spat_compex.subend[0];
+ }
+ if (*s) { /* ignore field after final "whitespace" */
+ dstr = str_new(0); /* if they interpolate, it's null anyway */
+ str_set(dstr,s);
+ astore(ary, iters++, dstr);
+ }
+ else {
+ while (iters > 0 && !*str_get(afetch(ary,iters-1)))
+ iters--;
+ }
+ if (retary) {
+ sarg = (STR**)safemalloc((iters+2)*sizeof(STR*));
+
+ sarg[0] = Nullstr;
+ sarg[iters+1] = Nullstr;
+ for (i = 1; i <= iters; i++)
+ sarg[i] = afetch(ary,i-1);
+ *retary = sarg;
+ }
+ return iters;
+}
+
+void
+do_join(arg,delim,str)
+register ARG *arg;
+register char *delim;
+register STR *str;
+{
+ STR **tmpary; /* must not be register */
+ register STR **elem;
+
+ (void)eval(arg[2].arg_ptr.arg_arg,&tmpary);
+ elem = tmpary+1;
+ if (*elem)
+ str_sset(str,*elem++);
+ for (; *elem; elem++) {
+ str_cat(str,delim);
+ str_scat(str,*elem);
+ }
+ STABSET(str);
+ safefree((char*)tmpary);
+}
+
+bool
+do_open(stab,name)
+STAB *stab;
+register char *name;
+{
+ FILE *fp;
+ int len = strlen(name);
+ register STIO *stio = stab->stab_io;
+
+ while (len && isspace(name[len-1]))
+ name[--len] = '\0';
+ if (!stio)
+ stio = stab->stab_io = stio_new();
+ if (stio->fp) {
+ if (stio->type == '|')
+ pclose(stio->fp);
+ else if (stio->type != '-')
+ fclose(stio->fp);
+ stio->fp = Nullfp;
+ }
+ stio->type = *name;
+ if (*name == '|') {
+ for (name++; isspace(*name); name++) ;
+ fp = popen(name,"w");
+ }
+ else if (*name == '>' && name[1] == '>') {
+ for (name += 2; isspace(*name); name++) ;
+ fp = fopen(name,"a");
+ }
+ else if (*name == '>') {
+ for (name++; isspace(*name); name++) ;
+ if (strEQ(name,"-")) {
+ fp = stdout;
+ stio->type = '-';
+ }
+ else
+ fp = fopen(name,"w");
+ }
+ else {
+ if (*name == '<') {
+ for (name++; isspace(*name); name++) ;
+ if (strEQ(name,"-")) {
+ fp = stdin;
+ stio->type = '-';
+ }
+ else
+ fp = fopen(name,"r");
+ }
+ else if (name[len-1] == '|') {
+ name[--len] = '\0';
+ while (len && isspace(name[len-1]))
+ name[--len] = '\0';
+ for (; isspace(*name); name++) ;
+ fp = popen(name,"r");
+ stio->type = '|';
+ }
+ else {
+ stio->type = '<';
+ for (; isspace(*name); name++) ;
+ if (strEQ(name,"-")) {
+ fp = stdin;
+ stio->type = '-';
+ }
+ else
+ fp = fopen(name,"r");
+ }
+ }
+ if (!fp)
+ return FALSE;
+ if (stio->type != '|' && stio->type != '-') {
+ if (fstat(fileno(fp),&statbuf) < 0) {
+ fclose(fp);
+ return FALSE;
+ }
+ if ((statbuf.st_mode & S_IFMT) != S_IFREG &&
+ (statbuf.st_mode & S_IFMT) != S_IFCHR) {
+ fclose(fp);
+ return FALSE;
+ }
+ }
+ stio->fp = fp;
+ return TRUE;
+}
+
+FILE *
+nextargv(stab)
+register STAB *stab;
+{
+ register STR *str;
+ char *oldname;
+
+ while (alen(stab->stab_array) >= 0L) {
+ str = ashift(stab->stab_array);
+ str_sset(stab->stab_val,str);
+ STABSET(stab->stab_val);
+ oldname = str_get(stab->stab_val);
+ if (do_open(stab,oldname)) {
+ if (inplace) {
+ if (*inplace) {
+ str_cat(str,inplace);
+#ifdef RENAME
+ rename(oldname,str->str_ptr);
+#else
+ UNLINK(str->str_ptr);
+ link(oldname,str->str_ptr);
+ UNLINK(oldname);
+#endif
+ }
+ sprintf(tokenbuf,">%s",oldname);
+ do_open(argvoutstab,tokenbuf);
+ defoutstab = argvoutstab;
+ }
+ str_free(str);
+ return stab->stab_io->fp;
+ }
+ else
+ fprintf(stderr,"Can't open %s\n",str_get(str));
+ str_free(str);
+ }
+ if (inplace) {
+ do_close(argvoutstab,FALSE);
+ defoutstab = stabent("stdout",TRUE);
+ }
+ return Nullfp;
+}
+
+bool
+do_close(stab,explicit)
+STAB *stab;
+bool explicit;
+{
+ bool retval = FALSE;
+ register STIO *stio = stab->stab_io;
+
+ if (!stio) /* never opened */
+ return FALSE;
+ if (stio->fp) {
+ if (stio->type == '|')
+ retval = (pclose(stio->fp) >= 0);
+ else if (stio->type == '-')
+ retval = TRUE;
+ else
+ retval = (fclose(stio->fp) != EOF);
+ stio->fp = Nullfp;
+ }
+ if (explicit)
+ stio->lines = 0;
+ stio->type = ' ';
+ return retval;
+}
+
+bool
+do_eof(stab)
+STAB *stab;
+{
+ register STIO *stio;
+ int ch;
+
+ if (!stab)
+ return TRUE;
+
+ stio = stab->stab_io;
+ if (!stio)
+ return TRUE;
+
+ while (stio->fp) {
+
+#ifdef STDSTDIO /* (the code works without this) */
+ if (stio->fp->_cnt) /* cheat a little, since */
+ return FALSE; /* this is the most usual case */
+#endif
+
+ ch = getc(stio->fp);
+ if (ch != EOF) {
+ ungetc(ch, stio->fp);
+ return FALSE;
+ }
+ if (stio->flags & IOF_ARGV) { /* not necessarily a real EOF yet? */
+ if (!nextargv(stab)) /* 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;
+ int ch;
+
+ if (!stab)
+ return -1L;
+
+ stio = stab->stab_io;
+ if (!stio || !stio->fp)
+ return -1L;
+
+ return ftell(stio->fp);
+}
+
+bool
+do_seek(stab, pos, whence)
+STAB *stab;
+long pos;
+int whence;
+{
+ register STIO *stio;
+
+ if (!stab)
+ return FALSE;
+
+ stio = stab->stab_io;
+ if (!stio || !stio->fp)
+ return FALSE;
+
+ return fseek(stio->fp, pos, whence) >= 0;
+}
+
+do_stat(arg,sarg,retary)
+register ARG *arg;
+register STR **sarg;
+STR ***retary;
+{
+ register ARRAY *ary;
+ static ARRAY *myarray = Null(ARRAY*);
+ int max = 13;
+ register int i;
+
+ ary = myarray;
+ if (!ary)
+ myarray = ary = anew();
+ ary->ary_fill = -1;
+ if (arg[1].arg_type == A_LVAL) {
+ tmpstab = arg[1].arg_ptr.arg_stab;
+ if (!tmpstab->stab_io ||
+ fstat(fileno(tmpstab->stab_io->fp),&statbuf) < 0) {
+ max = 0;
+ }
+ }
+ else
+ if (stat(str_get(sarg[1]),&statbuf) < 0)
+ max = 0;
+
+ if (retary) {
+ if (max) {
+ apush(ary,str_nmake((double)statbuf.st_dev));
+ apush(ary,str_nmake((double)statbuf.st_ino));
+ apush(ary,str_nmake((double)statbuf.st_mode));
+ apush(ary,str_nmake((double)statbuf.st_nlink));
+ apush(ary,str_nmake((double)statbuf.st_uid));
+ apush(ary,str_nmake((double)statbuf.st_gid));
+ apush(ary,str_nmake((double)statbuf.st_rdev));
+ apush(ary,str_nmake((double)statbuf.st_size));
+ apush(ary,str_nmake((double)statbuf.st_atime));
+ apush(ary,str_nmake((double)statbuf.st_mtime));
+ apush(ary,str_nmake((double)statbuf.st_ctime));
+ apush(ary,str_nmake((double)statbuf.st_blksize));
+ apush(ary,str_nmake((double)statbuf.st_blocks));
+ }
+ sarg = (STR**)safemalloc((max+2)*sizeof(STR*));
+ sarg[0] = Nullstr;
+ sarg[max+1] = Nullstr;
+ for (i = 1; i <= max; i++)
+ sarg[i] = afetch(ary,i-1);
+ *retary = sarg;
+ }
+ return max;
+}
+
+do_tms(retary)
+STR ***retary;
+{
+ register ARRAY *ary;
+ static ARRAY *myarray = Null(ARRAY*);
+ register STR **sarg;
+ int max = 4;
+ register int i;
+
+ ary = myarray;
+ if (!ary)
+ myarray = ary = anew();
+ ary->ary_fill = -1;
+ if (times(×buf) < 0)
+ max = 0;
+
+ if (retary) {
+ if (max) {
+ apush(ary,str_nmake(((double)timesbuf.tms_utime)/60.0));
+ apush(ary,str_nmake(((double)timesbuf.tms_stime)/60.0));
+ apush(ary,str_nmake(((double)timesbuf.tms_cutime)/60.0));
+ apush(ary,str_nmake(((double)timesbuf.tms_cstime)/60.0));
+ }
+ sarg = (STR**)safemalloc((max+2)*sizeof(STR*));
+ sarg[0] = Nullstr;
+ sarg[max+1] = Nullstr;
+ for (i = 1; i <= max; i++)
+ sarg[i] = afetch(ary,i-1);
+ *retary = sarg;
+ }
+ return max;
+}
+
+do_time(tmbuf,retary)
+struct tm *tmbuf;
+STR ***retary;
+{
+ register ARRAY *ary;
+ static ARRAY *myarray = Null(ARRAY*);
+ register STR **sarg;
+ int max = 9;
+ register int i;
+ STR *str;
+
+ ary = myarray;
+ if (!ary)
+ myarray = ary = anew();
+ ary->ary_fill = -1;
+ if (!tmbuf)
+ max = 0;
+
+ if (retary) {
+ if (max) {
+ apush(ary,str_nmake((double)tmbuf->tm_sec));
+ apush(ary,str_nmake((double)tmbuf->tm_min));
+ apush(ary,str_nmake((double)tmbuf->tm_hour));
+ apush(ary,str_nmake((double)tmbuf->tm_mday));
+ apush(ary,str_nmake((double)tmbuf->tm_mon));
+ apush(ary,str_nmake((double)tmbuf->tm_year));
+ apush(ary,str_nmake((double)tmbuf->tm_wday));
+ apush(ary,str_nmake((double)tmbuf->tm_yday));
+ apush(ary,str_nmake((double)tmbuf->tm_isdst));
+ }
+ sarg = (STR**)safemalloc((max+2)*sizeof(STR*));
+ sarg[0] = Nullstr;
+ sarg[max+1] = Nullstr;
+ for (i = 1; i <= max; i++)
+ sarg[i] = afetch(ary,i-1);
+ *retary = sarg;
+ }
+ return max;
+}
+
+void
+do_sprintf(str,len,sarg)
+register STR *str;
+register int len;
+register STR **sarg;
+{
+ register char *s;
+ register char *t;
+ bool dolong;
+ char ch;
+
+ str_set(str,"");
+ len--; /* don't count pattern string */
+ sarg++;
+ for (s = str_get(*(sarg++)); *sarg && *s && len; len--) {
+ dolong = FALSE;
+ for (t = s; *t && *t != '%'; t++) ;
+ if (!*t)
+ break; /* not enough % patterns, oh well */
+ for (t++; *sarg && *t && t != s; t++) {
+ switch (*t) {
+ case '\0':
+ break;
+ case '%':
+ ch = *(++t);
+ *t = '\0';
+ sprintf(buf,s);
+ s = t;
+ *(t--) = ch;
+ break;
+ case 'l':
+ dolong = TRUE;
+ break;
+ case 'D': case 'X': case 'O':
+ dolong = TRUE;
+ /* FALL THROUGH */
+ case 'd': case 'x': case 'o': case 'c':
+ ch = *(++t);
+ *t = '\0';
+ if (dolong)
+ sprintf(buf,s,(long)str_gnum(*(sarg++)));
+ else
+ sprintf(buf,s,(int)str_gnum(*(sarg++)));
+ s = t;
+ *(t--) = ch;
+ break;
+ case 'E': case 'e': case 'f': case 'G': case 'g':
+ ch = *(++t);
+ *t = '\0';
+ sprintf(buf,s,str_gnum(*(sarg++)));
+ s = t;
+ *(t--) = ch;
+ break;
+ case 's':
+ ch = *(++t);
+ *t = '\0';
+ sprintf(buf,s,str_get(*(sarg++)));
+ s = t;
+ *(t--) = ch;
+ break;
+ }
+ }
+ str_cat(str,buf);
+ }
+ if (*s)
+ str_cat(str,s);
+ STABSET(str);
+}
+
+bool
+do_print(s,fp)
+char *s;
+FILE *fp;
+{
+ if (!fp || !s)
+ return FALSE;
+ fputs(s,fp);
+ return TRUE;
+}
+
+bool
+do_aprint(arg,fp)
+register ARG *arg;
+register FILE *fp;
+{
+ STR **tmpary; /* must not be register */
+ register STR **elem;
+ register bool retval;
+ double value;
+
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
+ if (arg->arg_type == O_PRTF) {
+ do_sprintf(arg->arg_ptr.arg_str,32767,tmpary);
+ retval = do_print(str_get(arg->arg_ptr.arg_str),fp);
+ }
+ else {
+ retval = FALSE;
+ for (elem = tmpary+1; *elem; elem++) {
+ if (retval && ofs)
+ do_print(ofs, fp);
+ if (ofmt && fp) {
+ if ((*elem)->str_nok || str_gnum(*elem) != 0.0)
+ fprintf(fp, ofmt, str_gnum(*elem));
+ retval = TRUE;
+ }
+ else
+ retval = do_print(str_get(*elem), fp);
+ if (!retval)
+ break;
+ }
+ if (ors)
+ retval = do_print(ors, fp);
+ }
+ safefree((char*)tmpary);
+ return retval;
+}
+
+bool
+do_aexec(arg)
+register ARG *arg;
+{
+ STR **tmpary; /* must not be register */
+ register STR **elem;
+ register char **a;
+ register int i;
+ char **argv;
+
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
+ i = 0;
+ for (elem = tmpary+1; *elem; elem++)
+ i++;
+ if (i) {
+ argv = (char**)safemalloc((i+1)*sizeof(char*));
+ a = argv;
+ for (elem = tmpary+1; *elem; elem++) {
+ *a++ = str_get(*elem);
+ }
+ *a = Nullch;
+ execvp(argv[0],argv);
+ safefree((char*)argv);
+ }
+ safefree((char*)tmpary);
+ return FALSE;
+}
+
+bool
+do_exec(cmd)
+char *cmd;
+{
+ STR **tmpary; /* must not be register */
+ register char **a;
+ register char *s;
+ char **argv;
+
+ /* see if there are shell metacharacters in it */
+
+ for (s = cmd; *s; s++) {
+ if (*s != ' ' && !isalpha(*s) && index("$&*(){}[]'\";\\|?<>~`",*s)) {
+ execl("/bin/sh","sh","-c",cmd,0);
+ return FALSE;
+ }
+ }
+ argv = (char**)safemalloc(((s - cmd) / 2 + 2)*sizeof(char*));
+
+ a = argv;
+ for (s = cmd; *s;) {
+ while (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);
+ safefree((char*)argv);
+ return FALSE;
+}
+
+STR *
+do_push(arg,ary)
+register ARG *arg;
+register ARRAY *ary;
+{
+ STR **tmpary; /* must not be register */
+ register STR **elem;
+ register STR *str = &str_no;
+
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
+ for (elem = tmpary+1; *elem; elem++) {
+ str = str_new(0);
+ str_sset(str,*elem);
+ apush(ary,str);
+ }
+ safefree((char*)tmpary);
+ return str;
+}
+
+do_unshift(arg,ary)
+register ARG *arg;
+register ARRAY *ary;
+{
+ STR **tmpary; /* must not be register */
+ register STR **elem;
+ register STR *str = &str_no;
+ register int i;
+
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
+ i = 0;
+ for (elem = tmpary+1; *elem; elem++)
+ i++;
+ aunshift(ary,i);
+ i = 0;
+ for (elem = tmpary+1; *elem; elem++) {
+ str = str_new(0);
+ str_sset(str,*elem);
+ astore(ary,i++,str);
+ }
+ safefree((char*)tmpary);
+}
+
+apply(type,arg,sarg)
+int type;
+register ARG *arg;
+STR **sarg;
+{
+ STR **tmpary; /* must not be register */
+ register STR **elem;
+ register int i;
+ register int val;
+ register int val2;
+
+ if (sarg)
+ tmpary = sarg;
+ else
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
+ i = 0;
+ for (elem = tmpary+1; *elem; elem++)
+ i++;
+ switch (type) {
+ case O_CHMOD:
+ if (--i > 0) {
+ val = (int)str_gnum(tmpary[1]);
+ for (elem = tmpary+2; *elem; elem++)
+ if (chmod(str_get(*elem),val))
+ i--;
+ }
+ break;
+ case O_CHOWN:
+ if (i > 2) {
+ i -= 2;
+ val = (int)str_gnum(tmpary[1]);
+ val2 = (int)str_gnum(tmpary[2]);
+ for (elem = tmpary+3; *elem; elem++)
+ if (chown(str_get(*elem),val,val2))
+ i--;
+ }
+ else
+ i = 0;
+ break;
+ case O_KILL:
+ if (--i > 0) {
+ val = (int)str_gnum(tmpary[1]);
+ if (val < 0)
+ val = -val;
+ for (elem = tmpary+2; *elem; elem++)
+ if (kill(atoi(str_get(*elem)),val))
+ i--;
+ }
+ break;
+ case O_UNLINK:
+ for (elem = tmpary+1; *elem; elem++)
+ if (UNLINK(str_get(*elem)))
+ i--;
+ break;
+ }
+ if (!sarg)
+ safefree((char*)tmpary);
+ return i;
+}
+
+STR *
+do_subr(arg,sarg)
+register ARG *arg;
+register char **sarg;
+{
+ ARRAY *savearray;
+ STR *str;
+
+ savearray = defstab->stab_array;
+ defstab->stab_array = anew();
+ if (arg[1].arg_flags & AF_SPECIAL)
+ (void)do_push(arg,defstab->stab_array);
+ else if (arg[1].arg_type != A_NULL) {
+ str = str_new(0);
+ str_sset(str,sarg[1]);
+ apush(defstab->stab_array,str);
+ }
+ str = cmd_exec(arg[2].arg_ptr.arg_stab->stab_sub);
+ afree(defstab->stab_array); /* put back old $_[] */
+ defstab->stab_array = savearray;
+ return str;
+}
+
+void
+do_assign(retstr,arg)
+STR *retstr;
+register ARG *arg;
+{
+ STR **tmpary; /* must not be register */
+ register ARG *larg = arg[1].arg_ptr.arg_arg;
+ register STR **elem;
+ register STR *str;
+ register ARRAY *ary;
+ register int i;
+ register int lasti;
+ char *s;
+
+ (void)eval(arg[2].arg_ptr.arg_arg,&tmpary);
+
+ if (arg->arg_flags & AF_COMMON) {
+ if (*(tmpary+1)) {
+ for (elem=tmpary+2; *elem; elem++) {
+ *elem = str_static(*elem);
+ }
+ }
+ }
+ if (larg->arg_type == O_LIST) {
+ lasti = larg->arg_len;
+ for (i=1,elem=tmpary+1; i <= lasti; i++) {
+ if (*elem)
+ s = str_get(*(elem++));
+ else
+ s = "";
+ switch (larg[i].arg_type) {
+ case A_STAB:
+ case A_LVAL:
+ str = STAB_STR(larg[i].arg_ptr.arg_stab);
+ break;
+ case A_LEXPR:
+ str = eval(larg[i].arg_ptr.arg_arg,Null(STR***));
+ break;
+ }
+ str_set(str,s);
+ STABSET(str);
+ }
+ i = elem - tmpary - 1;
+ }
+ else { /* should be an array name */
+ ary = larg[1].arg_ptr.arg_stab->stab_array;
+ for (i=0,elem=tmpary+1; *elem; i++) {
+ str = str_new(0);
+ if (*elem)
+ str_sset(str,*(elem++));
+ astore(ary,i,str);
+ }
+ ary->ary_fill = i - 1; /* they can get the extra ones back by */
+ } /* setting an element larger than old fill */
+ str_numset(retstr,(double)i);
+ STABSET(retstr);
+ safefree((char*)tmpary);
+}
+
+int
+do_kv(hash,kv,sarg,retary)
+HASH *hash;
+int kv;
+register STR **sarg;
+STR ***retary;
+{
+ register ARRAY *ary;
+ int max = 0;
+ int i;
+ static ARRAY *myarray = Null(ARRAY*);
+ register HENT *entry;
+
+ ary = myarray;
+ if (!ary)
+ myarray = ary = anew();
+ ary->ary_fill = -1;
+
+ hiterinit(hash);
+ while (entry = hiternext(hash)) {
+ max++;
+ if (kv == O_KEYS)
+ apush(ary,str_make(hiterkey(entry)));
+ else
+ apush(ary,str_make(str_get(hiterval(entry))));
+ }
+ if (retary) { /* array wanted */
+ sarg = (STR**)saferealloc((char*)sarg,(max+2)*sizeof(STR*));
+ sarg[0] = Nullstr;
+ sarg[max+1] = Nullstr;
+ for (i = 1; i <= max; i++)
+ sarg[i] = afetch(ary,i-1);
+ *retary = sarg;
+ }
+ return max;
+}
+
+STR *
+do_each(hash,sarg,retary)
+HASH *hash;
+register STR **sarg;
+STR ***retary;
+{
+ static STR *mystr = Nullstr;
+ STR *retstr;
+ HENT *entry = hiternext(hash);
+
+ if (mystr) {
+ str_free(mystr);
+ mystr = Nullstr;
+ }
+
+ if (retary) { /* array wanted */
+ if (entry) {
+ sarg = (STR**)saferealloc((char*)sarg,4*sizeof(STR*));
+ sarg[0] = Nullstr;
+ sarg[3] = Nullstr;
+ sarg[1] = mystr = str_make(hiterkey(entry));
+ retstr = sarg[2] = hiterval(entry);
+ *retary = sarg;
+ }
+ else {
+ sarg = (STR**)saferealloc((char*)sarg,2*sizeof(STR*));
+ sarg[0] = Nullstr;
+ sarg[1] = retstr = Nullstr;
+ *retary = sarg;
+ }
+ }
+ else
+ retstr = hiterval(entry);
+
+ return retstr;
+}
+
+init_eval()
+{
+ register int i;
+
+#define A(e1,e2,e3) (e1+(e2<<1)+(e3<<2))
+ opargs[O_ITEM] = A(1,0,0);
+ opargs[O_ITEM2] = A(0,0,0);
+ opargs[O_ITEM3] = A(0,0,0);
+ opargs[O_CONCAT] = A(1,1,0);
+ opargs[O_MATCH] = A(1,0,0);
+ opargs[O_NMATCH] = A(1,0,0);
+ opargs[O_SUBST] = A(1,0,0);
+ opargs[O_NSUBST] = A(1,0,0);
+ opargs[O_ASSIGN] = A(1,1,0);
+ opargs[O_MULTIPLY] = A(1,1,0);
+ opargs[O_DIVIDE] = A(1,1,0);
+ opargs[O_MODULO] = A(1,1,0);
+ opargs[O_ADD] = A(1,1,0);
+ opargs[O_SUBTRACT] = A(1,1,0);
+ opargs[O_LEFT_SHIFT] = A(1,1,0);
+ opargs[O_RIGHT_SHIFT] = A(1,1,0);
+ opargs[O_LT] = A(1,1,0);
+ opargs[O_GT] = A(1,1,0);
+ opargs[O_LE] = A(1,1,0);
+ opargs[O_GE] = A(1,1,0);
+ opargs[O_EQ] = A(1,1,0);
+ opargs[O_NE] = A(1,1,0);
+ opargs[O_BIT_AND] = A(1,1,0);
+ opargs[O_XOR] = A(1,1,0);
+ opargs[O_BIT_OR] = A(1,1,0);
+ opargs[O_AND] = A(1,0,0); /* don't eval arg 2 (yet) */
+ opargs[O_OR] = A(1,0,0); /* don't eval arg 2 (yet) */
+ opargs[O_COND_EXPR] = A(1,0,0); /* don't eval args 2 or 3 */
+ opargs[O_COMMA] = A(1,1,0);
+ opargs[O_NEGATE] = A(1,0,0);
+ opargs[O_NOT] = A(1,0,0);
+ opargs[O_COMPLEMENT] = A(1,0,0);
+ opargs[O_WRITE] = A(1,0,0);
+ opargs[O_OPEN] = A(1,1,0);
+ opargs[O_TRANS] = A(1,0,0);
+ opargs[O_NTRANS] = A(1,0,0);
+ opargs[O_CLOSE] = A(0,0,0);
+ opargs[O_ARRAY] = A(1,0,0);
+ opargs[O_HASH] = A(1,0,0);
+ opargs[O_LARRAY] = A(1,0,0);
+ opargs[O_LHASH] = A(1,0,0);
+ opargs[O_PUSH] = A(1,0,0);
+ opargs[O_POP] = A(0,0,0);
+ opargs[O_SHIFT] = A(0,0,0);
+ opargs[O_SPLIT] = A(1,0,0);
+ opargs[O_LENGTH] = A(1,0,0);
+ opargs[O_SPRINTF] = A(1,0,0);
+ opargs[O_SUBSTR] = A(1,1,1);
+ opargs[O_JOIN] = A(1,0,0);
+ opargs[O_SLT] = A(1,1,0);
+ opargs[O_SGT] = A(1,1,0);
+ opargs[O_SLE] = A(1,1,0);
+ opargs[O_SGE] = A(1,1,0);
+ opargs[O_SEQ] = A(1,1,0);
+ opargs[O_SNE] = A(1,1,0);
+ opargs[O_SUBR] = A(1,0,0);
+ opargs[O_PRINT] = A(1,0,0);
+ opargs[O_CHDIR] = A(1,0,0);
+ opargs[O_DIE] = A(1,0,0);
+ opargs[O_EXIT] = A(1,0,0);
+ opargs[O_RESET] = A(1,0,0);
+ opargs[O_LIST] = A(0,0,0);
+ opargs[O_EOF] = A(0,0,0);
+ opargs[O_TELL] = A(0,0,0);
+ opargs[O_SEEK] = A(0,1,1);
+ opargs[O_LAST] = A(1,0,0);
+ opargs[O_NEXT] = A(1,0,0);
+ opargs[O_REDO] = A(1,0,0);
+ opargs[O_GOTO] = A(1,0,0);
+ opargs[O_INDEX] = A(1,1,0);
+ opargs[O_TIME] = A(0,0,0);
+ opargs[O_TMS] = A(0,0,0);
+ opargs[O_LOCALTIME] = A(1,0,0);
+ opargs[O_GMTIME] = A(1,0,0);
+ opargs[O_STAT] = A(1,0,0);
+ opargs[O_CRYPT] = A(1,1,0);
+ opargs[O_EXP] = A(1,0,0);
+ opargs[O_LOG] = A(1,0,0);
+ opargs[O_SQRT] = A(1,0,0);
+ opargs[O_INT] = A(1,0,0);
+ opargs[O_PRTF] = A(1,0,0);
+ opargs[O_ORD] = A(1,0,0);
+ opargs[O_SLEEP] = A(1,0,0);
+ opargs[O_FLIP] = A(1,0,0);
+ opargs[O_FLOP] = A(0,1,0);
+ opargs[O_KEYS] = A(0,0,0);
+ opargs[O_VALUES] = A(0,0,0);
+ opargs[O_EACH] = A(0,0,0);
+ opargs[O_CHOP] = A(1,0,0);
+ opargs[O_FORK] = A(1,0,0);
+ opargs[O_EXEC] = A(1,0,0);
+ opargs[O_SYSTEM] = A(1,0,0);
+ opargs[O_OCT] = A(1,0,0);
+ opargs[O_HEX] = A(1,0,0);
+ opargs[O_CHMOD] = A(1,0,0);
+ opargs[O_CHOWN] = A(1,0,0);
+ opargs[O_KILL] = A(1,0,0);
+ opargs[O_RENAME] = A(1,1,0);
+ opargs[O_UNLINK] = A(1,0,0);
+ opargs[O_UMASK] = A(1,0,0);
+ opargs[O_UNSHIFT] = A(1,0,0);
+ opargs[O_LINK] = A(1,1,0);
+ opargs[O_REPEAT] = A(1,1,0);
+}
+
+static int (*ihand)();
+static int (*qhand)();
+
+STR *
+eval(arg,retary)
+register ARG *arg;
+STR ***retary; /* where to return an array to, null if nowhere */
+{
+ register STR *str;
+ register int anum;
+ register int optype;
+ register int maxarg;
+ double value;
+ STR *quicksarg[5];
+ register STR **sarg = quicksarg;
+ register char *tmps;
+ char *tmps2;
+ int argflags;
+ long tmplong;
+ FILE *fp;
+ STR *tmpstr;
+ FCMD *form;
+ STAB *stab;
+ ARRAY *ary;
+ bool assigning = FALSE;
+ double exp(), log(), sqrt(), modf();
+ char *crypt(), *getenv();
+
+ if (!arg)
+ return &str_no;
+ str = arg->arg_ptr.arg_str;
+ optype = arg->arg_type;
+ maxarg = arg->arg_len;
+ if (maxarg > 3 || retary) {
+ sarg = (STR **)safemalloc((maxarg+2) * sizeof(STR*));
+ }
+#ifdef DEBUGGING
+ if (debug & 8) {
+ deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg);
+ }
+ debname[dlevel] = opname[optype][0];
+ debdelim[dlevel++] = ':';
+#endif
+ for (anum = 1; anum <= maxarg; anum++) {
+ argflags = arg[anum].arg_flags;
+ if (argflags & AF_SPECIAL)
+ continue;
+ re_eval:
+ switch (arg[anum].arg_type) {
+ default:
+ sarg[anum] = &str_no;
+#ifdef DEBUGGING
+ tmps = "NULL";
+#endif
+ break;
+ case A_EXPR:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ tmps = "EXPR";
+ deb("%d.EXPR =>\n",anum);
+ }
+#endif
+ sarg[anum] = eval(arg[anum].arg_ptr.arg_arg, Null(STR***));
+ break;
+ case A_CMD:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ tmps = "CMD";
+ deb("%d.CMD (%lx) =>\n",anum,arg[anum].arg_ptr.arg_cmd);
+ }
+#endif
+ sarg[anum] = cmd_exec(arg[anum].arg_ptr.arg_cmd);
+ break;
+ case A_STAB:
+ sarg[anum] = STAB_STR(arg[anum].arg_ptr.arg_stab);
+#ifdef DEBUGGING
+ if (debug & 8) {
+ sprintf(buf,"STAB $%s ==",arg[anum].arg_ptr.arg_stab->stab_name);
+ tmps = buf;
+ }
+#endif
+ break;
+ case A_LEXPR:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ tmps = "LEXPR";
+ deb("%d.LEXPR =>\n",anum);
+ }
+#endif
+ str = eval(arg[anum].arg_ptr.arg_arg,Null(STR***));
+ if (!str)
+ fatal("panic: A_LEXPR\n");
+ goto do_crement;
+ case A_LVAL:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ sprintf(buf,"LVAL $%s ==",arg[anum].arg_ptr.arg_stab->stab_name);
+ tmps = buf;
+ }
+#endif
+ str = STAB_STR(arg[anum].arg_ptr.arg_stab);
+ if (!str)
+ fatal("panic: A_LVAL\n");
+ do_crement:
+ assigning = TRUE;
+ if (argflags & AF_PRE) {
+ if (argflags & AF_UP)
+ str_inc(str);
+ else
+ str_dec(str);
+ STABSET(str);
+ sarg[anum] = str;
+ str = arg->arg_ptr.arg_str;
+ }
+ else if (argflags & AF_POST) {
+ sarg[anum] = str_static(str);
+ if (argflags & AF_UP)
+ str_inc(str);
+ else
+ str_dec(str);
+ STABSET(str);
+ str = arg->arg_ptr.arg_str;
+ }
+ else {
+ sarg[anum] = str;
+ }
+ break;
+ case A_ARYLEN:
+ sarg[anum] = str_static(&str_no);
+ str_numset(sarg[anum],
+ (double)alen(arg[anum].arg_ptr.arg_stab->stab_array));
+#ifdef DEBUGGING
+ tmps = "ARYLEN";
+#endif
+ break;
+ case A_SINGLE:
+ sarg[anum] = arg[anum].arg_ptr.arg_str;
+#ifdef DEBUGGING
+ tmps = "SINGLE";
+#endif
+ break;
+ case A_DOUBLE:
+ (void) interp(str,str_get(arg[anum].arg_ptr.arg_str));
+ sarg[anum] = str;
+#ifdef DEBUGGING
+ tmps = "DOUBLE";
+#endif
+ break;
+ case A_BACKTICK:
+ tmps = str_get(arg[anum].arg_ptr.arg_str);
+ fp = popen(str_get(interp(str,tmps)),"r");
+ tmpstr = str_new(80);
+ str_set(str,"");
+ if (fp) {
+ while (str_gets(tmpstr,fp) != Nullch) {
+ str_scat(str,tmpstr);
+ }
+ statusvalue = pclose(fp);
+ }
+ else
+ statusvalue = -1;
+ str_free(tmpstr);
+
+ sarg[anum] = str;
+#ifdef DEBUGGING
+ tmps = "BACK";
+#endif
+ break;
+ case A_READ:
+ fp = Nullfp;
+ last_in_stab = arg[anum].arg_ptr.arg_stab;
+ if (last_in_stab->stab_io) {
+ fp = last_in_stab->stab_io->fp;
+ if (!fp && (last_in_stab->stab_io->flags & IOF_ARGV)) {
+ if (last_in_stab->stab_io->flags & IOF_START) {
+ last_in_stab->stab_io->flags &= ~IOF_START;
+ last_in_stab->stab_io->lines = 0;
+ if (alen(last_in_stab->stab_array) < 0L) {
+ tmpstr = str_make("-"); /* assume stdin */
+ apush(last_in_stab->stab_array, tmpstr);
+ }
+ }
+ fp = nextargv(last_in_stab);
+ if (!fp) /* Note: fp != last_in_stab->stab_io->fp */
+ do_close(last_in_stab,FALSE); /* now it does */
+ }
+ }
+ keepgoing:
+ if (!fp)
+ sarg[anum] = &str_no;
+ else if (!str_gets(str,fp)) {
+ if (last_in_stab->stab_io->flags & IOF_ARGV) {
+ fp = nextargv(last_in_stab);
+ if (fp)
+ goto keepgoing;
+ do_close(last_in_stab,FALSE);
+ last_in_stab->stab_io->flags |= IOF_START;
+ }
+ if (fp == stdin) {
+ clearerr(fp);
+ }
+ sarg[anum] = &str_no;
+ break;
+ }
+ else {
+ last_in_stab->stab_io->lines++;
+ sarg[anum] = str;
+ }
+#ifdef DEBUGGING
+ tmps = "READ";
+#endif
+ break;
+ }
+#ifdef DEBUGGING
+ if (debug & 8)
+ deb("%d.%s = '%s'\n",anum,tmps,str_peek(sarg[anum]));
+#endif
+ }
+ switch (optype) {
+ case O_ITEM:
+ if (str != sarg[1])
+ str_sset(str,sarg[1]);
+ STABSET(str);
+ break;
+ case O_ITEM2:
+ if (str != sarg[2])
+ str_sset(str,sarg[2]);
+ STABSET(str);
+ break;
+ case O_ITEM3:
+ if (str != sarg[3])
+ str_sset(str,sarg[3]);
+ STABSET(str);
+ break;
+ case O_CONCAT:
+ if (str != sarg[1])
+ str_sset(str,sarg[1]);
+ str_scat(str,sarg[2]);
+ STABSET(str);
+ break;
+ case O_REPEAT:
+ if (str != sarg[1])
+ str_sset(str,sarg[1]);
+ anum = (long)str_gnum(sarg[2]);
+ if (anum >= 1) {
+ tmpstr = str_new(0);
+ str_sset(tmpstr,str);
+ for (anum--; anum; anum--)
+ str_scat(str,tmpstr);
+ }
+ else
+ str_sset(str,&str_no);
+ STABSET(str);
+ break;
+ case O_MATCH:
+ str_set(str, do_match(str_get(sarg[1]),arg) ? Yes : No);
+ STABSET(str);
+ break;
+ case O_NMATCH:
+ str_set(str, do_match(str_get(sarg[1]),arg) ? No : Yes);
+ STABSET(str);
+ break;
+ case O_SUBST:
+ value = (double) do_subst(str, arg);
+ str = arg->arg_ptr.arg_str;
+ goto donumset;
+ case O_NSUBST:
+ str_set(arg->arg_ptr.arg_str, do_subst(str, arg) ? No : Yes);
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_ASSIGN:
+ if (arg[2].arg_flags & AF_SPECIAL)
+ do_assign(str,arg);
+ else {
+ if (str != sarg[2])
+ str_sset(str, sarg[2]);
+ STABSET(str);
+ }
+ break;
+ case O_CHOP:
+ tmps = str_get(str);
+ tmps += str->str_cur - (str->str_cur != 0);
+ str_set(arg->arg_ptr.arg_str,tmps); /* remember last char */
+ *tmps = '\0'; /* wipe it out */
+ str->str_cur = tmps - str->str_ptr;
+ str->str_nok = 0;
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_MULTIPLY:
+ value = str_gnum(sarg[1]);
+ value *= str_gnum(sarg[2]);
+ goto donumset;
+ case O_DIVIDE:
+ value = str_gnum(sarg[1]);
+ value /= str_gnum(sarg[2]);
+ goto donumset;
+ case O_MODULO:
+ value = str_gnum(sarg[1]);
+ value = (double)(((long)value) % (long)str_gnum(sarg[2]));
+ goto donumset;
+ case O_ADD:
+ value = str_gnum(sarg[1]);
+ value += str_gnum(sarg[2]);
+ goto donumset;
+ case O_SUBTRACT:
+ value = str_gnum(sarg[1]);
+ value -= str_gnum(sarg[2]);
+ goto donumset;
+ case O_LEFT_SHIFT:
+ value = str_gnum(sarg[1]);
+ value = (double)(((long)value) << (long)str_gnum(sarg[2]));
+ goto donumset;
+ case O_RIGHT_SHIFT:
+ value = str_gnum(sarg[1]);
+ value = (double)(((long)value) >> (long)str_gnum(sarg[2]));
+ goto donumset;
+ case O_LT:
+ value = str_gnum(sarg[1]);
+ value = (double)(value < str_gnum(sarg[2]));
+ goto donumset;
+ case O_GT:
+ value = str_gnum(sarg[1]);
+ value = (double)(value > str_gnum(sarg[2]));
+ goto donumset;
+ case O_LE:
+ value = str_gnum(sarg[1]);
+ value = (double)(value <= str_gnum(sarg[2]));
+ goto donumset;
+ case O_GE:
+ value = str_gnum(sarg[1]);
+ value = (double)(value >= str_gnum(sarg[2]));
+ goto donumset;
+ case O_EQ:
+ value = str_gnum(sarg[1]);
+ value = (double)(value == str_gnum(sarg[2]));
+ goto donumset;
+ case O_NE:
+ value = str_gnum(sarg[1]);
+ value = (double)(value != str_gnum(sarg[2]));
+ goto donumset;
+ case O_BIT_AND:
+ value = str_gnum(sarg[1]);
+ value = (double)(((long)value) & (long)str_gnum(sarg[2]));
+ goto donumset;
+ case O_XOR:
+ value = str_gnum(sarg[1]);
+ value = (double)(((long)value) ^ (long)str_gnum(sarg[2]));
+ goto donumset;
+ case O_BIT_OR:
+ value = str_gnum(sarg[1]);
+ value = (double)(((long)value) | (long)str_gnum(sarg[2]));
+ goto donumset;
+ case O_AND:
+ if (str_true(sarg[1])) {
+ anum = 2;
+ optype = O_ITEM2;
+ maxarg = 0;
+ argflags = arg[anum].arg_flags;
+ goto re_eval;
+ }
+ else {
+ if (assigning) {
+ str_sset(str, sarg[1]);
+ STABSET(str);
+ }
+ else
+ str = sarg[1];
+ break;
+ }
+ case O_OR:
+ if (str_true(sarg[1])) {
+ if (assigning) {
+ str_set(str, sarg[1]);
+ STABSET(str);
+ }
+ else
+ str = sarg[1];
+ break;
+ }
+ else {
+ anum = 2;
+ optype = O_ITEM2;
+ maxarg = 0;
+ argflags = arg[anum].arg_flags;
+ goto re_eval;
+ }
+ case O_COND_EXPR:
+ anum = (str_true(sarg[1]) ? 2 : 3);
+ optype = (anum == 2 ? O_ITEM2 : O_ITEM3);
+ maxarg = 0;
+ argflags = arg[anum].arg_flags;
+ goto re_eval;
+ case O_COMMA:
+ str = sarg[2];
+ break;
+ case O_NEGATE:
+ value = -str_gnum(sarg[1]);
+ goto donumset;
+ case O_NOT:
+ value = (double) !str_true(sarg[1]);
+ goto donumset;
+ case O_COMPLEMENT:
+ value = (double) ~(long)str_gnum(sarg[1]);
+ goto donumset;
+ case O_SELECT:
+ if (arg[1].arg_type == A_LVAL)
+ defoutstab = arg[1].arg_ptr.arg_stab;
+ else
+ defoutstab = stabent(str_get(sarg[1]),TRUE);
+ if (!defoutstab->stab_io)
+ defoutstab->stab_io = stio_new();
+ curoutstab = defoutstab;
+ str_set(str,curoutstab->stab_io->fp ? Yes : No);
+ STABSET(str);
+ break;
+ case O_WRITE:
+ if (maxarg == 0)
+ stab = defoutstab;
+ else if (arg[1].arg_type == A_LVAL)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sarg[1]),TRUE);
+ if (!stab->stab_io) {
+ str_set(str, No);
+ STABSET(str);
+ break;
+ }
+ curoutstab = stab;
+ fp = stab->stab_io->fp;
+ debarg = arg;
+ if (stab->stab_io->fmt_stab)
+ form = stab->stab_io->fmt_stab->stab_form;
+ else
+ form = stab->stab_form;
+ if (!form || !fp) {
+ str_set(str, No);
+ STABSET(str);
+ break;
+ }
+ format(&outrec,form);
+ do_write(&outrec,stab->stab_io);
+ if (stab->stab_io->flags & IOF_FLUSH)
+ fflush(fp);
+ str_set(str, Yes);
+ STABSET(str);
+ break;
+ case O_OPEN:
+ if (do_open(arg[1].arg_ptr.arg_stab,str_get(sarg[2]))) {
+ str_set(str, Yes);
+ arg[1].arg_ptr.arg_stab->stab_io->lines = 0;
+ }
+ else
+ str_set(str, No);
+ STABSET(str);
+ break;
+ case O_TRANS:
+ value = (double) do_trans(str,arg);
+ str = arg->arg_ptr.arg_str;
+ goto donumset;
+ case O_NTRANS:
+ str_set(arg->arg_ptr.arg_str, do_trans(str,arg) == 0 ? Yes : No);
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_CLOSE:
+ str_set(str,
+ do_close(arg[1].arg_ptr.arg_stab,TRUE) ? Yes : No );
+ STABSET(str);
+ break;
+ case O_EACH:
+ str_sset(str,do_each(arg[1].arg_ptr.arg_stab->stab_hash,sarg,retary));
+ retary = Null(STR***); /* do_each already did retary */
+ STABSET(str);
+ break;
+ case O_VALUES:
+ case O_KEYS:
+ value = (double) do_kv(arg[1].arg_ptr.arg_stab->stab_hash,
+ optype,sarg,retary);
+ retary = Null(STR***); /* do_keys already did retary */
+ goto donumset;
+ case O_ARRAY:
+ if (maxarg == 1) {
+ ary = arg[1].arg_ptr.arg_stab->stab_array;
+ maxarg = ary->ary_fill;
+ if (retary) { /* array wanted */
+ sarg =
+ (STR **)saferealloc((char*)sarg,(maxarg+3)*sizeof(STR*));
+ for (anum = 0; anum <= maxarg; anum++) {
+ sarg[anum+1] = str = afetch(ary,anum);
+ }
+ maxarg++;
+ }
+ else
+ str = afetch(ary,maxarg);
+ }
+ else
+ str = afetch(arg[2].arg_ptr.arg_stab->stab_array,
+ ((int)str_gnum(sarg[1])) - arybase);
+ if (!str)
+ return &str_no;
+ break;
+ case O_HASH:
+ tmpstab = arg[2].arg_ptr.arg_stab; /* XXX */
+ str = hfetch(tmpstab->stab_hash,str_get(sarg[1]));
+ if (!str)
+ return &str_no;
+ break;
+ case O_LARRAY:
+ anum = ((int)str_gnum(sarg[1])) - arybase;
+ str = afetch(arg[2].arg_ptr.arg_stab->stab_array,anum);
+ if (!str || str == &str_no) {
+ str = str_new(0);
+ astore(arg[2].arg_ptr.arg_stab->stab_array,anum,str);
+ }
+ break;
+ case O_LHASH:
+ tmpstab = arg[2].arg_ptr.arg_stab;
+ str = hfetch(tmpstab->stab_hash,str_get(sarg[1]));
+ if (!str) {
+ str = str_new(0);
+ hstore(tmpstab->stab_hash,str_get(sarg[1]),str);
+ }
+ if (tmpstab == envstab) { /* heavy wizardry going on here */
+ str->str_link.str_magic = tmpstab;/* str is now magic */
+ envname = savestr(str_get(sarg[1]));
+ /* he threw the brick up into the air */
+ }
+ else if (tmpstab == sigstab) { /* same thing, only different */
+ str->str_link.str_magic = tmpstab;
+ signame = savestr(str_get(sarg[1]));
+ }
+ break;
+ case O_PUSH:
+ if (arg[1].arg_flags & AF_SPECIAL)
+ str = do_push(arg,arg[2].arg_ptr.arg_stab->stab_array);
+ else {
+ str = str_new(0); /* must copy the STR */
+ str_sset(str,sarg[1]);
+ apush(arg[2].arg_ptr.arg_stab->stab_array,str);
+ }
+ break;
+ case O_POP:
+ str = apop(arg[1].arg_ptr.arg_stab->stab_array);
+ if (!str)
+ return &str_no;
+#ifdef STRUCTCOPY
+ *(arg->arg_ptr.arg_str) = *str;
+#else
+ bcopy((char*)str, (char*)arg->arg_ptr.arg_str, sizeof *str);
+#endif
+ safefree((char*)str);
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_SHIFT:
+ str = ashift(arg[1].arg_ptr.arg_stab->stab_array);
+ if (!str)
+ return &str_no;
+#ifdef STRUCTCOPY
+ *(arg->arg_ptr.arg_str) = *str;
+#else
+ bcopy((char*)str, (char*)arg->arg_ptr.arg_str, sizeof *str);
+#endif
+ safefree((char*)str);
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_SPLIT:
+ value = (double) do_split(str_get(sarg[1]),arg[2].arg_ptr.arg_spat,retary);
+ retary = Null(STR***); /* do_split already did retary */
+ goto donumset;
+ case O_LENGTH:
+ value = (double) str_len(sarg[1]);
+ goto donumset;
+ case O_SPRINTF:
+ sarg[maxarg+1] = Nullstr;
+ do_sprintf(str,arg->arg_len,sarg);
+ break;
+ case O_SUBSTR:
+ anum = ((int)str_gnum(sarg[2])) - arybase;
+ for (tmps = str_get(sarg[1]); *tmps && anum > 0; tmps++,anum--) ;
+ anum = (int)str_gnum(sarg[3]);
+ if (anum >= 0 && strlen(tmps) > anum)
+ str_nset(str, tmps, anum);
+ else
+ str_set(str, tmps);
+ break;
+ case O_JOIN:
+ if (arg[2].arg_flags & AF_SPECIAL && arg[2].arg_type == A_EXPR)
+ do_join(arg,str_get(sarg[1]),str);
+ else
+ ajoin(arg[2].arg_ptr.arg_stab->stab_array,str_get(sarg[1]),str);
+ break;
+ case O_SLT:
+ tmps = str_get(sarg[1]);
+ value = (double) strLT(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SGT:
+ tmps = str_get(sarg[1]);
+ value = (double) strGT(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SLE:
+ tmps = str_get(sarg[1]);
+ value = (double) strLE(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SGE:
+ tmps = str_get(sarg[1]);
+ value = (double) strGE(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SEQ:
+ tmps = str_get(sarg[1]);
+ value = (double) strEQ(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SNE:
+ tmps = str_get(sarg[1]);
+ value = (double) strNE(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SUBR:
+ str_sset(str,do_subr(arg,sarg));
+ STABSET(str);
+ break;
+ case O_PRTF:
+ case O_PRINT:
+ if (maxarg <= 1)
+ stab = defoutstab;
+ else {
+ stab = arg[2].arg_ptr.arg_stab;
+ if (!stab)
+ stab = defoutstab;
+ }
+ if (!stab->stab_io)
+ value = 0.0;
+ else if (arg[1].arg_flags & AF_SPECIAL)
+ value = (double)do_aprint(arg,stab->stab_io->fp);
+ else {
+ value = (double)do_print(str_get(sarg[1]),stab->stab_io->fp);
+ if (ors && optype == O_PRINT)
+ do_print(ors, stab->stab_io->fp);
+ }
+ if (stab->stab_io->flags & IOF_FLUSH)
+ fflush(stab->stab_io->fp);
+ goto donumset;
+ case O_CHDIR:
+ tmps = str_get(sarg[1]);
+ if (!tmps || !*tmps)
+ tmps = getenv("HOME");
+ if (!tmps || !*tmps)
+ tmps = getenv("LOGDIR");
+ value = (double)(chdir(tmps) >= 0);
+ goto donumset;
+ case O_DIE:
+ tmps = str_get(sarg[1]);
+ if (!tmps || !*tmps)
+ exit(1);
+ fatal("%s\n",str_get(sarg[1]));
+ value = 0.0;
+ goto donumset;
+ case O_EXIT:
+ exit((int)str_gnum(sarg[1]));
+ value = 0.0;
+ goto donumset;
+ case O_RESET:
+ str_reset(str_get(sarg[1]));
+ value = 1.0;
+ goto donumset;
+ case O_LIST:
+ if (maxarg > 0)
+ str = sarg[maxarg]; /* unwanted list, return last item */
+ else
+ str = &str_no;
+ break;
+ case O_EOF:
+ str_set(str, do_eof(maxarg > 0 ? arg[1].arg_ptr.arg_stab : last_in_stab) ? Yes : No);
+ STABSET(str);
+ break;
+ case O_TELL:
+ value = (double)do_tell(maxarg > 0 ? arg[1].arg_ptr.arg_stab : last_in_stab);
+ goto donumset;
+ break;
+ case O_SEEK:
+ value = str_gnum(sarg[2]);
+ str_set(str, do_seek(arg[1].arg_ptr.arg_stab,
+ (long)value, (int)str_gnum(sarg[3]) ) ? Yes : No);
+ STABSET(str);
+ break;
+ case O_REDO:
+ case O_NEXT:
+ case O_LAST:
+ if (maxarg > 0) {
+ tmps = str_get(sarg[1]);
+ while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label ||
+ strNE(tmps,loop_stack[loop_ptr].loop_label) )) {
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Skipping label #%d %s)\n",loop_ptr,
+ loop_stack[loop_ptr].loop_label);
+ }
+#endif
+ loop_ptr--;
+ }
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Found label #%d %s)\n",loop_ptr,
+ loop_stack[loop_ptr].loop_label);
+ }
+#endif
+ }
+ if (loop_ptr < 0)
+ fatal("Bad label: %s\n", maxarg > 0 ? tmps : "<null>");
+ longjmp(loop_stack[loop_ptr].loop_env, optype);
+ case O_GOTO:/* shudder */
+ goto_targ = str_get(sarg[1]);
+ longjmp(top_env, 1);
+ case O_INDEX:
+ tmps = str_get(sarg[1]);
+ if (!(tmps2 = instr(tmps,str_get(sarg[2]))))
+ value = (double)(-1 + arybase);
+ else
+ value = (double)(tmps2 - tmps + arybase);
+ goto donumset;
+ case O_TIME:
+ value = (double) time(0);
+ goto donumset;
+ case O_TMS:
+ value = (double) do_tms(retary);
+ retary = Null(STR***); /* do_tms already did retary */
+ goto donumset;
+ case O_LOCALTIME:
+ tmplong = (long) str_gnum(sarg[1]);
+ value = (double) do_time(localtime(&tmplong),retary);
+ retary = Null(STR***); /* do_localtime already did retary */
+ goto donumset;
+ case O_GMTIME:
+ tmplong = (long) str_gnum(sarg[1]);
+ value = (double) do_time(gmtime(&tmplong),retary);
+ retary = Null(STR***); /* do_gmtime already did retary */
+ goto donumset;
+ case O_STAT:
+ value = (double) do_stat(arg,sarg,retary);
+ retary = Null(STR***); /* do_stat already did retary */
+ goto donumset;
+ case O_CRYPT:
+ tmps = str_get(sarg[1]);
+ str_set(str,crypt(tmps,str_get(sarg[2])));
+ break;
+ case O_EXP:
+ value = exp(str_gnum(sarg[1]));
+ goto donumset;
+ case O_LOG:
+ value = log(str_gnum(sarg[1]));
+ goto donumset;
+ case O_SQRT:
+ value = sqrt(str_gnum(sarg[1]));
+ goto donumset;
+ case O_INT:
+ modf(str_gnum(sarg[1]),&value);
+ goto donumset;
+ case O_ORD:
+ value = (double) *str_get(sarg[1]);
+ goto donumset;
+ case O_SLEEP:
+ tmps = str_get(sarg[1]);
+ time(&tmplong);
+ if (!tmps || !*tmps)
+ sleep((32767<<16)+32767);
+ else
+ sleep(atoi(tmps));
+ value = (double)tmplong;
+ time(&tmplong);
+ value = ((double)tmplong) - value;
+ goto donumset;
+ case O_FLIP:
+ if (str_true(sarg[1])) {
+ str_numset(str,0.0);
+ anum = 2;
+ arg->arg_type = optype = O_FLOP;
+ maxarg = 0;
+ arg[2].arg_flags &= ~AF_SPECIAL;
+ arg[1].arg_flags |= AF_SPECIAL;
+ argflags = arg[anum].arg_flags;
+ goto re_eval;
+ }
+ str_set(str,"");
+ break;
+ case O_FLOP:
+ str_inc(str);
+ if (str_true(sarg[2])) {
+ arg->arg_type = O_FLIP;
+ arg[1].arg_flags &= ~AF_SPECIAL;
+ arg[2].arg_flags |= AF_SPECIAL;
+ str_cat(str,"E0");
+ }
+ break;
+ case O_FORK:
+ value = (double)fork();
+ goto donumset;
+ case O_SYSTEM:
+ if (anum = vfork()) {
+ ihand = signal(SIGINT, SIG_IGN);
+ qhand = signal(SIGQUIT, SIG_IGN);
+ while ((maxarg = wait(&argflags)) != anum && maxarg != -1)
+ ;
+ if (maxarg == -1)
+ argflags = -1;
+ signal(SIGINT, ihand);
+ signal(SIGQUIT, qhand);
+ value = (double)argflags;
+ goto donumset;
+ }
+ /* FALL THROUGH */
+ case O_EXEC:
+ if (arg[1].arg_flags & AF_SPECIAL)
+ value = (double)do_aexec(arg);
+ else {
+ value = (double)do_exec(str_get(sarg[1]));
+ }
+ goto donumset;
+ case O_HEX:
+ maxarg = 4;
+ goto snarfnum;
+
+ case O_OCT:
+ maxarg = 3;
+
+ snarfnum:
+ anum = 0;
+ tmps = str_get(sarg[1]);
+ for (;;) {
+ switch (*tmps) {
+ default:
+ goto out;
+ case '8': case '9':
+ if (maxarg != 4)
+ goto out;
+ /* FALL THROUGH */
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7':
+ anum <<= maxarg;
+ anum += *tmps++ & 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 (maxarg != 4)
+ goto out;
+ anum <<= 4;
+ anum += (*tmps++ & 7) + 9;
+ break;
+ case 'x':
+ maxarg = 4;
+ tmps++;
+ break;
+ }
+ }
+ out:
+ value = (double)anum;
+ goto donumset;
+ case O_CHMOD:
+ case O_CHOWN:
+ case O_KILL:
+ case O_UNLINK:
+ if (arg[1].arg_flags & AF_SPECIAL)
+ value = (double)apply(optype,arg,Null(STR**));
+ else {
+ sarg[2] = Nullstr;
+ value = (double)apply(optype,arg,sarg);
+ }
+ goto donumset;
+ case O_UMASK:
+ value = (double)umask((int)str_gnum(sarg[1]));
+ goto donumset;
+ case O_RENAME:
+ tmps = str_get(sarg[1]);
+#ifdef RENAME
+ value = (double)(rename(tmps,str_get(sarg[2])) >= 0);
+#else
+ tmps2 = str_get(sarg[2]);
+ UNLINK(tmps2);
+ if (!(anum = link(tmps,tmps2)))
+ anum = UNLINK(tmps);
+ value = (double)(anum >= 0);
+#endif
+ goto donumset;
+ case O_LINK:
+ tmps = str_get(sarg[1]);
+ value = (double)(link(tmps,str_get(sarg[2])) >= 0);
+ goto donumset;
+ case O_UNSHIFT:
+ ary = arg[2].arg_ptr.arg_stab->stab_array;
+ if (arg[1].arg_flags & AF_SPECIAL)
+ do_unshift(arg,ary);
+ else {
+ str = str_new(0); /* must copy the STR */
+ str_sset(str,sarg[1]);
+ aunshift(ary,1);
+ astore(ary,0,str);
+ }
+ value = (double)(ary->ary_fill + 1);
+ break;
+ }
+#ifdef DEBUGGING
+ dlevel--;
+ if (debug & 8)
+ deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str));
+#endif
+ goto freeargs;
+
+donumset:
+ str_numset(str,value);
+ STABSET(str);
+#ifdef DEBUGGING
+ dlevel--;
+ if (debug & 8)
+ deb("%s RETURNS \"%f\"\n",opname[optype],value);
+#endif
+
+freeargs:
+ if (sarg != quicksarg) {
+ if (retary) {
+ if (optype == O_LIST)
+ sarg[0] = &str_no;
+ else
+ sarg[0] = Nullstr;
+ sarg[maxarg+1] = Nullstr;
+ *retary = sarg; /* up to them to free it */
+ }
+ else
+ safefree(sarg);
+ }
+ return str;
+
+nullarray:
+ maxarg = 0;
+#ifdef DEBUGGING
+ dlevel--;
+ if (debug & 8)
+ deb("%s RETURNS ()\n",opname[optype],value);
+#endif
+ goto freeargs;
+}
--- /dev/null
+/* $Header: arg.h,v 1.0 87/12/18 13:04:39 root Exp $
+ *
+ * $Log: arg.h,v $
+ * Revision 1.0 87/12/18 13:04:39 root
+ * Initial revision
+ *
+ */
+
+#define O_NULL 0
+#define O_ITEM 1
+#define O_ITEM2 2
+#define O_ITEM3 3
+#define O_CONCAT 4
+#define O_MATCH 5
+#define O_NMATCH 6
+#define O_SUBST 7
+#define O_NSUBST 8
+#define O_ASSIGN 9
+#define O_MULTIPLY 10
+#define O_DIVIDE 11
+#define O_MODULO 12
+#define O_ADD 13
+#define O_SUBTRACT 14
+#define O_LEFT_SHIFT 15
+#define O_RIGHT_SHIFT 16
+#define O_LT 17
+#define O_GT 18
+#define O_LE 19
+#define O_GE 20
+#define O_EQ 21
+#define O_NE 22
+#define O_BIT_AND 23
+#define O_XOR 24
+#define O_BIT_OR 25
+#define O_AND 26
+#define O_OR 27
+#define O_COND_EXPR 28
+#define O_COMMA 29
+#define O_NEGATE 30
+#define O_NOT 31
+#define O_COMPLEMENT 32
+#define O_WRITE 33
+#define O_OPEN 34
+#define O_TRANS 35
+#define O_NTRANS 36
+#define O_CLOSE 37
+#define O_ARRAY 38
+#define O_HASH 39
+#define O_LARRAY 40
+#define O_LHASH 41
+#define O_PUSH 42
+#define O_POP 43
+#define O_SHIFT 44
+#define O_SPLIT 45
+#define O_LENGTH 46
+#define O_SPRINTF 47
+#define O_SUBSTR 48
+#define O_JOIN 49
+#define O_SLT 50
+#define O_SGT 51
+#define O_SLE 52
+#define O_SGE 53
+#define O_SEQ 54
+#define O_SNE 55
+#define O_SUBR 56
+#define O_PRINT 57
+#define O_CHDIR 58
+#define O_DIE 59
+#define O_EXIT 60
+#define O_RESET 61
+#define O_LIST 62
+#define O_SELECT 63
+#define O_EOF 64
+#define O_TELL 65
+#define O_SEEK 66
+#define O_LAST 67
+#define O_NEXT 68
+#define O_REDO 69
+#define O_GOTO 70
+#define O_INDEX 71
+#define O_TIME 72
+#define O_TMS 73
+#define O_LOCALTIME 74
+#define O_GMTIME 75
+#define O_STAT 76
+#define O_CRYPT 77
+#define O_EXP 78
+#define O_LOG 79
+#define O_SQRT 80
+#define O_INT 81
+#define O_PRTF 82
+#define O_ORD 83
+#define O_SLEEP 84
+#define O_FLIP 85
+#define O_FLOP 86
+#define O_KEYS 87
+#define O_VALUES 88
+#define O_EACH 89
+#define O_CHOP 90
+#define O_FORK 91
+#define O_EXEC 92
+#define O_SYSTEM 93
+#define O_OCT 94
+#define O_HEX 95
+#define O_CHMOD 96
+#define O_CHOWN 97
+#define O_KILL 98
+#define O_RENAME 99
+#define O_UNLINK 100
+#define O_UMASK 101
+#define O_UNSHIFT 102
+#define O_LINK 103
+#define O_REPEAT 104
+#define MAXO 105
+
+#ifndef DOINIT
+extern char *opname[];
+#else
+char *opname[] = {
+ "NULL",
+ "ITEM",
+ "ITEM2",
+ "ITEM3",
+ "CONCAT",
+ "MATCH",
+ "NMATCH",
+ "SUBST",
+ "NSUBST",
+ "ASSIGN",
+ "MULTIPLY",
+ "DIVIDE",
+ "MODULO",
+ "ADD",
+ "SUBTRACT",
+ "LEFT_SHIFT",
+ "RIGHT_SHIFT",
+ "LT",
+ "GT",
+ "LE",
+ "GE",
+ "EQ",
+ "NE",
+ "BIT_AND",
+ "XOR",
+ "BIT_OR",
+ "AND",
+ "OR",
+ "COND_EXPR",
+ "COMMA",
+ "NEGATE",
+ "NOT",
+ "COMPLEMENT",
+ "WRITE",
+ "OPEN",
+ "TRANS",
+ "NTRANS",
+ "CLOSE",
+ "ARRAY",
+ "HASH",
+ "LARRAY",
+ "LHASH",
+ "PUSH",
+ "POP",
+ "SHIFT",
+ "SPLIT",
+ "LENGTH",
+ "SPRINTF",
+ "SUBSTR",
+ "JOIN",
+ "SLT",
+ "SGT",
+ "SLE",
+ "SGE",
+ "SEQ",
+ "SNE",
+ "SUBR",
+ "PRINT",
+ "CHDIR",
+ "DIE",
+ "EXIT",
+ "RESET",
+ "LIST",
+ "SELECT",
+ "EOF",
+ "TELL",
+ "SEEK",
+ "LAST",
+ "NEXT",
+ "REDO",
+ "GOTO",/* shudder */
+ "INDEX",
+ "TIME",
+ "TIMES",
+ "LOCALTIME",
+ "GMTIME",
+ "STAT",
+ "CRYPT",
+ "EXP",
+ "LOG",
+ "SQRT",
+ "INT",
+ "PRINTF",
+ "ORD",
+ "SLEEP",
+ "FLIP",
+ "FLOP",
+ "KEYS",
+ "VALUES",
+ "EACH",
+ "CHOP",
+ "FORK",
+ "EXEC",
+ "SYSTEM",
+ "OCT",
+ "HEX",
+ "CHMOD",
+ "CHOWN",
+ "KILL",
+ "RENAME",
+ "UNLINK",
+ "UMASK",
+ "UNSHIFT",
+ "LINK",
+ "REPEAT",
+ "105"
+};
+#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_NUMBER 12
+
+#ifndef DOINIT
+extern char *argname[];
+#else
+char *argname[] = {
+ "A_NULL",
+ "EXPR",
+ "CMD",
+ "STAB",
+ "LVAL",
+ "SINGLE",
+ "DOUBLE",
+ "BACKTICK",
+ "READ",
+ "SPAT",
+ "LEXPR",
+ "ARYLEN",
+ "NUMBER",
+ "13"
+};
+#endif
+
+#ifndef DOINIT
+extern bool hoistable[];
+#else
+bool hoistable[] = {0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0};
+#endif
+
+struct arg {
+ union argptr {
+ ARG *arg_arg;
+ char *arg_cval;
+ STAB *arg_stab;
+ SPAT *arg_spat;
+ CMD *arg_cmd;
+ STR *arg_str;
+ double arg_nval;
+ } arg_ptr;
+ short arg_len;
+ char arg_type;
+ char arg_flags;
+};
+
+#define AF_SPECIAL 1 /* op wants to evaluate this arg itself */
+#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_NUMERIC 32 /* return as numeric rather than string */
+#define AF_LISTISH 64 /* turn into list if important */
+
+/*
+ * 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, 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*)
+
+EXT char opargs[MAXO];
+
+int do_trans();
+int do_split();
+bool do_eof();
+long do_tell();
+bool do_seek();
+int do_tms();
+int do_time();
+int do_stat();
--- /dev/null
+/* $Header: array.c,v 1.0 87/12/18 13:04:42 root Exp $
+ *
+ * $Log: array.c,v $
+ * Revision 1.0 87/12/18 13:04:42 root
+ * Initial revision
+ *
+ */
+
+#include <stdio.h>
+#include "EXTERN.h"
+#include "handy.h"
+#include "util.h"
+#include "search.h"
+#include "perl.h"
+
+STR *
+afetch(ar,key)
+register ARRAY *ar;
+int key;
+{
+ if (key < 0 || key > ar->ary_max)
+ return Nullstr;
+ return ar->ary_array[key];
+}
+
+bool
+astore(ar,key,val)
+register ARRAY *ar;
+int key;
+STR *val;
+{
+ bool retval;
+
+ if (key < 0)
+ return FALSE;
+ if (key > ar->ary_max) {
+ int newmax = key + ar->ary_max / 5;
+
+ ar->ary_array = (STR**)saferealloc((char*)ar->ary_array,
+ (newmax+1) * sizeof(STR*));
+ bzero((char*)&ar->ary_array[ar->ary_max+1],
+ (newmax - ar->ary_max) * sizeof(STR*));
+ ar->ary_max = newmax;
+ }
+ if (key > ar->ary_fill)
+ ar->ary_fill = key;
+ retval = (ar->ary_array[key] != Nullstr);
+ if (retval)
+ str_free(ar->ary_array[key]);
+ ar->ary_array[key] = val;
+ return retval;
+}
+
+bool
+adelete(ar,key)
+register ARRAY *ar;
+int key;
+{
+ if (key < 0 || key > ar->ary_max)
+ return FALSE;
+ if (ar->ary_array[key]) {
+ str_free(ar->ary_array[key]);
+ ar->ary_array[key] = Nullstr;
+ return TRUE;
+ }
+ return FALSE;
+}
+
+ARRAY *
+anew()
+{
+ register ARRAY *ar = (ARRAY*)safemalloc(sizeof(ARRAY));
+
+ ar->ary_array = (STR**) safemalloc(5 * sizeof(STR*));
+ ar->ary_fill = -1;
+ ar->ary_max = 4;
+ bzero((char*)ar->ary_array, 5 * sizeof(STR*));
+ return ar;
+}
+
+void
+afree(ar)
+register ARRAY *ar;
+{
+ register int key;
+
+ if (!ar)
+ return;
+ for (key = 0; key <= ar->ary_fill; key++)
+ str_free(ar->ary_array[key]);
+ safefree((char*)ar->ary_array);
+ safefree((char*)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;
+ astore(ar,ar->ary_fill+num,(STR*)0); /* maybe extend array */
+ sstr = ar->ary_array + ar->ary_fill;
+ dstr = sstr + num;
+ for (i = ar->ary_fill; i >= 0; i--) {
+ *dstr-- = *sstr--;
+ }
+ bzero((char*)(ar->ary_array), num * sizeof(STR*));
+}
+
+STR *
+ashift(ar)
+register ARRAY *ar;
+{
+ STR *retval;
+
+ if (ar->ary_fill < 0)
+ return Nullstr;
+ retval = ar->ary_array[0];
+ bcopy((char*)(ar->ary_array+1),(char*)ar->ary_array,
+ ar->ary_fill * sizeof(STR*));
+ ar->ary_array[ar->ary_fill--] = Nullstr;
+ return retval;
+}
+
+long
+alen(ar)
+register ARRAY *ar;
+{
+ return (long)ar->ary_fill;
+}
+
+void
+ajoin(ar,delim,str)
+register ARRAY *ar;
+char *delim;
+register STR *str;
+{
+ register int i;
+ register int len;
+ register int dlen;
+
+ if (ar->ary_fill < 0) {
+ str_set(str,"");
+ STABSET(str);
+ return;
+ }
+ dlen = strlen(delim);
+ len = ar->ary_fill * dlen; /* account for delimiters */
+ for (i = ar->ary_fill; i >= 0; i--)
+ len += str_len(ar->ary_array[i]);
+ str_grow(str,len); /* preallocate for efficiency */
+ str_sset(str,ar->ary_array[0]);
+ for (i = 1; i <= ar->ary_fill; i++) {
+ str_ncat(str,delim,dlen);
+ str_scat(str,ar->ary_array[i]);
+ }
+ STABSET(str);
+}
--- /dev/null
+/* $Header: array.h,v 1.0 87/12/18 13:04:46 root Exp $
+ *
+ * $Log: array.h,v $
+ * Revision 1.0 87/12/18 13:04:46 root
+ * Initial revision
+ *
+ */
+
+struct atbl {
+ STR **ary_array;
+ int ary_max;
+ int ary_fill;
+};
+
+STR *afetch();
+bool astore();
+bool adelete();
+STR *apop();
+STR *ashift();
+bool apush();
+long alen();
+ARRAY *anew();
--- /dev/null
+/* $Header: cmd.c,v 1.0 87/12/18 13:04:51 root Exp $
+ *
+ * $Log: cmd.c,v $
+ * Revision 1.0 87/12/18 13:04:51 root
+ * Initial revision
+ *
+ */
+
+#include "handy.h"
+#include "EXTERN.h"
+#include "search.h"
+#include "util.h"
+#include "perl.h"
+
+static STR str_chop;
+
+/* 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.
+ */
+
+STR *
+cmd_exec(cmd)
+register CMD *cmd;
+{
+ SPAT *oldspat;
+#ifdef DEBUGGING
+ int olddlevel;
+ int entdlevel;
+#endif
+ register STR *retstr;
+ register char *tmps;
+ register int cmdflags;
+ register bool match;
+ register char *go_to = goto_targ;
+ ARG *arg;
+ FILE *fp;
+
+ retstr = &str_no;
+#ifdef DEBUGGING
+ entdlevel = dlevel;
+#endif
+tail_recursion_entry:
+#ifdef DEBUGGING
+ dlevel = entdlevel;
+#endif
+ if (cmd == Nullcmd)
+ return retstr;
+ 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;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ retstr = &str_yes;
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ debname[dlevel] = 't';
+ debdelim[dlevel++] = '_';
+#endif
+ retstr = cmd_exec(cmd->ucmd.ccmd.cc_true);
+ }
+ if (!goto_targ) {
+ go_to = Nullch;
+ } else {
+ retstr = &str_no;
+ if (cmd->ucmd.ccmd.cc_alt) {
+#ifdef DEBUGGING
+ debname[dlevel] = 'e';
+ debdelim[dlevel++] = '_';
+#endif
+ retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt);
+ }
+ }
+ if (!goto_targ)
+ go_to = Nullch;
+ curspat = oldspat;
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ break;
+ case C_BLOCK:
+ case C_WHILE:
+ if (!(cmdflags & CF_ONCE)) {
+ cmdflags |= CF_ONCE;
+ loop_ptr++;
+ loop_stack[loop_ptr].loop_label = cmd->c_label;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d %s)\n",
+ loop_ptr,cmd->c_label);
+ }
+#endif
+ }
+ switch (setjmp(loop_stack[loop_ptr].loop_env)) {
+ case O_LAST: /* not done unless go_to found */
+ go_to = Nullch;
+ retstr = &str_no;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ curspat = oldspat;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Popping label #%d %s)\n",loop_ptr,
+ loop_stack[loop_ptr].loop_label);
+ }
+#endif
+ loop_ptr--;
+ cmd = cmd->c_next;
+ goto tail_recursion_entry;
+ case O_NEXT: /* not done unless go_to found */
+ go_to = Nullch;
+ goto next_iter;
+ case O_REDO: /* not done unless go_to found */
+ go_to = Nullch;
+ goto doit;
+ }
+ oldspat = curspat;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ debname[dlevel] = 't';
+ debdelim[dlevel++] = '_';
+#endif
+ cmd_exec(cmd->ucmd.ccmd.cc_true);
+ }
+ if (!goto_targ) {
+ go_to = Nullch;
+ goto next_iter;
+ }
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ if (cmd->ucmd.ccmd.cc_alt) {
+#ifdef DEBUGGING
+ debname[dlevel] = 'a';
+ debdelim[dlevel++] = '_';
+#endif
+ cmd_exec(cmd->ucmd.ccmd.cc_alt);
+ }
+ 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 retstr; /* targ isn't in this block */
+ goto tail_recursion_entry;
+ }
+ }
+
+until_loop:
+
+#ifdef DEBUGGING
+ 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++] = '!';
+#endif
+ while (tmps_max >= 0) /* clean up after last eval */
+ str_free(tmps_list[tmps_max--]);
+
+ /* Here is some common optimization */
+
+ if (cmdflags & CF_COND) {
+ switch (cmdflags & CF_OPTIMIZE) {
+
+ case CFT_FALSE:
+ retstr = cmd->c_first;
+ match = FALSE;
+ if (cmdflags & CF_NESURE)
+ goto maybe;
+ break;
+ case CFT_TRUE:
+ retstr = cmd->c_first;
+ match = TRUE;
+ if (cmdflags & CF_EQSURE)
+ goto flipmaybe;
+ break;
+
+ case CFT_REG:
+ retstr = STAB_STR(cmd->c_stab);
+ 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_first->str_ptr && !(cmdflags & CF_EQSURE))
+ goto scanner; /* just unanchor it */
+ else
+ break; /* must evaluate */
+ }
+ /* FALL THROUGH */
+ case CFT_STROP: /* string op optimization */
+ retstr = STAB_STR(cmd->c_stab);
+ if (*cmd->c_first->str_ptr == *str_get(retstr) &&
+ strnEQ(cmd->c_first->str_ptr, str_get(retstr),
+ cmd->c_flen) ) {
+ if (cmdflags & CF_EQSURE) {
+ match = !(cmdflags & CF_FIRSTNEG);
+ retstr = &str_yes;
+ goto flipmaybe;
+ }
+ }
+ else if (cmdflags & CF_NESURE) {
+ match = cmdflags & CF_FIRSTNEG;
+ retstr = &str_no;
+ goto flipmaybe;
+ }
+ break; /* must evaluate */
+
+ case CFT_SCAN: /* non-anchored search */
+ scanner:
+ retstr = STAB_STR(cmd->c_stab);
+ if (instr(str_get(retstr),cmd->c_first->str_ptr)) {
+ if (cmdflags & CF_EQSURE) {
+ match = !(cmdflags & CF_FIRSTNEG);
+ retstr = &str_yes;
+ goto flipmaybe;
+ }
+ }
+ else if (cmdflags & CF_NESURE) {
+ match = cmdflags & CF_FIRSTNEG;
+ retstr = &str_no;
+ goto flipmaybe;
+ }
+ break; /* must evaluate */
+
+ case CFT_GETS: /* really a while (<file>) */
+ last_in_stab = cmd->c_stab;
+ fp = last_in_stab->stab_io->fp;
+ retstr = defstab->stab_val;
+ if (fp && str_gets(retstr, fp)) {
+ last_in_stab->stab_io->lines++;
+ match = TRUE;
+ }
+ else if (last_in_stab->stab_io->flags & IOF_ARGV)
+ goto doeval; /* doesn't necessarily count as EOF yet */
+ else {
+ retstr = &str_no;
+ match = FALSE;
+ }
+ goto flipmaybe;
+ case CFT_EVAL:
+ break;
+ case CFT_UNFLIP:
+ retstr = eval(cmd->c_expr,Null(char***));
+ 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 = cmd->c_stab->stab_val;
+ match = (retstr->str_cur != 0);
+ tmps = str_get(retstr);
+ tmps += retstr->str_cur - match;
+ str_set(&str_chop,tmps);
+ *tmps = '\0';
+ retstr->str_nok = 0;
+ retstr->str_cur = tmps - retstr->str_ptr;
+ retstr = &str_chop;
+ goto flipmaybe;
+ }
+
+ /* we have tried to make this normal case as abnormal as possible */
+
+ doeval:
+ retstr = eval(cmd->c_expr,Null(char***));
+ match = str_true(retstr);
+ goto maybe;
+
+ /* if flipflop was true, flop it */
+
+ flipmaybe:
+ if (match && cmdflags & CF_FLIP) {
+ if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */
+ retstr = eval(cmd->c_expr,Null(char***)); /* let eval undo it */
+ cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd);
+ }
+ else {
+ retstr = eval(cmd->c_expr,Null(char***)); /* 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 && cmd->c_type != C_IF) {
+ cmd = cmd->c_next;
+ goto tail_recursion_entry;
+ }
+ }
+
+ /* now to do the actual command, if any */
+
+ switch (cmd->c_type) {
+ case C_NULL:
+ fatal("panic: cmd_exec\n");
+ case C_EXPR: /* evaluated for side effects */
+ if (cmd->ucmd.acmd.ac_expr) { /* more to do? */
+ retstr = eval(cmd->ucmd.acmd.ac_expr,Null(char***));
+ }
+ break;
+ case C_IF:
+ oldspat = curspat;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ if (match) {
+ retstr = &str_yes;
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ debname[dlevel] = 't';
+ debdelim[dlevel++] = '_';
+#endif
+ retstr = cmd_exec(cmd->ucmd.ccmd.cc_true);
+ }
+ }
+ else {
+ retstr = &str_no;
+ if (cmd->ucmd.ccmd.cc_alt) {
+#ifdef DEBUGGING
+ debname[dlevel] = 'e';
+ debdelim[dlevel++] = '_';
+#endif
+ retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt);
+ }
+ }
+ curspat = oldspat;
+#ifdef DEBUGGING
+ dlevel = olddlevel;
+#endif
+ break;
+ case C_BLOCK:
+ case C_WHILE:
+ if (!(cmdflags & CF_ONCE)) { /* first time through here? */
+ cmdflags |= CF_ONCE;
+ loop_ptr++;
+ loop_stack[loop_ptr].loop_label = cmd->c_label;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Pushing label #%d %s)\n",
+ loop_ptr,cmd->c_label);
+ }
+#endif
+ }
+ switch (setjmp(loop_stack[loop_ptr].loop_env)) {
+ case O_LAST:
+ retstr = &str_no;
+ curspat = oldspat;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Popping label #%d %s)\n",loop_ptr,
+ loop_stack[loop_ptr].loop_label);
+ }
+#endif
+ loop_ptr--;
+ cmd = cmd->c_next;
+ goto tail_recursion_entry;
+ case O_NEXT:
+ goto next_iter;
+ case O_REDO:
+ goto doit;
+ }
+ oldspat = curspat;
+#ifdef DEBUGGING
+ olddlevel = dlevel;
+#endif
+ doit:
+ if (cmd->ucmd.ccmd.cc_true) {
+#ifdef DEBUGGING
+ debname[dlevel] = 't';
+ debdelim[dlevel++] = '_';
+#endif
+ cmd_exec(cmd->ucmd.ccmd.cc_true);
+ }
+ /* actually, this spot is never 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
+ debname[dlevel] = 'a';
+ debdelim[dlevel++] = '_';
+#endif
+ cmd_exec(cmd->ucmd.ccmd.cc_alt);
+ }
+ finish_while:
+ curspat = oldspat;
+#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 */
+ goto until_loop;
+ }
+ cmd = cmd->c_next;
+ goto tail_recursion_entry;
+}
+
+#ifdef DEBUGGING
+/*VARARGS1*/
+deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
+char *pat;
+{
+ register int i;
+
+ 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);
+}
+#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_first = which->c_first;
+ cmd->c_flen = which->c_flen;
+ cmd->c_stab = which->c_stab;
+ return cmd->c_flags;
+}
--- /dev/null
+/* $Header: cmd.h,v 1.0 87/12/18 13:04:59 root Exp $
+ *
+ * $Log: cmd.h,v $
+ * Revision 1.0 87/12/18 13:04:59 root
+ * Initial revision
+ *
+ */
+
+#define C_NULL 0
+#define C_IF 1
+#define C_WHILE 2
+#define C_EXPR 3
+#define C_BLOCK 4
+
+#ifndef DOINIT
+extern char *cmdname[];
+#else
+char *cmdname[] = {
+ "NULL",
+ "IF",
+ "WHILE",
+ "EXPR",
+ "BLOCK",
+ "5",
+ "6",
+ "7",
+ "8",
+ "9",
+ "10",
+ "11",
+ "12",
+ "13",
+ "14",
+ "15",
+ "16"
+};
+#endif
+
+#define CF_OPTIMIZE 077 /* type of optimization */
+#define CF_FIRSTNEG 0100/* conditional is ($register NE 'string') */
+#define CF_NESURE 0200 /* if first doesn't match we're sure */
+#define CF_EQSURE 0400 /* if first 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 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 $reg = <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 */
+
+#ifndef DOINIT
+extern char *cmdopt[];
+#else
+char *cmdopt[] = {
+ "FALSE",
+ "TRUE",
+ "REG",
+ "ANCHOR",
+ "STROP",
+ "SCAN",
+ "GETS",
+ "EVAL",
+ "UNFLIP",
+ "CHOP",
+ "10"
+};
+#endif
+
+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 code or continue code */
+};
+
+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_first; /* head of 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 */
+ } ucmd;
+ short c_flen; /* len of c_first, if not null */
+ short c_flags; /* optimization flags--see above */
+ char c_type; /* what this command does */
+};
+
+#define Nullcmd Null(CMD*)
+
+EXT CMD *main_root INIT(Nullcmd);
+
+EXT struct compcmd {
+ CMD *comp_true;
+ CMD *comp_alt;
+};
+
+#ifndef DOINIT
+extern struct compcmd Nullccmd;
+#else
+struct compcmd Nullccmd = {Nullcmd, Nullcmd};
+#endif
+void opt_arg();
+void evalstatic();
+STR *cmd_exec();
--- /dev/null
+/* 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 /**/
+
+/* 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 /**/
+
+/* 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? */
+
+/* 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 /**/
+
+/* vfork:
+ * This symbol, if defined, remaps the vfork routine to fork if the
+ * vfork() routine isn't supported here.
+ */
+#/*undef vfork fork /**/
+
+/* 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
+ * 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
+
--- /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)
+ echo "Using config.sh from above..."
+ fi
+ . config.sh
+ ;;
+esac
+echo "Extracting config.h (with variable substitutions)"
+cat <<!GROK!THIS! >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.
+ */
+#$d_eunice EUNICE /**/
+#$d_eunice VMS /**/
+
+/* 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 /**/
+
+/* 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? */
+
+/* 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 /**/
+
+/* vfork:
+ * This symbol, if defined, remaps the vfork routine to fork if the
+ * vfork() routine isn't supported here.
+ */
+#$d_vfork vfork fork /**/
+
+/* 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
+ * level of void support necessary is not present, defines void to int.
+ */
+#ifndef VOIDUSED
+#define VOIDUSED $defvoidused
+#endif
+#define VOIDFLAGS $voidflags
+#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+#$define void int /* is void to be avoided? */
+#$define M_VOID /* Xenix strikes again */
+#endif
+
+!GROK!THIS!
--- /dev/null
+/* $Header: dump.c,v 1.0 87/12/18 13:05:03 root Exp $
+ *
+ * $Log: dump.c,v $
+ * Revision 1.0 87/12/18 13:05:03 root
+ * Initial revision
+ *
+ */
+
+#include "handy.h"
+#include "EXTERN.h"
+#include "search.h"
+#include "util.h"
+#include "perl.h"
+
+#ifdef DEBUGGING
+static int dumplvl = 0;
+
+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]);
+ 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)
+ strcat(buf,"FIRSTNEG,");
+ if (cmd->c_flags & CF_NESURE)
+ strcat(buf,"NESURE,");
+ if (cmd->c_flags & CF_EQSURE)
+ strcat(buf,"EQSURE,");
+ if (cmd->c_flags & CF_COND)
+ strcat(buf,"COND,");
+ if (cmd->c_flags & CF_LOOP)
+ strcat(buf,"LOOP,");
+ if (cmd->c_flags & CF_INVERT)
+ strcat(buf,"INVERT,");
+ if (cmd->c_flags & CF_ONCE)
+ strcat(buf,"ONCE,");
+ if (cmd->c_flags & CF_FLIP)
+ strcat(buf,"FLIP,");
+ if (*buf)
+ buf[strlen(buf)-1] = '\0';
+ dump("C_FLAGS = (%s)\n",buf);
+ if (cmd->c_first) {
+ dump("C_FIRST = \"%s\"\n",str_peek(cmd->c_first));
+ dump("C_FLEN = \"%d\"\n",cmd->c_flen);
+ }
+ 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_WHILE:
+ case C_BLOCK:
+ 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_ELSE = ");
+ dump_cmd(cmd->ucmd.ccmd.cc_alt,Nullcmd);
+ } else
+ dump("CC_ALT = NULL\n");
+ break;
+ case C_EXPR:
+ if (cmd->ucmd.acmd.ac_stab) {
+ dump("AC_STAB = ");
+ dump_arg(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;
+ }
+ 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{\n");
+ 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);
+ for (i = 1; i <= arg->arg_len; i++) {
+ dump("[%d]ARG_TYPE = %s\n",i,argname[arg[i].arg_type]);
+ if (arg[i].arg_len)
+ dump("[%d]ARG_LEN = %d\n",i,arg[i].arg_len);
+ *buf = '\0';
+ if (arg[i].arg_flags & AF_SPECIAL)
+ strcat(buf,"SPECIAL,");
+ if (arg[i].arg_flags & AF_POST)
+ strcat(buf,"POST,");
+ if (arg[i].arg_flags & AF_PRE)
+ strcat(buf,"PRE,");
+ if (arg[i].arg_flags & AF_UP)
+ strcat(buf,"UP,");
+ if (arg[i].arg_flags & AF_COMMON)
+ strcat(buf,"COMMON,");
+ if (arg[i].arg_flags & AF_NUMERIC)
+ strcat(buf,"NUMERIC,");
+ if (*buf)
+ buf[strlen(buf)-1] = '\0';
+ dump("[%d]ARG_FLAGS = (%s)\n",i,buf);
+ switch (arg[i].arg_type) {
+ case A_NULL:
+ 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_STAB:
+ case A_LVAL:
+ case A_READ:
+ case A_ARYLEN:
+ 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;
+ case A_NUMBER:
+ dump("[%d]ARG_NVAL = %f\n",i,arg[i].arg_ptr.arg_nval);
+ break;
+ }
+ }
+ dumplvl--;
+ dump("}\n");
+}
+
+dump_stab(stab)
+register STAB *stab;
+{
+ dumplvl++;
+ fprintf(stderr,"{\n");
+ dump("STAB_NAME = %s\n",stab->stab_name);
+ dumplvl--;
+ dump("}\n");
+}
+
+dump_spat(spat)
+register SPAT *spat;
+{
+ char ch;
+
+ fprintf(stderr,"{\n");
+ dumplvl++;
+ if (spat->spat_runtime) {
+ dump("SPAT_RUNTIME = ");
+ dump_arg(spat->spat_runtime);
+ } else {
+ if (spat->spat_flags & SPAT_USE_ONCE)
+ ch = '?';
+ else
+ ch = '/';
+ dump("SPAT_PRE %c%s%c\n",ch,spat->spat_compex.precomp,ch);
+ }
+ if (spat->spat_repl) {
+ dump("SPAT_REPL = ");
+ dump_arg(spat->spat_repl);
+ }
+ dumplvl--;
+ dump("}\n");
+}
+
+dump(arg1,arg2,arg3,arg4,arg5)
+char *arg1, *arg2, *arg3, *arg4, *arg5;
+{
+ int i;
+
+ for (i = dumplvl*4; i; i--)
+ 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)) {
+ write(fd,s,linestr->str_cur);
+ }
+ close(fd);
+ for (s=cmd; *s; s++)
+ if (*s < ' ')
+ *s += 96;
+ rsfp = popen(cmd,"r");
+ s = str_gets(linestr,rsfp);
+ return s;
+ }
+ }
+ return str_get(linestr);
+}
+#endif
--- /dev/null
+/* $Header: form.c,v 1.0 87/12/18 13:05:07 root Exp $
+ *
+ * $Log: form.c,v $
+ * Revision 1.0 87/12/18 13:05:07 root
+ * Initial revision
+ *
+ */
+
+#include "handy.h"
+#include "EXTERN.h"
+#include "search.h"
+#include "util.h"
+#include "perl.h"
+
+/* Forms stuff */
+
+#define CHKLEN(allow) \
+if (d - orec->o_str + (allow) >= 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)
+register struct outrec *orec;
+register FCMD *fcmd;
+{
+ register char *d = orec->o_str;
+ register char *s;
+ register int curlen = orec->o_len - 2;
+ register int size;
+ char tmpchar;
+ char *t;
+ CMD mycmd;
+ STR *str;
+ char *chophere;
+
+ mycmd.c_type = C_NULL;
+ orec->o_lines = 0;
+ for (; fcmd; fcmd = fcmd->f_next) {
+ CHKLEN(fcmd->f_presize);
+ for (s=fcmd->f_pre; *s;) {
+ if (*s == '\n') {
+ while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t'))
+ d--;
+ if (fcmd->f_flags & FC_NOBLANK &&
+ (d == orec->o_str || d[-1] == '\n') ) {
+ orec->o_lines--; /* don't print blank line */
+ break;
+ }
+ }
+ *d++ = *s++;
+ }
+ switch (fcmd->f_type) {
+ case F_NULL:
+ orec->o_lines++;
+ break;
+ case F_LEFT:
+ str = eval(fcmd->f_expr,Null(char***),(double*)0);
+ s = str_get(str);
+ size = fcmd->f_size;
+ CHKLEN(size);
+ chophere = Nullch;
+ while (size && *s && *s != '\n') {
+ size--;
+ if ((*d++ = *s++) == ' ')
+ chophere = s;
+ }
+ if (size)
+ 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++ = '.';
+ }
+ s = chophere;
+ while (*chophere == ' ' || *chophere == '\n')
+ 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:
+ t = s = str_get(eval(fcmd->f_expr,Null(char***),(double*)0));
+ size = fcmd->f_size;
+ CHKLEN(size);
+ chophere = Nullch;
+ while (size && *s && *s != '\n') {
+ size--;
+ if (*s++ == ' ')
+ chophere = s;
+ }
+ if (size)
+ 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++ = '.';
+ }
+ s = chophere;
+ while (*chophere == ' ' || *chophere == '\n')
+ chophere++;
+ str_chop(str,chophere);
+ }
+ tmpchar = *s;
+ *s = '\0';
+ while (size) {
+ size--;
+ *d++ = ' ';
+ }
+ size = s - t;
+ bcopy(t,d,size);
+ d += size;
+ *s = tmpchar;
+ break;
+ case F_CENTER: {
+ int halfsize;
+
+ t = s = str_get(eval(fcmd->f_expr,Null(char***),(double*)0));
+ size = fcmd->f_size;
+ CHKLEN(size);
+ chophere = Nullch;
+ while (size && *s && *s != '\n') {
+ size--;
+ if (*s++ == ' ')
+ chophere = s;
+ }
+ if (size)
+ 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++ = '.';
+ }
+ s = chophere;
+ while (*chophere == ' ' || *chophere == '\n')
+ chophere++;
+ str_chop(str,chophere);
+ }
+ tmpchar = *s;
+ *s = '\0';
+ halfsize = size / 2;
+ while (size > halfsize) {
+ size--;
+ *d++ = ' ';
+ }
+ size = s - t;
+ 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++ = ' ';
+ }
+ break;
+ }
+ case F_LINES:
+ str = eval(fcmd->f_expr,Null(char***),(double*)0);
+ s = str_get(str);
+ size = str_len(str);
+ CHKLEN(size);
+ orec->o_lines += countlines(s);
+ bcopy(s,d,size);
+ d += size;
+ break;
+ }
+ }
+ *d++ = '\0';
+}
+
+countlines(s)
+register char *s;
+{
+ register int count = 0;
+
+ while (*s) {
+ if (*s++ == '\n')
+ count++;
+ }
+ return count;
+}
+
+do_write(orec,stio)
+struct outrec *orec;
+register STIO *stio;
+{
+ FILE *ofp = stio->fp;
+
+#ifdef DEBUGGING
+ if (debug & 256)
+ fprintf(stderr,"left=%d, todo=%d\n",stio->lines_left, orec->o_lines);
+#endif
+ if (stio->lines_left < orec->o_lines) {
+ if (!stio->top_stab) {
+ STAB *topstab;
+
+ if (!stio->top_name)
+ stio->top_name = savestr("top");
+ topstab = stabent(stio->top_name,FALSE);
+ if (!topstab || !topstab->stab_form) {
+ stio->lines_left = 100000000;
+ goto forget_top;
+ }
+ stio->top_stab = topstab;
+ }
+ if (stio->lines_left >= 0)
+ putc('\f',ofp);
+ stio->lines_left = stio->page_len;
+ stio->page++;
+ format(&toprec,stio->top_stab->stab_form);
+ 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
+/* $Header: form.h,v 1.0 87/12/18 13:05:10 root Exp $
+ *
+ * $Log: form.h,v $
+ * Revision 1.0 87/12/18 13:05:10 root
+ * Initial revision
+ *
+ */
+
+#define F_NULL 0
+#define F_LEFT 1
+#define F_RIGHT 2
+#define F_CENTER 3
+#define F_LINES 4
+
+struct formcmd {
+ struct formcmd *f_next;
+ ARG *f_expr;
+ char *f_pre;
+ short f_presize;
+ short f_size;
+ char f_type;
+ char f_flags;
+};
+
+#define FC_CHOP 1
+#define FC_NOBLANK 2
+#define FC_MORE 4
+
+#define Nullfcmd Null(FCMD*)
--- /dev/null
+/* $Header: handy.h,v 1.0 87/12/18 13:05:14 root Exp $
+ *
+ * $Log: handy.h,v $
+ * Revision 1.0 87/12/18 13:05:14 root
+ * Initial revision
+ *
+ */
+
+#define Null(type) ((type)0)
+#define Nullch Null(char*)
+#define Nullfp Null(FILE*)
+
+#define bool char
+#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
+/* $Header: hash.c,v 1.0 87/12/18 13:05:17 root Exp $
+ *
+ * $Log: hash.c,v $
+ * Revision 1.0 87/12/18 13:05:17 root
+ * Initial revision
+ *
+ */
+
+#include <stdio.h>
+#include "EXTERN.h"
+#include "handy.h"
+#include "util.h"
+#include "search.h"
+#include "perl.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;
+ safefree((char*)entry->hent_val);
+ entry->hent_val = val;
+ return TRUE;
+ }
+ 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
+/* $Header: hash.h,v 1.0 87/12/18 13:05:20 root Exp $
+ *
+ * $Log: hash.h,v $
+ * Revision 1.0 87/12/18 13:05:20 root
+ * Initial revision
+ *
+ */
+
+#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
+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
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting makedepend (with variable substitutions)"
+$spitshell >makedepend <<!GROK!THIS!
+$startsh
+# $Header: makedepend.SH,v 1.0 87/12/18 17:54:32 root Exp $
+#
+# $Log: makedepend.SH,v $
+# Revision 1.0 87/12/18 17:54:32 root
+# Initial revision
+#
+#
+
+export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
+
+cat='$cat'
+cp='$cp'
+cpp='$cpp'
+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
+ mf=Makefile
+else
+ mf=makefile
+fi
+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 */*.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 '}'
+ $cpp -I/usr/local/include -I. -I./h $file.c | \
+ $sed \
+ -e '/^# *[0-9]/!d' \
+ -e 's/^.*"\(.*\)".*$/'$filebase'.o: \1/' \
+ -e 's|: \./|: |' \
+ -e 's|\.c\.c|.c|' | \
+ $uniq | $sort | $uniq >> .deptmp
+done
+
+$sed <Makefile >Makefile.new -e '1,/^# AUTOMATICALLY/!d'
+
+make shlist || ($echo "Searching for .SH files..."; \
+ $echo *.SH */*.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 Makefile..."
+ $echo "# If this runs make out of memory, delete /usr/include lines." \
+ >> Makefile.new
+ $sed 's|^\(.*\.o:\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
+ >>Makefile.new
+else
+ make hlist || ($echo "Searching for .h files..."; \
+ $echo *.h */*.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 Makefile..."
+ <.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' >> Makefile.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 >> Makefile.new
+ <.deptmp $sed -n 's|c:#include <\(.*\)>.*$|o: /usr/include/\1|p' \
+ >> Makefile.new
+ <.deptmp $sed -n 's|h:#include "\(.*\)".*$|h: \1|p' | \
+ $sed -f .hsed >> Makefile.new
+ <.deptmp $sed -n 's|h:#include <\(.*\)>.*$|h: /usr/include/\1|p' \
+ >> Makefile.new
+ for file in `$cat .shlist`; do
+ $echo `$expr X$file : 'X\(.*\).SH`: $file config.sh \; \
+ /bin/sh $file >> Makefile.new
+ done
+fi
+$rm -f Makefile.old
+$cp Makefile Makefile.old
+$cp Makefile.new Makefile
+$rm Makefile.new
+$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> Makefile
+$rm -f .deptmp `sed 's/\.c/.c.c/' .clist` .shlist .clist .hlist .hsed
+
+!NO!SUBS!
+$eunicefix makedepend
+chmod 755 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
+ . 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 1.0 87/12/18 13:05:32 root Exp $
+#
+# $Log: makedir.SH,v $
+# Revision 1.0 87/12/18 13:05:32 root
+# Initial revision
+#
+# Revision 4.3.1.1 85/05/10 11:35:14 lwall
+# Branch for patches.
+#
+# Revision 4.3 85/05/01 11:42:31 lwall
+# Baseline for release with 4.3bsd.
+#
+
+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 755 makedir
--- /dev/null
+/* $Header: malloc.c,v 1.0 87/12/18 13:05:35 root Exp $
+ *
+ * $Log: malloc.c,v $
+ * Revision 1.0 87/12/18 13:05:35 root
+ * Initial revision
+ *
+ */
+
+#ifndef lint
+static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83";
+#endif
+#include <stdio.h>
+
+#define RCHECK
+/*
+ * 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 <sys/types.h>
+
+#define NULL 0
+
+/*
+ * 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 */
+ 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 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
+
+char *
+malloc(nbytes)
+ register unsigned nbytes;
+{
+ register union overhead *p;
+ register int bucket = 0;
+ register unsigned shiftr;
+
+ /*
+ * 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)
+ return (NULL);
+ /* remove from linked list */
+ if (*((int*)p) > 0x10000000)
+ fprintf(stderr,"Corrupt malloc ptr 0x%x at 0x%x\n",*((int*)p),p);
+ nextf[bucket] = nextf[bucket]->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 ((char *)(p + 1));
+}
+
+/*
+ * Allocate more memory to the indicated bucket.
+ */
+static
+morecore(bucket)
+ register 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);
+ if ((int)op & 0x3ff)
+ sbrk(1024 - ((int)op & 0x3ff));
+ /* take 2k unless the block is bigger than that */
+ rnu = (bucket <= 8) ? 11 : bucket + 3;
+ 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.
+ */
+ if ((int)op & 7) {
+ op = (union overhead *)(((int)op + 8) &~ 7);
+ nblks--;
+ }
+ /*
+ * Add new memory allocated to that on
+ * free list for this hash bucket.
+ */
+ nextf[bucket] = op;
+ siz = 1 << (bucket + 3);
+ while (--nblks > 0) {
+ op->ov_next = (union overhead *)((caddr_t)op + siz);
+ op = (union overhead *)((caddr_t)op + siz);
+ }
+}
+
+free(cp)
+ char *cp;
+{
+ register int size;
+ register union overhead *op;
+
+ 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)
+ return; /* sanity */
+#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
+ * ``realloc_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 realloc_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */
+
+char *
+realloc(cp, nbytes)
+ char *cp;
+ unsigned nbytes;
+{
+ register u_int onb;
+ union overhead *op;
+ char *res;
+ register int i;
+ int was_alloced = 0;
+
+ 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 ``realloc_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, realloc_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)
+ return(cp);
+ if ((res = malloc(nbytes)) == NULL)
+ return (NULL);
+ if (cp != res) /* common optimization */
+ bcopy(cp, res, (nbytes < onb) ? nbytes : onb);
+ if (was_alloced)
+ free(cp);
+ return (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
--- /dev/null
+#define PATCHLEVEL 0
--- /dev/null
+/* $Header: perl.h,v 1.0 87/12/18 13:05:38 root Exp $
+ *
+ * $Log: perl.h,v $
+ * Revision 1.0 87/12/18 13:05:38 root
+ * Initial revision
+ *
+ */
+
+#define DEBUGGING
+#define STDSTDIO /* eventually should be in config.h */
+
+#define VOIDUSED 1
+#include "config.h"
+
+#ifndef BCOPY
+# define bcopy(s1,s2,l) memcpy(s2,s1,l);
+# define bzero(s,l) memset(s,0,l);
+#endif
+
+#include <stdio.h>
+#include <ctype.h>
+#include <setjmp.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <time.h>
+#include <sys/times.h>
+
+typedef struct arg ARG;
+typedef struct cmd CMD;
+typedef struct formcmd FCMD;
+typedef struct scanpat SPAT;
+typedef struct stab STAB;
+typedef struct stio STIO;
+typedef struct string STR;
+typedef struct atbl ARRAY;
+typedef struct htbl HASH;
+
+#include "str.h"
+#include "form.h"
+#include "stab.h"
+#include "spat.h"
+#include "arg.h"
+#include "cmd.h"
+#include "array.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)
+
+CMD *add_label();
+CMD *block_head();
+CMD *append_line();
+CMD *make_acmd();
+CMD *make_ccmd();
+CMD *invert();
+CMD *addcond();
+CMD *addloop();
+CMD *wopt();
+
+SPAT *stab_to_spat();
+
+STAB *stabent();
+
+ARG *stab_to_arg();
+ARG *op_new();
+ARG *make_op();
+ARG *make_lval();
+ARG *make_match();
+ARG *make_split();
+ARG *flipflip();
+
+STR *arg_to_str();
+STR *str_new();
+STR *stab_str();
+STR *eval();
+
+FCMD *load_format();
+
+char *scanpat();
+char *scansubst();
+char *scantrans();
+char *scanstr();
+char *scanreg();
+char *reg_get();
+char *str_append_till();
+char *str_gets();
+
+bool do_match();
+bool do_open();
+bool do_close();
+bool do_print();
+
+int do_subst();
+
+void str_free();
+void freearg();
+
+EXT int line INIT(0);
+EXT int arybase INIT(0);
+
+struct outrec {
+ int o_lines;
+ char *o_str;
+ int o_len;
+};
+
+EXT struct outrec outrec;
+EXT struct outrec toprec;
+
+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 STR *freestrroot INIT(Nullstr);
+
+EXT FILE *rsfp;
+EXT char buf[1024];
+EXT char *bufptr INIT(buf);
+
+EXT STR *linestr INIT(Nullstr);
+
+EXT char record_separator INIT('\n');
+EXT char *ofs INIT(Nullch);
+EXT char *ors INIT(Nullch);
+EXT char *ofmt INIT(Nullch);
+EXT char *inplace INIT(Nullch);
+
+EXT char tokenbuf[256];
+EXT int expectterm INIT(TRUE);
+EXT int lex_newlines INIT(FALSE);
+
+FILE *popen();
+/* char *str_get(); */
+STR *interp();
+void free_arg();
+STIO *stio_new();
+
+EXT struct stat statbuf;
+EXT struct tms timesbuf;
+
+#ifdef DEBUGGING
+EXT int debug INIT(0);
+EXT int dlevel INIT(0);
+EXT char debname[40];
+EXT char debdelim[40];
+#define YYDEBUG;
+extern int yydebug;
+#endif
+
+EXT STR str_no;
+EXT STR str_yes;
+
+/* runtime control stuff */
+
+EXT struct loop {
+ char *loop_label;
+ jmp_buf loop_env;
+} loop_stack[32];
+
+EXT int loop_ptr INIT(-1);
+
+EXT jmp_buf top_env;
+
+EXT char *goto_targ INIT(Nullch); /* cmd_exec gets strange when set */
+
+double atof();
+long time();
+struct tm *gmtime(), *localtime();
+
+#ifdef CHARSPRINTF
+ char *sprintf();
+#else
+ int sprintf();
+#endif
+
+#ifdef EUNICE
+#define UNLINK(f) while (unlink(f) >= 0)
+#else
+#define UNLINK unlink
+#endif
--- /dev/null
+.rn '' }`
+''' $Header: perl.man.1,v 1.0 87/12/18 16:18:16 root Exp $
+'''
+''' $Log: perl.man.1,v $
+''' Revision 1.0 87/12/18 16:18:16 root
+''' Initial revision
+'''
+'''
+.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 \(bs-|\(bv\*(Tr
+.ie n \{\
+.ds -- \(bs-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\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 LOCAL
+.SH NAME
+perl - Practical Extraction and Report Language
+.SH SYNOPSIS
+.B perl [options] filename args
+.SH DESCRIPTION
+.I Perl
+is a 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.
+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 sed and awk scripts into 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 via standard input.
+.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 won't 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
+ #!/bin/perl -spi.bak # same as -s -p -i.bak
+ .\|.\|.
+
+.fi
+Options include:
+.TP 5
+.B \-D<number>
+sets debugging flags.
+To watch how it executes your script, use
+.B \-D14.
+(This only works if debugging is compiled into your
+.IR perl .)
+.TP 5
+.B \-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
+.B \-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
+ #!/bin/perl -pi.bak
+ s/foo/bar/;
+
+which is equivalent to
+
+.ne 14
+ #!/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 \-i form doesn't need to compare $ARGV to $oldargv to know when
+the filename has changed.
+It does, however, use ARGVOUT for the selected filehandle.
+Note that stdout is restored as the default output filehandle after the loop.
+.TP 5
+.B \-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
+.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.
+.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.
+.TP 5
+.B \-P
+causes your script to be run through the C preprocessor before
+compilation by
+.I 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.
+Any switch found there will set 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 -x switch.
+.nf
+
+.ne 2
+ #!/bin/perl -s
+ if ($x) { print "true\en"; }
+
+.fi
+.Sh "Data Types and Objects"
+.PP
+Perl has about two and a half data types: strings, arrays of strings, and
+associative arrays.
+Strings and arrays of strings are first class objects, for the most part,
+in the sense that they can be used as a whole as values in an expression.
+Associative arrays can only be accessed on an association by association basis;
+they don't have a value as a whole (at least not yet).
+.PP
+Strings are interpreted numerically as appropriate.
+A string 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
+References to string variables always begin with \*(L'$\*(R', even when referring
+to a string that is part of an array.
+Thus:
+.nf
+
+.ne 3
+ $days \h'|2i'# a simple string variable
+ $days[28] \h'|2i'# 29th element of array @days
+ $days{'Feb'}\h'|2i'# one value from an associative array
+
+but entire arrays are denoted by \*(L'@\*(R':
+
+ @days \h'|2i'# ($days[0], $days[1],\|.\|.\|. $days[n])
+
+.fi
+.PP
+Any of these four constructs may be assigned to (in compiler lingo, may serve
+as an lvalue).
+(Additionally, 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.])
+.PP
+Every data type has its own namespace.
+You can, without fear of conflict, use the same name for a string 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'
+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.)
+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".
+(Many one character names have a predefined significance to
+.I perl.
+More later.)
+.PP
+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.
+The usual backslash rules apply for making characters such as newline, tab, etc.
+You can also embed newlines directly in your strings, i.e. they can end on
+a different line than they begin.
+This is nice, but if you forget your trailing quote, the error will not be
+reported until perl finds another line containing the quote character, which
+may be much further on in the script.
+Variable substitution inside strings is limited (currently) to simple string variables.
+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
+.PP
+Array literals are denoted by separating individual values by commas, and
+enclosing the list in parentheses.
+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
+
+ @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.
+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);
+
+.fi
+.PP
+Numeric literals are specified in any of the usual floating point or
+integer formats.
+.PP
+There are several other pseudo-literals that you should know about.
+If a string is enclosed by backticks (grave accents), it is interpreted as
+a command, and the output of that command is the value of the pseudo-literal,
+just like in any of the standard shells.
+The command is executed each time the pseudo-literal is evaluated.
+Unlike in \f2csh\f1, no interpretation is done on the
+data\*(--newlines remain newlines.
+.PP
+Evaluating a filehandle in angle brackets yields the next line
+from that file (newline included, so it's never false until EOF).
+Ordinarily you must assign that value to a variable,
+but there is one situation where in which 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 3
+ while ($_ = <stdin>) {
+ while (<stdin>) {
+ for (\|;\|<stdin>;\|) {
+
+.fi
+The filehandles
+.IR stdin ,
+.I stdout
+and
+.I stderr
+are predefined.
+Additional filehandles may be created with the
+.I open
+function.
+.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.
+.PP
+If you want to set @ARGV to you 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 stdin.
+.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 objects are assumed to start with a null or 0 value.
+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.
+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 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) ? die "Can't open $foo" : 'hi mom';
+
+.fi
+though the last one is a bit exotic.)
+.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 ,
+.I 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 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
+.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 unless
+modifiers also have the expected semantics (conditional evaluated first),
+except when applied to a do-BLOCK 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 loop 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 3
+The null list, used to initialize an array to null.
+.Ip . 8
+Concatenation of two strings.
+.Ip .= 8
+The corresponding 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 =~ 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.
+.nf
+
+ print '-' x 80; # print row of dashes
+ print '-' x80; # illegal, x80 is identifier
+
+ print "\et" x ($tab/8), ' ' x ($tab%8); # tab over
+
+.fi
+.Ip x= 8
+The corresponding assignment operator.
+.Ip .. 8
+The range operator, which is bistable.
+It is false as long as its left argument is false.
+Once the left argument is true, it stays true until the right argument is true,
+AFTER which it becomes false again.
+(It doesn't become false till the next time it's evaluated.
+It can become false on the same evaluation it became true, but it still returns
+true once.)
+The .. 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 argument to .. is static, that argument is implicitly compared to
+the $. variable, the current line number.
+Examples:
+.nf
+
+.ne 5
+ if (101 .. 200) { print; } # print 2nd hundred lines
+
+ next line if (1 .. /^$/); # skip header lines
+
+ s/^/> / if (/^$/ .. eof()); # quote body
+
+.fi
+.PP
+Here is what C has that
+.I perl
+doesn't:
+.Ip "unary &" 12
+Address-of operator.
+.Ip "unary *" 12
+Dereference-address 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
+Along with the literals and variables mentioned earlier,
+the following operations can serve as terms in an expression:
+.Ip "/PATTERN/" 8 4
+Searches a string for a pattern, 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 you prepend an `m' you can use any pair of characters as delimiters.
+This is particularly useful for matching Unix path names that contain `/'.
+.Sp
+Examples:
+.nf
+
+.ne 4
+ open(tty, '/dev/tty');
+ <tty> \|=~ \|/\|^[Yy]\|/ \|&& \|do foo(\|); # do foo if desired
+
+ if (/Version: \|*\|([0-9.]*\|)\|/\|) { $version = $1; }
+
+ next if m#^/usr/spool/uucp#;
+
+.fi
+.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 occurence of
+something in each of a set of files, for instance.
+.Ip "chdir EXPR" 8 2
+Changes the working director to EXPR, if possible.
+Returns 1 upon success, 0 otherwise.
+See example under die().
+.Ip "chmod LIST" 8 2
+Changes the permissions of a list of files.
+The first element of the list must be the numerical mode.
+LIST may be an array, in which case you may wish to use the unshift()
+command to put the mode on the front of the array.
+Returns the number of files successfully changed.
+Note: in order to use the value you must put the whole thing in parentheses.
+.nf
+
+ $cnt = (chmod 0755,'foo','bar');
+
+.fi
+.Ip "chop(VARIABLE)" 8 5
+.Ip "chop" 8
+Chops off the last character of a string and returns it.
+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
+.Ip "chown LIST" 8 2
+Changes the owner (and group) of a list of files.
+LIST may be an array.
+The first two elements of the list must be the NUMERICAL uid and gid, in that order.
+Returns the number of files successfully changed.
+Note: in order to use the value you must put the whole thing in parentheses.
+.nf
+
+ $cnt = (chown $uid,$gid,'foo');
+
+.fi
+Here's an example of looking up non-numeric uids:
+.nf
+
+.ne 16
+ print "User: ";
+ $user = <stdin>;
+ open(pass,'/etc/passwd') || die "Can't open passwd";
+ while (<pass>) {
+ ($login,$pass,$uid,$gid) = split(/:/);
+ $uid{$login} = $uid;
+ $gid{$login} = $gid;
+ }
+ @ary = ('foo','bar','bie','doll');
+ if ($uid{$user} eq '') {
+ die "$user not in passwd file";
+ }
+ else {
+ unshift(@ary,$uid{$user},$gid{$user});
+ chown @ary;
+ }
+
+.fi
+.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.
+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
+.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 "die EXPR" 8 6
+Prints the value of EXPR to stderr and exits with a non-zero status.
+Equivalent examples:
+.nf
+
+.ne 3
+ die "Can't cd to spool." unless chdir '/usr/spool/news';
+
+ (chdir '/usr/spool/news') || die "Can't cd to spool."
+
+.fi
+Note that the parens are necessary above due to precedence.
+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.
+(See the section on subroutines later on.)
+.Ip "each(ASSOC_ARRAY)" 8 6
+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.
+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
+Returns 1 if the next read on FILEHANDLE will return end of file, or if
+FILEHANDLE is not open.
+If (FILEHANDLE) is omitted, the eof status is returned for the last file read.
+The null filehandle 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.
+Example:
+.nf
+
+.ne 7
+ # insert dashes just before last line
+ while (<>) {
+ if (eof()) {
+ print "--------------\en";
+ }
+ print;
+ }
+
+.fi
+.Ip "exec LIST" 8 6
+If there is more than one argument in LIST,
+calls execvp() with the arguments in LIST.
+If there is only one argument, the argument is checked for shell metacharacters.
+If there are any, the entire argument is passed to /bin/sh -c for parsing.
+If there are none, the argument is split into words and passed directly to
+execvp(), which is more efficient.
+Note: exec (and system) do not flush your output buffer, so you may need to
+set $| to avoid lost output.
+.Ip "exit EXPR" 8 6
+Evaluates EXPR and exits immediately with that value.
+Example:
+.nf
+
+.ne 2
+ $ans = <stdin>;
+ exit 0 \|if \|$ans \|=~ \|/\|^[Xx]\|/\|;
+
+.fi
+See also
+.IR die .
+.Ip "exp(EXPR)" 8 3
+Returns e to the power of EXPR.
+.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 "gmtime(EXPR)" 8 4
+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
+ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
+ = gmtime(time);
+
+.fi
+All array elements are numeric.
+''' End of part 1
--- /dev/null
+''' Beginning of part 2
+''' $Header: perl.man.2,v 1.0 87/12/18 16:18:41 root Exp $
+'''
+''' $Log: perl.man.2,v $
+''' Revision 1.0 87/12/18 16:18:41 root
+''' Initial revision
+'''
+'''
+.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 sed-to-perl translator easier.
+Use at your own risk.
+.Ip "hex(EXPR)" 8 2
+Returns the decimal value of EXPR interpreted as an hex string.
+(To interpret strings that might start with 0 or 0x see oct().)
+.Ip "index(STR,SUBSTR)" 8 4
+Returns the position of SUBSTR in STR, 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 3
+Returns the integer portion of EXPR.
+.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
+
+ $_ = join(\|':', $login,$passwd,$uid,$gid,$gcos,$home,$shell);
+
+.fi
+See
+.IR split .
+.Ip "keys(ASSOC_ARRAY)" 8 6
+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),"\n";
+ }
+
+.fi
+.Ip "kill LIST" 8 2
+Sends a signal to a list of processes.
+The first element of the list must be the (numerical) signal to send.
+LIST may be an array, in which case you may wish to use the unshift
+command to put the signal on the front of the array.
+Returns the number of processes successfully signaled.
+Note: in order to use the value you must put the whole thing in parentheses:
+.nf
+
+ $cnt = (kill 9,$child1,$child2);
+
+.fi
+.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 "localtime(EXPR)" 8 4
+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
+ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
+ = localtime(time);
+
+.fi
+All array elements are numeric.
+.Ip "log(EXPR)" 8 3
+Returns logarithm (base e) of EXPR.
+.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 "length(EXPR)" 8 2
+Returns the length in characters of the value of EXPR.
+.Ip "link(OLDFILE,NEWFILE)" 8 2
+Creates a new filename linked to the old filename.
+Returns 1 for success, 0 otherwise.
+.Ip "oct(EXPR)" 8 2
+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
+.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 EXPR is omitted, the string variable of the same name as the FILEHANDLE
+contains the filename.
+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.
+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.)
+On non-pipe opens, the filename '\-' represents either stdin or stdout, as
+appropriate.
+Open returns 1 upon success, '' otherwise.
+Examples:
+.nf
+
+.ne 3
+ $article = 100;
+ open article || die "Can't find article $article";
+ while (<article>) {\|.\|.\|.
+
+ open(log, '>>/usr/spool/news/twitlog'\|);
+
+ open(article, "caeser <$article |"\|); # decrypt article
+
+ open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process#
+
+.fi
+.Ip "ord(EXPR)" 8 3
+Returns the ascii value of the first character of EXPR.
+.Ip "pop ARRAY" 8 6
+.Ip "pop(ARRAY)" 8
+Pops and returns the last value of the array, shortening the array by 1.
+''' $tmp = $ARRAY[$#ARRAY--]
+.Ip "print FILEHANDLE LIST" 8 9
+.Ip "print LIST" 8
+.Ip "print" 8
+Prints a string or comma-separated list of strings.
+If FILEHANDLE is omitted, prints by default to standard output (or to the
+last selected output channel\*(--see select()).
+If LIST is also omitted, prints $_ to stdout.
+LIST may also be an array value.
+To set the default output channel to something other than stdout use the select operation.
+.Ip "printf FILEHANDLE LIST" 8 9
+.Ip "printf LIST" 8
+Equivalent to a "print FILEHANDLE sprintf(LIST)".
+.Ip "push(ARRAY,EXPR)" 8 7
+Treats ARRAY (@ is optional) as a stack, and pushes the value of EXPR
+onto the end of ARRAY.
+The length of ARRAY increases by 1.
+Has the same effect as
+.nf
+
+ $ARRAY[$#ARRAY+1] = EXPR;
+
+.fi
+but is more efficient.
+.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.
+.Ip "reset EXPR" 8 3
+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 string variables beginning with one of those letters are set to the null
+string.
+If the expression is omitted, one-match searches (?pattern?) are reset to
+match again.
+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
+.Ip "s/PATTERN/REPLACEMENT/g" 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 occurences
+of the pattern are to be replaced.
+Any delimiter may replace the slashes; if single quotes are used, no
+interpretation is done on the replacement string.
+If no string is specified via the =~ or !~ operator,
+the $_ string is searched and modified.
+(The string specified with =~ must be a string variable or array element,
+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.
+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
+
+ 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 "seek(FILEHANDLE,POSITION,WHENCE)" 8 3
+Randomly positions the file pointer for FILEHANDLE, just like the fseek()
+call of stdio.
+Returns 1 upon success, 0 otherwise.
+.Ip "select(FILEHANDLE)" 8 3
+Sets the current default filehandle for output.
+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
+Select happens to return TRUE if the file is currently open and FALSE otherwise,
+but this has no effect on its operation.
+.Ip "shift(ARRAY)" 8 6
+.Ip "shift ARRAY" 8
+.Ip "shift" 8
+Shifts the first value of the array off, shortening the array by 1 and
+moving everything down.
+If ARRAY is omitted, shifts the ARGV array.
+See also unshift().
+.Ip "sleep EXPR" 8 6
+.Ip "sleep" 8
+Causes the script to sleep for EXPR seconds, or forever if no EXPR.
+May be interrupted by sending the process a SIGALARM.
+Returns the number of seconds actually slept.
+.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 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.)
+Trailing null fields are stripped, which potential users of pop() would
+do well to remember.
+A pattern matching the null string will split into separate characters.
+.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 3
+Return the square root of EXPR.
+.Ip "stat(FILEHANDLE)" 8 6
+.Ip "stat(EXPR)" 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
+.Ip "substr(EXPR,OFFSET,LEN)" 8 2
+Extracts a substring out of EXPR and returns it.
+First character is at offset 0, or whatever you've set $[ to.
+.Ip "system LIST" 8 6
+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.
+See exec.
+.Ip "tell(FILEHANDLE)" 8 6
+.Ip "tell" 8
+Returns the current file position for FILEHANDLE.
+If FILEHANDLE is omitted, assumes the file last read.
+.Ip "time" 8 4
+Returns the number of seconds since 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/" 8 5
+.Ip "y/SEARCHLIST/REPLACEMENTLIST/" 8
+Translates all occurences of the characters found in the search list with
+the corresponding character in the replacement list.
+It returns the number of characters replaced.
+If no string is specified via the =~ or !~ operator,
+the $_ string is translated.
+(The string specified with =~ must be a string variable or array element,
+i.e. an lvalue.)
+For
+.I sed
+devotees,
+.I y
+is provided as a synonym for
+.IR tr .
+Examples:
+.nf
+
+ $ARGV[1] \|=~ \|y/A-Z/a-z/; \h'|3i'# canonicalize to lower case
+
+ $cnt = tr/*/*/; \h'|3i'# count the stars in $_
+
+.fi
+.Ip "umask(EXPR)" 8 3
+Sets the umask for the process and returns the old one.
+.Ip "unlink LIST" 8 2
+Deletes a list of files.
+LIST may be an array.
+Returns the number of files successfully deleted.
+Note: in order to use the value you must put the whole thing in parentheses:
+.nf
+
+ $cnt = (unlink 'a','b','c');
+
+.fi
+.Ip "unshift(ARRAY,LIST)" 8 4
+Does the opposite of a shift.
+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 "values(ASSOC_ARRAY)" 8 6
+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 produces (given that the associative array
+has not been modified).
+See also keys() and each().
+.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, 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 \*(L"top\*(R", but it
+may be set to the
+format of your choice by assigning the name to the $^ variable.
+.sp
+If FILEHANDLE is unspecified, output goes to the current default output channel,
+which starts out as 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.
+.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 return value of the subroutine is the value of the last expression
+evaluated.
+There are no local variables\*(--everything is a global variable.
+.PP
+A subroutine is called using the
+.I do
+operator.
+(CAVEAT: For efficiency reasons recursive subroutine calls are not currently
+supported.
+This restriction may go away in the future. Then again, it may not.)
+.nf
+
+.ne 12
+Example:
+
+ sub MAX {
+ $max = pop(@_);
+ while ($foo = pop(@_)) {
+ $max = $foo \|if \|$max < $foo;
+ }
+ $max;
+ }
+
+ .\|.\|.
+ $bestday = do 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 ($_ = get_line(\|)) {
+ .\|.\|.
+ }
+
+.fi
+.nf
+.ne 6
+Use array assignment to name your formal arguments:
+
+ sub maybeset {
+ ($key,$value) = @_;
+ $foo{$key} = $value unless $foo{$key};
+ }
+
+.fi
+.Sh "Regular Expressions"
+The patterns used in pattern matching are regular expressions such as
+those used by
+.IR egrep (1).
+In addition, \ew matches an alphanumeric character and \eW a nonalphanumeric.
+Word boundaries may be matched by \eb, and non-boundaries by \eB.
+The bracketing construct \|(\ .\|.\|.\ \|) may also be used, $<digit>
+matches the digit'th substring, where digit can range from 1 to 9.
+(You can also use the old standby \e<digit> in search patterns,
+but $<digit> also works in replacement patterns and in the block controlled
+by the current conditional.)
+$+ returns whatever the last bracket match matched.
+$& returns the entire matched string.
+Up to 10 alternatives may given in a pattern, separated by |, with the
+caveat that \|(\ .\|.\|.\ |\ .\|.\|.\ \|) is illegal.
+Examples:
+.nf
+
+ s/\|^\|([^ \|]*\|) \|*([^ \|]*\|)\|/\|$2 $1\|/; # swap first two words
+
+.ne 5
+ if (/\|Time: \|(.\|.\|):\|(.\|.\|):\|(.\|.\|)\|/\|) {
+ $hours = $1;
+ $minutes = $2;
+ $seconds = $3;
+ }
+
+.fi
+By default, the ^ character matches only the beginning of the string, and
+.I perl
+does certain optimizations with the assumption that the string contains
+only one line.
+You may, however, wish to treat a string as a multi-line buffer, such that
+the ^ will match after any newline within the string.
+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.
+.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 justfication,
+right justification, or centering.
+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.
+They must currently be either string variable names or string literals (or
+pseudo-literals).
+Currently you can separate values with spaces, but commas may be placed
+between values to prepare for possible future versions in which full expressions
+are allowed as values.
+.PP
+Picture fields that begin with ^ rather than @ are treated specially.
+The value supplied must be a string 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 string 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.
+.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.)
+The tilde will be translated to a space upon output.
+.PP
+Examples:
+.nf
+.lg 0
+.cs R 25
+
+.ne 10
+# a report on the /etc/passwd file
+format 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 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
+\&.
+
+.cs R
+.lg
+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.
+.fi
+.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 "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 "a-zA-Z" 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 file that was read.
+Readonly.
+(Mnemonic: many programs use . to mean the current line number.)
+.Ip $/ 8
+The input record separator, newline by default.
+Works like awk's RS variable, including treating blank lines as delimiters
+if set to the null string.
+If set to a value longer than one character, only the first character is used.
+(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 awk, set this variable as you would set
+awk's OFS variable to specify what is printed between fields.
+(Mnemonic: what is printed when there is a , in your print statement.)
+.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 awk, set this variable as you would set
+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 perl.)
+.Ip $# 8
+The output format for printed numbers.
+This variable is a half-hearted attempt to emulate awk's OFMT variable.
+There are times, however, when awk and perl have differing notions of what
+is in fact numeric.
+Also, the initial value is %.20g rather than %.6g, so you need to set $#
+explicitly to get 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.
+(Mnemonic: brother to $^.)
+.Ip $^ 8
+The name of the current top-of-page format for the currently selected output
+channel.
+(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 stdout will typically be line buffered if output is to the
+terminal and block buffered otherwise.
+Setting this variable is useful primarily when you are outputting to a pipe,
+such as when you are running a perl script under rsh and want to see the
+output as it's happening.
+(Mnemonic: when you want your pipes to be piping hot.)
+.Ip $$ 8
+The process number of the
+.I perl
+running this script.
+(Mnemonic: same as shells.)
+.Ip $? 8
+The status returned by the last backtick (``) command.
+(Mnemonic: same as sh and ksh.)
+.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 assume strings contain
+a single line.
+Default is 0.
+(Mnemonic: * matches multiple things.)
+.Ip $0 8
+Contains the name of the file containing the
+.I perl
+script being executed.
+The value should be copied elsewhere before any pattern matching happens, which
+clobbers $0.
+(Mnemonic: same as sh and ksh.)
+.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 current value of errno, with all the usual caveats.
+(Mnemonic: What just went bang?)
+.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 $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
+ ($sig) = @_;
+ print "Caught a SIG$sig--shutting down\n";
+ close(log);
+ exit(0);
+ }
+
+ $SIG{'INT'} = 'handler';
+ $SIG{'QUIT'} = 'handler';
+ ...
+ $SIG{'INT'} = 'DEFAULT'; # restore default action
+ $SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT
+
+.fi
+.SH ENVIRONMENT
+.I Perl
+currently 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'};
+ $ENV{'IFS'} = '' if $ENV{'IFS'};
+
+.fi
+.SH AUTHOR
+Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
+.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.)
+.SH TRAPS
+Accustomed awk users should take special note of the following:
+.Ip * 4 2
+Semicolons are required after all simple statements in 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 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
+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 split 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 initially the name of the program executed, then the last matched
+string.)
+.Ip * 4 2
+The current filename is $ARGV, not $FILENAME.
+NR, RS, ORS, OFS, and OFMT have equivalents with other symbols.
+FS doesn't have an equivalent, since you have to be explicit about
+split statements.
+.Ip * 4 2
+$<digit> does not refer to fields--it refers to substrings matched by the last
+match pattern.
+.Ip * 4 2
+The 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.)
+.Ip * 4 2
+The concatenation operator is \*(L".\*(R", not the null string.
+(Using the null string would render \*(L"/pat/ /pat/\*(R" unparseable,
+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
+The \ennn construct in patterns must be given as [\ennn] to avoid interpretation
+as a backreference.
+.Ip * 4 2
+Next, exit, and continue work differently.
+.Ip * 4 2
+When in doubt, run the 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
+Break and continue become last and next, respectively.
+.Ip * 4 2
+There's no switch statement.
+.Ip * 4 2
+Variables begin with $ or @ in 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
+Subroutines are not reentrant.
+.Ip * 4 2
+ARGV must be capitalized.
+.Ip * 4 2
+The \*(L"system\*(R" calls link, unlink, rename, etc. return 1 for success, not 0.
+.Ip * 4 2
+Signal handlers deal with signal names, not numbers.
+.PP
+Seasoned 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.
+.SH BUGS
+.PP
+You can't currently dereference array elements inside a double-quoted string.
+You must assign them to a temporary and interpolate that.
+.PP
+Associative arrays really ought to be first class objects.
+.PP
+Recursive subroutines are not currently supported, due to the way temporary
+values are stored in the syntax tree.
+.PP
+Arrays ought to be passable to subroutines just as strings are.
+.PP
+The array literal consisting of one element is currently misinterpreted, i.e.
+.nf
+
+ @array = (123);
+
+.fi
+doesn't work right.
+.PP
+.I Perl
+actually stands for Pathologically Eclectic Rubbish Lister, but don't tell
+anyone I said that.
+.rn }` ''
--- /dev/null
+/* $Header: perl.y,v 1.0 87/12/18 15:48:59 root Exp $
+ *
+ * $Log: perl.y,v $
+ * Revision 1.0 87/12/18 15:48:59 root
+ * Initial revision
+ *
+ */
+
+%{
+#include "handy.h"
+#include "EXTERN.h"
+#include "search.h"
+#include "util.h"
+#include "INTERN.h"
+#include "perl.h"
+char *tokename[] = {
+"256",
+"word",
+"append","open","write","select","close","loopctl",
+"using","format","do","shift","push","pop","chop",
+"while","until","if","unless","else","elsif","continue","split","sprintf",
+"for", "eof", "tell", "seek", "stat",
+"function(no args)","function(1 arg)","function(2 args)","function(3 args)","array function",
+"join", "sub",
+"format lines",
+"register","array_length", "array",
+"s","pattern",
+"string","y",
+"print", "unary operation",
+"..",
+"||",
+"&&",
+"==","!=", "EQ", "NE",
+"<=",">=", "LT", "GT", "LE", "GE",
+"<<",">>",
+"=~","!~",
+"unary -",
+"++", "--",
+"???"
+};
+
+%}
+
+%start prog
+
+%union {
+ int ival;
+ char *cval;
+ ARG *arg;
+ CMD *cmdval;
+ struct compcmd compval;
+ STAB *stabval;
+ FCMD *formval;
+}
+
+%token <cval> WORD
+%token <ival> APPEND OPEN WRITE SELECT CLOSE LOOPEX
+%token <ival> USING FORMAT DO SHIFT PUSH POP CHOP
+%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT SPRINTF
+%token <ival> FOR FEOF TELL SEEK STAT
+%token <ival> FUNC0 FUNC1 FUNC2 FUNC3 STABFUN
+%token <ival> JOIN SUB
+%token <formval> FORMLIST
+%token <stabval> REG ARYLEN ARY
+%token <arg> SUBST PATTERN
+%token <arg> RSTRING TRANS
+
+%type <ival> prog decl format
+%type <stabval>
+%type <cmdval> block lineseq line loop cond sideff nexpr else
+%type <arg> expr sexpr term
+%type <arg> condmod loopmod cexpr
+%type <arg> texpr print
+%type <cval> label
+%type <compval> compblock
+
+%nonassoc <ival> PRINT
+%left ','
+%nonassoc <ival> UNIOP
+%right '='
+%right '?' ':'
+%nonassoc DOTDOT
+%left OROR
+%left ANDAND
+%left '|' '^'
+%left '&'
+%nonassoc EQ NE SEQ SNE
+%nonassoc '<' '>' LE GE SLT SGT SLE SGE
+%left LS RS
+%left '+' '-' '.'
+%left '*' '/' '%' 'x'
+%left MATCH NMATCH
+%right '!' '~' UMINUS
+%nonassoc INC DEC
+%left '('
+
+%% /* RULES */
+
+prog : lineseq
+ { main_root = block_head($1); }
+ ;
+
+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
+ { $$ = make_ccmd(C_IF,$3,$5); }
+ ;
+
+block : '{' lineseq '}'
+ { $$ = block_head($2); }
+ ;
+
+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(make_acmd(C_EXPR, Nullstab,
+ Nullarg, Nullarg) );
+ } else
+ $$ = Nullcmd; }
+ | label sideff ';'
+ { $$ = add_label($1,$2); }
+ ;
+
+sideff : expr
+ { $$ = make_acmd(C_EXPR, Nullstab, $1, Nullarg); }
+ | expr condmod
+ { $$ = addcond(
+ make_acmd(C_EXPR, Nullstab, Nullarg, $1), $2); }
+ | expr loopmod
+ { $$ = addloop(
+ make_acmd(C_EXPR, Nullstab, Nullarg, $1), $2); }
+ ;
+
+cond : IF '(' expr ')' compblock
+ { $$ = make_ccmd(C_IF,$3,$5); }
+ | UNLESS '(' expr ')' compblock
+ { $$ = invert(make_ccmd(C_IF,$3,$5)); }
+ | IF block compblock
+ { $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); }
+ | UNLESS block compblock
+ { $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); }
+ ;
+
+loop : label WHILE '(' texpr ')' compblock
+ { $$ = wopt(add_label($1,
+ make_ccmd(C_WHILE,$4,$6) )); }
+ | label UNTIL '(' expr ')' compblock
+ { $$ = wopt(add_label($1,
+ invert(make_ccmd(C_WHILE,$4,$6)) )); }
+ | label WHILE block compblock
+ { $$ = wopt(add_label($1,
+ make_ccmd(C_WHILE, cmd_to_arg($3),$4) )); }
+ | label UNTIL block compblock
+ { $$ = wopt(add_label($1,
+ invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); }
+ | label FOR '(' nexpr ';' texpr ';' nexpr ')' block
+ /* basically fake up an initialize-while lineseq */
+ { yyval.compval.comp_true = $10;
+ yyval.compval.comp_alt = $8;
+ $$ = 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 */
+ { scanstr("1"); $$ = yylval.arg; }
+ | expr
+ ;
+
+label : /* empty */
+ { $$ = Nullch; }
+ | WORD ':'
+ ;
+
+loopmod : WHILE expr
+ { $$ = $2; }
+ | UNTIL expr
+ { $$ = make_op(O_NOT,1,$2,Nullarg,Nullarg,0); }
+ ;
+
+condmod : IF expr
+ { $$ = $2; }
+ | UNLESS expr
+ { $$ = make_op(O_NOT,1,$2,Nullarg,Nullarg,0); }
+ ;
+
+decl : format
+ { $$ = 0; }
+ | subrout
+ { $$ = 0; }
+ ;
+
+format : FORMAT WORD '=' FORMLIST '.'
+ { stabent($2,TRUE)->stab_form = $4; safefree($2); }
+ | FORMAT '=' FORMLIST '.'
+ { stabent("stdout",TRUE)->stab_form = $3; }
+ ;
+
+subrout : SUB WORD block
+ { stabent($2,TRUE)->stab_sub = $3; }
+ ;
+
+expr : print
+ | cexpr
+ ;
+
+cexpr : sexpr ',' cexpr
+ { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg,0); }
+ | sexpr
+ ;
+
+sexpr : sexpr '=' sexpr
+ { $1 = listish($1);
+ if ($1->arg_type == O_LIST)
+ $3 = listish($3);
+ $$ = l(make_op(O_ASSIGN, 2, $1, $3, Nullarg,1)); }
+ | sexpr '*' '=' sexpr
+ { $$ = l(make_op(O_MULTIPLY, 2, $1, $4, Nullarg,0)); }
+ | sexpr '/' '=' sexpr
+ { $$ = l(make_op(O_DIVIDE, 2, $1, $4, Nullarg,0)); }
+ | sexpr '%' '=' sexpr
+ { $$ = l(make_op(O_MODULO, 2, $1, $4, Nullarg,0)); }
+ | sexpr 'x' '=' sexpr
+ { $$ = l(make_op(O_REPEAT, 2, $1, $4, Nullarg,0)); }
+ | sexpr '+' '=' sexpr
+ { $$ = l(make_op(O_ADD, 2, $1, $4, Nullarg,0)); }
+ | sexpr '-' '=' sexpr
+ { $$ = l(make_op(O_SUBTRACT, 2, $1, $4, Nullarg,0)); }
+ | sexpr LS '=' sexpr
+ { $$ = l(make_op(O_LEFT_SHIFT, 2, $1, $4, Nullarg,0)); }
+ | sexpr RS '=' sexpr
+ { $$ = l(make_op(O_RIGHT_SHIFT, 2, $1, $4, Nullarg,0)); }
+ | sexpr '&' '=' sexpr
+ { $$ = l(make_op(O_BIT_AND, 2, $1, $4, Nullarg,0)); }
+ | sexpr '^' '=' sexpr
+ { $$ = l(make_op(O_XOR, 2, $1, $4, Nullarg,0)); }
+ | sexpr '|' '=' sexpr
+ { $$ = l(make_op(O_BIT_OR, 2, $1, $4, Nullarg,0)); }
+ | sexpr '.' '=' sexpr
+ { $$ = l(make_op(O_CONCAT, 2, $1, $4, Nullarg,0)); }
+
+
+ | sexpr '*' sexpr
+ { $$ = make_op(O_MULTIPLY, 2, $1, $3, Nullarg,0); }
+ | sexpr '/' sexpr
+ { $$ = make_op(O_DIVIDE, 2, $1, $3, Nullarg,0); }
+ | sexpr '%' sexpr
+ { $$ = make_op(O_MODULO, 2, $1, $3, Nullarg,0); }
+ | sexpr 'x' sexpr
+ { $$ = make_op(O_REPEAT, 2, $1, $3, Nullarg,0); }
+ | sexpr '+' sexpr
+ { $$ = make_op(O_ADD, 2, $1, $3, Nullarg,0); }
+ | sexpr '-' sexpr
+ { $$ = make_op(O_SUBTRACT, 2, $1, $3, Nullarg,0); }
+ | sexpr LS sexpr
+ { $$ = make_op(O_LEFT_SHIFT, 2, $1, $3, Nullarg,0); }
+ | sexpr RS sexpr
+ { $$ = make_op(O_RIGHT_SHIFT, 2, $1, $3, Nullarg,0); }
+ | sexpr '<' sexpr
+ { $$ = make_op(O_LT, 2, $1, $3, Nullarg,0); }
+ | sexpr '>' sexpr
+ { $$ = make_op(O_GT, 2, $1, $3, Nullarg,0); }
+ | sexpr LE sexpr
+ { $$ = make_op(O_LE, 2, $1, $3, Nullarg,0); }
+ | sexpr GE sexpr
+ { $$ = make_op(O_GE, 2, $1, $3, Nullarg,0); }
+ | sexpr EQ sexpr
+ { $$ = make_op(O_EQ, 2, $1, $3, Nullarg,0); }
+ | sexpr NE sexpr
+ { $$ = make_op(O_NE, 2, $1, $3, Nullarg,0); }
+ | sexpr SLT sexpr
+ { $$ = make_op(O_SLT, 2, $1, $3, Nullarg,0); }
+ | sexpr SGT sexpr
+ { $$ = make_op(O_SGT, 2, $1, $3, Nullarg,0); }
+ | sexpr SLE sexpr
+ { $$ = make_op(O_SLE, 2, $1, $3, Nullarg,0); }
+ | sexpr SGE sexpr
+ { $$ = make_op(O_SGE, 2, $1, $3, Nullarg,0); }
+ | sexpr SEQ sexpr
+ { $$ = make_op(O_SEQ, 2, $1, $3, Nullarg,0); }
+ | sexpr SNE sexpr
+ { $$ = make_op(O_SNE, 2, $1, $3, Nullarg,0); }
+ | sexpr '&' sexpr
+ { $$ = make_op(O_BIT_AND, 2, $1, $3, Nullarg,0); }
+ | sexpr '^' sexpr
+ { $$ = make_op(O_XOR, 2, $1, $3, Nullarg,0); }
+ | sexpr '|' sexpr
+ { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg,0); }
+ | sexpr DOTDOT sexpr
+ { $$ = make_op(O_FLIP, 4,
+ flipflip($1),
+ flipflip($3),
+ Nullarg,0);}
+ | sexpr ANDAND sexpr
+ { $$ = make_op(O_AND, 2, $1, $3, Nullarg,0); }
+ | sexpr OROR sexpr
+ { $$ = make_op(O_OR, 2, $1, $3, Nullarg,0); }
+ | sexpr '?' sexpr ':' sexpr
+ { $$ = make_op(O_COND_EXPR, 3, $1, $3, $5,0); }
+ | sexpr '.' sexpr
+ { $$ = make_op(O_CONCAT, 2, $1, $3, Nullarg,0); }
+ | sexpr MATCH sexpr
+ { $$ = mod_match(O_MATCH, $1, $3); }
+ | sexpr NMATCH sexpr
+ { $$ = mod_match(O_NMATCH, $1, $3); }
+ | term INC
+ { $$ = addflags(1, AF_POST|AF_UP,
+ l(make_op(O_ITEM,1,$1,Nullarg,Nullarg,0))); }
+ | term DEC
+ { $$ = addflags(1, AF_POST,
+ l(make_op(O_ITEM,1,$1,Nullarg,Nullarg,0))); }
+ | INC term
+ { $$ = addflags(1, AF_PRE|AF_UP,
+ l(make_op(O_ITEM,1,$2,Nullarg,Nullarg,0))); }
+ | DEC term
+ { $$ = addflags(1, AF_PRE,
+ l(make_op(O_ITEM,1,$2,Nullarg,Nullarg,0))); }
+ | term
+ { $$ = $1; }
+ ;
+
+term : '-' term %prec UMINUS
+ { $$ = make_op(O_NEGATE, 1, $2, Nullarg, Nullarg,0); }
+ | '!' term
+ { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg,0); }
+ | '~' term
+ { $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg,0);}
+ | '(' expr ')'
+ { $$ = make_list(hide_ary($2)); }
+ | '(' ')'
+ { $$ = make_list(Nullarg); }
+ | DO block %prec '('
+ { $$ = cmd_to_arg($2); }
+ | REG %prec '('
+ { $$ = stab_to_arg(A_STAB,$1); }
+ | REG '[' expr ']' %prec '('
+ { $$ = make_op(O_ARRAY, 2,
+ $3, stab_to_arg(A_STAB,aadd($1)), Nullarg,0); }
+ | ARY %prec '('
+ { $$ = make_op(O_ARRAY, 1,
+ stab_to_arg(A_STAB,$1),
+ Nullarg, Nullarg, 1); }
+ | REG '{' expr '}' %prec '('
+ { $$ = make_op(O_HASH, 2,
+ $3, stab_to_arg(A_STAB,hadd($1)), Nullarg,0); }
+ | ARYLEN %prec '('
+ { $$ = stab_to_arg(A_ARYLEN,$1); }
+ | RSTRING %prec '('
+ { $$ = $1; }
+ | PATTERN %prec '('
+ { $$ = $1; }
+ | SUBST %prec '('
+ { $$ = $1; }
+ | TRANS %prec '('
+ { $$ = $1; }
+ | DO WORD '(' expr ')'
+ { $$ = make_op(O_SUBR, 2,
+ make_list($4),
+ stab_to_arg(A_STAB,stabent($2,TRUE)),
+ Nullarg,1); }
+ | DO WORD '(' ')'
+ { $$ = make_op(O_SUBR, 2,
+ make_list(Nullarg),
+ stab_to_arg(A_STAB,stabent($2,TRUE)),
+ Nullarg,1); }
+ | LOOPEX
+ { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg,0); }
+ | LOOPEX WORD
+ { $$ = make_op($1,1,cval_to_arg($2),
+ Nullarg,Nullarg,0); }
+ | UNIOP
+ { $$ = make_op($1,1,Nullarg,Nullarg,Nullarg,0); }
+ | UNIOP sexpr
+ { $$ = make_op($1,1,$2,Nullarg,Nullarg,0); }
+ | WRITE
+ { $$ = make_op(O_WRITE, 0,
+ Nullarg, Nullarg, Nullarg,0); }
+ | WRITE '(' ')'
+ { $$ = make_op(O_WRITE, 0,
+ Nullarg, Nullarg, Nullarg,0); }
+ | WRITE '(' WORD ')'
+ { $$ = l(make_op(O_WRITE, 1,
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ Nullarg, Nullarg,0)); safefree($3); }
+ | WRITE '(' expr ')'
+ { $$ = make_op(O_WRITE, 1, $3, Nullarg, Nullarg,0); }
+ | SELECT '(' WORD ')'
+ { $$ = l(make_op(O_SELECT, 1,
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ Nullarg, Nullarg,0)); safefree($3); }
+ | SELECT '(' expr ')'
+ { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg,0); }
+ | OPEN WORD %prec '('
+ { $$ = make_op(O_OPEN, 2,
+ stab_to_arg(A_STAB,stabent($2,TRUE)),
+ stab_to_arg(A_STAB,stabent($2,TRUE)),
+ Nullarg,0); }
+ | OPEN '(' WORD ')'
+ { $$ = make_op(O_OPEN, 2,
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ Nullarg,0); }
+ | OPEN '(' WORD ',' expr ')'
+ { $$ = make_op(O_OPEN, 2,
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ $5, Nullarg,0); }
+ | CLOSE '(' WORD ')'
+ { $$ = make_op(O_CLOSE, 1,
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ Nullarg, Nullarg,0); }
+ | CLOSE WORD %prec '('
+ { $$ = make_op(O_CLOSE, 1,
+ stab_to_arg(A_STAB,stabent($2,TRUE)),
+ Nullarg, Nullarg,0); }
+ | FEOF '(' WORD ')'
+ { $$ = make_op(O_EOF, 1,
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ Nullarg, Nullarg,0); }
+ | FEOF '(' ')'
+ { $$ = make_op(O_EOF, 0,
+ stab_to_arg(A_STAB,stabent("ARGV",TRUE)),
+ Nullarg, Nullarg,0); }
+ | FEOF
+ { $$ = make_op(O_EOF, 0,
+ Nullarg, Nullarg, Nullarg,0); }
+ | TELL '(' WORD ')'
+ { $$ = make_op(O_TELL, 1,
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ Nullarg, Nullarg,0); }
+ | TELL
+ { $$ = make_op(O_TELL, 0,
+ Nullarg, Nullarg, Nullarg,0); }
+ | SEEK '(' WORD ',' sexpr ',' expr ')'
+ { $$ = make_op(O_SEEK, 3,
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ $5, $7,1); }
+ | PUSH '(' WORD ',' expr ')'
+ { $$ = make_op($1, 2,
+ make_list($5),
+ stab_to_arg(A_STAB,aadd(stabent($3,TRUE))),
+ Nullarg,1); }
+ | PUSH '(' ARY ',' expr ')'
+ { $$ = make_op($1, 2,
+ make_list($5),
+ stab_to_arg(A_STAB,$3),
+ Nullarg,1); }
+ | POP WORD %prec '('
+ { $$ = make_op(O_POP, 1,
+ stab_to_arg(A_STAB,aadd(stabent($2,TRUE))),
+ Nullarg, Nullarg,0); }
+ | POP '(' WORD ')'
+ { $$ = make_op(O_POP, 1,
+ stab_to_arg(A_STAB,aadd(stabent($3,TRUE))),
+ Nullarg, Nullarg,0); }
+ | POP ARY %prec '('
+ { $$ = make_op(O_POP, 1,
+ stab_to_arg(A_STAB,$2),
+ Nullarg,
+ Nullarg,
+ 0); }
+ | POP '(' ARY ')'
+ { $$ = make_op(O_POP, 1,
+ stab_to_arg(A_STAB,$3),
+ Nullarg,
+ Nullarg,
+ 0); }
+ | SHIFT WORD %prec '('
+ { $$ = make_op(O_SHIFT, 1,
+ stab_to_arg(A_STAB,aadd(stabent($2,TRUE))),
+ Nullarg, Nullarg,0); }
+ | SHIFT '(' WORD ')'
+ { $$ = make_op(O_SHIFT, 1,
+ stab_to_arg(A_STAB,aadd(stabent($3,TRUE))),
+ Nullarg, Nullarg,0); }
+ | SHIFT ARY %prec '('
+ { $$ = make_op(O_SHIFT, 1,
+ stab_to_arg(A_STAB,$2), Nullarg, Nullarg,0); }
+ | SHIFT '(' ARY ')'
+ { $$ = make_op(O_SHIFT, 1,
+ stab_to_arg(A_STAB,$3), Nullarg, Nullarg,0); }
+ | SHIFT %prec '('
+ { $$ = make_op(O_SHIFT, 1,
+ stab_to_arg(A_STAB,aadd(stabent("ARGV",TRUE))),
+ Nullarg, Nullarg,0); }
+ | SPLIT %prec '('
+ { scanpat("/[ \t\n]+/");
+ $$ = make_split(defstab,yylval.arg); }
+ | SPLIT '(' WORD ')'
+ { scanpat("/[ \t\n]+/");
+ $$ = make_split(stabent($3,TRUE),yylval.arg); }
+ | SPLIT '(' WORD ',' PATTERN ')'
+ { $$ = make_split(stabent($3,TRUE),$5); }
+ | SPLIT '(' WORD ',' PATTERN ',' sexpr ')'
+ { $$ = mod_match(O_MATCH,
+ $7,
+ make_split(stabent($3,TRUE),$5) ); }
+ | SPLIT '(' sexpr ',' sexpr ')'
+ { $$ = mod_match(O_MATCH, $5, make_split(defstab,$3) ); }
+ | SPLIT '(' sexpr ')'
+ { $$ = mod_match(O_MATCH,
+ stab_to_arg(A_STAB,defstab),
+ make_split(defstab,$3) ); }
+ | JOIN '(' WORD ',' expr ')'
+ { $$ = make_op(O_JOIN, 2,
+ $5,
+ stab_to_arg(A_STAB,aadd(stabent($3,TRUE))),
+ Nullarg,0); }
+ | JOIN '(' sexpr ',' expr ')'
+ { $$ = make_op(O_JOIN, 2,
+ $3,
+ make_list($5),
+ Nullarg,2); }
+ | SPRINTF '(' expr ')'
+ { $$ = make_op(O_SPRINTF, 1,
+ make_list($3),
+ Nullarg,
+ Nullarg,1); }
+ | STAT '(' WORD ')'
+ { $$ = l(make_op(O_STAT, 1,
+ stab_to_arg(A_STAB,stabent($3,TRUE)),
+ Nullarg, Nullarg,0)); }
+ | STAT '(' expr ')'
+ { $$ = make_op(O_STAT, 1, $3, Nullarg, Nullarg,0); }
+ | CHOP
+ { $$ = l(make_op(O_CHOP, 1,
+ stab_to_arg(A_STAB,defstab),
+ Nullarg, Nullarg,0)); }
+ | CHOP '(' expr ')'
+ { $$ = l(make_op(O_CHOP, 1, $3, Nullarg, Nullarg,0)); }
+ | FUNC0
+ { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg,0); }
+ | FUNC1 '(' expr ')'
+ { $$ = make_op($1, 1, $3, Nullarg, Nullarg,0); }
+ | FUNC2 '(' sexpr ',' expr ')'
+ { $$ = make_op($1, 2, $3, $5, Nullarg, 0); }
+ | FUNC3 '(' sexpr ',' sexpr ',' expr ')'
+ { $$ = make_op($1, 3, $3, $5, $7, 0); }
+ | STABFUN '(' WORD ')'
+ { $$ = make_op($1, 1,
+ stab_to_arg(A_STAB,hadd(stabent($3,TRUE))),
+ Nullarg,
+ Nullarg, 0); }
+ ;
+
+print : PRINT
+ { $$ = make_op($1,2,
+ stab_to_arg(A_STAB,defstab),
+ stab_to_arg(A_STAB,Nullstab),
+ Nullarg,0); }
+ | PRINT expr
+ { $$ = make_op($1,2,make_list($2),
+ stab_to_arg(A_STAB,Nullstab),
+ Nullarg,1); }
+ | PRINT WORD
+ { $$ = make_op($1,2,
+ stab_to_arg(A_STAB,defstab),
+ stab_to_arg(A_STAB,stabent($2,TRUE)),
+ Nullarg,1); }
+ | PRINT WORD expr
+ { $$ = make_op($1,2,make_list($3),
+ stab_to_arg(A_STAB,stabent($2,TRUE)),
+ Nullarg,1); }
+ ;
+
+%% /* PROGRAM */
+#include "perly.c"
--- /dev/null
+char rcsid[] = "$Header: perly.c,v 1.0 87/12/18 15:53:31 root Exp $";
+/*
+ * $Log: perly.c,v $
+ * Revision 1.0 87/12/18 15:53:31 root
+ * Initial revision
+ *
+ */
+
+bool preprocess = FALSE;
+bool assume_n = FALSE;
+bool assume_p = FALSE;
+bool doswitches = FALSE;
+char *filename;
+char *e_tmpname = "/tmp/perl-eXXXXXX";
+FILE *e_fp = Nullfp;
+ARG *l();
+
+main(argc,argv,env)
+register int argc;
+register char **argv;
+register char **env;
+{
+ register STR *str;
+ register char *s;
+ char *index();
+
+ linestr = str_new(80);
+ str = str_make("-I/usr/lib/perl "); /* 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 'e':
+ if (!e_fp) {
+ mktemp(e_tmpname);
+ e_fp = fopen(e_tmpname,"w");
+ }
+ if (argv[1])
+ fputs(argv[1],e_fp);
+ putc('\n', e_fp);
+ argc--,argv++;
+ break;
+ case 'i':
+ inplace = savestr(argv[0]+2);
+ argvoutstab = stabent("ARGVOUT",TRUE);
+ break;
+ case 'I':
+ str_cat(str,argv[0]);
+ str_cat(str," ");
+ if (!argv[0][2]) {
+ str_cat(str,argv[1]);
+ argc--,argv++;
+ str_cat(str," ");
+ }
+ break;
+ case 'n':
+ assume_n = TRUE;
+ strcpy(argv[0], argv[0]+1);
+ goto reswitch;
+ case 'p':
+ assume_p = TRUE;
+ strcpy(argv[0], argv[0]+1);
+ goto reswitch;
+ case 'P':
+ preprocess = TRUE;
+ strcpy(argv[0], argv[0]+1);
+ goto reswitch;
+ case 's':
+ doswitches = TRUE;
+ strcpy(argv[0], argv[0]+1);
+ goto reswitch;
+ case 'v':
+ version();
+ exit(0);
+ case '-':
+ argc--,argv++;
+ goto switch_end;
+ case 0:
+ break;
+ default:
+ fatal("Unrecognized switch: %s\n",argv[0]);
+ }
+ }
+ switch_end:
+ if (e_fp) {
+ fclose(e_fp);
+ argc++,argv--;
+ argv[0] = e_tmpname;
+ }
+
+ str_set(&str_no,No);
+ str_set(&str_yes,Yes);
+ init_eval();
+
+ /* open script */
+
+ if (argv[0] == Nullch)
+ argv[0] = "-";
+ filename = savestr(argv[0]);
+ if (strEQ(filename,"-"))
+ argv[0] = "";
+ if (preprocess) {
+ sprintf(buf, "\
+/bin/sed -e '/^[^#]/b' \
+ -e '/^#[ ]*include[ ]/b' \
+ -e '/^#[ ]*define[ ]/b' \
+ -e '/^#[ ]*if[ ]/b' \
+ -e '/^#[ ]*ifdef[ ]/b' \
+ -e '/^#[ ]*else/b' \
+ -e '/^#[ ]*endif/b' \
+ -e 's/^#.*//' \
+ %s | /lib/cpp -C %s-",
+ argv[0], str_get(str));
+ rsfp = popen(buf,"r");
+ }
+ else if (!*argv[0])
+ rsfp = stdin;
+ else
+ rsfp = fopen(argv[0],"r");
+ if (rsfp == Nullfp)
+ fatal("Perl script \"%s\" doesn't seem to exist.\n",filename);
+ str_free(str); /* free -I directories */
+
+ defstab = stabent("_",TRUE);
+
+ /* init tokener */
+
+ bufptr = str_get(linestr);
+
+ /* now parse the report spec */
+
+ if (yyparse())
+ fatal("Execution aborted due to compilation errors.\n");
+
+ if (e_fp) {
+ e_fp = Nullfp;
+ UNLINK(e_tmpname);
+ }
+ argc--,argv++; /* skip name of script */
+ if (doswitches) {
+ for (; argc > 0 && **argv == '-'; argc--,argv++) {
+ if (argv[0][1] == '-') {
+ argc--,argv++;
+ break;
+ }
+ str_numset(stabent(argv[0]+1,TRUE)->stab_val,(double)1.0);
+ }
+ }
+ if (argvstab = stabent("ARGV",FALSE)) {
+ for (; argc > 0; argc--,argv++) {
+ apush(argvstab->stab_array,str_make(argv[0]));
+ }
+ }
+ if (envstab = stabent("ENV",FALSE)) {
+ for (; *env; env++) {
+ if (!(s = index(*env,'=')))
+ continue;
+ *s++ = '\0';
+ str = str_make(s);
+ str->str_link.str_magic = envstab;
+ hstore(envstab->stab_hash,*env,str);
+ *--s = '=';
+ }
+ }
+ sigstab = stabent("SIG",FALSE);
+
+ magicalize("!#?^~=-%0123456789.+&*(),\\/[|");
+
+ (tmpstab = stabent("0",FALSE)) && str_set(STAB_STR(tmpstab),filename);
+ (tmpstab = stabent("$",FALSE)) &&
+ str_numset(STAB_STR(tmpstab),(double)getpid());
+
+ tmpstab = stabent("stdin",TRUE);
+ tmpstab->stab_io = stio_new();
+ tmpstab->stab_io->fp = stdin;
+
+ tmpstab = stabent("stdout",TRUE);
+ tmpstab->stab_io = stio_new();
+ tmpstab->stab_io->fp = stdout;
+ defoutstab = tmpstab;
+ curoutstab = tmpstab;
+
+ tmpstab = stabent("stderr",TRUE);
+ tmpstab->stab_io = stio_new();
+ tmpstab->stab_io->fp = stderr;
+
+ setjmp(top_env); /* sets goto_targ on longjump */
+
+#ifdef DEBUGGING
+ if (debug & 1024)
+ dump_cmd(main_root,Nullcmd);
+ if (debug)
+ fprintf(stderr,"\nEXECUTING...\n\n");
+#endif
+
+ /* do it */
+
+ (void) cmd_exec(main_root);
+
+ if (goto_targ)
+ fatal("Can't find label \"%s\"--aborting.\n",goto_targ);
+ exit(0);
+}
+
+magicalize(list)
+register char *list;
+{
+ register STAB *stab;
+ char sym[2];
+
+ sym[1] = '\0';
+ while (*sym = *list++) {
+ if (stab = stabent(sym,FALSE)) {
+ stab->stab_flags = SF_VMAGIC;
+ stab->stab_val->str_link.str_magic = stab;
+ }
+ }
+}
+
+#define RETURN(retval) return (bufptr = s,retval)
+#define OPERATOR(retval) return (expectterm = TRUE,bufptr = s,retval)
+#define TERM(retval) return (expectterm = FALSE,bufptr = s,retval)
+#define LOOPX(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,LOOPEX)
+#define UNI(f) return (yylval.ival = f,expectterm = TRUE,bufptr = s,UNIOP)
+#define FUN0(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC0)
+#define FUN1(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC1)
+#define FUN2(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC2)
+#define FUN3(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC3)
+#define SFUN(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,STABFUN)
+
+yylex()
+{
+ register char *s = bufptr;
+ register char *d;
+ register int tmp;
+ static bool in_format = FALSE;
+ static bool firstline = TRUE;
+
+ 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 0:
+ s = str_get(linestr);
+ *s = '\0';
+ if (firstline && (assume_n || assume_p)) {
+ firstline = FALSE;
+ str_set(linestr,"while (<>) {");
+ s = str_get(linestr);
+ goto retry;
+ }
+ if (!rsfp)
+ RETURN(0);
+ if (in_format) {
+ yylval.formval = load_format(); /* leaves . in buffer */
+ in_format = FALSE;
+ s = str_get(linestr);
+ TERM(FORMLIST);
+ }
+ line++;
+ if ((s = str_gets(linestr, rsfp)) == Nullch) {
+ if (preprocess)
+ pclose(rsfp);
+ else if (rsfp != stdin)
+ fclose(rsfp);
+ rsfp = Nullfp;
+ if (assume_n || assume_p) {
+ str_set(linestr,assume_p ? "}continue{print;" : "");
+ str_cat(linestr,"}");
+ s = str_get(linestr);
+ goto retry;
+ }
+ s = str_get(linestr);
+ RETURN(0);
+ }
+#ifdef DEBUG
+ else if (firstline) {
+ char *showinput();
+ s = showinput();
+ }
+#endif
+ firstline = FALSE;
+ goto retry;
+ case ' ': case '\t':
+ s++;
+ goto retry;
+ case '\n':
+ case '#':
+ if (preprocess && s == str_get(linestr) &&
+ s[1] == ' ' && isdigit(s[2])) {
+ line = atoi(s+2)-1;
+ for (s += 2; isdigit(*s); s++) ;
+ while (*s && isspace(*s)) s++;
+ if (filename)
+ safefree(filename);
+ s[strlen(s)-1] = '\0'; /* wipe out newline */
+ filename = savestr(s);
+ s = str_get(linestr);
+ }
+ *s = '\0';
+ if (lex_newlines)
+ RETURN('\n');
+ goto retry;
+ case '+':
+ case '-':
+ if (s[1] == *s) {
+ s++;
+ if (*s++ == '+')
+ RETURN(INC);
+ else
+ RETURN(DEC);
+ }
+ /* FALL THROUGH */
+ case '*':
+ case '%':
+ case '^':
+ case '~':
+ case '(':
+ case ',':
+ case ':':
+ case ';':
+ case '{':
+ case '[':
+ tmp = *s++;
+ OPERATOR(tmp);
+ case ')':
+ case ']':
+ case '}':
+ tmp = *s++;
+ TERM(tmp);
+ case '&':
+ s++;
+ tmp = *s++;
+ if (tmp == '&')
+ OPERATOR(ANDAND);
+ s--;
+ OPERATOR('&');
+ case '|':
+ s++;
+ tmp = *s++;
+ if (tmp == '|')
+ OPERATOR(OROR);
+ s--;
+ OPERATOR('|');
+ case '=':
+ s++;
+ tmp = *s++;
+ if (tmp == '=')
+ OPERATOR(EQ);
+ if (tmp == '~')
+ OPERATOR(MATCH);
+ s--;
+ OPERATOR('=');
+ case '!':
+ s++;
+ tmp = *s++;
+ if (tmp == '=')
+ OPERATOR(NE);
+ if (tmp == '~')
+ OPERATOR(NMATCH);
+ s--;
+ OPERATOR('!');
+ case '<':
+ if (expectterm) {
+ s = scanstr(s);
+ TERM(RSTRING);
+ }
+ s++;
+ tmp = *s++;
+ if (tmp == '<')
+ OPERATOR(LS);
+ if (tmp == '=')
+ OPERATOR(LE);
+ s--;
+ OPERATOR('<');
+ case '>':
+ s++;
+ tmp = *s++;
+ if (tmp == '>')
+ OPERATOR(RS);
+ if (tmp == '=')
+ OPERATOR(GE);
+ s--;
+ OPERATOR('>');
+
+#define SNARFWORD \
+ d = tokenbuf; \
+ while (isalpha(*s) || isdigit(*s) || *s == '_') \
+ *d++ = *s++; \
+ *d = '\0'; \
+ d = tokenbuf;
+
+ case '$':
+ if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) {
+ s++;
+ s = scanreg(s,tokenbuf);
+ yylval.stabval = aadd(stabent(tokenbuf,TRUE));
+ TERM(ARYLEN);
+ }
+ s = scanreg(s,tokenbuf);
+ yylval.stabval = stabent(tokenbuf,TRUE);
+ TERM(REG);
+
+ case '@':
+ s = scanreg(s,tokenbuf);
+ 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++;
+ OPERATOR(tmp);
+
+ case '.':
+ if (!expectterm || !isdigit(s[1])) {
+ s++;
+ tmp = *s++;
+ if (tmp == '.')
+ OPERATOR(DOTDOT);
+ s--;
+ OPERATOR('.');
+ }
+ /* 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 '_':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'a': case 'A':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'b': case 'B':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'c': case 'C':
+ SNARFWORD;
+ if (strEQ(d,"continue"))
+ OPERATOR(CONTINUE);
+ if (strEQ(d,"chdir"))
+ UNI(O_CHDIR);
+ if (strEQ(d,"close"))
+ OPERATOR(CLOSE);
+ if (strEQ(d,"crypt"))
+ FUN2(O_CRYPT);
+ if (strEQ(d,"chop"))
+ OPERATOR(CHOP);
+ if (strEQ(d,"chmod")) {
+ yylval.ival = O_CHMOD;
+ OPERATOR(PRINT);
+ }
+ if (strEQ(d,"chown")) {
+ yylval.ival = O_CHOWN;
+ OPERATOR(PRINT);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'd': case 'D':
+ SNARFWORD;
+ if (strEQ(d,"do"))
+ OPERATOR(DO);
+ if (strEQ(d,"die"))
+ UNI(O_DIE);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'e': case 'E':
+ SNARFWORD;
+ if (strEQ(d,"else"))
+ OPERATOR(ELSE);
+ if (strEQ(d,"elsif"))
+ OPERATOR(ELSIF);
+ if (strEQ(d,"eq") || strEQ(d,"EQ"))
+ OPERATOR(SEQ);
+ if (strEQ(d,"exit"))
+ UNI(O_EXIT);
+ if (strEQ(d,"eof"))
+ TERM(FEOF);
+ if (strEQ(d,"exp"))
+ FUN1(O_EXP);
+ if (strEQ(d,"each"))
+ SFUN(O_EACH);
+ if (strEQ(d,"exec")) {
+ yylval.ival = O_EXEC;
+ OPERATOR(PRINT);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'f': case 'F':
+ SNARFWORD;
+ if (strEQ(d,"for"))
+ OPERATOR(FOR);
+ if (strEQ(d,"format")) {
+ in_format = TRUE;
+ OPERATOR(FORMAT);
+ }
+ if (strEQ(d,"fork"))
+ FUN0(O_FORK);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'g': case 'G':
+ SNARFWORD;
+ if (strEQ(d,"gt") || strEQ(d,"GT"))
+ OPERATOR(SGT);
+ if (strEQ(d,"ge") || strEQ(d,"GE"))
+ OPERATOR(SGE);
+ if (strEQ(d,"goto"))
+ LOOPX(O_GOTO);
+ if (strEQ(d,"gmtime"))
+ FUN1(O_GMTIME);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'h': case 'H':
+ SNARFWORD;
+ if (strEQ(d,"hex"))
+ FUN1(O_HEX);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'i': case 'I':
+ SNARFWORD;
+ if (strEQ(d,"if"))
+ OPERATOR(IF);
+ if (strEQ(d,"index"))
+ FUN2(O_INDEX);
+ if (strEQ(d,"int"))
+ FUN1(O_INT);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'j': case 'J':
+ SNARFWORD;
+ if (strEQ(d,"join"))
+ OPERATOR(JOIN);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'k': case 'K':
+ SNARFWORD;
+ if (strEQ(d,"keys"))
+ SFUN(O_KEYS);
+ if (strEQ(d,"kill")) {
+ yylval.ival = O_KILL;
+ OPERATOR(PRINT);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'l': case 'L':
+ SNARFWORD;
+ if (strEQ(d,"last"))
+ LOOPX(O_LAST);
+ if (strEQ(d,"length"))
+ FUN1(O_LENGTH);
+ if (strEQ(d,"lt") || strEQ(d,"LT"))
+ OPERATOR(SLT);
+ if (strEQ(d,"le") || strEQ(d,"LE"))
+ OPERATOR(SLE);
+ if (strEQ(d,"localtime"))
+ FUN1(O_LOCALTIME);
+ if (strEQ(d,"log"))
+ FUN1(O_LOG);
+ if (strEQ(d,"link"))
+ FUN2(O_LINK);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'm': case 'M':
+ SNARFWORD;
+ if (strEQ(d,"m")) {
+ s = scanpat(s-1);
+ TERM(PATTERN);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'n': case 'N':
+ SNARFWORD;
+ if (strEQ(d,"next"))
+ LOOPX(O_NEXT);
+ if (strEQ(d,"ne") || strEQ(d,"NE"))
+ OPERATOR(SNE);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'o': case 'O':
+ SNARFWORD;
+ if (strEQ(d,"open"))
+ OPERATOR(OPEN);
+ if (strEQ(d,"ord"))
+ FUN1(O_ORD);
+ if (strEQ(d,"oct"))
+ FUN1(O_OCT);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'p': case 'P':
+ SNARFWORD;
+ if (strEQ(d,"print")) {
+ yylval.ival = O_PRINT;
+ OPERATOR(PRINT);
+ }
+ if (strEQ(d,"printf")) {
+ yylval.ival = O_PRTF;
+ OPERATOR(PRINT);
+ }
+ if (strEQ(d,"push")) {
+ yylval.ival = O_PUSH;
+ OPERATOR(PUSH);
+ }
+ if (strEQ(d,"pop"))
+ OPERATOR(POP);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'q': case 'Q':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'r': case 'R':
+ SNARFWORD;
+ if (strEQ(d,"reset"))
+ UNI(O_RESET);
+ if (strEQ(d,"redo"))
+ LOOPX(O_REDO);
+ if (strEQ(d,"rename"))
+ FUN2(O_RENAME);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 's': case 'S':
+ SNARFWORD;
+ if (strEQ(d,"s")) {
+ s = scansubst(s);
+ TERM(SUBST);
+ }
+ if (strEQ(d,"shift"))
+ TERM(SHIFT);
+ if (strEQ(d,"split"))
+ TERM(SPLIT);
+ if (strEQ(d,"substr"))
+ FUN3(O_SUBSTR);
+ if (strEQ(d,"sprintf"))
+ OPERATOR(SPRINTF);
+ if (strEQ(d,"sub"))
+ OPERATOR(SUB);
+ if (strEQ(d,"select"))
+ OPERATOR(SELECT);
+ if (strEQ(d,"seek"))
+ OPERATOR(SEEK);
+ if (strEQ(d,"stat"))
+ OPERATOR(STAT);
+ if (strEQ(d,"sqrt"))
+ FUN1(O_SQRT);
+ if (strEQ(d,"sleep"))
+ UNI(O_SLEEP);
+ if (strEQ(d,"system")) {
+ yylval.ival = O_SYSTEM;
+ OPERATOR(PRINT);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 't': case 'T':
+ SNARFWORD;
+ if (strEQ(d,"tr")) {
+ s = scantrans(s);
+ TERM(TRANS);
+ }
+ if (strEQ(d,"tell"))
+ TERM(TELL);
+ if (strEQ(d,"time"))
+ FUN0(O_TIME);
+ if (strEQ(d,"times"))
+ FUN0(O_TMS);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'u': case 'U':
+ SNARFWORD;
+ if (strEQ(d,"using"))
+ OPERATOR(USING);
+ if (strEQ(d,"until"))
+ OPERATOR(UNTIL);
+ if (strEQ(d,"unless"))
+ OPERATOR(UNLESS);
+ if (strEQ(d,"umask"))
+ FUN1(O_UMASK);
+ if (strEQ(d,"unshift")) {
+ yylval.ival = O_UNSHIFT;
+ OPERATOR(PUSH);
+ }
+ if (strEQ(d,"unlink")) {
+ yylval.ival = O_UNLINK;
+ OPERATOR(PRINT);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'v': case 'V':
+ SNARFWORD;
+ if (strEQ(d,"values"))
+ SFUN(O_VALUES);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'w': case 'W':
+ SNARFWORD;
+ if (strEQ(d,"write"))
+ TERM(WRITE);
+ if (strEQ(d,"while"))
+ OPERATOR(WHILE);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'x': case 'X':
+ SNARFWORD;
+ if (!expectterm && strEQ(d,"x"))
+ OPERATOR('x');
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'y': case 'Y':
+ SNARFWORD;
+ if (strEQ(d,"y")) {
+ s = scantrans(s);
+ TERM(TRANS);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'z': case 'Z':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ }
+}
+
+STAB *
+stabent(name,add)
+register char *name;
+int add;
+{
+ register STAB *stab;
+
+ for (stab = stab_index[*name]; stab; stab = stab->stab_next) {
+ if (strEQ(name,stab->stab_name))
+ return stab;
+ }
+
+ /* no entry--should we add one? */
+
+ if (add) {
+ stab = (STAB *) safemalloc(sizeof(STAB));
+ bzero((char*)stab, sizeof(STAB));
+ stab->stab_name = savestr(name);
+ stab->stab_val = str_new(0);
+ stab->stab_next = stab_index[*name];
+ stab_index[*name] = stab;
+ return stab;
+ }
+ return Nullstab;
+}
+
+STIO *
+stio_new()
+{
+ STIO *stio = (STIO *) safemalloc(sizeof(STIO));
+
+ bzero((char*)stio, sizeof(STIO));
+ stio->page_len = 60;
+ return stio;
+}
+
+char *
+scanreg(s,dest)
+register char *s;
+char *dest;
+{
+ register char *d;
+
+ s++;
+ d = dest;
+ while (isalpha(*s) || isdigit(*s) || *s == '_')
+ *d++ = *s++;
+ *d = '\0';
+ d = dest;
+ if (!*d) {
+ *d = *s++;
+ if (*d == '{') {
+ d = dest;
+ while (*s && *s != '}')
+ *d++ = *s++;
+ *d = '\0';
+ d = dest;
+ if (*s)
+ s++;
+ }
+ else
+ d[1] = '\0';
+ }
+ if (*d == '^' && !isspace(*s))
+ *d = *s++ & 31;
+ return s;
+}
+
+STR *
+scanconst(string)
+char *string;
+{
+ register STR *retstr;
+ register char *t;
+ register char *d;
+
+ if (index(string,'|')) {
+ return Nullstr;
+ }
+ retstr = str_make(string);
+ t = str_get(retstr);
+ for (d=t; *d; ) {
+ switch (*d) {
+ case '.': case '[': case '$': case '(': case ')': case '|':
+ *d = '\0';
+ break;
+ case '\\':
+ if (index("wWbB0123456789",d[1])) {
+ *d = '\0';
+ break;
+ }
+ strcpy(d,d+1);
+ switch(*d) {
+ case 'n':
+ *d = '\n';
+ break;
+ case 't':
+ *d = '\t';
+ break;
+ case 'f':
+ *d = '\f';
+ break;
+ case 'r':
+ *d = '\r';
+ break;
+ }
+ /* FALL THROUGH */
+ default:
+ if (d[1] == '*' || d[1] == '+' || d[1] == '?') {
+ *d = '\0';
+ break;
+ }
+ d++;
+ }
+ }
+ if (!*t) {
+ str_free(retstr);
+ return Nullstr;
+ }
+ retstr->str_cur = strlen(retstr->str_ptr); /* XXX cheating here */
+ return retstr;
+}
+
+char *
+scanpat(s)
+register char *s;
+{
+ register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
+ register char *d;
+
+ bzero((char *)spat, sizeof(SPAT));
+ spat->spat_next = spat_root; /* link into spat list */
+ spat_root = spat;
+ init_compex(&spat->spat_compex);
+
+ switch (*s++) {
+ case 'm':
+ s++;
+ break;
+ case '/':
+ break;
+ case '?':
+ spat->spat_flags |= SPAT_USE_ONCE;
+ break;
+ default:
+ fatal("Search pattern not found:\n%s",str_get(linestr));
+ }
+ s = cpytill(tokenbuf,s,s[-1]);
+ if (!*s)
+ fatal("Search pattern not terminated:\n%s",str_get(linestr));
+ s++;
+ if (*tokenbuf == '^') {
+ spat->spat_first = scanconst(tokenbuf+1);
+ if (spat->spat_first) {
+ spat->spat_flen = strlen(spat->spat_first->str_ptr);
+ if (spat->spat_flen == strlen(tokenbuf+1))
+ spat->spat_flags |= SPAT_SCANALL;
+ }
+ }
+ else {
+ spat->spat_flags |= SPAT_SCANFIRST;
+ spat->spat_first = scanconst(tokenbuf);
+ if (spat->spat_first) {
+ spat->spat_flen = strlen(spat->spat_first->str_ptr);
+ if (spat->spat_flen == strlen(tokenbuf))
+ spat->spat_flags |= SPAT_SCANALL;
+ }
+ }
+ if (d = compile(&spat->spat_compex,tokenbuf,TRUE,FALSE))
+ fatal(d);
+ yylval.arg = make_match(O_MATCH,stab_to_arg(A_STAB,defstab),spat);
+ return s;
+}
+
+char *
+scansubst(s)
+register char *s;
+{
+ register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
+ register char *d;
+
+ bzero((char *)spat, sizeof(SPAT));
+ spat->spat_next = spat_root; /* link into spat list */
+ spat_root = spat;
+ init_compex(&spat->spat_compex);
+
+ s = cpytill(tokenbuf,s+1,*s);
+ if (!*s)
+ fatal("Substitution pattern not terminated:\n%s",str_get(linestr));
+ for (d=tokenbuf; *d; d++) {
+ if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+ 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_make(tokenbuf);
+ goto get_repl; /* skip compiling for now */
+ }
+ }
+ if (*tokenbuf == '^') {
+ spat->spat_first = scanconst(tokenbuf+1);
+ if (spat->spat_first)
+ spat->spat_flen = strlen(spat->spat_first->str_ptr);
+ }
+ else {
+ spat->spat_flags |= SPAT_SCANFIRST;
+ spat->spat_first = scanconst(tokenbuf);
+ if (spat->spat_first)
+ spat->spat_flen = strlen(spat->spat_first->str_ptr);
+ }
+ if (d = compile(&spat->spat_compex,tokenbuf,TRUE,FALSE))
+ fatal(d);
+get_repl:
+ s = scanstr(s);
+ if (!*s)
+ fatal("Substitution replacement not terminated:\n%s",str_get(linestr));
+ spat->spat_repl = yylval.arg;
+ if (*s == 'g') {
+ s++;
+ spat->spat_flags &= ~SPAT_USE_ONCE;
+ }
+ else
+ spat->spat_flags |= SPAT_USE_ONCE;
+ yylval.arg = make_match(O_SUBST,stab_to_arg(A_STAB,defstab),spat);
+ return s;
+}
+
+ARG *
+make_split(stab,arg)
+register STAB *stab;
+register ARG *arg;
+{
+ if (arg->arg_type != O_MATCH) {
+ register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
+ register char *d;
+
+ bzero((char *)spat, sizeof(SPAT));
+ spat->spat_next = spat_root; /* link into spat list */
+ spat_root = spat;
+ init_compex(&spat->spat_compex);
+
+ spat->spat_runtime = arg;
+ arg = make_match(O_MATCH,stab_to_arg(A_STAB,defstab),spat);
+ }
+ arg->arg_type = O_SPLIT;
+ arg[2].arg_ptr.arg_spat->spat_repl = stab_to_arg(A_STAB,aadd(stab));
+ return arg;
+}
+
+char *
+expand_charset(s)
+register char *s;
+{
+ char t[512];
+ register char *d = t;
+ register int i;
+
+ while (*s) {
+ if (s[1] == '-' && s[2]) {
+ for (i = s[0]; i <= s[2]; i++)
+ *d++ = i;
+ s += 3;
+ }
+ else
+ *d++ = *s++;
+ }
+ *d = '\0';
+ return savestr(t);
+}
+
+char *
+scantrans(s)
+register char *s;
+{
+ ARG *arg =
+ l(make_op(O_TRANS,2,stab_to_arg(A_STAB,defstab),Nullarg,Nullarg,0));
+ register char *t;
+ register char *r;
+ register char *tbl = safemalloc(256);
+ register int i;
+
+ arg[2].arg_type = A_NULL;
+ arg[2].arg_ptr.arg_cval = tbl;
+ for (i=0; i<256; i++)
+ tbl[i] = 0;
+ s = scanstr(s);
+ if (!*s)
+ fatal("Translation pattern not terminated:\n%s",str_get(linestr));
+ t = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str));
+ free_arg(yylval.arg);
+ s = scanstr(s-1);
+ if (!*s)
+ fatal("Translation replacement not terminated:\n%s",str_get(linestr));
+ r = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str));
+ free_arg(yylval.arg);
+ yylval.arg = arg;
+ if (!*r) {
+ safefree(r);
+ r = t;
+ }
+ for (i = 0; t[i]; i++) {
+ if (!r[i])
+ r[i] = r[i-1];
+ tbl[t[i] & 0377] = r[i];
+ }
+ if (r != t)
+ safefree(r);
+ safefree(t);
+ return s;
+}
+
+CMD *
+block_head(tail)
+register CMD *tail;
+{
+ if (tail == Nullcmd) {
+ return tail;
+ }
+ return tail->c_head;
+}
+
+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 *
+make_acmd(type,stab,cond,arg)
+int type;
+STAB *stab;
+ARG *cond;
+ARG *arg;
+{
+ register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
+
+ bzero((char *)cmd, sizeof(CMD));
+ cmd->c_type = type;
+ cmd->ucmd.acmd.ac_stab = stab;
+ cmd->ucmd.acmd.ac_expr = arg;
+ cmd->c_expr = cond;
+ if (cond) {
+ opt_arg(cmd,1);
+ cmd->c_flags |= CF_COND;
+ }
+ return cmd;
+}
+
+CMD *
+make_ccmd(type,arg,cblock)
+int type;
+register ARG *arg;
+struct compcmd cblock;
+{
+ register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
+
+ bzero((char *)cmd, sizeof(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) {
+ opt_arg(cmd,1);
+ cmd->c_flags |= CF_COND;
+ }
+ return cmd;
+}
+
+void
+opt_arg(cmd,fliporflop)
+register CMD *cmd;
+int fliporflop;
+{
+ register ARG *arg;
+ int opt = CFT_EVAL;
+ int sure = 0;
+ ARG *arg2;
+ char *tmps; /* for True macro */
+ int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */
+ int flp = fliporflop;
+
+ if (!cmd)
+ return;
+ arg = cmd->c_expr;
+
+ /* Turn "if (!expr)" into "unless (expr)" */
+
+ while (arg->arg_type == O_NOT && arg[1].arg_type == A_EXPR) {
+ 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 */
+
+ if (arg->arg_type == O_AND)
+ context |= 1;
+ else if (arg->arg_type == O_OR)
+ context |= 2;
+ if (context && arg[flp].arg_type == A_EXPR) {
+ arg = arg[flp].arg_ptr.arg_arg;
+ flp = 1;
+ }
+
+ if (arg[flp].arg_flags & (AF_PRE|AF_POST)) {
+ cmd->c_flags |= opt;
+ 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_SINGLE) {
+ opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE);
+ cmd->c_first = arg[flp].arg_ptr.arg_str;
+ goto literal;
+ }
+ else if (arg[flp].arg_type == A_STAB || arg[flp].arg_type == A_LVAL) {
+ cmd->c_stab = arg[flp].arg_ptr.arg_stab;
+ opt = CFT_REG;
+ literal:
+ if (!context) { /* no && or ||? */
+ free_arg(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_SPAT &&
+ arg[2].arg_ptr.arg_spat->spat_first ) {
+ cmd->c_stab = arg[1].arg_ptr.arg_stab;
+ cmd->c_first = arg[2].arg_ptr.arg_spat->spat_first;
+ cmd->c_flen = arg[2].arg_ptr.arg_spat->spat_flen;
+ if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANALL &&
+ (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) )
+ sure |= CF_EQSURE; /* (SUBST must be forced even */
+ /* if we know it will work.) */
+ arg[2].arg_ptr.arg_spat->spat_first = Nullstr;
+ arg[2].arg_ptr.arg_spat->spat_flen = 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) {
+ arg[2].arg_type = A_SINGLE; /* don't do twice */
+ arg[2].arg_ptr.arg_str = &str_yes;
+ }
+ 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) {
+ cmd->c_stab = arg[1].arg_ptr.arg_stab;
+ cmd->c_first = arg[2].arg_ptr.arg_str;
+ cmd->c_flen = 30000;
+ 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_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 (!(arg2[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV)) {
+ free_arg(arg2);
+ 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 */
+ arg[3].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
+ bcopy((char *)cmd, (char *)arg[3].arg_ptr.arg_cmd, sizeof(CMD));
+ arg[4].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
+ bcopy((char *)cmd, (char *)arg[4].arg_ptr.arg_cmd, sizeof(CMD));
+ opt_arg(arg[4].arg_ptr.arg_cmd,2);
+ 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;
+ }
+ }
+}
+
+ARG *
+mod_match(type,left,pat)
+register ARG *left;
+register ARG *pat;
+{
+
+ register SPAT *spat;
+ register ARG *newarg;
+
+ 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,0);
+ break;
+ case O_SUBST:
+ newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST,
+ pat->arg_len,
+ left,Nullarg,Nullarg,0));
+ break;
+ case O_TRANS:
+ newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS,
+ pat->arg_len,
+ left,Nullarg,Nullarg,0));
+ break;
+ case O_SPLIT:
+ newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT,
+ pat->arg_len,
+ left,Nullarg,Nullarg,0);
+ 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_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_flags = pat[3].arg_flags;
+ }
+ }
+ safefree((char*)pat);
+ }
+ else {
+ spat = (SPAT *) safemalloc(sizeof (SPAT));
+ bzero((char *)spat, sizeof(SPAT));
+ spat->spat_next = spat_root; /* link into spat list */
+ spat_root = spat;
+ init_compex(&spat->spat_compex);
+
+ spat->spat_runtime = pat;
+ newarg = make_op(type,2,left,Nullarg,Nullarg,0);
+ newarg[2].arg_type = A_SPAT;
+ newarg[2].arg_ptr.arg_spat = spat;
+ newarg[2].arg_flags = AF_SPECIAL;
+ }
+
+ return newarg;
+}
+
+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;
+ opt_arg(cmd,1);
+ cmd->c_flags |= CF_COND;
+ return cmd;
+}
+
+CMD *
+addloop(cmd, arg)
+register CMD *cmd;
+register ARG *arg;
+{
+ cmd->c_expr = arg;
+ opt_arg(cmd,1);
+ cmd->c_flags |= CF_COND|CF_LOOP;
+ 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_type == O_SUBR)
+ cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */
+ }
+ return cmd;
+}
+
+CMD *
+invert(cmd)
+register CMD *cmd;
+{
+ cmd->c_flags ^= CF_INVERT;
+ return cmd;
+}
+
+yyerror(s)
+char *s;
+{
+ char tmpbuf[128];
+ char *tname = tmpbuf;
+
+ if (yychar > 256) {
+ tname = tokename[yychar-256];
+ if (strEQ(tname,"word"))
+ strcpy(tname,tokenbuf);
+ else if (strEQ(tname,"register"))
+ sprintf(tname,"$%s",tokenbuf);
+ else if (strEQ(tname,"array_length"))
+ sprintf(tname,"$#%s",tokenbuf);
+ }
+ else if (!yychar)
+ strcpy(tname,"EOF");
+ else if (yychar < 32)
+ sprintf(tname,"^%c",yychar+64);
+ else if (yychar == 127)
+ strcpy(tname,"^?");
+ else
+ sprintf(tname,"%c",yychar);
+ printf("%s in file %s at line %d, next token \"%s\"\n",
+ s,filename,line,tname);
+}
+
+char *
+scanstr(s)
+register char *s;
+{
+ register char term;
+ register char *d;
+ register ARG *arg;
+ register bool makesingle = FALSE;
+ char *leave = "\\$nrtfb0123456789"; /* which backslash sequences to keep */
+
+ 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':
+ {
+ 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 '8': case '9':
+ if (shift != 4)
+ fatal("Illegal octal digit at line %d",line);
+ /* 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:
+ sprintf(tokenbuf,"%d",i);
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ }
+ 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 == '_')
+ *d++ = *s++;
+ if (*s == '.' && index("0123456789eE",s[1]))
+ *d++ = *s++;
+ while (isdigit(*s) || *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';
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ break;
+ case '\'':
+ arg[1].arg_type = A_SINGLE;
+ term = *s;
+ leave = Nullch;
+ goto snarf_it;
+
+ case '<':
+ arg[1].arg_type = A_READ;
+ s = cpytill(tokenbuf,s+1,'>');
+ if (!*tokenbuf)
+ strcpy(tokenbuf,"ARGV");
+ if (*s)
+ s++;
+ if (rsfp == stdin && strEQ(tokenbuf,"stdin"))
+ fatal("Can't get both program and data from <stdin>\n");
+ arg[1].arg_ptr.arg_stab = stabent(tokenbuf,TRUE);
+ arg[1].arg_ptr.arg_stab->stab_io = stio_new();
+ if (strEQ(tokenbuf,"ARGV")) {
+ aadd(arg[1].arg_ptr.arg_stab);
+ arg[1].arg_ptr.arg_stab->stab_io->flags |= IOF_ARGV|IOF_START;
+ }
+ break;
+ case '"':
+ arg[1].arg_type = A_DOUBLE;
+ makesingle = TRUE; /* maybe disable runtime scanning */
+ term = *s;
+ goto snarf_it;
+ case '`':
+ arg[1].arg_type = A_BACKTICK;
+ term = *s;
+ snarf_it:
+ {
+ STR *tmpstr;
+ int sqstart = line;
+ char *tmps;
+
+ tmpstr = str_new(strlen(s));
+ s = str_append_till(tmpstr,s+1,term,leave);
+ while (!*s) { /* multiple line string? */
+ s = str_gets(linestr, rsfp);
+ if (!*s)
+ fatal("EOF in string at line %d\n",sqstart);
+ line++;
+ s = str_append_till(tmpstr,s,term,leave);
+ }
+ s++;
+ if (term == '\'') {
+ arg[1].arg_ptr.arg_str = tmpstr;
+ break;
+ }
+ tmps = s;
+ s = d = tmpstr->str_ptr; /* assuming shrinkage only */
+ while (*s) {
+ if (*s == '$' && s[1]) {
+ makesingle = FALSE; /* force interpretation */
+ if (!isalpha(s[1])) { /* an internal register? */
+ int len;
+
+ len = scanreg(s,tokenbuf) - s;
+ stabent(tokenbuf,TRUE); /* make sure it's created */
+ while (len--)
+ *d++ = *s++;
+ continue;
+ }
+ }
+ else if (*s == '\\' && s[1]) {
+ s++;
+ switch (*s) {
+ default:
+ defchar:
+ if (!leave || index(leave,*s))
+ *d++ = '\\';
+ *d++ = *s++;
+ continue;
+ case '0': case '1': case '2': case '3':
+ case '4': case '5': case '6': case '7':
+ *d = *s++ - '0';
+ if (index("01234567",*s)) {
+ *d <<= 3;
+ *d += *s++ - '0';
+ }
+ else if (!index('`"',term)) { /* oops, a subpattern */
+ s--;
+ goto defchar;
+ }
+ if (index("01234567",*s)) {
+ *d <<= 3;
+ *d += *s++ - '0';
+ }
+ d++;
+ 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;
+ }
+ s++;
+ continue;
+ }
+ *d++ = *s++;
+ }
+ *d = '\0';
+ if (arg[1].arg_type == A_DOUBLE) {
+ if (makesingle)
+ arg[1].arg_type = A_SINGLE; /* now we can optimize on it */
+ else
+ leave = "\\";
+ for (d = s = tmpstr->str_ptr; *s; *d++ = *s++) {
+ if (*s == '\\' && (!leave || index(leave,s[1])))
+ s++;
+ }
+ *d = '\0';
+ }
+ tmpstr->str_cur = d - tmpstr->str_ptr; /* XXX cheat */
+ arg[1].arg_ptr.arg_str = tmpstr;
+ s = tmps;
+ break;
+ }
+ }
+ return s;
+}
+
+ARG *
+make_op(type,newlen,arg1,arg2,arg3,dolist)
+int type;
+int newlen;
+ARG *arg1;
+ARG *arg2;
+ARG *arg3;
+int dolist;
+{
+ register ARG *arg;
+ register ARG *chld;
+ register int doarg;
+
+ arg = op_new(newlen);
+ arg->arg_type = type;
+ doarg = opargs[type];
+ if (chld = arg1) {
+ if (!(doarg & 1))
+ arg[1].arg_flags |= AF_SPECIAL;
+ if (doarg & 16)
+ arg[1].arg_flags |= AF_NUMERIC;
+ if (chld->arg_type == O_ITEM &&
+ (hoistable[chld[1].arg_type] || chld[1].arg_type == A_LVAL) ) {
+ arg[1].arg_type = chld[1].arg_type;
+ arg[1].arg_ptr = chld[1].arg_ptr;
+ arg[1].arg_flags |= chld[1].arg_flags;
+ free_arg(chld);
+ }
+ else {
+ arg[1].arg_type = A_EXPR;
+ arg[1].arg_ptr.arg_arg = chld;
+ if (dolist & 1) {
+ if (chld->arg_type == O_LIST) {
+ if (newlen == 1) { /* we can hoist entire list */
+ chld->arg_type = type;
+ free_arg(arg);
+ arg = chld;
+ }
+ else {
+ arg[1].arg_flags |= AF_SPECIAL;
+ }
+ }
+ else if (chld->arg_type == O_ARRAY && chld->arg_len == 1)
+ arg[1].arg_flags |= AF_SPECIAL;
+ }
+ }
+ }
+ if (chld = arg2) {
+ if (!(doarg & 2))
+ arg[2].arg_flags |= AF_SPECIAL;
+ if (doarg & 32)
+ arg[2].arg_flags |= AF_NUMERIC;
+ if (chld->arg_type == O_ITEM &&
+ (hoistable[chld[1].arg_type] ||
+ (type == O_ASSIGN &&
+ (chld[1].arg_type == A_READ ||
+ chld[1].arg_type == A_DOUBLE ||
+ chld[1].arg_type == A_BACKTICK ) ) ) ) {
+ arg[2].arg_type = chld[1].arg_type;
+ arg[2].arg_ptr = chld[1].arg_ptr;
+ free_arg(chld);
+ }
+ else {
+ arg[2].arg_type = A_EXPR;
+ arg[2].arg_ptr.arg_arg = chld;
+ if ((dolist & 2) &&
+ (chld->arg_type == O_LIST ||
+ (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
+ arg[2].arg_flags |= AF_SPECIAL;
+ }
+ }
+ if (chld = arg3) {
+ if (!(doarg & 4))
+ arg[3].arg_flags |= AF_SPECIAL;
+ if (doarg & 64)
+ arg[3].arg_flags |= AF_NUMERIC;
+ if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) {
+ arg[3].arg_type = chld[1].arg_type;
+ arg[3].arg_ptr = chld[1].arg_ptr;
+ free_arg(chld);
+ }
+ else {
+ arg[3].arg_type = A_EXPR;
+ arg[3].arg_ptr.arg_arg = chld;
+ if ((dolist & 4) &&
+ (chld->arg_type == O_LIST ||
+ (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
+ arg[3].arg_flags |= AF_SPECIAL;
+ }
+ }
+#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],arg[1].arg_ptr.arg_arg);
+ if (arg2)
+ fprintf(stderr,",%s=%lx",
+ argname[arg[2].arg_type],arg[2].arg_ptr.arg_arg);
+ if (arg3)
+ fprintf(stderr,",%s=%lx",
+ argname[arg[3].arg_type],arg[3].arg_ptr.arg_arg);
+ fprintf(stderr,")\n");
+ }
+#endif
+ evalstatic(arg); /* see if we can consolidate anything */
+ return arg;
+}
+
+/* turn 123 into 123 == $. */
+
+ARG *
+flipflip(arg)
+register ARG *arg;
+{
+ if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_SINGLE) {
+ arg = (ARG*)saferealloc((char*)arg,3*sizeof(ARG));
+ arg->arg_type = O_EQ;
+ arg->arg_len = 2;
+ arg[2].arg_type = A_STAB;
+ arg[2].arg_flags = 0;
+ arg[2].arg_ptr.arg_stab = stabent(".",TRUE);
+ }
+ return arg;
+}
+
+void
+evalstatic(arg)
+register ARG *arg;
+{
+ register STR *str;
+ register STR *s1;
+ register STR *s2;
+ double value; /* must not be register */
+ register char *tmps;
+ int i;
+ double exp(), log(), sqrt(), modf();
+ char *crypt();
+
+ if (!arg || !arg->arg_len)
+ return;
+
+ if (arg[1].arg_type == A_SINGLE &&
+ (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) {
+ str = str_new(0);
+ s1 = arg[1].arg_ptr.arg_str;
+ if (arg->arg_len > 1)
+ s2 = arg[2].arg_ptr.arg_str;
+ else
+ s2 = Nullstr;
+ switch (arg->arg_type) {
+ default:
+ str_free(str);
+ str = Nullstr; /* can't be evaluated yet */
+ break;
+ case O_CONCAT:
+ str_sset(str,s1);
+ str_scat(str,s2);
+ break;
+ case O_REPEAT:
+ i = (int)str_gnum(s2);
+ while (i--)
+ str_scat(str,s1);
+ break;
+ case O_MULTIPLY:
+ value = str_gnum(s1);
+ str_numset(str,value * str_gnum(s2));
+ break;
+ case O_DIVIDE:
+ value = str_gnum(s1);
+ str_numset(str,value / str_gnum(s2));
+ break;
+ case O_MODULO:
+ value = str_gnum(s1);
+ str_numset(str,(double)(((long)value) % ((long)str_gnum(s2))));
+ break;
+ case O_ADD:
+ value = str_gnum(s1);
+ str_numset(str,value + str_gnum(s2));
+ break;
+ case O_SUBTRACT:
+ value = str_gnum(s1);
+ str_numset(str,value - str_gnum(s2));
+ break;
+ case O_LEFT_SHIFT:
+ value = str_gnum(s1);
+ str_numset(str,(double)(((long)value) << ((long)str_gnum(s2))));
+ break;
+ case O_RIGHT_SHIFT:
+ value = str_gnum(s1);
+ str_numset(str,(double)(((long)value) >> ((long)str_gnum(s2))));
+ break;
+ case O_LT:
+ value = str_gnum(s1);
+ str_numset(str,(double)(value < str_gnum(s2)));
+ break;
+ case O_GT:
+ value = str_gnum(s1);
+ str_numset(str,(double)(value > str_gnum(s2)));
+ break;
+ case O_LE:
+ value = str_gnum(s1);
+ str_numset(str,(double)(value <= str_gnum(s2)));
+ break;
+ case O_GE:
+ value = str_gnum(s1);
+ str_numset(str,(double)(value >= str_gnum(s2)));
+ break;
+ case O_EQ:
+ value = str_gnum(s1);
+ str_numset(str,(double)(value == str_gnum(s2)));
+ break;
+ case O_NE:
+ value = str_gnum(s1);
+ str_numset(str,(double)(value != str_gnum(s2)));
+ break;
+ case O_BIT_AND:
+ value = str_gnum(s1);
+ str_numset(str,(double)(((long)value) & ((long)str_gnum(s2))));
+ break;
+ case O_XOR:
+ value = str_gnum(s1);
+ str_numset(str,(double)(((long)value) ^ ((long)str_gnum(s2))));
+ break;
+ case O_BIT_OR:
+ value = str_gnum(s1);
+ str_numset(str,(double)(((long)value) | ((long)str_gnum(s2))));
+ break;
+ case O_AND:
+ if (str_true(s1))
+ str = str_make(str_get(s2));
+ else
+ str = str_make(str_get(s1));
+ break;
+ case O_OR:
+ if (str_true(s1))
+ str = str_make(str_get(s1));
+ else
+ str = str_make(str_get(s2));
+ break;
+ case O_COND_EXPR:
+ if (arg[3].arg_type != A_SINGLE) {
+ str_free(str);
+ str = Nullstr;
+ }
+ else {
+ str = str_make(str_get(str_true(s1) ? s2 : arg[3].arg_ptr.arg_str));
+ str_free(arg[3].arg_ptr.arg_str);
+ }
+ break;
+ case O_NEGATE:
+ str_numset(str,(double)(-str_gnum(s1)));
+ break;
+ case O_NOT:
+ str_numset(str,(double)(!str_true(s1)));
+ break;
+ case O_COMPLEMENT:
+ str_numset(str,(double)(~(long)str_gnum(s1)));
+ break;
+ case O_LENGTH:
+ str_numset(str, (double)str_len(s1));
+ break;
+ case O_SUBSTR:
+ if (arg[3].arg_type != A_SINGLE || stabent("[",FALSE)) {
+ str_free(str); /* making the fallacious assumption */
+ str = Nullstr; /* that any $[ occurs before substr()*/
+ }
+ else {
+ char *beg;
+ int len = (int)str_gnum(s2);
+ int tmp;
+
+ for (beg = str_get(s1); *beg && len > 0; beg++,len--) ;
+ len = (int)str_gnum(arg[3].arg_ptr.arg_str);
+ str_free(arg[3].arg_ptr.arg_str);
+ if (len > (tmp = strlen(beg)))
+ len = tmp;
+ str_nset(str,beg,len);
+ }
+ break;
+ case O_SLT:
+ tmps = str_get(s1);
+ str_numset(str,(double)(strLT(tmps,str_get(s2))));
+ break;
+ case O_SGT:
+ tmps = str_get(s1);
+ str_numset(str,(double)(strGT(tmps,str_get(s2))));
+ break;
+ case O_SLE:
+ tmps = str_get(s1);
+ str_numset(str,(double)(strLE(tmps,str_get(s2))));
+ break;
+ case O_SGE:
+ tmps = str_get(s1);
+ str_numset(str,(double)(strGE(tmps,str_get(s2))));
+ break;
+ case O_SEQ:
+ tmps = str_get(s1);
+ str_numset(str,(double)(strEQ(tmps,str_get(s2))));
+ break;
+ case O_SNE:
+ tmps = str_get(s1);
+ str_numset(str,(double)(strNE(tmps,str_get(s2))));
+ break;
+ case O_CRYPT:
+ tmps = str_get(s1);
+ str_set(str,crypt(tmps,str_get(s2)));
+ break;
+ case O_EXP:
+ str_numset(str,exp(str_gnum(s1)));
+ break;
+ case O_LOG:
+ str_numset(str,log(str_gnum(s1)));
+ break;
+ case O_SQRT:
+ str_numset(str,sqrt(str_gnum(s1)));
+ break;
+ case O_INT:
+ modf(str_gnum(s1),&value);
+ str_numset(str,value);
+ break;
+ case O_ORD:
+ str_numset(str,(double)(*str_get(s1)));
+ break;
+ }
+ if (str) {
+ arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */
+ str_free(s1);
+ str_free(s2);
+ arg[1].arg_ptr.arg_str = str;
+ }
+ }
+}
+
+ARG *
+l(arg)
+register ARG *arg;
+{
+ register int i;
+ register ARG *arg1;
+
+ arg->arg_flags |= AF_COMMON; /* XXX should cross-match */
+
+ /* see if it's an array reference */
+
+ if (arg[1].arg_type == A_EXPR) {
+ arg1 = arg[1].arg_ptr.arg_arg;
+
+ if (arg1->arg_type == O_LIST && arg->arg_type != O_ITEM) {
+ /* assign to list */
+ arg[1].arg_flags |= AF_SPECIAL;
+ arg[2].arg_flags |= AF_SPECIAL;
+ for (i = arg1->arg_len; i >= 1; i--) {
+ switch (arg1[i].arg_type) {
+ case A_STAB: case A_LVAL:
+ arg1[i].arg_type = A_LVAL;
+ break;
+ case A_EXPR: case A_LEXPR:
+ arg1[i].arg_type = A_LEXPR;
+ if (arg1[i].arg_ptr.arg_arg->arg_type == O_ARRAY)
+ arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY;
+ else if (arg1[i].arg_ptr.arg_arg->arg_type == O_HASH)
+ arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH;
+ if (arg1[i].arg_ptr.arg_arg->arg_type == O_LARRAY)
+ break;
+ if (arg1[i].arg_ptr.arg_arg->arg_type == O_LHASH)
+ break;
+ /* FALL THROUGH */
+ default:
+ sprintf(tokenbuf,
+ "Illegal item (%s) as lvalue",argname[arg1[i].arg_type]);
+ yyerror(tokenbuf);
+ }
+ }
+ }
+ else if (arg1->arg_type == O_ARRAY) {
+ if (arg1->arg_len == 1 && arg->arg_type != O_ITEM) {
+ /* assign to array */
+ arg[1].arg_flags |= AF_SPECIAL;
+ arg[2].arg_flags |= AF_SPECIAL;
+ }
+ else
+ arg1->arg_type = O_LARRAY; /* assign to array elem */
+ }
+ else if (arg1->arg_type == O_HASH)
+ arg1->arg_type = O_LHASH;
+ else {
+ sprintf(tokenbuf,
+ "Illegal expression (%s) as lvalue",opname[arg1->arg_type]);
+ yyerror(tokenbuf);
+ }
+ arg[1].arg_type = A_LEXPR;
+#ifdef DEBUGGING
+ if (debug & 16)
+ fprintf(stderr,"lval LEXPR\n");
+#endif
+ return arg;
+ }
+
+ /* not an array reference, should be a register name */
+
+ if (arg[1].arg_type != A_STAB && arg[1].arg_type != A_LVAL) {
+ sprintf(tokenbuf,
+ "Illegal item (%s) as lvalue",argname[arg[1].arg_type]);
+ yyerror(tokenbuf);
+ }
+ arg[1].arg_type = A_LVAL;
+#ifdef DEBUGGING
+ if (debug & 16)
+ fprintf(stderr,"lval LVAL\n");
+#endif
+ return arg;
+}
+
+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)
+ return make_op(O_ITEM,1,arg,Nullarg,Nullarg,0);
+ 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) {
+ arg->arg_flags |= AF_LISTISH; /* see listish() below */
+ return arg;
+ }
+ for (i = 2, node = arg; ; i++) {
+ if (node->arg_len < 2)
+ break;
+ if (node[2].arg_type != A_EXPR)
+ break;
+ node = node[2].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;
+ *arg = *node; /* copy everything except the STR */
+ arg->arg_ptr.arg_str = tmpstr;
+ for (j = 1; ; ) {
+ arg[j++] = node[1];
+ if (j >= i) {
+ arg[j] = node[2];
+ free_arg(node);
+ break;
+ }
+ nxtnode = node[2].arg_ptr.arg_arg;
+ free_arg(node);
+ node = nxtnode;
+ }
+ }
+ 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_flags & AF_LISTISH)
+ arg = make_op(O_LIST,1,arg,Nullarg,Nullarg,0);
+ return arg;
+}
+
+ARG *
+stab_to_arg(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);
+ safefree(cval);
+ return arg;
+}
+
+ARG *
+op_new(numargs)
+int numargs;
+{
+ register ARG *arg;
+
+ arg = (ARG*)safemalloc((numargs + 1) * sizeof (ARG));
+ bzero((char *)arg, (numargs + 1) * sizeof (ARG));
+ arg->arg_ptr.arg_str = str_new(0);
+ arg->arg_len = numargs;
+ return arg;
+}
+
+void
+free_arg(arg)
+ARG *arg;
+{
+ str_free(arg->arg_ptr.arg_str);
+ safefree((char*)arg);
+}
+
+ARG *
+make_match(type,expr,spat)
+int type;
+ARG *expr;
+SPAT *spat;
+{
+ register ARG *arg;
+
+ arg = make_op(type,2,expr,Nullarg,Nullarg,0);
+
+ arg[2].arg_type = A_SPAT;
+ arg[2].arg_ptr.arg_spat = spat;
+#ifdef DEBUGGING
+ if (debug & 16)
+ fprintf(stderr,"make_match SPAT=%lx\n",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;
+}
+
+CMD *
+wopt(cmd)
+register CMD *cmd;
+{
+ register CMD *tail;
+ register ARG *arg = cmd->c_expr;
+ char *tmps; /* used by True macro */
+
+ /* 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 (arg[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV) {
+ cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */
+ stab_to_arg(A_LVAL,defstab), arg, Nullarg,1 ));
+ }
+ else {
+ free_arg(arg);
+ cmd->c_expr = Nullarg;
+ }
+ }
+
+ /* First find the end of the true list */
+
+ if (cmd->ucmd.ccmd.cc_true == Nullcmd)
+ return cmd;
+ for (tail = cmd->ucmd.ccmd.cc_true; tail->c_next; 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;
+ 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 = (CMD *) safemalloc(sizeof (CMD));
+ tail = tail->c_next;
+ if (!cmd->ucmd.ccmd.cc_alt)
+ cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */
+
+ bcopy((char *)cmd, (char *)tail, sizeof(CMD));
+ 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,0);
+ tail->ucmd.acmd.ac_stab = Nullstab;
+ return cmd;
+}
+
+FCMD *
+load_format()
+{
+ FCMD froot;
+ FCMD *flinebeg;
+ register FCMD *fprev = &froot;
+ register FCMD *fcmd;
+ register char *s;
+ register char *t;
+ register char tmpchar;
+ bool noblank;
+
+ while ((s = str_gets(linestr,rsfp)) != Nullch) {
+ line++;
+ if (strEQ(s,".\n")) {
+ bufptr = s;
+ return froot.f_next;
+ }
+ if (*s == '#')
+ continue;
+ flinebeg = Nullfcmd;
+ noblank = FALSE;
+ while (*s) {
+ fcmd = (FCMD *)safemalloc(sizeof (FCMD));
+ bzero((char*)fcmd, sizeof (FCMD));
+ fprev->f_next = fcmd;
+ fprev = fcmd;
+ for (t=s; *t && *t != '@' && *t != '^'; t++) {
+ if (*t == '~') {
+ noblank = TRUE;
+ *t = ' ';
+ }
+ }
+ tmpchar = *t;
+ *t = '\0';
+ fcmd->f_pre = savestr(s);
+ fcmd->f_presize = strlen(s);
+ *t = tmpchar;
+ s = t;
+ if (!*s) {
+ if (noblank)
+ fcmd->f_flags |= FC_NOBLANK;
+ 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;
+ default:
+ 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 ((bufptr = str_gets(linestr ,rsfp)) == Nullch)
+ goto badform;
+ line++;
+ if (strEQ(bufptr,".\n")) {
+ yyerror("Missing values line");
+ return froot.f_next;
+ }
+ if (*bufptr == '#')
+ goto again;
+ lex_newlines = TRUE;
+ while (flinebeg || *bufptr) {
+ switch(yylex()) {
+ default:
+ yyerror("Bad value in format");
+ *bufptr = '\0';
+ break;
+ case '\n':
+ if (flinebeg)
+ yyerror("Missing value in format");
+ *bufptr = '\0';
+ break;
+ case REG:
+ yylval.arg = stab_to_arg(A_LVAL,yylval.stabval);
+ /* FALL THROUGH */
+ case RSTRING:
+ if (!flinebeg)
+ yyerror("Extra value in format");
+ else {
+ flinebeg->f_expr = yylval.arg;
+ do {
+ flinebeg = flinebeg->f_next;
+ } while (flinebeg && flinebeg->f_size == 0);
+ }
+ break;
+ case ',': case ';':
+ continue;
+ }
+ }
+ lex_newlines = FALSE;
+ }
+ }
+ badform:
+ bufptr = str_get(linestr);
+ yyerror("Format not terminated");
+ return froot.f_next;
+}
--- /dev/null
+/* $Header: search.c,v 1.0 87/12/18 13:05:59 root Exp $
+ *
+ * $Log: search.c,v $
+ * Revision 1.0 87/12/18 13:05:59 root
+ * Initial revision
+ *
+ */
+
+/* string search routines */
+
+#include <stdio.h>
+#include <ctype.h>
+
+#include "EXTERN.h"
+#include "handy.h"
+#include "util.h"
+#include "INTERN.h"
+#include "search.h"
+
+#define VERBOSE
+#define FLUSH
+#define MEM_SIZE int
+
+#ifndef BITSPERBYTE
+#define BITSPERBYTE 8
+#endif
+
+#define BMAPSIZ (127 / BITSPERBYTE + 1)
+
+#define CHAR 0 /* a normal character */
+#define ANY 1 /* . matches anything except newline */
+#define CCL 2 /* [..] character class */
+#define NCCL 3 /* [^..]negated character class */
+#define BEG 4 /* ^ beginning of a line */
+#define END 5 /* $ end of a line */
+#define LPAR 6 /* ( begin sub-match */
+#define RPAR 7 /* ) end sub-match */
+#define REF 8 /* \N backreference to the Nth submatch */
+#define WORD 9 /* \w matches alphanumeric character */
+#define NWORD 10 /* \W matches non-alphanumeric character */
+#define WBOUND 11 /* \b matches word boundary */
+#define NWBOUND 12 /* \B matches non-boundary */
+#define FINIS 13 /* the end of the pattern */
+
+#define CODEMASK 15
+
+/* Quantifiers: */
+
+#define MINZERO 16 /* minimum is 0, not 1 */
+#define MAXINF 32 /* maximum is infinity, not 1 */
+
+#define ASCSIZ 0200
+typedef char TRANSTABLE[ASCSIZ];
+
+static TRANSTABLE trans = {
+0000,0001,0002,0003,0004,0005,0006,0007,
+0010,0011,0012,0013,0014,0015,0016,0017,
+0020,0021,0022,0023,0024,0025,0026,0027,
+0030,0031,0032,0033,0034,0035,0036,0037,
+0040,0041,0042,0043,0044,0045,0046,0047,
+0050,0051,0052,0053,0054,0055,0056,0057,
+0060,0061,0062,0063,0064,0065,0066,0067,
+0070,0071,0072,0073,0074,0075,0076,0077,
+0100,0101,0102,0103,0104,0105,0106,0107,
+0110,0111,0112,0113,0114,0115,0116,0117,
+0120,0121,0122,0123,0124,0125,0126,0127,
+0130,0131,0132,0133,0134,0135,0136,0137,
+0140,0141,0142,0143,0144,0145,0146,0147,
+0150,0151,0152,0153,0154,0155,0156,0157,
+0160,0161,0162,0163,0164,0165,0166,0167,
+0170,0171,0172,0173,0174,0175,0176,0177,
+};
+static bool folding = FALSE;
+
+static int err;
+#define NOERR 0
+#define BEGFAIL 1
+#define FATAL 2
+
+static char *FirstCharacter;
+static char *matchend;
+static char *matchtill;
+
+void
+search_init()
+{
+#ifdef UNDEF
+ register int i;
+
+ for (i = 0; i < ASCSIZ; i++)
+ trans[i] = i;
+#else
+ ;
+#endif
+}
+
+void
+init_compex(compex)
+register COMPEX *compex;
+{
+ /* the following must start off zeroed */
+
+ compex->precomp = Nullch;
+ compex->complen = 0;
+ compex->subbase = Nullch;
+}
+
+#ifdef NOTUSED
+void
+free_compex(compex)
+register COMPEX *compex;
+{
+ if (compex->complen) {
+ safefree(compex->compbuf);
+ compex->complen = 0;
+ }
+ if (compex->subbase) {
+ safefree(compex->subbase);
+ compex->subbase = Nullch;
+ }
+}
+#endif
+
+static char *gbr_str = Nullch;
+static int gbr_siz = 0;
+
+char *
+getparen(compex,n)
+register COMPEX *compex;
+int n;
+{
+ int length = compex->subend[n] - compex->subbeg[n];
+
+ if (!n &&
+ (!compex->numsubs || n > compex->numsubs || !compex->subend[n] || length<0))
+ return "";
+ growstr(&gbr_str, &gbr_siz, length+1);
+ safecpy(gbr_str, compex->subbeg[n], length+1);
+ return gbr_str;
+}
+
+void
+case_fold(which)
+int which;
+{
+ register int i;
+
+ if (which != folding) {
+ if (which) {
+ for (i = 'A'; i <= 'Z'; i++)
+ trans[i] = tolower(i);
+ }
+ else {
+ for (i = 'A'; i <= 'Z'; i++)
+ trans[i] = i;
+ }
+ folding = which;
+ }
+}
+
+/* Compile the regular expression into internal form */
+
+char *
+compile(compex, sp, regex, fold)
+register COMPEX *compex;
+register char *sp;
+int regex;
+int fold;
+{
+ register int c;
+ register char *cp;
+ char *lastcp;
+ char paren[MAXSUB],
+ *parenp;
+ char **alt = compex->alternatives;
+ char *retmes = "Badly formed search string";
+
+ case_fold(compex->do_folding = fold);
+ if (compex->precomp)
+ safefree(compex->precomp);
+ compex->precomp = savestr(sp);
+ if (!compex->complen) {
+ compex->compbuf = safemalloc(84);
+ compex->complen = 80;
+ }
+ cp = compex->compbuf; /* point at compiled buffer */
+ *alt++ = cp; /* first alternative starts here */
+ parenp = paren; /* first paren goes here */
+ if (*sp == 0) { /* nothing to compile? */
+#ifdef NOTDEF
+ if (*cp == 0) /* nothing there yet? */
+ return "Null search string";
+#endif
+ if (*cp)
+ return Nullch; /* just keep old expression */
+ }
+ compex->numsubs = 0; /* no parens yet */
+ lastcp = 0;
+ for (;;) {
+ if (cp - compex->compbuf >= compex->complen) {
+ char *ocompbuf = compex->compbuf;
+
+ grow_comp(compex);
+ if (ocompbuf != compex->compbuf) { /* adjust pointers? */
+ char **tmpalt;
+
+ cp = compex->compbuf + (cp - ocompbuf);
+ if (lastcp)
+ lastcp = compex->compbuf + (lastcp - ocompbuf);
+ for (tmpalt = compex->alternatives; tmpalt < alt; tmpalt++)
+ if (*tmpalt)
+ *tmpalt = compex->compbuf + (*tmpalt - ocompbuf);
+ }
+ }
+ c = *sp++; /* get next char of pattern */
+ if (c == 0) { /* end of pattern? */
+ if (parenp != paren) { /* balanced parentheses? */
+#ifdef VERBOSE
+ retmes = "Missing right parenthesis";
+#endif
+ goto badcomp;
+ }
+ *cp++ = FINIS; /* append a stopper */
+ *alt++ = 0; /* terminate alternative list */
+ /*
+ compex->complen = cp - compex->compbuf + 1;
+ compex->compbuf = saferealloc(compex->compbuf,compex->complen+4); */
+ return Nullch; /* return success */
+ }
+ if (c != '*' && c != '?' && c != '+')
+ lastcp = cp;
+ if (!regex) { /* just a normal search string? */
+ *cp++ = CHAR; /* everything is a normal char */
+ *cp++ = trans[c];
+ }
+ else /* it is a regular expression */
+ switch (c) {
+
+ default:
+ normal_char:
+ *cp++ = CHAR;
+ *cp++ = trans[c];
+ continue;
+
+ case '.':
+ *cp++ = ANY;
+ continue;
+
+ case '[': { /* character class */
+ register int i;
+
+ if (cp - compex->compbuf >= compex->complen - BMAPSIZ) {
+ char *ocompbuf = compex->compbuf;
+
+ grow_comp(compex); /* reserve bitmap */
+ if (ocompbuf != compex->compbuf) {/* adjust pointers? */
+ char **tmpalt;
+
+ cp = compex->compbuf + (cp - ocompbuf);
+ if (lastcp)
+ lastcp = compex->compbuf + (lastcp - ocompbuf);
+ for (tmpalt = compex->alternatives; tmpalt < alt;
+ tmpalt++)
+ if (*tmpalt)
+ *tmpalt =
+ compex->compbuf + (*tmpalt - ocompbuf);
+ }
+ }
+ for (i = BMAPSIZ; i; --i)
+ cp[i] = 0;
+
+ if ((c = *sp++) == '^') {
+ c = *sp++;
+ *cp++ = NCCL; /* negated */
+ }
+ else
+ *cp++ = CCL; /* normal */
+
+ i = 0; /* remember oldchar */
+ do {
+ if (c == '\0') {
+#ifdef VERBOSE
+ retmes = "Missing ]";
+#endif
+ goto badcomp;
+ }
+ if (c == '\\' && *sp) {
+ switch (*sp) {
+ default:
+ c = *sp++;
+ break;
+ case '0': case '1': case '2': case '3':
+ case '4': case '5': case '6': case '7':
+ c = *sp++ - '0';
+ if (index("01234567",*sp)) {
+ c <<= 3;
+ c += *sp++ - '0';
+ }
+ if (index("01234567",*sp)) {
+ c <<= 3;
+ c += *sp++ - '0';
+ }
+ break;
+ case 'b':
+ c = '\b';
+ sp++;
+ break;
+ case 'n':
+ c = '\n';
+ sp++;
+ break;
+ case 'r':
+ c = '\r';
+ sp++;
+ break;
+ case 'f':
+ c = '\f';
+ sp++;
+ break;
+ case 't':
+ c = '\t';
+ sp++;
+ break;
+ }
+ }
+ if (*sp == '-' && *(++sp))
+ i = *sp++;
+ else
+ i = c;
+ while (c <= i) {
+ cp[c / BITSPERBYTE] |= 1 << (c % BITSPERBYTE);
+ if (fold && isalpha(c))
+ cp[(c ^ 32) / BITSPERBYTE] |=
+ 1 << ((c ^ 32) % BITSPERBYTE);
+ /* set the other bit too */
+ c++;
+ }
+ } while ((c = *sp++) != ']');
+ if (cp[-1] == NCCL)
+ cp[0] |= 1;
+ cp += BMAPSIZ;
+ continue;
+ }
+
+ case '^':
+ if (cp != compex->compbuf && cp[-1] != FINIS)
+ goto normal_char;
+ *cp++ = BEG;
+ continue;
+
+ case '$':
+ if (isdigit(*sp)) {
+ *cp++ = REF;
+ *cp++ = *sp - '0';
+ break;
+ }
+ if (*sp && *sp != '|')
+ goto normal_char;
+ *cp++ = END;
+ continue;
+
+ case '*': case '?': case '+':
+ if (lastcp == 0 ||
+ (*lastcp & (MINZERO|MAXINF)) ||
+ *lastcp == LPAR ||
+ *lastcp == RPAR ||
+ *lastcp == BEG ||
+ *lastcp == END ||
+ *lastcp == WBOUND ||
+ *lastcp == NWBOUND )
+ goto normal_char;
+ if (c != '+')
+ *lastcp |= MINZERO;
+ if (c != '?')
+ *lastcp |= MAXINF;
+ continue;
+
+ case '(':
+ if (compex->numsubs >= MAXSUB) {
+#ifdef VERBOSE
+ retmes = "Too many parens";
+#endif
+ goto badcomp;
+ }
+ *parenp++ = ++compex->numsubs;
+ *cp++ = LPAR;
+ *cp++ = compex->numsubs;
+ break;
+ case ')':
+ if (parenp <= paren) {
+#ifdef VERBOSE
+ retmes = "Unmatched right paren";
+#endif
+ goto badcomp;
+ }
+ *cp++ = RPAR;
+ *cp++ = *--parenp;
+ break;
+ case '|':
+ if (parenp>paren) {
+#ifdef VERBOSE
+ retmes = "No | in subpattern"; /* Sigh! */
+#endif
+ goto badcomp;
+ }
+ *cp++ = FINIS;
+ if (alt - compex->alternatives >= MAXALT) {
+#ifdef VERBOSE
+ retmes = "Too many alternatives";
+#endif
+ goto badcomp;
+ }
+ *alt++ = cp;
+ break;
+ case '\\': /* backslashed thingie */
+ switch (c = *sp++) {
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ *cp++ = REF;
+ *cp++ = c - '0';
+ break;
+ case 'w':
+ *cp++ = WORD;
+ break;
+ case 'W':
+ *cp++ = NWORD;
+ break;
+ case 'b':
+ *cp++ = WBOUND;
+ break;
+ case 'B':
+ *cp++ = NWBOUND;
+ break;
+ default:
+ *cp++ = CHAR;
+ if (c == '\0')
+ goto badcomp;
+ switch (c) {
+ case 'n':
+ c = '\n';
+ break;
+ case 'r':
+ c = '\r';
+ break;
+ case 'f':
+ c = '\f';
+ break;
+ case 't':
+ c = '\t';
+ break;
+ }
+ *cp++ = c;
+ break;
+ }
+ break;
+ }
+ }
+badcomp:
+ compex->compbuf[0] = 0;
+ compex->numsubs = 0;
+ return retmes;
+}
+
+void
+grow_comp(compex)
+register COMPEX *compex;
+{
+ compex->complen += 80;
+ compex->compbuf = saferealloc(compex->compbuf, (MEM_SIZE)compex->complen + 4);
+}
+
+char *
+execute(compex, addr, beginning, minend)
+register COMPEX *compex;
+char *addr;
+bool beginning;
+int minend;
+{
+ register char *p1 = addr;
+ register char *trt = trans;
+ register int c;
+ register int scr;
+ register int c2;
+
+ if (addr == Nullch)
+ return Nullch;
+ if (compex->numsubs) { /* any submatches? */
+ for (c = 0; c <= compex->numsubs; c++)
+ compex->subbeg[c] = compex->subend[c] = Nullch;
+ }
+ case_fold(compex->do_folding); /* make sure table is correct */
+ if (beginning)
+ FirstCharacter = p1; /* for ^ tests */
+ else {
+ if (multiline || compex->alternatives[1] || compex->compbuf[0] != BEG)
+ FirstCharacter = Nullch;
+ else
+ return Nullch; /* can't match */
+ }
+ matchend = Nullch;
+ matchtill = addr + minend;
+ err = 0;
+ if (compex->compbuf[0] == CHAR && !compex->alternatives[1]) {
+ if (compex->do_folding) {
+ c = compex->compbuf[1]; /* fast check for first character */
+ do {
+ if (trt[*p1] == c && try(compex, p1, compex->compbuf))
+ goto got_it;
+ } while (*p1++ && !err);
+ }
+ else {
+ c = compex->compbuf[1]; /* faster check for first character */
+ if (compex->compbuf[2] == CHAR)
+ c2 = compex->compbuf[3];
+ else
+ c2 = 0;
+ do {
+ false_alarm:
+ while (scr = *p1++, scr && scr != c) ;
+ if (!scr)
+ break;
+ if (c2 && *p1 != c2) /* and maybe even second character */
+ goto false_alarm;
+ if (try(compex, p1, compex->compbuf+2)) {
+ p1--;
+ goto got_it;
+ }
+ } while (!err);
+ }
+ return Nullch;
+ }
+ else { /* normal algorithm */
+ do {
+ register char **alt = compex->alternatives;
+ while (*alt) {
+ if (try(compex, p1, *alt++))
+ goto got_it;
+ }
+ } while (*p1++ && err < FATAL);
+ return Nullch;
+ }
+
+got_it:
+ if (compex->numsubs) { /* any parens? */
+ trt = savestr(addr); /* in case addr is not static */
+ if (compex->subbase)
+ safefree(compex->subbase); /* (may be freeing addr!) */
+ compex->subbase = trt;
+ scr = compex->subbase - addr;
+ p1 += scr;
+ matchend += scr;
+ for (c = 0; c <= compex->numsubs; c++) {
+ if (compex->subend[c]) {
+ compex->subbeg[c] += scr;
+ compex->subend[c] += scr;
+ }
+ }
+ }
+ compex->subend[0] = matchend;
+ compex->subbeg[0] = p1;
+ return p1;
+}
+
+bool
+try(compex, sp, cp)
+COMPEX *compex;
+register char *cp;
+register char *sp;
+{
+ register char *basesp;
+ register char *trt = trans;
+ register int i;
+ register int backlen;
+ register int code;
+
+ while (*sp || (*cp & MAXINF) || *cp == BEG || *cp == RPAR ||
+ *cp == WBOUND || *cp == NWBOUND) {
+ switch ((code = *cp++) & CODEMASK) {
+
+ case CHAR:
+ basesp = sp;
+ i = *cp++;
+ if (code & MAXINF)
+ while (*sp && trt[*sp] == i) sp++;
+ else
+ if (*sp && trt[*sp] == i) sp++;
+ backlen = 1;
+ goto backoff;
+
+ backoff:
+ while (sp > basesp) {
+ if (try(compex, sp, cp))
+ goto right;
+ sp -= backlen;
+ }
+ if (code & MINZERO)
+ continue;
+ goto wrong;
+
+ case ANY:
+ basesp = sp;
+ if (code & MAXINF)
+ while (*sp && *sp != '\n') sp++;
+ else
+ if (*sp && *sp != '\n') sp++;
+ backlen = 1;
+ goto backoff;
+
+ case CCL:
+ basesp = sp;
+ if (code & MAXINF)
+ while (*sp && cclass(cp, *sp, 1)) sp++;
+ else
+ if (*sp && cclass(cp, *sp, 1)) sp++;
+ cp += BMAPSIZ;
+ backlen = 1;
+ goto backoff;
+
+ case NCCL:
+ basesp = sp;
+ if (code & MAXINF)
+ while (*sp && cclass(cp, *sp, 0)) sp++;
+ else
+ if (*sp && cclass(cp, *sp, 0)) sp++;
+ cp += BMAPSIZ;
+ backlen = 1;
+ goto backoff;
+
+ case END:
+ if (!*sp || *sp == '\n') {
+ matchtill--;
+ continue;
+ }
+ goto wrong;
+
+ case BEG:
+ if (sp == FirstCharacter || (
+ *sp && sp[-1] == '\n') ) {
+ matchtill--;
+ continue;
+ }
+ if (!multiline) /* no point in advancing more */
+ err = BEGFAIL;
+ goto wrong;
+
+ case WORD:
+ basesp = sp;
+ if (code & MAXINF)
+ while (*sp && isalnum(*sp)) sp++;
+ else
+ if (*sp && isalnum(*sp)) sp++;
+ backlen = 1;
+ goto backoff;
+
+ case NWORD:
+ basesp = sp;
+ if (code & MAXINF)
+ while (*sp && !isalnum(*sp)) sp++;
+ else
+ if (*sp && !isalnum(*sp)) sp++;
+ backlen = 1;
+ goto backoff;
+
+ case WBOUND:
+ if ((sp == FirstCharacter || !isalnum(sp[-1])) !=
+ (!*sp || !isalnum(*sp)) )
+ continue;
+ goto wrong;
+
+ case NWBOUND:
+ if ((sp == FirstCharacter || !isalnum(sp[-1])) ==
+ (!*sp || !isalnum(*sp)))
+ continue;
+ goto wrong;
+
+ case FINIS:
+ goto right;
+
+ case LPAR:
+ compex->subbeg[*cp++] = sp;
+ continue;
+
+ case RPAR:
+ i = *cp++;
+ compex->subend[i] = sp;
+ compex->lastparen = i;
+ continue;
+
+ case REF:
+ if (compex->subend[i = *cp++] == 0) {
+ fputs("Bad subpattern reference\n",stdout) FLUSH;
+ err = FATAL;
+ goto wrong;
+ }
+ basesp = sp;
+ backlen = compex->subend[i] - compex->subbeg[i];
+ if (code & MAXINF)
+ while (*sp && subpat(compex, i, sp)) sp += backlen;
+ else
+ if (*sp && subpat(compex, i, sp)) sp += backlen;
+ goto backoff;
+
+ default:
+ fputs("Botched pattern compilation\n",stdout) FLUSH;
+ err = FATAL;
+ return -1;
+ }
+ }
+ if (*cp == FINIS || *cp == END) {
+right:
+ if (matchend == Nullch || sp > matchend)
+ matchend = sp;
+ return matchend >= matchtill;
+ }
+wrong:
+ matchend = Nullch;
+ return FALSE;
+}
+
+bool
+subpat(compex, i, sp)
+register COMPEX *compex;
+register int i;
+register char *sp;
+{
+ register char *bp;
+
+ bp = compex->subbeg[i];
+ while (*sp && *bp == *sp) {
+ bp++;
+ sp++;
+ if (bp >= compex->subend[i])
+ return TRUE;
+ }
+ return FALSE;
+}
+
+bool
+cclass(set, c, af)
+register char *set;
+register int c;
+{
+ c &= 0177;
+#if BITSPERBYTE == 8
+ if (set[c >> 3] & 1 << (c & 7))
+#else
+ if (set[c / BITSPERBYTE] & 1 << (c % BITSPERBYTE))
+#endif
+ return af;
+ return !af;
+}
--- /dev/null
+/* $Header: search.h,v 1.0 87/12/18 13:06:06 root Exp $
+ *
+ * $Log: search.h,v $
+ * Revision 1.0 87/12/18 13:06:06 root
+ * Initial revision
+ *
+ */
+
+#ifndef MAXSUB
+#define MAXSUB 10 /* how many sub-patterns are allowed */
+#define MAXALT 10 /* how many alternatives are allowed */
+
+typedef struct {
+ char *precomp; /* the original pattern, for debug output */
+ char *compbuf; /* the compiled pattern */
+ int complen; /* length of compbuf */
+ char *alternatives[MAXALT]; /* list of alternatives */
+ char *subbeg[MAXSUB]; /* subpattern start list */
+ char *subend[MAXSUB]; /* subpattern end list */
+ char *subbase; /* saved match string after execute() */
+ char lastparen; /* which subpattern matched last */
+ char numsubs; /* how many subpatterns the compiler saw */
+ bool do_folding; /* fold upper and lower case? */
+} COMPEX;
+
+EXT int multiline INIT(0);
+
+void search_init();
+void init_compex();
+void free_compex();
+char *getparen();
+void case_fold();
+char *compile();
+void grow_comp();
+char *execute();
+bool try();
+bool subpat();
+bool cclass();
+#endif
--- /dev/null
+/* $Header: spat.h,v 1.0 87/12/18 13:06:10 root Exp $
+ *
+ * $Log: spat.h,v $
+ * Revision 1.0 87/12/18 13:06:10 root
+ * Initial revision
+ *
+ */
+
+struct scanpat {
+ SPAT *spat_next; /* list of all scanpats */
+ COMPEX spat_compex; /* compiled expression */
+ ARG *spat_repl; /* replacement string for subst */
+ ARG *spat_runtime; /* compile pattern at runtime */
+ STR *spat_first; /* for a fast bypass of execute() */
+ bool spat_flags;
+ char spat_flen;
+};
+
+#define SPAT_USED 1 /* spat has been used once already */
+#define SPAT_USE_ONCE 2 /* use pattern only once per article */
+#define SPAT_SCANFIRST 4 /* initial constant not anchored */
+#define SPAT_SCANALL 8 /* initial constant is whole pat */
+
+EXT SPAT *spat_root; /* list of all spats */
+EXT SPAT *curspat; /* what to do \ interps from */
+
+#define Nullspat Null(SPAT*)
--- /dev/null
+/* $Header: stab.c,v 1.0 87/12/18 13:06:14 root Exp $
+ *
+ * $Log: stab.c,v $
+ * Revision 1.0 87/12/18 13:06:14 root
+ * Initial revision
+ *
+ */
+
+#include <signal.h>
+#include "handy.h"
+#include "EXTERN.h"
+#include "search.h"
+#include "util.h"
+#include "perl.h"
+
+static char *sig_name[] = {
+ "",
+ "HUP",
+ "INT",
+ "QUIT",
+ "ILL",
+ "TRAP",
+ "IOT",
+ "EMT",
+ "FPE",
+ "KILL",
+ "BUS",
+ "SEGV",
+ "SYS",
+ "PIPE",
+ "ALRM",
+ "TERM",
+ "???"
+#ifdef SIGTSTP
+ ,"STOP",
+ "TSTP",
+ "CONT",
+ "CHLD",
+ "TTIN",
+ "TTOU",
+ "TINT",
+ "XCPU",
+ "XFSZ"
+#ifdef SIGPROF
+ ,"VTALARM",
+ "PROF"
+#ifdef SIGWINCH
+ ,"WINCH"
+#ifdef SIGLOST
+ ,"LOST"
+#ifdef SIGUSR1
+ ,"USR1"
+#endif
+#ifdef SIGUSR2
+ ,"USR2"
+#endif /* SIGUSR2 */
+#endif /* SIGLOST */
+#endif /* SIGWINCH */
+#endif /* SIGPROF */
+#endif /* SIGTSTP */
+ ,0
+ };
+
+STR *
+stab_str(stab)
+STAB *stab;
+{
+ register int paren;
+ register char *s;
+ extern int errno;
+
+ switch (*stab->stab_name) {
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': case '&':
+ if (curspat) {
+ paren = atoi(stab->stab_name);
+ if (curspat->spat_compex.subend[paren] &&
+ (s = getparen(&curspat->spat_compex,paren))) {
+ curspat->spat_compex.subend[paren] = Nullch;
+ str_set(stab->stab_val,s);
+ }
+ }
+ break;
+ case '+':
+ if (curspat) {
+ paren = curspat->spat_compex.lastparen;
+ if (curspat->spat_compex.subend[paren] &&
+ (s = getparen(&curspat->spat_compex,paren))) {
+ curspat->spat_compex.subend[paren] = Nullch;
+ str_set(stab->stab_val,s);
+ }
+ }
+ break;
+ case '.':
+ if (last_in_stab) {
+ str_numset(stab->stab_val,(double)last_in_stab->stab_io->lines);
+ }
+ break;
+ case '?':
+ str_numset(stab->stab_val,(double)statusvalue);
+ break;
+ case '^':
+ s = curoutstab->stab_io->top_name;
+ str_set(stab->stab_val,s);
+ break;
+ case '~':
+ s = curoutstab->stab_io->fmt_name;
+ str_set(stab->stab_val,s);
+ break;
+ case '=':
+ str_numset(stab->stab_val,(double)curoutstab->stab_io->lines);
+ break;
+ case '-':
+ str_numset(stab->stab_val,(double)curoutstab->stab_io->lines_left);
+ break;
+ case '%':
+ str_numset(stab->stab_val,(double)curoutstab->stab_io->page);
+ break;
+ case '(':
+ if (curspat) {
+ str_numset(stab->stab_val,(double)(curspat->spat_compex.subbeg[0] -
+ curspat->spat_compex.subbase));
+ }
+ break;
+ case ')':
+ if (curspat) {
+ str_numset(stab->stab_val,(double)(curspat->spat_compex.subend[0] -
+ curspat->spat_compex.subbeg[0]));
+ }
+ break;
+ case '/':
+ *tokenbuf = record_separator;
+ tokenbuf[1] = '\0';
+ str_set(stab->stab_val,tokenbuf);
+ break;
+ case '[':
+ str_numset(stab->stab_val,(double)arybase);
+ break;
+ case '|':
+ str_numset(stab->stab_val,
+ (double)((curoutstab->stab_io->flags & IOF_FLUSH) != 0) );
+ break;
+ case ',':
+ str_set(stab->stab_val,ofs);
+ break;
+ case '\\':
+ str_set(stab->stab_val,ors);
+ break;
+ case '#':
+ str_set(stab->stab_val,ofmt);
+ break;
+ case '!':
+ str_numset(stab->stab_val,(double)errno);
+ break;
+ }
+ return stab->stab_val;
+}
+
+stabset(stab,str)
+register STAB *stab;
+STR *str;
+{
+ char *s;
+ int i;
+ int sighandler();
+
+ if (stab->stab_flags & SF_VMAGIC) {
+ switch (stab->stab_name[0]) {
+ case '^':
+ safefree(curoutstab->stab_io->top_name);
+ curoutstab->stab_io->top_name = str_get(str);
+ curoutstab->stab_io->top_stab = stabent(str_get(str),FALSE);
+ break;
+ case '~':
+ safefree(curoutstab->stab_io->fmt_name);
+ curoutstab->stab_io->fmt_name = str_get(str);
+ curoutstab->stab_io->fmt_stab = stabent(str_get(str),FALSE);
+ break;
+ case '=':
+ curoutstab->stab_io->page_len = (long)str_gnum(str);
+ break;
+ case '-':
+ curoutstab->stab_io->lines_left = (long)str_gnum(str);
+ break;
+ case '%':
+ curoutstab->stab_io->page = (long)str_gnum(str);
+ break;
+ case '|':
+ curoutstab->stab_io->flags &= ~IOF_FLUSH;
+ if (str_gnum(str) != 0.0) {
+ curoutstab->stab_io->flags |= IOF_FLUSH;
+ }
+ break;
+ case '*':
+ multiline = (int)str_gnum(str) != 0;
+ break;
+ case '/':
+ record_separator = *str_get(str);
+ break;
+ case '\\':
+ if (ors)
+ safefree(ors);
+ ors = savestr(str_get(str));
+ break;
+ case ',':
+ if (ofs)
+ safefree(ofs);
+ ofs = savestr(str_get(str));
+ break;
+ case '#':
+ if (ofmt)
+ safefree(ofmt);
+ ofmt = savestr(str_get(str));
+ break;
+ case '[':
+ arybase = (int)str_gnum(str);
+ break;
+ case '!':
+ errno = (int)str_gnum(str); /* will anyone ever use this? */
+ break;
+ case '.':
+ case '+':
+ case '&':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case '(':
+ case ')':
+ break; /* "read-only" registers */
+ }
+ }
+ else if (stab == envstab && envname) {
+ setenv(envname,str_get(str));
+ /* And you'll never guess what the dog had */
+ safefree(envname); /* in its mouth... */
+ envname = Nullch;
+ }
+ else if (stab == sigstab && signame) {
+ s = str_get(str);
+ i = whichsig(signame); /* ...no, a brick */
+ if (strEQ(s,"IGNORE"))
+ signal(i,SIG_IGN);
+ else if (strEQ(s,"DEFAULT") || !*s)
+ signal(i,SIG_DFL);
+ else
+ signal(i,sighandler);
+ safefree(signame);
+ signame = Nullch;
+ }
+}
+
+whichsig(signame)
+char *signame;
+{
+ register char **sigv;
+
+ for (sigv = sig_name+1; *sigv; sigv++)
+ if (strEQ(signame,*sigv))
+ return sigv - sig_name;
+ return 0;
+}
+
+sighandler(sig)
+int sig;
+{
+ STAB *stab;
+ ARRAY *savearray;
+ STR *str;
+
+ stab = stabent(str_get(hfetch(sigstab->stab_hash,sig_name[sig])),FALSE);
+ savearray = defstab->stab_array;
+ defstab->stab_array = anew();
+ str = str_new(0);
+ str_set(str,sig_name[sig]);
+ apush(defstab->stab_array,str);
+ str = cmd_exec(stab->stab_sub);
+ afree(defstab->stab_array); /* put back old $_[] */
+ defstab->stab_array = savearray;
+}
+
+char *
+reg_get(name)
+char *name;
+{
+ return STAB_GET(stabent(name,TRUE));
+}
+
+#ifdef NOTUSED
+reg_set(name,value)
+char *name;
+char *value;
+{
+ str_set(STAB_STR(stabent(name,TRUE)),value);
+}
+#endif
+
+STAB *
+aadd(stab)
+register STAB *stab;
+{
+ if (!stab->stab_array)
+ stab->stab_array = anew();
+ return stab;
+}
+
+STAB *
+hadd(stab)
+register STAB *stab;
+{
+ if (!stab->stab_hash)
+ stab->stab_hash = hnew();
+ return stab;
+}
--- /dev/null
+/* $Header: stab.h,v 1.0 87/12/18 13:06:18 root Exp $
+ *
+ * $Log: stab.h,v $
+ * Revision 1.0 87/12/18 13:06:18 root
+ * Initial revision
+ *
+ */
+
+struct stab {
+ struct stab *stab_next;
+ char *stab_name;
+ STR *stab_val;
+ struct stio *stab_io;
+ FCMD *stab_form;
+ ARRAY *stab_array;
+ HASH *stab_hash;
+ CMD *stab_sub;
+ char stab_flags;
+};
+
+#define SF_VMAGIC 1 /* call routine to dereference STR val */
+
+struct stio {
+ FILE *fp;
+ long lines;
+ long page;
+ long page_len;
+ long lines_left;
+ char *top_name;
+ STAB *top_stab;
+ char *fmt_name;
+ STAB *fmt_stab;
+ 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 */
+
+#define Nullstab Null(STAB*)
+
+#define STAB_STR(s) (tmpstab = (s), tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val)
+#define STAB_GET(s) (tmpstab = (s), str_get(tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val))
+#define STAB_GNUM(s) (tmpstab = (s), str_gnum(tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val))
+
+EXT STAB *tmpstab;
+
+EXT STAB *stab_index[128];
+
+EXT char *envname; /* place for ENV name being assigned--gross cheat */
+EXT char *signame; /* place for SIG name being assigned--gross cheat */
+
+EXT int statusvalue;
+EXT int subsvalue;
+
+STAB *aadd();
+STAB *hadd();
--- /dev/null
+/* $Header: str.c,v 1.0 87/12/18 13:06:22 root Exp $
+ *
+ * $Log: str.c,v $
+ * Revision 1.0 87/12/18 13:06:22 root
+ * Initial revision
+ *
+ */
+
+#include "handy.h"
+#include "EXTERN.h"
+#include "search.h"
+#include "util.h"
+#include "perl.h"
+
+str_reset(s)
+register char *s;
+{
+ register STAB *stab;
+ register STR *str;
+ register int i;
+ register int max;
+ register SPAT *spat;
+
+ if (!*s) { /* reset ?? searches */
+ for (spat = spat_root; spat != Nullspat; spat = spat->spat_next) {
+ spat->spat_flags &= ~SPAT_USED;
+ }
+ return;
+ }
+
+ /* reset variables */
+
+ while (*s) {
+ i = *s;
+ if (s[1] == '-') {
+ s += 2;
+ }
+ max = *s++;
+ for ( ; i <= max; i++) {
+ for (stab = stab_index[i]; stab; stab = stab->stab_next) {
+ str = stab->stab_val;
+ str->str_cur = 0;
+ if (str->str_ptr != Nullch)
+ str->str_ptr[0] = '\0';
+ }
+ }
+ }
+}
+
+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;
+ str->str_link.str_magic = Nullstab;
+ }
+ 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 char *ptr; /* in the innermost loop into registers */
+ register char newline = record_separator; /* (assuming >= 6 registers) */
+ int i;
+ int bpx;
+ int obpx;
+ register int get_paragraph;
+ register char *oldbp;
+
+ if (get_paragraph = !newline) { /* yes, that's an assignment */
+ newline = '\n';
+ oldbp = Nullch; /* remember last \n position (none) */
+ }
+ 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 (;;) {
+ screamer:
+ while (--cnt >= 0) { /* this */ /* eat */
+ if ((*bp++ = *ptr++) == newline) /* really */ /* dust */
+ goto thats_all_folks; /* screams */ /* sed :-) */
+ }
+
+ 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 */
+ if (get_paragraph && oldbp)
+ obpx = oldbp - str->str_ptr;
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + cnt + 1);
+ bp = str->str_ptr + bpx; /* reconstitute our pointer */
+ if (get_paragraph && oldbp)
+ oldbp = str->str_ptr + obpx;
+
+ 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 (get_paragraph && bp - 1 != oldbp) {
+ oldbp = bp; /* remember where this newline was */
+ goto screamer; /* and go back to the fray */
+ }
+thats_really_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;
+}
+
+
+STR *
+interp(str,s)
+register STR *str;
+register char *s;
+{
+ register char *t = s;
+ char *envsave = envname;
+ envname = Nullch;
+
+ str_set(str,"");
+ while (*s) {
+ if (*s == '\\' && s[1] == '$') {
+ str_ncat(str, t, s++ - t);
+ t = s++;
+ }
+ else if (*s == '$' && s[1] && s[1] != '|') {
+ str_ncat(str,t,s-t);
+ s = scanreg(s,tokenbuf);
+ str_cat(str,reg_get(tokenbuf));
+ t = s;
+ }
+ else
+ s++;
+ }
+ envname = envsave;
+ str_ncat(str,t,s-t);
+ return str;
+}
+
+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_static(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
+/* $Header: str.h,v 1.0 87/12/18 13:06:26 root Exp $
+ *
+ * $Log: str.h,v $
+ * Revision 1.0 87/12/18 13:06:26 root
+ * Initial revision
+ *
+ */
+
+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 */
+ STAB *str_magic; /* while in use, ptr to magic stab, if any */
+ } 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_static();
+STR *str_make();
+STR *str_nmake();
--- /dev/null
+This is the perl test library. To run all the tests, just type 'TEST'.
+
+To add new tests, just look at the current tests and do likewise.
+
+If a test fails, run it by itself to see if it prints any informative
+diagnostics. If not, modify the test to print informative diagnostics.
+If you put out extra lines with a '#' character on the front, you don't
+have to worry about removing the extra print statements later since TEST
+ignores lines beginning with '#'.
+
+If you come up with new tests, send them to lwall@jpl-devvax.jpl.nasa.gov.
--- /dev/null
+#!./perl
+
+# $Header: TEST,v 1.0 87/12/18 13:11:34 root Exp $
+
+# This is written in a peculiar style, since we're trying to avoid
+# most of the constructs we'll be testing for.
+
+if ($ARGV[0] eq '-v') {
+ $verbose = 1;
+ shift;
+}
+
+if ($ARGV[0] eq '') {
+ @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.*`);
+}
+
+$bad = 0;
+while ($test = shift) {
+ print "$test...";
+ open(results,"$test|") || (print "can't run.\n");
+ $ok = 0;
+ while (<results>) {
+ if ($verbose) {
+ print $_;
+ }
+ unless (/^#/) {
+ if (/^1\.\.([0-9]+)/) {
+ $max = $1;
+ $next = 1;
+ $ok = 1;
+ } else {
+ 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.";
+ }
+ }
+}
+
+if ($bad == 0) {
+ if ($ok) {
+ print "All tests successful.\n";
+ } else {
+ die "FAILED--no tests were run for some reason.";
+ }
+} else {
+ if ($bad == 1) {
+ die "Failed 1 test.";
+ } else {
+ die "Failed $bad tests.";
+ }
+}
+($user,$sys,$cuser,$csys) = times;
+print sprintf("u=%g s=%g cu=%g cs=%g\n",$user,$sys,$cuser,$csys);
--- /dev/null
+#!./perl
+
+# $Header: base.cond,v 1.0 87/12/18 13:11:41 root Exp $
+
+# 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: base.if,v 1.0 87/12/18 13:11:45 root Exp $
+
+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: base.lex,v 1.0 87/12/18 13:11:51 root Exp $
+
+print "1..4\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";}
--- /dev/null
+#!./perl
+
+# $Header: base.pat,v 1.0 87/12/18 13:11:56 root Exp $
+
+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: base.term,v 1.0 87/12/18 13:11:59 root Exp $
+
+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";}
+
+open(try, "/etc/termcap") || (die "Can't open /etc/termcap.");
+if (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";}
--- /dev/null
+#!./perl
+
+# $Header: cmd.elsif,v 1.0 87/12/18 13:12:02 root Exp $
+
+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\n";}
+if (($x = do foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2\n";}
+if (($x = do foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3\n";}
+if (($x = do foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4\n";}
--- /dev/null
+#!./perl
+
+# $Header: cmd.for,v 1.0 87/12/18 13:12:05 root Exp $
+
+print "1..2\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";}
--- /dev/null
+#!./perl
+
+# $Header: cmd.mod,v 1.0 87/12/18 13:12:09 root Exp $
+
+print "1..6\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";}
--- /dev/null
+#!./perl
+
+# $Header: cmd.subval,v 1.0 87/12/18 13:12:12 root Exp $
+
+sub foo1 {
+ 'true1';
+ if ($_[0]) { 'true2'; }
+}
+
+sub foo2 {
+ 'true1';
+ if ($_[0]) { 'true2'; } else { 'true3'; }
+}
+
+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..12\n";
+
+if (do foo1(0) eq '') {print "ok 1\n";} else {print "not ok 1\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 '') {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 '') {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 '') {print "ok 12\n";} else {print "not ok 12\n";}
--- /dev/null
+#!./perl
+
+# $Header: cmd.while,v 1.0 87/12/18 13:12:15 root Exp $
+
+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: comp.cmdopt,v 1.0 87/12/18 13:12:19 root Exp $
+
+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: comp.cpp,v 1.0 87/12/18 13:12:22 root Exp $
+
+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.";
+print try '$ok = "not ok 3\n";'; print try "\n";
+print try "#include <Comp.cpp.inc>\n";
+print try "#ifdef OK\n";
+print try '$ok = OK;'; print try "\n";
+print try "#endif\n";
+print try 'print $ok;'; print try "\n";
+close try;
+
+open(try,">Comp.cpp.inc") || (die "Can't open temp include file.");
+print try '#define OK "ok 3\n"'; print try "\n";
+close try;
+
+$pwd=`pwd`;
+$pwd =~ s/\n//;
+$x = `./perl -P -I$pwd Comp.cpp.tmp`;
+print $x;
+`/bin/rm -f Comp.cpp.tmp Comp.cpp.inc`;
--- /dev/null
+#!./perl
+
+# $Header: comp.decl,v 1.0 87/12/18 13:12:27 root Exp $
+
+# 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: comp.multiline,v 1.0 87/12/18 13:12:31 root Exp $
+
+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
+
+# $Header: comp.script,v 1.0 87/12/18 13:12:36 root Exp $
+
+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: comp.term,v 1.0 87/12/18 13:12:40 root Exp $
+
+# tests that aren't important enough for base.term
+
+print "1..9\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";}
+
--- /dev/null
+#!./perl
+
+# $Header: io.argv,v 1.0 87/12/18 13:12:44 root Exp $
+
+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\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: io.fs,v 1.0 87/12/18 13:12:48 root Exp $
+
+print "1..18\n";
+
+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";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('b');
+if ($ino) {print "ok 16\n";} else {print "not ok 16\n";}
+
+if ((unlink 'b') == 1) {print "ok 17\n";} else {print "not ok 17\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('b');
+if ($ino == 0) {print "ok 18\n";} else {print "not ok 18\n";}
+unlink 'c';
--- /dev/null
+#!./perl -i.bak
+
+# $Header: io.inplace,v 1.0 87/12/18 13:12:51 root Exp $
+
+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: io.print,v 1.0 87/12/18 13:12:55 root Exp $
+
+print "1..11\n";
+
+print stdout "ok 1\n";
+print "ok 2\n","ok 3\n","ok 4\n","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";
--- /dev/null
+#!./perl
+
+# $Header: io.tell,v 1.0 87/12/18 13:13:02 root Exp $
+
+print "1..13\n";
+
+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) { 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
+
+# $Header: op.append,v 1.0 87/12/18 13:13:05 root Exp $
+
+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: op.auto,v 1.0 87/12/18 13:13:08 root Exp $
+
+print "1..30\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";}
--- /dev/null
+#!./perl
+
+# $Header: op.chop,v 1.0 87/12/18 13:13:11 root Exp $
+
+print "1..2\n";
+
+# optimized
+
+$_ = 'abc';
+$c = do foo();
+if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1\n";}
+
+# unoptimized
+
+$_ = 'abc';
+$c = chop($_);
+if ($c . $_ eq 'cab') {print "ok 2\n";} else {print "not ok 2\n";}
+
+sub foo {
+ chop;
+}
--- /dev/null
+#!./perl
+
+# $Header: op.cond,v 1.0 87/12/18 13:13:14 root Exp $
+
+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: op.crypt,v 1.0 87/12/18 13:13:17 root Exp $
+
+print "1..2\n";
+
+# this evaluates entirely at compile time!
+if (crypt('uh','oh') eq 'ohPnjpYtoi1NU') {print "ok 1\n";} else {print "not ok 1\n";}
+
+# this doesn't.
+$uh = 'uh';
+if (crypt($uh,'oh') eq 'ohPnjpYtoi1NU') {print "ok 2\n";} else {print "not ok 2\n";}
--- /dev/null
+#!./perl
+
+# $Header: op.do,v 1.0 87/12/18 13:13:20 root Exp $
+sub foo1
+{
+ print $_[0];
+ 'value';
+}
+
+sub foo2
+{
+ shift(_);
+ print $_[0];
+ $x = 'value';
+ $x;
+}
+
+print "1..8\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"; }
--- /dev/null
+#!./perl
+
+# $Header: op.each,v 1.0 87/12/18 13:13:23 root Exp $
+
+print "1..2\n";
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl'} = 'JKL';
+$h{'xyz'} = 'XYZ';
+$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";}
--- /dev/null
+#!./perl
+
+# $Header: op.exec,v 1.0 87/12/18 13:13:26 root Exp $
+
+$| = 1; # flush stdout
+print "1..4\n";
+
+system "echo ok \\1"; # shell interpreted
+system "echo ok 2"; # split and directly called
+system "echo", "ok", "3"; # directly called
+
+exec "echo","ok","4";
--- /dev/null
+#!./perl
+
+# $Header: op.exp,v 1.0 87/12/18 13:13:29 root Exp $
+
+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: op.flip,v 1.0 87/12/18 13:13:34 root Exp $
+
+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,'/etc/termcap');
+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: op.fork,v 1.0 87/12/18 13:13:37 root Exp $
+
+$| = 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: op.goto,v 1.0 87/12/18 13:13:40 root Exp $
+
+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
+
+# $Header: op.int,v 1.0 87/12/18 13:13:43 root Exp $
+
+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: op.join,v 1.0 87/12/18 13:13:46 root Exp $
+
+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: op.list,v 1.0 87/12/18 13:13:50 root Exp $
+
+print "1..11\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\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";}
--- /dev/null
+#!./perl
+
+# $Header: op.magic,v 1.0 87/12/18 13:13:54 root Exp $
+
+print "1..4\n";
+
+$| = 1; # command buffering
+
+$ENV{'foo'} = 'hi there';
+if (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";}
+
+$! = 0;
+open(foo,'ajslkdfpqjsjfkslkjdflksd');
+if ($! == 2) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$SIG{'INT'} = 'ok3';
+kill 2,$$;
+$SIG{'INT'} = 'IGNORE';
+kill 2,$$;
+print "ok 4\n";
+$SIG{'INT'} = 'DEFAULT';
+kill 2,$$;
+print "not ok\n";
+
+sub ok3 {
+ print "ok 3\n" if pop(@_) eq 'INT';
+}
--- /dev/null
+#!./perl
+
+# $Header: op.oct,v 1.0 87/12/18 13:13:57 root Exp $
+
+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: op.ord,v 1.0 87/12/18 13:14:01 root Exp $
+
+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: op.pat,v 1.0 87/12/18 13:14:07 root Exp $
+print "1..22\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";}
--- /dev/null
+#!./perl
+
+# $Header: op.push,v 1.0 87/12/18 13:14:10 root Exp $
+
+print "1..2\n";
+
+@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";}
--- /dev/null
+#!./perl
+
+# $Header: op.repeat,v 1.0 87/12/18 13:14:14 root Exp $
+
+print "1..11\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";}
+
--- /dev/null
+#!./perl
+
+# $Header: op.sleep,v 1.0 87/12/18 13:14:17 root Exp $
+
+print "1..1\n";
+
+$x = sleep 2;
+if ($x == 2) {print "ok 1\n";} else {print "not ok 1\n";}
--- /dev/null
+#!./perl
+
+# $Header: op.split,v 1.0 87/12/18 13:14:20 root Exp $
+
+print "1..4\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";
+@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";}
--- /dev/null
+#!./perl
+
+# $Header: op.sprintf,v 1.0 87/12/18 13:14:24 root Exp $
+
+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\n";}
--- /dev/null
+#!./perl
+
+# $Header: op.stat,v 1.0 87/12/18 13:14:27 root Exp $
+
+print "1..4\n";
+
+open(foo, ">Op.stat.tmp");
+
+($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);
+
+$base = time;
+while (time == $base) {}
+
+`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) {print "ok 4\n";} else {print "not ok 4\n";}
+print "#4 :$mtime: != :$ctime:\n";
+
+`rm -f Op.stat.tmp Op.stat.tmp2`;
--- /dev/null
+#!./perl
+
+# $Header: op.subst,v 1.0 87/12/18 13:14:30 root Exp $
+
+print "1..7\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";}
+
+$a = 'abcdef';
+$b = 'cd';
+$a =~ 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\n";}
+
+if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx')
+ {print "ok 7\n";} else {print "not ok 7\n";}
--- /dev/null
+#!./perl
+
+# $Header: op.time,v 1.0 87/12/18 13:14:33 root Exp $
+
+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 && $yday && $wday && $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 && $yday && $wday && $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: op.unshift,v 1.0 87/12/18 13:14:37 root Exp $
+
+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
+/* $Header: util.c,v 1.0 87/12/18 13:06:30 root Exp $
+ *
+ * $Log: util.c,v $
+ * Revision 1.0 87/12/18 13:06:30 root
+ * Initial revision
+ *
+ */
+
+#include <stdio.h>
+
+#include "handy.h"
+#include "EXTERN.h"
+#include "search.h"
+#include "perl.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;
+}
+
+#ifdef undef
+/* safe version of string concatenate, with \n deletion and space padding */
+
+char *
+safecat(to,from,len)
+char *to;
+register char *from;
+register int len;
+{
+ register char *dest = to;
+
+ len--; /* leave room for null */
+ if (*dest) {
+ while (len && *dest++) len--;
+ if (len) {
+ len--;
+ *(dest-1) = ' ';
+ }
+ }
+ if (from != Nullch)
+ while (len && (*dest++ = *from++)) len--;
+ if (len)
+ dest--;
+ if (*(dest-1) == '\n')
+ dest--;
+ *dest = '\0';
+ return to;
+}
+#endif
+
+/* 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 == '\\' && from[1] == delim)
+ from++;
+ 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;
+{
+ extern FILE *e_fp;
+ extern char *e_tmpname;
+
+ fprintf(stderr,pat,a1,a2,a3,a4);
+ if (e_fp)
+ UNLINK(e_tmpname);
+ exit(1);
+}
+
+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
+/* $Header: util.h,v 1.0 87/12/18 13:06:33 root Exp $
+ *
+ * $Log: util.h,v $
+ * Revision 1.0 87/12/18 13:06:33 root
+ * Initial revision
+ *
+ */
+
+/* is the string for makedir a directory name or a filename? */
+
+#define MD_DIR 0
+#define MD_FILE 1
+
+void util_init();
+int doshell();
+char *safemalloc();
+char *saferealloc();
+char *safecpy();
+char *safecat();
+char *cpytill();
+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
+/* $Header: version.c,v 1.0 87/12/18 13:06:41 root Exp $
+ *
+ * $Log: version.c,v $
+ * Revision 1.0 87/12/18 13:06:41 root
+ * Initial revision
+ *
+ */
+
+#include "patchlevel.h"
+
+/* Print out the version number. */
+
+version()
+{
+ extern char rcsid[];
+
+ printf("%s\r\nPatch level: %d\r\n", rcsid, PATCHLEVEL);
+}
--- /dev/null
+/* $Header: EXTERN.h,v 1.0 87/12/18 13:06:44 root Exp $
+ *
+ * $Log: EXTERN.h,v $
+ * Revision 1.0 87/12/18 13:06:44 root
+ * Initial revision
+ *
+ */
+
+#undef EXT
+#define EXT extern
+
+#undef INIT
+#define INIT(x)
+
+#undef DOINIT
--- /dev/null
+/* $Header: INTERN.h,v 1.0 87/12/18 13:06:48 root Exp $
+ *
+ * $Log: INTERN.h,v $
+ * Revision 1.0 87/12/18 13:06:48 root
+ * Initial revision
+ *
+ */
+
+#undef EXT
+#define EXT
+
+#undef INIT
+#define INIT(x) = x
+
+#define DOINIT
--- /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
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting x2p/Makefile (with variable substitutions)"
+cat >Makefile <<!GROK!THIS!
+# $Header: Makefile.SH,v 1.0 87/12/18 17:50:17 root Exp $
+#
+# $Log: Makefile.SH,v $
+# Revision 1.0 87/12/18 17:50:17 root
+# Initial revision
+#
+#
+
+CC = $cc
+bin = $bin
+lib = $lib
+mansrc = $mansrc
+manext = $manext
+CFLAGS = $ccflags -O
+LDFLAGS = $ldflags
+SMALL = $small
+LARGE = $large $split
+
+libs = $libnm -lm
+!GROK!THIS!
+
+cat >>Makefile <<'!NO!SUBS!'
+
+public = a2p s2p
+
+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 ../malloc.c str.c util.c walk.c
+
+obj = hash.o malloc.o str.o util.o walk.o
+
+lintflags = -phbvxac
+
+addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
+
+# grrr
+SHELL = /bin/sh
+
+.c.o:
+ $(CC) -c $(CFLAGS) $(LARGE) $*.c
+
+all: $(public) $(private) $(util)
+ touch all
+
+a2p: $(obj) a2p.o
+ $(CC) $(LDFLAGS) $(LARGE) $(obj) a2p.o $(libs) -o a2p
+
+a2p.c: a2p.y
+ @ echo Expect 107 shift/reduce errors...
+ 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
+ $(CC) -c $(CFLAGS) $(LARGE) a2p.c
+
+# if a .h file depends on another .h file...
+$(h):
+ touch $@
+install: a2p s2p
+# won't work with csh
+ export PATH || exit 1
+ - mv $(bin)/a2p $(bin)/a2p.old
+ - mv $(bin)/s2p $(bin)/s2p.old
+ - if test `pwd` != $(bin); then cp $(public) $(bin); fi
+ cd $(bin); \
+for pub in $(public); do \
+chmod 755 `basename $$pub`; \
+done
+ - test $(bin) = /bin || rm -f /bin/a2p
+# chmod 755 makedir
+# - makedir `filexp $(lib)`
+# - \
+#if test `pwd` != `filexp $(lib)`; then \
+#cp $(private) `filexp $(lib)`; \
+#fi
+# cd `filexp $(lib)`; \
+#for priv in $(private); do \
+#chmod 755 `basename $$priv`; \
+#done
+ - if test `pwd` != $(mansrc); then \
+for page in $(manpages); do \
+cp $$page $(mansrc)/`basename $$page .man`.$(manext); \
+done; \
+fi
+
+clean:
+ rm -f *.o
+
+realclean:
+ rm -f a2p *.orig */*.orig *.o core $(addedbyconf)
+
+# 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: ../makedepend
+ ../makedepend
+
+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):
+ @ 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
--- /dev/null
+/* $Header: a2p.h,v 1.0 87/12/18 13:06:58 root Exp $
+ *
+ * $Log: a2p.h,v $
+ * Revision 1.0 87/12/18 13:06:58 root
+ * Initial revision
+ *
+ */
+
+#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 OSUB 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
+
+#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",
+ "SUB",
+ "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",
+ "70"
+};
+#else
+extern char *opname[];
+#endif
+
+union {
+ int ival;
+ char *cval;
+} ops[50000]; /* hope they have 200k to spare */
+
+EXT int mop INIT(1);
+
+#define DEBUGGING
+
+#include <stdio.h>
+#include <ctype.h>
+#include <setjmp.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <time.h>
+#include <sys/times.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[1024];
+EXT char *bufptr INIT(buf);
+
+EXT STR *linestr INIT(Nullstr);
+
+EXT char tokenbuf[256];
+EXT int expectterm INIT(TRUE);
+
+#ifdef DEBUGGING
+EXT int debug INIT(0);
+EXT int dlevel INIT(0);
+#define YYDEBUG;
+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 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;
--- /dev/null
+.rn '' }`
+''' $Header: a2p.man,v 1.0 87/12/18 17:23:56 root Exp $
+'''
+''' $Log: a2p.man,v $
+''' Revision 1.0 87/12/18 17:23:56 root
+''' Initial revision
+'''
+'''
+.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 \(bs-|\(bv\*(Tr
+.ie n \{\
+.ds -- \(bs-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\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 will do 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
+The split operator in perl always strips off all null fields from the end.
+Awk does NOT do this, if you've set FS.
+If the perl script splits to an array, the field count may not reflect
+what you expect.
+Ordinarily this isn't a problem, since nonexistent array elements have a null
+value, but if you rely on NF in awk, you could be in for trouble.
+Either force the number of fields with \-<number>, or count the number of
+delimiters another way, e.g. with y/:/:/.
+Or add something non-null to the end before you split, and then pop it off
+the resulting array.
+.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.
+.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 with each(), but
+iteration over a numeric array is NOT.
+You need a for loop, or while loop with a pop() or shift(), so you might
+need to modify any loop that is iterating over the array in question.
+.PP
+Arrays which have been split into are assumed to be numerically indexed.
+The usual perl idiom for iterating over such arrays is to use pop() or shift()
+and assign the resulting value to a variable inside the conditional of the
+while loop.
+This is destructive to the array, however, so a2p can't assume this is
+reasonable.
+A2p will write a standard for loop with a scratch variable.
+You may wish to change it to a pop() loop for more efficiency, presuming
+you don't want to keep the array around.
+.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
+There may occasionally be extra parentheses that you can remove.
+.PP
+For aesthetic reasons you may wish to change the array base $[ from 1 back
+to the 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 not
+translated.
+.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.
+.SH ENVIRONMENT
+A2p uses no environment variables.
+.SH AUTHOR
+Larry Wall <lwall@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
+%{
+/* $Header: a2p.y,v 1.0 87/12/18 13:07:05 root Exp $
+ *
+ * $Log: a2p.y,v $
+ * Revision 1.0 87/12/18 13:07:05 root
+ * Initial revision
+ *
+ */
+
+#include "INTERN.h"
+#include "a2p.h"
+
+int root;
+
+%}
+%token BEGIN END
+%token REGEX
+%token SEMINEW NEWLINE COMMENT
+%token FUN1 GRGR
+%token PRINT PRINTF SPRINTF SPLIT
+%token IF ELSE WHILE FOR IN
+%token EXIT NEXT BREAK CONTINUE
+
+%right ASGNOP
+%left OROR
+%left ANDAND
+%left NOT
+%left NUMBER VAR SUBSTR INDEX
+%left GETLINE
+%nonassoc RELOP MATCHOP
+%left OR
+%left STRING
+%left '+' '-'
+%left '*' '/' '%'
+%right UMINUS
+%left INCR DECR
+%left FIELD VFIELD
+
+%%
+
+program : junk begin hunks end
+ { root = oper4(OPROG,$1,$2,$3,$4); }
+ ;
+
+begin : BEGIN '{' states '}' junk
+ { $$ = oper2(OJUNK,$3,$5); in_begin = FALSE; }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+end : END '{' states '}'
+ { $$ = $3; }
+ | end NEWLINE
+ { $$ = $1; }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+hunks : hunks hunk junk
+ { $$ = oper3(OHUNKS,$1,$2,$3); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+hunk : patpat
+ { $$ = oper1(OHUNK,$1); need_entire = TRUE; }
+ | patpat '{' states '}'
+ { $$ = oper2(OHUNK,$1,$3); }
+ | '{' states '}'
+ { $$ = oper2(OHUNK,Nullop,$2); }
+ ;
+
+patpat : pat
+ { $$ = oper1(OPAT,$1); }
+ | pat ',' pat
+ { $$ = oper2(ORANGE,$1,$3); }
+ ;
+
+pat : REGEX
+ { $$ = oper1(OREGEX,$1); }
+ | match
+ | rel
+ | compound_pat
+ ;
+
+compound_pat
+ : '(' compound_pat ')'
+ { $$ = oper1(OPPAREN,$2); }
+ | pat ANDAND pat
+ { $$ = oper2(OPANDAND,$1,$3); }
+ | pat OROR pat
+ { $$ = oper2(OPOROR,$1,$3); }
+ | NOT pat
+ { $$ = oper1(OPNOT,$2); }
+ ;
+
+cond : expr
+ | match
+ | rel
+ | compound_cond
+ ;
+
+compound_cond
+ : '(' compound_cond ')'
+ { $$ = oper1(OCPAREN,$2); }
+ | cond ANDAND cond
+ { $$ = oper2(OCANDAND,$1,$3); }
+ | cond OROR cond
+ { $$ = oper2(OCOROR,$1,$3); }
+ | NOT cond
+ { $$ = oper1(OCNOT,$2); }
+ ;
+
+rel : expr RELOP expr
+ { $$ = oper3(ORELOP,$2,$1,$3); }
+ | '(' rel ')'
+ { $$ = oper1(ORPAREN,$2); }
+ ;
+
+match : expr MATCHOP REGEX
+ { $$ = oper3(OMATCHOP,$2,$1,$3); }
+ | '(' match ')'
+ { $$ = oper1(OMPAREN,$2); }
+ ;
+
+expr : term
+ { $$ = $1; }
+ | expr term
+ { $$ = oper2(OCONCAT,$1,$2); }
+ | variable ASGNOP expr
+ { $$ = 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; }
+ | term '+' term
+ { $$ = oper2(OADD,$1,$3); }
+ | term '-' term
+ { $$ = oper2(OSUB,$1,$3); }
+ | term '*' term
+ { $$ = oper2(OMULT,$1,$3); }
+ | term '/' term
+ { $$ = oper2(ODIV,$1,$3); }
+ | term '%' term
+ { $$ = oper2(OMOD,$1,$3); }
+ | 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); }
+ | '(' expr ')'
+ { $$ = oper1(OPAREN,$2); }
+ | GETLINE
+ { $$ = oper0(OGETLINE); }
+ | FUN1
+ { $$ = oper0($1); need_entire = do_chop = TRUE; }
+ | FUN1 '(' ')'
+ { $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; }
+ | FUN1 '(' expr ')'
+ { $$ = oper1($1,$3); }
+ | SPRINTF print_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,numary($5),$7); }
+ | SPLIT '(' expr ',' VAR ')'
+ { $$ = oper2(OSPLIT,$3,numary($5)); }
+ | INDEX '(' expr ',' expr ')'
+ { $$ = oper2(OINDEX,$3,$5); }
+ ;
+
+variable: NUMBER
+ { $$ = oper1(ONUM,$1); }
+ | STRING
+ { $$ = oper1(OSTR,$1); }
+ | VAR
+ { $$ = oper1(OVAR,$1); }
+ | VAR '[' expr ']'
+ { $$ = oper2(OVAR,$1,$3); }
+ | FIELD
+ { $$ = oper1(OFLD,$1); }
+ | VFIELD term
+ { $$ = oper1(OVFLD,$2); }
+ ;
+
+maybe : NEWLINE
+ { $$ = oper0(ONEWLINE); }
+ | /* NULL */
+ { $$ = Nullop; }
+ | COMMENT
+ { $$ = oper1(OCOMMENT,$1); }
+ ;
+
+print_list
+ : expr
+ | clist
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+clist : expr ',' expr
+ { $$ = oper2(OCOMMA,$1,$3); }
+ | clist ',' expr
+ { $$ = oper2(OCOMMA,$1,$3); }
+ | '(' clist ')' /* these parens are invisible */
+ { $$ = $2; }
+ ;
+
+junk : junk hunksep
+ { $$ = oper2(OJUNK,$1,$2); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+hunksep : ';'
+ { $$ = oper0(OSEMICOLON); }
+ | SEMINEW
+ { $$ = oper0(OSEMICOLON); }
+ | NEWLINE
+ { $$ = oper0(ONEWLINE); }
+ | COMMENT
+ { $$ = oper1(OCOMMENT,$1); }
+ ;
+
+separator
+ : ';'
+ { $$ = oper0(OSEMICOLON); }
+ | SEMINEW
+ { $$ = oper0(OSNEWLINE); }
+ | NEWLINE
+ { $$ = oper0(OSNEWLINE); }
+ | COMMENT
+ { $$ = oper1(OSCOMMENT,$1); }
+ ;
+
+states : states statement
+ { $$ = oper2(OSTATES,$1,$2); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+statement
+ : simple separator
+ { $$ = oper2(OSTATE,$1,$2); }
+ | compound
+ ;
+
+simple
+ : expr
+ | PRINT print_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 print_list
+ { $$ = oper1(OPRINT,$2);
+ if (!$2) need_entire = TRUE;
+ saw_ORS = saw_OFS = TRUE;
+ }
+ | PRINTF print_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 print_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); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+redir : RELOP
+ { $$ = 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)); }
+ | FOR '(' simple ';' cond ';' simple ')' maybe statement
+ { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); }
+ | FOR '(' simple ';' ';' simple ')' maybe statement
+ { $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); }
+ | FOR '(' VAR IN VAR ')' maybe statement
+ { $$ = oper3(OFORIN,$3,$5,bl($8,$7)); }
+ | '{' states '}'
+ { $$ = oper1(OBLOCK,$2); }
+ ;
+
+%%
+#include "a2py.c"
--- /dev/null
+/* $Header: a2py.c,v 1.0 87/12/18 17:50:33 root Exp $
+ *
+ * $Log: a2py.c,v $
+ * Revision 1.0 87/12/18 17:50:33 root
+ * Initial revision
+ *
+ */
+
+#include "util.h"
+char *index();
+
+char *filename;
+
+main(argc,argv,env)
+register int argc;
+register char **argv;
+register char **env;
+{
+ register STR *str;
+ register char *s;
+ int i;
+ STR *walk();
+ STR *tmpstr;
+
+ 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]);
+ }
+ }
+ switch_end:
+
+ /* open script */
+
+ if (argv[0] == Nullch)
+ 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();
+
+ /* 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);
+ str = str_make("#!/bin/perl\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);
+ 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,VAR)
+
+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 '(':
+ 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++;
+ XTERM(MATCHOP);
+ case '+':
+ case '-':
+ if (s[1] == *s) {
+ s++;
+ if (*s++ == '+')
+ XTERM(INCR);
+ else
+ XTERM(DECR);
+ }
+ /* FALL THROUGH */
+ case '*':
+ case '%':
+ tmp = *s++;
+ if (*s == '=') {
+ 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--;
+ 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--;
+ yylval = string("<",1);
+ XTERM(RELOP);
+ case '>':
+ s++;
+ tmp = *s++;
+ if (tmp == '=') {
+ yylval = string(">=",2);
+ XTERM(RELOP);
+ }
+ s--;
+ yylval = string(">",1);
+ XTERM(RELOP);
+
+#define SNARFWORD \
+ d = tokenbuf; \
+ while (isalpha(*s) || isdigit(*s) || *s == '_') \
+ *d++ = *s++; \
+ *d = '\0'; \
+ d = tokenbuf;
+
+ case '$':
+ s++;
+ if (*s == '0') {
+ s++;
+ do_chop = TRUE;
+ need_entire = TRUE;
+ 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':
+ 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;
+ 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);
+ ID(d);
+ case 'd': case 'D':
+ SNARFWORD;
+ 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);
+ }
+ 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,"FILENAME"))
+ d = "ARGV";
+ if (strEQ(d,"for"))
+ XTERM(FOR);
+ ID(d);
+ case 'g': case 'G':
+ SNARFWORD;
+ if (strEQ(d,"getline"))
+ XTERM(GETLINE);
+ ID(d);
+ case 'h': case 'H':
+ SNARFWORD;
+ 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;
+ ID(d);
+ case 'k': case 'K':
+ SNARFWORD;
+ ID(d);
+ case 'l': case 'L':
+ SNARFWORD;
+ if (strEQ(d,"length")) {
+ yylval = OLENGTH;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"log")) {
+ yylval = OLOG;
+ XTERM(FUN1);
+ }
+ ID(d);
+ case 'm': case 'M':
+ SNARFWORD;
+ ID(d);
+ case 'n': case 'N':
+ SNARFWORD;
+ if (strEQ(d,"NF"))
+ do_split = split_to_array = set_array_base = TRUE;
+ if (strEQ(d,"next")) {
+ saw_line_op = TRUE;
+ XTERM(NEXT);
+ }
+ 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 = "$#";
+ }
+ ID(d);
+ case 'p': case 'P':
+ SNARFWORD;
+ if (strEQ(d,"print")) {
+ XTERM(PRINT);
+ }
+ if (strEQ(d,"printf")) {
+ XTERM(PRINTF);
+ }
+ ID(d);
+ case 'q': case 'Q':
+ SNARFWORD;
+ ID(d);
+ case 'r': case 'R':
+ SNARFWORD;
+ if (strEQ(d,"RS")) {
+ d = "$/";
+ saw_RS = TRUE;
+ }
+ 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,"sprintf"))
+ XTERM(SPRINTF);
+ if (strEQ(d,"sqrt")) {
+ yylval = OSQRT;
+ XTERM(FUN1);
+ }
+ ID(d);
+ case 't': case 'T':
+ SNARFWORD;
+ ID(d);
+ case 'u': case 'U':
+ SNARFWORD;
+ ID(d);
+ case 'v': case 'V':
+ SNARFWORD;
+ ID(d);
+ case 'w': case 'W':
+ SNARFWORD;
+ if (strEQ(d,"while"))
+ XTERM(WHILE);
+ ID(d);
+ case 'x': case 'X':
+ SNARFWORD;
+ ID(d);
+ case 'y': case 'Y':
+ SNARFWORD;
+ 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));
+ }
+ s = cpytill(tokenbuf,s,s[-1]);
+ 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) || *s == '_')
+ *d++ = *s++;
+ if (*s == '.' && index("0123456789eE",s[1]))
+ *d++ = *s++;
+ while (isdigit(*s) || *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';
+ return retval;
+}
+
+oper0(type)
+int type;
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type;
+ 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;
+ 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;
+ 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;
+ 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;
+ 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;
+ 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) {
+ *d = '\0';
+ putone();
+ putchar('\n');
+ if (d[-1] != ';' && !(newpos % 4)) {
+ *t++ = ' ';
+ *t++ = ' ';
+ newpos += 2;
+ }
+ strcpy(t,d+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");
+ }
+ }
+ t = tokenbuf;
+ if (*t == '#') {
+ if (strnEQ(t,"#!/bin/awk",10) || strnEQ(t,"#! /bin/awk",11))
+ return;
+ }
+ fputs(tokenbuf,stdout);
+}
+
+numary(arg)
+int arg;
+{
+ STR *key;
+ int dummy;
+
+ key = walk(0,0,arg,&dummy);
+ str_cat(key,"[]");
+ hstore(symtab,key->str_ptr,str_make("1"));
+ str_free(key);
+ set_array_base = TRUE;
+ return arg;
+}
--- /dev/null
+/* $Header: handy.h,v 1.0 87/12/18 13:07:15 root Exp $
+ *
+ * $Log: handy.h,v $
+ * Revision 1.0 87/12/18 13:07:15 root
+ * Initial revision
+ *
+ */
+
+#define Null(type) ((type)0)
+#define Nullch Null(char*)
+#define Nullfp Null(FILE*)
+
+#define bool char
+#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
+/* $Header: hash.c,v 1.0 87/12/18 13:07:18 root Exp $
+ *
+ * $Log: hash.c,v $
+ * Revision 1.0 87/12/18 13:07:18 root
+ * Initial revision
+ *
+ */
+
+#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;
+ safefree((char*)entry->hent_val);
+ entry->hent_val = val;
+ return TRUE;
+ }
+ 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
+/* $Header: hash.h,v 1.0 87/12/18 13:07:23 root Exp $
+ *
+ * $Log: hash.h,v $
+ * Revision 1.0 87/12/18 13:07:23 root
+ * Initial revision
+ *
+ */
+
+#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
+#!/bin/perl
+
+$indent = 4;
+$shiftwidth = 4;
+$l = '{'; $r = '}';
+$tempvar = '1';
+
+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: $_";
+}
+
+unless ($debug) {
+ open(body,">/tmp/sperl$$") || do Die("Can't open temp file.");
+}
+
+if (!$assumen && !$assumep) {
+ print body
+'while ($ARGV[0] =~ /^-/) {
+ $_ = shift;
+ last if /^--/;
+ if (/^-n/) {
+ $nflag++;
+ next;
+ }
+ die "I don\'t recognize this switch: $_";
+}
+
+';
+}
+
+print body '
+#ifdef PRINTIT
+#ifdef ASSUMEP
+$printit++;
+#else
+$printit++ unless $nflag;
+#endif
+#endif
+line: while (<>) {
+';
+
+line: while (<>) {
+ s/[ \t]*(.*)\n$/$1/;
+ if (/^:/) {
+ s/^:[ \t]*//;
+ $label = do make_label($_);
+ if ($. == 1) {
+ $toplabel = $label;
+ }
+ $_ = "$label:";
+ if ($lastlinewaslabel++) {$_ .= "\t;";}
+ if ($indent >= 2) {
+ $indent -= 2;
+ $indmod = 2;
+ }
+ next;
+ } else {
+ $lastlinewaslabel = '';
+ }
+ $addr1 = '';
+ $addr2 = '';
+ if (s/^([0-9]+)//) {
+ $addr1 = "$1";
+ }
+ elsif (s/^\$//) {
+ $addr1 = 'eof()';
+ }
+ elsif (s|^/||) {
+ $addr1 = '/';
+ delim: while (s:^([^(|)\\/]*)([(|)\\/])::) {
+ $prefix = $1;
+ $delim = $2;
+ if ($delim eq '\\') {
+ s/(.)(.*)/$2/;
+ $ch = $1;
+ $delim = '' if index("(|)",$ch) >= 0;
+ $delim .= $1;
+ }
+ elsif ($delim ne '/') {
+ $delim = '\\' . $delim;
+ }
+ $addr1 .= $prefix;
+ $addr1 .= $delim;
+ if ($delim eq '/') {
+ last delim;
+ }
+ }
+ }
+ if (s/^,//) {
+ if (s/^([0-9]+)//) {
+ $addr2 = "$1";
+ } elsif (s/^\$//) {
+ $addr2 = "eof()";
+ } elsif (s|^/||) {
+ $addr2 = '/';
+ delim: while (s:^([^(|)\\/]*)([(|)\\/])::) {
+ $prefix = $1;
+ $delim = $2;
+ if ($delim eq '\\') {
+ s/(.)(.*)/$2/;
+ $ch = $1;
+ $delim = '' if index("(|)",$ch) >= 0;
+ $delim .= $1;
+ }
+ elsif ($delim ne '/') {
+ $delim = '\\' . $delim;
+ }
+ $addr2 .= $prefix;
+ $addr2 .= $delim;
+ if ($delim eq '/') {
+ last delim;
+ }
+ }
+ } else {
+ do Die("Invalid second address at line $.: $_");
+ }
+ $addr1 .= " .. $addr2";
+ }
+ # 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 = substr(' ',0,$shiftwidth);
+ } else {
+ $space = '';
+ }
+ $_ = do transmogrify();
+ }
+
+ if ($addr1) {
+ if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
+ $_ !~ / if / && $_ !~ / unless /) {
+ s/;$/ $if $addr1;/;
+ $_ = substr($_,$shiftwidth,1000);
+ } else {
+ $command = $_;
+ $_ = "$if ($addr1) $l\n$change$command$rmaybe";
+ }
+ $change = '';
+ next line;
+ }
+} continue {
+ @lines = split(/\n/,$_);
+ while ($#lines >= 0) {
+ $_ = shift(lines);
+ unless (s/^ *<<--//) {
+ print body substr("\t\t\t\t\t\t\t\t\t\t\t\t",0,$indent / 8),
+ substr(' ',0,$indent % 8);
+ }
+ print body $_, "\n";
+ }
+ $indent += $indmod;
+ $indmod = 0;
+ if ($redo) {
+ $_ = $redo;
+ $redo = '';
+ redo line;
+ }
+}
+
+print body "}\n";
+if ($appendseen || $tseen || !$assumen) {
+ $printit++ if $dseen || (!$assumen && !$assumep);
+ print body '
+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
+}
+';
+}
+
+close body;
+
+unless ($debug) {
+ open(head,">/tmp/sperl2$$") || do 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,"/tmp/sperl$$") || do Die("Can't reopen temp file.");
+ while (<body>) {
+ print head $_;
+ }
+ close head;
+
+ print "#!/bin/perl\n\n";
+ open(body,"cc -E /tmp/sperl2$$ |") ||
+ do Die("Can't reopen temp file.");
+ while (<body>) {
+ /^# [0-9]/ && next;
+ /^[ \t]*$/ && next;
+ s/^<><>//;
+ print;
+ }
+}
+
+`/bin/rm -f /tmp/sperl$$ /tmp/sperl2$$`;
+
+sub Die {
+ `/bin/rm -f /tmp/sperl$$ /tmp/sperl2$$`;
+ die $_[0];
+}
+sub make_filehandle {
+ $fname = $_ = $_[0];
+ s/[^a-zA-Z]/_/g;
+ s/^_*//;
+ if (/^([a-z])([a-z]*)$/) {
+ $first = $1;
+ $rest = $2;
+ $first =~ y/a-z/A-Z/;
+ $_ = $first . $rest;
+ }
+ if (!$seen{$_}) {
+ $opens .= "open($_,'>$fname') || die \"Can't create $fname.\";\n";
+ }
+ $seen{$_} = $_;
+}
+
+sub make_label {
+ $label = $_[0];
+ $label =~ s/[^a-zA-Z0-9]/_/g;
+ if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
+ $label = substr($label,0,8);
+ if ($label =~ /^([a-z])([a-z]*)$/) {
+ $first = $1;
+ $rest = $2;
+ $first =~ y/a-z/A-Z/;
+ $label = $first . $rest;
+ }
+ $label;
+}
+
+sub transmogrify {
+ { # case
+ if (/^d/) {
+ $dseen++;
+ $_ = '
+<<--#ifdef PRINTIT
+$printit = \'\';
+<<--#endif
+next line;';
+ next;
+ }
+
+ if (/^n/) {
+ $_ =
+'<<--#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';
+ 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";
+ $_ = "
+<<--#ifdef PRINTIT
+$space\$printit = '';
+<<--#endif
+${space}next line;";
+ }
+ last;
+ }
+
+ if (/^s/) {
+ $delim = substr($_,1,1);
+ $len = length($_);
+ $repl = $end = 0;
+ for ($i = 2; $i < $len; $i++) {
+ $c = substr($_,$i,1);
+ if ($c eq '\\') {
+ $i++;
+ if ($i >= $len) {
+ $_ .= 'n';
+ $_ .= <>;
+ $len = length($_);
+ $_ = substr($_,0,--$len);
+ }
+ elsif (!$repl && index("(|)",substr($_,$i,1)) >= 0) {
+ $i--;
+ $len--;
+ $_ = substr($_,0,$i) . substr($_,$i+1,10000);
+ }
+ }
+ elsif ($c eq $delim) {
+ if ($repl) {
+ $end = $i;
+ last;
+ } else {
+ $repl = $i;
+ }
+ }
+ elsif (!$repl && index("(|)",$c) >= 0) {
+ $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
+ $i++;
+ $len++;
+ }
+ }
+ print "repl $repl end $end $_\n";
+ do Die("Malformed substitution at line $.") unless $end;
+ $pat = substr($_, 0, $repl + 1);
+ $repl = substr($_, $repl + 1, $end - $repl - 1);
+ $end = substr($_, $end + 1, 1000);
+ $dol = '$';
+ $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 = do make_filehandle($end);
+ $cmd .= " && (print $fh \$_)";
+ $end = '';
+ next;
+ }
+ do Die("Unrecognized substitution command ($end) at line $.");
+ }
+ $_ = $subst . $cmd . ';';
+ next;
+ }
+
+ if (/^p/) {
+ $_ = 'print;';
+ next;
+ }
+
+ if (/^w/) {
+ s/^w[ \t]*//;
+ $fh = do make_filehandle($_);
+ $_ = "print $fh \$_;";
+ next;
+ }
+
+ if (/^r/) {
+ $appendseen++;
+ s/^r[ \t]*//;
+ $file = $_;
+ $_ = "\$atext .= `cat $file 2>/dev/null`;";
+ next;
+ }
+
+ if (/^P/) {
+ $_ =
+'if (/(^[^\n]*\n)/) {
+ print $1;
+}';
+ next;
+ }
+
+ if (/^D/) {
+ $_ =
+'s/^[^\n]*\n//;
+if ($_) {redo line;}
+next line;';
+ next;
+ }
+
+ if (/^N/) {
+ $_ = '
+$_ .= <>;
+<<--#ifdef TSEEN
+$tflag = \'\';
+<<--#endif';
+ 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 = do 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 = do make_label($_);
+ if ($lab eq $toplabel) {
+ $_ = 'if ($tflag) {$tflag = \'\'; redo line;}';
+ } else {
+ $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}";
+ }
+ $tseen++;
+ next;
+ }
+
+ if (/^=/) {
+ $_ = 'print "$.\n";';
+ next;
+ }
+
+ if (/^q/) {
+ $_ =
+'close(ARGV);
+@ARGV = ();
+next line;';
+ next;
+ }
+ } continue {
+ if ($space) {
+ s/^/$space/;
+ s/(\n)(.)/$1$space$2/g;
+ }
+ last;
+ }
+ $_;
+}
+
--- /dev/null
+.rn '' }`
+''' $Header: s2p.man,v 1.0 87/12/18 17:37:16 root Exp $
+'''
+''' $Log: s2p.man,v $
+''' Revision 1.0 87/12/18 17:37:16 root
+''' Initial revision
+'''
+'''
+.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 \(bs-|\(bv\*(Tr
+.ie n \{\
+.ds -- \(bs-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\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.
+.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
+/* $Header: str.c,v 1.0 87/12/18 13:07:26 root Exp $
+ *
+ * $Log: str.c,v $
+ * Revision 1.0 87/12/18 13:07:26 root
+ * Initial revision
+ *
+ */
+
+#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 char *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) { /* this */ /* eat */
+ if ((*bp++ = *ptr++) == newline) /* really */ /* dust */
+ goto thats_all_folks; /* screams */ /* sed :-) */
+ }
+
+ 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_static(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
+/* $Header: str.h,v 1.0 87/12/18 13:07:30 root Exp $
+ *
+ * $Log: str.h,v $
+ * Revision 1.0 87/12/18 13:07:30 root
+ * Initial revision
+ *
+ */
+
+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_static();
+STR *str_make();
+STR *str_nmake();
+char *str_gets();
--- /dev/null
+/* $Header: util.c,v 1.0 87/12/18 13:07:34 root Exp $
+ *
+ * $Log: util.c,v $
+ * Revision 1.0 87/12/18 13:07:34 root
+ * Initial revision
+ *
+ */
+
+#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;
+}
+
+#ifdef undef
+/* safe version of string concatenate, with \n deletion and space padding */
+
+char *
+safecat(to,from,len)
+char *to;
+register char *from;
+register int len;
+{
+ register char *dest = to;
+
+ len--; /* leave room for null */
+ if (*dest) {
+ while (len && *dest++) len--;
+ if (len) {
+ len--;
+ *(dest-1) = ' ';
+ }
+ }
+ if (from != Nullch)
+ while (len && (*dest++ = *from++)) len--;
+ if (len)
+ dest--;
+ if (*(dest-1) == '\n')
+ dest--;
+ *dest = '\0';
+ return to;
+}
+#endif
+
+/* 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 == '\\' && from[1] == delim)
+ *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 == '\\' && from[1] == delim)
+ *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);
+}
+
+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
+/* $Header: util.h,v 1.0 87/12/18 13:07:37 root Exp $
+ *
+ * $Log: util.h,v $
+ * Revision 1.0 87/12/18 13:07:37 root
+ * Initial revision
+ *
+ */
+
+/* is the string for makedir a directory name or a filename? */
+
+#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
+/* $Header: walk.c,v 1.0 87/12/18 13:07:40 root Exp $
+ *
+ * $Log: walk.c,v $
+ * Revision 1.0 87/12/18 13:07:40 root
+ * Initial revision
+ *
+ */
+
+#include "handy.h"
+#include "EXTERN.h"
+#include "util.h"
+#include "a2p.h"
+
+bool exitval = FALSE;
+bool realexit = FALSE;
+int maxtmp = 0;
+
+STR *
+walk(useval,level,node,numericptr)
+int useval;
+int level;
+register int node;
+int *numericptr;
+{
+ register int len;
+ register STR *str;
+ register int type;
+ register int i;
+ register STR *tmpstr;
+ STR *tmp2str;
+ char *t;
+ char *d, *s;
+ int numarg;
+ int numeric = FALSE;
+ STR *fstr;
+ char *index();
+
+ if (!node) {
+ *numericptr = 0;
+ return str_make("");
+ }
+ type = ops[node].ival;
+ len = type >> 8;
+ type &= 255;
+ switch (type) {
+ case OPROG:
+ str = walk(0,level,ops[node+1].ival,&numarg);
+ opens = str_new(0);
+ 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\\n]+';\t\t# default field separator\n");
+ }
+ if (saw_OFS) {
+ str_cat(str,"$, = ' ';\t\t# default output field separator\n");
+ }
+ if (saw_ORS) {
+ str_cat(str,"$\\ = \"\\n\";\t\t# default output record separator\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));
+ str_free(fstr);
+ str_cat(str,"\n\n");
+ }
+ 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);
+ }
+ 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;
+ if (do_split)
+ emit_split(str,level);
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
+ str_free(fstr);
+ fixtab(str,--level);
+ str_cat(str,"}\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));
+ str_free(fstr);
+ str_cat(str,"\n");
+ }
+ if (exitval)
+ str_cat(str,"exit ExitValue;\n");
+ if (do_fancy_opens) {
+ str_cat(str,"\n\
+sub Pick {\n\
+ ($name) = @_;\n\
+ $fh = $opened{$name};\n\
+ if (!$fh) {\n\
+ $nextfh == 0 && open(fh_0,$name);\n\
+ $nextfh == 1 && open(fh_1,$name);\n\
+ $nextfh == 2 && open(fh_2,$name);\n\
+ $nextfh == 3 && open(fh_3,$name);\n\
+ $nextfh == 4 && open(fh_4,$name);\n\
+ $nextfh == 5 && open(fh_5,$name);\n\
+ $nextfh == 6 && open(fh_6,$name);\n\
+ $nextfh == 7 && open(fh_7,$name);\n\
+ $nextfh == 8 && open(fh_8,$name);\n\
+ $nextfh == 9 && open(fh_9,$name);\n\
+ $fh = $opened{$name} = 'fh_' . $nextfh++;\n\
+ }\n\
+ select($fh);\n\
+}\n\
+");
+ }
+ break;
+ case OHUNKS:
+ str = walk(0,level,ops[node+1].ival,&numarg);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ if (len == 3) {
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
+ str_free(fstr);
+ }
+ else {
+ }
+ break;
+ case ORANGE:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str," .. ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ 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);
+ /* 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';
+ 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);
+ str_cat(str," if ");
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg));
+ str_free(fstr);
+ str_cat(str,";");
+ }
+ else {
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg);
+ 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));
+ str_free(fstr);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ tab(str,level);
+ }
+ else {
+ str = walk(0,level,ops[node+2].ival,&numarg);
+ }
+ }
+ break;
+ case OPPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg));
+ str_free(fstr);
+ str_cat(str,")");
+ break;
+ case OPANDAND:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str," && ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ break;
+ case OPOROR:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str," || ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ break;
+ case OPNOT:
+ str = str_new(0);
+ str_set(str,"!");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ 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));
+ str_free(fstr);
+ numeric |= numarg;
+ str_cat(str,")");
+ break;
+ case OCANDAND:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ str_cat(str," && ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ break;
+ case OCOROR:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ str_cat(str," || ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ break;
+ case OCNOT:
+ str = str_new(0);
+ str_set(str,"!");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case ORELOP:
+ str = walk(1,level,ops[node+2].ival,&numarg);
+ numeric |= numarg;
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg);
+ tmp2str = walk(1,level,ops[node+3].ival,&numarg);
+ numeric |= numarg;
+ if (!numeric) {
+ 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));
+ str_free(fstr);
+ numeric |= numarg;
+ str_cat(str,")");
+ break;
+ case OMATCHOP:
+ str = walk(1,level,ops[node+2].ival,&numarg);
+ str_cat(str," ");
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg);
+ 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));
+ 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));
+ str_free(fstr);
+ numeric |= numarg;
+ str_cat(str,")");
+ break;
+ case OCONCAT:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str," . ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ break;
+ case OASSIGN:
+ str = walk(0,level,ops[node+2].ival,&numarg);
+ str_cat(str," ");
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg);
+ 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));
+ str_free(fstr);
+ numeric |= numarg;
+ if (strEQ(str->str_ptr,"$FS = '\240'"))
+ str_set(str,"$FS = '[\240\\n\\t]+'");
+ break;
+ case OADD:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str," + ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OSUB:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str," - ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OMULT:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str," * ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case ODIV:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str," / ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OMOD:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str," % ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OPOSTINCR:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str,"++");
+ numeric = 1;
+ break;
+ case OPOSTDECR:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str,"--");
+ numeric = 1;
+ break;
+ case OPREINCR:
+ str = str_new(0);
+ str_set(str,"++");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OPREDECR:
+ str = str_new(0);
+ str_set(str,"--");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OUMINUS:
+ str = str_new(0);
+ str_set(str,"-");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ 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));
+ str_free(fstr);
+ str_cat(str,")");
+ numeric |= numarg;
+ break;
+ case OGETLINE:
+ str = str_new(0);
+ str_set(str,"$_ = <>;\n");
+ tab(str,level);
+ if (do_chop) {
+ str_cat(str,"chop;\t# strip record separator\n");
+ tab(str,level);
+ }
+ if (do_split)
+ emit_split(str,level);
+ break;
+ case OSPRINTF:
+ str = str_new(0);
+ str_set(str,"sprintf(");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ 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));
+ str_free(fstr);
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ str_cat(str,", ");
+ if (len == 3) {
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg));
+ 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);
+ numeric = 1;
+ tmpstr = walk(1,level,ops[node+2].ival,&numarg);
+ 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);
+ if (str_len(fstr) == 3 && *fstr->str_ptr == '\'') {
+ i = fstr->str_ptr[1] & 127;
+ if (index("*+?.[]()|^$\\",i))
+ sprintf(tokenbuf,"/\\%c/",i);
+ 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,"/[ \\t\\n]+/");
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_free(fstr);
+ str_cat(str,")");
+ 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));
+ str_free(fstr);
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ str_cat(str,")");
+ numeric = 1;
+ break;
+ case ONUM:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OSTR:
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg);
+ s = "'";
+ for (t = tmpstr->str_ptr; *t; t++) {
+ if (*t == '\\' || *t == '\'')
+ s = "\"";
+ *t += 128;
+ }
+ str = str_new(0);
+ str_set(str,s);
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ str_cat(str,s);
+ break;
+ case OVAR:
+ str = str_new(0);
+ str_set(str,"$");
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg));
+ if (len == 1) {
+ tmp2str = hfetch(symtab,tmpstr->str_ptr);
+ if (tmp2str && atoi(tmp2str->str_ptr))
+ numeric = 2;
+ 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 {
+ 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));
+ str_free(fstr);
+ 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));
+ str_free(fstr);
+ str_cat(str,"]");
+ }
+ else {
+ i = atoi(walk(1,level,ops[node+1].ival,&numarg)->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);
+ 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);
+ 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);
+ for (s = tmpstr->str_ptr; *s && *s != '\n'; s++)
+ *s += 128;
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ tab(str,level);
+ break;
+ case OCOMMA:
+ str = walk(1,level,ops[node+1].ival,&numarg);
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ break;
+ case OSEMICOLON:
+ str = str_new(1);
+ str_set(str,"; ");
+ break;
+ case OSTATES:
+ str = walk(0,level,ops[node+1].ival,&numarg);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ 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));
+ str_free(fstr);
+ if (len >= 2) {
+ tmpstr = walk(0,level,ops[node+2].ival,&numarg);
+ if (*tmpstr->str_ptr == ';') {
+ addsemi(str);
+ str_cat(str,tmpstr->str_ptr+1);
+ }
+ str_free(tmpstr);
+ }
+ }
+ break;
+ case OPRINTF:
+ case OPRINT:
+ str = str_new(0);
+ if (len == 3) { /* output redirection */
+ tmpstr = walk(1,level,ops[node+3].ival,&numarg);
+ tmp2str = walk(1,level,ops[node+2].ival,&numarg);
+ 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 (!isalpha(*t) && !isdigit(*t))
+ *t = '_';
+ }
+ if (!index(tokenbuf,'_'))
+ strcpy(t,"_fh");
+ 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");
+ str_free(tmpstr);
+ str_free(tmp2str);
+ safefree(s);
+ safefree(d);
+ }
+ else {
+ sprintf(tokenbuf,"do Pick('%s' . (%s)) &&\n",
+ tmp2str->str_ptr, tmpstr->str_ptr);
+ str_cat(str,tokenbuf);
+ tab(str,level+1);
+ *tokenbuf = '\0';
+ str_free(tmpstr);
+ str_free(tmp2str);
+ }
+ }
+ else
+ strcpy(tokenbuf,"stdout");
+ if (type == OPRINTF)
+ str_cat(str,"printf");
+ else
+ str_cat(str,"print");
+ if (len == 3 || do_fancy_opens) {
+ if (*tokenbuf)
+ str_cat(str," ");
+ str_cat(str,tokenbuf);
+ }
+ tmpstr = walk(1+(type==OPRINT),level,ops[node+1].ival,&numarg);
+ 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," ");
+ str_scat(str,tmpstr);
+ }
+ else {
+ str_cat(str," $_");
+ }
+ str_free(tmpstr);
+ break;
+ 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);
+ else
+ tmpstr = str_new(0);;
+ if (!*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) {
+ str_set(str,"exit");
+ if (len == 1) {
+ str_cat(str," ");
+ exitval = TRUE;
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ 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));
+ 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));
+ str_free(fstr);
+ str_cat(str,") ");
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ 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));
+ str_free(fstr);
+ }
+ else {
+ str_cat(str,"else ");
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
+ 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));
+ str_free(fstr);
+ str_cat(str,") ");
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ 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));
+ 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);
+ 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));
+ str_free(fstr);
+ str_cat(str,") ");
+ str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg));
+ str_free(fstr);
+ break;
+ case OFORIN:
+ tmpstr=walk(0,level,ops[node+2].ival,&numarg);
+ str = str_new(0);
+ str_sset(str,tmpstr);
+ str_cat(str,"[]");
+ tmp2str = hfetch(symtab,str->str_ptr);
+ if (tmp2str && atoi(tmp2str->str_ptr)) {
+ maxtmp++;
+ fstr=walk(1,level,ops[node+1].ival,&numarg);
+ sprintf(tokenbuf,
+ "for ($T_%d = 1; ($%s = $%s[$T_%d]) || $T_%d <= $#%s; $T_%d++)%c",
+ maxtmp,
+ fstr->str_ptr,
+ tmpstr->str_ptr,
+ maxtmp,
+ maxtmp,
+ tmpstr->str_ptr,
+ maxtmp,
+ 0377);
+ str_set(str,tokenbuf);
+ str_free(fstr);
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
+ str_free(fstr);
+ }
+ else {
+ str_set(str,"while (($junkkey,$");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_free(fstr);
+ str_cat(str,") = each(");
+ str_scat(str,tmpstr);
+ str_cat(str,")) ");
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
+ str_free(fstr);
+ }
+ str_free(tmpstr);
+ break;
+ case OBLOCK:
+ str = str_new(0);
+ str_set(str,"{");
+ if (len == 2) {
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ str_free(fstr);
+ }
+ fixtab(str,++level);
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg));
+ str_free(fstr);
+ addsemi(str);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ tab(str,level);
+ break;
+ default:
+ def:
+ if (len) {
+ if (len > 5)
+ fatal("Garbage length in walk");
+ str = walk(0,level,ops[node+1].ival,&numarg);
+ for (i = 2; i<= len; i++) {
+ str_scat(str,fstr=walk(0,level,ops[node+i].ival,&numarg));
+ str_free(fstr);
+ }
+ }
+ else {
+ str = Nullstr;
+ }
+ break;
+ }
+ if (!str)
+ str = str_new(0);
+ *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--;
+ 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]/);\n",const_FS);
+ str_cat(str,tokenbuf);
+ }
+ else if (saw_FS)
+ str_cat(str," = split($FS);\n");
+ else
+ str_cat(str," = split;\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;
+
+ 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 OSUB:
+ 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 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 ONUM:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OSTR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ 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);
+ 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 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 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,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);
+ prewalk(0,level,ops[node+3].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);
+ tmp2str = str_make("1");
+ hstore(symtab,tmpstr->str_ptr,tmp2str);
+ }
+}
https://perl5.git.perl.org / perl5.git / commitdiff