From: Larry Wall Date: Fri, 18 Dec 1987 00:00:00 +0000 (+0000) Subject: a "replacement" for awk and sed X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8d063cd8450e59ea1c611a2f4f5a21059a2804f1;p=p5sagit%2Fp5-mst-13.2.git a "replacement" for awk and sed [ Perl is kind of designed to make awk and sed semi-obsolete. This posting will include the first 10 patches after the main source. The following description is lifted from Larry's manpage. --r$ ] 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, sed, awk, and sh, so people familiar with those languages should have little difficulty with it. (Language historians will also note some vestiges of csh, Pascal, and even BASIC-PLUS.) Expression syntax corresponds quite closely to C expression syntax. If you have a problem that would ordinarily use sed or awk or sh, but it exceeds their capabilities or must run a little faster, and you don't want to write the silly thing in C, then perl may be for you. There are also translators to turn your sed and awk scripts into perl scripts. --- 8d063cd8450e59ea1c611a2f4f5a21059a2804f1 diff --git a/Configure b/Configure new file mode 100755 index 0000000..3035f15 --- /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 /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 <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 <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 < 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 </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 <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 <&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 <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)}' 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 </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 <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' /dev/null 2>&1; then + dflt=n + $cat < 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 0000000..a5fff1f --- /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 0000000..06a59f0 --- /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 0000000..085b831 --- /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 0000000..f45bb3f --- /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 <>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 0000000..b5d95e1 --- /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 0000000..1233293 --- /dev/null +++ b/Wishlist @@ -0,0 +1,5 @@ +date support +case statement +ioctl() support +random numbers +directory reading via <> diff --git a/arg.c b/arg.c new file mode 100644 index 0000000..9561bb6 --- /dev/null +++ b/arg.c @@ -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 +#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 : ""); + 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; +} diff --git a/arg.h b/arg.h new file mode 100644 index 0000000..2e1bd8a --- /dev/null +++ b/arg.h @@ -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 0000000..156b783 --- /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 +#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 0000000..4ad9487 --- /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(); diff --git a/cmd.c b/cmd.c new file mode 100644 index 0000000..ba57a2a --- /dev/null +++ b/cmd.c @@ -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 () */ + 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; ic_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; +} diff --git a/cmd.h b/cmd.h new file mode 100644 index 0000000..9eb4a8f --- /dev/null +++ b/cmd.h @@ -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 = */ +#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 0000000..bb9eb6b --- /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 0000000..0789bc6 --- /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 <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 0000000..4f93fd1 --- /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 0000000..8894621 --- /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 0000000..fc2257b --- /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 0000000..3eb2477 --- /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 0000000..61e7f87 --- /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 +#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; ihent_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 0000000..6e9a7a0 --- /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 0000000..6b20cac --- /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 <>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.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 0000000..54a0c11 --- /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 </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 0000000..17c3b27 --- /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 + +#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 + +#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 +#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 0000000..935ec35 --- /dev/null +++ b/patchlevel.h @@ -0,0 +1 @@ +#define PATCHLEVEL 0 diff --git a/perl.h b/perl.h new file mode 100644 index 0000000..3ccff10 --- /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 +#include +#include +#include +#include +#include +#include + +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 0000000..ea40065 --- /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 +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 +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 +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 ($_ = ) { + while () { + for (\|;\|;\|) { + +.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 () { + .\|.\|. # 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 { + $_ = ; + .\|.\|. + } 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'); + \|=~ \|/\|^[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 = ; + open(pass,'/etc/passwd') || die "Can't open passwd"; + while () { + ($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 = ; + 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 0000000..ecda600 --- /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 () { + 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 () { + 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 (
) {\|.\|.\|. + + 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 () { + while (s|\|({.*}.*\|){.*}|$1 \||) {} + s|{.*}| \||; + if (s|{.*| \||) { + $front = $_; + while () { + 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 () { +.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 = ) { + if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) { + $thisline \|.= \|$lookahead; + } + else { + last line; + } + } + $thisline; + } + + $lookahead = ; # 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, $ +matches the digit'th substring, where digit can range from 1 to 9. +(You can also use the old standby \e in search patterns, +but $ 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 +.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 +$ 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 0000000..16f8a9a --- /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 WORD +%token APPEND OPEN WRITE SELECT CLOSE LOOPEX +%token USING FORMAT DO SHIFT PUSH POP CHOP +%token WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT SPRINTF +%token FOR FEOF TELL SEEK STAT +%token FUNC0 FUNC1 FUNC2 FUNC3 STABFUN +%token JOIN SUB +%token FORMLIST +%token REG ARYLEN ARY +%token SUBST PATTERN +%token RSTRING TRANS + +%type prog decl format +%type +%type block lineseq line loop cond sideff nexpr else +%type expr sexpr term +%type condmod loopmod cexpr +%type texpr print +%type label +%type compblock + +%nonassoc PRINT +%left ',' +%nonassoc 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 0000000..bc32318 --- /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 \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 ()" 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 0000000..79712a1 --- /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 +#include + +#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 0000000..992da7d --- /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 0000000..d1d2dc3 --- /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 0000000..b9ef533 --- /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 +#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 0000000..cd38d6d --- /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(); diff --git a/str.c b/str.c new file mode 100644 index 0000000..52e83f2 --- /dev/null +++ b/str.c @@ -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; +} diff --git a/str.h b/str.h new file mode 100644 index 0000000..d082dca --- /dev/null +++ b/str.h @@ -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 0000000..1c07940 --- /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 0000000..11c48e2 --- /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 () { + 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 0000000..b592b59 --- /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 0000000..e5133a6 --- /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 0000000..2cfe311 --- /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 += '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 0000000..d796b69 --- /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 0000000..509454f --- /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 ( eq '') {print "ok 5\n";} else {print "not ok 5\n";} + +open(try, "/etc/termcap") || (die "Can't open /etc/termcap."); +if ( 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 0000000..51a7641 --- /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 0000000..769bec2 --- /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 0000000..96367e9 --- /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 0000000..2b4962f --- /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 0000000..585e27f --- /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 () { + 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 () { + 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 () { + 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 () { + 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 () { + 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 () { + 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 0000000..c459324 --- /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 0000000..ee7ad73 --- /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 \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 0000000..649103a --- /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 0000000..9bf1be2 --- /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 () { + $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 0000000..0364d19 --- /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 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 0000000..8282a3d --- /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 0000000..996986c --- /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 0000000..2a24530 --- /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 0000000..f183b14 --- /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 0000000..130b4c4 --- /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 = ; +$secondpos = tell; + +$x = 0; +while () { + 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 ) { 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 0000000..5972ac4 --- /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 0000000..6ad44ce --- /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 0000000..c86ea9c --- /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 0000000..7391e58 --- /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 0000000..b28dda6 --- /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 0000000..90fdae9 --- /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 0000000..8e91950 --- /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 0000000..328e470 --- /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 0000000..8a3a8b6 --- /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 0000000..6a54b19 --- /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 () { + (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 0000000..5d6dee3 --- /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 0000000..45dfcf7 --- /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 0000000..b358ad7 --- /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 0000000..f3555a6 --- /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 0000000..e0c90fa --- /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 0000000..7696803 --- /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 0000000..718a4d3 --- /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 0000000..a46ef78 --- /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 0000000..1013610 --- /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 0000000..01cbfbf --- /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 0000000..1c03c31 --- /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 0000000..e32e62b --- /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 0000000..988af49 --- /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 0000000..cb4e5c7 --- /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 0000000..c087c24 --- /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 0000000..e431be8 --- /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 0000000..1d92bac --- /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 0000000..3008da5 --- /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 0000000..b0b78f1 --- /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 + +#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; jMakefile <>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 0000000..35f8bbe --- /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 +#include +#include +#include +#include +#include +#include + +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 0000000..d367526 --- /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 +sets debugging flags. +.TP 5 +.B \-F +tells a2p that this awk script is always invoked with this -F switch. +.TP 5 +.B \-n +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 \- +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 \-, 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 +.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 0000000..15484d2 --- /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 0000000..8a1ad78 --- /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> 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 0000000..441bb43 --- /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 0000000..db32c4c --- /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 +#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; ihent_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 0000000..06d803a --- /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 0000000..6c50cd2 --- /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 () { + print head $_; + } + close head; + + print "#!/bin/perl\n\n"; + open(body,"cc -E /tmp/sperl2$$ |") || + do Die("Can't reopen temp file."); + while () { + /^# [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 0000000..6db8a8e --- /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 +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 +.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 0000000..5de045a --- /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 0000000..cbb0c77 --- /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 0000000..83adfc2 --- /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 + +#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> 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); + } +}