diff --git a/Changes b/Changes new file mode 100644 index 000000000000..c2f50c229be8 --- /dev/null +++ b/Changes @@ -0,0 +1,89 @@ +New regexp routines derived from Henry Spencer's. + Support for /(foo|bar)/. + Support for /(foo)*/ and /(foo)+/. + \s for whitespace, \S nonwhitespace + \d for digit, \D nondigit + +Local variables in blocks, subroutines and evals. + +Recursive subroutine calls are now supported. + +Array values may now be interpolated into lists: + unlink 'foo', 'bar', @trashcan, 'tmp'; + +File globbing via <*.foo>. + +Use of <> in array contexts returns the whole file or glob list: + unlink <*.foo>; + +New iterator for normal arrays, foreach, that allows both read and write: + foreach $elem ($array) { + $elem =~ s/foo/bar/; + } + +Ability to open pipe to a forked off script for secure pipes in setuid scripts. + +File inclusion via + do 'foo.pl'; + +More file tests, including -t to see if, for instance, stdin is +a terminal. File tests now behave in a more correct manner. You can do +file tests on filehandles as well as filenames. The special filetests +-T and -B test a file to see if it's text or binary. + +An eof can now be used on each file of the <> input for such purposes +as resetting the line numbers or appending to each file of an inplace edit. + +Assignments can now function as lvalues, so you can say things like + ($HOST = $host) =~ tr/a-z/A-Z/; + ($obj = $src) =~ s/\.c$/.o/; + +You can now do certain file operations with a variable which holds the name +of a filehandle, e.g. open(++$incl,$includefilename); $foo = <$incl>; + +You can now a subroutine indirectly through a scalar variable: + $which = 'xyz'; + do $which('foo'); # calls xyz + +Warnings are now available (with -w) on use of uninitialized variables and on +identifiers that are mentioned only once, and on reference to various +undefined things. + +The -S switch causes perl to search the PATH for the script so that you can say + eval "exec /usr/bin/perl -S $0 $*" + if $running_under_some_shell; + +Reset now resets arrays and associative arrays as well as string variables. + +Assigning off the end of an array now nulls out any intervening values. + +$#foo is now an lvalue. You can preallocate or truncate arrays, or recover +values lost to prior truncation. + +$#foo is now indexed to $[ properly. + +s/foo/bar/i optimization bug fixed. + +The $x = "...$x..."; bug is fixed. + +The @ary = (1); bug is now fixed. You can even say @ary = 1; + +$= now returns the correct value. + +Several of the larger files are now split into smaller pieces for easier +compilation. + +Pattern matches evaluated in an array context now return ($1, $2...). + +There is now a wait operator. + +There is now a sort operator. + +The requirement of parens around certain expressions when taking their value +has been lifted. In particular, you can say + $x = print "foo","bar"; + $x = unlink "foo","bar"; + chdir "foo" || die "Can't chdir to foo\n"; + +The manual is now not lying when it says that perl is generally faster than +sed. I hope. diff --git a/Configure b/Configure index 991f3bbae118..81be1407ddc1 100755 --- a/Configure +++ b/Configure @@ -8,14 +8,14 @@ # 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.1.6 88/02/02 11:20:07 root Exp $ +# $Header: Configure,v 2.0.1.1 88/06/28 16:24:02 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' +PATH='.:/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/local:/usr/lbin:/etc:/usr/new:/usr/new/bin:/usr/nbin' export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0; kill $$) if test ! -t 0; then @@ -34,6 +34,10 @@ if test ! -d ../UU; then cd UU fi +case "$1" in +-d) shift; fastread='yes';; +esac + d_eunice='' eunicefix='' define='' @@ -61,24 +65,38 @@ Mcc='' vi='' mailx='' mail='' +cpp='' Log='' Header='' bin='' cc='' contains='' -cpp='' +cppstdin='' cppminus='' d_bcopy='' d_charsprf='' d_crypt='' +d_dosuid='' +d_fchmod='' +d_fchown='' +d_getgrps='' d_index='' +d_killpg='' +d_memcpy='' +d_rename='' +d_setegid='' +d_seteuid='' +d_setrgid='' +d_setruid='' d_statblks='' d_stdstdio='' +d_strcspn='' d_strctcpy='' d_symlink='' d_tminsys='' d_vfork='' d_voidsig='' +gidtype='' libc='' libnm='' mallocsrc='' @@ -102,10 +120,11 @@ shsharp='' sharpbang='' startsh='' stdchar='' +uidtype='' voidflags='' defvoidused='' +privlib='' CONFIG='' - : set package name package=perl @@ -115,15 +134,28 @@ echo "Beginning of configuration questions for $package kit." echo " " define='define' -undef='/*undef' +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 + +: We must find out about Eunice early +eunicefix=':' +if test -f /etc/unixtovms; then + eunicefix=/etc/unixtovms +fi +if test -f /etc/unixtovms.exe; then + eunicefix=/etc/unixtovms.exe +fi + attrlist="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 mc300 mc500 mc700 sparc" -pth="/usr/ucb /bin /usr/bin /usr/local /usr/local/bin /usr/lbin /etc /usr/lib" +attrlist="$attrlist nsc32000 sinix xenix venix posix ansi M_XENIX" +attrlist="$attrlist $mc68k __STDC__" +pth="/usr/ucb /bin /usr/bin /usr/local /usr/local/bin /usr/lbin /etc /usr/lib /lib" +d_newshome="../../NeWS" defvoidused=7 : some greps do not return status, grrr. @@ -144,7 +176,7 @@ contains*) cat >contains <<'EOSS' grep "$1" "$2" >.greptmp && cat .greptmp && test -s .greptmp EOSS -chmod 755 contains +chmod +x contains esac : first determine how to suppress newline on echo command @@ -167,7 +199,10 @@ rm -f .echotmp : now set up to do reads with possible shell escape and default assignment cat <myread -ans='!' +case "\$fastread" in +yes) ans=''; echo " " ;; +*) ans='!';; +esac while expr "X\$ans" : "X!" >/dev/null; do read ans case "\$ans" in @@ -273,6 +308,10 @@ for dir in \$*; do if test -f \$dir/\$thing; then echo \$dir/\$thing exit 0 + elif test -f \$dir/\$thing.exe; then + : on Eunice apparently + echo \$dir/\$thing + exit 0 fi ;; esac @@ -280,7 +319,7 @@ done echo \$dflt exit 1 EOSC -chmod 755 loc +chmod +x loc $eunicefix loc loclist=" expr @@ -300,6 +339,7 @@ trylist=" test egrep Mcc +cpp " for file in $loclist; do xxx=`loc $file $file $pth` @@ -398,6 +438,12 @@ if test -f /lib/libc.a; then libc=/lib/libc.a else ans=`loc libc.a blurfl/dyick $libpth` + if test ! -f $ans; then + ans=`loc clib blurfl/dyick $libpth` + fi + if test ! -f $ans; then + ans=`loc libc blurfl/dyick $libpth` + fi if test -f $ans; then echo "Your C library is in $ans, of all places." libc=$ans @@ -423,17 +469,31 @@ EOM fi echo " " $echo $n "Extracting names from $libc for later perusal...$c" -if ar t $libc > libc.list; then +nm $libc 2>/dev/null | sed -n -e 's/^.* T _//p' -e 's/^.* T //p' > libc.list +if $contains '^printf$' libc.list >/dev/null 2>&1; 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?" + nm $libc 2>/dev/null | sed -n -e 's/^.* D _//p' -e 's/^.* D //p' > libc.list + if $contains '^printf$' libc.list >/dev/null 2>&1; then + echo "done" else - echo "That didn't work either. Giving up." - exit 1 + echo " " + echo "nm didn't seem to work right." + echo "Trying ar instead..." + rmlist="$rmlist libc.tmp" + if ar t $libc > libc.tmp; then + sed -e 's/\.o$//' < libc.tmp > libc.list + echo "Ok." + else + echo "ar didn't seem to work right." + echo "Maybe this is a Cray...trying bld instead..." + if bld t $libc | sed -e 's/.*\///' -e 's/\.o:.*$//' > libc.list; then + echo "Ok." + else + echo "That didn't work either. Giving up." + exit 1 + fi + fi fi fi rmlist="$rmlist libc.list" @@ -446,7 +506,7 @@ if $contains SIGTSTP /usr/include/signal.h >/dev/null 2>&1 ; then echo exit 0 >bsd echo exit 1 >usg echo exit 1 >v7 -elif $contains fcntl libc.list >/dev/null 2>&1 ; then +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 @@ -457,7 +517,7 @@ else echo exit 1 >usg echo exit 0 >v7 fi -if $contains vmssystem libc.list >/dev/null 2>&1 ; then +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. @@ -481,7 +541,8 @@ else echo "It's not Xenix..." echo "exit 1" >xenix fi -chmod 755 xenix +chmod +x xenix +$eunicefix xenix if test -f /venix; then echo "Actually, this looks more like a VENIX system..." echo "exit 0" >venix @@ -494,8 +555,8 @@ else fi echo "exit 1" >venix fi -chmod 755 bsd usg v7 eunice venix xenix -$eunicefix bsd usg v7 eunice venix xenix +chmod +x bsd usg v7 eunice venix +$eunicefix bsd usg v7 eunice venix rmlist="$rmlist bsd usg v7 eunice venix xenix" : see if sh knows # comments @@ -509,15 +570,15 @@ if sh -c '#' >/dev/null 2>&1 ; then echo "Okay, let's see if #! works on this system..." echo "#!/bin/echo hi" > try $eunicefix try - chmod 755 try + chmod +x try try > today - if test -s today; then + if $contains hi today >/dev/null 2>&1; then echo "It does." sharpbang='#!' else echo "#! /bin/echo hi" > try $eunicefix try - chmod 755 try + chmod +x try try > today if test -s today; then echo "It does." @@ -531,7 +592,7 @@ else echo "Your sh doesn't grok # comments--I will strip them later on." shsharp=false echo "exec grep -v '^#'" >spitshell - chmod 755 spitshell + chmod +x spitshell $eunicefix spitshell spitshell=`pwd`/spitshell echo "I presume that if # doesn't work, #! won't work either!" @@ -549,7 +610,7 @@ set abc test "$?abc" != 1 EOSS -chmod 755 try +chmod +x try $eunicefix try if try; then echo "Yup, it does." @@ -566,71 +627,71 @@ cat <<'EOT' >testcpp.c #define XYZ xyz ABC.XYZ EOT -echo 'Maybe "/lib/cpp" will work...' -/lib/cpp testcpp.out 2>&1 -if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then +echo 'Maybe "'$cpp'" will work...' +$cpp testcpp.out 2>&1 +if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, it does." - cpp='/lib/cpp' + cppstdin="$cpp" cppminus=''; else - echo 'Nope, maybe "/lib/cpp -" will work...' - /lib/cpp - testcpp.out 2>&1 - if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then + echo 'Nope, maybe "'$cpp' -" will work...' + $cpp - testcpp.out 2>&1 + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, it does." - cpp='/lib/cpp' + cppstdin="$cpp" cppminus='-'; else echo 'No such luck...maybe "cc -E" will work...' cc -E testcpp.out 2>&1 - if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "It works!" - cpp='cc -E' + cppstdin='cc -E' cppminus=''; else echo 'Nixed again...maybe "cc -E -" will work...' cc -E - testcpp.out 2>&1 - if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Hooray, it works! I was beginning to wonder." - cpp='cc -E' + cppstdin='cc -E' cppminus='-'; else echo 'Nope...maybe "cc -P" will work...' cc -P testcpp.out 2>&1 - if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, that does." - cpp='cc -P' + cppstdin='cc -P' cppminus=''; else echo 'Nope...maybe "cc -P -" will work...' cc -P - testcpp.out 2>&1 - if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, that does." - cpp='cc -P' + cppstdin='cc -P' cppminus='-'; else echo 'Hmm...perhaps you already told me...' - case "$cpp" in + case "$cppstdin" in '') ;; - *) $cpp $cppminus testcpp.out 2>&1;; + *) $cppstdin $cppminus testcpp.out 2>&1;; esac - if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Hooray, you did! I was beginning to wonder." else echo 'Uh-uh. Time to get fancy...' echo 'Trying (cat >/tmp/$$.c; cc -E /tmp/$$.c; rm /tmp/$$.c)' - cpp='(cat >/tmp/$$.c; cc -E /tmp/$$.c; rm /tmp/$$.c)' + cppstdin='(cat >/tmp/$$.c; cc -E /tmp/$$.c; rm /tmp/$$.c)' cppminus=''; - $cpp testcpp.out 2>&1 - if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then + $cppstdin testcpp.out 2>&1 + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Eureka!." else dflt=blurfl $echo $n "No dice. I can't find a C preprocessor. Name one: $c" rp='Name a C preprocessor:' . myread - cpp="$ans" - $cpp testcpp.out 2>&1 - if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then + cppstdin="$ans" + $cppstdin 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." @@ -648,7 +709,7 @@ rm -f testcpp.c testcpp.out : see if bcopy exists echo " " -if $contains bcopy libc.list >/dev/null 2>&1; then +if $contains '^bcopy$' libc.list >/dev/null 2>&1; then echo 'bcopy() found.' d_bcopy="$define" else @@ -658,17 +719,21 @@ fi : see if sprintf is declared as int or pointer to char echo " " -if $contains 'char.*sprintf' /usr/include/stdio.h >/dev/null 2>&1 ; then - echo "Your sprintf() returns (char*)." - d_charsprf="$define" -else +cat >.ucbsprf.c <<'EOF' +main() { char buf[10]; exit((unsigned long)sprintf(buf,"%s","foo") > 10L); } +EOF +if cc .ucbsprf.c -o .ucbsprf >/dev/null 2>&1 && .ucbsprf; then echo "Your sprintf() returns (int)." d_charsprf="$undef" +else + echo "Your sprintf() returns (char*)." + d_charsprf="$define" fi +/bin/rm -f .ucbsprf.c .ucbsprf : see if crypt exists echo " " -if $contains crypt libc.list >/dev/null 2>&1; then +if $contains '^crypt$' libc.list >/dev/null 2>&1; then echo 'crypt() found.' d_crypt="$define" else @@ -676,27 +741,165 @@ else d_crypt="$undef" fi +: now see if they want to do setuid emulation +case "$d_dosuid" in +'') if bsd; then + dflt=y + else + dflt=n + fi + ;; +*undef*) dflt=n;; +*) dflt=y;; +esac +cat </dev/null 2>&1; then + echo 'fchmod() found.' + d_fchmod="$define" +else + echo 'fchmod() not found.' + d_fchmod="$undef" +fi + +: see if fchown exists +echo " " +if $contains '^fchown$' libc.list >/dev/null 2>&1; then + echo 'fchown() found.' + d_fchown="$define" +else + echo 'fchown() not found.' + d_fchown="$undef" +fi + +: see if getgroups exists +echo " " +if $contains '^getgroups$' libc.list >/dev/null 2>&1; then + echo 'getgroups() found.' + d_getgrps="$define" +else + echo 'getgroups() not found.' + d_getgrps="$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 +case "$d_index" in +n) dflt=n;; +*) dflt=y;; +esac +if $contains '^index$' libc.list >/dev/null 2>&1 ; then + if $contains '^strchr$' libc.list >/dev/null 2>&1 ; then + echo "Your system has both index() and strchr(). Shall I use" + rp="index() rather than strchr()? [$dflt]" + $echo $n "$rp $c" + . myread + case "$ans" in + n*) d_index="$define" ;; + *) d_index="$undef" ;; + esac + else + d_index="$undef" + echo "index() found." + fi else - 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 + if $contains '^strchr$' libc.list >/dev/null 2>&1 ; then + d_index="$define" + echo "strchr() found." + else + echo "No index() or strchr() found!" + d_index="$undef" + fi +fi + +: see if killpg exists +echo " " +if $contains '^killpg$' libc.list >/dev/null 2>&1; then + echo 'killpg() found.' + d_killpg="$define" +else + echo 'killpg() not found.' + d_killpg="$undef" +fi + +: see if memcpy exists +echo " " +if $contains '^memcpy$' libc.list >/dev/null 2>&1; then + echo 'memcpy() found.' + d_memcpy="$define" +else + echo 'memcpy() not found.' + d_memcpy="$undef" +fi + +: see if rename exists +echo " " +if $contains '^rename$' libc.list >/dev/null 2>&1; then + echo 'rename() found.' + d_rename="$define" +else + echo 'rename() not found.' + d_rename="$undef" +fi + +: see if setegid exists +echo " " +if $contains '^setegid$' libc.list >/dev/null 2>&1; then + echo 'setegid() found.' + d_setegid="$define" +else + echo 'setegid() not found.' + d_setegid="$undef" +fi + +: see if seteuid exists +echo " " +if $contains '^seteuid$' libc.list >/dev/null 2>&1; then + echo 'seteuid() found.' + d_seteuid="$define" +else + echo 'seteuid() not found.' + d_seteuid="$undef" +fi + +: see if setrgid exists +echo " " +if $contains '^setrgid$' libc.list >/dev/null 2>&1; then + echo 'setrgid() found.' + d_setrgid="$define" +else + echo 'setrgid() not found.' + d_setrgid="$undef" +fi + +: see if setruid exists +echo " " +if $contains '^setruid$' libc.list >/dev/null 2>&1; then + echo 'setruid() found.' + d_setruid="$define" +else + echo 'setruid() not found.' + d_setruid="$undef" fi : see if stat knows about block sizes @@ -729,6 +932,16 @@ else d_stdstdio="$undef" fi +: see if strcspn exists +echo " " +if $contains '^strcspn$' libc.list >/dev/null 2>&1; then + echo 'strcspn() found.' + d_strcspn="$define" +else + echo 'strcspn() not found.' + d_strcspn="$undef" +fi + : check for structure copying echo " " echo "Checking to see if your C compiler can copy structs..." @@ -751,6 +964,16 @@ else fi $rm -f try.* +: see if symlink exists +echo " " +if $contains '^symlink$' libc.list >/dev/null 2>&1; then + echo 'symlink() found.' + d_symlink="$define" +else + echo 'symlink() not found.' + d_symlink="$undef" +fi + : see if struct tm is defined in sys/time.h echo " " if $contains 'struct tm' /usr/include/time.h >/dev/null 2>&1 ; then @@ -763,7 +986,7 @@ fi : see if there is a vfork echo " " -if $contains vfork libc.list >/dev/null 2>&1 ; then +if $contains '^vfork$' libc.list >/dev/null 2>&1 ; then echo "vfork() found." d_vfork="$undef" else @@ -801,13 +1024,13 @@ void main() { main() { #endif extern void *moo(); - void (*goo)(); + void *(*goo)(); #if TRY & 2 void (*foo[10])(); #endif #if TRY & 4 - if(goo == moo) { + if(*goo == moo) { exit(0); } #endif @@ -851,19 +1074,28 @@ $echo $n "$rp $c" voidflags="$ans" $rm -f try.* .out -: see what type of char stdio uses. +: see what type gids are declared as in the kernel +case "$gidtype" in +'') + if $contains 'gid_t;' /usr/include/sys/types.h >/dev/null 2>&1 ; then + dflt='gid_t'; + else + set `grep 'groups\[NGROUPS\];' /usr/include/sys/user.h 2>/dev/null` unsigned short + case $1 in + unsigned) dflt="$1 $2" ;; + *) dflt="$1" ;; + esac + fi + ;; +*) dflt="$gidtype" + ;; +esac +cont=true echo " " -if $contains 'unsigned.*char.*_ptr;' /usr/include/stdio.h >/dev/null 2>&1 ; then - echo "Your stdio uses unsigned chars." - stdchar="unsigned char" -else - echo "Your stdio uses signed chars." - stdchar="char" -fi - -: preserve RCS keywords in files with variable substitution, grrr -Log='$Log' -Header='$Header' +rp="What type are group ids on this system declared as? [$dflt]" +$echo $n "$rp $c" +. myread +gidtype="$ans" : set up shell script to do ~ expansion cat >filexp </dev/null 2>&1 ; then + echo "Your stdio uses unsigned chars." + stdchar="unsigned char" +else + echo "Your stdio uses signed chars." + stdchar="char" +fi + +: see what type uids are declared as in the kernel +case "$uidtype" in +'') + if $contains 'uid_t;' /usr/include/sys/types.h >/dev/null 2>&1 ; then + dflt='uid_t'; + else + set `grep '_ruid;' /usr/include/sys/user.h 2>/dev/null` unsigned short + case $1 in + unsigned) dflt="$1 $2" ;; + *) dflt="$1" ;; + esac + fi + ;; +*) dflt="$uidtype" + ;; +esac +cont=true +echo " " +rp="What type are user ids on this system declared as? [$dflt]" +$echo $n "$rp $c" +. myread +uidtype="$ans" + +: preserve RCS keywords in files with variable substitution, grrr +Log='$Log' +Header='$Header' + : determine where public executables go case "$bin" in '') @@ -968,6 +1256,9 @@ case "$mansrc" in *n) manext=n ;; +*C) + manext=C + ;; *) manext=1 ;; @@ -1008,7 +1299,7 @@ exit 0; _ _ _ _\1\\ \1\\ #endif\\ /' >/tmp/Cppsym\$\$ echo exit 1 >>/tmp/Cppsym\$\$ -$cpp $cppminus /tmp/Cppsym2\$\$ +$cppstdin $cppminus /tmp/Cppsym2\$\$ case "\$list" in true) awk 'NF > 5 {print substr(\$6,2,100)}' Cppsym.true @@ -1082,8 +1373,8 @@ none) *split) case "$split" in '') - if $contains '-i' $mansrc/ld.1 >/dev/null 2>&1 || \ - $contains '-i' $mansrc/cc.1 >/dev/null 2>&1; then + if $contains '\-i' $mansrc/ld.1 >/dev/null 2>&1 || \ + $contains '\-i' $mansrc/cc.1 >/dev/null 2>&1; then dflt='-i' else dflt='none' @@ -1245,16 +1536,6 @@ else cc=cc fi -: see if symlink exists -echo " " -if $contains symlink libc.list >/dev/null 2>&1; then - echo 'symlink() found.' - d_symlink="$define" -else - echo 'symlink() not found.' - d_symlink="$undef" -fi - : see if we should include -lnm echo " " if $test -r /usr/lib/libnm.a || $test -r /usr/local/lib/libnm.a ; then @@ -1341,24 +1622,38 @@ Mcc='$Mcc' vi='$vi' mailx='$mailx' mail='$mail' +cpp='$cpp' Log='$Log' Header='$Header' bin='$bin' cc='$cc' contains='$contains' -cpp='$cpp' +cppstdin='$cppstdin' cppminus='$cppminus' d_bcopy='$d_bcopy' d_charsprf='$d_charsprf' d_crypt='$d_crypt' +d_dosuid='$d_dosuid' +d_fchmod='$d_fchmod' +d_fchown='$d_fchown' +d_getgrps='$d_getgrps' d_index='$d_index' +d_killpg='$d_killpg' +d_memcpy='$d_memcpy' +d_rename='$d_rename' +d_setegid='$d_setegid' +d_seteuid='$d_seteuid' +d_setrgid='$d_setrgid' +d_setruid='$d_setruid' d_statblks='$d_statblks' d_stdstdio='$d_stdstdio' +d_strcspn='$d_strcspn' d_strctcpy='$d_strctcpy' d_symlink='$d_symlink' d_tminsys='$d_tminsys' d_vfork='$d_vfork' d_voidsig='$d_voidsig' +gidtype='$gidtype' libc='$libc' libnm='$libnm' mallocsrc='$mallocsrc' @@ -1382,15 +1677,18 @@ shsharp='$shsharp' sharpbang='$sharpbang' startsh='$startsh' stdchar='$stdchar' +uidtype='$uidtype' voidflags='$voidflags' defvoidused='$defvoidused' +privlib='$privlib' CONFIG=true EOT - + CONFIG=true echo " " dflt='' +fastread='' echo "If you didn't make any mistakes, then just type a carriage return here." rp="If you need to edit config.sh, do it as a shell escape here:" $echo $n "$rp $c" @@ -1400,6 +1698,7 @@ case "$ans" in *) : in case they cannot read eval $ans;; esac +. ./config.sh echo " " echo "Doing variable substitutions on .SH files..." @@ -1457,5 +1756,8 @@ else fi $rm -f kit*isdone +: the following is currently useless cd UU && $rm -f $rmlist +: since this removes it all anyway +cd .. && $rm -rf UU : end of Configure diff --git a/EXTERN.h b/EXTERN.h index a5fff1f74e39..793da6d1e354 100644 --- a/EXTERN.h +++ b/EXTERN.h @@ -1,8 +1,8 @@ -/* $Header: EXTERN.h,v 1.0 87/12/18 13:02:26 root Exp $ +/* $Header: EXTERN.h,v 2.0 88/06/05 00:07:46 root Exp $ * * $Log: EXTERN.h,v $ - * Revision 1.0 87/12/18 13:02:26 root - * Initial revision + * Revision 2.0 88/06/05 00:07:46 root + * Baseline version 2.0. * */ diff --git a/INTERN.h b/INTERN.h index 06a59f0e7133..a070e5345ecc 100644 --- a/INTERN.h +++ b/INTERN.h @@ -1,8 +1,8 @@ -/* $Header: INTERN.h,v 1.0 87/12/18 13:02:39 root Exp $ +/* $Header: INTERN.h,v 2.0 88/06/05 00:07:49 root Exp $ * * $Log: INTERN.h,v $ - * Revision 1.0 87/12/18 13:02:39 root - * Initial revision + * Revision 2.0 88/06/05 00:07:49 root + * Baseline version 2.0. * */ diff --git a/MANIFEST b/MANIFEST index 085b831183be..39abd2a5df69 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2,111 +2,154 @@ 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 +Changes 13 Differences between 1.0 level 29 and 2.0 level 0 +Configure 6 Run this first +EXTERN.h 6 Included before foreign .h files +INTERN.h 15 Included before domestic .h files +MANIFEST 11 This list of files +Makefile.SH 13 Precursor to Makefile +README 1 The Instructions +Wishlist 4 Some things that may or may not happen +arg.c 1 Expression evaluation +arg.h 12 Public declarations for the above +array.c 13 Numerically subscripted arrays +array.h 15 Public declarations for the above +cmd.c 10 Command interpreter +cmd.h 13 Public declarations for the above +config.H 13 Sample config.h +config.h.SH 11 Produces config.h. +dump.c 12 Debugging output +eg/ADB 15 An adb wrapper to put in your crash dir +eg/README 1 Intro to example perl scripts +eg/changes 15 A program to list recently changed files +eg/dus 15 A program to do du -s on non-mounted dirs +eg/findcp 14 A find wrapper that implements a -cp switch +eg/findtar 15 A find wrapper that pumps out a tar file +eg/g/gcp 14 A program to do a global rcp +eg/g/gcp.man 14 Manual page for gcp +eg/g/ged 1 A program to do a global edit +eg/g/ghosts 15 A sample /etc/ghosts file +eg/g/gsh 10 A program to do a global rsh +eg/g/gsh.man 14 Manual page for gsh +eg/myrup 15 A program to find lightly loaded machines +eg/nih 15 Script to insert #! workaround +eg/rmfrom 15 A program to feed doomed filenames to +eg/scan/scan_df 14 Scan for filesystem anomalies +eg/scan/scan_last 14 Scan for login anomalies +eg/scan/scan_messages 13 Scan for console message anomalies +eg/scan/scan_passwd 15 Scan for passwd file anomalies +eg/scan/scan_ps 15 Scan for process anomalies +eg/scan/scan_sudo 14 Scan for sudo anomalies +eg/scan/scan_suid 8 Scan for setuid anomalies +eg/scan/scanner 14 An anomaly reporter +eg/shmkill 15 A program to remove unused shared memory +eg/van/empty 15 A program to empty the trashcan +eg/van/unvanish 14 A program to undo what vanish does +eg/van/vanexp 15 A program to expire vanished files +eg/van/vanish 14 A program to put files in a trashcan +eval.c 8 The expression evaluator +form.c 12 Format processing +form.h 15 Public declarations for the above +handy.h 15 Handy definitions +hash.c 12 Associative arrays +hash.h 14 Public declarations for the above +lib/getopt.pl 14 Perl library supporting option parsing +lib/importenv.pl 15 Perl routine to get environment into variables. +lib/stat.pl 15 Perl library supporting stat function +makedepend.SH 5 Precursor to makedepend +makedir.SH 14 Precursor to makedir +malloc.c 11 A version of malloc you might not want +patchlevel.h 12 The current patch level of perl +perl.h 12 Global declarations +perl.man.1 5 The manual page(s), first half +perl.man.2 3 The manual page(s), second half +perl.y 10 Yacc grammar for perl +perldb 11 Perl symbolic debugger +perldb.man 13 Manual page for perl debugger +perlsh 15 A poor man's perl shell. +perly.c 4 The perl compiler +regexp.c 2 String matching +regexp.h 14 Public declarations for the above +spat.h 14 Search pattern declarations +stab.c 6 Symbol table stuff +stab.h 3 Public declarations for the above +str.c 7 String handling package +str.h 14 Public declarations for the above +t/README 1 Instructions for regression tests +t/TEST 14 The regression tester +t/base.cond 15 See if conditionals work +t/base.if 15 See if if works +t/base.lex 15 See if lexical items work +t/base.pat 15 See if pattern matching works +t/base.term 15 See if various terms work +t/cmd.elsif 15 See if else-if works +t/cmd.for 15 See if for loops work +t/cmd.mod 15 See if statement modifiers work +t/cmd.subval 14 See if subroutine values work +t/cmd.while 14 See if while loops work +t/comp.cmdopt 13 See if command optimization works +t/comp.cpp 15 See if C preprocessor works +t/comp.decl 15 See if declarations work +t/comp.multiline 15 See if multiline strings work +t/comp.script 14 See if script invokation works +t/comp.term 15 See if more terms work +t/io.argv 15 See if ARGV stuff works +t/io.dup 15 See if >& works right +t/io.fs 12 See if directory manipulations work +t/io.inplace 15 See if inplace editing works +t/io.pipe 15 See if secure pipes work +t/io.print 15 See if print commands work +t/io.tell 13 See if file seeking works +t/op.append 15 See if . works +t/op.auto 14 See if autoincrement et all work +t/op.chop 15 See if chop works +t/op.cond 5 See if conditional expressions work +t/op.delete 15 See if delete works +t/op.do 14 See if subroutines work +t/op.each 14 See if associative iterators work +t/op.eval 14 See if eval operator works +t/op.exec 15 See if exec and system work +t/op.exp 15 See if math functions work +t/op.flip 15 See if range operator works +t/op.fork 15 See if fork works +t/op.goto 15 See if goto works +t/op.int 15 See if int works +t/op.join 15 See if join works +t/op.list 14 See if array lists work +t/op.magic 15 See if magic variables work +t/op.oct 15 See if oct and hex work +t/op.ord 15 See if ord works +t/op.pat 14 See if esoteric patterns work +t/op.push 15 See if push and pop work +t/op.regexp 15 See if regular expressions work +t/op.repeat 15 See if x operator works +t/op.sleep 15 See if sleep works +t/op.split 7 See if split works +t/op.sprintf 15 See if sprintf works +t/op.stat 11 See if stat works +t/op.study 14 See if study works +t/op.subst 14 See if substitutions work +t/op.time 14 See if time functions work +t/op.unshift 15 See if unshift works +t/re_tests 13 Input file for op.regexp +toke.c 9 The tokener +util.c 8 Utility routines +util.h 15 Public declarations for the above +version.c 15 Prints version of perl +x2p/EXTERN.h 15 Same as above +x2p/INTERN.h 15 Same as above +x2p/Makefile.SH 4 Precursor to Makefile +x2p/a2p.h 13 Global declarations +x2p/a2p.man 12 Manual page for awk to perl translator +x2p/a2p.y 12 A yacc grammer for awk +x2p/a2py.c 9 Awk compiler, sort of +x2p/handy.h 15 Handy definitions +x2p/hash.c 13 Associative arrays again +x2p/hash.h 14 Public declarations for the above +x2p/s2p 10 Sed to perl translator +x2p/s2p.man 9 Manual page for sed to perl translator +x2p/str.c 11 String handling package +x2p/str.h 15 Public declarations for the above +x2p/util.c 13 Utility routines +x2p/util.h 15 Public declarations for the above +x2p/walk.c 7 Parse tree walker diff --git a/Makefile.SH b/Makefile.SH index 884539653919..931a3af78c85 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -6,7 +6,7 @@ case $CONFIG in ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) fi - . config.sh + . ./config.sh ;; esac case "$0" in @@ -18,33 +18,28 @@ case "$d_symlink" in *) sln='ln';; esac +case "$d_dosuid" in +*define*) suidperl='suidperl' ;; +*) suidperl='';; +esac + echo "Extracting Makefile (with variable substitutions)" cat >Makefile <>Makefile <<'!NO!SUBS!' +public = perl perldb $suidperl -public = perl perldb +!GROK!THIS! +cat >>Makefile <<'!NO!SUBS!' private = manpages = perl.man perldb.man @@ -71,17 +66,17 @@ 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 +h2 = hash.h perl.h regexp.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 $(mallocsrc) -c2 = search.c stab.c str.c util.c version.c +c1 = arg.c array.c cmd.c dump.c eval.c form.c hash.c $(mallocsrc) +c2 = perly.c regexp.c stab.c str.c toke.c util.c version.c c = $(c1) $(c2) -obj1 = arg.o array.o cmd.o dump.o form.o hash.o $(mallocobj) -obj2 = search.o stab.o str.o util.o version.o +obj1 = arg.o array.o cmd.o dump.o eval.o form.o hash.o $(mallocobj) +obj2 = regexp.o stab.o str.o toke.o util.o version.o obj = $(obj1) $(obj2) @@ -98,15 +93,36 @@ SHELL = /bin/sh all: $(public) $(private) $(util) touch all -perl: $(obj) perl.o - $(CC) $(LDFLAGS) $(LARGE) $(obj) perl.o $(libs) -o perl +perl: perly.o $(obj) perl.o + $(CC) $(LDFLAGS) $(LARGE) perly.o $(obj) perl.o $(libs) -o perl + +!NO!SUBS! -perl.c: perl.y - @ echo Expect 2 shift/reduce errors... - yacc perl.y +case "$d_dosuid" in +*define*) + cat >>Makefile <<'!NO!SUBS!' + +suidperl: sperly.o $(obj) perl.o + $(CC) $(LDFLAGS) $(LARGE) sperly.o $(obj) perl.o $(libs) -o suidperl + +sperly.o: perly.c + /bin/rm -f sperly.c + ln perly.c sperly.c + $(CC) -c -DIAMSUID $(CFLAGS) $(LARGE) sperly.c + /bin/rm -f sperly.c +!NO!SUBS! + ;; +esac + +cat >>Makefile <<'!NO!SUBS!' + +perl.c perly.h: perl.y + @ echo Expect 37 shift/reduce errors... + yacc -d perl.y mv y.tab.c perl.c + mv y.tab.h perly.h -perl.o: perl.c perly.c perl.h EXTERN.h search.h util.h INTERN.h handy.h +perl.o: perl.c perly.h perl.h EXTERN.h regexp.h util.h INTERN.h handy.h config.h $(CC) -c $(CFLAGS) $(LARGE) perl.c # if a .h file depends on another .h file... @@ -119,23 +135,34 @@ perl.man: perl.man.1 perl.man.2 install: perl perl.man # won't work with csh export PATH || exit 1 - - mv $(bin)/perl $(bin)/perl.old + - mv $(bin)/perl $(bin)/perl.old 2>/dev/null - if test `pwd` != $(bin); then cp $(public) $(bin); fi - cd $(bin); \ + - cd $(bin); \ for pub in $(public); do \ -chmod 755 `basename $$pub`; \ +chmod +x `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)`; \ +!NO!SUBS! + +case "$d_dosuid" in +*define*) + cat >>Makefile <<'!NO!SUBS!' + - chmod 4711 $(bin)/suidperl 2>/dev/null +!NO!SUBS! + ;; +esac + +cat >>Makefile <<'!NO!SUBS!' + - test $(bin) = /usr/bin || rm -f /usr/bin/perl + - test $(bin) = /usr/bin || $(SLN) $(bin)/perl /usr/bin || cp $(bin)/perl /usr/bin + chmod +x makedir + - ./makedir $(lib) + - \ +if test `pwd` != $(lib); then \ +cp $(private) lib/*.pl $(lib); \ +fi +# cd $(lib); \ #for priv in $(private); do \ -#chmod 755 `basename $$priv`; \ +#chmod +x `basename $$priv`; \ #done - if test `pwd` != $(mansrc); then \ for page in $(manpages); do \ @@ -147,21 +174,23 @@ clean: rm -f *.o realclean: - rm -f perl *.orig */*.orig *.o core $(addedbyconf) + 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 +lint: perl.c $(c) + lint $(lintflags) $(defs) perl.c $(c) > perl.fuzz depend: makedepend + - test -f perly.h || cp /dev/null perly.h ./makedepend + - test -s perly.h || /bin/rm -f perly.h test: perl - chmod 755 t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.* + chmod +x t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.* cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST clist: @@ -174,7 +203,7 @@ shlist: echo $(sh) | tr ' ' '\012' >.shlist # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE -$(obj): +perly.o $(obj): @ echo "You haven't done a "'"make depend" yet!'; exit 1 makedepend: makedepend.SH /bin/sh makedepend.SH diff --git a/README b/README index b5d95e17766a..0fb953aec063 100644 --- a/README +++ b/README @@ -1,7 +1,7 @@ - Perl Kit, Version 1.0 + Perl Kit, Version 2.0 - Copyright (c) 1987, Larry Wall + Copyright (c) 1988, 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. @@ -52,7 +52,9 @@ Installation 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. + See the README in the t subdirectory. Note that you can't run it + in background if this disables opening of /dev/tty. If in doubt, just + cd to the t directory and run TEST by hand. 6) make install diff --git a/Wishlist b/Wishlist index 1233293f8467..04e757db53fe 100644 --- a/Wishlist +++ b/Wishlist @@ -2,4 +2,3 @@ date support case statement ioctl() support random numbers -directory reading via <> diff --git a/arg.c b/arg.c index 74da53c1da5c..4cdb88936772 100644 --- a/arg.c +++ b/arg.c @@ -1,112 +1,168 @@ -/* $Header: arg.c,v 1.0.1.7 88/02/02 11:22:19 root Exp $ +/* $Header: arg.c,v 2.0 88/06/05 00:08:04 root Exp $ * * $Log: arg.c,v $ - * Revision 1.0.1.7 88/02/02 11:22:19 root - * patch13: fixed split(' ') to work right second time. Added CRYPT dependency. - * - * Revision 1.0.1.6 88/02/01 17:32:26 root - * patch12: made split(' ') behave like awk in ignoring leading white space. - * - * Revision 1.0.1.5 88/01/30 08:53:16 root - * patch9: fixed some missing right parens introduced (?) by patch 2 - * - * Revision 1.0.1.4 88/01/28 10:22:06 root - * patch8: added eval operator. - * - * Revision 1.0.1.2 88/01/24 03:52:34 root - * patch 2: added STATBLKS dependencies. - * - * Revision 1.0.1.1 88/01/21 21:27:10 root - * Now defines signal return values correctly using VOIDSIG. - * - * Revision 1.0 87/12/18 13:04:33 root - * Initial revision + * Revision 2.0 88/06/05 00:08:04 root + * Baseline version 2.0. * */ -#include -#include "handy.h" #include "EXTERN.h" -#include "search.h" -#include "util.h" #include "perl.h" -ARG *debarg; +#include +#include + +extern int errno; -bool -do_match(s,arg) -register char *s; +STR * +do_match(arg,retary,sarg,ptrmaxsarg,sargoff,cushion) register ARG *arg; +STR ***retary; +register STR **sarg; +int *ptrmaxsarg; +int sargoff; +int cushion; { register SPAT *spat = arg[2].arg_ptr.arg_spat; - register char *d; register char *t; + register char *s = str_get(sarg[1]); + char *strend = s + sarg[1]->str_cur; - if (!spat || !s) - fatal("panic: do_match\n"); + if (!spat) + return &str_yes; + if (!s) + fatal("panic: do_match"); + if (retary) { + *retary = sarg; /* assume no match */ + *ptrmaxsarg = sargoff; + } if (spat->spat_flags & SPAT_USED) { #ifdef DEBUGGING if (debug & 8) deb("2.SPAT USED\n"); #endif - return FALSE; + return &str_no; } if (spat->spat_runtime) { - t = str_get(eval(spat->spat_runtime,Null(STR***))); + t = str_get(eval(spat->spat_runtime,Null(STR***),-1)); #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) + spat->spat_regexp = regcomp(t,spat->spat_flags & SPAT_FOLD,1); + if (!*spat->spat_regexp->precomp && lastspat) + spat = lastspat; + if (regexec(spat->spat_regexp, s, strend, TRUE, 0, + sarg[1]->str_pok & 4 ? sarg[1] : Nullstr)) { + if (spat->spat_regexp->subbase) curspat = spat; - return TRUE; + lastspat = spat; + goto gotcha; } else - return FALSE; + return &str_no; } else { #ifdef DEBUGGING if (debug & 8) { char ch; - if (spat->spat_flags & SPAT_USE_ONCE) + if (spat->spat_flags & SPAT_ONCE) ch = '?'; else ch = '/'; - deb("2.SPAT %c%s%c\n",ch,spat->spat_compex.precomp,ch); + deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch); } #endif - if (spat->spat_compex.complen <= 1 && curspat) - spat = curspat; - if (spat->spat_first) { + if (!*spat->spat_regexp->precomp && lastspat) + spat = lastspat; + t = s; + if (hint) { + if (hint < s || hint > strend) + fatal("panic: hint in do_match"); + s = hint; + hint = Nullch; + if (spat->spat_regexp->regback >= 0) { + s -= spat->spat_regexp->regback; + if (s < t) + s = t; + } + else + s = t; + } + else if (spat->spat_short) { if (spat->spat_flags & SPAT_SCANFIRST) { - str_free(spat->spat_first); - spat->spat_first = Nullstr; /* disable optimization */ + if (sarg[1]->str_pok == 5) { + if (screamfirst[spat->spat_short->str_rare] < 0) + goto nope; + else if (!(s = screaminstr(sarg[1],spat->spat_short))) + goto nope; + else if (spat->spat_flags & SPAT_ALL) + goto yup; + } + else if (!(s = fbminstr(s, strend, spat->spat_short))) + goto nope; + else if (spat->spat_flags & SPAT_ALL) + goto yup; + else if (spat->spat_regexp->regback >= 0) { + ++*(long*)&spat->spat_short->str_nval; + s -= spat->spat_regexp->regback; + if (s < t) + s = t; + } + else + s = t; + } + else if (!multiline && (*spat->spat_short->str_ptr != *s || + strnNE(spat->spat_short->str_ptr, s, spat->spat_slen) )) + goto nope; + if (--*(long*)&spat->spat_short->str_nval < 0) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; /* opt is being useless */ } - 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) + if (regexec(spat->spat_regexp, s, strend, s == t, 0, + sarg[1]->str_pok & 4 ? sarg[1] : Nullstr)) { + if (spat->spat_regexp->subbase) curspat = spat; - if (spat->spat_flags & SPAT_USE_ONCE) + lastspat = spat; + if (spat->spat_flags & SPAT_ONCE) spat->spat_flags |= SPAT_USED; - return TRUE; + goto gotcha; } else - return FALSE; + return &str_no; } /*NOTREACHED*/ + + gotcha: + if (retary && curspat == spat) { + int iters, i, len; + + iters = spat->spat_regexp->nparens; + *ptrmaxsarg = iters + sargoff; + sarg = (STR**)saferealloc((char*)(sarg - sargoff), + (iters+2+cushion+sargoff)*sizeof(STR*)) + sargoff; + + for (i = 1; i <= iters; i++) { + sarg[i] = str_static(&str_no); + if (s = spat->spat_regexp->startp[i]) { + len = spat->spat_regexp->endp[i] - s; + if (len > 0) + str_nset(sarg[i],s,len); + } + } + *retary = sarg; + } + return &str_yes; + +yup: + ++*(long*)&spat->spat_short->str_nval; + return &str_yes; + +nope: + ++*(long*)&spat->spat_short->str_nval; + return &str_no; } int @@ -116,63 +172,96 @@ register ARG *arg; { register SPAT *spat; register STR *dstr; - register char *s; + register char *s = str_get(str); + char *strend = s + str->str_cur; register char *m; spat = arg[2].arg_ptr.arg_spat; - s = str_get(str); if (!spat || !s) - fatal("panic: do_subst\n"); + fatal("panic: do_subst"); 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; - } + m = str_get(eval(spat->spat_runtime,Null(STR***),-1)); + spat->spat_regexp = regcomp(m,spat->spat_flags & SPAT_FOLD,1); } #ifdef DEBUGGING if (debug & 8) { - deb("2.SPAT /%s/\n",spat->spat_compex.precomp); + deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); } #endif - if (spat->spat_compex.complen <= 1 && curspat) - spat = curspat; - if (spat->spat_first) { + if (!*spat->spat_regexp->precomp && lastspat) + spat = lastspat; + m = s; + if (hint) { + if (hint < s || hint > strend) + fatal("panic: hint in do_match"); + s = hint; + hint = Nullch; + if (spat->spat_regexp->regback >= 0) { + s -= spat->spat_regexp->regback; + if (s < m) + s = m; + } + else + s = m; + } + else if (spat->spat_short) { if (spat->spat_flags & SPAT_SCANFIRST) { - str_free(spat->spat_first); - spat->spat_first = Nullstr; /* disable optimization */ + if (str->str_pok == 5) { + if (screamfirst[spat->spat_short->str_rare] < 0) + goto nope; + else if (!(s = screaminstr(str,spat->spat_short))) + goto nope; + } + else if (!(s = fbminstr(s, strend, spat->spat_short))) + goto nope; + else if (spat->spat_regexp->regback >= 0) { + ++*(long*)&spat->spat_short->str_nval; + s -= spat->spat_regexp->regback; + if (s < m) + s = m; + } + else + s = m; + } + else if (!multiline && (*spat->spat_short->str_ptr != *s || + strnNE(spat->spat_short->str_ptr, s, spat->spat_slen) )) + goto nope; + if (--*(long*)&spat->spat_short->str_nval < 0) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; /* opt is being useless */ } - 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)) { + if (regexec(spat->spat_regexp, s, strend, s == m, 1, + str->str_pok & 4 ? str : Nullstr)) { int iters = 0; dstr = str_new(str_len(str)); - if (spat->spat_compex.numsubs) + str_nset(dstr,m,s-m); + if (spat->spat_regexp->subbase) curspat = spat; + lastspat = spat; do { + m = spat->spat_regexp->startp[0]; if (iters++ > 10000) - fatal("Substitution loop?\n"); - if (spat->spat_compex.numsubs) - s = spat->spat_compex.subbase; + fatal("Substitution loop"); + if (spat->spat_regexp->subbase) + s = spat->spat_regexp->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) + s = spat->spat_regexp->endp[0]; + str_scat(dstr,eval(spat->spat_repl,Null(STR***),-1)); + if (spat->spat_flags & SPAT_ONCE) break; - } while (m = execute(&spat->spat_compex, s, FALSE, 1)); + } while (regexec(spat->spat_regexp, s, strend, FALSE, 1, Nullstr)); str_cat(dstr,s); str_replace(str,dstr); STABSET(str); return iters; } return 0; + +nope: + ++*(long*)&spat->spat_short->str_nval; + return 0; } int @@ -188,7 +277,7 @@ register ARG *arg; tbl = arg[2].arg_ptr.arg_cval; s = str_get(str); if (!tbl || !s) - fatal("panic: do_trans\n"); + fatal("panic: do_trans"); #ifdef DEBUGGING if (debug & 8) { deb("2.TBL\n"); @@ -206,28 +295,29 @@ register ARG *arg; } int -do_split(s,spat,retary) -register char *s; +do_split(spat,retary,sarg,ptrmaxsarg,sargoff,cushion) register SPAT *spat; STR ***retary; +register STR **sarg; +int *ptrmaxsarg; +int sargoff; +int cushion; { + register char *s = str_get(sarg[1]); + char *strend = s + sarg[1]->str_cur; 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"); + fatal("panic: do_split"); else if (spat->spat_runtime) { - char *d; - - m = str_get(eval(spat->spat_runtime,Null(STR***))); + m = str_get(eval(spat->spat_runtime,Null(STR***),-1)); if (!*m || (*m == ' ' && !m[1])) { - m = "[ \\t\\n]+"; + m = "\\s+"; spat->spat_flags |= SPAT_SKIPWHITE; } if (spat->spat_runtime->arg_type == O_ITEM && @@ -235,16 +325,11 @@ STR ***retary; arg_free(spat->spat_runtime); /* it won't change, so */ spat->spat_runtime = Nullarg; /* no point compiling again */ } - if (d = compile(&spat->spat_compex,m,TRUE,FALSE)) { -#ifdef DEBUGGING - deb("/%s/: %s\n", m, d); -#endif - return FALSE; - } + spat->spat_regexp = regcomp(m,spat->spat_flags & SPAT_FOLD,1); } #ifdef DEBUGGING if (debug & 8) { - deb("2.SPAT /%s/\n",spat->spat_compex.precomp); + deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); } #endif if (retary) @@ -252,21 +337,36 @@ STR ***retary; else ary = spat->spat_repl[1].arg_ptr.arg_stab->stab_array; if (!ary) - myarray = ary = anew(); + myarray = ary = anew(Nullstab); ary->ary_fill = -1; if (spat->spat_flags & SPAT_SKIPWHITE) { while (isspace(*s)) s++; } - 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 (spat->spat_short) { + i = spat->spat_short->str_cur; + while (*s && (m = fbminstr(s, strend, spat->spat_short))) { + dstr = str_new(m-s); + str_nset(dstr,s,m-s); + astore(ary, iters++, dstr); + if (iters > 10000) + fatal("Substitution loop"); + s = m + i; + } + } + else { + while (*s && regexec(spat->spat_regexp, s, strend, (iters == 0), 1, + Nullstr)) { + m = spat->spat_regexp->startp[0]; + if (spat->spat_regexp->subbase) + s = spat->spat_regexp->subbase; + dstr = str_new(m-s); + str_nset(dstr,s,m-s); + astore(ary, iters++, dstr); + if (iters > 10000) + fatal("Substitution loop"); + s = spat->spat_regexp->endp[0]; + } } if (*s) { /* ignore field after final "whitespace" */ dstr = str_new(0); /* if they interpolate, it's null anyway */ @@ -278,10 +378,10 @@ STR ***retary; iters--; } if (retary) { - sarg = (STR**)safemalloc((iters+2)*sizeof(STR*)); + *ptrmaxsarg = iters + sargoff; + sarg = (STR**)saferealloc((char*)(sarg - sargoff), + (iters+2+cushion+sargoff)*sizeof(STR*)) + sargoff; - sarg[0] = Nullstr; - sarg[iters+1] = Nullstr; for (i = 1; i <= iters; i++) sarg[i] = afetch(ary,i-1); *retary = sarg; @@ -297,12 +397,14 @@ register STR *str; { STR **tmpary; /* must not be register */ register STR **elem; + register int items; - (void)eval(arg[2].arg_ptr.arg_arg,&tmpary); + (void)eval(arg[2].arg_ptr.arg_arg,&tmpary,-1); + items = (int)str_gnum(*tmpary); elem = tmpary+1; - if (*elem) - str_sset(str,*elem++); - for (; *elem; elem++) { + if (items-- > 0) + str_sset(str,*elem++); + for (; items > 0; items--,elem++) { str_cat(str,delim); str_scat(str,*elem); } @@ -310,6 +412,49 @@ register STR *str; safefree((char*)tmpary); } +FILE * +forkopen(name,mode) +char *name; +char *mode; +{ + int pfd[2]; + + if (pipe(pfd) < 0) + return Nullfp; + while ((forkprocess = fork()) == -1) { + if (errno != EAGAIN) + return Nullfp; + sleep(5); + } + if (*mode == 'w') { + if (forkprocess) { + close(pfd[0]); + return fdopen(pfd[1],"w"); + } + else { + close(pfd[1]); + close(0); + dup(pfd[0]); /* substitute our pipe for stdin */ + close(pfd[0]); + return Nullfp; + } + } + else { + if (forkprocess) { + close(pfd[1]); + return fdopen(pfd[0],"r"); + } + else { + close(pfd[0]); + close(1); + if (dup(pfd[1]) == 0) + dup(pfd[1]); /* substitute our pipe for stdout */ + close(pfd[1]); + return Nullfp; + } + } +} + bool do_open(stab,name) STAB *stab; @@ -318,27 +463,61 @@ register char *name; FILE *fp; int len = strlen(name); register STIO *stio = stab->stab_io; + char *myname = savestr(name); + int result; + int fd; + name = myname; + forkprocess = 1; /* assume true if no fork */ while (len && isspace(name[len-1])) name[--len] = '\0'; if (!stio) stio = stab->stab_io = stio_new(); if (stio->fp) { + fd = fileno(stio->fp); if (stio->type == '|') - pclose(stio->fp); + result = pclose(stio->fp); else if (stio->type != '-') - fclose(stio->fp); + result = fclose(stio->fp); + else + result = 0; + if (result == EOF && fd > 2) + fprintf(stderr,"Warning: unable to close filehandle %s properly.\n", + stab->stab_name); stio->fp = Nullfp; } stio->type = *name; if (*name == '|') { for (name++; isspace(*name); name++) ; - fp = popen(name,"w"); + if (strNE(name,"-")) + fp = popen(name,"w"); + else { + fp = forkopen(name,"w"); + stio->subprocess = forkprocess; + stio->type = '%'; + } } else if (*name == '>' && name[1] == '>') { + stio->type = 'a'; for (name += 2; isspace(*name); name++) ; fp = fopen(name,"a"); } + else if (*name == '>' && name[1] == '&') { + for (name += 2; isspace(*name); name++) ; + if (isdigit(*name)) + fd = atoi(name); + else { + stab = stabent(name,FALSE); + if (stab->stab_io && stab->stab_io->fp) { + fd = fileno(stab->stab_io->fp); + stio->type = stab->stab_io->type; + } + else + fd = -1; + } + fp = fdopen(dup(fd),stio->type == 'a' ? "a" : + (stio->type == '<' ? "r" : "w") ); + } else if (*name == '>') { for (name++; isspace(*name); name++) ; if (strEQ(name,"-")) { @@ -363,8 +542,15 @@ register char *name; while (len && isspace(name[len-1])) name[--len] = '\0'; for (; isspace(*name); name++) ; - fp = popen(name,"r"); - stio->type = '|'; + if (strNE(name,"-")) { + fp = popen(name,"r"); + stio->type = '|'; + } + else { + fp = forkopen(name,"r"); + stio->subprocess = forkprocess; + stio->type = '%'; + } } else { stio->type = '<'; @@ -377,9 +563,11 @@ register char *name; fp = fopen(name,"r"); } } + safefree(myname); if (!fp) return FALSE; - if (stio->type != '|' && stio->type != '-') { + if (stio->type && + stio->type != '|' && stio->type != '-' && stio->type != '%') { if (fstat(fileno(fp),&statbuf) < 0) { fclose(fp); return FALSE; @@ -400,14 +588,18 @@ register STAB *stab; { register STR *str; char *oldname; + int filemode,fileuid,filegid; - while (alen(stab->stab_array) >= 0L) { + while (alen(stab->stab_array) >= 0) { 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) { + filemode = statbuf.st_mode; + fileuid = statbuf.st_uid; + filegid = statbuf.st_gid; if (*inplace) { str_cat(str,inplace); #ifdef RENAME @@ -418,9 +610,23 @@ register STAB *stab; UNLINK(oldname); #endif } + else { + UNLINK(oldname); + } sprintf(tokenbuf,">%s",oldname); + errno = 0; /* in case sprintf set errno */ do_open(argvoutstab,tokenbuf); defoutstab = argvoutstab; +#ifdef FCHMOD + fchmod(fileno(argvoutstab->stab_io->fp),filemode); +#else + chmod(oldname,filemode); +#endif +#ifdef FCHOWN + fchown(fileno(argvoutstab->stab_io->fp),fileuid,filegid); +#else + chown(oldname,fileuid,filegid); +#endif } str_free(str); return stab->stab_io->fp; @@ -443,16 +649,30 @@ bool explicit; { bool retval = FALSE; register STIO *stio = stab->stab_io; + int status; + int tmp; - if (!stio) /* never opened */ + if (!stio) { /* never opened */ + if (dowarn && explicit) + warn("Close on unopened file <%s>",stab->stab_name); return FALSE; + } if (stio->fp) { if (stio->type == '|') retval = (pclose(stio->fp) >= 0); else if (stio->type == '-') retval = TRUE; - else + else { retval = (fclose(stio->fp) != EOF); + if (stio->type == '%' && stio->subprocess) { + while ((tmp = wait(&status)) != stio->subprocess && tmp != -1) + ; + if (tmp == -1) + statusvalue = -1; + else + statusvalue = (unsigned)status & 0xffff; + } + } stio->fp = Nullfp; } if (explicit) @@ -468,10 +688,11 @@ STAB *stab; register STIO *stio; int ch; - if (!stab) - return TRUE; + if (!stab) /* eof() */ + stio = argvstab->stab_io; + else + stio = stab->stab_io; - stio = stab->stab_io; if (!stio) return TRUE; @@ -487,8 +708,8 @@ STAB *stab; ungetc(ch, stio->fp); return FALSE; } - if (stio->flags & IOF_ARGV) { /* not necessarily a real EOF yet? */ - if (!nextargv(stab)) /* get another fp handy */ + if (!stab) { /* not necessarily a real EOF yet? */ + if (!nextargv(argvstab)) /* get another fp handy */ return TRUE; } else @@ -502,16 +723,20 @@ do_tell(stab) STAB *stab; { register STIO *stio; - int ch; if (!stab) - return -1L; + goto phooey; stio = stab->stab_io; if (!stio || !stio->fp) - return -1L; + goto phooey; return ftell(stio->fp); + +phooey: + if (dowarn) + warn("tell() on unopened file"); + return -1L; } bool @@ -523,19 +748,113 @@ int whence; register STIO *stio; if (!stab) - return FALSE; + goto nuts; stio = stab->stab_io; if (!stio || !stio->fp) - return FALSE; + goto nuts; return fseek(stio->fp, pos, whence) >= 0; + +nuts: + if (dowarn) + warn("seek() on unopened file"); + return FALSE; } -do_stat(arg,sarg,retary) +static CMD *sortcmd; +static STAB *firststab = Nullstab; +static STAB *secondstab = Nullstab; + +do_sort(arg,stab,retary,sarg,ptrmaxsarg,sargoff,cushion) register ARG *arg; +STAB *stab; +STR ***retary; register STR **sarg; +int *ptrmaxsarg; +int sargoff; +int cushion; +{ + STR **tmpary; /* must not be register */ + register STR **elem; + register bool retval; + register int max; + register int i; + int sortcmp(); + int sortsub(); + STR *oldfirst; + STR *oldsecond; + + (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1); + max = (int)str_gnum(*tmpary); + + if (retary) { + sarg = (STR**)saferealloc((char*)(sarg - sargoff), + (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff; + for (i = 1; i <= max; i++) + sarg[i] = tmpary[i]; + *retary = sarg; + if (max > 1) { + if (stab->stab_sub && (sortcmd = stab->stab_sub->cmd)) { + if (!firststab) { + firststab = stabent("a",TRUE); + secondstab = stabent("b",TRUE); + } + oldfirst = firststab->stab_val; + oldsecond = secondstab->stab_val; + qsort((char*)(sarg+1),max,sizeof(STR*),sortsub); + firststab->stab_val = oldfirst; + secondstab->stab_val = oldsecond; + } + else + qsort((char*)(sarg+1),max,sizeof(STR*),sortcmp); + } + while (max > 0 && !sarg[max]) + max--; + *ptrmaxsarg = max + sargoff; + } + safefree((char*)tmpary); + return max; +} + +int +sortcmp(str1,str2) +STR **str1; +STR **str2; +{ + char *tmps; + + if (!*str1) + return -1; + if (!*str2) + return 1; + tmps = str_get(*str1); + return strcmp(tmps,str_get(*str2)); +} + +int +sortsub(str1,str2) +STR **str1; +STR **str2; +{ + STR *str; + + if (!*str1) + return -1; + if (!*str2) + return 1; + firststab->stab_val = *str1; + secondstab->stab_val = *str2; + return (int)str_gnum(cmd_exec(sortcmd)); +} + +do_stat(arg,retary,sarg,ptrmaxsarg,sargoff,cushion) +register ARG *arg; STR ***retary; +register STR **sarg; +int *ptrmaxsarg; +int sargoff; +int cushion; { register ARRAY *ary; static ARRAY *myarray = Null(ARRAY*); @@ -544,7 +863,7 @@ STR ***retary; ary = myarray; if (!ary) - myarray = ary = anew(); + myarray = ary = anew(Nullstab); ary->ary_fill = -1; if (arg[1].arg_type == A_LVAL) { tmpstab = arg[1].arg_ptr.arg_stab; @@ -578,9 +897,9 @@ STR ***retary; apush(ary,str_make("")); #endif } - sarg = (STR**)safemalloc((max+2)*sizeof(STR*)); - sarg[0] = Nullstr; - sarg[max+1] = Nullstr; + *ptrmaxsarg = max + sargoff; + sarg = (STR**)saferealloc((char*)(sarg - sargoff), + (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff; for (i = 1; i <= max; i++) sarg[i] = afetch(ary,i-1); *retary = sarg; @@ -588,32 +907,38 @@ STR ***retary; return max; } -do_tms(retary) +do_tms(retary,sarg,ptrmaxsarg,sargoff,cushion) STR ***retary; +STR **sarg; +int *ptrmaxsarg; +int sargoff; +int cushion; { register ARRAY *ary; static ARRAY *myarray = Null(ARRAY*); - register STR **sarg; int max = 4; register int i; ary = myarray; if (!ary) - myarray = ary = anew(); + myarray = ary = anew(Nullstab); ary->ary_fill = -1; - if (times(×buf) < 0) - max = 0; + times(×buf); + +#ifndef HZ +#define HZ 60 +#endif 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; + apush(ary,str_nmake(((double)timesbuf.tms_utime)/HZ)); + apush(ary,str_nmake(((double)timesbuf.tms_stime)/HZ)); + apush(ary,str_nmake(((double)timesbuf.tms_cutime)/HZ)); + apush(ary,str_nmake(((double)timesbuf.tms_cstime)/HZ)); + } + *ptrmaxsarg = max + sargoff; + sarg = (STR**)saferealloc((char*)(sarg - sargoff), + (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff; for (i = 1; i <= max; i++) sarg[i] = afetch(ary,i-1); *retary = sarg; @@ -621,20 +946,22 @@ STR ***retary; return max; } -do_time(tmbuf,retary) +do_time(tmbuf,retary,sarg,ptrmaxsarg,sargoff,cushion) struct tm *tmbuf; STR ***retary; +STR **sarg; +int *ptrmaxsarg; +int sargoff; +int cushion; { 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(); + myarray = ary = anew(Nullstab); ary->ary_fill = -1; if (!tmbuf) max = 0; @@ -651,9 +978,9 @@ STR ***retary; 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; + *ptrmaxsarg = max + sargoff; + sarg = (STR**)saferealloc((char*)(sarg - sargoff), + (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff; for (i = 1; i <= max; i++) sarg[i] = afetch(ary,i-1); *retary = sarg; @@ -688,6 +1015,7 @@ register STR **sarg; for (t++; *sarg && *t && t != s; t++) { switch (*t) { case '\0': + t--; break; case '%': ch = *(++t); @@ -702,7 +1030,7 @@ register STR **sarg; case 'D': case 'X': case 'O': dolong = TRUE; /* FALL THROUGH */ - case 'd': case 'x': case 'o': case 'c': + case 'd': case 'x': case 'o': case 'c': case 'u': ch = *(++t); *t = '\0'; if (dolong) @@ -722,7 +1050,12 @@ register STR **sarg; case 's': ch = *(++t); *t = '\0'; - sprintf(buf,s,str_get(*(sarg++))); + if (strEQ(s,"%s")) { /* some printfs fail on >128 chars */ + *buf = '\0'; + str_scat(str,*(sarg++)); /* so handle simple case */ + } + else + sprintf(buf,s,str_get(*(sarg++))); s = t; *(t--) = ch; break; @@ -736,13 +1069,22 @@ register STR **sarg; } bool -do_print(s,fp) -char *s; +do_print(str,fp) +register STR *str; FILE *fp; { - if (!fp || !s) + if (!fp) { + if (dowarn) + warn("print to unopened file"); + return FALSE; + } + if (!str) return FALSE; - fputs(s,fp); + if (ofmt && + ((str->str_nok && str->str_nval != 0.0) || str_gnum(str) != 0.0) ) + fprintf(fp, ofmt, str->str_nval); + else + fputs(str_get(str),fp); return TRUE; } @@ -754,30 +1096,30 @@ register FILE *fp; STR **tmpary; /* must not be register */ register STR **elem; register bool retval; - double value; + register int items; - (void)eval(arg[1].arg_ptr.arg_arg,&tmpary); + if (!fp) { + if (dowarn) + warn("print to unopened file"); + return FALSE; + } + (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1); + items = (int)str_gnum(*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); + do_sprintf(arg->arg_ptr.arg_str,items,tmpary); + retval = do_print(arg->arg_ptr.arg_str,fp); } else { retval = FALSE; - for (elem = tmpary+1; *elem; elem++) { + for (elem = tmpary+1; items > 0; items--,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); + fputs(ofs, fp); + retval = do_print(*elem, fp); if (!retval) break; } if (ors) - retval = do_print(ors, fp); + fputs(ors, fp); } safefree((char*)tmpary); return retval; @@ -790,18 +1132,19 @@ register ARG *arg; STR **tmpary; /* must not be register */ register STR **elem; register char **a; - register int i; + register int items; 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*)); + (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1); + items = (int)str_gnum(*tmpary); + if (items) { + argv = (char**)safemalloc((items+1)*sizeof(char*)); a = argv; - for (elem = tmpary+1; *elem; elem++) { - *a++ = str_get(*elem); + for (elem = tmpary+1; items > 0; items--,elem++) { + if (*elem) + *a++ = str_get(*elem); + else + *a++ = ""; } *a = Nullch; execvp(argv[0],argv); @@ -812,19 +1155,19 @@ register ARG *arg; } bool -do_exec(cmd) -char *cmd; +do_exec(str) +STR *str; { - STR **tmpary; /* must not be register */ register char **a; register char *s; char **argv; + char *cmd = str_get(str); /* 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); + execl("/bin/sh","sh","-c",cmd,(char*)0); return FALSE; } } @@ -854,11 +1197,14 @@ register ARRAY *ary; STR **tmpary; /* must not be register */ register STR **elem; register STR *str = &str_no; + register int items; - (void)eval(arg[1].arg_ptr.arg_arg,&tmpary); - for (elem = tmpary+1; *elem; elem++) { + (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1); + items = (int)str_gnum(*tmpary); + for (elem = tmpary+1; items > 0; items--,elem++) { str = str_new(0); - str_sset(str,*elem); + if (*elem) + str_sset(str,*elem); apush(ary,str); } safefree((char*)tmpary); @@ -873,17 +1219,16 @@ register ARRAY *ary; register STR **elem; register STR *str = &str_no; register int i; + register int items; - (void)eval(arg[1].arg_ptr.arg_arg,&tmpary); - i = 0; - for (elem = tmpary+1; *elem; elem++) - i++; - aunshift(ary,i); + (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1); + items = (int)str_gnum(*tmpary); + aunshift(ary,items); i = 0; - for (elem = tmpary+1; *elem; elem++) { + for (elem = tmpary+1; i < items; i++,elem++) { str = str_new(0); str_sset(str,*elem); - astore(ary,i++,str); + astore(ary,i,str); } safefree((char*)tmpary); } @@ -895,69 +1240,133 @@ STR **sarg; { STR **tmpary; /* must not be register */ register STR **elem; - register int i; + register int items; register int val; register int val2; + char *s; - if (sarg) + if (sarg) { tmpary = sarg; - else - (void)eval(arg[1].arg_ptr.arg_arg,&tmpary); - i = 0; - for (elem = tmpary+1; *elem; elem++) - i++; + items = 0; + for (elem = tmpary+1; *elem; elem++) + items++; + } + else { + (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1); + items = (int)str_gnum(*tmpary); + } switch (type) { case O_CHMOD: - if (--i > 0) { + if (--items > 0) { val = (int)str_gnum(tmpary[1]); for (elem = tmpary+2; *elem; elem++) if (chmod(str_get(*elem),val)) - i--; + items--; } break; case O_CHOWN: - if (i > 2) { - i -= 2; + if (items > 2) { + items -= 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--; + items--; } else - i = 0; + items = 0; break; case O_KILL: - if (--i > 0) { + if (--items > 0) { val = (int)str_gnum(tmpary[1]); - if (val < 0) + if (val < 0) { val = -val; - for (elem = tmpary+2; *elem; elem++) - if (kill(atoi(str_get(*elem)),val)) - i--; + for (elem = tmpary+2; *elem; elem++) +#ifdef KILLPG + if (killpg((int)(str_gnum(*elem)),val)) /* BSD */ +#else + if (kill(-(int)(str_gnum(*elem)),val)) /* SYSV */ +#endif + items--; + } + else { + for (elem = tmpary+2; *elem; elem++) + if (kill((int)(str_gnum(*elem)),val)) + items--; + } } break; case O_UNLINK: - for (elem = tmpary+1; *elem; elem++) - if (UNLINK(str_get(*elem))) - i--; + for (elem = tmpary+1; *elem; elem++) { + s = str_get(*elem); + if (euid || unsafe) { + if (UNLINK(s)) + items--; + } + else { /* don't let root wipe out directories without -U */ + if (stat(s,&statbuf) < 0 || + (statbuf.st_mode & S_IFMT) == S_IFDIR ) + items--; + else { + if (UNLINK(s)) + items--; + } + } + } + break; + case O_UTIME: + if (items > 2) { + struct { + long atime, + mtime; + } utbuf; + + utbuf.atime = (long)str_gnum(tmpary[1]); /* time accessed */ + utbuf.mtime = (long)str_gnum(tmpary[2]); /* time modified */ + items -= 2; + for (elem = tmpary+3; *elem; elem++) + if (utime(str_get(*elem),&utbuf)) + items--; + } + else + items = 0; break; } if (!sarg) safefree((char*)tmpary); - return i; + return items; } STR * do_subr(arg,sarg) register ARG *arg; -register char **sarg; +register STR **sarg; { + register SUBR *sub; ARRAY *savearray; STR *str; + STAB *stab; + char *oldfile = filename; + int oldsave = savestack->ary_fill; + int oldtmps_base = tmps_base; + if (arg[2].arg_type == A_WORD) + stab = arg[2].arg_ptr.arg_stab; + else + stab = stabent(str_get(arg[2].arg_ptr.arg_stab->stab_val),TRUE); + if (!stab) { + if (dowarn) + warn("Undefined subroutine called"); + return &str_no; + } + sub = stab->stab_sub; + if (!sub) { + if (dowarn) + warn("Undefined subroutine \"%s\" called", stab->stab_name); + return &str_no; + } savearray = defstab->stab_array; - defstab->stab_array = anew(); + defstab->stab_array = anew(defstab); if (arg[1].arg_flags & AF_SPECIAL) (void)do_push(arg,defstab->stab_array); else if (arg[1].arg_type != A_NULL) { @@ -965,16 +1374,34 @@ register char **sarg; str_sset(str,sarg[1]); apush(defstab->stab_array,str); } - str = cmd_exec(arg[2].arg_ptr.arg_stab->stab_sub); + sub->depth++; + if (sub->depth >= 2) { /* save temporaries on recursion? */ + if (sub->depth == 100 && dowarn) + warn("Deep recursion on subroutine \"%s\"",stab->stab_name); + savelist(sub->tosave->ary_array,sub->tosave->ary_fill); + } + filename = sub->filename; + tmps_base = tmps_max; + + str = cmd_exec(sub->cmd); /* so do it already */ + + sub->depth--; /* assuming no longjumps out of here */ afree(defstab->stab_array); /* put back old $_[] */ defstab->stab_array = savearray; + filename = oldfile; + tmps_base = oldtmps_base; + if (savestack->ary_fill > oldsave) { + str = str_static(str); /* in case restore wipes old str */ + restorelist(oldsave); + } return str; } void -do_assign(retstr,arg) +do_assign(retstr,arg,sarg) STR *retstr; register ARG *arg; +register STR **sarg; { STR **tmpary; /* must not be register */ register ARG *larg = arg[1].arg_ptr.arg_arg; @@ -982,60 +1409,76 @@ register ARG *arg; register STR *str; register ARRAY *ary; register int i; - register int lasti; - char *s; + register int items; + STR *tmpstr; - (void)eval(arg[2].arg_ptr.arg_arg,&tmpary); + if (arg[2].arg_flags & AF_SPECIAL) { + (void)eval(arg[2].arg_ptr.arg_arg,&tmpary,-1); + items = (int)str_gnum(*tmpary); + } + else { + tmpary = sarg; + sarg[1] = sarg[2]; + sarg[2] = Nullstr; + items = 1; + } - if (arg->arg_flags & AF_COMMON) { + if (arg->arg_flags & AF_COMMON) { /* always true currently, alas */ if (*(tmpary+1)) { - for (elem=tmpary+2; *elem; elem++) { + for (i=2,elem=tmpary+2; i <= items; i++,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 = ""; + for (i=1,elem=tmpary+1; i <= larg->arg_len; i++) { 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***)); + str = eval(larg[i].arg_ptr.arg_arg,Null(STR***),-1); break; } - str_set(str,s); + if (larg->arg_flags & AF_LOCAL) { + apush(savestack,str); /* save pointer */ + tmpstr = str_new(0); + str_sset(tmpstr,str); + apush(savestack,tmpstr); /* save value */ + } + if (*elem) + str_sset(str,*(elem++)); + else + str_set(str,""); 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++) { + for (i=0,elem=tmpary+1; i < items; 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); + ary->ary_fill = items - 1;/* they can get the extra ones back by */ + } /* setting $#ary larger than old fill */ + str_numset(retstr,(double)items); STABSET(retstr); - safefree((char*)tmpary); + if (tmpary != sarg); + safefree((char*)tmpary); } int -do_kv(hash,kv,sarg,retary) +do_kv(hash,kv,retary,sarg,ptrmaxsarg,sargoff,cushion) HASH *hash; int kv; -register STR **sarg; STR ***retary; +register STR **sarg; +int *ptrmaxsarg; +int sargoff; +int cushion; { register ARRAY *ary; int max = 0; @@ -1045,7 +1488,7 @@ STR ***retary; ary = myarray; if (!ary) - myarray = ary = anew(); + myarray = ary = anew(Nullstab); ary->ary_fill = -1; hiterinit(hash); @@ -1057,9 +1500,9 @@ STR ***retary; 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; + *ptrmaxsarg = max + sargoff; + sarg = (STR**)saferealloc((char*)(sarg - sargoff), + (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff; for (i = 1; i <= max; i++) sarg[i] = afetch(ary,i-1); *retary = sarg; @@ -1068,10 +1511,13 @@ STR ***retary; } STR * -do_each(hash,sarg,retary) +do_each(hash,retary,sarg,ptrmaxsarg,sargoff,cushion) HASH *hash; -register STR **sarg; STR ***retary; +STR **sarg; +int *ptrmaxsarg; +int sargoff; +int cushion; { static STR *mystr = Nullstr; STR *retstr; @@ -1084,17 +1530,18 @@ STR ***retary; if (retary) { /* array wanted */ if (entry) { - sarg = (STR**)saferealloc((char*)sarg,4*sizeof(STR*)); - sarg[0] = Nullstr; - sarg[3] = Nullstr; + *ptrmaxsarg = 2 + sargoff; + sarg = (STR**)saferealloc((char*)(sarg - sargoff), + (2+2+cushion+sargoff)*sizeof(STR*)) + sargoff; 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; + *ptrmaxsarg = sargoff; + sarg = (STR**)saferealloc((char*)(sarg - sargoff), + (2+cushion+sargoff)*sizeof(STR*)) + sargoff; + retstr = Nullstr; *retary = sarg; } } @@ -1104,32 +1551,172 @@ STR ***retary; return retstr; } -init_eval() +int +mystat(arg,str) +ARG *arg; +STR *str; { - register int i; + STIO *stio; -#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); + if (arg[1].arg_flags & AF_SPECIAL) { + stio = arg[1].arg_ptr.arg_stab->stab_io; + if (stio && stio->fp) + return fstat(fileno(stio->fp), &statbuf); + else { + if (dowarn) + warn("Stat on unopened file <%s>", + arg[1].arg_ptr.arg_stab->stab_name); + return -1; + } + } + else + return stat(str_get(str),&statbuf); +} + +STR * +do_fttext(arg,str) +register ARG *arg; +STR *str; +{ + int i; + int len; + int odd = 0; + STDCHAR tbuf[512]; + register STDCHAR *s; + register STIO *stio; + + if (arg[1].arg_flags & AF_SPECIAL) { + stio = arg[1].arg_ptr.arg_stab->stab_io; + if (stio && stio->fp) { +#ifdef STDSTDIO + if (stio->fp->_cnt <= 0) { + i = getc(stio->fp); + ungetc(i,stio->fp); + } + if (stio->fp->_cnt <= 0) /* null file is anything */ + return &str_yes; + len = stio->fp->_cnt + (stio->fp->_ptr - stio->fp->_base); + s = stio->fp->_base; +#else + fatal("-T and -B not implemented on filehandles\n"); +#endif + } + else { + if (dowarn) + warn("Test on unopened file <%s>", + arg[1].arg_ptr.arg_stab->stab_name); + return &str_no; + } + } + else { + i = open(str_get(str),0); + if (i < 0) + return &str_no; + len = read(i,tbuf,512); + if (len <= 0) /* null file is anything */ + return &str_yes; + close(i); + s = tbuf; + } + + /* now scan s to look for textiness */ + + for (i = 0; i < len; i++,s++) { + if (!*s) { /* null never allowed in text */ + odd += len; + break; + } + else if (*s & 128) + odd++; + else if (*s < 32 && + *s != '\n' && *s != '\r' && *s != '\b' && + *s != '\t' && *s != '\f' && *s != 27) + odd++; + } + + if ((odd * 10 > len) == (arg->arg_type == O_FTTEXT)) /* allow 10% odd */ + return &str_no; + else + return &str_yes; +} + +int +do_study(str) +STR *str; +{ + register char *s = str_get(str); + register int pos = str->str_cur; + register int ch; + register int *sfirst; + register int *snext; + static int maxscream = -1; + static STR *lastscream = Nullstr; + + if (lastscream && lastscream->str_pok == 5) + lastscream->str_pok &= ~4; + lastscream = str; + if (pos <= 0) + return 0; + if (pos > maxscream) { + if (maxscream < 0) { + maxscream = pos + 80; + screamfirst = (int*)safemalloc((MEM_SIZE)(256 * sizeof(int))); + screamnext = (int*)safemalloc((MEM_SIZE)(maxscream * sizeof(int))); + } + else { + maxscream = pos + pos / 4; + screamnext = (int*)saferealloc((char*)screamnext, + (MEM_SIZE)(maxscream * sizeof(int))); + } + } + + sfirst = screamfirst; + snext = screamnext; + + if (!sfirst || !snext) + fatal("do_study: out of memory"); + + for (ch = 256; ch; --ch) + *sfirst++ = -1; + sfirst -= 256; + + while (--pos >= 0) { + ch = s[pos]; + if (sfirst[ch] >= 0) + snext[pos] = sfirst[ch] - pos; + else + snext[pos] = -pos; + sfirst[ch] = pos; + } + + str->str_pok |= 4; + return 1; +} + +init_eval() +{ +#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); @@ -1165,15 +1752,15 @@ init_eval() 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_PRINT] = A(1,1,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_EOF] = A(1,0,0); + opargs[O_TELL] = A(1,0,0); + opargs[O_SEEK] = A(1,1,1); opargs[O_LAST] = A(1,0,0); opargs[O_NEXT] = A(1,0,0); opargs[O_REDO] = A(1,0,0); @@ -1189,7 +1776,7 @@ init_eval() 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_PRTF] = A(1,1,0); opargs[O_ORD] = A(1,0,0); opargs[O_SLEEP] = A(1,0,0); opargs[O_FLIP] = A(1,0,0); @@ -1213,956 +1800,35 @@ init_eval() opargs[O_LINK] = A(1,1,0); opargs[O_REPEAT] = A(1,1,0); opargs[O_EVAL] = A(1,0,0); -} - -#ifdef VOIDSIG -static void (*ihand)(); -static void (*qhand)(); -#else -static int (*ihand)(); -static int (*qhand)(); -#endif - -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: -#ifdef CRYPT - tmps = str_get(sarg[1]); - str_set(str,crypt(tmps,str_get(sarg[2]))); -#else - fatal( - "The crypt() function is unimplemented due to excessive paranoia."); -#endif - 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; - case O_EVAL: - str_sset(str, - do_eval(arg[1].arg_type != A_NULL ? sarg[1] : defstab->stab_val) ); - STABSET(str); - 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; + opargs[O_FTEREAD] = A(1,0,0); + opargs[O_FTEWRITE] = A(1,0,0); + opargs[O_FTEEXEC] = A(1,0,0); + opargs[O_FTEOWNED] = A(1,0,0); + opargs[O_FTRREAD] = A(1,0,0); + opargs[O_FTRWRITE] = A(1,0,0); + opargs[O_FTREXEC] = A(1,0,0); + opargs[O_FTROWNED] = A(1,0,0); + opargs[O_FTIS] = A(1,0,0); + opargs[O_FTZERO] = A(1,0,0); + opargs[O_FTSIZE] = A(1,0,0); + opargs[O_FTFILE] = A(1,0,0); + opargs[O_FTDIR] = A(1,0,0); + opargs[O_FTLINK] = A(1,0,0); + opargs[O_SYMLINK] = A(1,1,0); + opargs[O_FTPIPE] = A(1,0,0); + opargs[O_FTSUID] = A(1,0,0); + opargs[O_FTSGID] = A(1,0,0); + opargs[O_FTSVTX] = A(1,0,0); + opargs[O_FTCHR] = A(1,0,0); + opargs[O_FTBLK] = A(1,0,0); + opargs[O_FTSOCK] = A(1,0,0); + opargs[O_FTTTY] = A(1,0,0); + opargs[O_DOFILE] = A(1,0,0); + opargs[O_FTTEXT] = A(1,0,0); + opargs[O_FTBINARY] = A(1,0,0); + opargs[O_UTIME] = A(1,0,0); + opargs[O_WAIT] = A(0,0,0); + opargs[O_SORT] = A(1,0,0); + opargs[O_STUDY] = A(1,0,0); + opargs[O_DELETE] = A(1,0,0); } diff --git a/arg.h b/arg.h index d442b02dfafc..efb3e3696cd8 100644 --- a/arg.h +++ b/arg.h @@ -1,11 +1,8 @@ -/* $Header: arg.h,v 1.0.1.1 88/01/28 10:22:40 root Exp $ +/* $Header: arg.h,v 2.0 88/06/05 00:08:14 root Exp $ * * $Log: arg.h,v $ - * Revision 1.0.1.1 88/01/28 10:22:40 root - * patch8: added eval operator. - * - * Revision 1.0 87/12/18 13:04:39 root - * Initial revision + * Revision 2.0 88/06/05 00:08:14 root + * Baseline version 2.0. * */ @@ -115,7 +112,38 @@ #define O_LINK 103 #define O_REPEAT 104 #define O_EVAL 105 -#define MAXO 106 +#define O_FTEREAD 106 +#define O_FTEWRITE 107 +#define O_FTEEXEC 108 +#define O_FTEOWNED 109 +#define O_FTRREAD 110 +#define O_FTRWRITE 111 +#define O_FTREXEC 112 +#define O_FTROWNED 113 +#define O_FTIS 114 +#define O_FTZERO 115 +#define O_FTSIZE 116 +#define O_FTFILE 117 +#define O_FTDIR 118 +#define O_FTLINK 119 +#define O_SYMLINK 120 +#define O_FTPIPE 121 +#define O_FTSOCK 122 +#define O_FTBLK 123 +#define O_FTCHR 124 +#define O_FTSUID 125 +#define O_FTSGID 126 +#define O_FTSVTX 127 +#define O_FTTTY 128 +#define O_DOFILE 129 +#define O_FTTEXT 130 +#define O_FTBINARY 131 +#define O_UTIME 132 +#define O_WAIT 133 +#define O_SORT 134 +#define O_DELETE 135 +#define O_STUDY 136 +#define MAXO 137 #ifndef DOINIT extern char *opname[]; @@ -227,7 +255,38 @@ char *opname[] = { "LINK", "REPEAT", "EVAL", - "106" + "FTEREAD", + "FTEWRITE", + "FTEEXEC", + "FTEOWNED", + "FTRREAD", + "FTRWRITE", + "FTREXEC", + "FTROWNED", + "FTIS", + "FTZERO", + "FTSIZE", + "FTFILE", + "FTDIR", + "FTLINK", + "SYMLINK", + "FTPIPE", + "FTSOCK", + "FTBLK", + "FTCHR", + "FTSUID", + "FTSGID", + "FTSVTX", + "FTTTY", + "DOFILE", + "FTTEXT", + "FTBINARY", + "UTIME", + "WAIT", + "SORT", + "DELETE", + "STUDY", + "135" }; #endif @@ -244,6 +303,10 @@ char *opname[] = { #define A_LEXPR 10 #define A_ARYLEN 11 #define A_NUMBER 12 +#define A_LARYLEN 13 +#define A_GLOB 14 +#define A_WORD 15 +#define A_INDREAD 16 #ifndef DOINIT extern char *argname[]; @@ -262,29 +325,35 @@ char *argname[] = { "LEXPR", "ARYLEN", "NUMBER", - "13" + "LARYLEN", + "GLOB", + "WORD", + "INDREAD", + "17" }; #endif #ifndef DOINIT extern bool hoistable[]; #else -bool hoistable[] = {0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0}; +bool hoistable[] = {0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0}; #endif +union argptr { + ARG *arg_arg; + char *arg_cval; + STAB *arg_stab; + SPAT *arg_spat; + CMD *arg_cmd; + STR *arg_str; + double arg_nval; +}; + 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; + union argptr arg_ptr; short arg_len; - char arg_type; - char arg_flags; + unsigned char arg_type; + unsigned char arg_flags; }; #define AF_SPECIAL 1 /* op wants to evaluate this arg itself */ @@ -294,6 +363,7 @@ struct arg { #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 */ +#define AF_LOCAL 128 /* list of local variables */ /* * Most of the ARG pointers are used as pointers to arrays of ARG. When @@ -317,3 +387,6 @@ bool do_seek(); int do_tms(); int do_time(); int do_stat(); +STR *do_push(); +FILE *nextargv(); +STR *do_fttext(); diff --git a/array.c b/array.c index 156b78378feb..f1446a7e9071 100644 --- a/array.c +++ b/array.c @@ -1,16 +1,12 @@ -/* $Header: array.c,v 1.0 87/12/18 13:04:42 root Exp $ +/* $Header: array.c,v 2.0 88/06/05 00:08:17 root Exp $ * * $Log: array.c,v $ - * Revision 1.0 87/12/18 13:04:42 root - * Initial revision + * Revision 2.0 88/06/05 00:08:17 root + * Baseline version 2.0. * */ -#include #include "EXTERN.h" -#include "handy.h" -#include "util.h" -#include "search.h" #include "perl.h" STR * @@ -18,7 +14,7 @@ afetch(ar,key) register ARRAY *ar; int key; { - if (key < 0 || key > ar->ary_max) + if (key < 0 || key > ar->ary_fill) return Nullstr; return ar->ary_array[key]; } @@ -42,8 +38,12 @@ STR *val; (newmax - ar->ary_max) * sizeof(STR*)); ar->ary_max = newmax; } - if (key > ar->ary_fill) - ar->ary_fill = key; + while (ar->ary_fill < key) { + if (++ar->ary_fill < key && ar->ary_array[ar->ary_fill] != Nullstr) { + str_free(ar->ary_array[ar->ary_fill]); + ar->ary_array[ar->ary_fill] = Nullstr; + } + } retval = (ar->ary_array[key] != Nullstr); if (retval) str_free(ar->ary_array[key]); @@ -67,17 +67,35 @@ int key; } ARRAY * -anew() +anew(stab) +STAB *stab; { register ARRAY *ar = (ARRAY*)safemalloc(sizeof(ARRAY)); ar->ary_array = (STR**) safemalloc(5 * sizeof(STR*)); + ar->ary_magic = str_new(0); + ar->ary_magic->str_link.str_magic = stab; ar->ary_fill = -1; + ar->ary_index = -1; ar->ary_max = 4; bzero((char*)ar->ary_array, 5 * sizeof(STR*)); return ar; } +void +aclear(ar) +register ARRAY *ar; +{ + register int key; + + if (!ar) + return; + for (key = 0; key <= ar->ary_max; key++) + str_free(ar->ary_array[key]); + ar->ary_fill = -1; + bzero((char*)ar->ary_array, (ar->ary_max+1) * sizeof(STR*)); +} + void afree(ar) register ARRAY *ar; @@ -86,8 +104,9 @@ register ARRAY *ar; if (!ar) return; - for (key = 0; key <= ar->ary_fill; key++) + for (key = 0; key <= ar->ary_max; key++) str_free(ar->ary_array[key]); + str_free(ar->ary_magic); safefree((char*)ar->ary_array); safefree((char*)ar); } @@ -123,8 +142,8 @@ register int num; 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; + dstr = ar->ary_array + ar->ary_fill; + sstr = dstr - num; for (i = ar->ary_fill; i >= 0; i--) { *dstr-- = *sstr--; } @@ -146,11 +165,23 @@ register ARRAY *ar; return retval; } -long +int alen(ar) register ARRAY *ar; { - return (long)ar->ary_fill; + return ar->ary_fill; +} + +afill(ar, fill) +register ARRAY *ar; +int fill; +{ + if (fill < 0) + fill = -1; + if (fill <= ar->ary_max) + ar->ary_fill = fill; + else + astore(ar,fill,Nullstr); } void diff --git a/array.h b/array.h index 4ad948796d03..d8dfe541b934 100644 --- a/array.h +++ b/array.h @@ -1,15 +1,17 @@ -/* $Header: array.h,v 1.0 87/12/18 13:04:46 root Exp $ +/* $Header: array.h,v 2.0 88/06/05 00:08:21 root Exp $ * * $Log: array.h,v $ - * Revision 1.0 87/12/18 13:04:46 root - * Initial revision + * Revision 2.0 88/06/05 00:08:21 root + * Baseline version 2.0. * */ struct atbl { STR **ary_array; - int ary_max; - int ary_fill; + STR *ary_magic; + int ary_max; + int ary_fill; + int ary_index; }; STR *afetch(); @@ -17,6 +19,8 @@ bool astore(); bool adelete(); STR *apop(); STR *ashift(); +void afree(); +void aclear(); bool apush(); -long alen(); +int alen(); ARRAY *anew(); diff --git a/cmd.c b/cmd.c index c2be1a26cd3a..f5649b62e66c 100644 --- a/cmd.c +++ b/cmd.c @@ -1,18 +1,12 @@ -/* $Header: cmd.c,v 1.0.1.1 88/01/21 21:24:16 root Exp $ +/* $Header: cmd.c,v 2.0 88/06/05 00:08:24 root Exp $ * * $Log: cmd.c,v $ - * Revision 1.0.1.1 88/01/21 21:24:16 root - * The redo cmd got a segmentation fault because trace context stack overflowed. - * - * Revision 1.0 87/12/18 13:04:51 root - * Initial revision + * Revision 2.0 88/06/05 00:08:24 root + * Baseline version 2.0. * */ -#include "handy.h" #include "EXTERN.h" -#include "search.h" -#include "util.h" #include "perl.h" static STR str_chop; @@ -24,9 +18,14 @@ static STR str_chop; STR * cmd_exec(cmd) +#ifdef cray /* nobody else has complained yet */ +CMD *cmd; +#else register CMD *cmd; +#endif { SPAT *oldspat; + int oldsave; #ifdef DEBUGGING int olddlevel; int entdlevel; @@ -34,10 +33,10 @@ register CMD *cmd; register STR *retstr; register char *tmps; register int cmdflags; - register bool match; + register int match; register char *go_to = goto_targ; - ARG *arg; FILE *fp; + ARRAY *ar; retstr = &str_no; #ifdef DEBUGGING @@ -57,14 +56,17 @@ register CMD *cmd; switch (cmd->c_type) { case C_IF: oldspat = curspat; + oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif retstr = &str_yes; if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING - debname[dlevel] = 't'; - debdelim[dlevel++] = '_'; + if (debug) { + debname[dlevel] = 't'; + debdelim[dlevel++] = '_'; + } #endif retstr = cmd_exec(cmd->ucmd.ccmd.cc_true); } @@ -74,8 +76,10 @@ register CMD *cmd; retstr = &str_no; if (cmd->ucmd.ccmd.cc_alt) { #ifdef DEBUGGING - debname[dlevel] = 'e'; - debdelim[dlevel++] = '_'; + if (debug) { + debname[dlevel] = 'e'; + debdelim[dlevel++] = '_'; + } #endif retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt); } @@ -83,6 +87,8 @@ register CMD *cmd; if (!goto_targ) go_to = Nullch; curspat = oldspat; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); #ifdef DEBUGGING dlevel = olddlevel; #endif @@ -108,15 +114,9 @@ register CMD *cmd; 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; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); + goto next_cmd; case O_NEXT: /* not done unless go_to found */ go_to = Nullch; goto next_iter; @@ -125,13 +125,16 @@ register CMD *cmd; goto doit; } oldspat = curspat; + oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING - debname[dlevel] = 't'; - debdelim[dlevel++] = '_'; + if (debug) { + debname[dlevel] = 't'; + debdelim[dlevel++] = '_'; + } #endif cmd_exec(cmd->ucmd.ccmd.cc_true); } @@ -144,8 +147,10 @@ register CMD *cmd; #endif if (cmd->ucmd.ccmd.cc_alt) { #ifdef DEBUGGING - debname[dlevel] = 'a'; - debdelim[dlevel++] = '_'; + if (debug) { + debname[dlevel] = 'a'; + debdelim[dlevel++] = '_'; + } #endif cmd_exec(cmd->ucmd.ccmd.cc_alt); } @@ -155,24 +160,41 @@ register CMD *cmd; goto finish_while; } cmd = cmd->c_next; - if (cmd && cmd->c_head == cmd) /* reached end of while loop */ + if (cmd && cmd->c_head == cmd) + /* reached end of while loop */ return retstr; /* targ isn't in this block */ + if (cmdflags & CF_ONCE) { +#ifdef DEBUGGING + if (debug & 4) { + deb("(Popping label #%d %s)\n",loop_ptr, + loop_stack[loop_ptr].loop_label); + } +#endif + loop_ptr--; + } goto tail_recursion_entry; } } until_loop: + /* Set line number so run-time errors can be located */ + + line = cmd->c_line; + #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); + if (debug) { + if (debug & 2) { + deb("%s (%lx) r%lx t%lx a%lx n%lx cs%lx\n", + cmdname[cmd->c_type],cmd,cmd->c_expr, + cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt,cmd->c_next, + curspat); + } + debname[dlevel] = cmdname[cmd->c_type][0]; + debdelim[dlevel++] = '!'; } - debname[dlevel] = cmdname[cmd->c_type][0]; - debdelim[dlevel++] = '!'; #endif - while (tmps_max >= 0) /* clean up after last eval */ + while (tmps_max > tmps_base) /* clean up after last eval */ str_free(tmps_list[tmps_max--]); /* Here is some common optimization */ @@ -181,13 +203,13 @@ register CMD *cmd; switch (cmdflags & CF_OPTIMIZE) { case CFT_FALSE: - retstr = cmd->c_first; + retstr = cmd->c_short; match = FALSE; if (cmdflags & CF_NESURE) goto maybe; break; case CFT_TRUE: - retstr = cmd->c_first; + retstr = cmd->c_short; match = TRUE; if (cmdflags & CF_EQSURE) goto flipmaybe; @@ -202,7 +224,7 @@ register CMD *cmd; case CFT_ANCHOR: /* /^pat/ optimization */ if (multiline) { - if (*cmd->c_first->str_ptr && !(cmdflags & CF_EQSURE)) + if (*cmd->c_short->str_ptr && !(cmdflags & CF_EQSURE)) goto scanner; /* just unanchor it */ else break; /* must evaluate */ @@ -210,9 +232,9 @@ register CMD *cmd; /* 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 (*cmd->c_short->str_ptr == *str_get(retstr) && + strnEQ(cmd->c_short->str_ptr, str_get(retstr), + cmd->c_slen) ) { if (cmdflags & CF_EQSURE) { match = !(cmdflags & CF_FIRSTNEG); retstr = &str_yes; @@ -229,27 +251,92 @@ register CMD *cmd; case CFT_SCAN: /* non-anchored search */ scanner: retstr = STAB_STR(cmd->c_stab); - if (instr(str_get(retstr),cmd->c_first->str_ptr)) { + if (retstr->str_pok == 5) + if (screamfirst[cmd->c_short->str_rare] >= 0) + tmps = screaminstr(retstr, cmd->c_short); + else + tmps = Nullch; + else { + tmps = str_get(retstr); /* make sure it's pok */ + tmps = fbminstr(tmps, tmps + retstr->str_cur, cmd->c_short); + } + if (tmps) { if (cmdflags & CF_EQSURE) { + ++*(long*)&cmd->c_short->str_nval; match = !(cmdflags & CF_FIRSTNEG); retstr = &str_yes; goto flipmaybe; } + else + hint = tmps; + } + else { + if (cmdflags & CF_NESURE) { + ++*(long*)&cmd->c_short->str_nval; + match = cmdflags & CF_FIRSTNEG; + retstr = &str_no; + goto flipmaybe; + } + } + if (--*(long*)&cmd->c_short->str_nval < 0) { + str_free(cmd->c_short); + cmd->c_short = Nullstr; + cmdflags &= ~CF_OPTIMIZE; + cmdflags |= CFT_EVAL; /* never try this optimization again */ + cmd->c_flags = cmdflags; + } + break; /* must evaluate */ + + case CFT_NUMOP: /* numeric op optimization */ + retstr = STAB_STR(cmd->c_stab); + switch (cmd->c_slen) { + case O_EQ: + match = (str_gnum(retstr) == cmd->c_short->str_nval); + break; + case O_NE: + match = (str_gnum(retstr) != cmd->c_short->str_nval); + break; + case O_LT: + match = (str_gnum(retstr) < cmd->c_short->str_nval); + break; + case O_LE: + match = (str_gnum(retstr) <= cmd->c_short->str_nval); + break; + case O_GT: + match = (str_gnum(retstr) > cmd->c_short->str_nval); + break; + case O_GE: + match = (str_gnum(retstr) >= cmd->c_short->str_nval); + break; + } + if (match) { + if (cmdflags & CF_EQSURE) { + retstr = &str_yes; + goto flipmaybe; + } } else if (cmdflags & CF_NESURE) { - match = cmdflags & CF_FIRSTNEG; retstr = &str_no; goto flipmaybe; } break; /* must evaluate */ + case CFT_INDGETS: /* while (<$foo>) */ + last_in_stab = stabent(str_get(STAB_STR(cmd->c_stab)),TRUE); + if (!last_in_stab->stab_io) + last_in_stab->stab_io = stio_new(); + goto dogets; case CFT_GETS: /* really a while () */ last_in_stab = cmd->c_stab; + dogets: fp = last_in_stab->stab_io->fp; retstr = defstab->stab_val; if (fp && str_gets(retstr, fp)) { + if (*retstr->str_ptr == '0' && !retstr->str_ptr[1]) + match = FALSE; + else + match = TRUE; 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 */ @@ -261,7 +348,7 @@ register CMD *cmd; case CFT_EVAL: break; case CFT_UNFLIP: - retstr = eval(cmd->c_expr,Null(char***)); + retstr = eval(cmd->c_expr,Null(STR***),-1); 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); @@ -277,12 +364,32 @@ register CMD *cmd; retstr->str_cur = tmps - retstr->str_ptr; retstr = &str_chop; goto flipmaybe; + case CFT_ARRAY: + ar = cmd->c_expr[1].arg_ptr.arg_stab->stab_array; + match = ar->ary_index; /* just to get register */ + + if (match < 0) /* first time through here? */ + cmd->c_short = cmd->c_stab->stab_val; + + if (match >= ar->ary_fill) { + ar->ary_index = -1; +/* cmd->c_stab->stab_val = cmd->c_short; - Can't be done in LAST */ + match = FALSE; + } + else { + match++; + retstr = cmd->c_stab->stab_val = ar->ary_array[match]; + ar->ary_index = match; + match = TRUE; + } + goto maybe; } /* we have tried to make this normal case as abnormal as possible */ doeval: - retstr = eval(cmd->c_expr,Null(char***)); + lastretstr = retstr; + retstr = eval(cmd->c_expr,Null(STR***),-1); match = str_true(retstr); goto maybe; @@ -291,11 +398,11 @@ register CMD *cmd; 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 */ + retstr = eval(cmd->c_expr,Null(STR***),-1);/*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 */ + retstr = eval(cmd->c_expr,Null(STR***),-1);/* 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); } @@ -311,24 +418,24 @@ register CMD *cmd; maybe: if (cmdflags & CF_INVERT) match = !match; - if (!match && cmd->c_type != C_IF) { - cmd = cmd->c_next; - goto tail_recursion_entry; - } + if (!match && cmd->c_type != C_IF) + goto next_cmd; } /* now to do the actual command, if any */ switch (cmd->c_type) { case C_NULL: - fatal("panic: cmd_exec\n"); + fatal("panic: cmd_exec"); 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***)); + lastretstr = retstr; + retstr = eval(cmd->ucmd.acmd.ac_expr,Null(STR***),-1); } break; case C_IF: oldspat = curspat; + oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif @@ -336,8 +443,10 @@ register CMD *cmd; retstr = &str_yes; if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING - debname[dlevel] = 't'; - debdelim[dlevel++] = '_'; + if (debug) { + debname[dlevel] = 't'; + debdelim[dlevel++] = '_'; + } #endif retstr = cmd_exec(cmd->ucmd.ccmd.cc_true); } @@ -346,13 +455,17 @@ register CMD *cmd; retstr = &str_no; if (cmd->ucmd.ccmd.cc_alt) { #ifdef DEBUGGING - debname[dlevel] = 'e'; - debdelim[dlevel++] = '_'; + if (debug) { + debname[dlevel] = 'e'; + debdelim[dlevel++] = '_'; + } #endif retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt); } } curspat = oldspat; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); #ifdef DEBUGGING dlevel = olddlevel; #endif @@ -372,17 +485,11 @@ register CMD *cmd; } switch (setjmp(loop_stack[loop_ptr].loop_env)) { case O_LAST: - retstr = &str_no; + retstr = lastretstr; 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; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); + goto next_cmd; case O_NEXT: goto next_iter; case O_REDO: @@ -392,18 +499,21 @@ register CMD *cmd; goto doit; } oldspat = curspat; + oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif doit: if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING - debname[dlevel] = 't'; - debdelim[dlevel++] = '_'; + if (debug) { + debname[dlevel] = 't'; + debdelim[dlevel++] = '_'; + } #endif cmd_exec(cmd->ucmd.ccmd.cc_true); } - /* actually, this spot is never reached anymore since the above + /* actually, this spot is rarely reached anymore since the above * cmd_exec() returns through longjmp(). Hooray for structure. */ next_iter: @@ -412,13 +522,17 @@ register CMD *cmd; #endif if (cmd->ucmd.ccmd.cc_alt) { #ifdef DEBUGGING - debname[dlevel] = 'a'; - debdelim[dlevel++] = '_'; + if (debug) { + debname[dlevel] = 'a'; + debdelim[dlevel++] = '_'; + } #endif cmd_exec(cmd->ucmd.ccmd.cc_alt); } finish_while: curspat = oldspat; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); #ifdef DEBUGGING dlevel = olddlevel - 1; #endif @@ -427,8 +541,24 @@ register CMD *cmd; } if (cmdflags & CF_LOOP) { cmdflags |= CF_COND; /* now test the condition */ +#ifdef DEBUGGING + dlevel = entdlevel; +#endif goto until_loop; } + next_cmd: + if (cmdflags & CF_ONCE) { +#ifdef DEBUGGING + if (debug & 4) { + deb("(Popping label #%d %s)\n",loop_ptr, + loop_stack[loop_ptr].loop_label); + } +#endif + loop_ptr--; + if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY) { + cmd->c_stab->stab_val = cmd->c_short; + } + } cmd = cmd->c_next; goto tail_recursion_entry; } @@ -440,6 +570,7 @@ char *pat; { register int i; + fprintf(stderr,"%-4ld",(long)line); 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_short = which->c_short; + cmd->c_slen = which->c_slen; cmd->c_stab = which->c_stab; return cmd->c_flags; } + +void +savelist(sarg,maxsarg) +register STR **sarg; +int maxsarg; +{ + register STR *str; + register int i; + + for (i = 1; i <= maxsarg; i++) { + apush(savestack,sarg[i]); /* remember the pointer */ + str = str_new(0); + str_sset(str,sarg[i]); + apush(savestack,str); /* remember the value */ + } +} + +void +restorelist(base) +int base; +{ + register STR *str; + register STR *value; + + while (savestack->ary_fill > base) { + value = apop(savestack); + str = apop(savestack); + str_sset(str,value); + STABSET(str); + str_free(value); + } +} diff --git a/cmd.h b/cmd.h index 9a019f2c7476..e320ee274664 100644 --- a/cmd.h +++ b/cmd.h @@ -1,11 +1,8 @@ -/* $Header: cmd.h,v 1.0.1.1 88/01/28 10:23:07 root Exp $ +/* $Header: cmd.h,v 2.0 88/06/05 00:08:28 root Exp $ * * $Log: cmd.h,v $ - * Revision 1.0.1.1 88/01/28 10:23:07 root - * patch8: added eval_root for eval operator. - * - * Revision 1.0 87/12/18 13:04:59 root - * Initial revision + * Revision 2.0 88/06/05 00:08:28 root + * Baseline version 2.0. * */ @@ -15,6 +12,7 @@ #define C_EXPR 3 #define C_BLOCK 4 +#ifdef DEBUGGING #ifndef DOINIT extern char *cmdname[]; #else @@ -38,11 +36,12 @@ char *cmdname[] = { "16" }; #endif +#endif /* DEBUGGING */ #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_NESURE 0200 /* if short doesn't match we're sure */ +#define CF_EQSURE 0400 /* if short does match we're sure */ #define CF_COND 01000 /* test c_expr as conditional first, if not null. */ /* Set for everything except do {} while currently */ #define CF_LOOP 02000 /* loop on the c_expr conditional (loop modifiers) */ @@ -56,11 +55,15 @@ char *cmdname[] = { #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_GETS 6 /* c_expr is */ #define CFT_EVAL 7 /* c_expr is not optimized, so call eval() */ #define CFT_UNFLIP 8 /* 2nd half of range not optimized */ #define CFT_CHOP 9 /* c_expr is a chop on a register */ +#define CFT_ARRAY 10 /* this is a foreach loop */ +#define CFT_INDGETS 11 /* c_expr is <$variable> */ +#define CFT_NUMOP 12 /* c_expr is a numeric comparison */ +#ifdef DEBUGGING #ifndef DOINIT extern char *cmdopt[]; #else @@ -75,9 +78,13 @@ char *cmdopt[] = { "EVAL", "UNFLIP", "CHOP", - "10" + "ARRAY", + "INDGETS", + "NUMOP", + "13" }; #endif +#endif /* DEBUGGING */ struct acmd { STAB *ac_stab; /* a symbol table entry */ @@ -93,7 +100,7 @@ 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 */ + STR *c_short; /* string to match as shortcut */ STAB *c_stab; /* a symbol table entry, mostly for fp */ SPAT *c_spat; /* pattern used by optimization */ char *c_label; /* label for this construct */ @@ -101,8 +108,10 @@ struct cmd { struct acmd acmd; /* normal command */ struct ccmd ccmd; /* compound command */ } ucmd; - short c_flen; /* len of c_first, if not null */ + short c_slen; /* len of c_short, if not null */ short c_flags; /* optimization flags--see above */ + char *c_file; /* file the following line # is from */ + line_t c_line; /* line # of this command */ char c_type; /* what this command does */ }; @@ -116,11 +125,6 @@ EXT struct compcmd { 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.SH b/config.h.SH index a1778a456818..bb4b62bc7257 100644 --- a/config.h.SH +++ b/config.h.SH @@ -7,11 +7,11 @@ case $CONFIG in (echo "Can't find config.sh."; exit 1) echo "Using config.sh from above..." fi - . config.sh + . ./config.sh ;; esac echo "Extracting config.h (with variable substitutions)" -cat <config.h +sed <config.h -e 's!^#undef!/\*#undef!' /* 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 @@ -37,7 +37,7 @@ cat <config.h #$d_eunice EUNICE /**/ #$d_eunice VMS /**/ -/* CPP: +/* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard * output. Typical value of "cc -E" or "/lib/cpp". @@ -45,10 +45,10 @@ cat <config.h /* CPPMINUS: * This symbol contains the second part of the string which will invoke * the C preprocessor on the standard input and produce to standard - * output. This symbol will have the value "-" if CPP needs a minus + * output. This symbol will have the value "-" if CPPSTDIN needs a minus * to specify standard input, otherwise the value is "". */ -#define CPP "$cpp" +#define CPPSTDIN "$cppstdin" #define CPPMINUS "$cppminus" /* BCOPY: @@ -71,6 +71,40 @@ cat <config.h */ #$d_crypt CRYPT /**/ +/* DOSUID: + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +#$d_dosuid DOSUID /**/ + +/* FCHMOD: + * This symbol, if defined, indicates that the fchmod routine is available + * to change mode of opened files. If unavailable, use chmod(). + */ +#$d_fchmod FCHMOD /**/ + +/* FCHOWN: + * This symbol, if defined, indicates that the fchown routine is available + * to change ownership of opened files. If unavailable, use chown(). + */ +#$d_fchown FCHOWN /**/ + +/* GETGROUPS: + * This symbol, if defined, indicates that the getgroups() routine is + * available to get the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +#$d_getgrps GETGROUPS /**/ + /* index: * This preprocessor symbol is defined, along with rindex, if the system * uses the strchr and strrchr routines instead. @@ -82,6 +116,51 @@ cat <config.h #$d_index index strchr /* cultural */ #$d_index rindex strrchr /* differences? */ +/* KILLPG: + * This symbol, if defined, indicates that the killpg routine is available + * to kill process groups. If unavailable, you probably should use kill + * with a negative process number. + */ +#$d_killpg KILLPG /**/ + +/* MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy blocks of memory. Otherwise you should probably use bcopy(). + * If neither is defined, roll your own. + */ +#$d_memcpy MEMCPY /**/ + +/* RENAME: + * This symbol, if defined, indicates that the rename routine is available + * to rename files. Otherwise you should do the unlink(), link(), unlink() + * trick. + */ +#$d_rename RENAME /**/ + +/* SETEGID: + * This symbol, if defined, indicates that the setegid routine is available + * to change the effective gid of the current program. + */ +#$d_setegid SETEGID /**/ + +/* SETEUID: + * This symbol, if defined, indicates that the seteuid routine is available + * to change the effective uid of the current program. + */ +#$d_seteuid SETEUID /**/ + +/* SETRGID: + * This symbol, if defined, indicates that the setrgid routine is available + * to change the real gid of the current program. + */ +#$d_setrgid SETRGID /**/ + +/* SETRUID: + * This symbol, if defined, indicates that the setruid routine is available + * to change the real uid of the current program. + */ +#$d_setruid SETRUID /**/ + /* STATBLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. @@ -94,6 +173,12 @@ cat <config.h */ #$d_stdstdio STDSTDIO /**/ +/* STRCSPN: + * This symbol, if defined, indicates that the strcspn routine is available + * to scan strings. + */ +#$d_strcspn STRCSPN /**/ + /* 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 @@ -129,12 +214,24 @@ cat <config.h */ #$d_voidsig VOIDSIG /**/ +/* GIDTYPE: + * This symbol has a value like gid_t, int, ushort, or whatever type is + * used to declare group ids in the kernel. + */ +#define GIDTYPE $gidtype /**/ + /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". */ #define STDCHAR $stdchar /**/ +/* UIDTYPE: + * This symbol has a value like uid_t, int, ushort, or whatever type is + * used to declare user ids in the kernel. + */ +#define UIDTYPE $uidtype /**/ + /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: @@ -158,4 +255,11 @@ cat <config.h #$define M_VOID /* Xenix strikes again */ #endif +/* PRIVLIB: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. + */ +#define PRIVLIB "$privlib" /**/ + !GROK!THIS! diff --git a/dump.c b/dump.c index 4f93fd186c5e..156701789b30 100644 --- a/dump.c +++ b/dump.c @@ -1,15 +1,12 @@ -/* $Header: dump.c,v 1.0 87/12/18 13:05:03 root Exp $ +/* $Header: dump.c,v 2.0 88/06/05 00:08:44 root Exp $ * * $Log: dump.c,v $ - * Revision 1.0 87/12/18 13:05:03 root - * Initial revision + * Revision 2.0 88/06/05 00:08:44 root + * Baseline version 2.0. * */ -#include "handy.h" #include "EXTERN.h" -#include "search.h" -#include "util.h" #include "perl.h" #ifdef DEBUGGING @@ -23,6 +20,8 @@ register CMD *alt; while (cmd) { dumplvl++; dump("C_TYPE = %s\n",cmdname[cmd->c_type]); + if (cmd->c_line) + dump("C_LINE = %d\n",cmd->c_line); if (cmd->c_label) dump("C_LABEL = \"%s\"\n",cmd->c_label); dump("C_OPT = CFT_%s\n",cmdopt[cmd->c_flags & CF_OPTIMIZE]); @@ -46,9 +45,9 @@ register CMD *alt; 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_short) { + dump("C_SHORT = \"%s\"\n",str_peek(cmd->c_short)); + dump("C_SLEN = \"%d\"\n",cmd->c_slen); } if (cmd->c_stab) { dump("C_STAB = "); @@ -81,7 +80,7 @@ register CMD *alt; case C_EXPR: if (cmd->ucmd.acmd.ac_stab) { dump("AC_STAB = "); - dump_arg(cmd->ucmd.acmd.ac_stab); + dump_stab(cmd->ucmd.acmd.ac_stab); } else dump("AC_STAB = NULL\n"); if (cmd->ucmd.acmd.ac_expr) { @@ -117,26 +116,18 @@ register ARG *arg; dumplvl++; dump("OP_TYPE = %s\n",opname[arg->arg_type]); dump("OP_LEN = %d\n",arg->arg_len); + if (arg->arg_flags) { + dump_flags(buf,arg->arg_flags); + dump("OP_FLAGS = (%s)\n",buf); + } for (i = 1; i <= arg->arg_len; i++) { dump("[%d]ARG_TYPE = %s\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); + if (arg[i].arg_flags) { + dump_flags(buf,arg[i].arg_flags); + dump("[%d]ARG_FLAGS = (%s)\n",i,buf); + } switch (arg[i].arg_type) { case A_NULL: break; @@ -149,9 +140,11 @@ register ARG *arg; dump("[%d]ARG_CMD = ",i); dump_cmd(arg[i].arg_ptr.arg_cmd,Nullcmd); break; + case A_WORD: case A_STAB: case A_LVAL: case A_READ: + case A_GLOB: case A_ARYLEN: dump("[%d]ARG_STAB = ",i); dump_stab(arg[i].arg_ptr.arg_stab); @@ -174,9 +167,38 @@ register ARG *arg; dump("}\n"); } +dump_flags(b,flags) +char *b; +unsigned flags; +{ + *b = '\0'; + if (flags & AF_SPECIAL) + strcat(b,"SPECIAL,"); + if (flags & AF_POST) + strcat(b,"POST,"); + if (flags & AF_PRE) + strcat(b,"PRE,"); + if (flags & AF_UP) + strcat(b,"UP,"); + if (flags & AF_COMMON) + strcat(b,"COMMON,"); + if (flags & AF_NUMERIC) + strcat(b,"NUMERIC,"); + if (flags & AF_LISTISH) + strcat(b,"LISTISH,"); + if (flags & AF_LOCAL) + strcat(b,"LOCAL,"); + if (*b) + b[strlen(b)-1] = '\0'; +} + dump_stab(stab) register STAB *stab; { + if (!stab) { + fprintf(stderr,"{}\n"); + return; + } dumplvl++; fprintf(stderr,"{\n"); dump("STAB_NAME = %s\n",stab->stab_name); @@ -189,28 +211,37 @@ register SPAT *spat; { char ch; + if (!spat) { + fprintf(stderr,"{}\n"); + return; + } fprintf(stderr,"{\n"); dumplvl++; if (spat->spat_runtime) { dump("SPAT_RUNTIME = "); dump_arg(spat->spat_runtime); } else { - if (spat->spat_flags & SPAT_USE_ONCE) + if (spat->spat_flags & SPAT_ONCE) ch = '?'; else ch = '/'; - dump("SPAT_PRE %c%s%c\n",ch,spat->spat_compex.precomp,ch); + dump("SPAT_PRE %c%s%c\n",ch,spat->spat_regexp->precomp,ch); } if (spat->spat_repl) { dump("SPAT_REPL = "); dump_arg(spat->spat_repl); } + if (spat->spat_short) { + dump("SPAT_SHORT = \"%s\"\n",str_peek(spat->spat_short)); + } dumplvl--; dump("}\n"); } +/* VARARGS1 */ dump(arg1,arg2,arg3,arg4,arg5) -char *arg1, *arg2, *arg3, *arg4, *arg5; +char *arg1; +long arg2, arg3, arg4, arg5; { int i; diff --git a/eg/ADB b/eg/ADB new file mode 100644 index 000000000000..1a43b903808e --- /dev/null +++ b/eg/ADB @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +# $Header: ADB,v 2.0 88/06/05 00:16:39 root Exp $ + +# This script is only useful when used in your crash directory. + +$num = shift; +exec 'adb', '-k', "vmunix.$num", "vmcore.$num"; diff --git a/eg/README b/eg/README new file mode 100644 index 000000000000..bec7538f83ac --- /dev/null +++ b/eg/README @@ -0,0 +1,18 @@ +This stuff is supplied on an as-is basis--little attempt has been made to make +any of it portable. It's mostly here to give you an idea of what perl code +looks like, and what tricks and idioms are used. + +System administrators responsible for many computers will enjoy the items +down in the g directory very much. The scan directory contains the beginnings +of a system to check on and report various kinds of anomalies. + +If you machine doesn't support #!, the first thing you'll want to do is +replace the #! with a couple of lines that look like this: + + eval "exec /usr/bin/perl -S $0 $*" + if $running_under_some_shell; + +being sure to include any flags that were on the #! line. A supplied script +called "nih" will translate perl scripts in place for you: + + nih g/g?? diff --git a/eg/changes b/eg/changes new file mode 100644 index 000000000000..db9b7b1d53a1 --- /dev/null +++ b/eg/changes @@ -0,0 +1,34 @@ +#!/usr/bin/perl -P + +# $Header: changes,v 2.0 88/06/05 00:16:41 root Exp $ + +($dir, $days) = @ARGV; +$dir = '/' if $dir eq ''; +$days = '14' if $days eq ''; + +# Masscomps do things differently from Suns + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Find, "find $dir -mtime -$days -print |") || + die "changes: can't run find"; +#else +open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") || + die "changes: can't run find"; +#endif + +while () { + +#if defined(mc300) || defined(mc500) || defined(mc700) + $x = `/bin/ls -ild $_`; + $_ = $x; + ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split(' '); +#else + ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split(' '); +#endif + + printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n", + $perm,$links,$owner,$group,$size,$month,$day,$name); +} + diff --git a/eg/dus b/eg/dus new file mode 100644 index 000000000000..8c7ff9434033 --- /dev/null +++ b/eg/dus @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +# $Header: dus,v 2.0 88/06/05 00:16:44 root Exp $ + +# This script does a du -s on any directories in the current directory that +# are not mount points for another filesystem. + +($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('.'); + +open(ls,'ls -F1|'); + +while () { + chop; + next unless s|/$||; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($_); + next unless $dev == $mydev; + push(@ary,$_); +} + +exec 'du', '-s', @ary; diff --git a/eg/findcp b/eg/findcp new file mode 100644 index 000000000000..57cac2e36731 --- /dev/null +++ b/eg/findcp @@ -0,0 +1,53 @@ +#!/usr/bin/perl + +# $Header: findcp,v 2.0 88/06/05 00:16:47 root Exp $ + +# This is a wrapper around the find command that pretends find has a switch +# of the form -cp host:destination. It presumes your find implements -ls. +# It uses tar to do the actual copy. If your tar knows about the I switch +# you may prefer to use findtar, since this one has to do the tar in batches. + +sub copy { + `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`; +} + +$sourcedir = $ARGV[0]; +if ($sourcedir =~ /^\//) { + $ARGV[0] = '.'; + unless (chdir($sourcedir)) { die "Can't find directory: $sourcedir"; } +} + +$args = join(' ',@ARGV); +if ($args =~ s/-cp *([^ ]+)/-ls/) { + $dest = $1; + if ($dest =~ /(.*):(.*)/) { + $desthost = $1; + $destdir = $2; + } + else { + die "Malformed destination--should be host:directory"; + } +} +else { + die("No destination specified"); +} + +open(find,"find $args |") || die "Can't run find for you."; + +while () { + @x = split(' '); + if ($x[2] =~ /^d/) { next;} + chop($filename = $x[10]); + if (length($list) > 5000) { + do copy(); + $list = ''; + } + else { + $list .= ' '; + } + $list .= $filename; +} + +if ($list) { + do copy(); +} diff --git a/eg/findtar b/eg/findtar new file mode 100644 index 000000000000..8b604b396fd8 --- /dev/null +++ b/eg/findtar @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +# $Header: findtar,v 2.0 88/06/05 00:16:49 root Exp $ + +# findtar takes find-style arguments and spits out a tarfile on stdout. +# It won't work unless your find supports -ls and your tar the I flag. + +$args = join(' ',@ARGV); +open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you."; + +open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you."; + +while () { + @x = split(' '); + if ($x[2] =~ /^d/) { print tar '-d ';} + print tar $x[10],"\n"; +} diff --git a/eg/g/gcp b/eg/g/gcp new file mode 100644 index 000000000000..6b4a9a79f77b --- /dev/null +++ b/eg/g/gcp @@ -0,0 +1,114 @@ +#!/usr/bin/perl + +# $Header: gcp,v 2.0 88/06/05 00:17:02 root Exp $ + +# Here is a script to do global rcps. See man page. + +$#ARGV >= 1 || die "Not enough arguments.\n"; + +if ($ARGV[0] eq '-r') { + $rcp = 'rcp -r'; + shift; +} else { + $rcp = 'rcp'; +} +$args = $rcp; +$dest = $ARGV[$#ARGV]; + +$SIG{'QUIT'} = 'CLEANUP'; +$SIG{'INT'} = 'CONT'; + +while ($arg = shift) { + if ($arg =~ /^([-a-zA-Z0-9_+]+):/) { + if ($systype && $systype ne $1) { + die "Can't mix system type specifers ($systype vs $1).\n"; + } + $#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n"; + $systype = $1; + $args .= " $arg"; + } else { + if ($#ARGV >= 0) { + if ($arg =~ /^[\/~]/) { + $arg =~ /^(.*)\// && ($dir = $1); + } else { + if (!$pwd) { + chop($pwd = `pwd`); + } + $dir = $pwd; + } + } + if ($olddir && $dir ne $olddir && $dest =~ /:$/) { + $args .= " $dest$olddir; $rcp"; + } + $olddir = $dir; + $args .= " $arg"; + } +} + +die "No system type specified.\n" unless $systype; + +$args =~ s/:$/:$olddir/; + +chop($thishost = `hostname`); + +$one_of_these = ":$systype:"; +if ($systype =~ s/\+/[+]/g) { + $one_of_these =~ s/\+/:/g; +} +$one_of_these =~ s/-/:-/g; + +@ARGV = (); +push(@ARGV,'.grem') if -f '.grem'; +push(@ARGV,'.ghosts') if -f '.ghosts'; +push(@ARGV,'/etc/ghosts'); + +$remainder = ''; + +line: while (<>) { + s/[ \t]*\n//; + if (!$_ || /^#/) { + next line; + } + if (/^([a-zA-Z_0-9]+)=(.+)/) { + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $repl =~ s/-/:-/g; + $one_of_these =~ s/:$name:/:$repl:/; + $repl =~ s/:/:-/g; + $one_of_these =~ s/:-$name:/:-$repl:/g; + next line; + } + @gh = split(' '); + $host = $gh[0]; + next line if $host eq $thishost; # should handle aliases too + $wanted = 0; + foreach $class (@gh) { + $wanted++ if index($one_of_these,":$class:") >= 0; + $wanted = -9999 if index($one_of_these,":-$class:") >= 0; + } + if ($wanted > 0) { + ($cmd = $args) =~ s/[ \t]$systype:/ $host:/g; + print "$cmd\n"; + $result = `$cmd 2>&1`; + $remainder .= "$host+" if + $result =~ /Connection timed out|Permission denied/; + print $result; + } +} + +if ($remainder) { + chop($remainder); + open(grem,">.grem") || (printf stderr "Can't create .grem\n"); + print grem 'rem=', $remainder, "\n"; + close(grem); + print 'rem=', $remainder, "\n"; +} + +sub CLEANUP { + exit; +} + +sub CONT { + print "Continuing...\n"; # Just ignore the signal that kills rcp + $remainder .= "$host+"; +} diff --git a/eg/g/gcp.man b/eg/g/gcp.man new file mode 100644 index 000000000000..83c5d85ca49e --- /dev/null +++ b/eg/g/gcp.man @@ -0,0 +1,77 @@ +.\" $Header: gcp.man,v 2.0 88/06/05 00:17:05 root Exp $ +.TH GCP 1C "13 May 1988" +.SH NAME +gcp \- global file copy +.SH SYNOPSIS +.B gcp +file1 file2 +.br +.B gcp +[ +.B \-r +] file ... directory +.SH DESCRIPTION +.I gcp +works just like rcp(1C) except that you may specify a set of hosts to copy files +from or to. +The host sets are defined in the file /etc/ghosts. +(An individual host name can be used as a set containing one member.) +You can give a command like + + gcp /etc/motd sun: + +to copy your /etc/motd file to /etc/motd on all the Suns. +If, on the other hand, you say + + gcp /a/foo /b/bar sun:/tmp + +then your files will be copied to /tmp on all the Suns. +The general rule is that if you don't specify the destination directory, +files go to the same directory they are in currently. +.P +You may specify the union of two or more sets by using + as follows: + + gcp /a/foo /b/bar 750+mc: + +which will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy +/b/bar to /b/bar on all 750's and Masscomps. +.P +Commonly used sets should be defined in /etc/ghosts. +For example, you could add a line that says + + pep=manny+moe+jack + +Another way to do that would be to add the word "pep" after each of the host +entries: + + manny sun3 pep +.br + moe sun3 pep +.br + jack sun3 pep + +Hosts and sets of host can also be excluded: + + foo=sun-sun2 + +Any host so excluded will never be included, even if a subsequent set on the +line includes it: + + foo=abc+def +.br + bar=xyz-abc+foo + +comes out to xyz+def. + +You can define private host sets by creating .ghosts in your current directory +with entries just like /etc/ghosts. +Also, if there is a file .grem, it defines "rem" to be the remaining hosts +from the last gsh or gcp that didn't succeed everywhere. +.PP +Interrupting with a SIGINT will cause the rcp to the current host to be skipped +and execution resumed with the next host. +To stop completely, send a SIGQUIT. +.SH SEE ALSO +rcp(1C) +.SH BUGS +All the bugs of rcp, since it calls rcp. diff --git a/eg/g/ged b/eg/g/ged new file mode 100644 index 000000000000..bb7c222b3a5a --- /dev/null +++ b/eg/g/ged @@ -0,0 +1,21 @@ +#!/usr/bin/perl + +# $Header: ged,v 2.0 88/06/05 00:17:08 root Exp $ + +# Does inplace edits on a set of files on a set of machines. +# +# Typical invokation: +# +# ged vax+sun /etc/passwd +# s/Freddy/Freddie/; +# ^D +# + +$class = shift; +$files = join(' ',@ARGV); + +die "Usage: ged class files /tmp/gsh$$`; # get input into a handy place + $dist = " ) { # for each line of ghosts + + s/[ \t]*\n//; # trim trailing whitespace + if (!$_ || /^#/) { # skip blank line or comment + next line; + } + + if (/^(\w+)=(.+)/) { # a macro line? + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $repl =~ s/-/:-/g; + $one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list + $repl =~ s/:/:-/g; + $one_of_these =~ s/:-$name:/:-$repl:/; + next line; + } + + # we have a normal line + + @attr = split(' '); # a list of attributes to match against + # which we put into an array + $host = $attr[0]; # the first attribute is the host name + if ($showhost) { + $showhost = "$host:\t"; + } + + $wanted = 0; + foreach $attr (@attr) { # iterate over attribute array + $wanted++ if index($one_of_these,":$attr:") >= 0; + $wanted = -9999 if index($one_of_these,":-$attr:") >= 0; + } + if ($wanted > 0) { + print "rsh $host$l$n '$cmd'\n" unless $silent; + $SIG{'INT'} = 'DEFAULT'; + if (open(pipe,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh + $SIG{'INT'} = 'cont'; + for ($iter=0; ; $iter++) { + unless ($iter) { + $remainder .= "$host+" + if /Connection timed out|Permission denied/; + } + print $showhost,$_; + } + close(pipe); + } else { + $SIG{'INT'} = 'cont'; + print "(Can't execute rsh.)\n"; + } + } +} + +unlink "/tmp/gsh$$" if $dodist; + +if ($remainder) { + chop($remainder); + open(grem,">.grem") || (printf stderr "Can't make a .grem file\n"); + print grem 'rem=', $remainder, "\n"; + close(grem); + print 'rem=', $remainder, "\n"; +} + +# here are a couple of subroutines that serve as signal handlers + +sub cont { + print "\rContinuing...\n"; + $remainder .= "$host+"; +} + +sub quit { + $| = 1; + print "\r"; + $SIG{'INT'} = ''; + kill 2, $$; +} diff --git a/eg/g/gsh.man b/eg/g/gsh.man new file mode 100644 index 000000000000..4522129df0ad --- /dev/null +++ b/eg/g/gsh.man @@ -0,0 +1,80 @@ +.\" $Header: gsh.man,v 2.0 88/06/05 00:17:23 root Exp $ +.TH GSH 8 "13 May 1988" +.SH NAME +gsh \- global shell +.SH SYNOPSIS +.B gsh +[options] +.I host +[options] +.I command +.SH DESCRIPTION +.I gsh +works just like rsh(1C) except that you may specify a set of hosts to execute +the command on. +The host sets are defined in the file /etc/ghosts. +(An individual host name can be used as a set containing one member.) +You can give a command like + + gsh sun /etc/mungmotd + +to run /etc/mungmotd on all your Suns. +.P +You may specify the union of two or more sets by using + as follows: + + gsh 750+mc /etc/mungmotd + +which will run mungmotd on all 750's and Masscomps. +.P +Commonly used sets should be defined in /etc/ghosts. +For example, you could add a line that says + + pep=manny+moe+jack + +Another way to do that would be to add the word "pep" after each of the host +entries: + + manny sun3 pep +.br + moe sun3 pep +.br + jack sun3 pep + +Hosts and sets of host can also be excluded: + + foo=sun-sun2 + +Any host so excluded will never be included, even if a subsequent set on the +line includes it: + + foo=abc+def + bar=xyz-abc+foo + +comes out to xyz+def. + +You can define private host sets by creating .ghosts in your current directory +with entries just like /etc/ghosts. +Also, if there is a file .grem, it defines "rem" to be the remaining hosts +from the last gsh or gcp that didn't succeed everywhere. + +Options include all those defined by rsh, as well as + +.IP "\-d" 8 +Causes gsh to collect input till end of file, and then distribute that input +to each invokation of rsh. +.IP "\-h" 8 +Rather than print out the command followed by the output, merely prepends the +host name to each line of output. +.IP "\-s" 8 +Do work silently. +.PP +Interrupting with a SIGINT will cause the rsh to the current host to be skipped +and execution resumed with the next host. +To stop completely, send a SIGQUIT. +.SH SEE ALSO +rsh(1C) +.SH BUGS +All the bugs of rsh, since it calls rsh. + +Also, will not properly return data from the remote execution that contains +null characters. diff --git a/eg/myrup b/eg/myrup new file mode 100644 index 000000000000..c32c99ccd234 --- /dev/null +++ b/eg/myrup @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +# $Header: myrup,v 2.0 88/06/05 00:16:51 root Exp $ + +# This was a customization of ruptime requested by someone here who wanted +# to be able to find the least loaded machine easily. It uses the +# /etc/ghosts file that's defined for gsh and gcp to prune down the +# number of entries to those hosts we have administrative control over. + +print "node load (u)\n------- --------\n"; + +open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts"; +line: while () { + next line if /^#/; + next line if /^$/; + next line if /=/; + ($host) = split; + $wanted{$host} = 1; +} + +open(ruptime,'ruptime|') || die "Can't run ruptime"; +open(sort,'|sort +1n'); + +while () { + ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/); + if ($wanted{$host} && $upness eq 'up') { + printf sort "%s\t%s (%d)\n", $host, $load, $users; + } +} diff --git a/eg/nih b/eg/nih new file mode 100644 index 000000000000..15cb60f49657 --- /dev/null +++ b/eg/nih @@ -0,0 +1,10 @@ +eval "exec /usr/bin/perl -Spi.bak $0 $*" + if $running_under_some_shell; + +# $Header: nih,v 2.0 88/06/05 00:16:54 root Exp $ + +# This script makes #! scripts directly executable on machines that don't +# support #!. It edits in place any scripts mentioned on the command line. + +s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;| + if $. == 1; diff --git a/eg/rmfrom b/eg/rmfrom new file mode 100644 index 000000000000..0fca30413e5c --- /dev/null +++ b/eg/rmfrom @@ -0,0 +1,7 @@ +#!/usr/bin/perl -n + +# $Header: rmfrom,v 2.0 88/06/05 00:16:57 root Exp $ + +# A handy (but dangerous) script to put after a find ... -print. + +chop; unlink; diff --git a/eg/scan/scan_df b/eg/scan/scan_df new file mode 100644 index 000000000000..ca316425e4a7 --- /dev/null +++ b/eg/scan/scan_df @@ -0,0 +1,51 @@ +#!/usr/bin/perl -P + +# $Header: scan_df,v 2.0 88/06/05 00:17:56 root Exp $ + +# This report points out filesystems that are in danger of overflowing. + +(chdir '/usr/adm/private/memories') || die "Can't cd."; +`df >newdf`; +open(Df, 'olddf'); + +while () { + ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; + next if $fs =~ /:/; + next if $fs eq ''; + $oldused{$fs} = $used; +} + +open(Df, 'newdf') || die "scan_df: can't open newdf"; + +while () { + ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; + next if $fs =~ /:/; + next if $fs eq ''; + $oldused = $oldused{$fs}; + next if ($oldused == $used && $capacity < 99); # inactive filesystem + if ($capacity >= 90) { +#if defined(mc300) || defined(mc500) || defined(mc700) + $_ = substr($_,0,13) . ' ' . substr($_,13,1000); + $kbytes /= 2; # translate blocks to K + $used /= 2; + $oldused /= 2; + $avail /= 2; +#endif + $diff = int($used - $oldused); + if ($avail < $diff * 2) { # mark specially if in danger + $mounted_on .= ' *'; + } + next if $diff < 50 && $mounted_on eq '/'; + $fs =~ s|/dev/||; + if ($diff >= 0) { + $diff = '(+' . $diff . ')'; + } + else { + $diff = '(' . $diff . ')'; + } + printf "%-8s%8d%8d %-8s%8d%7s %s\n", + $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on; + } +} + +rename('newdf','olddf'); diff --git a/eg/scan/scan_last b/eg/scan/scan_last new file mode 100644 index 000000000000..25d7843e308e --- /dev/null +++ b/eg/scan/scan_last @@ -0,0 +1,57 @@ +#!/usr/bin/perl -P + +# $Header: scan_last,v 2.0 88/06/05 00:17:58 root Exp $ + +# This reports who was logged on at weird hours + +($dy, $mo, $lastdt) = split(/ +/,`date`); + +open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last"; + +while () { +#if defined(mc300) || defined(mc500) || defined(mc700) + $_ = substr($_,0,19) . substr($_,23,100); +#endif + next if /^$/; + (print),next if m|^/|; + $login = substr($_,0,8); + $tty = substr($_,10,7); + $from = substr($_,19,15); + $day = substr($_,36,3); + $mo = substr($_,40,3); + $dt = substr($_,44,2); + $hr = substr($_,47,2); + $min = substr($_,50,2); + $dash = substr($_,53,1); + $tohr = substr($_,55,2); + $tomin = substr($_,58,2); + $durhr = substr($_,63,2); + $durmin = substr($_,66,2); + + next unless $hr; + next if $login eq 'reboot '; + next if $login eq 'shutdown'; + + if ($dt != $lastdt) { + if ($lastdt < $dt) { + $seen += $dt - $lastdt; + } + else { + $seen++; + } + $lastdt = $dt; + } + + $inat = $hr + $min / 60; + if ($tohr =~ /^[a-z]/) { + $outat = 12; # something innocuous + } else { + $outat = $tohr + $tomin / 60; + } + + last if $seen + ($inat < 8) > 1; + + if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) { + print; + } +} diff --git a/eg/scan/scan_messages b/eg/scan/scan_messages new file mode 100644 index 000000000000..6f8ab2b58bec --- /dev/null +++ b/eg/scan/scan_messages @@ -0,0 +1,222 @@ +#!/usr/bin/perl -P + +# $Header: scan_messages,v 2.0 88/06/05 00:17:46 root Exp $ + +# This prints out extraordinary console messages. You'll need to customize. + +chdir('/usr/adm/private/memories') || die "Can't cd."; + +$maxpos = `cat oldmsgs 2>&1`; + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Msgs, '/dev/null') || die "scan_messages: can't open messages"; +#else +open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages"; +#endif + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(Msgs); + +if ($size < $maxpos) { # Did somebody truncate messages file? + $maxpos = 0; +} + +seek(Msgs,$maxpos,0); # Start where we left off last time. + +while () { + s/\[(\d+)\]/#/ && s/$1/#/g; +#ifdef vax + $_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//; + next if /root@.*:/; + next if /^vmunix: 4.3 BSD UNIX/; + next if /^vmunix: Copyright/; + next if /^vmunix: avail mem =/; + next if /^vmunix: SBIA0 at /; + next if /^vmunix: disk ra81 is/; + next if /^vmunix: dmf. at uba/; + next if /^vmunix: dmf.:.*asynch/; + next if /^vmunix: ex. at uba/; + next if /^vmunix: ex.: HW/; + next if /^vmunix: il. at uba/; + next if /^vmunix: il.: hardware/; + next if /^vmunix: ra. at uba/; + next if /^vmunix: ra.: media/; + next if /^vmunix: real mem/; + next if /^vmunix: syncing disks/; + next if /^vmunix: tms/; + next if /^vmunix: tmscp. at uba/; + next if /^vmunix: uba. at /; + next if /^vmunix: uda. at /; + next if /^vmunix: uda.: unit . ONLIN/; + next if /^vmunix: .*buffers containing/; + next if /^syslogd: .*newslog/; +#endif + next if /unknown service/; + next if /^\.\.\.$/; + if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) { + $pfx = ''; + next; + } + next if /^[ \t]*$/; + next if /^[ 0-9]*done$/; + if (/^A/) { + next if /^Accounting [sr]/; + } + elsif (/^C/) { + next if /^Called from/; + next if /^Copyright/; + } + elsif (/^E/) { + next if /^End traceback/; + next if /^Ethernet address =/; + } + elsif (/^K/) { + next if /^KERNEL MODE/; + } + elsif (/^R/) { + next if /^Rebooting Unix/; + } + elsif (/^S/) { + next if /^Sun UNIX 4\.2 Release/; + } + elsif (/^W/) { + next if /^WARNING: clock gained/; + } + elsif (/^a/) { + next if /^arg /; + next if /^avail mem =/; + } + elsif (/^b/) { + next if /^bwtwo[0-9] at /; + } + elsif (/^c/) { + next if /^cgone[0-9] at /; + next if /^cdp[0-9] at /; + next if /^csr /; + } + elsif (/^d/) { + next if /^dcpa: init/; + next if /^done$/; + next if /^dts/; + next if /^dump i\/o error/; + next if /^dumping to dev/; + next if /^dump succeeded/; + $pfx = '*' if /^dev = /; + } + elsif (/^e/) { + next if /^end \*\*/; + next if /^error in copy/; + } + elsif (/^f/) { + next if /^found /; + } + elsif (/^i/) { + next if /^ib[0-9] at /; + next if /^ie[0-9] at /; + } + elsif (/^l/) { + next if /^le[0-9] at /; + } + elsif (/^m/) { + next if /^mem = /; + next if /^mt[0-9] at /; + next if /^mti[0-9] at /; + $pfx = '*' if /^mode = /; + } + elsif (/^n/) { + next if /^not found /; + } + elsif (/^p/) { + next if /^page map /; + next if /^pi[0-9] at /; + $pfx = '*' if /^panic/; + } + elsif (/^q/) { + next if /^qqq /; + } + elsif (/^r/) { + next if /^read /; + next if /^revarp: Requesting/; + next if /^root [od]/; + } + elsif (/^s/) { + next if /^sc[0-9] at /; + next if /^sd[0-9] at /; + next if /^sd[0-9]: oldmsgs.tmp') || die "Can't create tmp file."; +while ($_ = pop(@seen)) { + print tmp $_; +} +close(tmp); +open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file."; +while () { + if (/^nd:/) { + next if $seen{$_} < 20; + } + if (/NFS/) { + next if $seen{$_} < 20; + } + if (/no carrier/) { + next if $seen{$_} < 20; + } + if (/silo overflow/) { + next if $seen{$_} < 20; + } + print $seen{$_},":\t",$_; +} + +print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`; diff --git a/eg/scan/scan_passwd b/eg/scan/scan_passwd new file mode 100644 index 000000000000..62ef1e779424 --- /dev/null +++ b/eg/scan/scan_passwd @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +# $Header: scan_passwd,v 2.0 88/06/05 00:17:49 root Exp $ + +# This scans passwd file for security holes. + +open(Pass,'/etc/passwd') || die "Can't open passwd file"; +# $dotriv = (`date` =~ /^Mon/); +$dotriv = 1; + +while () { + ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/); + if ($shell eq '') { + print "Short: $_"; + } + next if /^[+]/; + if ($pass eq '') { + if (index(":sync:lpq:+:", ":$login:") < 0) { + print "No pass: $login\t$gcos\n"; + } + } + elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) { + print "Trivial: $login\t$gcos\n"; + } + if ($uid == 0) { + if ($login !~ /^.?root$/ && $pass ne '*') { + print "Extra root: $_"; + } + } +} diff --git a/eg/scan/scan_ps b/eg/scan/scan_ps new file mode 100644 index 000000000000..bb33b87ae8fd --- /dev/null +++ b/eg/scan/scan_ps @@ -0,0 +1,32 @@ +#!/usr/bin/perl -P + +# $Header: scan_ps,v 2.0 88/06/05 00:17:51 root Exp $ + +# This looks for looping processes. + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps"; + +while () { + next if /rwhod/; + print if index(' T', substr($_,62,1)) < 0; +} +#else +open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps"; + +while () { + next if /dataserver/; + next if /nfsd/; + next if /update/; + next if /ypserv/; + next if /rwhod/; + next if /routed/; + next if /pagedaemon/; +#ifdef vax + ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split; +#else + ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split; +#endif + print if length($time) > 4; +} +#endif diff --git a/eg/scan/scan_sudo b/eg/scan/scan_sudo new file mode 100644 index 000000000000..e0a99ee0c3f3 --- /dev/null +++ b/eg/scan/scan_sudo @@ -0,0 +1,54 @@ +#!/usr/bin/perl -P + +# $Header: scan_sudo,v 2.0 88/06/05 00:18:01 root Exp $ + +# Analyze the sudo log. + +chdir('/usr/adm/private/memories') || die "Can't cd."; + +if (open(Oldsudo,'oldsudo')) { + $maxpos = ; + close Oldsudo; +} +else { + $maxpos = 0; + `echo 0 >oldsudo`; +} + +unless (open(Sudo, '/usr/adm/sudo.log')) { + print "Somebody removed sudo.log!!!\n" if $maxpos; + exit 0; +} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(Sudo); + +if ($size < $maxpos) { + $maxpos = 0; + print "Somebody reset sudo.log!!!\n"; +} + +seek(Sudo,$maxpos,0); + +while () { + s/^.* :[ \t]+//; + s/ipcrm.*/ipcrm/; + s/kill.*/kill/; + unless ($seen{$_}++) { + push(@seen,$_); + } + $last = $_; +} +$max = tell(Sudo); + +open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file."; +while ($_ = pop(@seen)) { + print tmp $_; +} +close(tmp); +open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file."; +while () { + print $seen{$_},":\t",$_; +} + +print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`; diff --git a/eg/scan/scan_suid b/eg/scan/scan_suid new file mode 100644 index 000000000000..4f62705504ac --- /dev/null +++ b/eg/scan/scan_suid @@ -0,0 +1,84 @@ +#!/usr/bin/perl -P + +# $Header: scan_suid,v 2.0 88/06/05 00:17:54 root Exp $ + +# Look for new setuid root files. + +chdir '/usr/adm/private/memories' || die "Can't cd."; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('oldsuid'); +if ($nlink) { + $lasttime = $mtime; + $tmp = $ctime - $atime; + if ($tmp <= 0 || $tmp >= 10) { + print "WARNING: somebody has read oldsuid!\n"; + } + $tmp = $ctime - $mtime; + if ($tmp <= 0 || $tmp >= 10) { + print "WARNING: somebody has modified oldsuid!!!\n"; + } +} else { + $lasttime = time - 60 * 60 * 24; # one day ago +} +$thistime = time; + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Find, 'find / -perm -04000 -print |') || + die "scan_find: can't run find"; +#else +open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') || + die "scan_find: can't run find"; +#endif + +open(suid, '>newsuid.tmp'); + +while () { + +#if defined(mc300) || defined(mc500) || defined(mc700) + $x = `/bin/ls -il $_`; + $_ = $x; + s/^ *//; + ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split; +#else + s/^ *//; + ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split; +#endif + + if ($perm =~ /[sS]/ && $owner eq 'root') { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($name); + $foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n", + $perm,$links,$owner,$group,$size,$month,$day,$name,$inode); + print suid $foo; + if ($ctime > $lasttime) { + if ($ctime > $thistime) { + print "Future file: $foo"; + } + else { + $ct .= $foo; + } + } + } +} +close(suid); + +print `sort +7 -8 newsuid.tmp >newsuid 2>&1`; +$foo = `/bin/diff oldsuid newsuid 2>&1`; +print "Differences in suid info:\n",$foo if $foo; +print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`; +print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`; +print `rm -f newsuid.tmp 2>&1`; + +@ct = split(/\n/,$ct); +$ct = ''; +$* = 1; +while ($#ct >= 0) { + $tmp = shift(@ct); + unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; } +} + +print "Inode changed since last time:\n",$ct if $ct; + diff --git a/eg/scan/scanner b/eg/scan/scanner new file mode 100644 index 000000000000..25e953d402a4 --- /dev/null +++ b/eg/scan/scanner @@ -0,0 +1,87 @@ +#!/usr/bin/perl + +# $Header: scanner,v 2.0 88/06/05 00:17:42 root Exp $ + +# This runs all the scan_* routines on all the machines in /etc/ghosts. +# We run this every morning at about 6 am: + +# !/bin/sh +# cd /usr/adm/private +# decrypt scanner | perl >scan.out 2>&1 +# mail admin = 0) { + @scanlist = @ARGV; +} else { + @scanlist = split(/[ \t\n]+/,`echo scan_*`); +} + +scan: while ($scan = shift(@scanlist)) { + print "\n********** $scan **********\n"; + $showhost++; + + $systype = 'all'; + + open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file'; + + $one_of_these = ":$systype:"; + if ($systype =~ s/\+/[+]/g) { + $one_of_these =~ s/\+/:/g; + } + + line: while () { + s/[ \t]*\n//; + if (!$_ || /^#/) { + next line; + } + if (/^([a-zA-Z_0-9]+)=(.+)/) { + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $one_of_these =~ s/:$name:/:$repl:/; + next line; + } + @gh = split; + $host = $gh[0]; + if ($showhost) { $showhost = "$host:\t"; } + class: while ($class = pop(gh)) { + if (index($one_of_these,":$class:") >=0) { + $iter = 0; + `exec crypt -inquire <$scan >.x 2>/dev/null`; + unless (open(scan,'.x')) { + print "Can't run $scan."; + next scan; + } + $cmd = ; + unless ($cmd =~ s/#!(.*)\n/$1/) { + $cmd = '/usr/bin/perl'; + } + close(scan); + if (open(pipe,"exec rsh $host '$cmd' <.x|")) { + sleep(5); + unlink '.x'; + while () { + last if $iter++ > 1000; # must be looping + next if /^[0-9.]+u [0-9.]+s/; + print $showhost,$_; + } + close(pipe); + } else { + print "(Can't execute rsh.)\n"; + } + last class; + } + } + } +} diff --git a/eg/shmkill b/eg/shmkill new file mode 100644 index 000000000000..ba288d8e0dc1 --- /dev/null +++ b/eg/shmkill @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +# $Header: shmkill,v 2.0 88/06/05 00:16:59 root Exp $ + +# A script to call from crontab periodically when people are leaving shared +# memory sitting around unattached. + +open(ipcs,'ipcs -m -o|') || die "Can't run ipcs"; + +while () { + $tmp = index($_,'NATTCH'); + $pos = $tmp if $tmp >= 0; + if (/^m/) { + ($m,$id,$key,$mode,$owner,$group,$attach) = split; + if ($attach != substr($_,$pos,6)) { + die "Different ipcs format--can't parse!"; + } + if ($attach == 0) { + push(@goners,'-m',$id); + } + } +} + +exec 'ipcrm', @goners if $#goners >= 0; diff --git a/eg/van/empty b/eg/van/empty new file mode 100644 index 000000000000..11a55583e1e4 --- /dev/null +++ b/eg/van/empty @@ -0,0 +1,45 @@ +#!/usr/bin/perl + +# $Header: empty,v 2.0 88/06/05 00:17:39 root Exp $ + +# This script empties a trashcan. + +$recursive = shift if $ARGV[0] eq '-r'; + +@ARGV = '.' if $#ARGV < 0; + +chop($pwd = `pwd`); + +dir: foreach $dir (@ARGV) { + unless (chdir $dir) { + print stderr "Can't find directory $dir\n"; + next dir; + } + if ($recursive) { + do cmd('find . -name .deleted -exec /bin/rm -rf {} ;'); + } + else { + if (-d '.deleted') { + do cmd('rm -rf .deleted'); + } + else { + if ($dir eq '.' && $pwd =~ m|/\.deleted$|) { + chdir '..'; + do cmd('rm -rf .deleted'); + } + else { + print stderr "No trashcan found in directory $dir\n"; + } + } + } +} +continue { + chdir $pwd; +} + +# force direct execution with no shell + +sub cmd { + system split(' ',join(' ',@_)); +} + diff --git a/eg/van/unvanish b/eg/van/unvanish new file mode 100644 index 000000000000..4a83c812329f --- /dev/null +++ b/eg/van/unvanish @@ -0,0 +1,66 @@ +#!/usr/bin/perl + +# $Header: unvanish,v 2.0 88/06/05 00:17:30 root Exp $ + +sub it { + if ($olddir ne '.') { + chop($pwd = `pwd`) if $pwd eq ''; + (chdir $olddir) || die "Directory $olddir is not accesible"; + } + unless ($olddir eq '.deleted') { + if (-d '.deleted') { + chdir '.deleted' || die "Directory .deleted is not accesible"; + } + else { + chop($pwd = `pwd`) if $pwd eq ''; + die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/; + } + } + print `mv $startfiles$filelist..$force`; + if ($olddir ne '.') { + (chdir $pwd) || die "Can't get back to original directory: $pwd"; + } +} + +if ($#ARGV < 0) { + open(lastcmd,'.deleted/.lastcmd') || + open(lastcmd,'.lastcmd') || + die "No previous vanish in this dir"; + $ARGV = ; + close(lastcmd); + @ARGV = split(/[\n ]+/,$ARGV); +} + +while ($ARGV[0] =~ /^-/) { + $_ = shift; + /^-f/ && ($force = ' >/dev/null 2>&1'); + /^-i/ && ($interactive = 1); + if (/^-+$/) { + $startfiles = '- '; + last; + } +} + +while ($file = shift) { + if ($file =~ s|^(.*)/||) { + $dir = $1; + } + else { + $dir = '.'; + } + + if ($dir ne $olddir) { + do it() if $olddir; + $olddir = $dir; + } + + if ($interactive) { + print "unvanish: restore $dir/$file? "; + next unless =~ /^y/i; + } + + $filelist .= $file; $filelist .= ' '; + +} + +do it() if $olddir; diff --git a/eg/van/vanexp b/eg/van/vanexp new file mode 100644 index 000000000000..29b42e8edfef --- /dev/null +++ b/eg/van/vanexp @@ -0,0 +1,21 @@ +#!/usr/bin/perl + +# $Header: vanexp,v 2.0 88/06/05 00:17:34 root Exp $ + +# This is for running from a find at night to expire old .deleteds + +$can = $ARGV[0]; + +exit 1 unless $can =~ /.deleted$/; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($can); + +exit 0 unless $size; + +if (time - $mtime > 2 * 24 * 60 * 60) { + `/bin/rm -rf $can`; +} +else { + `find $can -ctime +2 -exec rm -f {} \;`; +} diff --git a/eg/van/vanish b/eg/van/vanish new file mode 100644 index 000000000000..b665e7c8d9a8 --- /dev/null +++ b/eg/van/vanish @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +# $Header: vanish,v 2.0 88/06/05 00:17:36 root Exp $ + +sub it { + if ($olddir ne '.') { + chop($pwd = `pwd`) if $pwd eq ''; + (chdir $olddir) || die "Directory $olddir is not accesible"; + } + if (!-d .deleted) { + print `mkdir .deleted; chmod 775 .deleted`; + die "You can't remove files from $olddir" if $?; + } + $filelist =~ s/ $//; + $filelist =~ s/#/\\#/g; + if ($filelist !~ /^[ \t]*$/) { + open(lastcmd,'>.deleted/.lastcmd'); + print lastcmd $filelist,"\n"; + close(lastcmd); + print `/bin/mv $startfiles$filelist .deleted$force`; + } + if ($olddir ne '.') { + (chdir $pwd) || die "Can't get back to original directory: $pwd"; + } +} + +while ($ARGV[0] =~ /^-/) { + $_ = shift; + /^-f/ && ($force = ' >/dev/null 2>&1'); + /^-i/ && ($interactive = 1); + if (/^-+$/) { + $startfiles = '- '; + last; + } +} + +chop($pwd = `pwd`); + +while ($file = shift) { + if ($file =~ s|^(.*)/||) { + $dir = $1; + } + else { + $dir = '.'; + } + + if ($interactive) { + print "vanish: remove $dir/$file? "; + next unless =~ /^y/i; + } + + if ($file eq '.deleted') { + print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n"; + next; + } + + if ($dir ne $olddir) { + do it() if $olddir; + $olddir = $dir; + } + + $filelist .= $file; $filelist .= ' '; +} + +do it() if $olddir; diff --git a/eval.c b/eval.c new file mode 100644 index 000000000000..78a06cb1fb8c --- /dev/null +++ b/eval.c @@ -0,0 +1,1435 @@ +/* $Header: eval.c,v 2.0 88/06/05 00:08:48 root Exp $ + * + * $Log: eval.c,v $ + * Revision 2.0 88/06/05 00:08:48 root + * Baseline version 2.0. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#include +#include + +extern int errno; + +#ifdef VOIDSIG +static void (*ihand)(); +static void (*qhand)(); +#else +static int (*ihand)(); +static int (*qhand)(); +#endif + +ARG *debarg; +STR str_args; + +STR * +eval(arg,retary,sargoff) +register ARG *arg; +STR ***retary; /* where to return an array to, null if nowhere */ +int sargoff; /* how many elements in sarg are already assigned */ +{ + register STR *str; + register int anum; + register int optype; + int maxarg; + int maxsarg; + double value; + STR *quicksarg[5]; + register STR **sarg = quicksarg; + register char *tmps; + char *tmps2; + int argflags; + int argtype; + union argptr argptr; + int cushion; + unsigned long tmplong; + long when; + 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; + maxsarg = maxarg = arg->arg_len; + if (maxsarg > 3 || retary) { + if (sargoff >= 0) { /* array already exists, just append to it */ + cushion = 10; + sarg = (STR **)saferealloc((char*)*retary, + (maxsarg+sargoff+2+cushion) * sizeof(STR*)) + sargoff; + /* Note that sarg points into the middle of the array */ + } + else { + sargoff = cushion = 0; + sarg = (STR **)safemalloc((maxsarg+2) * sizeof(STR*)); + } + } + else + sargoff = 0; +#ifdef DEBUGGING + if (debug) { + 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; + argtype = arg[anum].arg_type; + argptr = arg[anum].arg_ptr; + re_eval: + switch (argtype) { + 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 + if (retary && + (optype == O_LIST || optype == O_ITEM2 || optype == O_ITEM3)) { + *retary = sarg - sargoff; + eval(argptr.arg_arg, retary, anum - 1 + sargoff); + sarg = *retary; /* they do realloc it... */ + argtype = maxarg - anum; /* how many left? */ + maxsarg = (int)(str_gnum(sarg[0])) + argtype; + sargoff = maxsarg - maxarg; + if (argtype > 9 - cushion) { /* we don't have room left */ + sarg = (STR **)saferealloc((char*)sarg, + (maxsarg+2+cushion) * sizeof(STR*)); + } + sarg += sargoff; + } + else + sarg[anum] = eval(argptr.arg_arg, Null(STR***),-1); + break; + case A_CMD: +#ifdef DEBUGGING + if (debug & 8) { + tmps = "CMD"; + deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd); + } +#endif + sarg[anum] = cmd_exec(argptr.arg_cmd); + break; + case A_STAB: + sarg[anum] = STAB_STR(argptr.arg_stab); +#ifdef DEBUGGING + if (debug & 8) { + sprintf(buf,"STAB $%s",argptr.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(argptr.arg_arg,Null(STR***),-1); + if (!str) + fatal("panic: A_LEXPR"); + goto do_crement; + case A_LVAL: +#ifdef DEBUGGING + if (debug & 8) { + sprintf(buf,"LVAL $%s",argptr.arg_stab->stab_name); + tmps = buf; + } +#endif + str = STAB_STR(argptr.arg_stab); + if (!str) + fatal("panic: A_LVAL"); + 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_LARYLEN: + str = sarg[anum] = + argptr.arg_stab->stab_array->ary_magic; +#ifdef DEBUGGING + tmps = "LARYLEN"; +#endif + if (!str) + fatal("panic: A_LEXPR"); + goto do_crement; + case A_ARYLEN: + stab = argptr.arg_stab; + sarg[anum] = stab->stab_array->ary_magic; + str_numset(sarg[anum],(double)(stab->stab_array->ary_fill+arybase)); +#ifdef DEBUGGING + tmps = "ARYLEN"; +#endif + break; + case A_SINGLE: + sarg[anum] = argptr.arg_str; +#ifdef DEBUGGING + tmps = "SINGLE"; +#endif + break; + case A_DOUBLE: + (void) interp(str,str_get(argptr.arg_str)); + sarg[anum] = str; +#ifdef DEBUGGING + tmps = "DOUBLE"; +#endif + break; + case A_BACKTICK: + tmps = str_get(argptr.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_INDREAD: + last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE); + goto do_read; + case A_GLOB: + argflags |= AF_POST; /* enable newline chopping */ + case A_READ: + last_in_stab = argptr.arg_stab; + do_read: + fp = Nullfp; + if (last_in_stab->stab_io) { + fp = last_in_stab->stab_io->fp; + if (!fp) { + if (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) < 0) { + 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 */ + } + else if (argtype == A_GLOB) { + (void) interp(str,str_get(last_in_stab->stab_val)); + tmps = str->str_ptr; + if (*tmps == '!') + sprintf(tokenbuf,"%s|",tmps+1); + else { + if (*tmps == ';') + sprintf(tokenbuf, "%s", tmps+1); + else + sprintf(tokenbuf, "echo %s", tmps); + strcat(tokenbuf, + "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); + } + do_open(last_in_stab,tokenbuf); + fp = last_in_stab->stab_io->fp; + } + } + } + if (!fp && dowarn) + warn("Read on closed filehandle <%s>",last_in_stab->stab_name); + 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; + } + else if (argflags & AF_POST) { + do_close(last_in_stab,FALSE); + } + if (fp == stdin) { + clearerr(fp); + } + sarg[anum] = &str_no; + if (retary) { + maxarg = anum - 1; + maxsarg = maxarg + sargoff; + } + break; + } + else { + last_in_stab->stab_io->lines++; + sarg[anum] = str; + if (argflags & AF_POST) { + if (str->str_cur > 0) + str->str_cur--; + str->str_ptr[str->str_cur] = '\0'; + } + if (retary) { + sarg[anum] = str_static(sarg[anum]); + anum++; + if (anum > maxarg) { + maxarg = anum + anum; + maxsarg = maxarg + sargoff; + sarg = (STR **)saferealloc((char*)(sarg-sargoff), + (maxsarg+2+cushion) * sizeof(STR*)) + sargoff; + } + goto keepgoing; + } + } + if (retary) { + maxarg = anum - 1; + maxsarg = maxarg + sargoff; + } +#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 (maxarg > arg->arg_len) + goto array_return; + if (str != sarg[1]) + str_sset(str,sarg[1]); + STABSET(str); + break; + case O_ITEM2: + if (str != sarg[--anum]) + str_sset(str,sarg[anum]); + STABSET(str); + break; + case O_ITEM3: + if (str != sarg[--anum]) + str_sset(str,sarg[anum]); + 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 = (int)str_gnum(sarg[2]); + if (anum >= 1) { + tmpstr = str_new(0); + str_sset(tmpstr,str); + while (--anum > 0) + str_scat(str,tmpstr); + } + else + str_sset(str,&str_no); + STABSET(str); + break; + case O_MATCH: + str_sset(str, do_match(arg, + retary,sarg,&maxsarg,sargoff,cushion)); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; + } + STABSET(str); + break; + case O_NMATCH: + str_sset(str, do_match(arg, + retary,sarg,&maxsarg,sargoff,cushion)); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; /* ignore negation */ + } + str_set(str, str_true(str) ? 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[1].arg_flags & AF_SPECIAL) + do_assign(str,arg,sarg); + 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_STUDY: + value = (double)do_study(str); + str = arg->arg_ptr.arg_str; + goto donumset; + case O_MULTIPLY: + value = str_gnum(sarg[1]); + value *= str_gnum(sarg[2]); + goto donumset; + case O_DIVIDE: + if ((value = str_gnum(sarg[2])) == 0.0) + fatal("Illegal division by zero"); + value = str_gnum(sarg[1]) / value; + goto donumset; + case O_MODULO: + if ((tmplong = (unsigned long) str_gnum(sarg[2])) == 0L) + fatal("Illegal modulus zero"); + value = str_gnum(sarg[1]); + value = (double)(((unsigned long)value) % tmplong); + 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]); + anum = (int)str_gnum(sarg[2]); + value = (double)(((unsigned long)value) << anum); + goto donumset; + case O_RIGHT_SHIFT: + value = str_gnum(sarg[1]); + anum = (int)str_gnum(sarg[2]); + value = (double)(((unsigned long)value) >> anum); + 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)(((unsigned long)value) & + (unsigned long)str_gnum(sarg[2])); + goto donumset; + case O_XOR: + value = str_gnum(sarg[1]); + value = (double)(((unsigned long)value) ^ + (unsigned long)str_gnum(sarg[2])); + goto donumset; + case O_BIT_OR: + value = str_gnum(sarg[1]); + value = (double)(((unsigned long)value) | + (unsigned long)str_gnum(sarg[2])); + goto donumset; + case O_AND: + if (str_true(sarg[1])) { + anum = 2; + optype = O_ITEM2; + argflags = arg[anum].arg_flags; + argtype = arg[anum].arg_type; + argptr = arg[anum].arg_ptr; + maxarg = anum = 1; + 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_sset(str, sarg[1]); + STABSET(str); + } + else + str = sarg[1]; + break; + } + else { + anum = 2; + optype = O_ITEM2; + argflags = arg[anum].arg_flags; + argtype = arg[anum].arg_type; + argptr = arg[anum].arg_ptr; + maxarg = anum = 1; + goto re_eval; + } + case O_COND_EXPR: + anum = (str_true(sarg[1]) ? 2 : 3); + optype = (anum == 2 ? O_ITEM2 : O_ITEM3); + argflags = arg[anum].arg_flags; + argtype = arg[anum].arg_type; + argptr = arg[anum].arg_ptr; + maxarg = anum = 1; + 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 (arg[1].arg_type == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(sarg[1]),TRUE); + if (do_open(stab,str_get(sarg[2]))) { + value = (double)forkprocess; + stab->stab_io->lines = 0; + goto donumset; + } + 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: + if (arg[1].arg_type == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(sarg[1]),TRUE); + str_set(str, do_close(stab,TRUE) ? Yes : No ); + STABSET(str); + break; + case O_EACH: + str_sset(str,do_each(arg[1].arg_ptr.arg_stab->stab_hash, + retary,sarg,&maxsarg,sargoff,cushion)); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; + } + STABSET(str); + break; + case O_VALUES: + case O_KEYS: + value = (double) do_kv(arg[1].arg_ptr.arg_stab->stab_hash, optype, + retary,sarg,&maxsarg,sargoff,cushion); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; + } + goto donumset; + case O_ARRAY: + if (maxarg == 1) { + ary = arg[1].arg_ptr.arg_stab->stab_array; + maxarg = ary->ary_fill; + maxsarg = maxarg + sargoff; + if (retary) { /* array wanted */ + sarg = (STR **)saferealloc((char*)(sarg-sargoff), + (maxsarg+3+cushion)*sizeof(STR*)) + sargoff; + for (anum = 0; anum <= maxarg; anum++) { + sarg[anum+1] = str = afetch(ary,anum); + } + maxarg++; + maxsarg++; + goto array_return; + } + else + str = afetch(ary,maxarg); + } + else + str = afetch(arg[2].arg_ptr.arg_stab->stab_array, + ((int)str_gnum(sarg[1])) - arybase); + if (!str) + str = &str_no; + break; + case O_DELETE: + tmpstab = arg[2].arg_ptr.arg_stab; /* XXX */ + str = hdelete(tmpstab->stab_hash,str_get(sarg[1])); + if (!str) + str = &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) + str = &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) { + str = &str_no; + break; + } +#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) { + str = &str_no; + break; + } +#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(arg[2].arg_ptr.arg_spat, + retary,sarg,&maxsarg,sargoff,cushion); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; + } + goto donumset; + case O_LENGTH: + value = (double) str_len(sarg[1]); + goto donumset; + case O_SPRINTF: + sarg[maxsarg+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_SORT: + if (maxarg <= 1) + stab = defoutstab; + else { + if (arg[2].arg_type == A_WORD) + stab = arg[2].arg_ptr.arg_stab; + else + stab = stabent(str_get(sarg[2]),TRUE); + if (!stab) + stab = defoutstab; + } + value = (double)do_sort(arg,stab, + retary,sarg,&maxsarg,sargoff,cushion); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; + } + goto donumset; + case O_PRTF: + case O_PRINT: + if (maxarg <= 1) + stab = defoutstab; + else { + if (arg[2].arg_type == A_WORD) + stab = arg[2].arg_ptr.arg_stab; + else + stab = stabent(str_get(sarg[2]),TRUE); + if (!stab) + stab = defoutstab; + } + if (!stab->stab_io || !(fp = stab->stab_io->fp)) + value = 0.0; + else { + if (arg[1].arg_flags & AF_SPECIAL) + value = (double)do_aprint(arg,fp); + else { + value = (double)do_print(sarg[1],fp); + if (ors && optype == O_PRINT) + fputs(ors, fp); + } + if (stab->stab_io->flags & IOF_FLUSH) + fflush(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",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 (arg->arg_flags & AF_LOCAL) + savelist(sarg,maxsarg); + if (maxarg > 0) + str = sarg[maxsarg]; /* unwanted list, return last item */ + else + str = &str_no; + if (retary) + goto array_return; + break; + case O_EOF: + if (maxarg <= 0) + stab = last_in_stab; + else if (arg[1].arg_type == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(sarg[1]),TRUE); + str_set(str, do_eof(stab) ? Yes : No); + STABSET(str); + break; + case O_TELL: + if (maxarg <= 0) + stab = last_in_stab; + else if (arg[1].arg_type == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(sarg[1]),TRUE); + value = (double)do_tell(stab); + goto donumset; + case O_SEEK: + if (arg[1].arg_type == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(sarg[1]),TRUE); + value = str_gnum(sarg[2]); + str_set(str, do_seek(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", 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 = fbminstr(tmps, tmps + sarg[1]->str_cur, sarg[2]))) + value = (double)(-1 + arybase); + else + value = (double)(tmps2 - tmps + arybase); + goto donumset; + case O_TIME: + value = (double) time(Null(long*)); + goto donumset; + case O_TMS: + value = (double) do_tms(retary,sarg,&maxsarg,sargoff,cushion); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; + } + goto donumset; + case O_LOCALTIME: + when = (long)str_gnum(sarg[1]); + value = (double)do_time(localtime(&when), + retary,sarg,&maxsarg,sargoff,cushion); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; + } + goto donumset; + case O_GMTIME: + when = (long)str_gnum(sarg[1]); + value = (double)do_time(gmtime(&when), + retary,sarg,&maxsarg,sargoff,cushion); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; + } + goto donumset; + case O_STAT: + value = (double) do_stat(arg, + retary,sarg,&maxsarg,sargoff,cushion); + if (retary) { + sarg = *retary; /* they realloc it */ + goto array_return; + } + goto donumset; + case O_CRYPT: +#ifdef CRYPT + tmps = str_get(sarg[1]); + str_set(str,crypt(tmps,str_get(sarg[2]))); +#else + fatal( + "The crypt() function is unimplemented due to excessive paranoia."); +#endif + 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: + value = str_gnum(sarg[1]); + if (value >= 0.0) + modf(value,&value); + else { + modf(-value,&value); + value = -value; + } + goto donumset; + case O_ORD: + value = (double) *str_get(sarg[1]); + goto donumset; + case O_SLEEP: + tmps = str_get(sarg[1]); + time(&when); + if (!tmps || !*tmps) + sleep((32767<<16)+32767); + else + sleep((unsigned)atoi(tmps)); + value = (double)when; + time(&when); + value = ((double)when) - value; + goto donumset; + case O_FLIP: + if (str_true(sarg[1])) { + str_numset(str,0.0); + anum = 2; + arg->arg_type = optype = O_FLOP; + arg[2].arg_flags &= ~AF_SPECIAL; + arg[1].arg_flags |= AF_SPECIAL; + argflags = arg[2].arg_flags; + argtype = arg[2].arg_type; + argptr = arg[2].arg_ptr; + 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_WAIT: + ihand = signal(SIGINT, SIG_IGN); + qhand = signal(SIGQUIT, SIG_IGN); + value = (double)wait(&argflags); + signal(SIGINT, ihand); + signal(SIGQUIT, qhand); + statusvalue = (unsigned short)argflags; + goto donumset; + case O_SYSTEM: + while ((anum = vfork()) == -1) { + if (errno != EAGAIN) { + value = -1.0; + goto donumset; + } + sleep(5); + } + if (anum > 0) { + ihand = signal(SIGINT, SIG_IGN); + qhand = signal(SIGQUIT, SIG_IGN); + while ((argtype = wait(&argflags)) != anum && argtype != -1) + ; + signal(SIGINT, ihand); + signal(SIGQUIT, qhand); + statusvalue = (unsigned short)argflags; + if (argtype == -1) + value = -1.0; + else { + value = (double)((unsigned int)argflags & 0xffff); + } + goto donumset; + } + if (arg[1].arg_flags & AF_SPECIAL) + value = (double)do_aexec(arg); + else { + value = (double)do_exec(str_static(sarg[1])); + } + _exit(-1); + case O_EXEC: + if (arg[1].arg_flags & AF_SPECIAL) + value = (double)do_aexec(arg); + else { + value = (double)do_exec(str_static(sarg[1])); + } + goto donumset; + case O_HEX: + argtype = 4; + goto snarfnum; + + case O_OCT: + argtype = 3; + + snarfnum: + anum = 0; + tmps = str_get(sarg[1]); + for (;;) { + switch (*tmps) { + default: + goto out; + case '8': case '9': + if (argtype != 4) + goto out; + /* FALL THROUGH */ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + anum <<= argtype; + 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 (argtype != 4) + goto out; + anum <<= 4; + anum += (*tmps++ & 7) + 9; + break; + case 'x': + argtype = 4; + tmps++; + break; + } + } + out: + value = (double)anum; + goto donumset; + case O_CHMOD: + case O_CHOWN: + case O_KILL: + case O_UNLINK: + case O_UTIME: + 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]); + if (euid || stat(tmps2,&statbuf) < 0 || + (statbuf.st_mode & S_IFMT) != S_IFDIR ) + UNLINK(tmps2); /* avoid unlinking a directory */ + 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; + case O_DOFILE: + case O_EVAL: + str_sset(str, + do_eval(arg[1].arg_type != A_NULL ? sarg[1] : defstab->stab_val, + optype) ); + STABSET(str); + break; + + case O_FTRREAD: + argtype = 0; + anum = S_IREAD; + goto check_perm; + case O_FTRWRITE: + argtype = 0; + anum = S_IWRITE; + goto check_perm; + case O_FTREXEC: + argtype = 0; + anum = S_IEXEC; + goto check_perm; + case O_FTEREAD: + argtype = 1; + anum = S_IREAD; + goto check_perm; + case O_FTEWRITE: + argtype = 1; + anum = S_IWRITE; + goto check_perm; + case O_FTEEXEC: + argtype = 1; + anum = S_IEXEC; + check_perm: + str = &str_no; + if (mystat(arg,sarg[1]) < 0) + break; + if (cando(anum,argtype)) + str = &str_yes; + break; + + case O_FTIS: + if (mystat(arg,sarg[1]) >= 0) + str = &str_yes; + else + str = &str_no; + break; + case O_FTEOWNED: + case O_FTROWNED: + if (mystat(arg,sarg[1]) >= 0 && + statbuf.st_uid == (optype == O_FTEOWNED ? euid : uid) ) + str = &str_yes; + else + str = &str_no; + break; + case O_FTZERO: + if (mystat(arg,sarg[1]) >= 0 && !statbuf.st_size) + str = &str_yes; + else + str = &str_no; + break; + case O_FTSIZE: + if (mystat(arg,sarg[1]) >= 0 && statbuf.st_size) + str = &str_yes; + else + str = &str_no; + break; + + case O_FTSOCK: +#ifdef S_IFSOCK + anum = S_IFSOCK; + goto check_file_type; +#else + str = &str_no; + break; +#endif + case O_FTCHR: + anum = S_IFCHR; + goto check_file_type; + case O_FTBLK: + anum = S_IFBLK; + goto check_file_type; + case O_FTFILE: + anum = S_IFREG; + goto check_file_type; + case O_FTDIR: + anum = S_IFDIR; + check_file_type: + if (mystat(arg,sarg[1]) >= 0 && + (statbuf.st_mode & S_IFMT) == anum ) + str = &str_yes; + else + str = &str_no; + break; + case O_FTPIPE: +#ifdef S_IFIFO + anum = S_IFIFO; + goto check_file_type; +#else + str = &str_no; + break; +#endif + case O_FTLINK: +#ifdef S_IFLNK + if (lstat(str_get(sarg[1]),&statbuf) >= 0 && + (statbuf.st_mode & S_IFMT) == S_IFLNK ) + str = &str_yes; + else +#endif + str = &str_no; + break; + case O_SYMLINK: +#ifdef SYMLINK + tmps = str_get(sarg[1]); + value = (double)(symlink(tmps,str_get(sarg[2])) >= 0); + goto donumset; +#else + fatal("Unsupported function symlink()"); +#endif + case O_FTSUID: + anum = S_ISUID; + goto check_xid; + case O_FTSGID: + anum = S_ISGID; + goto check_xid; + case O_FTSVTX: + anum = S_ISVTX; + check_xid: + if (mystat(arg,sarg[1]) >= 0 && statbuf.st_mode & anum) + str = &str_yes; + else + str = &str_no; + break; + case O_FTTTY: + if (arg[1].arg_flags & AF_SPECIAL) { + stab = arg[1].arg_ptr.arg_stab; + tmps = ""; + } + else + stab = stabent(tmps = str_get(sarg[1]),FALSE); + if (stab && stab->stab_io && stab->stab_io->fp) + anum = fileno(stab->stab_io->fp); + else if (isdigit(*tmps)) + anum = atoi(tmps); + else + anum = -1; + if (isatty(anum)) + str = &str_yes; + else + str = &str_no; + break; + case O_FTTEXT: + case O_FTBINARY: + str = do_fttext(arg,sarg[1]); + break; + } + if (retary) { + sarg[1] = str; + maxsarg = sargoff + 1; + } +#ifdef DEBUGGING + if (debug) { + dlevel--; + if (debug & 8) + deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str)); + } +#endif + goto freeargs; + +array_return: +#ifdef DEBUGGING + if (debug) { + dlevel--; + if (debug & 8) + deb("%s RETURNS ARRAY OF %d ARGS\n",opname[optype],maxsarg-sargoff); + } +#endif + goto freeargs; + +donumset: + str_numset(str,value); + STABSET(str); + if (retary) { + sarg[1] = str; + maxsarg = sargoff + 1; + } +#ifdef DEBUGGING + if (debug) { + dlevel--; + if (debug & 8) + deb("%s RETURNS \"%f\"\n",opname[optype],value); + } +#endif + +freeargs: + sarg -= sargoff; + if (sarg != quicksarg) { + if (retary) { + sarg[0] = &str_args; + str_numset(sarg[0], (double)(maxsarg)); + sarg[maxsarg+1] = Nullstr; + *retary = sarg; /* up to them to free it */ + } + else + safefree((char*)sarg); + } + return str; +} + +int +ingroup(gid,effective) +int gid; +int effective; +{ + if (gid == (effective ? getegid() : getgid())) + return TRUE; +#ifdef GETGROUPS +#ifndef NGROUPS +#define NGROUPS 32 +#endif + { + GIDTYPE gary[NGROUPS]; + int anum; + + anum = getgroups(NGROUPS,gary); + while (--anum >= 0) + if (gary[anum] == gid) + return TRUE; + } +#endif + return FALSE; +} + +/* Do the permissions allow some operation? Assumes statbuf already set. */ + +int +cando(bit, effective) +int bit; +int effective; +{ + if ((effective ? euid : uid) == 0) { /* root is special */ + if (bit == S_IEXEC) { + if (statbuf.st_mode & 0111 || + (statbuf.st_mode & S_IFMT) == S_IFDIR ) + return TRUE; + } + else + return TRUE; /* root reads and writes anything */ + return FALSE; + } + if (statbuf.st_uid == (effective ? euid : uid) ) { + if (statbuf.st_mode & bit) + return TRUE; /* ok as "user" */ + } + else if (ingroup((int)statbuf.st_gid,effective)) { + if (statbuf.st_mode & bit >> 3) + return TRUE; /* ok as "group" */ + } + else if (statbuf.st_mode & bit >> 6) + return TRUE; /* ok as "other" */ + return FALSE; +} diff --git a/form.c b/form.c index 8894621c9f4d..422d4a74b57d 100644 --- a/form.c +++ b/form.c @@ -1,15 +1,12 @@ -/* $Header: form.c,v 1.0 87/12/18 13:05:07 root Exp $ +/* $Header: form.c,v 2.0 88/06/05 00:08:57 root Exp $ * * $Log: form.c,v $ - * Revision 1.0 87/12/18 13:05:07 root - * Initial revision + * Revision 2.0 88/06/05 00:08:57 root + * Baseline version 2.0. * */ -#include "handy.h" #include "EXTERN.h" -#include "search.h" -#include "util.h" #include "perl.h" /* Forms stuff */ @@ -57,7 +54,7 @@ register FCMD *fcmd; orec->o_lines++; break; case F_LEFT: - str = eval(fcmd->f_expr,Null(char***),(double*)0); + str = eval(fcmd->f_expr,Null(STR***),-1); s = str_get(str); size = fcmd->f_size; CHKLEN(size); @@ -101,7 +98,7 @@ register FCMD *fcmd; } break; case F_RIGHT: - t = s = str_get(eval(fcmd->f_expr,Null(char***),(double*)0)); + t = s = str_get(eval(fcmd->f_expr,Null(STR***),-1)); size = fcmd->f_size; CHKLEN(size); chophere = Nullch; @@ -150,7 +147,7 @@ register FCMD *fcmd; case F_CENTER: { int halfsize; - t = s = str_get(eval(fcmd->f_expr,Null(char***),(double*)0)); + t = s = str_get(eval(fcmd->f_expr,Null(STR***),-1)); size = fcmd->f_size; CHKLEN(size); chophere = Nullch; @@ -207,7 +204,7 @@ register FCMD *fcmd; break; } case F_LINES: - str = eval(fcmd->f_expr,Null(char***),(double*)0); + str = eval(fcmd->f_expr,Null(STR***),-1); s = str_get(str); size = str_len(str); CHKLEN(size); @@ -240,7 +237,8 @@ register STIO *stio; #ifdef DEBUGGING if (debug & 256) - fprintf(stderr,"left=%d, todo=%d\n",stio->lines_left, orec->o_lines); + fprintf(stderr,"left=%ld, todo=%ld\n", + (long)stio->lines_left, (long)orec->o_lines); #endif if (stio->lines_left < orec->o_lines) { if (!stio->top_stab) { diff --git a/form.h b/form.h index fc2257b43a1e..3b7aa95178ea 100644 --- a/form.h +++ b/form.h @@ -1,8 +1,8 @@ -/* $Header: form.h,v 1.0 87/12/18 13:05:10 root Exp $ +/* $Header: form.h,v 2.0 88/06/05 00:09:01 root Exp $ * * $Log: form.h,v $ - * Revision 1.0 87/12/18 13:05:10 root - * Initial revision + * Revision 2.0 88/06/05 00:09:01 root + * Baseline version 2.0. * */ diff --git a/handy.h b/handy.h index 3eb24774ec2e..6a7c2c785c41 100644 --- a/handy.h +++ b/handy.h @@ -1,12 +1,16 @@ -/* $Header: handy.h,v 1.0 87/12/18 13:05:14 root Exp $ +/* $Header: handy.h,v 2.0 88/06/05 00:09:03 root Exp $ * * $Log: handy.h,v $ - * Revision 1.0 87/12/18 13:05:14 root - * Initial revision + * Revision 2.0 88/06/05 00:09:03 root + * Baseline version 2.0. * */ -#define Null(type) ((type)0) +#ifdef NULL +#undef NULL +#endif +#define NULL 0 +#define Null(type) ((type)NULL) #define Nullch Null(char*) #define Nullfp Null(FILE*) @@ -24,3 +28,14 @@ #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)) + +#define MEM_SIZE unsigned int + +/* Line numbers are unsigned, 16 bits. */ +typedef unsigned short line_t; +#ifdef lint +#define NOLINE ((line_t)0) +#else +#define NOLINE ((line_t) 65535) +#endif + diff --git a/hash.c b/hash.c index 61e7f87941b3..e0bc5f6ff92d 100644 --- a/hash.c +++ b/hash.c @@ -1,16 +1,12 @@ -/* $Header: hash.c,v 1.0 87/12/18 13:05:17 root Exp $ +/* $Header: hash.c,v 2.0 88/06/05 00:09:06 root Exp $ * * $Log: hash.c,v $ - * Revision 1.0 87/12/18 13:05:17 root - * Initial revision + * Revision 2.0 88/06/05 00:09:06 root + * Baseline version 2.0. * */ -#include #include "EXTERN.h" -#include "handy.h" -#include "util.h" -#include "search.h" #include "perl.h" STR * @@ -26,7 +22,7 @@ char *key; if (!tb) return Nullstr; for (s=key, i=0, hash = 0; - /* while */ *s; + /* while */ *s && i < COEFFSIZE; s++, i++, hash *= 5) { hash += *s * coeff[i]; } @@ -56,7 +52,7 @@ STR *val; if (!tb) return FALSE; for (s=key, i=0, hash = 0; - /* while */ *s; + /* while */ *s && i < COEFFSIZE; s++, i++, hash *= 5) { hash += *s * coeff[i]; } @@ -90,8 +86,7 @@ STR *val; return FALSE; } -#ifdef NOTUSED -bool +STR * hdelete(tb,key) register HASH *tb; char *key; @@ -101,11 +96,12 @@ char *key; register int hash; register HENT *entry; register HENT **oentry; + STR *str; if (!tb) - return FALSE; + return Nullstr; for (s=key, i=0, hash = 0; - /* while */ *s; + /* while */ *s && i < COEFFSIZE; s++, i++, hash *= 5) { hash += *s * coeff[i]; } @@ -113,22 +109,20 @@ char *key; oentry = &(tb->tbl_array[hash & tb->tbl_max]); entry = *oentry; i = 1; - for (; entry; i=0, oentry = &entry->hent_next, entry = entry->hent_next) { + for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) { 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); + str = str_static(entry->hent_val); + hentfree(entry); if (i) tb->tbl_fill--; - return TRUE; + return str; } - return FALSE; + return Nullstr; } -#endif hsplit(tb) HASH *tb; @@ -180,6 +174,54 @@ hnew() return tb; } +void +hentfree(hent) +register HENT *hent; +{ + if (!hent) + return; + str_free(hent->hent_val); + safefree(hent->hent_key); + safefree((char*)hent); +} + +void +hclear(tb) +register HASH *tb; +{ + register HENT *hent; + register HENT *ohent = Null(HENT*); + + if (!tb) + return; + hiterinit(tb); + while (hent = hiternext(tb)) { /* concise but not very efficient */ + hentfree(ohent); + ohent = hent; + } + hentfree(ohent); + tb->tbl_fill = 0; + bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*)); +} + +#ifdef NOTUSED +void +hfree(tb) +HASH *tb; +{ + if (!tb) + return + hiterinit(tb); + while (hent = hiternext(tb)) { + hentfree(ohent); + ohent = hent; + } + hentfree(ohent); + safefree((char*)tb->tbl_array); + safefree((char*)tb); +} +#endif + #ifdef NOTUSED hshow(tb) register HASH *tb; diff --git a/hash.h b/hash.h index 6e9a7a03e87c..a8ad28ae6ee7 100644 --- a/hash.h +++ b/hash.h @@ -1,13 +1,14 @@ -/* $Header: hash.h,v 1.0 87/12/18 13:05:20 root Exp $ +/* $Header: hash.h,v 2.0 88/06/05 00:09:08 root Exp $ * * $Log: hash.h,v $ - * Revision 1.0 87/12/18 13:05:20 root - * Initial revision + * Revision 2.0 88/06/05 00:09:08 root + * Baseline version 2.0. * */ #define FILLPCT 60 /* don't make greater than 99 */ +#define COEFFSIZE (16 * 8) /* size of array below */ #ifdef DOINIT char coeff[] = { 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, @@ -41,8 +42,11 @@ struct htbl { STR *hfetch(); bool hstore(); -bool hdelete(); +STR *hdelete(); HASH *hnew(); +void hclear(); +void hfree(); +void hentfree(); int hiterinit(); HENT *hiternext(); char *hiterkey(); diff --git a/lib/getopt.pl b/lib/getopt.pl new file mode 100644 index 000000000000..4832233ed2fe --- /dev/null +++ b/lib/getopt.pl @@ -0,0 +1,38 @@ +;# $Header: getopt.pl,v 2.0 88/06/05 00:16:22 root Exp $ + +;# Process single-character switches with switch clustering. Pass one argument +;# which is a string containing all switches that take an argument. For each +;# switch found, sets $opt_x (where x is the switch name) to the value of the +;# argument, or 1 if no argument. Switches which take an argument don't care +;# whether there is a space between the switch and the argument. + +;# Usage: +;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + +sub Getopt { + local($argumentative) = @_; + local($_,$first,$rest); + + while (($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + if (index($argumentative,$first) >= $[) { + if ($rest ne '') { + shift; + } + else { + shift; + $rest = shift; + } + eval "\$opt_$first = \$rest;"; + } + else { + eval "\$opt_$first = 1;"; + if ($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift; + } + } + } +} diff --git a/lib/importenv.pl b/lib/importenv.pl new file mode 100644 index 000000000000..c0c2be088e3d --- /dev/null +++ b/lib/importenv.pl @@ -0,0 +1,14 @@ +;# $Header: importenv.pl,v 2.0 88/06/05 00:16:17 root Exp $ + +;# This file, when interpreted, pulls the environment into normal variables. +;# Usage: +;# do 'importenv.pl'; +;# or +;# #include + +local($tmp,$key) = ''; + +foreach $key (keys(ENV)) { + $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; +} +eval $tmp; diff --git a/lib/stat.pl b/lib/stat.pl new file mode 100644 index 000000000000..1895c58c194c --- /dev/null +++ b/lib/stat.pl @@ -0,0 +1,27 @@ +;# $Header: stat.pl,v 2.0 88/06/05 00:16:29 root Exp $ + +;# Usage: +;# @ary = stat(foo); +;# $st_dev = @ary[$ST_DEV]; +;# +$ST_DEV = 0 + $[; +$ST_INO = 1 + $[; +$ST_MODE = 2 + $[; +$ST_NLINK = 3 + $[; +$ST_UID = 4 + $[; +$ST_GID = 5 + $[; +$ST_RDEV = 6 + $[; +$ST_SIZE = 7 + $[; +$ST_ATIME = 8 + $[; +$ST_MTIME = 9 + $[; +$ST_CTIME = 10 + $[; +$ST_BLKSIZE = 11 + $[; +$ST_BLOCKS = 12 + $[; + +;# Usage: +;# do Stat('foo'); # sets st_* as a side effect +;# +sub Stat { + ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size, + $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_)); +} diff --git a/makedepend.SH b/makedepend.SH index 5a8d9794fe16..70c6163548ed 100644 --- a/makedepend.SH +++ b/makedepend.SH @@ -6,7 +6,7 @@ case $CONFIG in ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) fi - . config.sh + . ./config.sh ;; esac case "$0" in @@ -15,22 +15,20 @@ esac echo "Extracting makedepend (with variable substitutions)" $spitshell >makedepend <>makedepend <<'!NO!SUBS!' +: the following weeds options from ccflags that are of no interest to cpp +case "$ccflags" in +'');; +*) set X $ccflags + ccflags='' + for flag do + case $flag in + -D*|-I*) ccflags="$ccflags $flag";; + esac + done + ;; +esac + $cat /dev/null >.deptmp $rm -f *.c.c c/*.c.c if test -f Makefile; then @@ -86,7 +97,7 @@ for file in `$cat .clist`; do -e 's|\\$||' \ -e p \ -e '}' - $cpp -I/usr/local/include -I. $file.c | \ + $cpp -I/usr/local/include -I. $ccflags $file.c | \ $sed \ -e '/^# *[0-9]/!d' \ -e 's/^.*"\(.*\)".*$/'$filebase'.o: \1/' \ @@ -145,7 +156,7 @@ $rm -f .deptmp `sed 's/\.c/.c.c/' .clist` .shlist .clist .hlist .hsed !NO!SUBS! $eunicefix makedepend -chmod 755 makedepend +chmod +x makedepend case `pwd` in *SH) $rm -f ../makedepend diff --git a/makedir.SH b/makedir.SH index 54a0c11b2a8d..215661a6eea3 100644 --- a/makedir.SH +++ b/makedir.SH @@ -6,7 +6,7 @@ case $CONFIG in ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) fi - . config.sh + . ./config.sh ;; esac case "$0" in @@ -15,17 +15,12 @@ esac echo "Extracting makedir (with variable substitutions)" $spitshell >makedir < #define RCHECK /* @@ -28,8 +24,6 @@ static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; */ #include "EXTERN.h" -#include "handy.h" -#include "search.h" #include "perl.h" /* I don't much care whether these are defined in sys/types.h--LAW */ @@ -38,8 +32,6 @@ static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; #define u_int unsigned int #define u_short unsigned short -#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 @@ -66,6 +58,7 @@ union overhead { }; #define MAGIC 0xff /* magic # on accounting info */ +#define OLDMAGIC 0x7f /* same after a free() */ #define RMAGIC 0x55555555 /* magic # on range info */ #ifdef RCHECK #define RSLOP sizeof (u_int) @@ -218,8 +211,12 @@ free(cp) #ifdef debug ASSERT(op->ov_magic == MAGIC); /* make sure it was in use */ #else - if (op->ov_magic != MAGIC) + if (op->ov_magic != MAGIC) { + fprintf(stderr,"%s free() ignored\n", + op->ov_magic == OLDMAGIC ? "Duplicate" : "Bad"); return; /* sanity */ + } + op->ov_magic = OLDMAGIC; #endif #ifdef RCHECK ASSERT(op->ov_rmagic == RMAGIC); @@ -242,11 +239,11 @@ free(cp) * 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 + * ``reall_srchlen'' blocks in each list for a match (the variable * is extern so the caller can modify it). If that fails we just copy * however many bytes was given to realloc() and hope it's not huge. */ -int realloc_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */ +int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */ char * realloc(cp, nbytes) @@ -272,13 +269,13 @@ realloc(cp, nbytes) * 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. + * the last ``reall_srchlen'' items free'd. * If all lookups fail, then assume the size of * the memory block being realloc'd is the * smallest possible. */ if ((i = findbucket(op, 1)) < 0 && - (i = findbucket(op, realloc_srchlen)) < 0) + (i = findbucket(op, reall_srchlen)) < 0) i = 0; } onb = (1 << (i + 3)) - sizeof (*op) - RSLOP; diff --git a/patchlevel.h b/patchlevel.h index f95be0eb07e7..110c86f392f4 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 14 +#define PATCHLEVEL 1 diff --git a/perl.h b/perl.h index 341afa800823..d4846b67f24e 100644 --- a/perl.h +++ b/perl.h @@ -1,37 +1,35 @@ -/* $Header: perl.h,v 1.0.1.4 88/01/30 08:54:00 root Exp $ +/* $Header: perl.h,v 2.0 88/06/05 00:09:21 root Exp $ * * $Log: perl.h,v $ - * Revision 1.0.1.4 88/01/30 08:54:00 root - * patch9: changed #define YYDEBUG; to #define YYDEBUG 1 - * - * Revision 1.0.1.3 88/01/28 10:24:17 root - * patch8: added eval operator. - * - * Revision 1.0.1.2 88/01/24 03:53:47 root - * patch 2: hid str_peek() in #ifdef DEBUGGING. - * - * Revision 1.0.1.1 88/01/21 21:29:23 root - * No longer defines STDSTDIO--gets it from config.h now. - * - * Revision 1.0 87/12/18 13:05:38 root - * Initial revision + * Revision 2.0 88/06/05 00:09:21 root + * Baseline version 2.0. * */ +#ifndef lint #define DEBUGGING +#endif #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); +#ifdef MEMCPY +extern char *memcpy(), *memset(); +#define bcopy(s1,s2,l) memcpy(s2,s1,l); +#define bzero(s,l) memset(s,0,l); #endif #include #include #include +#include /* if this needs types.h we're still wrong */ + +#ifndef _TYPES_ /* If types.h defines this it's easy. */ +#ifndef major /* Does everyone's types.h define this? */ #include +#endif +#endif + #include #ifdef TMINSYS @@ -48,11 +46,16 @@ typedef struct formcmd FCMD; typedef struct scanpat SPAT; typedef struct stab STAB; typedef struct stio STIO; +typedef struct sub SUBR; typedef struct string STR; typedef struct atbl ARRAY; typedef struct htbl HASH; +typedef struct regexp REGEXP; +#include "handy.h" +#include "regexp.h" #include "str.h" +#include "util.h" #include "form.h" #include "stab.h" #include "spat.h" @@ -75,7 +78,7 @@ 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 ))) #ifdef DEBUGGING -#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_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),(char*)buf) : "" ))) #endif #define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str))) @@ -93,24 +96,40 @@ CMD *invert(); CMD *addcond(); CMD *addloop(); CMD *wopt(); +CMD *over(); -SPAT *stab_to_spat(); +SPAT *stab2spat(); STAB *stabent(); +STAB *genstab(); -ARG *stab_to_arg(); +ARG *stab2arg(); ARG *op_new(); ARG *make_op(); ARG *make_lval(); ARG *make_match(); ARG *make_split(); ARG *flipflip(); +ARG *listish(); +ARG *localize(); +ARG *l(); +ARG *mod_match(); +ARG *make_list(); +ARG *cmd_to_arg(); +ARG *addflags(); +ARG *hide_ary(); +ARG *cval_to_arg(); STR *arg_to_str(); STR *str_new(); STR *stab_str(); STR *eval(); /* this evaluates expressions */ STR *do_eval(); /* this evaluates eval operator */ +STR *do_each(); +STR *do_subr(); +STR *do_match(); + +SUBR *make_sub(); FCMD *load_format(); @@ -123,23 +142,37 @@ char *reg_get(); char *str_append_till(); char *str_gets(); -bool do_match(); bool do_open(); bool do_close(); bool do_print(); +bool do_aprint(); +bool do_exec(); +bool do_aexec(); int do_subst(); +int cando(); +int ingroup(); +void str_grow(); +void str_replace(); +void str_inc(); +void str_dec(); void str_free(); void freearg(); - -EXT int line INIT(0); +void savelist(); +void restorelist(); +void ajoin(); +void do_join(); +void do_assign(); +void do_sprintf(); + +EXT line_t line INIT(0); EXT int arybase INIT(0); struct outrec { - int o_lines; - char *o_str; - int o_len; + line_t o_lines; + char *o_str; + int o_len; }; EXT struct outrec outrec; @@ -153,9 +186,13 @@ EXT STAB *sigstab INIT(Nullstab); EXT STAB *defoutstab INIT(Nullstab); EXT STAB *curoutstab INIT(Nullstab); EXT STAB *argvoutstab INIT(Nullstab); +EXT STAB *incstab INIT(Nullstab); EXT STR *freestrroot INIT(Nullstr); +EXT STR *lastretstr INIT(Nullstr); +EXT char *filename; +EXT char *origfilename; EXT FILE *rsfp; EXT char buf[1024]; EXT char *bufptr INIT(buf); @@ -168,10 +205,26 @@ EXT char *ors INIT(Nullch); EXT char *ofmt INIT(Nullch); EXT char *inplace INIT(Nullch); +EXT bool preprocess INIT(FALSE); +EXT bool minus_n INIT(FALSE); +EXT bool minus_p INIT(FALSE); +EXT bool minus_a INIT(FALSE); +EXT bool doswitches INIT(FALSE); +EXT bool dowarn INIT(FALSE); +EXT bool allstabs INIT(FALSE); /* init all customary symbols in symbol table?*/ +EXT bool sawampersand INIT(FALSE); /* must save all match strings */ +EXT bool sawstudy INIT(FALSE); /* do fbminstr on all strings */ + +#define TMPPATH "/tmp/perl-eXXXXXX" +EXT char *e_tmpname; +EXT FILE *e_fp INIT(Nullfp); + EXT char tokenbuf[256]; EXT int expectterm INIT(TRUE); EXT int lex_newlines INIT(FALSE); EXT int in_eval INIT(FALSE); +EXT int multiline INIT(0); +EXT int forkprocess; FILE *popen(); /* char *str_get(); */ @@ -181,16 +234,25 @@ STIO *stio_new(); EXT struct stat statbuf; EXT struct tms timesbuf; +EXT int uid; +EXT int euid; +UIDTYPE getuid(); +UIDTYPE geteuid(); +GIDTYPE getgid(); +GIDTYPE getegid(); +EXT int unsafe; #ifdef DEBUGGING EXT int debug INIT(0); EXT int dlevel INIT(0); -EXT char debname[40]; -EXT char debdelim[40]; +EXT char debname[128]; +EXT char debdelim[128]; #define YYDEBUG 1 extern int yydebug; #endif +EXT line_t cmdline INIT(NOLINE); + EXT STR str_no; EXT STR str_yes; @@ -199,7 +261,7 @@ EXT STR str_yes; EXT struct loop { char *loop_label; jmp_buf loop_env; -} loop_stack[32]; +} loop_stack[64]; EXT int loop_ptr INIT(-1); @@ -208,12 +270,21 @@ EXT jmp_buf eval_env; EXT char *goto_targ INIT(Nullch); /* cmd_exec gets strange when set */ +EXT ARRAY *savestack; /* to save non-local values on */ + +EXT ARRAY *tosave; /* strings to save on recursive subroutine */ + double atof(); -long time(); +unsigned sleep(); +long time(), times(); struct tm *gmtime(), *localtime(); +char *mktemp(); +char *index(), *rindex(); +char *strcpy(), *strcat(); #ifdef EUNICE -#define UNLINK(f) while (unlink(f) >= 0) +#define UNLINK unlnk +int unlnk(); #else #define UNLINK unlink #endif diff --git a/perl.man.1 b/perl.man.1 index d775ac4b5627..3a4db8beb1cf 100644 --- a/perl.man.1 +++ b/perl.man.1 @@ -1,15 +1,13 @@ .rn '' }` -''' $Header: perl.man.1,v 1.0.1.2 88/01/30 17:04:07 root Exp $ +''' $Header: perl.man.1,v 2.0.1.1 88/06/28 16:28:09 root Exp $ ''' ''' $Log: perl.man.1,v $ -''' Revision 1.0.1.2 88/01/30 17:04:07 root -''' patch 11: random cleanup +''' Revision 2.0.1.1 88/06/28 16:28:09 root +''' patch1: fixed some quotes +''' patch1: clarified syntax of LIST ''' -''' Revision 1.0.1.1 88/01/28 10:24:44 root -''' patch8: added eval operator. -''' -''' Revision 1.0 87/12/18 16:18:16 root -''' Initial revision +''' Revision 2.0 88/06/05 00:09:23 root +''' Baseline version 2.0. ''' ''' .de Sh @@ -34,11 +32,11 @@ ''' string Tr holds user defined translation string. ''' Bell System Logo is used as a dummy character. ''' -.tr \(bs-|\(bv\*(Tr +.tr \(*W-|\(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 -- \(*W- +.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch +.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch .ds L" "" .ds R" "" .ds L' ' @@ -91,7 +89,9 @@ switches on the command line. 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. +Passed in implicity via standard input. +This only works if there are no filename arguments\*(--to pass +arguments to a stdin script you must explicitly specify a - for the script name. .PP After locating your script, .I perl @@ -107,12 +107,30 @@ only allows one argument. Example: .nf .ne 2 - #!/bin/perl -spi.bak # same as -s -p -i.bak + #!/usr/bin/perl -spi.bak # same as -s -p -i.bak .\|.\|. .fi Options include: .TP 5 +.B \-a +turns on autosplit mode when used with a \-n or \-p. +An implicit split command to the @F array +is done as the first thing inside the implicit while loop produced by +the \-n or \-p. +.nf + + perl -ane 'print pop(@F),"\en";' + +is equivalent to + + while (<>) { + @F = split(' '); + print pop(@F),"\en"; + } + +.fi +.TP 5 .B \-D sets debugging flags. To watch how it executes your script, use @@ -139,18 +157,18 @@ 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 +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 + #!/usr/bin/perl -pi.bak s/foo/bar/; which is equivalent to .ne 14 - #!/bin/perl + #!/usr/bin/perl while (<>) { if ($ARGV ne $oldargv) { rename($ARGV,$ARGV . '.bak'); @@ -170,6 +188,9 @@ 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. +.Sp +You can use eof to locate the end of each input file, in case you want +to append to each file, or reset line numbering (see example under eof). .TP 5 .B \-I may be used in conjunction with @@ -186,7 +207,7 @@ over filename arguments somewhat like \*(L"sed -n\*(R" or \fIawk\fR: .ne 3 while (<>) { - ... # your script goes here + .\|.\|. # your script goes here } .fi @@ -194,6 +215,14 @@ Note that the lines are not printed by default. See .B \-p to have lines printed. +Here is an efficient way to delete all files older than a week: +.nf + + find . -mtime +7 -print | perl -ne 'chop;unlink;' + +.fi +This is faster than using the -exec switch find because you don't have to +start a process on every filename found. .TP 5 .B \-p causes @@ -204,7 +233,7 @@ over filename arguments somewhat like \fIsed\fR: .ne 5 while (<>) { - ... # your script goes here + .\|.\|. # your script goes here } continue { print; } @@ -239,34 +268,70 @@ invoked with a -xyz switch. .nf .ne 2 - #!/bin/perl -s + #!/usr/bin/perl -s if ($xyz) { print "true\en"; } .fi +.TP 5 +.B \-S +makes perl use the PATH environment variable to search for the script +(unless the name of the script starts with a slash). +Typically this is used to emulate #! startup on machines that don't +support #!, in the following manner: +.nf + + #!/usr/bin/perl + eval "exec /usr/bin/perl -S $0 $*" + if $running_under_some_shell; + +.fi +The system ignores the first line and feeds the script to /bin/sh, +which proceeds to try to execute the perl script as a shell script. +The shell executes the second line as a normal shell command, and thus +starts up the perl interpreter. +On some systems $0 doesn't always contain the full pathname, +so the -S tells perl to search for the script if necessary. +After perl locates the script, it parses the lines and ignores them because +the variable $running_under_some_shell is never true. +.TP 5 +.B \-U +allows perl to do unsafe operations. +Currently the only \*(L"unsafe\*(R" operation is the unlinking of directories while +running as superuser. +.TP 5 +.B \-v +prints the version and patchlevel of your perl executable. +.TP 5 +.B \-w +prints warnings about identifiers that are mentioned only once, and scalar +variables that are used before being set. +Also warns about redefined subroutines, and references to undefined +subroutines and filehandles. .Sh "Data Types and Objects" .PP -Perl has about two and a half data types: strings, arrays of strings, and +Perl has about two and a half data types: scalars, arrays of scalars, and associative arrays. -Strings and arrays of strings are first class objects, for the most part, +Scalars and arrays of scalars 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 +Scalars are interpreted as strings or numbers as appropriate. +A scalar is interpreted as TRUE in the boolean sense if it is not the null string or 0. Booleans returned by operators are 1 for true and '0' or '' (the null string) for false. .PP -References to string variables always begin with \*(L'$\*(R', even when referring -to a string that is part of an array. +References to scalar variables always begin with \*(L'$\*(R', even when referring +to a scalar that is part of an array. Thus: .nf .ne 3 - $days \h'|2i'# a simple string variable + $days \h'|2i'# a simple scalar variable $days[28] \h'|2i'# 29th element of array @days $days{'Feb'}\h'|2i'# one value from an associative array + $#days \h'|2i'# last index of array @days but entire arrays are denoted by \*(L'@\*(R': @@ -274,22 +339,44 @@ but entire arrays are denoted by \*(L'@\*(R': .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 +Any of these five constructs may server as an lvalue, +that is, may be assigned to. +(You may also use an assignment to one of these lvalues as an lvalue in +certain contexts\*(--see s, tr and chop.) +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.]) +(Actually, it's not the length of the array, it's the subscript of the last element, since there is (ordinarily) a 0th element.) +Assigning to $#days changes the length of the array. +Shortening an array by this method does not actually destroy any values. +Lengthening an array that was previously shortened recovers the values that +were in those elements. +You can also gain some measure of efficiency by preextending an array that +is going to get big. +(You can also extend an array by assigning to an element that is off the +end of the array. +This differs from assigning to $#whatever in that intervening values +are set to null rather than recovered.) +You can truncate an array down to nothing by assigning the null list () to +it. +The following are exactly equivalent +.nf + + @whatever = (); + $#whatever = $[ \- 1; + +.fi .PP Every data type has its own namespace. -You can, without fear of conflict, use the same name for a string variable, +You can, without fear of conflict, use the same name for a scalar variable, an array, an associative array, a filehandle, a subroutine name, and/or a label. Since variable and array references always start with \*(L'$\*(R' 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.) +don't have an initial special character. +Hint: you could say open(LOG,'logfile') rather than open(log,'logfile').) 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. @@ -309,7 +396,7 @@ 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. +Variable substitution inside strings is limited (currently) to simple scalar variables. The following code segment prints out \*(L"The price is $100.\*(R" .nf @@ -346,18 +433,24 @@ is an lvalue: ($map{'red'}, $map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00); .fi +Array assignment returns the number of elements assigned. .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. +If a string is enclosed by backticks (grave accents), it first undergoes +variable substitution just like a double quoted string. +It is then interpreted as a command, and the output of that command +is the value of the pseudo-literal, like in a shell. The command is executed each time the pseudo-literal is evaluated. -Unlike in \f2csh\f1, no interpretation is done on the +The status value of the command is returned in $? (see Predefined Names +for the interpretation of $?). +Unlike in \f2csh\f1, no translation is done on the return data\*(--newlines remain newlines. -The status value of the command is returned in $?. +Unlike in any of the shells, single quotes do not hide variable names +in the command from interpretation. +To pass a $ through to the shell you need to hide it with a backslash. .PP Evaluating a filehandle in angle brackets yields the next line from that file (newline included, so it's never false until EOF). @@ -390,6 +483,10 @@ Additional filehandles may be created with the .I open function. .PP +If a is used in a context that is looking for an array, an array +consisting of all the input lines is returned, one line per array element. +It's easy to make a LARGE data space this way, so use with care. +.PP The null filehandle <> is special and can be used to emulate the behavior of \fIsed\fR and \fIawk\fR. Input from <> comes either from standard input, or from each file listed on @@ -425,9 +522,10 @@ It also uses filehandle ARGV internally. You can modify @ARGV before the first <> as long as you leave the first filename at the beginning of the array. Line numbers ($.) continue as if the input was one big happy file. +(But see example under eof for how to reset line numbers on each file.) .PP .ne 5 -If you want to set @ARGV to you own list of files, go right ahead. +If you want to set @ARGV to your own list of files, go right ahead. If you want to pass switches into your script, you can put a loop on the front like this: .nf @@ -448,6 +546,45 @@ put a loop on the front like this: 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. +.PP +If the string inside the angle brackets is a reference to a scalar variable +(e.g. <$foo>), +then that variable contains the name of the filehandle to input from. +.PP +If the string inside angle brackets is not a filehandle, it is interpreted +as a filename pattern to be globbed, and either an array of filenames or the +next filename in the list is returned, depending on context. +One level of $ interpretation is done first, but you can't say <$foo> +because that's an indirect filehandle as explained in the previous +paragraph. +You could insert curly brackets to force interpretation as a +filename glob: <${foo}>. +Example: +.nf + +.ne 3 + while (<*.c>) { + chmod 0644,$_; + } + +is equivalent to + +.ne 5 + open(foo,"echo *.c | tr -s ' \et\er\ef' '\e\e012\e\e012\e\e012\e\e012'|"); + while () { + chop; + chmod 0644,$_; + } + +.fi +In fact, it's currently implemented that way. +(Which means it will not work on filenames with spaces in them.) +Of course, the shortest way to do the above is: +.nf + + chmod 0644,<*.c>; + +.fi .Sh "Syntax" .PP A @@ -496,10 +633,11 @@ The following compound commands may be used to control flow: .ne 4 if (EXPR) BLOCK if (EXPR) BLOCK else BLOCK - if (EXPR) BLOCK elsif (EXPR) BLOCK ... else BLOCK + if (EXPR) BLOCK elsif (EXPR) BLOCK .\|.\|. else BLOCK LABEL while (EXPR) BLOCK LABEL while (EXPR) BLOCK continue BLOCK LABEL for (EXPR; EXPR; EXPR) BLOCK + LABEL foreach VAR (ARRAY) BLOCK LABEL BLOCK continue BLOCK .fi @@ -595,6 +733,34 @@ is the same as } .fi .PP +The foreach loop iterates over a normal array value and sets the variable +VAR to be each element of the array in turn. +The \*(L"foreach\*(R" keyword is actually identical to the \*(L"for\*(R" keyword, +so you can use \*(L"foreach\*(R" for readability or \*(L"for\*(R" for brevity. +If VAR is omitted, $_ is set to each value. +If ARRAY is an actual array (as opposed to an expression returning an array +value), you can modify each element of the array +by modifying VAR inside the loop. +Examples: +.nf + +.ne 5 + for (@ary) { s/foo/bar/; } + + foreach $elem (@elements) { + $elem *= 2; + } + + for ((10,9,8,7,6,5,4,3,2,1,'BOOM')) { + print $_,"\en"; sleep(1); + } + +.ne 3 + foreach $item (split(/:[\e\e\en:]*/,$ENV{'TERMCAP'}) { + print "Item: $item\en"; + } +.fi +.PP The BLOCK by itself (labeled or not) is equivalent to a loop that executes once. Thus you can use any of the loop control statements in it to leave or @@ -613,6 +779,21 @@ This construct is particularly nice for doing case structures. $nothing = 1; } +.fi +It's also nice for exiting subroutines early. +Note the double curly brackets: +.nf + +.ne 8 + sub tokenize {{ + .\|.\|. + if (/foo/) { + 23; # return value + last; + } + .\|.\|. + }} + .fi .Sh "Simple statements" The only kind of simple statement is an expression evaluated for its side @@ -641,7 +822,7 @@ modifiers have the expected semantics. The .I while and -.I unless +.I until 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. @@ -724,12 +905,16 @@ number of times specified by the right operand. 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. +Each .. operator maintains its own boolean state. +It is false as long as its left operand is false. +Once the left operand is true, the range operator stays true +until the right operand is true, +AFTER which the range operator becomes false again. +(It doesn't become false till the next time the range operator evaluated. It can become false on the same evaluation it became true, but it still returns true once.) +The right operand is not evaluated while the operator is in the \*(L"false\*(R" state, +and the left operand is not evaluated while the operator is in the \*(L"true\*(R" state. The .. 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 &&. @@ -741,7 +926,7 @@ 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 +If either operand of .. is static, that operand is implicitly compared to the $. variable, the current line number. Examples: .nf @@ -754,6 +939,77 @@ Examples: s/^/> / if (/^$/ .. eof()); # quote body .fi +.Ip \-x 8 +A file test. +This unary operator takes one argument, either a filename or a filehandle, +and tests the associated file to see if something is true about it. +If the argument is omitted, tests $_, except for \-t, which tests stdin. +It returns 1 for true and '' for false. +Precedence is higher than logical and relational operators, but lower than +arithmetic operators. +The operator may be any of: +.nf + \-r File is readable by effective uid. + \-w File is writeable by effective uid. + \-x File is executable by effective uid. + \-o File is owned by effective uid. + \-R File is readable by real uid. + \-W File is writeable by real uid. + \-X File is executable by real uid. + \-O File is owned by real uid. + \-e File exists. + \-z File has zero size. + \-s File has non-zero size. + \-f File is a plain file. + \-d File is a directory. + \-l File is a symbolic link. + \-p File is a named pipe (FIFO). + \-S File is a socket. + \-b File is a block special file. + \-c File is a character special file. + \-u File has setuid bit set. + \-g File has setgid bit set. + \-k File has sticky bit set. + \-t Filehandle is opened to a tty. + \-T File is a text file. + \-B File is a binary file (opposite of \-T). + +.fi +The interpretation of the file permission operators \-r, \-R, \-w, \-W, \-x and \-X +is based solely on the mode of the file and the uids and gids of the user. +There may be other reasons you can't actually read, write or execute the file. +Also note that, for the superuser, \-r, \-R, \-w and \-W always return 1, and +\-x and \-X return 1 if any execute bit is set in the mode. +Scripts run by the superuser may thus need to do a stat() in order to determine +the actual mode of the file, or temporarily set the uid to something else. +.Sp +Example: +.nf +.ne 7 + + while (<>) { + chop; + next unless \-f $_; # ignore specials + .\|.\|. + } + +.fi +Note that -s/a/b/ does not do a negated substitution. +Saying -exp($foo) still works as expected, however\*(--only single letters +following a minus are interpreted as file tests. +.Sp +The \-T and \-B switches work as follows. +The first block or so of the file is examined for odd characters such as +strange control codes or metacharacters. +If too many odd characters (>10%) are found, it's a \-B file, otherwise it's a \-T file. +Also, any file containing null in the first block is considered a binary file. +If \-T or \-B is used on a filehandle, the current stdio buffer is examined +rather than the first block. +Since input doesn't work well on binary files you should probably test a +filehandle before doing any input if you're unsure of the nature of the +filehandle you've been handed (usually via stdin). +Both \-T and \-B return TRUE on a null file, or a file at EOF when testing +a filehandle. .PP Here is what C has that .I perl @@ -762,6 +1018,8 @@ doesn't: Address-of operator. .Ip "unary *" 12 Dereference-address operator. +.Ip "(TYPE)" 12 +Type casting operator. .PP Like C, .I perl @@ -780,9 +1038,31 @@ You can say .fi and this all reduces to one string internally. .PP +The autoincrement operator has a little extra built-in magic to it. +If you increment a variable that is numeric, or that has ever been used in +a numeric context, you get a normal increment. +If, however, the variable has only been used in string contexts since it +was set, and has a value that is not null and matches the +pattern /^[a-zA-Z]*[0-9]*$/, the increment is done +as a string, preserving each character within its range, with carry: +.nf + + print ++($foo = '99'); # prints '100' + print ++($foo = 'a0'); # prints 'a1' + print ++($foo = 'Az'); # prints 'Ba' + print ++($foo = 'zz'); # prints 'aaa' + +.fi +The autodecrement is not magical. +.PP Along with the literals and variables mentioned earlier, -the following operations can serve as terms in an expression: -.Ip "/PATTERN/" 8 4 +the following operations can serve as terms in an expression. +Some of these operations take a LIST as an argument. +Such a list can consist of any combination of scalar arguments or arrays; +the arrays will be included in the list as if each individual element were +interpolated at that point in the list. +Elements of the LIST should be separated by commas. +.Ip "/PATTERN/i" 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. @@ -791,40 +1071,51 @@ 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 `/'. +If the final delimiter is followed by the optional letter `i', the matching is +done in a case-insensitive manner. +.Sp +If used in a context that requires an array value, a pattern match returns an +array consisting of the subexpressions matched by the parens in pattern, +i.e. ($1, $2, $3.\|.\|.). .Sp Examples: .nf .ne 4 open(tty, '/dev/tty'); - \|=~ \|/\|^[Yy]\|/ \|&& \|do foo(\|); # do foo if desired + \|=~ \|/\|^y\|/i \|&& \|do foo(\|); # do foo if desired if (/Version: \|*\|([0-9.]*\|)\|/\|) { $version = $1; } next if m#^/usr/spool/uucp#; + if (($F1,$F2,$Etc) = ($foo =~ /^(\eS+)\es+(\eS+)\es*(.*)/)) + .fi +This last example splits $foo into the first two words and the remainder +of the line, and assigns those three fields to $F1, $F2 and $Etc. +The conditional is true if any variables were assigned, i.e. if the pattern +matched. .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. +something in each file of a set of files, for instance. .Ip "chdir EXPR" 8 2 -Changes the working director to EXPR, if possible. +Changes the working directory 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'); +.ne 2 + $cnt = chmod 0755,'foo','bar'; + chmod 0755,@executables; .fi .Ip "chop(VARIABLE)" 8 5 @@ -844,31 +1135,42 @@ Example: .\|.\|. } +.fi +You can actually chop anything that's an lvalue, including an assignment: +.nf + + chop($cwd = `pwd`); + .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. +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'); +.ne 2 + $cnt = chown $uid,$gid,'foo','bar'; + chown $uid,$gid,@filenames; .fi -.ne 18 +.ne 23 Here's an example of looking up non-numeric uids: .nf print "User: "; $user = ; + chop($user); + print "Files: " + $pattern = ; + chop($pattern); 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'); + @ary = <$pattern>; # get filenames if ($uid{$user} eq '') { die "$user not in passwd file"; } @@ -896,27 +1198,62 @@ Example: .ne 4 open(output,'|sort >foo'); # pipe to sort - ... # print stuff to output + .\|.\|. # print stuff to output close(output); # wait for sort to finish open(input,'foo'); # get sort's results .fi +FILEHANDLE may be an expression whose value gives the real filehandle name. .Ip "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 "delete $ASSOC{KEY}" 8 6 +Deletes the specified value from the specified associative array. +Returns the deleted value; +The following deletes all the values of an associative array: +.nf + +.ne 3 + foreach $key (keys(ARRAY)) { + delete $ARRAY{$key}; + } + +.fi +(But it would be faster to use the reset command.) .Ip "die EXPR" 8 6 -Prints the value of EXPR to stderr and exits with a non-zero status. +Prints the value of EXPR to stderr and exits with the current value of $! +(errno). +If $! is 0, exits with the value of ($? >> 8) (`command` status). +If ($? >> 8) is 0, exits with 255. Equivalent examples: .nf .ne 3 - die "Can't cd to spool." unless chdir '/usr/spool/news'; + die "Can't cd to spool.\en" unless chdir '/usr/spool/news'; + + chdir '/usr/spool/news' || die "Can't cd to spool.\en" + +.fi +.Sp +If the value of EXPR does not end in a newline, the current script line +number and input line number (if any) are also printed, and a newline is +supplied. +Hint: sometimes appending \*(L", stopped\*(R" to your message will cause it to make +better sense when the string \*(L"at foo line 123\*(R" is appended. +Suppose you are running script \*(L"canasta\*(R". +.nf + +.ne 7 + die "/etc/games is no good"; + die "/etc/games is no good, stopped"; + +produce, respectively - (chdir '/usr/spool/news') || die "Can't cd to spool." + /etc/games is no good at canasta line 123. + /etc/games is no good, stopped at canasta line 123. .fi -Note that the parens are necessary above due to precedence. See also .IR exit . .Ip "do BLOCK" 8 4 @@ -930,7 +1267,40 @@ Executes a SUBROUTINE declared by a .I sub declaration, and returns the value of the last expression evaluated in SUBROUTINE. +If you pass arrays as part of LIST you may wish to pass the length +of the array in front of each array. (See the section on subroutines later on.) +SUBROUTINE may be a scalar variable, in which case the variable contains +the name of the subroutine to execute. +The parentheses are required to avoid confusion with the next form of \*(L"do\*(R". +.Ip "do EXPR" 8 3 +Uses the value of EXPR as a filename and executes the contents of the file +as a perl script. +It's primary use is to include subroutines from a perl subroutine library. +.nf + do 'stat.pl'; + +is just like + + eval `cat stat.pl`; + +.fi +except that it's more efficient, more concise, keeps track of the current +filename for error messages, and searches all the -I libraries if the file +isn't in the current directory (see also the @INC array in Predefined Names). +It's the same, however, in that it does reparse the file every time you +call it, so if you are going to use the file inside a loop you might prefer +to use #include, at the expense of a little more startup time. +(The main problem with #include is that cpp doesn't grok # comments--a +workaround is to use \*(L";#\*(R" for standalone comments.) +Note that the following are NOT equivalent: +.nf + +.ne 2 + do $foo; # eval a file + do $foo(); # call a subroutine + +.fi .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. @@ -939,7 +1309,9 @@ When the array is entirely read, a null array is returned (which when assigned produces a FALSE (0) value). The next call to each() after that will start iterating again. The iterator can be reset only by reading all the elements from the array. -You should not modify the array while iterating over it. +You must not modify the array while iterating over it. +There is a single iterator for each associative array, shared by all +each(), keys() and values() function calls in the program. The following prints out your environment like the printenv program, only in a different order: .nf @@ -955,15 +1327,17 @@ See also keys() and values(). .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 +FILEHANDLE may be an expression whose value gives the real filehandle name. +An eof without an argument returns the eof status for the last file read. +Empty parentheses () may be used to indicate the pseudo file formed of the files listed on the command line, i.e. eof() is reasonable to use inside -a while (<>) loop. -Example: +a while (<>) loop to detect the end of only the last file. +Use eof(ARGV) or eof without the parens to test EACH file in a while (<>) loop. +Examples: .nf .ne 7 - # insert dashes just before last line + # insert dashes just before last line of last file while (<>) { if (eof()) { print "--------------\en"; @@ -971,6 +1345,15 @@ Example: print; } +.ne 7 + # reset line numbering on each input file + while (<>) { + print "$.\et$_"; + if (eof) { # Not eof(). + close(ARGV); + } + } + .fi .Ip "eval EXPR" 8 6 EXPR is parsed and executed as if it were a little perl program. @@ -981,6 +1364,7 @@ as with subroutines. If there is a syntax error or runtime error, a null string is returned by eval, and $@ is set to the error message. If there was no error, $@ is null. +If EXPR is omitted, evaluates $_. .Ip "exec LIST" 8 6 If there is more than one argument in LIST, calls execvp() with the arguments in LIST. @@ -990,6 +1374,13 @@ If there are none, the argument is split into words and passed directly to execvp(), which is more efficient. Note: exec (and system) do not flush your output buffer, so you may need to set $| to avoid lost output. +Examples: +.nf + + exec '/bin/echo', 'Your arguments are: ', @ARGV; + exec "sort $outfile | uniq"; + +.fi .Ip "exit EXPR" 8 6 Evaluates EXPR and exits immediately with that value. Example: @@ -1020,5 +1411,7 @@ Typically used as follows: = gmtime(time); .fi -All array elements are numeric. +All array elements are numeric, and come straight out of a struct tm. +In particular this means that $mon has the range 0..11 and $wday has the +range 0..6. ''' End of part 1 diff --git a/perl.man.2 b/perl.man.2 index 05eb4a9130e3..9abd3901f3ed 100644 --- a/perl.man.2 +++ b/perl.man.2 @@ -1,18 +1,15 @@ ''' Beginning of part 2 -''' $Header: perl.man.2,v 1.0.1.3 88/02/01 17:33:03 root Exp $ +''' $Header: perl.man.2,v 2.0.1.1 88/06/28 16:31:49 root Exp $ ''' ''' $Log: perl.man.2,v $ -''' Revision 1.0.1.3 88/02/01 17:33:03 root -''' patch12: documented split more adequately. +''' Revision 2.0.1.1 88/06/28 16:31:49 root +''' patch1: fixed some quotes +''' patch1: clarified semantics of study +''' patch1: added example of y with short second string +''' patch1: added example of unlink with <*> ''' -''' Revision 1.0.1.2 88/01/30 17:04:28 root -''' patch 11: random cleanup -''' -''' Revision 1.0.1.1 88/01/28 10:25:11 root -''' patch8: added $@ variable. -''' -''' Revision 1.0 87/12/18 16:18:41 root -''' Initial revision +''' Revision 2.0 88/06/05 00:09:30 root +''' Baseline version 2.0. ''' ''' .Ip "goto LABEL" 8 6 @@ -56,22 +53,30 @@ Here is yet another way to print your environment: @keys = keys(ENV); @values = values(ENV); while ($#keys >= 0) { - print pop(keys),'=',pop(values),"\n"; + print pop(keys),'=',pop(values),"\en"; + } + +or how about sorted by key: + +.ne 3 + foreach $key (sort keys(ENV)) { + print $key,'=',$ENV{$key},"\en"; } .fi .Ip "kill LIST" 8 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); + $cnt = kill 1,$child1,$child2; + kill 9,@goners; .fi +If the signal is negative, kills process groups instead of processes. +(On System V, a negative \fIprocess\fR number will also kill process groups, +but that's not portable.) .Ip "last LABEL" 8 8 .Ip "last" 8 The @@ -91,6 +96,39 @@ block, if any, is not executed: .\|.\|. } +.fi +.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 "local(LIST)" 8 4 +Declares the listed (scalar) variables to be local to the enclosing block, +subroutine or eval. +(The \*(L"do 'filename';\*(R" operator also counts as an eval.) +This operator works by saving the current values of those variables in LIST +on a hidden stack and restoring them upon exiting the block, subroutine or eval. +The LIST may be assigned to if desired, which allows you to initialize +your local variables. +Commonly this is used to name the parameters to a subroutine. +Examples: +.nf + +.ne 13 + sub RANGEVAL { + local($min, $max, $thunk) = @_; + local($result) = ''; + local($i); + + # Presumably $thunk makes reference to $i + + for ($i = $min; $i < $max; $i++) { + $result .= eval $thunk; + } + + $result; + } + .fi .Ip "localtime(EXPR)" 8 4 Converts a time as returned by the time function to a 9-element array with @@ -103,7 +141,9 @@ Typically used as follows: = localtime(time); .fi -All array elements are numeric. +All array elements are numeric, and come straight out of a struct tm. +In particular this means that $mon has the range 0..11 and $wday has the +range 0..6. .Ip "log(EXPR)" 8 3 Returns logarithm (base e) of EXPR. .Ip "next LABEL" 8 8 @@ -126,11 +166,6 @@ 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.) @@ -145,7 +180,9 @@ The following will handle decimal, octal and hex in the standard notation: .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 +If FILEHANDLE is an expression, its value is used as the name of the +real filehandle wanted. +If EXPR is omitted, the scalar variable of the same name as the FILEHANDLE contains the filename. If the filename begins with \*(L">\*(R", the file is opened for output. If the filename begins with \*(L">>\*(R", the file is opened for appending. @@ -160,43 +197,130 @@ Examples: .nf .ne 3 - $article = 100; - open article || die "Can't find article $article"; - while (
) {\|.\|.\|. + $article = 100; + open article || die "Can't find article $article"; + while (
) {\|.\|.\|. + + open(LOG, '>>/usr/spool/news/twitlog'\|); # (log is reserved) + + open(article, "caeser <$article |"\|); # decrypt article + + open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process# + +.ne 7 + # process argument list of files along with any includes + + foreach $file (@ARGV) { + do process($file,'fh00'); # no pun intended + } + + sub process {{ + local($filename,$input) = @_; + $input++; # this is a string increment + unless (open($input,$filename)) { + print stderr "Can't open $filename\en"; + last; # note block inside sub + } + while (<$input>) { # note the use of indirection + if (/^#include "(.*)"/) { + do process($1,$input); + next; + } + .\|.\|. # whatever + } + }} + +.fi +You may also, in the Bourne shell tradition, specify an EXPR beginning +with \*(L">&\*(R", in which case the rest of the string +is interpreted as the name of a filehandle +(or file descriptor, if numeric) which is to be duped and opened. +Here is a script that saves, redirects, and restores stdout and stdin: +.nf + +.ne 21 + #!/usr/bin/perl + open(saveout,">&stdout"); + open(saveerr,">&stderr"); + + open(stdout,">foo.out") || die "Can't redirect stdout"; + open(stderr,">&stdout") || die "Can't dup stdout"; + + select(stderr); $| = 1; # make unbuffered + select(stdout); $| = 1; # make unbuffered + + print stdout "stdout 1\en"; # this works for + print stderr "stderr 1\en"; # subprocesses too + + close(stdout); + close(stderr); + + open(stdout,">&saveout"); + open(stderr,">&saveerr"); + + print stdout "stdout 2\en"; + print stderr "stderr 2\en"; - open(log, '>>/usr/spool/news/twitlog'\|); +.fi +If you open a pipe on the command \*(L"-\*(R", i.e. either \*(L"|-\*(R" or \*(L"-|\*(R", +then there is an implicit fork done, and the return value of open +is the pid of the child within the parent process, and 0 within the child +process. +The filehandle behaves normally for the parent, but i/o to that +filehandle is piped from/to the stdout/stdin of the child process. +In the child process the filehandle isn't opened--i/o happens from/to +the new stdout or stdin. +Typically this is used like the normal piped open when you want to exercise +more control over just how the pipe command gets executed, such as when +you are running setuid, and don't want to have to scan shell commands +for metacharacters. +The following pairs are equivalent: +.nf - open(article, "caeser <$article |"\|); # decrypt article +.ne 5 + open(FOO,"|tr '[a-z]' '[A-Z]'"); + open(FOO,"|-") || exec 'tr', '[a-z]', '[A-Z]'; - open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process# + open(FOO,"cat -n $file|"); + open(FOO,"-|") || exec 'cat', '-n', $file; .fi +Explicitly closing the filehandle causes the parent process to wait for the +child to finish, and returns the status value in $?. .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--] +Has the same effect as +.nf + + $tmp = $ARRAY[$#ARRAY]; $#ARRAY--; + +.fi .Ip "print FILEHANDLE LIST" 8 9 .Ip "print LIST" 8 .Ip "print" 8 -Prints a string or comma-separated list of strings. +Prints a string or a comma-separated list of strings. +FILEHANDLE may be a scalar variable name, in which case the variable contains +the name of the filehandle, thus introducing one level of indirection. 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 +Equivalent to a \*(L"print FILEHANDLE sprintf(LIST)\*(R". +.Ip "push(ARRAY,LIST)" 8 7 +Treats ARRAY (@ is optional) as a stack, and pushes the values of LIST onto the end of ARRAY. -The length of ARRAY increases by 1. +The length of ARRAY increases by the length of LIST. Has the same effect as .nf - $ARRAY[$#ARRAY+1] = EXPR; + for $value (LIST) { + $ARRAY[$#ARRAY+1] = $value; + } .fi but is more efficient. @@ -242,8 +366,8 @@ 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. +All variables and arrays beginning with one of those letters are reset to +their pristine state. If the expression is omitted, one-match searches (?pattern?) are reset to match again. Always returns 1. @@ -256,18 +380,22 @@ Examples: reset; \h'|2i'# just reset ?? searches .fi -.Ip "s/PATTERN/REPLACEMENT/g" 8 3 +Note: resetting "A-Z" is not recommended since you'll wipe out your ARGV and ENV +arrays. +.Ip "s/PATTERN/REPLACEMENT/gi" 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. +The \*(L"i\*(R" is also optional, and if present, indicates that matching +is to be done in a case-insensitive manner. 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.) +(The string specified with =~ must be a scalar variable, an array element, +or an assignment to one of those, i.e. an lvalue.) If the pattern contains a $ that looks like a variable rather than an end-of-string test, the variable will be interpolated into the pattern at run-time. @@ -283,12 +411,15 @@ Examples: s/\|([^ \|]*\|) *\|([^ \|]*\|)\|/\|$2 $1/; # reverse 1st two fields + ($foo = $bar) =~ s/bar/foo/; + .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. +FILEHANDLE may be an expression whose value gives the name of the filehandle. Returns 1 upon success, 0 otherwise. .Ip "select(FILEHANDLE)" 8 3 Sets the current default filehandle for output. @@ -312,11 +443,12 @@ one output channel, you might do the following: .fi Select happens to return TRUE if the file is currently open and FALSE otherwise, but this has no effect on its operation. +FILEHANDLE may be an expression whose value gives the name of the actual filehandle. .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. +Shifts the first value of the array off and returns it, +shortening the array by 1 and moving everything down. If ARRAY is omitted, shifts the ARGV array. See also unshift(), push() and pop(). Shift() and unshift() do the same thing to the left end of an array that push() @@ -326,6 +458,40 @@ and pop() do to the right end. 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 "sort SUBROUTINE LIST" 8 7 +.Ip "sort LIST" 8 +Sorts the LIST and returns the sorted array value. +Nonexistent values of arrays are stripped out. +If SUBROUTINE is omitted, sorts in standard string comparison order. +If SUBROUTINE is specified, gives the name of a subroutine that returns +a -1, 0, or 1, depending on how the elements of the array are to be ordered. +In the interests of efficiency the normal calling code for subroutines +is bypassed, with the following effects: the subroutine may not be a recursive +subroutine, and the two elements to be compared are passed into the subroutine +not via @_ but as $a and $b (see example below). +SUBROUTINE may be a scalar variable name, in which case the value provides +the name of the subroutine to use. +Examples: +.nf + +.ne 4 + sub byage { + $age{$a} < $age{$b} ? -1 : $age{$a} > $age{$b} ? 1 : 0; + } + @sortedclass = sort byage @class; + +.ne 9 + sub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; } + @harry = ('dog','cat','x','Cain','Abel'); + @george = ('gone','chased','yz','Punished','Axed'); + print sort @harry; + # prints AbelCaincatdogx + print sort reverse @harry; + # prints xdogcatCainAbel + print sort @george,'to',@harry; + # prints AbelAxedCainPunishedcatchaseddoggonetoxyz + +.fi .Ip "split(/PATTERN/,EXPR)" 8 8 .Ip "split(/PATTERN/)" 8 .Ip "split" 8 @@ -393,6 +559,69 @@ Typically used as follows: $atime,$mtime,$ctime,$blksize,$blocks) = stat($filename); +.fi +.Ip "study(SCALAR)" 8 6 +.Ip "study" +Takes extra time to study SCALAR ($_ if unspecified) in anticipation of +doing many pattern matches on the string before it is next modified. +This may or may not save time, depending on the nature and number of patterns +you are searching on, and on the distribution of character frequencies in +the string to be searched\*(--you probably want to compare runtimes with and +without it to see which runs faster. +Those loops which scan for many short constant strings (including the constant +parts of more complex patterns) will benefit most. +(The way study works is this: a linked list of every character in the string +to be searched is made, so we know, for example, where all the `k' characters +are. +From each search string, the rarest character is selected, based on some +static frequency tables constructed from some C programs and English text. +Only those places that contain this \*(L"rarest\*(R" character are examined.) +.Sp +For example, here is a loop which inserts index producing entries before an line +containing a certain pattern: +.nf + +.ne 8 + while (<>) { + study; + print ".IX foo\en" if /\ebfoo\eb/; + print ".IX bar\en" if /\ebbar\eb/; + print ".IX blurfl\en" if /\ebblurfl\eb/; + .\|.\|. + print; + } + +.fi +In searching for /\ebfoo\eb/, only those locations in $_ that contain `f' +will be looked at, because `f' is rarer than `o'. +In general, this is a big win except in pathological cases. +The only question is whether it saves you more time than it took to build +the linked list in the first place. +.Sp +Note that if you have to look for strings that you don't know till runtime, +you can build an entire loop as a string and eval that to avoid recompiling +all your patterns all the time. +Together with setting $/ to input entire files as one record, this can +be very fast, often faster than specialized programs like fgrep. +The following scans a list of files (@files) +for a list of words (@words), and prints out the names of those files that +contain a match: +.nf + +.ne 12 + $search = 'while (<>) { study;'; + foreach $word (@words) { + $search .= "\e++$seen{\e$ARGV} if /\eb$word\eb/;\en"; + } + $search .= "}"; + @ARGV = @files; + $/ = "\e177"; # something that doesn't occur + eval $search; # this screams + $/ = "\en"; # put back to normal input delim + foreach $file (sort keys(seen)) { + print $file,"\en"; + } + .fi .Ip "substr(EXPR,OFFSET,LEN)" 8 2 Extracts a substring out of EXPR and returns it. @@ -401,11 +630,26 @@ First character is at offset 0, or whatever you've set $[ to. Does exactly the same thing as \*(L"exec LIST\*(R" except that a fork is done first, and the parent process waits for the child process to complete. Note that argument processing varies depending on the number of arguments. -The return value is the exit status of the program. -See exec. +The return value is the exit status of the program as returned by the wait() +call. +To get the actual exit value divide by 256. +See also exec. +.Ip "symlink(OLDFILE,NEWFILE)" 8 2 +Creates a new filename symbolically linked to the old filename. +Returns 1 for success, 0 otherwise. +On systems that don't support symbolic links, produces a fatal error at +run time. +To check for that, use eval: +.nf + + $symlink_exists = (eval 'symlink("","");', $@ eq ''); + +.fi .Ip "tell(FILEHANDLE)" 8 6 .Ip "tell" 8 Returns the current file position for FILEHANDLE. +FILEHANDLE may be an expression whose value gives the name of the actual +filehandle. If FILEHANDLE is omitted, assumes the file last read. .Ip "time" 8 4 Returns the number of seconds since January 1, 1970. @@ -423,8 +667,8 @@ 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.) +(The string specified with =~ must be a scalar variable, an array element, +or an assignment to one of those, i.e. an lvalue.) For .I sed devotees, @@ -438,28 +682,51 @@ Examples: $cnt = tr/*/*/; \h'|3i'# count the stars in $_ + ($HOST = $host) =~ tr/a-z/A-Z/; + + y/\e001-@[-_{-\e177/ /; \h'|3i'# change non-alphas to space + .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'); +.ne 2 + $cnt = unlink 'a','b','c'; + unlink @goners; + unlink <*.bak>; .fi +Note: unlink will not delete directories unless you are superuser and the \-U +flag is supplied to perl. .ne 7 .Ip "unshift(ARRAY,LIST)" 8 4 Does the opposite of a shift. +Or the opposite of a push, depending on how you look at it. Prepends list to the front of the array, and returns the number of elements in the new array. .nf unshift(ARGV,'-e') unless $ARGV[0] =~ /^-/; +.fi +.Ip "utime LIST" 8 2 +Changes the access and modification times on each file of a list of files. +The first two elements of the list must be the NUMERICAL access and +modification times, in that order. +Returns the number of files successfully changed. +The inode modification time of each file is set to the current time. +Example of a \*(L"touch\*(R" command: +.nf + +.ne 3 + #!/usr/bin/perl + $now = time; + utime $now,$now,@ARGV; + .fi .Ip "values(ASSOC_ARRAY)" 8 6 Returns a normal array consisting of all the values of the named associative @@ -468,6 +735,10 @@ 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 "wait" 8 6 +Waits for a child process to terminate and returns the pid of the deceased +process. +The status is returned in $?. .Ip "write(FILEHANDLE)" 8 6 .Ip "write(EXPR)" 8 .Ip "write(\|)" 8 @@ -494,6 +765,46 @@ 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 "Precedence" +Perl operators have the following associativity and precedence: +.nf + +nonassoc\h'|1i'print printf exec system sort +\h'1.5i'chmod chown kill unlink utime +left\h'|1i', +right\h'|1i'= +right\h'|1i'?: +nonassoc\h'|1i'.. +left\h'|1i'|| +left\h'|1i'&& +left\h'|1i'| ^ +left\h'|1i'& +nonassoc\h'|1i'== != eq ne +nonassoc\h'|1i'< > <= >= lt gt le ge +nonassoc\h'|1i'chdir die exit eval reset sleep +nonassoc\h'|1i'-r -w -x etc. +left\h'|1i'<< >> +left\h'|1i'+ - . +left\h'|1i'* / % x +left\h'|1i'=~ !~ +right\h'|1i'! ~ and unary minus +nonassoc\h'|1i'++ -- +left\h'|1i''(' + +.fi +Actually, the precedence of list operators such as print, sort or chmod is +either very high or very low depending on whether you look at the left +side of operator or the right side of it. +For example, in + + @ary = (1, 3, sort 4, 2); + print @ary; # prints 1324 + +the commas on the right of the sort are evaluated before the sort, but +the commas on the left are evaluated after. +In other words, list operators tend to gobble up all the arguments that +follow them, and then act like a simple term with regard to the preceding +expression. .Sh "Subroutines" A subroutine may be declared as follows: .nf @@ -506,22 +817,19 @@ 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. +To create local variables see the \*(L"local\*(R" operator. .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(@_)) { + local($max) = pop(@_); + foreach $foo (@_) { $max = $foo \|if \|$max < $foo; } $max; @@ -556,29 +864,36 @@ Example: .fi .nf .ne 6 -Use array assignment to name your formal arguments: +Use array assignment to local list to name your formal arguments: sub maybeset { - ($key,$value) = @_; + local($key,$value) = @_; $foo{$key} = $value unless $foo{$key}; } .fi +Subroutines may be called recursively. .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. +those supplied in the Version 8 regexp routines. +(In fact, the routines are derived from Henry Spencer's freely redistributable +reimplementation of the V8 routines.) +In addition, \ew matches an alphanumeric character (including \*(L"_\*(R") and \eW a nonalphanumeric. Word boundaries may be matched by \eb, and non-boundaries by \eB. -The bracketing construct \|(\ .\|.\|.\ \|) may also be used, $ +A whitespace character is matched by \es, non-whitespace by \eS. +A numeric character is matched by \ed, non-numeric by \eD. +You may use \ew, \es and \ed within character classes. +Also, \en, \er, \ef, \et and \eNNN have their normal interpretations. +Within character classes \eb represents backspace rather than a word boundary. +The bracketing construct \|(\ .\|.\|.\ \|) may also be used, in which case \e 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.) +(Outside of patterns, use $ instead of \e in front of the digit. +The scope of $ extends to the end of the enclosing BLOCK, or to +the next pattern match with subexpressions.) $+ 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. +($0 normally returns the same thing, but don't depend on it.) +Alternatives may be separated by |. Examples: .nf @@ -603,6 +918,23 @@ $* to 1. Setting it back to 0 makes .I perl revert to its old behavior. +.PP +To facilitate multi-line substitutions, the . character never matches a newline. +In particular, the following leaves a newline on the $_ string: +.nf + + $_ = ; + s/.*(some_string).*/$1/; + +If the newline is unwanted, try one of + + s/.*(some_string).*\en/$1/; + s/.*(some_string)[^\000]*/$1/; + s/.*(some_string)(.|\en)*/$1/; + chop; s/.*(some_string).*/$1/; + /(some_string)/ && ($_ = $1); + +.fi .Sh "Formats" Output record formats for use with the .I write @@ -641,18 +973,18 @@ 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 +They must currently be either scalar variable names or 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 +The value supplied must be a scalar variable name which contains a text string. .I Perl puts as much text as it can into the field, and then chops off the front -of the string so that the next time the string variable is referenced, +of the string so that the next time the variable is referenced, more of the text can be printed. Normally you would use a sequence of fields in a vertical stack to print out a block of text. @@ -727,7 +1059,7 @@ field and forgetting to zero it. 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 +to take the chance that someone would say reset \*(L"a-zA-Z\*(R" and wipe them all out. You'll just have to suffer along with these silly symbols. Most of them have reasonable mnemonics, or analogues in one of the shells. @@ -755,8 +1087,11 @@ The following pairs are equivalent: .fi (Mnemonic: underline is understood in certain operations.) .Ip $. 8 -The current input line number of the last file that was read. +The current input line number of the last filehandle that was read. Readonly. +Remember that only an explicit close on the filehandle resets the line number. +Since <> never does an explicit close, line numbers increase across ARGV files +(but see examples under eof). (Mnemonic: many programs use . to mean the current line number.) .Ip $/ 8 The input record separator, newline by default. @@ -822,8 +1157,15 @@ The process number of the running this script. (Mnemonic: same as shells.) .Ip $? 8 -The status returned by the last backtick (``) command. -(Mnemonic: same as sh and ksh.) +The status returned by the last backtick (``) command or system operator. +Note that this is the status word returned by the wait() system +call, so the exit value of the subprocess is actually ($? >> 8). +$? & 255 gives which signal, if any, the process died from, and whether +there was a core dump. +(Mnemonic: similar to sh and ksh.) +.Ip $& 8 4 +The string matched by the last pattern match. +(Mnemonic: like & in some editors.) .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 @@ -863,17 +1205,58 @@ behave more like 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. +If used in a numeric context, yields the current value of errno, with all the +usual caveats. +If used in a string context, yields the corresponding system error string. +You can assign to $! in order to set errno +if, for instance, you want $! to return the string for error n, or you want +to set the exit value for the die operator. (Mnemonic: What just went bang?) .Ip $@ 8 2 The error message from the last eval command. If null, the last eval parsed and executed correctly. -(Mnemonic: Where was the syntax error "at"?) +(Mnemonic: Where was the syntax error \*(L"at\*(R"?) +.Ip $< 8 2 +The real uid of this process. +(Mnemonic: it's the uid you came FROM, if you're running setuid.) +.Ip $> 8 2 +The effective uid of this process. +Example: +.nf + + $< = $>; # set real uid to the effective uid + +.fi +(Mnemonic: it's the uid you went TO, if you're running setuid.) +.Ip $( 8 2 +The real gid of this process. +If you are on a machine that supports membership in multiple groups +simultaneously, gives a space separated list of groups you are in. +The first number is the one returned by getgid(), and the subsequent ones +by getgroups(), one of which may be the same as the first number. +(Mnemonic: parens are used to GROUP things. +The real gid is the group you LEFT, if you're running setgid.) +.Ip $) 8 2 +The effective gid of this process. +If you are on a machine that supports membership in multiple groups +simultaneously, gives a space separated list of groups you are in. +The first number is the one returned by getegid(), and the subsequent ones +by getgroups(), one of which may be the same as the first number. +(Mnemonic: parens are used to GROUP things. +The effective gid is the group that's RIGHT for you, if you're running setgid.) +.Sp +Note: $<, $>, $( and $) can only be set on machines that support the +corresponding set[re][ug]id() routine. .Ip @ARGV 8 3 The array ARGV contains the command line arguments intended for the script. Note that $#ARGV is the generally number of arguments minus one, since $ARGV[0] is the first argument, NOT the command name. See $0 for the command name. +.Ip @INC 8 3 +The array INC contains the list of places to look for perl scripts to be +evaluated by the \*(L"do EXPR\*(R" command. +It initially consists of the arguments to any -I command line switches, followed +by the default perl library, probably \*(L"/usr/local/lib/perl\*(R". .Ip $ENV{expr} 8 2 The associative array ENV contains your current environment. Setting a value in ENV changes the environment for child processes. @@ -884,15 +1267,15 @@ Example: .ne 12 sub handler { # 1st argument is signal name - ($sig) = @_; - print "Caught a SIG$sig--shutting down\n"; - close(log); + local($sig) = @_; + print "Caught a SIG$sig--shutting down\en"; + close(LOG); exit(0); } $SIG{'INT'} = 'handler'; $SIG{'QUIT'} = 'handler'; - ... + .\|.\|. $SIG{'INT'} = 'DEFAULT'; # restore default action $SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT @@ -948,6 +1331,8 @@ Likewise string positions in substr() and index(). .Ip * 4 2 You have to decide whether your array has numeric or string indices. .Ip * 4 2 +Associative array values do not spring into existence upon mere reference. +.Ip * 4 2 You have to decide whether you want to use string or numeric comparisons. .Ip * 4 2 Reading an input line does not split it for you. You get to split it yourself @@ -984,9 +1369,6 @@ 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. @@ -1009,11 +1391,9 @@ 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. +The \*(L"system\*(R" calls link, unlink, rename, etc. return nonzero for success, not 0. .Ip * 4 2 Signal handlers deal with signal names, not numbers. .PP @@ -1022,25 +1402,37 @@ Seasoned sed programmers should take note of the following: Backreferences in substitutions use $ rather than \e. .Ip * 4 2 The pattern matching metacharacters (, ), and | do not have backslashes in front. +.Ip * 4 2 +The range operator is .. rather than comma. +.PP +Sharp shell programmers should take note of the following: +.Ip * 4 2 +The backtick operator does variable interpretation without regard to the +presence of single quotes in the command. +.Ip * 4 2 +The backtick operator does no translation of the return value, unlike csh. +.Ip * 4 2 +Shells (especially csh) do several levels of substitution on each command line. +Perl does substitution only in certain constructs such as double quotes, +backticks, angle brackets and search patterns. +.Ip * 4 2 +Shells interpret scripts a little bit at a time. +Perl compiles the whole program before executing it. +.Ip * 4 2 +The arguments are available via @ARGV, not $1, $2, etc. +.Ip * 4 2 +The environment is not automatically made available as variables. .SH BUGS .PP -You can't currently dereference array elements inside a double-quoted string. -You must assign them to a temporary and interpolate that. +You can't currently dereference arrays or array elements inside a +double-quoted string. +You must assign them to a scalar 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. +Perl is at the mercy of the C compiler's definitions of various operations +such as % and atof(). +In particular, don't trust % on negative numbers. .PP .I Perl actually stands for Pathologically Eclectic Rubbish Lister, but don't tell diff --git a/perl.y b/perl.y index b9a7a8e30e0e..45feaafdf1ef 100644 --- a/perl.y +++ b/perl.y @@ -1,40 +1,36 @@ -/* $Header: perl.y,v 1.0.1.1 88/01/28 10:25:31 root Exp $ +/* $Header: perl.y,v 2.0 88/06/05 00:09:36 root Exp $ * * $Log: perl.y,v $ - * Revision 1.0.1.1 88/01/28 10:25:31 root - * patch8: added eval operator. - * - * Revision 1.0 87/12/18 15:48:59 root - * Initial revision + * Revision 2.0 88/06/05 00:09:36 root + * Baseline version 2.0. * */ %{ -#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", +"using","format","do","shift","push","pop","chop/study", "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", +"join", "sub", "file test", "local", "delete", "format lines", "register","array_length", "array", "s","pattern", -"string","y", -"print", "unary operation", +"string","tr", +"list operator", "..", "||", "&&", "==","!=", "EQ", "NE", "<=",">=", "LT", "GT", "LE", "GE", +"unary operation", +"file test", "<<",">>", "=~","!~", "unary -", @@ -42,6 +38,8 @@ char *tokename[] = { "???" }; +STAB *scrstab; + %} %start prog @@ -58,11 +56,11 @@ char *tokename[] = { %token WORD %token APPEND OPEN WRITE SELECT CLOSE LOOPEX -%token USING FORMAT DO SHIFT PUSH POP CHOP +%token USING FORMAT DO SHIFT PUSH POP LVALFUN %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 JOIN SUB FILETEST LOCAL DELETE %token FORMLIST %token REG ARYLEN ARY %token SUBST PATTERN @@ -72,14 +70,13 @@ char *tokename[] = { %type %type block lineseq line loop cond sideff nexpr else %type expr sexpr term -%type condmod loopmod cexpr -%type texpr print +%type condmod loopmod +%type texpr listop %type label %type compblock -%nonassoc PRINT +%nonassoc LISTOP %left ',' -%nonassoc UNIOP %right '=' %right '?' ':' %nonassoc DOTDOT @@ -89,6 +86,8 @@ char *tokename[] = { %left '&' %nonassoc EQ NE SEQ SNE %nonassoc '<' '>' LE GE SLT SGT SLE SGE +%nonassoc UNIOP +%nonassoc FILETEST %left LS RS %left '+' '-' '.' %left '*' '/' '%' 'x' @@ -117,7 +116,8 @@ else : /* NULL */ | ELSE block { $$ = $2; } | ELSIF '(' expr ')' compblock - { $$ = make_ccmd(C_IF,$3,$5); } + { cmdline = $1; + $$ = make_ccmd(C_IF,$3,$5); } ; block : '{' lineseq '}' @@ -137,7 +137,7 @@ line : decl | loop /* loops add their own labels */ | label ';' { if ($1 != Nullch) { - $$ = add_label(make_acmd(C_EXPR, Nullstab, + $$ = add_label($1, make_acmd(C_EXPR, Nullstab, Nullarg, Nullarg) ); } else $$ = Nullcmd; } @@ -156,31 +156,99 @@ sideff : expr ; cond : IF '(' expr ')' compblock - { $$ = make_ccmd(C_IF,$3,$5); } + { cmdline = $1; + $$ = make_ccmd(C_IF,$3,$5); } | UNLESS '(' expr ')' compblock - { $$ = invert(make_ccmd(C_IF,$3,$5)); } + { cmdline = $1; + $$ = invert(make_ccmd(C_IF,$3,$5)); } | IF block compblock - { $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); } + { cmdline = $1; + $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); } | UNLESS block compblock - { $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); } + { cmdline = $1; + $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); } ; loop : label WHILE '(' texpr ')' compblock - { $$ = wopt(add_label($1, + { cmdline = $2; + $$ = wopt(add_label($1, make_ccmd(C_WHILE,$4,$6) )); } | label UNTIL '(' expr ')' compblock - { $$ = wopt(add_label($1, + { cmdline = $2; + $$ = wopt(add_label($1, invert(make_ccmd(C_WHILE,$4,$6)) )); } | label WHILE block compblock - { $$ = wopt(add_label($1, + { cmdline = $2; + $$ = wopt(add_label($1, make_ccmd(C_WHILE, cmd_to_arg($3),$4) )); } | label UNTIL block compblock - { $$ = wopt(add_label($1, + { cmdline = $2; + $$ = wopt(add_label($1, invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); } + | label FOR REG '(' expr ')' compblock + { cmdline = $2; + /* + * The following gobbledygook catches EXPRs that + * aren't explicit array refs and translates + * foreach VAR (EXPR) { + * into + * @ary = EXPR; + * foreach VAR (@ary) { + * where @ary is a hidden array made by genstab(). + */ + if ($5->arg_type != O_ARRAY) { + scrstab = aadd(genstab()); + $$ = append_line( + make_acmd(C_EXPR, Nullstab, + l(make_op(O_ASSIGN,2, + listish(make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg, 1)), + listish($5), + Nullarg,1)), + Nullarg), + wopt(over($3,add_label($1, + make_ccmd(C_WHILE, + make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg, 1 ), + $7))))); + } + else { + $$ = wopt(over($3,add_label($1, + make_ccmd(C_WHILE,$5,$7) ))); + } + } + | label FOR '(' expr ')' compblock + { cmdline = $2; + if ($4->arg_type != O_ARRAY) { + scrstab = aadd(genstab()); + $$ = append_line( + make_acmd(C_EXPR, Nullstab, + l(make_op(O_ASSIGN,2, + listish(make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg, 1 )), + listish($4), + Nullarg,1)), + Nullarg), + wopt(over(defstab,add_label($1, + make_ccmd(C_WHILE, + make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg, 1 ), + $6))))); + } + else { /* lisp, anyone? */ + $$ = wopt(over(defstab,add_label($1, + make_ccmd(C_WHILE,$4,$6) ))); + } + } | label FOR '(' nexpr ';' texpr ';' nexpr ')' block /* basically fake up an initialize-while lineseq */ { yyval.compval.comp_true = $10; yyval.compval.comp_alt = $8; + cmdline = $2; $$ = append_line($4,wopt(add_label($1, make_ccmd(C_WHILE,$6,yyval.compval) ))); } | label compblock /* a block is a loop that happens once */ @@ -227,14 +295,10 @@ format : FORMAT WORD '=' FORMLIST '.' ; subrout : SUB WORD block - { stabent($2,TRUE)->stab_sub = $3; } - ; - -expr : print - | cexpr + { make_sub($2,$3); } ; -cexpr : sexpr ',' cexpr +expr : sexpr ',' expr { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg,0); } | sexpr ; @@ -355,26 +419,49 @@ term : '-' term %prec UMINUS { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg,0); } | '~' term { $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg,0);} + | FILETEST WORD + { opargs[$1] = 0; /* force it special */ + $$ = make_op($1, 1, + stab2arg(A_STAB,stabent($2,TRUE)), + Nullarg, Nullarg,0); + } + | FILETEST sexpr + { opargs[$1] = 1; + $$ = make_op($1, 1, $2, Nullarg, Nullarg,0); } + | FILETEST + { opargs[$1] = ($1 != O_FTTTY); + $$ = make_op($1, 1, + stab2arg(A_STAB, + $1 == O_FTTTY?stabent("stdin",TRUE):defstab), + Nullarg, Nullarg,0); } + | LOCAL '(' expr ')' + { $$ = localize(listish(make_list(hide_ary($3)))); } | '(' expr ')' { $$ = make_list(hide_ary($2)); } | '(' ')' { $$ = make_list(Nullarg); } + | DO sexpr %prec FILETEST + { $$ = make_op(O_DOFILE,1,$2,Nullarg,Nullarg,0); + allstabs = TRUE;} | DO block %prec '(' { $$ = cmd_to_arg($2); } | REG %prec '(' - { $$ = stab_to_arg(A_STAB,$1); } + { $$ = stab2arg(A_STAB,$1); } | REG '[' expr ']' %prec '(' { $$ = make_op(O_ARRAY, 2, - $3, stab_to_arg(A_STAB,aadd($1)), Nullarg,0); } + $3, stab2arg(A_STAB,aadd($1)), Nullarg,0); } | ARY %prec '(' { $$ = make_op(O_ARRAY, 1, - stab_to_arg(A_STAB,$1), + stab2arg(A_STAB,$1), Nullarg, Nullarg, 1); } | REG '{' expr '}' %prec '(' { $$ = make_op(O_HASH, 2, - $3, stab_to_arg(A_STAB,hadd($1)), Nullarg,0); } + $3, stab2arg(A_STAB,hadd($1)), Nullarg,0); } + | DELETE REG '{' expr '}' %prec '(' + { $$ = make_op(O_DELETE, 2, + $4, stab2arg(A_STAB,hadd($2)), Nullarg,0); } | ARYLEN %prec '(' - { $$ = stab_to_arg(A_ARYLEN,$1); } + { $$ = stab2arg(A_ARYLEN,$1); } | RSTRING %prec '(' { $$ = $1; } | PATTERN %prec '(' @@ -386,12 +473,22 @@ term : '-' term %prec UMINUS | DO WORD '(' expr ')' { $$ = make_op(O_SUBR, 2, make_list($4), - stab_to_arg(A_STAB,stabent($2,TRUE)), + stab2arg(A_WORD,stabent($2,TRUE)), Nullarg,1); } | DO WORD '(' ')' { $$ = make_op(O_SUBR, 2, make_list(Nullarg), - stab_to_arg(A_STAB,stabent($2,TRUE)), + stab2arg(A_WORD,stabent($2,TRUE)), + Nullarg,1); } + | DO REG '(' expr ')' + { $$ = make_op(O_SUBR, 2, + make_list($4), + stab2arg(A_STAB,$2), + Nullarg,1); } + | DO REG '(' ')' + { $$ = make_op(O_SUBR, 2, + make_list(Nullarg), + stab2arg(A_STAB,$2), Nullarg,1); } | LOOPEX { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg,0); } @@ -410,113 +507,133 @@ term : '-' term %prec UMINUS Nullarg, Nullarg, Nullarg,0); } | WRITE '(' WORD ')' { $$ = l(make_op(O_WRITE, 1, - stab_to_arg(A_STAB,stabent($3,TRUE)), + stab2arg(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)), + stab2arg(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)), + stab2arg(A_WORD,stabent($2,TRUE)), + stab2arg(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)), + stab2arg(A_WORD,stabent($3,TRUE)), + stab2arg(A_STAB,stabent($3,TRUE)), Nullarg,0); } | OPEN '(' WORD ',' expr ')' { $$ = make_op(O_OPEN, 2, - stab_to_arg(A_STAB,stabent($3,TRUE)), + stab2arg(A_WORD,stabent($3,TRUE)), + $5, Nullarg,0); } + | OPEN '(' sexpr ',' expr ')' + { $$ = make_op(O_OPEN, 2, + $3, $5, Nullarg,0); } | CLOSE '(' WORD ')' { $$ = make_op(O_CLOSE, 1, - stab_to_arg(A_STAB,stabent($3,TRUE)), + stab2arg(A_WORD,stabent($3,TRUE)), + Nullarg, Nullarg,0); } + | CLOSE '(' expr ')' + { $$ = make_op(O_CLOSE, 1, + $3, Nullarg, Nullarg,0); } | CLOSE WORD %prec '(' { $$ = make_op(O_CLOSE, 1, - stab_to_arg(A_STAB,stabent($2,TRUE)), + stab2arg(A_WORD,stabent($2,TRUE)), Nullarg, Nullarg,0); } | FEOF '(' WORD ')' { $$ = make_op(O_EOF, 1, - stab_to_arg(A_STAB,stabent($3,TRUE)), + stab2arg(A_WORD,stabent($3,TRUE)), + Nullarg, Nullarg,0); } + | FEOF '(' expr ')' + { $$ = make_op(O_EOF, 1, + $3, Nullarg, Nullarg,0); } | FEOF '(' ')' - { $$ = make_op(O_EOF, 0, - stab_to_arg(A_STAB,stabent("ARGV",TRUE)), + { $$ = make_op(O_EOF, 1, + stab2arg(A_WORD,Nullstab), 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)), + stab2arg(A_WORD,stabent($3,TRUE)), + Nullarg, Nullarg,0); } + | TELL '(' expr ')' + { $$ = make_op(O_TELL, 1, + $3, 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)), + stab2arg(A_WORD,stabent($3,TRUE)), + $5, $7,1); } + | SEEK '(' sexpr ',' sexpr ',' expr ')' + { $$ = make_op(O_SEEK, 3, + $3, $5, $7,1); } | PUSH '(' WORD ',' expr ')' { $$ = make_op($1, 2, make_list($5), - stab_to_arg(A_STAB,aadd(stabent($3,TRUE))), + stab2arg(A_STAB,aadd(stabent($3,TRUE))), Nullarg,1); } | PUSH '(' ARY ',' expr ')' { $$ = make_op($1, 2, make_list($5), - stab_to_arg(A_STAB,$3), + stab2arg(A_STAB,$3), Nullarg,1); } | POP WORD %prec '(' { $$ = make_op(O_POP, 1, - stab_to_arg(A_STAB,aadd(stabent($2,TRUE))), + stab2arg(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))), + stab2arg(A_STAB,aadd(stabent($3,TRUE))), Nullarg, Nullarg,0); } | POP ARY %prec '(' { $$ = make_op(O_POP, 1, - stab_to_arg(A_STAB,$2), + stab2arg(A_STAB,$2), Nullarg, Nullarg, 0); } | POP '(' ARY ')' { $$ = make_op(O_POP, 1, - stab_to_arg(A_STAB,$3), + stab2arg(A_STAB,$3), Nullarg, Nullarg, 0); } | SHIFT WORD %prec '(' { $$ = make_op(O_SHIFT, 1, - stab_to_arg(A_STAB,aadd(stabent($2,TRUE))), + stab2arg(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))), + stab2arg(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); } + stab2arg(A_STAB,$2), Nullarg, Nullarg,0); } | SHIFT '(' ARY ')' { $$ = make_op(O_SHIFT, 1, - stab_to_arg(A_STAB,$3), Nullarg, Nullarg,0); } + stab2arg(A_STAB,$3), Nullarg, Nullarg,0); } | SHIFT %prec '(' { $$ = make_op(O_SHIFT, 1, - stab_to_arg(A_STAB,aadd(stabent("ARGV",TRUE))), + stab2arg(A_STAB,aadd(stabent("ARGV",TRUE))), Nullarg, Nullarg,0); } | SPLIT %prec '(' - { scanpat("/[ \t\n]+/"); + { scanpat("/\\s+/"); $$ = make_split(defstab,yylval.arg); } | SPLIT '(' WORD ')' - { scanpat("/[ \t\n]+/"); + { scanpat("/\\s+/"); $$ = make_split(stabent($3,TRUE),yylval.arg); } | SPLIT '(' WORD ',' PATTERN ')' { $$ = make_split(stabent($3,TRUE),$5); } @@ -528,12 +645,12 @@ term : '-' term %prec UMINUS { $$ = mod_match(O_MATCH, $5, make_split(defstab,$3) ); } | SPLIT '(' sexpr ')' { $$ = mod_match(O_MATCH, - stab_to_arg(A_STAB,defstab), + stab2arg(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))), + stab2arg(A_STAB,aadd(stabent($3,TRUE))), Nullarg,0); } | JOIN '(' sexpr ',' expr ')' { $$ = make_op(O_JOIN, 2, @@ -547,50 +664,56 @@ term : '-' term %prec UMINUS Nullarg,1); } | STAT '(' WORD ')' { $$ = l(make_op(O_STAT, 1, - stab_to_arg(A_STAB,stabent($3,TRUE)), + stab2arg(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), + | LVALFUN + { $$ = l(make_op($1, 1, + stab2arg(A_STAB,defstab), Nullarg, Nullarg,0)); } - | CHOP '(' expr ')' - { $$ = l(make_op(O_CHOP, 1, $3, Nullarg, Nullarg,0)); } + | LVALFUN '(' expr ')' + { $$ = l(make_op($1, 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); } + { $$ = make_op($1, 2, $3, $5, Nullarg, 0); + if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE) + fbmcompile($$[2].arg_ptr.arg_str); } | 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))), + stab2arg(A_STAB,hadd(stabent($3,TRUE))), Nullarg, Nullarg, 0); } + | listop ; -print : PRINT +listop : LISTOP { $$ = make_op($1,2, - stab_to_arg(A_STAB,defstab), - stab_to_arg(A_STAB,Nullstab), + stab2arg(A_STAB,defstab), + stab2arg(A_WORD,Nullstab), Nullarg,0); } - | PRINT expr + | LISTOP expr { $$ = make_op($1,2,make_list($2), - stab_to_arg(A_STAB,Nullstab), + stab2arg(A_WORD,Nullstab), Nullarg,1); } - | PRINT WORD + | LISTOP WORD { $$ = make_op($1,2, - stab_to_arg(A_STAB,defstab), - stab_to_arg(A_STAB,stabent($2,TRUE)), + stab2arg(A_STAB,defstab), + stab2arg(A_WORD,stabent($2,TRUE)), + Nullarg,1); } + | LISTOP WORD expr + { $$ = make_op($1,2,make_list($3), + stab2arg(A_WORD,stabent($2,TRUE)), Nullarg,1); } - | PRINT WORD expr + | LISTOP REG expr { $$ = make_op($1,2,make_list($3), - stab_to_arg(A_STAB,stabent($2,TRUE)), + stab2arg(A_STAB,$2), Nullarg,1); } ; %% /* PROGRAM */ -#include "perly.c" diff --git a/perldb b/perldb index d548f7299d82..9f03a7651a3e 100644 --- a/perldb +++ b/perldb @@ -1,10 +1,10 @@ -#!/bin/perl +#!/usr/bin/perl -# $Header: perldb,v 1.0.1.1 88/01/28 10:27:16 root Exp $ +# $Header: perldb,v 2.0 88/06/05 00:09:45 root Exp $ # # $Log: perldb,v $ -# Revision 1.0.1.1 88/01/28 10:27:16 root -# patch8: created this file. +# Revision 2.0 88/06/05 00:09:45 root +# Baseline version 2.0. # # @@ -25,7 +25,7 @@ open(script,$filename) || die "Can't find $filename"; open(tmp, ">$tmp") || die "Can't make temp script"; -$perl = '/bin/perl'; +$perl = '/usr/bin/perl'; $init = 1; $state = 'statement'; @@ -61,7 +61,8 @@ while (