From: Larry Wall Date: Wed, 18 Oct 1989 00:00:00 +0000 (+0000) Subject: perl 3.0: (no announcement message available) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a687059cbaf2c6fdccb5e0fae2aee80ec15625a8;p=p5sagit%2Fp5-mst-13.2.git perl 3.0: (no announcement message available) A few of the new features: (18 Oct) * Perl can now handle binary data correctly and has functions to pack and unpack binary structures into arrays or lists. You can now do arbitrary ioctl functions. * You can now pass things to subroutines by reference. * Debugger enhancements. * An array or associative array may now appear in a local() list. * Array values may now be interpolated into strings. * Subroutine names are now distinguished by prefixing with &. You can call subroutines without using do, and without passing any argument list at all. * You can use the new -u switch to cause perl to dump core so that you can run undump and produce a binary executable image. Alternately you can use the "dump" operator after initializing any variables and such. * You can now chop lists. * Perl now uses /bin/csh to do filename globbing, if available. This means that filenames with spaces or other strangenesses work right. * New functions: mkdir and rmdir, getppid, getpgrp and setpgrp, getpriority and setpriority, chroot, ioctl and fcntl, flock, readlink, lstat, rindex, pack and unpack, read, warn, dbmopen and dbmclose, dump, reverse, defined, undef. --- diff --git a/Changes b/Changes index c2f50c2..fdd452d 100644 --- a/Changes +++ b/Changes @@ -1,89 +1,259 @@ -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 +Changes to perl +--------------- -Local variables in blocks, subroutines and evals. +Apart from little bug fixes, here are the new features: -Recursive subroutine calls are now supported. +Perl can now handle binary data correctly and has functions to pack and +unpack binary structures into arrays or lists. You can now do arbitrary +ioctl functions. -Array values may now be interpolated into lists: - unlink 'foo', 'bar', @trashcan, 'tmp'; +You can do i/o with sockets and select. -File globbing via <*.foo>. +You can now write packages with their own namespace. -Use of <> in array contexts returns the whole file or glob list: - unlink <*.foo>; +You can now pass things to subroutines by reference. -New iterator for normal arrays, foreach, that allows both read and write: - foreach $elem ($array) { - $elem =~ s/foo/bar/; - } +The debugger now has hooks in the perl parser so it doesn't get confused. +The debugger won't interfere with stdin and stdout. New debugger commands: + n Single step around subroutine call. + l min+incr List incr+1 lines starting at min. + l List incr+1 more lines. + l subname List subroutine. + b subname Set breakpoint at first line of subroutine. + S List subroutine names. + D Delete all breakpoints. + A List line actions. + < command Define command before prompt. + > command Define command after prompt. + ! number Redo command (default previous command). + ! -number Redo numberth to last command. + h -number Display last number commands (default all). + p expr Same as \"print DBout expr\". -Ability to open pipe to a forked off script for secure pipes in setuid scripts. +The rules are more consistent about where parens are needed and +where they are not. In particular, unary operators and list operators now +behave like functions if they're called like functions. -File inclusion via - do 'foo.pl'; +There are some new quoting mechanisms: + $foo = q/"'"'"'"'"'"'"/; + $foo = qq/"'"''$bar"''/; + $foo = q(hi there); + $foo = <<'EOF' x 10; + Why, it's the old here-is mechanism! + EOF -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. +You can now work with array slices (note the initial @): + @foo[1,2,3]; + @foo{'Sun','Mon','Tue','Wed','Thu','Fri','Sat'} = (1,2,3,4,5,6,7); + @foo{split} = (1,1,1,1,1,1,1); -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. +There's now a range operator that works in array contexts: + for (1..15) { ... + @foo[3..5] = ('time','for','all'); + @foo{'Sun','Mon','Tue','Wed','Thu','Fri','Sat'} = 1..7; -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 reference associative arrays as a whole: + %abc = %def; + %foo = ('Sun',1,'Mon',2,'Tue',3,'Wed',4,'Thu',5,'Fri',6,'Sat',7); -You can now do certain file operations with a variable which holds the name -of a filehandle, e.g. open(++$incl,$includefilename); $foo = <$incl>; +Associative arrays can now be bound to a dbm or ndbm file. Perl automatically +caches references to the dbm file for you. -You can now a subroutine indirectly through a scalar variable: - $which = 'xyz'; - do $which('foo'); # calls xyz +An array or associative array can now be assigned to as part of a list, if +it's the last thing in the list: + ($a,$b,@rest) = split; -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. +An array or associative array may now appear in a local() list. + local(%assoc); + local(@foo) = @_; -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; +Array values may now be interpolated into strings: + `echo @ARGV`; + print "first three = @list[0..2]\n"; + print "@ENV{keys(ENV)}"; + ($" is used as the delimiter between array elements) -Reset now resets arrays and associative arrays as well as string variables. +Array sizes may be interpolated into strings: + print "The last element is $#foo.\n"; -Assigning off the end of an array now nulls out any intervening values. +Array values may now be returned from subroutines, evals, and do blocks. -$#foo is now an lvalue. You can preallocate or truncate arrays, or recover -values lost to prior truncation. +Lists of values in formats may now be arbitrary expressions, separated +by commas. -$#foo is now indexed to $[ properly. +Subroutine names are now distinguished by prefixing with &. You can call +subroutines without using do, and without passing any argument list at all: + $foo = &min($a,$b,$c); + $num = &myrand; -s/foo/bar/i optimization bug fixed. +You can use the new -u switch to cause perl to dump core so that you can +run undump and produce a binary executable image. Alternately you can +use the "dump" operator after initializing any variables and such. -The $x = "...$x..."; bug is fixed. +Perl now optimizes splits that are assigned directly to an array, or +to a list with fewer elements than the split would produce, or that +split on a constant string. -The @ary = (1); bug is now fixed. You can even say @ary = 1; +Perl now optimizes on end matches such as /foo$/; -$= now returns the correct value. +Perl now recognizes {n,m} in patterns to match preceding item at least n times +and no more than m times. Also recognizes {n,} and {n} to match n or more +times, or exactly n times. If { occurs in other than this context it is +still treated as a normal character. -Several of the larger files are now split into smaller pieces for easier -compilation. +Perl now optimizes "next" to avoid unnecessary longjmps and subroutine calls. -Pattern matches evaluated in an array context now return ($1, $2...). +Perl now optimizes appended input: $_ .= <>; -There is now a wait operator. +Substitutions are faster if the substituted text is constant, especially +when substituting at the beginning of a string. This plus the previous +optimization let you run down a file comparing multiple lines more +efficiently. (Basically the equivalents of sed's N and D are faster.) -There is now a sort operator. +Similarly, combinations of shifts and pushes on the same array are much +faster now--it doesn't copy all the pointers every time you shift (just +every n times, where n is approximately the length of the array plus 10, +more if you pre-extend the array), so you can use an array as a shift +register much more efficiently: + push(@ary,shift(@ary)); +or + shift(@ary); push(@ary,<>); -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 shift operator used inside subroutines now defaults to shifting +the @_ array. You can still shift ARGV explicitly, of course. + +The @_ array which is passed to subroutines is a local array, but the +elements of it are passed by reference now. This means that if you +explicitly modify $_[0], you are actually modifying the first argument +to the routine. Assignment to another location (such as the usual +local($foo) = @_ trick) causes a copy of the value, so this will not +affect most scripts. However, if you've modified @_ values in the +subroutine you could be in for a surprise. I don't believe most people +will find this a problem, and the long term efficiency gain is worth +a little confusion. + +Perl now detects sequences of references to the same variable and builds +switch statements internally wherever reasonable. + +The substr function can take offsets from the end of the string. + +The substr function can be assigned to in order to change the interior of a +string in place. + +The split function can return as part of the returned array any substrings +matched as part of the delimiter: + split(/([-,])/, '1-10,20') +returns + (1,'-',10,',',20) + +If you specify a maximum number of fields to split, the truncation of +trailing null fields is disabled. + +You can now chop lists. + +Perl now uses /bin/csh to do filename globbing, if available. This means +that filenames with spaces or other strangenesses work right. + +Perl can now report multiple syntax errors with a single invocation. + +Perl syntax errors now give two tokens of context where reasonable. + +Perl will now report the possibility of a runaway multi-line string if +such a string ends on a line with a syntax error. + +The assumed assignment in a while now works in the while modifier as +well as the while statement. + +Perl can now warn you if you use numeric == on non-numeric string values. + +New functions: + mkdir and rmdir + getppid + getpgrp and setpgrp + getpriority and setpriority + chroot + ioctl and fcntl + flock + readlink + lstat + rindex - find last occurrence of substring + pack and unpack - turn structures into arrays and vice versa + read - just what you think + warn - like die, only not fatal + dbmopen and dbmclose - bind a dbm file to an associative array + dump - do core dump so you can undump + reverse - turns an array value end for end + defined - does an object exist? + undef - make an object not exist + vec - treat string as a vector of small integers + fileno - return the file descriptor for a handle + wantarray - was subroutine called in array context? + opendir + readdir + telldir + seekdir + rewinddir + closedir + syscall + socket + bind + connect + listen + accept + shutdown + socketpair + getsockname + getpeername + getsockopt + setsockopt + getpwnam + getpwuid + getpwent + setpwent + endpwent + getgrnam + getgrgid + getgrent + setgrent + endgrent + gethostbyname + gethostbyaddr + gethostent + sethostent + endhostent + getnetbyname + getnetbyaddr + getnetent + setnetent + endnetent + getprotobyname + getprotobynumber + getprotoent + setprotoent + endprotoent + getservbyname + getservbyport + getservent + setservent + endservent + +Changes to s2p +-------------- + +In patterns, s2p now translates \{n,m\} correctly to {n,m}. + +In patterns, s2p no longer removes backslashes in front of |. + +In patterns, s2p now removes backslashes in front of [a-zA-Z0-9]. + +S2p now makes use of the location of perl as determined by Configure. + + +Changes to a2p +-------------- + +A2p can now accurately translate the "in" operator by using perl's new +"defined" operator. + +A2p can now accurately translate the passing of arrays by reference. -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 81be140..c3c65ea 100755 --- a/Configure +++ b/Configure @@ -8,7 +8,7 @@ # 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 2.0.1.1 88/06/28 16:24:02 root Exp $ +# $Header: Configure,v 3.0 89/10/18 15:04:55 lwall Locked $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than @@ -66,38 +66,108 @@ vi='' mailx='' mail='' cpp='' +perl='' +emacs='' +ls='' +rmail='' +sendmail='' +shar='' +smail='' +tbl='' +troff='' +nroff='' +uname='' +uuname='' +line='' +chgrp='' +chmod='' +lint='' +sleep='' +pr='' +tar='' +ln='' +lpr='' +lp='' +touch='' +make='' +date='' Log='' Header='' bin='' -cc='' +byteorder='' contains='' cppstdin='' cppminus='' +d_bcmp='' d_bcopy='' d_charsprf='' d_crypt='' +cryptlib='' d_dosuid='' +d_dup2='' d_fchmod='' d_fchown='' +d_fcntl='' +d_flock='' d_getgrps='' +d_gethent='' +d_getpgrp='' +d_getprior='' +d_htonl='' d_index='' +d_ioctl='' d_killpg='' +d_memcmp='' d_memcpy='' +d_mkdir='' +d_ndbm='' +d_odbm='' +d_readdir='' d_rename='' +d_rmdir='' d_setegid='' d_seteuid='' +d_setpgrp='' +d_setprior='' +d_setregid='' +d_setresgid='' +d_setreuid='' +d_setresuid='' d_setrgid='' d_setruid='' +d_socket='' +d_sockpair='' +d_oldsock='' +socketlib='' +sockethdr='' d_statblks='' d_stdstdio='' -d_strcspn='' d_strctcpy='' d_symlink='' +d_syscall='' d_tminsys='' +i_systime='' +d_varargs='' d_vfork='' d_voidsig='' +d_vprintf='' +d_charvspr='' gidtype='' +i_dirent='' +d_dirnamlen='' +i_fcntl='' +i_grp='' +i_pwd='' +d_pwquota='' +d_pwage='' +i_sysdir='' +i_sysioctl='' +i_varargs='' +i_vfork='' +intsize='' libc='' +libdbm='' +libndir='' libnm='' mallocsrc='' mallocobj='' @@ -110,11 +180,16 @@ small='' medium='' large='' huge='' +optimize='' ccflags='' ldflags='' +cc='' +libs='' n='' c='' package='' +randbits='' +sig_name='' spitshell='' shsharp='' sharpbang='' @@ -123,6 +198,7 @@ stdchar='' uidtype='' voidflags='' defvoidused='' +lib='' privlib='' CONFIG='' : set package name @@ -135,7 +211,7 @@ echo " " define='define' undef='undef' -libpth='/usr/lib /usr/local/lib /lib' +libpth='/usr/lib /usr/local/lib /usr/lib/386 /usr/lib/large /lib /lib/386 /lib/large /usr/lib/small /lib/small' 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 @@ -149,13 +225,21 @@ if test -f /etc/unixtovms.exe; then eunicefix=/etc/unixtovms.exe fi +: Now test for existence of everything in MANIFEST + +echo "First let's make sure your kit is complete. Checking..." +(cd ..; awk '' `awk '$1 !~ /PACKINGLIST/ {print $1}' MANIFEST` >/dev/null || kill $$) +echo " " + attrlist="mc68000 sun gcos unix ibm gimpel interdata tss os mert pyr" attrlist="$attrlist vax pdp11 i8086 z8000 u3b2 u3b5 u3b20 u3b200" +attrlist="$attrlist hpux hp9000s300 hp9000s500 hp9000s800" attrlist="$attrlist ns32000 ns16000 iAPX286 mc300 mc500 mc700 sparc" 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" +attrlist="$attrlist $mc68k __STDC__ UTS M_I8086 M_I186 M_I286 M_I386" +attrlist="$attrlist i186" +pth="/usr/ucb /bin /usr/bin /usr/local /usr/local/bin /usr/lbin /usr/plx /usr/5bin /vol/local/bin /etc /usr/lib /lib /usr/local/lib /sys5.3/bin /sys5.3/usr/bin /bsd4.3/bin /bsd4.3/usr/bin /bsd4.3/usr/ucb" +d_newshome="/usr/NeWS" defvoidused=7 : some greps do not return status, grrr. @@ -322,24 +406,25 @@ EOSC chmod +x loc $eunicefix loc loclist=" -expr -sed -echo cat -rm -mv cp -tr +echo +expr +grep mkdir +mv +rm +sed sort +tr uniq -grep " trylist=" -test -egrep Mcc cpp +egrep +test +uname " for file in $loclist; do xxx=`loc $file $file $pth` @@ -382,14 +467,10 @@ test) echo "Hopefully test is built into your sh." ;; /bin/test) - echo " " - dflt=n - rp="Is your "'"'"test"'"'" built into sh? [$dflt] (OK to guess)" - echo $n "$rp $c" - . myread - case "$ans" in - y*) test=test ;; - esac + if sh -c "PATH= test true" >/dev/null 2>&1; then + echo "Using the test built into your sh." + test=test + fi ;; *) test=test @@ -432,19 +513,37 @@ esac rmlist="$rmlist loc" : get list of predefined functions in a handy place +if $test -n "$uname"; then + os=`$uname -s` +else + os=unknown +fi echo " " if test -f /lib/libc.a; then echo "Your C library is in /lib/libc.a. You're normal." libc=/lib/libc.a else - ans=`loc libc.a blurfl/dyick $libpth` - if test ! -f $ans; then + if test "$os" = DomainOS ; then + ans=`loc libc blurfl/dyick $libpth` + else + ans=`loc libc.a blurfl/dyick $libpth` + fi + if test ! -f "$ans"; then ans=`loc clib blurfl/dyick $libpth` fi - if test ! -f $ans; then + if test ! -f "$ans"; then ans=`loc libc blurfl/dyick $libpth` fi - if test -f $ans; then + if test ! -f "$ans"; then + ans=`loc Slibc.a blurfl/dyick /usr/lib/386 /lib/386 $libpth` + fi + if test ! -f "$ans"; then + ans=`loc Mlibc.a blurfl/dyick $libpth` + fi + if test ! -f "$ans"; then + ans=`loc Llibc.a blurfl/dyick $libpth` + fi + if test -f "$ans"; then echo "Your C library is in $ans, of all places." libc=$ans else @@ -469,25 +568,32 @@ EOM fi echo " " $echo $n "Extracting names from $libc for later perusal...$c" -nm $libc 2>/dev/null | sed -n -e 's/^.* T _//p' -e 's/^.* T //p' > libc.list +nm $libc 2>/dev/null >libc.tmp +$sed -n -e 's/^.* [AT] *_[_.]*//p' -e 's/^.* [AT] //p' libc.list if $contains '^printf$' libc.list >/dev/null 2>&1; then echo "done" else - nm $libc 2>/dev/null | sed -n -e 's/^.* D _//p' -e 's/^.* D //p' > libc.list + if test "$os" = DomainOS ; then + $sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p' libc.list + else + $sed -n -e 's/^.* D __*//p' -e 's/^.* D //p' libc.list + fi + $contains '^printf$' libc.list >/dev/null 2>&1 || \ + $sed -n -e 's/^_//' \ + -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p' libc.list if $contains '^printf$' libc.list >/dev/null 2>&1; then echo "done" else 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 + $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 + if bld t $libc | $sed -e 's/.*\///' -e 's/\.o:.*$//' > libc.list; then echo "Ok." else echo "That didn't work either. Giving up." @@ -496,12 +602,19 @@ else fi fi fi -rmlist="$rmlist libc.list" + +inlibc='echo " "; +if $contains "^$1\$" libc.list >/dev/null 2>&1; +then echo "$1() found"; eval "$2=$define"; +else echo "$1() not found"; eval "$2=$undef"; fi' + +rmlist="$rmlist libc.tmp libc.list" : make some quick guesses about what we are up against echo " " $echo $n "Hmm... $c" -if $contains SIGTSTP /usr/include/signal.h >/dev/null 2>&1 ; then +cat /usr/include/signal.h /usr/include/sys/signal.h >foo +if $contains SIGTSTP foo >/dev/null 2>&1 ; then echo "Looks kind of like a BSD system, but we'll see..." echo exit 0 >bsd echo exit 1 >usg @@ -557,6 +670,7 @@ else fi chmod +x bsd usg v7 eunice venix $eunicefix bsd usg v7 eunice venix +rm -rf foo rmlist="$rmlist bsd usg v7 eunice venix xenix" : see if sh knows # comments @@ -619,287 +733,951 @@ else fi rm -f try today -: see how we invoke the C preprocessor -echo " " -echo "Now, how can we feed standard input to your C preprocessor..." -cat <<'EOT' >testcpp.c -#define ABC abc -#define XYZ xyz -ABC.XYZ -EOT -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." - cppstdin="$cpp" - cppminus=''; -else - 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." - cppstdin="$cpp" - cppminus='-'; +: set up shell script to do ~ expansion +cat >filexp <testcpp.out 2>&1 - if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "It works!" - 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 - echo "Hooray, it works! I was beginning to wonder." - 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 - echo "Yup, that does." - 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 - echo "Yup, that does." - cppstdin='cc -P' - cppminus='-'; - else - echo 'Hmm...perhaps you already told me...' - case "$cppstdin" in - '') ;; - *) $cppstdin $cppminus testcpp.out 2>&1;; - esac - if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Hooray, you did! I was beginning to wonder." - else - echo 'Uh-uh. Time to get fancy...' - echo 'Trying (cat >/tmp/$$.c; cc -E /tmp/$$.c; rm /tmp/$$.c)' - cppstdin='(cat >/tmp/$$.c; cc -E /tmp/$$.c; rm /tmp/$$.c)' - cppminus=''; - $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 - 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." - exit 1 - fi - fi - fi - fi - fi - fi + name=\`$expr x\$1 : '..\([^/]*\)'\` + dir=\`$sed -n -e "/^\${name}:/{s/^[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:\([^:]*\).*"'\$'"/\1/" -e p -e q -e '}' &2 + exit 1 fi - fi -fi -rm -f testcpp.c testcpp.out - -: see if bcopy exists -echo " " -if $contains '^bcopy$' libc.list >/dev/null 2>&1; then - echo 'bcopy() found.' - d_bcopy="$define" -else - echo 'bcopy() not found.' - d_bcopy="$undef" -fi - -: see if sprintf is declared as int or pointer to char -echo " " -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 - echo 'crypt() found.' - d_crypt="$define" -else - echo 'crypt() not found.' - 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 + case "\$1" in + */*) + echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\` + ;; + *) + echo \$dir + ;; + esac 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 " " -case "$d_index" in -n) dflt=n;; -*) dflt=y;; +: determine where public executables go +case "$bin" in +'') + dflt=`loc . /bin /usr/local/bin /usr/lbin /usr/local /usr/bin` + ;; +*) dflt="$bin" + ;; 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]" +cont=true +while $test "$cont" ; do + echo " " + rp="Where do you want to put the public executables? [$dflt]" + $echo $n "$rp $c" + . myread + bin="$ans" + bin=`filexp $bin` + if test -d $bin; then + cont='' + else + case "$fastread" in + yes) dflt=y;; + *) dflt=n;; + esac + rp="Directory $bin doesn't exist. Use that name anyway? [$dflt]" $echo $n "$rp $c" . myread + dflt='' case "$ans" in - n*) d_index="$define" ;; - *) d_index="$undef" ;; + y*) cont='';; esac - else - d_index="$undef" - echo "index() found." fi -else - 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 +done -: see if memcpy exists +: determine where manual pages go +$cat <pdp11.c <<'EOP' +main() { +#ifdef pdp11 + exit(0); +#else + exit(1); +#endif +} +EOP + cc -o pdp11 pdp11.c >/dev/null 2>&1 + if pdp11 2>/dev/null; then + dflt='unsplit split' + else + ans=`loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge` + case "$ans" in + X) dflt='none';; + *) if $test -d /lib/small || $test -d /usr/lib/small; then + dflt='small' + else + dflt='' + fi + if $test -d /lib/medium || $test -d /usr/lib/medium; then + dflt="$dflt medium" + fi + if $test -d /lib/large || $test -d /usr/lib/large; then + dflt="$dflt large" + fi + if $test -d /lib/huge || $test -d /usr/lib/huge; then + dflt="$dflt huge" + fi + esac + fi + ;; +*) dflt="$models" ;; +esac +$cat </dev/null 2>&1 || \ + $contains '\-i' $mansrc/man1/cc.1 >/dev/null 2>&1; then + dflt='-i' + else + dflt='none' + fi + ;; + *) dflt="$split";; + esac + rp="What flag indicates separate I and D space? [$dflt]" + $echo $n "$rp $c" + . myread + case "$ans" in + none) ans='';; + esac + split="$ans" + unsplit='' + ;; +*large*|*small*|*medium*|*huge*) + case "$models" in + *large*) + case "$large" in + '') dflt='-Ml';; + *) dflt="$large";; + esac + rp="What flag indicates large model? [$dflt]" + $echo $n "$rp $c" + . myread + case "$ans" in + none) ans=''; + esac + large="$ans" + ;; + *) large='';; + esac + case "$models" in + *huge*) + case "$huge" in + '') dflt='-Mh';; + *) dflt="$huge";; + esac + rp="What flag indicates huge model? [$dflt]" + $echo $n "$rp $c" + . myread + case "$ans" in + none) ans=''; + esac + huge="$ans" + ;; + *) huge="$large";; + esac + case "$models" in + *medium*) + case "$medium" in + '') dflt='-Mm';; + *) dflt="$medium";; + esac + rp="What flag indicates medium model? [$dflt]" + $echo $n "$rp $c" + . myread + case "$ans" in + none) ans=''; + esac + medium="$ans" + ;; + *) medium="$large";; + esac + case "$models" in + *small*) + case "$small" in + '') dflt='none';; + *) dflt="$small";; + esac + rp="What flag indicates small model? [$dflt]" + $echo $n "$rp $c" + . myread + case "$ans" in + none) ans=''; + esac + small="$ans" + ;; + *) small='';; + esac + ;; +*) + echo "Unrecognized memory models--you may have to edit Makefile.SH" + ;; +esac + +: see if we need a special compiler +echo " " +if usg; then + case "$cc" in + '') + case "$Mcc" in + /*) dflt='Mcc' + ;; + *) + case "$large" in + -M*) + dflt='cc' + ;; + *) + if $contains '\-M' $mansrc/cc.1 >/dev/null 2>&1 ; then + dflt='cc -M' + else + dflt='cc' + fi + ;; + esac + ;; + esac + ;; + *) dflt="$cc";; + esac + $cat <<'EOM' + +On some systems the default C compiler will not resolve multiple global +references that happen to have the same name. On some such systems the +"Mcc" command may be used to force these to be resolved. On other systems +a "cc -M" command is required. (Note that the -M flag on other systems +indicates a memory model to use!) If you have the Gnu C compiler, you +might wish to use that instead. What command will force resolution on +EOM + $echo $n "this system? [$dflt] $c" + rp="Command to resolve multiple refs? [$dflt]" + . myread + cc="$ans" +else + case "$cc" in + '') dflt=cc;; + *) dflt="$cc";; + esac + rp="Use which C compiler? [$dflt]" + $echo $n "$rp $c" + . myread + cc="$ans" +fi +case "$cc" in +gcc*) cpp=`loc gcc-cpp $cpp $pth`;; +esac + +: determine optimize, if desired, or use for debug flag also +case "$optimize" in +' ') dflt="none" + ;; +'') dflt="-O"; + ;; +*) dflt="$optimize" + ;; +esac +cat <try.c <<'EOCP' +#include +main() +{ + int i; + union { + unsigned long l; + char c[4]; + } u; + + u.l = 0x04030201; + printf("%c%c%c%c\n", u.c[0]+'0', u.c[1]+'0', u.c[2]+'0', u.c[3]+'0'); +} +EOCP + if $cc try.c -o try >/dev/null 2>&1 ; then + dflt=`try` + case "$dflt" in + ????) echo "(The test program ran ok.)";; + *) echo "(The test program didn't run right for some reason.)";; + esac + else + dflt='4321' + echo "(I can't seem to compile the test program. Guessing big-endian...)" + fi + ;; +*) + echo " " + dflt="$byteorder" + ;; +esac +rp="What is the order of bytes in a long? [$dflt]" +$echo $n "$rp $c" +. myread +byteorder="$ans" +$rm -f try.c try + +: see how we invoke the C preprocessor +echo " " +echo "Now, how can we feed standard input to your C preprocessor..." +cat <<'EOT' >testcpp.c +#define ABC abc +#define XYZ xyz +ABC.XYZ +EOT +echo 'Maybe "'"$cc"' -E" will work...' +$cc -E testcpp.out 2>&1 +if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + cppstdin="$cc -E" + cppminus=''; +else + 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." + cppstdin="$cpp" + cppminus=''; + else + echo 'No such luck...maybe "'$cpp' -" will work...' + $cpp - testcpp.out 2>&1 + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "It works!" + cppstdin="$cpp" + 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 + echo "Hooray, it works! I was beginning to wonder." + 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 + echo "Yup, that does." + 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 + echo "Yup, that does." + cppstdin="$cc -P" + cppminus='-'; + else + echo 'Hmm...perhaps you already told me...' + case "$cppstdin" in + '') ;; + *) $cppstdin $cppminus testcpp.out 2>&1;; + esac + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Hooray, you did! I was beginning to wonder." + else + echo 'Uh-uh. Time to get fancy...' + cd .. + echo 'Trying (cat >/tmp/$$.c; '"$cc"' -E /tmp/$$.c; rm /tmp/$$.c)' + echo 'cat >/tmp/$$.c; '"$cc"' -E /tmp/$$.c; rm /tmp/$$.c' >cppstdin + chmod 755 cppstdin + cppstdin=`pwd`/cppstdin + cppminus=''; + cd UU + $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 + 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." + exit 1 + fi + fi + fi + fi + fi + fi + fi + fi +fi +rm -f testcpp.c testcpp.out + +: see if bcmp exists +set bcmp d_bcmp +eval $inlibc + +: see if bcopy exists +set bcopy d_bcopy +eval $inlibc + +: see if sprintf is declared as int or pointer to char +echo " " +cat >.ucbsprf.c <<'EOF' +main() { char buf[10]; exit((unsigned long)sprintf(buf,"%s","foo") > 10L); } +EOF +if $cc $ccflags .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 vprintf exists +echo " " +if $contains '^vprintf$' libc.list >/dev/null 2>&1; then + echo 'vprintf() found.' + d_vprintf="$define" + cat >.ucbsprf.c <<'EOF' +#include + +main() { xxx("foo"); } + +xxx(va_alist) +va_dcl +{ + va_list args; + char buf[10]; + + va_start(args); + exit((unsigned long)vsprintf(buf,"%s",args) > 10L); +} +EOF + if $cc $ccflags .ucbsprf.c -o .ucbsprf >/dev/null 2>&1 && .ucbsprf; then + echo "Your vsprintf() returns (int)." + d_charvspr="$undef" + else + echo "Your vsprintf() returns (char*)." + d_charvspr="$define" + fi + /bin/rm -f .ucbsprf.c .ucbsprf +else + echo 'vprintf() not found.' + d_vprintf="$undef" + d_charvspr="$undef" +fi + +: see if crypt exists +echo " " +if $contains '^crypt$' libc.list >/dev/null 2>&1; then + echo 'crypt() found.' + d_crypt="$define" + cryptlib='' +else + cryptlib=`loc Slibcrypt.a "" /lib/386 /lib` + if $test -z "$cryptlib"; then + cryptlib=`loc Mlibcrypt.a "" /lib/386 /lib` + else + cryptlib=-lcrypt + fi + if $test -z "$cryptlib"; then + cryptlib=`loc Llibcrypt.a "" /lib/386 /lib` + else + cryptlib=-lcrypt + fi + if $test -z "$cryptlib"; then + cryptlib=`loc libcrypt.a "" $libpth` + else + cryptlib=-lcrypt + fi + if $test -z "$cryptlib"; then + echo 'crypt() not found.' + d_crypt="$undef" + else + d_crypt="$define" + fi +fi + +: see if this is a dirent system +echo " " +if $test -r /usr/include/dirent.h ; then + i_dirent="$define" + echo "dirent.h found." + if $contains 'd_namlen' /usr/include/sys/dirent.h >/dev/null 2>&1; then + d_dirnamlen="$define" + else + d_dirnamlen="$undef" + fi +else + i_dirent="$undef" + d_dirnamlen="$define" + echo "No dirent.h found." +fi + +: now see if they want to do setuid emulation +case "$d_dosuid" in +'') dflt=n;; +*undef*) dflt=n;; +*) dflt=y;; +esac +cat </dev/null 2>&1; then - echo 'memcpy() found.' - d_memcpy="$define" +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 'memcpy() not found.' - d_memcpy="$undef" + 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 rename exists +: see if ioctl defs are in sgtty/termio or sys/ioctl echo " " -if $contains '^rename$' libc.list >/dev/null 2>&1; then - echo 'rename() found.' - d_rename="$define" +if $test -r /usr/include/sys/ioctl.h ; then + d_ioctl="$define" + echo "sys/ioctl.h found." else - echo 'rename() not found.' - d_rename="$undef" + d_ioctl="$undef" + echo "sys/ioctl.h not found, assuming ioctl args are defined in sgtty.h." fi -: see if setegid exists +: see if killpg exists +set killpg d_killpg +eval $inlibc + +: see if memcmp exists +set memcmp d_memcmp +eval $inlibc + +: see if memcpy exists +set memcpy d_memcpy +eval $inlibc + +: see if mkdir exists +set mkdir d_mkdir +eval $inlibc + +: see if ndbm is available echo " " -if $contains '^setegid$' libc.list >/dev/null 2>&1; then - echo 'setegid() found.' - d_setegid="$define" +if $test -r /usr/include/ndbm.h || $test -r /usr/local/include/ndbm.h; then + d_ndbm="$define" + echo "ndbm.h found." else - echo 'setegid() not found.' - d_setegid="$undef" + d_ndbm="$undef" + echo "ndbm.h not found." fi -: see if seteuid exists +: see if we have the old dbm echo " " -if $contains '^seteuid$' libc.list >/dev/null 2>&1; then - echo 'seteuid() found.' - d_seteuid="$define" +if $test -r /usr/include/dbm.h ; then + d_odbm="$define" + echo "dbm.h found." else - echo 'seteuid() not found.' - d_seteuid="$undef" + d_odbm="$undef" + echo "dbm.h not found." fi -: see if setrgid exists +: see if this is an pwd system echo " " -if $contains '^setrgid$' libc.list >/dev/null 2>&1; then - echo 'setrgid() found.' - d_setrgid="$define" +if $test -r /usr/include/pwd.h ; then + i_pwd="$define" + echo "pwd.h found." + if $contains 'pw_quota' /usr/include/pwd.h >/dev/null 2>&1; then + d_pwquota="$define" + else + d_pwquota="$undef" + fi + if $contains 'pw_age' /usr/include/pwd.h >/dev/null 2>&1; then + d_pwage="$define" + else + d_pwage="$undef" + fi else - echo 'setrgid() not found.' - d_setrgid="$undef" + i_pwd="$undef" + d_pwquota="$undef" + d_pwage="$undef" + echo "No pwd.h found." fi +: see if readdir exists +set readdir d_readdir +eval $inlibc + +: see if rename exists +set rename d_rename +eval $inlibc + +: see if rmdir exists +set rmdir d_rmdir +eval $inlibc + +: see if setegid exists +set setegid d_setegid +eval $inlibc + +: see if seteuid exists +set seteuid d_seteuid +eval $inlibc + +: see if setpgrp exists +set setpgrp d_setpgrp +eval $inlibc + +: see if setpriority exists +set setpriority d_setprior +eval $inlibc + +: see if setregid exists +set setregid d_setregid +eval $inlibc +set setresgid d_setresgid +eval $inlibc + +: see if setreuid exists +set setreuid d_setreuid +eval $inlibc +set setresuid d_setresuid +eval $inlibc + +: see if setrgid exists +set setrgid d_setrgid +eval $inlibc + : see if setruid exists +set setruid d_setruid +eval $inlibc + +socketlib='' +sockethdr='' +: see whether socket exists echo " " -if $contains '^setruid$' libc.list >/dev/null 2>&1; then - echo 'setruid() found.' - d_setruid="$define" +if $contains socket libc.list >/dev/null 2>&1; then + echo "Looks like you have Berkeley networking support." + d_socket="$define" + : now check for advanced features + if $contains setsockopt libc.list >/dev/null 2>&1; then + d_oldsock="$undef" + else + echo "...but it uses the old 4.1c interface, rather than 4.2" + d_oldsock="$define" + fi +else + : hpux, for one, puts all the socket stuff in socklib.o + if $contains socklib libc.list >/dev/null 2>&1; then + echo "Looks like you have Berkeley networking support." + d_socket="$define" + : we will have to assume that it supports the 4.2 BSD interface + d_oldsock="$undef" + else + echo "Hmmm...you don't have Berkeley networking in libc.a..." + : look for an optional networking library + if test -f /usr/lib/libnet.a; then + (ar t /usr/lib/libnet.a || + nm -g /usr/lib/libnet.a) 2>/dev/null >> libc.list + if $contains socket libc.list >/dev/null 2>&1; then + echo "but the Wollongong group seems to have hacked it in." + socketlib="-lnet" + sockethdr="-I/usr/netinclude" + d_socket="$define" + : now check for advanced features + if $contains setsockopt libc.list >/dev/null 2>&1; then + d_oldsock="$undef" + else + echo "...using the old 4.1c interface, rather than 4.2" + d_oldsock="$define" + fi + else + echo "or even in libnet.a, which is peculiar." + d_socket="$undef" + d_oldsock="$undef" + fi + else + echo "or anywhere else I see." + d_socket="$undef" + d_oldsock="$undef" + fi + fi +fi +if $contains socketpair libc.list >/dev/null 2>&1; then + d_sockpair="$define" else - echo 'setruid() not found.' - d_setruid="$undef" + d_sockpair="$undef" fi : see if stat knows about block sizes @@ -932,16 +1710,6 @@ 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..." @@ -955,7 +1723,7 @@ main() foo = bar; } EOCP -if cc -c try.c >/dev/null 2>&1 ; then +if $cc -c try.c >/dev/null 2>&1 ; then d_strctcpy="$define" echo "Yup, it can." else @@ -965,35 +1733,43 @@ 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 +set symlink d_symlink +eval $inlibc + +: see if syscall exists +set syscall d_syscall +eval $inlibc : see if struct tm is defined in sys/time.h echo " " if $contains 'struct tm' /usr/include/time.h >/dev/null 2>&1 ; then echo "You have struct tm defined in rather than ." d_tminsys="$undef" + if test -f /usr/include/sys/time.h; then + i_systime="$define" + else + i_systime="$undef" + fi else echo "You have struct tm defined in rather than ." d_tminsys="$define" + i_systime="$define" fi -: see if there is a vfork +: see if this is a varargs system echo " " -if $contains '^vfork$' libc.list >/dev/null 2>&1 ; then - echo "vfork() found." - d_vfork="$undef" +if $test -r /usr/include/varargs.h ; then + d_varargs="$define" + echo "varargs.h found." else - echo "No vfork() found--will use fork() instead." - d_vfork="$define" + d_varargs="$undef" + echo "No varargs.h found, but that's ok (I hope)." fi +: see if there is a vfork +set vfork d_vfork +eval $inlibc + : see if signal is declared as pointer to function returning int or void echo " " if $contains 'void.*signal' /usr/include/signal.h >/dev/null 2>&1 ; then @@ -1023,37 +1799,37 @@ void main() { #else main() { #endif - extern void *moo(); - void *(*goo)(); + extern void moo(); /* function returning void */ + void (*goo)(); /* ptr to func returning void */ #if TRY & 2 void (*foo[10])(); #endif #if TRY & 4 - if(*goo == moo) { + if(goo == moo) { exit(0); } #endif exit(0); } EOCP - if cc -S -DTRY=7 try.c >.out 2>&1 ; then - voidflags=7 - echo "It appears to support void fully." + if $cc -S -DTRY=$defvoidused try.c >.out 2>&1 ; then + voidflags=$defvoidused + echo "It appears to support void." if $contains warning .out >/dev/null 2>&1; then echo "However, you might get some warnings that look like this:" $cat .out fi else - echo "Hmm, you compiler has some difficulty with void. Checking further..." - if cc -S -DTRY=1 try.c >/dev/null 2>&1 ; then + echo "Hmm, your compiler has some difficulty with void. Checking further..." + if $cc -S -DTRY=1 try.c >/dev/null 2>&1 ; then echo "It supports 1..." - if cc -S -DTRY=3 try.c >/dev/null 2>&1 ; then + if $cc -S -DTRY=3 try.c >/dev/null 2>&1 ; then voidflags=3 echo "And it supports 2 but not 4." else echo "It doesn't support 2..." - if cc -S -DTRY=3 try.c >/dev/null 2>&1 ; then + if $cc -S -DTRY=5 try.c >/dev/null 2>&1 ; then voidflags=5 echo "But it supports 4." else @@ -1097,444 +1873,261 @@ $echo $n "$rp $c" . myread gidtype="$ans" -: set up shell script to do ~ expansion -cat >filexp <&2 - exit 1 - fi - case "\$1" in - */*) - echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\` - ;; - *) - echo \$dir - ;; - esac - fi - ;; -*) - echo \$1 - ;; -esac -EOSS -chmod +x filexp -$eunicefix filexp - -: determine where private executables go -case "$privlib" in -'') - dflt=/usr/lib/perl - test -d /usr/local/lib && dflt=/usr/local/lib/perl - ;; -*) dflt="$privlib" - ;; -esac -$cat </dev/null 2>&1 ; then - echo "Your stdio uses unsigned chars." - stdchar="unsigned char" +if $test -r /usr/include/sys/dir.h ; then + i_sysdir="$define" + echo "sysdir.h found." else - echo "Your stdio uses signed chars." - stdchar="char" + i_sysdir="$undef" + echo "No sysdir.h found." 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 +: see if ioctl defs are in sgtty/termio or sys/ioctl echo " " -rp="What type are user ids on this system declared as? [$dflt]" -$echo $n "$rp $c" -. myread -uidtype="$ans" +if $test -r /usr/include/sys/ioctl.h ; then + i_sysioctl="$define" + echo "sys/ioctl.h found." +else + i_sysioctl="$undef" + echo "sys/ioctl.h not found, assuming ioctl args are defined in sgtty.h." +fi -: preserve RCS keywords in files with variable substitution, grrr -Log='$Log' -Header='$Header' +: see if this is a varargs system +echo " " +if $test -r /usr/include/varargs.h ; then + i_varargs="$define" + echo "varargs.h found." +else + i_varargs="$undef" + echo "No varargs.h found, but that's ok (I hope)." +fi -: determine where public executables go -case "$bin" in -'') - dflt=`loc . /bin /usr/local/bin /usr/lbin /usr/local /usr/bin` - ;; -*) dflt="$bin" - ;; -esac -cont=true -while $test "$cont" ; do - echo " " - rp="Where do you want to put the public executables? [$dflt]" - $echo $n "$rp $c" - . myread - bin="$ans" - bin=`filexp $bin` - if test -d $bin; then - cont='' - else - dflt=n - rp="Directory $bin doesn't exist. Use that name anyway? [$dflt]" - $echo $n "$rp $c" - . myread - dflt='' - case "$ans" in - y*) cont='';; - esac - fi -done +: see if this is a vfork system +echo " " +if $test -r /usr/include/vfork.h ; then + i_vfork="$define" + echo "vfork.h found." +else + i_vfork="$undef" + echo "No vfork.h found." +fi -: determine where manual pages go -case "$mansrc" in +: check for length of integer +echo " " +case "$intsize" in '') - dflt=`loc . /usr/man/man1 /usr/man/mann /usr/man/local/man1 /usr/man/u_man/man1 /usr/man/man1` - ;; -*) dflt="$mansrc" - ;; -esac -cont=true -while $test "$cont" ; do - echo " " - rp="Where do the manual pages (source) go? [$dflt]" - $echo $n "$rp $c" - . myread - mansrc=`filexp "$ans"` - if test -d $mansrc; then - cont='' + echo "Checking to see how big your integers are..." + $cat >try.c <<'EOCP' +#include +main() +{ + printf("%d\n", sizeof(int)); +} +EOCP + if $cc try.c -o try >/dev/null 2>&1 ; then + dflt=`try` else - dflt=n - rp="Directory $mansrc doesn't exist. Use that name anyway? [$dflt]" - $echo $n "$rp $c" - . myread - dflt='' - case "$ans" in - y*) cont='';; - esac - fi -done -case "$mansrc" in -*l) - manext=l - ;; -*n) - manext=n - ;; -*C) - manext=C - ;; -*) - manext=1 - ;; -esac - -: get C preprocessor symbols handy -echo " " -echo $attrlist | $tr '[ - ]' '[\012-\012]' >Cppsym.know -$cat <Cppsym -$startsh -case "\$1" in --l) list=true - shift - ;; -esac -unknown='' -case "\$list\$#" in -1|2) - for sym do - if $contains "^\$1$" Cppsym.true >/dev/null 2>&1; then - exit 0 - elif $contains "^\$1$" Cppsym.know >/dev/null 2>&1; then - : - else - unknown="\$unknown \$sym" - fi - done - set X \$unknown - shift + dflt='4' + echo "(I can't seem to compile the test program. Guessing...)" + fi ;; -esac -case \$# in -0) exit 1;; -esac -echo \$* | $tr '[ - ]' '[\012-\012]' | $sed -e 's/\(.*\)/\\ -#ifdef \1\\ -exit 0; _ _ _ _\1\\ \1\\ -#endif\\ -/' >/tmp/Cppsym\$\$ -echo exit 1 >>/tmp/Cppsym\$\$ -$cppstdin $cppminus /tmp/Cppsym2\$\$ -case "\$list" in -true) awk 'NF > 5 {print substr(\$6,2,100)}' Cppsym.true -cat Cppsym.true -rmlist="$rmlist Cppsym Cppsym.know Cppsym.true" +rp="What is the size of an integer (in bytes)? [$dflt]" +$echo $n "$rp $c" +. myread +intsize="$ans" +$rm -f try.c try -: see what memory models we can support -case "$models" in +: determine where private executables go +case "$privlib" in '') - if Cppsym pdp11; then - dflt='unsplit split' - else - ans=`loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge` - case "$ans" in - X) dflt='none';; - *) if $test -d /lib/small || $test -d /usr/lib/small; then - dflt='small' - else - dflt='' - fi - if $test -d /lib/medium || $test -d /usr/lib/medium; then - dflt="$dflt medium" - fi - if $test -d /lib/large || $test -d /usr/lib/large; then - dflt="$dflt large" - fi - if $test -d /lib/huge || $test -d /usr/lib/huge; then - dflt="$dflt huge" - fi - esac - fi + dflt=/usr/lib/$package + test -d /usr/local/lib && dflt=/usr/local/lib/$package + ;; +*) dflt="$privlib" ;; -*) dflt="$models" ;; esac $cat <try.c <<'EOCP' +#include +main() +{ + register int i; + register unsigned long tmp; + register unsigned long max = 0L; + + for (i=1000; i; i--) { + tmp = (unsigned long)rand(); + if (tmp > max) max = tmp; + } + for (i=0; max; i++) + max /= 2; + printf("%d\n",i); +} +EOCP + if $cc try.c -o try >/dev/null 2>&1 ; then + dflt=`try` + else + dflt='?' + echo "(I can't seem to compile the test program...)" + fi ;; -*split) - case "$split" in - '') - if $contains '\-i' $mansrc/ld.1 >/dev/null 2>&1 || \ - $contains '\-i' $mansrc/cc.1 >/dev/null 2>&1; then - dflt='-i' - else - dflt='none' - fi - ;; - *) dflt="$split";; - esac - rp="What flag indicates separate I and D space? [$dflt]" - $echo $n "$rp $c" - . myread - case "$ans" in - none) ans='';; - esac - split="$ans" - unsplit='' +*) + dflt="$randbits" ;; -*large*|*small*|*medium*|*huge*) - case "$model" in - *large*) - case "$large" in - '') dflt='-Ml';; - *) dflt="$large";; - esac - rp="What flag indicates large model? [$dflt]" - $echo $n "$rp $c" - . myread - case "$ans" in - none) ans=''; - esac - large="$ans" - ;; - *) large='';; - esac - case "$model" in - *huge*) - case "$huge" in - '') dflt='-Mh';; - *) dflt="$huge";; - esac - rp="What flag indicates huge model? [$dflt]" - $echo $n "$rp $c" - . myread - case "$ans" in - none) ans=''; - esac - huge="$ans" - ;; - *) huge="$large";; - esac - case "$model" in - *medium*) - case "$medium" in - '') dflt='-Mm';; - *) dflt="$medium";; - esac - rp="What flag indicates medium model? [$dflt]" - $echo $n "$rp $c" - . myread - case "$ans" in - none) ans=''; - esac - medium="$ans" - ;; - *) medium="$large";; - esac - case "$model" in - *small*) - case "$small" in - '') dflt='none';; - *) dflt="$small";; - esac - rp="What flag indicates small model? [$dflt]" - $echo $n "$rp $c" - . myread - case "$ans" in - none) ans=''; +esac +rp="How many bits does your rand() function produce? [$dflt]" +$echo $n "$rp $c" +. myread +randbits="$ans" +$rm -f try.c try + +: generate list of signal names +echo " " +case "$sig_name" in +'') + echo "Generating a list of signal names..." + set X `kill -l 2>/dev/null` + shift + case $# in + 0) echo 'kill -l' >/tmp/foo$$ + set X `/bin/csh -f /dev/null 2>&1 ; then + echo "Your stdio uses unsigned chars." + stdchar="unsigned char" +else + echo "Your stdio uses signed chars." + stdchar="char" +fi -case "$ldflags" in -'') if venix; then - dflt='-i -z' +: 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 - dflt='none' + 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="$ldflags";; +*) dflt="$uidtype" + ;; esac +cont=true echo " " -rp="Any additional ld flags? [$dflt]" +rp="What type are user ids on this system declared as? [$dflt]" $echo $n "$rp $c" . myread -case "$ans" in -none) ans=''; -esac -ldflags="$ans" +uidtype="$ans" -: see if we need a special compiler +: preserve RCS keywords in files with variable substitution, grrr +Log='$Log' +Header='$Header' + + +: see if we should include -ldbm echo " " -if usg; then - case "$cc" in - '') - case "$Mcc" in - /*) dflt='Mcc' - ;; - *) - case "$large" in - -M*) - dflt='cc' - ;; - *) - if $contains '\-M' $mansrc/cc.1 >/dev/null 2>&1 ; then - dflt='cc -M' - else - dflt='cc' - fi - ;; - esac - ;; - esac +if $test -r /usr/lib/libdbm.a || $test -r /usr/local/lib/libdbm.a ; then + echo "-ldbm found." + libdbm='-ldbm' +else + ans=`loc libdbm.a x $libpth` + case "$ans" in + x) + echo "No dbm library found." + libdbm='' + ;; + *) + echo "DBM library found in $ans." + libdbm="$ans" ;; - *) dflt="$cc";; esac - $cat <<'EOM' - -On some systems the default C compiler will not resolve multiple global -references that happen to have the same name. On some such systems the -"Mcc" command may be used to force these to be resolved. On other systems -a "cc -M" command is required. (Note that the -M flag on other systems -indicates a memory model to use!) What command will force resolution on -EOM - $echo $n "this system? [$dflt] $c" - rp="Command to resolve multiple refs? [$dflt]" - . myread - cc="$ans" +fi + +: see if we should include -lndir +echo " " +if $test -r /usr/lib/libndir.a || $test -r /usr/local/lib/libndir.a ; then + echo "New directory library found." + libndir='-lndir' else - echo "Not a USG system--assuming cc can resolve multiple definitions." - cc=cc + ans=`loc libndir.a x $libpth` + case "$ans" in + x) + echo "No ndir library found." + libndir='' + ;; + *) + echo "New directory library found in $ans." + libndir="$ans" + ;; + esac fi +case "$libndir" in +'') ;; +*) + case "$d_readdir" in + $define) + echo "Since you have readdir in the C library, I'll ignore $libndir" + libndir='' + ;; + esac + ;; +esac : see if we should include -lnm echo " " @@ -1623,38 +2216,108 @@ vi='$vi' mailx='$mailx' mail='$mail' cpp='$cpp' +perl='$perl' +emacs='$emacs' +ls='$ls' +rmail='$rmail' +sendmail='$sendmail' +shar='$shar' +smail='$smail' +tbl='$tbl' +troff='$troff' +nroff='$nroff' +uname='$uname' +uuname='$uuname' +line='$line' +chgrp='$chgrp' +chmod='$chmod' +lint='$lint' +sleep='$sleep' +pr='$pr' +tar='$tar' +ln='$ln' +lpr='$lpr' +lp='$lp' +touch='$touch' +make='$make' +date='$date' Log='$Log' Header='$Header' bin='$bin' -cc='$cc' +byteorder='$byteorder' contains='$contains' cppstdin='$cppstdin' cppminus='$cppminus' +d_bcmp='$d_bcmp' d_bcopy='$d_bcopy' d_charsprf='$d_charsprf' d_crypt='$d_crypt' +cryptlib='$cryptlib' d_dosuid='$d_dosuid' +d_dup2='$d_dup2' d_fchmod='$d_fchmod' d_fchown='$d_fchown' +d_fcntl='$d_fcntl' +d_flock='$d_flock' d_getgrps='$d_getgrps' +d_gethent='$d_gethent' +d_getpgrp='$d_getpgrp' +d_getprior='$d_getprior' +d_htonl='$d_htonl' d_index='$d_index' +d_ioctl='$d_ioctl' d_killpg='$d_killpg' +d_memcmp='$d_memcmp' d_memcpy='$d_memcpy' +d_mkdir='$d_mkdir' +d_ndbm='$d_ndbm' +d_odbm='$d_odbm' +d_readdir='$d_readdir' d_rename='$d_rename' +d_rmdir='$d_rmdir' d_setegid='$d_setegid' d_seteuid='$d_seteuid' +d_setpgrp='$d_setpgrp' +d_setprior='$d_setprior' +d_setregid='$d_setregid' +d_setresgid='$d_setresgid' +d_setreuid='$d_setreuid' +d_setresuid='$d_setresuid' d_setrgid='$d_setrgid' d_setruid='$d_setruid' +d_socket='$d_socket' +d_sockpair='$d_sockpair' +d_oldsock='$d_oldsock' +socketlib='$socketlib' +sockethdr='$sockethdr' d_statblks='$d_statblks' d_stdstdio='$d_stdstdio' -d_strcspn='$d_strcspn' d_strctcpy='$d_strctcpy' d_symlink='$d_symlink' +d_syscall='$d_syscall' d_tminsys='$d_tminsys' +i_systime='$i_systime' +d_varargs='$d_varargs' d_vfork='$d_vfork' d_voidsig='$d_voidsig' +d_vprintf='$d_vprintf' +d_charvspr='$d_charvspr' gidtype='$gidtype' +i_dirent='$i_dirent' +d_dirnamlen='$d_dirnamlen' +i_fcntl='$i_fcntl' +i_grp='$i_grp' +i_pwd='$i_pwd' +d_pwquota='$d_pwquota' +d_pwage='$d_pwage' +i_sysdir='$i_sysdir' +i_sysioctl='$i_sysioctl' +i_varargs='$i_varargs' +i_vfork='$i_vfork' +intsize='$intsize' libc='$libc' +libdbm='$libdbm' +libndir='$libndir' libnm='$libnm' mallocsrc='$mallocsrc' mallocobj='$mallocobj' @@ -1667,11 +2330,16 @@ small='$small' medium='$medium' large='$large' huge='$huge' +optimize='$optimize' ccflags='$ccflags' ldflags='$ldflags' +cc='$cc' +libs='$libs' n='$n' c='$c' package='$package' +randbits='$randbits' +sig_name='$sig_name' spitshell='$spitshell' shsharp='$shsharp' sharpbang='$sharpbang' @@ -1680,6 +2348,7 @@ stdchar='$stdchar' uidtype='$uidtype' voidflags='$voidflags' defvoidused='$defvoidused' +lib='$lib' privlib='$privlib' CONFIG=true EOT @@ -1742,8 +2411,7 @@ EOM $echo $n "$rp $c" . UU/myread case "$ans" in - y*) make depend - echo "Now you must run a make." + y*) make depend && echo "Now you must run a make." ;; *) echo "You must run 'make depend' then 'make'." ;; diff --git a/Copying b/Copying new file mode 100644 index 0000000..3c68f02 --- /dev/null +++ b/Copying @@ -0,0 +1,248 @@ + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/EXTERN.h b/EXTERN.h index 793da6d..19651c0 100644 --- a/EXTERN.h +++ b/EXTERN.h @@ -1,8 +1,13 @@ -/* $Header: EXTERN.h,v 2.0 88/06/05 00:07:46 root Exp $ +/* $Header: EXTERN.h,v 3.0 89/10/18 15:06:03 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: EXTERN.h,v $ - * Revision 2.0 88/06/05 00:07:46 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:06:03 lwall + * 3.0 baseline * */ diff --git a/INTERN.h b/INTERN.h index a070e53..d18b30c 100644 --- a/INTERN.h +++ b/INTERN.h @@ -1,8 +1,13 @@ -/* $Header: INTERN.h,v 2.0 88/06/05 00:07:49 root Exp $ +/* $Header: INTERN.h,v 3.0 89/10/18 15:06:25 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: INTERN.h,v $ - * Revision 2.0 88/06/05 00:07:49 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:06:25 lwall + * 3.0 baseline * */ diff --git a/MANIFEST b/MANIFEST index 39abd2a..edd1931 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,155 +1,193 @@ -After all the perl kits are run you should have the following files: - -Filename Kit Description --------- --- ----------- -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 +Changes Differences between 2.0 level 18 and 3.0 level 0 +Configure Run this first +Copying The GNU General Public License +EXTERN.h Included before foreign .h files +INTERN.h Included before domestic .h files +MANIFEST This list of files +Makefile.SH Precursor to Makefile +PACKINGLIST Which files came from which kits +README The Instructions +Wishlist Some things that may or may not happen +arg.h Public declarations for the above +array.c Numerically subscripted arrays +array.h Public declarations for the above +client A client to test sockets +cmd.c Command interpreter +cmd.h Public declarations for the above +config.H Sample config.h +config.h.SH Produces config.h +cons.c Routines to construct cmd nodes of a parse tree +consarg.c Routines to construct arg nodes of a parse tree +doarg.c Scalar expression evaluation +doio.c I/O operations +dolist.c Array expression evaluation +dump.c Debugging output +eg/ADB An adb wrapper to put in your crash dir +eg/README Intro to example perl scripts +eg/changes A program to list recently changed files +eg/down A program to do things to subdirectories +eg/dus A program to do du -s on non-mounted dirs +eg/findcp A find wrapper that implements a -cp switch +eg/findtar A find wrapper that pumps out a tar file +eg/g/gcp A program to do a global rcp +eg/g/gcp.man Manual page for gcp +eg/g/ged A program to do a global edit +eg/g/ghosts A sample /etc/ghosts file +eg/g/gsh A program to do a global rsh +eg/g/gsh.man Manual page for gsh +eg/muck A program to find missing make dependencies +eg/muck.man Manual page for muck +eg/myrup A program to find lightly loaded machines +eg/nih Script to insert #! workaround +eg/rename A program to rename files +eg/rmfrom A program to feed doomed filenames to +eg/scan/scan_df Scan for filesystem anomalies +eg/scan/scan_last Scan for login anomalies +eg/scan/scan_messages Scan for console message anomalies +eg/scan/scan_passwd Scan for passwd file anomalies +eg/scan/scan_ps Scan for process anomalies +eg/scan/scan_sudo Scan for sudo anomalies +eg/scan/scan_suid Scan for setuid anomalies +eg/scan/scanner An anomaly reporter +eg/shmkill A program to remove unused shared memory +eg/van/empty A program to empty the trashcan +eg/van/unvanish A program to undo what vanish does +eg/van/vanexp A program to expire vanished files +eg/van/vanish A program to put files in a trashcan +eg/who A sample who program +eval.c The expression evaluator +evalargs.xc The arg evaluator of eval.c +form.c Format processing +form.h Public declarations for the above +gettest A little script to test the get* routines +handy.h Handy definitions +hash.c Associative arrays +hash.h Public declarations for the above +ioctl.pl Sample ioctl.pl +lib/abbrev.pl An abbreviation table builder +lib/look.pl A "look" equivalent +lib/complete.pl A command completion subroutine +lib/dumpvar.pl A variable dumper +lib/getopt.pl Perl library supporting option parsing +lib/getopts.pl Perl library supporting option parsing +lib/importenv.pl Perl routine to get environment into variables +lib/perldb.pl Perl debugging routines +lib/stat.pl Perl library supporting stat function +lib/termcap.pl Perl library supporting termcap usage +lib/validate.pl Perl library supporting wholesale file mode validation +makedepend.SH Precursor to makedepend +makedir.SH Precursor to makedir +makelib.SH A thing to turn C .h file into perl .h files +malloc.c A version of malloc you might not want +patchlevel.h The current patch level of perl +perl.h Global declarations +perl.man.1 The manual page(s), first fourth +perl.man.2 The manual page(s), second fourth +perl.man.3 The manual page(s), third fourth +perl.man.4 The manual page(s), fourth fourth +perl.y Yacc grammar for perl +perlsh A poor man's perl shell +perly.c main() +regcomp.c Regular expression compiler +regcomp.h Private declarations for above +regexp.h Public declarations for the above +regexec.c Regular expression evaluator +server A server to test sockets +spat.h Search pattern declarations +stab.c Symbol table stuff +stab.h Public declarations for the above +str.c String handling package +str.h Public declarations for the above +t/README Instructions for regression tests +t/TEST The regression tester +t/base.cond See if conditionals work +t/base.if See if if works +t/base.lex See if lexical items work +t/base.pat See if pattern matching works +t/base.term See if various terms work +t/cmd.elsif See if else-if works +t/cmd.for See if for loops work +t/cmd.mod See if statement modifiers work +t/cmd.subval See if subroutine values work +t/cmd.switch See if switch optimizations work +t/cmd.while See if while loops work +t/comp.cmdopt See if command optimization works +t/comp.cpp See if C preprocessor works +t/comp.decl See if declarations work +t/comp.multiline See if multiline strings work +t/comp.package See if packages work +t/comp.script See if script invokation works +t/comp.term See if more terms work +t/io.argv See if ARGV stuff works +t/io.dup See if >& works right +t/io.fs See if directory manipulations work +t/io.inplace See if inplace editing works +t/io.pipe See if secure pipes work +t/io.print See if print commands work +t/io.tell See if file seeking works +t/op.append See if . works +t/op.array See if array operations work +t/op.auto See if autoincrement et all work +t/op.chop See if chop works +t/op.cond See if conditional expressions work +t/op.dbm See if dbm binding works +t/op.delete See if delete works +t/op.do See if subroutines work +t/op.each See if associative iterators work +t/op.eval See if eval operator works +t/op.exec See if exec and system work +t/op.exp See if math functions work +t/op.flip See if range operator works +t/op.fork See if fork works +t/op.glob See if <*> works +t/op.goto See if goto works +t/op.index See if index works +t/op.int See if int works +t/op.join See if join works +t/op.list See if array lists work +t/op.local See if local works +t/op.magic See if magic variables work +t/op.mkdir See if mkdir works +t/op.oct See if oct and hex work +t/op.ord See if ord works +t/op.pack See if pack and unpack work +t/op.pat See if esoteric patterns work +t/op.push See if push and pop work +t/op.range See if .. works +t/op.read See if read() works +t/op.regexp See if regular expressions work +t/op.repeat See if x operator works +t/op.sleep See if sleep works +t/op.sort See if sort works +t/op.split See if split works +t/op.sprintf See if sprintf works +t/op.stat See if stat works +t/op.study See if study works +t/op.subst See if substitutions work +t/op.substr See if substr works +t/op.time See if time functions work +t/op.undef See if undef works +t/op.unshift See if unshift works +t/op.vec See if vectors work +t/op.write See if write works +t/re_tests Input file for op.regexp +toke.c The tokener +util.c Utility routines +util.h Public declarations for the above +x2p/EXTERN.h Same as above +x2p/INTERN.h Same as above +x2p/Makefile.SH Precursor to Makefile +x2p/a2p.h Global declarations +x2p/a2p.man Manual page for awk to perl translator +x2p/a2p.y A yacc grammer for awk +x2p/a2py.c Awk compiler, sort of +x2p/handy.h Handy definitions +x2p/hash.c Associative arrays again +x2p/hash.h Public declarations for the above +x2p/s2p.SH Sed to perl translator +x2p/s2p.man Manual page for sed to perl translator +x2p/str.c String handling package +x2p/str.h Public declarations for the above +x2p/util.c Utility routines +x2p/util.h Public declarations for the above +x2p/walk.c Parse tree walker diff --git a/Makefile.SH b/Makefile.SH index 931a3af..6e66a4c 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -25,24 +25,19 @@ esac echo "Extracting Makefile (with variable substitutions)" cat >Makefile <>Makefile <<'!NO!SUBS!' private = -manpages = perl.man perldb.man +MAKE = make + +manpages = perl.man util = sh = Makefile.SH makedepend.SH h1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h form.h handy.h -h2 = hash.h perl.h regexp.h spat.h stab.h str.h util.h +h2 = hash.h perl.h regcomp.h regexp.h spat.h stab.h str.h util.h h = $(h1) $(h2) -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 +c1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c +c2 = eval.c form.c hash.c $(mallocsrc) perly.c regcomp.c regexec.c +c3 = stab.c str.c toke.c util.c + +c = $(c1) $(c2) $(c3) + +obj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o +obj2 = eval.o form.o hash.o $(mallocobj) perly.o regcomp.o regexec.o +obj3 = stab.o str.o toke.o util.o -c = $(c1) $(c2) +obj = $(obj1) $(obj2) $(obj3) -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 +tobj1 = tarray.o tcmd.o tcons.o tconsarg.o tdoarg.o tdoio.o tdolist.o tdump.o +tobj2 = teval.o tform.o thash.o $(mallocobj) tregcomp.o tregexec.o +tobj3 = tstab.o tstr.o ttoke.o tutil.o -obj = $(obj1) $(obj2) +tobj = $(tobj1) $(tobj2) $(tobj3) -lintflags = -phbvxac +lintflags = -hbvxac addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 @@ -90,57 +95,183 @@ SHELL = /bin/sh .c.o: $(CC) -c $(CFLAGS) $(LARGE) $*.c -all: $(public) $(private) $(util) +all: $(public) $(private) $(util) perl.man x2p/all touch all -perl: perly.o $(obj) perl.o - $(CC) $(LDFLAGS) $(LARGE) perly.o $(obj) perl.o $(libs) -o perl +x2p/all: + cd x2p; $(MAKE) all -!NO!SUBS! +# This is the standard version that contains no "taint" checks and is +# used for all scripts that aren't set-id or running under something set-id. -case "$d_dosuid" in -*define*) - cat >>Makefile <<'!NO!SUBS!' +perl: perl.o $(obj) + $(CC) $(LARGE) $(LDFLAGS) $(obj) perl.o $(libs) -o perl + +# This version, if specified in Configure, does ONLY those scripts which need +# set-id emulation. Suidperl must be setuid root. It contains the "taint" +# checks as well as the special code to validate that the script in question +# has been invoked correctly. -suidperl: sperly.o $(obj) perl.o - $(CC) $(LDFLAGS) $(LARGE) sperly.o $(obj) perl.o $(libs) -o suidperl +suidperl: tperl.o sperly.o $(tobj) + $(CC) $(LARGE) $(LDFLAGS) sperly.o $(tobj) tperl.o $(libs) -o suidperl -sperly.o: perly.c +# This version interprets scripts that are already set-id either via a wrapper +# or through the kernel allowing set-id scripts (bad idea). Taintperl must +# NOT be setuid to root or anything else. The only difference between it +# and normal perl is the presence of the "taint" checks. + +taintperl: tperl.o tperly.o $(tobj) + $(CC) $(LARGE) $(LDFLAGS) tperly.o $(tobj) tperl.o $(libs) -o taintperl + +# Replicating all this junk is yucky, but I don't see a portable way to fix it. + +tperl.o: perl.c perly.h perl.h EXTERN.h regexp.h util.h INTERN.h handy.h \ + config.h stab.h + /bin/rm -f tperl.c + $(SLN) perl.c tperl.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tperl.c + /bin/rm -f tperl.c + +tperly.o: perly.c + /bin/rm -f tperly.c + $(SLN) perly.c tperly.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tperly.c + /bin/rm -f tperly.c + +sperly.o: perly.c perl.h handy.h perly.h patchlevel.h /bin/rm -f sperly.c - ln perly.c sperly.c - $(CC) -c -DIAMSUID $(CFLAGS) $(LARGE) sperly.c + $(SLN) perly.c sperly.c + $(CC) -c -DTAINT -DIAMSUID $(CFLAGS) $(LARGE) sperly.c /bin/rm -f sperly.c -!NO!SUBS! - ;; -esac -cat >>Makefile <<'!NO!SUBS!' +tarray.o: array.c + /bin/rm -f tarray.c + $(SLN) array.c tarray.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tarray.c + /bin/rm -f tarray.c + +tcmd.o: cmd.c + /bin/rm -f tcmd.c + $(SLN) cmd.c tcmd.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tcmd.c + /bin/rm -f tcmd.c + +tcons.o: cons.c + /bin/rm -f tcons.c + $(SLN) cons.c tcons.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tcons.c + /bin/rm -f tcons.c + +tconsarg.o: consarg.c + /bin/rm -f tconsarg.c + $(SLN) consarg.c tconsarg.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tconsarg.c + /bin/rm -f tconsarg.c + +tdoarg.o: doarg.c + /bin/rm -f tdoarg.c + $(SLN) doarg.c tdoarg.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tdoarg.c + /bin/rm -f tdoarg.c + +tdoio.o: doio.c + /bin/rm -f tdoio.c + $(SLN) doio.c tdoio.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tdoio.c + /bin/rm -f tdoio.c + +tdolist.o: dolist.c + /bin/rm -f tdolist.c + $(SLN) dolist.c tdolist.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tdolist.c + /bin/rm -f tdolist.c + +tdump.o: dump.c + /bin/rm -f tdump.c + $(SLN) dump.c tdump.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tdump.c + /bin/rm -f tdump.c + +teval.o: eval.c + /bin/rm -f teval.c + $(SLN) eval.c teval.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) teval.c + /bin/rm -f teval.c + +tform.o: form.c + /bin/rm -f tform.c + $(SLN) form.c tform.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tform.c + /bin/rm -f tform.c + +thash.o: hash.c + /bin/rm -f thash.c + $(SLN) hash.c thash.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) thash.c + /bin/rm -f thash.c + +tregcomp.o: regcomp.c + /bin/rm -f tregcomp.c + $(SLN) regcomp.c tregcomp.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tregcomp.c + /bin/rm -f tregcomp.c + +tregexec.o: regexec.c + /bin/rm -f tregexec.c + $(SLN) regexec.c tregexec.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tregexec.c + /bin/rm -f tregexec.c + +tstab.o: stab.c + /bin/rm -f tstab.c + $(SLN) stab.c tstab.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tstab.c + /bin/rm -f tstab.c + +tstr.o: str.c + /bin/rm -f tstr.c + $(SLN) str.c tstr.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tstr.c + /bin/rm -f tstr.c + +ttoke.o: toke.c + /bin/rm -f ttoke.c + $(SLN) toke.c ttoke.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) ttoke.c + /bin/rm -f ttoke.c + +tutil.o: util.c + /bin/rm -f tutil.c + $(SLN) util.c tutil.c + $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tutil.c + /bin/rm -f tutil.c perl.c perly.h: perl.y - @ echo Expect 37 shift/reduce errors... + @ echo Expect 25 shift/reduce errors... yacc -d perl.y mv y.tab.c perl.c mv y.tab.h perly.h -perl.o: perl.c perly.h perl.h EXTERN.h regexp.h util.h INTERN.h handy.h config.h +perl.o: perl.c perly.h perl.h EXTERN.h regexp.h util.h INTERN.h handy.h \ + config.h arg.h stab.h $(CC) -c $(CFLAGS) $(LARGE) perl.c -# if a .h file depends on another .h file... -$(h): - touch $@ - -perl.man: perl.man.1 perl.man.2 - cat perl.man.1 perl.man.2 >perl.man +perl.man: perl.man.1 perl.man.2 perl.man.3 perl.man.4 patchlevel.h perl + ./perl -e '($$r,$$p)=$$]=~/(\d+\.\d+).*\n\D*(\d+)/;' \ + -e 'print ".ds RP Release $$r Patchlevel $$p\n";' >perl.man + cat perl.man.[1-4] >>perl.man -install: perl perl.man +install: all # won't work with csh export PATH || exit 1 + - rm -f $(bin)/perl.old $(bin)/suidperl $(bin)/taintperl - mv $(bin)/perl $(bin)/perl.old 2>/dev/null - if test `pwd` != $(bin); then cp $(public) $(bin); fi - cd $(bin); \ for pub in $(public); do \ chmod +x `basename $$pub`; \ done + - chmod 755 $(bin)/taintperl 2>/dev/null !NO!SUBS! case "$d_dosuid" in @@ -154,13 +285,12 @@ 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) + - sh ./makedir $(privlib) - \ -if test `pwd` != $(lib); then \ -cp $(private) lib/*.pl $(lib); \ +if test `pwd` != $(privlib); then \ +cp $(private) lib/*.pl $(privlib); \ fi -# cd $(lib); \ +# cd $(privlib); \ #for priv in $(private); do \ #chmod +x `basename $$priv`; \ #done @@ -169,12 +299,17 @@ for page in $(manpages); do \ cp $$page $(mansrc)/`basename $$page .man`.$(manext); \ done; \ fi + cd x2p; $(MAKE) install clean: - rm -f *.o + rm -f *.o all perl taintperl perl.man + cd x2p; $(MAKE) clean realclean: - rm -f perl *.orig */*.orig *~ */*~ *.o core $(addedbyconf) + cd x2p; $(MAKE) realclean + rm -f perl *.orig */*.orig *~ */*~ *.o core $(addedbyconf) perl.man + rm -f perl.c perly.h t/perl Makefile config.h makedepend makedir + rm -f x2p/Makefile # The following lint has practically everything turned on. Unfortunately, # you have to wade through a lot of mumbo jumbo that can't be suppressed. @@ -188,9 +323,10 @@ depend: makedepend - test -f perly.h || cp /dev/null perly.h ./makedepend - test -s perly.h || /bin/rm -f perly.h + cd x2p; $(MAKE) depend test: perl - chmod +x 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: diff --git a/PACKINGLIST b/PACKINGLIST new file mode 100644 index 0000000..1232dec --- /dev/null +++ b/PACKINGLIST @@ -0,0 +1,197 @@ +After all the perl kits are run you should have the following files: + +Filename Kit Description +-------- --- ----------- +Changes 20 Differences between 2.0 level 18 and 3.0 level 0 +Configure 2 Run this first +Copying 10 The GNU General Public License +EXTERN.h 24 Included before foreign .h files +INTERN.h 24 Included before domestic .h files +MANIFEST 20 This list of files +Makefile.SH 19 Precursor to Makefile +PACKINGLIST 18 Which files came from which kits +README 1 The Instructions +Wishlist 24 Some things that may or may not happen +arg.h 11 Public declarations for the above +array.c 21 Numerically subscripted arrays +array.h 24 Public declarations for the above +client 24 A client to test sockets +cmd.c 15 Command interpreter +cmd.h 21 Public declarations for the above +config.H 15 Sample config.h +config.h.SH 14 Produces config.h +cons.c 10 Routines to construct cmd nodes of a parse tree +consarg.c 14 Routines to construct arg nodes of a parse tree +doarg.c 11 Scalar expression evaluation +doio.c 7 I/O operations +dolist.c 16 Array expression evaluation +dump.c 20 Debugging output +eg/ADB 24 An adb wrapper to put in your crash dir +eg/README 1 Intro to example perl scripts +eg/changes 23 A program to list recently changed files +eg/down 24 A program to do things to subdirectories +eg/dus 24 A program to do du -s on non-mounted dirs +eg/findcp 17 A find wrapper that implements a -cp switch +eg/findtar 24 A find wrapper that pumps out a tar file +eg/g/gcp 22 A program to do a global rcp +eg/g/gcp.man 23 Manual page for gcp +eg/g/ged 24 A program to do a global edit +eg/g/ghosts 22 A sample /etc/ghosts file +eg/g/gsh 22 A program to do a global rsh +eg/g/gsh.man 21 Manual page for gsh +eg/muck 22 A program to find missing make dependencies +eg/muck.man 24 Manual page for muck +eg/myrup 23 A program to find lightly loaded machines +eg/nih 24 Script to insert #! workaround +eg/rename 24 A program to rename files +eg/rmfrom 24 A program to feed doomed filenames to +eg/scan/scan_df 23 Scan for filesystem anomalies +eg/scan/scan_last 23 Scan for login anomalies +eg/scan/scan_messages 21 Scan for console message anomalies +eg/scan/scan_passwd 6 Scan for passwd file anomalies +eg/scan/scan_ps 24 Scan for process anomalies +eg/scan/scan_sudo 23 Scan for sudo anomalies +eg/scan/scan_suid 22 Scan for setuid anomalies +eg/scan/scanner 23 An anomaly reporter +eg/shmkill 23 A program to remove unused shared memory +eg/van/empty 24 A program to empty the trashcan +eg/van/unvanish 23 A program to undo what vanish does +eg/van/vanexp 24 A program to expire vanished files +eg/van/vanish 23 A program to put files in a trashcan +eg/who 24 A sample who program +eval.c 3 The expression evaluator +evalargs.xc 19 The arg evaluator of eval.c +form.c 20 Format processing +form.h 24 Public declarations for the above +gettest 24 A little script to test the get* routines +handy.h 22 Handy definitions +hash.c 18 Associative arrays +hash.h 23 Public declarations for the above +ioctl.pl 21 Sample ioctl.pl +lib/abbrev.pl 24 An abbreviation table builder +lib/complete.pl 23 A command completion subroutine +lib/dumpvar.pl 24 A variable dumper +lib/getopt.pl 23 Perl library supporting option parsing +lib/getopts.pl 24 Perl library supporting option parsing +lib/importenv.pl 24 Perl routine to get environment into variables +lib/look.pl 23 A "look" equivalent +lib/perldb.pl 18 Perl debugging routines +lib/stat.pl 24 Perl library supporting stat function +lib/termcap.pl 22 Perl library supporting termcap usage +lib/validate.pl 21 Perl library supporting wholesale file mode validation +makedepend.SH 21 Precursor to makedepend +makedir.SH 23 Precursor to makedir +makelib.SH 21 A thing to turn C .h file into perl .h files +malloc.c 19 A version of malloc you might not want +patchlevel.h 10 The current patch level of perl +perl.h 8 Global declarations +perl.man.1 1 The manual page(s), first fourth +perl.man.2 9 The manual page(s), second fourth +perl.man.3 8 The manual page(s), third fourth +perl.man.4 6 The manual page(s), fourth fourth +perl.y 12 Yacc grammar for perl +perlsh 24 A poor man's perl shell +perly.c 17 main() +regcomp.c 12 Regular expression compiler +regcomp.h 7 Private declarations for above +regexec.c 13 Regular expression evaluator +regexp.h 23 Public declarations for the above +server 24 A server to test sockets +spat.h 23 Search pattern declarations +stab.c 9 Symbol table stuff +stab.h 20 Public declarations for the above +str.c 13 String handling package +str.h 14 Public declarations for the above +t/README 1 Instructions for regression tests +t/TEST 23 The regression tester +t/base.cond 24 See if conditionals work +t/base.if 24 See if if works +t/base.lex 23 See if lexical items work +t/base.pat 24 See if pattern matching works +t/base.term 24 See if various terms work +t/cmd.elsif 24 See if else-if works +t/cmd.for 23 See if for loops work +t/cmd.mod 24 See if statement modifiers work +t/cmd.subval 22 See if subroutine values work +t/cmd.switch 12 See if switch optimizations work +t/cmd.while 22 See if while loops work +t/comp.cmdopt 22 See if command optimization works +t/comp.cpp 24 See if C preprocessor works +t/comp.decl 24 See if declarations work +t/comp.multiline 24 See if multiline strings work +t/comp.package 24 See if packages work +t/comp.script 24 See if script invokation works +t/comp.term 23 See if more terms work +t/io.argv 23 See if ARGV stuff works +t/io.dup 24 See if >& works right +t/io.fs 22 See if directory manipulations work +t/io.inplace 24 See if inplace editing works +t/io.pipe 24 See if secure pipes work +t/io.print 24 See if print commands work +t/io.tell 23 See if file seeking works +t/op.append 24 See if . works +t/op.array 22 See if array operations work +t/op.auto 18 See if autoincrement et all work +t/op.chop 24 See if chop works +t/op.cond 24 See if conditional expressions work +t/op.dbm 22 See if dbm binding works +t/op.delete 24 See if delete works +t/op.do 23 See if subroutines work +t/op.each 23 See if associative iterators work +t/op.eval 23 See if eval operator works +t/op.exec 24 See if exec and system work +t/op.exp 1 See if math functions work +t/op.flip 24 See if range operator works +t/op.fork 24 See if fork works +t/op.glob 24 See if <*> works +t/op.goto 24 See if goto works +t/op.index 24 See if index works +t/op.int 24 See if int works +t/op.join 24 See if join works +t/op.list 10 See if array lists work +t/op.local 24 See if local works +t/op.magic 23 See if magic variables work +t/op.mkdir 24 See if mkdir works +t/op.oct 24 See if oct and hex work +t/op.ord 24 See if ord works +t/op.pack 24 See if pack and unpack work +t/op.pat 22 See if esoteric patterns work +t/op.push 15 See if push and pop work +t/op.range 24 See if .. works +t/op.read 24 See if read() works +t/op.regexp 24 See if regular expressions work +t/op.repeat 23 See if x operator works +t/op.sleep 8 See if sleep works +t/op.sort 24 See if sort works +t/op.split 13 See if split works +t/op.sprintf 24 See if sprintf works +t/op.stat 21 See if stat works +t/op.study 23 See if study works +t/op.subst 21 See if substitutions work +t/op.substr 23 See if substr works +t/op.time 23 See if time functions work +t/op.undef 23 See if undef works +t/op.unshift 24 See if unshift works +t/op.vec 24 See if vectors work +t/op.write 23 See if write works +t/re_tests 22 Input file for op.regexp +toke.c 5 The tokener +util.c 17 Utility routines +util.h 24 Public declarations for the above +x2p/EXTERN.h 24 Same as above +x2p/INTERN.h 24 Same as above +x2p/Makefile.SH 22 Precursor to Makefile +x2p/a2p.h 20 Global declarations +x2p/a2p.man 20 Manual page for awk to perl translator +x2p/a2p.y 19 A yacc grammer for awk +x2p/a2py.c 16 Awk compiler, sort of +x2p/handy.h 24 Handy definitions +x2p/hash.c 21 Associative arrays again +x2p/hash.h 23 Public declarations for the above +x2p/s2p.SH 18 Sed to perl translator +x2p/s2p.man 22 Manual page for sed to perl translator +x2p/str.c 19 String handling package +x2p/str.h 23 Public declarations for the above +x2p/util.c 15 Utility routines +x2p/util.h 24 Public declarations for the above +x2p/walk.c 4 Parse tree walker diff --git a/README b/README index 0fb953a..ba603da 100644 --- a/README +++ b/README @@ -1,10 +1,22 @@ - Perl Kit, Version 2.0 + Perl Kit, Version 3.0 - Copyright (c) 1988, Larry Wall + Copyright (c) 1989, Larry Wall + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -You may copy the perl kit in whole or in part as long as you don't try to -make money off it, or pretend that you wrote it. -------------------------------------------------------------------------- Perl is a language that combines some of the features of C, sed, awk and shell. @@ -13,7 +25,7 @@ See the manual page for more hype. Perl will probably not run on machines with a small address space. Please read all the directions below before you proceed any further, and -then follow them carefully. Failure to do so may void your warranty. :-) +then follow them carefully. After you have unpacked your kit, you should have all the files listed in MANIFEST. @@ -58,7 +70,7 @@ Installation 6) make install - This will put perl into a public directory (normally /usr/local/bin). + This will put perl into a public directory (such as /usr/local/bin). It will also try to put the man pages in a reasonable place. It will not nroff the man page, however. You may need to be root to do this. If you are not root, you must own the directories in question and you should @@ -66,10 +78,7 @@ Installation 7) Read the manual entry before running perl. -8) Go down to the x2p directory and do a "make depend, a "make" and a - "make install" to create the awk to perl and sed to perl translators. - -9) IMPORTANT! Help save the world! Communicate any problems and suggested +8) IMPORTANT! Help save the world! Communicate any problems and suggested patches to me, lwall@jpl-devvax.jpl.nasa.gov (Larry Wall), so we can keep the world in sync. If you have a problem, there's someone else out there who either has had or will have the same problem. @@ -83,3 +92,9 @@ Installation perl and aren't sure how many patches there are, write to me and I'll send any you don't have. Your current patch level is shown in patchlevel.h. + +Just a personal note: I want you to know that I create nice things like this +because it pleases the Author of my story. If this bothers you, then your +notion of Authorship needs some revision. But you can use perl anyway. :-) + + The author. diff --git a/Wishlist b/Wishlist index 04e757d..13954af 100644 --- a/Wishlist +++ b/Wishlist @@ -1,4 +1,6 @@ -date support -case statement -ioctl() support -random numbers +ctime to time support +better format pictures +pager? +built-in cpp +perl to C translator +multi-threading diff --git a/arg.c b/arg.c deleted file mode 100644 index 4cdb889..0000000 --- a/arg.c +++ /dev/null @@ -1,1834 +0,0 @@ -/* $Header: arg.c,v 2.0 88/06/05 00:08:04 root Exp $ - * - * $Log: arg.c,v $ - * Revision 2.0 88/06/05 00:08:04 root - * Baseline version 2.0. - * - */ - -#include "EXTERN.h" -#include "perl.h" - -#include -#include - -extern int errno; - -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 *t; - register char *s = str_get(sarg[1]); - char *strend = s + sarg[1]->str_cur; - - 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 &str_no; - } - if (spat->spat_runtime) { - t = str_get(eval(spat->spat_runtime,Null(STR***),-1)); -#ifdef DEBUGGING - if (debug & 8) - deb("2.SPAT /%s/\n",t); -#endif - 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; - lastspat = spat; - goto gotcha; - } - else - return &str_no; - } - else { -#ifdef DEBUGGING - if (debug & 8) { - char ch; - - if (spat->spat_flags & SPAT_ONCE) - ch = '?'; - else - ch = '/'; - deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch); - } -#endif - 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) { - 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 */ - } - } - 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; - lastspat = spat; - if (spat->spat_flags & SPAT_ONCE) - spat->spat_flags |= SPAT_USED; - goto gotcha; - } - else - 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 -do_subst(str,arg) -STR *str; -register ARG *arg; -{ - register SPAT *spat; - register STR *dstr; - register char *s = str_get(str); - char *strend = s + str->str_cur; - register char *m; - - spat = arg[2].arg_ptr.arg_spat; - if (!spat || !s) - fatal("panic: do_subst"); - else if (spat->spat_runtime) { - 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_regexp->precomp); - } -#endif - 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) { - 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 */ - } - } - 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)); - 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"); - if (spat->spat_regexp->subbase) - s = spat->spat_regexp->subbase; - str_ncat(dstr,s,m-s); - s = spat->spat_regexp->endp[0]; - str_scat(dstr,eval(spat->spat_repl,Null(STR***),-1)); - if (spat->spat_flags & SPAT_ONCE) - break; - } 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 -do_trans(str,arg) -STR *str; -register ARG *arg; -{ - register char *tbl; - register char *s; - register int matches = 0; - register int ch; - - tbl = arg[2].arg_ptr.arg_cval; - s = str_get(str); - if (!tbl || !s) - fatal("panic: do_trans"); -#ifdef DEBUGGING - if (debug & 8) { - deb("2.TBL\n"); - } -#endif - while (*s) { - if (ch = tbl[*s & 0377]) { - matches++; - *s = ch; - } - s++; - } - STABSET(str); - return matches; -} - -int -do_split(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; - int i; - - if (!spat || !s) - fatal("panic: do_split"); - else if (spat->spat_runtime) { - m = str_get(eval(spat->spat_runtime,Null(STR***),-1)); - if (!*m || (*m == ' ' && !m[1])) { - m = "\\s+"; - spat->spat_flags |= SPAT_SKIPWHITE; - } - if (spat->spat_runtime->arg_type == O_ITEM && - spat->spat_runtime[1].arg_type == A_SINGLE) { - arg_free(spat->spat_runtime); /* it won't change, so */ - spat->spat_runtime = Nullarg; /* no point compiling again */ - } - spat->spat_regexp = regcomp(m,spat->spat_flags & SPAT_FOLD,1); - } -#ifdef DEBUGGING - if (debug & 8) { - deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); - } -#endif - if (retary) - ary = myarray; - else - ary = spat->spat_repl[1].arg_ptr.arg_stab->stab_array; - if (!ary) - myarray = ary = anew(Nullstab); - ary->ary_fill = -1; - if (spat->spat_flags & SPAT_SKIPWHITE) { - while (isspace(*s)) - s++; - } - 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 */ - str_set(dstr,s); - astore(ary, iters++, dstr); - } - else { - while (iters > 0 && !*str_get(afetch(ary,iters-1))) - iters--; - } - if (retary) { - *ptrmaxsarg = iters + sargoff; - sarg = (STR**)saferealloc((char*)(sarg - sargoff), - (iters+2+cushion+sargoff)*sizeof(STR*)) + sargoff; - - for (i = 1; i <= iters; i++) - sarg[i] = afetch(ary,i-1); - *retary = sarg; - } - return iters; -} - -void -do_join(arg,delim,str) -register ARG *arg; -register char *delim; -register STR *str; -{ - STR **tmpary; /* must not be register */ - register STR **elem; - register int items; - - (void)eval(arg[2].arg_ptr.arg_arg,&tmpary,-1); - items = (int)str_gnum(*tmpary); - elem = tmpary+1; - if (items-- > 0) - str_sset(str,*elem++); - for (; items > 0; items--,elem++) { - str_cat(str,delim); - str_scat(str,*elem); - } - STABSET(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; -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 == '|') - result = pclose(stio->fp); - else if (stio->type != '-') - 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++) ; - 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,"-")) { - fp = stdout; - stio->type = '-'; - } - else - fp = fopen(name,"w"); - } - else { - if (*name == '<') { - for (name++; isspace(*name); name++) ; - if (strEQ(name,"-")) { - fp = stdin; - stio->type = '-'; - } - else - fp = fopen(name,"r"); - } - else if (name[len-1] == '|') { - name[--len] = '\0'; - while (len && isspace(name[len-1])) - name[--len] = '\0'; - for (; isspace(*name); name++) ; - if (strNE(name,"-")) { - fp = popen(name,"r"); - stio->type = '|'; - } - else { - fp = forkopen(name,"r"); - stio->subprocess = forkprocess; - stio->type = '%'; - } - } - else { - stio->type = '<'; - for (; isspace(*name); name++) ; - if (strEQ(name,"-")) { - fp = stdin; - stio->type = '-'; - } - else - fp = fopen(name,"r"); - } - } - safefree(myname); - if (!fp) - return FALSE; - if (stio->type && - stio->type != '|' && stio->type != '-' && stio->type != '%') { - if (fstat(fileno(fp),&statbuf) < 0) { - fclose(fp); - return FALSE; - } - if ((statbuf.st_mode & S_IFMT) != S_IFREG && - (statbuf.st_mode & S_IFMT) != S_IFCHR) { - fclose(fp); - return FALSE; - } - } - stio->fp = fp; - return TRUE; -} - -FILE * -nextargv(stab) -register STAB *stab; -{ - register STR *str; - char *oldname; - int filemode,fileuid,filegid; - - 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 - rename(oldname,str->str_ptr); -#else - UNLINK(str->str_ptr); - link(oldname,str->str_ptr); - 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; - } - else - fprintf(stderr,"Can't open %s\n",str_get(str)); - str_free(str); - } - if (inplace) { - do_close(argvoutstab,FALSE); - defoutstab = stabent("stdout",TRUE); - } - return Nullfp; -} - -bool -do_close(stab,explicit) -STAB *stab; -bool explicit; -{ - bool retval = FALSE; - register STIO *stio = stab->stab_io; - int status; - int tmp; - - 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 { - 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) - stio->lines = 0; - stio->type = ' '; - return retval; -} - -bool -do_eof(stab) -STAB *stab; -{ - register STIO *stio; - int ch; - - if (!stab) /* eof() */ - stio = argvstab->stab_io; - else - stio = stab->stab_io; - - if (!stio) - return TRUE; - - while (stio->fp) { - -#ifdef STDSTDIO /* (the code works without this) */ - if (stio->fp->_cnt) /* cheat a little, since */ - return FALSE; /* this is the most usual case */ -#endif - - ch = getc(stio->fp); - if (ch != EOF) { - ungetc(ch, stio->fp); - return FALSE; - } - if (!stab) { /* not necessarily a real EOF yet? */ - if (!nextargv(argvstab)) /* get another fp handy */ - return TRUE; - } - else - return TRUE; /* normal fp, definitely end of file */ - } - return TRUE; -} - -long -do_tell(stab) -STAB *stab; -{ - register STIO *stio; - - if (!stab) - goto phooey; - - stio = stab->stab_io; - if (!stio || !stio->fp) - goto phooey; - - return ftell(stio->fp); - -phooey: - if (dowarn) - warn("tell() on unopened file"); - return -1L; -} - -bool -do_seek(stab, pos, whence) -STAB *stab; -long pos; -int whence; -{ - register STIO *stio; - - if (!stab) - goto nuts; - - stio = stab->stab_io; - if (!stio || !stio->fp) - goto nuts; - - return fseek(stio->fp, pos, whence) >= 0; - -nuts: - if (dowarn) - warn("seek() on unopened file"); - return FALSE; -} - -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*); - int max = 13; - register int i; - - ary = myarray; - if (!ary) - myarray = ary = anew(Nullstab); - ary->ary_fill = -1; - if (arg[1].arg_type == A_LVAL) { - tmpstab = arg[1].arg_ptr.arg_stab; - if (!tmpstab->stab_io || - fstat(fileno(tmpstab->stab_io->fp),&statbuf) < 0) { - max = 0; - } - } - else - if (stat(str_get(sarg[1]),&statbuf) < 0) - max = 0; - - if (retary) { - if (max) { - apush(ary,str_nmake((double)statbuf.st_dev)); - apush(ary,str_nmake((double)statbuf.st_ino)); - apush(ary,str_nmake((double)statbuf.st_mode)); - apush(ary,str_nmake((double)statbuf.st_nlink)); - apush(ary,str_nmake((double)statbuf.st_uid)); - apush(ary,str_nmake((double)statbuf.st_gid)); - apush(ary,str_nmake((double)statbuf.st_rdev)); - apush(ary,str_nmake((double)statbuf.st_size)); - apush(ary,str_nmake((double)statbuf.st_atime)); - apush(ary,str_nmake((double)statbuf.st_mtime)); - apush(ary,str_nmake((double)statbuf.st_ctime)); -#ifdef STATBLOCKS - apush(ary,str_nmake((double)statbuf.st_blksize)); - apush(ary,str_nmake((double)statbuf.st_blocks)); -#else - apush(ary,str_make("")); - apush(ary,str_make("")); -#endif - } - *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; - } - return max; -} - -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*); - int max = 4; - register int i; - - ary = myarray; - if (!ary) - myarray = ary = anew(Nullstab); - ary->ary_fill = -1; - times(×buf); - -#ifndef HZ -#define HZ 60 -#endif - - if (retary) { - if (max) { - 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; - } - return max; -} - -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*); - int max = 9; - register int i; - - ary = myarray; - if (!ary) - myarray = ary = anew(Nullstab); - ary->ary_fill = -1; - if (!tmbuf) - max = 0; - - if (retary) { - if (max) { - apush(ary,str_nmake((double)tmbuf->tm_sec)); - apush(ary,str_nmake((double)tmbuf->tm_min)); - apush(ary,str_nmake((double)tmbuf->tm_hour)); - apush(ary,str_nmake((double)tmbuf->tm_mday)); - apush(ary,str_nmake((double)tmbuf->tm_mon)); - apush(ary,str_nmake((double)tmbuf->tm_year)); - apush(ary,str_nmake((double)tmbuf->tm_wday)); - apush(ary,str_nmake((double)tmbuf->tm_yday)); - apush(ary,str_nmake((double)tmbuf->tm_isdst)); - } - *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; - } - return max; -} - -void -do_sprintf(str,len,sarg) -register STR *str; -register int len; -register STR **sarg; -{ - register char *s; - register char *t; - bool dolong; - char ch; - static STR *sargnull = &str_no; - - str_set(str,""); - len--; /* don't count pattern string */ - sarg++; - for (s = str_get(*(sarg++)); *s; len--) { - if (len <= 0 || !*sarg) { - sarg = &sargnull; - len = 0; - } - dolong = FALSE; - for (t = s; *t && *t != '%'; t++) ; - if (!*t) - break; /* not enough % patterns, oh well */ - for (t++; *sarg && *t && t != s; t++) { - switch (*t) { - case '\0': - t--; - break; - case '%': - ch = *(++t); - *t = '\0'; - sprintf(buf,s); - s = t; - *(t--) = ch; - break; - case 'l': - dolong = TRUE; - break; - case 'D': case 'X': case 'O': - dolong = TRUE; - /* FALL THROUGH */ - case 'd': case 'x': case 'o': case 'c': case 'u': - ch = *(++t); - *t = '\0'; - if (dolong) - sprintf(buf,s,(long)str_gnum(*(sarg++))); - else - sprintf(buf,s,(int)str_gnum(*(sarg++))); - s = t; - *(t--) = ch; - break; - case 'E': case 'e': case 'f': case 'G': case 'g': - ch = *(++t); - *t = '\0'; - sprintf(buf,s,str_gnum(*(sarg++))); - s = t; - *(t--) = ch; - break; - case 's': - ch = *(++t); - *t = '\0'; - 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; - } - } - str_cat(str,buf); - } - if (*s) - str_cat(str,s); - STABSET(str); -} - -bool -do_print(str,fp) -register STR *str; -FILE *fp; -{ - if (!fp) { - if (dowarn) - warn("print to unopened file"); - return FALSE; - } - if (!str) - return FALSE; - 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; -} - -bool -do_aprint(arg,fp) -register ARG *arg; -register FILE *fp; -{ - STR **tmpary; /* must not be register */ - register STR **elem; - register bool retval; - register int items; - - 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,items,tmpary); - retval = do_print(arg->arg_ptr.arg_str,fp); - } - else { - retval = FALSE; - for (elem = tmpary+1; items > 0; items--,elem++) { - if (retval && ofs) - fputs(ofs, fp); - retval = do_print(*elem, fp); - if (!retval) - break; - } - if (ors) - fputs(ors, fp); - } - safefree((char*)tmpary); - return retval; -} - -bool -do_aexec(arg) -register ARG *arg; -{ - STR **tmpary; /* must not be register */ - register STR **elem; - register char **a; - register int items; - char **argv; - - (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; items > 0; items--,elem++) { - if (*elem) - *a++ = str_get(*elem); - else - *a++ = ""; - } - *a = Nullch; - execvp(argv[0],argv); - safefree((char*)argv); - } - safefree((char*)tmpary); - return FALSE; -} - -bool -do_exec(str) -STR *str; -{ - 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,(char*)0); - return FALSE; - } - } - argv = (char**)safemalloc(((s - cmd) / 2 + 2)*sizeof(char*)); - - a = argv; - for (s = cmd; *s;) { - while (isspace(*s)) s++; - if (*s) - *(a++) = s; - while (*s && !isspace(*s)) s++; - if (*s) - *s++ = '\0'; - } - *a = Nullch; - if (argv[0]) - execvp(argv[0],argv); - safefree((char*)argv); - return FALSE; -} - -STR * -do_push(arg,ary) -register ARG *arg; -register ARRAY *ary; -{ - STR **tmpary; /* must not be register */ - register STR **elem; - register STR *str = &str_no; - register int items; - - (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); - if (*elem) - str_sset(str,*elem); - apush(ary,str); - } - safefree((char*)tmpary); - return str; -} - -do_unshift(arg,ary) -register ARG *arg; -register ARRAY *ary; -{ - STR **tmpary; /* must not be register */ - register STR **elem; - register STR *str = &str_no; - register int i; - register int items; - - (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1); - items = (int)str_gnum(*tmpary); - aunshift(ary,items); - i = 0; - for (elem = tmpary+1; i < items; i++,elem++) { - str = str_new(0); - str_sset(str,*elem); - astore(ary,i,str); - } - safefree((char*)tmpary); -} - -apply(type,arg,sarg) -int type; -register ARG *arg; -STR **sarg; -{ - STR **tmpary; /* must not be register */ - register STR **elem; - register int items; - register int val; - register int val2; - char *s; - - if (sarg) { - tmpary = sarg; - 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 (--items > 0) { - val = (int)str_gnum(tmpary[1]); - for (elem = tmpary+2; *elem; elem++) - if (chmod(str_get(*elem),val)) - items--; - } - break; - case O_CHOWN: - 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)) - items--; - } - else - items = 0; - break; - case O_KILL: - if (--items > 0) { - val = (int)str_gnum(tmpary[1]); - if (val < 0) { - val = -val; - 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++) { - 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 items; -} - -STR * -do_subr(arg,sarg) -register ARG *arg; -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); - if (arg[1].arg_flags & AF_SPECIAL) - (void)do_push(arg,defstab->stab_array); - else if (arg[1].arg_type != A_NULL) { - str = str_new(0); - str_sset(str,sarg[1]); - apush(defstab->stab_array,str); - } - 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,sarg) -STR *retstr; -register ARG *arg; -register STR **sarg; -{ - STR **tmpary; /* must not be register */ - register ARG *larg = arg[1].arg_ptr.arg_arg; - register STR **elem; - register STR *str; - register ARRAY *ary; - register int i; - register int items; - STR *tmpstr; - - 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) { /* always true currently, alas */ - if (*(tmpary+1)) { - for (i=2,elem=tmpary+2; i <= items; i++,elem++) { - *elem = str_static(*elem); - } - } - } - if (larg->arg_type == O_LIST) { - 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***),-1); - break; - } - 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); - } - } - else { /* should be an array name */ - ary = larg[1].arg_ptr.arg_stab->stab_array; - 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 = items - 1;/* they can get the extra ones back by */ - } /* setting $#ary larger than old fill */ - str_numset(retstr,(double)items); - STABSET(retstr); - if (tmpary != sarg); - safefree((char*)tmpary); -} - -int -do_kv(hash,kv,retary,sarg,ptrmaxsarg,sargoff,cushion) -HASH *hash; -int kv; -STR ***retary; -register STR **sarg; -int *ptrmaxsarg; -int sargoff; -int cushion; -{ - register ARRAY *ary; - int max = 0; - int i; - static ARRAY *myarray = Null(ARRAY*); - register HENT *entry; - - ary = myarray; - if (!ary) - myarray = ary = anew(Nullstab); - ary->ary_fill = -1; - - hiterinit(hash); - while (entry = hiternext(hash)) { - max++; - if (kv == O_KEYS) - apush(ary,str_make(hiterkey(entry))); - else - apush(ary,str_make(str_get(hiterval(entry)))); - } - if (retary) { /* array wanted */ - *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; - } - return max; -} - -STR * -do_each(hash,retary,sarg,ptrmaxsarg,sargoff,cushion) -HASH *hash; -STR ***retary; -STR **sarg; -int *ptrmaxsarg; -int sargoff; -int cushion; -{ - static STR *mystr = Nullstr; - STR *retstr; - HENT *entry = hiternext(hash); - - if (mystr) { - str_free(mystr); - mystr = Nullstr; - } - - if (retary) { /* array wanted */ - if (entry) { - *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 { - *ptrmaxsarg = sargoff; - sarg = (STR**)saferealloc((char*)(sarg - sargoff), - (2+cushion+sargoff)*sizeof(STR*)) + sargoff; - retstr = Nullstr; - *retary = sarg; - } - } - else - retstr = hiterval(entry); - - return retstr; -} - -int -mystat(arg,str) -ARG *arg; -STR *str; -{ - STIO *stio; - - 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); - opargs[O_BIT_OR] = A(1,1,0); - opargs[O_AND] = A(1,0,0); /* don't eval arg 2 (yet) */ - opargs[O_OR] = A(1,0,0); /* don't eval arg 2 (yet) */ - opargs[O_COND_EXPR] = A(1,0,0); /* don't eval args 2 or 3 */ - opargs[O_COMMA] = A(1,1,0); - opargs[O_NEGATE] = A(1,0,0); - opargs[O_NOT] = A(1,0,0); - opargs[O_COMPLEMENT] = A(1,0,0); - opargs[O_WRITE] = A(1,0,0); - opargs[O_OPEN] = A(1,1,0); - opargs[O_TRANS] = A(1,0,0); - opargs[O_NTRANS] = A(1,0,0); - opargs[O_CLOSE] = A(0,0,0); - opargs[O_ARRAY] = A(1,0,0); - opargs[O_HASH] = A(1,0,0); - opargs[O_LARRAY] = A(1,0,0); - opargs[O_LHASH] = A(1,0,0); - opargs[O_PUSH] = A(1,0,0); - opargs[O_POP] = A(0,0,0); - opargs[O_SHIFT] = A(0,0,0); - opargs[O_SPLIT] = A(1,0,0); - opargs[O_LENGTH] = A(1,0,0); - opargs[O_SPRINTF] = A(1,0,0); - opargs[O_SUBSTR] = A(1,1,1); - opargs[O_JOIN] = A(1,0,0); - opargs[O_SLT] = A(1,1,0); - opargs[O_SGT] = A(1,1,0); - opargs[O_SLE] = A(1,1,0); - opargs[O_SGE] = A(1,1,0); - opargs[O_SEQ] = A(1,1,0); - opargs[O_SNE] = A(1,1,0); - opargs[O_SUBR] = A(1,0,0); - opargs[O_PRINT] = A(1,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(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); - opargs[O_GOTO] = A(1,0,0); - opargs[O_INDEX] = A(1,1,0); - opargs[O_TIME] = A(0,0,0); - opargs[O_TMS] = A(0,0,0); - opargs[O_LOCALTIME] = A(1,0,0); - opargs[O_GMTIME] = A(1,0,0); - opargs[O_STAT] = A(1,0,0); - opargs[O_CRYPT] = A(1,1,0); - opargs[O_EXP] = A(1,0,0); - opargs[O_LOG] = A(1,0,0); - opargs[O_SQRT] = A(1,0,0); - opargs[O_INT] = A(1,0,0); - opargs[O_PRTF] = A(1,1,0); - opargs[O_ORD] = A(1,0,0); - opargs[O_SLEEP] = A(1,0,0); - opargs[O_FLIP] = A(1,0,0); - opargs[O_FLOP] = A(0,1,0); - opargs[O_KEYS] = A(0,0,0); - opargs[O_VALUES] = A(0,0,0); - opargs[O_EACH] = A(0,0,0); - opargs[O_CHOP] = A(1,0,0); - opargs[O_FORK] = A(1,0,0); - opargs[O_EXEC] = A(1,0,0); - opargs[O_SYSTEM] = A(1,0,0); - opargs[O_OCT] = A(1,0,0); - opargs[O_HEX] = A(1,0,0); - opargs[O_CHMOD] = A(1,0,0); - opargs[O_CHOWN] = A(1,0,0); - opargs[O_KILL] = A(1,0,0); - opargs[O_RENAME] = A(1,1,0); - opargs[O_UNLINK] = A(1,0,0); - opargs[O_UMASK] = A(1,0,0); - opargs[O_UNSHIFT] = A(1,0,0); - opargs[O_LINK] = A(1,1,0); - opargs[O_REPEAT] = A(1,1,0); - opargs[O_EVAL] = A(1,0,0); - 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 efb3e36..ae52789 100644 --- a/arg.h +++ b/arg.h @@ -1,8 +1,13 @@ -/* $Header: arg.h,v 2.0 88/06/05 00:08:14 root Exp $ +/* $Header: arg.h,v 3.0 89/10/18 15:08:27 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: arg.h,v $ - * Revision 2.0 88/06/05 00:08:14 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:08:27 lwall + * 3.0 baseline * */ @@ -143,7 +148,111 @@ #define O_SORT 134 #define O_DELETE 135 #define O_STUDY 136 -#define MAXO 137 +#define O_ATAN2 137 +#define O_SIN 138 +#define O_COS 139 +#define O_RAND 140 +#define O_SRAND 141 +#define O_POW 142 +#define O_RETURN 143 +#define O_GETC 144 +#define O_MKDIR 145 +#define O_RMDIR 146 +#define O_GETPPID 147 +#define O_GETPGRP 148 +#define O_SETPGRP 149 +#define O_GETPRIORITY 150 +#define O_SETPRIORITY 151 +#define O_CHROOT 152 +#define O_IOCTL 153 +#define O_FCNTL 154 +#define O_FLOCK 155 +#define O_RINDEX 156 +#define O_PACK 157 +#define O_UNPACK 158 +#define O_READ 159 +#define O_WARN 160 +#define O_DBMOPEN 161 +#define O_DBMCLOSE 162 +#define O_ASLICE 163 +#define O_HSLICE 164 +#define O_LASLICE 165 +#define O_LHSLICE 166 +#define O_F_OR_R 167 +#define O_RANGE 168 +#define O_RCAT 169 +#define O_AASSIGN 170 +#define O_SASSIGN 171 +#define O_DUMP 172 +#define O_REVERSE 173 +#define O_ADDROF 174 +#define O_SOCKET 175 +#define O_BIND 176 +#define O_CONNECT 177 +#define O_LISTEN 178 +#define O_ACCEPT 179 +#define O_SEND 180 +#define O_RECV 181 +#define O_SSELECT 182 +#define O_SOCKETPAIR 183 +#define O_DBSUBR 184 +#define O_DEFINED 185 +#define O_UNDEF 186 +#define O_READLINK 187 +#define O_LSTAT 188 +#define O_AELEM 189 +#define O_HELEM 190 +#define O_LAELEM 191 +#define O_LHELEM 192 +#define O_LOCAL 193 +#define O_UNUSED 194 +#define O_FILENO 195 +#define O_GHBYNAME 196 +#define O_GHBYADDR 197 +#define O_GHOSTENT 198 +#define O_SHOSTENT 199 +#define O_EHOSTENT 200 +#define O_GSBYNAME 201 +#define O_GSBYPORT 202 +#define O_GSERVENT 203 +#define O_SSERVENT 204 +#define O_ESERVENT 205 +#define O_GPBYNAME 206 +#define O_GPBYNUMBER 207 +#define O_GPROTOENT 208 +#define O_SPROTOENT 209 +#define O_EPROTOENT 210 +#define O_GNBYNAME 211 +#define O_GNBYADDR 212 +#define O_GNETENT 213 +#define O_SNETENT 214 +#define O_ENETENT 215 +#define O_VEC 216 +#define O_GREP 217 +#define O_GPWNAM 218 +#define O_GPWUID 219 +#define O_GPWENT 220 +#define O_SPWENT 221 +#define O_EPWENT 222 +#define O_GGRNAM 223 +#define O_GGRGID 224 +#define O_GGRENT 225 +#define O_SGRENT 226 +#define O_EGRENT 227 +#define O_SHUTDOWN 228 +#define O_OPENDIR 229 +#define O_READDIR 230 +#define O_TELLDIR 231 +#define O_SEEKDIR 232 +#define O_REWINDDIR 233 +#define O_CLOSEDIR 234 +#define O_GETLOGIN 235 +#define O_SYSCALL 236 +#define O_GSOCKOPT 237 +#define O_SSOCKOPT 238 +#define O_GETSOCKNAME 239 +#define O_GETPEERNAME 240 +#define MAXO 241 #ifndef DOINIT extern char *opname[]; @@ -286,7 +395,111 @@ char *opname[] = { "SORT", "DELETE", "STUDY", - "135" + "ATAN2", + "SIN", + "COS", + "RAND", + "SRAND", + "POW", + "RETURN", + "GETC", + "MKDIR", + "RMDIR", + "GETPPID", + "GETPGRP", + "SETPGRP", + "GETPRIORITY", + "SETPRIORITY", + "CHROOT", + "IOCTL", + "FCNTL", + "FLOCK", + "RINDEX", + "PACK", + "UNPACK", + "READ", + "WARN", + "DBMOPEN", + "DBMCLOSE", + "ASLICE", + "HSLICE", + "LASLICE", + "LHSLICE", + "FLIP_OR_RANGE", + "RANGE", + "RCAT", + "AASSIGN", + "SASSIGN", + "DUMP", + "REVERSE", + "ADDRESS_OF", + "SOCKET", + "BIND", + "CONNECT", + "LISTEN", + "ACCEPT", + "SEND", + "RECV", + "SSELECT", + "SOCKETPAIR", + "DBSUBR", + "DEFINED", + "UNDEF", + "READLINK", + "LSTAT", + "AELEM", + "HELEM", + "LAELEM", + "LHELEM", + "LOCAL", + "UNUSED", + "FILENO", + "GHBYNAME", + "GHBYADDR", + "GHOSTENT", + "SHOSTENT", + "EHOSTENT", + "GSBYNAME", + "GSBYPORT", + "GSERVENT", + "SSERVENT", + "ESERVENT", + "GPBYNAME", + "GPBYNUMBER", + "GPROTOENT", + "SPROTOENT", + "EPROTOENT", + "GNBYNAME", + "GNBYADDR", + "GNETENT", + "SNETENT", + "ENETENT", + "VEC", + "GREP", + "GPWNAM", + "GPWUID", + "GPWENT", + "SPWENT", + "EPWENT", + "GGRNAM", + "GGRGID", + "GGRENT", + "SGRENT", + "EGRENT", + "SHUTDOWN", + "OPENDIR", + "READDIR", + "TELLDIR", + "SEEKDIR", + "REWINDDIR", + "CLOSEDIR", + "GETLOGIN", + "SYSCALL", + "GSOCKOPT", + "SSOCKOPT", + "GETSOCKNAME", + "GETPEERNAME", + "241" }; #endif @@ -302,11 +515,18 @@ char *opname[] = { #define A_SPAT 9 #define A_LEXPR 10 #define A_ARYLEN 11 -#define A_NUMBER 12 +#define A_ARYSTAB 12 #define A_LARYLEN 13 #define A_GLOB 14 #define A_WORD 15 #define A_INDREAD 16 +#define A_LARYSTAB 17 +#define A_STAR 18 +#define A_LSTAR 19 +#define A_WANTARRAY 20 + +#define A_MASK 31 +#define A_DONT 32 /* or this into type to suppress evaluation */ #ifndef DOINIT extern char *argname[]; @@ -324,19 +544,46 @@ char *argname[] = { "SPAT", "LEXPR", "ARYLEN", - "NUMBER", + "ARYSTAB", "LARYLEN", "GLOB", "WORD", "INDREAD", - "17" + "LARYSTAB", + "STAR", + "LSTAR", + "WANTARRAY", + "21" }; #endif #ifndef DOINIT extern bool hoistable[]; #else -bool hoistable[] = {0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0}; +bool hoistable[] = + {0, /* A_NULL */ + 0, /* EXPR */ + 1, /* CMD */ + 1, /* STAB */ + 0, /* LVAL */ + 1, /* SINGLE */ + 0, /* DOUBLE */ + 0, /* BACKTICK */ + 0, /* READ */ + 0, /* SPAT */ + 0, /* LEXPR */ + 1, /* ARYLEN */ + 1, /* ARYSTAB */ + 0, /* LARYLEN */ + 0, /* GLOB */ + 1, /* WORD */ + 0, /* INDREAD */ + 0, /* LARYSTAB */ + 1, /* STAR */ + 1, /* LSTAR */ + 1, /* WANTARRAY */ + 0, /* 21 */ +}; #endif union argptr { @@ -346,22 +593,25 @@ union argptr { SPAT *arg_spat; CMD *arg_cmd; STR *arg_str; - double arg_nval; + HASH *arg_hash; }; struct arg { union argptr arg_ptr; short arg_len; +#ifdef mips + short pad; +#endif unsigned char arg_type; unsigned char arg_flags; }; -#define AF_SPECIAL 1 /* op wants to evaluate this arg itself */ +#define AF_ARYOK 1 /* op can handle multiple values here */ #define AF_POST 2 /* post *crement this item */ #define AF_PRE 4 /* pre *crement this item */ #define AF_UP 8 /* increment rather than decrement */ #define AF_COMMON 16 /* left and right have symbols in common */ -#define AF_NUMERIC 32 /* return as numeric rather than string */ +#define AF_UNUSED 32 /* */ #define AF_LISTISH 64 /* turn into list if important */ #define AF_LOCAL 128 /* list of local variables */ @@ -371,13 +621,262 @@ struct arg { * use on the list of arguments following. The arg_len in the 0th element * gives the maximum argument number, and the arg_str is used to store * the return value in a more-or-less static location. Sorry it's not - * re-entrant, but it sure makes it efficient. The arg_type of the + * re-entrant (yet), but it sure makes it efficient. The arg_type of the * 0th element is an operator (O_*) rather than an argument type (A_*). */ #define Nullarg Null(ARG*) -EXT char opargs[MAXO]; +#ifndef DOINIT +EXT char opargs[MAXO+1]; +#else +#define A(e1,e2,e3) (e1+(e2<<2)+(e3<<4)) +char opargs[MAXO+1] = { + A(0,0,0), /* NULL */ + A(1,0,0), /* ITEM */ + A(0,0,0), /* ITEM2 */ + A(0,0,0), /* ITEM3 */ + A(1,1,0), /* CONCAT */ + A(1,0,0), /* MATCH */ + A(1,0,0), /* NMATCH */ + A(1,0,0), /* SUBST */ + A(1,0,0), /* NSUBST */ + A(1,1,0), /* ASSIGN */ + A(1,1,0), /* MULTIPLY */ + A(1,1,0), /* DIVIDE */ + A(1,1,0), /* MODULO */ + A(1,1,0), /* ADD */ + A(1,1,0), /* SUBTRACT */ + A(1,1,0), /* LEFT_SHIFT */ + A(1,1,0), /* RIGHT_SHIFT */ + A(1,1,0), /* LT */ + A(1,1,0), /* GT */ + A(1,1,0), /* LE */ + A(1,1,0), /* GE */ + A(1,1,0), /* EQ */ + A(1,1,0), /* NE */ + A(1,1,0), /* BIT_AND */ + A(1,1,0), /* XOR */ + A(1,1,0), /* BIT_OR */ + A(1,0,0), /* AND */ + A(1,0,0), /* OR */ + A(1,0,0), /* COND_EXPR */ + A(1,1,0), /* COMMA */ + A(1,0,0), /* NEGATE */ + A(1,0,0), /* NOT */ + A(1,0,0), /* COMPLEMENT */ + A(1,0,0), /* WRITE */ + A(1,1,0), /* OPEN */ + A(1,0,0), /* TRANS */ + A(1,0,0), /* NTRANS */ + A(1,0,0), /* CLOSE */ + A(0,0,0), /* ARRAY */ + A(0,0,0), /* HASH */ + A(0,0,0), /* LARRAY */ + A(0,0,0), /* LHASH */ + A(0,3,0), /* PUSH */ + A(0,0,0), /* POP */ + A(0,0,0), /* SHIFT */ + A(1,0,1), /* SPLIT */ + A(1,0,0), /* LENGTH */ + A(3,0,0), /* SPRINTF */ + A(1,1,1), /* SUBSTR */ + A(1,3,0), /* JOIN */ + A(1,1,0), /* SLT */ + A(1,1,0), /* SGT */ + A(1,1,0), /* SLE */ + A(1,1,0), /* SGE */ + A(1,1,0), /* SEQ */ + A(1,1,0), /* SNE */ + A(0,3,0), /* SUBR */ + A(1,3,0), /* PRINT */ + A(1,0,0), /* CHDIR */ + A(0,3,0), /* DIE */ + A(1,0,0), /* EXIT */ + A(1,0,0), /* RESET */ + A(3,0,0), /* LIST */ + A(1,0,0), /* SELECT */ + A(1,0,0), /* EOF */ + A(1,0,0), /* TELL */ + A(1,1,1), /* SEEK */ + A(0,0,0), /* LAST */ + A(0,0,0), /* NEXT */ + A(0,0,0), /* REDO */ + A(0,0,0), /* GOTO */ + A(1,1,0), /* INDEX */ + A(0,0,0), /* TIME */ + A(0,0,0), /* TIMES */ + A(1,0,0), /* LOCALTIME */ + A(1,0,0), /* GMTIME */ + A(1,0,0), /* STAT */ + A(1,1,0), /* CRYPT */ + A(1,0,0), /* EXP */ + A(1,0,0), /* LOG */ + A(1,0,0), /* SQRT */ + A(1,0,0), /* INT */ + A(1,3,0), /* PRINTF */ + A(1,0,0), /* ORD */ + A(1,0,0), /* SLEEP */ + A(1,0,0), /* FLIP */ + A(0,1,0), /* FLOP */ + A(0,0,0), /* KEYS */ + A(0,0,0), /* VALUES */ + A(0,0,0), /* EACH */ + A(3,0,0), /* CHOP */ + A(0,0,0), /* FORK */ + A(1,3,0), /* EXEC */ + A(1,3,0), /* SYSTEM */ + A(1,0,0), /* OCT */ + A(1,0,0), /* HEX */ + A(0,3,0), /* CHMOD */ + A(0,3,0), /* CHOWN */ + A(0,3,0), /* KILL */ + A(1,1,0), /* RENAME */ + A(0,3,0), /* UNLINK */ + A(1,0,0), /* UMASK */ + A(0,3,0), /* UNSHIFT */ + A(1,1,0), /* LINK */ + A(1,1,0), /* REPEAT */ + A(1,0,0), /* EVAL */ + A(1,0,0), /* FTEREAD */ + A(1,0,0), /* FTEWRITE */ + A(1,0,0), /* FTEEXEC */ + A(1,0,0), /* FTEOWNED */ + A(1,0,0), /* FTRREAD */ + A(1,0,0), /* FTRWRITE */ + A(1,0,0), /* FTREXEC */ + A(1,0,0), /* FTROWNED */ + A(1,0,0), /* FTIS */ + A(1,0,0), /* FTZERO */ + A(1,0,0), /* FTSIZE */ + A(1,0,0), /* FTFILE */ + A(1,0,0), /* FTDIR */ + A(1,0,0), /* FTLINK */ + A(1,1,0), /* SYMLINK */ + A(1,0,0), /* FTPIPE */ + A(1,0,0), /* FTSOCK */ + A(1,0,0), /* FTBLK */ + A(1,0,0), /* FTCHR */ + A(1,0,0), /* FTSUID */ + A(1,0,0), /* FTSGID */ + A(1,0,0), /* FTSVTX */ + A(1,0,0), /* FTTTY */ + A(1,0,0), /* DOFILE */ + A(1,0,0), /* FTTEXT */ + A(1,0,0), /* FTBINARY */ + A(0,3,0), /* UTIME */ + A(0,0,0), /* WAIT */ + A(1,3,0), /* SORT */ + A(0,1,0), /* DELETE */ + A(1,0,0), /* STUDY */ + A(1,1,0), /* ATAN2 */ + A(1,0,0), /* SIN */ + A(1,0,0), /* COS */ + A(1,0,0), /* RAND */ + A(1,0,0), /* SRAND */ + A(1,1,0), /* POW */ + A(0,3,0), /* RETURN */ + A(1,0,0), /* GETC */ + A(1,1,0), /* MKDIR */ + A(1,0,0), /* RMDIR */ + A(0,0,0), /* GETPPID */ + A(1,0,0), /* GETPGRP */ + A(1,1,0), /* SETPGRP */ + A(1,1,0), /* GETPRIORITY */ + A(1,1,1), /* SETPRIORITY */ + A(1,0,0), /* CHROOT */ + A(1,1,1), /* IOCTL */ + A(1,1,1), /* FCNTL */ + A(1,1,0), /* FLOCK */ + A(1,1,0), /* RINDEX */ + A(1,3,0), /* PACK */ + A(1,1,0), /* UNPACK */ + A(1,1,1), /* READ */ + A(0,3,0), /* WARN */ + A(1,1,1), /* DBMOPEN */ + A(1,0,0), /* DBMCLOSE */ + A(0,3,0), /* ASLICE */ + A(0,3,0), /* HSLICE */ + A(0,3,0), /* LASLICE */ + A(0,3,0), /* LHSLICE */ + A(1,0,0), /* F_OR_R */ + A(1,1,0), /* RANGE */ + A(1,1,0), /* RCAT */ + A(3,3,0), /* AASSIGN */ + A(0,0,0), /* SASSIGN */ + A(0,0,0), /* DUMP */ + A(0,0,0), /* REVERSE */ + A(1,0,0), /* ADDROF */ + A(1,1,1), /* SOCKET */ + A(1,1,0), /* BIND */ + A(1,1,0), /* CONNECT */ + A(1,1,0), /* LISTEN */ + A(1,1,0), /* ACCEPT */ + A(1,1,2), /* SEND */ + A(1,1,1), /* RECV */ + A(1,1,1), /* SSELECT */ + A(1,1,1), /* SOCKETPAIR */ + A(0,3,0), /* DBSUBR */ + A(1,0,0), /* DEFINED */ + A(1,0,0), /* UNDEF */ + A(1,0,0), /* READLINK */ + A(1,0,0), /* LSTAT */ + A(0,1,0), /* AELEM */ + A(0,1,0), /* HELEM */ + A(0,1,0), /* LAELEM */ + A(0,1,0), /* LHELEM */ + A(1,0,0), /* LOCAL */ + A(0,0,0), /* UNUSED */ + A(1,0,0), /* FILENO */ + A(1,0,0), /* GHBYNAME */ + A(1,1,0), /* GHBYADDR */ + A(0,0,0), /* GHOSTENT */ + A(1,0,0), /* SHOSTENT */ + A(0,0,0), /* EHOSTENT */ + A(1,1,0), /* GSBYNAME */ + A(1,1,0), /* GSBYPORT */ + A(0,0,0), /* GSERVENT */ + A(1,0,0), /* SSERVENT */ + A(0,0,0), /* ESERVENT */ + A(1,0,0), /* GPBYNAME */ + A(1,0,0), /* GPBYNUMBER */ + A(0,0,0), /* GPROTOENT */ + A(1,0,0), /* SPROTOENT */ + A(0,0,0), /* EPROTOENT */ + A(1,0,0), /* GNBYNAME */ + A(1,1,0), /* GNBYADDR */ + A(0,0,0), /* GNETENT */ + A(1,0,0), /* SNETENT */ + A(0,0,0), /* ENETENT */ + A(1,1,1), /* VEC */ + A(0,3,0), /* GREP */ + A(1,0,0), /* GPWNAM */ + A(1,0,0), /* GPWUID */ + A(0,0,0), /* GPWENT */ + A(0,0,0), /* SPWENT */ + A(0,0,0), /* EPWENT */ + A(1,0,0), /* GGRNAM */ + A(1,0,0), /* GGRGID */ + A(0,0,0), /* GGRENT */ + A(0,0,0), /* SGRENT */ + A(0,0,0), /* EGRENT */ + A(1,1,0), /* SHUTDOWN */ + A(1,1,0), /* OPENDIR */ + A(1,0,0), /* READDIR */ + A(1,0,0), /* TELLDIR */ + A(1,1,0), /* SEEKDIR */ + A(1,0,0), /* REWINDDIR */ + A(1,0,0), /* CLOSEDIR */ + A(0,0,0), /* GETLOGIN */ + A(1,3,0), /* SYSCALL */ + A(1,1,1), /* GSOCKOPT */ + A(1,1,1), /* SSOCKOPT */ + A(1,0,0), /* GETSOCKNAME */ + A(1,0,0), /* GETPEERNAME */ + 0 +}; +#undef A +#endif int do_trans(); int do_split(); @@ -390,3 +889,4 @@ int do_stat(); STR *do_push(); FILE *nextargv(); STR *do_fttext(); +int do_slice(); diff --git a/array.c b/array.c index f1446a7..6875d28 100644 --- a/array.c +++ b/array.c @@ -1,8 +1,13 @@ -/* $Header: array.c,v 2.0 88/06/05 00:08:17 root Exp $ +/* $Header: array.c,v 3.0 89/10/18 15:08:33 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: array.c,v $ - * Revision 2.0 88/06/05 00:08:17 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:08:33 lwall + * 3.0 baseline * */ @@ -10,12 +15,30 @@ #include "perl.h" STR * -afetch(ar,key) +afetch(ar,key,lval) register ARRAY *ar; int key; +int lval; { - if (key < 0 || key > ar->ary_fill) - return Nullstr; + STR *str; + + if (key < 0 || key > ar->ary_fill) { + if (lval && key >= 0) { + if (ar->ary_flags & ARF_REAL) + str = Str_new(5,0); + else + str = str_static(&str_undef); + (void)astore(ar,key,str); + return str; + } + else + return Nullstr; + } + if (lval && !ar->ary_array[key]) { + str = Str_new(6,0); + (void)astore(ar,key,str); + return str; + } return ar->ary_array[key]; } @@ -25,60 +48,84 @@ register ARRAY *ar; int key; STR *val; { - bool retval; + int retval; if (key < 0) return FALSE; if (key > ar->ary_max) { - int newmax = key + ar->ary_max / 5; - - ar->ary_array = (STR**)saferealloc((char*)ar->ary_array, - (newmax+1) * sizeof(STR*)); - bzero((char*)&ar->ary_array[ar->ary_max+1], - (newmax - ar->ary_max) * sizeof(STR*)); - ar->ary_max = newmax; + int newmax; + + if (ar->ary_alloc != ar->ary_array) { + retval = ar->ary_array - ar->ary_alloc; + Copy(ar->ary_array, ar->ary_alloc, ar->ary_max+1, STR*); + Zero(ar->ary_alloc+ar->ary_max+1, retval, STR*); + ar->ary_max += retval; + ar->ary_array -= retval; + if (key > ar->ary_max - 10) { + newmax = key + ar->ary_max; + goto resize; + } + } + else { + newmax = key + ar->ary_max / 5; + resize: + Renew(ar->ary_alloc,newmax+1, STR*); + Zero(&ar->ary_alloc[ar->ary_max+1], newmax - ar->ary_max, STR*); + ar->ary_array = ar->ary_alloc; + ar->ary_max = newmax; + } } - 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; + if ((ar->ary_flags & ARF_REAL) && ar->ary_fill < key) { + while (++ar->ary_fill < key) { + if (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) + if (retval && (ar->ary_flags & ARF_REAL)) str_free(ar->ary_array[key]); ar->ary_array[key] = val; return retval; } -bool -adelete(ar,key) -register ARRAY *ar; -int key; -{ - if (key < 0 || key > ar->ary_max) - return FALSE; - if (ar->ary_array[key]) { - str_free(ar->ary_array[key]); - ar->ary_array[key] = Nullstr; - return TRUE; - } - return FALSE; -} - ARRAY * anew(stab) STAB *stab; { - register ARRAY *ar = (ARRAY*)safemalloc(sizeof(ARRAY)); + register ARRAY *ar; - ar->ary_array = (STR**) safemalloc(5 * sizeof(STR*)); - ar->ary_magic = str_new(0); - ar->ary_magic->str_link.str_magic = stab; + New(1,ar,1,ARRAY); + Newz(2,ar->ary_alloc,5,STR*); + ar->ary_array = ar->ary_alloc; + ar->ary_magic = Str_new(7,0); + str_magic(ar->ary_magic, stab, '#', Nullch, 0); ar->ary_fill = -1; ar->ary_index = -1; ar->ary_max = 4; - bzero((char*)ar->ary_array, 5 * sizeof(STR*)); + ar->ary_flags = ARF_REAL; + return ar; +} + +ARRAY * +afake(stab,size,strp) +STAB *stab; +int size; +STR **strp; +{ + register ARRAY *ar; + + New(3,ar,1,ARRAY); + New(4,ar->ary_alloc,size+1,STR*); + Copy(strp,ar->ary_alloc,size,STR*); + ar->ary_array = ar->ary_alloc; + ar->ary_magic = Str_new(8,0); + str_magic(ar->ary_magic, stab, '#', Nullch, 0); + ar->ary_fill = size - 1; + ar->ary_index = -1; + ar->ary_max = size - 1; + ar->ary_flags = 0; return ar; } @@ -88,12 +135,16 @@ register ARRAY *ar; { register int key; - if (!ar) + if (!ar || !(ar->ary_flags & ARF_REAL)) return; + if (key = ar->ary_array - ar->ary_alloc) { + ar->ary_max += key; + ar->ary_array -= key; + } 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*)); + Zero(ar->ary_array, ar->ary_max+1, STR*); } void @@ -104,11 +155,17 @@ register ARRAY *ar; if (!ar) return; - for (key = 0; key <= ar->ary_max; key++) - str_free(ar->ary_array[key]); + if (key = ar->ary_array - ar->ary_alloc) { + ar->ary_max += key; + ar->ary_array -= key; + } + if (ar->ary_flags & ARF_REAL) { + 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); + Safefree(ar->ary_alloc); + Safefree(ar); } bool @@ -141,13 +198,21 @@ register int num; if (num <= 0) return; - astore(ar,ar->ary_fill+num,(STR*)0); /* maybe extend array */ - dstr = ar->ary_array + ar->ary_fill; - sstr = dstr - num; - for (i = ar->ary_fill; i >= 0; i--) { - *dstr-- = *sstr--; + if (ar->ary_array - ar->ary_alloc >= num) { + ar->ary_max += num; + ar->ary_fill += num; + while (num--) + *--ar->ary_array = Nullstr; + } + else { + (void)astore(ar,ar->ary_fill+num,(STR*)0); /* maybe extend array */ + dstr = ar->ary_array + ar->ary_fill; + sstr = dstr - num; + for (i = ar->ary_fill; i >= 0; i--) { + *dstr-- = *sstr--; + } + Zero(ar->ary_array, num, STR*); } - bzero((char*)(ar->ary_array), num * sizeof(STR*)); } STR * @@ -158,10 +223,10 @@ register ARRAY *ar; if (ar->ary_fill < 0) return Nullstr; - retval = ar->ary_array[0]; - bcopy((char*)(ar->ary_array+1),(char*)ar->ary_array, - ar->ary_fill * sizeof(STR*)); - ar->ary_array[ar->ary_fill--] = Nullstr; + retval = *ar->ary_array; + *(ar->ary_array++) = Nullstr; + ar->ary_max--; + ar->ary_fill--; return retval; } @@ -181,33 +246,5 @@ int fill; if (fill <= ar->ary_max) ar->ary_fill = fill; else - astore(ar,fill,Nullstr); -} - -void -ajoin(ar,delim,str) -register ARRAY *ar; -char *delim; -register STR *str; -{ - register int i; - register int len; - register int dlen; - - if (ar->ary_fill < 0) { - str_set(str,""); - STABSET(str); - return; - } - dlen = strlen(delim); - len = ar->ary_fill * dlen; /* account for delimiters */ - for (i = ar->ary_fill; i >= 0; i--) - len += str_len(ar->ary_array[i]); - str_grow(str,len); /* preallocate for efficiency */ - str_sset(str,ar->ary_array[0]); - for (i = 1; i <= ar->ary_fill; i++) { - str_ncat(str,delim,dlen); - str_scat(str,ar->ary_array[i]); - } - STABSET(str); + (void)astore(ar,fill,Nullstr); } diff --git a/array.h b/array.h index d8dfe54..d489f64 100644 --- a/array.h +++ b/array.h @@ -1,22 +1,30 @@ -/* $Header: array.h,v 2.0 88/06/05 00:08:21 root Exp $ +/* $Header: array.h,v 3.0 89/10/18 15:08:41 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: array.h,v $ - * Revision 2.0 88/06/05 00:08:21 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:08:41 lwall + * 3.0 baseline * */ struct atbl { STR **ary_array; + STR **ary_alloc; STR *ary_magic; int ary_max; int ary_fill; int ary_index; + char ary_flags; }; +#define ARF_REAL 1 /* free old entries */ + STR *afetch(); bool astore(); -bool adelete(); STR *apop(); STR *ashift(); void afree(); @@ -24,3 +32,4 @@ void aclear(); bool apush(); int alen(); ARRAY *anew(); +ARRAY *afake(); diff --git a/client b/client new file mode 100644 index 0000000..97ecbc2 --- /dev/null +++ b/client @@ -0,0 +1,34 @@ +#!./perl + +$pat = 'S n C4 x8'; +$inet = 2; +$echo = 7; +$smtp = 25; +$nntp = 119; +$test = 2345; + +$SIG{'INT'} = 'dokill'; + +$this = pack($pat,$inet,0, 128,149,13,43); +$that = pack($pat,$inet,$test,127,0,0,1); + +if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } +if (bind(S,$this)) { print "bind ok\n"; } else { die $!; } +if (connect(S,$that)) { print "connect ok\n"; } else { die $!; } + +select(S); $| = 1; select(stdout); + +if ($child = fork) { + while (<>) { + print S; + } + sleep 3; + do dokill(); +} +else { + while () { + print; + } +} + +sub dokill { kill 9,$child if $child; } diff --git a/cmd.c b/cmd.c index f5649b6..682bd08 100644 --- a/cmd.c +++ b/cmd.c @@ -1,44 +1,60 @@ -/* $Header: cmd.c,v 2.0 88/06/05 00:08:24 root Exp $ +/* $Header: cmd.c,v 3.0 89/10/18 15:09:02 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: cmd.c,v $ - * Revision 2.0 88/06/05 00:08:24 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:09:02 lwall + * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" +#ifdef I_VARARGS +# include +#endif + static STR str_chop; +void grow_dlevel(); + /* This is the main command loop. We try to spend as much time in this loop * as possible, so lots of optimizations do their activities in here. This * means things get a little sloppy. */ -STR * -cmd_exec(cmd) +int +cmd_exec(cmd,gimme,sp) #ifdef cray /* nobody else has complained yet */ CMD *cmd; #else register CMD *cmd; #endif +int gimme; +int sp; { SPAT *oldspat; int oldsave; + int aryoptsave; #ifdef DEBUGGING int olddlevel; int entdlevel; #endif - register STR *retstr; + register STR *retstr = &str_undef; register char *tmps; register int cmdflags; register int match; register char *go_to = goto_targ; + register int newsp = -2; + register STR **st = stack->ary_array; FILE *fp; ARRAY *ar; - retstr = &str_no; + lastsize = 0; #ifdef DEBUGGING entdlevel = dlevel; #endif @@ -46,8 +62,17 @@ tail_recursion_entry: #ifdef DEBUGGING dlevel = entdlevel; #endif - if (cmd == Nullcmd) - return retstr; +#ifdef TAINT + tainted = 0; /* Each statement is presumed innocent */ +#endif + if (cmd == Nullcmd) { + if (gimme == G_ARRAY && newsp > -2) + return newsp; + else { + st[++sp] = retstr; + return sp; + } + } cmdflags = cmd->c_flags; /* hopefully load register */ if (go_to) { if (cmd->c_label && strEQ(go_to,cmd->c_label)) @@ -61,28 +86,50 @@ tail_recursion_entry: olddlevel = dlevel; #endif retstr = &str_yes; + newsp = -2; if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING if (debug) { debname[dlevel] = 't'; - debdelim[dlevel++] = '_'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); } #endif - retstr = cmd_exec(cmd->ucmd.ccmd.cc_true); + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; } - if (!goto_targ) { + if (!goto_targ) go_to = Nullch; - } else { - retstr = &str_no; - if (cmd->ucmd.ccmd.cc_alt) { + curspat = oldspat; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); #ifdef DEBUGGING - if (debug) { - debname[dlevel] = 'e'; - debdelim[dlevel++] = '_'; - } + dlevel = olddlevel; #endif - retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt); + cmd = cmd->ucmd.ccmd.cc_alt; + goto tail_recursion_entry; + case C_ELSE: + oldspat = curspat; + oldsave = savestack->ary_fill; +#ifdef DEBUGGING + olddlevel = dlevel; +#endif + retstr = &str_undef; + newsp = -2; + if (cmd->ucmd.ccmd.cc_true) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 'e'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; } if (!goto_targ) go_to = Nullch; @@ -97,19 +144,31 @@ tail_recursion_entry: case C_WHILE: if (!(cmdflags & CF_ONCE)) { cmdflags |= CF_ONCE; - loop_ptr++; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } loop_stack[loop_ptr].loop_label = cmd->c_label; + loop_stack[loop_ptr].loop_sp = sp; #ifdef DEBUGGING if (debug & 4) { deb("(Pushing label #%d %s)\n", - loop_ptr,cmd->c_label); + loop_ptr, cmd->c_label ? cmd->c_label : ""); } #endif } switch (setjmp(loop_stack[loop_ptr].loop_env)) { case O_LAST: /* not done unless go_to found */ go_to = Nullch; - retstr = &str_no; + st = stack->ary_array; /* possibly reallocated */ + if (lastretstr) { + retstr = lastretstr; + newsp = -2; + } + else { + newsp = sp + lastsize; + retstr = st[newsp]; + } #ifdef DEBUGGING olddlevel = dlevel; #endif @@ -133,10 +192,14 @@ tail_recursion_entry: #ifdef DEBUGGING if (debug) { debname[dlevel] = 't'; - debdelim[dlevel++] = '_'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); } #endif - cmd_exec(cmd->ucmd.ccmd.cc_true); + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; } if (!goto_targ) { go_to = Nullch; @@ -149,10 +212,14 @@ tail_recursion_entry: #ifdef DEBUGGING if (debug) { debname[dlevel] = 'a'; - debdelim[dlevel++] = '_'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); } #endif - cmd_exec(cmd->ucmd.ccmd.cc_alt); + newsp = cmd_exec(cmd->ucmd.ccmd.cc_alt,gimme,sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; } if (goto_targ) break; @@ -162,12 +229,13 @@ tail_recursion_entry: cmd = cmd->c_next; if (cmd && cmd->c_head == cmd) /* reached end of while loop */ - return retstr; /* targ isn't in this block */ + return sp; /* targ isn't in this block */ if (cmdflags & CF_ONCE) { #ifdef DEBUGGING if (debug & 4) { + tmps = loop_stack[loop_ptr].loop_label; deb("(Popping label #%d %s)\n",loop_ptr, - loop_stack[loop_ptr].loop_label); + tmps ? tmps : "" ); } #endif loop_ptr--; @@ -191,11 +259,11 @@ until_loop: curspat); } debname[dlevel] = cmdname[cmd->c_type][0]; - debdelim[dlevel++] = '!'; + debdelim[dlevel] = '!'; + if (++dlevel >= dlmax) + grow_dlevel(); } #endif - while (tmps_max > tmps_base) /* clean up after last eval */ - str_free(tmps_list[tmps_max--]); /* Here is some common optimization */ @@ -204,12 +272,14 @@ until_loop: case CFT_FALSE: retstr = cmd->c_short; + newsp = -2; match = FALSE; if (cmdflags & CF_NESURE) goto maybe; break; case CFT_TRUE: retstr = cmd->c_short; + newsp = -2; match = TRUE; if (cmdflags & CF_EQSURE) goto flipmaybe; @@ -217,6 +287,7 @@ until_loop: case CFT_REG: retstr = STAB_STR(cmd->c_stab); + newsp = -2; match = str_true(retstr); /* => retstr = retstr, c2 should fix */ if (cmdflags & (match ? CF_EQSURE : CF_NESURE)) goto flipmaybe; @@ -232,10 +303,23 @@ until_loop: /* FALL THROUGH */ case CFT_STROP: /* string op optimization */ retstr = STAB_STR(cmd->c_stab); + newsp = -2; +#ifndef I286 if (*cmd->c_short->str_ptr == *str_get(retstr) && - strnEQ(cmd->c_short->str_ptr, str_get(retstr), - cmd->c_slen) ) { + bcmp(cmd->c_short->str_ptr, str_get(retstr), + cmd->c_slen) == 0 ) { if (cmdflags & CF_EQSURE) { + if (sawampersand && (cmdflags & CF_OPTIMIZE) != CFT_STROP) { + curspat = Nullspat; + if (leftstab) + str_nset(stab_val(leftstab),"",0); + if (amperstab) + str_sset(stab_val(amperstab),cmd->c_short); + if (rightstab) + str_nset(stab_val(rightstab), + retstr->str_ptr + cmd->c_slen, + retstr->str_cur - cmd->c_slen); + } match = !(cmdflags & CF_FIRSTNEG); retstr = &str_yes; goto flipmaybe; @@ -246,23 +330,76 @@ until_loop: retstr = &str_no; goto flipmaybe; } +#else + { + char *zap1, *zap2, zap1c, zap2c; + int zaplen; + + zap1 = cmd->c_short->str_ptr; + zap2 = str_get(retstr); + zap1c = *zap1; + zap2c = *zap2; + zaplen = cmd->c_slen; + if ((zap1c == zap2c) && (bcmp(zap1, zap2, zaplen) == 0)) { + if (cmdflags & CF_EQSURE) { + if (sawampersand && + (cmdflags & CF_OPTIMIZE) != CFT_STROP) { + curspat = Nullspat; + if (leftstab) + str_nset(stab_val(leftstab),"",0); + if (amperstab) + str_sset(stab_val(amperstab),cmd->c_short); + if (rightstab) + str_nset(stab_val(rightstab), + retstr->str_ptr + cmd->c_slen, + retstr->str_cur - cmd->c_slen); + } + match = !(cmdflags & CF_FIRSTNEG); + retstr = &str_yes; + goto flipmaybe; + } + } + else if (cmdflags & CF_NESURE) { + match = cmdflags & CF_FIRSTNEG; + retstr = &str_no; + goto flipmaybe; + } + } +#endif break; /* must evaluate */ case CFT_SCAN: /* non-anchored search */ scanner: retstr = STAB_STR(cmd->c_stab); - if (retstr->str_pok == 5) + newsp = -2; + if (retstr->str_pok & SP_STUDIED) 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); +#ifndef lint + tmps = fbminstr((unsigned char*)tmps, + (unsigned char*)tmps + retstr->str_cur, cmd->c_short); +#endif } if (tmps) { if (cmdflags & CF_EQSURE) { - ++*(long*)&cmd->c_short->str_nval; + ++cmd->c_short->str_u.str_useful; + if (sawampersand) { + curspat = Nullspat; + if (leftstab) + str_nset(stab_val(leftstab),retstr->str_ptr, + tmps - retstr->str_ptr); + if (amperstab) + str_sset(stab_val(amperstab),cmd->c_short); + if (rightstab) + str_nset(stab_val(rightstab), + tmps + cmd->c_short->str_cur, + retstr->str_cur - (tmps - retstr->str_ptr) - + cmd->c_short->str_cur); + } match = !(cmdflags & CF_FIRSTNEG); retstr = &str_yes; goto flipmaybe; @@ -272,13 +409,13 @@ until_loop: } else { if (cmdflags & CF_NESURE) { - ++*(long*)&cmd->c_short->str_nval; + ++cmd->c_short->str_u.str_useful; match = cmdflags & CF_FIRSTNEG; retstr = &str_no; goto flipmaybe; } } - if (--*(long*)&cmd->c_short->str_nval < 0) { + if (--cmd->c_short->str_u.str_useful < 0) { str_free(cmd->c_short); cmd->c_short = Nullstr; cmdflags &= ~CF_OPTIMIZE; @@ -289,24 +426,29 @@ until_loop: case CFT_NUMOP: /* numeric op optimization */ retstr = STAB_STR(cmd->c_stab); + newsp = -2; switch (cmd->c_slen) { case O_EQ: - match = (str_gnum(retstr) == cmd->c_short->str_nval); + if (dowarn) { + if ((!retstr->str_nok && !looks_like_number(retstr))) + warn("Possible use of == on string value"); + } + match = (str_gnum(retstr) == cmd->c_short->str_u.str_nval); break; case O_NE: - match = (str_gnum(retstr) != cmd->c_short->str_nval); + match = (str_gnum(retstr) != cmd->c_short->str_u.str_nval); break; case O_LT: - match = (str_gnum(retstr) < cmd->c_short->str_nval); + match = (str_gnum(retstr) < cmd->c_short->str_u.str_nval); break; case O_LE: - match = (str_gnum(retstr) <= cmd->c_short->str_nval); + match = (str_gnum(retstr) <= cmd->c_short->str_u.str_nval); break; case O_GT: - match = (str_gnum(retstr) > cmd->c_short->str_nval); + match = (str_gnum(retstr) > cmd->c_short->str_u.str_nval); break; case O_GE: - match = (str_gnum(retstr) >= cmd->c_short->str_nval); + match = (str_gnum(retstr) >= cmd->c_short->str_u.str_nval); break; } if (match) { @@ -323,86 +465,111 @@ until_loop: 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(); + if (!stab_io(last_in_stab)) + stab_io(last_in_stab) = 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]) + fp = stab_io(last_in_stab)->ifp; + retstr = stab_val(defstab); + newsp = -2; + if (fp && str_gets(retstr, fp, 0)) { + if (*retstr->str_ptr == '0' && retstr->str_cur == 1) match = FALSE; else match = TRUE; - last_in_stab->stab_io->lines++; + stab_io(last_in_stab)->lines++; } - else if (last_in_stab->stab_io->flags & IOF_ARGV) + else if (stab_io(last_in_stab)->flags & IOF_ARGV) goto doeval; /* doesn't necessarily count as EOF yet */ else { - retstr = &str_no; + retstr = &str_undef; match = FALSE; } goto flipmaybe; case CFT_EVAL: break; case CFT_UNFLIP: - retstr = eval(cmd->c_expr,Null(STR***),-1); + while (tmps_max > tmps_base) /* clean up after last eval */ + str_free(tmps_list[tmps_max--]); + newsp = eval(cmd->c_expr,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; match = str_true(retstr); if (cmd->c_expr->arg_type == O_FLIP) /* undid itself? */ cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd); goto maybe; case CFT_CHOP: - retstr = cmd->c_stab->stab_val; + retstr = stab_val(cmd->c_stab); + newsp = -2; match = (retstr->str_cur != 0); tmps = str_get(retstr); tmps += retstr->str_cur - match; - str_set(&str_chop,tmps); + str_nset(&str_chop,tmps,match); *tmps = '\0'; retstr->str_nok = 0; 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; + ar = stab_array(cmd->c_expr[1].arg_ptr.arg_stab); 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 < 0) { /* first time through here? */ + aryoptsave = savestack->ary_fill; + savesptr(&stab_val(cmd->c_stab)); + saveint(&ar->ary_index); + } - if (match >= ar->ary_fill) { - ar->ary_index = -1; -/* cmd->c_stab->stab_val = cmd->c_short; - Can't be done in LAST */ + if (match >= ar->ary_fill) { /* we're in LAST, probably */ + retstr = &str_undef; + ar->ary_index = -1; /* this is actually redundant */ match = FALSE; } else { match++; - retstr = cmd->c_stab->stab_val = ar->ary_array[match]; + retstr = stab_val(cmd->c_stab) = ar->ary_array[match]; ar->ary_index = match; match = TRUE; } + newsp = -2; goto maybe; } /* we have tried to make this normal case as abnormal as possible */ doeval: - lastretstr = retstr; - retstr = eval(cmd->c_expr,Null(STR***),-1); - match = str_true(retstr); + if (gimme == G_ARRAY) { + lastretstr = Nullstr; + lastspbase = sp; + lastsize = newsp - sp; + } + else + lastretstr = retstr; + while (tmps_max > tmps_base) /* clean up after last eval */ + str_free(tmps_list[tmps_max--]); + newsp = eval(cmd->c_expr,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + if (newsp > sp) + match = str_true(retstr); + else + match = FALSE; goto maybe; /* if flipflop was true, flop it */ flipmaybe: if (match && cmdflags & CF_FLIP) { + while (tmps_max > tmps_base) /* clean up after last eval */ + str_free(tmps_list[tmps_max--]); if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */ - retstr = eval(cmd->c_expr,Null(STR***),-1);/*let eval undo it*/ + newsp = eval(cmd->c_expr,G_SCALAR,sp);/*let eval undo it*/ cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd); } else { - retstr = eval(cmd->c_expr,Null(STR***),-1);/* let eval do it */ + newsp = eval(cmd->c_expr,G_SCALAR,sp);/* 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); } @@ -418,9 +585,12 @@ until_loop: maybe: if (cmdflags & CF_INVERT) match = !match; - if (!match && cmd->c_type != C_IF) + if (!match) goto next_cmd; } +#ifdef TAINT + tainted = 0; /* modifier doesn't affect regular expression */ +#endif /* now to do the actual command, if any */ @@ -429,39 +599,87 @@ until_loop: fatal("panic: cmd_exec"); case C_EXPR: /* evaluated for side effects */ if (cmd->ucmd.acmd.ac_expr) { /* more to do? */ - lastretstr = retstr; - retstr = eval(cmd->ucmd.acmd.ac_expr,Null(STR***),-1); + if (gimme == G_ARRAY) { + lastretstr = Nullstr; + lastspbase = sp; + lastsize = newsp - sp; + } + else + lastretstr = retstr; + while (tmps_max > tmps_base) /* clean up after last eval */ + str_free(tmps_list[tmps_max--]); + newsp = eval(cmd->ucmd.acmd.ac_expr,gimme && (cmdflags&CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; } break; + case C_NSWITCH: + match = (int)str_gnum(STAB_STR(cmd->c_stab)); + goto doswitch; + case C_CSWITCH: + match = *(str_get(STAB_STR(cmd->c_stab))) & 255; + doswitch: + match -= cmd->ucmd.scmd.sc_offset; + if (match < 0) + match = 0; + else if (match > cmd->ucmd.scmd.sc_max) + match = cmd->c_slen; + cmd = cmd->ucmd.scmd.sc_next[match]; + goto tail_recursion_entry; + case C_NEXT: + cmd = cmd->ucmd.ccmd.cc_alt; + goto tail_recursion_entry; + case C_ELSIF: + fatal("panic: ELSIF"); case C_IF: oldspat = curspat; oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif - if (match) { - retstr = &str_yes; - if (cmd->ucmd.ccmd.cc_true) { + retstr = &str_yes; + newsp = -2; + if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING - if (debug) { - debname[dlevel] = 't'; - debdelim[dlevel++] = '_'; - } -#endif - retstr = cmd_exec(cmd->ucmd.ccmd.cc_true); + if (debug) { + debname[dlevel] = 't'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; } - else { - retstr = &str_no; - if (cmd->ucmd.ccmd.cc_alt) { + curspat = oldspat; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); #ifdef DEBUGGING - if (debug) { - debname[dlevel] = 'e'; - debdelim[dlevel++] = '_'; - } + dlevel = olddlevel; #endif - retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt); + cmd = cmd->ucmd.ccmd.cc_alt; + goto tail_recursion_entry; + case C_ELSE: + oldspat = curspat; + oldsave = savestack->ary_fill; +#ifdef DEBUGGING + olddlevel = dlevel; +#endif + retstr = &str_undef; + newsp = -2; + if (cmd->ucmd.ccmd.cc_true) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 'e'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; } curspat = oldspat; if (savestack->ary_fill > oldsave) @@ -474,18 +692,31 @@ until_loop: case C_WHILE: if (!(cmdflags & CF_ONCE)) { /* first time through here? */ cmdflags |= CF_ONCE; - loop_ptr++; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } loop_stack[loop_ptr].loop_label = cmd->c_label; + loop_stack[loop_ptr].loop_sp = sp; #ifdef DEBUGGING if (debug & 4) { deb("(Pushing label #%d %s)\n", - loop_ptr,cmd->c_label); + loop_ptr, cmd->c_label ? cmd->c_label : ""); } #endif } switch (setjmp(loop_stack[loop_ptr].loop_env)) { case O_LAST: - retstr = lastretstr; + /* retstr = lastretstr; */ + st = stack->ary_array; /* possibly reallocated */ + if (lastretstr) { + retstr = lastretstr; + newsp = -2; + } + else { + newsp = sp + lastsize; + retstr = st[newsp]; + } curspat = oldspat; if (savestack->ary_fill > oldsave) restorelist(oldsave); @@ -508,10 +739,14 @@ until_loop: #ifdef DEBUGGING if (debug) { debname[dlevel] = 't'; - debdelim[dlevel++] = '_'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); } #endif - cmd_exec(cmd->ucmd.ccmd.cc_true); + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; } /* actually, this spot is rarely reached anymore since the above * cmd_exec() returns through longjmp(). Hooray for structure. @@ -524,10 +759,14 @@ until_loop: #ifdef DEBUGGING if (debug) { debname[dlevel] = 'a'; - debdelim[dlevel++] = '_'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); } #endif - cmd_exec(cmd->ucmd.ccmd.cc_alt); + newsp = cmd_exec(cmd->ucmd.ccmd.cc_alt,gimme,sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; } finish_while: curspat = oldspat; @@ -550,20 +789,20 @@ until_loop: if (cmdflags & CF_ONCE) { #ifdef DEBUGGING if (debug & 4) { - deb("(Popping label #%d %s)\n",loop_ptr, - loop_stack[loop_ptr].loop_label); + tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, tmps ? tmps : ""); } #endif loop_ptr--; - if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY) { - cmd->c_stab->stab_val = cmd->c_short; - } + if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY) + restorelist(aryoptsave); } cmd = cmd->c_next; goto tail_recursion_entry; } #ifdef DEBUGGING +# ifndef VARARGS /*VARARGS1*/ deb(pat,a1,a2,a3,a4,a5,a6,a7,a8) char *pat; @@ -575,6 +814,25 @@ char *pat; fprintf(stderr,"%c%c ",debname[i],debdelim[i]); fprintf(stderr,pat,a1,a2,a3,a4,a5,a6,a7,a8); } +# else +/*VARARGS1*/ +deb(va_alist) +va_dcl +{ + va_list args; + char *pat; + register int i; + + va_start(args); + fprintf(stderr,"%-4ld",(long)line); + for (i=0; ic_flags; } +ARRAY * +saveary(stab) +STAB *stab; +{ + register STR *str; + + str = Str_new(10,0); + str->str_state = SS_SARY; + str->str_u.str_stab = stab; + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)stab_array(stab); + (void)apush(savestack,str); /* save array ptr */ + stab_xarray(stab) = Null(ARRAY*); + return stab_xarray(aadd(stab)); +} + +HASH * +savehash(stab) +STAB *stab; +{ + register STR *str; + + str = Str_new(11,0); + str->str_state = SS_SHASH; + str->str_u.str_stab = stab; + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)stab_hash(stab); + (void)apush(savestack,str); /* save hash ptr */ + stab_xhash(stab) = Null(HASH*); + return stab_xhash(hadd(stab)); +} + +void +saveitem(item) +register STR *item; +{ + register STR *str; + + (void)apush(savestack,item); /* remember the pointer */ + str = Str_new(12,0); + str_sset(str,item); + (void)apush(savestack,str); /* remember the value */ +} + +void +saveint(intp) +int *intp; +{ + register STR *str; + + str = Str_new(13,0); + str->str_state = SS_SINT; + str->str_u.str_useful = (long)*intp; /* remember value */ + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)intp; /* remember pointer */ + (void)apush(savestack,str); +} + +void +savelong(longp) +long *longp; +{ + register STR *str; + + str = Str_new(14,0); + str->str_state = SS_SLONG; + str->str_u.str_useful = *longp; /* remember value */ + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)longp; /* remember pointer */ + (void)apush(savestack,str); +} + +void +savesptr(sptr) +STR **sptr; +{ + register STR *str; + + str = Str_new(15,0); + str->str_state = SS_SSTRP; + str->str_magic = *sptr; /* remember value */ + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)sptr; /* remember pointer */ + (void)apush(savestack,str); +} + +void +savenostab(stab) +STAB *stab; +{ + register STR *str; + + str = Str_new(16,0); + str->str_state = SS_SNSTAB; + str->str_magic = (STR*)stab; /* remember which stab to free */ + (void)apush(savestack,str); +} + +void +savehptr(hptr) +HASH **hptr; +{ + register STR *str; + + str = Str_new(17,0); + str->str_state = SS_SHPTR; + str->str_u.str_hash = *hptr; /* remember value */ + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)hptr; /* remember pointer */ + (void)apush(savestack,str); +} + void savelist(sarg,maxsarg) register STR **sarg; @@ -598,10 +986,10 @@ int maxsarg; register int i; for (i = 1; i <= maxsarg; i++) { - apush(savestack,sarg[i]); /* remember the pointer */ - str = str_new(0); + (void)apush(savestack,sarg[i]); /* remember the pointer */ + str = Str_new(18,0); str_sset(str,sarg[i]); - apush(savestack,str); /* remember the value */ + (void)apush(savestack,str); /* remember the value */ } } @@ -611,12 +999,70 @@ int base; { register STR *str; register STR *value; + register STAB *stab; + if (base < -1) + fatal("panic: corrupt saved stack index"); while (savestack->ary_fill > base) { value = apop(savestack); - str = apop(savestack); - str_sset(str,value); - STABSET(str); - str_free(value); + switch (value->str_state) { + case SS_NORM: /* normal string */ + case SS_INCR: + str = apop(savestack); + str_replace(str,value); + STABSET(str); + break; + case SS_SARY: /* array reference */ + stab = value->str_u.str_stab; + afree(stab_xarray(stab)); + stab_xarray(stab) = (ARRAY*)value->str_ptr; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SHASH: /* hash reference */ + stab = value->str_u.str_stab; + (void)hfree(stab_xhash(stab)); + stab_xhash(stab) = (HASH*)value->str_ptr; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SINT: /* int reference */ + *((int*)value->str_ptr) = (int)value->str_u.str_useful; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SLONG: /* long reference */ + *((long*)value->str_ptr) = value->str_u.str_useful; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SSTRP: /* STR* reference */ + *((STR**)value->str_ptr) = value->str_magic; + value->str_magic = Nullstr; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SHPTR: /* HASH* reference */ + *((HASH**)value->str_ptr) = value->str_u.str_hash; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SNSTAB: + stab = (STAB*)value->str_magic; + value->str_magic = Nullstr; + (void)stab_clear(stab); + str_free(value); + break; + default: + fatal("panic: restorelist inconsistency"); + } } } + +void +grow_dlevel() +{ + dlmax += 128; + Renew(debname, dlmax, char); + Renew(debdelim, dlmax, char); +} diff --git a/cmd.h b/cmd.h index e320ee2..5e880a4 100644 --- a/cmd.h +++ b/cmd.h @@ -1,16 +1,26 @@ -/* $Header: cmd.h,v 2.0 88/06/05 00:08:28 root Exp $ +/* $Header: cmd.h,v 3.0 89/10/18 15:09:15 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: cmd.h,v $ - * Revision 2.0 88/06/05 00:08:28 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:09:15 lwall + * 3.0 baseline * */ #define C_NULL 0 #define C_IF 1 -#define C_WHILE 2 -#define C_EXPR 3 +#define C_ELSE 2 +#define C_WHILE 3 #define C_BLOCK 4 +#define C_EXPR 5 +#define C_NEXT 6 +#define C_ELSIF 7 /* temporary--turns into an IF + ELSE */ +#define C_CSWITCH 8 /* created by switch optimization in block_head() */ +#define C_NSWITCH 9 /* likewise */ #ifdef DEBUGGING #ifndef DOINIT @@ -19,21 +29,15 @@ extern char *cmdname[]; char *cmdname[] = { "NULL", "IF", + "ELSE", "WHILE", - "EXPR", "BLOCK", - "5", - "6", - "7", - "8", - "9", - "10", - "11", - "12", - "13", - "14", - "15", - "16" + "EXPR", + "NEXT", + "ELSIF", + "CSWITCH", + "NSWITCH", + "10" }; #endif #endif /* DEBUGGING */ @@ -48,6 +52,7 @@ char *cmdname[] = { #define CF_INVERT 04000 /* it's an "unless" or an "until" */ #define CF_ONCE 010000 /* we've already pushed the label on the stack */ #define CF_FLIP 020000 /* on a match do flipflop */ +#define CF_TERM 040000 /* value of this cmd might be returned */ #define CFT_FALSE 0 /* c_expr is always false */ #define CFT_TRUE 1 /* c_expr is always true */ @@ -62,6 +67,7 @@ char *cmdname[] = { #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 */ +#define CFT_CCLASS 13 /* c_expr must start with one of these characters */ #ifdef DEBUGGING #ifndef DOINIT @@ -81,7 +87,8 @@ char *cmdopt[] = { "ARRAY", "INDGETS", "NUMOP", - "13" + "CCLASS", + "14" }; #endif #endif /* DEBUGGING */ @@ -93,7 +100,13 @@ struct acmd { struct ccmd { CMD *cc_true; /* normal code to do on if and while */ - CMD *cc_alt; /* else code or continue code */ + CMD *cc_alt; /* else cmd ptr or continue code */ +}; + +struct scmd { + CMD **sc_next; /* array of pointers to commands */ + short sc_offset; /* first value - 1 */ + short sc_max; /* last value + 1 */ }; struct cmd { @@ -107,6 +120,7 @@ struct cmd { union ucmd { struct acmd acmd; /* normal command */ struct ccmd ccmd; /* compound command */ + struct scmd scmd; /* switch command */ } ucmd; short c_slen; /* len of c_short, if not null */ short c_flags; /* optimization flags--see above */ @@ -120,11 +134,11 @@ struct cmd { EXT CMD *main_root INIT(Nullcmd); EXT CMD *eval_root INIT(Nullcmd); -EXT struct compcmd { +struct compcmd { CMD *comp_true; CMD *comp_alt; }; void opt_arg(); void evalstatic(); -STR *cmd_exec(); +int cmd_exec(); diff --git a/config.H b/config.H index bb9eb6b..a21a110 100644 --- a/config.H +++ b/config.H @@ -20,8 +20,48 @@ * This symbol, if defined, indicates that the program is running under * VMS. It is currently only set in conjunction with the EUNICE symbol. */ -#/*undef EUNICE /**/ -#/*undef VMS /**/ +/*#undef EUNICE /**/ +/*#undef VMS /**/ + +/* BIN: + * This symbol holds the name of the directory in which the user wants + * to put publicly executable images for the package in question. It + * is most often a local directory such as /usr/local/bin. + */ +#define BIN "/usr/local/bin" /**/ + +/* BYTEORDER: + * This symbol contains an encoding of the order of bytes in a long. + * Usual values (in octal) are 01234, 04321, 02143, 03412... + */ +#define BYTEORDER 01234 /**/ + +/* 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". + */ +/* 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 CPPSTDIN needs a minus + * to specify standard input, otherwise the value is "". + */ +#define CPPSTDIN "/lib/cpp" +#define CPPMINUS "" + +/* BCMP: + * This symbol, if defined, indicates that the bcmp routine is available + * to compare blocks of memory. If undefined, use memcmp. If that's + * not available, roll your own. + */ +#define BCMP /**/ + +/* BCOPY: + * This symbol, if defined, indicates that the bcopy routine is available + * to copy blocks of memory. Otherwise you should probably use memcpy(). + */ +#define BCOPY /**/ /* CHARSPRINTF: * This symbol is defined if this system declares "char *sprintf()" in @@ -31,6 +71,103 @@ */ #define CHARSPRINTF /**/ +/* CRYPT: + * This symbol, if defined, indicates that the crypt routine is available + * to encrypt passwords and the like. + */ +#define 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. + */ +#define DOSUID /**/ + +/* DUP2: + * This symbol, if defined, indicates that the dup2 routine is available + * to dup file descriptors. Otherwise you should use dup(). + */ +#define DUP2 /**/ + +/* FCHMOD: + * This symbol, if defined, indicates that the fchmod routine is available + * to change mode of opened files. If unavailable, use chmod(). + */ +#define FCHMOD /**/ + +/* FCHOWN: + * This symbol, if defined, indicates that the fchown routine is available + * to change ownership of opened files. If unavailable, use chown(). + */ +#define FCHOWN /**/ + +/* FCNTL: + * This symbol, if defined, indicates to the C program that it should + * include fcntl.h. + */ +#define FCNTL /**/ + +/* FLOCK: + * This symbol, if defined, indicates that the flock() routine is + * available to do file locking. + */ +#define FLOCK /**/ + +/* 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. + */ +#define GETGROUPS /**/ + +/* GETHOSTENT: + * This symbol, if defined, indicates that the gethostent() routine is + * available to lookup host names in some data base or other. + */ +#define GETHOSTENT /**/ + +/* GETPGRP: + * This symbol, if defined, indicates that the getpgrp() routine is + * available to get the current process group. + */ +#define GETPGRP /**/ + +/* GETPRIORITY: + * This symbol, if defined, indicates that the getpriority() routine is + * available to get a process's priority. + */ +#define GETPRIORITY /**/ + +/* HTONS: + * This symbol, if defined, indicates that the htons routine (and friends) + * are available to do network order byte swapping. + */ +/* HTONL: + * This symbol, if defined, indicates that the htonl routine (and friends) + * are available to do network order byte swapping. + */ +/* NTOHS: + * This symbol, if defined, indicates that the ntohs routine (and friends) + * are available to do network order byte swapping. + */ +/* NTOHL: + * This symbol, if defined, indicates that the ntohl routine (and friends) + * are available to do network order byte swapping. + */ +#define HTONS /**/ +#define HTONL /**/ +#define NTOHS /**/ +#define NTOHL /**/ + /* index: * This preprocessor symbol is defined, along with rindex, if the system * uses the strchr and strrchr routines instead. @@ -39,8 +176,151 @@ * This preprocessor symbol is defined, along with index, if the system * uses the strchr and strrchr routines instead. */ -#/*undef index strchr /* cultural */ -#/*undef rindex strrchr /* differences? */ +/*#undef index strchr /* cultural */ +/*#undef rindex strrchr /* differences? */ + +/* IOCTL: + * This symbol, if defined, indicates that sys/ioctl.h exists and should + * be included. + */ +#define IOCTL /**/ + +/* 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. + */ +#define KILLPG /**/ + +/* MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * to compare blocks of memory. If undefined, roll your own. + */ +#define MEMCMP /**/ + +/* 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. + */ +#define MEMCPY /**/ + +/* MKDIR: + * This symbol, if defined, indicates that the mkdir routine is available + * to create directories. Otherwise you should fork off a new process to + * exec /bin/mkdir. + */ +#define MKDIR /**/ + +/* NDBM: + * This symbol, if defined, indicates that ndbm.h exists and should + * be included. + */ +#define NDBM /**/ + +/* ODBM: + * This symbol, if defined, indicates that dbm.h exists and should + * be included. + */ +#define ODBM /**/ + +/* READDIR: + * This symbol, if defined, indicates that the readdir routine is available + * from the C library to create directories. + */ +#define READDIR /**/ + +/* RENAME: + * This symbol, if defined, indicates that the rename routine is available + * to rename files. Otherwise you should do the unlink(), link(), unlink() + * trick. + */ +#define RENAME /**/ + +/* RMDIR: + * This symbol, if defined, indicates that the rmdir routine is available + * to remove directories. Otherwise you should fork off a new process to + * exec /bin/rmdir. + */ +#define RMDIR /**/ + +/* SETEGID: + * This symbol, if defined, indicates that the setegid routine is available + * to change the effective gid of the current program. + */ +#define SETEGID /**/ + +/* SETEUID: + * This symbol, if defined, indicates that the seteuid routine is available + * to change the effective uid of the current program. + */ +#define SETEUID /**/ + +/* SETPGRP: + * This symbol, if defined, indicates that the setpgrp() routine is + * available to set the current process group. + */ +#define SETPGRP /**/ + +/* SETPRIORITY: + * This symbol, if defined, indicates that the setpriority() routine is + * available to set a process's priority. + */ +#define SETPRIORITY /**/ + +/* SETREGID: + * This symbol, if defined, indicates that the setregid routine is available + * to change the real and effective gid of the current program. + */ +#define SETREGID /**/ + +/* SETREUID: + * This symbol, if defined, indicates that the setreuid routine is available + * to change the real and effective uid of the current program. + */ +#define SETREUID /**/ + +/* SETRGID: + * This symbol, if defined, indicates that the setrgid routine is available + * to change the real gid of the current program. + */ +#define SETRGID /**/ + +/* SETRUID: + * This symbol, if defined, indicates that the setruid routine is available + * to change the real uid of the current program. + */ +#define SETRUID /**/ + +/* SOCKET: + * This symbol, if defined, indicates that the BSD socket interface is + * supported. + */ +/* SOCKETPAIR: + * This symbol, if defined, indicates that the BSD socketpair call is + * supported. + */ +/* OLDSOCKET: + * This symbol, if defined, indicates that the 4.1c BSD socket interface + * is supported instead of the 4.2/4.3 BSD socket interface. + */ +#define SOCKET /**/ + +#define SOCKETPAIR /**/ + +/*#undef OLDSOCKET /**/ + +/* STATBLOCKS: + * This symbol is defined if this system has a stat structure declaring + * st_blksize and st_blocks. + */ +#define STATBLOCKS /**/ + +/* STDSTDIO: + * This symbol is defined if this system has a FILE structure declaring + * _ptr and _cnt in stdio.h. + */ +#define STDSTDIO /**/ /* STRUCTCOPY: * This symbol, if defined, indicates that this C compiler knows how @@ -49,11 +329,156 @@ */ #define STRUCTCOPY /**/ +/* SYMLINK: + * This symbol, if defined, indicates that the symlink routine is available + * to create symbolic links. + */ +#define SYMLINK /**/ + +/* SYSCALL: + * This symbol, if defined, indicates that the syscall routine is available + * to call arbitrary system calls. If undefined, that's tough. + */ +#define SYSCALL /**/ + +/* TMINSYS: + * This symbol is defined if this system declares "struct tm" in + * in rather than . We can't just say + * -I/usr/include/sys because some systems have both time files, and + * the -I trick gets the wrong one. + */ +/* I_SYSTIME: + * This symbol is defined if this system has the file . + */ +/*#undef TMINSYS /**/ +#define I_SYSTIME /**/ + +/* VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include varargs.h. + */ +#define VARARGS /**/ + /* vfork: * This symbol, if defined, remaps the vfork routine to fork if the * vfork() routine isn't supported here. */ -#/*undef vfork fork /**/ +/*#undef vfork fork /**/ + +/* VOIDSIG: + * This symbol is defined if this system declares "void (*signal())()" in + * signal.h. The old way was to declare it as "int (*signal())()". It + * is up to the package author to declare things correctly based on the + * symbol. + */ +/*#undef VOIDSIG /**/ + +/* VPRINTF: + * This symbol, if defined, indicates that the vprintf routine is available + * to printf with a pointer to an argument list. If unavailable, you + * may need to write your own, probably in terms of _doprnt(). + */ +/* CHARVSPRINTF: + * This symbol is defined if this system has vsprintf() returning type + * (char*). The trend seems to be to declare it as "int vsprintf()". It + * is up to the package author to declare vsprintf correctly based on the + * symbol. + */ +/*#undef VPRINTF /**/ +/*#undef CHARVSPRINTF /**/ + +/* 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 gid_t /**/ + +/* I_DIRENT: + * This symbol, if defined, indicates to the C program that it should + * include dirent.h. + */ +/* DIRNAMLEN: + * This symbol, if defined, indicates to the C program that the length + * of directory entry names is provided by a d_namlen field. Otherwise + * you need to do strlen() on the d_name field. + */ +/*#undef I_DIRENT /**/ +#define DIRNAMLEN /**/ + +/* I_FCNTL: + * This symbol, if defined, indicates to the C program that it should + * include fcntl.h. + */ +#define I_FCNTL /**/ + +/* I_GRP: + * This symbol, if defined, indicates to the C program that it should + * include grp.h. + */ +#define I_GRP /**/ + +/* I_PWD: + * This symbol, if defined, indicates to the C program that it should + * include pwd.h. + */ +/* PWQUOTA: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +#define I_PWD /**/ +#define PWQUOTA /**/ +/*#undef PWAGE /**/ + +/* I_SYSDIR: + * This symbol, if defined, indicates to the C program that it should + * include sys/dir.h. + */ +#define I_SYSDIR /**/ + +/* I_SYSIOCTL: + * This symbol, if defined, indicates that sys/ioctl.h exists and should + * be included. + */ +#define I_SYSIOCTL /**/ + +/* I_VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include varargs.h. + */ +#define I_VARARGS /**/ + +/* INTSIZE: + * This symbol contains the size of an int, so that the C preprocessor + * can make decisions based on it. + */ +#define INTSIZE 4 /**/ + +/* RANDBITS: + * This symbol contains the number of bits of random number the rand() + * function produces. Usual values are 15, 16, and 31. + */ +#define RANDBITS 31 /**/ + +/* SIG_NAME: + * This symbol contains an list of signal names in order. + */ +#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CHLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","USR1","USR2" /**/ + +/* 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 char /**/ + +/* 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 uid_t /**/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this @@ -67,6 +492,7 @@ * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the + * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED @@ -78,3 +504,11 @@ #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. The program + * should be prepared to do ~ expansion. + */ +#define PRIVLIB "/usr/local/lib/perl" /**/ + diff --git a/config.h.SH b/config.h.SH index bb4b62b..5cf8ad1 100644 --- a/config.h.SH +++ b/config.h.SH @@ -37,6 +37,19 @@ sed <config.h -e 's!^#undef!/\*#undef!' #$d_eunice EUNICE /**/ #$d_eunice VMS /**/ +/* BIN: + * This symbol holds the name of the directory in which the user wants + * to put publicly executable images for the package in question. It + * is most often a local directory such as /usr/local/bin. + */ +#define BIN "$bin" /**/ + +/* BYTEORDER: + * This symbol contains an encoding of the order of bytes in a long. + * Usual values (in octal) are 01234, 04321, 02143, 03412... + */ +#define BYTEORDER 0$byteorder /**/ + /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard @@ -51,6 +64,13 @@ sed <config.h -e 's!^#undef!/\*#undef!' #define CPPSTDIN "$cppstdin" #define CPPMINUS "$cppminus" +/* BCMP: + * This symbol, if defined, indicates that the bcmp routine is available + * to compare blocks of memory. If undefined, use memcmp. If that's + * not available, roll your own. + */ +#$d_bcmp BCMP /**/ + /* BCOPY: * This symbol, if defined, indicates that the bcopy routine is available * to copy blocks of memory. Otherwise you should probably use memcpy(). @@ -86,6 +106,12 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_dosuid DOSUID /**/ +/* DUP2: + * This symbol, if defined, indicates that the dup2 routine is available + * to dup file descriptors. Otherwise you should use dup(). + */ +#$d_dup2 DUP2 /**/ + /* FCHMOD: * This symbol, if defined, indicates that the fchmod routine is available * to change mode of opened files. If unavailable, use chmod(). @@ -98,6 +124,18 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_fchown FCHOWN /**/ +/* FCNTL: + * This symbol, if defined, indicates to the C program that it should + * include fcntl.h. + */ +#$d_fcntl FCNTL /**/ + +/* FLOCK: + * This symbol, if defined, indicates that the flock() routine is + * available to do file locking. + */ +#$d_flock FLOCK /**/ + /* GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple @@ -105,6 +143,45 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_getgrps GETGROUPS /**/ +/* GETHOSTENT: + * This symbol, if defined, indicates that the gethostent() routine is + * available to lookup host names in some data base or other. + */ +#$d_gethent GETHOSTENT /**/ + +/* GETPGRP: + * This symbol, if defined, indicates that the getpgrp() routine is + * available to get the current process group. + */ +#$d_getpgrp GETPGRP /**/ + +/* GETPRIORITY: + * This symbol, if defined, indicates that the getpriority() routine is + * available to get a process's priority. + */ +#$d_getprior GETPRIORITY /**/ + +/* HTONS: + * This symbol, if defined, indicates that the htons routine (and friends) + * are available to do network order byte swapping. + */ +/* HTONL: + * This symbol, if defined, indicates that the htonl routine (and friends) + * are available to do network order byte swapping. + */ +/* NTOHS: + * This symbol, if defined, indicates that the ntohs routine (and friends) + * are available to do network order byte swapping. + */ +/* NTOHL: + * This symbol, if defined, indicates that the ntohl routine (and friends) + * are available to do network order byte swapping. + */ +#$d_htonl HTONS /**/ +#$d_htonl HTONL /**/ +#$d_htonl NTOHS /**/ +#$d_htonl NTOHL /**/ + /* index: * This preprocessor symbol is defined, along with rindex, if the system * uses the strchr and strrchr routines instead. @@ -116,6 +193,12 @@ sed <config.h -e 's!^#undef!/\*#undef!' #$d_index index strchr /* cultural */ #$d_index rindex strrchr /* differences? */ +/* IOCTL: + * This symbol, if defined, indicates that sys/ioctl.h exists and should + * be included. + */ +#$d_ioctl IOCTL /**/ + /* KILLPG: * This symbol, if defined, indicates that the killpg routine is available * to kill process groups. If unavailable, you probably should use kill @@ -123,6 +206,12 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_killpg KILLPG /**/ +/* MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * to compare blocks of memory. If undefined, roll your own. + */ +#$d_memcmp MEMCMP /**/ + /* MEMCPY: * This symbol, if defined, indicates that the memcpy routine is available * to copy blocks of memory. Otherwise you should probably use bcopy(). @@ -130,6 +219,31 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_memcpy MEMCPY /**/ +/* MKDIR: + * This symbol, if defined, indicates that the mkdir routine is available + * to create directories. Otherwise you should fork off a new process to + * exec /bin/mkdir. + */ +#$d_mkdir MKDIR /**/ + +/* NDBM: + * This symbol, if defined, indicates that ndbm.h exists and should + * be included. + */ +#$d_ndbm NDBM /**/ + +/* ODBM: + * This symbol, if defined, indicates that dbm.h exists and should + * be included. + */ +#$d_odbm ODBM /**/ + +/* READDIR: + * This symbol, if defined, indicates that the readdir routine is available + * from the C library to create directories. + */ +#$d_readdir READDIR /**/ + /* RENAME: * This symbol, if defined, indicates that the rename routine is available * to rename files. Otherwise you should do the unlink(), link(), unlink() @@ -137,6 +251,13 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_rename RENAME /**/ +/* RMDIR: + * This symbol, if defined, indicates that the rmdir routine is available + * to remove directories. Otherwise you should fork off a new process to + * exec /bin/rmdir. + */ +#$d_rmdir RMDIR /**/ + /* SETEGID: * This symbol, if defined, indicates that the setegid routine is available * to change the effective gid of the current program. @@ -149,6 +270,42 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_seteuid SETEUID /**/ +/* SETPGRP: + * This symbol, if defined, indicates that the setpgrp() routine is + * available to set the current process group. + */ +#$d_setpgrp SETPGRP /**/ + +/* SETPRIORITY: + * This symbol, if defined, indicates that the setpriority() routine is + * available to set a process's priority. + */ +#$d_setprior SETPRIORITY /**/ + +/* SETREGID: + * This symbol, if defined, indicates that the setregid routine is + * available to change the real and effective gid of the current program. + */ +/* SETRESGID: + * This symbol, if defined, indicates that the setresgid routine is + * available to change the real, effective and saved gid of the current + * program. + */ +#$d_setregid SETREGID /**/ +#$d_setresgid SETRESGID /**/ + +/* SETREUID: + * This symbol, if defined, indicates that the setreuid routine is + * available to change the real and effective uid of the current program. + */ +/* SETRESUID: + * This symbol, if defined, indicates that the setresuid routine is + * available to change the real, effective and saved uid of the current + * program. + */ +#$d_setreuid SETREUID /**/ +#$d_setresuid SETRESUID /**/ + /* SETRGID: * This symbol, if defined, indicates that the setrgid routine is available * to change the real gid of the current program. @@ -161,6 +318,24 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_setruid SETRUID /**/ +/* SOCKET: + * This symbol, if defined, indicates that the BSD socket interface is + * supported. + */ +/* SOCKETPAIR: + * This symbol, if defined, indicates that the BSD socketpair call is + * supported. + */ +/* OLDSOCKET: + * This symbol, if defined, indicates that the 4.1c BSD socket interface + * is supported instead of the 4.2/4.3 BSD socket interface. + */ +#$d_socket SOCKET /**/ + +#$d_sockpair SOCKETPAIR /**/ + +#$d_oldsock OLDSOCKET /**/ + /* STATBLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. @@ -173,12 +348,6 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$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 @@ -192,13 +361,29 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_symlink SYMLINK /**/ +/* SYSCALL: + * This symbol, if defined, indicates that the syscall routine is available + * to call arbitrary system calls. If undefined, that's tough. + */ +#$d_syscall SYSCALL /**/ + /* TMINSYS: * This symbol is defined if this system declares "struct tm" in * in rather than . We can't just say * -I/usr/include/sys because some systems have both time files, and * the -I trick gets the wrong one. */ +/* I_SYSTIME: + * This symbol is defined if this system has the file . + */ #$d_tminsys TMINSYS /**/ +#$i_systime I_SYSTIME /**/ + +/* VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include varargs.h. + */ +#$d_varargs VARARGS /**/ /* vfork: * This symbol, if defined, remaps the vfork routine to fork if the @@ -214,12 +399,107 @@ sed <config.h -e 's!^#undef!/\*#undef!' */ #$d_voidsig VOIDSIG /**/ +/* VPRINTF: + * This symbol, if defined, indicates that the vprintf routine is available + * to printf with a pointer to an argument list. If unavailable, you + * may need to write your own, probably in terms of _doprnt(). + */ +/* CHARVSPRINTF: + * This symbol is defined if this system has vsprintf() returning type + * (char*). The trend seems to be to declare it as "int vsprintf()". It + * is up to the package author to declare vsprintf correctly based on the + * symbol. + */ +#$d_vprintf VPRINTF /**/ +#$d_charvspr CHARVSPRINTF /**/ + /* 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 /**/ +/* I_DIRENT: + * This symbol, if defined, indicates to the C program that it should + * include dirent.h. + */ +/* DIRNAMLEN: + * This symbol, if defined, indicates to the C program that the length + * of directory entry names is provided by a d_namlen field. Otherwise + * you need to do strlen() on the d_name field. + */ +#$i_dirent I_DIRENT /**/ +#$d_dirnamlen DIRNAMLEN /**/ + +/* I_FCNTL: + * This symbol, if defined, indicates to the C program that it should + * include fcntl.h. + */ +#$i_fcntl I_FCNTL /**/ + +/* I_GRP: + * This symbol, if defined, indicates to the C program that it should + * include grp.h. + */ +#$i_grp I_GRP /**/ + +/* I_PWD: + * This symbol, if defined, indicates to the C program that it should + * include pwd.h. + */ +/* PWQUOTA: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +#$i_pwd I_PWD /**/ +#$d_pwquota PWQUOTA /**/ +#$d_pwage PWAGE /**/ + +/* I_SYSDIR: + * This symbol, if defined, indicates to the C program that it should + * include sys/dir.h. + */ +#$i_sysdir I_SYSDIR /**/ + +/* I_SYSIOCTL: + * This symbol, if defined, indicates that sys/ioctl.h exists and should + * be included. + */ +#$i_sysioctl I_SYSIOCTL /**/ + +/* I_VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include varargs.h. + */ +#$i_varargs I_VARARGS /**/ + +/* I_VFORK: + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +#$i_vfork I_VFORK /**/ + +/* INTSIZE: + * This symbol contains the size of an int, so that the C preprocessor + * can make decisions based on it. + */ +#define INTSIZE $intsize /**/ + +/* RANDBITS: + * This symbol contains the number of bits of random number the rand() + * function produces. Usual values are 15, 16, and 31. + */ +#define RANDBITS $randbits /**/ + +/* SIG_NAME: + * This symbol contains an list of signal names in order. + */ +#define SIG_NAME "`echo $sig_name | sed 's/ /","/g'`" /**/ + /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". @@ -244,6 +524,7 @@ sed <config.h -e 's!^#undef!/\*#undef!' * The package designer should define VOIDUSED to indicate the requirements * of the package. This can be done either by #defining VOIDUSED before * including config.h, or by defining defvoidused in Myinit.U. If the + * latter approach is taken, only those flags will be tested. If the * level of void support necessary is not present, defines void to int. */ #ifndef VOIDUSED @@ -258,7 +539,8 @@ sed <config.h -e 's!^#undef!/\*#undef!' /* 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. + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. */ #define PRIVLIB "$privlib" /**/ diff --git a/cons.c b/cons.c new file mode 100644 index 0000000..8e0c146 --- /dev/null +++ b/cons.c @@ -0,0 +1,1284 @@ +/* $Header: cons.c,v 3.0 89/10/18 15:10:23 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. + * + * $Log: cons.c,v $ + * Revision 3.0 89/10/18 15:10:23 lwall + * 3.0 baseline + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "perly.h" + +extern char *tokename[]; +extern int yychar; + +static int cmd_tosave(); +static int arg_tosave(); +static int spat_tosave(); + +static bool saw_return; + +SUBR * +make_sub(name,cmd) +char *name; +CMD *cmd; +{ + register SUBR *sub; + STAB *stab = stabent(name,TRUE); + + Newz(101,sub,1,SUBR); + if (stab_sub(stab)) { + if (dowarn) { + line_t oldline = line; + + if (cmd) + line = cmd->c_line; + warn("Subroutine %s redefined",name); + line = oldline; + } + cmd_free(stab_sub(stab)->cmd); + afree(stab_sub(stab)->tosave); + Safefree(stab_sub(stab)); + } + sub->filename = filename; + saw_return = FALSE; + tosave = anew(Nullstab); + tosave->ary_fill = 0; /* make 1 based */ + (void)cmd_tosave(cmd,FALSE); /* this builds the tosave array */ + sub->tosave = tosave; + if (saw_return) { + struct compcmd mycompblock; + + mycompblock.comp_true = cmd; + mycompblock.comp_alt = Nullcmd; + cmd = add_label(savestr("SUB"),make_ccmd(C_BLOCK,Nullarg,mycompblock)); + saw_return = FALSE; + } + sub->cmd = cmd; + stab_sub(stab) = sub; + if (perldb) { + STR *str = str_nmake((double)subline); + + str_cat(str,"-"); + sprintf(buf,"%ld",(long)line); + str_cat(str,buf); + name = str_get(subname); + hstore(stab_xhash(DBsub),name,strlen(name),str,0); + str_set(subname,"main"); + } + subline = 0; + return sub; +} + +CMD * +block_head(tail) +register CMD *tail; +{ + CMD *head; + register int opt; + register int last_opt = 0; + register STAB *last_stab = Nullstab; + register int count = 0; + register CMD *switchbeg = Nullcmd; + + if (tail == Nullcmd) { + return tail; + } + head = tail->c_head; + + for (tail = head; tail; tail = tail->c_next) { + + /* save one measly dereference at runtime */ + if (tail->c_type == C_IF) { + if (!(tail->ucmd.ccmd.cc_alt = tail->ucmd.ccmd.cc_alt->c_next)) + tail->c_flags |= CF_TERM; + } + else if (tail->c_type == C_EXPR) { + ARG *arg; + + if (tail->ucmd.acmd.ac_expr) + arg = tail->ucmd.acmd.ac_expr; + else + arg = tail->c_expr; + if (arg) { + if (arg->arg_type == O_RETURN) + tail->c_flags |= CF_TERM; + else if (arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD) + tail->c_flags |= CF_TERM; + } + } + if (!tail->c_next) + tail->c_flags |= CF_TERM; + + if (tail->c_expr && (tail->c_flags & CF_OPTIMIZE) == CFT_FALSE) + opt_arg(tail,1, tail->c_type == C_EXPR); + + /* now do a little optimization on case-ish structures */ + switch(tail->c_flags & (CF_OPTIMIZE|CF_FIRSTNEG|CF_INVERT)) { + case CFT_ANCHOR: + if (stabent("*",FALSE)) { /* bad assumption here!!! */ + opt = 0; + break; + } + /* FALL THROUGH */ + case CFT_STROP: + opt = (tail->c_flags & CF_NESURE) ? CFT_STROP : 0; + break; + case CFT_CCLASS: + opt = CFT_STROP; + break; + case CFT_NUMOP: + opt = (tail->c_slen == O_NE ? 0 : CFT_NUMOP); + if ((tail->c_flags&(CF_NESURE|CF_EQSURE)) != (CF_NESURE|CF_EQSURE)) + opt = 0; + break; + default: + opt = 0; + } + if (opt && opt == last_opt && tail->c_stab == last_stab) + count++; + else { + if (count >= 3) { /* is this the breakeven point? */ + if (last_opt == CFT_NUMOP) + make_nswitch(switchbeg,count); + else + make_cswitch(switchbeg,count); + } + if (opt) { + count = 1; + switchbeg = tail; + } + else + count = 0; + } + last_opt = opt; + last_stab = tail->c_stab; + } + if (count >= 3) { /* is this the breakeven point? */ + if (last_opt == CFT_NUMOP) + make_nswitch(switchbeg,count); + else + make_cswitch(switchbeg,count); + } + return head; +} + +/* We've spotted a sequence of CMDs that all test the value of the same + * spat. Thus we can insert a SWITCH in front and jump directly + * to the correct one. + */ +make_cswitch(head,count) +register CMD *head; +int count; +{ + register CMD *cur; + register CMD **loc; + register int i; + register int min = 255; + register int max = 0; + + /* make a new head in the exact same spot */ + New(102,cur, 1, CMD); +#ifdef STRUCTCOPY + *cur = *head; +#else + Copy(head,cur,1,CMD); +#endif + Zero(head,1,CMD); + head->c_type = C_CSWITCH; + head->c_next = cur; /* insert new cmd at front of list */ + head->c_stab = cur->c_stab; + + Newz(103,loc,258,CMD*); + loc++; /* lie a little */ + while (count--) { + if ((cur->c_flags & CF_OPTIMIZE) == CFT_CCLASS) { + for (i = 0; i <= 255; i++) { + if (!loc[i] && cur->c_short->str_ptr[i>>3] & (1 << (i&7))) { + loc[i] = cur; + if (i < min) + min = i; + if (i > max) + max = i; + } + } + } + else { + i = *cur->c_short->str_ptr & 255; + if (!loc[i]) { + loc[i] = cur; + if (i < min) + min = i; + if (i > max) + max = i; + } + } + cur = cur->c_next; + } + max++; + if (min > 0) + Copy(&loc[min],&loc[0], max - min, CMD*); + loc--; + min--; + max -= min; + for (i = 0; i <= max; i++) + if (!loc[i]) + loc[i] = cur; + Renew(loc,max+1,CMD*); /* chop it down to size */ + head->ucmd.scmd.sc_offset = min; + head->ucmd.scmd.sc_max = max; + head->ucmd.scmd.sc_next = loc; +} + +make_nswitch(head,count) +register CMD *head; +int count; +{ + register CMD *cur = head; + register CMD **loc; + register int i; + register int min = 32767; + register int max = -32768; + int origcount = count; + double value; /* or your money back! */ + short changed; /* so triple your money back! */ + + while (count--) { + i = (int)str_gnum(cur->c_short); + value = (double)i; + if (value != cur->c_short->str_u.str_nval) + return; /* fractional values--just forget it */ + changed = i; + if (changed != i) + return; /* too big for a short */ + if (cur->c_slen == O_LE) + i++; + else if (cur->c_slen == O_GE) /* we only do < or > here */ + i--; + if (i < min) + min = i; + if (i > max) + max = i; + cur = cur->c_next; + } + count = origcount; + if (max - min > count * 2 + 10) /* too sparse? */ + return; + + /* now make a new head in the exact same spot */ + New(104,cur, 1, CMD); +#ifdef STRUCTCOPY + *cur = *head; +#else + Copy(head,cur,1,CMD); +#endif + Zero(head,1,CMD); + head->c_type = C_NSWITCH; + head->c_next = cur; /* insert new cmd at front of list */ + head->c_stab = cur->c_stab; + + Newz(105,loc, max - min + 3, CMD*); + loc++; + while (count--) { + i = (int)str_gnum(cur->c_short); + i -= min; + max -= min; + max++; + switch(cur->c_slen) { + case O_LE: + i++; + case O_LT: + for (i--; i >= -1; i--) + if (!loc[i]) + loc[i] = cur; + break; + case O_GE: + i--; + case O_GT: + for (i++; i <= max; i++) + if (!loc[i]) + loc[i] = cur; + break; + case O_EQ: + if (!loc[i]) + loc[i] = cur; + break; + } + cur = cur->c_next; + } + loc--; + min--; + for (i = 0; i <= max; i++) + if (!loc[i]) + loc[i] = cur; + head->ucmd.scmd.sc_offset = min; + head->ucmd.scmd.sc_max = max; + head->ucmd.scmd.sc_next = loc; +} + +CMD * +append_line(head,tail) +register CMD *head; +register CMD *tail; +{ + if (tail == Nullcmd) + return head; + if (!tail->c_head) /* make sure tail is well formed */ + tail->c_head = tail; + if (head != Nullcmd) { + tail = tail->c_head; /* get to start of tail list */ + if (!head->c_head) + head->c_head = head; /* start a new head list */ + while (head->c_next) { + head->c_next->c_head = head->c_head; + head = head->c_next; /* get to end of head list */ + } + head->c_next = tail; /* link to end of old list */ + tail->c_head = head->c_head; /* propagate head pointer */ + } + while (tail->c_next) { + tail->c_next->c_head = tail->c_head; + tail = tail->c_next; + } + return tail; +} + +CMD * +dodb(cur) +CMD *cur; +{ + register CMD *cmd; + register CMD *head = cur->c_head; + register ARG *arg; + STR *str; + + if (!head) + head = cur; + if (!head->c_line) + return cur; + str = afetch(lineary,(int)head->c_line,FALSE); + if (!str || str->str_nok) + return cur; + str->str_u.str_nval = (double)head->c_line; + str->str_nok = 1; + Newz(106,cmd,1,CMD); + cmd->c_type = C_EXPR; + cmd->ucmd.acmd.ac_stab = Nullstab; + cmd->ucmd.acmd.ac_expr = Nullarg; + arg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg); + arg[1].arg_type = A_SINGLE; + arg[1].arg_ptr.arg_str = str_nmake((double)head->c_line); + cmd->c_expr = make_op(O_SUBR, 2, + stab2arg(A_WORD,DBstab), + make_list(arg), + Nullarg); + cmd->c_flags |= CF_COND; + cmd->c_line = head->c_line; + cmd->c_label = head->c_label; + cmd->c_file = filename; + return append_line(cmd, cur); +} + +CMD * +make_acmd(type,stab,cond,arg) +int type; +STAB *stab; +ARG *cond; +ARG *arg; +{ + register CMD *cmd; + + Newz(107,cmd,1,CMD); + cmd->c_type = type; + cmd->ucmd.acmd.ac_stab = stab; + cmd->ucmd.acmd.ac_expr = arg; + cmd->c_expr = cond; + if (cond) + cmd->c_flags |= CF_COND; + if (cmdline != NOLINE) { + cmd->c_line = cmdline; + cmdline = NOLINE; + } + cmd->c_file = filename; + if (perldb) + cmd = dodb(cmd); + return cmd; +} + +CMD * +make_ccmd(type,arg,cblock) +int type; +ARG *arg; +struct compcmd cblock; +{ + register CMD *cmd; + + Newz(108,cmd, 1, CMD); + cmd->c_type = type; + cmd->c_expr = arg; + cmd->ucmd.ccmd.cc_true = cblock.comp_true; + cmd->ucmd.ccmd.cc_alt = cblock.comp_alt; + if (arg) + cmd->c_flags |= CF_COND; + if (cmdline != NOLINE) { + cmd->c_line = cmdline; + cmdline = NOLINE; + } + if (perldb) + cmd = dodb(cmd); + return cmd; +} + +CMD * +make_icmd(type,arg,cblock) +int type; +ARG *arg; +struct compcmd cblock; +{ + register CMD *cmd; + register CMD *alt; + register CMD *cur; + register CMD *head; + struct compcmd ncblock; + + Newz(109,cmd, 1, CMD); + head = cmd; + cmd->c_type = type; + cmd->c_expr = arg; + cmd->ucmd.ccmd.cc_true = cblock.comp_true; + cmd->ucmd.ccmd.cc_alt = cblock.comp_alt; + if (arg) + cmd->c_flags |= CF_COND; + if (cmdline != NOLINE) { + cmd->c_line = cmdline; + cmdline = NOLINE; + } + cur = cmd; + alt = cblock.comp_alt; + while (alt && alt->c_type == C_ELSIF) { + cur = alt; + alt = alt->ucmd.ccmd.cc_alt; + } + if (alt) { /* a real life ELSE at the end? */ + ncblock.comp_true = alt; + ncblock.comp_alt = Nullcmd; + alt = append_line(cur,make_ccmd(C_ELSE,Nullarg,ncblock)); + cur->ucmd.ccmd.cc_alt = alt; + } + else + alt = cur; /* no ELSE, so cur is proxy ELSE */ + + cur = cmd; + while (cmd) { /* now point everyone at the ELSE */ + cur = cmd; + cmd = cur->ucmd.ccmd.cc_alt; + cur->c_head = head; + if (cur->c_type == C_ELSIF) + cur->c_type = C_IF; + if (cur->c_type == C_IF) + cur->ucmd.ccmd.cc_alt = alt; + if (cur == alt) + break; + cur->c_next = cmd; + } + if (perldb) + cur = dodb(cur); + return cur; +} + +void +opt_arg(cmd,fliporflop,acmd) +register CMD *cmd; +int fliporflop; +int acmd; +{ + register ARG *arg; + int opt = CFT_EVAL; + int sure = 0; + ARG *arg2; + int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */ + int flp = fliporflop; + + if (!cmd) + return; + if (!(arg = cmd->c_expr)) { + cmd->c_flags &= ~CF_COND; + return; + } + + /* Can we turn && and || into if and unless? */ + + if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM) && + (arg->arg_type == O_AND || arg->arg_type == O_OR) ) { + dehoist(arg,1); + arg[2].arg_type &= A_MASK; /* don't suppress eval */ + dehoist(arg,2); + cmd->ucmd.acmd.ac_expr = arg[2].arg_ptr.arg_arg; + cmd->c_expr = arg[1].arg_ptr.arg_arg; + if (arg->arg_type == O_OR) + cmd->c_flags ^= CF_INVERT; /* || is like unless */ + arg->arg_len = 0; + free_arg(arg); + arg = cmd->c_expr; + } + + /* Turn "if (!expr)" into "unless (expr)" */ + + if (!(cmd->c_flags & CF_TERM)) { /* unless return value wanted */ + while (arg->arg_type == O_NOT) { + dehoist(arg,1); + cmd->c_flags ^= CF_INVERT; /* flip sense of cmd */ + cmd->c_expr = arg[1].arg_ptr.arg_arg; /* hoist the rest of expr */ + free_arg(arg); + arg = cmd->c_expr; /* here we go again */ + } + } + + if (!arg->arg_len) { /* sanity check */ + cmd->c_flags |= opt; + return; + } + + /* for "cond .. cond" we set up for the initial check */ + + if (arg->arg_type == O_FLIP) + context |= 4; + + /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */ + + morecontext: + if (arg->arg_type == O_AND) + context |= 1; + else if (arg->arg_type == O_OR) + context |= 2; + if (context && (arg[flp].arg_type & A_MASK) == A_EXPR) { + arg = arg[flp].arg_ptr.arg_arg; + flp = 1; + if (arg->arg_type == O_AND || arg->arg_type == O_OR) + goto morecontext; + } + if ((context & 3) == 3) + return; + + if (arg[flp].arg_flags & (AF_PRE|AF_POST)) { + cmd->c_flags |= opt; + return; /* side effect, can't optimize */ + } + + if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP || + arg->arg_type == O_AND || arg->arg_type == O_OR) { + if ((arg[flp].arg_type & A_MASK) == A_SINGLE) { + opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE); + cmd->c_short = str_smake(arg[flp].arg_ptr.arg_str); + goto literal; + } + else if ((arg[flp].arg_type & A_MASK) == A_STAB || + (arg[flp].arg_type & A_MASK) == A_LVAL) { + cmd->c_stab = arg[flp].arg_ptr.arg_stab; + opt = CFT_REG; + literal: + if (!context) { /* no && or ||? */ + free_arg(arg); + cmd->c_expr = Nullarg; + } + if (!(context & 1)) + cmd->c_flags |= CF_EQSURE; + if (!(context & 2)) + cmd->c_flags |= CF_NESURE; + } + } + else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST || + arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) { + if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && + (arg[2].arg_type & A_MASK) == A_SPAT && + arg[2].arg_ptr.arg_spat->spat_short ) { + cmd->c_stab = arg[1].arg_ptr.arg_stab; + cmd->c_short = str_smake(arg[2].arg_ptr.arg_spat->spat_short); + cmd->c_slen = arg[2].arg_ptr.arg_spat->spat_slen; + if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ALL && + !(arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ONCE) && + (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) ) + sure |= CF_EQSURE; /* (SUBST must be forced even */ + /* if we know it will work.) */ + if (arg->arg_type != O_SUBST) { + arg[2].arg_ptr.arg_spat->spat_short = Nullstr; + arg[2].arg_ptr.arg_spat->spat_slen = 0; /* only one chk */ + } + sure |= CF_NESURE; /* normally only sure if it fails */ + if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) + cmd->c_flags |= CF_FIRSTNEG; + if (context & 1) { /* only sure if thing is false */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_NESURE; + else + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_EQSURE; + else + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { /* if we know anything*/ + if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST) + opt = CFT_SCAN; + else + opt = CFT_ANCHOR; + if (sure == (CF_EQSURE|CF_NESURE) /* really sure? */ + && arg->arg_type == O_MATCH + && context & 4 + && fliporflop == 1) { + spat_free(arg[2].arg_ptr.arg_spat); + arg[2].arg_ptr.arg_spat = Nullspat; /* don't do twice */ + } + cmd->c_flags |= sure; + } + } + } + else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE || + arg->arg_type == O_SLT || arg->arg_type == O_SGT) { + if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) { + if (arg[2].arg_type == A_SINGLE) { + cmd->c_stab = arg[1].arg_ptr.arg_stab; + cmd->c_short = str_smake(arg[2].arg_ptr.arg_str); + cmd->c_slen = cmd->c_short->str_cur+1; + switch (arg->arg_type) { + case O_SLT: case O_SGT: + sure |= CF_EQSURE; + cmd->c_flags |= CF_FIRSTNEG; + break; + case O_SNE: + cmd->c_flags |= CF_FIRSTNEG; + /* FALL THROUGH */ + case O_SEQ: + sure |= CF_NESURE|CF_EQSURE; + break; + } + if (context & 1) { /* only sure if thing is false */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_NESURE; + else + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_EQSURE; + else + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { + opt = CFT_STROP; + cmd->c_flags |= sure; + } + } + } + } + else if (arg->arg_type == O_EQ || arg->arg_type == O_NE || + arg->arg_type == O_LE || arg->arg_type == O_GE || + arg->arg_type == O_LT || arg->arg_type == O_GT) { + if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) { + if (arg[2].arg_type == A_SINGLE) { + cmd->c_stab = arg[1].arg_ptr.arg_stab; + if (dowarn) { + STR *str = arg[2].arg_ptr.arg_str; + + if ((!str->str_nok && !looks_like_number(str))) + warn("Possible use of == on string value"); + } + cmd->c_short = str_nmake(str_gnum(arg[2].arg_ptr.arg_str)); + cmd->c_slen = arg->arg_type; + sure |= CF_NESURE|CF_EQSURE; + if (context & 1) { /* only sure if thing is false */ + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { + opt = CFT_NUMOP; + cmd->c_flags |= sure; + } + } + } + } + else if (arg->arg_type == O_ASSIGN && + (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && + arg[1].arg_ptr.arg_stab == defstab && + arg[2].arg_type == A_EXPR ) { + arg2 = arg[2].arg_ptr.arg_arg; + if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) { + opt = CFT_GETS; + cmd->c_stab = arg2[1].arg_ptr.arg_stab; + if (!(stab_io(arg2[1].arg_ptr.arg_stab)->flags & IOF_ARGV)) { + free_arg(arg2); + free_arg(arg); + cmd->c_expr = Nullarg; + } + } + } + else if (arg->arg_type == O_CHOP && + (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) { + opt = CFT_CHOP; + cmd->c_stab = arg[1].arg_ptr.arg_stab; + free_arg(arg); + cmd->c_expr = Nullarg; + } + if (context & 4) + opt |= CF_FLIP; + cmd->c_flags |= opt; + + if (cmd->c_flags & CF_FLIP) { + if (fliporflop == 1) { + arg = cmd->c_expr; /* get back to O_FLIP arg */ + New(110,arg[3].arg_ptr.arg_cmd, 1, CMD); + Copy(cmd, arg[3].arg_ptr.arg_cmd, 1, CMD); + New(111,arg[4].arg_ptr.arg_cmd,1,CMD); + Copy(cmd, arg[4].arg_ptr.arg_cmd, 1, CMD); + opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd); + arg->arg_len = 2; /* this is a lie */ + } + else { + if ((opt & CF_OPTIMIZE) == CFT_EVAL) + cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP; + } + } +} + +CMD * +add_label(lbl,cmd) +char *lbl; +register CMD *cmd; +{ + if (cmd) + cmd->c_label = lbl; + return cmd; +} + +CMD * +addcond(cmd, arg) +register CMD *cmd; +register ARG *arg; +{ + cmd->c_expr = arg; + cmd->c_flags |= CF_COND; + return cmd; +} + +CMD * +addloop(cmd, arg) +register CMD *cmd; +register ARG *arg; +{ + void while_io(); + + cmd->c_expr = arg; + cmd->c_flags |= CF_COND|CF_LOOP; + + if (!(cmd->c_flags & CF_INVERT)) + while_io(cmd); /* add $_ =, if necessary */ + + if (cmd->c_type == C_BLOCK) + cmd->c_flags &= ~CF_COND; + else { + arg = cmd->ucmd.acmd.ac_expr; + if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD) + cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */ + if (arg && arg->arg_type == O_SUBR) + cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */ + } + return cmd; +} + +CMD * +invert(cmd) +register CMD *cmd; +{ + if (cmd->c_head) + cmd->c_head->c_flags ^= CF_INVERT; + else + cmd->c_flags ^= CF_INVERT; + return cmd; +} + +yyerror(s) +char *s; +{ + char tmpbuf[258]; + char tmp2buf[258]; + char *tname = tmpbuf; + + if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 && + oldoldbufptr != oldbufptr && oldbufptr != bufptr) { + while (isspace(*oldoldbufptr)) + oldoldbufptr++; + strncpy(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr); + tmp2buf[bufptr - oldoldbufptr] = '\0'; + sprintf(tname,"next 2 tokens \"%s\"",tmp2buf); + } + else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 && + oldbufptr != bufptr) { + while (isspace(*oldbufptr)) + oldbufptr++; + strncpy(tmp2buf, oldbufptr, bufptr - oldbufptr); + tmp2buf[bufptr - oldbufptr] = '\0'; + sprintf(tname,"next token \"%s\"",tmp2buf); + } + else if (yychar > 256) + tname = "next token ???"; + else if (!yychar) + (void)strcpy(tname,"at EOF"); + else if (yychar < 32) + (void)sprintf(tname,"next char ^%c",yychar+64); + else if (yychar == 127) + (void)strcpy(tname,"at EOF"); + else + (void)sprintf(tname,"next char %c",yychar); + (void)sprintf(buf, "%s in file %s at line %d, %s\n", + s,filename,line,tname); + if (line == multi_end && multi_start < multi_end) + sprintf(buf+strlen(buf), + " (Might be a runaway multi-line %c%c string starting on line %d)\n", + multi_open,multi_close,multi_start); + if (in_eval) + str_cat(stab_val(stabent("@",TRUE)),buf); + else + fputs(buf,stderr); + if (++error_count >= 10) + fatal("Too many errors\n"); +} + +void +while_io(cmd) +register CMD *cmd; +{ + register ARG *arg = cmd->c_expr; + STAB *asgnstab; + + /* hoist "while ()" up into command block */ + + if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) { + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_GETS; /* and set it to do the input */ + cmd->c_stab = arg[1].arg_ptr.arg_stab; + if (stab_io(arg[1].arg_ptr.arg_stab)->flags & IOF_ARGV) { + cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */ + stab2arg(A_LVAL,defstab), arg, Nullarg)); + } + else { + free_arg(arg); + cmd->c_expr = Nullarg; + } + } + else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) { + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_INDGETS; /* and set it to do the input */ + cmd->c_stab = arg[1].arg_ptr.arg_stab; + free_arg(arg); + cmd->c_expr = Nullarg; + } + else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) { + if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY) + asgnstab = cmd->c_stab; + else + asgnstab = defstab; + cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$foo =" */ + stab2arg(A_LVAL,asgnstab), arg, Nullarg)); + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + } +} + +CMD * +wopt(cmd) +register CMD *cmd; +{ + register CMD *tail; + CMD *newtail; + register int i; + + if (cmd->c_expr && (cmd->c_flags & CF_OPTIMIZE) == CFT_FALSE) + opt_arg(cmd,1, cmd->c_type == C_EXPR); + + while_io(cmd); /* add $_ =, if necessary */ + + /* First find the end of the true list */ + + tail = cmd->ucmd.ccmd.cc_true; + if (tail == Nullcmd) + return cmd; + New(112,newtail, 1, CMD); /* guaranteed continue */ + for (;;) { + /* optimize "next" to point directly to continue block */ + if (tail->c_type == C_EXPR && + tail->ucmd.acmd.ac_expr && + tail->ucmd.acmd.ac_expr->arg_type == O_NEXT && + (tail->ucmd.acmd.ac_expr->arg_len == 0 || + (cmd->c_label && + strEQ(cmd->c_label, + tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) ))) + { + arg_free(tail->ucmd.acmd.ac_expr); + tail->c_type = C_NEXT; + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) + tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt; + else + tail->ucmd.ccmd.cc_alt = newtail; + tail->ucmd.ccmd.cc_true = Nullcmd; + } + else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) { + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) + tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt; + else + tail->ucmd.ccmd.cc_alt = newtail; + } + else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) { + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) { + for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) + if (!tail->ucmd.scmd.sc_next[i]) + tail->ucmd.scmd.sc_next[i] = cmd->ucmd.ccmd.cc_alt; + } + else { + for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) + if (!tail->ucmd.scmd.sc_next[i]) + tail->ucmd.scmd.sc_next[i] = newtail; + } + } + + if (!tail->c_next) + break; + tail = tail->c_next; + } + + /* if there's a continue block, link it to true block and find end */ + + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) { + tail->c_next = cmd->ucmd.ccmd.cc_alt; + tail = tail->c_next; + for (;;) { + /* optimize "next" to point directly to continue block */ + if (tail->c_type == C_EXPR && + tail->ucmd.acmd.ac_expr && + tail->ucmd.acmd.ac_expr->arg_type == O_NEXT && + (tail->ucmd.acmd.ac_expr->arg_len == 0 || + (cmd->c_label && + strEQ(cmd->c_label, + tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) ))) + { + arg_free(tail->ucmd.acmd.ac_expr); + tail->c_type = C_NEXT; + tail->ucmd.ccmd.cc_alt = newtail; + tail->ucmd.ccmd.cc_true = Nullcmd; + } + else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) { + tail->ucmd.ccmd.cc_alt = newtail; + } + else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) { + for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) + if (!tail->ucmd.scmd.sc_next[i]) + tail->ucmd.scmd.sc_next[i] = newtail; + } + + if (!tail->c_next) + break; + tail = tail->c_next; + } + for ( ; tail->c_next; tail = tail->c_next) ; + } + + /* Here's the real trick: link the end of the list back to the beginning, + * inserting a "last" block to break out of the loop. This saves one or + * two procedure calls every time through the loop, because of how cmd_exec + * does tail recursion. + */ + + tail->c_next = newtail; + tail = newtail; + if (!cmd->ucmd.ccmd.cc_alt) + cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */ + +#ifndef lint + (void)bcopy((char *)cmd, (char *)tail, sizeof(CMD)); +#endif + tail->c_type = C_EXPR; + tail->c_flags ^= CF_INVERT; /* turn into "last unless" */ + tail->c_next = tail->ucmd.ccmd.cc_true; /* loop directly back to top */ + tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg); + tail->ucmd.acmd.ac_stab = Nullstab; + return cmd; +} + +CMD * +over(eachstab,cmd) +STAB *eachstab; +register CMD *cmd; +{ + /* hoist "for $foo (@bar)" up into command block */ + + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_ARRAY; /* and set it to do the iteration */ + cmd->c_stab = eachstab; + + return cmd; +} + +cmd_free(cmd) +register CMD *cmd; +{ + register CMD *tofree; + register CMD *head = cmd; + + while (cmd) { + if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */ + if (cmd->c_label) + Safefree(cmd->c_label); + if (cmd->c_short) + str_free(cmd->c_short); + if (cmd->c_spat) + spat_free(cmd->c_spat); + if (cmd->c_expr) + arg_free(cmd->c_expr); + } + switch (cmd->c_type) { + case C_WHILE: + case C_BLOCK: + case C_ELSE: + case C_IF: + if (cmd->ucmd.ccmd.cc_true) + cmd_free(cmd->ucmd.ccmd.cc_true); + break; + case C_EXPR: + if (cmd->ucmd.acmd.ac_expr) + arg_free(cmd->ucmd.acmd.ac_expr); + break; + } + tofree = cmd; + cmd = cmd->c_next; + Safefree(tofree); + if (cmd && cmd == head) /* reached end of while loop */ + break; + } +} + +arg_free(arg) +register ARG *arg; +{ + register int i; + + for (i = 1; i <= arg->arg_len; i++) { + switch (arg[i].arg_type & A_MASK) { + case A_NULL: + break; + case A_LEXPR: + if (arg->arg_type == O_AASSIGN && + arg[i].arg_ptr.arg_arg->arg_type == O_LARRAY) { + char *name = + stab_name(arg[i].arg_ptr.arg_arg[1].arg_ptr.arg_stab); + + if (strnEQ("_GEN_",name, 5)) /* array for foreach */ + hdelete(defstash,name,strlen(name)); + } + /* FALL THROUGH */ + case A_EXPR: + arg_free(arg[i].arg_ptr.arg_arg); + break; + case A_CMD: + cmd_free(arg[i].arg_ptr.arg_cmd); + break; + case A_WORD: + case A_STAB: + case A_LVAL: + case A_READ: + case A_GLOB: + case A_ARYLEN: + case A_LARYLEN: + case A_ARYSTAB: + case A_LARYSTAB: + break; + case A_SINGLE: + case A_DOUBLE: + case A_BACKTICK: + str_free(arg[i].arg_ptr.arg_str); + break; + case A_SPAT: + spat_free(arg[i].arg_ptr.arg_spat); + break; + } + } + free_arg(arg); +} + +spat_free(spat) +register SPAT *spat; +{ + register SPAT *sp; + HENT *entry; + + if (spat->spat_runtime) + arg_free(spat->spat_runtime); + if (spat->spat_repl) { + arg_free(spat->spat_repl); + } + if (spat->spat_short) { + str_free(spat->spat_short); + } + if (spat->spat_regexp) { + regfree(spat->spat_regexp); + } + + /* now unlink from spat list */ + + for (entry = defstash->tbl_array['_']; entry; entry = entry->hent_next) { + register HASH *stash; + STAB *stab = (STAB*)entry->hent_val; + + if (!stab) + continue; + stash = stab_hash(stab); + if (!stash || stash->tbl_spatroot == Null(SPAT*)) + continue; + if (stash->tbl_spatroot == spat) + stash->tbl_spatroot = spat->spat_next; + else { + for (sp = stash->tbl_spatroot; + sp && sp->spat_next != spat; + sp = sp->spat_next) + ; + if (sp) + sp->spat_next = spat->spat_next; + } + } + Safefree(spat); +} + +/* Recursively descend a command sequence and push the address of any string + * that needs saving on recursion onto the tosave array. + */ + +static int +cmd_tosave(cmd,willsave) +register CMD *cmd; +int willsave; /* willsave passes down the tree */ +{ + register CMD *head = cmd; + int shouldsave = FALSE; /* shouldsave passes up the tree */ + int tmpsave; + register CMD *lastcmd = Nullcmd; + + while (cmd) { + if (cmd->c_spat) + shouldsave |= spat_tosave(cmd->c_spat); + if (cmd->c_expr) + shouldsave |= arg_tosave(cmd->c_expr,willsave); + switch (cmd->c_type) { + case C_WHILE: + if (cmd->ucmd.ccmd.cc_true) { + tmpsave = cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave); + + /* Here we check to see if the temporary array generated for + * a foreach needs to be localized because of recursion. + */ + if (tmpsave && (cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY && + lastcmd && + lastcmd->c_type == C_EXPR && + lastcmd->ucmd.acmd.ac_expr) { + ARG *arg = lastcmd->ucmd.acmd.ac_expr; + + if (arg->arg_type == O_ASSIGN && + arg[1].arg_type == A_LEXPR && + arg[1].arg_ptr.arg_arg->arg_type == O_LARRAY && + strnEQ("_GEN_", + stab_name(arg[1].arg_ptr.arg_arg[1].arg_ptr.arg_stab), + 5)) { /* array generated for foreach */ + (void)localize(arg[1].arg_ptr.arg_arg); + } + } + shouldsave |= tmpsave; + } + break; + case C_BLOCK: + case C_ELSE: + case C_IF: + if (cmd->ucmd.ccmd.cc_true) + shouldsave |= cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave); + break; + case C_EXPR: + if (cmd->ucmd.acmd.ac_expr) + shouldsave |= arg_tosave(cmd->ucmd.acmd.ac_expr,willsave); + break; + } + lastcmd = cmd; + cmd = cmd->c_next; + if (cmd && cmd == head) /* reached end of while loop */ + break; + } + return shouldsave; +} + +static int +arg_tosave(arg,willsave) +register ARG *arg; +int willsave; +{ + register int i; + int shouldsave = FALSE; + + for (i = arg->arg_len; i >= 1; i--) { + switch (arg[i].arg_type & A_MASK) { + case A_NULL: + break; + case A_LEXPR: + case A_EXPR: + shouldsave |= arg_tosave(arg[i].arg_ptr.arg_arg,shouldsave); + break; + case A_CMD: + shouldsave |= cmd_tosave(arg[i].arg_ptr.arg_cmd,shouldsave); + break; + case A_WORD: + case A_STAB: + case A_LVAL: + case A_READ: + case A_GLOB: + case A_ARYLEN: + case A_SINGLE: + case A_DOUBLE: + case A_BACKTICK: + break; + case A_SPAT: + shouldsave |= spat_tosave(arg[i].arg_ptr.arg_spat); + break; + } + } + switch (arg->arg_type) { + case O_RETURN: + saw_return = TRUE; + break; + case O_EVAL: + case O_SUBR: + shouldsave = TRUE; + break; + } + if (willsave) + (void)apush(tosave,arg->arg_ptr.arg_str); + return shouldsave; +} + +static int +spat_tosave(spat) +register SPAT *spat; +{ + int shouldsave = FALSE; + + if (spat->spat_runtime) + shouldsave |= arg_tosave(spat->spat_runtime,FALSE); + if (spat->spat_repl) { + shouldsave |= arg_tosave(spat->spat_repl,FALSE); + } + + return shouldsave; +} + diff --git a/consarg.c b/consarg.c new file mode 100644 index 0000000..5a2c84f --- /dev/null +++ b/consarg.c @@ -0,0 +1,1130 @@ +/* $Header: consarg.c,v 3.0 89/10/18 15:10:30 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. + * + * $Log: consarg.c,v $ + * Revision 3.0 89/10/18 15:10:30 lwall + * 3.0 baseline + * + */ + +#include "EXTERN.h" +#include "perl.h" +static int nothing_in_common(); +static int arg_common(); +static int spat_common(); + +ARG * +make_split(stab,arg,limarg) +register STAB *stab; +register ARG *arg; +ARG *limarg; +{ + register SPAT *spat; + + if (arg->arg_type != O_MATCH) { + Newz(201,spat,1,SPAT); + spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ + curstash->tbl_spatroot = spat; + + spat->spat_runtime = arg; + arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat); + } + Renew(arg,4,ARG); + arg->arg_len = 3; + if (limarg) { + if (limarg->arg_type == O_ITEM) { + Copy(limarg+1,arg+3,1,ARG); + limarg[1].arg_type = A_NULL; + arg_free(limarg); + } + else { + arg[3].arg_type = A_EXPR; + arg[3].arg_ptr.arg_arg = limarg; + } + } + else + arg[3].arg_type = A_NULL; + arg->arg_type = O_SPLIT; + spat = arg[2].arg_ptr.arg_spat; + spat->spat_repl = stab2arg(A_STAB,aadd(stab)); + if (spat->spat_short) { /* exact match can bypass regexec() */ + if (!((spat->spat_flags & SPAT_SCANFIRST) && + (spat->spat_flags & SPAT_ALL) )) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; + } + } + return arg; +} + +ARG * +mod_match(type,left,pat) +register ARG *left; +register ARG *pat; +{ + + register SPAT *spat; + register ARG *newarg; + + if ((pat->arg_type == O_MATCH || + pat->arg_type == O_SUBST || + pat->arg_type == O_TRANS || + pat->arg_type == O_SPLIT + ) && + pat[1].arg_ptr.arg_stab == defstab ) { + switch (pat->arg_type) { + case O_MATCH: + newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH, + pat->arg_len, + left,Nullarg,Nullarg); + break; + case O_SUBST: + newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST, + pat->arg_len, + left,Nullarg,Nullarg)); + break; + case O_TRANS: + newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS, + pat->arg_len, + left,Nullarg,Nullarg)); + break; + case O_SPLIT: + newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT, + pat->arg_len, + left,Nullarg,Nullarg); + break; + } + if (pat->arg_len >= 2) { + newarg[2].arg_type = pat[2].arg_type; + newarg[2].arg_ptr = pat[2].arg_ptr; + newarg[2].arg_flags = pat[2].arg_flags; + if (pat->arg_len >= 3) { + newarg[3].arg_type = pat[3].arg_type; + newarg[3].arg_ptr = pat[3].arg_ptr; + newarg[3].arg_flags = pat[3].arg_flags; + } + } + Safefree(pat); + } + else { + Newz(202,spat,1,SPAT); + spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ + curstash->tbl_spatroot = spat; + + spat->spat_runtime = pat; + newarg = make_op(type,2,left,Nullarg,Nullarg); + newarg[2].arg_type = A_SPAT | A_DONT; + newarg[2].arg_ptr.arg_spat = spat; + } + + return newarg; +} + +ARG * +make_op(type,newlen,arg1,arg2,arg3) +int type; +int newlen; +ARG *arg1; +ARG *arg2; +ARG *arg3; +{ + register ARG *arg; + register ARG *chld; + register int doarg; + extern ARG *arg4; /* should be normal arguments, really */ + extern ARG *arg5; + + arg = op_new(newlen); + arg->arg_type = type; + doarg = opargs[type]; + if (chld = arg1) { + if (chld->arg_type == O_ITEM && + (hoistable[chld[1].arg_type] || chld[1].arg_type == A_LVAL || + (chld[1].arg_type == A_LEXPR && + (chld[1].arg_ptr.arg_arg->arg_type == O_LIST || + chld[1].arg_ptr.arg_arg->arg_type == O_ARRAY || + chld[1].arg_ptr.arg_arg->arg_type == O_HASH )))) + { + arg[1].arg_type = chld[1].arg_type; + arg[1].arg_ptr = chld[1].arg_ptr; + arg[1].arg_flags |= chld[1].arg_flags; + arg[1].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[1].arg_type = A_EXPR; + arg[1].arg_ptr.arg_arg = chld; + } + if (!(doarg & 1)) + arg[1].arg_type |= A_DONT; + if (doarg & 2) + arg[1].arg_flags |= AF_ARYOK; + } + doarg >>= 2; + if (chld = arg2) { + if (chld->arg_type == O_ITEM && + (hoistable[chld[1].arg_type] || + (type == O_ASSIGN && + ((chld[1].arg_type == A_READ && !(arg[1].arg_type & A_DONT)) + || + (chld[1].arg_type == A_INDREAD && !(arg[1].arg_type & A_DONT)) + || + (chld[1].arg_type == A_GLOB && !(arg[1].arg_type & A_DONT)) + ) ) ) ) { + arg[2].arg_type = chld[1].arg_type; + arg[2].arg_ptr = chld[1].arg_ptr; + arg[2].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[2].arg_type = A_EXPR; + arg[2].arg_ptr.arg_arg = chld; + } + if (!(doarg & 1)) + arg[2].arg_type |= A_DONT; + if (doarg & 2) + arg[2].arg_flags |= AF_ARYOK; + } + doarg >>= 2; + if (chld = arg3) { + if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) { + arg[3].arg_type = chld[1].arg_type; + arg[3].arg_ptr = chld[1].arg_ptr; + arg[3].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[3].arg_type = A_EXPR; + arg[3].arg_ptr.arg_arg = chld; + } + if (!(doarg & 1)) + arg[3].arg_type |= A_DONT; + if (doarg & 2) + arg[3].arg_flags |= AF_ARYOK; + } + if (newlen >= 4 && (chld = arg4)) { + if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) { + arg[4].arg_type = chld[1].arg_type; + arg[4].arg_ptr = chld[1].arg_ptr; + arg[4].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[4].arg_type = A_EXPR; + arg[4].arg_ptr.arg_arg = chld; + } + } + if (newlen >= 5 && (chld = arg5)) { + if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) { + arg[5].arg_type = chld[1].arg_type; + arg[5].arg_ptr = chld[1].arg_ptr; + arg[5].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[5].arg_type = A_EXPR; + arg[5].arg_ptr.arg_arg = chld; + } + } +#ifdef DEBUGGING + if (debug & 16) { + fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]); + if (arg1) + fprintf(stderr,",%s=%lx", + argname[arg[1].arg_type&A_MASK],arg[1].arg_ptr.arg_arg); + if (arg2) + fprintf(stderr,",%s=%lx", + argname[arg[2].arg_type&A_MASK],arg[2].arg_ptr.arg_arg); + if (arg3) + fprintf(stderr,",%s=%lx", + argname[arg[3].arg_type&A_MASK],arg[3].arg_ptr.arg_arg); + if (newlen >= 4) + fprintf(stderr,",%s=%lx", + argname[arg[4].arg_type&A_MASK],arg[4].arg_ptr.arg_arg); + if (newlen >= 5) + fprintf(stderr,",%s=%lx", + argname[arg[5].arg_type&A_MASK],arg[5].arg_ptr.arg_arg); + fprintf(stderr,")\n"); + } +#endif + evalstatic(arg); /* see if we can consolidate anything */ + return arg; +} + +void +evalstatic(arg) +register ARG *arg; +{ + register STR *str; + register STR *s1; + register STR *s2; + double value; /* must not be register */ + register char *tmps; + int i; + unsigned long tmplong; + long tmp2; + double exp(), log(), sqrt(), modf(); + char *crypt(); + double sin(), cos(), atan2(), pow(); + + if (!arg || !arg->arg_len) + return; + + if ((arg[1].arg_type == A_SINGLE || arg->arg_type == O_AELEM) && + (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) { + str = Str_new(20,0); + s1 = arg[1].arg_ptr.arg_str; + if (arg->arg_len > 1) + s2 = arg[2].arg_ptr.arg_str; + else + s2 = Nullstr; + switch (arg->arg_type) { + case O_AELEM: + i = (int)str_gnum(s2); + if (i < 32767 && i >= 0) { + arg->arg_type = O_ITEM; + arg->arg_len = 1; + arg[1].arg_type = A_ARYSTAB; /* $abc[123] is hoistable now */ + arg[1].arg_len = i; + arg[1].arg_ptr = arg[1].arg_ptr; /* get stab pointer */ + str_free(s2); + } + /* FALL THROUGH */ + default: + str_free(str); + str = Nullstr; /* can't be evaluated yet */ + break; + case O_CONCAT: + str_sset(str,s1); + str_scat(str,s2); + break; + case O_REPEAT: + i = (int)str_gnum(s2); + while (i-- > 0) + str_scat(str,s1); + break; + case O_MULTIPLY: + value = str_gnum(s1); + str_numset(str,value * str_gnum(s2)); + break; + case O_DIVIDE: + value = str_gnum(s2); + if (value == 0.0) + yyerror("Illegal division by constant zero"); + else + str_numset(str,str_gnum(s1) / value); + break; + case O_MODULO: + tmplong = (long)str_gnum(s2); + if (tmplong == 0L) { + yyerror("Illegal modulus of constant zero"); + break; + } + tmp2 = (long)str_gnum(s1); +#ifndef lint + if (tmp2 >= 0) + str_numset(str,(double)(tmp2 % tmplong)); + else + str_numset(str,(double)(tmplong - (-tmp2 % tmplong))); +#else + tmp2 = tmp2; +#endif + break; + case O_ADD: + value = str_gnum(s1); + str_numset(str,value + str_gnum(s2)); + break; + case O_SUBTRACT: + value = str_gnum(s1); + str_numset(str,value - str_gnum(s2)); + break; + case O_LEFT_SHIFT: + value = str_gnum(s1); + i = (int)str_gnum(s2); +#ifndef lint + str_numset(str,(double)(((long)value) << i)); +#endif + break; + case O_RIGHT_SHIFT: + value = str_gnum(s1); + i = (int)str_gnum(s2); +#ifndef lint + str_numset(str,(double)(((long)value) >> i)); +#endif + break; + case O_LT: + value = str_gnum(s1); + str_numset(str,(value < str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_GT: + value = str_gnum(s1); + str_numset(str,(value > str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_LE: + value = str_gnum(s1); + str_numset(str,(value <= str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_GE: + value = str_gnum(s1); + str_numset(str,(value >= str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_EQ: + if (dowarn) { + if ((!s1->str_nok && !looks_like_number(s1)) || + (!s2->str_nok && !looks_like_number(s2)) ) + warn("Possible use of == on string value"); + } + value = str_gnum(s1); + str_numset(str,(value == str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_NE: + value = str_gnum(s1); + str_numset(str,(value != str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_BIT_AND: + value = str_gnum(s1); +#ifndef lint + str_numset(str,(double)(((long)value) & ((long)str_gnum(s2)))); +#endif + break; + case O_XOR: + value = str_gnum(s1); +#ifndef lint + str_numset(str,(double)(((long)value) ^ ((long)str_gnum(s2)))); +#endif + break; + case O_BIT_OR: + value = str_gnum(s1); +#ifndef lint + str_numset(str,(double)(((long)value) | ((long)str_gnum(s2)))); +#endif + break; + case O_AND: + if (str_true(s1)) + str_sset(str,s2); + else + str_sset(str,s1); + break; + case O_OR: + if (str_true(s1)) + str_sset(str,s1); + else + str_sset(str,s2); + break; + case O_COND_EXPR: + if ((arg[3].arg_type & A_MASK) != A_SINGLE) { + str_free(str); + str = Nullstr; + } + else { + if (str_true(s1)) + str_sset(str,s2); + else + str_sset(str,arg[3].arg_ptr.arg_str); + str_free(arg[3].arg_ptr.arg_str); + } + break; + case O_NEGATE: + str_numset(str,(double)(-str_gnum(s1))); + break; + case O_NOT: + str_numset(str,(double)(!str_true(s1))); + break; + case O_COMPLEMENT: +#ifndef lint + str_numset(str,(double)(~(long)str_gnum(s1))); +#endif + break; + case O_SIN: + str_numset(str,sin(str_gnum(s1))); + break; + case O_COS: + str_numset(str,cos(str_gnum(s1))); + break; + case O_ATAN2: + value = str_gnum(s1); + str_numset(str,atan2(value, str_gnum(s2))); + break; + case O_POW: + value = str_gnum(s1); + str_numset(str,pow(value, str_gnum(s2))); + break; + case O_LENGTH: + str_numset(str, (double)str_len(s1)); + break; + case O_SLT: + str_numset(str,(double)(str_cmp(s1,s2) < 0)); + break; + case O_SGT: + str_numset(str,(double)(str_cmp(s1,s2) > 0)); + break; + case O_SLE: + str_numset(str,(double)(str_cmp(s1,s2) <= 0)); + break; + case O_SGE: + str_numset(str,(double)(str_cmp(s1,s2) >= 0)); + break; + case O_SEQ: + str_numset(str,(double)(str_eq(s1,s2))); + break; + case O_SNE: + str_numset(str,(double)(!str_eq(s1,s2))); + break; + case O_CRYPT: +#ifdef CRYPT + tmps = str_get(s1); + str_set(str,crypt(tmps,str_get(s2))); +#else + yyerror( + "The crypt() function is unimplemented due to excessive paranoia."); +#endif + break; + case O_EXP: + str_numset(str,exp(str_gnum(s1))); + break; + case O_LOG: + str_numset(str,log(str_gnum(s1))); + break; + case O_SQRT: + str_numset(str,sqrt(str_gnum(s1))); + break; + case O_INT: + value = str_gnum(s1); + if (value >= 0.0) + (void)modf(value,&value); + else { + (void)modf(-value,&value); + value = -value; + } + str_numset(str,value); + break; + case O_ORD: +#ifndef I286 + str_numset(str,(double)(*str_get(s1))); +#else + { + int zapc; + char *zaps; + + zaps = str_get(s1); + zapc = (int) *zaps; + str_numset(str,(double)(zapc)); + } +#endif + break; + } + if (str) { + arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */ + str_free(s1); + str_free(s2); + arg[1].arg_ptr.arg_str = str; + } + } +} + +ARG * +l(arg) +register ARG *arg; +{ + register int i; + register ARG *arg1; + register ARG *arg2; + SPAT *spat; + int arghog = 0; + + i = arg[1].arg_type & A_MASK; + + arg->arg_flags |= AF_COMMON; /* assume something in common */ + /* which forces us to copy things */ + + if (i == A_ARYLEN) { + arg[1].arg_type = A_LARYLEN; + return arg; + } + if (i == A_ARYSTAB) { + arg[1].arg_type = A_LARYSTAB; + return arg; + } + + /* see if it's an array reference */ + + if (i == A_EXPR || i == A_LEXPR) { + arg1 = arg[1].arg_ptr.arg_arg; + + if (arg1->arg_type == O_LIST || arg1->arg_type == O_ITEM) { + /* assign to list */ + if (arg->arg_len > 1) { + dehoist(arg,2); + arg2 = arg[2].arg_ptr.arg_arg; + if (nothing_in_common(arg1,arg2)) + arg->arg_flags &= ~AF_COMMON; + if (arg->arg_type == O_ASSIGN) { + if (arg1->arg_flags & AF_LOCAL) + arg->arg_flags |= AF_LOCAL; + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + else if (arg->arg_type != O_CHOP) + arg->arg_type = O_ASSIGN; /* possible local(); */ + for (i = arg1->arg_len; i >= 1; i--) { + switch (arg1[i].arg_type) { + case A_STAR: case A_LSTAR: + arg1[i].arg_type = A_LSTAR; + break; + case A_STAB: case A_LVAL: + arg1[i].arg_type = A_LVAL; + break; + case A_ARYLEN: case A_LARYLEN: + arg1[i].arg_type = A_LARYLEN; + break; + case A_ARYSTAB: case A_LARYSTAB: + arg1[i].arg_type = A_LARYSTAB; + break; + case A_EXPR: case A_LEXPR: + arg1[i].arg_type = A_LEXPR; + switch(arg1[i].arg_ptr.arg_arg->arg_type) { + case O_ARRAY: case O_LARRAY: + arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY; + arghog = 1; + break; + case O_AELEM: case O_LAELEM: + arg1[i].arg_ptr.arg_arg->arg_type = O_LAELEM; + break; + case O_HASH: case O_LHASH: + arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH; + arghog = 1; + break; + case O_HELEM: case O_LHELEM: + arg1[i].arg_ptr.arg_arg->arg_type = O_LHELEM; + break; + case O_ASLICE: case O_LASLICE: + arg1[i].arg_ptr.arg_arg->arg_type = O_LASLICE; + break; + case O_HSLICE: case O_LHSLICE: + arg1[i].arg_ptr.arg_arg->arg_type = O_LHSLICE; + break; + default: + goto ill_item; + } + break; + default: + ill_item: + (void)sprintf(tokenbuf, "Illegal item (%s) as lvalue", + argname[arg1[i].arg_type&A_MASK]); + yyerror(tokenbuf); + } + } + if (arg->arg_len > 1) { + if (arg2->arg_type == O_SPLIT && !arg2[3].arg_type && !arghog) { + arg2[3].arg_type = A_SINGLE; + arg2[3].arg_ptr.arg_str = + str_nmake((double)arg1->arg_len + 1); /* limit split len*/ + } + } + } + else if (arg1->arg_type == O_AELEM || arg1->arg_type == O_LAELEM) + arg1->arg_type = O_LAELEM; + else if (arg1->arg_type == O_ARRAY || arg1->arg_type == O_LARRAY) { + arg1->arg_type = O_LARRAY; + if (arg->arg_len > 1) { + dehoist(arg,2); + arg2 = arg[2].arg_ptr.arg_arg; + if (arg2->arg_type == O_SPLIT) { /* use split's builtin =?*/ + spat = arg2[2].arg_ptr.arg_spat; + if (spat->spat_repl[1].arg_ptr.arg_stab == defstab && + nothing_in_common(arg1,spat->spat_repl)) { + spat->spat_repl[1].arg_ptr.arg_stab = + arg1[1].arg_ptr.arg_stab; + arg_free(arg1); /* recursive */ + free_arg(arg); /* non-recursive */ + return arg2; /* split has builtin assign */ + } + } + else if (nothing_in_common(arg1,arg2)) + arg->arg_flags &= ~AF_COMMON; + if (arg->arg_type == O_ASSIGN) { + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + } + else if (arg1->arg_type == O_HELEM || arg1->arg_type == O_LHELEM) + arg1->arg_type = O_LHELEM; + else if (arg1->arg_type == O_HASH || arg1->arg_type == O_LHASH) { + arg1->arg_type = O_LHASH; + if (arg->arg_len > 1) { + dehoist(arg,2); + arg2 = arg[2].arg_ptr.arg_arg; + if (nothing_in_common(arg1,arg2)) + arg->arg_flags &= ~AF_COMMON; + if (arg->arg_type == O_ASSIGN) { + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + } + else if (arg1->arg_type == O_ASLICE) { + arg1->arg_type = O_LASLICE; + if (arg->arg_type == O_ASSIGN) { + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + else if (arg1->arg_type == O_HSLICE) { + arg1->arg_type = O_LHSLICE; + if (arg->arg_type == O_ASSIGN) { + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + else if ((arg->arg_type == O_DEFINED || arg->arg_type == O_UNDEF) && + (arg1->arg_type == (perldb ? O_DBSUBR : O_SUBR)) ) { + arg[1].arg_type |= A_DONT; + } + else if (arg1->arg_type == O_SUBSTR || arg1->arg_type == O_VEC) { + (void)l(arg1); + Renewc(arg1->arg_ptr.arg_str, 1, struct lstring, STR); + /* grow string struct to hold an lstring struct */ + } + else if (arg1->arg_type == O_ASSIGN) { + if (arg->arg_type == O_CHOP) + arg[1].arg_flags &= ~AF_ARYOK; /* grandfather chop idiom */ + } + else { + (void)sprintf(tokenbuf, + "Illegal expression (%s) as lvalue",opname[arg1->arg_type]); + yyerror(tokenbuf); + } + arg[1].arg_type = A_LEXPR | (arg[1].arg_type & A_DONT); + if (arg->arg_type == O_ASSIGN && (arg1[1].arg_flags & AF_ARYOK)) { + arg[1].arg_flags |= AF_ARYOK; + if (arg->arg_len > 1) + arg[2].arg_flags |= AF_ARYOK; + } +#ifdef DEBUGGING + if (debug & 16) + fprintf(stderr,"lval LEXPR\n"); +#endif + return arg; + } + if (i == A_STAR || i == A_LSTAR) { + arg[1].arg_type = A_LSTAR | (arg[1].arg_type & A_DONT); + return arg; + } + + /* not an array reference, should be a register name */ + + if (i != A_STAB && i != A_LVAL) { + (void)sprintf(tokenbuf, + "Illegal item (%s) as lvalue",argname[arg[1].arg_type&A_MASK]); + yyerror(tokenbuf); + } + arg[1].arg_type = A_LVAL | (arg[1].arg_type & A_DONT); +#ifdef DEBUGGING + if (debug & 16) + fprintf(stderr,"lval LVAL\n"); +#endif + return arg; +} + +ARG * +fixl(type,arg) +int type; +ARG *arg; +{ + if (type == O_DEFINED || type == O_UNDEF) { + if (arg->arg_type != O_ITEM) + arg = hide_ary(arg); + if (arg->arg_type == O_ITEM) { + type = arg[1].arg_type & A_MASK; + if (type == A_EXPR || type == A_LEXPR) + arg[1].arg_type = A_LEXPR|A_DONT; + } + } + return arg; +} + +dehoist(arg,i) +ARG *arg; +{ + ARG *tmparg; + + if (arg[i].arg_type != A_EXPR) { /* dehoist */ + tmparg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg); + tmparg[1] = arg[i]; + arg[i].arg_ptr.arg_arg = tmparg; + arg[i].arg_type = A_EXPR; + } +} + +ARG * +addflags(i,flags,arg) +register ARG *arg; +{ + arg[i].arg_flags |= flags; + return arg; +} + +ARG * +hide_ary(arg) +ARG *arg; +{ + if (arg->arg_type == O_ARRAY || arg->arg_type == O_HASH) + return make_op(O_ITEM,1,arg,Nullarg,Nullarg); + return arg; +} + +/* maybe do a join on multiple array dimensions */ + +ARG * +jmaybe(arg) +register ARG *arg; +{ + if (arg && arg->arg_type == O_COMMA) { + arg = listish(arg); + arg = make_op(O_JOIN, 2, + stab2arg(A_STAB,stabent(";",TRUE)), + make_list(arg), + Nullarg); + } + return arg; +} + +ARG * +make_list(arg) +register ARG *arg; +{ + register int i; + register ARG *node; + register ARG *nxtnode; + register int j; + STR *tmpstr; + + if (!arg) { + arg = op_new(0); + arg->arg_type = O_LIST; + } + if (arg->arg_type != O_COMMA) { + if (arg->arg_type != O_ARRAY) + arg->arg_flags |= AF_LISTISH; /* see listish() below */ + return arg; + } + for (i = 2, node = arg; ; i++) { + if (node->arg_len < 2) + break; + if (node[1].arg_type != A_EXPR) + break; + node = node[1].arg_ptr.arg_arg; + if (node->arg_type != O_COMMA) + break; + } + if (i > 2) { + node = arg; + arg = op_new(i); + tmpstr = arg->arg_ptr.arg_str; +#ifdef STRUCTCOPY + *arg = *node; /* copy everything except the STR */ +#else + (void)bcopy((char *)node, (char *)arg, sizeof(ARG)); +#endif + arg->arg_ptr.arg_str = tmpstr; + for (j = i; ; ) { +#ifdef STRUCTCOPY + arg[j] = node[2]; +#else + (void)bcopy((char *)(node+2), (char *)(arg+j), sizeof(ARG)); +#endif + arg[j].arg_flags |= AF_ARYOK; + --j; /* Bug in Xenix compiler */ + if (j < 2) { +#ifdef STRUCTCOPY + arg[1] = node[1]; +#else + (void)bcopy((char *)(node+1), (char *)(arg+1), sizeof(ARG)); +#endif + free_arg(node); + break; + } + nxtnode = node[1].arg_ptr.arg_arg; + free_arg(node); + node = nxtnode; + } + } + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + arg->arg_type = O_LIST; + arg->arg_len = i; + return arg; +} + +/* turn a single item into a list */ + +ARG * +listish(arg) +ARG *arg; +{ + if (arg->arg_flags & AF_LISTISH) + arg = make_op(O_LIST,1,arg,Nullarg,Nullarg); + return arg; +} + +ARG * +maybelistish(optype, arg) +int optype; +ARG *arg; +{ + if (optype == O_PRTF || + (arg->arg_type == O_ASLICE || arg->arg_type == O_HSLICE || + arg->arg_type == O_F_OR_R) ) + arg = listish(arg); + return arg; +} + +/* mark list of local variables */ + +ARG * +localize(arg) +ARG *arg; +{ + arg->arg_flags |= AF_LOCAL; + return arg; +} + +ARG * +fixeval(arg) +ARG *arg; +{ + Renew(arg, 3, ARG); + arg->arg_len = 2; + arg[2].arg_ptr.arg_hash = curstash; + arg[2].arg_type = A_NULL; + return arg; +} + +ARG * +rcatmaybe(arg) +ARG *arg; +{ + if (arg->arg_type == O_CONCAT && arg[2].arg_type == A_READ) { + arg->arg_type = O_RCAT; + arg[2].arg_type = arg[2].arg_ptr.arg_arg[1].arg_type; + arg[2].arg_ptr = arg[2].arg_ptr.arg_arg[1].arg_ptr; + free_arg(arg[2].arg_ptr.arg_arg); + } + return arg; +} + +ARG * +stab2arg(atype,stab) +int atype; +register STAB *stab; +{ + register ARG *arg; + + arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = atype; + arg[1].arg_ptr.arg_stab = stab; + return arg; +} + +ARG * +cval_to_arg(cval) +register char *cval; +{ + register ARG *arg; + + arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = A_SINGLE; + arg[1].arg_ptr.arg_str = str_make(cval,0); + Safefree(cval); + return arg; +} + +ARG * +op_new(numargs) +int numargs; +{ + register ARG *arg; + + Newz(203,arg, numargs + 1, ARG); + arg->arg_ptr.arg_str = Str_new(21,0); + arg->arg_len = numargs; + return arg; +} + +void +free_arg(arg) +ARG *arg; +{ + str_free(arg->arg_ptr.arg_str); + Safefree(arg); +} + +ARG * +make_match(type,expr,spat) +int type; +ARG *expr; +SPAT *spat; +{ + register ARG *arg; + + arg = make_op(type,2,expr,Nullarg,Nullarg); + + arg[2].arg_type = A_SPAT|A_DONT; + arg[2].arg_ptr.arg_spat = spat; +#ifdef DEBUGGING + if (debug & 16) + fprintf(stderr,"make_match SPAT=%lx\n",(long)spat); +#endif + + if (type == O_SUBST || type == O_NSUBST) { + if (arg[1].arg_type != A_STAB) { + yyerror("Illegal lvalue"); + } + arg[1].arg_type = A_LVAL; + } + return arg; +} + +ARG * +cmd_to_arg(cmd) +CMD *cmd; +{ + register ARG *arg; + + arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = A_CMD; + arg[1].arg_ptr.arg_cmd = cmd; + return arg; +} + +/* Check two expressions to see if there is any identifier in common */ + +static int +nothing_in_common(arg1,arg2) +ARG *arg1; +ARG *arg2; +{ + static int thisexpr = 0; /* I don't care if this wraps */ + + thisexpr++; + if (arg_common(arg1,thisexpr,1)) + return 0; /* hit eval or do {} */ + if (arg_common(arg2,thisexpr,0)) + return 0; /* hit identifier again */ + return 1; +} + +/* Recursively descend an expression and mark any identifier or check + * it to see if it was marked already. + */ + +static int +arg_common(arg,exprnum,marking) +register ARG *arg; +int exprnum; +int marking; +{ + register int i; + + if (!arg) + return 0; + for (i = arg->arg_len; i >= 1; i--) { + switch (arg[i].arg_type & A_MASK) { + case A_NULL: + break; + case A_LEXPR: + case A_EXPR: + if (arg_common(arg[i].arg_ptr.arg_arg,exprnum,marking)) + return 1; + break; + case A_CMD: + return 1; /* assume hanky panky */ + case A_STAR: + case A_LSTAR: + case A_STAB: + case A_LVAL: + case A_ARYLEN: + case A_LARYLEN: + if (marking) + stab_lastexpr(arg[i].arg_ptr.arg_stab) = exprnum; + else if (stab_lastexpr(arg[i].arg_ptr.arg_stab) == exprnum) + return 1; + break; + case A_DOUBLE: + case A_BACKTICK: + { + register char *s = arg[i].arg_ptr.arg_str->str_ptr; + register char *send = s + arg[i].arg_ptr.arg_str->str_cur; + register STAB *stab; + + while (*s) { + if (*s == '$' && s[1]) { + s = scanreg(s,send,tokenbuf); + stab = stabent(tokenbuf,TRUE); + if (marking) + stab_lastexpr(stab) = exprnum; + else if (stab_lastexpr(stab) == exprnum) + return 1; + continue; + } + else if (*s == '\\' && s[1]) + s++; + s++; + } + } + break; + case A_SPAT: + if (spat_common(arg[i].arg_ptr.arg_spat,exprnum,marking)) + return 1; + break; + case A_READ: + case A_INDREAD: + case A_GLOB: + case A_WORD: + case A_SINGLE: + break; + } + } + switch (arg->arg_type) { + case O_ARRAY: + case O_LARRAY: + if ((arg[1].arg_type & A_MASK) == A_STAB) + (void)aadd(arg[1].arg_ptr.arg_stab); + break; + case O_HASH: + case O_LHASH: + if ((arg[1].arg_type & A_MASK) == A_STAB) + (void)hadd(arg[1].arg_ptr.arg_stab); + break; + case O_EVAL: + case O_SUBR: + case O_DBSUBR: + return 1; + } + return 0; +} + +static int +spat_common(spat,exprnum,marking) +register SPAT *spat; +int exprnum; +int marking; +{ + if (spat->spat_runtime) + if (arg_common(spat->spat_runtime,exprnum,marking)) + return 1; + if (spat->spat_repl) { + if (arg_common(spat->spat_repl,exprnum,marking)) + return 1; + } + return 0; +} diff --git a/doarg.c b/doarg.c new file mode 100644 index 0000000..7ff4d4d --- /dev/null +++ b/doarg.c @@ -0,0 +1,1264 @@ +/* $Header: doarg.c,v 3.0 89/10/18 15:10:41 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. + * + * $Log: doarg.c,v $ + * Revision 3.0 89/10/18 15:10:41 lwall + * 3.0 baseline + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#include + +extern unsigned char fold[]; + +int wantarray; + +int +do_subst(str,arg,sp) +STR *str; +ARG *arg; +int sp; +{ + register SPAT *spat; + SPAT *rspat; + register STR *dstr; + register char *s = str_get(str); + char *strend = s + str->str_cur; + register char *m; + char *c; + register char *d; + int clen; + int iters = 0; + register int i; + bool once; + char *orig; + int safebase; + + rspat = spat = arg[2].arg_ptr.arg_spat; + if (!spat || !s) + fatal("panic: do_subst"); + else if (spat->spat_runtime) { + nointrp = "|)"; + (void)eval(spat->spat_runtime,G_SCALAR,sp); + m = str_get(dstr = stack->ary_array[sp+1]); + nointrp = ""; + if (spat->spat_regexp) + regfree(spat->spat_regexp); + spat->spat_regexp = regcomp(m,m+dstr->str_cur, + spat->spat_flags & SPAT_FOLD,1); + if (spat->spat_flags & SPAT_KEEP) { + arg_free(spat->spat_runtime); /* it won't change, so */ + spat->spat_runtime = Nullarg; /* no point compiling again */ + } + } +#ifdef DEBUGGING + if (debug & 8) { + deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); + } +#endif + safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) && + !sawampersand); + if (!*spat->spat_regexp->precomp && lastspat) + spat = lastspat; + orig = 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) { + if (str->str_pok & SP_STUDIED) { + if (screamfirst[spat->spat_short->str_rare] < 0) + goto nope; + else if (!(s = screaminstr(str,spat->spat_short))) + goto nope; + } +#ifndef lint + else if (!(s = fbminstr((unsigned char*)s, (unsigned char*)strend, + spat->spat_short))) + goto nope; +#endif + if (s && spat->spat_regexp->regback >= 0) { + ++spat->spat_short->str_u.str_useful; + s -= spat->spat_regexp->regback; + if (s < m) + s = m; + } + else + s = m; + } + else if (!multiline && (*spat->spat_short->str_ptr != *s || + bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) )) + goto nope; + if (--spat->spat_short->str_u.str_useful < 0) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; /* opt is being useless */ + } + } + once = ((rspat->spat_flags & SPAT_ONCE) != 0); + if (rspat->spat_flags & SPAT_CONST) { /* known replacement string? */ + if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE) + dstr = rspat->spat_repl[1].arg_ptr.arg_str; + else { /* constant over loop, anyway */ + (void)eval(rspat->spat_repl,G_SCALAR,sp); + dstr = stack->ary_array[sp+1]; + } + c = str_get(dstr); + clen = dstr->str_cur; + if (clen <= spat->spat_slen + spat->spat_regexp->regback) { + /* can do inplace substitution */ + if (regexec(spat->spat_regexp, s, strend, orig, 1, + str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) { + if (spat->spat_regexp->subbase) /* oops, no we can't */ + goto long_way; + d = s; + lastspat = spat; + str->str_pok = SP_VALID; /* disable possible screamer */ + if (once) { + m = spat->spat_regexp->startp[0]; + d = spat->spat_regexp->endp[0]; + s = orig; + if (m - s > strend - d) { /* faster to shorten from end */ + if (clen) { + (void)bcopy(c, m, clen); + m += clen; + } + i = strend - d; + if (i > 0) { + (void)bcopy(d, m, i); + m += i; + } + *m = '\0'; + str->str_cur = m - s; + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + else if (i = m - s) { /* faster from front */ + d -= clen; + m = d; + str_chop(str,d-i); + s += i; + while (i--) + *--d = *--s; + if (clen) + (void)bcopy(c, m, clen); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + else if (clen) { + d -= clen; + str_chop(str,d); + (void)bcopy(c,d,clen); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + else { + str_chop(str,d); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + /* NOTREACHED */ + } + do { + if (iters++ > 10000) + fatal("Substitution loop"); + m = spat->spat_regexp->startp[0]; + if (i = m - s) { + if (s != d) + (void)bcopy(s,d,i); + d += i; + } + if (clen) { + (void)bcopy(c,d,clen); + d += clen; + } + s = spat->spat_regexp->endp[0]; + } while (regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, + TRUE)); + if (s != d) { + i = strend - s; + str->str_cur = d - str->str_ptr + i; + (void)bcopy(s,d,i+1); /* include the Null */ + } + STABSET(str); + str_numset(arg->arg_ptr.arg_str, (double)iters); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + str_numset(arg->arg_ptr.arg_str, 0.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + } + else + c = Nullch; + if (regexec(spat->spat_regexp, s, strend, orig, 1, + str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) { + long_way: + dstr = Str_new(25,str_len(str)); + str_nset(dstr,m,s-m); + if (spat->spat_regexp->subbase) + curspat = spat; + lastspat = spat; + do { + if (iters++ > 10000) + fatal("Substitution loop"); + if (spat->spat_regexp->subbase + && spat->spat_regexp->subbase != orig) { + m = s; + s = orig; + orig = spat->spat_regexp->subbase; + s = orig + (m - s); + strend = s + (strend - m); + } + m = spat->spat_regexp->startp[0]; + str_ncat(dstr,s,m-s); + s = spat->spat_regexp->endp[0]; + if (c) { + if (clen) + str_ncat(dstr,c,clen); + } + else { + (void)eval(rspat->spat_repl,G_SCALAR,sp); + str_scat(dstr,stack->ary_array[sp+1]); + } + if (once) + break; + } while (regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, + safebase)); + str_ncat(dstr,s,strend - s); + str_replace(str,dstr); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, (double)iters); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + str_numset(arg->arg_ptr.arg_str, 0.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + +nope: + ++spat->spat_short->str_u.str_useful; + str_numset(arg->arg_ptr.arg_str, 0.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; +} + +int +do_trans(str,arg) +STR *str; +register ARG *arg; +{ + register char *tbl; + register char *s; + register int matches = 0; + register int ch; + register char *send; + + tbl = arg[2].arg_ptr.arg_cval; + s = str_get(str); + send = s + str->str_cur; + if (!tbl || !s) + fatal("panic: do_trans"); +#ifdef DEBUGGING + if (debug & 8) { + deb("2.TBL\n"); + } +#endif + while (s < send) { + if (ch = tbl[*s & 0377]) { + matches++; + *s = ch; + } + s++; + } + STABSET(str); + return matches; +} + +void +do_join(str,arglast) +register STR *str; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register char *delim = str_get(st[sp]); + int delimlen = st[sp]->str_cur; + + st += ++sp; + if (items-- > 0) + str_sset(str,*st++); + else + str_set(str,""); + for (; items > 0; items--,st++) { + str_ncat(str,delim,delimlen); + str_scat(str,*st); + } + STABSET(str); +} + +void +do_pack(str,arglast) +register STR *str; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items; + register char *pat = str_get(st[sp]); + register char *patend = pat + st[sp]->str_cur; + register int len; + int datumtype; + STR *fromstr; + static char *null10 = "\0\0\0\0\0\0\0\0\0\0"; + static char *space10 = " "; + + /* These must not be in registers: */ + char achar; + short ashort; + int aint; + long along; + char *aptr; + + items = arglast[2] - sp; + st += ++sp; + str_nset(str,"",0); + while (pat < patend) { +#define NEXTFROM (items-- > 0 ? *st++ : &str_no) + datumtype = *pat++; + if (isdigit(*pat)) { + len = atoi(pat); + while (isdigit(*pat)) + pat++; + } + else + len = 1; + switch(datumtype) { + default: + break; + case 'x': + while (len >= 10) { + str_ncat(str,null10,10); + len -= 10; + } + str_ncat(str,null10,len); + break; + case 'A': + case 'a': + fromstr = NEXTFROM; + aptr = str_get(fromstr); + if (fromstr->str_cur > len) + str_ncat(str,aptr,len); + else + str_ncat(str,aptr,fromstr->str_cur); + len -= fromstr->str_cur; + if (datumtype == 'A') { + while (len >= 10) { + str_ncat(str,space10,10); + len -= 10; + } + str_ncat(str,space10,len); + } + else { + while (len >= 10) { + str_ncat(str,null10,10); + len -= 10; + } + str_ncat(str,null10,len); + } + break; + case 'C': + case 'c': + while (len-- > 0) { + fromstr = NEXTFROM; + aint = (int)str_gnum(fromstr); + achar = aint; + str_ncat(str,&achar,sizeof(char)); + } + break; + case 'n': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (short)str_gnum(fromstr); +#ifdef HTONS + ashort = htons(ashort); +#endif + str_ncat(str,(char*)&ashort,sizeof(short)); + } + break; + case 'S': + case 's': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (short)str_gnum(fromstr); + str_ncat(str,(char*)&ashort,sizeof(short)); + } + break; + case 'I': + case 'i': + while (len-- > 0) { + fromstr = NEXTFROM; + aint = (int)str_gnum(fromstr); + str_ncat(str,(char*)&aint,sizeof(int)); + } + break; + case 'N': + while (len-- > 0) { + fromstr = NEXTFROM; + along = (long)str_gnum(fromstr); +#ifdef HTONL + along = htonl(along); +#endif + str_ncat(str,(char*)&along,sizeof(long)); + } + break; + case 'L': + case 'l': + while (len-- > 0) { + fromstr = NEXTFROM; + along = (long)str_gnum(fromstr); + str_ncat(str,(char*)&along,sizeof(long)); + } + break; + case 'p': + while (len-- > 0) { + fromstr = NEXTFROM; + aptr = str_get(fromstr); + str_ncat(str,(char*)&aptr,sizeof(char*)); + } + break; + } + } + STABSET(str); +} +#undef NEXTFROM + +void +do_sprintf(str,len,sarg) +register STR *str; +register int len; +register STR **sarg; +{ + register char *s; + register char *t; + bool dolong; + char ch; + static STR *sargnull = &str_no; + register char *send; + char *xs; + int xlen; + + str_set(str,""); + len--; /* don't count pattern string */ + s = str_get(*sarg); + send = s + (*sarg)->str_cur; + sarg++; + for ( ; s < send; len--) { + if (len <= 0 || !*sarg) { + sarg = &sargnull; + len = 0; + } + dolong = FALSE; + for (t = s; t < send && *t != '%'; t++) ; + if (t >= send) + break; /* not enough % patterns, oh well */ + for (t++; *sarg && t < send && t != s; t++) { + switch (*t) { + default: + ch = *(++t); + *t = '\0'; + (void)sprintf(buf,s); + s = t; + *(t--) = ch; + len++; + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + case '.': case '#': case '-': case '+': + break; + case 'l': + dolong = TRUE; + break; + case 'D': case 'X': case 'O': + dolong = TRUE; + /* FALL THROUGH */ + case 'c': + *buf = (int)str_gnum(*(sarg++)); + str_ncat(str,buf,1); /* force even if null */ + *buf = '\0'; + s = t+1; + break; + case 'd': case 'x': case 'o': case 'u': + ch = *(++t); + *t = '\0'; + if (dolong) + (void)sprintf(buf,s,(long)str_gnum(*(sarg++))); + else + (void)sprintf(buf,s,(int)str_gnum(*(sarg++))); + s = t; + *(t--) = ch; + break; + case 'E': case 'e': case 'f': case 'G': case 'g': + ch = *(++t); + *t = '\0'; + (void)sprintf(buf,s,str_gnum(*(sarg++))); + s = t; + *(t--) = ch; + break; + case 's': + ch = *(++t); + *t = '\0'; + xs = str_get(*sarg); + xlen = (*sarg)->str_cur; + if (*xs == 'S' && xs[1] == 't' && xs[2] == 'a' && xs[3] == 'b' + && xlen == sizeof(STBP) && strlen(xs) < xlen) { + xs = stab_name(((STAB*)(*sarg))); /* a stab value! */ + sprintf(tokenbuf,"*%s",xs); /* reformat to non-binary */ + xs = tokenbuf; + xlen = strlen(tokenbuf); + } + if (strEQ(t-2,"%s")) { /* some printfs fail on >128 chars */ + *buf = '\0'; + str_ncat(str,s,t - s - 2); + str_ncat(str,xs,xlen); /* so handle simple case */ + } + else + (void)sprintf(buf,s,xs); + sarg++; + s = t; + *(t--) = ch; + break; + } + } + if (s < t && t >= send) { + str_cat(str,s); + s = t; + break; + } + str_cat(str,buf); + } + if (*s) { + (void)sprintf(buf,s,0,0,0,0); + str_cat(str,buf); + } + STABSET(str); +} + +STR * +do_push(ary,arglast) +register ARRAY *ary; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register STR *str = &str_undef; + + for (st += ++sp; items > 0; items--,st++) { + str = Str_new(26,0); + if (*st) + str_sset(str,*st); + (void)apush(ary,str); + } + return str; +} + +int +do_unshift(ary,arglast) +register ARRAY *ary; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register STR *str; + register int i; + + aunshift(ary,items); + i = 0; + for (st += ++sp; i < items; i++,st++) { + str = Str_new(27,0); + str_sset(str,*st); + (void)astore(ary,i,str); + } +} + +int +do_subr(arg,gimme,arglast) +register ARG *arg; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register SUBR *sub; + ARRAY *savearray; + STAB *stab; + char *oldfile = filename; + int oldsave = savestack->ary_fill; + int oldtmps_base = tmps_base; + + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else { + STR *tmpstr = stab_val(arg[1].arg_ptr.arg_stab); + + if (tmpstr) + stab = stabent(str_get(tmpstr),TRUE); + else + stab = Nullstab; + } + if (!stab) + fatal("Undefined subroutine called"); + sub = stab_sub(stab); + if (!sub) + fatal("Undefined subroutine \"%s\" called", stab_name(stab)); + if ((arg[2].arg_type & A_MASK) != A_NULL) { + savearray = stab_xarray(defstab); + stab_xarray(defstab) = afake(defstab, items, &st[sp+1]); + } + savelong(&sub->depth); + sub->depth++; + saveint(&wantarray); + wantarray = gimme; + if (sub->depth >= 2) { /* save temporaries on recursion? */ + if (sub->depth == 100 && dowarn) + warn("Deep recursion on subroutine \"%s\"",stab_name(stab)); + savelist(sub->tosave->ary_array,sub->tosave->ary_fill); + } + filename = sub->filename; + tmps_base = tmps_max; + sp = cmd_exec(sub->cmd,gimme,--sp); /* so do it already */ + st = stack->ary_array; + + if ((arg[2].arg_type & A_MASK) != A_NULL) { + afree(stab_xarray(defstab)); /* put back old $_[] */ + stab_xarray(defstab) = savearray; + } + filename = oldfile; + tmps_base = oldtmps_base; + if (savestack->ary_fill > oldsave) { + for (items = arglast[0] + 1; items <= sp; items++) + st[items] = str_static(st[items]); + /* in case restore wipes old str */ + restorelist(oldsave); + } + return sp; +} + +int +do_dbsubr(arg,gimme,arglast) +register ARG *arg; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register SUBR *sub; + ARRAY *savearray; + STR *str; + STAB *stab; + char *oldfile = filename; + int oldsave = savestack->ary_fill; + int oldtmps_base = tmps_base; + + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else { + STR *tmpstr = stab_val(arg[1].arg_ptr.arg_stab); + + if (tmpstr) + stab = stabent(str_get(tmpstr),TRUE); + else + stab = Nullstab; + } + if (!stab) + fatal("Undefined subroutine called"); + sub = stab_sub(stab); + if (!sub) + fatal("Undefined subroutine \"%s\" called", stab_name(stab)); +/* begin differences */ + str = stab_val(DBsub); + saveitem(str); + str_set(str,stab_name(stab)); + sub = stab_sub(DBsub); + if (!sub) + fatal("No DBsub routine"); +/* end differences */ + if ((arg[2].arg_type & A_MASK) != A_NULL) { + savearray = stab_xarray(defstab); + stab_xarray(defstab) = afake(defstab, items, &st[sp+1]); + } + savelong(&sub->depth); + sub->depth++; + saveint(&wantarray); + wantarray = gimme; + if (sub->depth >= 2) { /* save temporaries on recursion? */ + if (sub->depth == 100 && dowarn) + warn("Deep recursion on subroutine \"%s\"",stab_name(stab)); + savelist(sub->tosave->ary_array,sub->tosave->ary_fill); + } + filename = sub->filename; + tmps_base = tmps_max; + sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */ + st = stack->ary_array; + + if ((arg[2].arg_type & A_MASK) != A_NULL) { + afree(stab_xarray(defstab)); /* put back old $_[] */ + stab_xarray(defstab) = savearray; + } + filename = oldfile; + tmps_base = oldtmps_base; + if (savestack->ary_fill > oldsave) { + for (items = arglast[0] + 1; items <= sp; items++) + st[items] = str_static(st[items]); + /* in case restore wipes old str */ + restorelist(oldsave); + } + return sp; +} + +int +do_assign(arg,gimme,arglast) +register ARG *arg; +int gimme; +int *arglast; +{ + + register STR **st = stack->ary_array; + STR **firstrelem = st + arglast[1] + 1; + STR **firstlelem = st + arglast[0] + 1; + STR **lastrelem = st + arglast[2]; + STR **lastlelem = st + arglast[1]; + register STR **relem; + register STR **lelem; + + register STR *str; + register ARRAY *ary; + register int makelocal; + HASH *hash; + int i; + + makelocal = (arg->arg_flags & AF_LOCAL); + delaymagic = DM_DELAY; /* catch simultaneous items */ + + /* If there's a common identifier on both sides we have to take + * special care that assigning the identifier on the left doesn't + * clobber a value on the right that's used later in the list. + */ + if (arg->arg_flags & AF_COMMON) { + for (relem = firstrelem; relem <= lastrelem; relem++) { + if (str = *relem) + *relem = str_static(str); + } + } + relem = firstrelem; + lelem = firstlelem; + ary = Null(ARRAY*); + hash = Null(HASH*); + while (lelem <= lastlelem) { + str = *lelem++; + if (str->str_state >= SS_HASH) { + if (str->str_state == SS_ARY) { + if (makelocal) + ary = saveary(str->str_u.str_stab); + else { + ary = stab_array(str->str_u.str_stab); + ary->ary_fill = -1; + } + i = 0; + while (relem <= lastrelem) { /* gobble up all the rest */ + str = Str_new(28,0); + if (*relem) + str_sset(str,*(relem++)); + else + relem++; + (void)astore(ary,i++,str); + } + } + else if (str->str_state == SS_HASH) { + char *tmps; + STR *tmpstr; + + if (makelocal) + hash = savehash(str->str_u.str_stab); + else { + hash = stab_hash(str->str_u.str_stab); + hclear(hash); + } + while (relem < lastrelem) { /* gobble up all the rest */ + if (*relem) + str = *(relem++); + else + str = &str_no, relem++; + tmps = str_get(str); + tmpstr = Str_new(29,0); + if (*relem) + str_sset(tmpstr,*(relem++)); /* value */ + else + relem++; + (void)hstore(hash,tmps,str->str_cur,tmpstr,0); + } + } + else + fatal("panic: do_assign"); + } + else { + if (makelocal) + saveitem(str); + if (relem <= lastrelem) + str_sset(str, *(relem++)); + else + str_nset(str, "", 0); + STABSET(str); + } + } + if (delaymagic > 1) { +#ifdef SETREUID + if (delaymagic & DM_REUID) + setreuid(uid,euid); +#endif +#ifdef SETREGID + if (delaymagic & DM_REGID) + setregid(gid,egid); +#endif + } + delaymagic = 0; + if (gimme == G_ARRAY) { + i = lastrelem - firstrelem + 1; + if (ary || hash) + Copy(firstrelem, firstlelem, i, STR*); + return arglast[0] + i; + } + else { + str_numset(arg->arg_ptr.arg_str,(double)(arglast[2] - arglast[1])); + *firstlelem = arg->arg_ptr.arg_str; + return arglast[0] + 1; + } +} + +int +do_study(str,arg,gimme,arglast) +STR *str; +ARG *arg; +int gimme; +int *arglast; +{ + register unsigned char *s; + register int pos = str->str_cur; + register int ch; + register int *sfirst; + register int *snext; + static int maxscream = -1; + static STR *lastscream = Nullstr; + int retval; + int retarg = arglast[0] + 1; + +#ifndef lint + s = (unsigned char*)(str_get(str)); +#else + s = Null(unsigned char*); +#endif + if (lastscream) + lastscream->str_pok &= ~SP_STUDIED; + lastscream = str; + if (pos <= 0) { + retval = 0; + goto ret; + } + if (pos > maxscream) { + if (maxscream < 0) { + maxscream = pos + 80; + New(301,screamfirst, 256, int); + New(302,screamnext, maxscream, int); + } + else { + maxscream = pos + pos / 4; + Renew(screamnext, maxscream, 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; + + /* If there were any case insensitive searches, we must assume they + * all are. This speeds up insensitive searches much more than + * it slows down sensitive ones. + */ + if (sawi) + sfirst[fold[ch]] = pos; + } + + str->str_pok |= SP_STUDIED; + retval = 1; + ret: + str_numset(arg->arg_ptr.arg_str,(double)retval); + stack->ary_array[retarg] = arg->arg_ptr.arg_str; + return retarg; +} + +int +do_defined(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register int type; + register int retarg = arglast[0] + 1; + int retval; + + if ((arg[1].arg_type & A_MASK) != A_LEXPR) + fatal("Illegal argument to defined()"); + arg = arg[1].arg_ptr.arg_arg; + type = arg->arg_type; + + if (type == O_ARRAY || type == O_LARRAY) + retval = stab_xarray(arg[1].arg_ptr.arg_stab) != 0; + else if (type == O_HASH || type == O_LHASH) + retval = stab_xhash(arg[1].arg_ptr.arg_stab) != 0; + else if (type == O_SUBR || type == O_DBSUBR) + retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0; + else if (type == O_ASLICE || type == O_LASLICE) + retval = stab_xarray(arg[1].arg_ptr.arg_stab) != 0; + else if (type == O_HSLICE || type == O_LHSLICE) + retval = stab_xhash(arg[1].arg_ptr.arg_stab) != 0; + else + retval = FALSE; + str_numset(str,(double)retval); + stack->ary_array[retarg] = str; + return retarg; +} + +int +do_undef(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register int type; + register STAB *stab; + int retarg = arglast[0] + 1; + + if ((arg[1].arg_type & A_MASK) != A_LEXPR) + fatal("Illegal argument to undef()"); + arg = arg[1].arg_ptr.arg_arg; + type = arg->arg_type; + + if (type == O_ARRAY || type == O_LARRAY) { + stab = arg[1].arg_ptr.arg_stab; + afree(stab_xarray(stab)); + stab_xarray(stab) = Null(ARRAY*); + } + else if (type == O_HASH || type == O_LHASH) { + stab = arg[1].arg_ptr.arg_stab; + (void)hfree(stab_xhash(stab)); + stab_xhash(stab) = Null(HASH*); + } + else if (type == O_SUBR || type == O_DBSUBR) { + stab = arg[1].arg_ptr.arg_stab; + cmd_free(stab_sub(stab)->cmd); + afree(stab_sub(stab)->tosave); + Safefree(stab_sub(stab)); + stab_sub(stab) = Null(SUBR*); + } + else + fatal("Can't undefine that kind of object"); + str_numset(str,0.0); + stack->ary_array[retarg] = str; + return retarg; +} + +int +do_vec(lvalue,astr,arglast) +int lvalue; +STR *astr; +int *arglast; +{ + STR **st = stack->ary_array; + int sp = arglast[0]; + register STR *str = st[++sp]; + register int offset = (int)str_gnum(st[++sp]); + register int size = (int)str_gnum(st[++sp]); + unsigned char *s = (unsigned char*)str_get(str); + unsigned long retnum; + int len; + + sp = arglast[1]; + offset *= size; /* turn into bit offset */ + len = (offset + size + 7) / 8; + if (offset < 0 || size < 1) + retnum = 0; + else if (!lvalue && len > str->str_cur) + retnum = 0; + else { + if (len > str->str_cur) { + STR_GROW(str,len); + (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur); + str->str_cur = len; + } + s = (unsigned char*)str_get(str); + if (size < 8) + retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); + else { + offset >>= 3; + if (size == 8) + retnum = s[offset]; + else if (size == 16) + retnum = (s[offset] << 8) + s[offset+1]; + else if (size == 32) + retnum = (s[offset] << 24) + (s[offset + 1] << 16) + + (s[offset + 2] << 8) + s[offset+3]; + } + + if (lvalue) { /* it's an lvalue! */ + struct lstring *lstr = (struct lstring*)astr; + + astr->str_magic = str; + st[sp]->str_rare = 'v'; + lstr->lstr_offset = offset; + lstr->lstr_len = size; + } + } + + str_numset(astr,(double)retnum); + st[sp] = astr; + return sp; +} + +void +do_vecset(mstr,str) +STR *mstr; +STR *str; +{ + struct lstring *lstr = (struct lstring*)str; + register int offset; + register int size; + register unsigned char *s = (unsigned char*)mstr->str_ptr; + register unsigned long lval = (unsigned long)str_gnum(str); + int mask; + + mstr->str_rare = 0; + str->str_magic = Nullstr; + offset = lstr->lstr_offset; + size = lstr->lstr_len; + if (size < 8) { + mask = (1 << size) - 1; + size = offset & 7; + lval &= mask; + offset >>= 3; + s[offset] &= ~(mask << size); + s[offset] |= lval << size; + } + else { + if (size == 8) + s[offset] = lval & 255; + else if (size == 16) { + s[offset] = (lval >> 8) & 255; + s[offset+1] = lval & 255; + } + else if (size == 32) { + s[offset] = (lval >> 24) & 255; + s[offset+1] = (lval >> 16) & 255; + s[offset+2] = (lval >> 8) & 255; + s[offset+3] = lval & 255; + } + } +} + +do_chop(astr,str) +register STR *astr; +register STR *str; +{ + register char *tmps; + register int i; + ARRAY *ary; + HASH *hash; + HENT *entry; + + if (!str) + return; + if (str->str_state == SS_ARY) { + ary = stab_array(str->str_u.str_stab); + for (i = 0; i <= ary->ary_fill; i++) + do_chop(astr,ary->ary_array[i]); + return; + } + if (str->str_state == SS_HASH) { + hash = stab_hash(str->str_u.str_stab); + (void)hiterinit(hash); + while (entry = hiternext(hash)) + do_chop(astr,hiterval(hash,entry)); + return; + } + tmps = str_get(str); + if (!tmps) + return; + tmps += str->str_cur - (str->str_cur != 0); + str_nset(astr,tmps,1); /* remember last char */ + *tmps = '\0'; /* wipe it out */ + str->str_cur = tmps - str->str_ptr; + str->str_nok = 0; +} + +do_vop(optype,str,left,right) +STR *str; +STR *left; +STR *right; +{ + register char *s = str_get(str); + register char *l = str_get(left); + register char *r = str_get(right); + register int len; + + len = left->str_cur; + if (len > right->str_cur) + len = right->str_cur; + if (str->str_cur > len) + str->str_cur = len; + else if (str->str_cur < len) { + STR_GROW(str,len); + (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur); + str->str_cur = len; + s = str_get(str); + } + switch (optype) { + case O_BIT_AND: + while (len--) + *s++ = *l++ & *r++; + break; + case O_XOR: + while (len--) + *s++ = *l++ ^ *r++; + goto mop_up; + case O_BIT_OR: + while (len--) + *s++ = *l++ | *r++; + mop_up: + len = str->str_cur; + if (right->str_cur > len) + str_ncat(str,right->str_ptr+len,right->str_cur - len); + else if (left->str_cur > len) + str_ncat(str,left->str_ptr+len,left->str_cur - len); + break; + } +} + +int +do_syscall(arglast) +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + long arg[8]; + register int i = 0; + int retval = -1; + +#ifdef SYSCALL +#ifdef TAINT + for (st += ++sp; items--; st++) + tainted |= (*st)->str_tainted; + st = stack->ary_array; + sp = arglast[1]; + items = arglast[2] - sp; +#endif +#ifdef TAINT + taintproper("Insecure dependency in syscall"); +#endif + /* This probably won't work on machines where sizeof(long) != sizeof(int) + * or where sizeof(long) != sizeof(char*). But such machines will + * not likely have syscall implemented either, so who cares? + */ + while (items--) { + if (st[++sp]->str_nok || !i) + arg[i++] = (long)str_gnum(st[sp]); +#ifndef lint + else + arg[i++] = (long)st[sp]->str_ptr; +#endif /* lint */ + } + sp = arglast[1]; + items = arglast[2] - sp; + switch (items) { + case 0: + fatal("Too few args to syscall"); + case 1: + retval = syscall(arg[0]); + break; + case 2: + retval = syscall(arg[0],arg[1]); + break; + case 3: + retval = syscall(arg[0],arg[1],arg[2]); + break; + case 4: + retval = syscall(arg[0],arg[1],arg[2],arg[3]); + break; + case 5: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4]); + break; + case 6: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5]); + break; + case 7: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6]); + break; + case 8: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7]); + break; + } + st[sp] = str_static(&str_undef); + str_numset(st[sp], (double)retval); + return sp; +#else + fatal("syscall() unimplemented"); +#endif +} + + diff --git a/doio.c b/doio.c new file mode 100644 index 0000000..c0ba205 --- /dev/null +++ b/doio.c @@ -0,0 +1,1937 @@ +/* $Header: doio.c,v 3.0 89/10/18 15:10:54 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. + * + * $Log: doio.c,v $ + * Revision 3.0 89/10/18 15:10:54 lwall + * 3.0 baseline + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#ifdef SOCKET +#include +#include +#endif + +#include +#ifdef I_PWD +#include +#endif +#ifdef I_GRP +#include +#endif + +extern int errno; + +bool +do_open(stab,name) +STAB *stab; +register char *name; +{ + FILE *fp; + int len = strlen(name); + register STIO *stio = stab_io(stab); + char *myname = savestr(name); + int result; + int fd; + int writing = 0; + char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ + + name = myname; + forkprocess = 1; /* assume true if no fork */ + while (len && isspace(name[len-1])) + name[--len] = '\0'; + if (!stio) + stio = stab_io(stab) = stio_new(); + else if (stio->ifp) { + fd = fileno(stio->ifp); + if (stio->type == '|') + result = mypclose(stio->ifp); + else if (stio->ifp != stio->ofp) { + if (stio->ofp) + fclose(stio->ofp); + result = fclose(stio->ifp); + } + else if (stio->type != '-') + result = fclose(stio->ifp); + else + result = 0; + if (result == EOF && fd > 2) + fprintf(stderr,"Warning: unable to close filehandle %s properly.\n", + stab_name(stab)); + stio->ofp = stio->ifp = Nullfp; + } + if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */ + mode[1] = *name++; + mode[2] = '\0'; + --len; + writing = 1; + } + else { + mode[1] = '\0'; + } + stio->type = *name; + if (*name == '|') { + for (name++; isspace(*name); name++) ; +#ifdef TAINT + taintenv(); + taintproper("Insecure dependency in piped open"); +#endif + fp = mypopen(name,"w"); + writing = 1; + } + else if (*name == '>' && name[1] == '>') { +#ifdef TAINT + taintproper("Insecure dependency in open"); +#endif + mode[0] = stio->type = 'a'; + for (name += 2; isspace(*name); name++) ; + fp = fopen(name, mode); + writing = 1; + } + else if (*name == '>' && name[1] == '&') { +#ifdef TAINT + taintproper("Insecure dependency in open"); +#endif + for (name += 2; isspace(*name); name++) ; + if (isdigit(*name)) + fd = atoi(name); + else { + stab = stabent(name,FALSE); + if (stab_io(stab) && stab_io(stab)->ifp) { + fd = fileno(stab_io(stab)->ifp); + stio->type = stab_io(stab)->type; + } + else + fd = -1; + } + fp = fdopen(dup(fd),stio->type == 'a' ? "a" : + (stio->type == '<' ? "r" : "w") ); + writing = 1; + } + else if (*name == '>') { +#ifdef TAINT + taintproper("Insecure dependency in open"); +#endif + for (name++; isspace(*name); name++) ; + if (strEQ(name,"-")) { + fp = stdout; + stio->type = '-'; + } + else { + mode[0] = 'w'; + fp = fopen(name,mode); + } + writing = 1; + } + else { + if (*name == '<') { + for (name++; isspace(*name); name++) ; + if (strEQ(name,"-")) { + fp = stdin; + stio->type = '-'; + } + else { + mode[0] = 'r'; + fp = fopen(name,mode); + } + } + else if (name[len-1] == '|') { +#ifdef TAINT + taintenv(); + taintproper("Insecure dependency in piped open"); +#endif + name[--len] = '\0'; + while (len && isspace(name[len-1])) + name[--len] = '\0'; + for (; isspace(*name); name++) ; + fp = mypopen(name,"r"); + stio->type = '|'; + } + else { + stio->type = '<'; + for (; isspace(*name); name++) ; + if (strEQ(name,"-")) { + fp = stdin; + stio->type = '-'; + } + else + fp = fopen(name,"r"); + } + } + Safefree(myname); + if (!fp) + return FALSE; + if (stio->type && + stio->type != '|' && stio->type != '-') { + if (fstat(fileno(fp),&statbuf) < 0) { + (void)fclose(fp); + return FALSE; + } + if ((statbuf.st_mode & S_IFMT) != S_IFREG && +#ifdef S_IFSOCK + (statbuf.st_mode & S_IFMT) != S_IFSOCK && +#endif +#ifdef S_IFFIFO + (statbuf.st_mode & S_IFMT) != S_IFFIFO && +#endif + (statbuf.st_mode & S_IFMT) != S_IFCHR) { + (void)fclose(fp); + return FALSE; + } + } + stio->ifp = fp; + if (writing) + stio->ofp = fp; + return TRUE; +} + +FILE * +nextargv(stab) +register STAB *stab; +{ + register STR *str; + char *oldname; + int filemode,fileuid,filegid; + + while (alen(stab_xarray(stab)) >= 0) { + str = ashift(stab_xarray(stab)); + str_sset(stab_val(stab),str); + STABSET(stab_val(stab)); + oldname = str_get(stab_val(stab)); + if (do_open(stab,oldname)) { + if (inplace) { +#ifdef TAINT + taintproper("Insecure dependency in inplace open"); +#endif + filemode = statbuf.st_mode; + fileuid = statbuf.st_uid; + filegid = statbuf.st_gid; + if (*inplace) { + str_cat(str,inplace); +#ifdef RENAME + (void)rename(oldname,str->str_ptr); +#else + (void)UNLINK(str->str_ptr); + (void)link(oldname,str->str_ptr); + (void)UNLINK(oldname); +#endif + } + else { + (void)UNLINK(oldname); + } + + str_nset(str,">",1); + str_cat(str,oldname); + errno = 0; /* in case sprintf set errno */ + if (!do_open(argvoutstab,str->str_ptr)) + fatal("Can't do inplace edit"); + defoutstab = argvoutstab; +#ifdef FCHMOD + (void)fchmod(fileno(stab_io(argvoutstab)->ifp),filemode); +#else + (void)chmod(oldname,filemode); +#endif +#ifdef FCHOWN + (void)fchown(fileno(stab_io(argvoutstab)->ifp),fileuid,filegid); +#else + (void)chown(oldname,fileuid,filegid); +#endif + } + str_free(str); + return stab_io(stab)->ifp; + } + else + fprintf(stderr,"Can't open %s\n",str_get(str)); + str_free(str); + } + if (inplace) { + (void)do_close(argvoutstab,FALSE); + defoutstab = stabent("STDOUT",TRUE); + } + return Nullfp; +} + +bool +do_close(stab,explicit) +STAB *stab; +bool explicit; +{ + bool retval = FALSE; + register STIO *stio = stab_io(stab); + int status; + + if (!stio) { /* never opened */ + if (dowarn && explicit) + warn("Close on unopened file <%s>",stab_name(stab)); + return FALSE; + } + if (stio->ifp) { + if (stio->type == '|') { + status = mypclose(stio->ifp); + retval = (status >= 0); + statusvalue = (unsigned)status & 0xffff; + } + else if (stio->type == '-') + retval = TRUE; + else { + if (stio->ofp && stio->ofp != stio->ifp) /* a socket */ + fclose(stio->ofp); + retval = (fclose(stio->ifp) != EOF); + } + stio->ofp = stio->ifp = Nullfp; + } + if (explicit) + stio->lines = 0; + stio->type = ' '; + return retval; +} + +bool +do_eof(stab) +STAB *stab; +{ + register STIO *stio; + int ch; + + if (!stab) { /* eof() */ + if (argvstab) + stio = stab_io(argvstab); + else + return TRUE; + } + else + stio = stab_io(stab); + + if (!stio) + return TRUE; + + while (stio->ifp) { + +#ifdef STDSTDIO /* (the code works without this) */ + if (stio->ifp->_cnt > 0) /* cheat a little, since */ + return FALSE; /* this is the most usual case */ +#endif + + ch = getc(stio->ifp); + if (ch != EOF) { + (void)ungetc(ch, stio->ifp); + return FALSE; + } + if (!stab) { /* not necessarily a real EOF yet? */ + if (!nextargv(argvstab)) /* get another fp handy */ + return TRUE; + } + else + return TRUE; /* normal fp, definitely end of file */ + } + return TRUE; +} + +long +do_tell(stab) +STAB *stab; +{ + register STIO *stio; + + if (!stab) + goto phooey; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto phooey; + + if (feof(stio->ifp)) + (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */ + + return ftell(stio->ifp); + +phooey: + if (dowarn) + warn("tell() on unopened file"); + return -1L; +} + +bool +do_seek(stab, pos, whence) +STAB *stab; +long pos; +int whence; +{ + register STIO *stio; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + if (feof(stio->ifp)) + (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */ + + return fseek(stio->ifp, pos, whence) >= 0; + +nuts: + if (dowarn) + warn("seek() on unopened file"); + return FALSE; +} + +int +do_ctl(optype,stab,func,argstr) +int optype; +STAB *stab; +int func; +STR *argstr; +{ + register STIO *stio; + register char *s; + int retval; + + if (!stab || !argstr) + return -1; + stio = stab_io(stab); + if (!stio) + return -1; + + if (argstr->str_pok || !argstr->str_nok) { + if (!argstr->str_pok) + s = str_get(argstr); + +#ifdef IOCPARM_MASK +#ifndef IOCPARM_LEN +#define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK) +#endif +#endif +#ifdef IOCPARM_LEN + retval = IOCPARM_LEN(func); /* on BSDish systes we're safe */ +#else + retval = 256; /* otherwise guess at what's safe */ +#endif + if (argstr->str_cur < retval) { + str_grow(argstr,retval+1); + argstr->str_cur = retval; + } + + s = argstr->str_ptr; + s[argstr->str_cur] = 17; /* a little sanity check here */ + } + else { + retval = (int)str_gnum(argstr); + s = (char*)retval; /* ouch */ + } + +#ifndef lint + if (optype == O_IOCTL) + retval = ioctl(fileno(stio->ifp), func, s); + else +#ifdef I_FCNTL + retval = fcntl(fileno(stio->ifp), func, s); +#else + fatal("fcntl is not implemented"); +#endif +#else /* lint */ + retval = 0; +#endif /* lint */ + + if (argstr->str_pok) { + if (s[argstr->str_cur] != 17) + fatal("Return value overflowed string"); + s[argstr->str_cur] = 0; /* put our null back */ + } + return retval; +} + +int +do_stat(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0] + 1; + int max = 13; + register int i; + + if ((arg[1].arg_type & A_MASK) == A_WORD) { + tmpstab = arg[1].arg_ptr.arg_stab; + if (tmpstab != defstab) { + statstab = tmpstab; + str_set(statname,""); + if (!stab_io(tmpstab) || + fstat(fileno(stab_io(tmpstab)->ifp),&statcache) < 0) { + max = 0; + } + } + } + else { + str_sset(statname,ary->ary_array[sp]); + statstab = Nullstab; +#ifdef SYMLINK + if (arg->arg_type == O_LSTAT) + i = lstat(str_get(statname),&statcache); + else +#endif + i = stat(str_get(statname),&statcache); + if (i < 0) + max = 0; + } + + if (gimme != G_ARRAY) { + if (max) + str_sset(str,&str_yes); + else + str_sset(str,&str_undef); + STABSET(str); + ary->ary_array[sp] = str; + return sp; + } + sp--; + if (max) { +#ifndef lint + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_dev))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_ino))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_mode))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_nlink))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_uid))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_gid))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_rdev))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_size))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_atime))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_mtime))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_ctime))); +#ifdef STATBLOCKS + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_blksize))); + (void)astore(ary,++sp, + str_2static(str_nmake((double)statcache.st_blocks))); +#else + (void)astore(ary,++sp, + str_2static(str_make("",0))); + (void)astore(ary,++sp, + str_2static(str_make("",0))); +#endif +#else /* lint */ + (void)astore(ary,++sp,str_nmake(0.0)); +#endif /* lint */ + } + return sp; +} + +int +looks_like_number(str) +STR *str; +{ + register char *s; + register char *send; + + if (!str->str_pok) + return TRUE; + s = str->str_ptr; + send = s + str->str_cur; + while (isspace(*s)) + s++; + if (s >= send) + return FALSE; + if (*s == '+' || *s == '-') + s++; + while (isdigit(*s)) + s++; + if (s == send) + return TRUE; + if (*s == '.') + s++; + else if (s == str->str_ptr) + return FALSE; + while (isdigit(*s)) + s++; + if (s == send) + return TRUE; + if (*s == 'e' || *s == 'E') { + s++; + if (*s == '+' || *s == '-') + s++; + while (isdigit(*s)) + s++; + } + while (isspace(*s)) + s++; + if (s >= send) + return TRUE; + return FALSE; +} + +bool +do_print(str,fp) +register STR *str; +FILE *fp; +{ + register char *tmps; + + if (!fp) { + if (dowarn) + warn("print to unopened file"); + return FALSE; + } + if (!str) + return FALSE; + if (ofmt && + ((str->str_nok && str->str_u.str_nval != 0.0) + || (looks_like_number(str) && str_gnum(str) != 0.0) ) ) + fprintf(fp, ofmt, str->str_u.str_nval); + else { + tmps = str_get(str); + if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'a' && tmps[3] == 'b' + && str->str_cur == sizeof(STBP) && strlen(tmps) < str->str_cur) { + tmps = stab_name(((STAB*)str)); /* a stab value, be nice */ + str = ((STAB*)str)->str_magic; + putc('*',fp); + } + if (str->str_cur && fwrite(tmps,1,str->str_cur,fp) == 0) + return FALSE; + } + return TRUE; +} + +bool +do_aprint(arg,fp,arglast) +register ARG *arg; +register FILE *fp; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int retval; + register int items = arglast[2] - sp; + + if (!fp) { + if (dowarn) + warn("print to unopened file"); + return FALSE; + } + st += ++sp; + if (arg->arg_type == O_PRTF) { + do_sprintf(arg->arg_ptr.arg_str,items,st); + retval = do_print(arg->arg_ptr.arg_str,fp); + } + else { + retval = (items <= 0); + for (; items > 0; items--,st++) { + if (retval && ofslen) { + if (fwrite(ofs, 1, ofslen, fp) == 0) { + retval = FALSE; + break; + } + } + if (!(retval = do_print(*st, fp))) + break; + } + if (retval && orslen) + if (fwrite(ors, 1, orslen, fp) == 0) + retval = FALSE; + } + return retval; +} + +int +mystat(arg,str) +ARG *arg; +STR *str; +{ + STIO *stio; + + if (arg[1].arg_type & A_DONT) { + stio = stab_io(arg[1].arg_ptr.arg_stab); + if (stio && stio->ifp) { + statstab = arg[1].arg_ptr.arg_stab; + str_set(statname,""); + return fstat(fileno(stio->ifp), &statcache); + } + else { + if (arg[1].arg_ptr.arg_stab == defstab) + return 0; + if (dowarn) + warn("Stat on unopened file <%s>", + stab_name(arg[1].arg_ptr.arg_stab)); + statstab = Nullstab; + str_set(statname,""); + return -1; + } + } + else { + statstab = Nullstab; + str_sset(statname,str); + return stat(str_get(str),&statcache); + } +} + +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_type & A_DONT) { + if (arg[1].arg_ptr.arg_stab == defstab) { + if (statstab) + stio = stab_io(statstab); + else { + str = statname; + goto really_filename; + } + } + else { + statstab = arg[1].arg_ptr.arg_stab; + str_set(statname,""); + stio = stab_io(statstab); + } + if (stio && stio->ifp) { +#ifdef STDSTDIO + fstat(fileno(stio->ifp),&statcache); + if (stio->ifp->_cnt <= 0) { + i = getc(stio->ifp); + if (i != EOF) + (void)ungetc(i,stio->ifp); + } + if (stio->ifp->_cnt <= 0) /* null file is anything */ + return &str_yes; + len = stio->ifp->_cnt + (stio->ifp->_ptr - stio->ifp->_base); + s = stio->ifp->_base; +#else + fatal("-T and -B not implemented on filehandles\n"); +#endif + } + else { + if (dowarn) + warn("Test on unopened file <%s>", + stab_name(arg[1].arg_ptr.arg_stab)); + return &str_undef; + } + } + else { + statstab = Nullstab; + str_sset(statname,str); + really_filename: + i = open(str_get(str),0); + if (i < 0) + return &str_undef; + fstat(i,&statcache); + len = read(i,tbuf,512); + if (len <= 0) /* null file is anything */ + return &str_yes; + (void)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; +} + +bool +do_aexec(really,arglast) +STR *really; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register char **a; + char **argv; + char *tmps; + + if (items) { + New(401,argv, items+1, char*); + a = argv; + for (st += ++sp; items > 0; items--,st++) { + if (*st) + *a++ = str_get(*st); + else + *a++ = ""; + } + *a = Nullch; +#ifdef TAINT + if (*argv[0] != '/') /* will execvp use PATH? */ + taintenv(); /* testing IFS here is overkill, probably */ +#endif + if (really && *(tmps = str_get(really))) + execvp(tmps,argv); + else + execvp(argv[0],argv); + Safefree(argv); + } + return FALSE; +} + +bool +do_exec(cmd) +char *cmd; +{ + register char **a; + register char *s; + char **argv; + char flags[10]; + +#ifdef TAINT + taintenv(); + taintproper("Insecure dependency in exec"); +#endif + + /* save an extra exec if possible */ + + if (csh > 0 && strnEQ(cmd,"/bin/csh -c",11)) { + strcpy(flags,"-c"); + s = cmd+11; + if (*s == 'f') { + s++; + strcat(flags,"f"); + } + if (*s == ' ') + s++; + if (*s++ == '\'') { + char *ncmd = s; + + while (*s) + s++; + if (s[-1] == '\n') + *--s = '\0'; + if (s[-1] == '\'') { + *--s = '\0'; + execl("/bin/csh","csh", flags,ncmd,(char*)0); + *s = '\''; + return FALSE; + } + } + } + + /* see if there are shell metacharacters in it */ + + for (s = cmd; *s; s++) { + if (*s != ' ' && !isalpha(*s) && index("$&*(){}[]'\";\\|?<>~`\n",*s)) { + if (*s == '\n' && !s[1]) { + *s = '\0'; + break; + } + doshell: + execl("/bin/sh","sh","-c",cmd,(char*)0); + return FALSE; + } + } + New(402,argv, (s - cmd) / 2 + 2, char*); + + a = argv; + for (s = cmd; *s;) { + while (*s && isspace(*s)) s++; + if (*s) + *(a++) = s; + while (*s && !isspace(*s)) s++; + if (*s) + *s++ = '\0'; + } + *a = Nullch; + if (argv[0]) { + execvp(argv[0],argv); + if (errno == ENOEXEC) /* for system V NIH syndrome */ + goto doshell; + } + Safefree(argv); + return FALSE; +} + +#ifdef SOCKET +int +do_socket(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int domain, type, protocol, fd; + + if (!stab) + return FALSE; + + stio = stab_io(stab); + if (!stio) + stio = stab_io(stab) = stio_new(); + else if (stio->ifp) + do_close(stab,FALSE); + + domain = (int)str_gnum(st[++sp]); + type = (int)str_gnum(st[++sp]); + protocol = (int)str_gnum(st[++sp]); +#ifdef TAINT + taintproper("Insecure dependency in socket"); +#endif + fd = socket(domain,type,protocol); + if (fd < 0) + return FALSE; + stio->ifp = fdopen(fd, "r"); /* stdio gets confused about sockets */ + stio->ofp = fdopen(fd, "w"); + stio->type = 's'; + + return TRUE; +} + +int +do_bind(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + char *addr; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + addr = str_get(st[++sp]); +#ifdef TAINT + taintproper("Insecure dependency in bind"); +#endif + return bind(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0; + +nuts: + if (dowarn) + warn("bind() on closed fd"); + return FALSE; + +} + +int +do_connect(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + char *addr; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + addr = str_get(st[++sp]); +#ifdef TAINT + taintproper("Insecure dependency in connect"); +#endif + return connect(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0; + +nuts: + if (dowarn) + warn("connect() on closed fd"); + return FALSE; + +} + +int +do_listen(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int backlog; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + backlog = (int)str_gnum(st[++sp]); + return listen(fileno(stio->ifp), backlog) >= 0; + +nuts: + if (dowarn) + warn("listen() on closed fd"); + return FALSE; +} + +void +do_accept(str, nstab, gstab) +STR *str; +STAB *nstab; +STAB *gstab; +{ + register STIO *nstio; + register STIO *gstio; + int len = sizeof buf; + int fd; + + if (!nstab) + goto badexit; + if (!gstab) + goto nuts; + + gstio = stab_io(gstab); + nstio = stab_io(nstab); + + if (!gstio || !gstio->ifp) + goto nuts; + if (!nstio) + nstio = stab_io(nstab) = stio_new(); + else if (nstio->ifp) + do_close(nstab,FALSE); + + fd = accept(fileno(gstio->ifp),buf,&len); + if (fd < 0) + goto badexit; + nstio->ifp = fdopen(fd, "r"); + nstio->ofp = fdopen(fd, "w"); + nstio->type = 's'; + + str_nset(str, buf, len); + return; + +nuts: + if (dowarn) + warn("accept() on closed fd"); +badexit: + str_sset(str,&str_undef); + return; +} + +int +do_shutdown(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int how; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + how = (int)str_gnum(st[++sp]); + return shutdown(fileno(stio->ifp), how) >= 0; + +nuts: + if (dowarn) + warn("shutdown() on closed fd"); + return FALSE; + +} + +int +do_sopt(optype, stab, arglast) +int optype; +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int fd; + int lvl; + int optname; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + fd = fileno(stio->ifp); + lvl = (int)str_gnum(st[sp+1]); + optname = (int)str_gnum(st[sp+2]); + switch (optype) { + case O_GSOCKOPT: + st[sp] = str_2static(str_new(257)); + st[sp]->str_cur = 256; + if (getsockopt(fd, lvl, optname, st[sp]->str_ptr, &st[sp]->str_cur) < 0) + goto nuts; + break; + case O_SSOCKOPT: + st[sp] = st[sp+3]; + if (setsockopt(fd, lvl, optname, st[sp]->str_ptr, st[sp]->str_cur) < 0) + goto nuts; + st[sp] = &str_yes; + break; + } + + return sp; + +nuts: + if (dowarn) + warn("shutdown() on closed fd"); + st[sp] = &str_undef; + return sp; + +} + +int +do_getsockname(optype, stab, arglast) +int optype; +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int fd; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + st[sp] = str_2static(str_new(257)); + st[sp]->str_cur = 256; + fd = fileno(stio->ifp); + switch (optype) { + case O_GETSOCKNAME: + if (getsockname(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0) + goto nuts; + break; + case O_GETPEERNAME: + if (getpeername(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0) + goto nuts; + break; + } + + return sp; + +nuts: + if (dowarn) + warn("shutdown() on closed fd"); + st[sp] = &str_undef; + return sp; + +} + +int +do_ghent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct hostent *gethostbynam(); + struct hostent *gethostbyaddr(); +#ifdef GETHOSTENT + struct hostent *gethostent(); +#endif + struct hostent *hent; + unsigned long len; + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str_static(&str_undef)); + return sp; + } + + if (which == O_GHBYNAME) { + char *name = str_get(ary->ary_array[sp+1]); + + hent = gethostbyname(name); + } + else if (which == O_GHBYADDR) { + STR *addrstr = ary->ary_array[sp+1]; + int addrtype = (int)str_gnum(ary->ary_array[sp+2]); + char *addr = str_get(addrstr); + + hent = gethostbyaddr(addr,addrstr->str_cur,addrtype); + } + else +#ifdef GETHOSTENT + hent = gethostent(); +#else + fatal("gethostent not implemented"); +#endif + if (hent) { +#ifndef lint + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, hent->h_name); + (void)astore(ary, ++sp, str = str_static(&str_no)); + for (elem = hent->h_aliases; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_numset(str, (double)hent->h_addrtype); + (void)astore(ary, ++sp, str = str_static(&str_no)); + len = hent->h_length; + str_numset(str, (double)len); +#ifdef h_addr + for (elem = hent->h_addr_list; *elem; elem++) { + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_nset(str, *elem, len); + } +#else + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_nset(str, hent->h_addr, len); +#endif /* h_addr */ +#else /* lint */ + elem = Nullch; + elem = elem; + (void)astore(ary, ++sp, str_static(&str_no)); +#endif /* lint */ + } + + return sp; +} + +int +do_gnent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct netent *getnetbyname(); + struct netent *getnetbyaddr(); + struct netent *getnetent(); + struct netent *nent; + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str_static(&str_undef)); + return sp; + } + + if (which == O_GNBYNAME) { + char *name = str_get(ary->ary_array[sp+1]); + + nent = getnetbyname(name); + } + else if (which == O_GNBYADDR) { + STR *addrstr = ary->ary_array[sp+1]; + int addrtype = (int)str_gnum(ary->ary_array[sp+2]); + char *addr = str_get(addrstr); + + nent = getnetbyaddr(addr,addrtype); + } + else + nent = getnetent(); + + if (nent) { +#ifndef lint + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, nent->n_name); + (void)astore(ary, ++sp, str = str_static(&str_no)); + for (elem = nent->n_aliases; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_numset(str, (double)nent->n_addrtype); + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_numset(str, (double)nent->n_net); +#else /* lint */ + elem = Nullch; + elem = elem; + (void)astore(ary, ++sp, str_static(&str_no)); +#endif /* lint */ + } + + return sp; +} + +int +do_gpent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct protoent *getprotobyname(); + struct protoent *getprotobynumber(); + struct protoent *getprotoent(); + struct protoent *pent; + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str_static(&str_undef)); + return sp; + } + + if (which == O_GPBYNAME) { + char *name = str_get(ary->ary_array[sp+1]); + + pent = getprotobyname(name); + } + else if (which == O_GPBYNUMBER) { + int proto = (int)str_gnum(ary->ary_array[sp+1]); + + pent = getprotobynumber(proto); + } + else + pent = getprotoent(); + + if (pent) { +#ifndef lint + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, pent->p_name); + (void)astore(ary, ++sp, str = str_static(&str_no)); + for (elem = pent->p_aliases; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_numset(str, (double)pent->p_proto); +#else /* lint */ + elem = Nullch; + elem = elem; + (void)astore(ary, ++sp, str_static(&str_no)); +#endif /* lint */ + } + + return sp; +} + +int +do_gsent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct servent *getservbyname(); + struct servent *getservbynumber(); + struct servent *getservent(); + struct servent *sent; + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str_static(&str_undef)); + return sp; + } + + if (which == O_GSBYNAME) { + char *name = str_get(ary->ary_array[sp+1]); + char *proto = str_get(ary->ary_array[sp+2]); + + if (proto && !*proto) + proto = Nullch; + + sent = getservbyname(name,proto); + } + else if (which == O_GSBYPORT) { + int port = (int)str_gnum(ary->ary_array[sp+1]); + char *proto = str_get(ary->ary_array[sp+2]); + + sent = getservbyport(port,proto); + } + else + sent = getservent(); + if (sent) { +#ifndef lint + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, sent->s_name); + (void)astore(ary, ++sp, str = str_static(&str_no)); + for (elem = sent->s_aliases; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + (void)astore(ary, ++sp, str = str_static(&str_no)); +#ifdef NTOHS + str_numset(str, (double)ntohs(sent->s_port)); +#else + str_numset(str, (double)(sent->s_port)); +#endif + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, sent->s_proto); +#else /* lint */ + elem = Nullch; + elem = elem; + (void)astore(ary, ++sp, str_static(&str_no)); +#endif /* lint */ + } + + return sp; +} + +int +do_select(gimme,arglast) +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[0]; + register int i; + register int j; + register char *s; + register STR *str; + double value; + int maxlen = 0; + int nfound; + struct timeval timebuf; + struct timeval *tbuf = &timebuf; + + for (i = 1; i <= 3; i++) { + j = st[sp+i]->str_len; + if (maxlen < j) + maxlen = j; + } + for (i = 1; i <= 3; i++) { + str = st[sp+i]; + j = str->str_len; + if (j < maxlen) { + if (str->str_pok) { + str_grow(str,maxlen); + s = str_get(str) + j; + while (++j <= maxlen) { + *s++ = '\0'; + } + } + else if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_ptr = Nullch; + } + } + } + str = st[sp+4]; + if (str->str_nok || str->str_pok) { + value = str_gnum(str); + if (value < 0.0) + value = 0.0; + timebuf.tv_sec = (long)value; + value -= (double)timebuf.tv_sec; + timebuf.tv_usec = (long)(value * 1000000.0); + } + else + tbuf = Null(struct timeval*); + + nfound = select( + maxlen * 8, + st[sp+1]->str_ptr, + st[sp+2]->str_ptr, + st[sp+3]->str_ptr, + tbuf); + + st[++sp] = str_static(&str_no); + str_numset(st[sp], (double)nfound); + if (gimme == G_ARRAY && tbuf) { + value = (double)(timebuf.tv_sec) + + (double)(timebuf.tv_usec) / 1000000.0; + st[++sp] = str_static(&str_no); + str_numset(st[sp], value); + } + return sp; +} + +int +do_spair(stab1, stab2, arglast) +STAB *stab1; +STAB *stab2; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[2]; + register STIO *stio1; + register STIO *stio2; + int domain, type, protocol, fd[2]; + + if (!stab1 || !stab2) + return FALSE; + + stio1 = stab_io(stab1); + stio2 = stab_io(stab2); + if (!stio1) + stio1 = stab_io(stab1) = stio_new(); + else if (stio1->ifp) + do_close(stab1,FALSE); + if (!stio2) + stio2 = stab_io(stab2) = stio_new(); + else if (stio2->ifp) + do_close(stab2,FALSE); + + domain = (int)str_gnum(st[++sp]); + type = (int)str_gnum(st[++sp]); + protocol = (int)str_gnum(st[++sp]); +#ifdef TAINT + taintproper("Insecure dependency in socketpair"); +#endif +#ifdef SOCKETPAIR + if (socketpair(domain,type,protocol,fd) < 0) + return FALSE; +#else + fatal("Socketpair unimplemented"); +#endif + stio1->ifp = fdopen(fd[0], "r"); + stio1->ofp = fdopen(fd[0], "w"); + stio1->type = 's'; + stio2->ifp = fdopen(fd[1], "r"); + stio2->ofp = fdopen(fd[1], "w"); + stio2->type = 's'; + + return TRUE; +} + +#endif /* SOCKET */ + +int +do_gpwent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ +#ifdef I_PWD + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct passwd *getpwnam(); + struct passwd *getpwuid(); + struct passwd *getpwent(); + struct passwd *pwent; + unsigned long len; + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str_static(&str_undef)); + return sp; + } + + if (which == O_GPWNAM) { + char *name = str_get(ary->ary_array[sp+1]); + + pwent = getpwnam(name); + } + else if (which == O_GPWUID) { + int uid = (int)str_gnum(ary->ary_array[sp+1]); + + pwent = getpwuid(uid); + } + else + pwent = getpwent(); + + if (pwent) { + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, pwent->pw_name); + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, pwent->pw_passwd); + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_numset(str, (double)pwent->pw_uid); + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_numset(str, (double)pwent->pw_gid); + (void)astore(ary, ++sp, str = str_static(&str_no)); +#ifdef PWQUOTA + str_numset(str, (double)pwent->pw_quota); +#else +#ifdef PWAGE + str_set(str, pwent->pw_age); +#endif +#endif + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, pwent->pw_comment); + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, pwent->pw_gecos); + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, pwent->pw_dir); + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, pwent->pw_shell); + } + + return sp; +#else + fatal("password routines not implemented"); +#endif +} + +int +do_ggrent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ +#ifdef I_GRP + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct group *getgrnam(); + struct group *getgrgid(); + struct group *getgrent(); + struct group *grent; + unsigned long len; + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str_static(&str_undef)); + return sp; + } + + if (which == O_GGRNAM) { + char *name = str_get(ary->ary_array[sp+1]); + + grent = getgrnam(name); + } + else if (which == O_GGRGID) { + int gid = (int)str_gnum(ary->ary_array[sp+1]); + + grent = getgrgid(gid); + } + else + grent = getgrent(); + + if (grent) { + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, grent->gr_name); + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_set(str, grent->gr_passwd); + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_numset(str, (double)grent->gr_gid); + (void)astore(ary, ++sp, str = str_static(&str_no)); + for (elem = grent->gr_mem; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + } + + return sp; +#else + fatal("group routines not implemented"); +#endif +} + +int +do_dirop(optype,stab,gimme,arglast) +int optype; +STAB *stab; +int gimme; +int *arglast; +{ +#ifdef DIRENT + register ARRAY *ary = stack; + register STR **st = ary->ary_array; + register int sp = arglast[1]; + register STIO *stio; + long along; + long telldir(); + struct DIRENT *readdir(); + register struct DIRENT *dp; + + if (!stab) + goto nope; + if (!(stio = stab_io(stab))) + stio = stab_io(stab) = stio_new(); + if (!stio->dirp && optype != O_OPENDIR) + goto nope; + st[sp] = &str_yes; + switch (optype) { + case O_OPENDIR: + if (stio->dirp) + closedir(stio->dirp); + if (!(stio->dirp = opendir(str_get(st[sp+1])))) + goto nope; + break; + case O_READDIR: + if (gimme == G_ARRAY) { + --sp; + while (dp = readdir(stio->dirp)) { +#ifdef DIRNAMLEN + (void)astore(ary,++sp, + str_2static(str_make(dp->d_name,dp->d_namlen))); +#else + (void)astore(ary,++sp, + str_2static(str_make(dp->d_name,0))); +#endif + } + } + else { + if (!(dp = readdir(stio->dirp))) + goto nope; + st[sp] = str_static(&str_undef); +#ifdef DIRNAMLEN + str_nset(st[sp], dp->d_name, dp->d_namlen); +#else + str_set(st[sp], dp->d_name); +#endif + } + break; + case O_TELLDIR: + st[sp] = str_static(&str_undef); + str_numset(st[sp], (double)telldir(stio->dirp)); + break; + case O_SEEKDIR: + st[sp] = str_static(&str_undef); + along = (long)str_gnum(st[sp+1]); + (void)seekdir(stio->dirp,along); + break; + case O_REWINDDIR: + st[sp] = str_static(&str_undef); + (void)rewinddir(stio->dirp); + break; + case O_CLOSEDIR: + st[sp] = str_static(&str_undef); + (void)closedir(stio->dirp); + stio->dirp = 0; + break; + } + return sp; + +nope: + st[sp] = &str_undef; + return sp; + +#else + fatal("Unimplemented directory operation"); +#endif +} + +apply(type,arglast) +int type; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register int val; + register int val2; + register int tot = 0; + char *s; + +#ifdef TAINT + for (st += ++sp; items--; st++) + tainted |= (*st)->str_tainted; + st = stack->ary_array; + sp = arglast[1]; + items = arglast[2] - sp; +#endif + switch (type) { + case O_CHMOD: +#ifdef TAINT + taintproper("Insecure dependency in chmod"); +#endif + if (--items > 0) { + tot = items; + val = (int)str_gnum(st[++sp]); + while (items--) { + if (chmod(str_get(st[++sp]),val)) + tot--; + } + } + break; + case O_CHOWN: +#ifdef TAINT + taintproper("Insecure dependency in chown"); +#endif + if (items > 2) { + items -= 2; + tot = items; + val = (int)str_gnum(st[++sp]); + val2 = (int)str_gnum(st[++sp]); + while (items--) { + if (chown(str_get(st[++sp]),val,val2)) + tot--; + } + } + break; + case O_KILL: +#ifdef TAINT + taintproper("Insecure dependency in kill"); +#endif + if (--items > 0) { + tot = items; + s = str_get(st[++sp]); + if (isupper(*s)) { + if (*s == 'S' && s[1] == 'I' && s[2] == 'G') + s += 3; + if (!(val = whichsig(s))) + fatal("Unrecognized signal name \"%s\"",s); + } + else + val = (int)str_gnum(st[sp]); + if (val < 0) { + val = -val; + while (items--) { + int proc = (int)str_gnum(st[++sp]); +#ifdef KILLPG + if (killpg(proc,val)) /* BSD */ +#else + if (kill(-proc,val)) /* SYSV */ +#endif + tot--; + } + } + else { + while (items--) { + if (kill((int)(str_gnum(st[++sp])),val)) + tot--; + } + } + } + break; + case O_UNLINK: +#ifdef TAINT + taintproper("Insecure dependency in unlink"); +#endif + tot = items; + while (items--) { + s = str_get(st[++sp]); + if (euid || unsafe) { + if (UNLINK(s)) + tot--; + } + else { /* don't let root wipe out directories without -U */ +#ifdef SYMLINK + if (lstat(s,&statbuf) < 0 || +#else + if (stat(s,&statbuf) < 0 || +#endif + (statbuf.st_mode & S_IFMT) == S_IFDIR ) + tot--; + else { + if (UNLINK(s)) + tot--; + } + } + } + break; + case O_UTIME: +#ifdef TAINT + taintproper("Insecure dependency in utime"); +#endif + if (items > 2) { + struct { + long atime, + mtime; + } utbuf; + + utbuf.atime = (long)str_gnum(st[++sp]); /* time accessed */ + utbuf.mtime = (long)str_gnum(st[++sp]); /* time modified */ + items -= 2; +#ifndef lint + tot = items; + while (items--) { + if (utime(str_get(st[++sp]),&utbuf)) + tot--; + } +#endif + } + else + items = 0; + break; + } + return tot; +} + +/* Do the permissions allow some operation? Assumes statcache already set. */ + +int +cando(bit, effective, statbufp) +int bit; +int effective; +register struct stat *statbufp; +{ + if ((effective ? euid : uid) == 0) { /* root is special */ + if (bit == S_IEXEC) { + if (statbufp->st_mode & 0111 || + (statbufp->st_mode & S_IFMT) == S_IFDIR ) + return TRUE; + } + else + return TRUE; /* root reads and writes anything */ + return FALSE; + } + if (statbufp->st_uid == (effective ? euid : uid) ) { + if (statbufp->st_mode & bit) + return TRUE; /* ok as "user" */ + } + else if (ingroup((int)statbufp->st_gid,effective)) { + if (statbufp->st_mode & bit >> 3) + return TRUE; /* ok as "group" */ + } + else if (statbufp->st_mode & bit >> 6) + return TRUE; /* ok as "other" */ + return FALSE; +} + +int +ingroup(testgid,effective) +int testgid; +int effective; +{ + if (testgid == (effective ? egid : gid)) + 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] == testgid) + return TRUE; + } +#endif + return FALSE; +} diff --git a/dolist.c b/dolist.c new file mode 100644 index 0000000..e47c37d --- /dev/null +++ b/dolist.c @@ -0,0 +1,1044 @@ +/* $Header: dolist.c,v 3.0 89/10/18 15:11:02 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. + * + * $Log: dolist.c,v $ + * Revision 3.0 89/10/18 15:11:02 lwall + * 3.0 baseline + * + */ + +#include "EXTERN.h" +#include "perl.h" + + +int +do_match(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register SPAT *spat = arg[2].arg_ptr.arg_spat; + register char *t; + register int sp = arglast[0] + 1; + STR *srchstr = st[sp]; + register char *s = str_get(st[sp]); + char *strend = s + st[sp]->str_cur; + STR *tmpstr; + + if (!spat) { + if (gimme == G_ARRAY) + return --sp; + str_set(str,Yes); + STABSET(str); + st[sp] = str; + return sp; + } + if (!s) + fatal("panic: do_match"); + if (spat->spat_flags & SPAT_USED) { +#ifdef DEBUGGING + if (debug & 8) + deb("2.SPAT USED\n"); +#endif + if (gimme == G_ARRAY) + return --sp; + str_set(str,No); + STABSET(str); + st[sp] = str; + return sp; + } + --sp; + if (spat->spat_runtime) { + nointrp = "|)"; + sp = eval(spat->spat_runtime,G_SCALAR,sp); + st = stack->ary_array; + t = str_get(tmpstr = st[sp--]); + nointrp = ""; +#ifdef DEBUGGING + if (debug & 8) + deb("2.SPAT /%s/\n",t); +#endif + if (spat->spat_regexp) + regfree(spat->spat_regexp); + spat->spat_regexp = regcomp(t,t+tmpstr->str_cur, + spat->spat_flags & SPAT_FOLD,1); + if (!*spat->spat_regexp->precomp && lastspat) + spat = lastspat; + if (spat->spat_flags & SPAT_KEEP) { + arg_free(spat->spat_runtime); /* it won't change, so */ + spat->spat_runtime = Nullarg; /* no point compiling again */ + } + if (!spat->spat_regexp->nparens) + gimme = G_SCALAR; /* accidental array context? */ + if (regexec(spat->spat_regexp, s, strend, s, 0, + srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr, + gimme == G_ARRAY)) { + if (spat->spat_regexp->subbase) + curspat = spat; + lastspat = spat; + goto gotcha; + } + else { + if (gimme == G_ARRAY) + return sp; + str_sset(str,&str_no); + STABSET(str); + st[++sp] = str; + return sp; + } + } + else { +#ifdef DEBUGGING + if (debug & 8) { + char ch; + + if (spat->spat_flags & SPAT_ONCE) + ch = '?'; + else + ch = '/'; + deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch); + } +#endif + 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) { + if (srchstr->str_pok & SP_STUDIED) { + if (screamfirst[spat->spat_short->str_rare] < 0) + goto nope; + else if (!(s = screaminstr(srchstr,spat->spat_short))) + goto nope; + else if (spat->spat_flags & SPAT_ALL) + goto yup; + } +#ifndef lint + else if (!(s = fbminstr((unsigned char*)s, + (unsigned char*)strend, spat->spat_short))) + goto nope; +#endif + else if (spat->spat_flags & SPAT_ALL) + goto yup; + if (s && spat->spat_regexp->regback >= 0) { + ++spat->spat_short->str_u.str_useful; + s -= spat->spat_regexp->regback; + if (s < t) + s = t; + } + else + s = t; + } + else if (!multiline && (*spat->spat_short->str_ptr != *s || + bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) )) + goto nope; + if (--spat->spat_short->str_u.str_useful < 0) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; /* opt is being useless */ + } + } + if (!spat->spat_regexp->nparens) + gimme = G_SCALAR; /* accidental array context? */ + if (regexec(spat->spat_regexp, s, strend, t, 0, + srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr, + gimme == G_ARRAY)) { + if (spat->spat_regexp->subbase) + curspat = spat; + lastspat = spat; + if (spat->spat_flags & SPAT_ONCE) + spat->spat_flags |= SPAT_USED; + goto gotcha; + } + else { + if (gimme == G_ARRAY) + return sp; + str_sset(str,&str_no); + STABSET(str); + st[++sp] = str; + return sp; + } + } + /*NOTREACHED*/ + + gotcha: + if (gimme == G_ARRAY) { + int iters, i, len; + + iters = spat->spat_regexp->nparens; + if (sp + iters >= stack->ary_max) { + astore(stack,sp + iters, Nullstr); + st = stack->ary_array; /* possibly realloced */ + } + + for (i = 1; i <= iters; i++) { + st[++sp] = str_static(&str_no); + if (s = spat->spat_regexp->startp[i]) { + len = spat->spat_regexp->endp[i] - s; + if (len > 0) + str_nset(st[sp],s,len); + } + } + return sp; + } + else { + str_sset(str,&str_yes); + STABSET(str); + st[++sp] = str; + return sp; + } + +yup: + ++spat->spat_short->str_u.str_useful; + lastspat = spat; + if (spat->spat_flags & SPAT_ONCE) + spat->spat_flags |= SPAT_USED; + if (sawampersand) { + char *tmps; + + tmps = spat->spat_regexp->subbase = nsavestr(t,strend-t); + tmps = spat->spat_regexp->startp[0] = tmps + (s - t); + spat->spat_regexp->endp[0] = tmps + spat->spat_short->str_cur; + curspat = spat; + } + str_sset(str,&str_yes); + STABSET(str); + st[++sp] = str; + return sp; + +nope: + ++spat->spat_short->str_u.str_useful; + if (gimme == G_ARRAY) + return sp; + str_sset(str,&str_no); + STABSET(str); + st[++sp] = str; + return sp; +} + +int +do_split(str,spat,limit,gimme,arglast) +STR *str; +register SPAT *spat; +register int limit; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + STR **st = ary->ary_array; + register int sp = arglast[0] + 1; + register char *s = str_get(st[sp]); + char *strend = s + st[sp--]->str_cur; + register STR *dstr; + register char *m; + int iters = 0; + int i; + char *orig; + int origlimit = limit; + int realarray = 0; + + if (!spat || !s) + fatal("panic: do_split"); + else if (spat->spat_runtime) { + nointrp = "|)"; + sp = eval(spat->spat_runtime,G_SCALAR,sp); + st = stack->ary_array; + m = str_get(dstr = st[sp--]); + nointrp = ""; + if (!dstr->str_cur || (*m == ' ' && dstr->str_cur == 1)) { + str_set(dstr,"\\s+"); + m = dstr->str_ptr; + spat->spat_flags |= SPAT_SKIPWHITE; + } + if (spat->spat_regexp) + regfree(spat->spat_regexp); + spat->spat_regexp = regcomp(m,m+dstr->str_cur, + spat->spat_flags & SPAT_FOLD,1); + if (spat->spat_flags & SPAT_KEEP || + (spat->spat_runtime->arg_type == O_ITEM && + (spat->spat_runtime[1].arg_type & A_MASK) == A_SINGLE) ) { + arg_free(spat->spat_runtime); /* it won't change, so */ + spat->spat_runtime = Nullarg; /* no point compiling again */ + } + } +#ifdef DEBUGGING + if (debug & 8) { + deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); + } +#endif + ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab); + if (ary && ((ary->ary_flags & ARF_REAL) || gimme != G_ARRAY)) { + ary->ary_flags |= ARF_REAL; + realarray = 1; + ary->ary_fill = -1; + sp = -1; /* temporarily switch stacks */ + } + else + ary = stack; + orig = s; + if (spat->spat_flags & SPAT_SKIPWHITE) { + while (isspace(*s)) + s++; + } + if (!limit) + limit = 10001; + if (spat->spat_short) { + i = spat->spat_short->str_cur; + if (i == 1) { + i = *spat->spat_short->str_ptr; + while (--limit) { + for (m = s; m < strend && *m != i; m++) ; + if (m >= strend) + break; + if (realarray) + dstr = Str_new(30,m-s); + else + dstr = str_static(&str_undef); + str_nset(dstr,s,m-s); + (void)astore(ary, ++sp, dstr); + s = m + 1; + } + } + else { +#ifndef lint + while (s < strend && --limit && + (m=fbminstr((unsigned char*)s, (unsigned char*)strend, + spat->spat_short)) ) +#endif + { + if (realarray) + dstr = Str_new(31,m-s); + else + dstr = str_static(&str_undef); + str_nset(dstr,s,m-s); + (void)astore(ary, ++sp, dstr); + s = m + i; + } + } + } + else { + while (s < strend && --limit && + regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) { + if (spat->spat_regexp->subbase + && spat->spat_regexp->subbase != orig) { + m = s; + s = orig; + orig = spat->spat_regexp->subbase; + s = orig + (m - s); + strend = s + (strend - m); + } + m = spat->spat_regexp->startp[0]; + if (realarray) + dstr = Str_new(32,m-s); + else + dstr = str_static(&str_undef); + str_nset(dstr,s,m-s); + (void)astore(ary, ++sp, dstr); + if (spat->spat_regexp->nparens) { + for (i = 1; i <= spat->spat_regexp->nparens; i++) { + s = spat->spat_regexp->startp[i]; + m = spat->spat_regexp->endp[i]; + if (realarray) + dstr = Str_new(33,m-s); + else + dstr = str_static(&str_undef); + str_nset(dstr,s,m-s); + (void)astore(ary, ++sp, dstr); + } + } + s = spat->spat_regexp->endp[0]; + } + } + if (realarray) + iters = sp + 1; + else + iters = sp - arglast[0]; + if (iters > 9999) + fatal("Split loop"); + if (s < strend || origlimit) { /* keep field after final delim? */ + if (realarray) + dstr = Str_new(34,strend-s); + else + dstr = str_static(&str_undef); + str_nset(dstr,s,strend-s); + (void)astore(ary, ++sp, dstr); + iters++; + } + else { +#ifndef I286 + while (iters > 0 && ary->ary_array[sp]->str_cur == 0) + iters--,sp--; +#else + char *zaps; + int zapb; + + if (iters > 0) { + zaps = str_get(afetch(ary,sp,FALSE)); + zapb = (int) *zaps; + } + + while (iters > 0 && (!zapb)) { + iters--,sp--; + if (iters > 0) { + zaps = str_get(afetch(ary,iters-1,FALSE)); + zapb = (int) *zaps; + } + } +#endif + } + if (realarray) { + ary->ary_fill = sp; + if (gimme == G_ARRAY) { + sp++; + astore(stack, arglast[0] + 1 + sp, Nullstr); + Copy(ary->ary_array, stack->ary_array + arglast[0] + 1, sp, STR*); + return arglast[0] + sp; + } + } + else { + if (gimme == G_ARRAY) + return sp; + } + sp = arglast[0] + 1; + str_numset(str,(double)iters); + STABSET(str); + st[sp] = str; + return sp; +} + +int +do_unpack(str,gimme,arglast) +STR *str; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register int sp = arglast[0] + 1; + register char *pat = str_get(st[sp++]); + register char *s = str_get(st[sp]); + char *strend = s + st[sp--]->str_cur; + register char *patend = pat + st[sp]->str_cur; + int datumtype; + register int len; + + /* These must not be in registers: */ + char achar; + short ashort; + int aint; + long along; + unsigned char auchar; + unsigned short aushort; + unsigned int auint; + unsigned long aulong; + char *aptr; + + if (gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[sp] = str; + return sp; + } + sp--; + while (pat < patend) { + datumtype = *pat++; + if (isdigit(*pat)) { + len = atoi(pat); + while (isdigit(*pat)) + pat++; + } + else + len = 1; + switch(datumtype) { + default: + break; + case 'x': + s += len; + break; + case 'A': + case 'a': + if (s + len > strend) + len = strend - s; + str = Str_new(35,len); + str_nset(str,s,len); + s += len; + if (datumtype == 'A') { + aptr = s; /* borrow register */ + s = str->str_ptr + len - 1; + while (s >= str->str_ptr && (!*s || isspace(*s))) + s--; + *++s = '\0'; + str->str_cur = s - str->str_ptr; + s = aptr; /* unborrow register */ + } + (void)astore(stack, ++sp, str_2static(str)); + break; + case 'c': + while (len-- > 0) { + if (s + sizeof(char) > strend) + achar = 0; + else { + bcopy(s,(char*)&achar,sizeof(char)); + s += sizeof(char); + } + str = Str_new(36,0); + aint = achar; + if (aint >= 128) /* fake up signed chars */ + aint -= 256; + str_numset(str,(double)aint); + (void)astore(stack, ++sp, str_2static(str)); + } + break; + case 'C': + while (len-- > 0) { + if (s + sizeof(unsigned char) > strend) + auchar = 0; + else { + bcopy(s,(char*)&auchar,sizeof(unsigned char)); + s += sizeof(unsigned char); + } + str = Str_new(37,0); + auint = auchar; /* some can't cast uchar to double */ + str_numset(str,(double)auint); + (void)astore(stack, ++sp, str_2static(str)); + } + break; + case 's': + while (len-- > 0) { + if (s + sizeof(short) > strend) + ashort = 0; + else { + bcopy(s,(char*)&ashort,sizeof(short)); + s += sizeof(short); + } + str = Str_new(38,0); + str_numset(str,(double)ashort); + (void)astore(stack, ++sp, str_2static(str)); + } + break; + case 'n': + case 'S': + while (len-- > 0) { + if (s + sizeof(unsigned short) > strend) + aushort = 0; + else { + bcopy(s,(char*)&aushort,sizeof(unsigned short)); + s += sizeof(unsigned short); + } + str = Str_new(39,0); +#ifdef NTOHS + if (datumtype == 'n') + aushort = ntohs(aushort); +#endif + str_numset(str,(double)aushort); + (void)astore(stack, ++sp, str_2static(str)); + } + break; + case 'i': + while (len-- > 0) { + if (s + sizeof(int) > strend) + aint = 0; + else { + bcopy(s,(char*)&aint,sizeof(int)); + s += sizeof(int); + } + str = Str_new(40,0); + str_numset(str,(double)aint); + (void)astore(stack, ++sp, str_2static(str)); + } + break; + case 'I': + while (len-- > 0) { + if (s + sizeof(unsigned int) > strend) + auint = 0; + else { + bcopy(s,(char*)&auint,sizeof(unsigned int)); + s += sizeof(unsigned int); + } + str = Str_new(41,0); + str_numset(str,(double)auint); + (void)astore(stack, ++sp, str_2static(str)); + } + break; + case 'l': + while (len-- > 0) { + if (s + sizeof(long) > strend) + along = 0; + else { + bcopy(s,(char*)&along,sizeof(long)); + s += sizeof(long); + } + str = Str_new(42,0); + str_numset(str,(double)along); + (void)astore(stack, ++sp, str_2static(str)); + } + break; + case 'N': + case 'L': + while (len-- > 0) { + if (s + sizeof(unsigned long) > strend) + aulong = 0; + else { + bcopy(s,(char*)&aulong,sizeof(unsigned long)); + s += sizeof(unsigned long); + } + str = Str_new(43,0); +#ifdef NTOHL + if (datumtype == 'N') + aulong = ntohl(aulong); +#endif + str_numset(str,(double)aulong); + (void)astore(stack, ++sp, str_2static(str)); + } + break; + case 'p': + while (len-- > 0) { + if (s + sizeof(char*) > strend) + aptr = 0; + else { + bcopy(s,(char*)&aptr,sizeof(char*)); + s += sizeof(char*); + } + str = Str_new(44,0); + if (aptr) + str_set(str,aptr); + (void)astore(stack, ++sp, str_2static(str)); + } + break; + } + } + return sp; +} + +int +do_slice(stab,numarray,lval,gimme,arglast) +register STAB *stab; +int numarray; +int lval; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int max = arglast[2]; + register char *tmps; + register int len; + register int magic = 0; + + if (lval && !numarray) { + if (stab == envstab) + magic = 'E'; + else if (stab == sigstab) + magic = 'S'; +#ifdef SOME_DBM + else if (stab_hash(stab)->tbl_dbm) + magic = 'D'; +#endif /* SOME_DBM */ + } + + if (gimme == G_ARRAY) { + if (numarray) { + while (sp < max) { + if (st[++sp]) { + st[sp-1] = afetch(stab_array(stab),(int)str_gnum(st[sp]), + lval); + } + else + st[sp-1] = Nullstr; + } + } + else { + while (sp < max) { + if (st[++sp]) { + tmps = str_get(st[sp]); + len = st[sp]->str_cur; + st[sp-1] = hfetch(stab_hash(stab),tmps,len, lval); + if (magic) + str_magic(st[sp-1],stab,magic,tmps,len); + } + else + st[sp-1] = Nullstr; + } + } + sp--; + } + else { + if (numarray) { + if (st[max]) + st[sp] = afetch(stab_array(stab),(int)str_gnum(st[max]), lval); + else + st[sp] = Nullstr; + } + else { + if (st[max]) { + tmps = str_get(st[max]); + len = st[max]->str_cur; + st[sp] = hfetch(stab_hash(stab),tmps,len, lval); + if (magic) + str_magic(st[sp],stab,magic,tmps,len); + } + else + st[sp] = Nullstr; + } + } + return sp; +} + +int +do_grep(arg,str,gimme,arglast) +register ARG *arg; +STR *str; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register STR **dst = &st[arglast[1]]; + register STR **src = dst + 1; + register int sp = arglast[2]; + register int i = sp - arglast[1]; + int oldsave = savestack->ary_fill; + + savesptr(&stab_val(defstab)); + if ((arg[1].arg_type & A_MASK) != A_EXPR) + dehoist(arg,1); + arg = arg[1].arg_ptr.arg_arg; + while (i-- > 0) { + stab_val(defstab) = *src; + (void)eval(arg,G_SCALAR,sp); + if (str_true(st[sp+1])) + *dst++ = *src; + src++; + } + restorelist(oldsave); + if (gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[arglast[0]+1] = str; + return arglast[0]+1; + } + return arglast[0] + (dst - &st[arglast[1]]); +} + +int +do_reverse(str,gimme,arglast) +STR *str; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register STR **up = &st[arglast[1]]; + register STR **down = &st[arglast[2]]; + register int i = arglast[2] - arglast[1]; + + if (gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[arglast[0]+1] = str; + return arglast[0]+1; + } + while (i-- > 0) { + *up++ = *down; + *down-- = *up; + } + return arglast[2] - 1; +} + +static CMD *sortcmd; +static STAB *firststab = Nullstab; +static STAB *secondstab = Nullstab; + +int +do_sort(str,stab,gimme,arglast) +STR *str; +STAB *stab; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + int sp = arglast[1]; + register STR **up; + register int max = arglast[2] - sp; + register int i; + int sortcmp(); + int sortsub(); + STR *oldfirst; + STR *oldsecond; + ARRAY *oldstack; + static ARRAY *sortstack = Null(ARRAY*); + + if (gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[sp] = str; + return sp; + } + up = &st[sp]; + for (i = 0; i < max; i++) { + if ((*up = up[1]) && !(*up)->str_pok) + (void)str_2ptr(*up); + up++; + } + sp--; + if (max > 1) { + if (stab_sub(stab) && (sortcmd = stab_sub(stab)->cmd)) { + int oldtmps_base = tmps_base; + + if (!sortstack) { + sortstack = anew(Nullstab); + sortstack->ary_flags = 0; + } + oldstack = stack; + stack = sortstack; + tmps_base = tmps_max; + if (!firststab) { + firststab = stabent("a",TRUE); + secondstab = stabent("b",TRUE); + } + oldfirst = stab_val(firststab); + oldsecond = stab_val(secondstab); +#ifndef lint + qsort((char*)(st+sp+1),max,sizeof(STR*),sortsub); +#else + qsort(Nullch,max,sizeof(STR*),sortsub); +#endif + stab_val(firststab) = oldfirst; + stab_val(secondstab) = oldsecond; + tmps_base = oldtmps_base; + stack = oldstack; + } +#ifndef lint + else + qsort((char*)(st+sp+1),max,sizeof(STR*),sortcmp); +#endif + } + up = &st[arglast[1]]; + while (max > 0 && !*up) + max--,up--; + return sp+max; +} + +int +sortsub(str1,str2) +STR **str1; +STR **str2; +{ + if (!*str1) + return -1; + if (!*str2) + return 1; + stab_val(firststab) = *str1; + stab_val(secondstab) = *str2; + cmd_exec(sortcmd,G_SCALAR,-1); + return (int)str_gnum(*stack->ary_array); +} + +sortcmp(strp1,strp2) +STR **strp1; +STR **strp2; +{ + register STR *str1 = *strp1; + register STR *str2 = *strp2; + int retval; + + if (!str1) + return -1; + if (!str2) + return 1; + + if (str1->str_cur < str2->str_cur) { + if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur)) + return retval; + else + return -1; + } + else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur)) + return retval; + else if (str1->str_cur == str2->str_cur) + return 0; + else + return 1; +} + +int +do_range(gimme,arglast) +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register int sp = arglast[0]; + register int i = (int)str_gnum(st[sp+1]); + register ARRAY *ary = stack; + register STR *str; + int max = (int)str_gnum(st[sp+2]); + + if (gimme != G_ARRAY) + fatal("panic: do_range"); + + while (i <= max) { + (void)astore(ary, ++sp, str = str_static(&str_no)); + str_numset(str,(double)i++); + } + return sp; +} + +int +do_tms(str,gimme,arglast) +STR *str; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register int sp = arglast[0]; + + if (gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[++sp] = str; + return sp; + } + (void)times(×buf); + +#ifndef HZ +#define HZ 60 +#endif + +#ifndef lint + (void)astore(stack,++sp, + str_2static(str_nmake(((double)timesbuf.tms_utime)/HZ))); + (void)astore(stack,++sp, + str_2static(str_nmake(((double)timesbuf.tms_stime)/HZ))); + (void)astore(stack,++sp, + str_2static(str_nmake(((double)timesbuf.tms_cutime)/HZ))); + (void)astore(stack,++sp, + str_2static(str_nmake(((double)timesbuf.tms_cstime)/HZ))); +#else + (void)astore(stack,++sp, + str_2static(str_nmake(0.0))); +#endif + return sp; +} + +int +do_time(str,tmbuf,gimme,arglast) +STR *str; +struct tm *tmbuf; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + STR **st = ary->ary_array; + register int sp = arglast[0]; + + if (!tmbuf || gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[++sp] = str; + return sp; + } + (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_sec))); + (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_min))); + (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_hour))); + (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_mday))); + (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_mon))); + (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_year))); + (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_wday))); + (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_yday))); + (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_isdst))); + return sp; +} + +int +do_kv(str,hash,kv,gimme,arglast) +STR *str; +HASH *hash; +int kv; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + STR **st = ary->ary_array; + register int sp = arglast[0]; + int i; + register HENT *entry; + char *tmps; + STR *tmpstr; + int dokeys = (kv == O_KEYS || kv == O_HASH); + int dovalues = (kv == O_VALUES || kv == O_HASH); + + if (gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[++sp] = str; + return sp; + } + (void)hiterinit(hash); + while (entry = hiternext(hash)) { + if (dokeys) { + tmps = hiterkey(entry,&i); + (void)astore(ary,++sp,str_2static(str_make(tmps,i))); + } + if (dovalues) { + tmpstr = Str_new(45,0); +#ifdef DEBUGGING + if (debug & 8192) { + sprintf(buf,"%d%%%d=%d\n",entry->hent_hash, + hash->tbl_max+1,entry->hent_hash & hash->tbl_max); + str_set(tmpstr,buf); + } + else +#endif + str_sset(tmpstr,hiterval(hash,entry)); + (void)astore(ary,++sp,str_2static(tmpstr)); + } + } + return sp; +} + +int +do_each(str,hash,gimme,arglast) +STR *str; +HASH *hash; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register int sp = arglast[0]; + static STR *mystrk = Nullstr; + HENT *entry = hiternext(hash); + int i; + char *tmps; + + if (mystrk) { + str_free(mystrk); + mystrk = Nullstr; + } + + if (entry) { + if (gimme == G_ARRAY) { + tmps = hiterkey(entry, &i); + st[++sp] = mystrk = str_make(tmps,i); + } + st[++sp] = str; + str_sset(str,hiterval(hash,entry)); + STABSET(str); + return sp; + } + else + return sp; +} diff --git a/dump.c b/dump.c index 1567017..778dc3b 100644 --- a/dump.c +++ b/dump.c @@ -1,8 +1,13 @@ -/* $Header: dump.c,v 2.0 88/06/05 00:08:44 root Exp $ +/* $Header: dump.c,v 3.0 89/10/18 15:11:16 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: dump.c,v $ - * Revision 2.0 88/06/05 00:08:44 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:11:16 lwall + * 3.0 baseline * */ @@ -12,6 +17,24 @@ #ifdef DEBUGGING static int dumplvl = 0; +dump_all() +{ + register int i; + register STAB *stab; + register HENT *entry; + + dump_cmd(main_root,Nullcmd); + for (i = 0; i <= 127; i++) { + for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) { + stab = (STAB*)entry->hent_val; + if (stab_sub(stab)) { + dump("\nSUB %s = ", stab_name(stab)); + dump_cmd(stab_sub(stab)->cmd,Nullcmd); + } + } + } +} + dump_cmd(cmd,alt) register CMD *cmd; register CMD *alt; @@ -20,28 +43,32 @@ register CMD *alt; while (cmd) { dumplvl++; dump("C_TYPE = %s\n",cmdname[cmd->c_type]); + dump("C_ADDR = 0x%lx\n",cmd); + dump("C_NEXT = 0x%lx\n",cmd->c_next); if (cmd->c_line) - dump("C_LINE = %d\n",cmd->c_line); + dump("C_LINE = %d (0x%lx)\n",cmd->c_line,cmd); if (cmd->c_label) dump("C_LABEL = \"%s\"\n",cmd->c_label); dump("C_OPT = CFT_%s\n",cmdopt[cmd->c_flags & CF_OPTIMIZE]); *buf = '\0'; if (cmd->c_flags & CF_FIRSTNEG) - strcat(buf,"FIRSTNEG,"); + (void)strcat(buf,"FIRSTNEG,"); if (cmd->c_flags & CF_NESURE) - strcat(buf,"NESURE,"); + (void)strcat(buf,"NESURE,"); if (cmd->c_flags & CF_EQSURE) - strcat(buf,"EQSURE,"); + (void)strcat(buf,"EQSURE,"); if (cmd->c_flags & CF_COND) - strcat(buf,"COND,"); + (void)strcat(buf,"COND,"); if (cmd->c_flags & CF_LOOP) - strcat(buf,"LOOP,"); + (void)strcat(buf,"LOOP,"); if (cmd->c_flags & CF_INVERT) - strcat(buf,"INVERT,"); + (void)strcat(buf,"INVERT,"); if (cmd->c_flags & CF_ONCE) - strcat(buf,"ONCE,"); + (void)strcat(buf,"ONCE,"); if (cmd->c_flags & CF_FLIP) - strcat(buf,"FLIP,"); + (void)strcat(buf,"FLIP,"); + if (cmd->c_flags & CF_TERM) + (void)strcat(buf,"TERM,"); if (*buf) buf[strlen(buf)-1] = '\0'; dump("C_FLAGS = (%s)\n",buf); @@ -63,18 +90,24 @@ register CMD *alt; } else dump("C_EXPR = NULL\n"); switch (cmd->c_type) { + case C_NEXT: case C_WHILE: case C_BLOCK: + case C_ELSE: case C_IF: if (cmd->ucmd.ccmd.cc_true) { dump("CC_TRUE = "); dump_cmd(cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt); - } else + } + else dump("CC_TRUE = NULL\n"); if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt) { - dump("CC_ELSE = "); - dump_cmd(cmd->ucmd.ccmd.cc_alt,Nullcmd); - } else + dump("CC_ENDELSE = 0x%lx\n",cmd->ucmd.ccmd.cc_alt); + } + else if (cmd->c_type == C_NEXT && cmd->ucmd.ccmd.cc_alt) { + dump("CC_NEXT = 0x%lx\n",cmd->ucmd.ccmd.cc_alt); + } + else dump("CC_ALT = NULL\n"); break; case C_EXPR: @@ -89,6 +122,21 @@ register CMD *alt; } else dump("AC_EXPR = NULL\n"); break; + case C_CSWITCH: + case C_NSWITCH: + { + int max, i; + + max = cmd->ucmd.scmd.sc_max; + dump("SC_MIN = (%d)\n",cmd->ucmd.scmd.sc_offset + 1); + dump("SC_MAX = (%d)\n", max + cmd->ucmd.scmd.sc_offset - 1); + dump("SC_NEXT[LT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[0]); + for (i = 1; i < max; i++) + dump("SC_NEXT[%d] = 0x%lx\n", i + cmd->ucmd.scmd.sc_offset, + cmd->ucmd.scmd.sc_next[i]); + dump("SC_NEXT[GT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[max]); + } + break; } cmd = cmd->c_next; if (cmd && cmd->c_head == cmd) { /* reached end of while loop */ @@ -101,7 +149,7 @@ register CMD *alt; dump("}\n"); if (cmd) if (cmd == alt) - dump("CONT{\n"); + dump("CONT 0x%lx {\n",cmd); else dump("{\n"); } @@ -121,14 +169,15 @@ register ARG *arg; 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]); + dump("[%d]ARG_TYPE = %s%s\n",i,argname[arg[i].arg_type & A_MASK], + arg[i].arg_type & A_DONT ? " (unevaluated)" : ""); if (arg[i].arg_len) dump("[%d]ARG_LEN = %d\n",i,arg[i].arg_len); 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) { + switch (arg[i].arg_type & A_MASK) { case A_NULL: break; case A_LEXPR: @@ -146,6 +195,8 @@ register ARG *arg; case A_READ: case A_GLOB: case A_ARYLEN: + case A_ARYSTAB: + case A_LARYSTAB: dump("[%d]ARG_STAB = ",i); dump_stab(arg[i].arg_ptr.arg_stab); break; @@ -158,9 +209,6 @@ register ARG *arg; dump("[%d]ARG_SPAT = ",i); dump_spat(arg[i].arg_ptr.arg_spat); break; - case A_NUMBER: - dump("[%d]ARG_NVAL = %f\n",i,arg[i].arg_ptr.arg_nval); - break; } } dumplvl--; @@ -172,22 +220,22 @@ char *b; unsigned flags; { *b = '\0'; - if (flags & AF_SPECIAL) - strcat(b,"SPECIAL,"); + if (flags & AF_ARYOK) + (void)strcat(b,"ARYOK,"); if (flags & AF_POST) - strcat(b,"POST,"); + (void)strcat(b,"POST,"); if (flags & AF_PRE) - strcat(b,"PRE,"); + (void)strcat(b,"PRE,"); if (flags & AF_UP) - strcat(b,"UP,"); + (void)strcat(b,"UP,"); if (flags & AF_COMMON) - strcat(b,"COMMON,"); - if (flags & AF_NUMERIC) - strcat(b,"NUMERIC,"); + (void)strcat(b,"COMMON,"); + if (flags & AF_UNUSED) + (void)strcat(b,"UNUSED,"); if (flags & AF_LISTISH) - strcat(b,"LISTISH,"); + (void)strcat(b,"LISTISH,"); if (flags & AF_LOCAL) - strcat(b,"LOCAL,"); + (void)strcat(b,"LOCAL,"); if (*b) b[strlen(b)-1] = '\0'; } @@ -201,7 +249,7 @@ register STAB *stab; } dumplvl++; fprintf(stderr,"{\n"); - dump("STAB_NAME = %s\n",stab->stab_name); + dump("STAB_NAME = %s\n",stab_name(stab)); dumplvl--; dump("}\n"); } @@ -246,7 +294,7 @@ long arg2, arg3, arg4, arg5; int i; for (i = dumplvl*4; i; i--) - putc(' ',stderr); + (void)putc(' ',stderr); fprintf(stderr,arg1, arg2, arg3, arg4, arg5); } #endif @@ -267,15 +315,15 @@ showinput() if (*s & 0200) { fd = creat("/tmp/.foo",0600); write(fd,str_get(linestr),linestr->str_cur); - while(s = str_gets(linestr,rsfp)) { + while(s = str_gets(linestr,rsfp,0)) { write(fd,s,linestr->str_cur); } - close(fd); + (void)close(fd); for (s=cmd; *s; s++) if (*s < ' ') *s += 96; - rsfp = popen(cmd,"r"); - s = str_gets(linestr,rsfp); + rsfp = mypopen(cmd,"r"); + s = str_gets(linestr,rsfp,0); return s; } } diff --git a/eg/ADB b/eg/ADB index 1a43b90..ef54d6d 100644 --- a/eg/ADB +++ b/eg/ADB @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: ADB,v 2.0 88/06/05 00:16:39 root Exp $ +# $Header: ADB,v 3.0 89/10/18 15:13:04 lwall Locked $ # This script is only useful when used in your crash directory. diff --git a/eg/changes b/eg/changes index db9b7b1..7cdc4cd 100644 --- a/eg/changes +++ b/eg/changes @@ -1,6 +1,6 @@ #!/usr/bin/perl -P -# $Header: changes,v 2.0 88/06/05 00:16:41 root Exp $ +# $Header: changes,v 3.0 89/10/18 15:13:23 lwall Locked $ ($dir, $days) = @ARGV; $dir = '/' if $dir eq ''; diff --git a/eg/down b/eg/down new file mode 100644 index 0000000..bbb0d06 --- /dev/null +++ b/eg/down @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +$| = 1; +if ($#ARGV >= 0) { + $cmd = join(' ',@ARGV); +} +else { + print "Command: "; + $cmd = ; + chop($cmd); + while ($cmd =~ s/\\$//) { + print "+ "; + $cmd .= ; + chop($cmd); + } +} +$cwd = `pwd`; chop($cwd); + +open(FIND,'find . -type d -print|') || die "Can't run find"; + +while () { + chop; + unless (chdir $_) { + print stderr "Can't cd to $_\n"; + next; + } + print "\t--> ",$_,"\n"; + system $cmd; + chdir $cwd; +} diff --git a/eg/dus b/eg/dus index 8c7ff94..3f6e774 100644 --- a/eg/dus +++ b/eg/dus @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: dus,v 2.0 88/06/05 00:16:44 root Exp $ +# $Header: dus,v 3.0 89/10/18 15:13:43 lwall Locked $ # This script does a du -s on any directories in the current directory that # are not mount points for another filesystem. diff --git a/eg/findcp b/eg/findcp index 57cac2e..537264e 100644 --- a/eg/findcp +++ b/eg/findcp @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: findcp,v 2.0 88/06/05 00:16:47 root Exp $ +# $Header: findcp,v 3.0 89/10/18 15:13:47 lwall Locked $ # 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. @@ -14,7 +14,7 @@ sub copy { $sourcedir = $ARGV[0]; if ($sourcedir =~ /^\//) { $ARGV[0] = '.'; - unless (chdir($sourcedir)) { die "Can't find directory: $sourcedir"; } + unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; } } $args = join(' ',@ARGV); @@ -32,7 +32,7 @@ else { die("No destination specified"); } -open(find,"find $args |") || die "Can't run find for you."; +open(find,"find $args |") || die "Can't run find for you: $!"; while () { @x = split(' '); diff --git a/eg/findtar b/eg/findtar index 8b604b3..4fdcdad 100644 --- a/eg/findtar +++ b/eg/findtar @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: findtar,v 2.0 88/06/05 00:16:49 root Exp $ +# $Header: findtar,v 3.0 89/10/18 15:13:52 lwall Locked $ # 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. @@ -8,7 +8,7 @@ $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."; +open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!"; while () { @x = split(' '); diff --git a/eg/g/gcp b/eg/g/gcp index 6b4a9a7..9485772 100644 --- a/eg/g/gcp +++ b/eg/g/gcp @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: gcp,v 2.0 88/06/05 00:17:02 root Exp $ +# $Header: gcp,v 3.0 89/10/18 15:13:59 lwall Locked $ # Here is a script to do global rcps. See man page. @@ -98,7 +98,7 @@ line: while (<>) { if ($remainder) { chop($remainder); - open(grem,">.grem") || (printf stderr "Can't create .grem\n"); + open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n"); print grem 'rem=', $remainder, "\n"; close(grem); print 'rem=', $remainder, "\n"; diff --git a/eg/g/gcp.man b/eg/g/gcp.man index 83c5d85..e14534b 100644 --- a/eg/g/gcp.man +++ b/eg/g/gcp.man @@ -1,4 +1,4 @@ -.\" $Header: gcp.man,v 2.0 88/06/05 00:17:05 root Exp $ +.\" $Header: gcp.man,v 3.0 89/10/18 15:14:09 lwall Locked $ .TH GCP 1C "13 May 1988" .SH NAME gcp \- global file copy diff --git a/eg/g/ged b/eg/g/ged index bb7c222..ef1867a 100644 --- a/eg/g/ged +++ b/eg/g/ged @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: ged,v 2.0 88/06/05 00:17:08 root Exp $ +# $Header: ged,v 3.0 89/10/18 15:14:22 lwall Locked $ # Does inplace edits on a set of files on a set of machines. # diff --git a/eg/g/gsh b/eg/g/gsh index 50ce1f7..b60deb2 100644 --- a/eg/g/gsh +++ b/eg/g/gsh @@ -1,6 +1,6 @@ #!/bin/perl -# $Header: gsh,v 2.0 88/06/05 00:17:20 root Exp $ +# $Header: gsh,v 3.0 89/10/18 15:14:36 lwall Locked $ # Do rsh globally--see man page @@ -85,8 +85,8 @@ line: while (<>) { # for each line of ghosts } close(pipe); } else { + print "(Can't execute rsh: $!)\n"; $SIG{'INT'} = 'cont'; - print "(Can't execute rsh.)\n"; } } } @@ -95,7 +95,7 @@ unlink "/tmp/gsh$$" if $dodist; if ($remainder) { chop($remainder); - open(grem,">.grem") || (printf stderr "Can't make a .grem file\n"); + open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n"); print grem 'rem=', $remainder, "\n"; close(grem); print 'rem=', $remainder, "\n"; diff --git a/eg/g/gsh.man b/eg/g/gsh.man index 4522129..08bed19 100644 --- a/eg/g/gsh.man +++ b/eg/g/gsh.man @@ -1,4 +1,4 @@ -.\" $Header: gsh.man,v 2.0 88/06/05 00:17:23 root Exp $ +.\" $Header: gsh.man,v 3.0 89/10/18 15:14:42 lwall Locked $ .TH GSH 8 "13 May 1988" .SH NAME gsh \- global shell diff --git a/eg/muck b/eg/muck new file mode 100644 index 0000000..873539b --- /dev/null +++ b/eg/muck @@ -0,0 +1,141 @@ +#!../perl + +$M = '-M'; +$M = '-m' if -d '/usr/uts' && -f '/etc/master'; + +do 'getopt.pl'; +do Getopt('f'); + +if ($opt_f) { + $makefile = $opt_f; +} +elsif (-f 'makefile') { + $makefile = 'makefile'; +} +elsif (-f 'Makefile') { + $makefile = 'Makefile'; +} +else { + die "No makefile\n"; +} + +$MF = 'mf00'; + +while(($key,$val) = each(ENV)) { + $mac{$key} = $val; +} + +do scan($makefile); + +$co = $action{'.c.o'}; +$co = ' ' unless $co; + +$missing = "Missing dependencies:\n"; +foreach $key (sort keys(o)) { + if ($oc{$key}) { + $src = $oc{$key}; + $action = $action{$key}; + } + else { + $action = ''; + } + if (!$action) { + if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) { + $src = $c; + $action = $co; + } + else { + print "No source found for $key $c\n"; + next; + } + } + $I = ''; + $D = ''; + $I .= $1 while $action =~ s/(-I\S+\s*)//; + $D .= $1 . ' ' while $action =~ s/(-D\w+)//; + if ($opt_v) { + $cmd = "Checking $key: cc $M $D $I $src"; + $cmd =~ s/\s\s+/ /g; + print stderr $cmd,"\n"; + } + open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!"; + while () { + ($name,$dep) = split; + $dep =~ s|^\./||; + (print $missing,"$key: $dep\n"),($missing='') + unless ($dep{"$key: $dep"} += 2) > 2; + } +} + +$extra = "\nExtraneous dependencies:\n"; +foreach $key (sort keys(dep)) { + if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) { + print $extra,$key,"\n"; + $extra = ''; + } +} + +sub scan { + local($makefile) = @_; + local($MF) = $MF; + print stderr "Analyzing $makefile.\n" if $opt_v; + $MF++; + open($MF,$makefile) || die "Can't open $makefile: $!"; + while (<$MF>) { + chop; + chop($_ = $_ . <$MF>) while s/\\$//; + next if /^#/; + next if /^$/; + s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; + s/\$\((\w+)\)/$mac{$1}/eg; + $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/; + if (/^include\s+(.*)/) { + do scan($1); + print stderr "Continuing $makefile.\n" if $opt_v; + next; + } + if (/^([^:]+):\s*(.*)/) { + $left = $1; + $right = $2; + if ($right =~ /^([^;]*);(.*)/) { + $right = $1; + $action = $2; + } + else { + $action = ''; + } + while (<$MF>) { + last unless /^\t/; + chop; + chop($_ = $_ . <$MF>) while s/\\$//; + next if /^#/; + last if /^$/; + s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; + s/\$\((\w+)\)/$mac{$1}/eg; + $action .= $_; + } + foreach $targ (split(' ',$left)) { + $targ =~ s|^\./||; + foreach $src (split(' ',$right)) { + $src =~ s|^\./||; + $deplist{$targ} .= ' ' . $src; + $dep{"$targ: $src"} = 1; + $o{$src} = 1 if $src =~ /\.o$/; + $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/; + } + $action{$targ} .= $action; + } + redo if $_; + } + } + close($MF); +} + +sub subst { + local($foo,$from,$to) = @_; + $foo = $mac{$foo}; + $from =~ s/\./[.]/; + y/a/a/; + $foo =~ s/\b$from\b/$to/g; + $foo; +} diff --git a/eg/muck.man b/eg/muck.man new file mode 100644 index 0000000..e432715 --- /dev/null +++ b/eg/muck.man @@ -0,0 +1,21 @@ +.\" $Header: muck.man,v 3.0 89/10/18 15:14:55 lwall Locked $ +.TH MUCK 1 "10 Jan 1989" +.SH NAME +muck \- make usage checker +.SH SYNOPSIS +.B muck +[options] +.SH DESCRIPTION +.I muck +looks at your current makefile and complains if you've left out any dependencies +between .o and .h files. +It also complains about extraneous dependencies. +.PP +You can use the -f FILENAME option to specify an alternate name for your +makefile. +The -v option is a little more verbose about what muck is mucking around +with at the moment. +.SH SEE ALSO +make(1) +.SH BUGS +Only knows about .h, .c and .o files. diff --git a/eg/myrup b/eg/myrup index c32c99c..f7d64db 100644 --- a/eg/myrup +++ b/eg/myrup @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: myrup,v 2.0 88/06/05 00:16:51 root Exp $ +# $Header: myrup,v 3.0 89/10/18 15:15:06 lwall Locked $ # 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 @@ -9,7 +9,7 @@ print "node load (u)\n------- --------\n"; -open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts"; +open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!"; line: while () { next line if /^#/; next line if /^$/; @@ -18,7 +18,7 @@ line: while () { $wanted{$host} = 1; } -open(ruptime,'ruptime|') || die "Can't run ruptime"; +open(ruptime,'ruptime|') || die "Can't run ruptime: $!"; open(sort,'|sort +1n'); while () { diff --git a/eg/nih b/eg/nih index 15cb60f..67f25cd 100644 --- a/eg/nih +++ b/eg/nih @@ -1,7 +1,7 @@ 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 $ +# $Header: nih,v 3.0 89/10/18 15:15:12 lwall Locked $ # This script makes #! scripts directly executable on machines that don't # support #!. It edits in place any scripts mentioned on the command line. diff --git a/eg/rename b/eg/rename new file mode 100644 index 0000000..1708d35 --- /dev/null +++ b/eg/rename @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +($op = shift) || die "Usage: rename perlexpr [filenames]\n"; +if ($#ARGV < 0) { + @ARGV = ; + chop(@ARGV); +} +for (@ARGV) { + $was = $_; + eval $op; + die $@ if $@; + rename($was,$_) unless $was eq $_; +} diff --git a/eg/rmfrom b/eg/rmfrom index 0fca304..43ce105 100644 --- a/eg/rmfrom +++ b/eg/rmfrom @@ -1,6 +1,6 @@ #!/usr/bin/perl -n -# $Header: rmfrom,v 2.0 88/06/05 00:16:57 root Exp $ +# $Header: rmfrom,v 3.0 89/10/18 15:15:20 lwall Locked $ # A handy (but dangerous) script to put after a find ... -print. diff --git a/eg/scan/scan_df b/eg/scan/scan_df index ca31642..27ee81a 100644 --- a/eg/scan/scan_df +++ b/eg/scan/scan_df @@ -1,10 +1,10 @@ #!/usr/bin/perl -P -# $Header: scan_df,v 2.0 88/06/05 00:17:56 root Exp $ +# $Header: scan_df,v 3.0 89/10/18 15:15:26 lwall Locked $ # This report points out filesystems that are in danger of overflowing. -(chdir '/usr/adm/private/memories') || die "Can't cd."; +(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; `df >newdf`; open(Df, 'olddf'); diff --git a/eg/scan/scan_last b/eg/scan/scan_last index 25d7843..65a07fe 100644 --- a/eg/scan/scan_last +++ b/eg/scan/scan_last @@ -1,6 +1,6 @@ #!/usr/bin/perl -P -# $Header: scan_last,v 2.0 88/06/05 00:17:58 root Exp $ +# $Header: scan_last,v 3.0 89/10/18 15:15:31 lwall Locked $ # This reports who was logged on at weird hours diff --git a/eg/scan/scan_messages b/eg/scan/scan_messages index 6f8ab2b..ae641a9 100644 --- a/eg/scan/scan_messages +++ b/eg/scan/scan_messages @@ -1,10 +1,10 @@ #!/usr/bin/perl -P -# $Header: scan_messages,v 2.0 88/06/05 00:17:46 root Exp $ +# $Header: scan_messages,v 3.0 89/10/18 15:15:38 lwall Locked $ # This prints out extraordinary console messages. You'll need to customize. -chdir('/usr/adm/private/memories') || die "Can't cd."; +chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; $maxpos = `cat oldmsgs 2>&1`; @@ -197,12 +197,12 @@ while () { } $max = tell(Msgs); -open(tmp,'|sort >oldmsgs.tmp') || die "Can't create tmp file."; +open(tmp,'|sort >oldmsgs.tmp') || die "Can't create tmp file: $!\n"; while ($_ = pop(@seen)) { print tmp $_; } close(tmp); -open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file."; +open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file: $!\n"; while () { if (/^nd:/) { next if $seen{$_} < 20; diff --git a/eg/scan/scan_passwd b/eg/scan/scan_passwd index 62ef1e7..f49b1a9 100644 --- a/eg/scan/scan_passwd +++ b/eg/scan/scan_passwd @@ -1,10 +1,10 @@ #!/usr/bin/perl -# $Header: scan_passwd,v 2.0 88/06/05 00:17:49 root Exp $ +# $Header: scan_passwd,v 3.0 89/10/18 15:15:43 lwall Locked $ # This scans passwd file for security holes. -open(Pass,'/etc/passwd') || die "Can't open passwd file"; +open(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n"; # $dotriv = (`date` =~ /^Mon/); $dotriv = 1; diff --git a/eg/scan/scan_ps b/eg/scan/scan_ps index bb33b87..a70f360 100644 --- a/eg/scan/scan_ps +++ b/eg/scan/scan_ps @@ -1,6 +1,6 @@ #!/usr/bin/perl -P -# $Header: scan_ps,v 2.0 88/06/05 00:17:51 root Exp $ +# $Header: scan_ps,v 3.0 89/10/18 15:15:47 lwall Locked $ # This looks for looping processes. diff --git a/eg/scan/scan_sudo b/eg/scan/scan_sudo index e0a99ee..bfbebe2 100644 --- a/eg/scan/scan_sudo +++ b/eg/scan/scan_sudo @@ -1,10 +1,10 @@ #!/usr/bin/perl -P -# $Header: scan_sudo,v 2.0 88/06/05 00:18:01 root Exp $ +# $Header: scan_sudo,v 3.0 89/10/18 15:15:52 lwall Locked $ # Analyze the sudo log. -chdir('/usr/adm/private/memories') || die "Can't cd."; +chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; if (open(Oldsudo,'oldsudo')) { $maxpos = ; @@ -41,12 +41,12 @@ while () { } $max = tell(Sudo); -open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file."; +open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n"; while ($_ = pop(@seen)) { print tmp $_; } close(tmp); -open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file."; +open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n"; while () { print $seen{$_},":\t",$_; } diff --git a/eg/scan/scan_suid b/eg/scan/scan_suid index 4f62705..1ebca0b 100644 --- a/eg/scan/scan_suid +++ b/eg/scan/scan_suid @@ -1,10 +1,10 @@ #!/usr/bin/perl -P -# $Header: scan_suid,v 2.0 88/06/05 00:17:54 root Exp $ +# $Header: scan_suid,v 3.0 89/10/18 15:15:57 lwall Locked $ # Look for new setuid root files. -chdir '/usr/adm/private/memories' || die "Can't cd."; +chdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n"; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('oldsuid'); diff --git a/eg/scan/scanner b/eg/scan/scanner index 25e953d..8ef7fe8 100644 --- a/eg/scan/scanner +++ b/eg/scan/scanner @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: scanner,v 2.0 88/06/05 00:17:42 root Exp $ +# $Header: scanner,v 3.0 89/10/18 15:16:02 lwall Locked $ # This runs all the scan_* routines on all the machines in /etc/ghosts. # We run this every morning at about 6 am: @@ -20,7 +20,7 @@ $| = 1; # command buffering on stdout print "Subject: bizarre happenings\n\n"; -(chdir '/usr/adm/private') || die "Can't cd."; +(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n"; if ($#ARGV >= 0) { @scanlist = @ARGV; @@ -60,7 +60,7 @@ scan: while ($scan = shift(@scanlist)) { $iter = 0; `exec crypt -inquire <$scan >.x 2>/dev/null`; unless (open(scan,'.x')) { - print "Can't run $scan."; + print "Can't run $scan: $!\n"; next scan; } $cmd = ; @@ -78,7 +78,7 @@ scan: while ($scan = shift(@scanlist)) { } close(pipe); } else { - print "(Can't execute rsh.)\n"; + print "(Can't execute rsh: $!)\n"; } last class; } diff --git a/eg/shmkill b/eg/shmkill index ba288d8..f3d4aec 100644 --- a/eg/shmkill +++ b/eg/shmkill @@ -1,11 +1,11 @@ #!/usr/bin/perl -# $Header: shmkill,v 2.0 88/06/05 00:16:59 root Exp $ +# $Header: shmkill,v 3.0 89/10/18 15:16:09 lwall Locked $ # 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"; +open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!"; while () { $tmp = index($_,'NATTCH'); @@ -13,7 +13,7 @@ while () { if (/^m/) { ($m,$id,$key,$mode,$owner,$group,$attach) = split; if ($attach != substr($_,$pos,6)) { - die "Different ipcs format--can't parse!"; + die "Different ipcs format--can't parse!\n"; } if ($attach == 0) { push(@goners,'-m',$id); diff --git a/eg/van/empty b/eg/van/empty index 11a5558..0f3d9e3 100644 --- a/eg/van/empty +++ b/eg/van/empty @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: empty,v 2.0 88/06/05 00:17:39 root Exp $ +# $Header: empty,v 3.0 89/10/18 15:16:28 lwall Locked $ # This script empties a trashcan. @@ -12,7 +12,7 @@ chop($pwd = `pwd`); dir: foreach $dir (@ARGV) { unless (chdir $dir) { - print stderr "Can't find directory $dir\n"; + print stderr "Can't find directory $dir: $!\n"; next dir; } if ($recursive) { diff --git a/eg/van/unvanish b/eg/van/unvanish index 4a83c81..5c0dab0 100644 --- a/eg/van/unvanish +++ b/eg/van/unvanish @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: unvanish,v 2.0 88/06/05 00:17:30 root Exp $ +# $Header: unvanish,v 3.0 89/10/18 15:16:35 lwall Locked $ sub it { if ($olddir ne '.') { @@ -18,7 +18,7 @@ sub it { } print `mv $startfiles$filelist..$force`; if ($olddir ne '.') { - (chdir $pwd) || die "Can't get back to original directory: $pwd"; + (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; } } diff --git a/eg/van/vanexp b/eg/van/vanexp index 29b42e8..ef31882 100644 --- a/eg/van/vanexp +++ b/eg/van/vanexp @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: vanexp,v 2.0 88/06/05 00:17:34 root Exp $ +# $Header: vanexp,v 3.0 89/10/18 15:16:41 lwall Locked $ # This is for running from a find at night to expire old .deleteds diff --git a/eg/van/vanish b/eg/van/vanish index b665e7c..e49c052 100644 --- a/eg/van/vanish +++ b/eg/van/vanish @@ -1,6 +1,6 @@ #!/usr/bin/perl -# $Header: vanish,v 2.0 88/06/05 00:17:36 root Exp $ +# $Header: vanish,v 3.0 89/10/18 15:16:46 lwall Locked $ sub it { if ($olddir ne '.') { @@ -20,7 +20,7 @@ sub it { print `/bin/mv $startfiles$filelist .deleted$force`; } if ($olddir ne '.') { - (chdir $pwd) || die "Can't get back to original directory: $pwd"; + (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; } } diff --git a/eg/who b/eg/who new file mode 100644 index 0000000..6543908 --- /dev/null +++ b/eg/who @@ -0,0 +1,13 @@ +#!/usr/bin/perl +# This assumes your /etc/utmp file looks like ours +open(utmp,'/etc/utmp'); +@mo = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'); +while (read(utmp,$utmp,36)) { + ($line,$name,$host,$time) = unpack('A8A8A16l',$utmp); + if ($name) { + $host = "($host)" if $host; + ($sec,$min,$hour,$mday,$mon) = localtime($time); + printf "%-9s%-8s%s %2d %02d:%02d %s\n", + $name,$line,$mo[$mon],$mday,$hour,$min,$host; + } +} diff --git a/eval.c b/eval.c index 78a06cb..32da854 100644 --- a/eval.c +++ b/eval.c @@ -1,8 +1,13 @@ -/* $Header: eval.c,v 2.0 88/06/05 00:08:48 root Exp $ +/* $Header: eval.c,v 3.0 89/10/18 15:17:04 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: eval.c,v $ - * Revision 2.0 88/06/05 00:08:48 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:17:04 lwall + * 3.0 baseline * */ @@ -12,6 +17,10 @@ #include #include +#ifdef I_VFORK +# include +#endif + extern int errno; #ifdef VOIDSIG @@ -24,27 +33,36 @@ static int (*qhand)(); ARG *debarg; STR str_args; +static STAB *stab2; +static STIO *stio; +static struct lstring *lstr; +static char old_record_separator; -STR * -eval(arg,retary,sargoff) +double sin(), cos(), atan2(), pow(); + +char *getlogin(); + +extern int sys_nerr; +extern char *sys_errlist[]; + +int +eval(arg,gimme,sp) register ARG *arg; -STR ***retary; /* where to return an array to, null if nowhere */ -int sargoff; /* how many elements in sarg are already assigned */ +int gimme; +register int sp; { register STR *str; register int anum; register int optype; + register STR **st; 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; + int arglast[8]; /* highest sp for arg--valid only for non-O_LIST args */ unsigned long tmplong; long when; FILE *fp; @@ -55,319 +73,67 @@ int sargoff; /* how many elements in sarg are already assigned */ bool assigning = FALSE; double exp(), log(), sqrt(), modf(); char *crypt(), *getenv(); + extern void grow_dlevel(); if (!arg) - return &str_no; - str = arg->arg_ptr.arg_str; + goto say_undef; 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; + maxarg = arg->arg_len; + arglast[0] = sp; + str = arg->arg_ptr.arg_str; + if (sp + maxarg > stack->ary_max) + astore(stack, sp + maxarg, Nullstr); + st = stack->ary_array; + #ifdef DEBUGGING if (debug) { if (debug & 8) { deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg); } debname[dlevel] = opname[optype][0]; - debdelim[dlevel++] = ':'; + debdelim[dlevel] = ':'; + if (++dlevel >= dlmax) + grow_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 - } +#include "evalargs.xc" + + st += arglast[0]; switch (optype) { + case O_RCAT: + STABSET(str); + break; case O_ITEM: - if (maxarg > arg->arg_len) + if (gimme == G_ARRAY) goto array_return; - if (str != sarg[1]) - str_sset(str,sarg[1]); + STR_SSET(str,st[1]); STABSET(str); break; case O_ITEM2: - if (str != sarg[--anum]) - str_sset(str,sarg[anum]); + if (gimme == G_ARRAY) + goto array_return; + --anum; + STR_SSET(str,st[arglast[anum]-arglast[0]]); STABSET(str); break; case O_ITEM3: - if (str != sarg[--anum]) - str_sset(str,sarg[anum]); + if (gimme == G_ARRAY) + goto array_return; + --anum; + STR_SSET(str,st[arglast[anum]-arglast[0]]); STABSET(str); break; case O_CONCAT: - if (str != sarg[1]) - str_sset(str,sarg[1]); - str_scat(str,sarg[2]); + STR_SSET(str,st[1]); + str_scat(str,st[2]); STABSET(str); break; case O_REPEAT: - if (str != sarg[1]) - str_sset(str,sarg[1]); - anum = (int)str_gnum(sarg[2]); + STR_SSET(str,st[1]); + anum = (int)str_gnum(st[2]); if (anum >= 1) { - tmpstr = str_new(0); + tmpstr = Str_new(50,0); str_sset(tmpstr,str); while (--anum > 0) str_scat(str,tmpstr); @@ -377,239 +143,365 @@ int sargoff; /* how many elements in sarg are already assigned */ STABSET(str); break; case O_MATCH: - str_sset(str, do_match(arg, - retary,sarg,&maxsarg,sargoff,cushion)); - if (retary) { - sarg = *retary; /* they realloc it */ + sp = do_match(str,arg, + gimme,arglast); + if (gimme == G_ARRAY) 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); + sp = do_match(str,arg, + gimme,arglast); + if (gimme == G_ARRAY) + goto array_return; + str_sset(str, str_true(str) ? &str_no : &str_yes); STABSET(str); break; case O_SUBST: - value = (double) do_subst(str, arg); - str = arg->arg_ptr.arg_str; - goto donumset; + sp = do_subst(str,arg,arglast[0]); + goto array_return; case O_NSUBST: - str_set(arg->arg_ptr.arg_str, do_subst(str, arg) ? No : Yes); + sp = do_subst(str,arg,arglast[0]); str = arg->arg_ptr.arg_str; - break; + str_set(str, str_true(str) ? No : Yes); + goto array_return; case O_ASSIGN: - if (arg[1].arg_flags & AF_SPECIAL) - do_assign(str,arg,sarg); + if (arg[1].arg_flags & AF_ARYOK) { + if (arg->arg_len == 1) { + arg->arg_type = O_LOCAL; + arg->arg_flags |= AF_LOCAL; + goto local; + } + else { + arg->arg_type = O_AASSIGN; + goto aassign; + } + } else { - if (str != sarg[2]) - str_sset(str, sarg[2]); - STABSET(str); + arg->arg_type = O_SASSIGN; + goto sassign; } + case O_LOCAL: + local: + arglast[2] = arglast[1]; /* push a null array */ + /* FALL THROUGH */ + case O_AASSIGN: + aassign: + sp = do_assign(arg, + gimme,arglast); + goto array_return; + case O_SASSIGN: + sassign: + STR_SSET(str, st[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; + st -= arglast[0]; str = arg->arg_ptr.arg_str; + for (sp = arglast[0] + 1; sp <= arglast[1]; sp++) + do_chop(str,st[sp]); + st += arglast[0]; break; + case O_DEFINED: + if (arg[1].arg_type & A_DONT) { + sp = do_defined(str,arg, + gimme,arglast); + goto array_return; + } + else if (str->str_pok || str->str_nok) + goto say_yes; + goto say_no; + case O_UNDEF: + if (arg[1].arg_type & A_DONT) { + sp = do_undef(str,arg, + gimme,arglast); + goto array_return; + } + else if (str != stab_val(defstab)) { + str->str_pok = str->str_nok = 0; + STABSET(str); + } + goto say_undef; case O_STUDY: - value = (double)do_study(str); - str = arg->arg_ptr.arg_str; + sp = do_study(str,arg, + gimme,arglast); + goto array_return; + case O_POW: + value = str_gnum(st[1]); + value = pow(value,str_gnum(st[2])); goto donumset; case O_MULTIPLY: - value = str_gnum(sarg[1]); - value *= str_gnum(sarg[2]); + value = str_gnum(st[1]); + value *= str_gnum(st[2]); goto donumset; case O_DIVIDE: - if ((value = str_gnum(sarg[2])) == 0.0) + if ((value = str_gnum(st[2])) == 0.0) fatal("Illegal division by zero"); - value = str_gnum(sarg[1]) / value; + value = str_gnum(st[1]) / value; goto donumset; case O_MODULO: - if ((tmplong = (unsigned long) str_gnum(sarg[2])) == 0L) + tmplong = (long) str_gnum(st[2]); + if (tmplong == 0L) fatal("Illegal modulus zero"); - value = str_gnum(sarg[1]); - value = (double)(((unsigned long)value) % tmplong); + when = (long)str_gnum(st[1]); +#ifndef lint + if (when >= 0) + value = (double)(when % tmplong); + else + value = (double)(tmplong - (-when % tmplong)); +#endif goto donumset; case O_ADD: - value = str_gnum(sarg[1]); - value += str_gnum(sarg[2]); + value = str_gnum(st[1]); + value += str_gnum(st[2]); goto donumset; case O_SUBTRACT: - value = str_gnum(sarg[1]); - value -= str_gnum(sarg[2]); + value = str_gnum(st[1]); + value -= str_gnum(st[2]); goto donumset; case O_LEFT_SHIFT: - value = str_gnum(sarg[1]); - anum = (int)str_gnum(sarg[2]); - value = (double)(((unsigned long)value) << anum); + value = str_gnum(st[1]); + anum = (int)str_gnum(st[2]); +#ifndef lint + value = (double)(((long)value) << anum); +#endif goto donumset; case O_RIGHT_SHIFT: - value = str_gnum(sarg[1]); - anum = (int)str_gnum(sarg[2]); - value = (double)(((unsigned long)value) >> anum); + value = str_gnum(st[1]); + anum = (int)str_gnum(st[2]); +#ifndef lint + value = (double)(((long)value) >> anum); +#endif goto donumset; case O_LT: - value = str_gnum(sarg[1]); - value = (double)(value < str_gnum(sarg[2])); + value = str_gnum(st[1]); + value = (value < str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_GT: - value = str_gnum(sarg[1]); - value = (double)(value > str_gnum(sarg[2])); + value = str_gnum(st[1]); + value = (value > str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_LE: - value = str_gnum(sarg[1]); - value = (double)(value <= str_gnum(sarg[2])); + value = str_gnum(st[1]); + value = (value <= str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_GE: - value = str_gnum(sarg[1]); - value = (double)(value >= str_gnum(sarg[2])); + value = str_gnum(st[1]); + value = (value >= str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_EQ: - value = str_gnum(sarg[1]); - value = (double)(value == str_gnum(sarg[2])); + if (dowarn) { + if ((!st[1]->str_nok && !looks_like_number(st[1])) || + (!st[2]->str_nok && !looks_like_number(st[2])) ) + warn("Possible use of == on string value"); + } + value = str_gnum(st[1]); + value = (value == str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_NE: - value = str_gnum(sarg[1]); - value = (double)(value != str_gnum(sarg[2])); + value = str_gnum(st[1]); + value = (value != str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_BIT_AND: - value = str_gnum(sarg[1]); - value = (double)(((unsigned long)value) & - (unsigned long)str_gnum(sarg[2])); - goto donumset; + if (!sawvec || st[1]->str_nok || st[2]->str_nok) { + value = str_gnum(st[1]); +#ifndef lint + value = (double)(((long)value) & (long)str_gnum(st[2])); +#endif + goto donumset; + } + else + do_vop(optype,str,st[1],st[2]); + break; case O_XOR: - value = str_gnum(sarg[1]); - value = (double)(((unsigned long)value) ^ - (unsigned long)str_gnum(sarg[2])); - goto donumset; + if (!sawvec || st[1]->str_nok || st[2]->str_nok) { + value = str_gnum(st[1]); +#ifndef lint + value = (double)(((long)value) ^ (long)str_gnum(st[2])); +#endif + goto donumset; + } + else + do_vop(optype,str,st[1],st[2]); + break; case O_BIT_OR: - value = str_gnum(sarg[1]); - value = (double)(((unsigned long)value) | - (unsigned long)str_gnum(sarg[2])); - goto donumset; + if (!sawvec || st[1]->str_nok || st[2]->str_nok) { + value = str_gnum(st[1]); +#ifndef lint + value = (double)(((long)value) | (long)str_gnum(st[2])); +#endif + goto donumset; + } + else + do_vop(optype,str,st[1],st[2]); + break; +/* use register in evaluating str_true() */ case O_AND: - if (str_true(sarg[1])) { + if (str_true(st[1])) { anum = 2; optype = O_ITEM2; argflags = arg[anum].arg_flags; - argtype = arg[anum].arg_type; + if (gimme == G_ARRAY) + argflags |= AF_ARYOK; + argtype = arg[anum].arg_type & A_MASK; argptr = arg[anum].arg_ptr; maxarg = anum = 1; + sp = arglast[0]; + st -= sp; goto re_eval; } else { if (assigning) { - str_sset(str, sarg[1]); + str_sset(str, st[1]); STABSET(str); } else - str = sarg[1]; + str = st[1]; break; } case O_OR: - if (str_true(sarg[1])) { + if (str_true(st[1])) { if (assigning) { - str_sset(str, sarg[1]); + str_sset(str, st[1]); STABSET(str); } else - str = sarg[1]; + str = st[1]; break; } else { anum = 2; optype = O_ITEM2; argflags = arg[anum].arg_flags; - argtype = arg[anum].arg_type; + if (gimme == G_ARRAY) + argflags |= AF_ARYOK; + argtype = arg[anum].arg_type & A_MASK; argptr = arg[anum].arg_ptr; maxarg = anum = 1; + sp = arglast[0]; + st -= sp; goto re_eval; } case O_COND_EXPR: - anum = (str_true(sarg[1]) ? 2 : 3); + anum = (str_true(st[1]) ? 2 : 3); optype = (anum == 2 ? O_ITEM2 : O_ITEM3); argflags = arg[anum].arg_flags; - argtype = arg[anum].arg_type; + if (gimme == G_ARRAY) + argflags |= AF_ARYOK; + argtype = arg[anum].arg_type & A_MASK; argptr = arg[anum].arg_ptr; maxarg = anum = 1; + sp = arglast[0]; + st -= sp; goto re_eval; case O_COMMA: - str = sarg[2]; + if (gimme == G_ARRAY) + goto array_return; + str = st[2]; break; case O_NEGATE: - value = -str_gnum(sarg[1]); + value = -str_gnum(st[1]); goto donumset; case O_NOT: - value = (double) !str_true(sarg[1]); + value = (double) !str_true(st[1]); goto donumset; case O_COMPLEMENT: - value = (double) ~(long)str_gnum(sarg[1]); +#ifndef lint + value = (double) ~(long)str_gnum(st[1]); +#endif 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); + tmps = stab_name(defoutstab); + if (maxarg > 0) { + if ((arg[1].arg_type & A_MASK) == A_WORD) + defoutstab = arg[1].arg_ptr.arg_stab; + else + defoutstab = stabent(str_get(st[1]),TRUE); + if (!stab_io(defoutstab)) + stab_io(defoutstab) = stio_new(); + curoutstab = defoutstab; + } + str_set(str, tmps); 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 if ((arg[1].arg_type & A_MASK) == A_WORD) { + if (!(stab = arg[1].arg_ptr.arg_stab)) + stab = defoutstab; + } else - stab = stabent(str_get(sarg[1]),TRUE); - if (!stab->stab_io) { + stab = stabent(str_get(st[1]),TRUE); + if (!stab_io(stab)) { str_set(str, No); STABSET(str); break; } curoutstab = stab; - fp = stab->stab_io->fp; + fp = stab_io(stab)->ofp; debarg = arg; - if (stab->stab_io->fmt_stab) - form = stab->stab_io->fmt_stab->stab_form; + if (stab_io(stab)->fmt_stab) + form = stab_form(stab_io(stab)->fmt_stab); else - form = stab->stab_form; + form = stab_form(stab); if (!form || !fp) { + if (dowarn) { + if (form) + warn("No format for filehandle"); + else { + if (stab_io(stab)->ifp) + warn("Filehandle only opened for input"); + else + warn("Write on closed filehandle"); + } + } 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); + format(&outrec,form,sp); + do_write(&outrec,stab_io(stab),sp); + if (stab_io(stab)->flags & IOF_FLUSH) + (void)fflush(fp); str_set(str, Yes); STABSET(str); break; + case O_DBMOPEN: +#ifdef SOME_DBM + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + anum = (int)str_gnum(st[3]); + value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum); + goto donumset; +#else + fatal("No dbm or ndbm on this machine"); +#endif + case O_DBMCLOSE: +#ifdef SOME_DBM + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + hdbmclose(stab_hash(stab)); + goto say_yes; +#else + fatal("No dbm or ndbm on this machine"); +#endif case O_OPEN: - if (arg[1].arg_type == A_WORD) + if ((arg[1].arg_type & A_MASK) == 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]))) { + stab = stabent(str_get(st[1]),TRUE); + if (do_open(stab,str_get(st[2]))) { value = (double)forkprocess; - stab->stab_io->lines = 0; + stab_io(stab)->lines = 0; goto donumset; } else - str_set(str, No); - STABSET(str); + goto say_undef; break; case O_TRANS: value = (double) do_trans(str,arg); @@ -620,298 +512,490 @@ int sargoff; /* how many elements in sarg are already assigned */ str = arg->arg_ptr.arg_str; break; case O_CLOSE: - if (arg[1].arg_type == A_WORD) + if (maxarg == 0) + stab = defoutstab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else - stab = stabent(str_get(sarg[1]),TRUE); + stab = stabent(str_get(st[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; + sp = do_each(str,stab_hash(arg[1].arg_ptr.arg_stab), + gimme,arglast); + goto array_return; 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; + sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype, + gimme,arglast); + goto array_return; + case O_LARRAY: + str->str_nok = str->str_pok = 0; + str->str_u.str_stab = arg[1].arg_ptr.arg_stab; + str->str_state = SS_ARY; + break; 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; + ary = stab_array(arg[1].arg_ptr.arg_stab); + maxarg = ary->ary_fill + 1; + if (gimme == G_ARRAY) { /* array wanted */ + sp = arglast[0]; + st -= sp; + if (maxarg > 0 && sp + maxarg > stack->ary_max) { + astore(stack,sp + maxarg, Nullstr); + st = stack->ary_array; } - else - str = afetch(ary,maxarg); + Copy(ary->ary_array, &st[sp+1], maxarg, STR*); + sp += maxarg; + goto array_return; } else - str = afetch(arg[2].arg_ptr.arg_stab->stab_array, - ((int)str_gnum(sarg[1])) - arybase); + str = afetch(ary,maxarg - 1,FALSE); + break; + case O_AELEM: + str = afetch(stab_array(arg[1].arg_ptr.arg_stab), + ((int)str_gnum(st[2])) - arybase,FALSE); if (!str) - str = &str_no; + goto say_undef; break; case O_DELETE: - tmpstab = arg[2].arg_ptr.arg_stab; /* XXX */ - str = hdelete(tmpstab->stab_hash,str_get(sarg[1])); + tmpstab = arg[1].arg_ptr.arg_stab; + tmps = str_get(st[2]); + str = hdelete(stab_hash(tmpstab),tmps,st[2]->str_cur); + if (tmpstab == envstab) + setenv(tmps,Nullch); if (!str) - str = &str_no; + goto say_undef; + break; + case O_LHASH: + str->str_nok = str->str_pok = 0; + str->str_u.str_stab = arg[1].arg_ptr.arg_stab; + str->str_state = SS_HASH; break; case O_HASH: - tmpstab = arg[2].arg_ptr.arg_stab; /* XXX */ - str = hfetch(tmpstab->stab_hash,str_get(sarg[1])); + if (gimme == G_ARRAY) { /* array wanted */ + sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype, + gimme,arglast); + goto array_return; + } + else { + tmpstab = arg[1].arg_ptr.arg_stab; + sprintf(buf,"%d/%d",stab_hash(tmpstab)->tbl_fill, + stab_hash(tmpstab)->tbl_max+1); + str_set(str,buf); + } + break; + case O_HELEM: + tmpstab = arg[1].arg_ptr.arg_stab; + tmps = str_get(st[2]); + str = hfetch(stab_hash(tmpstab),tmps,st[2]->str_cur,FALSE); if (!str) - str = &str_no; + goto say_undef; 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); - } + case O_LAELEM: + anum = ((int)str_gnum(st[2])) - arybase; + str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,TRUE); + if (!str) + fatal("Assignment to non-creatable value, subscript %d",anum); 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])); + case O_LHELEM: + tmpstab = arg[1].arg_ptr.arg_stab; + tmps = str_get(st[2]); + anum = st[2]->str_cur; + str = hfetch(stab_hash(tmpstab),tmps,anum,TRUE); + if (!str) + fatal("Assignment to non-creatable value, subscript \"%s\"",tmps); + if (tmpstab == envstab) /* heavy wizardry going on here */ + str_magic(str, tmpstab, 'E', tmps, anum); /* str is now magic */ /* 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])); - } + else if (tmpstab == sigstab) + str_magic(str, tmpstab, 'S', tmps, anum); +#ifdef SOME_DBM + else if (stab_hash(tmpstab)->tbl_dbm) + str_magic(str, tmpstab, 'D', tmps, anum); +#endif break; + case O_ASLICE: + anum = TRUE; + argtype = FALSE; + goto do_slice_already; + case O_HSLICE: + anum = FALSE; + argtype = FALSE; + goto do_slice_already; + case O_LASLICE: + anum = TRUE; + argtype = TRUE; + goto do_slice_already; + case O_LHSLICE: + anum = FALSE; + argtype = TRUE; + do_slice_already: + sp = do_slice(arg[1].arg_ptr.arg_stab,anum,argtype, + gimme,arglast); + goto array_return; case O_PUSH: - if (arg[1].arg_flags & AF_SPECIAL) - str = do_push(arg,arg[2].arg_ptr.arg_stab->stab_array); + if (arglast[2] - arglast[1] != 1) + str = do_push(stab_array(arg[1].arg_ptr.arg_stab),arglast); else { - str = str_new(0); /* must copy the STR */ - str_sset(str,sarg[1]); - apush(arg[2].arg_ptr.arg_stab->stab_array,str); + str = Str_new(51,0); /* must copy the STR */ + str_sset(str,st[2]); + (void)apush(stab_array(arg[1].arg_ptr.arg_stab),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; + str = apop(ary = stab_array(arg[1].arg_ptr.arg_stab)); + goto staticalization; 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; + str = ashift(ary = stab_array(arg[1].arg_ptr.arg_stab)); + staticalization: + if (!str) + goto say_undef; + if (ary->ary_flags & ARF_REAL) + (void)str_2static(str); break; + case O_UNPACK: + sp = do_unpack(str,gimme,arglast); + goto array_return; 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; + value = str_gnum(st[3]); + sp = do_split(str, arg[2].arg_ptr.arg_spat, (int)value, + gimme,arglast); + goto array_return; case O_LENGTH: - value = (double) str_len(sarg[1]); + if (maxarg < 1) + value = (double)str_len(stab_val(defstab)); + else + value = (double)str_len(st[1]); goto donumset; case O_SPRINTF: - sarg[maxsarg+1] = Nullstr; - do_sprintf(str,arg->arg_len,sarg); + do_sprintf(str, sp-arglast[0], st+1); 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) + anum = ((int)str_gnum(st[2])) - arybase; /* anum=where to start*/ + tmps = str_get(st[1]); /* force conversion to string */ + if (argtype = (str == st[1])) + str = arg->arg_ptr.arg_str; + if (anum < 0) + anum += st[1]->str_cur + arybase; + if (anum < 0 || anum > st[1]->str_cur) + str_nset(str,"",0); + else { + optype = (int)str_gnum(st[3]); + if (optype < 0) + optype = 0; + tmps += anum; + anum = st[1]->str_cur - anum; /* anum=how many bytes left*/ + if (anum > optype) + anum = optype; str_nset(str, tmps, anum); - else - str_set(str, tmps); + if (argtype) { /* it's an lvalue! */ + lstr = (struct lstring*)str; + str->str_magic = st[1]; + st[1]->str_rare = 's'; + lstr->lstr_offset = tmps - str_get(st[1]); + lstr->lstr_len = anum; + } + } + break; + case O_PACK: + (void)do_pack(str,arglast); break; + case O_GREP: + sp = do_grep(arg,str,gimme,arglast); + goto array_return; 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); + do_join(str,arglast); break; case O_SLT: - tmps = str_get(sarg[1]); - value = (double) strLT(tmps,str_get(sarg[2])); + tmps = str_get(st[1]); + value = (double) (str_cmp(st[1],st[2]) < 0); goto donumset; case O_SGT: - tmps = str_get(sarg[1]); - value = (double) strGT(tmps,str_get(sarg[2])); + tmps = str_get(st[1]); + value = (double) (str_cmp(st[1],st[2]) > 0); goto donumset; case O_SLE: - tmps = str_get(sarg[1]); - value = (double) strLE(tmps,str_get(sarg[2])); + tmps = str_get(st[1]); + value = (double) (str_cmp(st[1],st[2]) <= 0); goto donumset; case O_SGE: - tmps = str_get(sarg[1]); - value = (double) strGE(tmps,str_get(sarg[2])); + tmps = str_get(st[1]); + value = (double) (str_cmp(st[1],st[2]) >= 0); goto donumset; case O_SEQ: - tmps = str_get(sarg[1]); - value = (double) strEQ(tmps,str_get(sarg[2])); + tmps = str_get(st[1]); + value = (double) str_eq(st[1],st[2]); goto donumset; case O_SNE: - tmps = str_get(sarg[1]); - value = (double) strNE(tmps,str_get(sarg[2])); + tmps = str_get(st[1]); + value = (double) !str_eq(st[1],st[2]); goto donumset; case O_SUBR: - str_sset(str,do_subr(arg,sarg)); - STABSET(str); - break; + sp = do_subr(arg,gimme,arglast); + st = stack->ary_array + arglast[0]; /* maybe realloced */ + goto array_return; + case O_DBSUBR: + sp = do_dbsubr(arg,gimme,arglast); + st = stack->ary_array + arglast[0]; /* maybe realloced */ + goto array_return; case O_SORT: - if (maxarg <= 1) + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab) stab = defoutstab; + sp = do_sort(str,stab, + gimme,arglast); + goto array_return; + case O_REVERSE: + sp = do_reverse(str, + gimme,arglast); + goto array_return; + case O_WARN: + if (arglast[2] - arglast[1] != 1) { + do_join(str,arglast); + tmps = str_get(st[1]); + } 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; + str = st[2]; + tmps = str_get(st[2]); } - value = (double)do_sort(arg,stab, - retary,sarg,&maxsarg,sargoff,cushion); - if (retary) { - sarg = *retary; /* they realloc it */ - goto array_return; + if (!tmps || !*tmps) + tmps = "Warning: something's wrong"; + warn("%s",tmps); + goto say_yes; + case O_DIE: + if (arglast[2] - arglast[1] != 1) { + do_join(str,arglast); + tmps = str_get(st[1]); } - goto donumset; + else { + str = st[2]; + tmps = str_get(st[2]); + } + if (!tmps || !*tmps) + exit(1); + fatal("%s",tmps); + goto say_zero; case O_PRTF: case O_PRINT: - if (maxarg <= 1) + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab) 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_io(stab)) { + if (dowarn) + warn("Filehandle never opened"); + goto say_zero; + } + if (!(fp = stab_io(stab)->ofp)) { + if (dowarn) { + if (stab_io(stab)->ifp) + warn("Filehandle opened only for input"); + else + warn("Print on closed filehandle"); + } + goto say_zero; } - 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); + if (optype == O_PRTF || arglast[2] - arglast[1] != 1) + value = (double)do_aprint(arg,fp,arglast); else { - value = (double)do_print(sarg[1],fp); - if (ors && optype == O_PRINT) - fputs(ors, fp); + value = (double)do_print(st[2],fp); + if (orslen && optype == O_PRINT) + if (fwrite(ors, 1, orslen, fp) == 0) + goto say_zero; } - if (stab->stab_io->flags & IOF_FLUSH) - fflush(fp); + if (stab_io(stab)->flags & IOF_FLUSH) + if (fflush(fp) == EOF) + goto say_zero; } goto donumset; case O_CHDIR: - tmps = str_get(sarg[1]); - if (!tmps || !*tmps) - tmps = getenv("HOME"); - if (!tmps || !*tmps) - tmps = getenv("LOGDIR"); + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); + if (!tmps || !*tmps) { + tmpstr = hfetch(stab_hash(envstab),"HOME",4,FALSE); + if (tmpstr) + tmps = str_get(tmpstr); + } + if (!tmps || !*tmps) { + tmpstr = hfetch(stab_hash(envstab),"LOGDIR",6,FALSE); + if (tmpstr) + tmps = str_get(tmpstr); + } +#ifdef TAINT + taintproper("Insecure dependency in chdir"); +#endif 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; + if (maxarg < 1) + anum = 0; + else + anum = (int)str_gnum(st[1]); + exit(anum); + goto say_zero; case O_RESET: - str_reset(str_get(sarg[1])); + if (maxarg < 1) + tmps = ""; + else + tmps = str_get(st[1]); + str_reset(tmps,arg[2].arg_ptr.arg_hash); value = 1.0; goto donumset; case O_LIST: - if (arg->arg_flags & AF_LOCAL) - savelist(sarg,maxsarg); + if (gimme == G_ARRAY) + goto array_return; if (maxarg > 0) - str = sarg[maxsarg]; /* unwanted list, return last item */ + str = st[sp - arglast[0]]; /* unwanted list, return last item */ else - str = &str_no; - if (retary) - goto array_return; + str = &str_undef; break; case O_EOF: if (maxarg <= 0) stab = last_in_stab; - else if (arg[1].arg_type == A_WORD) + else if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else - stab = stabent(str_get(sarg[1]),TRUE); + stab = stabent(str_get(st[1]),TRUE); str_set(str, do_eof(stab) ? Yes : No); STABSET(str); break; - case O_TELL: + case O_GETC: if (maxarg <= 0) - stab = last_in_stab; - else if (arg[1].arg_type == A_WORD) + stab = stdinstab; + else if ((arg[1].arg_type & A_MASK) == 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; + stab = stabent(str_get(st[1]),TRUE); + if (do_eof(stab)) /* make sure we have fp with something */ + str_set(str, No); + else { +#ifdef TAINT + tainted = 1; +#endif + str_set(str," "); + *str->str_ptr = getc(stab_io(stab)->ifp); /* should never be EOF */ + } + STABSET(str); + break; + case O_TELL: + if (maxarg <= 0) + stab = last_in_stab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_tell(stab); +#else + (void)do_tell(stab); +#endif + goto donumset; + case O_RECV: + case O_READ: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + tmps = str_get(st[2]); + anum = (int)str_gnum(st[3]); + STR_GROW(st[2], anum+1), (tmps = str_get(st[2])); /* sneaky */ + errno = 0; + if (!stab_io(stab) || !stab_io(stab)->ifp) + goto say_zero; +#ifdef SOCKET + else if (optype == O_RECV) { + argtype = sizeof buf; + optype = (int)str_gnum(st[4]); + anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, optype, + buf, &argtype); + if (anum >= 0) { + st[2]->str_cur = anum; + st[2]->str_ptr[anum] = '\0'; + str_nset(str,buf,argtype); + } + else + str_sset(str,&str_undef); + break; + } + else if (stab_io(stab)->type == 's') { + argtype = sizeof buf; + anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, 0, + buf, &argtype); + } +#else + else if (optype == O_RECV) + goto badsock; +#endif + else + anum = fread(tmps, 1, anum, stab_io(stab)->ifp); + if (anum < 0) + goto say_undef; + st[2]->str_cur = anum; + st[2]->str_ptr[anum] = '\0'; + value = (double)anum; + goto donumset; + case O_SEND: +#ifdef SOCKET + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + tmps = str_get(st[2]); + anum = (int)str_gnum(st[3]); + optype = sp - arglast[0]; + errno = 0; + if (optype > 4) + warn("Too many args on send"); + if (optype >= 4) { + tmps2 = str_get(st[4]); + anum = sendto(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, + anum, tmps2, st[4]->str_cur); + } + else + anum = send(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, anum); + if (anum < 0) + goto say_undef; + value = (double)anum; + goto donumset; +#else + goto badsock; +#endif + case O_SEEK: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; else - stab = stabent(str_get(sarg[1]),TRUE); - value = str_gnum(sarg[2]); + stab = stabent(str_get(st[1]),TRUE); + value = str_gnum(st[2]); str_set(str, do_seek(stab, - (long)value, (int)str_gnum(sarg[3]) ) ? Yes : No); + (long)value, (int)str_gnum(st[3]) ) ? Yes : No); STABSET(str); break; + case O_RETURN: + tmps = "SUB"; /* just fake up a "last SUB" */ + optype = O_LAST; + if (gimme == G_ARRAY) { + lastretstr = Nullstr; + lastspbase = arglast[1]; + lastsize = arglast[2] - arglast[1]; + } + else + lastretstr = str_static(st[arglast[2] - arglast[0]]); + goto dopop; case O_REDO: case O_NEXT: case O_LAST: if (maxarg > 0) { - tmps = str_get(sarg[1]); + tmps = str_get(arg[1].arg_ptr.arg_str); + dopop: while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label || strNE(tmps,loop_stack[loop_ptr].loop_label) )) { #ifdef DEBUGGING @@ -931,129 +1015,303 @@ int sargoff; /* how many elements in sarg are already assigned */ } if (loop_ptr < 0) fatal("Bad label: %s", maxarg > 0 ? tmps : ""); + if (!lastretstr && optype == O_LAST && lastsize) { + st -= arglast[0]; + st += lastspbase + 1; + optype = loop_stack[loop_ptr].loop_sp - lastspbase; /* negative */ + if (optype) { + for (anum = lastsize; anum > 0; anum--,st++) + st[optype] = str_static(st[0]); + } + longjmp(loop_stack[loop_ptr].loop_env, O_LAST); + } longjmp(loop_stack[loop_ptr].loop_env, optype); + case O_DUMP: case O_GOTO:/* shudder */ - goto_targ = str_get(sarg[1]); + goto_targ = str_get(arg[1].arg_ptr.arg_str); + if (!*goto_targ) + goto_targ = Nullch; /* just restart from top */ + if (optype == O_DUMP) { + do_undump = 1; + abort(); + } longjmp(top_env, 1); case O_INDEX: - tmps = str_get(sarg[1]); - if (!(tmps2 = fbminstr(tmps, tmps + sarg[1]->str_cur, sarg[2]))) + tmps = str_get(st[1]); +#ifndef lint + if (!(tmps2 = fbminstr((unsigned char*)tmps, + (unsigned char*)tmps + st[1]->str_cur, st[2]))) +#else + if (tmps2 = fbminstr(Null(unsigned char*),Null(unsigned char*),Nullstr)) +#endif + value = (double)(-1 + arybase); + else + value = (double)(tmps2 - tmps + arybase); + goto donumset; + case O_RINDEX: + tmps = str_get(st[1]); + tmps2 = str_get(st[2]); +#ifndef lint + if (!(tmps2 = rninstr(tmps, tmps + st[1]->str_cur, + tmps2, tmps2 + st[2]->str_cur))) +#else + if (tmps2 = rninstr(Nullch,Nullch,Nullch,Nullch)) +#endif value = (double)(-1 + arybase); else value = (double)(tmps2 - tmps + arybase); goto donumset; case O_TIME: +#ifndef lint value = (double) time(Null(long*)); +#endif 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; + sp = do_tms(str,gimme,arglast); + goto array_return; 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; + if (maxarg < 1) + (void)time(&when); + else + when = (long)str_gnum(st[1]); + sp = do_time(str,localtime(&when), + gimme,arglast); + goto array_return; 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; + if (maxarg < 1) + (void)time(&when); + else + when = (long)str_gnum(st[1]); + sp = do_time(str,gmtime(&when), + gimme,arglast); + goto array_return; + case O_LSTAT: 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; + sp = do_stat(str,arg, + gimme,arglast); + goto array_return; case O_CRYPT: #ifdef CRYPT - tmps = str_get(sarg[1]); - str_set(str,crypt(tmps,str_get(sarg[2]))); + tmps = str_get(st[1]); +#ifdef FCRYPT + str_set(str,fcrypt(tmps,str_get(st[2]))); +#else + str_set(str,crypt(tmps,str_get(st[2]))); +#endif #else fatal( "The crypt() function is unimplemented due to excessive paranoia."); #endif break; + case O_ATAN2: + value = str_gnum(st[1]); + value = atan2(value,str_gnum(st[2])); + goto donumset; + case O_SIN: + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + value = sin(value); + goto donumset; + case O_COS: + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + value = cos(value); + goto donumset; + case O_RAND: + if (maxarg < 1) + value = 1.0; + else + value = str_gnum(st[1]); + if (value == 0.0) + value = 1.0; +#if RANDBITS == 31 + value = rand() * value / 2147483648.0; +#else +#if RANDBITS == 16 + value = rand() * value / 65536.0; +#else +#if RANDBITS == 15 + value = rand() * value / 32768.0; +#else + value = rand() * value / (double)(((unsigned long)1) << RANDBITS); +#endif +#endif +#endif + goto donumset; + case O_SRAND: + if (maxarg < 1) { + (void)time(&when); + anum = when; + } + else + anum = (int)str_gnum(st[1]); + (void)srand(anum); + goto say_yes; case O_EXP: - value = exp(str_gnum(sarg[1])); + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + value = exp(value); goto donumset; case O_LOG: - value = log(str_gnum(sarg[1])); + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + value = log(value); goto donumset; case O_SQRT: - value = sqrt(str_gnum(sarg[1])); + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + value = sqrt(value); goto donumset; case O_INT: - value = str_gnum(sarg[1]); + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); if (value >= 0.0) - modf(value,&value); + (void)modf(value,&value); else { - modf(-value,&value); + (void)modf(-value,&value); value = -value; } goto donumset; case O_ORD: - value = (double) *str_get(sarg[1]); + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); +#ifndef I286 + value = (double) *tmps; +#else + anum = (int) *tmps; + value = (double) anum; +#endif goto donumset; case O_SLEEP: - tmps = str_get(sarg[1]); - time(&when); + if (maxarg < 1) + tmps = Nullch; + else + tmps = str_get(st[1]); + (void)time(&when); if (!tmps || !*tmps) sleep((32767<<16)+32767); else - sleep((unsigned)atoi(tmps)); + sleep((unsigned int)atoi(tmps)); +#ifndef lint value = (double)when; - time(&when); + (void)time(&when); value = ((double)when) - value; +#endif goto donumset; + case O_RANGE: + sp = do_range(gimme,arglast); + goto array_return; + case O_F_OR_R: + if (gimme == G_ARRAY) { /* it's a range */ + /* can we optimize to constant array? */ + if ((arg[1].arg_type & A_MASK) == A_SINGLE && + (arg[2].arg_type & A_MASK) == A_SINGLE) { + st[2] = arg[2].arg_ptr.arg_str; + sp = do_range(gimme,arglast); + st = stack->ary_array; + maxarg = sp - arglast[0]; + str_free(arg[1].arg_ptr.arg_str); + str_free(arg[2].arg_ptr.arg_str); + arg->arg_type = O_ARRAY; + arg[1].arg_type = A_STAB|A_DONT; + arg->arg_len = 1; + stab = arg[1].arg_ptr.arg_stab = aadd(genstab()); + ary = stab_array(stab); + afill(ary,maxarg - 1); + st += arglast[0]+1; + while (maxarg-- > 0) + ary->ary_array[maxarg] = str_smake(st[maxarg]); + goto array_return; + } + arg->arg_type = optype = O_RANGE; + maxarg = arg->arg_len = 2; + anum = 2; + arg[anum].arg_flags &= ~AF_ARYOK; + argflags = arg[anum].arg_flags; + argtype = arg[anum].arg_type & A_MASK; + arg[anum].arg_type = argtype; + argptr = arg[anum].arg_ptr; + sp = arglast[0]; + st -= sp; + sp++; + goto re_eval; + } + arg->arg_type = O_FLIP; + /* FALL THROUGH */ case O_FLIP: - if (str_true(sarg[1])) { + if ((arg[1].arg_type & A_MASK) == A_SINGLE ? + last_in_stab && (int)str_gnum(st[1]) == stab_io(last_in_stab)->lines + : + str_true(st[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; + arg[2].arg_type &= ~A_DONT; + arg[1].arg_type |= A_DONT; argflags = arg[2].arg_flags; - argtype = arg[2].arg_type; + argtype = arg[2].arg_type & A_MASK; argptr = arg[2].arg_ptr; + sp = arglast[0]; + st -= sp; goto re_eval; } str_set(str,""); break; case O_FLOP: str_inc(str); - if (str_true(sarg[2])) { + if ((arg[2].arg_type & A_MASK) == A_SINGLE ? + last_in_stab && (int)str_gnum(st[2]) == stab_io(last_in_stab)->lines + : + str_true(st[2]) ) { arg->arg_type = O_FLIP; - arg[1].arg_flags &= ~AF_SPECIAL; - arg[2].arg_flags |= AF_SPECIAL; + arg[1].arg_type &= ~A_DONT; + arg[2].arg_type |= A_DONT; str_cat(str,"E0"); } break; case O_FORK: - value = (double)fork(); + anum = fork(); + if (!anum && (tmpstab = stabent("$",allstabs))) + str_numset(STAB_STR(tmpstab),(double)getpid()); + value = (double)anum; goto donumset; case O_WAIT: +#ifndef lint ihand = signal(SIGINT, SIG_IGN); qhand = signal(SIGQUIT, SIG_IGN); - value = (double)wait(&argflags); - signal(SIGINT, ihand); - signal(SIGQUIT, qhand); + anum = wait(&argflags); + if (anum > 0) + pidgone(anum,argflags); + value = (double)anum; +#else + ihand = qhand = 0; +#endif + (void)signal(SIGINT, ihand); + (void)signal(SIGQUIT, qhand); statusvalue = (unsigned short)argflags; goto donumset; case O_SYSTEM: +#ifdef TAINT + if (arglast[2] - arglast[1] == 1) { + taintenv(); + tainted |= st[2]->str_tainted; + taintproper("Insecure dependency in system"); + } +#endif while ((anum = vfork()) == -1) { if (errno != EAGAIN) { value = -1.0; @@ -1062,12 +1320,16 @@ int sargoff; /* how many elements in sarg are already assigned */ sleep(5); } if (anum > 0) { +#ifndef lint ihand = signal(SIGINT, SIG_IGN); qhand = signal(SIGQUIT, SIG_IGN); - while ((argtype = wait(&argflags)) != anum && argtype != -1) - ; - signal(SIGINT, ihand); - signal(SIGQUIT, qhand); + while ((argtype = wait(&argflags)) != anum && argtype >= 0) + pidgone(argtype,argflags); +#else + ihand = qhand = 0; +#endif + (void)signal(SIGINT, ihand); + (void)signal(SIGQUIT, qhand); statusvalue = (unsigned short)argflags; if (argtype == -1) value = -1.0; @@ -1076,17 +1338,21 @@ int sargoff; /* how many elements in sarg are already assigned */ } goto donumset; } - if (arg[1].arg_flags & AF_SPECIAL) - value = (double)do_aexec(arg); + if ((arg[1].arg_type & A_MASK) == A_STAB) + value = (double)do_aexec(st[1],arglast); + else if (arglast[2] - arglast[1] != 1) + value = (double)do_aexec(Nullstr,arglast); else { - value = (double)do_exec(str_static(sarg[1])); + value = (double)do_exec(str_get(str_static(st[2]))); } _exit(-1); case O_EXEC: - if (arg[1].arg_flags & AF_SPECIAL) - value = (double)do_aexec(arg); + if ((arg[1].arg_type & A_MASK) == A_STAB) + value = (double)do_aexec(st[1],arglast); + else if (arglast[2] - arglast[1] != 1) + value = (double)do_aexec(Nullstr,arglast); else { - value = (double)do_exec(str_static(sarg[1])); + value = (double)do_exec(str_get(str_static(st[2]))); } goto donumset; case O_HEX: @@ -1098,7 +1364,10 @@ int sargoff; /* how many elements in sarg are already assigned */ snarfnum: anum = 0; - tmps = str_get(sarg[1]); + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); for (;;) { switch (*tmps) { default: @@ -1133,53 +1402,222 @@ int sargoff; /* how many elements in sarg are already assigned */ 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); - } + value = (double)apply(optype,arglast); goto donumset; case O_UMASK: - value = (double)umask((int)str_gnum(sarg[1])); + if (maxarg < 1) { + anum = umask(0); + (void)umask(anum); + } + else + anum = umask((int)str_gnum(st[1])); + value = (double)anum; +#ifdef TAINT + taintproper("Insecure dependency in umask"); +#endif goto donumset; case O_RENAME: - tmps = str_get(sarg[1]); + tmps = str_get(st[1]); + tmps2 = str_get(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in rename"); +#endif #ifdef RENAME - value = (double)(rename(tmps,str_get(sarg[2])) >= 0); + value = (double)(rename(tmps,tmps2) >= 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 */ + (void)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); + tmps = str_get(st[1]); + tmps2 = str_get(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in link"); +#endif + value = (double)(link(tmps,tmps2) >= 0); + goto donumset; + case O_MKDIR: + tmps = str_get(st[1]); + anum = (int)str_gnum(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in mkdir"); +#endif +#ifdef MKDIR + value = (double)(mkdir(tmps,anum) >= 0); +#else + (void)sprintf(buf,"mkdir %s 2>&1",tmps); + one_liner: + rsfp = mypopen(buf,"r"); + if (rsfp) { + *buf = '\0'; + tmps2 = fgets(buf,sizeof buf,rsfp); + (void)mypclose(rsfp); + if (tmps2 != Nullch) { + for (errno = 1; errno <= sys_nerr; errno++) { + if (instr(buf,sys_errlist[errno])) /* you don't see this */ + goto say_zero; + } + errno = 0; + goto say_zero; + } + else + value = 1.0; + } + else + goto say_zero; +#endif + goto donumset; + case O_RMDIR: + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); +#ifdef TAINT + taintproper("Insecure dependency in rmdir"); +#endif +#ifdef RMDIR + value = (double)(rmdir(tmps) >= 0); + goto donumset; +#else + (void)sprintf(buf,"rmdir %s 2>&1",tmps); + goto one_liner; /* see above in MKDIR */ +#endif + case O_GETPPID: + value = (double)getppid(); + goto donumset; + case O_GETPGRP: +#ifdef GETPGRP + if (maxarg < 1) + anum = 0; + else + anum = (int)str_gnum(st[1]); + value = (double)getpgrp(anum); + goto donumset; +#else + fatal("The getpgrp() function is unimplemented on this machine"); + break; +#endif + case O_SETPGRP: +#ifdef SETPGRP + argtype = (int)str_gnum(st[1]); + anum = (int)str_gnum(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in setpgrp"); +#endif + value = (double)(setpgrp(argtype,anum) >= 0); + goto donumset; +#else + fatal("The setpgrp() function is unimplemented on this machine"); + break; +#endif + case O_GETPRIORITY: +#ifdef GETPRIORITY + argtype = (int)str_gnum(st[1]); + anum = (int)str_gnum(st[2]); + value = (double)getpriority(argtype,anum); + goto donumset; +#else + fatal("The getpriority() function is unimplemented on this machine"); + break; +#endif + case O_SETPRIORITY: +#ifdef SETPRIORITY + argtype = (int)str_gnum(st[1]); + anum = (int)str_gnum(st[2]); + optype = (int)str_gnum(st[3]); +#ifdef TAINT + taintproper("Insecure dependency in setpriority"); +#endif + value = (double)(setpriority(argtype,anum,optype) >= 0); goto donumset; +#else + fatal("The setpriority() function is unimplemented on this machine"); + break; +#endif + case O_CHROOT: + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); +#ifdef TAINT + taintproper("Insecure dependency in chroot"); +#endif + value = (double)(chroot(tmps) >= 0); + goto donumset; + case O_FCNTL: + case O_IOCTL: + if (maxarg <= 0) + stab = last_in_stab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + argtype = (int)str_gnum(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in ioctl"); +#endif + anum = do_ctl(optype,stab,argtype,st[3]); + if (anum == -1) + goto say_undef; + if (anum != 0) + goto donumset; + str_set(str,"0 but true"); + STABSET(str); + break; + case O_FLOCK: +#ifdef FLOCK + if (maxarg <= 0) + stab = last_in_stab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (stab && stab_io(stab)) + fp = stab_io(stab)->ifp; + else + fp = Nullfp; + if (fp) { + argtype = (int)str_gnum(st[2]); + value = (double)(flock(fileno(fp),argtype) >= 0); + } + else + value = 0; + goto donumset; +#else + fatal("The flock() function is unimplemented on this machine"); + break; +#endif case O_UNSHIFT: - ary = arg[2].arg_ptr.arg_stab->stab_array; - if (arg[1].arg_flags & AF_SPECIAL) - do_unshift(arg,ary); + ary = stab_array(arg[1].arg_ptr.arg_stab); + if (arglast[2] - arglast[1] != 1) + do_unshift(ary,arglast); else { - str = str_new(0); /* must copy the STR */ - str_sset(str,sarg[1]); + str = Str_new(52,0); /* must copy the STR */ + str_sset(str,st[2]); aunshift(ary,1); - astore(ary,0,str); + (void)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; + if (maxarg < 1) + tmpstr = stab_val(defstab); + else + tmpstr = + (arg[1].arg_type & A_MASK) != A_NULL ? st[1] : stab_val(defstab); +#ifdef TAINT + tainted |= tmpstr->str_tainted; + taintproper("Insecure dependency in eval"); +#endif + sp = do_eval(tmpstr, optype, arg[2].arg_ptr.arg_hash, + gimme,arglast); + goto array_return; case O_FTRREAD: argtype = 0; @@ -1205,47 +1643,42 @@ int sargoff; /* how many elements in sarg are already assigned */ 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; + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (cando(anum,argtype,&statcache)) + goto say_yes; + goto say_no; case O_FTIS: - if (mystat(arg,sarg[1]) >= 0) - str = &str_yes; - else - str = &str_no; - break; + if (mystat(arg,st[1]) < 0) + goto say_undef; + goto say_yes; 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; + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (statcache.st_uid == (optype == O_FTEOWNED ? euid : uid) ) + goto say_yes; + goto say_no; case O_FTZERO: - if (mystat(arg,sarg[1]) >= 0 && !statbuf.st_size) - str = &str_yes; - else - str = &str_no; - break; + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (!statcache.st_size) + goto say_yes; + goto say_no; case O_FTSIZE: - if (mystat(arg,sarg[1]) >= 0 && statbuf.st_size) - str = &str_yes; - else - str = &str_no; - break; + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (statcache.st_size) + goto say_yes; + goto say_no; case O_FTSOCK: #ifdef S_IFSOCK anum = S_IFSOCK; goto check_file_type; #else - str = &str_no; - break; + goto say_no; #endif case O_FTCHR: anum = S_IFCHR; @@ -1259,37 +1692,52 @@ int sargoff; /* how many elements in sarg are already assigned */ 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; + if (mystat(arg,st[1]) < 0) + goto say_undef; + if ((statcache.st_mode & S_IFMT) == anum ) + goto say_yes; + goto say_no; case O_FTPIPE: #ifdef S_IFIFO anum = S_IFIFO; goto check_file_type; #else - str = &str_no; - break; + goto say_no; #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 +#ifdef SYMLINK + if (lstat(str_get(st[1]),&statcache) < 0) + goto say_undef; + if ((statcache.st_mode & S_IFMT) == S_IFLNK ) + goto say_yes; #endif - str = &str_no; - break; + goto say_no; case O_SYMLINK: #ifdef SYMLINK - tmps = str_get(sarg[1]); - value = (double)(symlink(tmps,str_get(sarg[2])) >= 0); + tmps = str_get(st[1]); + tmps2 = str_get(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in symlink"); +#endif + value = (double)(symlink(tmps,tmps2) >= 0); goto donumset; #else fatal("Unsupported function symlink()"); #endif + case O_READLINK: +#ifdef SYMLINK + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); + anum = readlink(tmps,buf,sizeof buf); + if (anum < 0) + goto say_undef; + str_nset(str,buf,anum); + break; +#else + fatal("Unsupported function readlink()"); +#endif case O_FTSUID: anum = S_ISUID; goto check_xid; @@ -1299,38 +1747,286 @@ int sargoff; /* how many elements in sarg are already assigned */ 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; + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (statcache.st_mode & anum) + goto say_yes; + goto say_no; case O_FTTTY: - if (arg[1].arg_flags & AF_SPECIAL) { + if (arg[1].arg_type & A_DONT) { 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); + stab = stabent(tmps = str_get(st[1]),FALSE); + if (stab && stab_io(stab) && stab_io(stab)->ifp) + anum = fileno(stab_io(stab)->ifp); else if (isdigit(*tmps)) anum = atoi(tmps); else - anum = -1; + goto say_undef; if (isatty(anum)) - str = &str_yes; - else - str = &str_no; - break; + goto say_yes; + goto say_no; case O_FTTEXT: case O_FTBINARY: - str = do_fttext(arg,sarg[1]); + str = do_fttext(arg,st[1]); break; +#ifdef SOCKET + case O_SOCKET: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_socket(stab,arglast); +#else + (void)do_socket(stab,arglast); +#endif + goto donumset; + case O_BIND: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_bind(stab,arglast); +#else + (void)do_bind(stab,arglast); +#endif + goto donumset; + case O_CONNECT: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_connect(stab,arglast); +#else + (void)do_connect(stab,arglast); +#endif + goto donumset; + case O_LISTEN: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_listen(stab,arglast); +#else + (void)do_listen(stab,arglast); +#endif + goto donumset; + case O_ACCEPT: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if ((arg[2].arg_type & A_MASK) == A_WORD) + stab2 = arg[2].arg_ptr.arg_stab; + else + stab2 = stabent(str_get(st[2]),TRUE); + do_accept(str,stab,stab2); + STABSET(str); + break; + case O_GHBYNAME: + if (maxarg < 1) + goto say_undef; + case O_GHBYADDR: + case O_GHOSTENT: + sp = do_ghent(optype, + gimme,arglast); + goto array_return; + case O_GNBYNAME: + if (maxarg < 1) + goto say_undef; + case O_GNBYADDR: + case O_GNETENT: + sp = do_gnent(optype, + gimme,arglast); + goto array_return; + case O_GPBYNAME: + if (maxarg < 1) + goto say_undef; + case O_GPBYNUMBER: + case O_GPROTOENT: + sp = do_gpent(optype, + gimme,arglast); + goto array_return; + case O_GSBYNAME: + if (maxarg < 1) + goto say_undef; + case O_GSBYPORT: + case O_GSERVENT: + sp = do_gsent(optype, + gimme,arglast); + goto array_return; + case O_SHOSTENT: + value = (double) sethostent((int)str_gnum(st[1])); + goto donumset; + case O_SNETENT: + value = (double) setnetent((int)str_gnum(st[1])); + goto donumset; + case O_SPROTOENT: + value = (double) setprotoent((int)str_gnum(st[1])); + goto donumset; + case O_SSERVENT: + value = (double) setservent((int)str_gnum(st[1])); + goto donumset; + case O_EHOSTENT: + value = (double) endhostent(); + goto donumset; + case O_ENETENT: + value = (double) endnetent(); + goto donumset; + case O_EPROTOENT: + value = (double) endprotoent(); + goto donumset; + case O_ESERVENT: + value = (double) endservent(); + goto donumset; + case O_SSELECT: + sp = do_select(gimme,arglast); + goto array_return; + case O_SOCKETPAIR: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if ((arg[2].arg_type & A_MASK) == A_WORD) + stab2 = arg[2].arg_ptr.arg_stab; + else + stab2 = stabent(str_get(st[2]),TRUE); +#ifndef lint + value = (double)do_spair(stab,stab2,arglast); +#else + (void)do_spair(stab,stab2,arglast); +#endif + goto donumset; + case O_SHUTDOWN: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_shutdown(stab,arglast); +#else + (void)do_shutdown(stab,arglast); +#endif + goto donumset; + case O_GSOCKOPT: + case O_SSOCKOPT: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + sp = do_sopt(optype,stab,arglast); + goto array_return; + case O_GETSOCKNAME: + case O_GETPEERNAME: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + sp = do_getsockname(optype,stab,arglast); + goto array_return; + +#else /* SOCKET not defined */ + case O_SOCKET: + case O_BIND: + case O_CONNECT: + case O_LISTEN: + case O_ACCEPT: + case O_SSELECT: + case O_SOCKETPAIR: + case O_GHBYNAME: + case O_GHBYADDR: + case O_GHOSTENT: + case O_GNBYNAME: + case O_GNBYADDR: + case O_GNETENT: + case O_GPBYNAME: + case O_GPBYNUMBER: + case O_GPROTOENT: + case O_GSBYNAME: + case O_GSBYPORT: + case O_GSERVENT: + case O_SHOSTENT: + case O_SNETENT: + case O_SPROTOENT: + case O_SSERVENT: + case O_EHOSTENT: + case O_ENETENT: + case O_EPROTOENT: + case O_ESERVENT: + case O_SHUTDOWN: + case O_GSOCKOPT: + case O_SSOCKOPT: + case O_GETSOCKNAME: + case O_GETPEERNAME: + badsock: + fatal("Unsupported socket function"); +#endif /* SOCKET */ + case O_FILENO: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp)) + goto say_undef; + value = fileno(fp); + goto donumset; + case O_VEC: + sp = do_vec(str == st[1], arg->arg_ptr.arg_str, arglast); + goto array_return; + case O_GPWNAM: + case O_GPWUID: + case O_GPWENT: + sp = do_gpwent(optype, + gimme,arglast); + goto array_return; + case O_SPWENT: + value = (double) setpwent(); + goto donumset; + case O_EPWENT: + value = (double) endpwent(); + goto donumset; + case O_GGRNAM: + case O_GGRGID: + case O_GGRENT: + sp = do_ggrent(optype, + gimme,arglast); + goto array_return; + case O_SGRENT: + value = (double) setgrent(); + goto donumset; + case O_EGRENT: + value = (double) endgrent(); + goto donumset; + case O_GETLOGIN: + if (!(tmps = getlogin())) + goto say_undef; + str_set(str,tmps); + break; + case O_OPENDIR: + case O_READDIR: + case O_TELLDIR: + case O_SEEKDIR: + case O_REWINDDIR: + case O_CLOSEDIR: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + sp = do_dirop(optype,stab,gimme,arglast); + goto array_return; + case O_SYSCALL: + value = (double)do_syscall(arglast); + goto donumset; } - if (retary) { - sarg[1] = str; - maxsarg = sargoff + 1; - } + + normal_return: + st[1] = str; #ifdef DEBUGGING if (debug) { dlevel--; @@ -1338,25 +2034,38 @@ int sargoff; /* how many elements in sarg are already assigned */ deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str)); } #endif - goto freeargs; + return arglast[0] + 1; array_return: #ifdef DEBUGGING if (debug) { dlevel--; if (debug & 8) - deb("%s RETURNS ARRAY OF %d ARGS\n",opname[optype],maxsarg-sargoff); + deb("%s RETURNS ARRAY OF %d ARGS\n",opname[optype],sp - arglast[0]); } #endif - goto freeargs; + return sp; + +say_yes: + str = &str_yes; + goto normal_return; + +say_no: + str = &str_no; + goto normal_return; + +say_undef: + str = &str_undef; + goto normal_return; + +say_zero: + value = 0.0; + /* FALL THROUGH */ donumset: str_numset(str,value); STABSET(str); - if (retary) { - sarg[1] = str; - maxsarg = sargoff + 1; - } + st[1] = str; #ifdef DEBUGGING if (debug) { dlevel--; @@ -1364,72 +2073,5 @@ donumset: 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; + return arglast[0] + 1; } diff --git a/evalargs.xc b/evalargs.xc new file mode 100644 index 0000000..b9d4a26 --- /dev/null +++ b/evalargs.xc @@ -0,0 +1,347 @@ +/* This file is included by eval.c. It's separate from eval.c to keep + * kit sizes from getting too big. + */ + +/* $Header: evalargs.xc,v 3.0 89/10/18 15:17:16 lwall Locked $ + * + * $Log: evalargs.xc,v $ + * Revision 3.0 89/10/18 15:17:16 lwall + * 3.0 baseline + * + */ + + for (anum = 1; anum <= maxarg; anum++) { + argflags = arg[anum].arg_flags; + argtype = arg[anum].arg_type; + argptr = arg[anum].arg_ptr; + re_eval: + switch (argtype) { + default: + st[++sp] = &str_undef; +#ifdef DEBUGGING + tmps = "NULL"; +#endif + break; + case A_EXPR: +#ifdef DEBUGGING + if (debug & 8) { + tmps = "EXPR"; + deb("%d.EXPR =>\n",anum); + } +#endif + sp = eval(argptr.arg_arg, + (argflags & AF_ARYOK) ? G_ARRAY : G_SCALAR, sp); + if (sp + (maxarg - anum) > stack->ary_max) + astore(stack, sp + (maxarg - anum), Nullstr); + st = stack->ary_array; /* possibly reallocated */ + break; + case A_CMD: +#ifdef DEBUGGING + if (debug & 8) { + tmps = "CMD"; + deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd); + } +#endif + sp = cmd_exec(argptr.arg_cmd, gimme, sp); + if (sp + (maxarg - anum) > stack->ary_max) + astore(stack, sp + (maxarg - anum), Nullstr); + st = stack->ary_array; /* possibly reallocated */ + break; + case A_LARYSTAB: + ++sp; + str = afetch(stab_array(argptr.arg_stab), + arg[anum].arg_len - arybase, TRUE); +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"LARYSTAB $%s[%d]",stab_name(argptr.arg_stab), + arg[anum].arg_len); + tmps = buf; + } +#endif + goto do_crement; + case A_ARYSTAB: + st[++sp] = afetch(stab_array(argptr.arg_stab), + arg[anum].arg_len - arybase, FALSE); + if (!st[sp]) + st[sp] = &str_undef; +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab), + arg[anum].arg_len); + tmps = buf; + } +#endif + break; + case A_STAR: + st[++sp] = (STR*)argptr.arg_stab; +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"STAR *%s",stab_name(argptr.arg_stab)); + tmps = buf; + } +#endif + break; + case A_LSTAR: + str = st[++sp] = (STR*)argptr.arg_stab; +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"LSTAR *%s",stab_name(argptr.arg_stab)); + tmps = buf; + } +#endif + break; + case A_STAB: + st[++sp] = STAB_STR(argptr.arg_stab); +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab)); + tmps = buf; + } +#endif + break; + case A_LEXPR: +#ifdef DEBUGGING + if (debug & 8) { + tmps = "LEXPR"; + deb("%d.LEXPR =>\n",anum); + } +#endif + if (argflags & AF_ARYOK) { + sp = eval(argptr.arg_arg, G_ARRAY, sp); + if (sp + (maxarg - anum) > stack->ary_max) + astore(stack, sp + (maxarg - anum), Nullstr); + st = stack->ary_array; /* possibly reallocated */ + } + else { + sp = eval(argptr.arg_arg, G_SCALAR, sp); + st = stack->ary_array; /* possibly reallocated */ + str = st[sp]; + goto do_crement; + } + break; + case A_LVAL: +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"LVAL $%s",stab_name(argptr.arg_stab)); + tmps = buf; + } +#endif + ++sp; + 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); + st[sp] = str; + str = arg->arg_ptr.arg_str; + } + else if (argflags & AF_POST) { + st[sp] = str_static(str); + if (argflags & AF_UP) + str_inc(str); + else + str_dec(str); + STABSET(str); + str = arg->arg_ptr.arg_str; + } + else + st[sp] = str; + break; + case A_LARYLEN: + ++sp; + stab = argptr.arg_stab; + str = stab_array(argptr.arg_stab)->ary_magic; + if (argflags & (AF_PRE|AF_POST)) + str_numset(str,(double)(stab_array(stab)->ary_fill+arybase)); +#ifdef DEBUGGING + tmps = "LARYLEN"; +#endif + if (!str) + fatal("panic: A_LEXPR"); + goto do_crement; + case A_ARYLEN: + stab = argptr.arg_stab; + st[++sp] = stab_array(stab)->ary_magic; + str_numset(st[sp],(double)(stab_array(stab)->ary_fill+arybase)); +#ifdef DEBUGGING + tmps = "ARYLEN"; +#endif + break; + case A_SINGLE: + st[++sp] = argptr.arg_str; +#ifdef DEBUGGING + tmps = "SINGLE"; +#endif + break; + case A_DOUBLE: + (void) interp(str,argptr.arg_str,sp); + st = stack->ary_array; + st[++sp] = str; +#ifdef DEBUGGING + tmps = "DOUBLE"; +#endif + break; + case A_BACKTICK: + tmps = str_get(interp(str,argptr.arg_str,sp)); + st = stack->ary_array; +#ifdef TAINT + taintproper("Insecure dependency in ``"); +#endif + fp = mypopen(tmps,"r"); + str_set(str,""); + if (fp) { + while (str_gets(str,fp,str->str_cur) != Nullch) + ; + statusvalue = mypclose(fp); + } + else + statusvalue = -1; + + st[++sp] = str; +#ifdef DEBUGGING + tmps = "BACK"; +#endif + break; + case A_WANTARRAY: + { + extern int wantarray; + + if (wantarray == G_ARRAY) + st[++sp] = &str_yes; + else + st[++sp] = &str_no; + } +#ifdef DEBUGGING + tmps = "WANTARRAY"; +#endif + break; + case A_INDREAD: + last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE); + old_record_separator = record_separator; + goto do_read; + case A_GLOB: + argflags |= AF_POST; /* enable newline chopping */ + last_in_stab = argptr.arg_stab; + old_record_separator = record_separator; + if (csh > 0) + record_separator = 0; + else + record_separator = '\n'; + goto do_read; + case A_READ: + last_in_stab = argptr.arg_stab; + old_record_separator = record_separator; + do_read: + if (anum > 1) /* assign to scalar */ + gimme = G_SCALAR; /* force context to scalar */ + ++sp; + fp = Nullfp; + if (stab_io(last_in_stab)) { + fp = stab_io(last_in_stab)->ifp; + if (!fp) { + if (stab_io(last_in_stab)->flags & IOF_ARGV) { + if (stab_io(last_in_stab)->flags & IOF_START) { + stab_io(last_in_stab)->flags &= ~IOF_START; + stab_io(last_in_stab)->lines = 0; + if (alen(stab_array(last_in_stab)) < 0) { + tmpstr = str_make("-",1); /* assume stdin */ + (void)apush(stab_array(last_in_stab), tmpstr); + } + } + fp = nextargv(last_in_stab); + if (!fp) /* Note: fp != stab_io(last_in_stab)->ifp */ + (void)do_close(last_in_stab,FALSE); /* now it does*/ + } + else if (argtype == A_GLOB) { + (void) interp(str,stab_val(last_in_stab),sp); + st = stack->ary_array; + tmpstr = Str_new(55,0); + if (csh > 0) { + str_set(tmpstr,"/bin/csh -cf 'set nonomatch; glob "); + str_scat(tmpstr,str); + str_cat(tmpstr,"'|"); + } + else { + str_set(tmpstr, "echo "); + str_scat(tmpstr,str); + str_cat(tmpstr, + "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); + } + (void)do_open(last_in_stab,tmpstr->str_ptr); + fp = stab_io(last_in_stab)->ifp; + } + } + } + if (!fp && dowarn) + warn("Read on closed filehandle <%s>",stab_name(last_in_stab)); + keepgoing: + if (!fp) + st[sp] = &str_undef; + else if (!str_gets(str,fp, optype == O_RCAT ? str->str_cur : 0)) { + clearerr(fp); + if (stab_io(last_in_stab)->flags & IOF_ARGV) { + fp = nextargv(last_in_stab); + if (fp) + goto keepgoing; + (void)do_close(last_in_stab,FALSE); + stab_io(last_in_stab)->flags |= IOF_START; + } + else if (argflags & AF_POST) { + (void)do_close(last_in_stab,FALSE); + } + st[sp] = &str_undef; + record_separator = old_record_separator; + if (gimme == G_ARRAY) { + --sp; + goto array_return; + } + break; + } + else { + stab_io(last_in_stab)->lines++; + st[sp] = str; +#ifdef TAINT + str->str_tainted = 1; /* Anything from the outside world...*/ +#endif + if (argflags & AF_POST) { + if (str->str_cur > 0) + str->str_cur--; + if (str->str_ptr[str->str_cur] == record_separator) + str->str_ptr[str->str_cur] = '\0'; + else + str->str_cur++; + for (tmps = str->str_ptr; *tmps; tmps++) + if (!isalpha(*tmps) && !isdigit(*tmps) && + index("$&*(){}[]'\";\\|?<>~`",*tmps)) + break; + if (*tmps && stat(str->str_ptr,&statbuf) < 0) + goto keepgoing; /* unmatched wildcard? */ + } + if (gimme == G_ARRAY) { + st[sp] = str_static(st[sp]); + if (++sp > stack->ary_max) { + astore(stack, sp, Nullstr); + st = stack->ary_array; + } + goto keepgoing; + } + } + record_separator = old_record_separator; +#ifdef DEBUGGING + tmps = "READ"; +#endif + break; + } +#ifdef DEBUGGING + if (debug & 8) + deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp])); +#endif + if (anum < 8) + arglast[anum] = sp; + } diff --git a/form.c b/form.c index 422d4a7..5d0db88 100644 --- a/form.c +++ b/form.c @@ -1,8 +1,13 @@ -/* $Header: form.c,v 2.0 88/06/05 00:08:57 root Exp $ +/* $Header: form.c,v 3.0 89/10/18 15:17:26 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: form.c,v $ - * Revision 2.0 88/06/05 00:08:57 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:17:26 lwall + * 3.0 baseline * */ @@ -11,22 +16,72 @@ /* Forms stuff */ +void +form_parseargs(fcmd) +register FCMD *fcmd; +{ + register int i; + register ARG *arg; + register int items; + STR *str; + ARG *parselist(); + line_t oldline = line; + int oldsave = savestack->ary_fill; + + str = fcmd->f_unparsed; + line = fcmd->f_line; + fcmd->f_unparsed = Nullstr; + (void)savehptr(&curstash); + curstash = str->str_u.str_hash; + arg = parselist(str); + restorelist(oldsave); + + items = arg->arg_len - 1; /* ignore $$ on end */ + for (i = 1; i <= items; i++) { + if (!fcmd || fcmd->f_type == F_NULL) + fatal("Too many field values"); + dehoist(arg,i); + fcmd->f_expr = make_op(O_ITEM,1, + arg[i].arg_ptr.arg_arg,Nullarg,Nullarg); + if (fcmd->f_flags & FC_CHOP) { + if ((fcmd->f_expr[1].arg_type & A_MASK) == A_STAB) + fcmd->f_expr[1].arg_type = A_LVAL; + else if ((fcmd->f_expr[1].arg_type & A_MASK) == A_EXPR) + fcmd->f_expr[1].arg_type = A_LEXPR; + else + fatal("^ field requires scalar lvalue"); + } + fcmd = fcmd->f_next; + } + if (fcmd && fcmd->f_type) + fatal("Not enough field values"); + line = oldline; + Safefree(arg); + str_free(str); +} + +int newsize; + #define CHKLEN(allow) \ -if (d - orec->o_str + (allow) >= curlen) { \ +newsize = (d - orec->o_str) + (allow); \ +if (newsize >= curlen) { \ curlen = d - orec->o_str; \ GROWSTR(&orec->o_str,&orec->o_len,orec->o_len + (allow)); \ d = orec->o_str + curlen; /* in case it moves */ \ curlen = orec->o_len - 2; \ } -format(orec,fcmd) +format(orec,fcmd,sp) register struct outrec *orec; register FCMD *fcmd; +int sp; { register char *d = orec->o_str; register char *s; register int curlen = orec->o_len - 2; register int size; + FCMD *nextfcmd; + FCMD *linebeg = fcmd; char tmpchar; char *t; CMD mycmd; @@ -35,37 +90,55 @@ register FCMD *fcmd; mycmd.c_type = C_NULL; orec->o_lines = 0; - for (; fcmd; fcmd = fcmd->f_next) { + for (; fcmd; fcmd = nextfcmd) { + nextfcmd = fcmd->f_next; CHKLEN(fcmd->f_presize); - for (s=fcmd->f_pre; *s;) { - if (*s == '\n') { - while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t')) - d--; - if (fcmd->f_flags & FC_NOBLANK && - (d == orec->o_str || d[-1] == '\n') ) { - orec->o_lines--; /* don't print blank line */ - break; + if (s = fcmd->f_pre) { + while (*s) { + if (*s == '\n') { + while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t')) + d--; + if (fcmd->f_flags & FC_NOBLANK) { + if (d == orec->o_str || d[-1] == '\n') { + orec->o_lines--; /* don't print blank line */ + linebeg = fcmd->f_next; + break; + } + else if (fcmd->f_flags & FC_REPEAT) + nextfcmd = linebeg; + } + else + linebeg = fcmd->f_next; } + *d++ = *s++; } - *d++ = *s++; } + if (fcmd->f_unparsed) + form_parseargs(fcmd); switch (fcmd->f_type) { case F_NULL: orec->o_lines++; break; case F_LEFT: - str = eval(fcmd->f_expr,Null(STR***),-1); + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; s = str_get(str); size = fcmd->f_size; CHKLEN(size); chophere = Nullch; while (size && *s && *s != '\n') { + if (*s == '\t') + *s = ' '; size--; - if ((*d++ = *s++) == ' ') + if (*s && index(chopset,(*d++ = *s++))) chophere = s; + if (*s == '\n' && (fcmd->f_flags & FC_CHOP)) + *s = ' '; } if (size) chophere = s; + else if (chophere && chophere < s && *s && index(chopset,*s)) + chophere = s; if (fcmd->f_flags & FC_CHOP) { if (!chophere) chophere = s; @@ -85,9 +158,8 @@ register FCMD *fcmd; *d++ = '.'; *d++ = '.'; } - s = chophere; - while (*chophere == ' ' || *chophere == '\n') - chophere++; + while (*chophere && index(chopset,*chophere)) + chophere++; str_chop(str,chophere); } if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n') @@ -98,40 +170,32 @@ register FCMD *fcmd; } break; case F_RIGHT: - t = s = str_get(eval(fcmd->f_expr,Null(STR***),-1)); + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + t = s = str_get(str); size = fcmd->f_size; CHKLEN(size); chophere = Nullch; while (size && *s && *s != '\n') { + if (*s == '\t') + *s = ' '; size--; - if (*s++ == ' ') - chophere = s; + if (*s && index(chopset,*s++)) + chophere = s; + if (*s == '\n' && (fcmd->f_flags & FC_CHOP)) + *s = ' '; } if (size) chophere = s; + else if (chophere && chophere < s && *s && index(chopset,*s)) + chophere = s; if (fcmd->f_flags & FC_CHOP) { if (!chophere) chophere = s; size += (s - chophere); - d -= (s - chophere); - if (fcmd->f_flags & FC_MORE && - *chophere && strNE(chophere,"\n")) { - while (size < 3) { - d--; - size++; - } - while (d[-1] == ' ' && size < fcmd->f_size) { - d--; - size++; - } - *d++ = '.'; - *d++ = '.'; - *d++ = '.'; - } s = chophere; - while (*chophere == ' ' || *chophere == '\n') - chophere++; - str_chop(str,chophere); + while (*chophere && index(chopset,*chophere)) + chophere++; } tmpchar = *s; *s = '\0'; @@ -140,47 +204,41 @@ register FCMD *fcmd; *d++ = ' '; } size = s - t; - bcopy(t,d,size); + (void)bcopy(t,d,size); d += size; *s = tmpchar; + if (fcmd->f_flags & FC_CHOP) + str_chop(str,chophere); break; case F_CENTER: { int halfsize; - t = s = str_get(eval(fcmd->f_expr,Null(STR***),-1)); + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + t = s = str_get(str); size = fcmd->f_size; CHKLEN(size); chophere = Nullch; while (size && *s && *s != '\n') { + if (*s == '\t') + *s = ' '; size--; - if (*s++ == ' ') - chophere = s; + if (*s && index(chopset,*s++)) + chophere = s; + if (*s == '\n' && (fcmd->f_flags & FC_CHOP)) + *s = ' '; } if (size) chophere = s; + else if (chophere && chophere < s && *s && index(chopset,*s)) + chophere = s; if (fcmd->f_flags & FC_CHOP) { if (!chophere) chophere = s; size += (s - chophere); - d -= (s - chophere); - if (fcmd->f_flags & FC_MORE && - *chophere && strNE(chophere,"\n")) { - while (size < 3) { - d--; - size++; - } - while (d[-1] == ' ' && size < fcmd->f_size) { - d--; - size++; - } - *d++ = '.'; - *d++ = '.'; - *d++ = '.'; - } s = chophere; - while (*chophere == ' ' || *chophere == '\n') - chophere++; - str_chop(str,chophere); + while (*chophere && index(chopset,*chophere)) + chophere++; } tmpchar = *s; *s = '\0'; @@ -190,7 +248,7 @@ register FCMD *fcmd; *d++ = ' '; } size = s - t; - bcopy(t,d,size); + (void)bcopy(t,d,size); d += size; *s = tmpchar; if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n') @@ -201,16 +259,20 @@ register FCMD *fcmd; size--; *d++ = ' '; } + if (fcmd->f_flags & FC_CHOP) + str_chop(str,chophere); break; } case F_LINES: - str = eval(fcmd->f_expr,Null(STR***),-1); + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; s = str_get(str); size = str_len(str); CHKLEN(size); orec->o_lines += countlines(s); - bcopy(s,d,size); + (void)bcopy(s,d,size); d += size; + linebeg = fcmd->f_next; break; } } @@ -229,11 +291,12 @@ register char *s; return count; } -do_write(orec,stio) +do_write(orec,stio,sp) struct outrec *orec; register STIO *stio; +int sp; { - FILE *ofp = stio->fp; + FILE *ofp = stio->ofp; #ifdef DEBUGGING if (debug & 256) @@ -247,17 +310,17 @@ register STIO *stio; if (!stio->top_name) stio->top_name = savestr("top"); topstab = stabent(stio->top_name,FALSE); - if (!topstab || !topstab->stab_form) { + if (!topstab || !stab_form(topstab)) { stio->lines_left = 100000000; goto forget_top; } stio->top_stab = topstab; } - if (stio->lines_left >= 0) - putc('\f',ofp); + if (stio->lines_left >= 0 && stio->page > 0) + (void)putc('\f',ofp); stio->lines_left = stio->page_len; stio->page++; - format(&toprec,stio->top_stab->stab_form); + format(&toprec,stab_form(stio->top_stab),sp); fputs(toprec.o_str,ofp); stio->lines_left -= toprec.o_lines; } diff --git a/form.h b/form.h index 3b7aa95..ee055a5 100644 --- a/form.h +++ b/form.h @@ -1,8 +1,13 @@ -/* $Header: form.h,v 2.0 88/06/05 00:09:01 root Exp $ +/* $Header: form.h,v 3.0 89/10/18 15:17:39 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: form.h,v $ - * Revision 2.0 88/06/05 00:09:01 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:17:39 lwall + * 3.0 baseline * */ @@ -15,6 +20,8 @@ struct formcmd { struct formcmd *f_next; ARG *f_expr; + STR *f_unparsed; + line_t f_line; char *f_pre; short f_presize; short f_size; @@ -25,5 +32,8 @@ struct formcmd { #define FC_CHOP 1 #define FC_NOBLANK 2 #define FC_MORE 4 +#define FC_REPEAT 8 #define Nullfcmd Null(FCMD*) + +EXT char *chopset INIT(" \n-"); diff --git a/gettest b/gettest new file mode 100644 index 0000000..565ae82 --- /dev/null +++ b/gettest @@ -0,0 +1,20 @@ +#!./perl + + while (($name,$aliases,$addrtype,$length,@addrs) = gethostent) { + print $name,' ',$aliases, + sprintf(" %d.%d.%d.%d\n",unpack('CCCC',$addrs[0])); + last if $i++ > 50; + } + ; + while (($name,$aliases,$addrtype,$net) = getnetent) { + print "$name $aliases $addrtype ",sprintf("%08lx",$net),"\n"; + } + ; + while (($name,$aliases,$proto) = getprotoent) { + print "$name $aliases $proto\n"; + } + ; + while (($name,$aliases,$port,$proto) = getservent) { + print "$name $aliases $port $proto\n"; + } + diff --git a/handy.h b/handy.h index 6a7c2c7..37cfef4 100644 --- a/handy.h +++ b/handy.h @@ -1,20 +1,33 @@ -/* $Header: handy.h,v 2.0 88/06/05 00:09:03 root Exp $ +/* $Header: handy.h,v 3.0 89/10/18 15:18:24 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: handy.h,v $ - * Revision 2.0 88/06/05 00:09:03 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:18:24 lwall + * 3.0 baseline * */ #ifdef NULL #undef NULL #endif -#define NULL 0 +#ifndef I286 +# define NULL 0 +#else +# define NULL 0L +#endif #define Null(type) ((type)NULL) #define Nullch Null(char*) #define Nullfp Null(FILE*) +#ifdef UTS +#define bool int +#else #define bool char +#endif #define TRUE (1) #define FALSE (0) @@ -39,3 +52,43 @@ typedef unsigned short line_t; #define NOLINE ((line_t) 65535) #endif +#ifndef lint +#ifndef LEAKTEST +char *safemalloc(); +char *saferealloc(); +void safefree(); +#define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) +#define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) +#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \ + bzero((char*)(v), (n) * sizeof(t)) +#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Safefree(d) safefree((char*)d) +#define Str_new(x,len) str_new(len) +#else /* LEAKTEST */ +char *safexmalloc(); +char *safexrealloc(); +void safexfree(); +#define New(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) +#define Newc(x,v,n,t,c) (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) +#define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \ + bzero((char*)(v), (n) * sizeof(t)) +#define Renew(v,n,t) (v = (t*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Safefree(d) safexfree((char*)d) +#define Str_new(x,len) str_new(x,len) +#define MAXXCOUNT 1200 +long xcount[MAXXCOUNT]; +long lastxcount[MAXXCOUNT]; +#endif /* LEAKTEST */ +#define Copy(s,d,n,t) (void)bcopy((char*)(s),(char*)(d), (n) * sizeof(t)) +#define Zero(d,n,t) (void)bzero((char*)(d), (n) * sizeof(t)) +#else /* lint */ +#define New(x,v,n,s) (v = Null(s *)) +#define Newc(x,v,n,s,c) (v = Null(s *)) +#define Newz(x,v,n,s) (v = Null(s *)) +#define Renew(v,n,s) (v = Null(s *)) +#define Copy(s,d,n,t) +#define Zero(d,n,t) +#define Safefree(d) d = d +#endif /* lint */ diff --git a/hash.c b/hash.c index e0bc5f6..6031fa8 100644 --- a/hash.c +++ b/hash.c @@ -1,60 +1,125 @@ -/* $Header: hash.c,v 2.0 88/06/05 00:09:06 root Exp $ +/* $Header: hash.c,v 3.0 89/10/18 15:18:32 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: hash.c,v $ - * Revision 2.0 88/06/05 00:09:06 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:18:32 lwall + * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" +#include + +extern int errno; STR * -hfetch(tb,key) +hfetch(tb,key,klen,lval) register HASH *tb; char *key; +int klen; +int lval; { register char *s; register int i; register int hash; register HENT *entry; + register int maxi; + STR *str; +#ifdef SOME_DBM + datum dkey,dcontent; +#endif if (!tb) return Nullstr; - for (s=key, i=0, hash = 0; - /* while */ *s && i < COEFFSIZE; - s++, i++, hash *= 5) { - hash += *s * coeff[i]; + + /* The hash function we use on symbols has to be equal to the first + * character when taken modulo 128, so that str_reset() can be implemented + * efficiently. We throw in the second character and the last character + * (times 128) so that long chains of identifiers starting with the + * same letter don't have to be strEQ'ed within hfetch(), since it + * compares hash values before trying strEQ(). + */ + if (!tb->tbl_coeffsize) + hash = *key + 128 * key[1] + 128 * key[klen-1]; /* assuming klen > 0 */ + else { /* use normal coefficients */ + if (klen < tb->tbl_coeffsize) + maxi = klen; + else + maxi = tb->tbl_coeffsize; + for (s=key, i=0, hash = 0; + i < maxi; + s++, i++, hash *= 5) { + hash += *s * coeff[i]; + } } + entry = tb->tbl_array[hash & tb->tbl_max]; for (; entry; entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; - if (strNE(entry->hent_key,key)) /* is this it? */ + if (entry->hent_klen != klen) + continue; + if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; return entry->hent_val; } +#ifdef SOME_DBM + if (tb->tbl_dbm) { + dkey.dptr = key; + dkey.dsize = klen; + dcontent = dbm_fetch(tb->tbl_dbm,dkey); + if (dcontent.dptr) { /* found one */ + str = Str_new(60,dcontent.dsize); + str_nset(str,dcontent.dptr,dcontent.dsize); + hstore(tb,key,klen,str,hash); /* cache it */ + return str; + } + } +#endif + if (lval) { /* gonna assign to this, so it better be there */ + str = Str_new(61,0); + hstore(tb,key,klen,str,hash); + return str; + } return Nullstr; } bool -hstore(tb,key,val) +hstore(tb,key,klen,val,hash) register HASH *tb; char *key; +int klen; STR *val; +register int hash; { register char *s; register int i; - register int hash; register HENT *entry; register HENT **oentry; + register int maxi; if (!tb) return FALSE; - for (s=key, i=0, hash = 0; - /* while */ *s && i < COEFFSIZE; - s++, i++, hash *= 5) { - hash += *s * coeff[i]; + + if (hash) + ; + else if (!tb->tbl_coeffsize) + hash = *key + 128 * key[1] + 128 * key[klen-1]; + else { /* use normal coefficients */ + if (klen < tb->tbl_coeffsize) + maxi = klen; + else + maxi = tb->tbl_coeffsize; + for (s=key, i=0, hash = 0; + i < maxi; + s++, i++, hash *= 5) { + hash += *s * coeff[i]; + } } oentry = &(tb->tbl_array[hash & tb->tbl_max]); @@ -63,33 +128,55 @@ STR *val; for (entry = *oentry; entry; i=0, entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; - if (strNE(entry->hent_key,key)) /* is this it? */ + if (entry->hent_klen != klen) + continue; + if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; - safefree((char*)entry->hent_val); + Safefree(entry->hent_val); entry->hent_val = val; return TRUE; } - entry = (HENT*) safemalloc(sizeof(HENT)); + New(501,entry, 1, HENT); - entry->hent_key = savestr(key); + entry->hent_klen = klen; + entry->hent_key = nsavestr(key,klen); entry->hent_val = val; entry->hent_hash = hash; entry->hent_next = *oentry; *oentry = entry; + /* hdbmstore not necessary here because it's called from stabset() */ + if (i) { /* initial entry? */ tb->tbl_fill++; - if ((tb->tbl_fill * 100 / (tb->tbl_max + 1)) > FILLPCT) +#ifdef SOME_DBM + if (tb->tbl_dbm && tb->tbl_max >= DBM_CACHE_MAX) + return FALSE; +#endif + if (tb->tbl_fill > tb->tbl_dosplit) hsplit(tb); } +#ifdef SOME_DBM + else if (tb->tbl_dbm) { /* is this just a cache for dbm file? */ + entry = tb->tbl_array[hash & tb->tbl_max]; + oentry = &entry->hent_next; + entry = *oentry; + while (entry) { /* trim chain down to 1 entry */ + *oentry = entry->hent_next; + hentfree(entry); /* no doubt they'll want this next. */ + entry = *oentry; + } + } +#endif return FALSE; } STR * -hdelete(tb,key) +hdelete(tb,key,klen) register HASH *tb; char *key; +int klen; { register char *s; register int i; @@ -97,13 +184,25 @@ char *key; register HENT *entry; register HENT **oentry; STR *str; + int maxi; +#ifdef SOME_DBM + datum dkey; +#endif if (!tb) return Nullstr; - for (s=key, i=0, hash = 0; - /* while */ *s && i < COEFFSIZE; - s++, i++, hash *= 5) { - hash += *s * coeff[i]; + if (!tb->tbl_coeffsize) + hash = *key + 128 * key[1] + 128 * key[klen-1]; + else { /* use normal coefficients */ + if (klen < tb->tbl_coeffsize) + maxi = klen; + else + maxi = tb->tbl_coeffsize; + for (s=key, i=0, hash = 0; + i < maxi; + s++, i++, hash *= 5) { + hash += *s * coeff[i]; + } } oentry = &(tb->tbl_array[hash & tb->tbl_max]); @@ -112,16 +211,31 @@ char *key; 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? */ + if (entry->hent_klen != klen) + continue; + if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; *oentry = entry->hent_next; str = str_static(entry->hent_val); hentfree(entry); if (i) tb->tbl_fill--; +#ifdef SOME_DBM + do_dbm_delete: + if (tb->tbl_dbm) { + dkey.dptr = key; + dkey.dsize = klen; + dbm_delete(tb->tbl_dbm,dkey); + } +#endif return str; } +#ifdef SOME_DBM + str = Nullstr; + goto do_dbm_delete; +#else return Nullstr; +#endif } hsplit(tb) @@ -135,9 +249,11 @@ HASH *tb; register HENT *entry; register HENT **oentry; - a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*)); - bzero((char*)&a[oldsize], oldsize * sizeof(HENT*)); /* zero second half */ + a = tb->tbl_array; + Renew(a, newsize, HENT*); + Zero(&a[oldsize], oldsize, HENT*); /* zero 2nd half*/ tb->tbl_max = --newsize; + tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100; tb->tbl_array = a; for (i=0; itbl_array = (HENT**) safemalloc(8 * sizeof(HENT*)); + Newz(502,tb, 1, HASH); + if (lookat) { + tb->tbl_coeffsize = lookat; + tb->tbl_max = 7; /* it's a normal associative array */ + tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100; + } + else { + tb->tbl_max = 127; /* it's a symbol table */ + tb->tbl_dosplit = 128; /* so never split */ + } + Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*); tb->tbl_fill = 0; - tb->tbl_max = 7; - hiterinit(tb); /* so each() will start off right */ - bzero((char*)tb->tbl_array, 8 * sizeof(HENT*)); +#ifdef SOME_DBM + tb->tbl_dbm = 0; +#endif + (void)hiterinit(tb); /* so each() will start off right */ return tb; } @@ -181,8 +309,8 @@ register HENT *hent; if (!hent) return; str_free(hent->hent_val); - safefree(hent->hent_key); - safefree((char*)hent); + Safefree(hent->hent_key); + Safefree(hent); } void @@ -194,45 +322,38 @@ register HASH *tb; if (!tb) return; - hiterinit(tb); + (void)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*)); +#ifndef lint + (void)bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*)); +#endif } -#ifdef NOTUSED void hfree(tb) -HASH *tb; +register HASH *tb; { + register HENT *hent; + register HENT *ohent = Null(HENT*); + if (!tb) - return - hiterinit(tb); + return; + (void)hiterinit(tb); while (hent = hiternext(tb)) { hentfree(ohent); ohent = hent; } hentfree(ohent); - safefree((char*)tb->tbl_array); - safefree((char*)tb); + Safefree(tb->tbl_array); + Safefree(tb); } -#endif - -#ifdef NOTUSED -hshow(tb) -register HASH *tb; -{ - fprintf(stderr,"%5d %4d (%2d%%)\n", - tb->tbl_max+1, - tb->tbl_fill, - tb->tbl_fill * 100 / (tb->tbl_max+1)); -} -#endif +int hiterinit(tb) register HASH *tb; { @@ -246,8 +367,43 @@ hiternext(tb) register HASH *tb; { register HENT *entry; +#ifdef SOME_DBM + datum key; +#endif entry = tb->tbl_eiter; +#ifdef SOME_DBM + if (tb->tbl_dbm) { + if (entry) { +#ifdef NDBM +#ifdef _CX_UX + key = dbm_nextkey(tb->tbl_dbm, key); +#else + key = dbm_nextkey(tb->tbl_dbm); +#endif /* _CX_UX */ +#else + key.dptr = entry->hent_key; + key.dsize = entry->hent_klen; + key = nextkey(key); +#endif + } + else { + Newz(504,entry, 1, HENT); + tb->tbl_eiter = entry; + key = dbm_firstkey(tb->tbl_dbm); + } + entry->hent_key = key.dptr; + entry->hent_klen = key.dsize; + if (!key.dptr) { + if (entry->hent_val) + str_free(entry->hent_val); + Safefree(entry); + tb->tbl_eiter = Null(HENT*); + return Null(HENT*); + } + return entry; + } +#endif do { if (entry) entry = entry->hent_next; @@ -266,15 +422,129 @@ register HASH *tb; } char * -hiterkey(entry) +hiterkey(entry,retlen) register HENT *entry; +int *retlen; { + *retlen = entry->hent_klen; return entry->hent_key; } STR * -hiterval(entry) +hiterval(tb,entry) +register HASH *tb; register HENT *entry; { +#ifdef SOME_DBM + datum key, content; + + if (tb->tbl_dbm) { + key.dptr = entry->hent_key; + key.dsize = entry->hent_klen; + content = dbm_fetch(tb->tbl_dbm,key); + if (!entry->hent_val) + entry->hent_val = Str_new(62,0); + str_nset(entry->hent_val,content.dptr,content.dsize); + } +#endif return entry->hent_val; } + +#ifdef SOME_DBM +#if defined(FCNTL) && ! defined(O_CREAT) +#include +#endif + +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif +#ifndef O_RDWR +#define O_RDWR 2 +#endif +#ifndef O_CREAT +#define O_CREAT 01000 +#endif + +#ifndef NDBM +static int dbmrefcnt = 0; +#endif + +bool +hdbmopen(tb,fname,mode) +register HASH *tb; +char *fname; +int mode; +{ + if (!tb) + return FALSE; +#ifndef NDBM + if (tb->tbl_dbm) /* never really closed it */ + return TRUE; +#endif + if (tb->tbl_dbm) + hdbmclose(tb); + hclear(tb); +#ifdef NDBM + tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode); + if (!tb->tbl_dbm) /* oops, just try reading it */ + tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode); +#else + if (dbmrefcnt++) + fatal("Old dbm can only open one database"); + sprintf(buf,"%s.dir",fname); + if (stat(buf, &statbuf) < 0) { + if (close(creat(buf,mode)) < 0) + return FALSE; + sprintf(buf,"%s.pag",fname); + if (close(creat(buf,mode)) < 0) + return FALSE; + } + tb->tbl_dbm = dbminit(fname) >= 0; +#endif + return tb->tbl_dbm != 0; +} + +void +hdbmclose(tb) +register HASH *tb; +{ + if (tb && tb->tbl_dbm) { +#ifdef NDBM + dbm_close(tb->tbl_dbm); + tb->tbl_dbm = 0; +#else + /* dbmrefcnt--; */ /* doesn't work, rats */ +#endif + } + else if (dowarn) + warn("Close on unopened dbm file"); +} + +bool +hdbmstore(tb,key,klen,str) +register HASH *tb; +char *key; +int klen; +register STR *str; +{ + datum dkey, dcontent; + int error; + + if (!tb || !tb->tbl_dbm) + return FALSE; + dkey.dptr = key; + dkey.dsize = klen; + dcontent.dptr = str_get(str); + dcontent.dsize = str->str_cur; + error = dbm_store(tb->tbl_dbm, dkey, dcontent, DBM_REPLACE); + if (error) { + if (errno == EPERM) + fatal("No write permission to dbm file"); + warn("dbm store returned %d, errno %d, key \"%s\"",error,errno,key); +#ifdef NDBM + dbm_clearerr(tb->tbl_dbm); +#endif + } + return !error; +} +#endif /* SOME_DBM */ diff --git a/hash.h b/hash.h index a8ad28a..d13f2b7 100644 --- a/hash.h +++ b/hash.h @@ -1,12 +1,19 @@ -/* $Header: hash.h,v 2.0 88/06/05 00:09:08 root Exp $ +/* $Header: hash.h,v 3.0 89/10/18 15:18:39 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: hash.h,v $ - * Revision 2.0 88/06/05 00:09:08 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:18:39 lwall + * 3.0 baseline * */ -#define FILLPCT 60 /* don't make greater than 99 */ +#define FILLPCT 80 /* don't make greater than 99 */ +#define DBM_CACHE_MAX 63 /* cache 64 entries for dbm file */ + /* (resident array acts as a write-thru cache)*/ #define COEFFSIZE (16 * 8) /* size of array below */ #ifdef DOINIT @@ -30,14 +37,25 @@ struct hentry { char *hent_key; STR *hent_val; int hent_hash; + int hent_klen; }; struct htbl { HENT **tbl_array; - int tbl_max; - int tbl_fill; + int tbl_max; /* subscript of last element of tbl_array */ + int tbl_dosplit; /* how full to get before splitting */ + int tbl_fill; /* how full tbl_array currently is */ int tbl_riter; /* current root of iterator */ HENT *tbl_eiter; /* current entry of iterator */ + SPAT *tbl_spatroot; /* list of spats for this package */ +#ifdef SOME_DBM +#ifdef NDBM + DBM *tbl_dbm; +#else + int tbl_dbm; +#endif +#endif + unsigned char tbl_coeffsize; /* is 0 for symbol tables */ }; STR *hfetch(); @@ -45,9 +63,11 @@ bool hstore(); STR *hdelete(); HASH *hnew(); void hclear(); -void hfree(); void hentfree(); int hiterinit(); HENT *hiternext(); char *hiterkey(); STR *hiterval(); +bool hdbmopen(); +void hdbmclose(); +bool hdbmstore(); diff --git a/ioctl.pl b/ioctl.pl new file mode 100644 index 0000000..0327dae --- /dev/null +++ b/ioctl.pl @@ -0,0 +1,169 @@ +$TIOCGSIZE = 0x40087468; +$TIOCSSIZE = 0x80087467; +$IOCPARM_MASK = 0x1fff; +$IOCPARM_MAX = 0x200; +$IOC_VOID = 0x20000000; +$IOC_OUT = 0x40000000; +$IOC_IN = 0x80000000; +$IOC_INOUT = 0xC0000000; +$IOC_DIRMASK = 0xe0000000; +$TIOCGETD = 0x40047400; +$TIOCSETD = 0x80047401; +$TIOCHPCL = 0x20007402; +$TIOCMODG = 0x40047403; +$TIOCMODS = 0x80047404; +$TIOCM_LE = 0001; +$TIOCM_DTR = 0002; +$TIOCM_RTS = 0004; +$TIOCM_ST = 0010; +$TIOCM_SR = 0020; +$TIOCM_CTS = 0040; +$TIOCM_CAR = 0100; +$TIOCM_CD = 0x40; +$TIOCM_RNG = 0200; +$TIOCM_RI = 0x80; +$TIOCM_DSR = 0400; +$TIOCGETP = 0x40067408; +$TIOCSETP = 0x80067409; +$TIOCSETN = 0x8006740A; +$TIOCEXCL = 0x2000740D; +$TIOCNXCL = 0x2000740E; +$TIOCFLUSH = 0x80047410; +$TIOCSETC = 0x80067411; +$TIOCGETC = 0x40067412; +$TANDEM = 0x00000001; +$CBREAK = 0x00000002; +$LCASE = 0x00000004; +$ECHO = 0x00000008; +$CRMOD = 0x00000010; +$RAW = 0x00000020; +$ODDP = 0x00000040; +$EVENP = 0x00000080; +$ANYP = 0x000000c0; +$NLDELAY = 0x00000300; +$NL0 = 0x00000000; +$NL1 = 0x00000100; +$NL2 = 0x00000200; +$NL3 = 0x00000300; +$TBDELAY = 0x00000c00; +$TAB0 = 0x00000000; +$TAB1 = 0x00000400; +$TAB2 = 0x00000800; +$XTABS = 0x00000c00; +$CRDELAY = 0x00003000; +$CR0 = 0x00000000; +$CR1 = 0x00001000; +$CR2 = 0x00002000; +$CR3 = 0x00003000; +$VTDELAY = 0x00004000; +$FF0 = 0x00000000; +$FF1 = 0x00004000; +$BSDELAY = 0x00008000; +$BS0 = 0x00000000; +$BS1 = 0x00008000; +$ALLDELAY = 0xFF00; +$CRTBS = 0x00010000; +$PRTERA = 0x00020000; +$CRTERA = 0x00040000; +$TILDE = 0x00080000; +$MDMBUF = 0x00100000; +$LITOUT = 0x00200000; +$TOSTOP = 0x00400000; +$FLUSHO = 0x00800000; +$NOHANG = 0x01000000; +$L001000 = 0x02000000; +$CRTKIL = 0x04000000; +$PASS8 = 0x08000000; +$CTLECH = 0x10000000; +$PENDIN = 0x20000000; +$DECCTQ = 0x40000000; +$NOFLSH = 0x80000000; +$TIOCLBIS = 0x8004747F; +$TIOCLBIC = 0x8004747E; +$TIOCLSET = 0x8004747D; +$TIOCLGET = 0x4004747C; +$LCRTBS = 0x1; +$LPRTERA = 0x2; +$LCRTERA = 0x4; +$LTILDE = 0x8; +$LMDMBUF = 0x10; +$LLITOUT = 0x20; +$LTOSTOP = 0x40; +$LFLUSHO = 0x80; +$LNOHANG = 0x100; +$LCRTKIL = 0x400; +$LPASS8 = 0x800; +$LCTLECH = 0x1000; +$LPENDIN = 0x2000; +$LDECCTQ = 0x4000; +$LNOFLSH = 0xFFFF8000; +$TIOCSBRK = 0x2000747B; +$TIOCCBRK = 0x2000747A; +$TIOCSDTR = 0x20007479; +$TIOCCDTR = 0x20007478; +$TIOCGPGRP = 0x40047477; +$TIOCSPGRP = 0x80047476; +$TIOCSLTC = 0x80067475; +$TIOCGLTC = 0x40067474; +$TIOCOUTQ = 0x40047473; +$TIOCSTI = 0x80017472; +$TIOCNOTTY = 0x20007471; +$TIOCPKT = 0x80047470; +$TIOCPKT_DATA = 0x00; +$TIOCPKT_FLUSHREAD = 0x01; +$TIOCPKT_FLUSHWRITE = 0x02; +$TIOCPKT_STOP = 0x04; +$TIOCPKT_START = 0x08; +$TIOCPKT_NOSTOP = 0x10; +$TIOCPKT_DOSTOP = 0x20; +$TIOCSTOP = 0x2000746F; +$TIOCSTART = 0x2000746E; +$TIOCMSET = 0x8004746D; +$TIOCMBIS = 0x8004746C; +$TIOCMBIC = 0x8004746B; +$TIOCMGET = 0x4004746A; +$TIOCREMOTE = 0x80047469; +$TIOCGWINSZ = 0x40087468; +$TIOCSWINSZ = 0x80087467; +$TIOCUCNTL = 0x80047466; +$TIOCSSOFTC = 0x80047465; +$TIOCGSOFTC = 0x40047464; +$TIOCSCARR = 0x80047463; +$TIOCWCARR = 0x20007462; +$OTTYDISC = 0; +$NETLDISC = 1; +$NTTYDISC = 2; +$TABLDISC = 3; +$SLIPDISC = 4; +$FIOCLEX = 0x20006601; +$FIONCLEX = 0x20006602; +$FIONREAD = 0x4004667F; +$FIONBIO = 0x8004667E; +$FIOASYNC = 0x8004667D; +$FIOSETOWN = 0x8004667C; +$FIOGETOWN = 0x4004667B; +$SIOCSHIWAT = 0x80047300; +$SIOCGHIWAT = 0x40047301; +$SIOCSLOWAT = 0x80047302; +$SIOCGLOWAT = 0x40047303; +$SIOCATMARK = 0x40047307; +$SIOCSPGRP = 0x80047308; +$SIOCGPGRP = 0x40047309; +$SIOCADDRT = 0x8030720A; +$SIOCDELRT = 0x8030720B; +$SIOCSIFADDR = 0x8020690C; +$SIOCGIFADDR = 0xC020690D; +$SIOCSIFDSTADDR = 0x8020690E; +$SIOCGIFDSTADDR = 0xC020690F; +$SIOCSIFFLAGS = 0x80206910; +$SIOCGIFFLAGS = 0xC0206911; +$SIOCGIFBRDADDR = 0xC0206912; +$SIOCSIFBRDADDR = 0x80206913; +$SIOCGIFCONF = 0xC0086914; +$SIOCGIFNETMASK = 0xC0206915; +$SIOCSIFNETMASK = 0x80206916; +$SIOCGIFMETRIC = 0xC0206917; +$SIOCSIFMETRIC = 0x80206918; +$SIOCSARP = 0x8024691E; +$SIOCGARP = 0xC024691F; +$SIOCDARP = 0x80246920; diff --git a/lib/abbrev.pl b/lib/abbrev.pl new file mode 100644 index 0000000..5859a7b --- /dev/null +++ b/lib/abbrev.pl @@ -0,0 +1,32 @@ +;# Usage: +;# %foo = (); +;# &abbrev(*foo,LIST); +;# ... +;# $long = $foo{$short}; + +package abbrev; + +sub main'abbrev { + local(*domain) = @_; + shift(@_); + @cmp = @_; + foreach $name (@_) { + @extra = split(//,$name); + $abbrev = shift(@extra); + $len = 1; + foreach $cmp (@cmp) { + next if $cmp eq $name; + while (substr($cmp,0,$len) eq $abbrev) { + $abbrev .= shift(@extra); + ++$len; + } + } + $domain{$abbrev} = $name; + while ($#extra >= 0) { + $abbrev .= shift(@extra); + $domain{$abbrev} = $name; + } + } +} + +1; diff --git a/lib/complete.pl b/lib/complete.pl new file mode 100644 index 0000000..fd50674 --- /dev/null +++ b/lib/complete.pl @@ -0,0 +1,84 @@ +;# +;# @(#)complete.pl 1.0 (sun!waynet) 11/11/88 +;# +;# Author: Wayne Thompson +;# +;# Description: +;# This routine provides word completion. +;# (TAB) attempts word completion. +;# (^D) prints completion list. +;# +;# Diagnostics: +;# Bell when word completion fails. +;# +;# Dependencies: +;# The tty driver is put into raw mode. +;# +;# Bugs: +;# The erase and kill characters are hard coded. +;# +;# Usage: +;# $input = do Complete('prompt_string', @completion_list); +;# + +sub Complete { + local ($prompt) = shift (@_); + local ($c, $cmp, $l, $r, $ret, $return, $test); + @_ = sort @_; + system 'stty raw -echo'; + loop: { + print $prompt, $return; + while (($c = getc(stdin)) ne "\r") { + if ($c eq "\t") { # (TAB) attempt completion + @_match = (); + foreach $cmp (@_) { + push (@_match, $cmp) if $cmp =~ /^$return/; + } + $test = $_match[0]; + $l = length ($test); + unless ($#_match == 0) { + shift (@_match); + foreach $cmp (@_match) { + until (substr ($cmp, 0, $l) eq substr ($test, 0, $l)) { + $l--; + } + } + print "\007"; + } + print $test = substr ($test, $r, $l - $r); + $r = length ($return .= $test); + } + elsif ($c eq "\004") { # (^D) completion list + print "\r\n"; + foreach $cmp (@_) { + print "$cmp\r\n" if $cmp =~ /^$return/; + } + redo loop; + } + elsif ($c eq "\025" && $r) { # (^U) kill + $return = ''; + $r = 0; + print "\r\n"; + redo loop; + } + # (DEL) || (BS) erase + elsif ($c eq "\177" || $c eq "\010") { + if($r) { + print "\b \b"; + chop ($return); + $r--; + } + } + elsif ($c =~ /\S/) { # printable char + $return .= $c; + $r++; + print $c; + } + } + } + system 'stty -raw echo'; + print "\n"; + $return; +} + +1; diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl new file mode 100644 index 0000000..8a49ec0 --- /dev/null +++ b/lib/dumpvar.pl @@ -0,0 +1,28 @@ +package dumpvar; + +sub main'dumpvar { + ($package) = @_; + local(*stab) = eval("*_$package"); + while (($key,$val) = each(%stab)) { + { + local(*entry) = $val; + if (defined $entry) { + print "\$$key = '$entry'\n"; + } + if (defined @entry) { + print "\@$key = (\n"; + foreach $num ($[ .. $#entry) { + print " $num\t'",$entry[$num],"'\n"; + } + print ")\n"; + } + if ($key ne "_$package" && defined %entry) { + print "\%$key = (\n"; + foreach $key (sort keys(%entry)) { + print " $key\t'",$entry{$key},"'\n"; + } + print ")\n"; + } + } + } +} diff --git a/lib/getopt.pl b/lib/getopt.pl index 4832233..b85b643 100644 --- a/lib/getopt.pl +++ b/lib/getopt.pl @@ -1,4 +1,4 @@ -;# $Header: getopt.pl,v 2.0 88/06/05 00:16:22 root Exp $ +;# $Header: getopt.pl,v 3.0 89/10/18 15:19:26 lwall Locked $ ;# Process single-character switches with switch clustering. Pass one argument ;# which is a string containing all switches that take an argument. For each @@ -17,11 +17,11 @@ sub Getopt { ($first,$rest) = ($1,$2); if (index($argumentative,$first) >= $[) { if ($rest ne '') { - shift; + shift(@ARGV); } else { - shift; - $rest = shift; + shift(@ARGV); + $rest = shift(@ARGV); } eval "\$opt_$first = \$rest;"; } @@ -31,8 +31,10 @@ sub Getopt { $ARGV[0] = "-$rest"; } else { - shift; + shift(@ARGV); } } } } + +1; diff --git a/lib/getopts.pl b/lib/getopts.pl new file mode 100644 index 0000000..9269885 --- /dev/null +++ b/lib/getopts.pl @@ -0,0 +1,45 @@ +;# getopts.pl - a better getopt.pl + +;# Usage: +;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a +;# # side effect. + +sub Getopts { + local($argumentative) = @_; + local(@args,$_,$first,$rest); + + @args = split( / */, $argumentative ); + while(($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + $pos = index($argumentative,$first); + if($pos >= $[) { + if($args[$pos+1] eq ':') { + shift; + if($rest eq '') { + $rest = shift; + } + eval "\$opt_$first = \$rest;"; + } + else { + eval "\$opt_$first = 1"; + if($rest eq '') { + shift; + } + else { + $ARGV[0] = "-$rest"; + } + } + } + else { + print stderr "Unknown option: $first\n"; + if($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift; + } + } + } +} + +1; diff --git a/lib/importenv.pl b/lib/importenv.pl index c0c2be0..c321a20 100644 --- a/lib/importenv.pl +++ b/lib/importenv.pl @@ -1,4 +1,4 @@ -;# $Header: importenv.pl,v 2.0 88/06/05 00:16:17 root Exp $ +;# $Header: importenv.pl,v 3.0 89/10/18 15:19:39 lwall Locked $ ;# This file, when interpreted, pulls the environment into normal variables. ;# Usage: @@ -12,3 +12,5 @@ foreach $key (keys(ENV)) { $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; } eval $tmp; + +1; diff --git a/lib/look.pl b/lib/look.pl new file mode 100644 index 0000000..ebbaa73 --- /dev/null +++ b/lib/look.pl @@ -0,0 +1,44 @@ +;# Usage: &look(*FILEHANDLE,$key,$dict,$fold) + +;# Sets file position in FILEHANDLE to be first line greater than or equal +;# (stringwise) to $key. Pass flags for dictionary order and case folding. + +sub look { + local(*FH,$key,$fold) = @_; + local($max,$min,$mid,$_); + local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(FH); + $blksize = 8192 unless $blksize; + $key =~ s/[^\w\s]//g if $dict; + $key =~ y/A-Z/a-z/ if $fold; + $max = $size + $blksize - 1; + $max -= $size % $blksize; + while ($max - $min > $blksize) { + $mid = ($max + $min) / 2; + die "look: internal error" if $mid % $blksize; + seek(FH,$mid,0); + $_ = ; # probably a partial line + $_ = ; + chop; + s/[^\w\s]//g if $dict; + y/A-Z/a-z/ if $fold; + if ($_ lt $key) { + $min = $mid; + } + else { + $max = $mid; + } + } + seek(FH,$min,0); + while () { + chop; + s/[^\w\s]//g if $dict; + y/A-Z/a-z/ if $fold; + last if $_ ge $key; + $min = tell(FH); + } + seek(FH,$min,0); + $min; +} + +1; diff --git a/lib/perldb.pl b/lib/perldb.pl new file mode 100644 index 0000000..51f6c24 --- /dev/null +++ b/lib/perldb.pl @@ -0,0 +1,434 @@ +package DB; + +$header = '$Header: perldb.pl,v 3.0 89/10/18 15:19:46 lwall Locked $'; +# +# This file is automatically included if you do perl -d. +# It's probably not useful to include this yourself. +# +# Perl supplies the values for @line and %sub. It effectively inserts +# a do DB'DB(); in front of every place that can +# have a breakpoint. It also inserts a do 'perldb.pl' before the first line. +# +# $Log: perldb.pl,v $ +# Revision 3.0 89/10/18 15:19:46 lwall +# 3.0 baseline +# +# Revision 2.0 88/06/05 00:09:45 root +# Baseline version 2.0. +# +# + +open(IN,"/dev/tty"); # so we don't dingle stdin +open(OUT,">/dev/tty"); # so we don't dongle stdout +select(OUT); +$| = 1; # for DB'OUT +select(STDOUT); +$| = 1; # for real STDOUT + +$header =~ s/\$Header: perldb.pl,v 3.0 89/10/18 15:19:46 lwall Locked $/$1$2/; +print OUT "\nLoading DB from $header\n\n"; + +sub DB { + local($. ,$@, $!, $[, $,, $/, $\); + $[ = 0; $, = ""; $/ = "\n"; $\ = ""; + ($line) = @_; + if ($stop[$line]) { + if ($stop eq '1') { + $signal |= 1; + } + else { + package main; + $DB'signal |= eval $DB'stop[$DB'line]; print DB'OUT $@; + $DB'stop[$DB'line] =~ s/;9$//; + } + } + if ($single || $trace || $signal) { + print OUT "$sub($line):\t",$line[$line]; + for ($i = $line + 1; $i <= $max && $line[$i] == 0; ++$i) { + last if $line[$i] =~ /^\s*(}|#|\n)/; + print OUT "$sub($i):\t",$line[$i]; + } + } + if ($action[$line]) { + package main; + eval $DB'action[$DB'line]; print DB'OUT $@; + } + if ($single || $signal) { + if ($pre) { + package main; + eval $DB'pre; print DB'OUT $@; + } + print OUT $#stack . " levels deep in subroutine calls!\n" + if $single & 4; + $start = $line; + while ((print OUT " DB<", $#hist+1, "> "), $cmd=) { + $single = 0; + $signal = 0; + $cmd eq '' && exit 0; + chop($cmd); + $cmd =~ /^q$/ && exit 0; + $cmd =~ /^$/ && ($cmd = $laststep); + push(@hist,$cmd) if length($cmd) > 1; + ($i) = split(/\s+/,$cmd); + eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; + $cmd =~ /^h$/ && do { + print OUT " +T Stack trace. +s Single step. +n Next, steps over subroutine calls. +f Finish current subroutine. +c [line] Continue; optionally inserts a one-time-only breakpoint + at the specified line. + Repeat last n or s. +l min+incr List incr+1 lines starting at min. +l min-max List lines. +l line List line; +l List next window. +- List previous window. +w line List window around line. +l subname List subroutine. +/pattern/ Search forwards for pattern; final / is optional. +?pattern? Search backwards for pattern. +L List breakpoints and actions. +S List subroutine names. +t Toggle trace mode. +b [line] [condition] + Set breakpoint; line defaults to the current execution line; + condition breaks if it evaluates to true, defaults to \'1\'. +b subname [condition] + Set breakpoint at first line of subroutine. +d [line] Delete breakpoint. +D Delete all breakpoints. +a [line] command + Set an action to be done before the line is executed. + Sequence is: check for breakpoint, print line if necessary, + do action, prompt user if breakpoint or step, evaluate line. +A Delete all actions. +V package List all variables and values in package (default main). +< command Define command before prompt. +> command Define command after prompt. +! number Redo command (default previous command). +! -number Redo number\'th to last command. +H -number Display last number commands (default all). +q or ^D Quit. +p expr Same as \"package main; print DB'OUT expr\". +command Execute as a perl statement. + +"; + next; }; + $cmd =~ /^t$/ && do { + $trace = !$trace; + print OUT "Trace = ".($trace?"on":"off")."\n"; + next; }; + $cmd =~ /^S$/ && do { + foreach $subname (sort(keys %sub)) { + if ($subname =~ /^main'(.*)/) { + print OUT $1,"\n"; + } + else { + print OUT $subname,"\n"; + } + } + next; }; + $cmd =~ /^V$/ && do { + $cmd = 'V main'; }; + $cmd =~ /^V\s*(['A-Za-z_]['\w]*)$/ && do { + $packname = $1; + do 'dumpvar.pl' unless defined &main'dumpvar; + if (defined &main'dumpvar) { + &main'dumpvar($packname); + } + else { + print DB'OUT "dumpvar.pl not available.\n"; + } + next; }; + $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do { + $subname = $1; + $subname = "main'" . $subname unless $subname =~ /'/; + $subrange = $sub{$subname}; + if ($subrange) { + if (eval($subrange) < -$window) { + $subrange =~ s/-.*/+/; + } + $cmd = "l $subrange"; + } else { + print OUT "Subroutine $1 not found.\n"; + next; + } }; + $cmd =~ /^w\s*(\d*)$/ && do { + $incr = $window - 1; + $start = $1 if $1; + $start -= $preview; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^-$/ && do { + $incr = $window - 1; + $cmd = 'l ' . ($start-$window*2) . '+'; }; + $cmd =~ /^l$/ && do { + $incr = $window - 1; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do { + $start = $1 if $1; + $incr = $2; + $incr = $window - 1 unless $incr; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { + $end = (!$2) ? $max : ($4 ? $4 : $2); + $end = $max if $end > $max; + $i = $2; + $i = $line if $i eq '.'; + $i = 1 if $i < 1; + for (; $i <= $end; $i++) { + print OUT "$i:\t", $line[$i]; + last if $signal; + } + $start = $i; # remember in case they want more + $start = $max if $start > $max; + next; }; + $cmd =~ /^D$/ && do { + print OUT "Deleting all breakpoints...\n"; + for ($i = 1; $i <= $max ; $i++) { + $stop[$i] = 0; + } + next; }; + $cmd =~ /^L$/ && do { + for ($i = 1; $i <= $max; $i++) { + if ($stop[$i] || $action[$i]) { + print OUT "$i:\t", $line[$i]; + print OUT " break if (", $stop[$i], ")\n" + if $stop[$i]; + print OUT " action: ", $action[$i], "\n" + if $action[$i]; + last if $signal; + } + } + next; }; + $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do { + $subname = $1; + $subname = "main'" . $subname unless $subname =~ /'/; + ($i) = split(/-/, $sub{$subname}); + if ($i) { + ++$i while $line[$i] == 0 && $i < $#line; + $stop[$i] = $2 ? $2 : 1; + } else { + print OUT "Subroutine $1 not found.\n"; + } + next; }; + $cmd =~ /^b\s*(\d*)\s*(.*)/ && do { + $i = ($1?$1:$line); + if ($line[$i] == 0) { + print OUT "Line $i not breakable.\n"; + } else { + $stop[$i] = $2 ? $2 : 1; + } + next; }; + $cmd =~ /^d\s*(\d+)?/ && do { + $i = ($1?$1:$line); + $stop[$i] = ''; + next; }; + $cmd =~ /^A$/ && do { + for ($i = 1; $i <= $max ; $i++) { + $action[$i] = ''; + } + next; }; + $cmd =~ /^<\s*(.*)/ && do { + $pre = do action($1); + next; }; + $cmd =~ /^>\s*(.*)/ && do { + $post = do action($1); + next; }; + $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do { + $i = $1; + if ($line[$i] == 0) { + print OUT "Line $i may not have an action.\n"; + } else { + $action[$i] = do action($3); + } + next; }; + $cmd =~ /^n$/ && do { + $single = 2; + $laststep = $cmd; + last; }; + $cmd =~ /^s$/ && do { + $single = 1; + $laststep = $cmd; + last; }; + $cmd =~ /^c\s*(\d*)\s*$/ && do { + $i = $1; + if ($i) { + if ($line[$i] == 0) { + print OUT "Line $i not breakable.\n"; + next; + } + $stop[$i] .= ";9"; # add one-time-only b.p. + } + for ($i=0; $i <= $#stack; ) { + $stack[$i++] &= ~1; + } + last; }; + $cmd =~ /^f$/ && do { + $stack[$#stack] |= 2; + last; }; + $cmd =~ /^T$/ && do { + for ($i=0; $i <= $#sub; ) { + print OUT $sub[$i++], "\n"; + last if $signal; + } + next; }; + $cmd =~ /^\/(.*)$/ && do { + $inpat = $1; + $inpat =~ s:([^\\])/$:$1:; + if ($inpat ne "") { + eval '$inpat =~ m'."\n$inpat\n"; + if ($@ ne "") { + print OUT "$@"; + next; + } + $pat = $inpat; + } + $end = $start; + eval ' + for (;;) { + ++$start; + $start = 1 if ($start > $max); + last if ($start == $end); + if ($line[$start] =~ m'."\n$pat\n".'i) { + print OUT "$start:\t", $line[$start], "\n"; + last; + } + } '; + print OUT "/$pat/: not found\n" if ($start == $end); + next; }; + $cmd =~ /^\?(.*)$/ && do { + $inpat = $1; + $inpat =~ s:([^\\])\?$:$1:; + if ($inpat ne "") { + eval '$inpat =~ m'."\n$inpat\n"; + if ($@ ne "") { + print OUT "$@"; + next; + } + $pat = $inpat; + } + $end = $start; + eval ' + for (;;) { + --$start; + $start = $max if ($start <= 0); + last if ($start == $end); + if ($line[$start] =~ m'."\n$pat\n".'i) { + print OUT "$start:\t", $line[$start], "\n"; + last; + } + } '; + print OUT "?$pat?: not found\n" if ($start == $end); + next; }; + $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { + pop(@hist) if length($cmd) > 1; + $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); + $cmd = $hist[$i] . "\n"; + print OUT $cmd; + redo; }; + $cmd =~ /^!(.+)$/ && do { + $pat = "^$1"; + pop(@hist) if length($cmd) > 1; + for ($i = $#hist; $i; --$i) { + last if $hist[$i] =~ $pat; + } + if (!$i) { + print OUT "No such command!\n\n"; + next; + } + $cmd = $hist[$i] . "\n"; + print OUT $cmd; + redo; }; + $cmd =~ /^H\s*(-(\d+))?/ && do { + $end = $2?($#hist-$2):0; + $hist = 0 if $hist < 0; + for ($i=$#hist; $i>$end; $i--) { + print OUT "$i: ",$hist[$i],"\n" + unless $hist[$i] =~ /^.?$/; + }; + next; }; + $cmd =~ s/^p( .*)?$/print DB'OUT$1/; + { + package main; + eval $DB'cmd; + } + print OUT $@,"\n"; + } + if ($post) { + package main; + eval $DB'post; print DB'OUT $@; + } + } +} + +sub action { + local($action) = @_; + while ($action =~ s/\\$//) { + print OUT "+ "; + $action .= ; + } + $action; +} + +sub catch { + $signal = 1; +} + +sub sub { + push(@stack, $single); + $single &= 1; + $single |= 4 if $#stack == $deep; + local(@args) = @_; + for (@args) { + if (/^Stab/ && length($_) == length($_main{'_main'})) { + $_ = sprintf("%s",$_); + print "ARG: $_\n"; + } + else { + s/'/\\'/g; + s/(.*)/'$1'/ unless /^-?[\d.]+$/; + } + } + push(@sub, $sub . '(' . join(', ', @args) . ') from ' . $line); + if (wantarray) { + @i = &$sub; + } + else { + $i = &$sub; + @i = $i; + } + --$#sub; + $single |= pop(@stack); + @i; +} + +$single = 1; # so it stops on first executable statement +$max = $#line; +@hist = ('?'); +$SIG{'INT'} = "DB'catch"; +$deep = 100; # warning if stack gets this deep +$window = 10; +$preview = 3; + +@stack = (0); +@args = @ARGV; +for (@args) { + s/'/\\'/g; + s/(.*)/'$1'/ unless /^-?[\d.]+$/; +} +push(@sub, 'main(' . join(', ', @args) . ")" ); +$sub = 'main'; + +if (-f '.perldb') { + do './.perldb'; +} +elsif (-f "$ENV{'LOGDIR'}/.perldb") { + do "$ENV{'LOGDIR'}/.perldb"; +} +elsif (-f "$ENV{'HOME'}/.perldb") { + do "$ENV{'HOME'}/.perldb"; +} + +1; diff --git a/lib/stat.pl b/lib/stat.pl index 1895c58..8cf0bde 100644 --- a/lib/stat.pl +++ b/lib/stat.pl @@ -1,4 +1,4 @@ -;# $Header: stat.pl,v 2.0 88/06/05 00:16:29 root Exp $ +;# $Header: stat.pl,v 3.0 89/10/18 15:19:53 lwall Locked $ ;# Usage: ;# @ary = stat(foo); @@ -25,3 +25,5 @@ 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(@_)); } + +1; diff --git a/lib/termcap.pl b/lib/termcap.pl new file mode 100644 index 0000000..ab693f2 --- /dev/null +++ b/lib/termcap.pl @@ -0,0 +1,164 @@ +;# $Header: termcap.pl,v 3.0 89/10/18 15:19:58 lwall Locked $ +;# +;# Usage: +;# do 'ioctl.pl'; +;# ioctl(TTY,$TIOCGETP,$foo); +;# ($ispeed,$ospeed) = unpack('cc',$foo); +;# do 'termcap.pl'; +;# do Tgetent('vt100'); # sets $TC{'cm'}, etc. +;# do Tgoto($TC{'cm'},$row,$col); +;# do Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); +;# +sub Tgetent { + local($TERM) = @_; + local($TERMCAP,$_,$entry,$loop,$field); + + warn "Tgetent: no ospeed set" unless $ospeed; + foreach $key (keys(TC)) { + delete $TC{$key}; + } + $TERM = $ENV{'TERM'} unless $TERM; + $TERMCAP = $ENV{'TERMCAP'}; + $TERMCAP = '/etc/termcap' unless $TERMCAP; + if ($TERMCAP !~ m:^/:) { + if (index($TERMCAP,"|$TERM|") < $[) { + $TERMCAP = '/etc/termcap'; + } + } + if ($TERMCAP =~ m:^/:) { + $entry = ''; + do { + $loop = " + open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\"; + while () { + next if /^#/; + next if /^\t/; + if (/\\|$TERM[:\\|]/) { + chop; + while (chop eq '\\\\') { + \$_ .= ; + chop; + } + \$_ .= ':'; + last; + } + } + close TERMCAP; + \$entry .= \$_; + "; + eval $loop; + } while s/:tc=([^:]+):/:/, $TERM = $1; + $TERMCAP = $entry; + } + + foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { + if ($field =~ /^\w\w$/) { + $TC{$field} = 1; + } + elsif ($field =~ /^(\w\w)#(.*)/) { + $TC{$1} = $2 if $TC{$1} eq ''; + } + elsif ($field =~ /^(\w\w)=(.*)/) { + $entry = $1; + $_ = $2; + s/\\E/\033/g; + s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; + s/\\n/\n/g; + s/\\r/\r/g; + s/\\t/\t/g; + s/\\b/\b/g; + s/\\f/\f/g; + s/\\\^/\377/g; + s/\^\?/\177/g; + s/\^(.)/pack('c',$1 & 031)/eg; + s/\\(.)/$1/g; + s/\377/^/g; + $TC{$entry} = $_ if $TC{$entry} eq ''; + } + } + $TC{'pc'} = "\0" if $TC{'pc'} eq ''; + $TC{'bc'} = "\b" if $TC{'bc'} eq ''; +} + +@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); + +sub Tputs { + local($string,$affcnt,$FH) = @_; + local($ms); + if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { + $ms = $1; + $ms *= $affcnt if $2; + $string = $3; + $decr = $Tputs[$ospeed]; + if ($decr > .1) { + $ms += $decr / 2; + $string .= $TC{'pc'} x ($ms / $decr); + } + } + print $FH $string if $FH; + $string; +} + +sub Tgoto { + local($string) = shift(@_); + local($result) = ''; + local($after) = ''; + local($code,$tmp) = @_; + @_ = ($tmp,$code); + local($online) = 0; + while ($string =~ /^([^%]*)%(.)(.*)/) { + $result .= $1; + $code = $2; + $string = $3; + if ($code eq 'd') { + $result .= sprintf("%d",shift(@_)); + } + elsif ($code eq '.') { + $tmp = shift(@_); + if ($tmp == 0 || $tmp == 4 || $tmp == 10) { + if ($online) { + ++$tmp, $after .= $TC{'up'} if $TC{'up'}; + } + else { + ++$tmp, $after .= $TC{'bc'}; + } + } + $result .= sprintf("%c",$tmp); + $online = !$online; + } + elsif ($code eq '+') { + $result .= sprintf("%c",shift(@_)+ord($string)); + $string = substr($string,1,99); + $online = !$online; + } + elsif ($code eq 'r') { + ($code,$tmp) = @_; + @_ = ($tmp,$code); + $online = !$online; + } + elsif ($code eq '>') { + ($code,$tmp,$string) = unpack("CCa99",$string); + if ($_[$[] > $code) { + $_[$[] += $tmp; + } + } + elsif ($code eq '2') { + $result .= sprintf("%02d",shift(@_)); + $online = !$online; + } + elsif ($code eq '3') { + $result .= sprintf("%03d",shift(@_)); + $online = !$online; + } + elsif ($code eq 'i') { + ($code,$tmp) = @_; + @_ = ($code+1,$tmp+1); + } + else { + return "OOPS"; + } + } + $result . $string . $after; +} + +1; diff --git a/lib/validate.pl b/lib/validate.pl new file mode 100644 index 0000000..bee7bba --- /dev/null +++ b/lib/validate.pl @@ -0,0 +1,103 @@ +;# $Header: validate.pl,v 3.0 89/10/18 15:20:04 lwall Locked $ + +;# The validate routine takes a single multiline string consisting of +;# lines containing a filename plus a file test to try on it. (The +;# file test may also be a 'cd', causing subsequent relative filenames +;# to be interpreted relative to that directory.) After the file test +;# you may put '|| die' to make it a fatal error if the file test fails. +;# The default is '|| warn'. The file test may optionally have a ! prepended +;# to test for the opposite condition. If you do a cd and then list some +;# relative filenames, you may want to indent them slightly for readability. +;# If you supply your own "die" or "warn" message, you can use $file to +;# interpolate the filename. + +;# Filetests may be bunched: -rwx tests for all of -r, -w and -x. +;# Only the first failed test of the bunch will produce a warning. + +;# The routine returns the number of warnings issued. + +;# Usage: +;# $warnings += do validate(' +;# /vmunix -e || die +;# /boot -e || die +;# /bin cd +;# csh -ex +;# csh !-ug +;# sh -ex +;# sh !-ug +;# /usr -d || warn "What happened to $file?\n" +;# '); + +sub validate { + local($file,$test,$warnings,$oldwarnings); + foreach $check (split(/\n/,$_[0])) { + next if $check =~ /^#/; + next if $check =~ /^$/; + ($file,$test) = split(' ',$check,2); + if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { + $testlist = $2; + @testlist = split(//,$testlist); + } + else { + @testlist = ('Z'); + } + $oldwarnings = $warnings; + foreach $one (@testlist) { + $this = $test; + $this =~ s/(-\w\b)/$1 \$file/g; + $this =~ s/-Z/-$one/; + $this .= ' || warn' unless $this =~ /\|\|/; + $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/; + $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; + eval $this; + last if $warnings > $oldwarnings; + } + } + $warnings; +} + +sub valmess { + local($disposition,$this) = @_; + $file = $cwd . '/' . $file unless $file =~ m|^/|; + if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { + $neg = $1; + $tmp = $2; + $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); + $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); + $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); + $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); + $tmp eq 'R' && ($mess = "$file is not readable by you."); + $tmp eq 'W' && ($mess = "$file is not writable by you."); + $tmp eq 'X' && ($mess = "$file is not executable by you."); + $tmp eq 'O' && ($mess = "$file is not owned by you."); + $tmp eq 'e' && ($mess = "$file does not exist."); + $tmp eq 'z' && ($mess = "$file does not have zero size."); + $tmp eq 's' && ($mess = "$file does not have non-zero size."); + $tmp eq 'f' && ($mess = "$file is not a plain file."); + $tmp eq 'd' && ($mess = "$file is not a directory."); + $tmp eq 'l' && ($mess = "$file is not a symbolic link."); + $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); + $tmp eq 'S' && ($mess = "$file is not a socket."); + $tmp eq 'b' && ($mess = "$file is not a block special file."); + $tmp eq 'c' && ($mess = "$file is not a character special file."); + $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); + $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); + $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); + $tmp eq 'T' && ($mess = "$file is not a text file."); + $tmp eq 'B' && ($mess = "$file is not a binary file."); + if ($neg eq '!') { + $mess =~ s/ is not / should not be / || + $mess =~ s/ does not / should not / || + $mess =~ s/ not / /; + } + print stderr $mess,"\n"; + } + else { + $this =~ s/\$file/'$file'/g; + print stderr "Can't do $this.\n"; + } + if ($disposition eq 'die') { exit 1; } + ++$warnings; +} + +1; diff --git a/makedepend.SH b/makedepend.SH index 70c6163..5cb95c5 100644 --- a/makedepend.SH +++ b/makedepend.SH @@ -15,18 +15,17 @@ esac echo "Extracting makedepend (with variable substitutions)" $spitshell >makedepend <.clist) + $echo *.c | $tr ' ' '\012' | $egrep -v '\*' >.clist) for file in `$cat .clist`; do # for file in `cat /dev/null`; do case "$file" in @@ -109,7 +108,7 @@ done $sed Makefile.new -e '1,/^# AUTOMATICALLY/!d' make shlist || ($echo "Searching for .SH files..."; \ - $echo *.SH */*.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist) + $echo *.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist) if $test -s .deptmp; then for file in `cat .shlist`; do $echo `$expr X$file : 'X\(.*\).SH`: $file config.sh \; \ @@ -122,7 +121,7 @@ if $test -s .deptmp; then >>Makefile.new else make hlist || ($echo "Searching for .h files..."; \ - $echo *.h */*.h | $tr ' ' '\012' | $egrep -v '\*' >.hlist) + $echo *.h | $tr ' ' '\012' | $egrep -v '\*' >.hlist) $echo "You don't seem to have a proper C preprocessor. Using grep instead." $egrep '^#include ' `cat .clist` `cat .hlist` >.deptmp $echo "Updating Makefile..." diff --git a/makedir.SH b/makedir.SH index 215661a..6064482 100644 --- a/makedir.SH +++ b/makedir.SH @@ -15,12 +15,11 @@ esac echo "Extracting makedir (with variable substitutions)" $spitshell >makedir <makelib <>makelib <<'!NO!SUBS!' + +chdir '/usr/include' || die "Can't cd /usr/include"; + +%isatype = ('char',1,'short',1,'int',1,'long',1); + +foreach $file (@ARGV) { + print $file,"\n"; + if ($file =~ m|^(.*)/|) { + $dir = $1; + if (!-d "$perlincl/$dir") { + mkdir("$perlincl/$dir",0777); + } + } + open(IN,"$file") || ((warn "Can't open $file: $!\n"),next); + open(OUT,">$perlincl/$file") || die "Can't create $file: $!\n"; + while () { + chop; + while (/\\$/) { + chop; + $_ .= ; + chop; + } + if (s:/\*:\200:g) { + s:\*/:\201:g; + s/\200[^\201]*\201//g; # delete single line comments + if (s/\200.*//) { # begin multi-line comment? + $_ .= '/*'; + $_ .= ; + redo; + } + } + if (s/^#\s*//) { + if (s/^define\s+(\w+)//) { + $name = $1; + $new = ''; + s/\s+$//; + if (s/^\(([\w,\s]*)\)//) { + $args = $1; + if ($args ne '') { + foreach $arg (split(/,\s*/,$args)) { + $curargs{$arg} = 1; + } + $args =~ s/\b(\w)/\$$1/g; + $args = "local($args) = \@_;\n$t "; + } + s/^\s+//; + do expr(); + $new =~ s/(["\\])/\\$1/g; + if ($t ne '') { + $new =~ s/(['\\])/\\$1/g; + print OUT $t, + "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n"; + } + else { + print OUT "sub $name {\n ${args}eval \"$new\";\n}\n"; + } + %curargs = (); + } + else { + s/^\s+//; + do expr(); + $new = 1 if $new eq ''; + if ($t ne '') { + $new =~ s/(['\\])/\\$1/g; + print OUT $t,"eval 'sub $name {",$new,";}';\n"; + } + else { + print OUT $t,"sub $name {",$new,";}\n"; + } + } + } + elsif (/^include <(.*)>/) { + print OUT $t,"do '$1' || die \"Can't include $1: \$!\";\n"; + } + elsif (/^ifdef\s+(\w+)/) { + print OUT $t,"if (defined &$1) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (/^ifndef\s+(\w+)/) { + print OUT $t,"if (!defined &$1) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (s/^if\s+//) { + $new = ''; + do expr(); + print OUT $t,"if ($new) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (s/^elif\s+//) { + $new = ''; + do expr(); + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n${t}elsif ($new) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (/^else/) { + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n${t}else {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (/^endif/) { + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n"; + } + } + } + print OUT "1;\n"; +} + +sub expr { + while ($_ ne '') { + s/^(\s+)// && do {$new .= ' '; next;}; + s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; + s/^(\d+)// && do {$new .= $1; next;}; + s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; + s/^'((\\"|[^"])*)'// && do { + if ($curargs{$1}) { + $new .= "ord('\$$1')"; + } + else { + $new .= "ord('$1')"; + } + next; + }; + s/^(struct\s+\w+)// && do {$new .= "'$1'"; next;}; + s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { + $new .= '$sizeof'; + next; + }; + s/^([_a-zA-Z]\w*)// && do { + $id = $1; + if ($curargs{$id}) { + $new .= '$' . $id; + } + elsif ($id eq 'defined') { + $new .= 'defined'; + } + elsif (/^\(/) { + s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/; # cheat + $new .= "&$id"; + } + elsif ($isatype{$id}) { + $new .= "'$id'"; + } + else { + $new .= '&' . $id; + } + next; + }; + s/^(.)// && do {$new .= $1; next;}; + } +} +!NO!SUBS! +chmod 755 makelib +$eunicefix makelib diff --git a/malloc.c b/malloc.c index 7830621..62ff232 100644 --- a/malloc.c +++ b/malloc.c @@ -1,16 +1,17 @@ -/* $Header: malloc.c,v 2.0 88/06/05 00:09:16 root Exp $ +/* $Header: malloc.c,v 3.0 89/10/18 15:20:39 lwall Locked $ * * $Log: malloc.c,v $ - * Revision 2.0 88/06/05 00:09:16 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:20:39 lwall + * 3.0 baseline * */ #ifndef lint static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; -#endif +#ifdef DEBUGGING #define RCHECK +#endif /* * malloc.c (Caltech) 2/21/82 * Chris Kingsley, kingsley@cit-20. @@ -43,6 +44,9 @@ static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; */ union overhead { union overhead *ov_next; /* when free */ +#ifdef mips + double strut; /* alignment problems */ +#endif struct { u_char ovu_magic; /* magic number */ u_char ovu_index; /* bucket # */ @@ -128,7 +132,11 @@ malloc(nbytes) return (NULL); /* remove from linked list */ if (*((int*)p) > 0x10000000) +#ifndef I286 fprintf(stderr,"Corrupt malloc ptr 0x%x at 0x%x\n",*((int*)p),p); +#else + fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",*((int*)p),p); +#endif nextf[bucket] = nextf[bucket]->ov_next; p->ov_magic = MAGIC; p->ov_index= bucket; @@ -153,7 +161,7 @@ malloc(nbytes) */ static morecore(bucket) - register bucket; + register int bucket; { register union overhead *op; register int rnu; /* 2^rnu bytes will be requested */ @@ -168,10 +176,21 @@ morecore(bucket) * make getpageize call? */ op = (union overhead *)sbrk(0); +#ifndef I286 if ((int)op & 0x3ff) - sbrk(1024 - ((int)op & 0x3ff)); + (void)sbrk(1024 - ((int)op & 0x3ff)); +#else + /* The sbrk(0) call on the I286 always returns the next segment */ +#endif + +#ifndef I286 /* take 2k unless the block is bigger than that */ rnu = (bucket <= 8) ? 11 : bucket + 3; +#else + /* take 16k unless the block is bigger than that + (80286s like large segments!) */ + rnu = (bucket <= 11) ? 14 : bucket + 3; +#endif nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */ if (rnu < bucket) rnu = bucket; @@ -183,10 +202,14 @@ morecore(bucket) * Round up to minimum allocation size boundary * and deduct from block count to reflect. */ +#ifndef I286 if ((int)op & 7) { op = (union overhead *)(((int)op + 8) &~ 7); nblks--; } +#else + /* Again, this should always be ok on an 80286 */ +#endif /* * Add new memory allocated to that on * free list for this hash bucket. @@ -212,7 +235,7 @@ free(cp) ASSERT(op->ov_magic == MAGIC); /* make sure it was in use */ #else if (op->ov_magic != MAGIC) { - fprintf(stderr,"%s free() ignored\n", + warn("%s free() ignored", op->ov_magic == OLDMAGIC ? "Duplicate" : "Bad"); return; /* sanity */ } @@ -281,12 +304,31 @@ realloc(cp, nbytes) onb = (1 << (i + 3)) - sizeof (*op) - RSLOP; /* avoid the copy if same size block */ if (was_alloced && - nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) + nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) { +#ifdef RCHECK + /* + * Record new allocated size of block and + * bound space with magic numbers. + */ + if (op->ov_index <= 13) { + /* + * Convert amount of memory requested into + * closest block size stored in hash buckets + * which satisfies request. Account for + * space used per block for accounting. + */ + nbytes += sizeof (union overhead) + RSLOP; + nbytes = (nbytes + 3) &~ 3; + op->ov_size = nbytes - 1; + *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC; + } +#endif return(cp); + } if ((res = malloc(nbytes)) == NULL) return (NULL); if (cp != res) /* common optimization */ - bcopy(cp, res, (nbytes < onb) ? nbytes : onb); + (void)bcopy(cp, res, (int)((nbytes < onb) ? nbytes : onb)); if (was_alloced) free(cp); return (res); @@ -348,3 +390,4 @@ mstats(s) totused, totfree); } #endif +#endif /* lint */ diff --git a/patchlevel.h b/patchlevel.h index 110c86f..935ec35 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 1 +#define PATCHLEVEL 0 diff --git a/perl.h b/perl.h index d4846b6..3ea3d82 100644 --- a/perl.h +++ b/perl.h @@ -1,8 +1,13 @@ -/* $Header: perl.h,v 2.0 88/06/05 00:09:21 root Exp $ +/* $Header: perl.h,v 3.0 89/10/18 15:21:21 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.h,v $ - * Revision 2.0 88/06/05 00:09:21 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:21:21 lwall + * 3.0 baseline * */ @@ -13,10 +18,19 @@ #define VOIDUSED 1 #include "config.h" +#ifdef IAMSUID +# ifndef TAINT +# define TAINT +# endif +#endif + #ifdef MEMCPY extern char *memcpy(), *memset(); -#define bcopy(s1,s2,l) memcpy(s2,s1,l); -#define bzero(s,l) memset(s,0,l); +#define bcopy(s1,s2,l) memcpy(s2,s1,l) +#define bzero(s,l) memset(s,0,l) +#endif +#ifndef BCMP /* prefer bcmp slightly 'cuz it doesn't order */ +#define bcmp(s1,s2,l) memcmp(s1,s2,l) #endif #include @@ -35,22 +49,86 @@ extern char *memcpy(), *memset(); #ifdef TMINSYS #include #else +#ifdef I_SYSTIME +#include +#else #include #endif +#endif #include +#ifdef I_SYSIOCTL +#ifndef _IOCTL_ +#include +#endif +#endif + +#if defined(mc300) || defined(mc500) || defined(mc700) /* MASSCOMP */ +#ifdef SOCKETPAIR +#undef SOCKETPAIR +#endif +#ifdef NDBM +#undef NDBM +#endif +#endif + +#ifdef NDBM +#include +#define SOME_DBM +#else +#ifdef ODBM +#ifdef NULL +#undef NULL /* suppress redefinition message */ +#endif +#include +#ifdef NULL +#undef NULL +#endif +#define NULL 0 /* silly thing is, we don't even use this */ +#define SOME_DBM +#define dbm_fetch(db,dkey) fetch(dkey) +#define dbm_delete(db,dkey) delete(dkey) +#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent) +#define dbm_close(db) dbmclose() +#define dbm_firstkey(db) firstkey() +#endif /* ODBM */ +#endif /* NDBM */ +#ifdef SOME_DBM +EXT char *dbmkey; +EXT int dbmlen; +#endif + +#if INTSIZE == 2 +#define htoni htons +#define ntohi ntohs +#else +#define htoni htonl +#define ntohi ntohl +#endif + +#ifdef I_DIRENT +#include +#define DIRENT dirent +#else +#ifdef I_SYSDIR +#include +#define DIRENT direct +#endif +#endif + typedef struct arg ARG; typedef struct cmd CMD; typedef struct formcmd FCMD; typedef struct scanpat SPAT; -typedef struct stab STAB; typedef struct stio STIO; typedef struct sub SUBR; typedef struct string STR; typedef struct atbl ARRAY; typedef struct htbl HASH; typedef struct regexp REGEXP; +typedef struct stabptrs STBP; +typedef struct stab STAB; #include "handy.h" #include "regexp.h" @@ -64,55 +142,129 @@ typedef struct regexp REGEXP; #include "array.h" #include "hash.h" +#if defined(iAPX286) || defined(M_I286) || defined(I80286) +# define I286 +#endif + +#ifndef __STDC__ #ifdef CHARSPRINTF char *sprintf(); #else int sprintf(); #endif +#endif -/* A string is TRUE if not "" or "0". */ -#define True(val) (tmps = (val), (*tmps && !(*tmps == '0' && !tmps[1]))) EXT char *Yes INIT("1"); EXT char *No INIT(""); -#define str_true(str) (Str = (str), (Str->str_pok ? True(Str->str_ptr) : (Str->str_nok ? (Str->str_nval != 0.0) : 0 ))) +/* "gimme" values */ + +/* Note: cmd.c assumes that it can use && to produce one of these values! */ +#define G_SCALAR 0 +#define G_ARRAY 1 + +#ifdef CRIPPLED_CC +int str_true(); +#else /* !CRIPPLED_CC */ +#define str_true(str) (Str = (str), \ + (Str->str_pok ? \ + ((*Str->str_ptr > '0' || \ + Str->str_cur > 1 || \ + (Str->str_cur && *Str->str_ptr != '0')) ? 1 : 0) \ + : \ + (Str->str_nok ? (Str->str_u.str_nval != 0.0) : 0 ) )) +#endif /* CRIPPLED_CC */ #ifdef DEBUGGING -#define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),(char*)buf) : "" ))) +#define str_peek(str) (Str = (str), \ + (Str->str_pok ? \ + Str->str_ptr : \ + (Str->str_nok ? \ + (sprintf(tokenbuf,"num(%g)",Str->str_u.str_nval), \ + (char*)tokenbuf) : \ + "" ))) #endif +#ifdef CRIPPLED_CC +char *str_get(); +#else +#ifdef TAINT +#define str_get(str) (Str = (str), tainted |= Str->str_tainted, \ + (Str->str_pok ? Str->str_ptr : str_2ptr(Str))) +#else #define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str))) -#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_nval : str_2num(Str))) +#endif /* TAINT */ +#endif /* CRIPPLED_CC */ + +#ifdef CRIPPLED_CC +double str_gnum(); +#else /* !CRIPPLED_CC */ +#ifdef TAINT +#define str_gnum(str) (Str = (str), tainted |= Str->str_tainted, \ + (Str->str_nok ? Str->str_u.str_nval : str_2num(Str))) +#else /* !TAINT */ +#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_u.str_nval : str_2num(Str))) +#endif /* TAINT*/ +#endif /* CRIPPLED_CC */ EXT STR *Str; #define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len) +#define STR_GROW(str,len) if ((str)->str_len < (len)) str_grow(str,len) + +#ifndef BYTEORDER +#define BYTEORDER 01234 +#endif + +#ifndef HTONL +#if BYTEORDER != 04321 +#define HTONS +#define HTONL +#define NTOHS +#define NTOHL +#define MYSWAP +#define htons my_swap +#define htonl my_htonl +#define ntohs my_swap +#define ntohl my_ntohl +#endif +#else +#if BYTEORDER == 04321 +#undef HTONS +#undef HTONL +#undef NTOHS +#undef NTOHL +#endif +#endif + CMD *add_label(); CMD *block_head(); CMD *append_line(); CMD *make_acmd(); CMD *make_ccmd(); +CMD *make_icmd(); CMD *invert(); CMD *addcond(); CMD *addloop(); CMD *wopt(); CMD *over(); -SPAT *stab2spat(); - STAB *stabent(); STAB *genstab(); ARG *stab2arg(); ARG *op_new(); ARG *make_op(); -ARG *make_lval(); ARG *make_match(); ARG *make_split(); -ARG *flipflip(); +ARG *rcatmaybe(); ARG *listish(); +ARG *maybelistish(); ARG *localize(); +ARG *fixeval(); +ARG *jmaybe(); ARG *l(); +ARG *fixl(); ARG *mod_match(); ARG *make_list(); ARG *cmd_to_arg(); @@ -120,14 +272,16 @@ 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(); + +int do_each(); +int do_subr(); +int do_match(); +int do_unpack(); +int eval(); /* this evaluates expressions */ +int do_eval(); /* this evaluates eval operator */ +int do_assign(); SUBR *make_sub(); @@ -138,9 +292,9 @@ char *scansubst(); char *scantrans(); char *scanstr(); char *scanreg(); -char *reg_get(); char *str_append_till(); char *str_gets(); +char *str_grow(); bool do_open(); bool do_close(); @@ -153,20 +307,28 @@ int do_subst(); int cando(); int ingroup(); -void str_grow(); void str_replace(); void str_inc(); void str_dec(); void str_free(); -void freearg(); -void savelist(); -void restorelist(); -void ajoin(); +void stab_clear(); void do_join(); -void do_assign(); void do_sprintf(); +void do_accept(); +void do_vecset(); +void savelist(); +void saveitem(); +void saveint(); +void savelong(); +void savesptr(); +void savehptr(); +void restorelist(); +HASH *savehash(); +ARRAY *saveary(); EXT line_t line INIT(0); +EXT line_t subline INIT(0); +EXT STR *subname INIT(Nullstr); EXT int arybase INIT(0); struct outrec { @@ -178,6 +340,7 @@ struct outrec { EXT struct outrec outrec; EXT struct outrec toprec; +EXT STAB *stdinstab INIT(Nullstab); EXT STAB *last_in_stab INIT(Nullstab); EXT STAB *defstab INIT(Nullstab); EXT STAB *argvstab INIT(Nullstab); @@ -187,23 +350,45 @@ EXT STAB *defoutstab INIT(Nullstab); EXT STAB *curoutstab INIT(Nullstab); EXT STAB *argvoutstab INIT(Nullstab); EXT STAB *incstab INIT(Nullstab); +EXT STAB *leftstab INIT(Nullstab); +EXT STAB *amperstab INIT(Nullstab); +EXT STAB *rightstab INIT(Nullstab); +EXT STAB *DBstab INIT(Nullstab); +EXT STAB *DBsub INIT(Nullstab); + +EXT HASH *defstash; /* main symbol table */ +EXT HASH *curstash; /* symbol table for current package */ +EXT HASH *debstash; /* symbol table for perldb package */ + +EXT STR *curstname; /* name of current package */ EXT STR *freestrroot INIT(Nullstr); EXT STR *lastretstr INIT(Nullstr); +EXT STR *DBsingle INIT(Nullstr); + +EXT int lastspbase; +EXT int lastsize; EXT char *filename; EXT char *origfilename; EXT FILE *rsfp; EXT char buf[1024]; -EXT char *bufptr INIT(buf); +EXT char *bufptr; +EXT char *oldbufptr; +EXT char *oldoldbufptr; +EXT char *bufend; EXT STR *linestr INIT(Nullstr); EXT char record_separator INIT('\n'); +EXT int rslen INIT(1); EXT char *ofs INIT(Nullch); +EXT int ofslen INIT(0); EXT char *ors INIT(Nullch); +EXT int orslen INIT(0); EXT char *ofmt INIT(Nullch); EXT char *inplace INIT(Nullch); +EXT char *nointrp INIT(""); EXT bool preprocess INIT(FALSE); EXT bool minus_n INIT(FALSE); @@ -214,17 +399,30 @@ 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 */ +EXT bool sawi INIT(FALSE); /* study must assume case insensitive */ +EXT bool sawvec INIT(FALSE); + +EXT int csh INIT(0); /* 1 if /bin/csh is there, -1 if not */ + +#ifdef TAINT +EXT bool tainted INIT(FALSE); /* using variables controlled by $< */ +#endif #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; +EXT int expectterm INIT(TRUE); /* how to interpret ambiguous tokens */ +EXT int in_eval INIT(FALSE); /* trap fatal errors? */ +EXT int multiline INIT(0); /* $*--do strings hold >1 line? */ +EXT int forkprocess; /* so do_open |- can return proc# */ +EXT int do_undump INIT(0); /* -u or dump seen? */ +EXT int error_count INIT(0); /* how many errors so far, max 10 */ +EXT int multi_start INIT(0); /* 1st line of multi-line string */ +EXT int multi_end INIT(0); /* last line of multi-line string */ +EXT int multi_open INIT(0); /* delimiter of said string */ +EXT int multi_close INIT(0); /* delimiter of said string */ FILE *popen(); /* char *str_get(); */ @@ -233,9 +431,14 @@ void free_arg(); STIO *stio_new(); EXT struct stat statbuf; +EXT struct stat statcache; +STAB *statstab INIT(Nullstab); +STR *statname; EXT struct tms timesbuf; EXT int uid; EXT int euid; +EXT int gid; +EXT int egid; UIDTYPE getuid(); UIDTYPE geteuid(); GIDTYPE getgid(); @@ -245,38 +448,48 @@ EXT int unsafe; #ifdef DEBUGGING EXT int debug INIT(0); EXT int dlevel INIT(0); -EXT char debname[128]; -EXT char debdelim[128]; +EXT int dlmax INIT(128); +EXT char *debname; +EXT char *debdelim; #define YYDEBUG 1 extern int yydebug; #endif +EXT int perldb INIT(0); EXT line_t cmdline INIT(NOLINE); +EXT STR str_undef; EXT STR str_no; EXT STR str_yes; /* runtime control stuff */ EXT struct loop { - char *loop_label; + char *loop_label; /* what the loop was called, if anything */ + int loop_sp; /* stack pointer to copy stuff down to */ jmp_buf loop_env; -} loop_stack[64]; +} *loop_stack; EXT int loop_ptr INIT(-1); +EXT int loop_max INIT(128); EXT jmp_buf top_env; EXT jmp_buf eval_env; EXT char *goto_targ INIT(Nullch); /* cmd_exec gets strange when set */ +EXT ARRAY *stack; /* THE STACK */ + EXT ARRAY *savestack; /* to save non-local values on */ EXT ARRAY *tosave; /* strings to save on recursive subroutine */ +EXT ARRAY *lineary; /* lines of script for debugger */ + +EXT ARRAY *pidstatary; /* keep pids and statuses by fd for mypopen */ + double atof(); -unsigned sleep(); -long time(), times(); +long time(); struct tm *gmtime(), *localtime(); char *mktemp(); char *index(), *rindex(); @@ -288,3 +501,16 @@ int unlnk(); #else #define UNLINK unlink #endif + +#ifndef SETREUID +#ifdef SETRESUID +#define setreuid(r,e) setresuid(r,e,-1) +#define SETREUID +#endif +#endif +#ifndef SETREGID +#ifdef SETRESGID +#define setregid(r,e) setresgid(r,e,-1) +#define SETREGID +#endif +#endif diff --git a/perl.man.1 b/perl.man.1 index 3a4db8b..3aec968 100644 --- a/perl.man.1 +++ b/perl.man.1 @@ -1,13 +1,9 @@ .rn '' }` -''' $Header: perl.man.1,v 2.0.1.1 88/06/28 16:28:09 root Exp $ +''' $Header: perl.man.1,v 3.0 89/10/18 15:21:29 lwall Locked $ ''' ''' $Log: perl.man.1,v $ -''' Revision 2.0.1.1 88/06/28 16:28:09 root -''' patch1: fixed some quotes -''' patch1: clarified syntax of LIST -''' -''' Revision 2.0 88/06/05 00:09:23 root -''' Baseline version 2.0. +''' Revision 3.0 89/10/18 15:21:29 lwall +''' 3.0 baseline ''' ''' .de Sh @@ -50,14 +46,16 @@ .ds L' ` .ds R' ' 'br\} -.TH PERL 1 LOCAL +.TH PERL 1 "\*(RP" +.UC .SH NAME -perl - Practical Extraction and Report Language +perl \- Practical Extraction and Report Language .SH SYNOPSIS -.B perl [options] filename args +.B perl +[options] filename args .SH DESCRIPTION .I Perl -is a interpreted language optimized for scanning arbitrary text files, +is an interpreted language optimized for scanning arbitrary text files, extracting information from those text files, and printing reports based on that information. It's also a good language for many system management tasks. @@ -69,13 +67,39 @@ so people familiar with those languages should have little difficulty with it. (Language historians will also note some vestiges of \fIcsh\fR, Pascal, and even BASIC-PLUS.) Expression syntax corresponds quite closely to C expression syntax. +Unlike most Unix utilities, +.I perl +does not arbitrarily limit the size of your data\*(--if you've got +the memory, +.I perl +can slurp in your whole file as a single string. +Recursion is of unlimited depth. +And the hash tables used by associative arrays grow as necessary to prevent +degraded performance. +.I Perl +uses sophisticated pattern matching techniques to scan large amounts of +data very quickly. +Although optimized for scanning text, +.I perl +can also deal with binary data, and can make dbm files look like associative +arrays (where dbm is available). +Setuid +.I perl +scripts are safer than C programs +through a dataflow tracing mechanism which prevents many stupid security holes. If you have a problem that would ordinarily use \fIsed\fR or \fIawk\fR or \fIsh\fR, but it exceeds their capabilities or must run a little faster, and you don't want to write the silly thing in C, then .I perl may be for you. -There are also translators to turn your sed and awk scripts into perl scripts. +There are also translators to turn your +.I sed +and +.I awk +scripts into +.I perl +scripts. OK, enough hype. .PP Upon startup, @@ -89,9 +113,11 @@ 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 implicity via standard input. +Passed in implicitly 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. +arguments to a +.I stdin +script you must explicitly specify a \- for the script name. .PP After locating your script, .I perl @@ -107,38 +133,50 @@ only allows one argument. Example: .nf .ne 2 - #!/usr/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. +turns on autosplit mode when used with a +.B \-n +or +.BR \-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. +the +.B \-n +or +.BR \-p . .nf - perl -ane 'print pop(@F),"\en";' + perl \-ane \'print pop(@F), "\en";\' is equivalent to while (<>) { - @F = split(' '); - print pop(@F),"\en"; + @F = split(\' \'); + print pop(@F), "\en"; } .fi .TP 5 -.B \-D +.BI \-d +runs the script under the perl debugger. +See the section on Debugging. +.TP 5 +.BI \-D number sets debugging flags. To watch how it executes your script, use -.B \-D14. +.BR \-D14 . (This only works if debugging is compiled into your .IR perl .) +Another nice value is \-D1024, which lists your compiled syntax tree. +And \-D512 displays compiled regular expressions. .TP 5 -.B \-e commandline +.BI \-e " commandline" may be used to enter one line of script. Multiple .B \-e @@ -149,7 +187,7 @@ is given, .I perl will not look for a script filename in the argument list. .TP 5 -.B \-i +.BI \-i extension specifies that files processed by the <> construct are to be edited in-place. It does this by renaming the input file, opening the output file by the @@ -157,12 +195,12 @@ 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 - #!/usr/bin/perl -pi.bak + #!/usr/bin/perl \-pi.bak s/foo/bar/; which is equivalent to @@ -171,8 +209,8 @@ which is equivalent to #!/usr/bin/perl while (<>) { if ($ARGV ne $oldargv) { - rename($ARGV,$ARGV . '.bak'); - open(ARGVOUT,">$ARGV"); + rename($ARGV, $ARGV . \'.bak\'); + open(ARGVOUT, ">$ARGV"); select(ARGVOUT); $oldargv = $ARGV; } @@ -181,18 +219,22 @@ which is equivalent to continue { print; # this prints to original filename } - select(stdout); + select(STDOUT); .fi -except that the \-i form doesn't need to compare $ARGV to $oldargv to know when +except that the +.B \-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. +Note that +.I 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 +.BI \-I directory may be used in conjunction with .B \-P to tell the C preprocessor where to look for include files. @@ -202,7 +244,7 @@ By default /usr/include and /usr/lib/perl are searched. causes .I perl to assume the following loop around your script, which makes it iterate -over filename arguments somewhat like \*(L"sed -n\*(R" or \fIawk\fR: +over filename arguments somewhat like \*(L"sed \-n\*(R" or \fIawk\fR: .nf .ne 3 @@ -218,10 +260,10 @@ 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;' + find . \-mtime +7 \-print | perl \-ne \'chop;unlink;\' .fi -This is faster than using the -exec switch find because you don't have to +This is faster than using the \-exec switch of find because you don't have to start a process on every filename found. .TP 5 .B \-p @@ -252,76 +294,126 @@ switch. .B \-P causes your script to be run through the C preprocessor before compilation by -.I perl. +.IR perl . (Since both comments and cpp directives begin with the # character, you should avoid starting comments with any words recognized by the C preprocessor such as \*(L"if\*(R", \*(L"else\*(R" or \*(L"define\*(R".) .TP 5 .B \-s enables some rudimentary switch parsing for switches on the command line -after the script name but before any filename arguments (or before a --). +after the script name but before any filename arguments (or before a \-\|\-). Any switch found there is removed from @ARGV and sets the corresponding variable in the .I perl script. The following script prints \*(L"true\*(R" if and only if the script is -invoked with a -xyz switch. +invoked with a \-xyz switch. .nf .ne 2 - #!/usr/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 +makes +.I 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 $*" + 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. +which proceeds to try to execute the +.I perl +script as a shell script. The shell executes the second line as a normal shell command, and thus -starts up the perl interpreter. +starts up the +.I 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 +so the +.B \-S +tells +.I perl +to search for the script if necessary. +After +.I 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 +causes +.I perl +to dump core after compiling your script. +You can then take this core dump and turn it into an executable file +by using the undump program (not supplied). +This speeds startup at the expense of some disk space (which you can +minimize by stripping the executable). +(Still, a "hello world" executable comes out to about 200K on my machine.) +If you are going to run your executable as a set-id program then you +should probably compile it using taintperl rather than normal perl. +If you want to execute a portion of your script before dumping, use the +dump operator instead. +.TP 5 .B \-U -allows perl to do unsafe operations. +allows +.I 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. +prints the version and patchlevel of your +.I 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. +filehandles or filehandles opened readonly that you are attempting to +write on. +Also warns you if you use == on values that don't look like numbers, and if +your subroutines recurse more than 100 deep. .Sh "Data Types and Objects" .PP -Perl has about two and a half data types: scalars, arrays of scalars, and -associative arrays. -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). +.I Perl +has three data types: scalars, arrays of scalars, and +associative arrays of scalars. +Normal arrays are indexed by number, and associative arrays by string. .PP -Scalars are interpreted as strings or numbers as appropriate. +The interpretation of operations and values in perl sometimes +depends on the requirements +of the context around the operation or value. +There are three major contexts: string, numeric and array. +Certain operations return array values +in contexts wanting an array, and scalar values otherwise. +(If this is true of an operation it will be mentioned in the documentation +for that operation.) +Operations which return scalars don't care whether the context is looking +for a string or a number, but +scalar variables and values are interpreted as strings or numbers +as appropriate to the context. 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 +Booleans returned by operators are 1 for true and \'0\' or \'\' (the null string) for false. .PP +There are actually two varieties of null string: defined and undefined. +Undefined null strings are returned when there is no real value for something, +such as when there was an error, or at end of file, or when you refer +to an uninitialized variable or element of an array. +An undefined null string may become defined the first time you access it, but +prior to that you can use the defined() operator to determine whether the +value is defined or not. +.PP References to scalar variables always begin with \*(L'$\*(R', even when referring to a scalar that is part of an array. Thus: @@ -330,19 +422,28 @@ Thus: .ne 3 $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{\'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': +but entire arrays or array slices are denoted by \*(L'@\*(R': @days \h'|2i'# ($days[0], $days[1],\|.\|.\|. $days[n]) + @days[3,4,5]\h'|2i'# same as @days[3.\|.5] + @days{'a','c'}\h'|2i'# same as ($days{'a'},$days{'c'}) + +and entire associative arrays are denoted by \*(L'%\*(R': + %days \h'|2i'# (key1, val1, key2, val2 .\|.\|.) .fi .PP -Any of these five constructs may server as an lvalue, +Any of these eight constructs may serve 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.) +(It also turns out that an assignment is itself an lvalue in +certain contexts\*(--see examples under s, tr and chop.) +Assignment to a scalar evaluates the righthand side in a scalar context, +while assignment to an array or array slice evaluates the righthand side +in an array context. +.PP You may find the length of array @days by evaluating \*(L"$#days\*(R", as in .IR csh . @@ -367,47 +468,136 @@ The following are exactly equivalent .fi .PP +Multi-dimensional arrays are not directly supported, but see the discussion +of the $; variable later for a means of emulating multiple subscripts with +an associative array. +.PP Every data type has its own namespace. 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 +Since variable and array references always start with \*(L'$\*(R', \*(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. -Hint: you could say open(LOG,'logfile') rather than open(log,'logfile').) +Hint: you could say open(LOG,\'logfile\') rather than open(log,\'logfile\'). +Using uppercase filehandles also improves readability and protects you +from conflict with future reserved words.) Case IS significant\*(--\*(L"FOO\*(R", \*(L"Foo\*(R" and \*(L"foo\*(R" are all different names. Names which start with a letter may also contain digits and underscores. Names which do not start with a letter are limited to one character, e.g. \*(L"$%\*(R" or \*(L"$$\*(R". -(Many one character names have a predefined significance to -.I perl. +(Most of the one character names have a predefined significance to +.IR perl . More later.) .PP +Numeric literals are specified in any of the usual floating point or +integer formats: +.nf + +.ne 5 + 12345 + 12345.67 + .23E-10 + 0xffff # hex + 0377 # octal + +.fi String literals are delimited by either single or double quotes. They work much like shell quotes: double-quoted string literals are subject to backslash and variable -substitution; single-quoted strings are not. +substitution; single-quoted strings are not (except for \e\' and \e\e). The usual backslash rules apply for making characters such as newline, tab, etc. You can also embed newlines directly in your strings, i.e. they can end on a different line than they begin. This is nice, but if you forget your trailing quote, the error will not be -reported until perl finds another line containing the quote character, which +reported until +.I 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 scalar variables. +Variable substitution inside strings is limited to scalar variables, normal +array values, and array slices. +(In other words, identifiers beginning with $ or @, followed by an optional +bracketed expression as a subscript.) The following code segment prints out \*(L"The price is $100.\*(R" .nf .ne 2 - $Price = '$100';\h'|3.5i'# not interpreted + $Price = \'$100\';\h'|3.5i'# not interpreted print "The price is $Price.\e\|n";\h'|3.5i'# interpreted .fi Note that you can put curly brackets around the identifier to delimit it from following alphanumerics. .PP +Array values are interpolated into double-quoted strings by joining all the +elements of the array with the delimiter specified in the $" variable, +space by default. +(Since in versions of perl prior to 3.0 the @ character was not a metacharacter +in double-quoted strings, the interpolation of @array, $array[EXPR], +@array[LIST], $array{EXPR}, or @array{LIST} only happens if array is +referenced elsewhere in the program or is predefined.) +The following are equivalent: +.nf + +.ne 4 + $temp = join($",@ARGV); + system "echo $temp"; + + system "echo @ARGV"; + +.fi +Within search patterns (which also undergo double-quoteish substitution) +there is a bad ambiguity: Is /$foo[bar]/ to be +interpreted as /${foo}[bar]/ (where [bar] is a character class for the +regular expression) or as /${foo[bar]}/ (where [bar] is the subscript to +array @foo)? +If @foo doesn't otherwise exist, then it's obviously a character class. +If @foo exists, perl takes a good guess about [bar], and is almost always right. +If it does guess wrong, or if you're just plain paranoid, +you can force the correct interpretation with curly brackets as above. +.PP +A line-oriented form of quoting is based on the shell here-is syntax. +Following a << you specify a string to terminate the quoted material, and all lines +following the current line down to the terminating string are the value +of the item. +The terminating string may be either an identifier (a word), or some +quoted text. +If quoted, the type of quotes you use determines the treatment of the text, +just as in regular quoting. +An unquoted identifier works like double quotes. +There must be no space between the << and the identifier. +(If you put a space it will be treated as a null identifier, which is +valid, and matches the first blank line\*(--see Merry Christmas example below.) +The terminating string must appear by itself (unquoted and with no surrounding +whitespace) on the terminating line. +.nf + + print <) { - while () { - for (\|;\|;\|) { +.ne 5 + while ($_ = ) { print; } + while () { print; } + for (\|;\|;\|) { print; } + print while $_ = ; + print while ; .fi The filehandles +.IR STDIN , +.I STDOUT +and +.I STDERR +are predefined. +(The filehandles .IR stdin , .I stdout and .I stderr -are predefined. +will also work except in packages, where they would be interpreted as +local identifiers rather than global.) Additional filehandles may be created with the .I open function. @@ -492,7 +714,7 @@ The null filehandle <> is special and can be used to emulate the behavior of Input from <> comes either from standard input, or from each file listed on the command line. Here's how it works: the first time <> is evaluated, the ARGV array is checked, -and if it is null, $ARGV[0] is set to '-', which when opened gives you standard +and if it is null, $ARGV[0] is set to \'-\', which when opened gives you standard input. The ARGV array is then processed as a list of filenames. The loop @@ -506,7 +728,7 @@ The loop .ne 10 is equivalent to - unshift(@ARGV, '\-') \|if \|$#ARGV < $[; + unshift(@ARGV, \'\-\') \|if \|$#ARGV < $[; while ($ARGV = shift) { open(ARGV, $ARGV); while () { @@ -545,7 +767,8 @@ put a loop on the front like this: .fi The <> symbol will return FALSE only once. If you call it again after this it will assume you are processing another -@ARGV list, and if you haven't set @ARGV, will input from stdin. +@ARGV list, and if you haven't set @ARGV, will input from +.IR STDIN . .PP If the string inside the angle brackets is a reference to a scalar variable (e.g. <$foo>), @@ -564,25 +787,26 @@ Example: .ne 3 while (<*.c>) { - chmod 0644,$_; + chmod 0644, $_; } is equivalent to .ne 5 - open(foo,"echo *.c | tr -s ' \et\er\ef' '\e\e012\e\e012\e\e012\e\e012'|"); + open(foo, "echo *.c | tr \-s \' \et\er\ef\' \'\e\e012\e\e012\e\e012\e\e012\'|"); while () { chop; - chmod 0644,$_; + chmod 0644, $_; } .fi In fact, it's currently implemented that way. -(Which means it will not work on filenames with spaces in them.) +(Which means it will not work on filenames with spaces in them unless +you have /bin/csh on your machine.) Of course, the shortest way to do the above is: .nf - chmod 0644,<*.c>; + chmod 0644, <*.c>; .fi .Sh "Syntax" @@ -594,7 +818,9 @@ The only things that need to be declared in .I perl are report formats and subroutines. See the sections below for more information on those declarations. -All objects are assumed to start with a null or 0 value. +All uninitialized objects user-created objects are assumed to +start with a null or 0 value until they +are defined by some explicit operation such as assignment. The sequence of commands is executed just once, unlike in .I sed and @@ -610,7 +836,8 @@ or switch.) .PP A declaration can be put anywhere a command can, but has no effect on the -execution of the primary sequence of commands. +execution of the primary sequence of commands--declarations all take effect +at compile time. Typically all the declarations are put at the beginning or the end of the script. .PP .I Perl @@ -650,11 +877,11 @@ The following all do the same thing: .nf .ne 5 - if (!open(foo)) { die "Can't open $foo"; } - die "Can't open $foo" unless open(foo); - open(foo) || die "Can't open $foo"; # foo or bust! - open(foo) ? die "Can't open $foo" : 'hi mom'; - # a bit exotic, that last one + if (!open(foo)) { die "Can't open $foo: $!"; } + die "Can't open $foo: $!" unless open(foo); + open(foo) || die "Can't open $foo: $!"; # foo or bust! + open(foo) ? die "Can't open $foo: $!" : \'hi mom\'; + # a bit exotic, that last one .fi .PP @@ -681,7 +908,7 @@ The LABEL is optional, and if present, consists of an identifier followed by a colon. The LABEL identifies the loop for the loop control statements .IR next , -.I last +.IR last , and .I redo (see below). @@ -751,14 +978,18 @@ Examples: $elem *= 2; } - for ((10,9,8,7,6,5,4,3,2,1,'BOOM')) { - print $_,"\en"; sleep(1); +.ne 3 + for ((10,9,8,7,6,5,4,3,2,1,\'BOOM\')) { + print $_, "\en"; sleep(1); } + for (1..15) { print "Merry Christmas\en"; } + .ne 3 - foreach $item (split(/:[\e\e\en:]*/,$ENV{'TERMCAP'}) { + 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 @@ -773,28 +1004,67 @@ This construct is particularly nice for doing case structures. .ne 6 foo: { - if (/abc/) { $abc = 1; last foo; } - if (/def/) { $def = 1; last foo; } - if (/xyz/) { $xyz = 1; last foo; } + if (/^abc/) { $abc = 1; last foo; } + if (/^def/) { $def = 1; last foo; } + if (/^xyz/) { $xyz = 1; last foo; } $nothing = 1; } .fi -It's also nice for exiting subroutines early. -Note the double curly brackets: +There is no official switch statement in perl, because there +are already several ways to write the equivalent. +In addition to the above, you could write .nf +.ne 6 + foo: { + $abc = 1, last foo if /^abc/; + $def = 1, last foo if /^def/; + $xyz = 1, last foo if /^xyz/; + $nothing = 1; + } + +or + +.ne 6 + foo: { + /^abc/ && do { $abc = 1; last foo; } + /^def/ && do { $def = 1; last foo; } + /^xyz/ && do { $xyz = 1; last foo; } + $nothing = 1; + } + +or + +.ne 6 + foo: { + /^abc/ && ($abc = 1, last foo); + /^def/ && ($def = 1, last foo); + /^xyz/ && ($xyz = 1, last foo); + $nothing = 1; + } + +or even + .ne 8 - sub tokenize {{ - .\|.\|. - if (/foo/) { - 23; # return value - last; - } - .\|.\|. - }} + if (/^abc/) + { $abc = 1; last foo; } + elsif (/^def/) + { $def = 1; last foo; } + elsif (/^xyz/) + { $xyz = 1; last foo; } + else + {$nothing = 1;} .fi +As it happens, these are all optimized internally to a switch structure, +so perl jumps directly to the desired statement, and you needn't worry +about perl executing a lot of unnecessary statements when you have a string +of 50 elsifs, as long as you are testing the same simple scalar variable +using ==, eq, or pattern matching as above. +(If you're curious as to whether the optimizer has done this for a particular +case statement, you can use the \-D1024 switch to list the syntax tree +before execution.) .Sh "Simple statements" The only kind of simple statement is an expression evaluated for its side effects. @@ -831,7 +1101,7 @@ This is so that you can write loops like: .ne 4 do { - $_ = ; + $_ = ; .\|.\|. } until $_ \|eq \|".\|\e\|n"; @@ -850,12 +1120,16 @@ will be mentioned here. Here's what .I perl has that C doesn't: +.Ip ** 8 2 +The exponentiation operator. +.Ip **= 8 +The exponentiation assignment operator. .Ip (\|) 8 3 The null list, used to initialize an array to null. .Ip . 8 Concatenation of two strings. .Ip .= 8 -The corresponding assignment operator. +The concatenation assignment operator. .Ip eq 8 String equality (== is numeric equality). For a mnemonic just think of \*(L"eq\*(R" as a string. @@ -895,66 +1169,85 @@ Returns a string consisting of the left operand repeated the number of times specified by the right operand. .nf - print '-' x 80; # print row of dashes - print '-' x80; # illegal, x80 is identifier + print \'\-\' x 80; # print row of dashes + print \'\-\' x80; # illegal, x80 is identifier - print "\et" x ($tab/8), ' ' x ($tab%8); # tab over + print "\et" x ($tab/8), \' \' x ($tab%8); # tab over .fi .Ip x= 8 -The corresponding assignment operator. -.Ip .. 8 -The range operator, which is bistable. -Each .. operator maintains its own boolean state. +The repetition assignment operator. +.Ip .\|. 8 +The range operator, which is really two different operators depending +on the context. +In an array context, returns an array of values counting (by ones) +from the left value to the right value. +This is useful for writing \*(L"for (1..10)\*(R" loops and for doing +slice operations on arrays. +.Sp +In a scalar context, .\|. returns a boolean value. +The operator is bistable, like a flip-flop.. +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 doesn't become false till the next time the range operator is 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 scalar .\|. operator is primarily intended for doing line number ranges +after the fashion of \fIsed\fR or \fIawk\fR. The precedence is a little lower than || and &&. The value returned is either the null string for false, or a sequence number (beginning with 1) for true. The sequence number is reset for each range encountered. -The final sequence number in a range has the string 'E0' appended to it, which +The final sequence number in a range has the string \'E0\' appended to it, which doesn't affect its numeric value, but gives you something to search for if you want to exclude the endpoint. You can exclude the beginning point by waiting for the sequence number to be greater than 1. -If either operand of .. is static, that operand is implicitly compared to -the $. variable, the current line number. +If either operand of scalar .\|. is static, that operand is implicitly compared +to the $. variable, the current line number. Examples: .nf -.ne 5 - if (101 .. 200) { print; } # print 2nd hundred lines +.ne 6 +As a scalar operator: + if (101 .\|. 200) { print; } # print 2nd hundred lines - next line if (1 .. /^$/); # skip header lines + next line if (1 .\|. /^$/); # skip header lines - s/^/> / if (/^$/ .. eof()); # quote body + s/^/> / if (/^$/ .\|. eof()); # quote body + +.ne 4 +As an array operator: + for (101 .\|. 200) { print; } # print $_ 100 times + + @foo = @foo[$[ .\|. $#foo]; # an expensive no-op + @foo = @foo[$#foo-4 .\|. $#foo]; # slice last 5 items .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. +If the argument is omitted, tests $_, except for \-t, which tests +.IR STDIN . +It returns 1 for true and \'\' for false, or the undefined value if the +file doesn't exist. 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. + \-w File is writable 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. + \-W File is writable by real uid. \-X File is executable by real uid. \-O File is owned by real uid. \-e File exists. @@ -994,8 +1287,8 @@ Example: } .fi -Note that -s/a/b/ does not do a negated substitution. -Saying -exp($foo) still works as expected, however\*(--only single letters +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. @@ -1005,12 +1298,34 @@ If too many odd characters (>10%) are found, it's a \-B file, otherwise it's a \ 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 +If any of the file tests (or either stat operator) are given the special +filehandle consisting of a solitary underline, then the stat structure +of the previous file test (or stat operator) is used, saving a system +call. +(This doesn't work with \-t, and you need to remember that lstat and -l +will leave values in the stat structure for the symbolic link, not the +real file.) +Example: +.nf + + print "Can do.\en" if -r $a || -w _ || -x _; + +.ne 9 + stat($filename); + print "Readable\en" if -r _; + print "Writable\en" if -w _; + print "Executable\en" if -x _; + print "Setuid\en" if -u _; + print "Setgid\en" if -g _; + print "Sticky\en" if -k _; + print "Text\en" if -T _; + print "Binary\en" if -B _; + +.fi +.PP Here is what C has that .I perl doesn't: @@ -1032,8 +1347,8 @@ You can say .nf .ne 2 - 'Now is the time for all' . "\|\e\|n" . - 'good men to come to.' + \'Now is the time for all\' . "\|\e\|n" . + \'good men to come to.\' .fi and this all reduces to one string internally. @@ -1043,375 +1358,14 @@ 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 +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' + print ++($foo = \'99\'); # prints \*(L'100\*(R' + print ++($foo = \'a0\'); # prints \*(L'a1\*(R' + print ++($foo = \'Az\'); # prints \*(L'Ba\*(R' + print ++($foo = \'zz\'); # prints \*(L'aaa\*(R' .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. -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. -(The string specified with =~ need not be an lvalue\*(--it may be the result of an expression evaluation, but remember the =~ binds rather tightly.) -See also the section on regular expressions. -.Sp -If you prepend an `m' you can use any pair of characters as delimiters. -This is particularly useful for matching Unix path names that contain `/'. -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'); - \|=~ \|/\|^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 file of a set of files, for instance. -.Ip "chdir EXPR" 8 2 -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. -Returns the number of files successfully changed. -.nf - -.ne 2 - $cnt = chmod 0755,'foo','bar'; - chmod 0755,@executables; - -.fi -.Ip "chop(VARIABLE)" 8 5 -.Ip "chop" 8 -Chops off the last character of a string and returns it. -It's used primarily to remove the newline from the end of an input record, -but is much more efficient than s/\en// because it neither scans nor copies -the string. -If VARIABLE is omitted, chops $_. -Example: -.nf - -.ne 5 - while (<>) { - chop; # avoid \en on last field - @array = split(/:/); - .\|.\|. - } - -.fi -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. -The first two elements of the list must be the NUMERICAL uid and gid, -in that order. -Returns the number of files successfully changed. -.nf - -.ne 2 - $cnt = chown $uid,$gid,'foo','bar'; - chown $uid,$gid,@filenames; - -.fi -.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 = <$pattern>; # get filenames - if ($uid{$user} eq '') { - die "$user not in passwd file"; - } - else { - unshift(@ary,$uid{$user},$gid{$user}); - chown @ary; - } - -.fi -.Ip "close(FILEHANDLE)" 8 5 -.Ip "close FILEHANDLE" 8 -Closes the file or pipe associated with the file handle. -You don't have to close FILEHANDLE if you are immediately going to -do another open on it, since open will close it for you. -(See -.IR open .) -However, an explicit close on an input file resets the line counter ($.), while -the implicit close done by -.I open -does not. -Also, closing a pipe will wait for the process executing on the pipe to complete, -in case you want to look at the output of the pipe afterwards. -Example: -.nf - -.ne 4 - open(output,'|sort >foo'); # pipe to sort - .\|.\|. # print stuff to output - close(output); # wait for sort to finish - open(input,'foo'); # get sort's results - -.fi -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 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.\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 - - /etc/games is no good at canasta line 123. - /etc/games is no good, stopped at canasta line 123. - -.fi -See also -.IR exit . -.Ip "do BLOCK" 8 4 -Returns the value of the last command in the sequence of commands indicated -by BLOCK. -When modified by a loop modifier, executes the BLOCK once before testing the -loop condition. -(On other statements the loop modifiers test the conditional first.) -.Ip "do SUBROUTINE (LIST)" 8 3 -Executes a SUBROUTINE declared by a -.I sub -declaration, and returns the value -of the last expression evaluated in SUBROUTINE. -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. -Entries are returned in an apparently random order. -When the array is entirely read, a null array is returned (which when -assigned produces a FALSE (0) value). -The next call to each() after that will start iterating again. -The iterator can be reset only by reading all the elements from the array. -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 - -.ne 3 - while (($key,$value) = each(ENV)) { - print "$key=$value\en"; - } - -.fi -See also keys() and values(). -.Ip "eof(FILEHANDLE)" 8 8 -.Ip "eof" 8 -Returns 1 if the next read on FILEHANDLE will return end of file, or if -FILEHANDLE is not open. -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 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 of last file - while (<>) { - if (eof()) { - print "--------------\en"; - } - 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. -It is executed in the context of the current perl program, so that -any variable settings, subroutine or format definitions remain afterwards. -The value returned is the value of the last expression evaluated, just -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. -If there is only one argument, the argument is checked for shell metacharacters. -If there are any, the entire argument is passed to /bin/sh -c for parsing. -If there are none, the argument is split into words and passed directly to -execvp(), which is more efficient. -Note: exec (and system) do not flush your output buffer, so you may need to -set $| to avoid lost output. -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: -.nf - -.ne 2 - $ans = ; - exit 0 \|if \|$ans \|=~ \|/\|^[Xx]\|/\|; - -.fi -See also -.IR die . -.Ip "exp(EXPR)" 8 3 -Returns e to the power of EXPR. -.Ip "fork" 8 4 -Does a fork() call. -Returns the child pid to the parent process and 0 to the child process. -Note: unflushed buffers remain unflushed in both processes, which means -you may need to set $| to avoid duplicate output. -.Ip "gmtime(EXPR)" 8 4 -Converts a time as returned by the time function to a 9-element array with -the time analyzed for the Greenwich timezone. -Typically used as follows: -.nf - -.ne 3 - ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) - = gmtime(time); - -.fi -All array elements are numeric, 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 9abd390..8e26ef2 100644 --- a/perl.man.2 +++ b/perl.man.2 @@ -1,1440 +1,1033 @@ ''' Beginning of part 2 -''' $Header: perl.man.2,v 2.0.1.1 88/06/28 16:31:49 root Exp $ +''' $Header: perl.man.2,v 3.0 89/10/18 15:21:37 lwall Locked $ ''' ''' $Log: perl.man.2,v $ -''' 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 2.0 88/06/05 00:09:30 root -''' Baseline version 2.0. +''' Revision 3.0 89/10/18 15:21:37 lwall +''' 3.0 baseline ''' ''' -.Ip "goto LABEL" 8 6 -Finds the statement labeled with LABEL and resumes execution there. -Currently you may only go to statements in the main body of the program -that are not nested inside a do {} construct. -This statement is not implemented very efficiently, and is here only to make -the sed-to-perl translator easier. -Use at your own risk. -.Ip "hex(EXPR)" 8 2 -Returns the decimal value of EXPR interpreted as an hex string. -(To interpret strings that might start with 0 or 0x see oct().) -.Ip "index(STR,SUBSTR)" 8 4 -Returns the position of SUBSTR in STR, based at 0, or whatever you've -set the $[ variable to. -If the substring is not found, returns one less than the base, ordinarily -1. -.Ip "int(EXPR)" 8 3 -Returns the integer portion of EXPR. -.Ip "join(EXPR,LIST)" 8 8 -.Ip "join(EXPR,ARRAY)" 8 -Joins the separate strings of LIST or ARRAY into a single string with fields -separated by the value of EXPR, and returns the string. -Example: +.PP +Along with the literals and variables mentioned earlier, +the operations in the following section 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 array values; +the array values will be included in the list as if each individual element were +interpolated at that point in the list, forming a longer single-dimensional +array value. +Elements of the LIST should be separated by commas. +If an operation is listed both with and without parentheses around its +arguments, it means you can either use it as a unary operator or +as a function call. +To use it as a function call, the next token on the same line must +be a left parenthesis. +(There may be intervening white space.) +Such a function then has highest precedence, as you would expect from +a function. +If any token other than a left parenthesis follows, then it is a +unary operator, with a precedence depending only on whether it is a LIST +operator or not. +LIST operators have lowest precedence. +All other unary operators have a precedence greater than relational operators +but less than arithmetic operators. +See the section on Precedence. +.Ip "/PATTERN/" 8 4 +See m/PATTERN/. +.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 occurrence of +something in each file of a set of files, for instance. +Only ?? patterns local to the current package are reset. +.Ip "accept(NEWSOCKET,GENERICSOCKET)" 8 2 +Does the same thing that the accept system call does. +Returns true if it succeeded, false otherwise. +See example in section on Interprocess Communication. +.Ip "atan2(X,Y)" 8 2 +Returns the arctangent of X/Y in the range +.if t \-\(*p to \(*p. +.if n \-PI to PI. +.Ip "bind(SOCKET,NAME)" 8 2 +Does the same thing that the bind system call does. +Returns true if it succeeded, false otherwise. +NAME should be a packed address of the proper type for the socket. +See example in section on Interprocess Communication. +.Ip "chdir(EXPR)" 8 2 +.Ip "chdir EXPR" 8 2 +Changes the working directory to EXPR, if possible. +If EXPR is omitted, changes to home directory. +Returns 1 upon success, 0 otherwise. +See example under +.IR die . +.Ip "chmod(LIST)" 8 2 +.Ip "chmod LIST" 8 2 +Changes the permissions of a list of files. +The first element of the list must be the numerical mode. +Returns the number of files successfully changed. .nf - - $_ = join(\|':', $login,$passwd,$uid,$gid,$gcos,$home,$shell); + +.ne 2 + $cnt = chmod 0755, \'foo\', \'bar\'; + chmod 0755, @executables; .fi -See -.IR split . -.Ip "keys(ASSOC_ARRAY)" 8 6 -Returns a normal array consisting of all the keys of the named associative -array. -The keys are returned in an apparently random order, but it is the same order -as either the values() or each() function produces (given that the associative array -has not been modified). -Here is yet another way to print your environment: +.Ip "chop(LIST)" 8 7 +.Ip "chop(VARIABLE)" 8 +.Ip "chop VARIABLE" 8 +.Ip "chop" 8 +Chops off the last character of a string and returns the character chopped. +It's used primarily to remove the newline from the end of an input record, +but is much more efficient than s/\en// because it neither scans nor copies +the string. +If VARIABLE is omitted, chops $_. +Example: .nf .ne 5 - @keys = keys(ENV); - @values = values(ENV); - while ($#keys >= 0) { - print pop(keys),'=',pop(values),"\en"; + while (<>) { + chop; # avoid \en on last field + @array = split(/:/); + .\|.\|. } -or how about sorted by key: +.fi +You can actually chop anything that's an lvalue, including an assignment: +.nf -.ne 3 - foreach $key (sort keys(ENV)) { - print $key,'=',$ENV{$key},"\en"; - } + chop($cwd = \`pwd\`); + chop($answer = ); .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. -Returns the number of processes successfully signaled. +If you chop a list, each element is chopped. +Only the value of the last chop is returned. +.Ip "chown(LIST)" 8 2 +.Ip "chown LIST" 8 2 +Changes the owner (and group) of a list of files. +The first two elements of the list must be the NUMERICAL uid and gid, +in that order. +Returns the number of files successfully changed. .nf - $cnt = kill 1,$child1,$child2; - kill 9,@goners; +.ne 2 + $cnt = chown $uid, $gid, \'foo\', \'bar\'; + chown $uid, $gid, @filenames; .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 -.I last -command is like the -.I break -statement in C (as used in loops); it immediately exits the loop in question. -If the LABEL is omitted, the command refers to the innermost enclosing loop. -The -.I continue -block, if any, is not executed: +.ne 23 +Here's an example of looking up non-numeric uids: .nf -.ne 4 - line: while () { - last line if /\|^$/; # exit when done with header - .\|.\|. + print "User: "; + $user = ; + chop($user); + print "Files: " + $pattern = ; + chop($pattern); + open(pass, \'/etc/passwd\') || die "Can't open passwd: $!\en"; + while () { + ($login,$pass,$uid,$gid) = split(/:/); + $uid{$login} = $uid; + $gid{$login} = $gid; + } + @ary = <$pattern>; # get filenames + if ($uid{$user} eq \'\') { + die "$user not in passwd file"; + } + else { + chown $uid{$user}, $gid{$user}, @ary; } .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: +.Ip "chroot(FILENAME)" 8 5 +.Ip "chroot FILENAME" 8 +Does the same as the system call of that name. +If you don't know what it does, don't worry about it. +If FILENAME is omitted, does chroot to $_. +.Ip "close(FILEHANDLE)" 8 5 +.Ip "close FILEHANDLE" 8 +Closes the file or pipe associated with the file handle. +You don't have to close FILEHANDLE if you are immediately going to +do another open on it, since open will close it for you. +(See +.IR open .) +However, an explicit close on an input file resets the line counter ($.), while +the implicit close done by +.I open +does not. +Also, closing a pipe will wait for the process executing on the pipe to complete, +in case you want to look at the output of the pipe afterwards. +Closing a pipe explicitly also puts the status value of the command into $?. +Example: .nf -.ne 13 - sub RANGEVAL { - local($min, $max, $thunk) = @_; - local($result) = ''; - local($i); - - # Presumably $thunk makes reference to $i +.ne 4 + open(OUTPUT, \'|sort >foo\'); # pipe to sort + .\|.\|. # print stuff to output + close OUTPUT; # wait for sort to finish + open(INPUT, \'foo\'); # get sort's results - for ($i = $min; $i < $max; $i++) { - $result .= eval $thunk; - } +.fi +FILEHANDLE may be an expression whose value gives the real filehandle name. +.Ip "closedir(DIRHANDLE)" 8 5 +.Ip "closedir DIRHANDLE" 8 +Closes a directory opened by opendir(). +.Ip "connect(SOCKET,NAME)" 8 2 +Does the same thing that the connect system call does. +Returns true if it succeeded, false otherwise. +NAME should be a package address of the proper type for the socket. +See example in section on Interprocess Communication. +.Ip "cos(EXPR)" 8 6 +.Ip "cos EXPR" 8 6 +Returns the cosine of EXPR (expressed in radians). +If EXPR is omitted takes cosine of $_. +.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 "dbmclose(ASSOC_ARRAY)" 8 6 +.Ip "dbmclose ASSOC_ARRAY" 8 +Breaks the binding between a dbm file and an associative array. +The values remaining in the associative array are meaningless unless +you happen to want to know what was in the cache for the dbm file. +This function is only useful if you have ndbm. +.Ip "dbmopen(ASSOC,DBNAME,MODE)" 8 6 +This binds a dbm or ndbm file to an associative array. +ASSOC is the name of the associative array. +(Unlike normal open, the first argument is NOT a filehandle, even though +it looks like one). +DBNAME is the name of the database (without the .dir or .pag extension). +If the database does not exist, it is created with protection specified +by MODE (as modified by the umask). +If your system only supports the older dbm functions, you may only have one +dbmopen in your program. +If your system has neither dbm nor ndbm, calling dbmopen produces a fatal +error. +.Sp +Values assigned to the associative array prior to the dbmopen are lost. +A certain number of values from the dbm file are cached in memory. +By default this number is 64, but you can increase it by preallocating +that number of garbage entries in the associative array before the dbmopen. +You can flush the cache if necessary with the reset command. +.Sp +If you don't have write access to the dbm file, you can only read +associative array variables, not set them. +If you want to test whether you can write, either use file tests or +try setting a dummy array entry inside an eval, which will trap the error. +.Sp +Note that functions such as keys() and values() may return huge array values +when used on large dbm files. +You may prefer to use the each() function to iterate over large dbm files. +Example: +.nf - $result; +.ne 6 + # print out history file offsets + dbmopen(HIST,'/usr/lib/news/history',0666); + while (($key,$val) = each %HIST) { + print $key, ' = ', unpack('L',$val), "\en"; } + dbmclose(HIST); .fi -.Ip "localtime(EXPR)" 8 4 -Converts a time as returned by the time function to a 9-element array with -the time analyzed for the local timezone. -Typically used as follows: +.Ip "defined(EXPR)" 8 6 +.Ip "defined EXPR" 8 +Returns a boolean value saying whether the lvalue EXPR has a real value +or not. +Many operations return the undefined value under exceptional conditions, +such as end of file, uninitialized variable, system error and such. +This function allows you to distinguish between an undefined null string +and a defined null string with operations that might return a real null +string, in particular referencing elements of an array. +You may also check to see if arrays or subroutines exist. +Use on predefined variables is not guaranteed to produce intuitive results. +Examples: .nf -.ne 3 - ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) - = localtime(time); +.ne 7 + print if defined $switch{'D'}; + print "$val\en" while defined($val = pop(@ary)); + die "Can't readlink $sym: $!" + unless defined($value = readlink $sym); + eval '@foo = ()' if defined(@foo); + die "No XYZ package defined" unless defined %_XYZ; + sub foo { defined &bar ? &bar(@_) : die "No bar"; } .fi -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 -.Ip "next" 8 -The -.I next -command is like the -.I continue -statement in C; it starts the next iteration of the loop: +See also undef. +.Ip "delete $ASSOC{KEY}" 8 6 +Deletes the specified value from the specified associative array. +Returns the deleted value, or the undefined value if nothing was deleted. +Deleting from $ENV{} modifies the environment. +Deleting from an array bound to a dbm file deletes the entry from the dbm +file. +.Sp +The following deletes all the values of an associative array: .nf -.ne 4 - line: while () { - next line if /\|^#/; # discard comments - .\|.\|. +.ne 3 + foreach $key (keys %ARRAY) { + delete $ARRAY{$key}; } .fi -Note that if there were a -.I continue -block on the above, it would get executed even on discarded lines. -If the LABEL is omitted, the command refers to the innermost enclosing loop. -.Ip "oct(EXPR)" 8 2 -Returns the decimal value of EXPR interpreted as an octal string. -(If EXPR happens to start off with 0x, interprets it as a hex string instead.) -The following will handle decimal, octal and hex in the standard notation: +(But it would be faster to use the +.I reset +command. +Saying undef %ARRAY is faster yet.) +.Ip "die(LIST)" 8 +.Ip "die LIST" 8 +Prints the value of LIST to +.I 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 - $val = oct($val) if $val =~ /^0/; - -.fi -.Ip "open(FILEHANDLE,EXPR)" 8 8 -.Ip "open(FILEHANDLE)" 8 -.Ip "open FILEHANDLE" 8 -Opens the file whose filename is given by EXPR, and associates it with -FILEHANDLE. -If 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. -If the filename begins with \*(L"|\*(R", the filename is interpreted -as a command to which output is to be piped, and if the filename ends -with a \*(L"|\*(R", the filename is interpreted as command which pipes -input to us. -(You may not have a command that pipes both in and out.) -Opening '\-' opens stdin and opening '>\-' opens stdout. -Open returns 1 upon success, '' otherwise. -Examples: -.nf - .ne 3 - $article = 100; - open article || die "Can't find article $article"; - while (
) {\|.\|.\|. - - open(LOG, '>>/usr/spool/news/twitlog'\|); # (log is reserved) + die "Can't cd to spool: $!\en" unless chdir \'/usr/spool/news\'; - open(article, "caeser <$article |"\|); # decrypt article + chdir \'/usr/spool/news\' || die "Can't cd to spool: $!\en" - open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process# +.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 - # process argument list of files along with any includes + die "/etc/games is no good"; + die "/etc/games is no good, stopped"; - foreach $file (@ARGV) { - do process($file,'fh00'); # no pun intended - } +produce, respectively - 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 - } - }} + /etc/games is no good at canasta line 123. + /etc/games is no good, stopped at canasta line 123. .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: +See also +.IR exit . +.Ip "do BLOCK" 8 4 +Returns the value of the last command in the sequence of commands indicated +by BLOCK. +When modified by a loop modifier, executes the BLOCK once before testing the +loop condition. +(On other statements the loop modifiers test the conditional first.) +.Ip "do SUBROUTINE (LIST)" 8 3 +Executes a SUBROUTINE declared by a +.I sub +declaration, and returns the value +of the last expression evaluated in SUBROUTINE. +If there is no subroutine by that name, produces a fatal error. +(You may use the \*(L"defined\*(R" operator to determine if a subroutine +exists.) +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 \*(L"do EXPR\*(R" +form. +.Sp +As an alternate form, you may call a subroutine by prefixing the name with +an ampersand: &foo(@args). +If you aren't passing any arguments, you don't have to use parentheses. +If you omit the parentheses, no @_ array is passed to the subroutine. +The & form is also used to specify subroutines to the defined and undef +operators. +.Ip "do EXPR" 8 3 +Uses the value of EXPR as a filename and executes the contents of the file +as a +.I perl +script. +Its primary use is to include subroutines from a +.I perl +subroutine library. .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 + do \'stat.pl\'; - print stdout "stdout 1\en"; # this works for - print stderr "stderr 1\en"; # subprocesses too +is just like - close(stdout); - close(stderr); - - open(stdout,">&saveout"); - open(stderr,">&saveerr"); - - print stdout "stdout 2\en"; - print stderr "stderr 2\en"; + eval \`cat stat.pl\`; .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: +except that it's more efficient, more concise, keeps track of the current +filename for error messages, and searches all the +.B \-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 \-P and #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 5 - open(FOO,"|tr '[a-z]' '[A-Z]'"); - open(FOO,"|-") || exec 'tr', '[a-z]', '[A-Z]'; - - open(FOO,"cat -n $file|"); - open(FOO,"-|") || exec 'cat', '-n', $file; +.ne 2 + do $foo; # eval a file + do $foo(); # call a subroutine .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. -Has the same effect as +.Ip "dump LABEL" 8 6 +This causes an immediate core dump. +Primarily this is so that you can use the undump program to turn your +core dump into an executable binary after having initialized all your +variables at the beginning of the program. +When the new binary is executed it will begin by executing a "goto LABEL" +(with all the restrictions that goto suffers). +Think of it as a goto with an intervening core dump and reincarnation. +If LABEL is omitted, restarts the program from the top. +WARNING: any files opened at the time of the dump will NOT be open any more +when the program is reincarnated, with possible resulting confusion on the part +of perl. +See also \-u. +.Sp +Example: .nf - $tmp = $ARRAY[$#ARRAY]; $#ARRAY--; +.ne 16 + #!/usr/bin/perl + do 'getopt.pl'; + do 'stat.pl'; + %days = ( + 'Sun',1, + 'Mon',2, + 'Tue',3, + 'Wed',4, + 'Thu',5, + 'Fri',6, + 'Sat',7); + + dump QUICKSTART if $ARGV[0] eq '-d'; + + QUICKSTART: + do Getopt('f'); .fi -.Ip "print FILEHANDLE LIST" 8 9 -.Ip "print LIST" 8 -.Ip "print" 8 -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. -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 \*(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 the length of LIST. -Has the same effect as +.Ip "each(ASSOC_ARRAY)" 8 6 +.Ip "each ASSOC_ARRAY" 8 +Returns a 2 element array consisting of the key and value for the next +value of an associative array, so that you can iterate over it. +Entries are returned in an apparently random order. +When the array is entirely read, a null array is returned (which when +assigned produces a FALSE (0) value). +The next call to each() after that will start iterating again. +The iterator can be reset only by reading all the elements from the array. +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 - for $value (LIST) { - $ARRAY[$#ARRAY+1] = $value; - } +.ne 3 + while (($key,$value) = each %ENV) { + print "$key=$value\en"; + } .fi -but is more efficient. -.Ip "redo LABEL" 8 8 -.Ip "redo" 8 -The -.I redo -command restarts the loop block without evaluating the conditional again. -The -.I continue -block, if any, is not executed. -If the LABEL is omitted, the command refers to the innermost enclosing loop. -This command is normally used by programs that want to lie to themselves -about what was just input: +See also keys() and values(). +.Ip "eof(FILEHANDLE)" 8 8 +.Ip "eof()" 8 +.Ip "eof" 8 +Returns 1 if the next read on FILEHANDLE will return end of file, or if +FILEHANDLE is not open. +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 to detect the end of only the last file. +Use eof(ARGV) or eof without the parentheses to test EACH file in a while (<>) loop. +Examples: .nf -.ne 16 - # a simpleminded Pascal comment stripper - # (warning: assumes no { or } in strings) - line: while () { - while (s|\|({.*}.*\|){.*}|$1 \||) {} - s|{.*}| \||; - if (s|{.*| \||) { - $front = $_; - while () { - if (\|/\|}/\|) { # end of comment? - s|^|$front{|; - redo line; - } - } +.ne 7 + # insert dashes just before last line of last file + while (<>) { + if (eof()) { + print "\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\en"; } print; } +.ne 7 + # reset line numbering on each input file + while (<>) { + print "$.\et$_"; + if (eof) { # Not eof(). + close(ARGV); + } + } + .fi -.Ip "rename(OLDNAME,NEWNAME)" 8 2 -Changes the name of a file. -Returns 1 for success, 0 otherwise. -.Ip "reset EXPR" 8 3 -Generally used in a -.I continue -block at the end of a loop to clear variables and reset ?? searches -so that they work again. -The expression is interpreted as a list of single characters (hyphens allowed -for ranges). -All 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. +.Ip "eval(EXPR)" 8 6 +.Ip "eval EXPR" 8 6 +EXPR is parsed and executed as if it were a little +.I perl +program. +It is executed in the context of the current +.I perl +program, so that +any variable settings, subroutine or format definitions remain afterwards. +The value returned is the value of the last expression evaluated, just +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 $_. +The final semicolon, if any, may be omitted from the expression. +.Sp +Note that, since eval traps otherwise-fatal errors, it is useful for +determining whether a particular feature +(such as dbmopen or symlink) is implemented. +.Ip "exec(LIST)" 8 8 +.Ip "exec LIST" 8 6 +If there is more than one argument in LIST, or if LIST is an array with +more than one value, +calls execvp() with the arguments in LIST. +If there is only one scalar argument, the argument is checked for shell metacharacters. +If there are any, the entire argument is passed to \*(L"/bin/sh \-c\*(R" for parsing. +If there are none, the argument is split into words and passed directly to +execvp(), which is more efficient. +Note: exec (and system) do not flush your output buffer, so you may need to +set $| to avoid lost output. Examples: .nf -.ne 3 - reset 'X'; \h'|2i'# reset all X variables - reset 'a-z';\h'|2i'# reset lower case variables - reset; \h'|2i'# just reset ?? searches + exec \'/bin/echo\', \'Your arguments are: \', @ARGV; + exec "sort $outfile | uniq"; .fi -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 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. -See also the section on regular expressions. -Examples: +.Sp +If you don't really want to execute the first argument, but want to lie +to the program you are executing about its own name, you can specify +the program you actually want to run by assigning that to a variable and +putting the name of the variable in front of the LIST without a comma. +(This always forces interpretation of the LIST as a multi-valued list, even +if there is only a single scalar in the list.) +Example: .nf - s/\|\e\|bgreen\e\|b/mauve/g; # don't change wintergreen - - $path \|=~ \|s|\|/usr/bin|\|/usr/local/bin|; - - s/Login: $foo/Login: $bar/; # run-time pattern +.ne 2 + $shell = '/bin/csh'; + exec $shell '-sh'; # pretend it's a login shell - s/\|([^ \|]*\|) *\|([^ \|]*\|)\|/\|$2 $1/; # reverse 1st two fields +.fi +.Ip "exit(EXPR)" 8 6 +.Ip "exit EXPR" 8 +Evaluates EXPR and exits immediately with that value. +Example: +.nf - ($foo = $bar) =~ s/bar/foo/; +.ne 2 + $ans = ; + exit 0 \|if \|$ans \|=~ \|/\|^[Xx]\|/\|; .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. -This has two effects: first, a -.I write -or a -.I print -without a filehandle will default to this FILEHANDLE. -Second, references to variables related to output will refer to this output -channel. -For example, if you have to set the top of form format for more than -one output channel, you might do the following: +See also +.IR die . +If EXPR is omitted, exits with 0 status. +.Ip "exp(EXPR)" 8 3 +.Ip "exp EXPR" 8 +Returns +.I e +to the power of EXPR. +If EXPR is omitted, gives exp($_). +.Ip "fcntl(FILEHANDLE,FUNCTION,SCALAR)" 8 4 +Implements the fcntl(2) function. +You'll probably have to say .nf -.ne 4 - select(report1); - $^ = 'report1_top'; - select(report2); - $^ = 'report2_top'; + do "fcntl.h"; # probably /usr/local/lib/perl/fcntl.h .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 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() -and pop() do to the right end. -.Ip "sleep EXPR" 8 6 -.Ip "sleep" 8 -Causes the script to sleep for EXPR seconds, or forever if no EXPR. -May be interrupted by sending the process a SIGALARM. -Returns the number of seconds actually slept. -.Ip "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: +first to get the correct function definitions. +If fcntl.h doesn't exist or doesn't have the correct definitions +you'll have to roll +your own, based on your C header files such as . +(There is a perl script called makelib that comes with the perl kit +which may help you in this.) +Argument processing and value return works just like ioctl below. +Note that fcntl will produce a fatal error if used on a machine that doesn't implement +fcntl(2). +.Ip "fileno(FILEHANDLE)" 8 4 +Returns the file descriptor for a filehandle. +Useful for constructing bitmaps for select(). +If FILEHANDLE is an expression, the value is taken as the name of +the filehandle. +.Ip "flock(FILEHANDLE,OPERATION)" 8 4 +Calls flock(2) on FILEHANDLE. +See manual page for flock(2) for definition of OPERATION. +Will produce a fatal error if used on a machine that doesn't implement +flock(2). +Here's a mailbox appender for BSD systems. .nf -.ne 4 - sub byage { - $age{$a} < $age{$b} ? -1 : $age{$a} > $age{$b} ? 1 : 0; +.ne 20 + $LOCK_SH = 1; + $LOCK_EX = 2; + $LOCK_NB = 4; + $LOCK_UN = 8; + + sub lock { + flock(MBOX,$LOCK_EX); + # and, in case someone appended + # while we were waiting... + seek(MBOX, 0, 2); } - @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 + sub unlock { + flock(MBOX,$LOCK_UN); + } -.fi -.Ip "split(/PATTERN/,EXPR)" 8 8 -.Ip "split(/PATTERN/)" 8 -.Ip "split" 8 -Splits a string into an array of strings, and returns it. -If EXPR is omitted, splits the $_ string. -If PATTERN is also omitted, splits on whitespace (/[\ \et\en]+/). -Anything matching PATTERN is taken to be a delimiter separating the fields. -(Note that the delimiter may be longer than one character.) -Trailing null fields are stripped, which potential users of pop() would -do well to remember. -A pattern matching the null string (not to be confused with a null pattern) -will split the value of EXPR into separate characters at each point it -matches that way. -For example: -.nf + open(MBOX, ">>/usr/spool/mail/$USER") + || die "Can't open mailbox: $!"; - print join(':',split(/ */,'hi there')); + do lock(); + print MBOX $msg,"\en\en"; + do unlock(); .fi -produces the output 'h:i:t:h:e:r:e'. - -The pattern /PATTERN/ may be replaced with an expression to specify patterns -that vary at runtime. -As a special case, specifying a space ('\ ') will split on white space -just as split with no arguments does, but leading white space does NOT -produce a null first field. -Thus, split('\ ') can be used to emulate awk's default behavior, whereas -split(/\ /) will give you as many null initial fields as there are -leading spaces. -.sp -Example: +.Ip "fork" 8 4 +Does a fork() call. +Returns the child pid to the parent process and 0 to the child process. +Note: unflushed buffers remain unflushed in both processes, which means +you may need to set $| to avoid duplicate output. +.Ip "getc(FILEHANDLE)" 8 4 +.Ip "getc FILEHANDLE" 8 +.Ip "getc" 8 +Returns the next character from the input file attached to FILEHANDLE, or +a null string at EOF. +If FILEHANDLE is omitted, reads from STDIN. +.Ip "getlogin" 8 3 +Returns the current login from /etc/utmp, if any. +If null, use getpwuid. + + ($login = getlogin) || (($login) = getpwuid($<)); + +.Ip "getpeername(SOCKET)" 8 3 +Returns the packed sockaddr address of other end of the SOCKET connection. .nf -.ne 5 - open(passwd, '/etc/passwd'); - while () { -.ie t \{\ - ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(\|/\|:\|/\|); -'br\} -.el \{\ - ($login, $passwd, $uid, $gid, $gcos, $home, $shell) - = split(\|/\|:\|/\|); -'br\} - .\|.\|. - } +.ne 4 + # An internet sockaddr + $sockaddr = 'S n a4 x8'; + $hersockaddr = getpeername(S); + ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr); .fi -(Note that $shell above will still have a newline on it. See chop().) -See also -.IR join . -.Ip "sprintf(FORMAT,LIST)" 8 4 -Returns a string formatted by the usual printf conventions. -The * character is not supported. -.Ip "sqrt(EXPR)" 8 3 -Return the square root of EXPR. -.Ip "stat(FILEHANDLE)" 8 6 -.Ip "stat(EXPR)" 8 -Returns a 13-element array giving the statistics for a file, either the file -opened via FILEHANDLE, or named by EXPR. -Typically used as follows: +.Ip "getpgrp(PID)" 8 4 +.Ip "getpgrp PID" 8 +Returns the current process group for the specified PID, 0 for the current +process. +Will produce a fatal error if used on a machine that doesn't implement +getpgrp(2). +If EXPR is omitted, returns process group of current process. +.Ip "getppid" 8 4 +Returns the process id of the parent process. +.Ip "getpriority(WHICH,WHO)" 8 4 +Returns the current priority for a process, a process group, or a user. +(See getpriority(2).) +Will produce a fatal error if used on a machine that doesn't implement +getpriority(2). +.Ip "getpwnam(NAME)" 8 +.Ip "getgrnam(NAME)" 8 +.Ip "gethostbyname(NAME)" 8 +.Ip "getnetbyname(NAME)" 8 +.Ip "getprotobyname(NAME)" 8 +.Ip "getpwuid(UID)" 8 +.Ip "getgrgid(GID)" 8 +.Ip "getservbyname(NAME,PROTO)" 8 +.Ip "gethostbyaddr(ADDR,ADDRTYPE)" 8 +.Ip "getnetbyaddr(ADDR,ADDRTYPE)" 8 +.Ip "getprotobynumber(NUMBER)" 8 +.Ip "getservbyport(PORT,PROTO)" 8 +.Ip "getpwent()" 8 +.Ip "getgrent()" 8 +.Ip "gethostent()" 8 +.Ip "getnetent()" 8 +.Ip "getprotoent()" 8 +.Ip "getservent()" 8 +.Ip "setpwent()" 8 +.Ip "setgrent()" 8 +.Ip "sethostent(STAYOPEN)" 8 +.Ip "setnetent(STAYOPEN)" 8 +.Ip "setprotoent(STAYOPEN)" 8 +.Ip "setservent(STAYOPEN)" 8 +.Ip "endpwent()" 8 +.Ip "endgrent()" 8 +.Ip "endhostent()" 8 +.Ip "endnetent()" 8 +.Ip "endprotoent()" 8 +.Ip "endservent()" 8 +These routines perform the same functions as their counterparts in the +system library. +The return values from the various get routines are as follows: .nf -.ne 3 - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) - = stat($filename); + ($name,$passwd,$uid,$gid, + $quota,$comment,$gcos,$dir,$shell) = getpw.\|.\|. + ($name,$passwd,$gid,$members) = getgr.\|.\|. + ($name,$aliases,$addrtype,$length,@addrs) = gethost.\|.\|. + ($name,$aliases,$addrtype,$net) = getnet.\|.\|. + ($name,$aliases,$proto) = getproto.\|.\|. + ($name,$aliases,$port,$proto) = getserv.\|.\|. .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.) +The $members value returned by getgr.\|.\|. is a space separated list +of the login names of the members of the group. .Sp -For example, here is a loop which inserts index producing entries before an line -containing a certain pattern: +The @addrs value returned by the gethost.\|.\|. functions is a list of the +raw addresses returned by the corresponding system library call. +In the Internet domain, each address is four bytes long and you can unpack +it by saying something like: .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; - } + ($a,$b,$c,$d) = unpack('C4',$addr[0]); .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: +.Ip "getsockname(SOCKET)" 8 3 +Returns the packed sockaddr address of this end of the SOCKET connection. .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"; - } +.ne 4 + # An internet sockaddr + $sockaddr = 'S n a4 x8'; + $mysockaddr = getsockname(S); + ($family, $port, $myaddr) = unpack($sockaddr,$mysockaddr); .fi -.Ip "substr(EXPR,OFFSET,LEN)" 8 2 -Extracts a substring out of EXPR and returns it. -First character is at offset 0, or whatever you've set $[ to. -.Ip "system LIST" 8 6 -Does exactly the same thing as \*(L"exec LIST\*(R" except that a fork -is done first, and the parent process waits for the child process to complete. -Note that argument processing varies depending on the number of arguments. -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: +.Ip "getsockopt(SOCKET,LEVEL,OPTNAME)" 8 3 +Returns the socket option requested, or undefined if there is an error. +.Ip "gmtime(EXPR)" 8 4 +.Ip "gmtime EXPR" 8 +Converts a time as returned by the time function to a 9-element array with +the time analyzed for the Greenwich timezone. +Typically used as follows: .nf - $symlink_exists = (eval 'symlink("","");', $@ eq ''); +.ne 3 + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); .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. -Suitable for feeding to gmtime() and localtime(). -.Ip "times" 8 4 -Returns a four-element array giving the user and system times, in seconds, for this -process and the children of this process. -.sp - ($user,$system,$cuser,$csystem) = times; -.sp -.Ip "tr/SEARCHLIST/REPLACEMENTLIST/" 8 5 -.Ip "y/SEARCHLIST/REPLACEMENTLIST/" 8 -Translates all occurences of the characters found in the search list with -the corresponding character in the replacement list. -It returns the number of characters replaced. -If no string is specified via the =~ or !~ operator, -the $_ string is translated. -(The string specified with =~ must be a scalar variable, an array element, -or an assignment to one of those, i.e. an lvalue.) -For +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. +If EXPR is omitted, does gmtime(time). +.Ip "goto LABEL" 8 6 +Finds the statement labeled with LABEL and resumes execution there. +Currently you may only go to statements in the main body of the program +that are not nested inside a do {} construct. +This statement is not implemented very efficiently, and is here only to make +the +.IR sed -to- perl +translator easier. +I may change its semantics at any time, consistent with support for translated .I sed -devotees, -.I y -is provided as a synonym for -.IR tr . -Examples: +scripts. +Use it at your own risk. +Better yet, don't use it at all. +.Ip "grep(EXPR,LIST)" 8 4 +Evaluates EXPR for each element of LIST (locally setting $_ to each element) +and returns the array value consisting of those elements for which the +expression evaluated to true. .nf - $ARGV[1] \|=~ \|y/A-Z/a-z/; \h'|3i'# canonicalize to lower case - - $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 + @foo = grep(!/^#/, @bar); # weed out comments .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. -Returns the number of files successfully deleted. +.Ip "hex(EXPR)" 8 4 +.Ip "hex EXPR" 8 +Returns the decimal value of EXPR interpreted as an hex string. +(To interpret strings that might start with 0 or 0x see oct().) +If EXPR is omitted, uses $_. +.Ip "ioctl(FILEHANDLE,FUNCTION,SCALAR)" 8 4 +Implements the ioctl(2) function. +You'll probably have to say .nf -.ne 2 - $cnt = unlink 'a','b','c'; - unlink @goners; - unlink <*.bak>; + do "ioctl.h"; # probably /usr/local/lib/perl/ioctl.h .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. +first to get the correct function definitions. +If ioctl.h doesn't exist or doesn't have the correct definitions +you'll have to roll +your own, based on your C header files such as . +(There is a perl script called makelib that comes with the perl kit +which may help you in this.) +SCALAR will be read and/or written depending on the FUNCTION\*(--a pointer +to the string value of SCALAR will be passed as the third argument of +the actual ioctl call. +(If SCALAR has no string value but does have a numeric value, that value +will be passed rather than a pointer to the string value. +To guarantee this to be true, add a 0 to the scalar before using it.) +The pack() and unpack() functions are useful for manipulating the values +of structures used by ioctl(). +The following example sets the erase character to DEL. .nf - unshift(ARGV,'-e') unless $ARGV[0] =~ /^-/; +.ne 9 + do 'ioctl.h'; + $sgttyb_t = "ccccs"; # 4 chars and a short + if (ioctl(STDIN,$TIOCGETP,$sgttyb)) { + @ary = unpack($sgttyb_t,$sgttyb); + $ary[2] = 127; + $sgttyb = pack($sgttyb_t,@ary); + ioctl(STDIN,$TIOCSETP,$sgttyb) + || die "Can't ioctl: $!"; + } .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: +The return value of ioctl (and fcntl) is as follows: .nf -.ne 3 - #!/usr/bin/perl - $now = time; - utime $now,$now,@ARGV; +.ne 4 + if OS returns:\h'|3i'perl returns: + -1\h'|3i' undefined value + 0\h'|3i' string "0 but true" + anything else\h'|3i' that number .fi -.Ip "values(ASSOC_ARRAY)" 8 6 -Returns a normal array consisting of all the values of the named associative -array. -The values are returned in an apparently random order, but it is the same order -as either the keys() or each() function produces (given that the associative array -has not been modified). -See also keys() and each(). -.Ip "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 -Writes a formatted record (possibly multi-line) to the specified file, -using the format associated with that file. -By default the format for a file is the one having the same name is the -filehandle, but the format for the current output channel (see -.IR select ) -may be set explicitly -by assigning the name of the format to the $~ variable. -.sp -Top of form processing is handled automatically: -if there is insufficient room on the current page for the formatted -record, the page is advanced, a special top-of-page format is used -to format the new page header, and then the record is written. -By default the top-of-page format is \*(L"top\*(R", but it -may be set to the -format of your choice by assigning the name to the $^ variable. -.sp -If FILEHANDLE is unspecified, output goes to the current default output channel, -which starts out as stdout but may be changed by the -.I select -operator. -If the FILEHANDLE is an EXPR, then the expression is evaluated and the -resulting string is used to look up the name of the FILEHANDLE at run time. -For more on formats, see the section on formats later on. -.Sh "Precedence" -Perl operators have the following associativity and precedence: +Thus perl returns true on success and false on failure, yet you can still +easily determine the actual value returned by the operating system: .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''(' - + ($retval = ioctl(...)) || ($retval = -1); + printf "System returned %d\en", $retval; .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: +.Ip "index(STR,SUBSTR)" 8 4 +Returns the position of the first occurrence of SUBSTR in STR, based at 0, or whatever you've +set the $[ variable to. +If the substring is not found, returns one less than the base, ordinarily \-1. +.Ip "int(EXPR)" 8 4 +.Ip "int EXPR" 8 +Returns the integer portion of EXPR. +If EXPR is omitted, uses $_. +.Ip "join(EXPR,LIST)" 8 8 +.Ip "join(EXPR,ARRAY)" 8 +Joins the separate strings of LIST or ARRAY into a single string with fields +separated by the value of EXPR, and returns the string. +Example: .nf - - sub NAME BLOCK + + $_ = join(\|\':\', $login,$passwd,$uid,$gid,$gcos,$home,$shell); .fi -.PP -Any arguments passed to the routine come in as array @_, -that is ($_[0], $_[1], .\|.\|.). -The return value of the subroutine is the value of the last expression -evaluated. -To create local variables see the \*(L"local\*(R" operator. -.PP -A subroutine is called using the -.I do -operator. +See +.IR split . +.Ip "keys(ASSOC_ARRAY)" 8 6 +.Ip "keys ASSOC_ARRAY" 8 +Returns a normal array consisting of all the keys of the named associative +array. +The keys are returned in an apparently random order, but it is the same order +as either the values() or each() function produces (given that the associative array +has not been modified). +Here is yet another way to print your environment: .nf -.ne 12 -Example: - - sub MAX { - local($max) = pop(@_); - foreach $foo (@_) { - $max = $foo \|if \|$max < $foo; - } - $max; +.ne 5 + @keys = keys %ENV; + @values = values %ENV; + while ($#keys >= 0) { + print pop(keys), \'=\', pop(values), "\en"; } - .\|.\|. - $bestday = do MAX($mon,$tue,$wed,$thu,$fri); - -.ne 21 -Example: - - # get a line, combining continuation lines - # that start with whitespace - sub get_line { - $thisline = $lookahead; - line: while ($lookahead = ) { - if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) { - $thisline \|.= \|$lookahead; - } - else { - last line; - } - } - $thisline; - } +or how about sorted by key: - $lookahead = ; # get first line - while ($_ = get_line(\|)) { - .\|.\|. +.ne 3 + foreach $key (sort(keys %ENV)) { + print $key, \'=\', $ENV{$key}, "\en"; } .fi +.Ip "kill(LIST)" 8 8 +.Ip "kill LIST" 8 2 +Sends a signal to a list of processes. +The first element of the list must be the signal to send. +Returns the number of processes successfully signaled. .nf -.ne 6 -Use array assignment to local list to name your formal arguments: - sub maybeset { - local($key,$value) = @_; - $foo{$key} = $value unless $foo{$key}; - } + $cnt = kill 1, $child1, $child2; + kill 9, @goners; .fi -Subroutines may be called recursively. -.Sh "Regular Expressions" -The patterns used in pattern matching are regular expressions such as -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. -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. -(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. -($0 normally returns the same thing, but don't depend on it.) -Alternatives may be separated by |. -Examples: +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.) +You may use a signal name in quotes. +.Ip "last LABEL" 8 8 +.Ip "last" 8 +The +.I last +command is like the +.I break +statement in C (as used in loops); it immediately exits the loop in question. +If the LABEL is omitted, the command refers to the innermost enclosing loop. +The +.I continue +block, if any, is not executed: .nf - - s/\|^\|([^ \|]*\|) \|*([^ \|]*\|)\|/\|$2 $1\|/; # swap first two words -.ne 5 - if (/\|Time: \|(.\|.\|):\|(.\|.\|):\|(.\|.\|)\|/\|) { - $hours = $1; - $minutes = $2; - $seconds = $3; +.ne 4 + line: while () { + last line if /\|^$/; # exit when done with header + .\|.\|. } .fi -By default, the ^ character matches only the beginning of the string, and -.I perl -does certain optimizations with the assumption that the string contains -only one line. -You may, however, wish to treat a string as a multi-line buffer, such that -the ^ will match after any newline within the string. -At the cost of a little more overhead, you can do this by setting the variable -$* to 1. -Setting it back to 0 makes -.I perl -revert to its old behavior. -.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 -operator may declared as follows: -.nf - -.ne 3 - format NAME = - FORMLIST - . - -.fi -If name is omitted, format \*(L"stdout\*(R" is defined. -FORMLIST consists of a sequence of lines, each of which may be of one of three -types: -.Ip 1. 4 -A comment. -.Ip 2. 4 -A \*(L"picture\*(R" line giving the format for one output line. -.Ip 3. 4 -An argument line supplying values to plug into a picture line. -.PP -Picture lines are printed exactly as they look, except for certain fields -that substitute values into the line. -Each picture field starts with either @ or ^. -The @ field (not to be confused with the array marker @) is the normal -case; ^ fields are used -to do rudimentary multi-line text block filling. -The length of the field is supplied by padding out the field -with multiple <, >, or | characters to specify, respectively, left justfication, -right justification, or centering. -If any of the values supplied for these fields contains a newline, only -the text up to the newline is printed. -The special field @* can be used for printing multi-line values. -It should appear by itself on a line. -.PP -The values are specified on the following line, in the same order as -the picture fields. -They must currently be either 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 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 variable is referenced, -more of the text can be printed. -Normally you would use a sequence of fields in a vertical stack to print -out a block of text. -If you like, you can end the final field with .\|.\|., which will appear in the -output if the text was too long to appear in its entirety. -.PP -Since use of ^ fields can produce variable length records if the text to be -formatted is short, you can suppress blank lines by putting the tilde (~) -character anywhere in the line. -(Normally you should put it in the front if possible.) -The tilde will be translated to a space upon output. -.PP +.Ip "length(EXPR)" 8 4 +.Ip "length EXPR" 8 +Returns the length in characters of the value of EXPR. +If EXPR is omitted, returns length of $_. +.Ip "link(OLDFILE,NEWFILE)" 8 2 +Creates a new filename linked to the old filename. +Returns 1 for success, 0 otherwise. +.Ip "listen(SOCKET,QUEUESIZE)" 8 2 +Does the same thing that the listen system call does. +Returns true if it succeeded, false otherwise. +See example in section on Interprocess Communication. +.Ip "local(LIST)" 8 4 +Declares the listed variables to be local to the enclosing block, +subroutine, eval or \*(L"do\*(R". +All the listed elements must be legal lvalues. +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. +This means that called subroutines can also reference the local variable, +but not the global one. +The LIST may be assigned to if desired, which allows you to initialize +your local variables. +(If no initializer is given, all scalars are initialized to the null string +and all arrays and associative arrays to the null array.) +Commonly this is used to name the parameters to a subroutine. Examples: .nf -.lg 0 -.cs R 25 - -.ne 10 -# a report on the /etc/passwd file -format top = -\& Passwd File -Name Login Office Uid Gid Home ------------------------------------------------------------------- -\&. -format stdout = -@<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<< -$name $login $office $uid $gid $home -\&. - -.ne 29 -# a report from a bug report form -format top = -\& Bug Reports -@<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>> -$system; $%; $date ------------------------------------------------------------------- -\&. -format stdout = -Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $subject -Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $index $description -Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $priority $date $description -From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $from $description -Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $programmer $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< -\& $description -\&~ ^<<<<<<<<<<<<<<<<<<<<<<<... -\& $description -\&. - -.cs R -.lg -It is possible to intermix prints with writes on the same output channel, -but you'll have to handle $\- (lines left on the page) yourself. -.fi -.PP -If you are printing lots of fields that are usually blank, you should consider -using the reset operator between records. -Not only is it more efficient, but it can prevent the bug of adding another -field and forgetting to zero it. -.Sh "Predefined Names" -The following names have special meaning to -.IR perl . -I could have used alphabetic symbols for some of these, but I didn't want -to take the chance that someone would say reset \*(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. -.Ip $_ 8 -The default input and pattern-searching space. -The following pairs are equivalent: -.nf -.ne 2 - while (<>) {\|.\|.\|. # only equivalent in while! - while ($_ = <>) {\|.\|.\|. +.ne 13 + sub RANGEVAL { + local($min, $max, $thunk) = @_; + local($result) = \'\'; + local($i); -.ne 2 - /\|^Subject:/ - $_ \|=~ \|/\|^Subject:/ + # Presumably $thunk makes reference to $i -.ne 2 - y/a-z/A-Z/ - $_ =~ y/a-z/A-Z/ + for ($i = $min; $i < $max; $i++) { + $result .= eval $thunk; + } -.ne 2 - chop - chop($_) - -.fi -(Mnemonic: underline is understood in certain operations.) -.Ip $. 8 -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. -Works like awk's RS variable, including treating blank lines as delimiters -if set to the null string. -If set to a value longer than one character, only the first character is used. -(Mnemonic: / is used to delimit line boundaries when quoting poetry.) -.Ip $, 8 -The output field separator for the print operator. -Ordinarily the print operator simply prints out the comma separated fields -you specify. -In order to get behavior more like awk, set this variable as you would set -awk's OFS variable to specify what is printed between fields. -(Mnemonic: what is printed when there is a , in your print statement.) -.Ip $\e 8 -The output record separator for the print operator. -Ordinarily the print operator simply prints out the comma separated fields -you specify, with no trailing newline or record separator assumed. -In order to get behavior more like awk, set this variable as you would set -awk's ORS variable to specify what is printed at the end of the print. -(Mnemonic: you set $\e instead of adding \en at the end of the print. -Also, it's just like /, but it's what you get \*(L"back\*(R" from perl.) -.Ip $# 8 -The output format for printed numbers. -This variable is a half-hearted attempt to emulate awk's OFMT variable. -There are times, however, when awk and perl have differing notions of what -is in fact numeric. -Also, the initial value is %.20g rather than %.6g, so you need to set $# -explicitly to get awk's value. -(Mnemonic: # is the number sign.) -.Ip $% 8 -The current page number of the currently selected output channel. -(Mnemonic: % is page number in nroff.) -.Ip $= 8 -The current page length (printable lines) of the currently selected output -channel. -Default is 60. -(Mnemonic: = has horizontal lines.) -.Ip $\- 8 -The number of lines left on the page of the currently selected output channel. -(Mnemonic: lines_on_page - lines_printed.) -.Ip $~ 8 -The name of the current report format for the currently selected output -channel. -(Mnemonic: brother to $^.) -.Ip $^ 8 -The name of the current top-of-page format for the currently selected output -channel. -(Mnemonic: points to top of page.) -.Ip $| 8 -If set to nonzero, forces a flush after every write or print on the currently -selected output channel. -Default is 0. -Note that stdout will typically be line buffered if output is to the -terminal and block buffered otherwise. -Setting this variable is useful primarily when you are outputting to a pipe, -such as when you are running a perl script under rsh and want to see the -output as it's happening. -(Mnemonic: when you want your pipes to be piping hot.) -.Ip $$ 8 -The process number of the -.I perl -running this script. -(Mnemonic: same as shells.) -.Ip $? 8 -The status returned by the last backtick (``) command 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 -matched. -For example: -.nf + $result; + } + +.ne 6 + if ($sw eq \'-v\') { + # init local array with global array + local(@ARGV) = @ARGV; + unshift(\'echo\',@ARGV); + system @ARGV; + } + # @ARGV restored - /Version: \|(.*\|)|Revision: \|(.*\|)\|/ \|&& \|($rev = $+); +.ne 6 + # temporarily add to digits associative array + if ($base12) { + # (NOTE: not claiming this is efficient!) + local(%digits) = (%digits,'t',10,'e',11); + do parse_num(); + } .fi -(Mnemonic: be positive and forward looking.) -.Ip $* 8 2 -Set to 1 to do multiline matching within a string, 0 to assume strings contain -a single line. -Default is 0. -(Mnemonic: * matches multiple things.) -.Ip $0 8 -Contains the name of the file containing the -.I perl -script being executed. -The value should be copied elsewhere before any pattern matching happens, which -clobbers $0. -(Mnemonic: same as sh and ksh.) -.Ip $ 8 -Contains the subpattern from the corresponding set of parentheses in the last -pattern matched, not counting patterns matched in nested blocks that have -been exited already. -(Mnemonic: like \edigit.) -.Ip $[ 8 2 -The index of the first element in an array, and of the first character in -a substring. -Default is 0, but you could set it to 1 to make -.I perl -behave more like -.I awk -(or Fortran) -when subscripting and when evaluating the index() and substr() functions. -(Mnemonic: [ begins subscripts.) -.Ip $! 8 2 -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 \*(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: +Note that local() is a run-time command, and so gets executed every time +through a loop, using up more stack storage each time until it's all +released at once when the loop is exited. +.Ip "localtime(EXPR)" 8 4 +.Ip "localtime EXPR" 8 +Converts a time as returned by the time function to a 9-element array with +the time analyzed for the local timezone. +Typically used as follows: .nf - $< = $>; # set real uid to the effective uid +.ne 3 + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); .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.) +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. +If EXPR is omitted, does localtime(time). +.Ip "log(EXPR)" 8 4 +.Ip "log EXPR" 8 +Returns logarithm (base +.IR e ) +of EXPR. +If EXPR is omitted, returns log of $_. +.Ip "lstat(FILEHANDLE)" 8 6 +.Ip "lstat FILEHANDLE" 8 +.Ip "lstat(EXPR)" 8 +Does the same thing as the stat() function, but stats a symbolic link +instead of the file the symbolic link points to. +If symbolic links are unimplemented on your system, a normal stat is done. +.Ip "m/PATTERN/io" 8 4 +.Ip "/PATTERN/io" 8 +Searches a string for a pattern match, and returns true (1) or false (\'\'). +If no string is specified via the =~ or !~ operator, +the $_ string is searched. +(The string specified with =~ need not be an lvalue\*(--it may be the result of an expression evaluation, but remember the =~ binds rather tightly.) +See also the section on regular expressions. .Sp -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. -.Ip $SIG{expr} 8 2 -The associative array SIG is used to set signal handlers for various signals. -Example: +If / is the delimiter then the initial \*(L'm\*(R' is optional. +With the \*(L'm\*(R' you can use any pair of characters as delimiters. +This is particularly useful for matching Unix path names that contain \*(L'/\*(R'. +If the final delimiter is followed by the optional letter \*(L'i\*(R', the matching is +done in a case-insensitive manner. +PATTERN may contain references to scalar variables, which will be interpolated +(and the pattern recompiled) every time the pattern search is evaluated. +If you want such a pattern to be compiled only once, add an \*(L"o\*(R" after +the trailing delimiter. +This avoids expensive run-time recompilations, and +is useful when the value you are interpolating won't change over the +life of the script. +.Sp +If used in a context that requires an array value, a pattern match returns an +array consisting of the subexpressions matched by the parentheses in the +pattern, +i.e. ($1, $2, $3.\|.\|.). +It does NOT actually set $1, $2, etc. in this case, nor does it set $+, $`, $& +or $'. +If the match fails, a null array is returned. +.Sp +Examples: .nf -.ne 12 - sub handler { # 1st argument is signal name - local($sig) = @_; - print "Caught a SIG$sig--shutting down\en"; - close(LOG); - exit(0); - } +.ne 4 + open(tty, \'/dev/tty\'); + \|=~ \|/\|^y\|/i \|&& \|do foo(\|); # do foo if desired - $SIG{'INT'} = 'handler'; - $SIG{'QUIT'} = 'handler'; - .\|.\|. - $SIG{'INT'} = 'DEFAULT'; # restore default action - $SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT + if (/Version: \|*\|([0\-9.]*\|)\|/\|) { $version = $1; } -.fi -.SH ENVIRONMENT -.I Perl -currently uses no environment variables, except to make them available -to the script being executed, and to child processes. -However, scripts running setuid would do well to execute the following lines -before doing anything else, just to keep people honest: -.nf + next if m#^/usr/spool/uucp#; -.ne 3 - $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need - $ENV{'SHELL'} = '/bin/sh' if $ENV{'SHELL'}; - $ENV{'IFS'} = '' if $ENV{'IFS'}; +.ne 5 + # poor man's grep + $arg = shift; + while (<>) { + print if /$arg/o; # compile only once + } + + if (($F1, $F2, $Etc) = ($foo =~ /^(\eS+)\es+(\eS+)\es*(.*)/)) .fi -.SH AUTHOR -Larry Wall -.SH FILES -/tmp/perl\-eXXXXXX temporary file for -.B \-e -commands. -.SH SEE ALSO -a2p awk to perl translator -.br -s2p sed to perl translator -.br -perldb interactive perl debugger -.SH DIAGNOSTICS -Compilation errors will tell you the line number of the error, with an -indication of the next token or token type that was to be examined. -(In the case of a script passed to -.I perl -via -.B \-e -switches, each -.B \-e -is counted as one line.) -.SH TRAPS -Accustomed awk users should take special note of the following: -.Ip * 4 2 -Semicolons are required after all simple statements in perl. Newline -is not a statement delimiter. -.Ip * 4 2 -Curly brackets are required on ifs and whiles. -.Ip * 4 2 -Variables begin with $ or @ in perl. -.Ip * 4 2 -Arrays index from 0 unless you set $[. -Likewise string positions in substr() and index(). -.Ip * 4 2 -You have to decide whether your array has numeric or string indices. -.Ip * 4 2 -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 -to an array. -And split has different arguments. -.Ip * 4 2 -The current input line is normally in $_, not $0. -It generally does not have the newline stripped. -($0 is initially the name of the program executed, then the last matched -string.) -.Ip * 4 2 -The current filename is $ARGV, not $FILENAME. -NR, RS, ORS, OFS, and OFMT have equivalents with other symbols. -FS doesn't have an equivalent, since you have to be explicit about -split statements. -.Ip * 4 2 -$ does not refer to fields--it refers to substrings matched by the last -match pattern. -.Ip * 4 2 -The print statement does not add field and record separators unless you set -$, and $\e. -.Ip * 4 2 -You must open your files before you print to them. -.Ip * 4 2 -The range operator is \*(L"..\*(R", not comma. -(The comma operator works as in C.) -.Ip * 4 2 -The match operator is \*(L"=~\*(R", not \*(L"~\*(R". -(\*(L"~\*(R" is the one's complement operator.) -.Ip * 4 2 -The concatenation operator is \*(L".\*(R", not the null string. -(Using the null string would render \*(L"/pat/ /pat/\*(R" unparseable, -since the third slash would be interpreted as a division operator\*(--the -tokener is in fact slightly context sensitive for operators like /, ?, and <. -And in fact, . itself can be the beginning of a number.) -.Ip * 4 2 -Next, exit, and continue work differently. -.Ip * 4 2 -When in doubt, run the awk construct through a2p and see what it gives you. -.PP -Cerebral C programmers should take note of the following: -.Ip * 4 2 -Curly brackets are required on ifs and whiles. -.Ip * 4 2 -You should use \*(L"elsif\*(R" rather than \*(L"else if\*(R" -.Ip * 4 2 -Break and continue become last and next, respectively. -.Ip * 4 2 -There's no switch statement. -.Ip * 4 2 -Variables begin with $ or @ in perl. -.Ip * 4 2 -Printf does not implement *. -.Ip * 4 2 -Comments begin with #, not /*. -.Ip * 4 2 -You can't take the address of anything. -.Ip * 4 2 -ARGV must be capitalized. -.Ip * 4 2 -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 -Seasoned sed programmers should take note of the following: -.Ip * 4 2 -Backreferences in substitutions use $ rather than \e. -.Ip * 4 2 -The pattern matching metacharacters (, ), and | do not have backslashes in front. -.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 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 -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 -anyone I said that. -.rn }` '' +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 "mkdir(FILENAME,MODE)" 8 3 +Creates the directory specified by FILENAME, with permissions specified by +MODE (as modified by umask). +If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). diff --git a/perl.man.3 b/perl.man.3 new file mode 100644 index 0000000..179bc3c --- /dev/null +++ b/perl.man.3 @@ -0,0 +1,1084 @@ +''' Beginning of part 3 +''' $Header: perl.man.3,v 3.0 89/10/18 15:21:46 lwall Locked $ +''' +''' $Log: perl.man.3,v $ +''' Revision 3.0 89/10/18 15:21:46 lwall +''' 3.0 baseline +''' +.Ip "next LABEL" 8 8 +.Ip "next" 8 +The +.I next +command is like the +.I continue +statement in C; it starts the next iteration of the loop: +.nf + +.ne 4 + line: while () { + next line if /\|^#/; # discard comments + .\|.\|. + } + +.fi +Note that if there were a +.I continue +block on the above, it would get executed even on discarded lines. +If the LABEL is omitted, the command refers to the innermost enclosing loop. +.Ip "oct(EXPR)" 8 4 +.Ip "oct EXPR" 8 +Returns the decimal value of EXPR interpreted as an octal string. +(If EXPR happens to start off with 0x, interprets it as a hex string instead.) +The following will handle decimal, octal and hex in the standard notation: +.nf + + $val = oct($val) if $val =~ /^0/; + +.fi +If EXPR is omitted, uses $_. +.Ip "open(FILEHANDLE,EXPR)" 8 8 +.Ip "open(FILEHANDLE)" 8 +.Ip "open FILEHANDLE" 8 +Opens the file whose filename is given by EXPR, and associates it with +FILEHANDLE. +If 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" or nothing, the file is opened for +input. +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. +(You can put a \'+\' in front of the \'>\' or \'<\' to indicate that you +want both read and write access to the file.) +If the filename begins with \*(L"|\*(R", the filename is interpreted +as a command to which output is to be piped, and if the filename ends +with a \*(L"|\*(R", the filename is interpreted as command which pipes +input to us. +(You may not have a command that pipes both in and out.) +Opening \'\-\' opens +.I STDIN +and opening \'>\-\' opens +.IR STDOUT . +Open returns non-zero upon success, the undefined value otherwise. +If the open involved a pipe, the return value happens to be the pid +of the subprocess. +Examples: +.nf + +.ne 3 + $article = 100; + open article || die "Can't find article $article: $!\en"; + while (
) {\|.\|.\|. + + open(LOG, \'>>/usr/spool/news/twitlog\'\|); # (log is reserved) + + open(article, "caesar <$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"; + return; + } + 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 +.I STDOUT +and +.IR 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"; + +.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. +(Use defined($pid) to determine if the open was successful.) +The filehandle behaves normally for the parent, but i/o to that +filehandle is piped from/to the +.IR STDOUT / STDIN +of the child process. +In the child process the filehandle isn't opened\*(--i/o happens from/to +the new +.I STDOUT +or +.IR 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 + +.ne 5 + open(FOO, "|tr \'[a\-z]\' \'[A\-Z]\'"); + open(FOO, "|\-") || exec \'tr\', \'[a\-z]\', \'[A\-Z]\'; + + open(FOO, "cat \-n $file|"); + open(FOO, "\-|") || exec \'cat\', \'\-n\', $file; + +.fi +Explicitly closing any piped filehandle causes the parent process to wait for the +child to finish, and returns the status value in $?. +.Ip "opendir(DIRHANDLE,EXPR)" 8 3 +Opens a directory named EXPR for processing by readdir(), telldir(), seekdir(), +rewinddir() and closedir(). +Returns true if successful. +DIRHANDLEs have their own namespace separate from FILEHANDLEs. +.Ip "ord(EXPR)" 8 4 +.Ip "ord EXPR" 8 +Returns the ascii value of the first character of EXPR. +If EXPR is omitted, uses $_. +.Ip "pack(TEMPLATE,LIST)" 8 4 +Takes an array or list of values and packs it into a binary structure, +returning the string containing the structure. +The TEMPLATE is a sequence of characters that give the order and type +of values, as follows: +.nf + + A An ascii string, will be space padded. + a An ascii string, will be null padded. + c A native char value. + C An unsigned char value. + s A signed short value. + S An unsigned short value. + i A signed integer value. + I An unsigned integer value. + l A signed long value. + L An unsigned long value. + n A short in \*(L"network\*(R" order. + N A long in \*(L"network\*(R" order. + p A pointer to a string. + x A null byte. + +.fi +Each letter may optionally be followed by a number which gives a repeat +count. +With all types except "a" and "A" the pack function will gobble up that many values +from the LIST. +The "a" and "A" types gobble just one value, but pack it as a string that long, +padding with nulls or spaces as necessary. +(When unpacking, "A" strips trailing spaces and nulls, but "a" does not.) +Examples: +.nf + + $foo = pack("cccc",65,66,67,68); + # foo eq "ABCD" + $foo = pack("c4",65,66,67,68); + # same thing + + $foo = pack("ccxxcc",65,66,67,68); + # foo eq "AB\e0\e0CD" + + $foo = pack("s2",1,2); + # "\e1\e0\e2\e0" on little-endian + # "\e0\e1\e0\e2" on big-endian + + $foo = pack("a4","abcd","x","y","z"); + # "abcd" + + $foo = pack("aaaa","abcd","x","y","z"); + # "axyz" + + $foo = pack("a14","abcdefg"); + # "abcdefg\e0\e0\e0\e0\e0\e0\e0" + + $foo = pack("i9pl", gmtime()); + # a real struct tm (on my system anyway) + +.fi +The same template may generally also be used in the unpack function. +.Ip "pop(ARRAY)" 8 +.Ip "pop ARRAY" 8 6 +Pops and returns the last value of the array, shortening the array by 1. +Has the same effect as +.nf + + $tmp = $ARRAY[$#ARRAY\-\|\-]; + +.fi +If there are no elements in the array, returns the undefined value. +.Ip "print(FILEHANDLE LIST)" 8 10 +.Ip "print(LIST)" 8 +.Ip "print FILEHANDLE LIST" 8 +.Ip "print LIST" 8 +.Ip "print" 8 +Prints a string or a comma-separated list of strings. +Returns non-zero if successful. +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 +.IR STDOUT . +To set the default output channel to something other than +.I STDOUT +use the select operation. +.Ip "printf(FILEHANDLE LIST)" 8 10 +.Ip "printf(LIST)" 8 +.Ip "printf FILEHANDLE LIST" 8 +.Ip "printf LIST" 8 +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 the length of LIST. +Has the same effect as +.nf + + for $value (LIST) { + $ARRAY[++$#ARRAY] = $value; + } + +.fi +but is more efficient. +.Ip "q/STRING/" 8 5 +.Ip "qq/STRING/" 8 +These are not really functions, but simply syntactic sugar to let you +avoid putting too many backslashes into quoted strings. +The q operator is a generalized single quote, and the qq operator a +generalized double quote. +Any delimiter can be used in place of /, including newline. +If the delimiter is an opening bracket or parenthesis, the final delimiter +will be the corresponding closing bracket or parenthesis. +(Embedded occurrences of the closing bracket need to be backslashed as usual.) +Examples: +.nf + +.ne 5 + $foo = q!I said, "You said, \'She said it.\'"!; + $bar = q(\'This is it.\'); + $_ .= qq +*** The previous line contains the naughty word "$&".\en + if /(ibm|apple|awk)/; # :-) + +.fi +.Ip "rand(EXPR)" 8 8 +.Ip "rand EXPR" 8 +.Ip "rand" 8 +Returns a random fractional number between 0 and the value of EXPR. +(EXPR should be positive.) +If EXPR is omitted, returns a value between 0 and 1. +See also srand(). +.Ip "read(FILEHANDLE,SCALAR,LENGTH)" 8 5 +Attempts to read LENGTH bytes of data into variable SCALAR from the specified +FILEHANDLE. +Returns the number of bytes actually read. +SCALAR will be grown or shrunk to the length actually read. +.Ip "readdir(DIRHANDLE)" 8 3 +Returns the next directory entry for a directory opened by opendir(). +If used in an array context, returns all the rest of the entries in the +directory. +If there are no more entries, returns an undefined value in a scalar context +or a null list in an array context. +.Ip "readlink(EXPR)" 8 6 +.Ip "readlink EXPR" 8 +Returns the value of a symbolic link, if symbolic links are implemented. +If not, gives a fatal error. +If there is some system error, returns the undefined value and sets $! (errno). +If EXPR is omitted, uses $_. +.Ip "recv(SOCKET,SCALAR,LEN,FLAGS)" 8 4 +Receives a message on a socket. +Attempts to receive LENGTH bytes of data into variable SCALAR from the specified +SOCKET filehandle. +Returns the address of the sender, or the undefined value if there's an error. +SCALAR will be grown or shrunk to the length actually read. +Takes the same flags as the system call of the same name. +.Ip "redo LABEL" 8 8 +.Ip "redo" 8 +The +.I redo +command restarts the loop block without evaluating the conditional again. +The +.I continue +block, if any, is not executed. +If the LABEL is omitted, the command refers to the innermost enclosing loop. +This command is normally used by programs that want to lie to themselves +about what was just input: +.nf + +.ne 16 + # a simpleminded Pascal comment stripper + # (warning: assumes no { or } in strings) + line: while () { + while (s|\|({.*}.*\|){.*}|$1 \||) {} + s|{.*}| \||; + if (s|{.*| \||) { + $front = $_; + while () { + if (\|/\|}/\|) { # end of comment? + s|^|$front{|; + redo line; + } + } + } + print; + } + +.fi +.Ip "rename(OLDNAME,NEWNAME)" 8 2 +Changes the name of a file. +Returns 1 for success, 0 otherwise. +Will not work across filesystem boundaries. +.Ip "reset(EXPR)" 8 6 +.Ip "reset EXPR" 8 +.Ip "reset" 8 +Generally used in a +.I continue +block at the end of a loop to clear variables and reset ?? searches +so that they work again. +The expression is interpreted as a list of single characters (hyphens allowed +for ranges). +All 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. +Only resets variables or searches in the current package. +Always returns 1. +Examples: +.nf + +.ne 3 + reset \'X\'; \h'|2i'# reset all X variables + reset \'a\-z\';\h'|2i'# reset lower case variables + reset; \h'|2i'# just reset ?? searches + +.fi +Note: resetting \*(L"A\-Z\*(R" is not recommended since you'll wipe out your ARGV and ENV +arrays. +.Sp +The use of reset on dbm associative arrays does not change the dbm file. +(It does, however, flush any entries cached by perl, which may be useful if +you are sharing the dbm file. +Then again, maybe not.) +.Ip "return LIST" 8 3 +Returns from a subroutine with the value specified. +(Note that a subroutine can automatically return +the value of the last expression evaluated. +That's the preferred method\*(--use of an explicit +.I return +is a bit slower.) +.Ip "reverse(LIST)" 8 4 +.Ip "reverse LIST" 8 +Returns an array value consisting of the elements of LIST in the opposite order. +.Ip "rewinddir(DIRHANDLE)" 8 5 +.Ip "rewinddir DIRHANDLE" 8 +Sets the current position to the beginning of the directory for the readdir() routine on DIRHANDLE. +.Ip "rindex(STR,SUBSTR)" 8 4 +Works just like index except that it +returns the position of the LAST occurrence of SUBSTR in STR. +.Ip "rmdir(FILENAME)" 8 4 +.Ip "rmdir FILENAME" 8 +Deletes the directory specified by FILENAME if it is empty. +If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). +If FILENAME is omitted, uses $_. +.Ip "s/PATTERN/REPLACEMENT/gieo" 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 occurrences +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. +The \*(L"e\*(R" is likewise optional, and if present, indicates that +the replacement string is to be evaluated as an expression rather than just +as a double-quoted string. +Any delimiter may replace the slashes; if single quotes are used, no +interpretation is done on the replacement string (the e modifier overrides +this, however). +If no string is specified via the =~ or !~ operator, +the $_ string is searched and modified. +(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. +If you only want the pattern compiled once the first time the variable is +interpolated, add an \*(L"o\*(R" at the end. +See also the section on regular expressions. +Examples: +.nf + + s/\|\e\|bgreen\e\|b/mauve/g; # don't change wintergreen + + $path \|=~ \|s|\|/usr/bin|\|/usr/local/bin|; + + s/Login: $foo/Login: $bar/; # run-time pattern + + ($foo = $bar) =~ s/bar/foo/; + + $_ = \'abc123xyz\'; + s/\ed+/$&*2/e; # yields \*(L'abc246xyz\*(R' + s/\ed+/sprintf("%5d",$&)/e; # yields \*(L'abc 246xyz\*(R' + s/\ew/$& x 2/eg; # yields \*(L'aabbcc 224466xxyyzz\*(R' + + s/\|([^ \|]*\|) *\|([^ \|]*\|)\|/\|$2 $1/; # reverse 1st two fields + +.fi +(Note the use of $ instead of \|\e\| in the last example. See section +on regular expressions.) +.Ip "seek(FILEHANDLE,POSITION,WHENCE)" 8 3 +Randomly positions the file pointer for FILEHANDLE, just like the fseek() +call of stdio. +FILEHANDLE may be an expression whose value gives the name of the filehandle. +Returns 1 upon success, 0 otherwise. +.Ip "seekdir(DIRHANDLE,POS)" 8 3 +Sets the current position for the readdir() routine on DIRHANDLE. +POS must be a value returned by seekdir(). +Has the same caveats about possible directory compaction as the corresponding +system library routine. +.Ip "select(FILEHANDLE)" 8 3 +.Ip "select" 8 3 +Returns the currently selected filehandle. +Sets the current default filehandle for output, if FILEHANDLE is supplied. +This has two effects: first, a +.I write +or a +.I print +without a filehandle will default to this FILEHANDLE. +Second, references to variables related to output will refer to this output +channel. +For example, if you have to set the top of form format for more than +one output channel, you might do the following: +.nf + +.ne 4 + select(REPORT1); + $^ = \'report1_top\'; + select(REPORT2); + $^ = \'report2_top\'; + +.fi +FILEHANDLE may be an expression whose value gives the name of the actual filehandle. +Thus: +.nf + + $oldfh = select(STDERR); $| = 1; select($oldfh); + +.fi +.Ip "select(RBITS,WBITS,EBITS,TIMEOUT)" 8 3 +This calls the select system call with the bitmasks specified, which can +be constructed using fileno() and vec(), along these lines: +.nf + + $rin = $win = $ein = ''; + vec($rin,fileno(STDIN),1) = 1; + vec($win,fileno(STDOUT),1) = 1; + $ein = $rin | $win; + +.fi +If you want to select on many filehandles you might wish to write a subroutine: +.nf + + sub fhbits { + local(@fhlist) = split(' ',$_[0]); + local($bits); + for (@fhlist) { + vec($bits,fileno($_),1) = 1; + } + $bits; + } + $rin = &fhbits('STDIN TTY SOCK'); + +.fi +The usual idiom is: +.nf + + ($nfound,$timeleft) = + select($rout=$rin, $wout=$win, $eout=$ein, $timeout); + +or to block until something becomes ready: + + $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef); + +.fi +Any of the bitmasks can also be undef. +The timeout, if specified, is in seconds, which may be fractional. +.Ip "setpgrp(PID,PGRP)" 8 4 +Sets the current process group for the specified PID, 0 for the current +process. +Will produce a fatal error if used on a machine that doesn't implement +setpgrp(2). +.Ip "send(SOCKET,MSG,FLAGS,TO)" 8 4 +.Ip "send(SOCKET,MSG,FLAGS)" 8 +Sends a message on a socket. +Takes the same flags as the system call of the same name. +On unconnected sockets you must specify a destination to send TO. +Returns the number of characters sent, or the undefined value if +there is an error. +.Ip "setpriority(WHICH,WHO,PRIORITY)" 8 4 +Sets the current priority for a process, a process group, or a user. +(See setpriority(2).) +Will produce a fatal error if used on a machine that doesn't implement +setpriority(2). +.Ip "setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)" 8 3 +Sets the socket option requested. +Returns undefined if there is an error. +OPTVAL may be specified as undef if you don't want to pass an argument. +.Ip "shift(ARRAY)" 8 6 +.Ip "shift ARRAY" 8 +.Ip "shift" 8 +Shifts the first value of the array off and returns it, +shortening the array by 1 and moving everything down. +If there are no elements in the array, returns the undefined value. +If ARRAY is omitted, shifts the @ARGV array in the main program, and the @_ +array in subroutines. +See also unshift(), push() and pop(). +Shift() and unshift() do the same thing to the left end of an array that push() +and pop() do to the right end. +.Ip "shutdown(SOCKET,HOW)" 8 3 +Shuts down a socket connection in the manner indicated by HOW, which has +the same interpretation as in the system call of the same name. +.Ip "sin(EXPR)" 8 4 +.Ip "sin EXPR" 8 +Returns the sine of EXPR (expressed in radians). +If EXPR is omitted, returns sine of $_. +.Ip "sleep(EXPR)" 8 6 +.Ip "sleep EXPR" 8 +.Ip "sleep" 8 +Causes the script to sleep for EXPR seconds, or forever if no EXPR. +May be interrupted by sending the process a SIGALARM. +Returns the number of seconds actually slept. +.Ip "socket(SOCKET,DOMAIN,TYPE,PROTOCOL)" 8 3 +Opens a socket of the specified kind and attaches it to filehandle SOCKET. +DOMAIN, TYPE and PROTOCOL are specified the same as for the system call +of the same name. +You may need to run makelib on sys/socket.h to get the proper values handy +in a perl library file. +Return true if successful. +See the example in the section on Interprocess Communication. +.Ip "socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)" 8 3 +Creates an unnamed pair of sockets in the specified domain, of the specified +type. +DOMAIN, TYPE and PROTOCOL are specified the same as for the system call +of the same name. +If unimplemented, yields a fatal error. +Return true if successful. +.Ip "sort(SUBROUTINE LIST)" 8 9 +.Ip "sort(LIST)" 8 +.Ip "sort SUBROUTINE LIST" 8 +.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 +an integer less than, equal to, or greater than 0, +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). +They are passed by reference so don't modify $a and $b. +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}; # presuming integers + } + @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,LIMIT)" 8 8 +.Ip "split(/PATTERN/,EXPR)" 8 8 +.Ip "split(/PATTERN/)" 8 +.Ip "split" 8 +Splits a string into an array of strings, and returns it. +(If not in an array context, returns the number of fields found and splits +into the @_ array.) +If EXPR is omitted, splits the $_ string. +If PATTERN is also omitted, splits on whitespace (/[\ \et\en]+/). +Anything matching PATTERN is taken to be a delimiter separating the fields. +(Note that the delimiter may be longer than one character.) +If LIMIT is specified, splits into no more than that many fields (though it +may split into fewer). +If LIMIT is unspecified, trailing null fields are stripped (which +potential users of pop() would do well to remember). +A pattern matching the null string (not to be confused with a null pattern, +which is one member of the set of patterns matching a null string) +will split the value of EXPR into separate characters at each point it +matches that way. +For example: +.nf + + print join(\':\', split(/ */, \'hi there\')); + +.fi +produces the output \*(L'h:i:t:h:e:r:e\*(R'. +.P +The NUM parameter can be used to partially split a line +.nf + + ($login, $passwd, $remainder) = split(\|/\|:\|/\|, $_, 3); + +.fi +(When assigning to a list, if NUM is omitted, perl supplies a NUM one +larger than the number of variables in the list, to avoid unnecessary work. +For the list above NUM would have been 4 by default. +In time critical applications it behooves you not to split into +more fields than you really need.) +.Sp +If the PATTERN contains parentheses, additional array elements are created +from each matching substring in the delimiter. +.Sp + split(/([,-])/,"1-10,20"); +.Sp +produces the array value +.Sp + (1,'-',10,',',20) +.Sp +The pattern /PATTERN/ may be replaced with an expression to specify patterns +that vary at runtime. +(To do runtime compilation only once, use /$variable/o.) +As a special case, specifying a space (\'\ \') will split on white space +just as split with no arguments does, but leading white space does NOT +produce a null first field. +Thus, split(\'\ \') can be used to emulate +.IR awk 's +default behavior, whereas +split(/\ /) will give you as many null initial fields as there are +leading spaces. +.Sp +Example: +.nf + +.ne 5 + open(passwd, \'/etc/passwd\'); + while () { +.ie t \{\ + ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(\|/\|:\|/\|); +'br\} +.el \{\ + ($login, $passwd, $uid, $gid, $gcos, $home, $shell) + = split(\|/\|:\|/\|); +'br\} + .\|.\|. + } + +.fi +(Note that $shell above will still have a newline on it. See chop().) +See also +.IR join . +.Ip "sprintf(FORMAT,LIST)" 8 4 +Returns a string formatted by the usual printf conventions. +The * character is not supported. +.Ip "sqrt(EXPR)" 8 4 +.Ip "sqrt EXPR" 8 +Return the square root of EXPR. +If EXPR is omitted, returns square root of $_. +.Ip "srand(EXPR)" 8 4 +.Ip "srand EXPR" 8 +Sets the random number seed for the +.I rand +operator. +If EXPR is omitted, does srand(time). +.Ip "stat(FILEHANDLE)" 8 6 +.Ip "stat FILEHANDLE" 8 +.Ip "stat(EXPR)" 8 +Returns a 13-element array giving the statistics for a file, either the file +opened via FILEHANDLE, or named by EXPR. +Typically used as follows: +.nf + +.ne 3 + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) + = stat($filename); + +.fi +If stat is passed the special filehandle consisting of an underline, +no stat is done, but the current contents of the stat structure from +the last stat or filetest are returned. +Example: +.nf + +.ne 3 + if (-x $file && (($d) = stat(_)) && $d < 0) { + print "$file is executable NFS file\en"; + } + +.fi +.Ip "study(SCALAR)" 8 6 +.Ip "study SCALAR" 8 +.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. +You may have only one study active at a time\*(--if you study a different +scalar the first is \*(L"unstudied\*(R". +(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 \*(L'k\*(R' 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 any 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 \*(L'f\*(R' +will be looked at, because \*(L'f\*(R' is rarer than \*(L'o\*(R'. +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. +First character is at offset 0, or whatever you've set $[ to. +If OFFSET is negative, starts that far from the end of the string. +You can use the substr() function as an lvalue, in which case EXPR must +be an lvalue. +If you assign something shorter than LEN, the string will shrink, and +if you assign something longer than LEN, the string will grow to accomodate it. +To keep the string the same length you may need to pad or chop your value using +sprintf(). +.Ip "syscall(LIST)" 8 6 +.Ip "syscall LIST" 8 +Calls the system call specified as the first element of the list, passing +the remaining elements as arguments to the system call. +If unimplemented, produces a fatal error. +The arguments are interpreted as follows: if a given argument is numeric, +the argument is passed as an int. +If not, the pointer to the string value is passed. +You are responsible to make sure a string is pre-extended long enough +to receive any result that might be written into a string. +If your integer arguments are not literals and have never been interpreted +in a numeric context, you may need to add 0 to them to force them to look +like numbers. +.nf + + do 'syscall.h'; # may need to run makelib + syscall(&SYS_write, fileno(STDOUT), "hi there\en", 9); + +.fi +.Ip "system(LIST)" 8 6 +.Ip "system LIST" 8 +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 as returned by the wait() +call. +To get the actual exit value divide by 256. +See also +.IR 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 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 "telldir(DIRHANDLE)" 8 5 +.Ip "telldir DIRHANDLE" 8 +Returns the current position of the readdir() routines on DIRHANDLE. +Value may be given to seekdir() to access a particular location in +a directory. +Has the same caveats about possible directory compaction as the corresponding +system library routine. +.Ip "time" 8 4 +Returns the number of non-leap seconds since January 1, 1970, UTC. +Suitable for feeding to gmtime() and localtime(). +.Ip "times" 8 4 +Returns a four-element array giving the user and system times, in seconds, for this +process and the children of this process. +.Sp + ($user,$system,$cuser,$csystem) = times; +.Sp +.Ip "tr/SEARCHLIST/REPLACEMENTLIST/" 8 5 +.Ip "y/SEARCHLIST/REPLACEMENTLIST/" 8 +Translates all occurrences of the characters found in the search list with +the corresponding character in the replacement list. +It returns the number of characters replaced. +If no string is specified via the =~ or !~ operator, +the $_ string is translated. +(The string specified with =~ must be a scalar variable, an array element, +or an assignment to one of those, i.e. an lvalue.) +For +.I sed +devotees, +.I y +is provided as a synonym for +.IR tr . +Examples: +.nf + + $ARGV[1] \|=~ \|y/A\-Z/a\-z/; \h'|3i'# canonicalize to lower case + + $cnt = tr/*/*/; \h'|3i'# count the stars in $_ + + ($HOST = $host) =~ tr/a\-z/A\-Z/; + + y/\e001\-@[\-_{\-\e177/ /; \h'|3i'# change non-alphas to space + +.fi +.Ip "umask(EXPR)" 8 4 +.Ip "umask EXPR" 8 +Sets the umask for the process and returns the old one. +If EXPR is omitted, merely returns current umask. +.Ip "undef(EXPR)" 8 6 +.Ip "undef EXPR" 8 +.Ip "undef" 8 +Undefines the value of EXPR, which must be an lvalue. +Use only on a scalar value, an entire array, or a subroutine name (using &). +(Undef will probably not do what you expect on most predefined variables or +dbm array values.) +Always returns the undefined value. +You can omit the EXPR, in which case nothing is undefined, but you still +get an undefined value that you could, for instance, return from a subroutine. +Examples: +.nf + +.ne 6 + undef $foo; + undef $bar{'blurfl'}; + undef @ary; + undef %assoc; + undef &mysub; + return (wantarray ? () : undef) if $they_blew_it; + +.fi +.Ip "unlink(LIST)" 8 4 +.Ip "unlink LIST" 8 +Deletes a list of files. +Returns the number of files successfully deleted. +.nf + +.ne 2 + $cnt = unlink \'a\', \'b\', \'c\'; + unlink @goners; + unlink <*.bak>; + +.fi +Note: unlink will not delete directories unless you are superuser and the +.B \-U +flag is supplied to +.IR perl . +Even if these conditions are met, be warned that unlinking a directory +can inflict damage on your filesystem. +Use rmdir instead. +.Ip "unpack(TEMPLATE,EXPR)" 8 4 +Unpack does the reverse of pack: it takes a string representing +a structure and expands it out into an array value, returning the array +value. +The TEMPLATE has the same format as in the pack function. +Here's a subroutine that does substring: +.nf + +.ne 4 + sub substr { + local($what,$where,$howmuch) = @_; + unpack("x$where a$howmuch", $what); + } + +.ne 3 +and then there's + + sub ord { unpack("c",$_[0]); } + +.fi +.Ip "unshift(ARRAY,LIST)" 8 4 +Does the opposite of a +.IR shift . +Or the opposite of a +.IR 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 +.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 +.Ip "values ASSOC_ARRAY" 8 +Returns a normal array consisting of all the values of the named associative +array. +The values are returned in an apparently random order, but it is the same order +as either the keys() or each() function would produce on the same array. +See also keys() and each(). +.Ip "vec(EXPR,OFFSET,BITS)" 8 2 +Treats a string as a vector of unsigned integers, and returns the value +of the bitfield specified. +May also be assigned to. +BITS must be a power of two from 1 to 32. +.Sp +Vectors created with vec() can also be manipulated with the logical operators +|, & and ^, +which will assume a bit vector operation is desired when both operands are +strings. +This interpretation is not enabled unless there is at least one vec() in +your program, to protect older programs. +.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 "wantarray" 8 4 +Returns true if the context of the currently executing subroutine +is looking for an array value. +Returns false if the context is looking for a scalar. +.nf + + return wantarray ? () : undef; + +.fi +.Ip "warn(LIST)" 8 4 +.Ip "warn LIST" 8 +Produces a message on STDERR just like \*(L"die\*(R", but doesn't exit. +.Ip "write(FILEHANDLE)" 8 6 +.Ip "write(EXPR)" 8 +.Ip "write(\|)" 8 +Writes a formatted record (possibly multi-line) to the specified file, +using the format associated with that file. +By default the format for a file is the one having the same name is the +filehandle, but the format for the current output channel (see +.IR select ) +may be set explicitly +by assigning the name of the format to the $~ variable. +.Sp +Top of form processing is handled automatically: +if there is insufficient room on the current page for the formatted +record, the page is advanced, a special top-of-page format is used +to format the new page header, and then the record is written. +By default the top-of-page format is \*(L"top\*(R", but it +may be set to the +format of your choice by assigning the name to the $^ variable. +.Sp +If FILEHANDLE is unspecified, output goes to the current default output channel, +which starts out as +.I STDOUT +but may be changed by the +.I select +operator. +If the FILEHANDLE is an EXPR, then the expression is evaluated and the +resulting string is used to look up the name of the FILEHANDLE at run time. +For more on formats, see the section on formats later on. +.Sp +Note that write is NOT the opposite of read. diff --git a/perl.man.4 b/perl.man.4 new file mode 100644 index 0000000..953ca8b --- /dev/null +++ b/perl.man.4 @@ -0,0 +1,1452 @@ +''' Beginning of part 4 +''' $Header: perl.man.4,v 3.0 89/10/18 15:21:55 lwall Locked $ +''' +''' $Log: perl.man.4,v $ +''' Revision 3.0 89/10/18 15:21:55 lwall +''' 3.0 baseline +''' +.Sh "Precedence" +.I Perl +operators have the following associativity and precedence: +.nf + +nonassoc\h'|1i'print printf exec system sort reverse +\h'1.5i'chmod chown kill unlink utime die return +left\h'|1i', +right\h'|1i'= += \-= *= etc. +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 exit eval reset sleep rand umask +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 +right\h'|1i'** +nonassoc\h'|1i'++ \-\|\- +left\h'|1i'\*(L'(\*(R' + +.fi +As mentioned earlier, if any list operator (print, etc.) or +any unary operator (chdir, etc.) +is followed by a left parenthesis as the next token on the same line, +the operator and arguments within parentheses are taken to +be of highest precedence, just like a normal function call. +Examples: +.nf + + chdir $foo || die; # (chdir $foo) || die + chdir($foo) || die; # (chdir $foo) || die + chdir ($foo) || die; # (chdir $foo) || die + chdir +($foo) || die; # (chdir $foo) || die + +but, because * is higher precedence than ||: + + chdir $foo * 20; # chdir ($foo * 20) + chdir($foo) * 20; # (chdir $foo) * 20 + chdir ($foo) * 20; # (chdir $foo) * 20 + chdir +($foo) * 20; # chdir ($foo * 20) + + rand 10 * 20; # rand (10 * 20) + rand(10) * 20; # (rand 10) * 20 + rand (10) * 20; # (rand 10) * 20 + rand +(10) * 20; # rand (10 * 20) + +.fi +In the absence of parentheses, +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 +.nf + + @ary = (1, 3, sort 4, 2); + print @ary; # prints 1324 + +.fi +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. +Note that you have to be careful with parens: +.nf + +.ne 3 + # These evaluate exit before doing the print: + print($foo, exit); # Obviously not what you want. + print $foo, exit; # Nor is this. + +.ne 4 + # These do the print before evaluating exit: + (print $foo), exit; # This is what you want. + print($foo), exit; # Or this. + print ($foo), exit; # Or even this. + +Also note that + + print ($foo & 255) + 1, "\en"; + +.fi +probably doesn't do what you expect at first glance. +.Sh "Subroutines" +A subroutine may be declared as follows: +.nf + + sub NAME BLOCK + +.fi +.PP +Any arguments passed to the routine come in as array @_, +that is ($_[0], $_[1], .\|.\|.). +The array @_ is a local array, but its values are references to the +actual scalar parameters. +The return value of the subroutine is the value of the last expression +evaluated, and can be either an array value or a scalar value. +Alternately, a return statement may be used to specify the returned value and +exit the subroutine. +To create local variables see the +.I local +operator. +.PP +A subroutine is called using the +.I do +operator or the & operator. +.nf + +.ne 12 +Example: + + sub MAX { + local($max) = pop(@_); + foreach $foo (@_) { + $max = $foo \|if \|$max < $foo; + } + $max; + } + + .\|.\|. + $bestday = &MAX($mon,$tue,$wed,$thu,$fri); + +.ne 21 +Example: + + # get a line, combining continuation lines + # that start with whitespace + sub get_line { + $thisline = $lookahead; + line: while ($lookahead = ) { + if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) { + $thisline \|.= \|$lookahead; + } + else { + last line; + } + } + $thisline; + } + + $lookahead = ; # get first line + while ($_ = do get_line(\|)) { + .\|.\|. + } + +.fi +.nf +.ne 6 +Use array assignment to a local list to name your formal arguments: + + sub maybeset { + local($key, $value) = @_; + $foo{$key} = $value unless $foo{$key}; + } + +.fi +This also has the effect of turning call-by-reference into call-by-value, +since the assignment copies the values. +.Sp +Subroutines may be called recursively. +If a subroutine is called using the & form, the argument list is optional. +If omitted, no @_ array is set up for the subroutine; the @_ array at the +time of the call is visible to subroutine instead. +.nf + + do foo(1,2,3); # pass three arguments + &foo(1,2,3); # the same + + do foo(); # pass a null list + &foo(); # the same + &foo; # pass no arguments--more efficient + +.fi +.Sh "Passing By Reference" +Sometimes you don't want to pass the value of an array to a subroutine but +rather the name of it, so that the subroutine can modify the global copy +of it rather than working with a local copy. +In perl you can refer to all the objects of a particular name by prefixing +the name with a star: *foo. +When evaluated, it produces a scalar value that represents all the objects +of that name. +When assigned to within a local() operation, it causes the name mentioned +to refer to whatever * value was assigned to it. +Example: +.nf + + sub doubleary { + local(*someary) = @_; + foreach $elem (@someary) { + $elem *= 2; + } + } + do doubleary(*foo); + do doubleary(*bar); + +.fi +Assignment to *name is currently recommended only inside a local(). +You can actually assign to *name anywhere, but the previous referent of +*name may be stranded forever. +This may or may not bother you. +.Sp +Note that scalars are already passed by reference, so you can modify scalar +arguments without using this mechanism by refering explicitly to the $_[nnn] +in question. +You can modify all the elements of an array by passing all the elements +as scalars, but you have to use the * mechanism to push, pop or change the +size of an array. +The * mechanism will probably be more efficient in any case. +.Sp +Since a *name value contains unprintable binary data, if it is used as +an argument in a print, or as a %s argument in a printf or sprintf, it +then has the value '*name', just so it prints out pretty. +.Sh "Regular Expressions" +The patterns used in pattern matching are regular expressions such as +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. +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. +Alternatives may be separated by |. +The bracketing construct \|(\ .\|.\|.\ \|) may also be used, in which case \e +matches the digit'th substring, where digit can range from 1 to 9. +(Outside of the pattern, always use $ instead of \e in front of the digit. +The scope of $ (and $\`, $& and $\') +extends to the end of the enclosing BLOCK or eval string, or to +the next pattern match with subexpressions. +The \e notation sometimes works outside the current pattern, but should +not be relied upon.) +$+ returns whatever the last bracket match matched. +$& returns the entire matched string. +($0 normally returns the same thing, but don't depend on it.) +$\` returns everything before the matched string. +$\' returns everything after the matched string. +Examples: +.nf + + s/\|^\|([^ \|]*\|) \|*([^ \|]*\|)\|/\|$2 $1\|/; # swap first two words + +.ne 5 + if (/\|Time: \|(.\|.\|):\|(.\|.\|):\|(.\|.\|)\|/\|) { + $hours = $1; + $minutes = $2; + $seconds = $3; + } + +.fi +By default, the ^ character matches only the beginning of the string, +the $ character matches only at the end (or before the newline at the end) +and +.I perl +does certain optimizations with the assumption that the string contains +only one line. +You may, however, wish to treat a string as a multi-line buffer, such that +the ^ will match after any newline within the string, and $ will match +before any newline. +At the cost of a little more overhead, you can do this by setting the variable +$* to 1. +Setting it back to 0 makes +.I perl +revert to its old behavior. +.PP +To facilitate multi-line substitutions, the . character never matches a newline +(even when $* is 0). +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)[^\e000]*/$1/; + s/.*(some_string)(.|\en)*/$1/; + chop; s/.*(some_string).*/$1/; + /(some_string)/ && ($_ = $1); + +.fi +Any item of a regular expression may be followed with digits in curly brackets +of the form {n,m}, where n gives the minimum number of times to match the item +and m gives the maximum. +The form {n} is equivalent to {n,n} and matches exactly n times. +The form {n,} matches n or more times. +(If a curly bracket occurs in any other context, it is treated as a regular +character.) +The * modifier is equivalent to {0,}, the + modifier to {1,} and the ? modifier +to {0,1}. +There is no limit to the size of n or m, but large numbers will chew up +more memory. +.Sp +You will note that all backslashed metacharacters in +.I perl +are alphanumeric, +such as \eb, \ew, \en. +Unlike some other regular expression languages, there are no backslashed +symbols that aren't alphanumeric. +So anything that looks like \e\e, \e(, \e), \e<, \e>, \e{, or \e} is always +interpreted as a literal character, not a metacharacter. +This makes it simple to quote a string that you want to use for a pattern +but that you are afraid might contain metacharacters. +Simply quote all the non-alphanumeric characters: +.nf + + $pattern =~ s/(\eW)/\e\e$1/g; + +.fi +.Sh "Formats" +Output record formats for use with the +.I write +operator may declared as follows: +.nf + +.ne 3 + format NAME = + FORMLIST + . + +.fi +If name is omitted, format \*(L"STDOUT\*(R" is defined. +FORMLIST consists of a sequence of lines, each of which may be of one of three +types: +.Ip 1. 4 +A comment. +.Ip 2. 4 +A \*(L"picture\*(R" line giving the format for one output line. +.Ip 3. 4 +An argument line supplying values to plug into a picture line. +.PP +Picture lines are printed exactly as they look, except for certain fields +that substitute values into the line. +Each picture field starts with either @ or ^. +The @ field (not to be confused with the array marker @) is the normal +case; ^ fields are used +to do rudimentary multi-line text block filling. +The length of the field is supplied by padding out the field +with multiple <, >, or | characters to specify, respectively, left justification, +right justification, or centering. +If any of the values supplied for these fields contains a newline, only +the text up to the newline is printed. +The special field @* can be used for printing multi-line values. +It should appear by itself on a line. +.PP +The values are specified on the following line, in the same order as +the picture fields. +The values should be separated by commas. +.PP +Picture fields that begin with ^ rather than @ are treated specially. +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 variable is referenced, +more of the text can be printed. +Normally you would use a sequence of fields in a vertical stack to print +out a block of text. +If you like, you can end the final field with .\|.\|., which will appear in the +output if the text was too long to appear in its entirety. +You can change which characters are legal to break on by changing the +variable $: to a list of the desired characters. +.PP +Since use of ^ fields can produce variable length records if the text to be +formatted is short, you can suppress blank lines by putting the tilde (~) +character anywhere in the line. +(Normally you should put it in the front if possible, for visibility.) +The tilde will be translated to a space upon output. +If you put a second tilde contiguous to the first, the line will be repeated +until all the fields on the line are exhausted. +(If you use a field of the @ variety, the expression you supply had better +not give the same value every time forever!) +.PP +Examples: +.nf +.lg 0 +.cs R 25 +.ft C + +.ne 10 +# a report on the /etc/passwd file +format top = +\& Passwd File +Name Login Office Uid Gid Home +------------------------------------------------------------------ +\&. +format STDOUT = +@<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<< +$name, $login, $office,$uid,$gid, $home +\&. + +.ne 29 +# a report from a bug report form +format top = +\& Bug Reports +@<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>> +$system, $%, $date +------------------------------------------------------------------ +\&. +format STDOUT = +Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $subject +Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $index, $description +Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $priority, $date, $description +From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $from, $description +Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $programmer, $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<... +\& $description +\&. + +.ft R +.cs R +.lg +.fi +It is possible to intermix prints with writes on the same output channel, +but you'll have to handle $\- (lines left on the page) yourself. +.PP +If you are printing lots of fields that are usually blank, you should consider +using the reset operator between records. +Not only is it more efficient, but it can prevent the bug of adding another +field and forgetting to zero it. +.Sh "Interprocess Communication" +The IPC facilities of perl are built on the Berkeley socket mechanism. +If you don't have sockets, you can ignore this section. +The calls have the same names as the corresponding system calls, +but the arguments tend to differ, for two reasons. +First, perl file handles work differently than C file descriptors. +Second, perl already knows the length of its strings, so you don't need +to pass that information. +Here is a sample client (untested): +.nf + + ($them,$port) = @ARGV; + $port = 2345 unless $port; + $them = 'localhost' unless $them; + + $SIG{'INT'} = 'dokill'; + sub dokill { kill 9,$child if $child; } + + do 'sys/socket.h' || die "Can't do sys/socket.h: $@"; + + $sockaddr = 'S n a4 x8'; + chop($hostname = `hostname`); + + ($name, $aliases, $proto) = getprotobyname('tcp'); + ($name, $aliases, $port) = getservbyname($port, 'tcp') + unless $port =~ /^\ed+$/;; + ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname); + ($name, $aliases, $type, $len, $thataddr) = gethostbyname($them); + + $this = pack($sockaddr, &AF_INET, 0, $thisaddr); + $that = pack($sockaddr, &AF_INET, $port, $thataddr); + + socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; + bind(S, $this) || die "bind: $!"; + connect(S, $that) || die "connect: $!"; + + select(S); $| = 1; select(stdout); + + if ($child = fork) { + while (<>) { + print S; + } + sleep 3; + do dokill(); + } + else { + while () { + print; + } + } + +.fi +And here's a server: +.nf + + ($port) = @ARGV; + $port = 2345 unless $port; + + do 'sys/socket.h' || die "Can't do sys/socket.h: $@"; + + $sockaddr = 'S n a4 x8'; + + ($name, $aliases, $proto) = getprotobyname('tcp'); + ($name, $aliases, $port) = getservbyname($port, 'tcp') + unless $port =~ /^\ed+$/;; + + $this = pack($sockaddr, &AF_INET, $port, "\e0\e0\e0\e0"); + + select(NS); $| = 1; select(stdout); + + socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; + bind(S, $this) || die "bind: $!"; + listen(S, 5) || die "connect: $!"; + + select(S); $| = 1; select(stdout); + + for (;;) { + print "Listening again\en"; + ($addr = accept(NS,S)) || die $!; + print "accept ok\en"; + + ($af,$port,$inetaddr) = unpack($pat,$addr); + @inetaddr = unpack('C4',$inetaddr); + print "$af $port @inetaddr\en"; + + while () { + print; + print NS; + } + } + +.fi +.Sh "Predefined Names" +The following names have special meaning to +.IR perl . +I could have used alphabetic symbols for some of these, but I didn't want +to take the chance that someone would say reset \*(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. +.Ip $_ 8 +The default input and pattern-searching space. +The following pairs are equivalent: +.nf + +.ne 2 + while (<>) {\|.\|.\|. # only equivalent in while! + while ($_ = <>) {\|.\|.\|. + +.ne 2 + /\|^Subject:/ + $_ \|=~ \|/\|^Subject:/ + +.ne 2 + y/a\-z/A\-Z/ + $_ =~ y/a\-z/A\-Z/ + +.ne 2 + chop + chop($_) + +.fi +(Mnemonic: underline is understood in certain operations.) +.Ip $. 8 +The current input line number of the last 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. +Works like +.IR awk 's +RS variable, including treating blank lines as delimiters +if set to the null string. +If set to a value longer than one character, only the first character is used. +(Mnemonic: / is used to delimit line boundaries when quoting poetry.) +.Ip $, 8 +The output field separator for the print operator. +Ordinarily the print operator simply prints out the comma separated fields +you specify. +In order to get behavior more like +.IR awk , +set this variable as you would set +.IR awk 's +OFS variable to specify what is printed between fields. +(Mnemonic: what is printed when there is a , in your print statement.) +.Ip $"" 8 +This is like $, except that it applies to array values interpolated into +a double-quoted string (or similar interpreted string). +Default is a space. +(Mnemonic: obvious, I think.) +.Ip $\e 8 +The output record separator for the print operator. +Ordinarily the print operator simply prints out the comma separated fields +you specify, with no trailing newline or record separator assumed. +In order to get behavior more like +.IR awk , +set this variable as you would set +.IR awk 's +ORS variable to specify what is printed at the end of the print. +(Mnemonic: you set $\e instead of adding \en at the end of the print. +Also, it's just like /, but it's what you get \*(L"back\*(R" from +.IR perl .) +.Ip $# 8 +The output format for printed numbers. +This variable is a half-hearted attempt to emulate +.IR awk 's +OFMT variable. +There are times, however, when +.I awk +and +.I perl +have differing notions of what +is in fact numeric. +Also, the initial value is %.20g rather than %.6g, so you need to set $# +explicitly to get +.IR awk 's +value. +(Mnemonic: # is the number sign.) +.Ip $% 8 +The current page number of the currently selected output channel. +(Mnemonic: % is page number in nroff.) +.Ip $= 8 +The current page length (printable lines) of the currently selected output +channel. +Default is 60. +(Mnemonic: = has horizontal lines.) +.Ip $\- 8 +The number of lines left on the page of the currently selected output channel. +(Mnemonic: lines_on_page \- lines_printed.) +.Ip $~ 8 +The name of the current report format for the currently selected output +channel. +(Mnemonic: brother to $^.) +.Ip $^ 8 +The name of the current top-of-page format for the currently selected output +channel. +(Mnemonic: points to top of page.) +.Ip $| 8 +If set to nonzero, forces a flush after every write or print on the currently +selected output channel. +Default is 0. +Note that +.I STDOUT +will typically be line buffered if output is to the +terminal and block buffered otherwise. +Setting this variable is useful primarily when you are outputting to a pipe, +such as when you are running a +.I perl +script under rsh and want to see the +output as it's happening. +(Mnemonic: when you want your pipes to be piping hot.) +.Ip $$ 8 +The process number of the +.I perl +running this script. +(Mnemonic: same as shells.) +.Ip $? 8 +The status returned by the last pipe close, backtick (\`\`) command or +.I 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 (not counting any matches hidden +within a BLOCK or eval enclosed by the current BLOCK). +(Mnemonic: like & in some editors.) +.Ip $\` 8 4 +The string preceding whatever was matched by the last pattern match +(not counting any matches hidden within a BLOCK or eval enclosed by the current +BLOCK). +(Mnemonic: \` often precedes a quoted string.) +.Ip $\' 8 4 +The string following whatever was matched by the last pattern match +(not counting any matches hidden within a BLOCK or eval enclosed by the current +BLOCK). +(Mnemonic: \' often follows a quoted string.) +Example: +.nf + +.ne 3 + $_ = \'abcdefghi\'; + /def/; + print "$\`:$&:$\'\en"; # prints abc:def:ghi + +.fi +.Ip $+ 8 4 +The last bracket matched by the last search pattern. +This is useful if you don't know which of a set of alternative patterns +matched. +For example: +.nf + + /Version: \|(.*\|)|Revision: \|(.*\|)\|/ \|&& \|($rev = $+); + +.fi +(Mnemonic: be positive and forward looking.) +.Ip $* 8 2 +Set to 1 to do multiline matching within a string, 0 to tell +.I perl +that it can assume that strings contain a single line, for the purpose +of optimizing pattern matches. +Pattern matches on strings containing multiple newlines can produce confusing +results when $* is 0. +Default is 0. +(Mnemonic: * matches multiple things.) +.Ip $0 8 +Contains the name of the file containing the +.I perl +script being executed. +The value should be copied elsewhere before any pattern matching happens, which +clobbers $0. +(Mnemonic: same as sh and ksh.) +.Ip $ 8 +Contains the subpattern from the corresponding set of parentheses in the last +pattern matched, not counting patterns matched in nested blocks that have +been exited already. +(Mnemonic: like \edigit.) +.Ip $[ 8 2 +The index of the first element in an array, and of the first character in +a substring. +Default is 0, but you could set it to 1 to make +.I perl +behave more like +.I awk +(or Fortran) +when subscripting and when evaluating the index() and substr() functions. +(Mnemonic: [ begins subscripts.) +.Ip $] 8 2 +The string printed out when you say \*(L"perl -v\*(R". +It can be used to determine at the beginning of a script whether the perl +interpreter executing the script is in the right range of versions. +Example: +.nf + +.ne 5 + # see if getc is available + ($version,$patchlevel) = + $] =~ /(\ed+\e.\ed+).*\enPatch level: (\ed+)/; + print STDERR "(No filename completion available.)\en" + if $version * 1000 + $patchlevel < 2016; + +.fi +(Mnemonic: Is this version of perl in the right bracket?) +.Ip $; 8 2 +The subscript separator for multi-dimensional array emulation. +If you refer to an associative array element as +.nf + $foo{$a,$b,$c} + +it really means + + $foo{join($;, $a, $b, $c)} + +But don't put + + @foo{$a,$b,$c} # a slice--note the @ + +which means + + ($foo{$a},$foo{$b},$foo{$c}) + +.fi +Default is "\e034", the same as SUBSEP in +.IR awk . +Note that if your keys contain binary data there might not be any safe +value for $;. +(Mnemonic: comma (the syntactic subscript separator) is a semi-semicolon. +Yeah, I know, it's pretty lame, but $, is already taken for something more +important.) +.Ip $! 8 2 +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 \*(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 + +.ne 2 + $< = $>; # set real uid to the effective uid + ($<,$>) = ($>,$<); # swap real and effective uid + +.fi +(Mnemonic: it's the uid you went TO, if you're running setuid.) +Note: $< and $> can only be swapped on machines supporting setreuid(). +.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: parentheses 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: parentheses 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. +$( and $) can only be swapped on machines supporting setregid(). +.Ip $: 8 2 +The current set of characters after which a string may be broken to +fill continuation fields (starting with ^) in a format. +Default is "\ \en-", to break on whitespace or hyphens. +(Mnemonic: a \*(L"colon\*(R" in poetry is a part of a line.) +.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 +.I perl +scripts to be +evaluated by the \*(L"do EXPR\*(R" command. +It initially consists of the arguments to any +.B \-I +command line switches, followed +by the default +.I 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. +.Ip $SIG{expr} 8 2 +The associative array SIG is used to set signal handlers for various signals. +Example: +.nf + +.ne 12 + sub handler { # 1st argument is signal name + 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 + +.fi +The SIG array only contains values for the signals actually set within +the perl script. +.Sh "Packages" +Perl provides a mechanism for alternate namespaces to protect packages from +stomping on each others variables. +By default, a perl script starts compiling into the package known as \*(L"main\*(R". +By use of the +.I package +declaration, you can switch namespaces. +The scope of the package declaration is from the declaration itself to the end +of the enclosing block (the same scope as the local() operator). +Typically it would be the first declaration in a file to be included by +the \*(L"do FILE\*(R" operator. +You can switch into a package in more than one place; it merely influences +which symbol table is used by the compiler for the rest of that block. +You can refer to variables in other packages by prefixing the name with +the package name and a single quote. +If the package name is null, the \*(L"main\*(R" package as assumed. +Eval'ed strings are compiled in the package in which the eval was compiled +in. +(Assignments to $SIG{}, however, assume the signal handler specified is in the +main package. +Qualify the signal handler name if you wish to have a signal handler in +a package.) +For an example, examine perldb.pl in the perl library. +It initially switches to the DB package so that the debugger doesn't interfere +with variables in the script you are trying to debug. +At various points, however, it temporarily switches back to the main package +to evaluate various expressions in the context of the main package. +.PP +The symbol table for a package happens to be stored in the associative array +of that name prepended with an underscore. +The value in each entry of the associative array is +what you are referring to when you use the *name notation. +In fact, the following have the same effect (in package main, anyway), +though the first is more +efficient because it does the symbol table lookups at compile time: +.nf + +.ne 2 + local(*foo) = *bar; + local($_main{'foo'}) = $_main{'bar'}; + +.fi +You can use this to print out all the variables in a package, for instance. +Here is dumpvar.pl from the perl library: +.nf +.ne 11 + package dumpvar; + + sub main'dumpvar { + \& ($package) = @_; + \& local(*stab) = eval("*_$package"); + \& while (($key,$val) = each(%stab)) { + \& { + \& local(*entry) = $val; + \& if (defined $entry) { + \& print "\e$$key = '$entry'\en"; + \& } +.ne 7 + \& if (defined @entry) { + \& print "\e@$key = (\en"; + \& foreach $num ($[ .. $#entry) { + \& print " $num\et'",$entry[$num],"'\en"; + \& } + \& print ")\en"; + \& } +.ne 10 + \& if ($key ne "_$package" && defined %entry) { + \& print "\e%$key = (\en"; + \& foreach $key (sort keys(%entry)) { + \& print " $key\et'",$entry{$key},"'\en"; + \& } + \& print ")\en"; + \& } + \& } + \& } + } + +.fi +Note that, even though the subroutine is compiled in package dumpvar, the +name of the subroutine is qualified so that it's name is inserted into package +\*(L"main\*(R". +.Sh "Style" +Each programmer will, of course, have his or her own preferences in regards +to formatting, but there are some general guidelines that will make your +programs easier to read. +.Ip 1. 4 4 +Just because you CAN do something a particular way doesn't mean that +you SHOULD do it that way. +.I Perl +is designed to give you several ways to do anything, so consider picking +the most readable one. +For instance + + open(FOO,$foo) || die "Can't open $foo: $!"; + +is better than + + die "Can't open $foo: $!" unless open(FOO,$foo); + +because the second way hides the main point of the statement in a +modifier. +On the other hand + + print "Starting analysis\en" if $verbose; + +is better than + + $verbose && print "Starting analysis\en"; + +since the main point isn't whether the user typed -v or not. +.Sp +Similarly, just because an operator lets you assume default arguments +doesn't mean that you have to make use of the defaults. +The defaults are there for lazy systems programmers writing one-shot +programs. +If you want your program to be readable, consider supplying the argument. +.Ip 2. 4 4 +Don't go through silly contortions to exit a loop at the top or the +bottom, when +.I perl +provides the "last" operator so you can exit in the middle. +Just outdent it a little to make it more visible: +.nf + +.ne 7 + line: + for (;;) { + statements; + last line if $foo; + next line if /^#/; + statements; + } + +.fi +.Ip 3. 4 4 +Don't be afraid to use loop labels\*(--they're there to enhance readability as +well as to allow multi-level loop breaks. +See last example. +.Ip 6. 4 4 +For portability, when using features that may not be implemented on every +machine, test the construct in an eval to see if it fails. +.Ip 4. 4 4 +Choose mnemonic indentifiers. +.Ip 5. 4 4 +Be consistent. +.Sh "Debugging" +If you invoke +.I perl +with a +.B \-d +switch, your script will be run under a debugging monitor. +It will halt before the first executable statement and ask you for a +command, such as: +.Ip "h" 12 4 +Prints out a help message. +.Ip "s" 12 4 +Single step. +Executes until it reaches the beginning of another statement. +.Ip "c" 12 4 +Continue. +Executes until the next breakpoint is reached. +.Ip "" 12 4 +Repeat last s or c. +.Ip "n" 12 4 +Single step around subroutine call. +.Ip "l min+incr" 12 4 +List incr+1 lines starting at min. +If min is omitted, starts where last listing left off. +If incr is omitted, previous value of incr is used. +.Ip "l min-max" 12 4 +List lines in the indicated range. +.Ip "l line" 12 4 +List just the indicated line. +.Ip "l" 12 4 +List incr+1 more lines after last printed line. +.Ip "l subname" 12 4 +List subroutine. +If it's a long subroutine it just lists the beginning. +Use \*(L"l\*(R" to list more. +.Ip "L" 12 4 +List lines that have breakpoints or actions. +.Ip "t" 12 4 +Toggle trace mode on or off. +.Ip "b line" 12 4 +Set a breakpoint. +If line is omitted, sets a breakpoint on the current line +line that is about to be executed. +Breakpoints may only be set on lines that begin an executable statement. +.Ip "b subname" 12 4 +Set breakpoint at first executable line of subroutine. +.Ip "S" 12 4 +Lists the names of all subroutines. +.Ip "d line" 12 4 +Delete breakpoint. +If line is omitted, deletes the breakpoint on the current line +line that is about to be executed. +.Ip "D" 12 4 +Delete all breakpoints. +.Ip "A" 12 4 +Delete all line actions. +.Ip "V package" 12 4 +List all variables in package. +Default is main package. +.Ip "a line command" 12 4 +Set an action for line. +A multi-line command may be entered by backslashing the newlines. +.Ip "< command" 12 4 +Set an action to happen before every debugger prompt. +A multi-line command may be entered by backslashing the newlines. +.Ip "> command" 12 4 +Set an action to happen after the prompt when you've just given a command +to return to executing the script. +A multi-line command may be entered by backslashing the newlines. +.Ip "! number" 12 4 +Redo a debugging command. +If number is omitted, redoes the previous command. +.Ip "! -number" 12 4 +Redo the command that was that many commands ago. +.Ip "H -number" 12 4 +Display last n commands. +Only commands longer than one character are listed. +If number is omitted, lists them all. +.Ip "q or ^D" 12 4 +Quit. +.Ip "command" 12 4 +Execute command as a perl statement. +A missing semicolon will be supplied. +.Ip "p expr" 12 4 +Same as \*(L"print DB'OUT expr\*(R". +The DB'OUT filehandle is opened to /dev/tty, regardless of where STDOUT +may be redirected to. +.PP +If you want to modify the debugger, copy perldb.pl from the perl library +to your current directory and modify it as necessary. +You can do some customization by setting up a .perldb file which contains +initialization code. +For instance, you could make aliases like these: +.nf + + $DBalias{'len'} = 's/^len(.*)/p length(\e$1)/'; + $DBalias{'stop'} = 's/^stop (at|in)/b/'; + $DBalias{'.'} = + 's/^./p "\e$DBsub(\e$DBline):\et\e$DBline[\e$DBline]"/'; + +.fi +.Sh "Setuid Scripts" +.I Perl +is designed to make it easy to write secure setuid and setgid scripts. +Unlike shells, which are based on multiple substitution passes on each line +of the script, +.I perl +uses a more conventional evaluation scheme with fewer hidden \*(L"gotchas\*(R". +Additionally, since the language has more built-in functionality, it +has to rely less upon external (and possibly untrustworthy) programs to +accomplish its purposes. +.PP +In an unpatched 4.2 or 4.3bsd kernel, setuid scripts are intrinsically +insecure, but this kernel feature can be disabled. +If it is, +.I perl +can emulate the setuid and setgid mechanism when it notices the otherwise +useless setuid/gid bits on perl scripts. +If the kernel feature isn't disabled, +.I perl +will complain loudly that your setuid script is insecure. +You'll need to either disable the kernel setuid script feature, or put +a C wrapper around the script. +.PP +When perl is executing a setuid script, it takes special precautions to +prevent you from falling into any obvious traps. +(In some ways, a perl script is more secure than the corresponding +C program.) +Any command line argument, environment variable, or input is marked as +\*(L"tainted\*(R", and may not be used, directly or indirectly, in any +command that invokes a subshell, or in any command that modifies files, +directories or processes. +Any variable that is set within an expression that has previously referenced +a tainted value also becomes tainted (even if it is logically impossible +for the tainted value to influence the variable). +For example: +.nf + +.ne 5 + $foo = shift; # $foo is tainted + $bar = $foo,\'bar\'; # $bar is also tainted + $xxx = <>; # Tainted + $path = $ENV{\'PATH\'}; # Tainted, but see below + $abc = \'abc\'; # Not tainted + +.ne 4 + system "echo $foo"; # Insecure + system "echo", $foo; # Secure (doesn't use sh) + system "echo $bar"; # Insecure + system "echo $abc"; # Insecure until PATH set + +.ne 5 + $ENV{\'PATH\'} = \'/bin:/usr/bin\'; + $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\'; + + $path = $ENV{\'PATH\'}; # Not tainted + system "echo $abc"; # Is secure now! + +.ne 5 + open(FOO,"$foo"); # OK + open(FOO,">$foo"); # Not OK + + open(FOO,"echo $foo|"); # Not OK, but... + open(FOO,"-|") || exec \'echo\', $foo; # OK + + $zzz = `echo $foo`; # Insecure, zzz tainted + + unlink $abc,$foo; # Insecure + umask $foo; # Insecure + +.ne 3 + exec "echo $foo"; # Insecure + exec "echo", $foo; # Secure (doesn't use sh) + exec "sh", \'-c\', $foo; # Considered secure, alas + +.fi +The taintedness is associated with each scalar value, so some elements +of an array can be tainted, and others not. +.PP +If you try to do something insecure, you will get a fatal error saying +something like \*(L"Insecure dependency\*(R" or \*(L"Insecure PATH\*(R". +Note that you can still write an insecure system call or exec, +but only by explicity doing something like the last example above. +You can also bypass the tainting mechanism by referencing +subpatterns\*(--\c +.I perl +presumes that if you reference a substring using $1, $2, etc, you knew +what you were doing when you wrote the pattern: +.nf + + $ARGV[0] =~ /^\-P(\ew+)$/; + $printer = $1; # Not tainted + +.fi +This is fairly secure since \ew+ doesn't match shell metacharacters. +Use of .+ would have been insecure, but +.I perl +doesn't check for that, so you must be careful with your patterns. +This is the ONLY mechanism for untainting user supplied filenames if you +want to do file operations on them (unless you make $> equal to $<). +.PP +It's also possible to get into trouble with other operations that don't care +whether they use tainted values. +Make judicious use of the file tests in dealing with any user-supplied +filenames. +When possible, do opens and such after setting $> = $<. +.I Perl +doesn't prevent you from opening tainted filenames for reading, so be +careful what you print out. +The tainting mechanism is intended to prevent stupid mistakes, not to remove +the need for thought. +.SH ENVIRONMENT +.I Perl +uses PATH in executing subprocesses, and in finding the script if \-S +is used. +HOME or LOGDIR are used if chdir has no argument. +.PP +Apart from these, +.I perl +uses no environment variables, except to make them available +to the script being executed, and to child processes. +However, scripts running setuid would do well to execute the following lines +before doing anything else, just to keep people honest: +.nf + +.ne 3 + $ENV{\'PATH\'} = \'/bin:/usr/bin\'; # or whatever you need + $ENV{\'SHELL\'} = \'/bin/sh\' if $ENV{\'SHELL\'} ne \'\'; + $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\'; + +.fi +.SH AUTHOR +Larry Wall +.SH FILES +/tmp/perl\-eXXXXXX temporary file for +.B \-e +commands. +.SH SEE ALSO +a2p awk to perl translator +.br +s2p sed to perl translator +.SH DIAGNOSTICS +Compilation errors will tell you the line number of the error, with an +indication of the next token or token type that was to be examined. +(In the case of a script passed to +.I perl +via +.B \-e +switches, each +.B \-e +is counted as one line.) +.PP +Setuid scripts have additional constraints that can produce error messages +such as \*(L"Insecure dependency\*(R". +See the section on setuid scripts. +.SH TRAPS +Accustomed +.IR awk +users should take special note of the following: +.Ip * 4 2 +Semicolons are required after all simple statements in +.IR perl . +Newline +is not a statement delimiter. +.Ip * 4 2 +Curly brackets are required on ifs and whiles. +.Ip * 4 2 +Variables begin with $ or @ in +.IR perl . +.Ip * 4 2 +Arrays index from 0 unless you set $[. +Likewise string positions in substr() and index(). +.Ip * 4 2 +You have to decide whether your array has numeric or string indices. +.Ip * 4 2 +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 +to an array. +And the +.I split +operator has different arguments. +.Ip * 4 2 +The current input line is normally in $_, not $0. +It generally does not have the newline stripped. +($0 is initially the name of the program executed, then the last matched +string.) +.Ip * 4 2 +$ does not refer to fields\*(--it refers to substrings matched by the last +match pattern. +.Ip * 4 2 +The +.I print +statement does not add field and record separators unless you set +$, and $\e. +.Ip * 4 2 +You must open your files before you print to them. +.Ip * 4 2 +The range operator is \*(L".\|.\*(R", not comma. +(The comma operator works as in C.) +.Ip * 4 2 +The match operator is \*(L"=~\*(R", not \*(L"~\*(R". +(\*(L"~\*(R" is the one's complement operator, as in C.) +.Ip * 4 2 +The exponentiation operator is \*(L"**\*(R", not \*(L"^\*(R". +(\*(L"^\*(R" is the XOR operator, as in C.) +.Ip * 4 2 +The concatenation operator is \*(L".\*(R", not the null string. +(Using the null string would render \*(L"/pat/ /pat/\*(R" unparsable, +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 +.IR Next , +.I exit +and +.I continue +work differently. +.Ip * 4 2 +The following variables work differently +.nf + + Awk \h'|2.5i'Perl + ARGC \h'|2.5i'$#ARGV + ARGV[0] \h'|2.5i'$0 + FILENAME\h'|2.5i'$ARGV + FNR \h'|2.5i'$. \- something + FS \h'|2.5i'(whatever you like) + NF \h'|2.5i'$#Fld, or some such + NR \h'|2.5i'$. + OFMT \h'|2.5i'$# + OFS \h'|2.5i'$, + ORS \h'|2.5i'$\e + RLENGTH \h'|2.5i'length($&) + RS \h'|2.5i'$/ + RSTART \h'|2.5i'length($\`) + SUBSEP \h'|2.5i'$; + +.fi +.Ip * 4 2 +When in doubt, run the +.I awk +construct through a2p and see what it gives you. +.PP +Cerebral C programmers should take note of the following: +.Ip * 4 2 +Curly brackets are required on ifs and whiles. +.Ip * 4 2 +You should use \*(L"elsif\*(R" rather than \*(L"else if\*(R" +.Ip * 4 2 +.I Break +and +.I continue +become +.I last +and +.IR next , +respectively. +.Ip * 4 2 +There's no switch statement. +.Ip * 4 2 +Variables begin with $ or @ in +.IR perl . +.Ip * 4 2 +Printf does not implement *. +.Ip * 4 2 +Comments begin with #, not /*. +.Ip * 4 2 +You can't take the address of anything. +.Ip * 4 2 +ARGV must be capitalized. +.Ip * 4 2 +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. +.Ip * 4 2 +You can't subscript array values, only arrays (no $x = (1,2,3)[2];). +.PP +Seasoned +.I sed +programmers should take note of the following: +.Ip * 4 2 +Backreferences in substitutions use $ rather than \e. +.Ip * 4 2 +The pattern matching metacharacters (, ), and | do not have backslashes in front. +.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. +.I 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. +.I 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 +.I Perl +is at the mercy of your machine's definitions of various operations +such as type casting, atof() and sprintf(). +.PP +If your stdio requires an seek or eof between reads and writes on a particular +stream, so does +.IR perl . +.PP +While none of the built-in data types have any arbitrary size limits (apart +from memory size), there are still a few arbitrary limits: +a given identifier may not be longer than 255 characters; +sprintf is limited on many machines to 128 characters per field (unless the format +specifier is exactly %s); +and no component of your PATH may be longer than 255 if you use \-S. +.PP +.I Perl +actually stands for Pathologically Eclectic Rubbish Lister, but don't tell +anyone I said that. +.rn }` '' diff --git a/perl.y b/perl.y index 45feaaf..827448e 100644 --- a/perl.y +++ b/perl.y @@ -1,8 +1,13 @@ -/* $Header: perl.y,v 2.0 88/06/05 00:09:36 root Exp $ +/* $Header: perl.y,v 3.0 89/10/18 15:22:04 lwall Locked $ + * + * Copyright (c) 1989, Larry Wall + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.y,v $ - * Revision 2.0 88/06/05 00:09:36 root - * Baseline version 2.0. + * Revision 3.0 89/10/18 15:22:04 lwall + * 3.0 baseline * */ @@ -10,35 +15,9 @@ #include "INTERN.h" #include "perl.h" -char *tokename[] = { -"256", -"word", -"append","open","write","select","close","loopctl", -"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", "file test", "local", "delete", -"format lines", -"register","array_length", "array", -"s","pattern", -"string","tr", -"list operator", -"..", -"||", -"&&", -"==","!=", "EQ", "NE", -"<=",">=", "LT", "GT", "LE", "GE", -"unary operation", -"file test", -"<<",">>", -"=~","!~", -"unary -", -"++", "--", -"???" -}; - STAB *scrstab; +ARG *arg4; /* rarely used arguments to make_op() */ +ARG *arg5; %} @@ -55,22 +34,22 @@ STAB *scrstab; } %token WORD -%token APPEND OPEN WRITE SELECT CLOSE LOOPEX +%token APPEND OPEN SELECT LOOPEX %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 FILETEST LOCAL DELETE +%token WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST +%token FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25 +%token FUNC0 FUNC1 FUNC2 FUNC3 HSHFUN HSHFUN3 +%token FLIST2 SUB FILETEST LOCAL DELETE +%token RELOP EQOP MULOP ADDOP PACKAGE AMPER LFUNC4 %token FORMLIST -%token REG ARYLEN ARY +%token REG ARYLEN ARY HSH STAR %token SUBST PATTERN %token RSTRING TRANS -%type prog decl format +%type prog decl format remember %type %type block lineseq line loop cond sideff nexpr else -%type expr sexpr term -%type condmod loopmod +%type expr sexpr cexpr csexpr term handle aryword hshword %type texpr listop %type label %type compblock @@ -84,15 +63,16 @@ STAB *scrstab; %left ANDAND %left '|' '^' %left '&' -%nonassoc EQ NE SEQ SNE -%nonassoc '<' '>' LE GE SLT SGT SLE SGE +%nonassoc EQOP +%nonassoc RELOP %nonassoc UNIOP %nonassoc FILETEST %left LS RS -%left '+' '-' '.' -%left '*' '/' '%' 'x' +%left ADDOP +%left MULOP %left MATCH NMATCH %right '!' '~' UMINUS +%right POW %nonassoc INC DEC %left '(' @@ -117,11 +97,17 @@ else : /* NULL */ { $$ = $2; } | ELSIF '(' expr ')' compblock { cmdline = $1; - $$ = make_ccmd(C_IF,$3,$5); } + $$ = make_ccmd(C_ELSIF,$3,$5); } ; -block : '{' lineseq '}' - { $$ = block_head($2); } +block : '{' remember lineseq '}' + { $$ = block_head($3); + if (savestack->ary_fill > $2) + restorelist($2); } + ; + +remember: /* NULL */ /* in case they push a package name */ + { $$ = savestack->ary_fill; } ; lineseq : /* NULL */ @@ -145,22 +131,30 @@ line : decl { $$ = add_label($1,$2); } ; -sideff : expr +sideff : error + { $$ = Nullcmd; } + | expr { $$ = make_acmd(C_EXPR, Nullstab, $1, Nullarg); } - | expr condmod + | expr IF expr { $$ = addcond( - make_acmd(C_EXPR, Nullstab, Nullarg, $1), $2); } - | expr loopmod + make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); } + | expr UNLESS expr + { $$ = addcond(invert( + make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); } + | expr WHILE expr { $$ = addloop( - make_acmd(C_EXPR, Nullstab, Nullarg, $1), $2); } + make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); } + | expr UNTIL expr + { $$ = addloop(invert( + make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); } ; cond : IF '(' expr ')' compblock { cmdline = $1; - $$ = make_ccmd(C_IF,$3,$5); } + $$ = make_icmd(C_IF,$3,$5); } | UNLESS '(' expr ')' compblock { cmdline = $1; - $$ = invert(make_ccmd(C_IF,$3,$5)); } + $$ = invert(make_icmd(C_IF,$3,$5)); } | IF block compblock { cmdline = $1; $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); } @@ -195,6 +189,9 @@ loop : label WHILE '(' texpr ')' compblock * @ary = EXPR; * foreach VAR (@ary) { * where @ary is a hidden array made by genstab(). + * (Note that @ary may become a local array if + * it is determined that it might be called + * recursively. See cmd_tosave().) */ if ($5->arg_type != O_ARRAY) { scrstab = aadd(genstab()); @@ -204,14 +201,14 @@ loop : label WHILE '(' texpr ')' compblock listish(make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), Nullarg,Nullarg, 1)), - listish($5), - Nullarg,1)), + listish(make_list($5)), + Nullarg)), Nullarg), wopt(over($3,add_label($1, make_ccmd(C_WHILE, make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), - Nullarg,Nullarg, 1 ), + Nullarg,Nullarg ), $7))))); } else { @@ -229,14 +226,14 @@ loop : label WHILE '(' texpr ')' compblock listish(make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), Nullarg,Nullarg, 1 )), - listish($4), - Nullarg,1)), + listish(make_list($4)), + Nullarg)), Nullarg), wopt(over(defstab,add_label($1, make_ccmd(C_WHILE, make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), - Nullarg,Nullarg, 1 ), + Nullarg,Nullarg ), $6))))); } else { /* lisp, anyone? */ @@ -261,7 +258,7 @@ nexpr : /* NULL */ ; texpr : /* NULL means true */ - { scanstr("1"); $$ = yylval.arg; } + { (void)scanstr("1"); $$ = yylval.arg; } | expr ; @@ -270,196 +267,196 @@ label : /* empty */ | WORD ':' ; -loopmod : WHILE expr - { $$ = $2; } - | UNTIL expr - { $$ = make_op(O_NOT,1,$2,Nullarg,Nullarg,0); } - ; - -condmod : IF expr - { $$ = $2; } - | UNLESS expr - { $$ = make_op(O_NOT,1,$2,Nullarg,Nullarg,0); } - ; - decl : format { $$ = 0; } | subrout { $$ = 0; } + | package + { $$ = 0; } ; -format : FORMAT WORD '=' FORMLIST '.' - { stabent($2,TRUE)->stab_form = $4; safefree($2); } - | FORMAT '=' FORMLIST '.' - { stabent("stdout",TRUE)->stab_form = $3; } +format : FORMAT WORD '=' FORMLIST + { stab_form(stabent($2,TRUE)) = $4; Safefree($2);} + | FORMAT '=' FORMLIST + { stab_form(stabent("STDOUT",TRUE)) = $3; } ; subrout : SUB WORD block { make_sub($2,$3); } ; -expr : sexpr ',' expr - { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg,0); } +package : PACKAGE WORD ';' + { char tmpbuf[256]; + + savehptr(&curstash); + saveitem(curstname); + str_set(curstname,$2); + sprintf(tmpbuf,"'_%s",$2); + curstash = stab_xhash(hadd(stabent(tmpbuf,TRUE))); + curstash->tbl_coeffsize = 0; + Safefree($2); + } + ; + +cexpr : ',' expr + { $$ = $2; } + ; + +expr : expr ',' sexpr + { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg); } | sexpr ; +csexpr : ',' sexpr + { $$ = $2; } + ; + sexpr : sexpr '=' sexpr { $1 = listish($1); + if ($1->arg_type == O_ASSIGN && $1->arg_len == 1) + $1->arg_type = O_ITEM; /* a local() */ if ($1->arg_type == O_LIST) $3 = listish($3); - $$ = l(make_op(O_ASSIGN, 2, $1, $3, Nullarg,1)); } - | sexpr '*' '=' sexpr - { $$ = l(make_op(O_MULTIPLY, 2, $1, $4, Nullarg,0)); } - | sexpr '/' '=' sexpr - { $$ = l(make_op(O_DIVIDE, 2, $1, $4, Nullarg,0)); } - | sexpr '%' '=' sexpr - { $$ = l(make_op(O_MODULO, 2, $1, $4, Nullarg,0)); } - | sexpr 'x' '=' sexpr - { $$ = l(make_op(O_REPEAT, 2, $1, $4, Nullarg,0)); } - | sexpr '+' '=' sexpr - { $$ = l(make_op(O_ADD, 2, $1, $4, Nullarg,0)); } - | sexpr '-' '=' sexpr - { $$ = l(make_op(O_SUBTRACT, 2, $1, $4, Nullarg,0)); } + $$ = l(make_op(O_ASSIGN, 2, $1, $3, Nullarg)); } + | sexpr POW '=' sexpr + { $$ = l(make_op(O_POW, 2, $1, $4, Nullarg)); } + | sexpr MULOP '=' sexpr + { $$ = l(make_op($2, 2, $1, $4, Nullarg)); } + | sexpr ADDOP '=' sexpr + { $$ = rcatmaybe(l(make_op($2, 2, $1, $4, Nullarg)));} | sexpr LS '=' sexpr - { $$ = l(make_op(O_LEFT_SHIFT, 2, $1, $4, Nullarg,0)); } + { $$ = l(make_op(O_LEFT_SHIFT, 2, $1, $4, Nullarg)); } | sexpr RS '=' sexpr - { $$ = l(make_op(O_RIGHT_SHIFT, 2, $1, $4, Nullarg,0)); } + { $$ = l(make_op(O_RIGHT_SHIFT, 2, $1, $4, Nullarg)); } | sexpr '&' '=' sexpr - { $$ = l(make_op(O_BIT_AND, 2, $1, $4, Nullarg,0)); } + { $$ = l(make_op(O_BIT_AND, 2, $1, $4, Nullarg)); } | sexpr '^' '=' sexpr - { $$ = l(make_op(O_XOR, 2, $1, $4, Nullarg,0)); } + { $$ = l(make_op(O_XOR, 2, $1, $4, Nullarg)); } | sexpr '|' '=' sexpr - { $$ = l(make_op(O_BIT_OR, 2, $1, $4, Nullarg,0)); } - | sexpr '.' '=' sexpr - { $$ = l(make_op(O_CONCAT, 2, $1, $4, Nullarg,0)); } - - - | sexpr '*' sexpr - { $$ = make_op(O_MULTIPLY, 2, $1, $3, Nullarg,0); } - | sexpr '/' sexpr - { $$ = make_op(O_DIVIDE, 2, $1, $3, Nullarg,0); } - | sexpr '%' sexpr - { $$ = make_op(O_MODULO, 2, $1, $3, Nullarg,0); } - | sexpr 'x' sexpr - { $$ = make_op(O_REPEAT, 2, $1, $3, Nullarg,0); } - | sexpr '+' sexpr - { $$ = make_op(O_ADD, 2, $1, $3, Nullarg,0); } - | sexpr '-' sexpr - { $$ = make_op(O_SUBTRACT, 2, $1, $3, Nullarg,0); } + { $$ = l(make_op(O_BIT_OR, 2, $1, $4, Nullarg)); } + + + | sexpr POW sexpr + { $$ = make_op(O_POW, 2, $1, $3, Nullarg); } + | sexpr MULOP sexpr + { $$ = make_op($2, 2, $1, $3, Nullarg); } + | sexpr ADDOP sexpr + { $$ = make_op($2, 2, $1, $3, Nullarg); } | sexpr LS sexpr - { $$ = make_op(O_LEFT_SHIFT, 2, $1, $3, Nullarg,0); } + { $$ = make_op(O_LEFT_SHIFT, 2, $1, $3, Nullarg); } | sexpr RS sexpr - { $$ = make_op(O_RIGHT_SHIFT, 2, $1, $3, Nullarg,0); } - | sexpr '<' sexpr - { $$ = make_op(O_LT, 2, $1, $3, Nullarg,0); } - | sexpr '>' sexpr - { $$ = make_op(O_GT, 2, $1, $3, Nullarg,0); } - | sexpr LE sexpr - { $$ = make_op(O_LE, 2, $1, $3, Nullarg,0); } - | sexpr GE sexpr - { $$ = make_op(O_GE, 2, $1, $3, Nullarg,0); } - | sexpr EQ sexpr - { $$ = make_op(O_EQ, 2, $1, $3, Nullarg,0); } - | sexpr NE sexpr - { $$ = make_op(O_NE, 2, $1, $3, Nullarg,0); } - | sexpr SLT sexpr - { $$ = make_op(O_SLT, 2, $1, $3, Nullarg,0); } - | sexpr SGT sexpr - { $$ = make_op(O_SGT, 2, $1, $3, Nullarg,0); } - | sexpr SLE sexpr - { $$ = make_op(O_SLE, 2, $1, $3, Nullarg,0); } - | sexpr SGE sexpr - { $$ = make_op(O_SGE, 2, $1, $3, Nullarg,0); } - | sexpr SEQ sexpr - { $$ = make_op(O_SEQ, 2, $1, $3, Nullarg,0); } - | sexpr SNE sexpr - { $$ = make_op(O_SNE, 2, $1, $3, Nullarg,0); } + { $$ = make_op(O_RIGHT_SHIFT, 2, $1, $3, Nullarg); } + | sexpr RELOP sexpr + { $$ = make_op($2, 2, $1, $3, Nullarg); } + | sexpr EQOP sexpr + { $$ = make_op($2, 2, $1, $3, Nullarg); } | sexpr '&' sexpr - { $$ = make_op(O_BIT_AND, 2, $1, $3, Nullarg,0); } + { $$ = make_op(O_BIT_AND, 2, $1, $3, Nullarg); } | sexpr '^' sexpr - { $$ = make_op(O_XOR, 2, $1, $3, Nullarg,0); } + { $$ = make_op(O_XOR, 2, $1, $3, Nullarg); } | sexpr '|' sexpr - { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg,0); } + { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg); } | sexpr DOTDOT sexpr - { $$ = make_op(O_FLIP, 4, - flipflip($1), - flipflip($3), - Nullarg,0);} + { arg4 = Nullarg; + $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg); } | sexpr ANDAND sexpr - { $$ = make_op(O_AND, 2, $1, $3, Nullarg,0); } + { $$ = make_op(O_AND, 2, $1, $3, Nullarg); } | sexpr OROR sexpr - { $$ = make_op(O_OR, 2, $1, $3, Nullarg,0); } + { $$ = make_op(O_OR, 2, $1, $3, Nullarg); } | sexpr '?' sexpr ':' sexpr - { $$ = make_op(O_COND_EXPR, 3, $1, $3, $5,0); } - | sexpr '.' sexpr - { $$ = make_op(O_CONCAT, 2, $1, $3, Nullarg,0); } + { $$ = make_op(O_COND_EXPR, 3, $1, $3, $5); } | sexpr MATCH sexpr { $$ = mod_match(O_MATCH, $1, $3); } | sexpr NMATCH sexpr { $$ = mod_match(O_NMATCH, $1, $3); } | term INC { $$ = addflags(1, AF_POST|AF_UP, - l(make_op(O_ITEM,1,$1,Nullarg,Nullarg,0))); } + l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); } | term DEC { $$ = addflags(1, AF_POST, - l(make_op(O_ITEM,1,$1,Nullarg,Nullarg,0))); } + l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); } | INC term { $$ = addflags(1, AF_PRE|AF_UP, - l(make_op(O_ITEM,1,$2,Nullarg,Nullarg,0))); } + l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); } | DEC term { $$ = addflags(1, AF_PRE, - l(make_op(O_ITEM,1,$2,Nullarg,Nullarg,0))); } + l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); } | term { $$ = $1; } ; term : '-' term %prec UMINUS - { $$ = make_op(O_NEGATE, 1, $2, Nullarg, Nullarg,0); } + { $$ = make_op(O_NEGATE, 1, $2, Nullarg, Nullarg); } + | '+' term %prec UMINUS + { $$ = $2; } | '!' term - { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg,0); } + { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg); } | '~' term - { $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg,0);} + { $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg);} | FILETEST WORD { opargs[$1] = 0; /* force it special */ $$ = make_op($1, 1, stab2arg(A_STAB,stabent($2,TRUE)), - Nullarg, Nullarg,0); + Nullarg, Nullarg); } | FILETEST sexpr { opargs[$1] = 1; - $$ = make_op($1, 1, $2, Nullarg, Nullarg,0); } + $$ = make_op($1, 1, $2, Nullarg, Nullarg); } | FILETEST { opargs[$1] = ($1 != O_FTTTY); $$ = make_op($1, 1, stab2arg(A_STAB, - $1 == O_FTTTY?stabent("stdin",TRUE):defstab), - Nullarg, Nullarg,0); } + $1 == O_FTTTY?stabent("STDIN",TRUE):defstab), + Nullarg, Nullarg); } | LOCAL '(' expr ')' - { $$ = localize(listish(make_list(hide_ary($3)))); } + { $$ = l(make_op(O_ITEM, 1, + localize(listish(make_list($3))), + Nullarg,Nullarg)); } | '(' expr ')' { $$ = make_list(hide_ary($2)); } | '(' ')' { $$ = make_list(Nullarg); } | DO sexpr %prec FILETEST - { $$ = make_op(O_DOFILE,1,$2,Nullarg,Nullarg,0); - allstabs = TRUE;} + { $$ = fixeval( + make_op(O_DOFILE,2,$2,Nullarg,Nullarg) ); + allstabs = TRUE;} | DO block %prec '(' { $$ = cmd_to_arg($2); } | REG %prec '(' { $$ = stab2arg(A_STAB,$1); } + | STAR %prec '(' + { $$ = stab2arg(A_STAR,$1); } | REG '[' expr ']' %prec '(' - { $$ = make_op(O_ARRAY, 2, - $3, stab2arg(A_STAB,aadd($1)), Nullarg,0); } + { $$ = make_op(O_AELEM, 2, + stab2arg(A_STAB,aadd($1)), $3, Nullarg); } + | HSH %prec '(' + { $$ = make_op(O_HASH, 1, + stab2arg(A_STAB,$1), + Nullarg, Nullarg); } | ARY %prec '(' { $$ = make_op(O_ARRAY, 1, stab2arg(A_STAB,$1), - Nullarg, Nullarg, 1); } + Nullarg, Nullarg); } | REG '{' expr '}' %prec '(' - { $$ = make_op(O_HASH, 2, - $3, stab2arg(A_STAB,hadd($1)), Nullarg,0); } + { $$ = make_op(O_HELEM, 2, + stab2arg(A_STAB,hadd($1)), + jmaybe($3), + Nullarg); } + | ARY '[' expr ']' %prec '(' + { $$ = make_op(O_ASLICE, 2, + stab2arg(A_STAB,aadd($1)), + listish(make_list($3)), + Nullarg); } + | ARY '{' expr '}' %prec '(' + { $$ = make_op(O_HSLICE, 2, + stab2arg(A_STAB,hadd($1)), + listish(make_list($3)), + Nullarg); } | DELETE REG '{' expr '}' %prec '(' { $$ = make_op(O_DELETE, 2, - $4, stab2arg(A_STAB,hadd($2)), Nullarg,0); } + stab2arg(A_STAB,hadd($2)), + jmaybe($4), + Nullarg); } | ARYLEN %prec '(' { $$ = stab2arg(A_ARYLEN,$1); } | RSTRING %prec '(' @@ -471,249 +468,241 @@ term : '-' term %prec UMINUS | TRANS %prec '(' { $$ = $1; } | DO WORD '(' expr ')' - { $$ = make_op(O_SUBR, 2, + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent($2,TRUE)), make_list($4), + Nullarg); Safefree($2); } + | AMPER WORD '(' expr ')' + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_WORD,stabent($2,TRUE)), - Nullarg,1); } + make_list($4), + Nullarg); Safefree($2); } | DO WORD '(' ')' - { $$ = make_op(O_SUBR, 2, + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent($2,TRUE)), make_list(Nullarg), + Nullarg); } + | AMPER WORD '(' ')' + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_WORD,stabent($2,TRUE)), - Nullarg,1); } + make_list(Nullarg), + Nullarg); } + | AMPER WORD + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent($2,TRUE)), + Nullarg, + Nullarg); } | DO REG '(' expr ')' - { $$ = make_op(O_SUBR, 2, + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,$2), make_list($4), + Nullarg); } + | AMPER REG '(' expr ')' + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_STAB,$2), - Nullarg,1); } + make_list($4), + Nullarg); } | DO REG '(' ')' - { $$ = make_op(O_SUBR, 2, + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,$2), make_list(Nullarg), + Nullarg); } + | AMPER REG '(' ')' + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_STAB,$2), - Nullarg,1); } + make_list(Nullarg), + Nullarg); } + | AMPER REG + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,$2), + Nullarg, + Nullarg); } | LOOPEX - { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg,0); } + { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); } | LOOPEX WORD { $$ = make_op($1,1,cval_to_arg($2), - Nullarg,Nullarg,0); } + Nullarg,Nullarg); } | UNIOP - { $$ = make_op($1,1,Nullarg,Nullarg,Nullarg,0); } + { $$ = make_op($1,1,Nullarg,Nullarg,Nullarg); + if ($1 == O_EVAL || $1 == O_RESET) + $$ = fixeval($$); } | UNIOP sexpr - { $$ = make_op($1,1,$2,Nullarg,Nullarg,0); } - | WRITE - { $$ = make_op(O_WRITE, 0, - Nullarg, Nullarg, Nullarg,0); } - | WRITE '(' ')' - { $$ = make_op(O_WRITE, 0, - Nullarg, Nullarg, Nullarg,0); } - | WRITE '(' WORD ')' - { $$ = l(make_op(O_WRITE, 1, - 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, - stab2arg(A_STAB,stabent($3,TRUE)), - Nullarg, Nullarg,0)); safefree($3); } - | SELECT '(' expr ')' - { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg,0); } + { $$ = make_op($1,1,$2,Nullarg,Nullarg); + if ($1 == O_EVAL || $1 == O_RESET) + $$ = fixeval($$); } + | SELECT + { $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);} + | SELECT '(' handle ')' + { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg); } + | SELECT '(' sexpr csexpr csexpr csexpr ')' + { arg4 = $6; + $$ = make_op(O_SSELECT, 4, $3, $4, $5); } | OPEN WORD %prec '(' { $$ = make_op(O_OPEN, 2, stab2arg(A_WORD,stabent($2,TRUE)), stab2arg(A_STAB,stabent($2,TRUE)), - Nullarg,0); } + Nullarg); } | OPEN '(' WORD ')' { $$ = make_op(O_OPEN, 2, stab2arg(A_WORD,stabent($3,TRUE)), stab2arg(A_STAB,stabent($3,TRUE)), - Nullarg,0); } - | OPEN '(' WORD ',' expr ')' - { $$ = make_op(O_OPEN, 2, - stab2arg(A_WORD,stabent($3,TRUE)), - $5, Nullarg,0); } - | OPEN '(' sexpr ',' expr ')' + Nullarg); } + | OPEN '(' handle cexpr ')' { $$ = make_op(O_OPEN, 2, $3, - $5, Nullarg,0); } - | CLOSE '(' WORD ')' - { $$ = make_op(O_CLOSE, 1, - stab2arg(A_WORD,stabent($3,TRUE)), - Nullarg, Nullarg,0); } - | CLOSE '(' expr ')' - { $$ = make_op(O_CLOSE, 1, + $4, Nullarg); } + | FILOP '(' handle ')' + { $$ = make_op($1, 1, $3, - Nullarg, Nullarg,0); } - | CLOSE WORD %prec '(' - { $$ = make_op(O_CLOSE, 1, + Nullarg, Nullarg); } + | FILOP WORD + { $$ = make_op($1, 1, stab2arg(A_WORD,stabent($2,TRUE)), - Nullarg, Nullarg,0); } - | FEOF '(' WORD ')' - { $$ = make_op(O_EOF, 1, - 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, 1, + Nullarg, Nullarg); + Safefree($2); } + | FILOP REG + { $$ = make_op($1, 1, + stab2arg(A_STAB,$2), + Nullarg, Nullarg); } + | FILOP '(' ')' + { $$ = make_op($1, 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, - 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, - 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 ')' + Nullarg, Nullarg); } + | FILOP %prec '(' + { $$ = make_op($1, 0, + Nullarg, Nullarg, Nullarg); } + | FILOP2 '(' handle cexpr ')' + { $$ = make_op($1, 2, $3, $4, Nullarg); } + | FILOP3 '(' handle csexpr cexpr ')' + { $$ = make_op($1, 3, $3, $4, $5); } + | FILOP22 '(' handle ',' handle ')' + { $$ = make_op($1, 2, $3, $5, Nullarg); } + | FILOP4 '(' handle csexpr csexpr cexpr ')' + { arg4 = $6; $$ = make_op($1, 4, $3, $4, $5); } + | FILOP25 '(' handle ',' handle csexpr csexpr cexpr ')' + { arg4 = $7; arg5 = $8; + $$ = make_op($1, 5, $3, $5, $6); } + | PUSH '(' aryword cexpr ')' { $$ = make_op($1, 2, - make_list($5), - stab2arg(A_STAB,aadd(stabent($3,TRUE))), - Nullarg,1); } - | PUSH '(' ARY ',' expr ')' - { $$ = make_op($1, 2, - make_list($5), - stab2arg(A_STAB,$3), - Nullarg,1); } - | POP WORD %prec '(' - { $$ = make_op(O_POP, 1, - stab2arg(A_STAB,aadd(stabent($2,TRUE))), - Nullarg, Nullarg,0); } - | POP '(' WORD ')' - { $$ = make_op(O_POP, 1, - stab2arg(A_STAB,aadd(stabent($3,TRUE))), - Nullarg, Nullarg,0); } - | POP ARY %prec '(' - { $$ = make_op(O_POP, 1, - stab2arg(A_STAB,$2), - Nullarg, - Nullarg, - 0); } - | POP '(' ARY ')' - { $$ = make_op(O_POP, 1, - stab2arg(A_STAB,$3), - Nullarg, - Nullarg, - 0); } - | SHIFT WORD %prec '(' - { $$ = make_op(O_SHIFT, 1, - stab2arg(A_STAB,aadd(stabent($2,TRUE))), - Nullarg, Nullarg,0); } - | SHIFT '(' WORD ')' - { $$ = make_op(O_SHIFT, 1, - stab2arg(A_STAB,aadd(stabent($3,TRUE))), - Nullarg, Nullarg,0); } - | SHIFT ARY %prec '(' - { $$ = make_op(O_SHIFT, 1, - stab2arg(A_STAB,$2), Nullarg, Nullarg,0); } - | SHIFT '(' ARY ')' - { $$ = make_op(O_SHIFT, 1, - stab2arg(A_STAB,$3), Nullarg, Nullarg,0); } + $3, + make_list($4), + Nullarg); } + | POP aryword %prec '(' + { $$ = make_op(O_POP, 1, $2, Nullarg, Nullarg); } + | POP '(' aryword ')' + { $$ = make_op(O_POP, 1, $3, Nullarg, Nullarg); } + | SHIFT aryword %prec '(' + { $$ = make_op(O_SHIFT, 1, $2, Nullarg, Nullarg); } + | SHIFT '(' aryword ')' + { $$ = make_op(O_SHIFT, 1, $3, Nullarg, Nullarg); } | SHIFT %prec '(' { $$ = make_op(O_SHIFT, 1, - stab2arg(A_STAB,aadd(stabent("ARGV",TRUE))), - Nullarg, Nullarg,0); } + stab2arg(A_STAB, + aadd(stabent(subline ? "_" : "ARGV", TRUE))), + Nullarg, Nullarg); } | SPLIT %prec '(' - { scanpat("/\\s+/"); - $$ = make_split(defstab,yylval.arg); } - | SPLIT '(' WORD ')' - { scanpat("/\\s+/"); - $$ = make_split(stabent($3,TRUE),yylval.arg); } - | SPLIT '(' WORD ',' PATTERN ')' - { $$ = make_split(stabent($3,TRUE),$5); } - | SPLIT '(' WORD ',' PATTERN ',' sexpr ')' - { $$ = mod_match(O_MATCH, - $7, - make_split(stabent($3,TRUE),$5) ); } - | SPLIT '(' sexpr ',' sexpr ')' - { $$ = mod_match(O_MATCH, $5, make_split(defstab,$3) ); } + { (void)scanpat("/\\s+/"); + $$ = make_split(defstab,yylval.arg,Nullarg); } + | SPLIT '(' sexpr csexpr csexpr ')' + { $$ = mod_match(O_MATCH, $4, + make_split(defstab,$3,$5));} + | SPLIT '(' sexpr csexpr ')' + { $$ = mod_match(O_MATCH, $4, + make_split(defstab,$3,Nullarg) ); } | SPLIT '(' sexpr ')' { $$ = mod_match(O_MATCH, stab2arg(A_STAB,defstab), - make_split(defstab,$3) ); } - | JOIN '(' WORD ',' expr ')' - { $$ = make_op(O_JOIN, 2, - $5, - stab2arg(A_STAB,aadd(stabent($3,TRUE))), - Nullarg,0); } - | JOIN '(' sexpr ',' expr ')' - { $$ = make_op(O_JOIN, 2, + make_split(defstab,$3,Nullarg) ); } + | FLIST2 '(' sexpr cexpr ')' + { $$ = make_op($1, 2, $3, - make_list($5), - Nullarg,2); } - | SPRINTF '(' expr ')' - { $$ = make_op(O_SPRINTF, 1, + listish(make_list($4)), + Nullarg); } + | FLIST '(' expr ')' + { $$ = make_op($1, 1, make_list($3), Nullarg, - Nullarg,1); } - | STAT '(' WORD ')' - { $$ = l(make_op(O_STAT, 1, - stab2arg(A_STAB,stabent($3,TRUE)), - Nullarg, Nullarg,0)); } - | STAT '(' expr ')' - { $$ = make_op(O_STAT, 1, $3, Nullarg, Nullarg,0); } + Nullarg); } + | LVALFUN sexpr %prec '(' + { $$ = l(make_op($1, 1, fixl($1,$2), + Nullarg, Nullarg)); } | LVALFUN { $$ = l(make_op($1, 1, stab2arg(A_STAB,defstab), - Nullarg, Nullarg,0)); } - | LVALFUN '(' expr ')' - { $$ = l(make_op($1, 1, $3, Nullarg, Nullarg,0)); } + Nullarg, Nullarg)); } | FUNC0 - { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg,0); } + { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } | FUNC1 '(' expr ')' - { $$ = make_op($1, 1, $3, Nullarg, Nullarg,0); } - | FUNC2 '(' sexpr ',' expr ')' - { $$ = make_op($1, 2, $3, $5, Nullarg, 0); + { $$ = make_op($1, 1, $3, Nullarg, Nullarg); + if ($1 == O_EVAL || $1 == O_RESET) + $$ = fixeval($$); } + | FUNC2 '(' sexpr cexpr ')' + { $$ = make_op($1, 2, $3, $4, Nullarg); 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 ')' + fbmcompile($$[2].arg_ptr.arg_str,0); } + | FUNC3 '(' sexpr csexpr cexpr ')' + { $$ = make_op($1, 3, $3, $4, $5); } + | LFUNC4 '(' sexpr csexpr csexpr cexpr ')' + { arg4 = $6; $$ = make_op($1, 4, l($3), $4, $5); } + | HSHFUN '(' hshword ')' + { $$ = make_op($1, 1, + $3, + Nullarg, + Nullarg); } + | HSHFUN hshword { $$ = make_op($1, 1, - stab2arg(A_STAB,hadd(stabent($3,TRUE))), + $2, Nullarg, - Nullarg, 0); } + Nullarg); } + | HSHFUN3 '(' hshword csexpr cexpr ')' + { $$ = make_op($1, 3, $3, $4, $5); } | listop ; listop : LISTOP { $$ = make_op($1,2, - stab2arg(A_STAB,defstab), stab2arg(A_WORD,Nullstab), - Nullarg,0); } + stab2arg(A_STAB,defstab), + Nullarg); } | LISTOP expr - { $$ = make_op($1,2,make_list($2), + { $$ = make_op($1,2, stab2arg(A_WORD,Nullstab), - Nullarg,1); } + maybelistish($1,make_list($2)), + Nullarg); } | LISTOP WORD { $$ = make_op($1,2, - stab2arg(A_STAB,defstab), stab2arg(A_WORD,stabent($2,TRUE)), - Nullarg,1); } + stab2arg(A_STAB,defstab), + Nullarg); } | LISTOP WORD expr - { $$ = make_op($1,2,make_list($3), + { $$ = make_op($1,2, stab2arg(A_WORD,stabent($2,TRUE)), - Nullarg,1); } + maybelistish($1,make_list($3)), + Nullarg); Safefree($2); } | LISTOP REG expr - { $$ = make_op($1,2,make_list($3), + { $$ = make_op($1,2, stab2arg(A_STAB,$2), - Nullarg,1); } + maybelistish($1,make_list($3)), + Nullarg); } + ; + +handle : WORD + { $$ = stab2arg(A_WORD,stabent($1,TRUE)); Safefree($1);} + | sexpr + ; + +aryword : WORD + { $$ = stab2arg(A_WORD,aadd(stabent($1,TRUE))); + Safefree($1); } + | ARY + { $$ = stab2arg(A_STAB,$1); } + ; + +hshword : WORD + { $$ = stab2arg(A_WORD,hadd(stabent($1,TRUE))); + Safefree($1); } + | HSH + { $$ = stab2arg(A_STAB,$1); } ; %% /* PROGRAM */ diff --git a/perldb b/perldb deleted file mode 100644 index 9f03a76..0000000 --- a/perldb +++ /dev/null @@ -1,298 +0,0 @@ -#!/usr/bin/perl - -# $Header: perldb,v 2.0 88/06/05 00:09:45 root Exp $ -# -# $Log: perldb,v $ -# Revision 2.0 88/06/05 00:09:45 root -# Baseline version 2.0. -# -# - -$tmp = "/tmp/pdb$$"; # default temporary file, -o overrides. - -# parse any switches - -while ($ARGV[0] =~ /^-/) { - $_ = shift; - /^-o$/ && ($tmp = shift,next); - die "Unrecognized switch: $_"; -} - -$filename = shift; -die "Usage: perldb [-o output] scriptname arguments" unless $filename; - -open(script,$filename) || die "Can't find $filename"; - -open(tmp, ">$tmp") || die "Can't make temp script"; - -$perl = '/usr/bin/perl'; -$init = 1; -$state = 'statement'; - -# now translate script to contain DB calls at the appropriate places - -while (