diff options
-rwxr-xr-x | Configure | 1279 | ||||
-rw-r--r-- | EXTERN.h | 15 | ||||
-rw-r--r-- | INTERN.h | 15 | ||||
-rw-r--r-- | MANIFEST | 112 | ||||
-rw-r--r-- | Makefile.SH | 168 | ||||
-rw-r--r-- | README | 83 | ||||
-rw-r--r-- | Wishlist | 5 | ||||
-rw-r--r-- | arg.c | 2111 | ||||
-rw-r--r-- | arg.h | 314 | ||||
-rw-r--r-- | array.c | 182 | ||||
-rw-r--r-- | array.h | 22 | ||||
-rw-r--r-- | cmd.c | 453 | ||||
-rw-r--r-- | cmd.h | 122 | ||||
-rw-r--r-- | config.H | 80 | ||||
-rw-r--r-- | config.h.SH | 95 | ||||
-rw-r--r-- | dump.c | 253 | ||||
-rw-r--r-- | form.c | 269 | ||||
-rw-r--r-- | form.h | 29 | ||||
-rw-r--r-- | handy.h | 26 | ||||
-rw-r--r-- | hash.c | 238 | ||||
-rw-r--r-- | hash.h | 49 | ||||
-rw-r--r-- | makedepend.SH | 151 | ||||
-rw-r--r-- | makedir.SH | 77 | ||||
-rw-r--r-- | malloc.c | 341 | ||||
-rw-r--r-- | patchlevel.h | 1 | ||||
-rw-r--r-- | perl.h | 196 | ||||
-rw-r--r-- | perl.man.1 | 997 | ||||
-rw-r--r-- | perl.man.2 | 1007 | ||||
-rw-r--r-- | perl.y | 590 | ||||
-rw-r--r-- | perly.c | 2460 | ||||
-rw-r--r-- | search.c | 751 | ||||
-rw-r--r-- | search.h | 39 | ||||
-rw-r--r-- | spat.h | 27 | ||||
-rw-r--r-- | stab.c | 320 | ||||
-rw-r--r-- | stab.h | 58 | ||||
-rw-r--r-- | str.c | 535 | ||||
-rw-r--r-- | str.h | 35 | ||||
-rw-r--r-- | t/README | 11 | ||||
-rw-r--r-- | t/TEST | 68 | ||||
-rw-r--r-- | t/base.cond | 19 | ||||
-rw-r--r-- | t/base.if | 11 | ||||
-rw-r--r-- | t/base.lex | 23 | ||||
-rw-r--r-- | t/base.pat | 11 | ||||
-rw-r--r-- | t/base.term | 36 | ||||
-rw-r--r-- | t/cmd.elsif | 25 | ||||
-rw-r--r-- | t/cmd.for | 25 | ||||
-rw-r--r-- | t/cmd.mod | 28 | ||||
-rw-r--r-- | t/cmd.subval | 50 | ||||
-rw-r--r-- | t/cmd.while | 110 | ||||
-rw-r--r-- | t/comp.cmdopt | 83 | ||||
-rw-r--r-- | t/comp.cpp | 35 | ||||
-rw-r--r-- | t/comp.decl | 49 | ||||
-rw-r--r-- | t/comp.multiline | 40 | ||||
-rw-r--r-- | t/comp.script | 23 | ||||
-rw-r--r-- | t/comp.term | 27 | ||||
-rw-r--r-- | t/io.argv | 36 | ||||
-rw-r--r-- | t/io.fs | 63 | ||||
-rw-r--r-- | t/io.inplace | 19 | ||||
-rw-r--r-- | t/io.print | 25 | ||||
-rw-r--r-- | t/io.tell | 42 | ||||
-rw-r--r-- | t/op.append | 21 | ||||
-rw-r--r-- | t/op.auto | 41 | ||||
-rw-r--r-- | t/op.chop | 21 | ||||
-rw-r--r-- | t/op.cond | 12 | ||||
-rw-r--r-- | t/op.crypt | 12 | ||||
-rw-r--r-- | t/op.do | 34 | ||||
-rw-r--r-- | t/op.each | 50 | ||||
-rw-r--r-- | t/op.exec | 12 | ||||
-rw-r--r-- | t/op.exp | 27 | ||||
-rw-r--r-- | t/op.flip | 26 | ||||
-rw-r--r-- | t/op.fork | 16 | ||||
-rw-r--r-- | t/op.goto | 34 | ||||
-rw-r--r-- | t/op.int | 17 | ||||
-rw-r--r-- | t/op.join | 12 | ||||
-rw-r--r-- | t/op.list | 34 | ||||
-rw-r--r-- | t/op.magic | 27 | ||||
-rw-r--r-- | t/op.oct | 9 | ||||
-rw-r--r-- | t/op.ord | 14 | ||||
-rw-r--r-- | t/op.pat | 56 | ||||
-rw-r--r-- | t/op.push | 11 | ||||
-rw-r--r-- | t/op.repeat | 32 | ||||
-rw-r--r-- | t/op.sleep | 8 | ||||
-rw-r--r-- | t/op.split | 24 | ||||
-rw-r--r-- | t/op.sprintf | 8 | ||||
-rw-r--r-- | t/op.stat | 29 | ||||
-rw-r--r-- | t/op.subst | 38 | ||||
-rw-r--r-- | t/op.time | 43 | ||||
-rw-r--r-- | t/op.unshift | 14 | ||||
-rw-r--r-- | util.c | 263 | ||||
-rw-r--r-- | util.h | 36 | ||||
-rw-r--r-- | version.c | 18 | ||||
-rw-r--r-- | x2p/EXTERN.h | 15 | ||||
-rw-r--r-- | x2p/INTERN.h | 15 | ||||
-rw-r--r-- | x2p/Makefile.SH | 148 | ||||
-rw-r--r-- | x2p/a2p.h | 253 | ||||
-rw-r--r-- | x2p/a2p.man | 191 | ||||
-rw-r--r-- | x2p/a2p.y | 325 | ||||
-rw-r--r-- | x2p/a2py.c | 859 | ||||
-rw-r--r-- | x2p/handy.h | 26 | ||||
-rw-r--r-- | x2p/hash.c | 237 | ||||
-rw-r--r-- | x2p/hash.h | 49 | ||||
-rw-r--r-- | x2p/s2p | 551 | ||||
-rw-r--r-- | x2p/s2p.man | 94 | ||||
-rw-r--r-- | x2p/str.c | 451 | ||||
-rw-r--r-- | x2p/str.h | 35 | ||||
-rw-r--r-- | x2p/util.c | 275 | ||||
-rw-r--r-- | x2p/util.h | 37 | ||||
-rw-r--r-- | x2p/walk.c | 1464 |
108 files changed, 20388 insertions, 0 deletions
diff --git a/Configure b/Configure new file mode 100755 index 0000000000..3035f15e18 --- /dev/null +++ b/Configure @@ -0,0 +1,1279 @@ +#! /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 diff --git a/EXTERN.h b/EXTERN.h new file mode 100644 index 0000000000..a5fff1f74e --- /dev/null +++ b/EXTERN.h @@ -0,0 +1,15 @@ +/* $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 diff --git a/INTERN.h b/INTERN.h new file mode 100644 index 0000000000..06a59f0e71 --- /dev/null +++ b/INTERN.h @@ -0,0 +1,15 @@ +/* $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 diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000000..085b831183 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,112 @@ +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 diff --git a/Makefile.SH b/Makefile.SH new file mode 100644 index 0000000000..f45bb3fe84 --- /dev/null +++ b/Makefile.SH @@ -0,0 +1,168 @@ +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 diff --git a/README b/README new file mode 100644 index 0000000000..b5d95e1776 --- /dev/null +++ b/README @@ -0,0 +1,83 @@ + + 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. + diff --git a/Wishlist b/Wishlist new file mode 100644 index 0000000000..1233293f84 --- /dev/null +++ b/Wishlist @@ -0,0 +1,5 @@ +date support +case statement +ioctl() support +random numbers +directory reading via <> @@ -0,0 +1,2111 @@ +/* $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; +} @@ -0,0 +1,314 @@ +/* $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(); diff --git a/array.c b/array.c new file mode 100644 index 0000000000..156b78378f --- /dev/null +++ b/array.c @@ -0,0 +1,182 @@ +/* $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); +} diff --git a/array.h b/array.h new file mode 100644 index 0000000000..4ad948796d --- /dev/null +++ b/array.h @@ -0,0 +1,22 @@ +/* $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(); @@ -0,0 +1,453 @@ +/* $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; +} @@ -0,0 +1,122 @@ +/* $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(); diff --git a/config.H b/config.H new file mode 100644 index 0000000000..bb9eb6b09a --- /dev/null +++ b/config.H @@ -0,0 +1,80 @@ +/* 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 + diff --git a/config.h.SH b/config.h.SH new file mode 100644 index 0000000000..0789bc69f2 --- /dev/null +++ b/config.h.SH @@ -0,0 +1,95 @@ +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! diff --git a/dump.c b/dump.c new file mode 100644 index 0000000000..4f93fd186c --- /dev/null +++ b/dump.c @@ -0,0 +1,253 @@ +/* $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 diff --git a/form.c b/form.c new file mode 100644 index 0000000000..8894621c9f --- /dev/null +++ b/form.c @@ -0,0 +1,269 @@ +/* $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; +} diff --git a/form.h b/form.h new file mode 100644 index 0000000000..fc2257b43a --- /dev/null +++ b/form.h @@ -0,0 +1,29 @@ +/* $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*) diff --git a/handy.h b/handy.h new file mode 100644 index 0000000000..3eb24774ec --- /dev/null +++ b/handy.h @@ -0,0 +1,26 @@ +/* $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)) diff --git a/hash.c b/hash.c new file mode 100644 index 0000000000..61e7f87941 --- /dev/null +++ b/hash.c @@ -0,0 +1,238 @@ +/* $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; +} diff --git a/hash.h b/hash.h new file mode 100644 index 0000000000..6e9a7a03e8 --- /dev/null +++ b/hash.h @@ -0,0 +1,49 @@ +/* $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(); diff --git a/makedepend.SH b/makedepend.SH new file mode 100644 index 0000000000..6b20cac7bf --- /dev/null +++ b/makedepend.SH @@ -0,0 +1,151 @@ +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 diff --git a/makedir.SH b/makedir.SH new file mode 100644 index 0000000000..54a0c11b2a --- /dev/null +++ b/makedir.SH @@ -0,0 +1,77 @@ +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 diff --git a/malloc.c b/malloc.c new file mode 100644 index 0000000000..17c3b27930 --- /dev/null +++ b/malloc.c @@ -0,0 +1,341 @@ +/* $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 diff --git a/patchlevel.h b/patchlevel.h new file mode 100644 index 0000000000..935ec354b7 --- /dev/null +++ b/patchlevel.h @@ -0,0 +1 @@ +#define PATCHLEVEL 0 diff --git a/perl.h b/perl.h new file mode 100644 index 0000000000..3ccff105c8 --- /dev/null +++ b/perl.h @@ -0,0 +1,196 @@ +/* $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 diff --git a/perl.man.1 b/perl.man.1 new file mode 100644 index 0000000000..ea40065c0d --- /dev/null +++ b/perl.man.1 @@ -0,0 +1,997 @@ +.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 diff --git a/perl.man.2 b/perl.man.2 new file mode 100644 index 0000000000..ecda600dbd --- /dev/null +++ b/perl.man.2 @@ -0,0 +1,1007 @@ +''' 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 }` '' diff --git a/perl.y b/perl.y new file mode 100644 index 0000000000..16f8a9aa96 --- /dev/null +++ b/perl.y @@ -0,0 +1,590 @@ +/* $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" diff --git a/perly.c b/perly.c new file mode 100644 index 0000000000..bc3231813e --- /dev/null +++ b/perly.c @@ -0,0 +1,2460 @@ +char rcsid[] = "$Header: perly.c,v 1.0 87/12/18 15:53:31 root Exp $"; +/* + * $Log: perly.c,v $ + * Revision 1.0 87/12/18 15:53:31 root + * Initial revision + * + */ + +bool preprocess = FALSE; +bool assume_n = FALSE; +bool assume_p = FALSE; +bool doswitches = FALSE; +char *filename; +char *e_tmpname = "/tmp/perl-eXXXXXX"; +FILE *e_fp = Nullfp; +ARG *l(); + +main(argc,argv,env) +register int argc; +register char **argv; +register char **env; +{ + register STR *str; + register char *s; + char *index(); + + linestr = str_new(80); + str = str_make("-I/usr/lib/perl "); /* first used for -I flags */ + for (argc--,argv++; argc; argc--,argv++) { + if (argv[0][0] != '-' || !argv[0][1]) + break; + reswitch: + switch (argv[0][1]) { +#ifdef DEBUGGING + case 'D': + debug = atoi(argv[0]+2); +#ifdef YYDEBUG + yydebug = (debug & 1); +#endif + break; +#endif + case 'e': + if (!e_fp) { + mktemp(e_tmpname); + e_fp = fopen(e_tmpname,"w"); + } + if (argv[1]) + fputs(argv[1],e_fp); + putc('\n', e_fp); + argc--,argv++; + break; + case 'i': + inplace = savestr(argv[0]+2); + argvoutstab = stabent("ARGVOUT",TRUE); + break; + case 'I': + str_cat(str,argv[0]); + str_cat(str," "); + if (!argv[0][2]) { + str_cat(str,argv[1]); + argc--,argv++; + str_cat(str," "); + } + break; + case 'n': + assume_n = TRUE; + strcpy(argv[0], argv[0]+1); + goto reswitch; + case 'p': + assume_p = TRUE; + strcpy(argv[0], argv[0]+1); + goto reswitch; + case 'P': + preprocess = TRUE; + strcpy(argv[0], argv[0]+1); + goto reswitch; + case 's': + doswitches = TRUE; + strcpy(argv[0], argv[0]+1); + goto reswitch; + case 'v': + version(); + exit(0); + case '-': + argc--,argv++; + goto switch_end; + case 0: + break; + default: + fatal("Unrecognized switch: %s\n",argv[0]); + } + } + switch_end: + if (e_fp) { + fclose(e_fp); + argc++,argv--; + argv[0] = e_tmpname; + } + + str_set(&str_no,No); + str_set(&str_yes,Yes); + init_eval(); + + /* open script */ + + if (argv[0] == Nullch) + argv[0] = "-"; + filename = savestr(argv[0]); + if (strEQ(filename,"-")) + argv[0] = ""; + if (preprocess) { + sprintf(buf, "\ +/bin/sed -e '/^[^#]/b' \ + -e '/^#[ ]*include[ ]/b' \ + -e '/^#[ ]*define[ ]/b' \ + -e '/^#[ ]*if[ ]/b' \ + -e '/^#[ ]*ifdef[ ]/b' \ + -e '/^#[ ]*else/b' \ + -e '/^#[ ]*endif/b' \ + -e 's/^#.*//' \ + %s | /lib/cpp -C %s-", + argv[0], str_get(str)); + rsfp = popen(buf,"r"); + } + else if (!*argv[0]) + rsfp = stdin; + else + rsfp = fopen(argv[0],"r"); + if (rsfp == Nullfp) + fatal("Perl script \"%s\" doesn't seem to exist.\n",filename); + str_free(str); /* free -I directories */ + + defstab = stabent("_",TRUE); + + /* init tokener */ + + bufptr = str_get(linestr); + + /* now parse the report spec */ + + if (yyparse()) + fatal("Execution aborted due to compilation errors.\n"); + + if (e_fp) { + e_fp = Nullfp; + UNLINK(e_tmpname); + } + argc--,argv++; /* skip name of script */ + if (doswitches) { + for (; argc > 0 && **argv == '-'; argc--,argv++) { + if (argv[0][1] == '-') { + argc--,argv++; + break; + } + str_numset(stabent(argv[0]+1,TRUE)->stab_val,(double)1.0); + } + } + if (argvstab = stabent("ARGV",FALSE)) { + for (; argc > 0; argc--,argv++) { + apush(argvstab->stab_array,str_make(argv[0])); + } + } + if (envstab = stabent("ENV",FALSE)) { + for (; *env; env++) { + if (!(s = index(*env,'='))) + continue; + *s++ = '\0'; + str = str_make(s); + str->str_link.str_magic = envstab; + hstore(envstab->stab_hash,*env,str); + *--s = '='; + } + } + sigstab = stabent("SIG",FALSE); + + magicalize("!#?^~=-%0123456789.+&*(),\\/[|"); + + (tmpstab = stabent("0",FALSE)) && str_set(STAB_STR(tmpstab),filename); + (tmpstab = stabent("$",FALSE)) && + str_numset(STAB_STR(tmpstab),(double)getpid()); + + tmpstab = stabent("stdin",TRUE); + tmpstab->stab_io = stio_new(); + tmpstab->stab_io->fp = stdin; + + tmpstab = stabent("stdout",TRUE); + tmpstab->stab_io = stio_new(); + tmpstab->stab_io->fp = stdout; + defoutstab = tmpstab; + curoutstab = tmpstab; + + tmpstab = stabent("stderr",TRUE); + tmpstab->stab_io = stio_new(); + tmpstab->stab_io->fp = stderr; + + setjmp(top_env); /* sets goto_targ on longjump */ + +#ifdef DEBUGGING + if (debug & 1024) + dump_cmd(main_root,Nullcmd); + if (debug) + fprintf(stderr,"\nEXECUTING...\n\n"); +#endif + + /* do it */ + + (void) cmd_exec(main_root); + + if (goto_targ) + fatal("Can't find label \"%s\"--aborting.\n",goto_targ); + exit(0); +} + +magicalize(list) +register char *list; +{ + register STAB *stab; + char sym[2]; + + sym[1] = '\0'; + while (*sym = *list++) { + if (stab = stabent(sym,FALSE)) { + stab->stab_flags = SF_VMAGIC; + stab->stab_val->str_link.str_magic = stab; + } + } +} + +#define RETURN(retval) return (bufptr = s,retval) +#define OPERATOR(retval) return (expectterm = TRUE,bufptr = s,retval) +#define TERM(retval) return (expectterm = FALSE,bufptr = s,retval) +#define LOOPX(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,LOOPEX) +#define UNI(f) return (yylval.ival = f,expectterm = TRUE,bufptr = s,UNIOP) +#define FUN0(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC0) +#define FUN1(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC1) +#define FUN2(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC2) +#define FUN3(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC3) +#define SFUN(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,STABFUN) + +yylex() +{ + register char *s = bufptr; + register char *d; + register int tmp; + static bool in_format = FALSE; + static bool firstline = TRUE; + + retry: +#ifdef YYDEBUG + if (yydebug) + if (index(s,'\n')) + fprintf(stderr,"Tokener at %s",s); + else + fprintf(stderr,"Tokener at %s\n",s); +#endif + switch (*s) { + default: + fprintf(stderr, + "Unrecognized character %c in file %s line %d--ignoring.\n", + *s++,filename,line); + goto retry; + case 0: + s = str_get(linestr); + *s = '\0'; + if (firstline && (assume_n || assume_p)) { + firstline = FALSE; + str_set(linestr,"while (<>) {"); + s = str_get(linestr); + goto retry; + } + if (!rsfp) + RETURN(0); + if (in_format) { + yylval.formval = load_format(); /* leaves . in buffer */ + in_format = FALSE; + s = str_get(linestr); + TERM(FORMLIST); + } + line++; + if ((s = str_gets(linestr, rsfp)) == Nullch) { + if (preprocess) + pclose(rsfp); + else if (rsfp != stdin) + fclose(rsfp); + rsfp = Nullfp; + if (assume_n || assume_p) { + str_set(linestr,assume_p ? "}continue{print;" : ""); + str_cat(linestr,"}"); + s = str_get(linestr); + goto retry; + } + s = str_get(linestr); + RETURN(0); + } +#ifdef DEBUG + else if (firstline) { + char *showinput(); + s = showinput(); + } +#endif + firstline = FALSE; + goto retry; + case ' ': case '\t': + s++; + goto retry; + case '\n': + case '#': + if (preprocess && s == str_get(linestr) && + s[1] == ' ' && isdigit(s[2])) { + line = atoi(s+2)-1; + for (s += 2; isdigit(*s); s++) ; + while (*s && isspace(*s)) s++; + if (filename) + safefree(filename); + s[strlen(s)-1] = '\0'; /* wipe out newline */ + filename = savestr(s); + s = str_get(linestr); + } + *s = '\0'; + if (lex_newlines) + RETURN('\n'); + goto retry; + case '+': + case '-': + if (s[1] == *s) { + s++; + if (*s++ == '+') + RETURN(INC); + else + RETURN(DEC); + } + /* FALL THROUGH */ + case '*': + case '%': + case '^': + case '~': + case '(': + case ',': + case ':': + case ';': + case '{': + case '[': + tmp = *s++; + OPERATOR(tmp); + case ')': + case ']': + case '}': + tmp = *s++; + TERM(tmp); + case '&': + s++; + tmp = *s++; + if (tmp == '&') + OPERATOR(ANDAND); + s--; + OPERATOR('&'); + case '|': + s++; + tmp = *s++; + if (tmp == '|') + OPERATOR(OROR); + s--; + OPERATOR('|'); + case '=': + s++; + tmp = *s++; + if (tmp == '=') + OPERATOR(EQ); + if (tmp == '~') + OPERATOR(MATCH); + s--; + OPERATOR('='); + case '!': + s++; + tmp = *s++; + if (tmp == '=') + OPERATOR(NE); + if (tmp == '~') + OPERATOR(NMATCH); + s--; + OPERATOR('!'); + case '<': + if (expectterm) { + s = scanstr(s); + TERM(RSTRING); + } + s++; + tmp = *s++; + if (tmp == '<') + OPERATOR(LS); + if (tmp == '=') + OPERATOR(LE); + s--; + OPERATOR('<'); + case '>': + s++; + tmp = *s++; + if (tmp == '>') + OPERATOR(RS); + if (tmp == '=') + OPERATOR(GE); + s--; + OPERATOR('>'); + +#define SNARFWORD \ + d = tokenbuf; \ + while (isalpha(*s) || isdigit(*s) || *s == '_') \ + *d++ = *s++; \ + *d = '\0'; \ + d = tokenbuf; + + case '$': + if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) { + s++; + s = scanreg(s,tokenbuf); + yylval.stabval = aadd(stabent(tokenbuf,TRUE)); + TERM(ARYLEN); + } + s = scanreg(s,tokenbuf); + yylval.stabval = stabent(tokenbuf,TRUE); + TERM(REG); + + case '@': + s = scanreg(s,tokenbuf); + yylval.stabval = aadd(stabent(tokenbuf,TRUE)); + TERM(ARY); + + case '/': /* may either be division or pattern */ + case '?': /* may either be conditional or pattern */ + if (expectterm) { + s = scanpat(s); + TERM(PATTERN); + } + tmp = *s++; + OPERATOR(tmp); + + case '.': + if (!expectterm || !isdigit(s[1])) { + s++; + tmp = *s++; + if (tmp == '.') + OPERATOR(DOTDOT); + s--; + OPERATOR('.'); + } + /* FALL THROUGH */ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + case '\'': case '"': case '`': + s = scanstr(s); + TERM(RSTRING); + + case '_': + SNARFWORD; + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'a': case 'A': + SNARFWORD; + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'b': case 'B': + SNARFWORD; + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'c': case 'C': + SNARFWORD; + if (strEQ(d,"continue")) + OPERATOR(CONTINUE); + if (strEQ(d,"chdir")) + UNI(O_CHDIR); + if (strEQ(d,"close")) + OPERATOR(CLOSE); + if (strEQ(d,"crypt")) + FUN2(O_CRYPT); + if (strEQ(d,"chop")) + OPERATOR(CHOP); + if (strEQ(d,"chmod")) { + yylval.ival = O_CHMOD; + OPERATOR(PRINT); + } + if (strEQ(d,"chown")) { + yylval.ival = O_CHOWN; + OPERATOR(PRINT); + } + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'd': case 'D': + SNARFWORD; + if (strEQ(d,"do")) + OPERATOR(DO); + if (strEQ(d,"die")) + UNI(O_DIE); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'e': case 'E': + SNARFWORD; + if (strEQ(d,"else")) + OPERATOR(ELSE); + if (strEQ(d,"elsif")) + OPERATOR(ELSIF); + if (strEQ(d,"eq") || strEQ(d,"EQ")) + OPERATOR(SEQ); + if (strEQ(d,"exit")) + UNI(O_EXIT); + if (strEQ(d,"eof")) + TERM(FEOF); + if (strEQ(d,"exp")) + FUN1(O_EXP); + if (strEQ(d,"each")) + SFUN(O_EACH); + if (strEQ(d,"exec")) { + yylval.ival = O_EXEC; + OPERATOR(PRINT); + } + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'f': case 'F': + SNARFWORD; + if (strEQ(d,"for")) + OPERATOR(FOR); + if (strEQ(d,"format")) { + in_format = TRUE; + OPERATOR(FORMAT); + } + if (strEQ(d,"fork")) + FUN0(O_FORK); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'g': case 'G': + SNARFWORD; + if (strEQ(d,"gt") || strEQ(d,"GT")) + OPERATOR(SGT); + if (strEQ(d,"ge") || strEQ(d,"GE")) + OPERATOR(SGE); + if (strEQ(d,"goto")) + LOOPX(O_GOTO); + if (strEQ(d,"gmtime")) + FUN1(O_GMTIME); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'h': case 'H': + SNARFWORD; + if (strEQ(d,"hex")) + FUN1(O_HEX); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'i': case 'I': + SNARFWORD; + if (strEQ(d,"if")) + OPERATOR(IF); + if (strEQ(d,"index")) + FUN2(O_INDEX); + if (strEQ(d,"int")) + FUN1(O_INT); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'j': case 'J': + SNARFWORD; + if (strEQ(d,"join")) + OPERATOR(JOIN); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'k': case 'K': + SNARFWORD; + if (strEQ(d,"keys")) + SFUN(O_KEYS); + if (strEQ(d,"kill")) { + yylval.ival = O_KILL; + OPERATOR(PRINT); + } + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'l': case 'L': + SNARFWORD; + if (strEQ(d,"last")) + LOOPX(O_LAST); + if (strEQ(d,"length")) + FUN1(O_LENGTH); + if (strEQ(d,"lt") || strEQ(d,"LT")) + OPERATOR(SLT); + if (strEQ(d,"le") || strEQ(d,"LE")) + OPERATOR(SLE); + if (strEQ(d,"localtime")) + FUN1(O_LOCALTIME); + if (strEQ(d,"log")) + FUN1(O_LOG); + if (strEQ(d,"link")) + FUN2(O_LINK); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'm': case 'M': + SNARFWORD; + if (strEQ(d,"m")) { + s = scanpat(s-1); + TERM(PATTERN); + } + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'n': case 'N': + SNARFWORD; + if (strEQ(d,"next")) + LOOPX(O_NEXT); + if (strEQ(d,"ne") || strEQ(d,"NE")) + OPERATOR(SNE); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'o': case 'O': + SNARFWORD; + if (strEQ(d,"open")) + OPERATOR(OPEN); + if (strEQ(d,"ord")) + FUN1(O_ORD); + if (strEQ(d,"oct")) + FUN1(O_OCT); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'p': case 'P': + SNARFWORD; + if (strEQ(d,"print")) { + yylval.ival = O_PRINT; + OPERATOR(PRINT); + } + if (strEQ(d,"printf")) { + yylval.ival = O_PRTF; + OPERATOR(PRINT); + } + if (strEQ(d,"push")) { + yylval.ival = O_PUSH; + OPERATOR(PUSH); + } + if (strEQ(d,"pop")) + OPERATOR(POP); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'q': case 'Q': + SNARFWORD; + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'r': case 'R': + SNARFWORD; + if (strEQ(d,"reset")) + UNI(O_RESET); + if (strEQ(d,"redo")) + LOOPX(O_REDO); + if (strEQ(d,"rename")) + FUN2(O_RENAME); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 's': case 'S': + SNARFWORD; + if (strEQ(d,"s")) { + s = scansubst(s); + TERM(SUBST); + } + if (strEQ(d,"shift")) + TERM(SHIFT); + if (strEQ(d,"split")) + TERM(SPLIT); + if (strEQ(d,"substr")) + FUN3(O_SUBSTR); + if (strEQ(d,"sprintf")) + OPERATOR(SPRINTF); + if (strEQ(d,"sub")) + OPERATOR(SUB); + if (strEQ(d,"select")) + OPERATOR(SELECT); + if (strEQ(d,"seek")) + OPERATOR(SEEK); + if (strEQ(d,"stat")) + OPERATOR(STAT); + if (strEQ(d,"sqrt")) + FUN1(O_SQRT); + if (strEQ(d,"sleep")) + UNI(O_SLEEP); + if (strEQ(d,"system")) { + yylval.ival = O_SYSTEM; + OPERATOR(PRINT); + } + yylval.cval = savestr(d); + OPERATOR(WORD); + case 't': case 'T': + SNARFWORD; + if (strEQ(d,"tr")) { + s = scantrans(s); + TERM(TRANS); + } + if (strEQ(d,"tell")) + TERM(TELL); + if (strEQ(d,"time")) + FUN0(O_TIME); + if (strEQ(d,"times")) + FUN0(O_TMS); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'u': case 'U': + SNARFWORD; + if (strEQ(d,"using")) + OPERATOR(USING); + if (strEQ(d,"until")) + OPERATOR(UNTIL); + if (strEQ(d,"unless")) + OPERATOR(UNLESS); + if (strEQ(d,"umask")) + FUN1(O_UMASK); + if (strEQ(d,"unshift")) { + yylval.ival = O_UNSHIFT; + OPERATOR(PUSH); + } + if (strEQ(d,"unlink")) { + yylval.ival = O_UNLINK; + OPERATOR(PRINT); + } + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'v': case 'V': + SNARFWORD; + if (strEQ(d,"values")) + SFUN(O_VALUES); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'w': case 'W': + SNARFWORD; + if (strEQ(d,"write")) + TERM(WRITE); + if (strEQ(d,"while")) + OPERATOR(WHILE); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'x': case 'X': + SNARFWORD; + if (!expectterm && strEQ(d,"x")) + OPERATOR('x'); + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'y': case 'Y': + SNARFWORD; + if (strEQ(d,"y")) { + s = scantrans(s); + TERM(TRANS); + } + yylval.cval = savestr(d); + OPERATOR(WORD); + case 'z': case 'Z': + SNARFWORD; + yylval.cval = savestr(d); + OPERATOR(WORD); + } +} + +STAB * +stabent(name,add) +register char *name; +int add; +{ + register STAB *stab; + + for (stab = stab_index[*name]; stab; stab = stab->stab_next) { + if (strEQ(name,stab->stab_name)) + return stab; + } + + /* no entry--should we add one? */ + + if (add) { + stab = (STAB *) safemalloc(sizeof(STAB)); + bzero((char*)stab, sizeof(STAB)); + stab->stab_name = savestr(name); + stab->stab_val = str_new(0); + stab->stab_next = stab_index[*name]; + stab_index[*name] = stab; + return stab; + } + return Nullstab; +} + +STIO * +stio_new() +{ + STIO *stio = (STIO *) safemalloc(sizeof(STIO)); + + bzero((char*)stio, sizeof(STIO)); + stio->page_len = 60; + return stio; +} + +char * +scanreg(s,dest) +register char *s; +char *dest; +{ + register char *d; + + s++; + d = dest; + while (isalpha(*s) || isdigit(*s) || *s == '_') + *d++ = *s++; + *d = '\0'; + d = dest; + if (!*d) { + *d = *s++; + if (*d == '{') { + d = dest; + while (*s && *s != '}') + *d++ = *s++; + *d = '\0'; + d = dest; + if (*s) + s++; + } + else + d[1] = '\0'; + } + if (*d == '^' && !isspace(*s)) + *d = *s++ & 31; + return s; +} + +STR * +scanconst(string) +char *string; +{ + register STR *retstr; + register char *t; + register char *d; + + if (index(string,'|')) { + return Nullstr; + } + retstr = str_make(string); + t = str_get(retstr); + for (d=t; *d; ) { + switch (*d) { + case '.': case '[': case '$': case '(': case ')': case '|': + *d = '\0'; + break; + case '\\': + if (index("wWbB0123456789",d[1])) { + *d = '\0'; + break; + } + strcpy(d,d+1); + switch(*d) { + case 'n': + *d = '\n'; + break; + case 't': + *d = '\t'; + break; + case 'f': + *d = '\f'; + break; + case 'r': + *d = '\r'; + break; + } + /* FALL THROUGH */ + default: + if (d[1] == '*' || d[1] == '+' || d[1] == '?') { + *d = '\0'; + break; + } + d++; + } + } + if (!*t) { + str_free(retstr); + return Nullstr; + } + retstr->str_cur = strlen(retstr->str_ptr); /* XXX cheating here */ + return retstr; +} + +char * +scanpat(s) +register char *s; +{ + register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT)); + register char *d; + + bzero((char *)spat, sizeof(SPAT)); + spat->spat_next = spat_root; /* link into spat list */ + spat_root = spat; + init_compex(&spat->spat_compex); + + switch (*s++) { + case 'm': + s++; + break; + case '/': + break; + case '?': + spat->spat_flags |= SPAT_USE_ONCE; + break; + default: + fatal("Search pattern not found:\n%s",str_get(linestr)); + } + s = cpytill(tokenbuf,s,s[-1]); + if (!*s) + fatal("Search pattern not terminated:\n%s",str_get(linestr)); + s++; + if (*tokenbuf == '^') { + spat->spat_first = scanconst(tokenbuf+1); + if (spat->spat_first) { + spat->spat_flen = strlen(spat->spat_first->str_ptr); + if (spat->spat_flen == strlen(tokenbuf+1)) + spat->spat_flags |= SPAT_SCANALL; + } + } + else { + spat->spat_flags |= SPAT_SCANFIRST; + spat->spat_first = scanconst(tokenbuf); + if (spat->spat_first) { + spat->spat_flen = strlen(spat->spat_first->str_ptr); + if (spat->spat_flen == strlen(tokenbuf)) + spat->spat_flags |= SPAT_SCANALL; + } + } + if (d = compile(&spat->spat_compex,tokenbuf,TRUE,FALSE)) + fatal(d); + yylval.arg = make_match(O_MATCH,stab_to_arg(A_STAB,defstab),spat); + return s; +} + +char * +scansubst(s) +register char *s; +{ + register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT)); + register char *d; + + bzero((char *)spat, sizeof(SPAT)); + spat->spat_next = spat_root; /* link into spat list */ + spat_root = spat; + init_compex(&spat->spat_compex); + + s = cpytill(tokenbuf,s+1,*s); + if (!*s) + fatal("Substitution pattern not terminated:\n%s",str_get(linestr)); + for (d=tokenbuf; *d; d++) { + if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') { + register ARG *arg; + + spat->spat_runtime = arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = A_DOUBLE; + arg[1].arg_ptr.arg_str = str_make(tokenbuf); + goto get_repl; /* skip compiling for now */ + } + } + if (*tokenbuf == '^') { + spat->spat_first = scanconst(tokenbuf+1); + if (spat->spat_first) + spat->spat_flen = strlen(spat->spat_first->str_ptr); + } + else { + spat->spat_flags |= SPAT_SCANFIRST; + spat->spat_first = scanconst(tokenbuf); + if (spat->spat_first) + spat->spat_flen = strlen(spat->spat_first->str_ptr); + } + if (d = compile(&spat->spat_compex,tokenbuf,TRUE,FALSE)) + fatal(d); +get_repl: + s = scanstr(s); + if (!*s) + fatal("Substitution replacement not terminated:\n%s",str_get(linestr)); + spat->spat_repl = yylval.arg; + if (*s == 'g') { + s++; + spat->spat_flags &= ~SPAT_USE_ONCE; + } + else + spat->spat_flags |= SPAT_USE_ONCE; + yylval.arg = make_match(O_SUBST,stab_to_arg(A_STAB,defstab),spat); + return s; +} + +ARG * +make_split(stab,arg) +register STAB *stab; +register ARG *arg; +{ + if (arg->arg_type != O_MATCH) { + register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT)); + register char *d; + + bzero((char *)spat, sizeof(SPAT)); + spat->spat_next = spat_root; /* link into spat list */ + spat_root = spat; + init_compex(&spat->spat_compex); + + spat->spat_runtime = arg; + arg = make_match(O_MATCH,stab_to_arg(A_STAB,defstab),spat); + } + arg->arg_type = O_SPLIT; + arg[2].arg_ptr.arg_spat->spat_repl = stab_to_arg(A_STAB,aadd(stab)); + return arg; +} + +char * +expand_charset(s) +register char *s; +{ + char t[512]; + register char *d = t; + register int i; + + while (*s) { + if (s[1] == '-' && s[2]) { + for (i = s[0]; i <= s[2]; i++) + *d++ = i; + s += 3; + } + else + *d++ = *s++; + } + *d = '\0'; + return savestr(t); +} + +char * +scantrans(s) +register char *s; +{ + ARG *arg = + l(make_op(O_TRANS,2,stab_to_arg(A_STAB,defstab),Nullarg,Nullarg,0)); + register char *t; + register char *r; + register char *tbl = safemalloc(256); + register int i; + + arg[2].arg_type = A_NULL; + arg[2].arg_ptr.arg_cval = tbl; + for (i=0; i<256; i++) + tbl[i] = 0; + s = scanstr(s); + if (!*s) + fatal("Translation pattern not terminated:\n%s",str_get(linestr)); + t = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str)); + free_arg(yylval.arg); + s = scanstr(s-1); + if (!*s) + fatal("Translation replacement not terminated:\n%s",str_get(linestr)); + r = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str)); + free_arg(yylval.arg); + yylval.arg = arg; + if (!*r) { + safefree(r); + r = t; + } + for (i = 0; t[i]; i++) { + if (!r[i]) + r[i] = r[i-1]; + tbl[t[i] & 0377] = r[i]; + } + if (r != t) + safefree(r); + safefree(t); + return s; +} + +CMD * +block_head(tail) +register CMD *tail; +{ + if (tail == Nullcmd) { + return tail; + } + return tail->c_head; +} + +CMD * +append_line(head,tail) +register CMD *head; +register CMD *tail; +{ + if (tail == Nullcmd) + return head; + if (!tail->c_head) /* make sure tail is well formed */ + tail->c_head = tail; + if (head != Nullcmd) { + tail = tail->c_head; /* get to start of tail list */ + if (!head->c_head) + head->c_head = head; /* start a new head list */ + while (head->c_next) { + head->c_next->c_head = head->c_head; + head = head->c_next; /* get to end of head list */ + } + head->c_next = tail; /* link to end of old list */ + tail->c_head = head->c_head; /* propagate head pointer */ + } + while (tail->c_next) { + tail->c_next->c_head = tail->c_head; + tail = tail->c_next; + } + return tail; +} + +CMD * +make_acmd(type,stab,cond,arg) +int type; +STAB *stab; +ARG *cond; +ARG *arg; +{ + register CMD *cmd = (CMD *) safemalloc(sizeof (CMD)); + + bzero((char *)cmd, sizeof(CMD)); + cmd->c_type = type; + cmd->ucmd.acmd.ac_stab = stab; + cmd->ucmd.acmd.ac_expr = arg; + cmd->c_expr = cond; + if (cond) { + opt_arg(cmd,1); + cmd->c_flags |= CF_COND; + } + return cmd; +} + +CMD * +make_ccmd(type,arg,cblock) +int type; +register ARG *arg; +struct compcmd cblock; +{ + register CMD *cmd = (CMD *) safemalloc(sizeof (CMD)); + + bzero((char *)cmd, sizeof(CMD)); + cmd->c_type = type; + cmd->c_expr = arg; + cmd->ucmd.ccmd.cc_true = cblock.comp_true; + cmd->ucmd.ccmd.cc_alt = cblock.comp_alt; + if (arg) { + opt_arg(cmd,1); + cmd->c_flags |= CF_COND; + } + return cmd; +} + +void +opt_arg(cmd,fliporflop) +register CMD *cmd; +int fliporflop; +{ + register ARG *arg; + int opt = CFT_EVAL; + int sure = 0; + ARG *arg2; + char *tmps; /* for True macro */ + int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */ + int flp = fliporflop; + + if (!cmd) + return; + arg = cmd->c_expr; + + /* Turn "if (!expr)" into "unless (expr)" */ + + while (arg->arg_type == O_NOT && arg[1].arg_type == A_EXPR) { + cmd->c_flags ^= CF_INVERT; /* flip sense of cmd */ + cmd->c_expr = arg[1].arg_ptr.arg_arg; /* hoist the rest of expr */ + free_arg(arg); + arg = cmd->c_expr; /* here we go again */ + } + + if (!arg->arg_len) { /* sanity check */ + cmd->c_flags |= opt; + return; + } + + /* for "cond .. cond" we set up for the initial check */ + + if (arg->arg_type == O_FLIP) + context |= 4; + + /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */ + + if (arg->arg_type == O_AND) + context |= 1; + else if (arg->arg_type == O_OR) + context |= 2; + if (context && arg[flp].arg_type == A_EXPR) { + arg = arg[flp].arg_ptr.arg_arg; + flp = 1; + } + + if (arg[flp].arg_flags & (AF_PRE|AF_POST)) { + cmd->c_flags |= opt; + return; /* side effect, can't optimize */ + } + + if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP || + arg->arg_type == O_AND || arg->arg_type == O_OR) { + if (arg[flp].arg_type == A_SINGLE) { + opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE); + cmd->c_first = arg[flp].arg_ptr.arg_str; + goto literal; + } + else if (arg[flp].arg_type == A_STAB || arg[flp].arg_type == A_LVAL) { + cmd->c_stab = arg[flp].arg_ptr.arg_stab; + opt = CFT_REG; + literal: + if (!context) { /* no && or ||? */ + free_arg(arg); + cmd->c_expr = Nullarg; + } + if (!(context & 1)) + cmd->c_flags |= CF_EQSURE; + if (!(context & 2)) + cmd->c_flags |= CF_NESURE; + } + } + else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST || + arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) { + if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && + arg[2].arg_type == A_SPAT && + arg[2].arg_ptr.arg_spat->spat_first ) { + cmd->c_stab = arg[1].arg_ptr.arg_stab; + cmd->c_first = arg[2].arg_ptr.arg_spat->spat_first; + cmd->c_flen = arg[2].arg_ptr.arg_spat->spat_flen; + if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANALL && + (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) ) + sure |= CF_EQSURE; /* (SUBST must be forced even */ + /* if we know it will work.) */ + arg[2].arg_ptr.arg_spat->spat_first = Nullstr; + arg[2].arg_ptr.arg_spat->spat_flen = 0; /* only one chk */ + sure |= CF_NESURE; /* normally only sure if it fails */ + if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) + cmd->c_flags |= CF_FIRSTNEG; + if (context & 1) { /* only sure if thing is false */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_NESURE; + else + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_EQSURE; + else + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { /* if we know anything*/ + if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST) + opt = CFT_SCAN; + else + opt = CFT_ANCHOR; + if (sure == (CF_EQSURE|CF_NESURE) /* really sure? */ + && arg->arg_type == O_MATCH + && context & 4 + && fliporflop == 1) { + arg[2].arg_type = A_SINGLE; /* don't do twice */ + arg[2].arg_ptr.arg_str = &str_yes; + } + cmd->c_flags |= sure; + } + } + } + else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE || + arg->arg_type == O_SLT || arg->arg_type == O_SGT) { + if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) { + if (arg[2].arg_type == A_SINGLE) { + cmd->c_stab = arg[1].arg_ptr.arg_stab; + cmd->c_first = arg[2].arg_ptr.arg_str; + cmd->c_flen = 30000; + switch (arg->arg_type) { + case O_SLT: case O_SGT: + sure |= CF_EQSURE; + cmd->c_flags |= CF_FIRSTNEG; + break; + case O_SNE: + cmd->c_flags |= CF_FIRSTNEG; + /* FALL THROUGH */ + case O_SEQ: + sure |= CF_NESURE|CF_EQSURE; + break; + } + if (context & 1) { /* only sure if thing is false */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_NESURE; + else + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_EQSURE; + else + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { + opt = CFT_STROP; + cmd->c_flags |= sure; + } + } + } + } + else if (arg->arg_type == O_ASSIGN && + (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && + arg[1].arg_ptr.arg_stab == defstab && + arg[2].arg_type == A_EXPR ) { + arg2 = arg[2].arg_ptr.arg_arg; + if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) { + opt = CFT_GETS; + cmd->c_stab = arg2[1].arg_ptr.arg_stab; + if (!(arg2[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV)) { + free_arg(arg2); + free_arg(arg); + cmd->c_expr = Nullarg; + } + } + } + else if (arg->arg_type == O_CHOP && + (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) { + opt = CFT_CHOP; + cmd->c_stab = arg[1].arg_ptr.arg_stab; + free_arg(arg); + cmd->c_expr = Nullarg; + } + if (context & 4) + opt |= CF_FLIP; + cmd->c_flags |= opt; + + if (cmd->c_flags & CF_FLIP) { + if (fliporflop == 1) { + arg = cmd->c_expr; /* get back to O_FLIP arg */ + arg[3].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD)); + bcopy((char *)cmd, (char *)arg[3].arg_ptr.arg_cmd, sizeof(CMD)); + arg[4].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD)); + bcopy((char *)cmd, (char *)arg[4].arg_ptr.arg_cmd, sizeof(CMD)); + opt_arg(arg[4].arg_ptr.arg_cmd,2); + arg->arg_len = 2; /* this is a lie */ + } + else { + if ((opt & CF_OPTIMIZE) == CFT_EVAL) + cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP; + } + } +} + +ARG * +mod_match(type,left,pat) +register ARG *left; +register ARG *pat; +{ + + register SPAT *spat; + register ARG *newarg; + + if ((pat->arg_type == O_MATCH || + pat->arg_type == O_SUBST || + pat->arg_type == O_TRANS || + pat->arg_type == O_SPLIT + ) && + pat[1].arg_ptr.arg_stab == defstab ) { + switch (pat->arg_type) { + case O_MATCH: + newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH, + pat->arg_len, + left,Nullarg,Nullarg,0); + break; + case O_SUBST: + newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST, + pat->arg_len, + left,Nullarg,Nullarg,0)); + break; + case O_TRANS: + newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS, + pat->arg_len, + left,Nullarg,Nullarg,0)); + break; + case O_SPLIT: + newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT, + pat->arg_len, + left,Nullarg,Nullarg,0); + break; + } + if (pat->arg_len >= 2) { + newarg[2].arg_type = pat[2].arg_type; + newarg[2].arg_ptr = pat[2].arg_ptr; + newarg[2].arg_flags = pat[2].arg_flags; + if (pat->arg_len >= 3) { + newarg[3].arg_type = pat[3].arg_type; + newarg[3].arg_ptr = pat[3].arg_ptr; + newarg[3].arg_flags = pat[3].arg_flags; + } + } + safefree((char*)pat); + } + else { + spat = (SPAT *) safemalloc(sizeof (SPAT)); + bzero((char *)spat, sizeof(SPAT)); + spat->spat_next = spat_root; /* link into spat list */ + spat_root = spat; + init_compex(&spat->spat_compex); + + spat->spat_runtime = pat; + newarg = make_op(type,2,left,Nullarg,Nullarg,0); + newarg[2].arg_type = A_SPAT; + newarg[2].arg_ptr.arg_spat = spat; + newarg[2].arg_flags = AF_SPECIAL; + } + + return newarg; +} + +CMD * +add_label(lbl,cmd) +char *lbl; +register CMD *cmd; +{ + if (cmd) + cmd->c_label = lbl; + return cmd; +} + +CMD * +addcond(cmd, arg) +register CMD *cmd; +register ARG *arg; +{ + cmd->c_expr = arg; + opt_arg(cmd,1); + cmd->c_flags |= CF_COND; + return cmd; +} + +CMD * +addloop(cmd, arg) +register CMD *cmd; +register ARG *arg; +{ + cmd->c_expr = arg; + opt_arg(cmd,1); + cmd->c_flags |= CF_COND|CF_LOOP; + if (cmd->c_type == C_BLOCK) + cmd->c_flags &= ~CF_COND; + else { + arg = cmd->ucmd.acmd.ac_expr; + if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD) + cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */ + if (arg && arg->arg_type == O_SUBR) + cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */ + } + return cmd; +} + +CMD * +invert(cmd) +register CMD *cmd; +{ + cmd->c_flags ^= CF_INVERT; + return cmd; +} + +yyerror(s) +char *s; +{ + char tmpbuf[128]; + char *tname = tmpbuf; + + if (yychar > 256) { + tname = tokename[yychar-256]; + if (strEQ(tname,"word")) + strcpy(tname,tokenbuf); + else if (strEQ(tname,"register")) + sprintf(tname,"$%s",tokenbuf); + else if (strEQ(tname,"array_length")) + sprintf(tname,"$#%s",tokenbuf); + } + else if (!yychar) + strcpy(tname,"EOF"); + else if (yychar < 32) + sprintf(tname,"^%c",yychar+64); + else if (yychar == 127) + strcpy(tname,"^?"); + else + sprintf(tname,"%c",yychar); + printf("%s in file %s at line %d, next token \"%s\"\n", + s,filename,line,tname); +} + +char * +scanstr(s) +register char *s; +{ + register char term; + register char *d; + register ARG *arg; + register bool makesingle = FALSE; + char *leave = "\\$nrtfb0123456789"; /* which backslash sequences to keep */ + + arg = op_new(1); + yylval.arg = arg; + arg->arg_type = O_ITEM; + + switch (*s) { + default: /* a substitution replacement */ + arg[1].arg_type = A_DOUBLE; + makesingle = TRUE; /* maybe disable runtime scanning */ + term = *s; + if (term == '\'') + leave = Nullch; + goto snarf_it; + case '0': + { + long i; + int shift; + + arg[1].arg_type = A_SINGLE; + if (s[1] == 'x') { + shift = 4; + s += 2; + } + else if (s[1] == '.') + goto decimal; + else + shift = 3; + i = 0; + for (;;) { + switch (*s) { + default: + goto out; + case '8': case '9': + if (shift != 4) + fatal("Illegal octal digit at line %d",line); + /* FALL THROUGH */ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + i <<= shift; + i += *s++ & 15; + break; + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + if (shift != 4) + goto out; + i <<= 4; + i += (*s++ & 7) + 9; + break; + } + } + out: + sprintf(tokenbuf,"%d",i); + arg[1].arg_ptr.arg_str = str_make(tokenbuf); + } + break; + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': case '.': + decimal: + arg[1].arg_type = A_SINGLE; + d = tokenbuf; + while (isdigit(*s) || *s == '_') + *d++ = *s++; + if (*s == '.' && index("0123456789eE",s[1])) + *d++ = *s++; + while (isdigit(*s) || *s == '_') + *d++ = *s++; + if (index("eE",*s) && index("+-0123456789",s[1])) + *d++ = *s++; + if (*s == '+' || *s == '-') + *d++ = *s++; + while (isdigit(*s)) + *d++ = *s++; + *d = '\0'; + arg[1].arg_ptr.arg_str = str_make(tokenbuf); + break; + case '\'': + arg[1].arg_type = A_SINGLE; + term = *s; + leave = Nullch; + goto snarf_it; + + case '<': + arg[1].arg_type = A_READ; + s = cpytill(tokenbuf,s+1,'>'); + if (!*tokenbuf) + strcpy(tokenbuf,"ARGV"); + if (*s) + s++; + if (rsfp == stdin && strEQ(tokenbuf,"stdin")) + fatal("Can't get both program and data from <stdin>\n"); + arg[1].arg_ptr.arg_stab = stabent(tokenbuf,TRUE); + arg[1].arg_ptr.arg_stab->stab_io = stio_new(); + if (strEQ(tokenbuf,"ARGV")) { + aadd(arg[1].arg_ptr.arg_stab); + arg[1].arg_ptr.arg_stab->stab_io->flags |= IOF_ARGV|IOF_START; + } + break; + case '"': + arg[1].arg_type = A_DOUBLE; + makesingle = TRUE; /* maybe disable runtime scanning */ + term = *s; + goto snarf_it; + case '`': + arg[1].arg_type = A_BACKTICK; + term = *s; + snarf_it: + { + STR *tmpstr; + int sqstart = line; + char *tmps; + + tmpstr = str_new(strlen(s)); + s = str_append_till(tmpstr,s+1,term,leave); + while (!*s) { /* multiple line string? */ + s = str_gets(linestr, rsfp); + if (!*s) + fatal("EOF in string at line %d\n",sqstart); + line++; + s = str_append_till(tmpstr,s,term,leave); + } + s++; + if (term == '\'') { + arg[1].arg_ptr.arg_str = tmpstr; + break; + } + tmps = s; + s = d = tmpstr->str_ptr; /* assuming shrinkage only */ + while (*s) { + if (*s == '$' && s[1]) { + makesingle = FALSE; /* force interpretation */ + if (!isalpha(s[1])) { /* an internal register? */ + int len; + + len = scanreg(s,tokenbuf) - s; + stabent(tokenbuf,TRUE); /* make sure it's created */ + while (len--) + *d++ = *s++; + continue; + } + } + else if (*s == '\\' && s[1]) { + s++; + switch (*s) { + default: + defchar: + if (!leave || index(leave,*s)) + *d++ = '\\'; + *d++ = *s++; + continue; + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + *d = *s++ - '0'; + if (index("01234567",*s)) { + *d <<= 3; + *d += *s++ - '0'; + } + else if (!index('`"',term)) { /* oops, a subpattern */ + s--; + goto defchar; + } + if (index("01234567",*s)) { + *d <<= 3; + *d += *s++ - '0'; + } + d++; + continue; + case 'b': + *d++ = '\b'; + break; + case 'n': + *d++ = '\n'; + break; + case 'r': + *d++ = '\r'; + break; + case 'f': + *d++ = '\f'; + break; + case 't': + *d++ = '\t'; + break; + } + s++; + continue; + } + *d++ = *s++; + } + *d = '\0'; + if (arg[1].arg_type == A_DOUBLE) { + if (makesingle) + arg[1].arg_type = A_SINGLE; /* now we can optimize on it */ + else + leave = "\\"; + for (d = s = tmpstr->str_ptr; *s; *d++ = *s++) { + if (*s == '\\' && (!leave || index(leave,s[1]))) + s++; + } + *d = '\0'; + } + tmpstr->str_cur = d - tmpstr->str_ptr; /* XXX cheat */ + arg[1].arg_ptr.arg_str = tmpstr; + s = tmps; + break; + } + } + return s; +} + +ARG * +make_op(type,newlen,arg1,arg2,arg3,dolist) +int type; +int newlen; +ARG *arg1; +ARG *arg2; +ARG *arg3; +int dolist; +{ + register ARG *arg; + register ARG *chld; + register int doarg; + + arg = op_new(newlen); + arg->arg_type = type; + doarg = opargs[type]; + if (chld = arg1) { + if (!(doarg & 1)) + arg[1].arg_flags |= AF_SPECIAL; + if (doarg & 16) + arg[1].arg_flags |= AF_NUMERIC; + if (chld->arg_type == O_ITEM && + (hoistable[chld[1].arg_type] || chld[1].arg_type == A_LVAL) ) { + arg[1].arg_type = chld[1].arg_type; + arg[1].arg_ptr = chld[1].arg_ptr; + arg[1].arg_flags |= chld[1].arg_flags; + free_arg(chld); + } + else { + arg[1].arg_type = A_EXPR; + arg[1].arg_ptr.arg_arg = chld; + if (dolist & 1) { + if (chld->arg_type == O_LIST) { + if (newlen == 1) { /* we can hoist entire list */ + chld->arg_type = type; + free_arg(arg); + arg = chld; + } + else { + arg[1].arg_flags |= AF_SPECIAL; + } + } + else if (chld->arg_type == O_ARRAY && chld->arg_len == 1) + arg[1].arg_flags |= AF_SPECIAL; + } + } + } + if (chld = arg2) { + if (!(doarg & 2)) + arg[2].arg_flags |= AF_SPECIAL; + if (doarg & 32) + arg[2].arg_flags |= AF_NUMERIC; + if (chld->arg_type == O_ITEM && + (hoistable[chld[1].arg_type] || + (type == O_ASSIGN && + (chld[1].arg_type == A_READ || + chld[1].arg_type == A_DOUBLE || + chld[1].arg_type == A_BACKTICK ) ) ) ) { + arg[2].arg_type = chld[1].arg_type; + arg[2].arg_ptr = chld[1].arg_ptr; + free_arg(chld); + } + else { + arg[2].arg_type = A_EXPR; + arg[2].arg_ptr.arg_arg = chld; + if ((dolist & 2) && + (chld->arg_type == O_LIST || + (chld->arg_type == O_ARRAY && chld->arg_len == 1) )) + arg[2].arg_flags |= AF_SPECIAL; + } + } + if (chld = arg3) { + if (!(doarg & 4)) + arg[3].arg_flags |= AF_SPECIAL; + if (doarg & 64) + arg[3].arg_flags |= AF_NUMERIC; + if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) { + arg[3].arg_type = chld[1].arg_type; + arg[3].arg_ptr = chld[1].arg_ptr; + free_arg(chld); + } + else { + arg[3].arg_type = A_EXPR; + arg[3].arg_ptr.arg_arg = chld; + if ((dolist & 4) && + (chld->arg_type == O_LIST || + (chld->arg_type == O_ARRAY && chld->arg_len == 1) )) + arg[3].arg_flags |= AF_SPECIAL; + } + } +#ifdef DEBUGGING + if (debug & 16) { + fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]); + if (arg1) + fprintf(stderr,",%s=%lx", + argname[arg[1].arg_type],arg[1].arg_ptr.arg_arg); + if (arg2) + fprintf(stderr,",%s=%lx", + argname[arg[2].arg_type],arg[2].arg_ptr.arg_arg); + if (arg3) + fprintf(stderr,",%s=%lx", + argname[arg[3].arg_type],arg[3].arg_ptr.arg_arg); + fprintf(stderr,")\n"); + } +#endif + evalstatic(arg); /* see if we can consolidate anything */ + return arg; +} + +/* turn 123 into 123 == $. */ + +ARG * +flipflip(arg) +register ARG *arg; +{ + if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_SINGLE) { + arg = (ARG*)saferealloc((char*)arg,3*sizeof(ARG)); + arg->arg_type = O_EQ; + arg->arg_len = 2; + arg[2].arg_type = A_STAB; + arg[2].arg_flags = 0; + arg[2].arg_ptr.arg_stab = stabent(".",TRUE); + } + return arg; +} + +void +evalstatic(arg) +register ARG *arg; +{ + register STR *str; + register STR *s1; + register STR *s2; + double value; /* must not be register */ + register char *tmps; + int i; + double exp(), log(), sqrt(), modf(); + char *crypt(); + + if (!arg || !arg->arg_len) + return; + + if (arg[1].arg_type == A_SINGLE && + (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) { + str = str_new(0); + s1 = arg[1].arg_ptr.arg_str; + if (arg->arg_len > 1) + s2 = arg[2].arg_ptr.arg_str; + else + s2 = Nullstr; + switch (arg->arg_type) { + default: + str_free(str); + str = Nullstr; /* can't be evaluated yet */ + break; + case O_CONCAT: + str_sset(str,s1); + str_scat(str,s2); + break; + case O_REPEAT: + i = (int)str_gnum(s2); + while (i--) + str_scat(str,s1); + break; + case O_MULTIPLY: + value = str_gnum(s1); + str_numset(str,value * str_gnum(s2)); + break; + case O_DIVIDE: + value = str_gnum(s1); + str_numset(str,value / str_gnum(s2)); + break; + case O_MODULO: + value = str_gnum(s1); + str_numset(str,(double)(((long)value) % ((long)str_gnum(s2)))); + break; + case O_ADD: + value = str_gnum(s1); + str_numset(str,value + str_gnum(s2)); + break; + case O_SUBTRACT: + value = str_gnum(s1); + str_numset(str,value - str_gnum(s2)); + break; + case O_LEFT_SHIFT: + value = str_gnum(s1); + str_numset(str,(double)(((long)value) << ((long)str_gnum(s2)))); + break; + case O_RIGHT_SHIFT: + value = str_gnum(s1); + str_numset(str,(double)(((long)value) >> ((long)str_gnum(s2)))); + break; + case O_LT: + value = str_gnum(s1); + str_numset(str,(double)(value < str_gnum(s2))); + break; + case O_GT: + value = str_gnum(s1); + str_numset(str,(double)(value > str_gnum(s2))); + break; + case O_LE: + value = str_gnum(s1); + str_numset(str,(double)(value <= str_gnum(s2))); + break; + case O_GE: + value = str_gnum(s1); + str_numset(str,(double)(value >= str_gnum(s2))); + break; + case O_EQ: + value = str_gnum(s1); + str_numset(str,(double)(value == str_gnum(s2))); + break; + case O_NE: + value = str_gnum(s1); + str_numset(str,(double)(value != str_gnum(s2))); + break; + case O_BIT_AND: + value = str_gnum(s1); + str_numset(str,(double)(((long)value) & ((long)str_gnum(s2)))); + break; + case O_XOR: + value = str_gnum(s1); + str_numset(str,(double)(((long)value) ^ ((long)str_gnum(s2)))); + break; + case O_BIT_OR: + value = str_gnum(s1); + str_numset(str,(double)(((long)value) | ((long)str_gnum(s2)))); + break; + case O_AND: + if (str_true(s1)) + str = str_make(str_get(s2)); + else + str = str_make(str_get(s1)); + break; + case O_OR: + if (str_true(s1)) + str = str_make(str_get(s1)); + else + str = str_make(str_get(s2)); + break; + case O_COND_EXPR: + if (arg[3].arg_type != A_SINGLE) { + str_free(str); + str = Nullstr; + } + else { + str = str_make(str_get(str_true(s1) ? s2 : arg[3].arg_ptr.arg_str)); + str_free(arg[3].arg_ptr.arg_str); + } + break; + case O_NEGATE: + str_numset(str,(double)(-str_gnum(s1))); + break; + case O_NOT: + str_numset(str,(double)(!str_true(s1))); + break; + case O_COMPLEMENT: + str_numset(str,(double)(~(long)str_gnum(s1))); + break; + case O_LENGTH: + str_numset(str, (double)str_len(s1)); + break; + case O_SUBSTR: + if (arg[3].arg_type != A_SINGLE || stabent("[",FALSE)) { + str_free(str); /* making the fallacious assumption */ + str = Nullstr; /* that any $[ occurs before substr()*/ + } + else { + char *beg; + int len = (int)str_gnum(s2); + int tmp; + + for (beg = str_get(s1); *beg && len > 0; beg++,len--) ; + len = (int)str_gnum(arg[3].arg_ptr.arg_str); + str_free(arg[3].arg_ptr.arg_str); + if (len > (tmp = strlen(beg))) + len = tmp; + str_nset(str,beg,len); + } + break; + case O_SLT: + tmps = str_get(s1); + str_numset(str,(double)(strLT(tmps,str_get(s2)))); + break; + case O_SGT: + tmps = str_get(s1); + str_numset(str,(double)(strGT(tmps,str_get(s2)))); + break; + case O_SLE: + tmps = str_get(s1); + str_numset(str,(double)(strLE(tmps,str_get(s2)))); + break; + case O_SGE: + tmps = str_get(s1); + str_numset(str,(double)(strGE(tmps,str_get(s2)))); + break; + case O_SEQ: + tmps = str_get(s1); + str_numset(str,(double)(strEQ(tmps,str_get(s2)))); + break; + case O_SNE: + tmps = str_get(s1); + str_numset(str,(double)(strNE(tmps,str_get(s2)))); + break; + case O_CRYPT: + tmps = str_get(s1); + str_set(str,crypt(tmps,str_get(s2))); + break; + case O_EXP: + str_numset(str,exp(str_gnum(s1))); + break; + case O_LOG: + str_numset(str,log(str_gnum(s1))); + break; + case O_SQRT: + str_numset(str,sqrt(str_gnum(s1))); + break; + case O_INT: + modf(str_gnum(s1),&value); + str_numset(str,value); + break; + case O_ORD: + str_numset(str,(double)(*str_get(s1))); + break; + } + if (str) { + arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */ + str_free(s1); + str_free(s2); + arg[1].arg_ptr.arg_str = str; + } + } +} + +ARG * +l(arg) +register ARG *arg; +{ + register int i; + register ARG *arg1; + + arg->arg_flags |= AF_COMMON; /* XXX should cross-match */ + + /* see if it's an array reference */ + + if (arg[1].arg_type == A_EXPR) { + arg1 = arg[1].arg_ptr.arg_arg; + + if (arg1->arg_type == O_LIST && arg->arg_type != O_ITEM) { + /* assign to list */ + arg[1].arg_flags |= AF_SPECIAL; + arg[2].arg_flags |= AF_SPECIAL; + for (i = arg1->arg_len; i >= 1; i--) { + switch (arg1[i].arg_type) { + case A_STAB: case A_LVAL: + arg1[i].arg_type = A_LVAL; + break; + case A_EXPR: case A_LEXPR: + arg1[i].arg_type = A_LEXPR; + if (arg1[i].arg_ptr.arg_arg->arg_type == O_ARRAY) + arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY; + else if (arg1[i].arg_ptr.arg_arg->arg_type == O_HASH) + arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH; + if (arg1[i].arg_ptr.arg_arg->arg_type == O_LARRAY) + break; + if (arg1[i].arg_ptr.arg_arg->arg_type == O_LHASH) + break; + /* FALL THROUGH */ + default: + sprintf(tokenbuf, + "Illegal item (%s) as lvalue",argname[arg1[i].arg_type]); + yyerror(tokenbuf); + } + } + } + else if (arg1->arg_type == O_ARRAY) { + if (arg1->arg_len == 1 && arg->arg_type != O_ITEM) { + /* assign to array */ + arg[1].arg_flags |= AF_SPECIAL; + arg[2].arg_flags |= AF_SPECIAL; + } + else + arg1->arg_type = O_LARRAY; /* assign to array elem */ + } + else if (arg1->arg_type == O_HASH) + arg1->arg_type = O_LHASH; + else { + sprintf(tokenbuf, + "Illegal expression (%s) as lvalue",opname[arg1->arg_type]); + yyerror(tokenbuf); + } + arg[1].arg_type = A_LEXPR; +#ifdef DEBUGGING + if (debug & 16) + fprintf(stderr,"lval LEXPR\n"); +#endif + return arg; + } + + /* not an array reference, should be a register name */ + + if (arg[1].arg_type != A_STAB && arg[1].arg_type != A_LVAL) { + sprintf(tokenbuf, + "Illegal item (%s) as lvalue",argname[arg[1].arg_type]); + yyerror(tokenbuf); + } + arg[1].arg_type = A_LVAL; +#ifdef DEBUGGING + if (debug & 16) + fprintf(stderr,"lval LVAL\n"); +#endif + return arg; +} + +ARG * +addflags(i,flags,arg) +register ARG *arg; +{ + arg[i].arg_flags |= flags; + return arg; +} + +ARG * +hide_ary(arg) +ARG *arg; +{ + if (arg->arg_type == O_ARRAY) + return make_op(O_ITEM,1,arg,Nullarg,Nullarg,0); + return arg; +} + +ARG * +make_list(arg) +register ARG *arg; +{ + register int i; + register ARG *node; + register ARG *nxtnode; + register int j; + STR *tmpstr; + + if (!arg) { + arg = op_new(0); + arg->arg_type = O_LIST; + } + if (arg->arg_type != O_COMMA) { + arg->arg_flags |= AF_LISTISH; /* see listish() below */ + return arg; + } + for (i = 2, node = arg; ; i++) { + if (node->arg_len < 2) + break; + if (node[2].arg_type != A_EXPR) + break; + node = node[2].arg_ptr.arg_arg; + if (node->arg_type != O_COMMA) + break; + } + if (i > 2) { + node = arg; + arg = op_new(i); + tmpstr = arg->arg_ptr.arg_str; + *arg = *node; /* copy everything except the STR */ + arg->arg_ptr.arg_str = tmpstr; + for (j = 1; ; ) { + arg[j++] = node[1]; + if (j >= i) { + arg[j] = node[2]; + free_arg(node); + break; + } + nxtnode = node[2].arg_ptr.arg_arg; + free_arg(node); + node = nxtnode; + } + } + arg->arg_type = O_LIST; + arg->arg_len = i; + return arg; +} + +/* turn a single item into a list */ + +ARG * +listish(arg) +ARG *arg; +{ + if (arg->arg_flags & AF_LISTISH) + arg = make_op(O_LIST,1,arg,Nullarg,Nullarg,0); + return arg; +} + +ARG * +stab_to_arg(atype,stab) +int atype; +register STAB *stab; +{ + register ARG *arg; + + arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = atype; + arg[1].arg_ptr.arg_stab = stab; + return arg; +} + +ARG * +cval_to_arg(cval) +register char *cval; +{ + register ARG *arg; + + arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = A_SINGLE; + arg[1].arg_ptr.arg_str = str_make(cval); + safefree(cval); + return arg; +} + +ARG * +op_new(numargs) +int numargs; +{ + register ARG *arg; + + arg = (ARG*)safemalloc((numargs + 1) * sizeof (ARG)); + bzero((char *)arg, (numargs + 1) * sizeof (ARG)); + arg->arg_ptr.arg_str = str_new(0); + arg->arg_len = numargs; + return arg; +} + +void +free_arg(arg) +ARG *arg; +{ + str_free(arg->arg_ptr.arg_str); + safefree((char*)arg); +} + +ARG * +make_match(type,expr,spat) +int type; +ARG *expr; +SPAT *spat; +{ + register ARG *arg; + + arg = make_op(type,2,expr,Nullarg,Nullarg,0); + + arg[2].arg_type = A_SPAT; + arg[2].arg_ptr.arg_spat = spat; +#ifdef DEBUGGING + if (debug & 16) + fprintf(stderr,"make_match SPAT=%lx\n",spat); +#endif + + if (type == O_SUBST || type == O_NSUBST) { + if (arg[1].arg_type != A_STAB) + yyerror("Illegal lvalue"); + arg[1].arg_type = A_LVAL; + } + return arg; +} + +ARG * +cmd_to_arg(cmd) +CMD *cmd; +{ + register ARG *arg; + + arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = A_CMD; + arg[1].arg_ptr.arg_cmd = cmd; + return arg; +} + +CMD * +wopt(cmd) +register CMD *cmd; +{ + register CMD *tail; + register ARG *arg = cmd->c_expr; + char *tmps; /* used by True macro */ + + /* hoist "while (<channel>)" up into command block */ + + if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) { + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_GETS; /* and set it to do the input */ + cmd->c_stab = arg[1].arg_ptr.arg_stab; + if (arg[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV) { + cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */ + stab_to_arg(A_LVAL,defstab), arg, Nullarg,1 )); + } + else { + free_arg(arg); + cmd->c_expr = Nullarg; + } + } + + /* First find the end of the true list */ + + if (cmd->ucmd.ccmd.cc_true == Nullcmd) + return cmd; + for (tail = cmd->ucmd.ccmd.cc_true; tail->c_next; tail = tail->c_next) ; + + /* if there's a continue block, link it to true block and find end */ + + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) { + tail->c_next = cmd->ucmd.ccmd.cc_alt; + for ( ; tail->c_next; tail = tail->c_next) ; + } + + /* Here's the real trick: link the end of the list back to the beginning, + * inserting a "last" block to break out of the loop. This saves one or + * two procedure calls every time through the loop, because of how cmd_exec + * does tail recursion. + */ + + tail->c_next = (CMD *) safemalloc(sizeof (CMD)); + tail = tail->c_next; + if (!cmd->ucmd.ccmd.cc_alt) + cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */ + + bcopy((char *)cmd, (char *)tail, sizeof(CMD)); + tail->c_type = C_EXPR; + tail->c_flags ^= CF_INVERT; /* turn into "last unless" */ + tail->c_next = tail->ucmd.ccmd.cc_true; /* loop directly back to top */ + tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg,0); + tail->ucmd.acmd.ac_stab = Nullstab; + return cmd; +} + +FCMD * +load_format() +{ + FCMD froot; + FCMD *flinebeg; + register FCMD *fprev = &froot; + register FCMD *fcmd; + register char *s; + register char *t; + register char tmpchar; + bool noblank; + + while ((s = str_gets(linestr,rsfp)) != Nullch) { + line++; + if (strEQ(s,".\n")) { + bufptr = s; + return froot.f_next; + } + if (*s == '#') + continue; + flinebeg = Nullfcmd; + noblank = FALSE; + while (*s) { + fcmd = (FCMD *)safemalloc(sizeof (FCMD)); + bzero((char*)fcmd, sizeof (FCMD)); + fprev->f_next = fcmd; + fprev = fcmd; + for (t=s; *t && *t != '@' && *t != '^'; t++) { + if (*t == '~') { + noblank = TRUE; + *t = ' '; + } + } + tmpchar = *t; + *t = '\0'; + fcmd->f_pre = savestr(s); + fcmd->f_presize = strlen(s); + *t = tmpchar; + s = t; + if (!*s) { + if (noblank) + fcmd->f_flags |= FC_NOBLANK; + break; + } + if (!flinebeg) + flinebeg = fcmd; /* start values here */ + if (*s++ == '^') + fcmd->f_flags |= FC_CHOP; /* for doing text filling */ + switch (*s) { + case '*': + fcmd->f_type = F_LINES; + *s = '\0'; + break; + case '<': + fcmd->f_type = F_LEFT; + while (*s == '<') + s++; + break; + case '>': + fcmd->f_type = F_RIGHT; + while (*s == '>') + s++; + break; + case '|': + fcmd->f_type = F_CENTER; + while (*s == '|') + s++; + break; + default: + fcmd->f_type = F_LEFT; + break; + } + if (fcmd->f_flags & FC_CHOP && *s == '.') { + fcmd->f_flags |= FC_MORE; + while (*s == '.') + s++; + } + fcmd->f_size = s-t; + } + if (flinebeg) { + again: + if ((bufptr = str_gets(linestr ,rsfp)) == Nullch) + goto badform; + line++; + if (strEQ(bufptr,".\n")) { + yyerror("Missing values line"); + return froot.f_next; + } + if (*bufptr == '#') + goto again; + lex_newlines = TRUE; + while (flinebeg || *bufptr) { + switch(yylex()) { + default: + yyerror("Bad value in format"); + *bufptr = '\0'; + break; + case '\n': + if (flinebeg) + yyerror("Missing value in format"); + *bufptr = '\0'; + break; + case REG: + yylval.arg = stab_to_arg(A_LVAL,yylval.stabval); + /* FALL THROUGH */ + case RSTRING: + if (!flinebeg) + yyerror("Extra value in format"); + else { + flinebeg->f_expr = yylval.arg; + do { + flinebeg = flinebeg->f_next; + } while (flinebeg && flinebeg->f_size == 0); + } + break; + case ',': case ';': + continue; + } + } + lex_newlines = FALSE; + } + } + badform: + bufptr = str_get(linestr); + yyerror("Format not terminated"); + return froot.f_next; +} diff --git a/search.c b/search.c new file mode 100644 index 0000000000..79712a1359 --- /dev/null +++ b/search.c @@ -0,0 +1,751 @@ +/* $Header: search.c,v 1.0 87/12/18 13:05:59 root Exp $ + * + * $Log: search.c,v $ + * Revision 1.0 87/12/18 13:05:59 root + * Initial revision + * + */ + +/* string search routines */ + +#include <stdio.h> +#include <ctype.h> + +#include "EXTERN.h" +#include "handy.h" +#include "util.h" +#include "INTERN.h" +#include "search.h" + +#define VERBOSE +#define FLUSH +#define MEM_SIZE int + +#ifndef BITSPERBYTE +#define BITSPERBYTE 8 +#endif + +#define BMAPSIZ (127 / BITSPERBYTE + 1) + +#define CHAR 0 /* a normal character */ +#define ANY 1 /* . matches anything except newline */ +#define CCL 2 /* [..] character class */ +#define NCCL 3 /* [^..]negated character class */ +#define BEG 4 /* ^ beginning of a line */ +#define END 5 /* $ end of a line */ +#define LPAR 6 /* ( begin sub-match */ +#define RPAR 7 /* ) end sub-match */ +#define REF 8 /* \N backreference to the Nth submatch */ +#define WORD 9 /* \w matches alphanumeric character */ +#define NWORD 10 /* \W matches non-alphanumeric character */ +#define WBOUND 11 /* \b matches word boundary */ +#define NWBOUND 12 /* \B matches non-boundary */ +#define FINIS 13 /* the end of the pattern */ + +#define CODEMASK 15 + +/* Quantifiers: */ + +#define MINZERO 16 /* minimum is 0, not 1 */ +#define MAXINF 32 /* maximum is infinity, not 1 */ + +#define ASCSIZ 0200 +typedef char TRANSTABLE[ASCSIZ]; + +static TRANSTABLE trans = { +0000,0001,0002,0003,0004,0005,0006,0007, +0010,0011,0012,0013,0014,0015,0016,0017, +0020,0021,0022,0023,0024,0025,0026,0027, +0030,0031,0032,0033,0034,0035,0036,0037, +0040,0041,0042,0043,0044,0045,0046,0047, +0050,0051,0052,0053,0054,0055,0056,0057, +0060,0061,0062,0063,0064,0065,0066,0067, +0070,0071,0072,0073,0074,0075,0076,0077, +0100,0101,0102,0103,0104,0105,0106,0107, +0110,0111,0112,0113,0114,0115,0116,0117, +0120,0121,0122,0123,0124,0125,0126,0127, +0130,0131,0132,0133,0134,0135,0136,0137, +0140,0141,0142,0143,0144,0145,0146,0147, +0150,0151,0152,0153,0154,0155,0156,0157, +0160,0161,0162,0163,0164,0165,0166,0167, +0170,0171,0172,0173,0174,0175,0176,0177, +}; +static bool folding = FALSE; + +static int err; +#define NOERR 0 +#define BEGFAIL 1 +#define FATAL 2 + +static char *FirstCharacter; +static char *matchend; +static char *matchtill; + +void +search_init() +{ +#ifdef UNDEF + register int i; + + for (i = 0; i < ASCSIZ; i++) + trans[i] = i; +#else + ; +#endif +} + +void +init_compex(compex) +register COMPEX *compex; +{ + /* the following must start off zeroed */ + + compex->precomp = Nullch; + compex->complen = 0; + compex->subbase = Nullch; +} + +#ifdef NOTUSED +void +free_compex(compex) +register COMPEX *compex; +{ + if (compex->complen) { + safefree(compex->compbuf); + compex->complen = 0; + } + if (compex->subbase) { + safefree(compex->subbase); + compex->subbase = Nullch; + } +} +#endif + +static char *gbr_str = Nullch; +static int gbr_siz = 0; + +char * +getparen(compex,n) +register COMPEX *compex; +int n; +{ + int length = compex->subend[n] - compex->subbeg[n]; + + if (!n && + (!compex->numsubs || n > compex->numsubs || !compex->subend[n] || length<0)) + return ""; + growstr(&gbr_str, &gbr_siz, length+1); + safecpy(gbr_str, compex->subbeg[n], length+1); + return gbr_str; +} + +void +case_fold(which) +int which; +{ + register int i; + + if (which != folding) { + if (which) { + for (i = 'A'; i <= 'Z'; i++) + trans[i] = tolower(i); + } + else { + for (i = 'A'; i <= 'Z'; i++) + trans[i] = i; + } + folding = which; + } +} + +/* Compile the regular expression into internal form */ + +char * +compile(compex, sp, regex, fold) +register COMPEX *compex; +register char *sp; +int regex; +int fold; +{ + register int c; + register char *cp; + char *lastcp; + char paren[MAXSUB], + *parenp; + char **alt = compex->alternatives; + char *retmes = "Badly formed search string"; + + case_fold(compex->do_folding = fold); + if (compex->precomp) + safefree(compex->precomp); + compex->precomp = savestr(sp); + if (!compex->complen) { + compex->compbuf = safemalloc(84); + compex->complen = 80; + } + cp = compex->compbuf; /* point at compiled buffer */ + *alt++ = cp; /* first alternative starts here */ + parenp = paren; /* first paren goes here */ + if (*sp == 0) { /* nothing to compile? */ +#ifdef NOTDEF + if (*cp == 0) /* nothing there yet? */ + return "Null search string"; +#endif + if (*cp) + return Nullch; /* just keep old expression */ + } + compex->numsubs = 0; /* no parens yet */ + lastcp = 0; + for (;;) { + if (cp - compex->compbuf >= compex->complen) { + char *ocompbuf = compex->compbuf; + + grow_comp(compex); + if (ocompbuf != compex->compbuf) { /* adjust pointers? */ + char **tmpalt; + + cp = compex->compbuf + (cp - ocompbuf); + if (lastcp) + lastcp = compex->compbuf + (lastcp - ocompbuf); + for (tmpalt = compex->alternatives; tmpalt < alt; tmpalt++) + if (*tmpalt) + *tmpalt = compex->compbuf + (*tmpalt - ocompbuf); + } + } + c = *sp++; /* get next char of pattern */ + if (c == 0) { /* end of pattern? */ + if (parenp != paren) { /* balanced parentheses? */ +#ifdef VERBOSE + retmes = "Missing right parenthesis"; +#endif + goto badcomp; + } + *cp++ = FINIS; /* append a stopper */ + *alt++ = 0; /* terminate alternative list */ + /* + compex->complen = cp - compex->compbuf + 1; + compex->compbuf = saferealloc(compex->compbuf,compex->complen+4); */ + return Nullch; /* return success */ + } + if (c != '*' && c != '?' && c != '+') + lastcp = cp; + if (!regex) { /* just a normal search string? */ + *cp++ = CHAR; /* everything is a normal char */ + *cp++ = trans[c]; + } + else /* it is a regular expression */ + switch (c) { + + default: + normal_char: + *cp++ = CHAR; + *cp++ = trans[c]; + continue; + + case '.': + *cp++ = ANY; + continue; + + case '[': { /* character class */ + register int i; + + if (cp - compex->compbuf >= compex->complen - BMAPSIZ) { + char *ocompbuf = compex->compbuf; + + grow_comp(compex); /* reserve bitmap */ + if (ocompbuf != compex->compbuf) {/* adjust pointers? */ + char **tmpalt; + + cp = compex->compbuf + (cp - ocompbuf); + if (lastcp) + lastcp = compex->compbuf + (lastcp - ocompbuf); + for (tmpalt = compex->alternatives; tmpalt < alt; + tmpalt++) + if (*tmpalt) + *tmpalt = + compex->compbuf + (*tmpalt - ocompbuf); + } + } + for (i = BMAPSIZ; i; --i) + cp[i] = 0; + + if ((c = *sp++) == '^') { + c = *sp++; + *cp++ = NCCL; /* negated */ + } + else + *cp++ = CCL; /* normal */ + + i = 0; /* remember oldchar */ + do { + if (c == '\0') { +#ifdef VERBOSE + retmes = "Missing ]"; +#endif + goto badcomp; + } + if (c == '\\' && *sp) { + switch (*sp) { + default: + c = *sp++; + break; + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + c = *sp++ - '0'; + if (index("01234567",*sp)) { + c <<= 3; + c += *sp++ - '0'; + } + if (index("01234567",*sp)) { + c <<= 3; + c += *sp++ - '0'; + } + break; + case 'b': + c = '\b'; + sp++; + break; + case 'n': + c = '\n'; + sp++; + break; + case 'r': + c = '\r'; + sp++; + break; + case 'f': + c = '\f'; + sp++; + break; + case 't': + c = '\t'; + sp++; + break; + } + } + if (*sp == '-' && *(++sp)) + i = *sp++; + else + i = c; + while (c <= i) { + cp[c / BITSPERBYTE] |= 1 << (c % BITSPERBYTE); + if (fold && isalpha(c)) + cp[(c ^ 32) / BITSPERBYTE] |= + 1 << ((c ^ 32) % BITSPERBYTE); + /* set the other bit too */ + c++; + } + } while ((c = *sp++) != ']'); + if (cp[-1] == NCCL) + cp[0] |= 1; + cp += BMAPSIZ; + continue; + } + + case '^': + if (cp != compex->compbuf && cp[-1] != FINIS) + goto normal_char; + *cp++ = BEG; + continue; + + case '$': + if (isdigit(*sp)) { + *cp++ = REF; + *cp++ = *sp - '0'; + break; + } + if (*sp && *sp != '|') + goto normal_char; + *cp++ = END; + continue; + + case '*': case '?': case '+': + if (lastcp == 0 || + (*lastcp & (MINZERO|MAXINF)) || + *lastcp == LPAR || + *lastcp == RPAR || + *lastcp == BEG || + *lastcp == END || + *lastcp == WBOUND || + *lastcp == NWBOUND ) + goto normal_char; + if (c != '+') + *lastcp |= MINZERO; + if (c != '?') + *lastcp |= MAXINF; + continue; + + case '(': + if (compex->numsubs >= MAXSUB) { +#ifdef VERBOSE + retmes = "Too many parens"; +#endif + goto badcomp; + } + *parenp++ = ++compex->numsubs; + *cp++ = LPAR; + *cp++ = compex->numsubs; + break; + case ')': + if (parenp <= paren) { +#ifdef VERBOSE + retmes = "Unmatched right paren"; +#endif + goto badcomp; + } + *cp++ = RPAR; + *cp++ = *--parenp; + break; + case '|': + if (parenp>paren) { +#ifdef VERBOSE + retmes = "No | in subpattern"; /* Sigh! */ +#endif + goto badcomp; + } + *cp++ = FINIS; + if (alt - compex->alternatives >= MAXALT) { +#ifdef VERBOSE + retmes = "Too many alternatives"; +#endif + goto badcomp; + } + *alt++ = cp; + break; + case '\\': /* backslashed thingie */ + switch (c = *sp++) { + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + *cp++ = REF; + *cp++ = c - '0'; + break; + case 'w': + *cp++ = WORD; + break; + case 'W': + *cp++ = NWORD; + break; + case 'b': + *cp++ = WBOUND; + break; + case 'B': + *cp++ = NWBOUND; + break; + default: + *cp++ = CHAR; + if (c == '\0') + goto badcomp; + switch (c) { + case 'n': + c = '\n'; + break; + case 'r': + c = '\r'; + break; + case 'f': + c = '\f'; + break; + case 't': + c = '\t'; + break; + } + *cp++ = c; + break; + } + break; + } + } +badcomp: + compex->compbuf[0] = 0; + compex->numsubs = 0; + return retmes; +} + +void +grow_comp(compex) +register COMPEX *compex; +{ + compex->complen += 80; + compex->compbuf = saferealloc(compex->compbuf, (MEM_SIZE)compex->complen + 4); +} + +char * +execute(compex, addr, beginning, minend) +register COMPEX *compex; +char *addr; +bool beginning; +int minend; +{ + register char *p1 = addr; + register char *trt = trans; + register int c; + register int scr; + register int c2; + + if (addr == Nullch) + return Nullch; + if (compex->numsubs) { /* any submatches? */ + for (c = 0; c <= compex->numsubs; c++) + compex->subbeg[c] = compex->subend[c] = Nullch; + } + case_fold(compex->do_folding); /* make sure table is correct */ + if (beginning) + FirstCharacter = p1; /* for ^ tests */ + else { + if (multiline || compex->alternatives[1] || compex->compbuf[0] != BEG) + FirstCharacter = Nullch; + else + return Nullch; /* can't match */ + } + matchend = Nullch; + matchtill = addr + minend; + err = 0; + if (compex->compbuf[0] == CHAR && !compex->alternatives[1]) { + if (compex->do_folding) { + c = compex->compbuf[1]; /* fast check for first character */ + do { + if (trt[*p1] == c && try(compex, p1, compex->compbuf)) + goto got_it; + } while (*p1++ && !err); + } + else { + c = compex->compbuf[1]; /* faster check for first character */ + if (compex->compbuf[2] == CHAR) + c2 = compex->compbuf[3]; + else + c2 = 0; + do { + false_alarm: + while (scr = *p1++, scr && scr != c) ; + if (!scr) + break; + if (c2 && *p1 != c2) /* and maybe even second character */ + goto false_alarm; + if (try(compex, p1, compex->compbuf+2)) { + p1--; + goto got_it; + } + } while (!err); + } + return Nullch; + } + else { /* normal algorithm */ + do { + register char **alt = compex->alternatives; + while (*alt) { + if (try(compex, p1, *alt++)) + goto got_it; + } + } while (*p1++ && err < FATAL); + return Nullch; + } + +got_it: + if (compex->numsubs) { /* any parens? */ + trt = savestr(addr); /* in case addr is not static */ + if (compex->subbase) + safefree(compex->subbase); /* (may be freeing addr!) */ + compex->subbase = trt; + scr = compex->subbase - addr; + p1 += scr; + matchend += scr; + for (c = 0; c <= compex->numsubs; c++) { + if (compex->subend[c]) { + compex->subbeg[c] += scr; + compex->subend[c] += scr; + } + } + } + compex->subend[0] = matchend; + compex->subbeg[0] = p1; + return p1; +} + +bool +try(compex, sp, cp) +COMPEX *compex; +register char *cp; +register char *sp; +{ + register char *basesp; + register char *trt = trans; + register int i; + register int backlen; + register int code; + + while (*sp || (*cp & MAXINF) || *cp == BEG || *cp == RPAR || + *cp == WBOUND || *cp == NWBOUND) { + switch ((code = *cp++) & CODEMASK) { + + case CHAR: + basesp = sp; + i = *cp++; + if (code & MAXINF) + while (*sp && trt[*sp] == i) sp++; + else + if (*sp && trt[*sp] == i) sp++; + backlen = 1; + goto backoff; + + backoff: + while (sp > basesp) { + if (try(compex, sp, cp)) + goto right; + sp -= backlen; + } + if (code & MINZERO) + continue; + goto wrong; + + case ANY: + basesp = sp; + if (code & MAXINF) + while (*sp && *sp != '\n') sp++; + else + if (*sp && *sp != '\n') sp++; + backlen = 1; + goto backoff; + + case CCL: + basesp = sp; + if (code & MAXINF) + while (*sp && cclass(cp, *sp, 1)) sp++; + else + if (*sp && cclass(cp, *sp, 1)) sp++; + cp += BMAPSIZ; + backlen = 1; + goto backoff; + + case NCCL: + basesp = sp; + if (code & MAXINF) + while (*sp && cclass(cp, *sp, 0)) sp++; + else + if (*sp && cclass(cp, *sp, 0)) sp++; + cp += BMAPSIZ; + backlen = 1; + goto backoff; + + case END: + if (!*sp || *sp == '\n') { + matchtill--; + continue; + } + goto wrong; + + case BEG: + if (sp == FirstCharacter || ( + *sp && sp[-1] == '\n') ) { + matchtill--; + continue; + } + if (!multiline) /* no point in advancing more */ + err = BEGFAIL; + goto wrong; + + case WORD: + basesp = sp; + if (code & MAXINF) + while (*sp && isalnum(*sp)) sp++; + else + if (*sp && isalnum(*sp)) sp++; + backlen = 1; + goto backoff; + + case NWORD: + basesp = sp; + if (code & MAXINF) + while (*sp && !isalnum(*sp)) sp++; + else + if (*sp && !isalnum(*sp)) sp++; + backlen = 1; + goto backoff; + + case WBOUND: + if ((sp == FirstCharacter || !isalnum(sp[-1])) != + (!*sp || !isalnum(*sp)) ) + continue; + goto wrong; + + case NWBOUND: + if ((sp == FirstCharacter || !isalnum(sp[-1])) == + (!*sp || !isalnum(*sp))) + continue; + goto wrong; + + case FINIS: + goto right; + + case LPAR: + compex->subbeg[*cp++] = sp; + continue; + + case RPAR: + i = *cp++; + compex->subend[i] = sp; + compex->lastparen = i; + continue; + + case REF: + if (compex->subend[i = *cp++] == 0) { + fputs("Bad subpattern reference\n",stdout) FLUSH; + err = FATAL; + goto wrong; + } + basesp = sp; + backlen = compex->subend[i] - compex->subbeg[i]; + if (code & MAXINF) + while (*sp && subpat(compex, i, sp)) sp += backlen; + else + if (*sp && subpat(compex, i, sp)) sp += backlen; + goto backoff; + + default: + fputs("Botched pattern compilation\n",stdout) FLUSH; + err = FATAL; + return -1; + } + } + if (*cp == FINIS || *cp == END) { +right: + if (matchend == Nullch || sp > matchend) + matchend = sp; + return matchend >= matchtill; + } +wrong: + matchend = Nullch; + return FALSE; +} + +bool +subpat(compex, i, sp) +register COMPEX *compex; +register int i; +register char *sp; +{ + register char *bp; + + bp = compex->subbeg[i]; + while (*sp && *bp == *sp) { + bp++; + sp++; + if (bp >= compex->subend[i]) + return TRUE; + } + return FALSE; +} + +bool +cclass(set, c, af) +register char *set; +register int c; +{ + c &= 0177; +#if BITSPERBYTE == 8 + if (set[c >> 3] & 1 << (c & 7)) +#else + if (set[c / BITSPERBYTE] & 1 << (c % BITSPERBYTE)) +#endif + return af; + return !af; +} diff --git a/search.h b/search.h new file mode 100644 index 0000000000..992da7d784 --- /dev/null +++ b/search.h @@ -0,0 +1,39 @@ +/* $Header: search.h,v 1.0 87/12/18 13:06:06 root Exp $ + * + * $Log: search.h,v $ + * Revision 1.0 87/12/18 13:06:06 root + * Initial revision + * + */ + +#ifndef MAXSUB +#define MAXSUB 10 /* how many sub-patterns are allowed */ +#define MAXALT 10 /* how many alternatives are allowed */ + +typedef struct { + char *precomp; /* the original pattern, for debug output */ + char *compbuf; /* the compiled pattern */ + int complen; /* length of compbuf */ + char *alternatives[MAXALT]; /* list of alternatives */ + char *subbeg[MAXSUB]; /* subpattern start list */ + char *subend[MAXSUB]; /* subpattern end list */ + char *subbase; /* saved match string after execute() */ + char lastparen; /* which subpattern matched last */ + char numsubs; /* how many subpatterns the compiler saw */ + bool do_folding; /* fold upper and lower case? */ +} COMPEX; + +EXT int multiline INIT(0); + +void search_init(); +void init_compex(); +void free_compex(); +char *getparen(); +void case_fold(); +char *compile(); +void grow_comp(); +char *execute(); +bool try(); +bool subpat(); +bool cclass(); +#endif diff --git a/spat.h b/spat.h new file mode 100644 index 0000000000..d1d2dc30d9 --- /dev/null +++ b/spat.h @@ -0,0 +1,27 @@ +/* $Header: spat.h,v 1.0 87/12/18 13:06:10 root Exp $ + * + * $Log: spat.h,v $ + * Revision 1.0 87/12/18 13:06:10 root + * Initial revision + * + */ + +struct scanpat { + SPAT *spat_next; /* list of all scanpats */ + COMPEX spat_compex; /* compiled expression */ + ARG *spat_repl; /* replacement string for subst */ + ARG *spat_runtime; /* compile pattern at runtime */ + STR *spat_first; /* for a fast bypass of execute() */ + bool spat_flags; + char spat_flen; +}; + +#define SPAT_USED 1 /* spat has been used once already */ +#define SPAT_USE_ONCE 2 /* use pattern only once per article */ +#define SPAT_SCANFIRST 4 /* initial constant not anchored */ +#define SPAT_SCANALL 8 /* initial constant is whole pat */ + +EXT SPAT *spat_root; /* list of all spats */ +EXT SPAT *curspat; /* what to do \ interps from */ + +#define Nullspat Null(SPAT*) diff --git a/stab.c b/stab.c new file mode 100644 index 0000000000..b9ef533dce --- /dev/null +++ b/stab.c @@ -0,0 +1,320 @@ +/* $Header: stab.c,v 1.0 87/12/18 13:06:14 root Exp $ + * + * $Log: stab.c,v $ + * Revision 1.0 87/12/18 13:06:14 root + * Initial revision + * + */ + +#include <signal.h> +#include "handy.h" +#include "EXTERN.h" +#include "search.h" +#include "util.h" +#include "perl.h" + +static char *sig_name[] = { + "", + "HUP", + "INT", + "QUIT", + "ILL", + "TRAP", + "IOT", + "EMT", + "FPE", + "KILL", + "BUS", + "SEGV", + "SYS", + "PIPE", + "ALRM", + "TERM", + "???" +#ifdef SIGTSTP + ,"STOP", + "TSTP", + "CONT", + "CHLD", + "TTIN", + "TTOU", + "TINT", + "XCPU", + "XFSZ" +#ifdef SIGPROF + ,"VTALARM", + "PROF" +#ifdef SIGWINCH + ,"WINCH" +#ifdef SIGLOST + ,"LOST" +#ifdef SIGUSR1 + ,"USR1" +#endif +#ifdef SIGUSR2 + ,"USR2" +#endif /* SIGUSR2 */ +#endif /* SIGLOST */ +#endif /* SIGWINCH */ +#endif /* SIGPROF */ +#endif /* SIGTSTP */ + ,0 + }; + +STR * +stab_str(stab) +STAB *stab; +{ + register int paren; + register char *s; + extern int errno; + + switch (*stab->stab_name) { + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': case '&': + if (curspat) { + paren = atoi(stab->stab_name); + if (curspat->spat_compex.subend[paren] && + (s = getparen(&curspat->spat_compex,paren))) { + curspat->spat_compex.subend[paren] = Nullch; + str_set(stab->stab_val,s); + } + } + break; + case '+': + if (curspat) { + paren = curspat->spat_compex.lastparen; + if (curspat->spat_compex.subend[paren] && + (s = getparen(&curspat->spat_compex,paren))) { + curspat->spat_compex.subend[paren] = Nullch; + str_set(stab->stab_val,s); + } + } + break; + case '.': + if (last_in_stab) { + str_numset(stab->stab_val,(double)last_in_stab->stab_io->lines); + } + break; + case '?': + str_numset(stab->stab_val,(double)statusvalue); + break; + case '^': + s = curoutstab->stab_io->top_name; + str_set(stab->stab_val,s); + break; + case '~': + s = curoutstab->stab_io->fmt_name; + str_set(stab->stab_val,s); + break; + case '=': + str_numset(stab->stab_val,(double)curoutstab->stab_io->lines); + break; + case '-': + str_numset(stab->stab_val,(double)curoutstab->stab_io->lines_left); + break; + case '%': + str_numset(stab->stab_val,(double)curoutstab->stab_io->page); + break; + case '(': + if (curspat) { + str_numset(stab->stab_val,(double)(curspat->spat_compex.subbeg[0] - + curspat->spat_compex.subbase)); + } + break; + case ')': + if (curspat) { + str_numset(stab->stab_val,(double)(curspat->spat_compex.subend[0] - + curspat->spat_compex.subbeg[0])); + } + break; + case '/': + *tokenbuf = record_separator; + tokenbuf[1] = '\0'; + str_set(stab->stab_val,tokenbuf); + break; + case '[': + str_numset(stab->stab_val,(double)arybase); + break; + case '|': + str_numset(stab->stab_val, + (double)((curoutstab->stab_io->flags & IOF_FLUSH) != 0) ); + break; + case ',': + str_set(stab->stab_val,ofs); + break; + case '\\': + str_set(stab->stab_val,ors); + break; + case '#': + str_set(stab->stab_val,ofmt); + break; + case '!': + str_numset(stab->stab_val,(double)errno); + break; + } + return stab->stab_val; +} + +stabset(stab,str) +register STAB *stab; +STR *str; +{ + char *s; + int i; + int sighandler(); + + if (stab->stab_flags & SF_VMAGIC) { + switch (stab->stab_name[0]) { + case '^': + safefree(curoutstab->stab_io->top_name); + curoutstab->stab_io->top_name = str_get(str); + curoutstab->stab_io->top_stab = stabent(str_get(str),FALSE); + break; + case '~': + safefree(curoutstab->stab_io->fmt_name); + curoutstab->stab_io->fmt_name = str_get(str); + curoutstab->stab_io->fmt_stab = stabent(str_get(str),FALSE); + break; + case '=': + curoutstab->stab_io->page_len = (long)str_gnum(str); + break; + case '-': + curoutstab->stab_io->lines_left = (long)str_gnum(str); + break; + case '%': + curoutstab->stab_io->page = (long)str_gnum(str); + break; + case '|': + curoutstab->stab_io->flags &= ~IOF_FLUSH; + if (str_gnum(str) != 0.0) { + curoutstab->stab_io->flags |= IOF_FLUSH; + } + break; + case '*': + multiline = (int)str_gnum(str) != 0; + break; + case '/': + record_separator = *str_get(str); + break; + case '\\': + if (ors) + safefree(ors); + ors = savestr(str_get(str)); + break; + case ',': + if (ofs) + safefree(ofs); + ofs = savestr(str_get(str)); + break; + case '#': + if (ofmt) + safefree(ofmt); + ofmt = savestr(str_get(str)); + break; + case '[': + arybase = (int)str_gnum(str); + break; + case '!': + errno = (int)str_gnum(str); /* will anyone ever use this? */ + break; + case '.': + case '+': + case '&': + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '(': + case ')': + break; /* "read-only" registers */ + } + } + else if (stab == envstab && envname) { + setenv(envname,str_get(str)); + /* And you'll never guess what the dog had */ + safefree(envname); /* in its mouth... */ + envname = Nullch; + } + else if (stab == sigstab && signame) { + s = str_get(str); + i = whichsig(signame); /* ...no, a brick */ + if (strEQ(s,"IGNORE")) + signal(i,SIG_IGN); + else if (strEQ(s,"DEFAULT") || !*s) + signal(i,SIG_DFL); + else + signal(i,sighandler); + safefree(signame); + signame = Nullch; + } +} + +whichsig(signame) +char *signame; +{ + register char **sigv; + + for (sigv = sig_name+1; *sigv; sigv++) + if (strEQ(signame,*sigv)) + return sigv - sig_name; + return 0; +} + +sighandler(sig) +int sig; +{ + STAB *stab; + ARRAY *savearray; + STR *str; + + stab = stabent(str_get(hfetch(sigstab->stab_hash,sig_name[sig])),FALSE); + savearray = defstab->stab_array; + defstab->stab_array = anew(); + str = str_new(0); + str_set(str,sig_name[sig]); + apush(defstab->stab_array,str); + str = cmd_exec(stab->stab_sub); + afree(defstab->stab_array); /* put back old $_[] */ + defstab->stab_array = savearray; +} + +char * +reg_get(name) +char *name; +{ + return STAB_GET(stabent(name,TRUE)); +} + +#ifdef NOTUSED +reg_set(name,value) +char *name; +char *value; +{ + str_set(STAB_STR(stabent(name,TRUE)),value); +} +#endif + +STAB * +aadd(stab) +register STAB *stab; +{ + if (!stab->stab_array) + stab->stab_array = anew(); + return stab; +} + +STAB * +hadd(stab) +register STAB *stab; +{ + if (!stab->stab_hash) + stab->stab_hash = hnew(); + return stab; +} diff --git a/stab.h b/stab.h new file mode 100644 index 0000000000..cd38d6d990 --- /dev/null +++ b/stab.h @@ -0,0 +1,58 @@ +/* $Header: stab.h,v 1.0 87/12/18 13:06:18 root Exp $ + * + * $Log: stab.h,v $ + * Revision 1.0 87/12/18 13:06:18 root + * Initial revision + * + */ + +struct stab { + struct stab *stab_next; + char *stab_name; + STR *stab_val; + struct stio *stab_io; + FCMD *stab_form; + ARRAY *stab_array; + HASH *stab_hash; + CMD *stab_sub; + char stab_flags; +}; + +#define SF_VMAGIC 1 /* call routine to dereference STR val */ + +struct stio { + FILE *fp; + long lines; + long page; + long page_len; + long lines_left; + char *top_name; + STAB *top_stab; + char *fmt_name; + STAB *fmt_stab; + char type; + char flags; +}; + +#define IOF_ARGV 1 /* this fp iterates over ARGV */ +#define IOF_START 2 /* check for null ARGV and substitute '-' */ +#define IOF_FLUSH 4 /* this fp wants a flush after write op */ + +#define Nullstab Null(STAB*) + +#define STAB_STR(s) (tmpstab = (s), tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val) +#define STAB_GET(s) (tmpstab = (s), str_get(tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val)) +#define STAB_GNUM(s) (tmpstab = (s), str_gnum(tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val)) + +EXT STAB *tmpstab; + +EXT STAB *stab_index[128]; + +EXT char *envname; /* place for ENV name being assigned--gross cheat */ +EXT char *signame; /* place for SIG name being assigned--gross cheat */ + +EXT int statusvalue; +EXT int subsvalue; + +STAB *aadd(); +STAB *hadd(); @@ -0,0 +1,535 @@ +/* $Header: str.c,v 1.0 87/12/18 13:06:22 root Exp $ + * + * $Log: str.c,v $ + * Revision 1.0 87/12/18 13:06:22 root + * Initial revision + * + */ + +#include "handy.h" +#include "EXTERN.h" +#include "search.h" +#include "util.h" +#include "perl.h" + +str_reset(s) +register char *s; +{ + register STAB *stab; + register STR *str; + register int i; + register int max; + register SPAT *spat; + + if (!*s) { /* reset ?? searches */ + for (spat = spat_root; spat != Nullspat; spat = spat->spat_next) { + spat->spat_flags &= ~SPAT_USED; + } + return; + } + + /* reset variables */ + + while (*s) { + i = *s; + if (s[1] == '-') { + s += 2; + } + max = *s++; + for ( ; i <= max; i++) { + for (stab = stab_index[i]; stab; stab = stab->stab_next) { + str = stab->stab_val; + str->str_cur = 0; + if (str->str_ptr != Nullch) + str->str_ptr[0] = '\0'; + } + } + } +} + +str_numset(str,num) +register STR *str; +double num; +{ + str->str_nval = num; + str->str_pok = 0; /* invalidate pointer */ + str->str_nok = 1; /* validate number */ +} + +char * +str_2ptr(str) +register STR *str; +{ + register char *s; + + if (!str) + return ""; + GROWSTR(&(str->str_ptr), &(str->str_len), 24); + s = str->str_ptr; + if (str->str_nok) { + sprintf(s,"%.20g",str->str_nval); + while (*s) s++; + } + *s = '\0'; + str->str_cur = s - str->str_ptr; + str->str_pok = 1; +#ifdef DEBUGGING + if (debug & 32) + fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr); +#endif + return str->str_ptr; +} + +double +str_2num(str) +register STR *str; +{ + if (!str) + return 0.0; + if (str->str_len && str->str_pok) + str->str_nval = atof(str->str_ptr); + else + str->str_nval = 0.0; + str->str_nok = 1; +#ifdef DEBUGGING + if (debug & 32) + fprintf(stderr,"0x%lx num(%g)\n",str,str->str_nval); +#endif + return str->str_nval; +} + +str_sset(dstr,sstr) +STR *dstr; +register STR *sstr; +{ + if (!sstr) + str_nset(dstr,No,0); + else if (sstr->str_nok) + str_numset(dstr,sstr->str_nval); + else if (sstr->str_pok) + str_nset(dstr,sstr->str_ptr,sstr->str_cur); + else + str_nset(dstr,"",0); +} + +str_nset(str,ptr,len) +register STR *str; +register char *ptr; +register int len; +{ + GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); + bcopy(ptr,str->str_ptr,len); + str->str_cur = len; + *(str->str_ptr+str->str_cur) = '\0'; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +str_set(str,ptr) +register STR *str; +register char *ptr; +{ + register int len; + + if (!ptr) + ptr = ""; + len = strlen(ptr); + GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); + bcopy(ptr,str->str_ptr,len+1); + str->str_cur = len; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +str_chop(str,ptr) /* like set but assuming ptr is in str */ +register STR *str; +register char *ptr; +{ + if (!(str->str_pok)) + str_2ptr(str); + str->str_cur -= (ptr - str->str_ptr); + bcopy(ptr,str->str_ptr, str->str_cur + 1); + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +str_ncat(str,ptr,len) +register STR *str; +register char *ptr; +register int len; +{ + if (!(str->str_pok)) + str_2ptr(str); + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); + bcopy(ptr,str->str_ptr+str->str_cur,len); + str->str_cur += len; + *(str->str_ptr+str->str_cur) = '\0'; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +str_scat(dstr,sstr) +STR *dstr; +register STR *sstr; +{ + if (!(sstr->str_pok)) + str_2ptr(sstr); + if (sstr) + str_ncat(dstr,sstr->str_ptr,sstr->str_cur); +} + +str_cat(str,ptr) +register STR *str; +register char *ptr; +{ + register int len; + + if (!ptr) + return; + if (!(str->str_pok)) + str_2ptr(str); + len = strlen(ptr); + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); + bcopy(ptr,str->str_ptr+str->str_cur,len+1); + str->str_cur += len; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +char * +str_append_till(str,from,delim,keeplist) +register STR *str; +register char *from; +register int delim; +char *keeplist; +{ + register char *to; + register int len; + + if (!from) + return Nullch; + len = strlen(from); + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ + to = str->str_ptr+str->str_cur; + for (; *from; from++,to++) { + if (*from == '\\' && from[1] && delim != '\\') { + if (!keeplist) { + if (from[1] == delim || from[1] == '\\') + from++; + else + *to++ = *from++; + } + else if (index(keeplist,from[1])) + *to++ = *from++; + else + from++; + } + else if (*from == delim) + break; + *to = *from; + } + *to = '\0'; + str->str_cur = to - str->str_ptr; + return from; +} + +STR * +str_new(len) +int len; +{ + register STR *str; + + if (freestrroot) { + str = freestrroot; + freestrroot = str->str_link.str_next; + str->str_link.str_magic = Nullstab; + } + else { + str = (STR *) safemalloc(sizeof(STR)); + bzero((char*)str,sizeof(STR)); + } + if (len) + GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); + return str; +} + +void +str_grow(str,len) +register STR *str; +int len; +{ + if (len && str) + GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); +} + +/* make str point to what nstr did */ + +void +str_replace(str,nstr) +register STR *str; +register STR *nstr; +{ + safefree(str->str_ptr); + str->str_ptr = nstr->str_ptr; + str->str_len = nstr->str_len; + str->str_cur = nstr->str_cur; + str->str_pok = nstr->str_pok; + if (str->str_nok = nstr->str_nok) + str->str_nval = nstr->str_nval; + safefree((char*)nstr); +} + +void +str_free(str) +register STR *str; +{ + if (!str) + return; + if (str->str_len) + str->str_ptr[0] = '\0'; + str->str_cur = 0; + str->str_nok = 0; + str->str_pok = 0; + str->str_link.str_next = freestrroot; + freestrroot = str; +} + +str_len(str) +register STR *str; +{ + if (!str) + return 0; + if (!(str->str_pok)) + str_2ptr(str); + if (str->str_len) + return str->str_cur; + else + return 0; +} + +char * +str_gets(str,fp) +register STR *str; +register FILE *fp; +{ +#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */ + + register char *bp; /* we're going to steal some values */ + register int cnt; /* from the stdio struct and put EVERYTHING */ + register char *ptr; /* in the innermost loop into registers */ + register char newline = record_separator; /* (assuming >= 6 registers) */ + int i; + int bpx; + int obpx; + register int get_paragraph; + register char *oldbp; + + if (get_paragraph = !newline) { /* yes, that's an assignment */ + newline = '\n'; + oldbp = Nullch; /* remember last \n position (none) */ + } + cnt = fp->_cnt; /* get count into register */ + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ + if (str->str_len <= cnt) /* make sure we have the room */ + GROWSTR(&(str->str_ptr), &(str->str_len), cnt+1); + bp = str->str_ptr; /* move these two too to registers */ + ptr = fp->_ptr; + for (;;) { + screamer: + while (--cnt >= 0) { /* this */ /* eat */ + if ((*bp++ = *ptr++) == newline) /* really */ /* dust */ + goto thats_all_folks; /* screams */ /* sed :-) */ + } + + fp->_cnt = cnt; /* deregisterize cnt and ptr */ + fp->_ptr = ptr; + i = _filbuf(fp); /* get more characters */ + cnt = fp->_cnt; + ptr = fp->_ptr; /* reregisterize cnt and ptr */ + + bpx = bp - str->str_ptr; /* prepare for possible relocation */ + if (get_paragraph && oldbp) + obpx = oldbp - str->str_ptr; + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + cnt + 1); + bp = str->str_ptr + bpx; /* reconstitute our pointer */ + if (get_paragraph && oldbp) + oldbp = str->str_ptr + obpx; + + if (i == newline) { /* all done for now? */ + *bp++ = i; + goto thats_all_folks; + } + else if (i == EOF) /* all done for ever? */ + goto thats_really_all_folks; + *bp++ = i; /* now go back to screaming loop */ + } + +thats_all_folks: + if (get_paragraph && bp - 1 != oldbp) { + oldbp = bp; /* remember where this newline was */ + goto screamer; /* and go back to the fray */ + } +thats_really_all_folks: + fp->_cnt = cnt; /* put these back or we're in trouble */ + fp->_ptr = ptr; + *bp = '\0'; + str->str_cur = bp - str->str_ptr; /* set length */ + +#else /* !STDSTDIO */ /* The big, slow, and stupid way */ + + static char buf[4192]; + + if (fgets(buf, sizeof buf, fp) != Nullch) + str_set(str, buf); + else + str_set(str, No); + +#endif /* STDSTDIO */ + + return str->str_cur ? str->str_ptr : Nullch; +} + + +STR * +interp(str,s) +register STR *str; +register char *s; +{ + register char *t = s; + char *envsave = envname; + envname = Nullch; + + str_set(str,""); + while (*s) { + if (*s == '\\' && s[1] == '$') { + str_ncat(str, t, s++ - t); + t = s++; + } + else if (*s == '$' && s[1] && s[1] != '|') { + str_ncat(str,t,s-t); + s = scanreg(s,tokenbuf); + str_cat(str,reg_get(tokenbuf)); + t = s; + } + else + s++; + } + envname = envsave; + str_ncat(str,t,s-t); + return str; +} + +void +str_inc(str) +register STR *str; +{ + register char *d; + + if (!str) + return; + if (str->str_nok) { + str->str_nval += 1.0; + str->str_pok = 0; + return; + } + if (!str->str_pok) { + str->str_nval = 1.0; + str->str_nok = 1; + return; + } + for (d = str->str_ptr; *d && *d != '.'; d++) ; + d--; + if (!isdigit(*str->str_ptr) || !isdigit(*d) ) { + str_numset(str,atof(str->str_ptr) + 1.0); /* punt */ + return; + } + while (d >= str->str_ptr) { + if (++*d <= '9') + return; + *(d--) = '0'; + } + /* oh,oh, the number grew */ + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + 2); + str->str_cur++; + for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--) + *d = d[-1]; + *d = '1'; +} + +void +str_dec(str) +register STR *str; +{ + register char *d; + + if (!str) + return; + if (str->str_nok) { + str->str_nval -= 1.0; + str->str_pok = 0; + return; + } + if (!str->str_pok) { + str->str_nval = -1.0; + str->str_nok = 1; + return; + } + for (d = str->str_ptr; *d && *d != '.'; d++) ; + d--; + if (!isdigit(*str->str_ptr) || !isdigit(*d) || (*d == '0' && d == str->str_ptr)) { + str_numset(str,atof(str->str_ptr) - 1.0); /* punt */ + return; + } + while (d >= str->str_ptr) { + if (--*d >= '0') + return; + *(d--) = '9'; + } +} + +/* make a string that will exist for the duration of the expression eval */ + +STR * +str_static(oldstr) +STR *oldstr; +{ + register STR *str = str_new(0); + static long tmps_size = -1; + + str_sset(str,oldstr); + if (++tmps_max > tmps_size) { + tmps_size = tmps_max; + if (!(tmps_size & 127)) { + if (tmps_size) + tmps_list = (STR**)saferealloc((char*)tmps_list, + (tmps_size + 128) * sizeof(STR*) ); + else + tmps_list = (STR**)safemalloc(128 * sizeof(char*)); + } + } + tmps_list[tmps_max] = str; + return str; +} + +STR * +str_make(s) +char *s; +{ + register STR *str = str_new(0); + + str_set(str,s); + return str; +} + +STR * +str_nmake(n) +double n; +{ + register STR *str = str_new(0); + + str_numset(str,n); + return str; +} @@ -0,0 +1,35 @@ +/* $Header: str.h,v 1.0 87/12/18 13:06:26 root Exp $ + * + * $Log: str.h,v $ + * Revision 1.0 87/12/18 13:06:26 root + * Initial revision + * + */ + +struct string { + char * str_ptr; /* pointer to malloced string */ + double str_nval; /* numeric value, if any */ + int str_len; /* allocated size */ + int str_cur; /* length of str_ptr as a C string */ + union { + STR *str_next; /* while free, link to next free str */ + STAB *str_magic; /* while in use, ptr to magic stab, if any */ + } str_link; + char str_pok; /* state of str_ptr */ + char str_nok; /* state of str_nval */ +}; + +#define Nullstr Null(STR*) + +/* the following macro updates any magic values this str is associated with */ + +#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x)) + +EXT STR **tmps_list; +EXT long tmps_max INIT(-1); + +char *str_2ptr(); +double str_2num(); +STR *str_static(); +STR *str_make(); +STR *str_nmake(); diff --git a/t/README b/t/README new file mode 100644 index 0000000000..1c079409c3 --- /dev/null +++ b/t/README @@ -0,0 +1,11 @@ +This is the perl test library. To run all the tests, just type 'TEST'. + +To add new tests, just look at the current tests and do likewise. + +If a test fails, run it by itself to see if it prints any informative +diagnostics. If not, modify the test to print informative diagnostics. +If you put out extra lines with a '#' character on the front, you don't +have to worry about removing the extra print statements later since TEST +ignores lines beginning with '#'. + +If you come up with new tests, send them to lwall@jpl-devvax.jpl.nasa.gov. diff --git a/t/TEST b/t/TEST new file mode 100644 index 0000000000..11c48e2908 --- /dev/null +++ b/t/TEST @@ -0,0 +1,68 @@ +#!./perl + +# $Header: TEST,v 1.0 87/12/18 13:11:34 root Exp $ + +# This is written in a peculiar style, since we're trying to avoid +# most of the constructs we'll be testing for. + +if ($ARGV[0] eq '-v') { + $verbose = 1; + shift; +} + +if ($ARGV[0] eq '') { + @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.*`); +} + +$bad = 0; +while ($test = shift) { + print "$test..."; + open(results,"$test|") || (print "can't run.\n"); + $ok = 0; + while (<results>) { + if ($verbose) { + print $_; + } + unless (/^#/) { + if (/^1\.\.([0-9]+)/) { + $max = $1; + $next = 1; + $ok = 1; + } else { + if (/^ok (.*)/ && $1 == $next) { + $next = $next + 1; + } else { + $ok = 0; + } + } + } + } + $next = $next - 1; + if ($ok && $next == $max) { + print "ok\n"; + } else { + $next += 1; + print "FAILED on test $next\n"; + $bad = $bad + 1; + $_ = $test; + if (/^base/) { + die "Failed a basic test--cannot continue."; + } + } +} + +if ($bad == 0) { + if ($ok) { + print "All tests successful.\n"; + } else { + die "FAILED--no tests were run for some reason."; + } +} else { + if ($bad == 1) { + die "Failed 1 test."; + } else { + die "Failed $bad tests."; + } +} +($user,$sys,$cuser,$csys) = times; +print sprintf("u=%g s=%g cu=%g cs=%g\n",$user,$sys,$cuser,$csys); diff --git a/t/base.cond b/t/base.cond new file mode 100644 index 0000000000..b592b59855 --- /dev/null +++ b/t/base.cond @@ -0,0 +1,19 @@ +#!./perl + +# $Header: base.cond,v 1.0 87/12/18 13:11:41 root Exp $ + +# make sure conditional operators work + +print "1..4\n"; + +$x = '0'; + +$x eq $x && (print "ok 1\n"); +$x ne $x && (print "not ok 1\n"); +$x eq $x || (print "not ok 2\n"); +$x ne $x || (print "ok 2\n"); + +$x == $x && (print "ok 3\n"); +$x != $x && (print "not ok 3\n"); +$x == $x || (print "not ok 4\n"); +$x != $x || (print "ok 4\n"); diff --git a/t/base.if b/t/base.if new file mode 100644 index 0000000000..e5133a6428 --- /dev/null +++ b/t/base.if @@ -0,0 +1,11 @@ +#!./perl + +# $Header: base.if,v 1.0 87/12/18 13:11:45 root Exp $ + +print "1..2\n"; + +# first test to see if we can run the tests. + +$x = 'test'; +if ($x eq $x) { print "ok 1\n"; } else { print "not ok 1\n";} +if ($x ne $x) { print "not ok 2\n"; } else { print "ok 2\n";} diff --git a/t/base.lex b/t/base.lex new file mode 100644 index 0000000000..2cfe311ed8 --- /dev/null +++ b/t/base.lex @@ -0,0 +1,23 @@ +#!./perl + +# $Header: base.lex,v 1.0 87/12/18 13:11:51 root Exp $ + +print "1..4\n"; + +$ # this is the register <space> += 'x'; + +print "#1 :$ : eq :x:\n"; +if ($ eq 'x') {print "ok 1\n";} else {print "not ok 1\n";} + +$x = $#; # this is the register $# + +if ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";} + +$x = $#x; + +if ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";} + +$x = '\\'; # '; + +if (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";} diff --git a/t/base.pat b/t/base.pat new file mode 100644 index 0000000000..d796b697fb --- /dev/null +++ b/t/base.pat @@ -0,0 +1,11 @@ +#!./perl + +# $Header: base.pat,v 1.0 87/12/18 13:11:56 root Exp $ + +print "1..2\n"; + +# first test to see if we can run the tests. + +$_ = 'test'; +if (/^test/) { print "ok 1\n"; } else { print "not ok 1\n";} +if (/^foo/) { print "not ok 2\n"; } else { print "ok 2\n";} diff --git a/t/base.term b/t/base.term new file mode 100644 index 0000000000..509454f053 --- /dev/null +++ b/t/base.term @@ -0,0 +1,36 @@ +#!./perl + +# $Header: base.term,v 1.0 87/12/18 13:11:59 root Exp $ + +print "1..6\n"; + +# check "" interpretation + +$x = "\n"; +if ($x lt ' ') {print "ok 1\n";} else {print "not ok 1\n";} + +# check `` processing + +$x = `echo hi there`; +if ($x eq "hi there\n") {print "ok 2\n";} else {print "not ok 2\n";} + +# check $#array + +$x[0] = 'foo'; +$x[1] = 'foo'; +$tmp = $#x; +print "#3\t:$tmp: == :1:\n"; +if ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";} + +# check numeric literal + +$x = 1; +if ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";} + +# check <> pseudoliteral + +open(try, "/dev/null") || (die "Can't open /dev/null."); +if (<try> eq '') {print "ok 5\n";} else {print "not ok 5\n";} + +open(try, "/etc/termcap") || (die "Can't open /etc/termcap."); +if (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";} diff --git a/t/cmd.elsif b/t/cmd.elsif new file mode 100644 index 0000000000..51a7641d08 --- /dev/null +++ b/t/cmd.elsif @@ -0,0 +1,25 @@ +#!./perl + +# $Header: cmd.elsif,v 1.0 87/12/18 13:12:02 root Exp $ + +sub foo { + if ($_[0] == 1) { + 1; + } + elsif ($_[0] == 2) { + 2; + } + elsif ($_[0] == 3) { + 3; + } + else { + 4; + } +} + +print "1..4\n"; + +if (($x = do foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1\n";} +if (($x = do foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2\n";} +if (($x = do foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3\n";} +if (($x = do foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4\n";} diff --git a/t/cmd.for b/t/cmd.for new file mode 100644 index 0000000000..769bec28bb --- /dev/null +++ b/t/cmd.for @@ -0,0 +1,25 @@ +#!./perl + +# $Header: cmd.for,v 1.0 87/12/18 13:12:05 root Exp $ + +print "1..2\n"; + +for ($i = 0; $i <= 10; $i++) { + $x[$i] = $i; +} +$y = $x[10]; +print "#1 :$y: eq :10:\n"; +$y = join(' ', @x); +print "#1 :$y: eq :0 1 2 3 4 5 6 7 8 9 10:\n"; +if (join(' ', @x) eq '0 1 2 3 4 5 6 7 8 9 10') { + print "ok 1\n"; +} else { + print "not ok 1\n"; +} + +$i = $c = 0; +for (;;) { + $c++; + last if $i++ > 10; +} +if ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";} diff --git a/t/cmd.mod b/t/cmd.mod new file mode 100644 index 0000000000..96367e96e9 --- /dev/null +++ b/t/cmd.mod @@ -0,0 +1,28 @@ +#!./perl + +# $Header: cmd.mod,v 1.0 87/12/18 13:12:09 root Exp $ + +print "1..6\n"; + +print "ok 1\n" if 1; +print "not ok 1\n" unless 1; + +print "ok 2\n" unless 0; +print "not ok 2\n" if 0; + +1 && (print "not ok 3\n") if 0; +1 && (print "ok 3\n") if 1; +0 || (print "not ok 4\n") if 0; +0 || (print "ok 4\n") if 1; + +$x = 0; +do {$x[$x] = $x;} while ($x++) < 10; +if (join(' ',@x) eq '0 1 2 3 4 5 6 7 8 9 10') { + print "ok 5\n"; +} else { + print "not ok 5\n"; +} + +$x = 15; +$x = 10 while $x < 10; +if ($x == 15) {print "ok 6\n";} else {print "not ok 6\n";} diff --git a/t/cmd.subval b/t/cmd.subval new file mode 100644 index 0000000000..2b4962f58a --- /dev/null +++ b/t/cmd.subval @@ -0,0 +1,50 @@ +#!./perl + +# $Header: cmd.subval,v 1.0 87/12/18 13:12:12 root Exp $ + +sub foo1 { + 'true1'; + if ($_[0]) { 'true2'; } +} + +sub foo2 { + 'true1'; + if ($_[0]) { 'true2'; } else { 'true3'; } +} + +sub foo3 { + 'true1'; + unless ($_[0]) { 'true2'; } +} + +sub foo4 { + 'true1'; + unless ($_[0]) { 'true2'; } else { 'true3'; } +} + +sub foo5 { + 'true1'; + 'true2' if $_[0]; +} + +sub foo6 { + 'true1'; + 'true2' unless $_[0]; +} + +print "1..12\n"; + +if (do foo1(0) eq '') {print "ok 1\n";} else {print "not ok 1\n";} +if (do foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";} +if (do foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";} +if (do foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";} + +if (do foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";} +if (do foo3(1) eq '') {print "ok 6\n";} else {print "not ok 6\n";} +if (do foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";} +if (do foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";} + +if (do foo5(0) eq '') {print "ok 9\n";} else {print "not ok 9\n";} +if (do foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";} +if (do foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";} +if (do foo6(1) eq '') {print "ok 12\n";} else {print "not ok 12\n";} diff --git a/t/cmd.while b/t/cmd.while new file mode 100644 index 0000000000..585e27f708 --- /dev/null +++ b/t/cmd.while @@ -0,0 +1,110 @@ +#!./perl + +# $Header: cmd.while,v 1.0 87/12/18 13:12:15 root Exp $ + +print "1..10\n"; + +open (tmp,'>Cmd.while.tmp') || die "Can't create Cmd.while.tmp."; +print tmp "tvi925\n"; +print tmp "tvi920\n"; +print tmp "vt100\n"; +print tmp "Amiga\n"; +print tmp "paper\n"; +close tmp; + +# test "last" command + +open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +while (<fh>) { + last if /vt100/; +} +if (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1\n";} + +# test "next" command + +$bad = ''; +open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +while (<fh>) { + next if /vt100/; + $bad = 1 if /vt100/; +} +if (!eof || /vt100/ || $bad) {print "not ok 2\n";} else {print "ok 2\n";} + +# test "redo" command + +$bad = ''; +open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +while (<fh>) { + if (s/vt100/VT100/g) { + s/VT100/Vt100/g; + redo; + } + $bad = 1 if /vt100/; + $bad = 1 if /VT100/; +} +if (!eof || $bad) {print "not ok 3\n";} else {print "ok 3\n";} + +# now do the same with a label and a continue block + +# test "last" command + +$badcont = ''; +open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +line: while (<fh>) { + if (/vt100/) {last line;} +} continue { + $badcont = 1 if /vt100/; +} +if (!eof && /vt100/) {print "ok 4\n";} else {print "not ok 4\n";} +if (!$badcont) {print "ok 5\n";} else {print "not ok 5\n";} + +# test "next" command + +$bad = ''; +$badcont = 1; +open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +entry: while (<fh>) { + next entry if /vt100/; + $bad = 1 if /vt100/; +} continue { + $badcont = '' if /vt100/; +} +if (!eof || /vt100/ || $bad) {print "not ok 6\n";} else {print "ok 6\n";} +if (!$badcont) {print "ok 7\n";} else {print "not ok 7\n";} + +# test "redo" command + +$bad = ''; +$badcont = ''; +open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; +loop: while (<fh>) { + if (s/vt100/VT100/g) { + s/VT100/Vt100/g; + redo loop; + } + $bad = 1 if /vt100/; + $bad = 1 if /VT100/; +} continue { + $badcont = 1 if /vt100/; +} +if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";} +if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";} + +`/bin/rm -f Cmd.while.tmp`; + +#$x = 0; +#while (1) { +# if ($x > 1) {last;} +# next; +#} continue { +# if ($x++ > 10) {last;} +# next; +#} +# +#if ($x < 10) {print "ok 10\n";} else {print "not ok 10\n";} + +$i = 9; +{ + $i++; +} +print "ok $i\n"; diff --git a/t/comp.cmdopt b/t/comp.cmdopt new file mode 100644 index 0000000000..c459324fcc --- /dev/null +++ b/t/comp.cmdopt @@ -0,0 +1,83 @@ +#!./perl + +# $Header: comp.cmdopt,v 1.0 87/12/18 13:12:19 root Exp $ + +print "1..40\n"; + +# test the optimization of constants + +if (1) { print "ok 1\n";} else { print "not ok 1\n";} +unless (0) { print "ok 2\n";} else { print "not ok 2\n";} + +if (0) { print "not ok 3\n";} else { print "ok 3\n";} +unless (1) { print "not ok 4\n";} else { print "ok 4\n";} + +unless (!1) { print "ok 5\n";} else { print "not ok 5\n";} +if (!0) { print "ok 6\n";} else { print "not ok 6\n";} + +unless (!0) { print "not ok 7\n";} else { print "ok 7\n";} +if (!1) { print "not ok 8\n";} else { print "ok 8\n";} + +$x = 1; +if (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";} +if (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";} +$x = ''; +if (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";} +if (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";} + +$x = 1; +if (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";} +if (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";} +$x = ''; +if (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";} +if (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";} + + +# test the optimization of registers + +$x = 1; +if ($x) { print "ok 17\n";} else { print "not ok 17\n";} +unless ($x) { print "not ok 18\n";} else { print "ok 18\n";} + +$x = ''; +if ($x) { print "not ok 19\n";} else { print "ok 19\n";} +unless ($x) { print "ok 20\n";} else { print "not ok 20\n";} + +# test optimization of string operations + +$a = 'a'; +if ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";} +if ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";} + +if ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";} +if ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";} +# test interaction of logicals and other operations + +$a = 'a'; +$x = 1; +if ($a eq 'a' && $x) { print "ok 25\n";} else { print "not ok 25\n";} +if ($a ne 'a' && $x) { print "not ok 26\n";} else { print "ok 26\n";} +$x = ''; +if ($a eq 'a' && $x) { print "not ok 27\n";} else { print "ok 27\n";} +if ($a ne 'a' && $x) { print "not ok 28\n";} else { print "ok 28\n";} + +$x = 1; +if ($a eq 'a' || $x) { print "ok 29\n";} else { print "not ok 29\n";} +if ($a ne 'a' || $x) { print "ok 30\n";} else { print "not ok 30\n";} +$x = ''; +if ($a eq 'a' || $x) { print "ok 31\n";} else { print "not ok 31\n";} +if ($a ne 'a' || $x) { print "not ok 32\n";} else { print "ok 32\n";} + +$x = 1; +if ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";} +if ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";} +$x = ''; +if ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";} + if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";} + +$x = 1; +if ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";} +if ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";} +$x = ''; +if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";} +if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";} diff --git a/t/comp.cpp b/t/comp.cpp new file mode 100644 index 0000000000..ee7ad73f16 --- /dev/null +++ b/t/comp.cpp @@ -0,0 +1,35 @@ +#!./perl -P + +# $Header: comp.cpp,v 1.0 87/12/18 13:12:22 root Exp $ + +print "1..3\n"; + +#this is a comment +#define MESS "ok 1\n" +print MESS; + +#If you capitalize, it's a comment. +#ifdef MESS + print "ok 2\n"; +#else + print "not ok 2\n"; +#endif + +open(try,">Comp.cpp.tmp") || die "Can't open temp perl file."; +print try '$ok = "not ok 3\n";'; print try "\n"; +print try "#include <Comp.cpp.inc>\n"; +print try "#ifdef OK\n"; +print try '$ok = OK;'; print try "\n"; +print try "#endif\n"; +print try 'print $ok;'; print try "\n"; +close try; + +open(try,">Comp.cpp.inc") || (die "Can't open temp include file."); +print try '#define OK "ok 3\n"'; print try "\n"; +close try; + +$pwd=`pwd`; +$pwd =~ s/\n//; +$x = `./perl -P -I$pwd Comp.cpp.tmp`; +print $x; +`/bin/rm -f Comp.cpp.tmp Comp.cpp.inc`; diff --git a/t/comp.decl b/t/comp.decl new file mode 100644 index 0000000000..649103ac14 --- /dev/null +++ b/t/comp.decl @@ -0,0 +1,49 @@ +#!./perl + +# $Header: comp.decl,v 1.0 87/12/18 13:12:27 root Exp $ + +# check to see if subroutine declarations work everwhere + +sub one { + print "ok 1\n"; +} +format one = +ok 5 +. + +print "1..7\n"; + +do one(); +do two(); + +sub two { + print "ok 2\n"; +} +format two = +@<<< +$foo +. + +if ($x eq $x) { + sub three { + print "ok 3\n"; + } + do three(); +} + +do four(); +$~ = 'one'; +write; +$~ = 'two'; +$foo = "ok 6"; +write; +$~ = 'three'; +write; + +format three = +ok 7 +. + +sub four { + print "ok 4\n"; +} diff --git a/t/comp.multiline b/t/comp.multiline new file mode 100644 index 0000000000..9bf1be21e0 --- /dev/null +++ b/t/comp.multiline @@ -0,0 +1,40 @@ +#!./perl + +# $Header: comp.multiline,v 1.0 87/12/18 13:12:31 root Exp $ + +print "1..5\n"; + +open(try,'>Comp.try') || (die "Can't open temp file."); + +$x = 'now is the time +for all good men +to come to. +'; + +$y = 'now is the time' . "\n" . +'for all good men' . "\n" . +'to come to.' . "\n"; + +if ($x eq $y) {print "ok 1\n";} else {print "not ok 1\n";} + +print try $x; +close try; + +open(try,'Comp.try') || (die "Can't reopen temp file."); +$count = 0; +$z = ''; +while (<try>) { + $z .= $_; + $count = $count + 1; +} + +if ($z eq $y) {print "ok 2\n";} else {print "not ok 2\n";} + +if ($count == 3) {print "ok 3\n";} else {print "not ok 3\n";} + +$_ = `cat Comp.try`; + +if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";} +`/bin/rm -f Comp.try`; + +if ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";} diff --git a/t/comp.script b/t/comp.script new file mode 100644 index 0000000000..0364d1901d --- /dev/null +++ b/t/comp.script @@ -0,0 +1,23 @@ +#!./perl + +# $Header: comp.script,v 1.0 87/12/18 13:12:36 root Exp $ + +print "1..3\n"; + +$x = `./perl -e 'print "ok\n";'`; + +if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";} + +open(try,">Comp.script") || (die "Can't open temp file."); +print try 'print "ok\n";'; print try "\n"; +close try; + +$x = `./perl Comp.script`; + +if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";} + +$x = `./perl <Comp.script`; + +if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";} + +`/bin/rm -f Comp.script`; diff --git a/t/comp.term b/t/comp.term new file mode 100644 index 0000000000..83cce45cbd --- /dev/null +++ b/t/comp.term @@ -0,0 +1,27 @@ +#!./perl + +# $Header: comp.term,v 1.0 87/12/18 13:12:40 root Exp $ + +# tests that aren't important enough for base.term + +print "1..9\n"; + +$x = "\\n"; +print "#1\t:$x: eq " . ':\n:' . "\n"; +if ($x eq '\n') {print "ok 1\n";} else {print "not ok 1\n";} + +$x = "#2\t:$x: eq :\\n:\n"; +print $x; +unless (index($x,'\\\\')>0) {print "ok 2\n";} else {print "not ok 2\n";} + +if (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";} + +$one = 'a'; + +if (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";} +if (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";} +if (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";} +if (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";} +if (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";} +if (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";} + diff --git a/t/io.argv b/t/io.argv new file mode 100644 index 0000000000..8282a3d0a8 --- /dev/null +++ b/t/io.argv @@ -0,0 +1,36 @@ +#!./perl + +# $Header: io.argv,v 1.0 87/12/18 13:12:44 root Exp $ + +print "1..5\n"; + +open(try, '>Io.argv.tmp') || (die "Can't open temp file."); +print try "a line\n"; +close try; + +$x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`; + +if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";} + +$x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`; + +if ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} + +$x = `echo foo|./perl -e 'while (<>) {print $_;}'`; + +if ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3\n";} + +@ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp'); +while (<>) { + $y .= $. . $_; + if (eof) { + if ($. == 3) {print "ok 4\n";} else {print "not ok 4\n";} + } +} + +if ($y eq "1a line\n2a line\n3a line\n") + {print "ok 5\n";} +else + {print "not ok 5\n";} + +`/bin/rm -f Io.argv.tmp`; diff --git a/t/io.fs b/t/io.fs new file mode 100644 index 0000000000..996986cd39 --- /dev/null +++ b/t/io.fs @@ -0,0 +1,63 @@ +#!./perl + +# $Header: io.fs,v 1.0 87/12/18 13:12:48 root Exp $ + +print "1..18\n"; + +chdir '/tmp'; +`/bin/rm -rf a b c x`; + +umask(022); + +if (umask(0) == 022) {print "ok 1\n";} else {print "not ok 1\n";} +open(fh,'>x') || die "Can't create x"; +close(fh); +open(fh,'>a') || die "Can't create a"; +close(fh); + +if (link('a','b')) {print "ok 2\n";} else {print "not ok 2\n";} + +if (link('b','c')) {print "ok 3\n";} else {print "not ok 3\n";} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('c'); + +if ($nlink == 3) {print "ok 4\n";} else {print "not ok 4\n";} +if (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";} + +if ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('c'); +if (($mode & 0777) == 0777) {print "ok 7\n";} else {print "not ok 7\n";} + +if ((chmod 0700,'c','x') == 2) {print "ok 8\n";} else {print "not ok 8\n";} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('c'); +if (($mode & 0777) == 0700) {print "ok 9\n";} else {print "not ok 9\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('x'); +if (($mode & 0777) == 0700) {print "ok 10\n";} else {print "not ok 10\n";} + +if ((unlink 'b','x') == 2) {print "ok 11\n";} else {print "not ok 11\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('b'); +if ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('x'); +if ($ino == 0) {print "ok 13\n";} else {print "not ok 13\n";} + +if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('a'); +if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('b'); +if ($ino) {print "ok 16\n";} else {print "not ok 16\n";} + +if ((unlink 'b') == 1) {print "ok 17\n";} else {print "not ok 17\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('b'); +if ($ino == 0) {print "ok 18\n";} else {print "not ok 18\n";} +unlink 'c'; diff --git a/t/io.inplace b/t/io.inplace new file mode 100644 index 0000000000..2a245306c9 --- /dev/null +++ b/t/io.inplace @@ -0,0 +1,19 @@ +#!./perl -i.bak + +# $Header: io.inplace,v 1.0 87/12/18 13:12:51 root Exp $ + +print "1..2\n"; + +@ARGV = ('.a','.b','.c'); +`echo foo | tee .a .b .c`; +while (<>) { + s/foo/bar/; +} +continue { + print; +} + +if (`cat .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";} +if (`cat .a.bak .b.bak .c.bak` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} + +unlink '.a', '.b', '.c', '.a.bak', '.b.bak', '.c.bak'; diff --git a/t/io.print b/t/io.print new file mode 100644 index 0000000000..f183b14013 --- /dev/null +++ b/t/io.print @@ -0,0 +1,25 @@ +#!./perl + +# $Header: io.print,v 1.0 87/12/18 13:12:55 root Exp $ + +print "1..11\n"; + +print stdout "ok 1\n"; +print "ok 2\n","ok 3\n","ok 4\n","ok 5\n"; + +open(foo,">-"); +print foo "ok 6\n"; + +printf "ok %d\n",7; +printf("ok %d\n",8); + +@a = ("ok %d%c",9,ord("\n")); +printf @a; + +$a[1] = 10; +printf stdout @a; + +$, = ' '; +$\ = "\n"; + +print "ok","11"; diff --git a/t/io.tell b/t/io.tell new file mode 100644 index 0000000000..130b4c4780 --- /dev/null +++ b/t/io.tell @@ -0,0 +1,42 @@ +#!./perl + +# $Header: io.tell,v 1.0 87/12/18 13:13:02 root Exp $ + +print "1..13\n"; + +open(tst, '../Makefile') || (die "Can't open ../Makefile"); + +if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; } + +$firstline = <tst>; +$secondpos = tell; + +$x = 0; +while (<tst>) { + if (eof) {$x++;} +} +if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; } + +$lastpos = tell; + +unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; } + +if (seek(tst,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; } + +if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; } + +if ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; } + +if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; } + +if (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; } + +if (eof) { print "not ok 9\n"; } else { print "ok 9\n"; } + +if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; } + +if (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } + +if ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; } + +unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } diff --git a/t/op.append b/t/op.append new file mode 100644 index 0000000000..5972ac4533 --- /dev/null +++ b/t/op.append @@ -0,0 +1,21 @@ +#!./perl + +# $Header: op.append,v 1.0 87/12/18 13:13:05 root Exp $ + +print "1..3\n"; + +$a = 'ab' . 'c'; # compile time +$b = 'def'; + +$c = $a . $b; +print "#1\t:$c: eq :abcdef:\n"; +if ($c eq 'abcdef') {print "ok 1\n";} else {print "not ok 1\n";} + +$c .= 'xyz'; +print "#2\t:$c: eq :abcdefxyz:\n"; +if ($c eq 'abcdefxyz') {print "ok 2\n";} else {print "not ok 2\n";} + +$_ = $a; +$_ .= $b; +print "#3\t:$_: eq :abcdef:\n"; +if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/t/op.auto b/t/op.auto new file mode 100644 index 0000000000..6ad44ce7ce --- /dev/null +++ b/t/op.auto @@ -0,0 +1,41 @@ +#!./perl + +# $Header: op.auto,v 1.0 87/12/18 13:13:08 root Exp $ + +print "1..30\n"; + +$x = 10000; +if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";} +if (0 + $x-- - 1 == 10000) { print "ok 2\n";} else {print "not ok 2\n";} +if (1 * $x == 10000) { print "ok 3\n";} else {print "not ok 3\n";} +if (0 + $x-- - 0 == 10000) { print "ok 4\n";} else {print "not ok 4\n";} +if (1 + $x == 10000) { print "ok 5\n";} else {print "not ok 5\n";} +if (1 + $x++ == 10000) { print "ok 6\n";} else {print "not ok 6\n";} +if (0 + $x == 10000) { print "ok 7\n";} else {print "not ok 7\n";} +if (0 + --$x + 1 == 10000) { print "ok 8\n";} else {print "not ok 8\n";} +if (0 + ++$x + 0 == 10000) { print "ok 9\n";} else {print "not ok 9\n";} +if ($x == 10000) { print "ok 10\n";} else {print "not ok 10\n";} + +$x[0] = 10000; +if (0 + ++$x[0] - 1 == 10000) { print "ok 11\n";} else {print "not ok 11\n";} +if (0 + $x[0]-- - 1 == 10000) { print "ok 12\n";} else {print "not ok 12\n";} +if (1 * $x[0] == 10000) { print "ok 13\n";} else {print "not ok 13\n";} +if (0 + $x[0]-- - 0 == 10000) { print "ok 14\n";} else {print "not ok 14\n";} +if (1 + $x[0] == 10000) { print "ok 15\n";} else {print "not ok 15\n";} +if (1 + $x[0]++ == 10000) { print "ok 16\n";} else {print "not ok 16\n";} +if (0 + $x[0] == 10000) { print "ok 17\n";} else {print "not ok 17\n";} +if (0 + --$x[0] + 1 == 10000) { print "ok 18\n";} else {print "not ok 18\n";} +if (0 + ++$x[0] + 0 == 10000) { print "ok 19\n";} else {print "not ok 19\n";} +if ($x[0] == 10000) { print "ok 20\n";} else {print "not ok 20\n";} + +$x{0} = 10000; +if (0 + ++$x{0} - 1 == 10000) { print "ok 21\n";} else {print "not ok 21\n";} +if (0 + $x{0}-- - 1 == 10000) { print "ok 22\n";} else {print "not ok 22\n";} +if (1 * $x{0} == 10000) { print "ok 23\n";} else {print "not ok 23\n";} +if (0 + $x{0}-- - 0 == 10000) { print "ok 24\n";} else {print "not ok 24\n";} +if (1 + $x{0} == 10000) { print "ok 25\n";} else {print "not ok 25\n";} +if (1 + $x{0}++ == 10000) { print "ok 26\n";} else {print "not ok 26\n";} +if (0 + $x{0} == 10000) { print "ok 27\n";} else {print "not ok 27\n";} +if (0 + --$x{0} + 1 == 10000) { print "ok 28\n";} else {print "not ok 28\n";} +if (0 + ++$x{0} + 0 == 10000) { print "ok 29\n";} else {print "not ok 29\n";} +if ($x{0} == 10000) { print "ok 30\n";} else {print "not ok 30\n";} diff --git a/t/op.chop b/t/op.chop new file mode 100644 index 0000000000..c86ea9cf3e --- /dev/null +++ b/t/op.chop @@ -0,0 +1,21 @@ +#!./perl + +# $Header: op.chop,v 1.0 87/12/18 13:13:11 root Exp $ + +print "1..2\n"; + +# optimized + +$_ = 'abc'; +$c = do foo(); +if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1\n";} + +# unoptimized + +$_ = 'abc'; +$c = chop($_); +if ($c . $_ eq 'cab') {print "ok 2\n";} else {print "not ok 2\n";} + +sub foo { + chop; +} diff --git a/t/op.cond b/t/op.cond new file mode 100644 index 0000000000..7391e5893b --- /dev/null +++ b/t/op.cond @@ -0,0 +1,12 @@ +#!./perl + +# $Header: op.cond,v 1.0 87/12/18 13:13:14 root Exp $ + +print "1..4\n"; + +print 1 ? "ok 1\n" : "not ok 1\n"; # compile time +print 0 ? "not ok 2\n" : "ok 2\n"; + +$x = 1; +print $x ? "ok 3\n" : "not ok 3\n"; # run time +print !$x ? "not ok 4\n" : "ok 4\n"; diff --git a/t/op.crypt b/t/op.crypt new file mode 100644 index 0000000000..b28dda6aaa --- /dev/null +++ b/t/op.crypt @@ -0,0 +1,12 @@ +#!./perl + +# $Header: op.crypt,v 1.0 87/12/18 13:13:17 root Exp $ + +print "1..2\n"; + +# this evaluates entirely at compile time! +if (crypt('uh','oh') eq 'ohPnjpYtoi1NU') {print "ok 1\n";} else {print "not ok 1\n";} + +# this doesn't. +$uh = 'uh'; +if (crypt($uh,'oh') eq 'ohPnjpYtoi1NU') {print "ok 2\n";} else {print "not ok 2\n";} diff --git a/t/op.do b/t/op.do new file mode 100644 index 0000000000..90fdae993d --- /dev/null +++ b/t/op.do @@ -0,0 +1,34 @@ +#!./perl + +# $Header: op.do,v 1.0 87/12/18 13:13:20 root Exp $ +sub foo1 +{ + print $_[0]; + 'value'; +} + +sub foo2 +{ + shift(_); + print $_[0]; + $x = 'value'; + $x; +} + +print "1..8\n"; + +$_[0] = "not ok 1\n"; +$result = do foo1("ok 1\n"); +print "#2\t:$result: eq :value:\n"; +if ($result EQ 'value') { print "ok 2\n"; } else { print "not ok 2\n"; } +if ($_[0] EQ "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; } + +$_[0] = "not ok 4\n"; +$result = do foo2("not ok 4\n","ok 4\n","not ok 4\n"); +print "#5\t:$result: eq :value:\n"; +if ($result EQ 'value') { print "ok 5\n"; } else { print "not ok 5\n"; } +if ($_[0] EQ "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; } + +$result = do{print "ok 7\n"; 'value';}; +print "#8\t:$result: eq :value:\n"; +if ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; } diff --git a/t/op.each b/t/op.each new file mode 100644 index 0000000000..8e91950e4b --- /dev/null +++ b/t/op.each @@ -0,0 +1,50 @@ +#!./perl + +# $Header: op.each,v 1.0 87/12/18 13:13:23 root Exp $ + +print "1..2\n"; + +$h{'abc'} = 'ABC'; +$h{'def'} = 'DEF'; +$h{'jkl'} = 'JKL'; +$h{'xyz'} = 'XYZ'; +$h{'a'} = 'A'; +$h{'b'} = 'B'; +$h{'c'} = 'C'; +$h{'d'} = 'D'; +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'G'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +@keys = keys(h); +@values = values(h); + +if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";} + +while (($key,$value) = each(h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 2\n";} else {print "not ok 2\n";} diff --git a/t/op.exec b/t/op.exec new file mode 100644 index 0000000000..328e470889 --- /dev/null +++ b/t/op.exec @@ -0,0 +1,12 @@ +#!./perl + +# $Header: op.exec,v 1.0 87/12/18 13:13:26 root Exp $ + +$| = 1; # flush stdout +print "1..4\n"; + +system "echo ok \\1"; # shell interpreted +system "echo ok 2"; # split and directly called +system "echo", "ok", "3"; # directly called + +exec "echo","ok","4"; diff --git a/t/op.exp b/t/op.exp new file mode 100644 index 0000000000..8a3a8b66af --- /dev/null +++ b/t/op.exp @@ -0,0 +1,27 @@ +#!./perl + +# $Header: op.exp,v 1.0 87/12/18 13:13:29 root Exp $ + +print "1..6\n"; + +# compile time evaluation + +$s = sqrt(2); +if (substr($s,0,5) eq '1.414') {print "ok 1\n";} else {print "not ok 1\n";} + +$s = exp(1); +if (substr($s,0,7) eq '2.71828') {print "ok 2\n";} else {print "not ok 2\n";} + +if (exp(log(1)) == 1) {print "ok 3\n";} else {print "not ok 3\n";} + +# run time evaluation + +$x1 = 1; +$x2 = 2; +$s = sqrt($x2); +if (substr($s,0,5) eq '1.414') {print "ok 4\n";} else {print "not ok 4\n";} + +$s = exp($x1); +if (substr($s,0,7) eq '2.71828') {print "ok 5\n";} else {print "not ok 5\n";} + +if (exp(log($x1)) == 1) {print "ok 6\n";} else {print "not ok 6\n";} diff --git a/t/op.flip b/t/op.flip new file mode 100644 index 0000000000..6a54b190b5 --- /dev/null +++ b/t/op.flip @@ -0,0 +1,26 @@ +#!./perl + +# $Header: op.flip,v 1.0 87/12/18 13:13:34 root Exp $ + +print "1..8\n"; + +@a = (1,2,3,4,5,6,7,8,9,10,11,12); + +while ($_ = shift(a)) { + if ($x = /4/../8/) { $z = $x; print "ok ", $x + 0, "\n"; } + $y .= /1/../2/; +} + +if ($z eq '5E0') {print "ok 6\n";} else {print "not ok 6\n";} + +if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";} + +@a = ('a','b','c','d','e','f','g'); + +open(of,'/etc/termcap'); +while (<of>) { + (3 .. 5) && $foo .= $_; +} +$x = ($foo =~ y/\n/\n/); + +if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";} diff --git a/t/op.fork b/t/op.fork new file mode 100644 index 0000000000..5d6dee3157 --- /dev/null +++ b/t/op.fork @@ -0,0 +1,16 @@ +#!./perl + +# $Header: op.fork,v 1.0 87/12/18 13:13:37 root Exp $ + +$| = 1; +print "1..2\n"; + +if ($cid = fork) { + sleep 2; + if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";} +} +else { + $| = 1; + print "ok 1\n"; + sleep 10; +} diff --git a/t/op.goto b/t/op.goto new file mode 100644 index 0000000000..45dfcf77d7 --- /dev/null +++ b/t/op.goto @@ -0,0 +1,34 @@ +#!./perl + +# $Header: op.goto,v 1.0 87/12/18 13:13:40 root Exp $ + +print "1..3\n"; + +while (0) { + $foo = 1; + label1: + $foo = 2; + goto label2; +} continue { + $foo = 0; + goto label4; + label3: + $foo = 4; + goto label4; +} +goto label1; + +$foo = 3; + +label2: +print "#1\t:$foo: == 2\n"; +if ($foo == 2) {print "ok 1\n";} else {print "not ok 1\n";} +goto label3; + +label4: +print "#2\t:$foo: == 4\n"; +if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} + +$x = `./perl -e 'goto foo;' 2>&1`; +print "#3\t/label/ in :$x"; +if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/t/op.int b/t/op.int new file mode 100644 index 0000000000..b358ad7cf5 --- /dev/null +++ b/t/op.int @@ -0,0 +1,17 @@ +#!./perl + +# $Header: op.int,v 1.0 87/12/18 13:13:43 root Exp $ + +print "1..4\n"; + +# compile time evaluation + +if (int(1.234) == 1) {print "ok 1\n";} else {print "not ok 1\n";} + +if (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";} + +# run time evaluation + +$x = 1.234; +if (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";} +if (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";} diff --git a/t/op.join b/t/op.join new file mode 100644 index 0000000000..f3555a63cc --- /dev/null +++ b/t/op.join @@ -0,0 +1,12 @@ +#!./perl + +# $Header: op.join,v 1.0 87/12/18 13:13:46 root Exp $ + +print "1..3\n"; + +@x = (1, 2, 3); +if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} + +if (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";} + +if (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/t/op.list b/t/op.list new file mode 100644 index 0000000000..e0c90fa553 --- /dev/null +++ b/t/op.list @@ -0,0 +1,34 @@ +#!./perl + +# $Header: op.list,v 1.0 87/12/18 13:13:50 root Exp $ + +print "1..11\n"; + +@foo = (1, 2, 3, 4); +if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";} + +$_ = join(foo,':'); +if ($_ eq '1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";} + +($a,$b,$c,$d) = (1,2,3,4); +if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 3\n";} else {print "not ok 3\n";} + +($c,$b,$a) = split(/ /,"111 222 333"); +if ("$a;$b;$c" eq '333;222;111') {print "ok 4\n";} else {print "not ok 4\n";} + +($a,$b,$c) = ($c,$b,$a); +if ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5\n";} + +($a, $b) = ($b, $a); +if ("$a;$b;$c" eq '222;111;333') {print "ok 6\n";} else {print "not ok 6\n";} + +($a, $b[1], $c{2}, $d) = (1, 2, 3, 4); +if ($a eq 1) {print "ok 7\n";} else {print "not ok 7\n";} +if ($b[1] eq 2) {print "ok 8\n";} else {print "not ok 8\n";} +if ($c{2} eq 3) {print "ok 9\n";} else {print "not ok 9\n";} +if ($d eq 4) {print "ok 10\n";} else {print "not ok 10\n";} + +@foo = (1,2,3,4,5,6,7,8); +($a, $b, $c, $d) = @foo; +print "#11 $a;$b;$c;$d eq 1;2;3;4\n"; +if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";} diff --git a/t/op.magic b/t/op.magic new file mode 100644 index 0000000000..7696803127 --- /dev/null +++ b/t/op.magic @@ -0,0 +1,27 @@ +#!./perl + +# $Header: op.magic,v 1.0 87/12/18 13:13:54 root Exp $ + +print "1..4\n"; + +$| = 1; # command buffering + +$ENV{'foo'} = 'hi there'; +if (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";} + +$! = 0; +open(foo,'ajslkdfpqjsjfkslkjdflksd'); +if ($! == 2) {print "ok 2\n";} else {print "not ok 2\n";} + +$SIG{'INT'} = 'ok3'; +kill 2,$$; +$SIG{'INT'} = 'IGNORE'; +kill 2,$$; +print "ok 4\n"; +$SIG{'INT'} = 'DEFAULT'; +kill 2,$$; +print "not ok\n"; + +sub ok3 { + print "ok 3\n" if pop(@_) eq 'INT'; +} diff --git a/t/op.oct b/t/op.oct new file mode 100644 index 0000000000..718a4d32b8 --- /dev/null +++ b/t/op.oct @@ -0,0 +1,9 @@ +#!./perl + +# $Header: op.oct,v 1.0 87/12/18 13:13:57 root Exp $ + +print "1..3\n"; + +if (oct('01234') == 01234) {print "ok 1\n";} else {print "not ok 1\n";} +if (oct('0x1234') == 0x1234) {print "ok 2\n";} else {print "not ok 2\n";} +if (hex('01234') == 0x1234) {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/t/op.ord b/t/op.ord new file mode 100644 index 0000000000..a46ef78258 --- /dev/null +++ b/t/op.ord @@ -0,0 +1,14 @@ +#!./perl + +# $Header: op.ord,v 1.0 87/12/18 13:14:01 root Exp $ + +print "1..2\n"; + +# compile time evaluation + +if (ord('A') == 65) {print "ok 1\n";} else {print "not ok 1\n";} + +# run time evaluation + +$x = 'ABC'; +if (ord($x) == 65) {print "ok 2\n";} else {print "not ok 2\n";} diff --git a/t/op.pat b/t/op.pat new file mode 100644 index 0000000000..1013610ae4 --- /dev/null +++ b/t/op.pat @@ -0,0 +1,56 @@ +#!./perl + +# $Header: op.pat,v 1.0 87/12/18 13:14:07 root Exp $ +print "1..22\n"; + +$x = "abc\ndef\n"; + +if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} +if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";} + +$* = 1; +if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";} +$* = 0; + +$_ = '123'; +if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";} + +if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";} +if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";} + +if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";} +if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";} + +if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";} +if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";} + +if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";} +if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";} + +$_ = 'aaabbbccc'; +if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') { + print "ok 13\n"; +} else { + print "not ok 13\n"; +} +if (/(a+b+c+)/ && $1 eq 'aaabbbccc') { + print "ok 14\n"; +} else { + print "not ok 14\n"; +} + +if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";} + +$_ = 'aaabccc'; +if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";} +if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";} + +$_ = 'aaaccc'; +if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";} +if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";} + +$_ = 'abcdef'; +if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";} +if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";} + +if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";} diff --git a/t/op.push b/t/op.push new file mode 100644 index 0000000000..01cbfbf6cf --- /dev/null +++ b/t/op.push @@ -0,0 +1,11 @@ +#!./perl + +# $Header: op.push,v 1.0 87/12/18 13:14:10 root Exp $ + +print "1..2\n"; + +@x = (1,2,3); +push(@x,@x); +if (join(x,':') eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} +push(x,4); +if (join(x,':') eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";} diff --git a/t/op.repeat b/t/op.repeat new file mode 100644 index 0000000000..1c03c31d9a --- /dev/null +++ b/t/op.repeat @@ -0,0 +1,32 @@ +#!./perl + +# $Header: op.repeat,v 1.0 87/12/18 13:14:14 root Exp $ + +print "1..11\n"; + +# compile time + +if ('-' x 5 eq '-----') {print "ok 1\n";} else {print "not ok 1\n";} +if ('-' x 1 eq '-') {print "ok 2\n";} else {print "not ok 2\n";} +if ('-' x 0 eq '') {print "ok 3\n";} else {print "not ok 3\n";} + +if ('ab' x 3 eq 'ababab') {print "ok 4\n";} else {print "not ok 4\n";} + +# run time + +$a = '-'; +if ($a x 5 eq '-----') {print "ok 5\n";} else {print "not ok 5\n";} +if ($a x 1 eq '-') {print "ok 6\n";} else {print "not ok 6\n";} +if ($a x 0 eq '') {print "ok 7\n";} else {print "not ok 7\n";} + +$a = 'ab'; +if ($a x 3 eq 'ababab') {print "ok 8\n";} else {print "not ok 8\n";} + +$a = 'xyz'; +$a x= 2; +if ($a eq 'xyzxyz') {print "ok 9\n";} else {print "not ok 9\n";} +$a x= 1; +if ($a eq 'xyzxyz') {print "ok 10\n";} else {print "not ok 10\n";} +$a x= 0; +if ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";} + diff --git a/t/op.sleep b/t/op.sleep new file mode 100644 index 0000000000..e32e62bf1b --- /dev/null +++ b/t/op.sleep @@ -0,0 +1,8 @@ +#!./perl + +# $Header: op.sleep,v 1.0 87/12/18 13:14:17 root Exp $ + +print "1..1\n"; + +$x = sleep 2; +if ($x == 2) {print "ok 1\n";} else {print "not ok 1\n";} diff --git a/t/op.split b/t/op.split new file mode 100644 index 0000000000..988af49d3d --- /dev/null +++ b/t/op.split @@ -0,0 +1,24 @@ +#!./perl + +# $Header: op.split,v 1.0 87/12/18 13:14:20 root Exp $ + +print "1..4\n"; + +$FS = ':'; + +$_ = 'a:b:c'; + +($a,$b,$c) = split($FS,$_); + +if (join(';',$a,$b,$c) eq 'a;b;c') {print "ok 1\n";} else {print "not ok 1\n";} + +@ary = split(/:b:/); +if (join("$_",@ary) eq 'aa:b:cc') {print "ok 2\n";} else {print "not ok 2\n";} + +$_ = "abc\n"; +@ary = split(//); +if (join(".",@ary) eq "a.b.c.\n") {print "ok 3\n";} else {print "not ok 3\n";} + +$_ = "a:b:c::::"; +@ary = split(/:/); +if (join(".",@ary) eq "a.b.c") {print "ok 4\n";} else {print "not ok 4\n";} diff --git a/t/op.sprintf b/t/op.sprintf new file mode 100644 index 0000000000..cb4e5c7b3a --- /dev/null +++ b/t/op.sprintf @@ -0,0 +1,8 @@ +#!./perl + +# $Header: op.sprintf,v 1.0 87/12/18 13:14:24 root Exp $ + +print "1..1\n"; + +$x = sprintf("%3s %-4s foo %5d%c%3.1f","hi",123,456,65,3.0999); +if ($x eq ' hi 123 foo 456A3.1') {print "ok 1\n";} else {print "not ok 1\n";} diff --git a/t/op.stat b/t/op.stat new file mode 100644 index 0000000000..c087c2484e --- /dev/null +++ b/t/op.stat @@ -0,0 +1,29 @@ +#!./perl + +# $Header: op.stat,v 1.0 87/12/18 13:14:27 root Exp $ + +print "1..4\n"; + +open(foo, ">Op.stat.tmp"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(foo); +if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";} +if ($mtime && $mtime == $ctime) {print "ok 2\n";} else {print "not ok 2\n";} + +print foo "Now is the time for all good men to come to.\n"; +close(foo); + +$base = time; +while (time == $base) {} + +`rm -f Op.stat.tmp2; ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('Op.stat.tmp'); + +if ($nlink == 2) {print "ok 3\n";} else {print "not ok 3\n";} +if ($mtime && $mtime != $ctime) {print "ok 4\n";} else {print "not ok 4\n";} +print "#4 :$mtime: != :$ctime:\n"; + +`rm -f Op.stat.tmp Op.stat.tmp2`; diff --git a/t/op.subst b/t/op.subst new file mode 100644 index 0000000000..e431be8cec --- /dev/null +++ b/t/op.subst @@ -0,0 +1,38 @@ +#!./perl + +# $Header: op.subst,v 1.0 87/12/18 13:14:30 root Exp $ + +print "1..7\n"; + +$x = 'foo'; +$_ = "x"; +s/x/\$x/; +print "#1\t:$_: eq :\$x:\n"; +if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";} + +$_ = "x"; +s/x/$x/; +print "#2\t:$_: eq :foo:\n"; +if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";} + +$_ = "x"; +s/x/\$x $x/; +print "#3\t:$_: eq :\$x foo:\n"; +if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";} + +$a = 'abcdef'; +$b = 'cd'; +$a =~ s'(b${b}e)'\n$1'; +print "#4\t:$1: eq :bcde:\n"; +print "#4\t:$a: eq :a\\n\$1f:\n"; +if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";} + +$a = 'abacada'; +if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx') + {print "ok 5\n";} else {print "not ok 5\n";} + +if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx') + {print "ok 6\n";} else {print "not ok 6\n";} + +if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx') + {print "ok 7\n";} else {print "not ok 7\n";} diff --git a/t/op.time b/t/op.time new file mode 100644 index 0000000000..1d92bac50f --- /dev/null +++ b/t/op.time @@ -0,0 +1,43 @@ +#!./perl + +# $Header: op.time,v 1.0 87/12/18 13:14:33 root Exp $ + +print "1..5\n"; + +($beguser,$begsys) = times; + +$beg = time; + +while (($now = time) == $beg) {} + +if ($now > $beg && $now - $beg < 10){print "ok 1\n";} else {print "not ok 1\n";} + +for ($i = 0; $i < 100000; $i++) { + ($nowuser, $nowsys) = times; + $i = 200000 if $nowuser > $beguser && $nowsys > $begsys; + last if time - $beg > 20; +} + +if ($i >= 200000) {print "ok 2\n";} else {print "not ok 2\n";} + +($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg); +($xsec,$foo) = localtime($now); +$localyday = $yday; + +if ($sec != $xsec && $yday && $wday && $year) + {print "ok 3\n";} +else + {print "not ok 3\n";} + +($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg); +($xsec,$foo) = localtime($now); + +if ($sec != $xsec && $yday && $wday && $year) + {print "ok 4\n";} +else + {print "not ok 4\n";} + +if (index(" :0:1:-1:365:366:-365:-366:",':' . ($localyday - $yday) . ':') > 0) + {print "ok 5\n";} +else + {print "not ok 5\n";} diff --git a/t/op.unshift b/t/op.unshift new file mode 100644 index 0000000000..3008da5de9 --- /dev/null +++ b/t/op.unshift @@ -0,0 +1,14 @@ +#!./perl + +# $Header: op.unshift,v 1.0 87/12/18 13:14:37 root Exp $ + +print "1..2\n"; + +@a = (1,2,3); +$cnt1 = unshift(a,0); + +if (join(' ',@a) eq '0 1 2 3') {print "ok 1\n";} else {print "not ok 1\n";} +$cnt2 = unshift(a,3,2,1); +if (join(' ',@a) eq '3 2 1 0 1 2 3') {print "ok 2\n";} else {print "not ok 2\n";} + + diff --git a/util.c b/util.c new file mode 100644 index 0000000000..b0b78f1926 --- /dev/null +++ b/util.c @@ -0,0 +1,263 @@ +/* $Header: util.c,v 1.0 87/12/18 13:06:30 root Exp $ + * + * $Log: util.c,v $ + * Revision 1.0 87/12/18 13:06:30 root + * Initial revision + * + */ + +#include <stdio.h> + +#include "handy.h" +#include "EXTERN.h" +#include "search.h" +#include "perl.h" +#include "INTERN.h" +#include "util.h" + +#define FLUSH +#define MEM_SIZE unsigned int + +static char nomem[] = "Out of memory!\n"; + +/* paranoid version of malloc */ + +static int an = 0; + +char * +safemalloc(size) +MEM_SIZE size; +{ + char *ptr; + char *malloc(); + + ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ +#ifdef DEBUGGING + if (debug & 128) + fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size); +#endif + if (ptr != Nullch) + return ptr; + else { + fputs(nomem,stdout) FLUSH; + exit(1); + } + /*NOTREACHED*/ +} + +/* paranoid version of realloc */ + +char * +saferealloc(where,size) +char *where; +MEM_SIZE size; +{ + char *ptr; + char *realloc(); + + ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ +#ifdef DEBUGGING + if (debug & 128) { + fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++); + fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size); + } +#endif + if (ptr != Nullch) + return ptr; + else { + fputs(nomem,stdout) FLUSH; + exit(1); + } + /*NOTREACHED*/ +} + +/* safe version of free */ + +safefree(where) +char *where; +{ +#ifdef DEBUGGING + if (debug & 128) + fprintf(stderr,"0x%x: (%05d) free\n",where,an++); +#endif + free(where); +} + +/* safe version of string copy */ + +char * +safecpy(to,from,len) +char *to; +register char *from; +register int len; +{ + register char *dest = to; + + if (from != Nullch) + for (len--; len && (*dest++ = *from++); len--) ; + *dest = '\0'; + return to; +} + +#ifdef undef +/* safe version of string concatenate, with \n deletion and space padding */ + +char * +safecat(to,from,len) +char *to; +register char *from; +register int len; +{ + register char *dest = to; + + len--; /* leave room for null */ + if (*dest) { + while (len && *dest++) len--; + if (len) { + len--; + *(dest-1) = ' '; + } + } + if (from != Nullch) + while (len && (*dest++ = *from++)) len--; + if (len) + dest--; + if (*(dest-1) == '\n') + dest--; + *dest = '\0'; + return to; +} +#endif + +/* copy a string up to some (non-backslashed) delimiter, if any */ + +char * +cpytill(to,from,delim) +register char *to, *from; +register int delim; +{ + for (; *from; from++,to++) { + if (*from == '\\' && from[1] == delim) + from++; + else if (*from == delim) + break; + *to = *from; + } + *to = '\0'; + return from; +} + +/* return ptr to little string in big string, NULL if not found */ + +char * +instr(big, little) +char *big, *little; + +{ + register char *t, *s, *x; + + for (t = big; *t; t++) { + for (x=t,s=little; *s; x++,s++) { + if (!*x) + return Nullch; + if (*s != *x) + break; + } + if (!*s) + return t; + } + return Nullch; +} + +/* copy a string to a safe spot */ + +char * +savestr(str) +char *str; +{ + register char *newaddr = safemalloc((MEM_SIZE)(strlen(str)+1)); + + (void)strcpy(newaddr,str); + return newaddr; +} + +/* grow a static string to at least a certain length */ + +void +growstr(strptr,curlen,newlen) +char **strptr; +int *curlen; +int newlen; +{ + if (newlen > *curlen) { /* need more room? */ + if (*curlen) + *strptr = saferealloc(*strptr,(MEM_SIZE)newlen); + else + *strptr = safemalloc((MEM_SIZE)newlen); + *curlen = newlen; + } +} + +/*VARARGS1*/ +fatal(pat,a1,a2,a3,a4) +char *pat; +{ + extern FILE *e_fp; + extern char *e_tmpname; + + fprintf(stderr,pat,a1,a2,a3,a4); + if (e_fp) + UNLINK(e_tmpname); + exit(1); +} + +static bool firstsetenv = TRUE; +extern char **environ; + +void +setenv(nam,val) +char *nam, *val; +{ + register int i=envix(nam); /* where does it go? */ + + if (!environ[i]) { /* does not exist yet */ + if (firstsetenv) { /* need we copy environment? */ + int j; +#ifndef lint + char **tmpenv = (char**) /* point our wand at memory */ + safemalloc((i+2) * sizeof(char*)); +#else + char **tmpenv = Null(char **); +#endif /* lint */ + + firstsetenv = FALSE; + for (j=0; j<i; j++) /* copy environment */ + tmpenv[j] = environ[j]; + environ = tmpenv; /* tell exec where it is now */ + } +#ifndef lint + else + environ = (char**) saferealloc((char*) environ, + (i+2) * sizeof(char*)); + /* just expand it a bit */ +#endif /* lint */ + environ[i+1] = Nullch; /* make sure it's null terminated */ + } + environ[i] = safemalloc(strlen(nam) + strlen(val) + 2); + /* this may or may not be in */ + /* the old environ structure */ + sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ +} + +int +envix(nam) +char *nam; +{ + register int i, len = strlen(nam); + + for (i = 0; environ[i]; i++) { + if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') + break; /* strnEQ must come first to avoid */ + } /* potential SEGV's */ + return i; +} diff --git a/util.h b/util.h new file mode 100644 index 0000000000..4f92eeb43c --- /dev/null +++ b/util.h @@ -0,0 +1,36 @@ +/* $Header: util.h,v 1.0 87/12/18 13:06:33 root Exp $ + * + * $Log: util.h,v $ + * Revision 1.0 87/12/18 13:06:33 root + * Initial revision + * + */ + +/* is the string for makedir a directory name or a filename? */ + +#define MD_DIR 0 +#define MD_FILE 1 + +void util_init(); +int doshell(); +char *safemalloc(); +char *saferealloc(); +char *safecpy(); +char *safecat(); +char *cpytill(); +char *instr(); +#ifdef SETUIDGID + int eaccess(); +#endif +char *getwd(); +void cat(); +void prexit(); +char *get_a_line(); +char *savestr(); +int makedir(); +void setenv(); +int envix(); +void notincl(); +char *getval(); +void growstr(); +void setdef(); diff --git a/version.c b/version.c new file mode 100644 index 0000000000..8771afd874 --- /dev/null +++ b/version.c @@ -0,0 +1,18 @@ +/* $Header: version.c,v 1.0 87/12/18 13:06:41 root Exp $ + * + * $Log: version.c,v $ + * Revision 1.0 87/12/18 13:06:41 root + * Initial revision + * + */ + +#include "patchlevel.h" + +/* Print out the version number. */ + +version() +{ + extern char rcsid[]; + + printf("%s\r\nPatch level: %d\r\n", rcsid, PATCHLEVEL); +} diff --git a/x2p/EXTERN.h b/x2p/EXTERN.h new file mode 100644 index 0000000000..d0e248160a --- /dev/null +++ b/x2p/EXTERN.h @@ -0,0 +1,15 @@ +/* $Header: EXTERN.h,v 1.0 87/12/18 13:06:44 root Exp $ + * + * $Log: EXTERN.h,v $ + * Revision 1.0 87/12/18 13:06:44 root + * Initial revision + * + */ + +#undef EXT +#define EXT extern + +#undef INIT +#define INIT(x) + +#undef DOINIT diff --git a/x2p/INTERN.h b/x2p/INTERN.h new file mode 100644 index 0000000000..76c51c5df8 --- /dev/null +++ b/x2p/INTERN.h @@ -0,0 +1,15 @@ +/* $Header: INTERN.h,v 1.0 87/12/18 13:06:48 root Exp $ + * + * $Log: INTERN.h,v $ + * Revision 1.0 87/12/18 13:06:48 root + * Initial revision + * + */ + +#undef EXT +#define EXT + +#undef INIT +#define INIT(x) = x + +#define DOINIT diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH new file mode 100644 index 0000000000..d965160cc3 --- /dev/null +++ b/x2p/Makefile.SH @@ -0,0 +1,148 @@ +case $CONFIG in +'') + if test ! -f config.sh; then + ln ../config.sh . || \ + ln ../../config.sh . || \ + ln ../../../config.sh . || \ + (echo "Can't find config.sh."; exit 1) + fi + . config.sh + ;; +esac +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac +echo "Extracting x2p/Makefile (with variable substitutions)" +cat >Makefile <<!GROK!THIS! +# $Header: Makefile.SH,v 1.0 87/12/18 17:50:17 root Exp $ +# +# $Log: Makefile.SH,v $ +# Revision 1.0 87/12/18 17:50:17 root +# Initial revision +# +# + +CC = $cc +bin = $bin +lib = $lib +mansrc = $mansrc +manext = $manext +CFLAGS = $ccflags -O +LDFLAGS = $ldflags +SMALL = $small +LARGE = $large $split + +libs = $libnm -lm +!GROK!THIS! + +cat >>Makefile <<'!NO!SUBS!' + +public = a2p s2p + +private = + +manpages = a2p.man s2p.man + +util = + +sh = Makefile.SH makedepend.SH + +h = EXTERN.h INTERN.h config.h handy.h hash.h a2p.h str.h util.h + +c = hash.c ../malloc.c str.c util.c walk.c + +obj = hash.o malloc.o str.o util.o walk.o + +lintflags = -phbvxac + +addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 + +# grrr +SHELL = /bin/sh + +.c.o: + $(CC) -c $(CFLAGS) $(LARGE) $*.c + +all: $(public) $(private) $(util) + touch all + +a2p: $(obj) a2p.o + $(CC) $(LDFLAGS) $(LARGE) $(obj) a2p.o $(libs) -o a2p + +a2p.c: a2p.y + @ echo Expect 107 shift/reduce errors... + yacc a2p.y + mv y.tab.c a2p.c + +a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h + $(CC) -c $(CFLAGS) $(LARGE) a2p.c + +# if a .h file depends on another .h file... +$(h): + touch $@ +install: a2p s2p +# won't work with csh + export PATH || exit 1 + - mv $(bin)/a2p $(bin)/a2p.old + - mv $(bin)/s2p $(bin)/s2p.old + - if test `pwd` != $(bin); then cp $(public) $(bin); fi + cd $(bin); \ +for pub in $(public); do \ +chmod 755 `basename $$pub`; \ +done + - test $(bin) = /bin || rm -f /bin/a2p +# chmod 755 makedir +# - makedir `filexp $(lib)` +# - \ +#if test `pwd` != `filexp $(lib)`; then \ +#cp $(private) `filexp $(lib)`; \ +#fi +# cd `filexp $(lib)`; \ +#for priv in $(private); do \ +#chmod 755 `basename $$priv`; \ +#done + - if test `pwd` != $(mansrc); then \ +for page in $(manpages); do \ +cp $$page $(mansrc)/`basename $$page .man`.$(manext); \ +done; \ +fi + +clean: + rm -f *.o + +realclean: + rm -f a2p *.orig */*.orig *.o core $(addedbyconf) + +# The following lint has practically everything turned on. Unfortunately, +# you have to wade through a lot of mumbo jumbo that can't be suppressed. +# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message +# for that spot. + +lint: + lint $(lintflags) $(defs) $(c) > a2p.fuzz + +depend: ../makedepend + ../makedepend + +clist: + echo $(c) | tr ' ' '\012' >.clist + +hlist: + echo $(h) | tr ' ' '\012' >.hlist + +shlist: + echo $(sh) | tr ' ' '\012' >.shlist + +# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE +$(obj): + @ echo "You haven't done a "'"make depend" yet!'; exit 1 +makedepend: makedepend.SH + /bin/sh makedepend.SH +!NO!SUBS! +$eunicefix Makefile +case `pwd` in +*SH) + $rm -f ../Makefile + ln Makefile ../Makefile + ;; +esac diff --git a/x2p/a2p.h b/x2p/a2p.h new file mode 100644 index 0000000000..35f8bbeb1f --- /dev/null +++ b/x2p/a2p.h @@ -0,0 +1,253 @@ +/* $Header: a2p.h,v 1.0 87/12/18 13:06:58 root Exp $ + * + * $Log: a2p.h,v $ + * Revision 1.0 87/12/18 13:06:58 root + * Initial revision + * + */ + +#include "handy.h" +#define Nullop 0 + +#define OPROG 1 +#define OJUNK 2 +#define OHUNKS 3 +#define ORANGE 4 +#define OPAT 5 +#define OHUNK 6 +#define OPPAREN 7 +#define OPANDAND 8 +#define OPOROR 9 +#define OPNOT 10 +#define OCPAREN 11 +#define OCANDAND 12 +#define OCOROR 13 +#define OCNOT 14 +#define ORELOP 15 +#define ORPAREN 16 +#define OMATCHOP 17 +#define OMPAREN 18 +#define OCONCAT 19 +#define OASSIGN 20 +#define OADD 21 +#define OSUB 22 +#define OMULT 23 +#define ODIV 24 +#define OMOD 25 +#define OPOSTINCR 26 +#define OPOSTDECR 27 +#define OPREINCR 28 +#define OPREDECR 29 +#define OUMINUS 30 +#define OUPLUS 31 +#define OPAREN 32 +#define OGETLINE 33 +#define OSPRINTF 34 +#define OSUBSTR 35 +#define OSTRING 36 +#define OSPLIT 37 +#define OSNEWLINE 38 +#define OINDEX 39 +#define ONUM 40 +#define OSTR 41 +#define OVAR 42 +#define OFLD 43 +#define ONEWLINE 44 +#define OCOMMENT 45 +#define OCOMMA 46 +#define OSEMICOLON 47 +#define OSCOMMENT 48 +#define OSTATES 49 +#define OSTATE 50 +#define OPRINT 51 +#define OPRINTF 52 +#define OBREAK 53 +#define ONEXT 54 +#define OEXIT 55 +#define OCONTINUE 56 +#define OREDIR 57 +#define OIF 58 +#define OWHILE 59 +#define OFOR 60 +#define OFORIN 61 +#define OVFLD 62 +#define OBLOCK 63 +#define OREGEX 64 +#define OLENGTH 65 +#define OLOG 66 +#define OEXP 67 +#define OSQRT 68 +#define OINT 69 + +#ifdef DOINIT +char *opname[] = { + "0", + "PROG", + "JUNK", + "HUNKS", + "RANGE", + "PAT", + "HUNK", + "PPAREN", + "PANDAND", + "POROR", + "PNOT", + "CPAREN", + "CANDAND", + "COROR", + "CNOT", + "RELOP", + "RPAREN", + "MATCHOP", + "MPAREN", + "CONCAT", + "ASSIGN", + "ADD", + "SUB", + "MULT", + "DIV", + "MOD", + "POSTINCR", + "POSTDECR", + "PREINCR", + "PREDECR", + "UMINUS", + "UPLUS", + "PAREN", + "GETLINE", + "SPRINTF", + "SUBSTR", + "STRING", + "SPLIT", + "SNEWLINE", + "INDEX", + "NUM", + "STR", + "VAR", + "FLD", + "NEWLINE", + "COMMENT", + "COMMA", + "SEMICOLON", + "SCOMMENT", + "STATES", + "STATE", + "PRINT", + "PRINTF", + "BREAK", + "NEXT", + "EXIT", + "CONTINUE", + "REDIR", + "IF", + "WHILE", + "FOR", + "FORIN", + "VFLD", + "BLOCK", + "REGEX", + "LENGTH", + "LOG", + "EXP", + "SQRT", + "INT", + "70" +}; +#else +extern char *opname[]; +#endif + +union { + int ival; + char *cval; +} ops[50000]; /* hope they have 200k to spare */ + +EXT int mop INIT(1); + +#define DEBUGGING + +#include <stdio.h> +#include <ctype.h> +#include <setjmp.h> +#include <sys/types.h> +#include <sys/stat.h> +#include <time.h> +#include <sys/times.h> + +typedef struct string STR; +typedef struct htbl HASH; + +#include "str.h" +#include "hash.h" + +/* A string is TRUE if not "" or "0". */ +#define True(val) (tmps = (val), (*tmps && !(*tmps == '0' && !tmps[1]))) +EXT char *Yes INIT("1"); +EXT char *No INIT(""); + +#define str_true(str) (Str = (str), (Str->str_pok ? True(Str->str_ptr) : (Str->str_nok ? (Str->str_nval != 0.0) : 0 ))) + +#define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),buf) : "" ))) +#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str))) +#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_nval : str_2num(Str))) +EXT STR *Str; + +#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len) + +STR *str_new(); + +char *scanpat(); +char *scannum(); + +void str_free(); + +EXT int line INIT(0); + +EXT FILE *rsfp; +EXT char buf[1024]; +EXT char *bufptr INIT(buf); + +EXT STR *linestr INIT(Nullstr); + +EXT char tokenbuf[256]; +EXT int expectterm INIT(TRUE); + +#ifdef DEBUGGING +EXT int debug INIT(0); +EXT int dlevel INIT(0); +#define YYDEBUG; +extern int yydebug; +#endif + +EXT STR *freestrroot INIT(Nullstr); + +EXT STR str_no; +EXT STR str_yes; + +EXT bool do_split INIT(FALSE); +EXT bool split_to_array INIT(FALSE); +EXT bool set_array_base INIT(FALSE); +EXT bool saw_RS INIT(FALSE); +EXT bool saw_OFS INIT(FALSE); +EXT bool saw_ORS INIT(FALSE); +EXT bool saw_line_op INIT(FALSE); +EXT bool in_begin INIT(TRUE); +EXT bool do_opens INIT(FALSE); +EXT bool do_fancy_opens INIT(FALSE); +EXT bool lval_field INIT(FALSE); +EXT bool do_chop INIT(FALSE); +EXT bool need_entire INIT(FALSE); +EXT bool absmaxfld INIT(FALSE); + +EXT char const_FS INIT(0); +EXT char *namelist INIT(Nullch); +EXT char fswitch INIT(0); + +EXT int saw_FS INIT(0); +EXT int maxfld INIT(0); +EXT int arymax INIT(0); +char *nameary[100]; + +EXT STR *opens; + +EXT HASH *symtab; diff --git a/x2p/a2p.man b/x2p/a2p.man new file mode 100644 index 0000000000..d367526893 --- /dev/null +++ b/x2p/a2p.man @@ -0,0 +1,191 @@ +.rn '' }` +''' $Header: a2p.man,v 1.0 87/12/18 17:23:56 root Exp $ +''' +''' $Log: a2p.man,v $ +''' Revision 1.0 87/12/18 17:23:56 root +''' Initial revision +''' +''' +.de Sh +.br +.ne 5 +.PP +\fB\\$1\fR +.PP +.. +.de Sp +.if t .sp .5v +.if n .sp +.. +.de Ip +.br +.ie \\n.$>=3 .ne \\$3 +.el .ne 3 +.IP "\\$1" \\$2 +.. +''' +''' Set up \*(-- to give an unbreakable dash; +''' string Tr holds user defined translation string. +''' Bell System Logo is used as a dummy character. +''' +.tr \(bs-|\(bv\*(Tr +.ie n \{\ +.ds -- \(bs- +.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch +.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\h'-8u'-\" diablo 12 pitch +.ds L" "" +.ds R" "" +.ds L' ' +.ds R' ' +'br\} +.el\{\ +.ds -- \(em\| +.tr \*(Tr +.ds L" `` +.ds R" '' +.ds L' ` +.ds R' ' +'br\} +.TH A2P 1 LOCAL +.SH NAME +a2p - Awk to Perl translator +.SH SYNOPSIS +.B a2p [options] filename +.SH DESCRIPTION +.I A2p +takes an awk script specified on the command line (or from standard input) +and produces a comparable +.I perl +script on the standard output. +.Sh "Options" +Options include: +.TP 5 +.B \-D<number> +sets debugging flags. +.TP 5 +.B \-F<character> +tells a2p that this awk script is always invoked with this -F switch. +.TP 5 +.B \-n<fieldlist> +specifies the names of the input fields if input does not have to be split into +an array. +If you were translating an awk script that processes the password file, you +might say: +.sp + a2p -7 -nlogin.password.uid.gid.gcos.shell.home +.sp +Any delimiter will do to separate the field names. +.TP 5 +.B \-<number> +causes a2p to assume that input will always have that many fields. +.Sh "Considerations" +A2p cannot do as good a job translating as a human would, but it usually +does pretty well. +There are some areas where you may want to examine the perl script produced +and tweak it some. +Here are some of them, in no particular order. +.PP +The split operator in perl always strips off all null fields from the end. +Awk does NOT do this, if you've set FS. +If the perl script splits to an array, the field count may not reflect +what you expect. +Ordinarily this isn't a problem, since nonexistent array elements have a null +value, but if you rely on NF in awk, you could be in for trouble. +Either force the number of fields with \-<number>, or count the number of +delimiters another way, e.g. with y/:/:/. +Or add something non-null to the end before you split, and then pop it off +the resulting array. +.PP +There is an awk idiom of putting int() around a string expression to force +numeric interpretation, even though the argument is always integer anyway. +This is generally unneeded in perl, but a2p can't tell if the argument +is always going to be integer, so it leaves it in. +You may wish to remove it. +.PP +Perl differentiates numeric comparison from string comparison. +Awk has one operator for both that decides at run time which comparison +to do. +A2p does not try to do a complete job of awk emulation at this point. +Instead it guesses which one you want. +It's almost always right, but it can be spoofed. +All such guesses are marked with the comment \*(L"#???\*(R". +You should go through and check them. +.PP +Perl does not attempt to emulate the behavior of awk in which nonexistent +array elements spring into existence simply by being referenced. +If somehow you are relying on this mechanism to create null entries for +a subsequent for...in, they won't be there in perl. +.PP +If a2p makes a split line that assigns to a list of variables that looks +like (Fld1, Fld2, Fld3...) you may want +to rerun a2p using the \-n option mentioned above. +This will let you name the fields throughout the script. +If it splits to an array instead, the script is probably referring to the number +of fields somewhere. +.PP +The exit statement in awk doesn't necessarily exit; it goes to the END +block if there is one. +Awk scripts that do contortions within the END block to bypass the block under +such circumstances can be simplified by removing the conditional +in the END block and just exiting directly from the perl script. +.PP +Perl has two kinds of array, numerically-indexed and associative. +Awk arrays are usually translated to associative arrays, but if you happen +to know that the index is always going to be numeric you could change +the {...} to [...]. +Iteration over an associative array is done with each(), but +iteration over a numeric array is NOT. +You need a for loop, or while loop with a pop() or shift(), so you might +need to modify any loop that is iterating over the array in question. +.PP +Arrays which have been split into are assumed to be numerically indexed. +The usual perl idiom for iterating over such arrays is to use pop() or shift() +and assign the resulting value to a variable inside the conditional of the +while loop. +This is destructive to the array, however, so a2p can't assume this is +reasonable. +A2p will write a standard for loop with a scratch variable. +You may wish to change it to a pop() loop for more efficiency, presuming +you don't want to keep the array around. +.PP +Awk starts by assuming OFMT has the value %.6g. +Perl starts by assuming its equivalent, $#, to have the value %.20g. +You'll want to set $# explicitly if you use the default value of OFMT. +.PP +Near the top of the line loop will be the split operation that is implicit in +the awk script. +There are times when you can move this down past some conditionals that +test the entire record so that the split is not done as often. +.PP +There may occasionally be extra parentheses that you can remove. +.PP +For aesthetic reasons you may wish to change the array base $[ from 1 back +to the default of 0, but remember to change all array subscripts AND +all substr() and index() operations to match. +.PP +Cute comments that say "# Here is a workaround because awk is dumb" are not +translated. +.PP +Awk scripts are often embedded in a shell script that pipes stuff into and +out of awk. +Often the shell script wrapper can be incorporated into the perl script, since +perl can start up pipes into and out of itself, and can do other things that +awk can't do by itself. +.SH ENVIRONMENT +A2p uses no environment variables. +.SH AUTHOR +Larry Wall <lwall@devvax.Jpl.Nasa.Gov> +.SH FILES +.SH SEE ALSO +perl The perl compiler/interpreter +.br +s2p sed to perl translator +.SH DIAGNOSTICS +.SH BUGS +It would be possible to emulate awk's behavior in selecting string versus +numeric operations at run time by inspection of the operands, but it would +be gross and inefficient. +Besides, a2p almost always guesses right. +.PP +Storage for the awk syntax tree is currently static, and can run out. +.rn }` '' diff --git a/x2p/a2p.y b/x2p/a2p.y new file mode 100644 index 0000000000..15484d2f3b --- /dev/null +++ b/x2p/a2p.y @@ -0,0 +1,325 @@ +%{ +/* $Header: a2p.y,v 1.0 87/12/18 13:07:05 root Exp $ + * + * $Log: a2p.y,v $ + * Revision 1.0 87/12/18 13:07:05 root + * Initial revision + * + */ + +#include "INTERN.h" +#include "a2p.h" + +int root; + +%} +%token BEGIN END +%token REGEX +%token SEMINEW NEWLINE COMMENT +%token FUN1 GRGR +%token PRINT PRINTF SPRINTF SPLIT +%token IF ELSE WHILE FOR IN +%token EXIT NEXT BREAK CONTINUE + +%right ASGNOP +%left OROR +%left ANDAND +%left NOT +%left NUMBER VAR SUBSTR INDEX +%left GETLINE +%nonassoc RELOP MATCHOP +%left OR +%left STRING +%left '+' '-' +%left '*' '/' '%' +%right UMINUS +%left INCR DECR +%left FIELD VFIELD + +%% + +program : junk begin hunks end + { root = oper4(OPROG,$1,$2,$3,$4); } + ; + +begin : BEGIN '{' states '}' junk + { $$ = oper2(OJUNK,$3,$5); in_begin = FALSE; } + | /* NULL */ + { $$ = Nullop; } + ; + +end : END '{' states '}' + { $$ = $3; } + | end NEWLINE + { $$ = $1; } + | /* NULL */ + { $$ = Nullop; } + ; + +hunks : hunks hunk junk + { $$ = oper3(OHUNKS,$1,$2,$3); } + | /* NULL */ + { $$ = Nullop; } + ; + +hunk : patpat + { $$ = oper1(OHUNK,$1); need_entire = TRUE; } + | patpat '{' states '}' + { $$ = oper2(OHUNK,$1,$3); } + | '{' states '}' + { $$ = oper2(OHUNK,Nullop,$2); } + ; + +patpat : pat + { $$ = oper1(OPAT,$1); } + | pat ',' pat + { $$ = oper2(ORANGE,$1,$3); } + ; + +pat : REGEX + { $$ = oper1(OREGEX,$1); } + | match + | rel + | compound_pat + ; + +compound_pat + : '(' compound_pat ')' + { $$ = oper1(OPPAREN,$2); } + | pat ANDAND pat + { $$ = oper2(OPANDAND,$1,$3); } + | pat OROR pat + { $$ = oper2(OPOROR,$1,$3); } + | NOT pat + { $$ = oper1(OPNOT,$2); } + ; + +cond : expr + | match + | rel + | compound_cond + ; + +compound_cond + : '(' compound_cond ')' + { $$ = oper1(OCPAREN,$2); } + | cond ANDAND cond + { $$ = oper2(OCANDAND,$1,$3); } + | cond OROR cond + { $$ = oper2(OCOROR,$1,$3); } + | NOT cond + { $$ = oper1(OCNOT,$2); } + ; + +rel : expr RELOP expr + { $$ = oper3(ORELOP,$2,$1,$3); } + | '(' rel ')' + { $$ = oper1(ORPAREN,$2); } + ; + +match : expr MATCHOP REGEX + { $$ = oper3(OMATCHOP,$2,$1,$3); } + | '(' match ')' + { $$ = oper1(OMPAREN,$2); } + ; + +expr : term + { $$ = $1; } + | expr term + { $$ = oper2(OCONCAT,$1,$2); } + | variable ASGNOP expr + { $$ = oper3(OASSIGN,$2,$1,$3); + if ((ops[$1].ival & 255) == OFLD) + lval_field = TRUE; + if ((ops[$1].ival & 255) == OVFLD) + lval_field = TRUE; + } + ; + +term : variable + { $$ = $1; } + | term '+' term + { $$ = oper2(OADD,$1,$3); } + | term '-' term + { $$ = oper2(OSUB,$1,$3); } + | term '*' term + { $$ = oper2(OMULT,$1,$3); } + | term '/' term + { $$ = oper2(ODIV,$1,$3); } + | term '%' term + { $$ = oper2(OMOD,$1,$3); } + | variable INCR + { $$ = oper1(OPOSTINCR,$1); } + | variable DECR + { $$ = oper1(OPOSTDECR,$1); } + | INCR variable + { $$ = oper1(OPREINCR,$2); } + | DECR variable + { $$ = oper1(OPREDECR,$2); } + | '-' term %prec UMINUS + { $$ = oper1(OUMINUS,$2); } + | '+' term %prec UMINUS + { $$ = oper1(OUPLUS,$2); } + | '(' expr ')' + { $$ = oper1(OPAREN,$2); } + | GETLINE + { $$ = oper0(OGETLINE); } + | FUN1 + { $$ = oper0($1); need_entire = do_chop = TRUE; } + | FUN1 '(' ')' + { $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; } + | FUN1 '(' expr ')' + { $$ = oper1($1,$3); } + | SPRINTF print_list + { $$ = oper1(OSPRINTF,$2); } + | SUBSTR '(' expr ',' expr ',' expr ')' + { $$ = oper3(OSUBSTR,$3,$5,$7); } + | SUBSTR '(' expr ',' expr ')' + { $$ = oper2(OSUBSTR,$3,$5); } + | SPLIT '(' expr ',' VAR ',' expr ')' + { $$ = oper3(OSPLIT,$3,numary($5),$7); } + | SPLIT '(' expr ',' VAR ')' + { $$ = oper2(OSPLIT,$3,numary($5)); } + | INDEX '(' expr ',' expr ')' + { $$ = oper2(OINDEX,$3,$5); } + ; + +variable: NUMBER + { $$ = oper1(ONUM,$1); } + | STRING + { $$ = oper1(OSTR,$1); } + | VAR + { $$ = oper1(OVAR,$1); } + | VAR '[' expr ']' + { $$ = oper2(OVAR,$1,$3); } + | FIELD + { $$ = oper1(OFLD,$1); } + | VFIELD term + { $$ = oper1(OVFLD,$2); } + ; + +maybe : NEWLINE + { $$ = oper0(ONEWLINE); } + | /* NULL */ + { $$ = Nullop; } + | COMMENT + { $$ = oper1(OCOMMENT,$1); } + ; + +print_list + : expr + | clist + | /* NULL */ + { $$ = Nullop; } + ; + +clist : expr ',' expr + { $$ = oper2(OCOMMA,$1,$3); } + | clist ',' expr + { $$ = oper2(OCOMMA,$1,$3); } + | '(' clist ')' /* these parens are invisible */ + { $$ = $2; } + ; + +junk : junk hunksep + { $$ = oper2(OJUNK,$1,$2); } + | /* NULL */ + { $$ = Nullop; } + ; + +hunksep : ';' + { $$ = oper0(OSEMICOLON); } + | SEMINEW + { $$ = oper0(OSEMICOLON); } + | NEWLINE + { $$ = oper0(ONEWLINE); } + | COMMENT + { $$ = oper1(OCOMMENT,$1); } + ; + +separator + : ';' + { $$ = oper0(OSEMICOLON); } + | SEMINEW + { $$ = oper0(OSNEWLINE); } + | NEWLINE + { $$ = oper0(OSNEWLINE); } + | COMMENT + { $$ = oper1(OSCOMMENT,$1); } + ; + +states : states statement + { $$ = oper2(OSTATES,$1,$2); } + | /* NULL */ + { $$ = Nullop; } + ; + +statement + : simple separator + { $$ = oper2(OSTATE,$1,$2); } + | compound + ; + +simple + : expr + | PRINT print_list redir expr + { $$ = oper3(OPRINT,$2,$3,$4); + do_opens = TRUE; + saw_ORS = saw_OFS = TRUE; + if (!$2) need_entire = TRUE; + if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } + | PRINT print_list + { $$ = oper1(OPRINT,$2); + if (!$2) need_entire = TRUE; + saw_ORS = saw_OFS = TRUE; + } + | PRINTF print_list redir expr + { $$ = oper3(OPRINTF,$2,$3,$4); + do_opens = TRUE; + if (!$2) need_entire = TRUE; + if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } + | PRINTF print_list + { $$ = oper1(OPRINTF,$2); + if (!$2) need_entire = TRUE; + } + | BREAK + { $$ = oper0(OBREAK); } + | NEXT + { $$ = oper0(ONEXT); } + | EXIT + { $$ = oper0(OEXIT); } + | EXIT expr + { $$ = oper1(OEXIT,$2); } + | CONTINUE + { $$ = oper0(OCONTINUE); } + | /* NULL */ + { $$ = Nullop; } + ; + +redir : RELOP + { $$ = oper1(OREDIR,string(">",1)); } + | GRGR + { $$ = oper1(OREDIR,string(">>",2)); } + | '|' + { $$ = oper1(OREDIR,string("|",1)); } + ; + +compound + : IF '(' cond ')' maybe statement + { $$ = oper2(OIF,$3,bl($6,$5)); } + | IF '(' cond ')' maybe statement ELSE maybe statement + { $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); } + | WHILE '(' cond ')' maybe statement + { $$ = oper2(OWHILE,$3,bl($6,$5)); } + | FOR '(' simple ';' cond ';' simple ')' maybe statement + { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); } + | FOR '(' simple ';' ';' simple ')' maybe statement + { $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); } + | FOR '(' VAR IN VAR ')' maybe statement + { $$ = oper3(OFORIN,$3,$5,bl($8,$7)); } + | '{' states '}' + { $$ = oper1(OBLOCK,$2); } + ; + +%% +#include "a2py.c" diff --git a/x2p/a2py.c b/x2p/a2py.c new file mode 100644 index 0000000000..8a1ad78b96 --- /dev/null +++ b/x2p/a2py.c @@ -0,0 +1,859 @@ +/* $Header: a2py.c,v 1.0 87/12/18 17:50:33 root Exp $ + * + * $Log: a2py.c,v $ + * Revision 1.0 87/12/18 17:50:33 root + * Initial revision + * + */ + +#include "util.h" +char *index(); + +char *filename; + +main(argc,argv,env) +register int argc; +register char **argv; +register char **env; +{ + register STR *str; + register char *s; + int i; + STR *walk(); + STR *tmpstr; + + linestr = str_new(80); + str = str_new(0); /* first used for -I flags */ + for (argc--,argv++; argc; argc--,argv++) { + if (argv[0][0] != '-' || !argv[0][1]) + break; + reswitch: + switch (argv[0][1]) { +#ifdef DEBUGGING + case 'D': + debug = atoi(argv[0]+2); +#ifdef YYDEBUG + yydebug = (debug & 1); +#endif + break; +#endif + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + maxfld = atoi(argv[0]+1); + absmaxfld = TRUE; + break; + case 'F': + fswitch = argv[0][2]; + break; + case 'n': + namelist = savestr(argv[0]+2); + break; + case '-': + argc--,argv++; + goto switch_end; + case 0: + break; + default: + fatal("Unrecognized switch: %s\n",argv[0]); + } + } + switch_end: + + /* open script */ + + if (argv[0] == Nullch) + argv[0] = "-"; + filename = savestr(argv[0]); + if (strEQ(filename,"-")) + argv[0] = ""; + if (!*argv[0]) + rsfp = stdin; + else + rsfp = fopen(argv[0],"r"); + if (rsfp == Nullfp) + fatal("Awk script \"%s\" doesn't seem to exist.\n",filename); + + /* init tokener */ + + bufptr = str_get(linestr); + symtab = hnew(); + + /* now parse the report spec */ + + if (yyparse()) + fatal("Translation aborted due to syntax errors.\n"); + +#ifdef DEBUGGING + if (debug & 2) { + int type, len; + + for (i=1; i<mop;) { + type = ops[i].ival; + len = type >> 8; + type &= 255; + printf("%d\t%d\t%d\t%-10s",i++,type,len,opname[type]); + if (type == OSTRING) + printf("\t\"%s\"\n",ops[i].cval),i++; + else { + while (len--) { + printf("\t%d",ops[i].ival),i++; + } + putchar('\n'); + } + } + } + if (debug & 8) + dump(root); +#endif + + /* first pass to look for numeric variables */ + + prewalk(0,0,root,&i); + + /* second pass to produce new program */ + + tmpstr = walk(0,0,root,&i); + str = str_make("#!/bin/perl\n\n"); + if (do_opens && opens) { + str_scat(str,opens); + str_free(opens); + str_cat(str,"\n"); + } + str_scat(str,tmpstr); + str_free(tmpstr); +#ifdef DEBUGGING + if (!(debug & 16)) +#endif + fixup(str); + putlines(str); + exit(0); +} + +#define RETURN(retval) return (bufptr = s,retval) +#define XTERM(retval) return (expectterm = TRUE,bufptr = s,retval) +#define XOP(retval) return (expectterm = FALSE,bufptr = s,retval) +#define ID(x) return (yylval=string(x,0),expectterm = FALSE,bufptr = s,VAR) + +yylex() +{ + register char *s = bufptr; + register char *d; + register int tmp; + + retry: +#ifdef YYDEBUG + if (yydebug) + if (index(s,'\n')) + fprintf(stderr,"Tokener at %s",s); + else + fprintf(stderr,"Tokener at %s\n",s); +#endif + switch (*s) { + default: + fprintf(stderr, + "Unrecognized character %c in file %s line %d--ignoring.\n", + *s++,filename,line); + goto retry; + case '\\': + case 0: + s = str_get(linestr); + *s = '\0'; + if (!rsfp) + RETURN(0); + line++; + if ((s = str_gets(linestr, rsfp)) == Nullch) { + if (rsfp != stdin) + fclose(rsfp); + rsfp = Nullfp; + s = str_get(linestr); + RETURN(0); + } + goto retry; + case ' ': case '\t': + s++; + goto retry; + case '\n': + *s = '\0'; + XTERM(NEWLINE); + case '#': + yylval = string(s,0); + *s = '\0'; + XTERM(COMMENT); + case ';': + tmp = *s++; + if (*s == '\n') { + s++; + XTERM(SEMINEW); + } + XTERM(tmp); + case '(': + case '{': + case '[': + case ')': + case ']': + tmp = *s++; + XOP(tmp); + case 127: + s++; + XTERM('}'); + case '}': + for (d = s + 1; isspace(*d); d++) ; + if (!*d) + s = d - 1; + *s = 127; + XTERM(';'); + case ',': + tmp = *s++; + XTERM(tmp); + case '~': + s++; + XTERM(MATCHOP); + case '+': + case '-': + if (s[1] == *s) { + s++; + if (*s++ == '+') + XTERM(INCR); + else + XTERM(DECR); + } + /* FALL THROUGH */ + case '*': + case '%': + tmp = *s++; + if (*s == '=') { + yylval = string(s-1,2); + s++; + XTERM(ASGNOP); + } + XTERM(tmp); + case '&': + s++; + tmp = *s++; + if (tmp == '&') + XTERM(ANDAND); + s--; + XTERM('&'); + case '|': + s++; + tmp = *s++; + if (tmp == '|') + XTERM(OROR); + s--; + XTERM('|'); + case '=': + s++; + tmp = *s++; + if (tmp == '=') { + yylval = string("==",2); + XTERM(RELOP); + } + s--; + yylval = string("=",1); + XTERM(ASGNOP); + case '!': + s++; + tmp = *s++; + if (tmp == '=') { + yylval = string("!=",2); + XTERM(RELOP); + } + if (tmp == '~') { + yylval = string("!~",2); + XTERM(MATCHOP); + } + s--; + XTERM(NOT); + case '<': + s++; + tmp = *s++; + if (tmp == '=') { + yylval = string("<=",2); + XTERM(RELOP); + } + s--; + yylval = string("<",1); + XTERM(RELOP); + case '>': + s++; + tmp = *s++; + if (tmp == '=') { + yylval = string(">=",2); + XTERM(RELOP); + } + s--; + yylval = string(">",1); + XTERM(RELOP); + +#define SNARFWORD \ + d = tokenbuf; \ + while (isalpha(*s) || isdigit(*s) || *s == '_') \ + *d++ = *s++; \ + *d = '\0'; \ + d = tokenbuf; + + case '$': + s++; + if (*s == '0') { + s++; + do_chop = TRUE; + need_entire = TRUE; + ID("0"); + } + do_split = TRUE; + if (isdigit(*s)) { + for (d = s; isdigit(*s); s++) ; + yylval = string(d,s-d); + tmp = atoi(d); + if (tmp > maxfld) + maxfld = tmp; + XOP(FIELD); + } + split_to_array = set_array_base = TRUE; + XOP(VFIELD); + + case '/': /* may either be division or pattern */ + if (expectterm) { + s = scanpat(s); + XTERM(REGEX); + } + tmp = *s++; + if (*s == '=') { + yylval = string("/=",2); + s++; + XTERM(ASGNOP); + } + XTERM(tmp); + + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + s = scannum(s); + XOP(NUMBER); + case '"': + s++; + s = cpy2(tokenbuf,s,s[-1]); + if (!*s) + fatal("String not terminated:\n%s",str_get(linestr)); + s++; + yylval = string(tokenbuf,0); + XOP(STRING); + + case 'a': case 'A': + SNARFWORD; + ID(d); + case 'b': case 'B': + SNARFWORD; + if (strEQ(d,"break")) + XTERM(BREAK); + if (strEQ(d,"BEGIN")) + XTERM(BEGIN); + ID(d); + case 'c': case 'C': + SNARFWORD; + if (strEQ(d,"continue")) + XTERM(CONTINUE); + ID(d); + case 'd': case 'D': + SNARFWORD; + ID(d); + case 'e': case 'E': + SNARFWORD; + if (strEQ(d,"END")) + XTERM(END); + if (strEQ(d,"else")) + XTERM(ELSE); + if (strEQ(d,"exit")) { + saw_line_op = TRUE; + XTERM(EXIT); + } + if (strEQ(d,"exp")) { + yylval = OEXP; + XTERM(FUN1); + } + ID(d); + case 'f': case 'F': + SNARFWORD; + if (strEQ(d,"FS")) { + saw_FS++; + if (saw_FS == 1 && in_begin) { + for (d = s; *d && isspace(*d); d++) ; + if (*d == '=') { + for (d++; *d && isspace(*d); d++) ; + if (*d == '"' && d[2] == '"') + const_FS = d[1]; + } + } + ID(tokenbuf); + } + if (strEQ(d,"FILENAME")) + d = "ARGV"; + if (strEQ(d,"for")) + XTERM(FOR); + ID(d); + case 'g': case 'G': + SNARFWORD; + if (strEQ(d,"getline")) + XTERM(GETLINE); + ID(d); + case 'h': case 'H': + SNARFWORD; + ID(d); + case 'i': case 'I': + SNARFWORD; + if (strEQ(d,"if")) + XTERM(IF); + if (strEQ(d,"in")) + XTERM(IN); + if (strEQ(d,"index")) { + set_array_base = TRUE; + XTERM(INDEX); + } + if (strEQ(d,"int")) { + yylval = OINT; + XTERM(FUN1); + } + ID(d); + case 'j': case 'J': + SNARFWORD; + ID(d); + case 'k': case 'K': + SNARFWORD; + ID(d); + case 'l': case 'L': + SNARFWORD; + if (strEQ(d,"length")) { + yylval = OLENGTH; + XTERM(FUN1); + } + if (strEQ(d,"log")) { + yylval = OLOG; + XTERM(FUN1); + } + ID(d); + case 'm': case 'M': + SNARFWORD; + ID(d); + case 'n': case 'N': + SNARFWORD; + if (strEQ(d,"NF")) + do_split = split_to_array = set_array_base = TRUE; + if (strEQ(d,"next")) { + saw_line_op = TRUE; + XTERM(NEXT); + } + ID(d); + case 'o': case 'O': + SNARFWORD; + if (strEQ(d,"ORS")) { + saw_ORS = TRUE; + d = "$\\"; + } + if (strEQ(d,"OFS")) { + saw_OFS = TRUE; + d = "$,"; + } + if (strEQ(d,"OFMT")) { + d = "$#"; + } + ID(d); + case 'p': case 'P': + SNARFWORD; + if (strEQ(d,"print")) { + XTERM(PRINT); + } + if (strEQ(d,"printf")) { + XTERM(PRINTF); + } + ID(d); + case 'q': case 'Q': + SNARFWORD; + ID(d); + case 'r': case 'R': + SNARFWORD; + if (strEQ(d,"RS")) { + d = "$/"; + saw_RS = TRUE; + } + ID(d); + case 's': case 'S': + SNARFWORD; + if (strEQ(d,"split")) { + set_array_base = TRUE; + XOP(SPLIT); + } + if (strEQ(d,"substr")) { + set_array_base = TRUE; + XTERM(SUBSTR); + } + if (strEQ(d,"sprintf")) + XTERM(SPRINTF); + if (strEQ(d,"sqrt")) { + yylval = OSQRT; + XTERM(FUN1); + } + ID(d); + case 't': case 'T': + SNARFWORD; + ID(d); + case 'u': case 'U': + SNARFWORD; + ID(d); + case 'v': case 'V': + SNARFWORD; + ID(d); + case 'w': case 'W': + SNARFWORD; + if (strEQ(d,"while")) + XTERM(WHILE); + ID(d); + case 'x': case 'X': + SNARFWORD; + ID(d); + case 'y': case 'Y': + SNARFWORD; + ID(d); + case 'z': case 'Z': + SNARFWORD; + ID(d); + } +} + +char * +scanpat(s) +register char *s; +{ + register char *d; + + switch (*s++) { + case '/': + break; + default: + fatal("Search pattern not found:\n%s",str_get(linestr)); + } + s = cpytill(tokenbuf,s,s[-1]); + if (!*s) + fatal("Search pattern not terminated:\n%s",str_get(linestr)); + s++; + yylval = string(tokenbuf,0); + return s; +} + +yyerror(s) +char *s; +{ + fprintf(stderr,"%s in file %s at line %d\n", + s,filename,line); +} + +char * +scannum(s) +register char *s; +{ + register char *d; + + switch (*s) { + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': case '0' : case '.': + d = tokenbuf; + while (isdigit(*s) || *s == '_') + *d++ = *s++; + if (*s == '.' && index("0123456789eE",s[1])) + *d++ = *s++; + while (isdigit(*s) || *s == '_') + *d++ = *s++; + if (index("eE",*s) && index("+-0123456789",s[1])) + *d++ = *s++; + if (*s == '+' || *s == '-') + *d++ = *s++; + while (isdigit(*s)) + *d++ = *s++; + *d = '\0'; + yylval = string(tokenbuf,0); + break; + } + return s; +} + +string(ptr,len) +char *ptr; +{ + int retval = mop; + + ops[mop++].ival = OSTRING + (1<<8); + if (!len) + len = strlen(ptr); + ops[mop].cval = safemalloc(len+1); + strncpy(ops[mop].cval,ptr,len); + ops[mop++].cval[len] = '\0'; + return retval; +} + +oper0(type) +int type; +{ + int retval = mop; + + if (type > 255) + fatal("type > 255 (%d)\n",type); + ops[mop++].ival = type; + return retval; +} + +oper1(type,arg1) +int type; +int arg1; +{ + int retval = mop; + + if (type > 255) + fatal("type > 255 (%d)\n",type); + ops[mop++].ival = type + (1<<8); + ops[mop++].ival = arg1; + return retval; +} + +oper2(type,arg1,arg2) +int type; +int arg1; +int arg2; +{ + int retval = mop; + + if (type > 255) + fatal("type > 255 (%d)\n",type); + ops[mop++].ival = type + (2<<8); + ops[mop++].ival = arg1; + ops[mop++].ival = arg2; + return retval; +} + +oper3(type,arg1,arg2,arg3) +int type; +int arg1; +int arg2; +int arg3; +{ + int retval = mop; + + if (type > 255) + fatal("type > 255 (%d)\n",type); + ops[mop++].ival = type + (3<<8); + ops[mop++].ival = arg1; + ops[mop++].ival = arg2; + ops[mop++].ival = arg3; + return retval; +} + +oper4(type,arg1,arg2,arg3,arg4) +int type; +int arg1; +int arg2; +int arg3; +int arg4; +{ + int retval = mop; + + if (type > 255) + fatal("type > 255 (%d)\n",type); + ops[mop++].ival = type + (4<<8); + ops[mop++].ival = arg1; + ops[mop++].ival = arg2; + ops[mop++].ival = arg3; + ops[mop++].ival = arg4; + return retval; +} + +oper5(type,arg1,arg2,arg3,arg4,arg5) +int type; +int arg1; +int arg2; +int arg3; +int arg4; +int arg5; +{ + int retval = mop; + + if (type > 255) + fatal("type > 255 (%d)\n",type); + ops[mop++].ival = type + (5<<8); + ops[mop++].ival = arg1; + ops[mop++].ival = arg2; + ops[mop++].ival = arg3; + ops[mop++].ival = arg4; + ops[mop++].ival = arg5; + return retval; +} + +int depth = 0; + +dump(branch) +int branch; +{ + register int type; + register int len; + register int i; + + type = ops[branch].ival; + len = type >> 8; + type &= 255; + for (i=depth; i; i--) + printf(" "); + if (type == OSTRING) { + printf("%-5d\"%s\"\n",branch,ops[branch+1].cval); + } + else { + printf("(%-5d%s %d\n",branch,opname[type],len); + depth++; + for (i=1; i<=len; i++) + dump(ops[branch+i].ival); + depth--; + for (i=depth; i; i--) + printf(" "); + printf(")\n"); + } +} + +bl(arg,maybe) +int arg; +int maybe; +{ + if (!arg) + return 0; + else if ((ops[arg].ival & 255) != OBLOCK) + return oper2(OBLOCK,arg,maybe); + else if ((ops[arg].ival >> 8) != 2) + return oper2(OBLOCK,ops[arg+1].ival,maybe); + else + return arg; +} + +fixup(str) +STR *str; +{ + register char *s; + register char *t; + + for (s = str->str_ptr; *s; s++) { + if (*s == ';' && s[1] == ' ' && s[2] == '\n') { + strcpy(s+1,s+2); + s++; + } + else if (*s == '\n') { + for (t = s+1; isspace(*t & 127); t++) ; + t--; + while (isspace(*t & 127) && *t != '\n') t--; + if (*t == '\n' && t-s > 1) { + if (s[-1] == '{') + s--; + strcpy(s+1,t); + } + s++; + } + } +} + +putlines(str) +STR *str; +{ + register char *d, *s, *t, *e; + register int pos, newpos; + + d = tokenbuf; + pos = 0; + for (s = str->str_ptr; *s; s++) { + *d++ = *s; + pos++; + if (*s == '\n') { + *d = '\0'; + d = tokenbuf; + pos = 0; + putone(); + } + else if (*s == '\t') + pos += 7; + if (pos > 78) { /* split a long line? */ + *d-- = '\0'; + newpos = 0; + for (t = tokenbuf; isspace(*t & 127); t++) { + if (*t == '\t') + newpos += 8; + else + newpos += 1; + } + e = d; + while (d > tokenbuf && (*d != ' ' || d[-1] != ';')) + d--; + if (d < t+10) { + d = e; + while (d > tokenbuf && + (*d != ' ' || d[-1] != '|' || d[-2] != '|') ) + d--; + } + if (d < t+10) { + d = e; + while (d > tokenbuf && + (*d != ' ' || d[-1] != '&' || d[-2] != '&') ) + d--; + } + if (d < t+10) { + d = e; + while (d > tokenbuf && (*d != ' ' || d[-1] != ',')) + d--; + } + if (d < t+10) { + d = e; + while (d > tokenbuf && *d != ' ') + d--; + } + if (d > t+3) { + *d = '\0'; + putone(); + putchar('\n'); + if (d[-1] != ';' && !(newpos % 4)) { + *t++ = ' '; + *t++ = ' '; + newpos += 2; + } + strcpy(t,d+1); + newpos += strlen(t); + d = t + strlen(t); + pos = newpos; + } + else + d = e + 1; + } + } +} + +putone() +{ + register char *t; + + for (t = tokenbuf; *t; t++) { + *t &= 127; + if (*t == 127) { + *t = ' '; + strcpy(t+strlen(t)-1, "\t#???\n"); + } + } + t = tokenbuf; + if (*t == '#') { + if (strnEQ(t,"#!/bin/awk",10) || strnEQ(t,"#! /bin/awk",11)) + return; + } + fputs(tokenbuf,stdout); +} + +numary(arg) +int arg; +{ + STR *key; + int dummy; + + key = walk(0,0,arg,&dummy); + str_cat(key,"[]"); + hstore(symtab,key->str_ptr,str_make("1")); + str_free(key); + set_array_base = TRUE; + return arg; +} diff --git a/x2p/handy.h b/x2p/handy.h new file mode 100644 index 0000000000..441bb4350c --- /dev/null +++ b/x2p/handy.h @@ -0,0 +1,26 @@ +/* $Header: handy.h,v 1.0 87/12/18 13:07:15 root Exp $ + * + * $Log: handy.h,v $ + * Revision 1.0 87/12/18 13:07:15 root + * Initial revision + * + */ + +#define Null(type) ((type)0) +#define Nullch Null(char*) +#define Nullfp Null(FILE*) + +#define bool char +#define TRUE (1) +#define FALSE (0) + +#define Ctl(ch) (ch & 037) + +#define strNE(s1,s2) (strcmp(s1,s2)) +#define strEQ(s1,s2) (!strcmp(s1,s2)) +#define strLT(s1,s2) (strcmp(s1,s2) < 0) +#define strLE(s1,s2) (strcmp(s1,s2) <= 0) +#define strGT(s1,s2) (strcmp(s1,s2) > 0) +#define strGE(s1,s2) (strcmp(s1,s2) >= 0) +#define strnNE(s1,s2,l) (strncmp(s1,s2,l)) +#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l)) diff --git a/x2p/hash.c b/x2p/hash.c new file mode 100644 index 0000000000..db32c4c5fe --- /dev/null +++ b/x2p/hash.c @@ -0,0 +1,237 @@ +/* $Header: hash.c,v 1.0 87/12/18 13:07:18 root Exp $ + * + * $Log: hash.c,v $ + * Revision 1.0 87/12/18 13:07:18 root + * Initial revision + * + */ + +#include <stdio.h> +#include "EXTERN.h" +#include "handy.h" +#include "util.h" +#include "a2p.h" + +STR * +hfetch(tb,key) +register HASH *tb; +char *key; +{ + register char *s; + register int i; + register int hash; + register HENT *entry; + + if (!tb) + return Nullstr; + for (s=key, i=0, hash = 0; + /* while */ *s; + s++, i++, hash *= 5) { + hash += *s * coeff[i]; + } + entry = tb->tbl_array[hash & tb->tbl_max]; + for (; entry; entry = entry->hent_next) { + if (entry->hent_hash != hash) /* strings can't be equal */ + continue; + if (strNE(entry->hent_key,key)) /* is this it? */ + continue; + return entry->hent_val; + } + return Nullstr; +} + +bool +hstore(tb,key,val) +register HASH *tb; +char *key; +STR *val; +{ + register char *s; + register int i; + register int hash; + register HENT *entry; + register HENT **oentry; + + if (!tb) + return FALSE; + for (s=key, i=0, hash = 0; + /* while */ *s; + s++, i++, hash *= 5) { + hash += *s * coeff[i]; + } + + oentry = &(tb->tbl_array[hash & tb->tbl_max]); + i = 1; + + for (entry = *oentry; entry; i=0, entry = entry->hent_next) { + if (entry->hent_hash != hash) /* strings can't be equal */ + continue; + if (strNE(entry->hent_key,key)) /* is this it? */ + continue; + safefree((char*)entry->hent_val); + entry->hent_val = val; + return TRUE; + } + entry = (HENT*) safemalloc(sizeof(HENT)); + + entry->hent_key = savestr(key); + entry->hent_val = val; + entry->hent_hash = hash; + entry->hent_next = *oentry; + *oentry = entry; + + if (i) { /* initial entry? */ + tb->tbl_fill++; + if ((tb->tbl_fill * 100 / (tb->tbl_max + 1)) > FILLPCT) + hsplit(tb); + } + + return FALSE; +} + +#ifdef NOTUSED +bool +hdelete(tb,key) +register HASH *tb; +char *key; +{ + register char *s; + register int i; + register int hash; + register HENT *entry; + register HENT **oentry; + + if (!tb) + return FALSE; + for (s=key, i=0, hash = 0; + /* while */ *s; + s++, i++, hash *= 5) { + hash += *s * coeff[i]; + } + + oentry = &(tb->tbl_array[hash & tb->tbl_max]); + entry = *oentry; + i = 1; + for (; entry; i=0, oentry = &entry->hent_next, entry = entry->hent_next) { + if (entry->hent_hash != hash) /* strings can't be equal */ + continue; + if (strNE(entry->hent_key,key)) /* is this it? */ + continue; + safefree((char*)entry->hent_val); + safefree(entry->hent_key); + *oentry = entry->hent_next; + safefree((char*)entry); + if (i) + tb->tbl_fill--; + return TRUE; + } + return FALSE; +} +#endif + +hsplit(tb) +HASH *tb; +{ + int oldsize = tb->tbl_max + 1; + register int newsize = oldsize * 2; + register int i; + register HENT **a; + register HENT **b; + register HENT *entry; + register HENT **oentry; + + a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*)); + bzero((char*)&a[oldsize], oldsize * sizeof(HENT*)); /* zero second half */ + tb->tbl_max = --newsize; + tb->tbl_array = a; + + for (i=0; i<oldsize; i++,a++) { + if (!*a) /* non-existent */ + continue; + b = a+oldsize; + for (oentry = a, entry = *a; entry; entry = *oentry) { + if ((entry->hent_hash & newsize) != i) { + *oentry = entry->hent_next; + entry->hent_next = *b; + if (!*b) + tb->tbl_fill++; + *b = entry; + continue; + } + else + oentry = &entry->hent_next; + } + if (!*a) /* everything moved */ + tb->tbl_fill--; + } +} + +HASH * +hnew() +{ + register HASH *tb = (HASH*)safemalloc(sizeof(HASH)); + + tb->tbl_array = (HENT**) safemalloc(8 * sizeof(HENT*)); + tb->tbl_fill = 0; + tb->tbl_max = 7; + hiterinit(tb); /* so each() will start off right */ + bzero((char*)tb->tbl_array, 8 * sizeof(HENT*)); + return tb; +} + +#ifdef NOTUSED +hshow(tb) +register HASH *tb; +{ + fprintf(stderr,"%5d %4d (%2d%%)\n", + tb->tbl_max+1, + tb->tbl_fill, + tb->tbl_fill * 100 / (tb->tbl_max+1)); +} +#endif + +hiterinit(tb) +register HASH *tb; +{ + tb->tbl_riter = -1; + tb->tbl_eiter = Null(HENT*); + return tb->tbl_fill; +} + +HENT * +hiternext(tb) +register HASH *tb; +{ + register HENT *entry; + + entry = tb->tbl_eiter; + do { + if (entry) + entry = entry->hent_next; + if (!entry) { + tb->tbl_riter++; + if (tb->tbl_riter > tb->tbl_max) { + tb->tbl_riter = -1; + break; + } + entry = tb->tbl_array[tb->tbl_riter]; + } + } while (!entry); + + tb->tbl_eiter = entry; + return entry; +} + +char * +hiterkey(entry) +register HENT *entry; +{ + return entry->hent_key; +} + +STR * +hiterval(entry) +register HENT *entry; +{ + return entry->hent_val; +} diff --git a/x2p/hash.h b/x2p/hash.h new file mode 100644 index 0000000000..06d803a12d --- /dev/null +++ b/x2p/hash.h @@ -0,0 +1,49 @@ +/* $Header: hash.h,v 1.0 87/12/18 13:07:23 root Exp $ + * + * $Log: hash.h,v $ + * Revision 1.0 87/12/18 13:07:23 root + * Initial revision + * + */ + +#define FILLPCT 60 /* don't make greater than 99 */ + +#ifdef DOINIT +char coeff[] = { + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1}; +#else +extern char coeff[]; +#endif + +typedef struct hentry HENT; + +struct hentry { + HENT *hent_next; + char *hent_key; + STR *hent_val; + int hent_hash; +}; + +struct htbl { + HENT **tbl_array; + int tbl_max; + int tbl_fill; + int tbl_riter; /* current root of iterator */ + HENT *tbl_eiter; /* current entry of iterator */ +}; + +STR *hfetch(); +bool hstore(); +bool hdelete(); +HASH *hnew(); +int hiterinit(); +HENT *hiternext(); +char *hiterkey(); +STR *hiterval(); diff --git a/x2p/s2p b/x2p/s2p new file mode 100644 index 0000000000..6c50cd2a11 --- /dev/null +++ b/x2p/s2p @@ -0,0 +1,551 @@ +#!/bin/perl + +$indent = 4; +$shiftwidth = 4; +$l = '{'; $r = '}'; +$tempvar = '1'; + +while ($ARGV[0] =~ '^-') { + $_ = shift; + last if /^--/; + if (/^-D/) { + $debug++; + open(body,'>-'); + next; + } + if (/^-n/) { + $assumen++; + next; + } + if (/^-p/) { + $assumep++; + next; + } + die "I don't recognize this switch: $_"; +} + +unless ($debug) { + open(body,">/tmp/sperl$$") || do Die("Can't open temp file."); +} + +if (!$assumen && !$assumep) { + print body +'while ($ARGV[0] =~ /^-/) { + $_ = shift; + last if /^--/; + if (/^-n/) { + $nflag++; + next; + } + die "I don\'t recognize this switch: $_"; +} + +'; +} + +print body ' +#ifdef PRINTIT +#ifdef ASSUMEP +$printit++; +#else +$printit++ unless $nflag; +#endif +#endif +line: while (<>) { +'; + +line: while (<>) { + s/[ \t]*(.*)\n$/$1/; + if (/^:/) { + s/^:[ \t]*//; + $label = do make_label($_); + if ($. == 1) { + $toplabel = $label; + } + $_ = "$label:"; + if ($lastlinewaslabel++) {$_ .= "\t;";} + if ($indent >= 2) { + $indent -= 2; + $indmod = 2; + } + next; + } else { + $lastlinewaslabel = ''; + } + $addr1 = ''; + $addr2 = ''; + if (s/^([0-9]+)//) { + $addr1 = "$1"; + } + elsif (s/^\$//) { + $addr1 = 'eof()'; + } + elsif (s|^/||) { + $addr1 = '/'; + delim: while (s:^([^(|)\\/]*)([(|)\\/])::) { + $prefix = $1; + $delim = $2; + if ($delim eq '\\') { + s/(.)(.*)/$2/; + $ch = $1; + $delim = '' if index("(|)",$ch) >= 0; + $delim .= $1; + } + elsif ($delim ne '/') { + $delim = '\\' . $delim; + } + $addr1 .= $prefix; + $addr1 .= $delim; + if ($delim eq '/') { + last delim; + } + } + } + if (s/^,//) { + if (s/^([0-9]+)//) { + $addr2 = "$1"; + } elsif (s/^\$//) { + $addr2 = "eof()"; + } elsif (s|^/||) { + $addr2 = '/'; + delim: while (s:^([^(|)\\/]*)([(|)\\/])::) { + $prefix = $1; + $delim = $2; + if ($delim eq '\\') { + s/(.)(.*)/$2/; + $ch = $1; + $delim = '' if index("(|)",$ch) >= 0; + $delim .= $1; + } + elsif ($delim ne '/') { + $delim = '\\' . $delim; + } + $addr2 .= $prefix; + $addr2 .= $delim; + if ($delim eq '/') { + last delim; + } + } + } else { + do Die("Invalid second address at line $.: $_"); + } + $addr1 .= " .. $addr2"; + } + # a { to keep vi happy + if ($_ eq '}') { + $indent -= 4; + next; + } + if (s/^!//) { + $if = 'unless'; + $else = "$r else $l\n"; + } else { + $if = 'if'; + $else = ''; + } + if (s/^{//) { # a } to keep vi happy + $indmod = 4; + $redo = $_; + $_ = ''; + $rmaybe = ''; + } else { + $rmaybe = "\n$r"; + if ($addr2 || $addr1) { + $space = substr(' ',0,$shiftwidth); + } else { + $space = ''; + } + $_ = do transmogrify(); + } + + if ($addr1) { + if ($_ !~ /[\n{}]/ && $rmaybe && !$change && + $_ !~ / if / && $_ !~ / unless /) { + s/;$/ $if $addr1;/; + $_ = substr($_,$shiftwidth,1000); + } else { + $command = $_; + $_ = "$if ($addr1) $l\n$change$command$rmaybe"; + } + $change = ''; + next line; + } +} continue { + @lines = split(/\n/,$_); + while ($#lines >= 0) { + $_ = shift(lines); + unless (s/^ *<<--//) { + print body substr("\t\t\t\t\t\t\t\t\t\t\t\t",0,$indent / 8), + substr(' ',0,$indent % 8); + } + print body $_, "\n"; + } + $indent += $indmod; + $indmod = 0; + if ($redo) { + $_ = $redo; + $redo = ''; + redo line; + } +} + +print body "}\n"; +if ($appendseen || $tseen || !$assumen) { + $printit++ if $dseen || (!$assumen && !$assumep); + print body ' +continue { +#ifdef PRINTIT +#ifdef DSEEN +#ifdef ASSUMEP + print if $printit++; +#else + if ($printit) { print;} else { $printit++ unless $nflag; } +#endif +#else + print if $printit; +#endif +#else + print; +#endif +#ifdef TSEEN + $tflag = \'\'; +#endif +#ifdef APPENDSEEN + if ($atext) { print $atext; $atext = \'\'; } +#endif +} +'; +} + +close body; + +unless ($debug) { + open(head,">/tmp/sperl2$$") || do Die("Can't open temp file 2.\n"); + print head "#define PRINTIT\n" if ($printit); + print head "#define APPENDSEEN\n" if ($appendseen); + print head "#define TSEEN\n" if ($tseen); + print head "#define DSEEN\n" if ($dseen); + print head "#define ASSUMEN\n" if ($assumen); + print head "#define ASSUMEP\n" if ($assumep); + if ($opens) {print head "$opens\n";} + open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file."); + while (<body>) { + print head $_; + } + close head; + + print "#!/bin/perl\n\n"; + open(body,"cc -E /tmp/sperl2$$ |") || + do Die("Can't reopen temp file."); + while (<body>) { + /^# [0-9]/ && next; + /^[ \t]*$/ && next; + s/^<><>//; + print; + } +} + +`/bin/rm -f /tmp/sperl$$ /tmp/sperl2$$`; + +sub Die { + `/bin/rm -f /tmp/sperl$$ /tmp/sperl2$$`; + die $_[0]; +} +sub make_filehandle { + $fname = $_ = $_[0]; + s/[^a-zA-Z]/_/g; + s/^_*//; + if (/^([a-z])([a-z]*)$/) { + $first = $1; + $rest = $2; + $first =~ y/a-z/A-Z/; + $_ = $first . $rest; + } + if (!$seen{$_}) { + $opens .= "open($_,'>$fname') || die \"Can't create $fname.\";\n"; + } + $seen{$_} = $_; +} + +sub make_label { + $label = $_[0]; + $label =~ s/[^a-zA-Z0-9]/_/g; + if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } + $label = substr($label,0,8); + if ($label =~ /^([a-z])([a-z]*)$/) { + $first = $1; + $rest = $2; + $first =~ y/a-z/A-Z/; + $label = $first . $rest; + } + $label; +} + +sub transmogrify { + { # case + if (/^d/) { + $dseen++; + $_ = ' +<<--#ifdef PRINTIT +$printit = \'\'; +<<--#endif +next line;'; + next; + } + + if (/^n/) { + $_ = +'<<--#ifdef PRINTIT +<<--#ifdef DSEEN +<<--#ifdef ASSUMEP +print if $printit++; +<<--#else +if ($printit) { print;} else { $printit++ unless $nflag; } +<<--#endif +<<--#else +print if $printit; +<<--#endif +<<--#else +print; +<<--#endif +<<--#ifdef APPENDSEEN +if ($atext) {print $atext; $atext = \'\';} +<<--#endif +$_ = <>; +<<--#ifdef TSEEN +$tflag = \'\'; +<<--#endif'; + next; + } + + if (/^a/) { + $appendseen++; + $command = $space . '$atext .=' . "\n<<--'"; + $lastline = 0; + while (<>) { + s/^[ \t]*//; + s/^[\\]//; + unless (s|\\$||) { $lastline = 1;} + s/'/\\'/g; + s/^([ \t]*\n)/<><>$1/; + $command .= $_; + $command .= '<<--'; + last if $lastline; + } + $_ = $command . "';"; + last; + } + + if (/^[ic]/) { + if (/^c/) { $change = 1; } + $addr1 = '$iter = (' . $addr1 . ')'; + $command = $space . 'if ($iter == 1) { print' . "\n<<--'"; + $lastline = 0; + while (<>) { + s/^[ \t]*//; + s/^[\\]//; + unless (s/\\$//) { $lastline = 1;} + s/'/\\'/g; + s/^([ \t]*\n)/<><>$1/; + $command .= $_; + $command .= '<<--'; + last if $lastline; + } + $_ = $command . "';}"; + if ($change) { + $dseen++; + $change = "$_\n"; + $_ = " +<<--#ifdef PRINTIT +$space\$printit = ''; +<<--#endif +${space}next line;"; + } + last; + } + + if (/^s/) { + $delim = substr($_,1,1); + $len = length($_); + $repl = $end = 0; + for ($i = 2; $i < $len; $i++) { + $c = substr($_,$i,1); + if ($c eq '\\') { + $i++; + if ($i >= $len) { + $_ .= 'n'; + $_ .= <>; + $len = length($_); + $_ = substr($_,0,--$len); + } + elsif (!$repl && index("(|)",substr($_,$i,1)) >= 0) { + $i--; + $len--; + $_ = substr($_,0,$i) . substr($_,$i+1,10000); + } + } + elsif ($c eq $delim) { + if ($repl) { + $end = $i; + last; + } else { + $repl = $i; + } + } + elsif (!$repl && index("(|)",$c) >= 0) { + $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000); + $i++; + $len++; + } + } + print "repl $repl end $end $_\n"; + do Die("Malformed substitution at line $.") unless $end; + $pat = substr($_, 0, $repl + 1); + $repl = substr($_, $repl + 1, $end - $repl - 1); + $end = substr($_, $end + 1, 1000); + $dol = '$'; + $repl =~ s'&'$&'g; + $repl =~ s/[\\]([0-9])/$dol$1/g; + $subst = "$pat$repl$delim"; + $cmd = ''; + while ($end) { + if ($end =~ s/^g//) { $subst .= 'g'; next; } + if ($end =~ s/^p//) { $cmd .= ' && (print)'; next; } + if ($end =~ s/^w[ \t]*//) { + $fh = do make_filehandle($end); + $cmd .= " && (print $fh \$_)"; + $end = ''; + next; + } + do Die("Unrecognized substitution command ($end) at line $."); + } + $_ = $subst . $cmd . ';'; + next; + } + + if (/^p/) { + $_ = 'print;'; + next; + } + + if (/^w/) { + s/^w[ \t]*//; + $fh = do make_filehandle($_); + $_ = "print $fh \$_;"; + next; + } + + if (/^r/) { + $appendseen++; + s/^r[ \t]*//; + $file = $_; + $_ = "\$atext .= `cat $file 2>/dev/null`;"; + next; + } + + if (/^P/) { + $_ = +'if (/(^[^\n]*\n)/) { + print $1; +}'; + next; + } + + if (/^D/) { + $_ = +'s/^[^\n]*\n//; +if ($_) {redo line;} +next line;'; + next; + } + + if (/^N/) { + $_ = ' +$_ .= <>; +<<--#ifdef TSEEN +$tflag = \'\'; +<<--#endif'; + next; + } + + if (/^h/) { + $_ = '$hold = $_;'; + next; + } + + if (/^H/) { + $_ = '$hold .= $_ ? $_ : "\n";'; + next; + } + + if (/^g/) { + $_ = '$_ = $hold;'; + next; + } + + if (/^G/) { + $_ = '$_ .= $hold ? $hold : "\n";'; + next; + } + + if (/^x/) { + $_ = '($_, $hold) = ($hold, $_);'; + next; + } + + if (/^b$/) { + $_ = 'next line;'; + next; + } + + if (/^b/) { + s/^b[ \t]*//; + $lab = do make_label($_); + if ($lab eq $toplabel) { + $_ = 'redo line;'; + } else { + $_ = "goto $lab;"; + } + next; + } + + if (/^t$/) { + $_ = 'next line if $tflag;'; + $tseen++; + next; + } + + if (/^t/) { + s/^t[ \t]*//; + $lab = do make_label($_); + if ($lab eq $toplabel) { + $_ = 'if ($tflag) {$tflag = \'\'; redo line;}'; + } else { + $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}"; + } + $tseen++; + next; + } + + if (/^=/) { + $_ = 'print "$.\n";'; + next; + } + + if (/^q/) { + $_ = +'close(ARGV); +@ARGV = (); +next line;'; + next; + } + } continue { + if ($space) { + s/^/$space/; + s/(\n)(.)/$1$space$2/g; + } + last; + } + $_; +} + diff --git a/x2p/s2p.man b/x2p/s2p.man new file mode 100644 index 0000000000..6db8a8e7aa --- /dev/null +++ b/x2p/s2p.man @@ -0,0 +1,94 @@ +.rn '' }` +''' $Header: s2p.man,v 1.0 87/12/18 17:37:16 root Exp $ +''' +''' $Log: s2p.man,v $ +''' Revision 1.0 87/12/18 17:37:16 root +''' Initial revision +''' +''' +.de Sh +.br +.ne 5 +.PP +\fB\\$1\fR +.PP +.. +.de Sp +.if t .sp .5v +.if n .sp +.. +.de Ip +.br +.ie \\n.$>=3 .ne \\$3 +.el .ne 3 +.IP "\\$1" \\$2 +.. +''' +''' Set up \*(-- to give an unbreakable dash; +''' string Tr holds user defined translation string. +''' Bell System Logo is used as a dummy character. +''' +.tr \(bs-|\(bv\*(Tr +.ie n \{\ +.ds -- \(bs- +.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch +.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\h'-8u'-\" diablo 12 pitch +.ds L" "" +.ds R" "" +.ds L' ' +.ds R' ' +'br\} +.el\{\ +.ds -- \(em\| +.tr \*(Tr +.ds L" `` +.ds R" '' +.ds L' ` +.ds R' ' +'br\} +.TH S2P 1 NEW +.SH NAME +s2p - Sed to Perl translator +.SH SYNOPSIS +.B s2p [options] filename +.SH DESCRIPTION +.I S2p +takes a sed script specified on the command line (or from standard input) +and produces a comparable +.I perl +script on the standard output. +.Sh "Options" +Options include: +.TP 5 +.B \-D<number> +sets debugging flags. +.TP 5 +.B \-n +specifies that this sed script was always invoked with a sed -n. +Otherwise a switch parser is prepended to the front of the script. +.TP 5 +.B \-p +specifies that this sed script was never invoked with a sed -n. +Otherwise a switch parser is prepended to the front of the script. +.Sh "Considerations" +The perl script produced looks very sed-ish, and there may very well be +better ways to express what you want to do in perl. +For instance, s2p does not make any use of the split operator, but you might +want to. +.PP +The perl script you end up with may be either faster or slower than the original +sed script. +If you're only interested in speed you'll just have to try it both ways. +Of course, if you want to do something sed doesn't do, you have no choice. +.SH ENVIRONMENT +S2p uses no environment variables. +.SH AUTHOR +Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov> +.SH FILES +.SH SEE ALSO +perl The perl compiler/interpreter +.br +a2p awk to perl translator +.SH DIAGNOSTICS +.SH BUGS +.rn }` '' diff --git a/x2p/str.c b/x2p/str.c new file mode 100644 index 0000000000..5de045a3be --- /dev/null +++ b/x2p/str.c @@ -0,0 +1,451 @@ +/* $Header: str.c,v 1.0 87/12/18 13:07:26 root Exp $ + * + * $Log: str.c,v $ + * Revision 1.0 87/12/18 13:07:26 root + * Initial revision + * + */ + +#include "handy.h" +#include "EXTERN.h" +#include "util.h" +#include "a2p.h" + +str_numset(str,num) +register STR *str; +double num; +{ + str->str_nval = num; + str->str_pok = 0; /* invalidate pointer */ + str->str_nok = 1; /* validate number */ +} + +char * +str_2ptr(str) +register STR *str; +{ + register char *s; + + if (!str) + return ""; + GROWSTR(&(str->str_ptr), &(str->str_len), 24); + s = str->str_ptr; + if (str->str_nok) { + sprintf(s,"%.20g",str->str_nval); + while (*s) s++; + } + *s = '\0'; + str->str_cur = s - str->str_ptr; + str->str_pok = 1; +#ifdef DEBUGGING + if (debug & 32) + fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr); +#endif + return str->str_ptr; +} + +double +str_2num(str) +register STR *str; +{ + if (!str) + return 0.0; + if (str->str_len && str->str_pok) + str->str_nval = atof(str->str_ptr); + else + str->str_nval = 0.0; + str->str_nok = 1; +#ifdef DEBUGGING + if (debug & 32) + fprintf(stderr,"0x%lx num(%g)\n",str,str->str_nval); +#endif + return str->str_nval; +} + +str_sset(dstr,sstr) +STR *dstr; +register STR *sstr; +{ + if (!sstr) + str_nset(dstr,No,0); + else if (sstr->str_nok) + str_numset(dstr,sstr->str_nval); + else if (sstr->str_pok) + str_nset(dstr,sstr->str_ptr,sstr->str_cur); + else + str_nset(dstr,"",0); +} + +str_nset(str,ptr,len) +register STR *str; +register char *ptr; +register int len; +{ + GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); + bcopy(ptr,str->str_ptr,len); + str->str_cur = len; + *(str->str_ptr+str->str_cur) = '\0'; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +str_set(str,ptr) +register STR *str; +register char *ptr; +{ + register int len; + + if (!ptr) + ptr = ""; + len = strlen(ptr); + GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); + bcopy(ptr,str->str_ptr,len+1); + str->str_cur = len; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +str_chop(str,ptr) /* like set but assuming ptr is in str */ +register STR *str; +register char *ptr; +{ + if (!(str->str_pok)) + str_2ptr(str); + str->str_cur -= (ptr - str->str_ptr); + bcopy(ptr,str->str_ptr, str->str_cur + 1); + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +str_ncat(str,ptr,len) +register STR *str; +register char *ptr; +register int len; +{ + if (!(str->str_pok)) + str_2ptr(str); + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); + bcopy(ptr,str->str_ptr+str->str_cur,len); + str->str_cur += len; + *(str->str_ptr+str->str_cur) = '\0'; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +str_scat(dstr,sstr) +STR *dstr; +register STR *sstr; +{ + if (!(sstr->str_pok)) + str_2ptr(sstr); + if (sstr) + str_ncat(dstr,sstr->str_ptr,sstr->str_cur); +} + +str_cat(str,ptr) +register STR *str; +register char *ptr; +{ + register int len; + + if (!ptr) + return; + if (!(str->str_pok)) + str_2ptr(str); + len = strlen(ptr); + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); + bcopy(ptr,str->str_ptr+str->str_cur,len+1); + str->str_cur += len; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +} + +char * +str_append_till(str,from,delim,keeplist) +register STR *str; +register char *from; +register int delim; +char *keeplist; +{ + register char *to; + register int len; + + if (!from) + return Nullch; + len = strlen(from); + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ + to = str->str_ptr+str->str_cur; + for (; *from; from++,to++) { + if (*from == '\\' && from[1] && delim != '\\') { + if (!keeplist) { + if (from[1] == delim || from[1] == '\\') + from++; + else + *to++ = *from++; + } + else if (index(keeplist,from[1])) + *to++ = *from++; + else + from++; + } + else if (*from == delim) + break; + *to = *from; + } + *to = '\0'; + str->str_cur = to - str->str_ptr; + return from; +} + +STR * +str_new(len) +int len; +{ + register STR *str; + + if (freestrroot) { + str = freestrroot; + freestrroot = str->str_link.str_next; + } + else { + str = (STR *) safemalloc(sizeof(STR)); + bzero((char*)str,sizeof(STR)); + } + if (len) + GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); + return str; +} + +void +str_grow(str,len) +register STR *str; +int len; +{ + if (len && str) + GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); +} + +/* make str point to what nstr did */ + +void +str_replace(str,nstr) +register STR *str; +register STR *nstr; +{ + safefree(str->str_ptr); + str->str_ptr = nstr->str_ptr; + str->str_len = nstr->str_len; + str->str_cur = nstr->str_cur; + str->str_pok = nstr->str_pok; + if (str->str_nok = nstr->str_nok) + str->str_nval = nstr->str_nval; + safefree((char*)nstr); +} + +void +str_free(str) +register STR *str; +{ + if (!str) + return; + if (str->str_len) + str->str_ptr[0] = '\0'; + str->str_cur = 0; + str->str_nok = 0; + str->str_pok = 0; + str->str_link.str_next = freestrroot; + freestrroot = str; +} + +str_len(str) +register STR *str; +{ + if (!str) + return 0; + if (!(str->str_pok)) + str_2ptr(str); + if (str->str_len) + return str->str_cur; + else + return 0; +} + +char * +str_gets(str,fp) +register STR *str; +register FILE *fp; +{ +#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */ + + register char *bp; /* we're going to steal some values */ + register int cnt; /* from the stdio struct and put EVERYTHING */ + register char *ptr; /* in the innermost loop into registers */ + register char newline = '\n'; /* (assuming at least 6 registers) */ + int i; + int bpx; + + cnt = fp->_cnt; /* get count into register */ + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ + if (str->str_len <= cnt) /* make sure we have the room */ + GROWSTR(&(str->str_ptr), &(str->str_len), cnt+1); + bp = str->str_ptr; /* move these two too to registers */ + ptr = fp->_ptr; + for (;;) { + while (--cnt >= 0) { /* this */ /* eat */ + if ((*bp++ = *ptr++) == newline) /* really */ /* dust */ + goto thats_all_folks; /* screams */ /* sed :-) */ + } + + fp->_cnt = cnt; /* deregisterize cnt and ptr */ + fp->_ptr = ptr; + i = _filbuf(fp); /* get more characters */ + cnt = fp->_cnt; + ptr = fp->_ptr; /* reregisterize cnt and ptr */ + + bpx = bp - str->str_ptr; /* prepare for possible relocation */ + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + cnt + 1); + bp = str->str_ptr + bpx; /* reconstitute our pointer */ + + if (i == newline) { /* all done for now? */ + *bp++ = i; + goto thats_all_folks; + } + else if (i == EOF) /* all done for ever? */ + goto thats_all_folks; + *bp++ = i; /* now go back to screaming loop */ + } + +thats_all_folks: + fp->_cnt = cnt; /* put these back or we're in trouble */ + fp->_ptr = ptr; + *bp = '\0'; + str->str_cur = bp - str->str_ptr; /* set length */ + +#else /* !STDSTDIO */ /* The big, slow, and stupid way */ + + static char buf[4192]; + + if (fgets(buf, sizeof buf, fp) != Nullch) + str_set(str, buf); + else + str_set(str, No); + +#endif /* STDSTDIO */ + + return str->str_cur ? str->str_ptr : Nullch; +} + +void +str_inc(str) +register STR *str; +{ + register char *d; + + if (!str) + return; + if (str->str_nok) { + str->str_nval += 1.0; + str->str_pok = 0; + return; + } + if (!str->str_pok) { + str->str_nval = 1.0; + str->str_nok = 1; + return; + } + for (d = str->str_ptr; *d && *d != '.'; d++) ; + d--; + if (!isdigit(*str->str_ptr) || !isdigit(*d) ) { + str_numset(str,atof(str->str_ptr) + 1.0); /* punt */ + return; + } + while (d >= str->str_ptr) { + if (++*d <= '9') + return; + *(d--) = '0'; + } + /* oh,oh, the number grew */ + GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + 2); + str->str_cur++; + for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--) + *d = d[-1]; + *d = '1'; +} + +void +str_dec(str) +register STR *str; +{ + register char *d; + + if (!str) + return; + if (str->str_nok) { + str->str_nval -= 1.0; + str->str_pok = 0; + return; + } + if (!str->str_pok) { + str->str_nval = -1.0; + str->str_nok = 1; + return; + } + for (d = str->str_ptr; *d && *d != '.'; d++) ; + d--; + if (!isdigit(*str->str_ptr) || !isdigit(*d) || (*d == '0' && d == str->str_ptr)) { + str_numset(str,atof(str->str_ptr) - 1.0); /* punt */ + return; + } + while (d >= str->str_ptr) { + if (--*d >= '0') + return; + *(d--) = '9'; + } +} + +/* make a string that will exist for the duration of the expression eval */ + +STR * +str_static(oldstr) +STR *oldstr; +{ + register STR *str = str_new(0); + static long tmps_size = -1; + + str_sset(str,oldstr); + if (++tmps_max > tmps_size) { + tmps_size = tmps_max; + if (!(tmps_size & 127)) { + if (tmps_size) + tmps_list = (STR**)saferealloc((char*)tmps_list, + (tmps_size + 128) * sizeof(STR*) ); + else + tmps_list = (STR**)safemalloc(128 * sizeof(char*)); + } + } + tmps_list[tmps_max] = str; + return str; +} + +STR * +str_make(s) +char *s; +{ + register STR *str = str_new(0); + + str_set(str,s); + return str; +} + +STR * +str_nmake(n) +double n; +{ + register STR *str = str_new(0); + + str_numset(str,n); + return str; +} diff --git a/x2p/str.h b/x2p/str.h new file mode 100644 index 0000000000..cbb0c77759 --- /dev/null +++ b/x2p/str.h @@ -0,0 +1,35 @@ +/* $Header: str.h,v 1.0 87/12/18 13:07:30 root Exp $ + * + * $Log: str.h,v $ + * Revision 1.0 87/12/18 13:07:30 root + * Initial revision + * + */ + +struct string { + char * str_ptr; /* pointer to malloced string */ + double str_nval; /* numeric value, if any */ + int str_len; /* allocated size */ + int str_cur; /* length of str_ptr as a C string */ + union { + STR *str_next; /* while free, link to next free str */ + } str_link; + char str_pok; /* state of str_ptr */ + char str_nok; /* state of str_nval */ +}; + +#define Nullstr Null(STR*) + +/* the following macro updates any magic values this str is associated with */ + +#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x)) + +EXT STR **tmps_list; +EXT long tmps_max INIT(-1); + +char *str_2ptr(); +double str_2num(); +STR *str_static(); +STR *str_make(); +STR *str_nmake(); +char *str_gets(); diff --git a/x2p/util.c b/x2p/util.c new file mode 100644 index 0000000000..83adfc276b --- /dev/null +++ b/x2p/util.c @@ -0,0 +1,275 @@ +/* $Header: util.c,v 1.0 87/12/18 13:07:34 root Exp $ + * + * $Log: util.c,v $ + * Revision 1.0 87/12/18 13:07:34 root + * Initial revision + * + */ + +#include <stdio.h> + +#include "handy.h" +#include "EXTERN.h" +#include "a2p.h" +#include "INTERN.h" +#include "util.h" + +#define FLUSH +#define MEM_SIZE unsigned int + +static char nomem[] = "Out of memory!\n"; + +/* paranoid version of malloc */ + +static int an = 0; + +char * +safemalloc(size) +MEM_SIZE size; +{ + char *ptr; + char *malloc(); + + ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ +#ifdef DEBUGGING + if (debug & 128) + fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size); +#endif + if (ptr != Nullch) + return ptr; + else { + fputs(nomem,stdout) FLUSH; + exit(1); + } + /*NOTREACHED*/ +} + +/* paranoid version of realloc */ + +char * +saferealloc(where,size) +char *where; +MEM_SIZE size; +{ + char *ptr; + char *realloc(); + + ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ +#ifdef DEBUGGING + if (debug & 128) { + fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++); + fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size); + } +#endif + if (ptr != Nullch) + return ptr; + else { + fputs(nomem,stdout) FLUSH; + exit(1); + } + /*NOTREACHED*/ +} + +/* safe version of free */ + +safefree(where) +char *where; +{ +#ifdef DEBUGGING + if (debug & 128) + fprintf(stderr,"0x%x: (%05d) free\n",where,an++); +#endif + free(where); +} + +/* safe version of string copy */ + +char * +safecpy(to,from,len) +char *to; +register char *from; +register int len; +{ + register char *dest = to; + + if (from != Nullch) + for (len--; len && (*dest++ = *from++); len--) ; + *dest = '\0'; + return to; +} + +#ifdef undef +/* safe version of string concatenate, with \n deletion and space padding */ + +char * +safecat(to,from,len) +char *to; +register char *from; +register int len; +{ + register char *dest = to; + + len--; /* leave room for null */ + if (*dest) { + while (len && *dest++) len--; + if (len) { + len--; + *(dest-1) = ' '; + } + } + if (from != Nullch) + while (len && (*dest++ = *from++)) len--; + if (len) + dest--; + if (*(dest-1) == '\n') + dest--; + *dest = '\0'; + return to; +} +#endif + +/* copy a string up to some (non-backslashed) delimiter, if any */ + +char * +cpytill(to,from,delim) +register char *to, *from; +register int delim; +{ + for (; *from; from++,to++) { + if (*from == '\\' && from[1] == delim) + *to++ = *from++; + else if (*from == delim) + break; + *to = *from; + } + *to = '\0'; + return from; +} + +char * +cpy2(to,from,delim) +register char *to, *from; +register int delim; +{ + for (; *from; from++,to++) { + if (*from == '\\' && from[1] == delim) + *to++ = *from++; + else if (*from == '$') + *to++ = '\\'; + else if (*from == delim) + break; + *to = *from; + } + *to = '\0'; + return from; +} + +/* return ptr to little string in big string, NULL if not found */ + +char * +instr(big, little) +char *big, *little; + +{ + register char *t, *s, *x; + + for (t = big; *t; t++) { + for (x=t,s=little; *s; x++,s++) { + if (!*x) + return Nullch; + if (*s != *x) + break; + } + if (!*s) + return t; + } + return Nullch; +} + +/* copy a string to a safe spot */ + +char * +savestr(str) +char *str; +{ + register char *newaddr = safemalloc((MEM_SIZE)(strlen(str)+1)); + + (void)strcpy(newaddr,str); + return newaddr; +} + +/* grow a static string to at least a certain length */ + +void +growstr(strptr,curlen,newlen) +char **strptr; +int *curlen; +int newlen; +{ + if (newlen > *curlen) { /* need more room? */ + if (*curlen) + *strptr = saferealloc(*strptr,(MEM_SIZE)newlen); + else + *strptr = safemalloc((MEM_SIZE)newlen); + *curlen = newlen; + } +} + +/*VARARGS1*/ +fatal(pat,a1,a2,a3,a4) +char *pat; +{ + fprintf(stderr,pat,a1,a2,a3,a4); + exit(1); +} + +static bool firstsetenv = TRUE; +extern char **environ; + +void +setenv(nam,val) +char *nam, *val; +{ + register int i=envix(nam); /* where does it go? */ + + if (!environ[i]) { /* does not exist yet */ + if (firstsetenv) { /* need we copy environment? */ + int j; +#ifndef lint + char **tmpenv = (char**) /* point our wand at memory */ + safemalloc((i+2) * sizeof(char*)); +#else + char **tmpenv = Null(char **); +#endif /* lint */ + + firstsetenv = FALSE; + for (j=0; j<i; j++) /* copy environment */ + tmpenv[j] = environ[j]; + environ = tmpenv; /* tell exec where it is now */ + } +#ifndef lint + else + environ = (char**) saferealloc((char*) environ, + (i+2) * sizeof(char*)); + /* just expand it a bit */ +#endif /* lint */ + environ[i+1] = Nullch; /* make sure it's null terminated */ + } + environ[i] = safemalloc(strlen(nam) + strlen(val) + 2); + /* this may or may not be in */ + /* the old environ structure */ + sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ +} + +int +envix(nam) +char *nam; +{ + register int i, len = strlen(nam); + + for (i = 0; environ[i]; i++) { + if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') + break; /* strnEQ must come first to avoid */ + } /* potential SEGV's */ + return i; +} diff --git a/x2p/util.h b/x2p/util.h new file mode 100644 index 0000000000..6249549221 --- /dev/null +++ b/x2p/util.h @@ -0,0 +1,37 @@ +/* $Header: util.h,v 1.0 87/12/18 13:07:37 root Exp $ + * + * $Log: util.h,v $ + * Revision 1.0 87/12/18 13:07:37 root + * Initial revision + * + */ + +/* is the string for makedir a directory name or a filename? */ + +#define MD_DIR 0 +#define MD_FILE 1 + +void util_init(); +int doshell(); +char *safemalloc(); +char *saferealloc(); +char *safecpy(); +char *safecat(); +char *cpytill(); +char *cpy2(); +char *instr(); +#ifdef SETUIDGID + int eaccess(); +#endif +char *getwd(); +void cat(); +void prexit(); +char *get_a_line(); +char *savestr(); +int makedir(); +void setenv(); +int envix(); +void notincl(); +char *getval(); +void growstr(); +void setdef(); diff --git a/x2p/walk.c b/x2p/walk.c new file mode 100644 index 0000000000..04d133b9c4 --- /dev/null +++ b/x2p/walk.c @@ -0,0 +1,1464 @@ +/* $Header: walk.c,v 1.0 87/12/18 13:07:40 root Exp $ + * + * $Log: walk.c,v $ + * Revision 1.0 87/12/18 13:07:40 root + * Initial revision + * + */ + +#include "handy.h" +#include "EXTERN.h" +#include "util.h" +#include "a2p.h" + +bool exitval = FALSE; +bool realexit = FALSE; +int maxtmp = 0; + +STR * +walk(useval,level,node,numericptr) +int useval; +int level; +register int node; +int *numericptr; +{ + register int len; + register STR *str; + register int type; + register int i; + register STR *tmpstr; + STR *tmp2str; + char *t; + char *d, *s; + int numarg; + int numeric = FALSE; + STR *fstr; + char *index(); + + if (!node) { + *numericptr = 0; + return str_make(""); + } + type = ops[node].ival; + len = type >> 8; + type &= 255; + switch (type) { + case OPROG: + str = walk(0,level,ops[node+1].ival,&numarg); + opens = str_new(0); + if (do_split && need_entire && !absmaxfld) + split_to_array = TRUE; + if (do_split && split_to_array) + set_array_base = TRUE; + if (set_array_base) { + str_cat(str,"$[ = 1;\t\t\t# set array base to 1\n"); + } + if (fswitch && !const_FS) + const_FS = fswitch; + if (saw_FS > 1 || saw_RS) + const_FS = 0; + if (saw_ORS && need_entire) + do_chop = TRUE; + if (fswitch) { + str_cat(str,"$FS = '"); + if (index("*+?.[]()|^$\\",fswitch)) + str_cat(str,"\\"); + sprintf(tokenbuf,"%c",fswitch); + str_cat(str,tokenbuf); + str_cat(str,"';\t\t# field separator from -F switch\n"); + } + else if (saw_FS && !const_FS) { + str_cat(str,"$FS = '[ \\t\\n]+';\t\t# default field separator\n"); + } + if (saw_OFS) { + str_cat(str,"$, = ' ';\t\t# default output field separator\n"); + } + if (saw_ORS) { + str_cat(str,"$\\ = \"\\n\";\t\t# default output record separator\n"); + } + if (str->str_cur > 20) + str_cat(str,"\n"); + if (ops[node+2].ival) { + str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg)); + str_free(fstr); + str_cat(str,"\n\n"); + } + if (saw_line_op) + str_cat(str,"line: "); + str_cat(str,"while (<>) {\n"); + tab(str,++level); + if (saw_FS && !const_FS) + do_chop = TRUE; + if (do_chop) { + str_cat(str,"chop;\t# strip record separator\n"); + tab(str,level); + } + arymax = 0; + if (namelist) { + while (isalpha(*namelist)) { + for (d = tokenbuf,s=namelist; + isalpha(*s) || isdigit(*s) || *s == '_'; + *d++ = *s++) ; + *d = '\0'; + while (*s && !isalpha(*s)) s++; + namelist = s; + nameary[++arymax] = savestr(tokenbuf); + } + } + if (maxfld < arymax) + maxfld = arymax; + if (do_split) + emit_split(str,level); + str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg)); + str_free(fstr); + fixtab(str,--level); + str_cat(str,"}\n"); + if (ops[node+4].ival) { + realexit = TRUE; + str_cat(str,"\n"); + tab(str,level); + str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg)); + str_free(fstr); + str_cat(str,"\n"); + } + if (exitval) + str_cat(str,"exit ExitValue;\n"); + if (do_fancy_opens) { + str_cat(str,"\n\ +sub Pick {\n\ + ($name) = @_;\n\ + $fh = $opened{$name};\n\ + if (!$fh) {\n\ + $nextfh == 0 && open(fh_0,$name);\n\ + $nextfh == 1 && open(fh_1,$name);\n\ + $nextfh == 2 && open(fh_2,$name);\n\ + $nextfh == 3 && open(fh_3,$name);\n\ + $nextfh == 4 && open(fh_4,$name);\n\ + $nextfh == 5 && open(fh_5,$name);\n\ + $nextfh == 6 && open(fh_6,$name);\n\ + $nextfh == 7 && open(fh_7,$name);\n\ + $nextfh == 8 && open(fh_8,$name);\n\ + $nextfh == 9 && open(fh_9,$name);\n\ + $fh = $opened{$name} = 'fh_' . $nextfh++;\n\ + }\n\ + select($fh);\n\ +}\n\ +"); + } + break; + case OHUNKS: + str = walk(0,level,ops[node+1].ival,&numarg); + str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg)); + str_free(fstr); + if (len == 3) { + str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg)); + str_free(fstr); + } + else { + } + break; + case ORANGE: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str," .. "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + break; + case OPAT: + goto def; + case OREGEX: + str = str_new(0); + str_set(str,"/"); + tmpstr=walk(0,level,ops[node+1].ival,&numarg); + /* translate \nnn to [\nnn] */ + for (s = tmpstr->str_ptr, d = tokenbuf; *s; s++, d++) { + if (*s == '\\' && isdigit(s[1]) && isdigit(s[2]) && isdigit(s[3])) { + *d++ = '['; + *d++ = *s++; + *d++ = *s++; + *d++ = *s++; + *d++ = *s; + *d = ']'; + } + else + *d = *s; + } + *d = '\0'; + str_cat(str,tokenbuf); + str_free(tmpstr); + str_cat(str,"/"); + break; + case OHUNK: + if (len == 1) { + str = str_new(0); + str = walk(0,level,oper1(OPRINT,0),&numarg); + str_cat(str," if "); + str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,";"); + } + else { + tmpstr = walk(0,level,ops[node+1].ival,&numarg); + if (*tmpstr->str_ptr) { + str = str_new(0); + str_set(str,"if ("); + str_scat(str,tmpstr); + str_cat(str,") {\n"); + tab(str,++level); + str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg)); + str_free(fstr); + fixtab(str,--level); + str_cat(str,"}\n"); + tab(str,level); + } + else { + str = walk(0,level,ops[node+2].ival,&numarg); + } + } + break; + case OPPAREN: + str = str_new(0); + str_set(str,"("); + str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,")"); + break; + case OPANDAND: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str," && "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + break; + case OPOROR: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str," || "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + break; + case OPNOT: + str = str_new(0); + str_set(str,"!"); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + break; + case OCPAREN: + str = str_new(0); + str_set(str,"("); + str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg)); + str_free(fstr); + numeric |= numarg; + str_cat(str,")"); + break; + case OCANDAND: + str = walk(1,level,ops[node+1].ival,&numarg); + numeric = 1; + str_cat(str," && "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + break; + case OCOROR: + str = walk(1,level,ops[node+1].ival,&numarg); + numeric = 1; + str_cat(str," || "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + break; + case OCNOT: + str = str_new(0); + str_set(str,"!"); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case ORELOP: + str = walk(1,level,ops[node+2].ival,&numarg); + numeric |= numarg; + tmpstr = walk(0,level,ops[node+1].ival,&numarg); + tmp2str = walk(1,level,ops[node+3].ival,&numarg); + numeric |= numarg; + if (!numeric) { + t = tmpstr->str_ptr; + if (strEQ(t,"==")) + str_set(tmpstr,"eq"); + else if (strEQ(t,"!=")) + str_set(tmpstr,"ne"); + else if (strEQ(t,"<")) + str_set(tmpstr,"lt"); + else if (strEQ(t,"<=")) + str_set(tmpstr,"le"); + else if (strEQ(t,">")) + str_set(tmpstr,"gt"); + else if (strEQ(t,">=")) + str_set(tmpstr,"ge"); + if (!index(tmpstr->str_ptr,'\'') && !index(tmpstr->str_ptr,'"') && + !index(tmp2str->str_ptr,'\'') && !index(tmp2str->str_ptr,'"') ) + numeric |= 2; + } + if (numeric & 2) { + if (numeric & 1) /* numeric is very good guess */ + str_cat(str," "); + else + str_cat(str,"\377"); + numeric = 1; + } + else + str_cat(str," "); + str_scat(str,tmpstr); + str_free(tmpstr); + str_cat(str," "); + str_scat(str,tmp2str); + str_free(tmp2str); + numeric = 1; + break; + case ORPAREN: + str = str_new(0); + str_set(str,"("); + str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg)); + str_free(fstr); + numeric |= numarg; + str_cat(str,")"); + break; + case OMATCHOP: + str = walk(1,level,ops[node+2].ival,&numarg); + str_cat(str," "); + tmpstr = walk(0,level,ops[node+1].ival,&numarg); + if (strEQ(tmpstr->str_ptr,"~")) + str_cat(str,"=~"); + else { + str_scat(str,tmpstr); + str_free(tmpstr); + } + str_cat(str," "); + str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case OMPAREN: + str = str_new(0); + str_set(str,"("); + str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg)); + str_free(fstr); + numeric |= numarg; + str_cat(str,")"); + break; + case OCONCAT: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str," . "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + break; + case OASSIGN: + str = walk(0,level,ops[node+2].ival,&numarg); + str_cat(str," "); + tmpstr = walk(0,level,ops[node+1].ival,&numarg); + str_scat(str,tmpstr); + if (str_len(tmpstr) > 1) + numeric = 1; + str_free(tmpstr); + str_cat(str," "); + str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg)); + str_free(fstr); + numeric |= numarg; + if (strEQ(str->str_ptr,"$FS = '\240'")) + str_set(str,"$FS = '[\240\\n\\t]+'"); + break; + case OADD: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str," + "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case OSUB: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str," - "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case OMULT: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str," * "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case ODIV: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str," / "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case OMOD: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str," % "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case OPOSTINCR: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str,"++"); + numeric = 1; + break; + case OPOSTDECR: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str,"--"); + numeric = 1; + break; + case OPREINCR: + str = str_new(0); + str_set(str,"++"); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case OPREDECR: + str = str_new(0); + str_set(str,"--"); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case OUMINUS: + str = str_new(0); + str_set(str,"-"); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + numeric = 1; + break; + case OUPLUS: + numeric = 1; + goto def; + case OPAREN: + str = str_new(0); + str_set(str,"("); + str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,")"); + numeric |= numarg; + break; + case OGETLINE: + str = str_new(0); + str_set(str,"$_ = <>;\n"); + tab(str,level); + if (do_chop) { + str_cat(str,"chop;\t# strip record separator\n"); + tab(str,level); + } + if (do_split) + emit_split(str,level); + break; + case OSPRINTF: + str = str_new(0); + str_set(str,"sprintf("); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,")"); + break; + case OSUBSTR: + str = str_new(0); + str_set(str,"substr("); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,", "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + str_cat(str,", "); + if (len == 3) { + str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg)); + str_free(fstr); + } + else + str_cat(str,"999999"); + str_cat(str,")"); + break; + case OSTRING: + str = str_new(0); + str_set(str,ops[node+1].cval); + break; + case OSPLIT: + str = str_new(0); + numeric = 1; + tmpstr = walk(1,level,ops[node+2].ival,&numarg); + if (useval) + str_set(str,"(@"); + else + str_set(str,"@"); + str_scat(str,tmpstr); + str_cat(str," = split("); + if (len == 3) { + fstr = walk(1,level,ops[node+3].ival,&numarg); + if (str_len(fstr) == 3 && *fstr->str_ptr == '\'') { + i = fstr->str_ptr[1] & 127; + if (index("*+?.[]()|^$\\",i)) + sprintf(tokenbuf,"/\\%c/",i); + else + sprintf(tokenbuf,"/%c/",i); + str_cat(str,tokenbuf); + } + else + str_scat(str,fstr); + str_free(fstr); + } + else if (const_FS) { + sprintf(tokenbuf,"/[%c\\n]/",const_FS); + str_cat(str,tokenbuf); + } + else if (saw_FS) + str_cat(str,"$FS"); + else + str_cat(str,"/[ \\t\\n]+/"); + str_cat(str,", "); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,")"); + if (useval) { + str_cat(str,")"); + } + str_free(tmpstr); + break; + case OINDEX: + str = str_new(0); + str_set(str,"index("); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,", "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + str_cat(str,")"); + numeric = 1; + break; + case ONUM: + str = walk(1,level,ops[node+1].ival,&numarg); + numeric = 1; + break; + case OSTR: + tmpstr = walk(1,level,ops[node+1].ival,&numarg); + s = "'"; + for (t = tmpstr->str_ptr; *t; t++) { + if (*t == '\\' || *t == '\'') + s = "\""; + *t += 128; + } + str = str_new(0); + str_set(str,s); + str_scat(str,tmpstr); + str_free(tmpstr); + str_cat(str,s); + break; + case OVAR: + str = str_new(0); + str_set(str,"$"); + str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg)); + if (len == 1) { + tmp2str = hfetch(symtab,tmpstr->str_ptr); + if (tmp2str && atoi(tmp2str->str_ptr)) + numeric = 2; + if (strEQ(str->str_ptr,"$NR")) { + numeric = 1; + str_set(str,"$."); + } + else if (strEQ(str->str_ptr,"$NF")) { + numeric = 1; + str_set(str,"$#Fld"); + } + else if (strEQ(str->str_ptr,"$0")) + str_set(str,"$_"); + } + else { + str_cat(tmpstr,"[]"); + tmp2str = hfetch(symtab,tmpstr->str_ptr); + if (tmp2str && atoi(tmp2str->str_ptr)) + str_cat(str,"["); + else + str_cat(str,"{"); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + if (tmp2str && atoi(tmp2str->str_ptr)) + strcpy(tokenbuf,"]"); + else + strcpy(tokenbuf,"}"); + *tokenbuf += 128; + str_cat(str,tokenbuf); + } + str_free(tmpstr); + break; + case OFLD: + str = str_new(0); + if (split_to_array) { + str_set(str,"$Fld"); + str_cat(str,"["); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,"]"); + } + else { + i = atoi(walk(1,level,ops[node+1].ival,&numarg)->str_ptr); + if (i <= arymax) + sprintf(tokenbuf,"$%s",nameary[i]); + else + sprintf(tokenbuf,"$Fld%d",i); + str_set(str,tokenbuf); + } + break; + case OVFLD: + str = str_new(0); + str_set(str,"$Fld["); + i = ops[node+1].ival; + if ((ops[i].ival & 255) == OPAREN) + i = ops[i+1].ival; + tmpstr=walk(1,level,i,&numarg); + str_scat(str,tmpstr); + str_free(tmpstr); + str_cat(str,"]"); + break; + case OJUNK: + goto def; + case OSNEWLINE: + str = str_new(2); + str_set(str,";\n"); + tab(str,level); + break; + case ONEWLINE: + str = str_new(1); + str_set(str,"\n"); + tab(str,level); + break; + case OSCOMMENT: + str = str_new(0); + str_set(str,";"); + tmpstr = walk(0,level,ops[node+1].ival,&numarg); + for (s = tmpstr->str_ptr; *s && *s != '\n'; s++) + *s += 128; + str_scat(str,tmpstr); + str_free(tmpstr); + tab(str,level); + break; + case OCOMMENT: + str = str_new(0); + tmpstr = walk(0,level,ops[node+1].ival,&numarg); + for (s = tmpstr->str_ptr; *s && *s != '\n'; s++) + *s += 128; + str_scat(str,tmpstr); + str_free(tmpstr); + tab(str,level); + break; + case OCOMMA: + str = walk(1,level,ops[node+1].ival,&numarg); + str_cat(str,", "); + str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg)); + str_free(fstr); + break; + case OSEMICOLON: + str = str_new(1); + str_set(str,"; "); + break; + case OSTATES: + str = walk(0,level,ops[node+1].ival,&numarg); + str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg)); + str_free(fstr); + break; + case OSTATE: + str = str_new(0); + if (len >= 1) { + str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg)); + str_free(fstr); + if (len >= 2) { + tmpstr = walk(0,level,ops[node+2].ival,&numarg); + if (*tmpstr->str_ptr == ';') { + addsemi(str); + str_cat(str,tmpstr->str_ptr+1); + } + str_free(tmpstr); + } + } + break; + case OPRINTF: + case OPRINT: + str = str_new(0); + if (len == 3) { /* output redirection */ + tmpstr = walk(1,level,ops[node+3].ival,&numarg); + tmp2str = walk(1,level,ops[node+2].ival,&numarg); + if (!do_fancy_opens) { + t = tmpstr->str_ptr; + if (*t == '"' || *t == '\'') + t = cpytill(tokenbuf,t+1,*t); + else + fatal("Internal error: OPRINT"); + d = savestr(t); + s = savestr(tokenbuf); + for (t = tokenbuf; *t; t++) { + *t &= 127; + if (!isalpha(*t) && !isdigit(*t)) + *t = '_'; + } + if (!index(tokenbuf,'_')) + strcpy(t,"_fh"); + str_cat(opens,"open("); + str_cat(opens,tokenbuf); + str_cat(opens,", "); + d[1] = '\0'; + str_cat(opens,d); + str_scat(opens,tmp2str); + str_cat(opens,tmpstr->str_ptr+1); + if (*tmp2str->str_ptr == '|') + str_cat(opens,") || die 'Cannot pipe to \""); + else + str_cat(opens,") || die 'Cannot create file \""); + if (*d == '"') + str_cat(opens,"'.\""); + str_cat(opens,s); + if (*d == '"') + str_cat(opens,"\".'"); + str_cat(opens,"\".';\n"); + str_free(tmpstr); + str_free(tmp2str); + safefree(s); + safefree(d); + } + else { + sprintf(tokenbuf,"do Pick('%s' . (%s)) &&\n", + tmp2str->str_ptr, tmpstr->str_ptr); + str_cat(str,tokenbuf); + tab(str,level+1); + *tokenbuf = '\0'; + str_free(tmpstr); + str_free(tmp2str); + } + } + else + strcpy(tokenbuf,"stdout"); + if (type == OPRINTF) + str_cat(str,"printf"); + else + str_cat(str,"print"); + if (len == 3 || do_fancy_opens) { + if (*tokenbuf) + str_cat(str," "); + str_cat(str,tokenbuf); + } + tmpstr = walk(1+(type==OPRINT),level,ops[node+1].ival,&numarg); + if (!*tmpstr->str_ptr && lval_field) { + t = saw_OFS ? "$," : "' '"; + if (split_to_array) { + sprintf(tokenbuf,"join(%s,@Fld)",t); + str_cat(tmpstr,tokenbuf); + } + else { + for (i = 1; i < maxfld; i++) { + if (i <= arymax) + sprintf(tokenbuf,"$%s, ",nameary[i]); + else + sprintf(tokenbuf,"$Fld%d, ",i); + str_cat(tmpstr,tokenbuf); + } + if (maxfld <= arymax) + sprintf(tokenbuf,"$%s",nameary[maxfld]); + else + sprintf(tokenbuf,"$Fld%d",maxfld); + str_cat(tmpstr,tokenbuf); + } + } + if (*tmpstr->str_ptr) { + str_cat(str," "); + str_scat(str,tmpstr); + } + else { + str_cat(str," $_"); + } + str_free(tmpstr); + break; + case OLENGTH: + str = str_make("length("); + goto maybe0; + case OLOG: + str = str_make("log("); + goto maybe0; + case OEXP: + str = str_make("exp("); + goto maybe0; + case OSQRT: + str = str_make("sqrt("); + goto maybe0; + case OINT: + str = str_make("int("); + maybe0: + numeric = 1; + if (len > 0) + tmpstr = walk(1,level,ops[node+1].ival,&numarg); + else + tmpstr = str_new(0);; + if (!*tmpstr->str_ptr) { + if (lval_field) { + t = saw_OFS ? "$," : "' '"; + if (split_to_array) { + sprintf(tokenbuf,"join(%s,@Fld)",t); + str_cat(tmpstr,tokenbuf); + } + else { + sprintf(tokenbuf,"join(%s, ",t); + str_cat(tmpstr,tokenbuf); + for (i = 1; i < maxfld; i++) { + if (i <= arymax) + sprintf(tokenbuf,"$%s,",nameary[i]); + else + sprintf(tokenbuf,"$Fld%d,",i); + str_cat(tmpstr,tokenbuf); + } + if (maxfld <= arymax) + sprintf(tokenbuf,"$%s)",nameary[maxfld]); + else + sprintf(tokenbuf,"$Fld%d)",maxfld); + str_cat(tmpstr,tokenbuf); + } + } + else + str_cat(tmpstr,"$_"); + } + if (strEQ(tmpstr->str_ptr,"$_")) { + if (type == OLENGTH && !do_chop) { + str = str_make("(length("); + str_cat(tmpstr,") - 1"); + } + } + str_scat(str,tmpstr); + str_free(tmpstr); + str_cat(str,")"); + break; + case OBREAK: + str = str_new(0); + str_set(str,"last"); + break; + case ONEXT: + str = str_new(0); + str_set(str,"next line"); + break; + case OEXIT: + str = str_new(0); + if (realexit) { + str_set(str,"exit"); + if (len == 1) { + str_cat(str," "); + exitval = TRUE; + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + } + } + else { + if (len == 1) { + str_set(str,"ExitValue = "); + exitval = TRUE; + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,"; "); + } + str_cat(str,"last line"); + } + break; + case OCONTINUE: + str = str_new(0); + str_set(str,"next"); + break; + case OREDIR: + goto def; + case OIF: + str = str_new(0); + str_set(str,"if ("); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,") "); + str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg)); + str_free(fstr); + if (len == 3) { + i = ops[node+3].ival; + if (i) { + if ((ops[i].ival & 255) == OBLOCK) { + i = ops[i+1].ival; + if (i) { + if ((ops[i].ival & 255) != OIF) + i = 0; + } + } + else + i = 0; + } + if (i) { + str_cat(str,"els"); + str_scat(str,fstr=walk(0,level,i,&numarg)); + str_free(fstr); + } + else { + str_cat(str,"else "); + str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg)); + str_free(fstr); + } + } + break; + case OWHILE: + str = str_new(0); + str_set(str,"while ("); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,") "); + str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg)); + str_free(fstr); + break; + case OFOR: + str = str_new(0); + str_set(str,"for ("); + str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg)); + i = numarg; + if (i) { + t = s = tmpstr->str_ptr; + while (isalpha(*t) || isdigit(*t) || *t == '$' || *t == '_') + t++; + i = t - s; + if (i < 2) + i = 0; + } + str_cat(str,"; "); + fstr=walk(1,level,ops[node+2].ival,&numarg); + if (i && (t = index(fstr->str_ptr,0377))) { + if (strnEQ(fstr->str_ptr,s,i)) + *t = ' '; + } + str_scat(str,fstr); + str_free(fstr); + str_free(tmpstr); + str_cat(str,"; "); + str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg)); + str_free(fstr); + str_cat(str,") "); + str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg)); + str_free(fstr); + break; + case OFORIN: + tmpstr=walk(0,level,ops[node+2].ival,&numarg); + str = str_new(0); + str_sset(str,tmpstr); + str_cat(str,"[]"); + tmp2str = hfetch(symtab,str->str_ptr); + if (tmp2str && atoi(tmp2str->str_ptr)) { + maxtmp++; + fstr=walk(1,level,ops[node+1].ival,&numarg); + sprintf(tokenbuf, + "for ($T_%d = 1; ($%s = $%s[$T_%d]) || $T_%d <= $#%s; $T_%d++)%c", + maxtmp, + fstr->str_ptr, + tmpstr->str_ptr, + maxtmp, + maxtmp, + tmpstr->str_ptr, + maxtmp, + 0377); + str_set(str,tokenbuf); + str_free(fstr); + str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg)); + str_free(fstr); + } + else { + str_set(str,"while (($junkkey,$"); + str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg)); + str_free(fstr); + str_cat(str,") = each("); + str_scat(str,tmpstr); + str_cat(str,")) "); + str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg)); + str_free(fstr); + } + str_free(tmpstr); + break; + case OBLOCK: + str = str_new(0); + str_set(str,"{"); + if (len == 2) { + str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg)); + str_free(fstr); + } + fixtab(str,++level); + str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg)); + str_free(fstr); + addsemi(str); + fixtab(str,--level); + str_cat(str,"}\n"); + tab(str,level); + break; + default: + def: + if (len) { + if (len > 5) + fatal("Garbage length in walk"); + str = walk(0,level,ops[node+1].ival,&numarg); + for (i = 2; i<= len; i++) { + str_scat(str,fstr=walk(0,level,ops[node+i].ival,&numarg)); + str_free(fstr); + } + } + else { + str = Nullstr; + } + break; + } + if (!str) + str = str_new(0); + *numericptr = numeric; +#ifdef DEBUGGING + if (debug & 4) { + printf("%3d %5d %15s %d %4d ",level,node,opname[type],len,str->str_cur); + for (t = str->str_ptr; *t && t - str->str_ptr < 40; t++) + if (*t == '\n') + printf("\\n"); + else if (*t == '\t') + printf("\\t"); + else + putchar(*t); + putchar('\n'); + } +#endif + return str; +} + +tab(str,lvl) +register STR *str; +register int lvl; +{ + while (lvl > 1) { + str_cat(str,"\t"); + lvl -= 2; + } + if (lvl) + str_cat(str," "); +} + +fixtab(str,lvl) +register STR *str; +register int lvl; +{ + register char *s; + + /* strip trailing white space */ + + s = str->str_ptr+str->str_cur - 1; + while (s >= str->str_ptr && (*s == ' ' || *s == '\t')) + s--; + s[1] = '\0'; + str->str_cur = s + 1 - str->str_ptr; + if (s >= str->str_ptr && *s != '\n') + str_cat(str,"\n"); + + tab(str,lvl); +} + +addsemi(str) +register STR *str; +{ + register char *s; + + s = str->str_ptr+str->str_cur - 1; + while (s >= str->str_ptr && (*s == ' ' || *s == '\t' || *s == '\n')) + s--; + if (s >= str->str_ptr && *s != ';' && *s != '}') + str_cat(str,";"); +} + +emit_split(str,level) +register STR *str; +int level; +{ + register int i; + + if (split_to_array) + str_cat(str,"@Fld"); + else { + str_cat(str,"("); + for (i = 1; i < maxfld; i++) { + if (i <= arymax) + sprintf(tokenbuf,"$%s,",nameary[i]); + else + sprintf(tokenbuf,"$Fld%d,",i); + str_cat(str,tokenbuf); + } + if (maxfld <= arymax) + sprintf(tokenbuf,"$%s)",nameary[maxfld]); + else + sprintf(tokenbuf,"$Fld%d)",maxfld); + str_cat(str,tokenbuf); + } + if (const_FS) { + sprintf(tokenbuf," = split(/[%c\\n]/);\n",const_FS); + str_cat(str,tokenbuf); + } + else if (saw_FS) + str_cat(str," = split($FS);\n"); + else + str_cat(str," = split;\n"); + tab(str,level); +} + +prewalk(numit,level,node,numericptr) +int numit; +int level; +register int node; +int *numericptr; +{ + register int len; + register int type; + register int i; + char *t; + char *d, *s; + int numarg; + int numeric = FALSE; + + if (!node) { + *numericptr = 0; + return 0; + } + type = ops[node].ival; + len = type >> 8; + type &= 255; + switch (type) { + case OPROG: + prewalk(0,level,ops[node+1].ival,&numarg); + if (ops[node+2].ival) { + prewalk(0,level,ops[node+2].ival,&numarg); + } + ++level; + prewalk(0,level,ops[node+3].ival,&numarg); + --level; + if (ops[node+3].ival) { + prewalk(0,level,ops[node+4].ival,&numarg); + } + break; + case OHUNKS: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + if (len == 3) { + prewalk(0,level,ops[node+3].ival,&numarg); + } + break; + case ORANGE: + prewalk(1,level,ops[node+1].ival,&numarg); + prewalk(1,level,ops[node+2].ival,&numarg); + break; + case OPAT: + goto def; + case OREGEX: + prewalk(0,level,ops[node+1].ival,&numarg); + break; + case OHUNK: + if (len == 1) { + prewalk(0,level,ops[node+1].ival,&numarg); + } + else { + i = prewalk(0,level,ops[node+1].ival,&numarg); + if (i) { + ++level; + prewalk(0,level,ops[node+2].ival,&numarg); + --level; + } + else { + prewalk(0,level,ops[node+2].ival,&numarg); + } + } + break; + case OPPAREN: + prewalk(0,level,ops[node+1].ival,&numarg); + break; + case OPANDAND: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + break; + case OPOROR: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + break; + case OPNOT: + prewalk(0,level,ops[node+1].ival,&numarg); + break; + case OCPAREN: + prewalk(0,level,ops[node+1].ival,&numarg); + numeric |= numarg; + break; + case OCANDAND: + prewalk(0,level,ops[node+1].ival,&numarg); + numeric = 1; + prewalk(0,level,ops[node+2].ival,&numarg); + break; + case OCOROR: + prewalk(0,level,ops[node+1].ival,&numarg); + numeric = 1; + prewalk(0,level,ops[node+2].ival,&numarg); + break; + case OCNOT: + prewalk(0,level,ops[node+1].ival,&numarg); + numeric = 1; + break; + case ORELOP: + prewalk(0,level,ops[node+2].ival,&numarg); + numeric |= numarg; + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+3].ival,&numarg); + numeric |= numarg; + numeric = 1; + break; + case ORPAREN: + prewalk(0,level,ops[node+1].ival,&numarg); + numeric |= numarg; + break; + case OMATCHOP: + prewalk(0,level,ops[node+2].ival,&numarg); + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+3].ival,&numarg); + numeric = 1; + break; + case OMPAREN: + prewalk(0,level,ops[node+1].ival,&numarg); + numeric |= numarg; + break; + case OCONCAT: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + break; + case OASSIGN: + prewalk(0,level,ops[node+2].ival,&numarg); + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+3].ival,&numarg); + if (numarg || strlen(ops[ops[node+1].ival+1].cval) > 1) { + numericize(ops[node+2].ival); + if (!numarg) + numericize(ops[node+3].ival); + } + numeric |= numarg; + break; + case OADD: + prewalk(1,level,ops[node+1].ival,&numarg); + prewalk(1,level,ops[node+2].ival,&numarg); + numeric = 1; + break; + case OSUB: + prewalk(1,level,ops[node+1].ival,&numarg); + prewalk(1,level,ops[node+2].ival,&numarg); + numeric = 1; + break; + case OMULT: + prewalk(1,level,ops[node+1].ival,&numarg); + prewalk(1,level,ops[node+2].ival,&numarg); + numeric = 1; + break; + case ODIV: + prewalk(1,level,ops[node+1].ival,&numarg); + prewalk(1,level,ops[node+2].ival,&numarg); + numeric = 1; + break; + case OMOD: + prewalk(1,level,ops[node+1].ival,&numarg); + prewalk(1,level,ops[node+2].ival,&numarg); + numeric = 1; + break; + case OPOSTINCR: + prewalk(1,level,ops[node+1].ival,&numarg); + numeric = 1; + break; + case OPOSTDECR: + prewalk(1,level,ops[node+1].ival,&numarg); + numeric = 1; + break; + case OPREINCR: + prewalk(1,level,ops[node+1].ival,&numarg); + numeric = 1; + break; + case OPREDECR: + prewalk(1,level,ops[node+1].ival,&numarg); + numeric = 1; + break; + case OUMINUS: + prewalk(1,level,ops[node+1].ival,&numarg); + numeric = 1; + break; + case OUPLUS: + prewalk(1,level,ops[node+1].ival,&numarg); + numeric = 1; + break; + case OPAREN: + prewalk(0,level,ops[node+1].ival,&numarg); + numeric |= numarg; + break; + case OGETLINE: + break; + case OSPRINTF: + prewalk(0,level,ops[node+1].ival,&numarg); + break; + case OSUBSTR: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(1,level,ops[node+2].ival,&numarg); + if (len == 3) { + prewalk(1,level,ops[node+3].ival,&numarg); + } + break; + case OSTRING: + break; + case OSPLIT: + numeric = 1; + prewalk(0,level,ops[node+2].ival,&numarg); + if (len == 3) + prewalk(0,level,ops[node+3].ival,&numarg); + prewalk(0,level,ops[node+1].ival,&numarg); + break; + case OINDEX: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + numeric = 1; + break; + case ONUM: + prewalk(0,level,ops[node+1].ival,&numarg); + numeric = 1; + break; + case OSTR: + prewalk(0,level,ops[node+1].ival,&numarg); + break; + case OVAR: + prewalk(0,level,ops[node+1].ival,&numarg); + if (len == 1) { + if (numit) + numericize(node); + } + else { + prewalk(0,level,ops[node+2].ival,&numarg); + } + break; + case OFLD: + prewalk(0,level,ops[node+1].ival,&numarg); + break; + case OVFLD: + i = ops[node+1].ival; + prewalk(0,level,i,&numarg); + break; + case OJUNK: + goto def; + case OSNEWLINE: + break; + case ONEWLINE: + break; + case OSCOMMENT: + break; + case OCOMMENT: + break; + case OCOMMA: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + break; + case OSEMICOLON: + break; + case OSTATES: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + break; + case OSTATE: + if (len >= 1) { + prewalk(0,level,ops[node+1].ival,&numarg); + if (len >= 2) { + prewalk(0,level,ops[node+2].ival,&numarg); + } + } + break; + case OPRINTF: + case OPRINT: + if (len == 3) { /* output redirection */ + prewalk(0,level,ops[node+3].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + } + prewalk(0+(type==OPRINT),level,ops[node+1].ival,&numarg); + break; + case OLENGTH: + goto maybe0; + case OLOG: + goto maybe0; + case OEXP: + goto maybe0; + case OSQRT: + goto maybe0; + case OINT: + maybe0: + numeric = 1; + if (len > 0) + prewalk(type != OLENGTH,level,ops[node+1].ival,&numarg); + break; + case OBREAK: + break; + case ONEXT: + break; + case OEXIT: + if (len == 1) { + prewalk(1,level,ops[node+1].ival,&numarg); + } + break; + case OCONTINUE: + break; + case OREDIR: + goto def; + case OIF: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + if (len == 3) { + prewalk(0,level,ops[node+3].ival,&numarg); + } + break; + case OWHILE: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + break; + case OFOR: + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+2].ival,&numarg); + prewalk(0,level,ops[node+3].ival,&numarg); + prewalk(0,level,ops[node+4].ival,&numarg); + break; + case OFORIN: + prewalk(0,level,ops[node+2].ival,&numarg); + prewalk(0,level,ops[node+1].ival,&numarg); + prewalk(0,level,ops[node+3].ival,&numarg); + break; + case OBLOCK: + if (len == 2) { + prewalk(0,level,ops[node+2].ival,&numarg); + } + ++level; + prewalk(0,level,ops[node+1].ival,&numarg); + --level; + break; + default: + def: + if (len) { + if (len > 5) + fatal("Garbage length in prewalk"); + prewalk(0,level,ops[node+1].ival,&numarg); + for (i = 2; i<= len; i++) { + prewalk(0,level,ops[node+i].ival,&numarg); + } + } + break; + } + *numericptr = numeric; + return 1; +} + +numericize(node) +register int node; +{ + register int len; + register int type; + register int i; + STR *tmpstr; + STR *tmp2str; + int numarg; + + type = ops[node].ival; + len = type >> 8; + type &= 255; + if (type == OVAR && len == 1) { + tmpstr=walk(0,0,ops[node+1].ival,&numarg); + tmp2str = str_make("1"); + hstore(symtab,tmpstr->str_ptr,tmp2str); + } +} |