--- /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"))
+ &n
https://perl5.git.perl.org / perl5.git / commitdiff