-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.
# 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
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=''
medium=''
large=''
huge=''
+optimize=''
ccflags=''
ldflags=''
+cc=''
+libs=''
n=''
c=''
package=''
+randbits=''
+sig_name=''
spitshell=''
shsharp=''
sharpbang=''
uidtype=''
voidflags=''
defvoidused=''
+lib=''
privlib=''
CONFIG=''
: set package name
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
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.
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`
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
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
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.tmp >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.tmp >libc.list
+ else
+ $sed -n -e 's/^.* D __*//p' -e 's/^.* D //p' <libc.tmp >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.tmp >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."
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
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
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.c >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.c >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 <<EOSS
+$startsh
+: expand filename
+case "\$1" in
+ ~/*|~)
+ echo \$1 | $sed "s|~|\${HOME-\$LOGDIR}|"
+ ;;
+ ~*)
+ if $test -f /bin/csh; then
+ /bin/csh -f -c "glob \$1"
+ echo ""
else
- echo 'No such luck...maybe "cc -E" will work...'
- cc -E <testcpp.c >testcpp.out 2>&1
- if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "It works!"
- cppstdin='cc -E'
- cppminus='';
- else
- echo 'Nixed again...maybe "cc -E -" will work...'
- cc -E - <testcpp.c >testcpp.out 2>&1
- if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "Hooray, it works! I was beginning to wonder."
- cppstdin='cc -E'
- cppminus='-';
- else
- echo 'Nope...maybe "cc -P" will work...'
- cc -P <testcpp.c >testcpp.out 2>&1
- if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "Yup, that does."
- cppstdin='cc -P'
- cppminus='';
- else
- echo 'Nope...maybe "cc -P -" will work...'
- cc -P - <testcpp.c >testcpp.out 2>&1
- if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "Yup, that does."
- cppstdin='cc -P'
- cppminus='-';
- else
- echo 'Hmm...perhaps you already told me...'
- case "$cppstdin" in
- '') ;;
- *) $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1;;
- esac
- if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "Hooray, you did! I was beginning to wonder."
- else
- 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.c >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.c >testcpp.out 2>&1
- if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
- echo "OK, that will do."
- else
- echo "Sorry, I can't get that to work. Go find one."
- exit 1
- fi
- fi
- fi
- fi
- fi
- fi
+ name=\`$expr x\$1 : '..\([^/]*\)'\`
+ dir=\`$sed -n -e "/^\${name}:/{s/^[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:\([^:]*\).*"'\$'"/\1/" -e p -e q -e '}' </etc/passwd\`
+ if $test ! -d "\$dir"; then
+ me=\`basename \$0\`
+ echo "\$me: can't locate home directory for: \$name" >&2
+ exit 1
fi
- 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 <<EOM
-
-Some sites have disabled setuid #! scripts because of a bug in the kernel
-that prevents them from being secure. If you are on such a system, the
-setuid/setgid bits on scripts are currently useless. It is possible for
-$package to detect those bits and emulate setuid/setgid in a secure fashion
-until a better solution is devised for the kernel problem.
-
-EOM
-rp="Do you want to do setuid/setgid emulation? [$dflt]"
-echo $n "$rp $c"
-. myread
-case "$ans" in
-'') $ans="$dflt";;
-esac
-case "$ans" in
-y*) d_dosuid="$define";;
-*) d_dosuid="$undef";;
+*)
+ echo \$1
+ ;;
esac
+EOSS
+chmod +x filexp
+$eunicefix filexp
-: see if fchmod exists
-echo " "
-if $contains '^fchmod$' libc.list >/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 <<EOM
+
+$package has manual pages that need to be installed in source form.
+EOM
+case "$mansrc" in
+'')
+ dflt=`loc . /usr/man/man1 /usr/man/mann /usr/man/manl /usr/man/local/man1 /usr/man/u_man/man1 /usr/man/man1 /usr/man/man.L`
+ ;;
+*) dflt="$mansrc"
+ ;;
+esac
+cont=true
+while $test "$cont" ; do
+ echo " "
+ rp="Where do the manual pages (source) go? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ mansrc=`filexp "$ans"`
+ if $test -d "$mansrc"; then
+ cont=''
+ else
+ if $test "$fastread" = yes; then
+ dflt=y
+ else
+ dflt=n
+ fi
+ 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
+ ;;
+*o)
+ manext=l
+ ;;
+*p)
+ manext=n
+ ;;
+*C)
+ manext=C
+ ;;
+*L)
+ manext=L
+ ;;
+*)
+ manext=1
+ ;;
+esac
+
+: see what memory models we can support
+case "$models" in
+'')
+ : We may not use Cppsym or we get a circular dependency through cc.
+ : But this should work regardless of which cc we eventually use.
+ 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 <<EOM
+
+Some systems have different model sizes. On most systems they are called
+small, medium, large, and huge. On the PDP11 they are called unsplit and
+split. If your system doesn't support different memory models, say "none".
+If you wish to force everything to one memory model, say "none" here and
+put the appropriate flags later when it asks you for other cc and ld flags.
+Venix systems may wish to put "none" and let the compiler figure things out.
+(In the following question multiple model names should be space separated.)
+
+EOM
+rp="Which models are supported? [$dflt]"
+$echo $n "$rp $c"
+. myread
+models="$ans"
+
+case "$models" in
+none)
+ small=''
+ medium=''
+ large=''
+ huge=''
+ unsplit=''
+ split=''
+ ;;
+*split)
+ case "$split" in
+ '')
+ if $contains '\-i' $mansrc/man1/ld.1 >/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 <<EOH
+Some C compilers have problems with their optimizers, by default, $package
+compiles with the -O flag to use the optimizer. Alternately, you might
+want to use the symbolic debugger, which uses the -g flag (on traditional
+Unix systems). Either flag can be specified here. To use neither flag,
+specify the word "none".
+
+EOH
+rp="What optimizer/debugger flag should be used? [$dflt]"
+$echo $n "$rp $c"
+. myread
+optimize="$ans"
+case "$optimize" in
+'none') optimize=" "
+ ;;
+esac
+
+case "$ccflags" in
+'') case "$cc" in
+ gcc) dflt='-fpcc_struct_return';;
+ *) dflt='none';;
+ esac
+ ;;
+*) dflt="$ccflags";;
+esac
+echo " "
+rp="Any additional cc flags? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+none) ans='';
+esac
+ccflags="$ans"
+
+case "$ldflags" in
+'') if venix; then
+ dflt='-i -z'
+ else
+ dflt='none'
+ fi
+ ;;
+*) dflt="$ldflags";;
+esac
+echo " "
+rp="Any additional ld flags (NOT including libraries)? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+none) ans='';
+esac
+ldflags="$ans"
+rmlist="$rmlist pdp11"
+
+case "$libs" in
+'') dflt='none';;
+*) dflt="$libs";;
+esac
+
+$cat <<EOM
+
+Some versions of Unix support shared libraries, which make
+executables smaller but make load time slightly longer.
+
+On some systems, mostly newer Unix System V's, the shared library
+is included by putting the option "-lc_s" as the last thing on the
+cc command line when linking. Other systems use shared libraries
+by default. There may be other libraries needed to compile $package
+on your machine as well. If your system needs the "-lc_s" option,
+include it here. Include any other special libraries here as well.
+EOM
+
+echo " "
+rp="Any additional libraries? [$dflt]"
+$echo $n "$rp $c"
+. myread
+case "$ans" in
+none) ans='';
+esac
+libs="$ans"
+
+: check for ordering of bytes in a long
+case "$byteorder" in
+'')
+cat <<'EOM'
+
+In the following, larger digits indicate more significance. A big-endian
+machine like a Pyramid or a Motorola 680?0 chip will come out to 4321. A
+little-endian machine like a Vax or an Intel 80?86 chip would be 1234. Other
+machines may have weird orders like 3412. If the test program works the
+default is probably right. I'm now running the test program...
+EOM
+ $cat >try.c <<'EOCP'
+#include <stdio.h>
+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.c >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.c >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.c >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.c >testcpp.out 2>&1
+ if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Hooray, it works! I was beginning to wonder."
+ cppstdin="$cc -E"
+ cppminus='-';
+ else
+ echo 'Nope...maybe "'"$cc"' -P" will work...'
+ $cc -P <testcpp.c >testcpp.out 2>&1
+ if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yup, that does."
+ cppstdin="$cc -P"
+ cppminus='';
+ else
+ echo 'Nope...maybe "'"$cc"' -P -" will work...'
+ $cc -P - <testcpp.c >testcpp.out 2>&1
+ if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yup, that does."
+ cppstdin="$cc -P"
+ cppminus='-';
+ else
+ echo 'Hmm...perhaps you already told me...'
+ case "$cppstdin" in
+ '') ;;
+ *) $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1;;
+ esac
+ if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Hooray, you did! I was beginning to wonder."
+ else
+ 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.c >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.c >testcpp.out 2>&1
+ if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "OK, that will do."
+ else
+ echo "Sorry, I can't get that to work. Go find one."
+ exit 1
+ fi
+ fi
+ fi
+ fi
+ fi
+ 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 <varargs.h>
+
+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 <<EOM
+
+Some sites have disabled setuid #! scripts because of a bug in the kernel
+that prevents them from being secure. If you are on such a system, the
+setuid/setgid bits on scripts are currently useless. It is possible for
+$package to detect those bits and emulate setuid/setgid in a secure fashion
+until a better solution is devised for the kernel problem.
+
+EOM
+rp="Do you want to do setuid/setgid emulation? [$dflt]"
+echo $n "$rp $c"
+. myread
+case "$ans" in
+'') $ans="$dflt";;
+esac
+case "$ans" in
+y*) d_dosuid="$define";;
+*) d_dosuid="$undef";;
+esac
+
+: see if dup2 exists
+set dup2 d_dup2
+eval $inlibc
+
+: see if fchmod exists
+set fchmod d_fchmod
+eval $inlibc
+
+: see if fchown exists
+set fchown d_fchown
+eval $inlibc
+
+: see if this is an fcntl system
+echo " "
+if $test -r /usr/include/fcntl.h ; then
+ d_fcntl="$define"
+ echo "fcntl.h found."
+else
+ d_fcntl="$undef"
+ echo "No fcntl.h found, but that's ok."
+fi
+
+: see if flock exists
+set flock d_flock
+eval $inlibc
+
+: see if getgroups exists
+set getgroups d_getgrps
+eval $inlibc
+
+: see if gethostent exists
+set gethostent d_gethent
+eval $inlibc
+
+: see if getpgrp exists
+set getpgrp d_getpgrp
+eval $inlibc
+
+: see if getpriority exists
+set getpriority d_getprior
+eval $inlibc
+
+: see if htonl exists
+set htonl d_htonl
+eval $inlibc
+
+: index or strcpy
echo " "
-if $contains '^memcpy$' libc.list >/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
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..."
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
$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 <time.h> rather than <sys/time.h>."
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 <sys/time.h> rather than <time.h>."
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
#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
. myread
gidtype="$ans"
-: set up shell script to do ~ expansion
-cat >filexp <<EOSS
-$startsh
-: expand filename
-case "\$1" in
- ~/*|~)
- echo \$1 | $sed "s|~|\${HOME-\$LOGDIR}|"
- ;;
- ~*)
- if $test -f /bin/csh; then
- /bin/csh -f -c "glob \$1"
- echo ""
- else
- name=\`$expr x\$1 : '..\([^/]*\)'\`
- dir=\`$sed -n -e "/^\${name}:/{s/^[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:\([^:]*\).*"'\$'"/\1/" -e p -e q -e '}' </etc/passwd\`
- if $test ! -d "\$dir"; then
- me=\`basename \$0\`
- echo "\$me: can't locate home directory for: \$name" >&2
- exit 1
- fi
- case "\$1" in
- */*)
- echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\`
- ;;
- *)
- echo \$dir
- ;;
- esac
- fi
- ;;
-*)
- echo \$1
- ;;
-esac
-EOSS
-chmod +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 <<EOM
+: see if this is an fcntl system
+echo " "
+if $test -r /usr/include/fcntl.h ; then
+ i_fcntl="$define"
+ echo "fcntl.h found."
+else
+ i_fcntl="$undef"
+ echo "No fcntl.h found, but that's ok."
+fi
-The perl package has some perl subroutine libraries that should be put in
-a directory that is accessible by everyone. Where do you want to put these
-EOM
-$echo $n "libraries? [$dflt] $c"
-rp="Put perl libraries where? [$dflt]"
-. myread
-privlib=`filexp $ans`
+: see if this is an grp system
+echo " "
+if $test -r /usr/include/grp.h ; then
+ i_grp="$define"
+ echo "grp.h found."
+else
+ i_grp="$undef"
+ echo "No grp.h found."
+fi
-: see what type of char stdio uses.
+: see if this is a sys/dir.h system
echo " "
-if $contains 'unsigned.*char.*_ptr;' /usr/include/stdio.h >/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 <stdio.h>
+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 <<EOSS >Cppsym
-$startsh
-case "\$1" in
--l) list=true
- shift
- ;;
-esac
-unknown=''
-case "\$list\$#" in
-1|2)
- for sym do
- if $contains "^\$1$" Cppsym.true >/dev/null 2>&1; then
- exit 0
- elif $contains "^\$1$" Cppsym.know >/dev/null 2>&1; then
- :
- else
- unknown="\$unknown \$sym"
- fi
- done
- set X \$unknown
- shift
+ 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/Cppsym\$\$ >/tmp/Cppsym2\$\$
-case "\$list" in
-true) awk 'NF > 5 {print substr(\$6,2,100)}' </tmp/Cppsym2\$\$ ;;
*)
- sh /tmp/Cppsym2\$\$
- status=\$?
+ dflt="$intsize"
;;
esac
-$rm -f /tmp/Cppsym\$\$ /tmp/Cppsym2\$\$
-exit \$status
-EOSS
-chmod +x Cppsym
-$eunicefix Cppsym
-echo "Your C preprocessor defines the following symbols:"
-Cppsym -l $attrlist >Cppsym.true
-cat Cppsym.true
-rmlist="$rmlist Cppsym Cppsym.know Cppsym.true"
+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 <<EOM
-
-Some systems have different model sizes. On most systems they are called
-small, medium, large, and huge. On the PDP11 they are called unsplit and
-split. If your system doesn't support different memory models, say "none".
-If you wish to force everything to one memory model, say "none" here and
-put the appropriate flags later when it asks you for other cc and ld flags.
-Venix systems may wish to put "none" and let the compiler figure things out.
-(In the following question multiple model names should be space separated.)
+The $package package has some auxiliary files that should be put in a library
+that is accessible by everyone. Where do you want to put these "private"
EOM
-rp="Which models are supported? [$dflt]"
-$echo $n "$rp $c"
+$echo $n "but accessible files? [$dflt] $c"
+rp="Put private files where? [$dflt]"
. myread
-models="$ans"
+privlib="$ans"
-case "$models" in
-none)
- small=''
- medium=''
- large=''
- huge=''
- unsplit=''
- split=''
+: check for size of random number generator
+echo " "
+case "$randbits" in
+'')
+ echo "Checking to see how many bits your rand function produces..."
+ $cat >try.c <<'EOCP'
+#include <stdio.h>
+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 </tmp/foo$$`
+ shift
+ case $# in
+ 0)set HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM
+ ;;
esac
- small="$ans"
;;
- *) small='';;
esac
- ;;
-*)
- echo "Unrecognized memory models--you may have to edit Makefile.SH"
+ sig_name="ZERO $*"
;;
esac
+echo "Signals are: $sig_name"
-case "$ccflags" in
-'') dflt='none';;
-*) dflt="$ccflags";;
-esac
+: see what type of char stdio uses.
echo " "
-rp="Any additional cc flags? [$dflt]"
-$echo $n "$rp $c"
-. myread
-case "$ans" in
-none) ans='';
-esac
-ccflags="$ans"
+if $contains 'unsigned.*char.*_ptr;' /usr/include/stdio.h >/dev/null 2>&1 ; then
+ echo "Your stdio uses unsigned chars."
+ stdchar="unsigned char"
+else
+ echo "Your stdio uses signed chars."
+ stdchar="char"
+fi
-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 " "
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'
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'
uidtype='$uidtype'
voidflags='$voidflags'
defvoidused='$defvoidused'
+lib='$lib'
privlib='$privlib'
CONFIG=true
EOT
$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'."
;;
--- /dev/null
+ 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.
+\f
+ 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.
+\f
+ 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.
+\f
+ 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
+\f
+ 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.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ 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.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
-/* $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
*
*/
-/* $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
*
*/
-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
echo "Extracting Makefile (with variable substitutions)"
cat >Makefile <<!GROK!THIS!
-# $Header: Makefile.SH,v 2.0.1.1 88/06/28 16:26:04 root Exp $
+# $Header: Makefile.SH,v 3.0 89/10/18 15:06:43 lwall Locked $
#
# $Log: Makefile.SH,v $
-# Revision 2.0.1.1 88/06/28 16:26:04 root
-# patch1: support for DOSUID
-# patch1: realclean now knows about ~ extension
-#
-# Revision 2.0 88/06/05 00:07:54 root
-# Baseline version 2.0.
-#
+# Revision 3.0 89/10/18 15:06:43 lwall
+# 3.0 baseline
#
CC = $cc
bin = $bin
-lib = $privlib
+privlib = $privlib
mansrc = $mansrc
manext = $manext
-CFLAGS = $ccflags -O
+CFLAGS = $ccflags $optimize $sockethdr
LDFLAGS = $ldflags
SMALL = $small
LARGE = $large $split
mallocobj = $mallocobj
SLN = $sln
-libs = $libnm -lm
+libs = $libnm -lm $libdbm $libs $libndir $socketlib
-public = perl perldb $suidperl
+public = perl taintperl $suidperl
!GROK!THIS!
cat >>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
.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
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
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.
- 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:
--- /dev/null
+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
- 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.
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.
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
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.
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.
-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
+++ /dev/null
-/* $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 <signal.h>
-#include <errno.h>
-
-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);
-}
-/* $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
*
*/
#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[];
"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
#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[];
"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 {
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 */
* 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();
STR *do_push();
FILE *nextargv();
STR *do_fttext();
+int do_slice();
-/* $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
*
*/
#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];
}
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;
}
{
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
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
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 *
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;
}
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);
}
-/* $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();
bool apush();
int alen();
ARRAY *anew();
+ARRAY *afake();
--- /dev/null
+#!./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 (<S>) {
+ print;
+ }
+}
+
+sub dokill { kill 9,$child if $child; }
-/* $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 <varargs.h>
+#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
#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))
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;
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
#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;
#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;
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--;
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 */
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;
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;
/* 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;
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;
}
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;
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) {
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 (<file>) */
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);
}
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 */
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)
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);
#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.
#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;
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;
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; i<dlevel; i++)
+ fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
+
+ pat = va_arg(args, char *);
+ (void) vfprintf(stderr,pat,args);
+ va_end( args );
+}
+# endif
#endif
copyopt(cmd,which)
return cmd->c_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;
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 */
}
}
{
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);
+}
-/* $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
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 */
#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 */
#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
"ARRAY",
"INDGETS",
"NUMOP",
- "13"
+ "CCLASS",
+ "14"
};
#endif
#endif /* DEBUGGING */
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 {
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 */
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();
* 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
*/
#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.
* 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
*/
#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 <sys/time.h> rather than <time.h>. 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 <sys/time.h>.
+ */
+/*#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
* 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
#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" /**/
+
#$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
#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().
*/
#$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().
*/
#$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
*/
#$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.
#$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
*/
#$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().
*/
#$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()
*/
#$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.
*/
#$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.
*/
#$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.
*/
#$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
*/
#$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 <sys/time.h> rather than <time.h>. 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 <sys/time.h>.
+ */
#$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
*/
#$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".
* 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
/* 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" /**/
--- /dev/null
+/* $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 (<channel>)" up into command block */
+
+ if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) {
+ cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
+ cmd->c_flags |= CFT_GETS; /* and set it to do the input */
+ cmd->c_stab = arg[1].arg_ptr.arg_stab;
+ if (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;
+}
+
--- /dev/null
+/* $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;
+}
--- /dev/null
+/* $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 <signal.h>
+
+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
+}
+
+
--- /dev/null
+/* $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 <sys/socket.h>
+#include <netdb.h>
+#endif
+
+#include <errno.h>
+#ifdef I_PWD
+#include <pwd.h>
+#endif
+#ifdef I_GRP
+#include <grp.h>
+#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;
+}
--- /dev/null
+/* $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;
+}
-/* $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
*
*/
#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;
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);
} 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:
} 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 */
dump("}\n");
if (cmd)
if (cmd == alt)
- dump("CONT{\n");
+ dump("CONT 0x%lx {\n",cmd);
else
dump("{\n");
}
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:
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;
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--;
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';
}
}
dumplvl++;
fprintf(stderr,"{\n");
- dump("STAB_NAME = %s\n",stab->stab_name);
+ dump("STAB_NAME = %s\n",stab_name(stab));
dumplvl--;
dump("}\n");
}
int i;
for (i = dumplvl*4; i; i--)
- putc(' ',stderr);
+ (void)putc(' ',stderr);
fprintf(stderr,arg1, arg2, arg3, arg4, arg5);
}
#endif
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;
}
}
#!/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.
#!/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 '';
--- /dev/null
+#!/usr/bin/perl
+
+$| = 1;
+if ($#ARGV >= 0) {
+ $cmd = join(' ',@ARGV);
+}
+else {
+ print "Command: ";
+ $cmd = <stdin>;
+ chop($cmd);
+ while ($cmd =~ s/\\$//) {
+ print "+ ";
+ $cmd .= <stdin>;
+ chop($cmd);
+ }
+}
+$cwd = `pwd`; chop($cwd);
+
+open(FIND,'find . -type d -print|') || die "Can't run find";
+
+while (<FIND>) {
+ chop;
+ unless (chdir $_) {
+ print stderr "Can't cd to $_\n";
+ next;
+ }
+ print "\t--> ",$_,"\n";
+ system $cmd;
+ chdir $cwd;
+}
#!/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.
#!/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.
$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);
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 (<find>) {
@x = split(' ');
#!/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.
$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 (<find>) {
@x = split(' ');
#!/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.
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";
-.\" $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
#!/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.
#
#!/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
}
close(pipe);
} else {
+ print "(Can't execute rsh: $!)\n";
$SIG{'INT'} = 'cont';
- print "(Can't execute rsh.)\n";
}
}
}
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";
-.\" $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
--- /dev/null
+#!../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 (<CPP>) {
+ ($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;
+}
--- /dev/null
+.\" $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.
#!/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
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 (<ghosts>) {
next line if /^#/;
next line if /^$/;
$wanted{$host} = 1;
}
-open(ruptime,'ruptime|') || die "Can't run ruptime";
+open(ruptime,'ruptime|') || die "Can't run ruptime: $!";
open(sort,'|sort +1n');
while (<ruptime>) {
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.
--- /dev/null
+#!/usr/bin/perl
+
+($op = shift) || die "Usage: rename perlexpr [filenames]\n";
+if ($#ARGV < 0) {
+ @ARGV = <stdin>;
+ chop(@ARGV);
+}
+for (@ARGV) {
+ $was = $_;
+ eval $op;
+ die $@ if $@;
+ rename($was,$_) unless $was eq $_;
+}
#!/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.
#!/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');
#!/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
#!/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`;
}
$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 (<tmp>) {
if (/^nd:/) {
next if $seen{$_} < 20;
#!/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;
#!/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.
#!/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 = <Oldsudo>;
}
$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 (<tmp>) {
print $seen{$_},":\t",$_;
}
#!/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');
#!/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:
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;
$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 = <scan>;
}
close(pipe);
} else {
- print "(Can't execute rsh.)\n";
+ print "(Can't execute rsh: $!)\n";
}
last class;
}
#!/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 (<ipcs>) {
$tmp = index($_,'NATTCH');
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);
#!/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.
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) {
#!/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 '.') {
}
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";
}
}
#!/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
#!/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 '.') {
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";
}
}
--- /dev/null
+#!/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;
+ }
+}
-/* $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
*
*/
#include <signal.h>
#include <errno.h>
+#ifdef I_VFORK
+# include <vfork.h>
+#endif
+
extern int errno;
#ifdef VOIDSIG
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;
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);
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);
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
}
if (loop_ptr < 0)
fatal("Bad label: %s", maxarg > 0 ? tmps : "<null>");
+ 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;
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;
}
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:
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:
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;
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;
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;
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--;
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--;
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;
}
--- /dev/null
+/* 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;
+ }
-/* $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
*
*/
/* 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;
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;
*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')
}
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';
*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';
*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')
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;
}
}
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)
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;
}
-/* $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
*
*/
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;
#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-");
--- /dev/null
+#!./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;
+ }
+ <stdin>;
+ while (($name,$aliases,$addrtype,$net) = getnetent) {
+ print "$name $aliases $addrtype ",sprintf("%08lx",$net),"\n";
+ }
+ <stdin>;
+ while (($name,$aliases,$proto) = getprotoent) {
+ print "$name $aliases $proto\n";
+ }
+ <stdin>;
+ while (($name,$aliases,$port,$proto) = getservent) {
+ print "$name $aliases $port $proto\n";
+ }
+
-/* $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)
#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 */
-/* $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 <errno.h>
+
+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]);
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;
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]);
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)
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; i<oldsize; i++,a++) {
}
HASH *
-hnew()
+hnew(lookat)
+unsigned int lookat;
{
- register HASH *tb = (HASH*)safemalloc(sizeof(HASH));
+ register HASH *tb;
- tb->tbl_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;
}
if (!hent)
return;
str_free(hent->hent_val);
- safefree(hent->hent_key);
- safefree((char*)hent);
+ Safefree(hent->hent_key);
+ Safefree(hent);
}
void
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;
{
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;
}
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 <fcntl.h>
+#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 */
-/* $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
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();
STR *hdelete();
HASH *hnew();
void hclear();
-void hfree();
void hentfree();
int hiterinit();
HENT *hiternext();
char *hiterkey();
STR *hiterval();
+bool hdbmopen();
+void hdbmclose();
+bool hdbmstore();
--- /dev/null
+$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;
--- /dev/null
+;# 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;
--- /dev/null
+;#
+;# @(#)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;
--- /dev/null
+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";
+ }
+ }
+ }
+}
-;# $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
($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;";
}
$ARGV[0] = "-$rest";
}
else {
- shift;
+ shift(@ARGV);
}
}
}
}
+
+1;
--- /dev/null
+;# 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;
-;# $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:
$tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
}
eval $tmp;
+
+1;
--- /dev/null
+;# 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);
+ $_ = <FH>; # probably a partial line
+ $_ = <FH>;
+ 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 (<FH>) {
+ 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;
--- /dev/null
+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(<linenum>); 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=<IN>) {
+ $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.
+<CR> 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 .= <IN>;
+ }
+ $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;
-;# $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);
($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;
--- /dev/null
+;# $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 (<TERMCAP>) {
+ next if /^#/;
+ next if /^\t/;
+ if (/\\|$TERM[:\\|]/) {
+ chop;
+ while (chop eq '\\\\') {
+ \$_ .= <TERMCAP>;
+ 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;
--- /dev/null
+;# $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;
echo "Extracting makedepend (with variable substitutions)"
$spitshell >makedepend <<!GROK!THIS!
$startsh
-# $Header: makedepend.SH,v 2.0 88/06/05 00:09:11 root Exp $
+# $Header: makedepend.SH,v 3.0 89/10/18 15:20:19 lwall Locked $
#
# $Log: makedepend.SH,v $
-# Revision 2.0 88/06/05 00:09:11 root
-# Baseline version 2.0.
-#
+# Revision 3.0 89/10/18 15:20:19 lwall
+# 3.0 baseline
#
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
cat='$cat'
-ccflags='$ccflags'
+ccflags='$ccflags $sockethdr'
cp='$cp'
cpp='$cppstdin'
echo='$echo'
esac
make clist || ($echo "Searching for .c files..."; \
- $echo *.c */*.c | $tr ' ' '\012' | $egrep -v '\*' >.clist)
+ $echo *.c | $tr ' ' '\012' | $egrep -v '\*' >.clist)
for file in `$cat .clist`; do
# for file in `cat /dev/null`; do
case "$file" in
$sed <Makefile >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 \; \
>>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..."
echo "Extracting makedir (with variable substitutions)"
$spitshell >makedir <<!GROK!THIS!
$startsh
-# $Header: makedir.SH,v 2.0 88/06/05 00:09:13 root Exp $
+# $Header: makedir.SH,v 3.0 89/10/18 15:20:27 lwall Locked $
#
# $Log: makedir.SH,v $
-# Revision 2.0 88/06/05 00:09:13 root
-# Baseline version 2.0.
-#
+# Revision 3.0 89/10/18 15:20:27 lwall
+# 3.0 baseline
#
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
--- /dev/null
+case $CONFIG in
+'')
+ if test ! -f config.sh; then
+ ln ../config.sh . || \
+ ln ../../config.sh . || \
+ ln ../../../config.sh . || \
+ (echo "Can't find config.sh."; exit 1)
+ fi
+ . config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting makelib (with variable substitutions)"
+: This section of the file will have variable substitutions done on it.
+: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
+: Protect any dollar signs and backticks that you do not want interpreted
+: by putting a backslash in front. You may delete these comments.
+$spitshell >makelib <<!GROK!THIS!
+#!/usr/bin/perl
+
+\$perlincl = '$privlib';
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>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 (<IN>) {
+ chop;
+ while (/\\$/) {
+ chop;
+ $_ .= <IN>;
+ chop;
+ }
+ if (s:/\*:\200:g) {
+ s:\*/:\201:g;
+ s/\200[^\201]*\201//g; # delete single line comments
+ if (s/\200.*//) { # begin multi-line comment?
+ $_ .= '/*';
+ $_ .= <IN>;
+ 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
-/* $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.
*/
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 # */
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;
*/
static
morecore(bucket)
- register bucket;
+ register int bucket;
{
register union overhead *op;
register int rnu; /* 2^rnu bytes will be requested */
* 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;
* 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.
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 */
}
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);
totused, totfree);
}
#endif
+#endif /* lint */
-#define PATCHLEVEL 1
+#define PATCHLEVEL 0
-/* $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
*
*/
#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 <stdio.h>
#ifdef TMINSYS
#include <sys/time.h>
#else
+#ifdef I_SYSTIME
+#include <sys/time.h>
+#else
#include <time.h>
#endif
+#endif
#include <sys/times.h>
+#ifdef I_SYSIOCTL
+#ifndef _IOCTL_
+#include <sys/ioctl.h>
+#endif
+#endif
+
+#if defined(mc300) || defined(mc500) || defined(mc700) /* MASSCOMP */
+#ifdef SOCKETPAIR
+#undef SOCKETPAIR
+#endif
+#ifdef NDBM
+#undef NDBM
+#endif
+#endif
+
+#ifdef NDBM
+#include <ndbm.h>
+#define SOME_DBM
+#else
+#ifdef ODBM
+#ifdef NULL
+#undef NULL /* suppress redefinition message */
+#endif
+#include <dbm.h>
+#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 <dirent.h>
+#define DIRENT dirent
+#else
+#ifdef I_SYSDIR
+#include <sys/dir.h>
+#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"
#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();
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();
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();
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 {
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);
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);
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(); */
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();
#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();
#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
.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
.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.
(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,
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
.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<number>
+.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
.I perl
will not look for a script filename in the argument list.
.TP 5
-.B \-i<extension>
+.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
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
#!/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;
}
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<directory>
+.BI \-I directory
may be used in conjunction with
.B \-P
to tell the C preprocessor where to look for include files.
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
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
.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:
.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 .
.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 <<EOF; # same as above
+The price is $Price.
+EOF
+
+ print <<"EOF"; # same as above
+The price is $Price.
+EOF
+
+ print << x 10; # null identifier is delimiter
+Merry Christmas!
+
+ print <<`EOC`; # execute commands
+echo hi there
+echo lo there
+EOC
+
+ print <<foo, <<bar; # you can stack them
+I said foo.
+foo
+I said bar.
+bar
+
+.fi
Array literals are denoted by separating individual values by commas, and
enclosing the list in parentheses.
In a context not requiring an array value, the value of the array literal
.nf
.ne 4
- @foo = ('cc', '\-E', $bar);
+ @foo = (\'cc\', \'\-E\', $bar);
assigns the entire array value to array foo, but
- $foo = ('cc', '\-E', $bar);
+ $foo = (\'cc\', \'\-E\', $bar);
.fi
assigns the value of variable bar to variable foo.
($a, $b, $c) = (1, 2, 3);
- ($map{'red'}, $map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00);
+ ($map{\'red\'}, $map{\'blue\'}, $map{\'green\'}) = (0x00f, 0x0f0, 0xf00);
+
+The final element may be an array or an associative array:
+
+ ($a, $b, @rest) = split;
+ local($a, $b, %rest) = @_;
.fi
-Array assignment returns the number of elements assigned.
+You can actually put an array anywhere in the list, but the first array
+in the list will soak up all the values, and anything after it will get
+a null value.
+This may be useful in a local().
.PP
-Numeric literals are specified in any of the usual floating point or
-integer formats.
+An associative array literal contains pairs of values to be interpreted
+as a key and a value:
+.nf
+
+.ne 2
+ # same as map assignment above
+ %map = ('red',0x00f,'blue',0x0f0,'green',0xf00);
+
+.fi
+Array assignment in a scalar context returns the number of elements
+produced by the expression on the right side of the assignment:
+.nf
+
+ $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2
+
+.fi
.PP
There are several other pseudo-literals that you should know about.
If a string is enclosed by backticks (grave accents), it first undergoes
To pass a $ through to the shell you need to hide it with a backslash.
.PP
Evaluating a filehandle in angle brackets yields the next line
-from that file (newline included, so it's never false until EOF).
+from that file (newline included, so it's never false until EOF, at
+which time an undefined value is returned).
Ordinarily you must assign that value to a variable,
but there is one situation where in which an automatic assignment happens.
If (and only if) the input symbol is the only thing inside the conditional of a
Anyway, the following lines are equivalent to each other:
.nf
-.ne 3
- while ($_ = <stdin>) {
- while (<stdin>) {
- for (\|;\|<stdin>;\|) {
+.ne 5
+ while ($_ = <STDIN>) { print; }
+ while (<STDIN>) { print; }
+ for (\|;\|<STDIN>;\|) { print; }
+ print while $_ = <STDIN>;
+ print while <STDIN>;
.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.
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
.ne 10
is equivalent to
- unshift(@ARGV, '\-') \|if \|$#ARGV < $[;
+ unshift(@ARGV, \'\-\') \|if \|$#ARGV < $[;
while ($ARGV = shift) {
open(ARGV, $ARGV);
while (<ARGV>) {
.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>),
.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 (<foo>) {
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"
.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
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
.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
a colon.
The LABEL identifies the loop for the loop control statements
.IR next ,
-.I last
+.IR last ,
and
.I redo
(see below).
$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
.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.
.ne 4
do {
- $_ = <stdin>;
+ $_ = <STDIN>;
.\|.\|.
} until $_ \|eq \|".\|\e\|n";
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.
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.
}
.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.
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:
.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.
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');
- <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 = <stdin>;
- chop($user);
- print "Files: "
- $pattern = <stdin>;
- chop($pattern);
- open(pass,'/etc/passwd') || die "Can't open passwd";
- while (<pass>) {
- ($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 = <stdin>;
- exit 0 \|if \|$ans \|=~ \|/\|^[Xx]\|/\|;
-
-.fi
-See also
-.IR die .
-.Ip "exp(EXPR)" 8 3
-Returns e to the power of EXPR.
-.Ip "fork" 8 4
-Does a fork() call.
-Returns the child pid to the parent process and 0 to the child process.
-Note: unflushed buffers remain unflushed in both processes, which means
-you may need to set $| to avoid duplicate output.
-.Ip "gmtime(EXPR)" 8 4
-Converts a time as returned by the time function to a 9-element array with
-the time analyzed for the Greenwich timezone.
-Typically used as follows:
-.nf
-
-.ne 3
- ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
- = gmtime(time);
-
-.fi
-All array elements are numeric, 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
''' 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 = <STDIN>);
.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 (<stdin>) {
- last line if /\|^$/; # exit when done with header
- .\|.\|.
+ print "User: ";
+ $user = <STDIN>;
+ chop($user);
+ print "Files: "
+ $pattern = <STDIN>;
+ chop($pattern);
+ open(pass, \'/etc/passwd\') || die "Can't open passwd: $!\en";
+ while (<pass>) {
+ ($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 (<stdin>) {
- 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 (<article>) {\|.\|.\|.
-
- 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 (<stdin>) {
- while (s|\|({.*}.*\|){.*}|$1 \||) {}
- s|{.*}| \||;
- if (s|{.*| \||) {
- $front = $_;
- while (<stdin>) {
- 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 = <STDIN>;
+ 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 <sys/fcntl.h>.
+(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 (<passwd>) {
-.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 <sys/ioctl.h>.
+(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 = <stdin>) {
- if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) {
- $thisline \|.= \|$lookahead;
- }
- else {
- last line;
- }
- }
- $thisline;
- }
+or how about sorted by key:
- $lookahead = <stdin>; # 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<digit>
-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 $<digit> 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 (<STDIN>) {
+ 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
-
- $_ = <stdin>;
- 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 $<digit> 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\');
+ <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 <lwall@jpl-devvax.Jpl.Nasa.Gov>
-.SH FILES
-/tmp/perl\-eXXXXXX temporary file for
-.B \-e
-commands.
-.SH SEE ALSO
-a2p awk to perl translator
-.br
-s2p sed to perl translator
-.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
-$<digit> does not refer to fields--it refers to substrings matched by the last
-match pattern.
-.Ip * 4 2
-The print statement does not add field and record separators unless you set
-$, and $\e.
-.Ip * 4 2
-You must open your files before you print to them.
-.Ip * 4 2
-The range operator is \*(L"..\*(R", not comma.
-(The comma operator works as in C.)
-.Ip * 4 2
-The match operator is \*(L"=~\*(R", not \*(L"~\*(R".
-(\*(L"~\*(R" is the one's complement operator.)
-.Ip * 4 2
-The concatenation operator is \*(L".\*(R", not the null string.
-(Using the null string would render \*(L"/pat/ /pat/\*(R" unparseable,
-since the third slash would be interpreted as a division operator\*(--the
-tokener is in fact slightly context sensitive for operators like /, ?, and <.
-And in fact, . itself can be the beginning of a number.)
-.Ip * 4 2
-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).
--- /dev/null
+''' 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 (<STDIN>) {
+ next line if /\|^#/; # discard comments
+ .\|.\|.
+ }
+
+.fi
+Note that if there were a
+.I continue
+block on the above, it would get executed even on discarded lines.
+If the LABEL is omitted, the command refers to the innermost enclosing loop.
+.Ip "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 (<article>) {\|.\|.\|.
+
+ 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 (<STDIN>) {
+ while (s|\|({.*}.*\|){.*}|$1 \||) {}
+ s|{.*}| \||;
+ if (s|{.*| \||) {
+ $front = $_;
+ while (<STDIN>) {
+ if (\|/\|}/\|) { # end of comment?
+ s|^|$front{|;
+ redo line;
+ }
+ }
+ }
+ print;
+ }
+
+.fi
+.Ip "rename(OLDNAME,NEWNAME)" 8 2
+Changes the name of a file.
+Returns 1 for success, 0 otherwise.
+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 (<passwd>) {
+.ie t \{\
+ ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(\|/\|:\|/\|);
+'br\}
+.el \{\
+ ($login, $passwd, $uid, $gid, $gcos, $home, $shell)
+ = split(\|/\|:\|/\|);
+'br\}
+ .\|.\|.
+ }
+
+.fi
+(Note that $shell above will still have a newline on it. See chop().)
+See also
+.IR join .
+.Ip "sprintf(FORMAT,LIST)" 8 4
+Returns a string formatted by the usual printf conventions.
+The * character is not supported.
+.Ip "sqrt(EXPR)" 8 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.
--- /dev/null
+''' 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 = <STDIN>) {
+ if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) {
+ $thisline \|.= \|$lookahead;
+ }
+ else {
+ last line;
+ }
+ }
+ $thisline;
+ }
+
+ $lookahead = <STDIN>; # 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<digit>
+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 $<digit> (and $\`, $& and $\')
+extends to the end of the enclosing BLOCK or eval string, or to
+the next pattern match with subexpressions.
+The \e<digit> 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
+
+ $_ = <STDIN>;
+ 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 (<S>) {
+ 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 (<NS>) {
+ 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 $<digit> 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 "<CR>" 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 <lwall@jpl-devvax.Jpl.Nasa.Gov>
+.SH FILES
+/tmp/perl\-eXXXXXX temporary file for
+.B \-e
+commands.
+.SH SEE ALSO
+a2p awk to perl translator
+.br
+s2p sed to perl translator
+.SH DIAGNOSTICS
+Compilation errors will tell you the line number of the error, with an
+indication of the next token or token type that was to be examined.
+(In the case of a script passed to
+.I perl
+via
+.B \-e
+switches, each
+.B \-e
+is counted as one line.)
+.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
+$<digit> 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 }` ''
-/* $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
*
*/
#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;
%}
}
%token <cval> WORD
-%token <ival> APPEND OPEN WRITE SELECT CLOSE LOOPEX
+%token <ival> APPEND OPEN SELECT LOOPEX
%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
-%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT SPRINTF
-%token <ival> FOR FEOF TELL SEEK STAT
-%token <ival> FUNC0 FUNC1 FUNC2 FUNC3 STABFUN
-%token <ival> JOIN SUB FILETEST LOCAL DELETE
+%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
+%token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
+%token <ival> FUNC0 FUNC1 FUNC2 FUNC3 HSHFUN HSHFUN3
+%token <ival> FLIST2 SUB FILETEST LOCAL DELETE
+%token <ival> RELOP EQOP MULOP ADDOP PACKAGE AMPER LFUNC4
%token <formval> FORMLIST
-%token <stabval> REG ARYLEN ARY
+%token <stabval> REG ARYLEN ARY HSH STAR
%token <arg> SUBST PATTERN
%token <arg> RSTRING TRANS
-%type <ival> prog decl format
+%type <ival> prog decl format remember
%type <stabval>
%type <cmdval> block lineseq line loop cond sideff nexpr else
-%type <arg> expr sexpr term
-%type <arg> condmod loopmod
+%type <arg> expr sexpr cexpr csexpr term handle aryword hshword
%type <arg> texpr listop
%type <cval> label
%type <compval> compblock
%left ANDAND
%left '|' '^'
%left '&'
-%nonassoc EQ NE SEQ SNE
-%nonassoc '<' '>' LE GE SLT SGT SLE SGE
+%nonassoc EQOP
+%nonassoc RELOP
%nonassoc <ival> UNIOP
%nonassoc FILETEST
%left LS RS
-%left '+' '-' '.'
-%left '*' '/' '%' 'x'
+%left ADDOP
+%left MULOP
%left MATCH NMATCH
%right '!' '~' UMINUS
+%right POW
%nonassoc INC DEC
%left '('
{ $$ = $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 */
{ $$ = 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); }
* @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());
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 {
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? */
;
texpr : /* NULL means true */
- { scanstr("1"); $$ = yylval.arg; }
+ { (void)scanstr("1"); $$ = yylval.arg; }
| expr
;
| 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 '('
| 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 */
+++ /dev/null
-#!/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 (<script>) {
- chop;
- if ($. == 1) {
- if (/^#! *([^ \t]*) (-[^ \t]*)/) {
- $perl = $1;
- $switch = $2;
- }
- elsif (/^#! *([^ \t]*)/) {
- $perl = $1;
- }
- }
- s/ *$//;
- push(@script,$_); # remember line for DBinit
- $line = $_;
- next if /^$/; # blank lines are uninteresting
- next if /^[ \t]*#/; # likewise comment lines
- if ($init) {
- print tmp "do DBinit($.);"; $init = '';
- }
- if ($inform) { # skip formats
- if (/^\.$/) {
- $inform = '';
- $state = 'statement';
- }
- next;
- }
- if (/^[ \t]*format /) {
- $inform++;
- next;
- }
- if ($state eq 'statement' &&
- !/^[ \t]*}|^[ \t]*else|^[ \t]*continue|^[ \t]*elsif/) {
- if (s/^([ \t]*[A-Za-z_0-9]+:)//) {
- $label = $1;
- }
- else {
- $label = '';
- }
- $line = $label . "do DB($.); " . $_; # all that work for this line
- }
- else {
- $script[$#script - 1] .= ' '; # mark line as having continuation
- }
- do parse(); # set $state to correct eol value
-}
-continue {
- print tmp $line,"\n";
-}
-
-# now put out our debugging subroutines. First the one that's called all over.
-
-print tmp '
-sub DB {
- push(@DB,$. ,$@, $!, $[, $,, $/, $\ );
- $[ = 0; $, = ""; $/ = "\n"; $\ = "";
- $DBline=pop(@_);
- if ($DBsingle || $DBstop[$DBline] || $DBtrace) {
- print "$DBline:\t",$DBline[$DBline],"\n";
- for ($DBi = $DBline; $DBline[$DBi++] =~ / $/; ) {
- print "$DBi:\t",$DBline[$DBi],"\n";
- }
- }
- if ($DBaction[$DBline]) {
- eval $DBaction[$DBline]; print $@;
- }
- if ($DBstop[$DBline] || $DBsingle) {
- for (;;) {
- print "perldb> ";
- $DBcmd = <stdin>;
- last if $DBcmd =~ /^$/;
- if ($DBcmd =~ /^q$/) {
- exit 0;
- }
- if ($DBcmd =~ /^h$/) {
- print "
-s Single step.
-c Continue.
-<CR> Repeat last s or c.
-l min-max List lines.
-l line List line.
-l List the whole program.
-L List breakpoints.
-t Toggle trace mode.
-b line Set breakpoint.
-d line Delete breakpoint.
-d Delete breakpoint at this line.
-a line command Set an action for this line.
-q Quit.
-command Execute as a perl statement.
-
-";
- next;
- }
- if ($DBcmd =~ /^t$/) {
- $DBtrace = !$DBtrace;
- print "Trace = $DBtrace\n";
- next;
- }
- if ($DBcmd =~ /^l (.*)[-,](.*)/) {
- for ($DBi = $1; $DBi <= $2; $DBi++) {
- print "$DBi:\t", $DBline[$DBi], "\n";
- }
- next;
- }
- if ($DBcmd =~ /^l (.*)/) {
- print "$1:\t", $DBline[$1], "\n";
- next;
- }
- if ($DBcmd =~ /^l$/) {
- for ($DBi = 1; $DBi <= $DBmax ; $DBi++) {
- print "$DBi:\t", $DBline[$DBi], "\n";
- }
- next;
- }
- if ($DBcmd =~ /^L$/) {
- for ($DBi = 1; $DBi <= $DBmax ; $DBi++) {
- print "$DBi:\t", $DBline[$DBi], "\n" if $DBstop[$DBi];
- }
- next;
- }
- if ($DBcmd =~ /^b (.*)/) {
- $DBi = $1;
- if ($DBline[$DBi-1] =~ / $/) {
- print "Line $DBi not breakable.\n";
- }
- else {
- $DBstop[$DBi] = 1;
- }
- next;
- }
- if ($DBcmd =~ /^d (.*)/) {
- $DBstop[$1] = 0;
- next;
- }
- if ($DBcmd =~ /^d$/) {
- $DBstop[$DBline] = 0;
- next;
- }
- if ($DBcmd =~ /^a ([0-9]+)[ \t]+(.*)/) {
- $DBi = $1;
- $DBaction = $2;
- $DBaction .= ";" unless $DBaction =~ /[;}]$/;
- $DBaction[$DBi] = $DBaction;
- next;
- }
- if ($DBcmd =~ /^s$/) {
- $DBsingle = 1;
- last;
- }
- if ($DBcmd =~ /^c$/) {
- $DBsingle = 0;
- last;
- }
- chop($DBcmd);
- $DBcmd .= ";" unless $DBcmd =~ /[;}]$/;
- eval $DBcmd;
- print $@,"\n";
- }
- }
- $\ = pop(@DB);
- $/ = pop(@DB);
- $, = pop(@DB);
- $[ = pop(@DB);
- $! = pop(@DB);
- $@ = pop(@DB);
- $. = pop(@DB);
-}
-
-sub DBinit {
- $DBstop[$_[0]] = 1;
-';
-print tmp " \$0 = '$script';\n";
-print tmp " \$DBmax = $.;\n";
-print tmp " unlink '/tmp/pdb$$';\n"; # expected to fail on -o.
-for ($i = 1; $#script >= 0; $i++) {
- $_ = shift(@script);
- s/'/\\'/g;
- print tmp " \$DBline[$i] = '$_';\n";
-}
-print tmp '}
-';
-
-close tmp;
-
-# prepare to run the new script
-
-unshift(@ARGV,$tmp);
-unshift(@ARGV,$switch) if $switch;
-unshift(@ARGV,$perl);
-exec @ARGV;
-
-# This routine tokenizes one perl line good enough to tell what state we are
-# in by the end of the line, so we can tell if the next line should contain
-# a call to DB or not.
-
-sub parse {
- until ($_ eq '') {
- $ord = ord($_);
- if ($quoting) {
- if ($quote == $ord) {
- $quoting--;
- }
- s/^.// if /^[\\]/;
- s/^.//;
- last if $_ eq "\n";
- $state = 'term' unless $quoting;
- next;
- }
- if ($ord > 64) {
- do quote(ord($1),1), next if s/^m\b(.)//;
- do quote(ord($1),2), next if s/^s\b(.)//;
- do quote(ord($1),2), next if s/^y\b(.)//;
- do quote(ord($1),2), next if s/^tr\b(.)//;
- do quote($ord,1), next if s/^`//;
- next if s/^[A-Za-z_][A-Za-z_0-9]*://;
- $state = 'term', next if s/^eof\b//;
- $state = 'term', next if s/^shift\b//;
- $state = 'term', next if s/^split\b//;
- $state = 'term', next if s/^tell\b//;
- $state = 'term', next if s/^write\b//;
- $state = 'operator', next if s/^[A-Za-z_][A-Za-z_0-9]*//;
- $state = 'operator', next if s/^[~^|]+//;
- $state = 'statement', next if s/^{//;
- $state = 'statement', next if s/^}[ \t]*$//;
- $state = 'statement', next if s/^}[ \t]*#/#/;
- $state = 'term', next if s/^}//;
- $state = 'operator', next if s/^\[//;
- $state = 'term', next if s/^]//;
- die "Illegal character $_";
- }
- elsif ($ord < 33) {
- next if s/[ \t\n\f]+//;
- die "Illegal character $_";
- }
- else {
- $state = 'statement', next if s/^;//;
- $state = 'term', next if s/^\.[0-9eE]+//;
- $state = 'term', next if s/^[0-9][0-9xaAbBcCddeEfF.]*//;
- $state = 'term', next if s/^\$[A-Za-z_][A-Za-z_0-9]*//;
- $state = 'term', next if s/^\$.//;
- $state = 'term', next if s/^@[A-Za-z_][A-Za-z_0-9]*//;
- $state = 'term', next if s/^@.//;
- $state = 'term', next if s/^<[A-Za-z_0-9]*>//;
- next if s/^\+\+//;
- next if s/^--//;
- $state = 'operator', next if s/^[-(!%&*=+:,.<>]//;
- $state = 'term', next if s/^\)+//;
- do quote($ord,1), next if s/^'//;
- do quote($ord,1), next if s/^"//;
- if (s|^[/?]||) {
- if ($state =~ /stat|oper/) {
- $state = 'term';
- do quote($ord,1), next;
- }
- $state = 'operator', next;
- }
- next if s/^#.*//;
- }
- }
-}
-
-sub quote {
- ($quote,$quoting) = @_;
- $state = 'quote';
-}
+++ /dev/null
-.rn '' }`
-''' $Header: perldb.man,v 2.0 88/06/05 00:09:50 root Exp $
-'''
-''' $Log: perldb.man,v $
-''' Revision 2.0 88/06/05 00:09:50 root
-''' Baseline version 2.0.
-'''
-'''
-.de Sh
-.br
-.ne 5
-.PP
-\fB\\$1\fR
-.PP
-..
-.de Sp
-.if t .sp .5v
-.if n .sp
-..
-.de Ip
-.br
-.ie \\n.$>=3 .ne \\$3
-.el .ne 3
-.IP "\\$1" \\$2
-..
-'''
-''' Set up \*(-- to give an unbreakable dash;
-''' string Tr holds user defined translation string.
-''' Bell System Logo is used as a dummy character.
-'''
-.tr \(*W-|\(bv\*(Tr
-.ie n \{\
-.ds -- \(*W-
-.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
-.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
-.ds L" ""
-.ds R" ""
-.ds L' '
-.ds R' '
-'br\}
-.el\{\
-.ds -- \(em\|
-.tr \*(Tr
-.ds L" ``
-.ds R" ''
-.ds L' `
-.ds R' '
-'br\}
-.TH PERLDB 1 LOCAL
-.SH NAME
-perldb - Perl Debugger
-.SH SYNOPSIS
-.B perldb [-o output] perlscript arguments
-.SH DESCRIPTION
-.I Perldb
-is a symbolic debugger for
-.I perl
-scripts.
-Run your script just as you normally would, only prepend \*(L"perldb\*(R" to
-the command.
-(On systems where #! doesn't work, put any perl switches into the #! line
-anyway\*(--perldb will pass them off to perl when it runs the script.)
-Perldb copies your script to a temporary file, instrumenting it in the process
-and adding a debugging monitor.
-It then executes the instrumented script for
-you and stops at the first statement so you can set any breakpoints or actions
-you desire.
-.PP
-There is only one switch: \-o, which tells perldb to put its temporary file
-in the filename you specify, and to refrain from deleting the file.
-Use this switch if you intend to rerun the instrumented script, or want to
-look at it for some reason.
-.PP
-These are the debugging commands:
-.Ip s 8
-Single step.
-Subsequent carriage returns will single step.
-.Ip c 8
-Continue.
-Turns off single step mode and runs till the next break point.
-Subsequent carriage returns will continue.
-.Ip <CR> 8
-Repeat last s or c.
-.Ip "l min-max" 8
-List lines in the indicated range.
-.Ip "l line" 8
-List indicated line.
-.Ip l 8
-List the whole program.
-.Ip L 8
-List breakpoints.
-.Ip t 8
-Toggle trace mode.
-Trace mode causes lines to be printed out as they are executed.
-.Ip "b line" 8
-Set breakpoint at indicated line.
-.Ip "d line" 8
-Delete breakpoint at indicated line.
-.Ip d 8
-Delete breakpoint at this line.
-.Ip "a line command" 8
-Set an action for indicated line.
-The command must be a valid perl command, except that a missing trailing ;
-will be supplied.
-.Ip q 8
-Quit.
-.Ip command 8
-Execute command as a perl statement.
-A missing trailing ; will be supplied if necessary.
-.SH ENVIRONMENT
-No environment variables are used by perldb.
-.SH AUTHOR
-Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
-.SH FILES
-/tmp/pdb$$ temporary file for instrumented script
-.SH SEE ALSO
-perl
-.SH DIAGNOSTICS
-.SH BUGS
-.rn }` ''
-char rcsid[] = "$Header: perly.c,v 2.0.1.1 88/06/28 16:36:49 root Exp $";
+char rcsid[] = "$Header: perly.c,v 3.0 89/10/18 15:22:21 lwall Locked $\nPatch level: ###\n";
/*
+ * 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: perly.c,v $
- * Revision 2.0.1.1 88/06/28 16:36:49 root
- * patch1: added DOSUID code
- *
- * Revision 2.0 88/06/05 00:09:56 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:22:21 lwall
+ * 3.0 baseline
*
*/
#include "EXTERN.h"
#include "perl.h"
#include "perly.h"
+#include "patchlevel.h"
-extern char *tokename[];
-extern int yychar;
+#ifdef IAMSUID
+#ifndef DOSUID
+#define DOSUID
+#endif
+#endif
-static int cmd_tosave();
-static int arg_tosave();
-static int spat_tosave();
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef DOSUID
+#undef DOSUID
+#endif
+#endif
main(argc,argv,env)
register int argc;
register char *s;
char *index(), *strcpy(), *getenv();
bool dosearch = FALSE;
-#ifdef DOSUID
char **origargv = argv;
+#ifdef DOSUID
char *validarg = "";
#endif
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef IAMSUID
+#undef IAMSUID
+ fatal("suidperl is no longer needed since the kernel can now execute\n\
+setuid perl scripts securely.\n");
+#endif
+#endif
+
uid = (int)getuid();
euid = (int)geteuid();
- linestr = str_new(80);
+ gid = (int)getgid();
+ egid = (int)getegid();
+ if (do_undump) {
+ do_undump = 0;
+ loop_ptr = 0; /* start label stack again */
+ goto just_doit;
+ }
+ (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
+ linestr = Str_new(65,80);
str_nset(linestr,"",0);
- str = str_make(""); /* first used for -I flags */
+ str = str_make("",0); /* first used for -I flags */
+ curstash = defstash = hnew(0);
+ curstname = str_make("main",4);
+ stab_xhash(stabent("_main",TRUE)) = defstash;
incstab = aadd(stabent("INC",TRUE));
+ incstab->str_pok |= SP_MULTI;
for (argc--,argv++; argc; argc--,argv++) {
if (argv[0][0] != '-' || !argv[0][1])
break;
minus_a = TRUE;
s++;
goto reswitch;
+ case 'd':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -d allowed in setuid scripts");
+#endif
+ perldb = TRUE;
+ s++;
+ goto reswitch;
#ifdef DEBUGGING
case 'D':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -D allowed in setuid scripts");
+#endif
debug = atoi(s+1);
#ifdef YYDEBUG
yydebug = (debug & 1);
break;
#endif
case 'e':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -e allowed in setuid scripts");
+#endif
if (!e_fp) {
- e_tmpname = strcpy(safemalloc(sizeof(TMPPATH)),TMPPATH);
- mktemp(e_tmpname);
+ e_tmpname = savestr(TMPPATH);
+ (void)mktemp(e_tmpname);
e_fp = fopen(e_tmpname,"w");
}
if (argv[1])
fputs(argv[1],e_fp);
- putc('\n', e_fp);
+ (void)putc('\n', e_fp);
argc--,argv++;
break;
case 'i':
argvoutstab = stabent("ARGVOUT",TRUE);
break;
case 'I':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -I allowed in setuid scripts");
+#endif
str_cat(str,"-");
str_cat(str,s);
str_cat(str," ");
- if (s[1]) {
- apush(incstab->stab_array,str_make(s+1));
+ if (*++s) {
+ (void)apush(stab_array(incstab),str_make(s,0));
}
else {
- apush(incstab->stab_array,str_make(argv[1]));
+ (void)apush(stab_array(incstab),str_make(argv[1],0));
str_cat(str,argv[1]);
argc--,argv++;
str_cat(str," ");
s++;
goto reswitch;
case 'P':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -P allowed in setuid scripts");
+#endif
preprocess = TRUE;
s++;
goto reswitch;
case 's':
+#ifdef TAINT
+ if (euid != uid || egid != gid)
+ fatal("No -s allowed in setuid scripts");
+#endif
doswitches = TRUE;
s++;
goto reswitch;
dosearch = TRUE;
s++;
goto reswitch;
+ case 'u':
+ do_undump = TRUE;
+ s++;
+ goto reswitch;
case 'U':
unsafe = TRUE;
s++;
goto reswitch;
case 'v':
- version();
+ fputs(rcsid,stdout);
+ fputs("\nCopyright (c) 1989, Larry Wall\n\n\
+Perl may be copied only under the terms of the GNU General Public License,\n\
+a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
exit(0);
case 'w':
dowarn = TRUE;
}
switch_end:
if (e_fp) {
- fclose(e_fp);
+ (void)fclose(e_fp);
argc++,argv--;
argv[0] = e_tmpname;
}
#ifndef PRIVLIB
#define PRIVLIB "/usr/local/lib/perl"
#endif
- apush(incstab->stab_array,str_make(PRIVLIB));
+ (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
str_set(&str_no,No);
str_set(&str_yes,Yes);
- init_eval();
/* open script */
if (argv[0] == Nullch)
argv[0] = "-";
- if (dosearch && argv[0][0] != '/' && (s = getenv("PATH"))) {
+ if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
char *xfound = Nullch, *xfailed = Nullch;
+ int len;
+ bufend = s + strlen(s);
while (*s) {
- s = cpytill(tokenbuf,s,':');
+ s = cpytill(tokenbuf,s,bufend,':',&len);
if (*s)
s++;
- if (tokenbuf[0])
- strcat(tokenbuf,"/");
- strcat(tokenbuf,argv[0]);
+ if (len)
+ (void)strcat(tokenbuf+len,"/");
+ (void)strcat(tokenbuf+len,argv[0]);
#ifdef DEBUGGING
if (debug & 1)
fprintf(stderr,"Looking for %s\n",tokenbuf);
if (stat(tokenbuf,&statbuf) < 0) /* not there? */
continue;
if ((statbuf.st_mode & S_IFMT) == S_IFREG
- && cando(S_IREAD,TRUE) && cando(S_IEXEC,TRUE)) {
+ && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) {
xfound = tokenbuf; /* bingo! */
break;
}
xfailed = savestr(tokenbuf);
}
if (!xfound)
- fatal("Can't execute %s", xfailed);
+ fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
if (xfailed)
- safefree(xfailed);
+ Safefree(xfailed);
argv[0] = savestr(xfound);
}
+
+ pidstatary = anew(Nullstab); /* for remembering popen pids, status */
+
filename = savestr(argv[0]);
origfilename = savestr(filename);
if (strEQ(filename,"-"))
if (preprocess) {
str_cat(str,"-I");
str_cat(str,PRIVLIB);
- sprintf(buf, "\
+ (void)sprintf(buf, "\
/bin/sed -e '/^[^#]/b' \
-e '/^#[ ]*include[ ]/b' \
-e '/^#[ ]*define[ ]/b' \
-e 's/^#.*//' \
%s | %s -C %s %s",
argv[0], CPPSTDIN, str_get(str), CPPMINUS);
-#ifdef IAMSUID
+#ifdef IAMSUID /* actually, this is caught earlier */
if (euid != uid && !euid) /* if running suidperl */
- seteuid(uid); /* musn't stay setuid root */
+#ifdef SETEUID
+ (void)seteuid(uid); /* musn't stay setuid root */
+#else
+#ifdef SETREUID
+ (void)setreuid(-1, uid);
+#else
+ setuid(uid);
+#endif
#endif
- rsfp = popen(buf,"r");
+#endif /* IAMSUID */
+ rsfp = mypopen(buf,"r");
}
else if (!*argv[0])
rsfp = stdin;
else
rsfp = fopen(argv[0],"r");
if (rsfp == Nullfp) {
+ extern char *sys_errlist[];
+ extern int errno;
+
#ifdef DOSUID
-#ifndef IAMSUID
+#ifndef IAMSUID /* in case script is not readable before setuid */
if (euid && stat(filename,&statbuf) >= 0 &&
statbuf.st_mode & (S_ISUID|S_ISGID)) {
- execvp("suidperl", origargv); /* try again */
+ (void)sprintf(buf, "%s/%s", BIN, "suidperl");
+ execv(buf, origargv); /* try again */
fatal("Can't do setuid\n");
}
#endif
#endif
- fatal("Perl script \"%s\" doesn't seem to exist",filename);
+ fatal("Can't open perl script \"%s\": %s\n",
+ filename, sys_errlist[errno]);
}
str_free(str); /* free -I directories */
* DOSUID must be defined in both perl and suidperl, and IAMSUID must
* be defined in suidperl only. suidperl must be setuid root. The
* Configure script will set this up for you if you want it.
+ *
+ * There is also the possibility of have a script which is running
+ * set-id due to a C wrapper. We want to do the TAINT checks
+ * on these set-id scripts, but don't want to have the overhead of
+ * them in normal perl, and can't use suidperl because it will lose
+ * the effective uid info, so we have an additional non-setuid root
+ * version called taintperl that just does the TAINT checks.
*/
+
#ifdef DOSUID
if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
fatal("Can't stat script \"%s\"",filename);
if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
int len;
+#ifdef IAMSUID
+#ifndef SETREUID
+ /* On this access check to make sure the directories are readable,
+ * there is actually a small window that the user could use to make
+ * filename point to an accessible directory. So there is a faint
+ * chance that someone could execute a setuid script down in a
+ * non-accessible directory. I don't know what to do about that.
+ * But I don't think it's too important. The manual lies when
+ * it says access() is useful in setuid programs.
+ */
if (access(filename,1)) /* as a double check */
fatal("Permission denied");
+#else
+ /* If we can swap euid and uid, then we can determine access rights
+ * with a simple stat of the file, and then compare device and
+ * inode to make sure we did stat() on the same file we opened.
+ * Then we just have to make sure he or she can execute it.
+ */
+ {
+ struct stat tmpstatbuf;
+
+ if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
+ fatal("Can't swap uid and euid"); /* really paranoid */
+ if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */
+ fatal("Permission denied");
+ if (tmpstatbuf.st_dev != statbuf.st_dev ||
+ tmpstatbuf.st_ino != statbuf.st_ino) {
+ (void)fclose(rsfp);
+ if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */
+ fprintf(rsfp,
+"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
+(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
+ uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
+ statbuf.st_dev, statbuf.st_ino,
+ filename, statbuf.st_uid, statbuf.st_gid);
+ (void)mypclose(rsfp);
+ }
+ fatal("Permission denied\n");
+ }
+ if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
+ fatal("Can't reswap uid and euid");
+ if (!cando(S_IEXEC,FALSE,&statbuf)) /* can real uid exec? */
+ fatal("Permission denied\n");
+ }
+#endif /* SETREUID */
+#endif /* IAMSUID */
+
if ((statbuf.st_mode & S_IFMT) != S_IFREG)
fatal("Permission denied");
+ if ((statbuf.st_mode >> 6) & S_IWRITE)
+ fatal("Setuid/gid script is writable by world");
doswitches = FALSE; /* -s is insecure in suid */
line++;
if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
for (s = tokenbuf+2; !isspace(*s); s++) ;
if (strnNE(s-4,"perl",4)) /* sanity check */
fatal("Not a perl script");
- while (*s && isspace(*s)) s++;
+ while (*s == ' ' || *s == '\t') s++;
/*
* #! arg must be what we saw above. They can invoke it by
* mentioning suidperl explicitly, but they may not add any strange
len = strlen(validarg);
if (strEQ(validarg," PHOOEY ") ||
strnNE(s,validarg,len) || !isspace(s[len]))
- fatal("Arg must be \"%s\"\n",s);
+ fatal("Args must match #! line");
+
+#ifndef IAMSUID
+ if (euid != uid && (statbuf.st_mode & S_ISUID) &&
+ euid == statbuf.st_uid)
+ if (!do_undump)
+ fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
+#endif /* IAMSUID */
if (euid) { /* oops, we're not the setuid root perl */
- fclose(rsfp);
+ (void)fclose(rsfp);
#ifndef IAMSUID
- execvp("suidperl", origargv); /* try again */
+ (void)sprintf(buf, "%s/%s", BIN, "suidperl");
+ execv(buf, origargv); /* try again */
#endif
fatal("Can't do setuid\n");
}
- if (statbuf.st_mode & S_ISUID && statbuf.st_uid != euid)
- seteuid(statbuf.st_uid); /* all that for this */
- else if (uid) /* oops, mustn't run as root */
- seteuid(uid);
if (statbuf.st_mode & S_ISGID && statbuf.st_gid != getegid())
- setegid(statbuf.st_gid);
+#ifdef SETEGID
+ (void)setegid(statbuf.st_gid);
+#else
+#ifdef SETREGID
+ (void)setregid((GIDTYPE)-1,statbuf.st_gid);
+#else
+ setgid(statbuf.st_gid);
+#endif
+#endif
+ if (statbuf.st_mode & S_ISUID) {
+ if (statbuf.st_uid != euid)
+#ifdef SETEUID
+ (void)seteuid(statbuf.st_uid); /* all that for this */
+#else
+#ifdef SETREUID
+ (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
+#else
+ setuid(statbuf.st_uid);
+#endif
+#endif
+ }
+ else if (uid) /* oops, mustn't run as root */
+#ifdef SETEUID
+ (void)seteuid((UIDTYPE)uid);
+#else
+#ifdef SETREUID
+ (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
+#else
+ setuid((UIDTYPE)uid);
+#endif
+#endif
euid = (int)geteuid();
- if (!cando(S_IEXEC,TRUE))
+ if (!cando(S_IEXEC,TRUE,&statbuf))
fatal("Permission denied\n"); /* they can't do this */
}
#ifdef IAMSUID
fatal("-P not allowed for setuid/setgid script\n");
else
fatal("Script is not setuid/setgid in suidperl\n");
+#else
+#ifndef TAINT /* we aren't taintperl or suidperl */
+ /* script has a wrapper--can't run suidperl or we lose euid */
+ else if (euid != uid || egid != gid) {
+ (void)fclose(rsfp);
+ (void)sprintf(buf, "%s/%s", BIN, "taintperl");
+ execv(buf, origargv); /* try again */
+ fatal("Can't run setuid script with taint checks");
+ }
+#endif /* TAINT */
#endif /* IAMSUID */
+#else /* !DOSUID */
+#ifndef TAINT /* we aren't taintperl or suidperl */
+ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
+#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+ fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
+ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
+ ||
+ (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
+ )
+ if (!do_undump)
+ fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
+#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
+ /* not set-id, must be wrapped */
+ (void)fclose(rsfp);
+ (void)sprintf(buf, "%s/%s", BIN, "taintperl");
+ execv(buf, origargv); /* try again */
+ fatal("Can't run setuid script with taint checks");
+ }
+#endif /* TAINT */
#endif /* DOSUID */
defstab = stabent("_",TRUE);
+ if (perldb) {
+ debstash = hnew(0);
+ stab_xhash(stabent("_DB",TRUE)) = debstash;
+ curstash = debstash;
+ lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE))));
+ tmpstab->str_pok |= SP_MULTI;
+ subname = str_make("main",4);
+ DBstab = stabent("DB",TRUE);
+ DBstab->str_pok |= SP_MULTI;
+ DBsub = hadd(tmpstab = stabent("sub",TRUE));
+ tmpstab->str_pok |= SP_MULTI;
+ DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
+ tmpstab->str_pok |= SP_MULTI;
+ curstash = defstash;
+ }
+
/* init tokener */
- bufptr = str_get(linestr);
+ bufend = bufptr = str_get(linestr);
+
+ savestack = anew(Nullstab); /* for saving non-local values */
+ stack = anew(Nullstab); /* for saving non-local values */
+ stack->ary_flags = 0; /* not a real array */
- /* now parse the report spec */
+ /* now parse the script */
- if (yyparse())
+ error_count = 0;
+ if (yyparse() || error_count)
fatal("Execution aborted due to compilation errors.\n");
- if (dowarn) {
- stab_check('A','Z');
- stab_check('a','z');
- }
+ New(50,loop_stack,128,struct loop);
+ New(51,debname,128,char);
+ New(52,debdelim,128,char);
+ curstash = defstash;
preprocess = FALSE;
if (e_fp) {
e_fp = Nullfp;
- UNLINK(e_tmpname);
+ (void)UNLINK(e_tmpname);
+ }
+
+ /* initialize everything that won't change if we undump */
+
+ if (sigstab = stabent("SIG",allstabs)) {
+ sigstab->str_pok |= SP_MULTI;
+ (void)hadd(sigstab);
+ }
+
+ magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
+
+ amperstab = stabent("&",allstabs);
+ leftstab = stabent("`",allstabs);
+ rightstab = stabent("'",allstabs);
+ sawampersand = (amperstab || leftstab || rightstab);
+ if (tmpstab = stabent(":",allstabs))
+ str_set(STAB_STR(tmpstab),chopset);
+
+ /* these aren't necessarily magical */
+ if (tmpstab = stabent(";",allstabs))
+ str_set(STAB_STR(tmpstab),"\034");
+#ifdef TAINT
+ tainted = 1;
+#endif
+ if (tmpstab = stabent("0",allstabs))
+ str_set(STAB_STR(tmpstab),origfilename);
+#ifdef TAINT
+ tainted = 0;
+#endif
+ if (tmpstab = stabent("]",allstabs))
+ str_set(STAB_STR(tmpstab),rcsid);
+ str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
+
+ stdinstab = stabent("STDIN",TRUE);
+ stdinstab->str_pok |= SP_MULTI;
+ stab_io(stdinstab) = stio_new();
+ stab_io(stdinstab)->ifp = stdin;
+ tmpstab = stabent("stdin",TRUE);
+ stab_io(tmpstab) = stab_io(stdinstab);
+ tmpstab->str_pok |= SP_MULTI;
+
+ tmpstab = stabent("STDOUT",TRUE);
+ tmpstab->str_pok |= SP_MULTI;
+ stab_io(tmpstab) = stio_new();
+ stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
+ defoutstab = tmpstab;
+ tmpstab = stabent("stdout",TRUE);
+ stab_io(tmpstab) = stab_io(defoutstab);
+ tmpstab->str_pok |= SP_MULTI;
+
+ curoutstab = stabent("STDERR",TRUE);
+ curoutstab->str_pok |= SP_MULTI;
+ stab_io(curoutstab) = stio_new();
+ stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
+ tmpstab = stabent("stderr",TRUE);
+ stab_io(tmpstab) = stab_io(curoutstab);
+ tmpstab->str_pok |= SP_MULTI;
+ curoutstab = defoutstab; /* switch back to STDOUT */
+
+ statname = Str_new(66,0); /* last filename we did stat on */
+
+ perldb = FALSE; /* don't try to instrument evals */
+
+ if (dowarn) {
+ stab_check('A','Z');
+ stab_check('a','z');
}
+
+ if (do_undump)
+ abort();
+
+ just_doit: /* come here if running an undumped a.out */
argc--,argv++; /* skip name of script */
if (doswitches) {
for (; argc > 0 && **argv == '-'; argc--,argv++) {
argc--,argv++;
break;
}
- str_numset(stabent(argv[0]+1,TRUE)->stab_val,(double)1.0);
+ str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
}
}
+#ifdef TAINT
+ tainted = 1;
+#endif
if (argvstab = stabent("ARGV",allstabs)) {
- aadd(argvstab);
+ argvstab->str_pok |= SP_MULTI;
+ (void)aadd(argvstab);
for (; argc > 0; argc--,argv++) {
- apush(argvstab->stab_array,str_make(argv[0]));
+ (void)apush(stab_array(argvstab),str_make(argv[0],0));
}
}
+#ifdef TAINT
+ (void) stabent("ENV",TRUE); /* must test PATH and IFS */
+#endif
if (envstab = stabent("ENV",allstabs)) {
- hadd(envstab);
+ envstab->str_pok |= SP_MULTI;
+ (void)hadd(envstab);
for (; *env; env++) {
if (!(s = index(*env,'=')))
continue;
*s++ = '\0';
- str = str_make(s);
- str->str_link.str_magic = envstab;
- hstore(envstab->stab_hash,*env,str);
- *--s = '=';
+ str = str_make(s--,0);
+ str_magic(str, envstab, 'E', *env, s - *env);
+ (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
+ *s = '=';
}
}
- if (sigstab = stabent("SIG",allstabs))
- hadd(sigstab);
-
- magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|");
-
- sawampersand = (stabent("&",FALSE) != Nullstab);
- if (tmpstab = stabent("0",allstabs))
- str_set(STAB_STR(tmpstab),origfilename);
+#ifdef TAINT
+ tainted = 0;
+#endif
if (tmpstab = stabent("$",allstabs))
str_numset(STAB_STR(tmpstab),(double)getpid());
- tmpstab = stabent("stdin",TRUE);
- tmpstab->stab_io = stio_new();
- tmpstab->stab_io->fp = stdin;
-
- tmpstab = stabent("stdout",TRUE);
- tmpstab->stab_io = stio_new();
- tmpstab->stab_io->fp = stdout;
- defoutstab = tmpstab;
- curoutstab = tmpstab;
-
- tmpstab = stabent("stderr",TRUE);
- tmpstab->stab_io = stio_new();
- tmpstab->stab_io->fp = stderr;
-
- savestack = anew(Nullstab); /* for saving non-local values */
-
- setjmp(top_env); /* sets goto_targ on longjump */
+ if (setjmp(top_env)) /* sets goto_targ on longjump */
+ loop_ptr = 0; /* start label stack again */
#ifdef DEBUGGING
if (debug & 1024)
- dump_cmd(main_root,Nullcmd);
+ dump_all();
if (debug)
fprintf(stderr,"\nEXECUTING...\n\n");
#endif
/* do it */
- (void) cmd_exec(main_root);
+ (void) cmd_exec(main_root,G_SCALAR,-1);
if (goto_targ)
fatal("Can't find label \"%s\"--aborting",goto_targ);
sym[1] = '\0';
while (*sym = *list++) {
if (stab = stabent(sym,allstabs)) {
- stab->stab_flags = SF_VMAGIC;
- stab->stab_val->str_link.str_magic = stab;
- }
- }
-}
-
-ARG *
-make_split(stab,arg)
-register STAB *stab;
-register ARG *arg;
-{
- register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
-
- if (arg->arg_type != O_MATCH) {
- spat = (SPAT *) safemalloc(sizeof (SPAT));
- bzero((char *)spat, sizeof(SPAT));
- spat->spat_next = spat_root; /* link into spat list */
- spat_root = spat;
-
- spat->spat_runtime = arg;
- arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
- }
- 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;
-}
-
-SUBR *
-make_sub(name,cmd)
-char *name;
-CMD *cmd;
-{
- register SUBR *sub = (SUBR *) safemalloc(sizeof (SUBR));
- STAB *stab = stabent(name,TRUE);
-
- if (stab->stab_sub) {
- if (dowarn) {
- line_t oldline = line;
-
- if (cmd)
- line = cmd->c_line;
- warn("Subroutine %s redefined",name);
- line = oldline;
+ stab_flags(stab) = SF_VMAGIC;
+ str_magic(stab_val(stab), stab, 0, Nullch, 0);
}
- cmd_free(stab->stab_sub->cmd);
- afree(stab->stab_sub->tosave);
- safefree((char*)stab->stab_sub);
}
- bzero((char *)sub, sizeof(SUBR));
- sub->cmd = cmd;
- sub->filename = filename;
- tosave = anew(Nullstab);
- tosave->ary_fill = 0; /* make 1 based */
- cmd_tosave(cmd); /* this builds the tosave array */
- sub->tosave = tosave;
- stab->stab_sub = sub;
}
-CMD *
-block_head(tail)
-register CMD *tail;
-{
- if (tail == Nullcmd) {
- return tail;
- }
- return tail->c_head;
-}
-
-CMD *
-append_line(head,tail)
-register CMD *head;
-register CMD *tail;
-{
- if (tail == Nullcmd)
- return head;
- if (!tail->c_head) /* make sure tail is well formed */
- tail->c_head = tail;
- if (head != Nullcmd) {
- tail = tail->c_head; /* get to start of tail list */
- if (!head->c_head)
- head->c_head = head; /* start a new head list */
- while (head->c_next) {
- head->c_next->c_head = head->c_head;
- head = head->c_next; /* get to end of head list */
- }
- head->c_next = tail; /* link to end of old list */
- tail->c_head = head->c_head; /* propagate head pointer */
- }
- while (tail->c_next) {
- tail->c_next->c_head = tail->c_head;
- tail = tail->c_next;
- }
- return tail;
-}
-
-CMD *
-make_acmd(type,stab,cond,arg)
-int type;
-STAB *stab;
-ARG *cond;
-ARG *arg;
-{
- register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
-
- bzero((char *)cmd, sizeof(CMD));
- cmd->c_type = type;
- cmd->ucmd.acmd.ac_stab = stab;
- cmd->ucmd.acmd.ac_expr = arg;
- cmd->c_expr = cond;
- if (cond) {
- opt_arg(cmd,1,1);
- cmd->c_flags |= CF_COND;
- }
- if (cmdline != NOLINE) {
- cmd->c_line = cmdline;
- cmdline = NOLINE;
- }
- cmd->c_file = filename;
- return cmd;
-}
-
-CMD *
-make_ccmd(type,arg,cblock)
-int type;
-register ARG *arg;
-struct compcmd cblock;
-{
- register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
-
- bzero((char *)cmd, sizeof(CMD));
- cmd->c_type = type;
- cmd->c_expr = arg;
- cmd->ucmd.ccmd.cc_true = cblock.comp_true;
- cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
- if (arg) {
- opt_arg(cmd,1,0);
- cmd->c_flags |= CF_COND;
- }
- if (cmdline != NOLINE) {
- cmd->c_line = cmdline;
- cmdline = NOLINE;
- }
- return cmd;
-}
+/* this routine is in perly.c by virtue of being sort of an alternate main() */
-void
-opt_arg(cmd,fliporflop,acmd)
-register CMD *cmd;
-int fliporflop;
-int acmd;
+int
+do_eval(str,optype,stash,gimme,arglast)
+STR *str;
+int optype;
+HASH *stash;
+int gimme;
+int *arglast;
{
- register ARG *arg;
- int opt = CFT_EVAL;
- int sure = 0;
- ARG *arg2;
- char *tmps; /* for True macro */
- int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */
- int flp = fliporflop;
-
- if (!cmd)
- return;
- arg = cmd->c_expr;
-
- /* Can we turn && and || into if and unless? */
-
- if (acmd && !cmd->ucmd.acmd.ac_expr &&
- (arg->arg_type == O_AND || arg->arg_type == O_OR) ) {
- dehoist(arg,1);
- 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;
- arg_free(arg);
- arg = cmd->c_expr;
- }
-
- /* Turn "if (!expr)" into "unless (expr)" */
-
- 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 */
-
- if (arg->arg_type == O_AND)
- context |= 1;
- else if (arg->arg_type == O_OR)
- context |= 2;
- if (context && arg[flp].arg_type == A_EXPR) {
- arg = arg[flp].arg_ptr.arg_arg;
- flp = 1;
- }
+ STR **st = stack->ary_array;
+ int retval;
+ CMD *myroot;
+ ARRAY *ar;
+ int i;
+ char *oldfile = filename;
+ line_t oldline = line;
+ int oldtmps_base = tmps_base;
+ int oldsave = savestack->ary_fill;
+ SPAT *oldspat = curspat;
+ static char *last_eval = Nullch;
+ static CMD *last_root = Nullcmd;
+ int sp = arglast[0];
- if (arg[flp].arg_flags & (AF_PRE|AF_POST)) {
- cmd->c_flags |= opt;
- return; /* side effect, can't optimize */
+ tmps_base = tmps_max;
+ if (curstash != stash) {
+ (void)savehptr(&curstash);
+ curstash = stash;
}
-
- if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP ||
- arg->arg_type == O_AND || arg->arg_type == O_OR) {
- if (arg[flp].arg_type == A_SINGLE) {
- opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE);
- cmd->c_short = arg[flp].arg_ptr.arg_str;
- goto literal;
- }
- else if (arg[flp].arg_type == A_STAB || arg[flp].arg_type == A_LVAL) {
- cmd->c_stab = arg[flp].arg_ptr.arg_stab;
- opt = CFT_REG;
- literal:
- if (!context) { /* no && or ||? */
- free_arg(arg);
- cmd->c_expr = Nullarg;
- }
- if (!(context & 1))
- cmd->c_flags |= CF_EQSURE;
- if (!(context & 2))
- cmd->c_flags |= CF_NESURE;
- }
+ str_set(stab_val(stabent("@",TRUE)),"");
+ if (optype != O_DOFILE) { /* normal eval */
+ filename = "(eval)";
+ line = 1;
+ str_sset(linestr,str);
+ str_cat(linestr,";"); /* be kind to them */
}
- else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST ||
- arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) {
- if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
- arg[2].arg_type == A_SPAT &&
- arg[2].arg_ptr.arg_spat->spat_short ) {
- cmd->c_stab = arg[1].arg_ptr.arg_stab;
- cmd->c_short = 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.) */
- 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 (last_root) {
+ Safefree(last_eval);
+ cmd_free(last_root);
+ last_root = Nullcmd;
}
- }
- 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 = arg[2].arg_ptr.arg_str;
- cmd->c_slen = 30000;
- switch (arg->arg_type) {
- case O_SLT: case O_SGT:
- sure |= CF_EQSURE;
- cmd->c_flags |= CF_FIRSTNEG;
- break;
- case O_SNE:
- cmd->c_flags |= CF_FIRSTNEG;
- /* FALL THROUGH */
- case O_SEQ:
- sure |= CF_NESURE|CF_EQSURE;
+ filename = savestr(str_get(str)); /* can't free this easily */
+ str_set(linestr,"");
+ rsfp = fopen(filename,"r");
+ ar = stab_array(incstab);
+ if (!rsfp && *filename != '/') {
+ for (i = 0; i <= ar->ary_fill; i++) {
+ (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename);
+ rsfp = fopen(buf,"r");
+ if (rsfp) {
+ filename = savestr(buf);
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;
- 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 (!(arg2[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV)) {
- free_arg(arg2);
- free_arg(arg);
- cmd->c_expr = Nullarg;
- }
+ if (!rsfp) {
+ filename = oldfile;
+ tmps_base = oldtmps_base;
+ if (gimme != G_ARRAY)
+ st[++sp] = &str_undef;
+ return sp;
}
+ line = 0;
}
- else if (arg->arg_type == O_CHOP &&
- (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) {
- opt = CFT_CHOP;
- cmd->c_stab = arg[1].arg_ptr.arg_stab;
- free_arg(arg);
- cmd->c_expr = Nullarg;
- }
- if (context & 4)
- opt |= CF_FLIP;
- cmd->c_flags |= opt;
-
- if (cmd->c_flags & CF_FLIP) {
- if (fliporflop == 1) {
- arg = cmd->c_expr; /* get back to O_FLIP arg */
- arg[3].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
- bcopy((char *)cmd, (char *)arg[3].arg_ptr.arg_cmd, sizeof(CMD));
- arg[4].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
- bcopy((char *)cmd, (char *)arg[4].arg_ptr.arg_cmd, sizeof(CMD));
- opt_arg(arg[4].arg_ptr.arg_cmd,2,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;
- }
+ in_eval++;
+ oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
+ bufend = bufptr + linestr->str_cur;
+ if (setjmp(eval_env)) {
+ retval = 1;
+ last_root = Nullcmd;
}
-}
-
-ARG *
-mod_match(type,left,pat)
-register ARG *left;
-register ARG *pat;
-{
-
- register SPAT *spat;
- register ARG *newarg;
-
- if ((pat->arg_type == O_MATCH ||
- pat->arg_type == O_SUBST ||
- pat->arg_type == O_TRANS ||
- pat->arg_type == O_SPLIT
- ) &&
- pat[1].arg_ptr.arg_stab == defstab ) {
- switch (pat->arg_type) {
- case O_MATCH:
- newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH,
- pat->arg_len,
- left,Nullarg,Nullarg,0);
- break;
- case O_SUBST:
- newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST,
- pat->arg_len,
- left,Nullarg,Nullarg,0));
- break;
- case O_TRANS:
- newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS,
- pat->arg_len,
- left,Nullarg,Nullarg,0));
- break;
- case O_SPLIT:
- newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT,
- pat->arg_len,
- left,Nullarg,Nullarg,0);
- break;
- }
- if (pat->arg_len >= 2) {
- newarg[2].arg_type = pat[2].arg_type;
- newarg[2].arg_ptr = pat[2].arg_ptr;
- newarg[2].arg_flags = pat[2].arg_flags;
- if (pat->arg_len >= 3) {
- newarg[3].arg_type = pat[3].arg_type;
- newarg[3].arg_ptr = pat[3].arg_ptr;
- newarg[3].arg_flags = pat[3].arg_flags;
+ else {
+ error_count = 0;
+ if (rsfp)
+ retval = yyparse();
+ else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
+ retval = 0;
+ eval_root = last_root; /* no point in reparsing */
+ }
+ else if (in_eval == 1) {
+ if (last_root) {
+ Safefree(last_eval);
+ cmd_free(last_root);
}
+ last_eval = savestr(bufptr);
+ last_root = Nullcmd;
+ retval = yyparse();
+ if (!retval)
+ last_root = eval_root;
}
- safefree((char*)pat);
+ else
+ retval = yyparse();
}
- else {
- spat = (SPAT *) safemalloc(sizeof (SPAT));
- bzero((char *)spat, sizeof(SPAT));
- spat->spat_next = spat_root; /* link into spat list */
- spat_root = spat;
-
- spat->spat_runtime = pat;
- newarg = make_op(type,2,left,Nullarg,Nullarg,0);
- newarg[2].arg_type = A_SPAT;
- newarg[2].arg_ptr.arg_spat = spat;
- newarg[2].arg_flags = AF_SPECIAL;
+ myroot = eval_root; /* in case cmd_exec does another eval! */
+ if (retval || error_count) {
+ str = &str_undef;
+ last_root = Nullcmd; /* can't free on error, for some reason */
+ if (rsfp) {
+ fclose(rsfp);
+ rsfp = 0;
+ }
}
-
- return newarg;
-}
-
-CMD *
-add_label(lbl,cmd)
-char *lbl;
-register CMD *cmd;
-{
- if (cmd)
- cmd->c_label = lbl;
- return cmd;
-}
-
-CMD *
-addcond(cmd, arg)
-register CMD *cmd;
-register ARG *arg;
-{
- cmd->c_expr = arg;
- opt_arg(cmd,1,0);
- cmd->c_flags |= CF_COND;
- return cmd;
-}
-
-CMD *
-addloop(cmd, arg)
-register CMD *cmd;
-register ARG *arg;
-{
- cmd->c_expr = arg;
- opt_arg(cmd,1,0);
- cmd->c_flags |= CF_COND|CF_LOOP;
- if (cmd->c_type == C_BLOCK)
- cmd->c_flags &= ~CF_COND;
else {
- arg = cmd->ucmd.acmd.ac_expr;
- if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD)
- cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */
- if (arg && arg->arg_type == O_SUBR)
- cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */
- }
- return cmd;
-}
-
-CMD *
-invert(cmd)
-register CMD *cmd;
-{
- cmd->c_flags ^= CF_INVERT;
- return cmd;
-}
-
-yyerror(s)
-char *s;
-{
- char tmpbuf[128];
- char *tname = tmpbuf;
-
- if (yychar > 256) {
- tname = tokename[yychar-256];
- if (strEQ(tname,"word"))
- strcpy(tname,tokenbuf);
- else if (strEQ(tname,"register"))
- sprintf(tname,"$%s",tokenbuf);
- else if (strEQ(tname,"array_length"))
- sprintf(tname,"$#%s",tokenbuf);
- }
- else if (!yychar)
- strcpy(tname,"EOF");
- else if (yychar < 32)
- sprintf(tname,"^%c",yychar+64);
- else if (yychar == 127)
- strcpy(tname,"^?");
- else
- sprintf(tname,"%c",yychar);
- sprintf(tokenbuf, "%s in file %s at line %d, next token \"%s\"\n",
- s,filename,line,tname);
- if (in_eval)
- str_set(stabent("@",TRUE)->stab_val,tokenbuf);
- else
- fputs(tokenbuf,stderr);
-}
-
-ARG *
-make_op(type,newlen,arg1,arg2,arg3,dolist)
-int type;
-int newlen;
-ARG *arg1;
-ARG *arg2;
-ARG *arg3;
-int dolist;
-{
- register ARG *arg;
- register ARG *chld;
- register int doarg;
-
- arg = op_new(newlen);
- arg->arg_type = type;
- doarg = opargs[type];
- if (chld = arg1) {
- if (!(doarg & 1))
- arg[1].arg_flags |= AF_SPECIAL;
- if (doarg & 16)
- arg[1].arg_flags |= AF_NUMERIC;
- if (chld->arg_type == O_ITEM &&
- (hoistable[chld[1].arg_type] || chld[1].arg_type == A_LVAL) ) {
- arg[1].arg_type = chld[1].arg_type;
- arg[1].arg_ptr = chld[1].arg_ptr;
- arg[1].arg_flags |= chld[1].arg_flags;
- free_arg(chld);
- }
- else {
- arg[1].arg_type = A_EXPR;
- arg[1].arg_ptr.arg_arg = chld;
- if (dolist & 1) {
- if (chld->arg_type == O_LIST) {
- if (newlen == 1) { /* we can hoist entire list */
- chld->arg_type = type;
- free_arg(arg);
- arg = chld;
- }
- else {
- arg[1].arg_flags |= AF_SPECIAL;
- }
- }
- else {
- switch (chld->arg_type) {
- case O_ARRAY:
- if (chld->arg_len == 1)
- arg[1].arg_flags |= AF_SPECIAL;
- break;
- case O_ITEM:
- if (chld[1].arg_type == A_READ ||
- chld[1].arg_type == A_INDREAD ||
- chld[1].arg_type == A_GLOB)
- arg[1].arg_flags |= AF_SPECIAL;
- break;
- case O_SPLIT:
- case O_TMS:
- case O_EACH:
- case O_VALUES:
- case O_KEYS:
- case O_SORT:
- arg[1].arg_flags |= AF_SPECIAL;
- break;
- }
- }
- }
- }
- }
- if (chld = arg2) {
- if (!(doarg & 2))
- arg[2].arg_flags |= AF_SPECIAL;
- if (doarg & 32)
- arg[2].arg_flags |= AF_NUMERIC;
- if (chld->arg_type == O_ITEM &&
- (hoistable[chld[1].arg_type] ||
- (type == O_ASSIGN &&
- ((chld[1].arg_type == A_READ && !(arg[1].arg_flags & AF_SPECIAL))
- ||
- (chld[1].arg_type == A_INDREAD && !(arg[1].arg_flags & AF_SPECIAL))
- ||
- (chld[1].arg_type == A_GLOB && !(arg[1].arg_flags & AF_SPECIAL))
- ||
- chld[1].arg_type == A_BACKTICK ) ) ) ) {
- arg[2].arg_type = chld[1].arg_type;
- arg[2].arg_ptr = chld[1].arg_ptr;
- free_arg(chld);
- }
- else {
- arg[2].arg_type = A_EXPR;
- arg[2].arg_ptr.arg_arg = chld;
- if ((dolist & 2) &&
- (chld->arg_type == O_LIST ||
- (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
- arg[2].arg_flags |= AF_SPECIAL;
- }
- }
- if (chld = arg3) {
- if (!(doarg & 4))
- arg[3].arg_flags |= AF_SPECIAL;
- if (doarg & 64)
- arg[3].arg_flags |= AF_NUMERIC;
- if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) {
- arg[3].arg_type = chld[1].arg_type;
- arg[3].arg_ptr = chld[1].arg_ptr;
- free_arg(chld);
- }
- else {
- arg[3].arg_type = A_EXPR;
- arg[3].arg_ptr.arg_arg = chld;
- if ((dolist & 4) &&
- (chld->arg_type == O_LIST ||
- (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
- arg[3].arg_flags |= AF_SPECIAL;
- }
- }
-#ifdef DEBUGGING
- if (debug & 16) {
- fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]);
- if (arg1)
- fprintf(stderr,",%s=%lx",
- argname[arg[1].arg_type],arg[1].arg_ptr.arg_arg);
- if (arg2)
- fprintf(stderr,",%s=%lx",
- argname[arg[2].arg_type],arg[2].arg_ptr.arg_arg);
- if (arg3)
- fprintf(stderr,",%s=%lx",
- argname[arg[3].arg_type],arg[3].arg_ptr.arg_arg);
- fprintf(stderr,")\n");
- }
-#endif
- evalstatic(arg); /* see if we can consolidate anything */
- return arg;
-}
-
-/* turn 123 into 123 == $. */
-
-ARG *
-flipflip(arg)
-register ARG *arg;
-{
- if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_SINGLE) {
- arg = (ARG*)saferealloc((char*)arg,3*sizeof(ARG));
- arg->arg_type = O_EQ;
- arg->arg_len = 2;
- arg[2].arg_type = A_STAB;
- arg[2].arg_flags = 0;
- arg[2].arg_ptr.arg_stab = stabent(".",TRUE);
- }
- return arg;
-}
-
-void
-evalstatic(arg)
-register ARG *arg;
-{
- register STR *str;
- register STR *s1;
- register STR *s2;
- double value; /* must not be register */
- register char *tmps;
- int i;
- unsigned long tmplong;
- double exp(), log(), sqrt(), modf();
- char *crypt();
-
- if (!arg || !arg->arg_len)
- return;
-
- if (arg[1].arg_type == A_SINGLE &&
- (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) {
- str = str_new(0);
- s1 = arg[1].arg_ptr.arg_str;
- if (arg->arg_len > 1)
- s2 = arg[2].arg_ptr.arg_str;
- else
- s2 = Nullstr;
- switch (arg->arg_type) {
- default:
- str_free(str);
- str = Nullstr; /* can't be evaluated yet */
- break;
- case O_CONCAT:
- str_sset(str,s1);
- str_scat(str,s2);
- break;
- case O_REPEAT:
- i = (int)str_gnum(s2);
- while (i-- > 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)
- fatal("Illegal division by constant zero");
- str_numset(str,str_gnum(s1) / value);
- break;
- case O_MODULO:
- tmplong = (unsigned long)str_gnum(s2);
- if (tmplong == 0L)
- fatal("Illegal modulus of constant zero");
- str_numset(str,(double)(((unsigned long)str_gnum(s1)) % tmplong));
- 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);
- str_numset(str,(double)(((unsigned long)value) << i));
- break;
- case O_RIGHT_SHIFT:
- value = str_gnum(s1);
- i = (int)str_gnum(s2);
- str_numset(str,(double)(((unsigned long)value) >> i));
- break;
- case O_LT:
- value = str_gnum(s1);
- str_numset(str,(double)(value < str_gnum(s2)));
- break;
- case O_GT:
- value = str_gnum(s1);
- str_numset(str,(double)(value > str_gnum(s2)));
- break;
- case O_LE:
- value = str_gnum(s1);
- str_numset(str,(double)(value <= str_gnum(s2)));
- break;
- case O_GE:
- value = str_gnum(s1);
- str_numset(str,(double)(value >= str_gnum(s2)));
- break;
- case O_EQ:
- value = str_gnum(s1);
- str_numset(str,(double)(value == str_gnum(s2)));
- break;
- case O_NE:
- value = str_gnum(s1);
- str_numset(str,(double)(value != str_gnum(s2)));
- break;
- case O_BIT_AND:
- value = str_gnum(s1);
- str_numset(str,(double)(((unsigned long)value) &
- ((unsigned long)str_gnum(s2))));
- break;
- case O_XOR:
- value = str_gnum(s1);
- str_numset(str,(double)(((unsigned long)value) ^
- ((unsigned long)str_gnum(s2))));
- break;
- case O_BIT_OR:
- value = str_gnum(s1);
- str_numset(str,(double)(((unsigned long)value) |
- ((unsigned long)str_gnum(s2))));
- break;
- case O_AND:
- if (str_true(s1))
- str = str_make(str_get(s2));
- else
- str = str_make(str_get(s1));
- break;
- case O_OR:
- if (str_true(s1))
- str = str_make(str_get(s1));
- else
- str = str_make(str_get(s2));
- break;
- case O_COND_EXPR:
- if (arg[3].arg_type != A_SINGLE) {
- str_free(str);
- str = Nullstr;
- }
- else {
- str = str_make(str_get(str_true(s1) ? s2 : arg[3].arg_ptr.arg_str));
- str_free(arg[3].arg_ptr.arg_str);
- }
- break;
- case O_NEGATE:
- str_numset(str,(double)(-str_gnum(s1)));
- break;
- case O_NOT:
- str_numset(str,(double)(!str_true(s1)));
- break;
- case O_COMPLEMENT:
- str_numset(str,(double)(~(long)str_gnum(s1)));
- break;
- case O_LENGTH:
- str_numset(str, (double)str_len(s1));
- break;
- case O_SUBSTR:
- if (arg[3].arg_type != A_SINGLE || stabent("[",allstabs)) {
- str_free(str); /* making the fallacious assumption */
- str = Nullstr; /* that any $[ occurs before substr()*/
- }
- else {
- char *beg;
- int len = (int)str_gnum(s2);
- int tmp;
-
- for (beg = str_get(s1); *beg && len > 0; beg++,len--) ;
- len = (int)str_gnum(arg[3].arg_ptr.arg_str);
- str_free(arg[3].arg_ptr.arg_str);
- if (len > (tmp = strlen(beg)))
- len = tmp;
- str_nset(str,beg,len);
- }
- break;
- case O_SLT:
- tmps = str_get(s1);
- str_numset(str,(double)(strLT(tmps,str_get(s2))));
- break;
- case O_SGT:
- tmps = str_get(s1);
- str_numset(str,(double)(strGT(tmps,str_get(s2))));
- break;
- case O_SLE:
- tmps = str_get(s1);
- str_numset(str,(double)(strLE(tmps,str_get(s2))));
- break;
- case O_SGE:
- tmps = str_get(s1);
- str_numset(str,(double)(strGE(tmps,str_get(s2))));
- break;
- case O_SEQ:
- tmps = str_get(s1);
- str_numset(str,(double)(strEQ(tmps,str_get(s2))));
- break;
- case O_SNE:
- tmps = str_get(s1);
- str_numset(str,(double)(strNE(tmps,str_get(s2))));
- break;
- case O_CRYPT:
-#ifdef CRYPT
- tmps = str_get(s1);
- str_set(str,crypt(tmps,str_get(s2)));
-#else
- fatal(
- "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)
- modf(value,&value);
- else {
- modf(-value,&value);
- value = -value;
- }
- str_numset(str,value);
- break;
- case O_ORD:
- str_numset(str,(double)(*str_get(s1)));
- break;
- }
- if (str) {
- arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */
- str_free(s1);
- str_free(s2);
- arg[1].arg_ptr.arg_str = str;
- }
- }
-}
-
-ARG *
-l(arg)
-register ARG *arg;
-{
- register int i;
- register ARG *arg1;
- ARG *tmparg;
-
- arg->arg_flags |= AF_COMMON; /* XXX should cross-match */
- /* this does unnecessary copying */
-
- if (arg[1].arg_type == A_ARYLEN) {
- arg[1].arg_type = A_LARYLEN;
- return arg;
- }
-
- /* see if it's an array reference */
-
- if (arg[1].arg_type == A_EXPR) {
- arg1 = arg[1].arg_ptr.arg_arg;
-
- if (arg1->arg_type == O_LIST && arg->arg_type != O_ITEM) {
- /* assign to list */
- arg[1].arg_flags |= AF_SPECIAL;
- dehoist(arg,2);
- arg[2].arg_flags |= AF_SPECIAL;
- for (i = arg1->arg_len; i >= 1; i--) {
- switch (arg1[i].arg_type) {
- case A_STAB: case A_LVAL:
- arg1[i].arg_type = A_LVAL;
- break;
- case A_EXPR: case A_LEXPR:
- arg1[i].arg_type = A_LEXPR;
- if (arg1[i].arg_ptr.arg_arg->arg_type == O_ARRAY)
- arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY;
- else if (arg1[i].arg_ptr.arg_arg->arg_type == O_HASH)
- arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH;
- if (arg1[i].arg_ptr.arg_arg->arg_type == O_LARRAY)
- break;
- if (arg1[i].arg_ptr.arg_arg->arg_type == O_LHASH)
- break;
- /* FALL THROUGH */
- default:
- sprintf(tokenbuf,
- "Illegal item (%s) as lvalue",argname[arg1[i].arg_type]);
- yyerror(tokenbuf);
- }
- }
- }
- else if (arg1->arg_type == O_ARRAY) {
- if (arg1->arg_len == 1 && arg->arg_type != O_ITEM) {
- /* assign to array */
- arg[1].arg_flags |= AF_SPECIAL;
- dehoist(arg,2);
- arg[2].arg_flags |= AF_SPECIAL;
- }
- else
- arg1->arg_type = O_LARRAY; /* assign to array elem */
- }
- else if (arg1->arg_type == O_HASH)
- arg1->arg_type = O_LHASH;
- else if (arg1->arg_type != O_ASSIGN) {
- sprintf(tokenbuf,
- "Illegal expression (%s) as lvalue",opname[arg1->arg_type]);
- yyerror(tokenbuf);
- }
- arg[1].arg_type = A_LEXPR;
-#ifdef DEBUGGING
- if (debug & 16)
- fprintf(stderr,"lval LEXPR\n");
-#endif
- return arg;
- }
-
- /* not an array reference, should be a register name */
-
- if (arg[1].arg_type != A_STAB && arg[1].arg_type != A_LVAL) {
- sprintf(tokenbuf,
- "Illegal item (%s) as lvalue",argname[arg[1].arg_type]);
- yyerror(tokenbuf);
- }
- arg[1].arg_type = A_LVAL;
-#ifdef DEBUGGING
- if (debug & 16)
- fprintf(stderr,"lval LVAL\n");
-#endif
- return arg;
-}
-
-dehoist(arg,i)
-ARG *arg;
-{
- ARG *tmparg;
-
- if (arg[i].arg_type != A_EXPR) { /* dehoist */
- tmparg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg,0);
- 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)
- return make_op(O_ITEM,1,arg,Nullarg,Nullarg,0);
- return arg;
-}
-
-ARG *
-make_list(arg)
-register ARG *arg;
-{
- register int i;
- register ARG *node;
- register ARG *nxtnode;
- register int j;
- STR *tmpstr;
-
- if (!arg) {
- arg = op_new(0);
- arg->arg_type = O_LIST;
- }
- if (arg->arg_type != O_COMMA) {
- arg->arg_flags |= AF_LISTISH; /* see listish() below */
- return arg;
- }
- for (i = 2, node = arg; ; i++) {
- if (node->arg_len < 2)
- break;
- if (node[2].arg_type != A_EXPR)
- break;
- node = node[2].arg_ptr.arg_arg;
- if (node->arg_type != O_COMMA)
- break;
- }
- if (i > 2) {
- node = arg;
- arg = op_new(i);
- tmpstr = arg->arg_ptr.arg_str;
- *arg = *node; /* copy everything except the STR */
- arg->arg_ptr.arg_str = tmpstr;
- for (j = 1; ; ) {
- arg[j] = node[1];
- ++j; /* Bug in Xenix compiler */
- if (j >= i) {
- arg[j] = node[2];
- free_arg(node);
- break;
- }
- nxtnode = node[2].arg_ptr.arg_arg;
- free_arg(node);
- node = nxtnode;
- }
- }
- arg->arg_type = O_LIST;
- arg->arg_len = i;
- return arg;
-}
-
-/* turn a single item into a list */
-
-ARG *
-listish(arg)
-ARG *arg;
-{
- if (arg->arg_flags & AF_LISTISH) {
- arg = make_op(O_LIST,1,arg,Nullarg,Nullarg,0);
- arg[1].arg_flags &= ~AF_SPECIAL;
- }
- return arg;
-}
-
-/* mark list of local variables */
-
-ARG *
-localize(arg)
-ARG *arg;
-{
- arg->arg_flags |= AF_LOCAL;
- 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);
- safefree(cval);
- return arg;
-}
-
-ARG *
-op_new(numargs)
-int numargs;
-{
- register ARG *arg;
-
- arg = (ARG*)safemalloc((numargs + 1) * sizeof (ARG));
- bzero((char *)arg, (numargs + 1) * sizeof (ARG));
- arg->arg_ptr.arg_str = str_new(0);
- arg->arg_len = numargs;
- return arg;
-}
-
-void
-free_arg(arg)
-ARG *arg;
-{
- str_free(arg->arg_ptr.arg_str);
- safefree((char*)arg);
-}
-
-ARG *
-make_match(type,expr,spat)
-int type;
-ARG *expr;
-SPAT *spat;
-{
- register ARG *arg;
-
- arg = make_op(type,2,expr,Nullarg,Nullarg,0);
-
- arg[2].arg_type = A_SPAT;
- arg[2].arg_ptr.arg_spat = spat;
-#ifdef DEBUGGING
- if (debug & 16)
- fprintf(stderr,"make_match SPAT=%lx\n",(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;
-}
-
-CMD *
-wopt(cmd)
-register CMD *cmd;
-{
- register CMD *tail;
- register ARG *arg = cmd->c_expr;
- STAB *asgnstab;
-
- /* hoist "while (<channel>)" up into command block */
-
- if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) {
- cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
- cmd->c_flags |= CFT_GETS; /* and set it to do the input */
- cmd->c_stab = arg[1].arg_ptr.arg_stab;
- if (arg[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV) {
- cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */
- stab2arg(A_LVAL,defstab), arg, Nullarg,1 ));
- }
- 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,1 ));
- cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
- }
-
- /* First find the end of the true list */
-
- if (cmd->ucmd.ccmd.cc_true == Nullcmd)
- return cmd;
- for (tail = cmd->ucmd.ccmd.cc_true; tail->c_next; tail = tail->c_next) ;
-
- /* if there's a continue block, link it to true block and find end */
-
- if (cmd->ucmd.ccmd.cc_alt != Nullcmd) {
- tail->c_next = cmd->ucmd.ccmd.cc_alt;
- for ( ; tail->c_next; tail = tail->c_next) ;
- }
-
- /* Here's the real trick: link the end of the list back to the beginning,
- * inserting a "last" block to break out of the loop. This saves one or
- * two procedure calls every time through the loop, because of how cmd_exec
- * does tail recursion.
- */
-
- tail->c_next = (CMD *) safemalloc(sizeof (CMD));
- tail = tail->c_next;
- if (!cmd->ucmd.ccmd.cc_alt)
- cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */
-
- bcopy((char *)cmd, (char *)tail, sizeof(CMD));
- tail->c_type = C_EXPR;
- tail->c_flags ^= CF_INVERT; /* turn into "last unless" */
- tail->c_next = tail->ucmd.ccmd.cc_true; /* loop directly back to top */
- tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg,0);
- tail->ucmd.acmd.ac_stab = Nullstab;
- return cmd;
-}
-
-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;
-}
-
-static int gensym = 0;
-
-STAB *
-genstab()
-{
- sprintf(tokenbuf,"_GEN_%d",gensym++);
- return stabent(tokenbuf,TRUE);
-}
-
-/* this routine is in perly.c by virtue of being sort of an alternate main() */
-
-STR *
-do_eval(str,optype)
-STR *str;
-int optype;
-{
- int retval;
- CMD *myroot;
- ARRAY *ar;
- int i;
- char *oldfile = filename;
- line_t oldline = line;
- int oldtmps_base = tmps_base;
- int oldsave = savestack->ary_fill;
-
- tmps_base = tmps_max;
- str_set(stabent("@",TRUE)->stab_val,"");
- if (optype != O_DOFILE) { /* normal eval */
- filename = "(eval)";
- line = 1;
- str_sset(linestr,str);
- }
- else {
- filename = savestr(str_get(str)); /* can't free this easily */
- str_set(linestr,"");
- rsfp = fopen(filename,"r");
- ar = incstab->stab_array;
- if (!rsfp && *filename != '/') {
- for (i = 0; i <= ar->ary_fill; i++) {
- sprintf(tokenbuf,"%s/%s",str_get(afetch(ar,i)),filename);
- rsfp = fopen(tokenbuf,"r");
- if (rsfp) {
- free(filename);
- filename = savestr(tokenbuf);
- break;
- }
- }
- }
- if (!rsfp) {
- filename = oldfile;
- tmps_base = oldtmps_base;
- return &str_no;
- }
- line = 0;
- }
- in_eval++;
- bufptr = str_get(linestr);
- if (setjmp(eval_env))
- retval = 1;
- else
- retval = yyparse();
- myroot = eval_root; /* in case cmd_exec does another eval! */
- if (retval)
- str = &str_no;
- else {
- str = str_static(cmd_exec(eval_root));
- /* if we don't save str, free zaps it */
- cmd_free(myroot); /* can't free on error, for some reason */
+ sp = cmd_exec(eval_root,gimme,sp);
+ st = stack->ary_array;
+ for (i = arglast[0] + 1; i <= sp; i++)
+ st[i] = str_static(st[i]);
+ /* if we don't save result, free zaps it */
+ if (in_eval != 1 && myroot != last_root)
+ cmd_free(myroot);
}
in_eval--;
filename = oldfile;
line = oldline;
tmps_base = oldtmps_base;
+ curspat = oldspat;
if (savestack->ary_fill > oldsave) /* let them use local() */
restorelist(oldsave);
- return str;
-}
-
-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_IF:
- if (cmd->ucmd.ccmd.cc_true)
- cmd_free(cmd->ucmd.ccmd.cc_true);
- if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt)
- cmd_free(cmd->ucmd.ccmd.cc_alt);
- 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((char*)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) {
- case A_NULL:
- break;
- case A_LEXPR:
- 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:
- 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;
- case A_NUMBER:
- break;
- }
- }
- free_arg(arg);
-}
-
-spat_free(spat)
-register SPAT *spat;
-{
- register SPAT *sp;
-
- 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 */
- if (spat_root == spat)
- spat_root = spat->spat_next;
- else {
- for (sp = spat_root; sp->spat_next != spat; sp = sp->spat_next) ;
- sp->spat_next = spat->spat_next;
- }
-
- safefree((char*)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)
-register CMD *cmd;
-{
- register CMD *head = cmd;
-
- while (cmd) {
- if (cmd->c_spat)
- spat_tosave(cmd->c_spat);
- if (cmd->c_expr)
- arg_tosave(cmd->c_expr);
- switch (cmd->c_type) {
- case C_WHILE:
- case C_BLOCK:
- case C_IF:
- if (cmd->ucmd.ccmd.cc_true)
- cmd_tosave(cmd->ucmd.ccmd.cc_true);
- if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt)
- cmd_tosave(cmd->ucmd.ccmd.cc_alt);
- break;
- case C_EXPR:
- if (cmd->ucmd.acmd.ac_expr)
- arg_tosave(cmd->ucmd.acmd.ac_expr);
- break;
- }
- cmd = cmd->c_next;
- if (cmd && cmd == head) /* reached end of while loop */
- break;
- }
-}
-
-static int
-arg_tosave(arg)
-register ARG *arg;
-{
- register int i;
- int saving = FALSE;
-
- for (i = 1; i <= arg->arg_len; i++) {
- switch (arg[i].arg_type) {
- case A_NULL:
- break;
- case A_LEXPR:
- case A_EXPR:
- saving |= arg_tosave(arg[i].arg_ptr.arg_arg);
- break;
- case A_CMD:
- cmd_tosave(arg[i].arg_ptr.arg_cmd);
- saving = TRUE; /* assume hanky panky */
- 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:
- saving |= spat_tosave(arg[i].arg_ptr.arg_spat);
- break;
- case A_NUMBER:
- break;
- }
- }
- switch (arg->arg_type) {
- case O_EVAL:
- case O_SUBR:
- saving = TRUE;
- }
- if (saving)
- apush(tosave,arg->arg_ptr.arg_str);
- return saving;
-}
-
-static int
-spat_tosave(spat)
-register SPAT *spat;
-{
- int saving = FALSE;
-
- if (spat->spat_runtime)
- saving |= arg_tosave(spat->spat_runtime);
- if (spat->spat_repl) {
- saving |= arg_tosave(spat->spat_repl);
- }
-
- return saving;
+ return sp;
}
--- /dev/null
+/* NOTE: this is derived from Henry Spencer's regexp code, and should not
+ * confused with the original package (see point 3 below). Thanks, Henry!
+ */
+
+/* Additional note: this code is very heavily munged from Henry's version
+ * in places. In some spots I've traded clarity for efficiency, so don't
+ * blame Henry for some of the lack of readability.
+ */
+
+/* $Header: regcomp.c,v 3.0 89/10/18 15:22:29 lwall Locked $
+ *
+ * $Log: regcomp.c,v $
+ * Revision 3.0 89/10/18 15:22:29 lwall
+ * 3.0 baseline
+ *
+ */
+
+/*
+ * regcomp and regexec -- regsub and regerror are not used in perl
+ *
+ * Copyright (c) 1986 by University of Toronto.
+ * Written by Henry Spencer. Not derived from licensed software.
+ *
+ * Permission is granted to anyone to use this software for any
+ * purpose on any computer system, and to redistribute it freely,
+ * subject to the following restrictions:
+ *
+ * 1. The author is not responsible for the consequences of use of
+ * this software, no matter how awful, even if they arise
+ * from defects in it.
+ *
+ * 2. The origin of this software must not be misrepresented, either
+ * by explicit claim or by omission.
+ *
+ * 3. Altered versions must be plainly marked as such, and must not
+ * be misrepresented as being the original software.
+ *
+ *
+ **** Alterations to Henry's code are...
+ ****
+ **** 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.
+ *
+ * Beware that some of this code is subtly aware of the way operator
+ * precedence is structured in regular expressions. Serious changes in
+ * regular-expression syntax might require a total rethink.
+ */
+#include "EXTERN.h"
+#include "perl.h"
+#include "INTERN.h"
+#include "regcomp.h"
+
+#ifndef STATIC
+#define STATIC static
+#endif
+
+#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
+#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
+ ((*s) == '{' && regcurly(s)))
+#define META "^$.[()|?+*\\"
+
+/*
+ * Flags to be passed up and down.
+ */
+#define HASWIDTH 01 /* Known never to match null string. */
+#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */
+#define SPSTART 04 /* Starts with * or +. */
+#define WORST 0 /* Worst case. */
+
+/*
+ * Global work variables for regcomp().
+ */
+static char *regprecomp; /* uncompiled string. */
+static char *regparse; /* Input-scan pointer. */
+static char *regxend; /* End of input for compile */
+static int regnpar; /* () count. */
+static char *regcode; /* Code-emit pointer; ®dummy = don't. */
+static long regsize; /* Code size. */
+static int regfold;
+static int regsawbracket; /* Did we do {d,d} trick? */
+
+/*
+ * Forward declarations for regcomp()'s friends.
+ */
+STATIC int regcurly();
+STATIC char *reg();
+STATIC char *regbranch();
+STATIC char *regpiece();
+STATIC char *regatom();
+STATIC char *regclass();
+STATIC char *regnode();
+STATIC void regc();
+STATIC void reginsert();
+STATIC void regtail();
+STATIC void regoptail();
+
+/*
+ - regcomp - compile a regular expression into internal code
+ *
+ * We can't allocate space until we know how big the compiled form will be,
+ * but we can't compile it (and thus know how big it is) until we've got a
+ * place to put the code. So we cheat: we compile it twice, once with code
+ * generation turned off and size counting turned on, and once "for real".
+ * This also means that we don't allocate space until we are sure that the
+ * thing really will compile successfully, and we never have to move the
+ * code and thus invalidate pointers into it. (Note that it has to be in
+ * one piece because free() must be able to free it all.) [NB: not true in perl]
+ *
+ * Beware that the optimization-preparation code in here knows about some
+ * of the structure of the compiled regexp. [I'll say.]
+ */
+regexp *
+regcomp(exp,xend,fold,rare)
+char *exp;
+char *xend;
+int fold;
+int rare;
+{
+ register regexp *r;
+ register char *scan;
+ register STR *longest;
+ register int len;
+ register char *first;
+ int flags;
+ int back;
+ int curback;
+ extern char *safemalloc();
+ extern char *savestr();
+
+ if (exp == NULL)
+ fatal("NULL regexp argument");
+
+ /* First pass: determine size, legality. */
+ regfold = fold;
+ regparse = exp;
+ regxend = xend;
+ regprecomp = nsavestr(exp,xend-exp);
+ regsawbracket = 0;
+ regnpar = 1;
+ regsize = 0L;
+ regcode = ®dummy;
+ regc(MAGIC);
+ if (reg(0, &flags) == NULL) {
+ Safefree(regprecomp);
+ return(NULL);
+ }
+
+ /* Small enough for pointer-storage convention? */
+ if (regsize >= 32767L) /* Probably could be 65535L. */
+ FAIL("regexp too big");
+
+ /* Allocate space. */
+ Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp);
+ if (r == NULL)
+ FAIL("regexp out of space");
+
+ /* Second pass: emit code. */
+ if (regsawbracket)
+ bcopy(regprecomp,exp,xend-exp);
+ r->precomp = regprecomp;
+ r->subbase = NULL;
+ regparse = exp;
+ regnpar = 1;
+ regcode = r->program;
+ regc(MAGIC);
+ if (reg(0, &flags) == NULL)
+ return(NULL);
+
+ /* Dig out information for optimizations. */
+ r->regstart = Nullstr; /* Worst-case defaults. */
+ r->reganch = 0;
+ r->regmust = Nullstr;
+ r->regback = -1;
+ r->regstclass = Nullch;
+ scan = r->program+1; /* First BRANCH. */
+ if (OP(regnext(scan)) == END) {/* Only one top-level choice. */
+ scan = NEXTOPER(scan);
+
+ first = scan;
+ while ((OP(first) > OPEN && OP(first) < CLOSE) ||
+ (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
+ (OP(first) == PLUS) )
+ first = NEXTOPER(first);
+
+ /* Starting-point info. */
+ if (OP(first) == EXACTLY) {
+ r->regstart =
+ str_make(OPERAND(first)+1,*OPERAND(first));
+ if (r->regstart->str_cur > !(sawstudy|fold))
+ fbmcompile(r->regstart,fold);
+ }
+ else if ((exp = index(simple,OP(first))) && exp > simple)
+ r->regstclass = first;
+ else if (OP(first) == BOUND || OP(first) == NBOUND)
+ r->regstclass = first;
+ else if (OP(first) == BOL)
+ r->reganch++;
+
+#ifdef DEBUGGING
+ if (debug & 512)
+ fprintf(stderr,"first %d next %d offset %d\n",
+ OP(first), OP(NEXTOPER(first)), first - scan);
+#endif
+ /*
+ * If there's something expensive in the r.e., find the
+ * longest literal string that must appear and make it the
+ * regmust. Resolve ties in favor of later strings, since
+ * the regstart check works with the beginning of the r.e.
+ * and avoiding duplication strengthens checking. Not a
+ * strong reason, but sufficient in the absence of others.
+ * [Now we resolve ties in favor of the earlier string if
+ * it happens that curback has been invalidated, since the
+ * earlier string may buy us something the later one won't.]
+ */
+ longest = str_make("",0);
+ len = 0;
+ curback = 0;
+ back = 0;
+ while (scan != NULL) {
+ if (OP(scan) == BRANCH) {
+ if (OP(regnext(scan)) == BRANCH) {
+ curback = -30000;
+ while (OP(scan) == BRANCH)
+ scan = regnext(scan);
+ }
+ else /* single branch is ok */
+ scan = NEXTOPER(scan);
+ }
+ if (OP(scan) == EXACTLY) {
+ first = scan;
+ while (OP(regnext(scan)) >= CLOSE)
+ scan = regnext(scan);
+ if (curback - back == len) {
+ str_ncat(longest, OPERAND(first)+1,
+ *OPERAND(first));
+ len += *OPERAND(first);
+ curback += *OPERAND(first);
+ first = regnext(scan);
+ }
+ else if (*OPERAND(first) >= len + (curback >= 0)) {
+ len = *OPERAND(first);
+ str_nset(longest, OPERAND(first)+1,len);
+ back = curback;
+ curback += len;
+ first = regnext(scan);
+ }
+ else
+ curback += *OPERAND(first);
+ }
+ else if (index(varies,OP(scan)))
+ curback = -30000;
+ else if (index(simple,OP(scan)))
+ curback++;
+ scan = regnext(scan);
+ }
+ if (len) {
+ r->regmust = longest;
+ if (back < 0)
+ back = -1;
+ r->regback = back;
+ if (len > !(sawstudy||fold||OP(first)==EOL))
+ fbmcompile(r->regmust,fold);
+ r->regmust->str_u.str_useful = 100;
+ if (OP(first) == EOL) /* is match anchored to EOL? */
+ r->regmust->str_pok |= SP_TAIL;
+ }
+ else
+ str_free(longest);
+ }
+
+ r->do_folding = fold;
+ r->nparens = regnpar - 1;
+#ifdef DEBUGGING
+ if (debug & 512)
+ regdump(r);
+#endif
+ return(r);
+}
+
+/*
+ - reg - regular expression, i.e. main body or parenthesized thing
+ *
+ * Caller must absorb opening parenthesis.
+ *
+ * Combining parenthesis handling with the base level of regular expression
+ * is a trifle forced, but the need to tie the tails of the branches to what
+ * follows makes it hard to avoid.
+ */
+static char *
+reg(paren, flagp)
+int paren; /* Parenthesized? */
+int *flagp;
+{
+ register char *ret;
+ register char *br;
+ register char *ender;
+ register int parno;
+ int flags;
+
+ *flagp = HASWIDTH; /* Tentatively. */
+
+ /* Make an OPEN node, if parenthesized. */
+ if (paren) {
+ if (regnpar >= NSUBEXP)
+ FAIL("too many () in regexp");
+ parno = regnpar;
+ regnpar++;
+ ret = regnode(OPEN+parno);
+ } else
+ ret = NULL;
+
+ /* Pick up the branches, linking them together. */
+ br = regbranch(&flags);
+ if (br == NULL)
+ return(NULL);
+ if (ret != NULL)
+ regtail(ret, br); /* OPEN -> first. */
+ else
+ ret = br;
+ if (!(flags&HASWIDTH))
+ *flagp &= ~HASWIDTH;
+ *flagp |= flags&SPSTART;
+ while (*regparse == '|') {
+ regparse++;
+ br = regbranch(&flags);
+ if (br == NULL)
+ return(NULL);
+ regtail(ret, br); /* BRANCH -> BRANCH. */
+ if (!(flags&HASWIDTH))
+ *flagp &= ~HASWIDTH;
+ *flagp |= flags&SPSTART;
+ }
+
+ /* Make a closing node, and hook it on the end. */
+ ender = regnode((paren) ? CLOSE+parno : END);
+ regtail(ret, ender);
+
+ /* Hook the tails of the branches to the closing node. */
+ for (br = ret; br != NULL; br = regnext(br))
+ regoptail(br, ender);
+
+ /* Check for proper termination. */
+ if (paren && *regparse++ != ')') {
+ FAIL("unmatched () in regexp");
+ } else if (!paren && regparse < regxend) {
+ if (*regparse == ')') {
+ FAIL("unmatched () in regexp");
+ } else
+ FAIL("junk on end of regexp"); /* "Can't happen". */
+ /* NOTREACHED */
+ }
+
+ return(ret);
+}
+
+/*
+ - regbranch - one alternative of an | operator
+ *
+ * Implements the concatenation operator.
+ */
+static char *
+regbranch(flagp)
+int *flagp;
+{
+ register char *ret;
+ register char *chain;
+ register char *latest;
+ int flags;
+
+ *flagp = WORST; /* Tentatively. */
+
+ ret = regnode(BRANCH);
+ chain = NULL;
+ while (regparse < regxend && *regparse != '|' && *regparse != ')') {
+ latest = regpiece(&flags);
+ if (latest == NULL)
+ return(NULL);
+ *flagp |= flags&HASWIDTH;
+ if (chain == NULL) /* First piece. */
+ *flagp |= flags&SPSTART;
+ else
+ regtail(chain, latest);
+ chain = latest;
+ }
+ if (chain == NULL) /* Loop ran zero times. */
+ (void) regnode(NOTHING);
+
+ return(ret);
+}
+
+/*
+ - regpiece - something followed by possible [*+?]
+ *
+ * Note that the branching code sequences used for ? and the general cases
+ * of * and + are somewhat optimized: they use the same NOTHING node as
+ * both the endmarker for their branch list and the body of the last branch.
+ * It might seem that this node could be dispensed with entirely, but the
+ * endmarker role is not redundant.
+ */
+static char *
+regpiece(flagp)
+int *flagp;
+{
+ register char *ret;
+ register char op;
+ register char *next;
+ int flags;
+ char *origparse = regparse;
+ int orignpar = regnpar;
+ char *max;
+ int iter;
+ char ch;
+
+ ret = regatom(&flags);
+ if (ret == NULL)
+ return(NULL);
+
+ op = *regparse;
+
+ /* Here's a total kludge: if after the atom there's a {\d+,?\d*}
+ * then we decrement the first number by one and reset our
+ * parsing back to the beginning of the same atom. If the first number
+ * is down to 0, decrement the second number instead and fake up
+ * a ? after it. Given the way this compiler doesn't keep track
+ * of offsets on the first pass, this is the only way to replicate
+ * a piece of code. Sigh.
+ */
+ if (op == '{' && regcurly(regparse)) {
+ next = regparse + 1;
+ max = Nullch;
+ while (isdigit(*next) || *next == ',') {
+ if (*next == ',') {
+ if (max)
+ break;
+ else
+ max = next;
+ }
+ next++;
+ }
+ if (*next == '}') { /* got one */
+ regsawbracket++; /* remember we clobbered exp */
+ if (!max)
+ max = next;
+ regparse++;
+ iter = atoi(regparse);
+ if (iter > 0) {
+ ch = *max;
+ sprintf(regparse,"%.*d", max-regparse, iter - 1);
+ *max = ch;
+ if (*max == ',' && atoi(max+1) > 0) {
+ ch = *next;
+ sprintf(max+1,"%.*d", next-(max+1), atoi(max+1) - 1);
+ *next = ch;
+ }
+ if (iter != 1 || (*max == ',' || atoi(max+1))) {
+ regparse = origparse; /* back up input pointer */
+ regnpar = orignpar; /* don't make more parens */
+ }
+ else {
+ regparse = next;
+ goto nest_check;
+ }
+ *flagp = flags;
+ return ret;
+ }
+ if (*max == ',') {
+ max++;
+ iter = atoi(max);
+ if (max == next) { /* any number more? */
+ regparse = next;
+ op = '*'; /* fake up one with a star */
+ }
+ else if (iter > 0) {
+ op = '?'; /* fake up optional atom */
+ ch = *next;
+ sprintf(max,"%.*d", next-max, iter - 1);
+ *next = ch;
+ if (iter == 1)
+ regparse = next;
+ else {
+ regparse = origparse - 1; /* offset ++ below */
+ regnpar = orignpar;
+ }
+ }
+ else
+ fatal("Can't do {n,0}");
+ }
+ else
+ fatal("Can't do {0}");
+ }
+ }
+
+ if (!ISMULT1(op)) {
+ *flagp = flags;
+ return(ret);
+ }
+
+ if (!(flags&HASWIDTH) && op != '?')
+ FAIL("regexp *+ operand could be empty");
+ *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH);
+
+ if (op == '*' && (flags&SIMPLE))
+ reginsert(STAR, ret);
+ else if (op == '*') {
+ /* Emit x* as (x&|), where & means "self". */
+ reginsert(BRANCH, ret); /* Either x */
+ regoptail(ret, regnode(BACK)); /* and loop */
+ regoptail(ret, ret); /* back */
+ regtail(ret, regnode(BRANCH)); /* or */
+ regtail(ret, regnode(NOTHING)); /* null. */
+ } else if (op == '+' && (flags&SIMPLE))
+ reginsert(PLUS, ret);
+ else if (op == '+') {
+ /* Emit x+ as x(&|), where & means "self". */
+ next = regnode(BRANCH); /* Either */
+ regtail(ret, next);
+ regtail(regnode(BACK), ret); /* loop back */
+ regtail(next, regnode(BRANCH)); /* or */
+ regtail(ret, regnode(NOTHING)); /* null. */
+ } else if (op == '?') {
+ /* Emit x? as (x|) */
+ reginsert(BRANCH, ret); /* Either x */
+ regtail(ret, regnode(BRANCH)); /* or */
+ next = regnode(NOTHING); /* null. */
+ regtail(ret, next);
+ regoptail(ret, next);
+ }
+ nest_check:
+ regparse++;
+ if (ISMULT2(regparse))
+ FAIL("nested *?+ in regexp");
+
+ return(ret);
+}
+
+/*
+ - regatom - the lowest level
+ *
+ * Optimization: gobbles an entire sequence of ordinary characters so that
+ * it can turn them into a single node, which is smaller to store and
+ * faster to run. Backslashed characters are exceptions, each becoming a
+ * separate node; the code is simpler that way and it's not worth fixing.
+ *
+ * [Yes, it is worth fixing, some scripts can run twice the speed.]
+ */
+static char *
+regatom(flagp)
+int *flagp;
+{
+ register char *ret;
+ int flags;
+
+ *flagp = WORST; /* Tentatively. */
+
+ switch (*regparse++) {
+ case '^':
+ ret = regnode(BOL);
+ break;
+ case '$':
+ ret = regnode(EOL);
+ break;
+ case '.':
+ ret = regnode(ANY);
+ *flagp |= HASWIDTH|SIMPLE;
+ break;
+ case '[':
+ ret = regclass();
+ *flagp |= HASWIDTH|SIMPLE;
+ break;
+ case '(':
+ ret = reg(1, &flags);
+ if (ret == NULL)
+ return(NULL);
+ *flagp |= flags&(HASWIDTH|SPSTART);
+ break;
+ case '|':
+ case ')':
+ FAIL("internal urp in regexp"); /* Supposed to be caught earlier. */
+ break;
+ case '?':
+ case '+':
+ case '*':
+ FAIL("?+* follows nothing in regexp");
+ break;
+ case '\\':
+ switch (*regparse) {
+ case 'w':
+ ret = regnode(ALNUM);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'W':
+ ret = regnode(NALNUM);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'b':
+ ret = regnode(BOUND);
+ *flagp |= SIMPLE;
+ regparse++;
+ break;
+ case 'B':
+ ret = regnode(NBOUND);
+ *flagp |= SIMPLE;
+ regparse++;
+ break;
+ case 's':
+ ret = regnode(SPACE);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'S':
+ ret = regnode(NSPACE);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'd':
+ ret = regnode(DIGIT);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'D':
+ ret = regnode(NDIGIT);
+ *flagp |= HASWIDTH|SIMPLE;
+ regparse++;
+ break;
+ case 'n':
+ case 'r':
+ case 't':
+ case 'f':
+ goto defchar;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ if (isdigit(regparse[1]))
+ goto defchar;
+ else {
+ ret = regnode(REF + *regparse++ - '0');
+ *flagp |= SIMPLE;
+ }
+ break;
+ case '\0':
+ if (regparse >= regxend)
+ FAIL("trailing \\ in regexp");
+ /* FALL THROUGH */
+ default:
+ goto defchar;
+ }
+ break;
+ default: {
+ register int len;
+ register char ender;
+ register char *p;
+ char *oldp;
+ int foo;
+
+ defchar:
+ ret = regnode(EXACTLY);
+ regc(0); /* save spot for len */
+ for (len=0, p=regparse-1;
+ len < 127 && p < regxend;
+ len++)
+ {
+ oldp = p;
+ switch (*p) {
+ case '^':
+ case '$':
+ case '.':
+ case '[':
+ case '(':
+ case ')':
+ case '|':
+ goto loopdone;
+ case '\\':
+ switch (*++p) {
+ case 'w':
+ case 'W':
+ case 'b':
+ case 'B':
+ case 's':
+ case 'S':
+ case 'd':
+ case 'D':
+ --p;
+ goto loopdone;
+ case 'n':
+ ender = '\n';
+ p++;
+ break;
+ case 'r':
+ ender = '\r';
+ p++;
+ break;
+ case 't':
+ ender = '\t';
+ p++;
+ break;
+ case 'f':
+ ender = '\f';
+ p++;
+ break;
+ case '0': case '1': case '2': case '3':case '4':
+ case '5': case '6': case '7': case '8':case '9':
+ if (isdigit(p[1])) {
+ foo = *p++ - '0';
+ foo <<= 3;
+ foo += *p - '0';
+ if (isdigit(p[1]))
+ foo = (foo<<3) + *++p - '0';
+ ender = foo;
+ p++;
+ }
+ else {
+ --p;
+ goto loopdone;
+ }
+ break;
+ case '\0':
+ if (p >= regxend)
+ FAIL("trailing \\ in regexp");
+ /* FALL THROUGH */
+ default:
+ ender = *p++;
+ break;
+ }
+ break;
+ default:
+ ender = *p++;
+ break;
+ }
+ if (regfold && isupper(ender))
+ ender = tolower(ender);
+ if (ISMULT2(p)) { /* Back off on ?+*. */
+ if (len)
+ p = oldp;
+ else {
+ len++;
+ regc(ender);
+ }
+ break;
+ }
+ regc(ender);
+ }
+ loopdone:
+ regparse = p;
+ if (len <= 0)
+ FAIL("internal disaster in regexp");
+ *flagp |= HASWIDTH;
+ if (len == 1)
+ *flagp |= SIMPLE;
+ if (regcode != ®dummy)
+ *OPERAND(ret) = len;
+ regc('\0');
+ }
+ break;
+ }
+
+ return(ret);
+}
+
+static void
+regset(bits,def,c)
+char *bits;
+int def;
+register int c;
+{
+ if (regcode == ®dummy)
+ return;
+ if (def)
+ bits[c >> 3] &= ~(1 << (c & 7));
+ else
+ bits[c >> 3] |= (1 << (c & 7));
+}
+
+static char *
+regclass()
+{
+ register char *bits;
+ register int class;
+ register int lastclass;
+ register int range = 0;
+ register char *ret;
+ register int def;
+
+ if (*regparse == '^') { /* Complement of range. */
+ ret = regnode(ANYBUT);
+ regparse++;
+ def = 0;
+ } else {
+ ret = regnode(ANYOF);
+ def = 255;
+ }
+ bits = regcode;
+ for (class = 0; class < 32; class++)
+ regc(def);
+ if (*regparse == ']' || *regparse == '-')
+ regset(bits,def,lastclass = *regparse++);
+ while (regparse < regxend && *regparse != ']') {
+ class = UCHARAT(regparse++);
+ if (class == '\\') {
+ class = UCHARAT(regparse++);
+ switch (class) {
+ case 'w':
+ for (class = 'a'; class <= 'z'; class++)
+ regset(bits,def,class);
+ for (class = 'A'; class <= 'Z'; class++)
+ regset(bits,def,class);
+ for (class = '0'; class <= '9'; class++)
+ regset(bits,def,class);
+ regset(bits,def,'_');
+ lastclass = 1234;
+ continue;
+ case 's':
+ regset(bits,def,' ');
+ regset(bits,def,'\t');
+ regset(bits,def,'\r');
+ regset(bits,def,'\f');
+ regset(bits,def,'\n');
+ lastclass = 1234;
+ continue;
+ case 'd':
+ for (class = '0'; class <= '9'; class++)
+ regset(bits,def,class);
+ lastclass = 1234;
+ continue;
+ case 'n':
+ class = '\n';
+ break;
+ case 'r':
+ class = '\r';
+ break;
+ case 't':
+ class = '\t';
+ break;
+ case 'f':
+ class = '\f';
+ break;
+ case 'b':
+ class = '\b';
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ class -= '0';
+ if (isdigit(*regparse)) {
+ class <<= 3;
+ class += *regparse++ - '0';
+ }
+ if (isdigit(*regparse)) {
+ class <<= 3;
+ class += *regparse++ - '0';
+ }
+ break;
+ }
+ }
+ if (!range && class == '-' && regparse < regxend &&
+ *regparse != ']') {
+ range = 1;
+ continue;
+ }
+ if (range) {
+ if (lastclass > class)
+ FAIL("invalid [] range in regexp");
+ }
+ else
+ lastclass = class - 1;
+ range = 0;
+ for (lastclass++; lastclass <= class; lastclass++) {
+ regset(bits,def,lastclass);
+ if (regfold && isupper(lastclass))
+ regset(bits,def,tolower(lastclass));
+ }
+ lastclass = class;
+ }
+ if (*regparse != ']')
+ FAIL("unmatched [] in regexp");
+ regset(bits,0,0); /* always bomb out on null */
+ regparse++;
+ return ret;
+}
+
+/*
+ - regnode - emit a node
+ */
+static char * /* Location. */
+regnode(op)
+char op;
+{
+ register char *ret;
+ register char *ptr;
+
+ ret = regcode;
+ if (ret == ®dummy) {
+#ifdef REGALIGN
+ if (!(regsize & 1))
+ regsize++;
+#endif
+ regsize += 3;
+ return(ret);
+ }
+
+#ifdef REGALIGN
+#ifndef lint
+ if (!((long)ret & 1))
+ *ret++ = 127;
+#endif
+#endif
+ ptr = ret;
+ *ptr++ = op;
+ *ptr++ = '\0'; /* Null "next" pointer. */
+ *ptr++ = '\0';
+ regcode = ptr;
+
+ return(ret);
+}
+
+/*
+ - regc - emit (if appropriate) a byte of code
+ */
+static void
+regc(b)
+char b;
+{
+ if (regcode != ®dummy)
+ *regcode++ = b;
+ else
+ regsize++;
+}
+
+/*
+ - reginsert - insert an operator in front of already-emitted operand
+ *
+ * Means relocating the operand.
+ */
+static void
+reginsert(op, opnd)
+char op;
+char *opnd;
+{
+ register char *src;
+ register char *dst;
+ register char *place;
+
+ if (regcode == ®dummy) {
+#ifdef REGALIGN
+ regsize += 4;
+#else
+ regsize += 3;
+#endif
+ return;
+ }
+
+ src = regcode;
+#ifdef REGALIGN
+ regcode += 4;
+#else
+ regcode += 3;
+#endif
+ dst = regcode;
+ while (src > opnd)
+ *--dst = *--src;
+
+ place = opnd; /* Op node, where operand used to be. */
+ *place++ = op;
+ *place++ = '\0';
+ *place++ = '\0';
+}
+
+/*
+ - regtail - set the next-pointer at the end of a node chain
+ */
+static void
+regtail(p, val)
+char *p;
+char *val;
+{
+ register char *scan;
+ register char *temp;
+ register int offset;
+
+ if (p == ®dummy)
+ return;
+
+ /* Find last node. */
+ scan = p;
+ for (;;) {
+ temp = regnext(scan);
+ if (temp == NULL)
+ break;
+ scan = temp;
+ }
+
+#ifdef REGALIGN
+ offset = val - scan;
+#ifndef lint
+ *(short*)(scan+1) = offset;
+#else
+ offset = offset;
+#endif
+#else
+ if (OP(scan) == BACK)
+ offset = scan - val;
+ else
+ offset = val - scan;
+ *(scan+1) = (offset>>8)&0377;
+ *(scan+2) = offset&0377;
+#endif
+}
+
+/*
+ - regoptail - regtail on operand of first argument; nop if operandless
+ */
+static void
+regoptail(p, val)
+char *p;
+char *val;
+{
+ /* "Operandless" and "op != BRANCH" are synonymous in practice. */
+ if (p == NULL || p == ®dummy || OP(p) != BRANCH)
+ return;
+ regtail(NEXTOPER(p), val);
+}
+
+/*
+ - regcurly - a little FSA that accepts {\d+,?\d*}
+ */
+STATIC int
+regcurly(s)
+register char *s;
+{
+ if (*s++ != '{')
+ return FALSE;
+ if (!isdigit(*s))
+ return FALSE;
+ while (isdigit(*s))
+ s++;
+ if (*s == ',')
+ s++;
+ while (isdigit(*s))
+ s++;
+ if (*s != '}')
+ return FALSE;
+ return TRUE;
+}
+
+#ifdef DEBUGGING
+
+/*
+ - regdump - dump a regexp onto stderr in vaguely comprehensible form
+ */
+void
+regdump(r)
+regexp *r;
+{
+ register char *s;
+ register char op = EXACTLY; /* Arbitrary non-END op. */
+ register char *next;
+ extern char *index();
+
+
+ s = r->program + 1;
+ while (op != END) { /* While that wasn't END last time... */
+#ifdef REGALIGN
+ if (!((long)s & 1))
+ s++;
+#endif
+ op = OP(s);
+ fprintf(stderr,"%2d%s", s-r->program, regprop(s)); /* Where, what. */
+ next = regnext(s);
+ if (next == NULL) /* Next ptr. */
+ fprintf(stderr,"(0)");
+ else
+ fprintf(stderr,"(%d)", (s-r->program)+(next-s));
+ s += 3;
+ if (op == ANYOF || op == ANYBUT) {
+ s += 32;
+ }
+ if (op == EXACTLY) {
+ /* Literal string, where present. */
+ s++;
+ while (*s != '\0') {
+ (void)putchar(*s);
+ s++;
+ }
+ s++;
+ }
+ (void)putchar('\n');
+ }
+
+ /* Header fields of interest. */
+ if (r->regstart)
+ fprintf(stderr,"start `%s' ", r->regstart->str_ptr);
+ if (r->regstclass)
+ fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
+ if (r->reganch)
+ fprintf(stderr,"anchored ");
+ if (r->regmust != NULL)
+ fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
+ r->regback);
+ fprintf(stderr,"\n");
+}
+
+/*
+ - regprop - printable representation of opcode
+ */
+char *
+regprop(op)
+char *op;
+{
+ register char *p;
+
+ (void) strcpy(buf, ":");
+
+ switch (OP(op)) {
+ case BOL:
+ p = "BOL";
+ break;
+ case EOL:
+ p = "EOL";
+ break;
+ case ANY:
+ p = "ANY";
+ break;
+ case ANYOF:
+ p = "ANYOF";
+ break;
+ case ANYBUT:
+ p = "ANYBUT";
+ break;
+ case BRANCH:
+ p = "BRANCH";
+ break;
+ case EXACTLY:
+ p = "EXACTLY";
+ break;
+ case NOTHING:
+ p = "NOTHING";
+ break;
+ case BACK:
+ p = "BACK";
+ break;
+ case END:
+ p = "END";
+ break;
+ case ALNUM:
+ p = "ALNUM";
+ break;
+ case NALNUM:
+ p = "NALNUM";
+ break;
+ case BOUND:
+ p = "BOUND";
+ break;
+ case NBOUND:
+ p = "NBOUND";
+ break;
+ case SPACE:
+ p = "SPACE";
+ break;
+ case NSPACE:
+ p = "NSPACE";
+ break;
+ case DIGIT:
+ p = "DIGIT";
+ break;
+ case NDIGIT:
+ p = "NDIGIT";
+ break;
+ case REF:
+ case REF+1:
+ case REF+2:
+ case REF+3:
+ case REF+4:
+ case REF+5:
+ case REF+6:
+ case REF+7:
+ case REF+8:
+ case REF+9:
+ (void)sprintf(buf+strlen(buf), "REF%d", OP(op)-REF);
+ p = NULL;
+ break;
+ case OPEN+1:
+ case OPEN+2:
+ case OPEN+3:
+ case OPEN+4:
+ case OPEN+5:
+ case OPEN+6:
+ case OPEN+7:
+ case OPEN+8:
+ case OPEN+9:
+ (void)sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
+ p = NULL;
+ break;
+ case CLOSE+1:
+ case CLOSE+2:
+ case CLOSE+3:
+ case CLOSE+4:
+ case CLOSE+5:
+ case CLOSE+6:
+ case CLOSE+7:
+ case CLOSE+8:
+ case CLOSE+9:
+ (void)sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
+ p = NULL;
+ break;
+ case STAR:
+ p = "STAR";
+ break;
+ case PLUS:
+ p = "PLUS";
+ break;
+ default:
+ FAIL("corrupted regexp opcode");
+ }
+ if (p != NULL)
+ (void) strcat(buf, p);
+ return(buf);
+}
+#endif /* DEBUGGING */
+
+regfree(r)
+struct regexp *r;
+{
+ if (r->precomp)
+ Safefree(r->precomp);
+ if (r->subbase)
+ Safefree(r->subbase);
+ if (r->regmust)
+ str_free(r->regmust);
+ if (r->regstart)
+ str_free(r->regstart);
+ Safefree(r);
+}
--- /dev/null
+/* $Header: regcomp.h,v 3.0 89/10/18 15:22:39 lwall Locked $
+ *
+ * $Log: regcomp.h,v $
+ * Revision 3.0 89/10/18 15:22:39 lwall
+ * 3.0 baseline
+ *
+ */
+
+/*
+ * The "internal use only" fields in regexp.h are present to pass info from
+ * compile to execute that permits the execute phase to run lots faster on
+ * simple cases. They are:
+ *
+ * regstart str that must begin a match; Nullch if none obvious
+ * reganch is the match anchored (at beginning-of-line only)?
+ * regmust string (pointer into program) that match must include, or NULL
+ * [regmust changed to STR* for bminstr()--law]
+ * regmlen length of regmust string
+ * [regmlen not used currently]
+ *
+ * Regstart and reganch permit very fast decisions on suitable starting points
+ * for a match, cutting down the work a lot. Regmust permits fast rejection
+ * of lines that cannot possibly match. The regmust tests are costly enough
+ * that regcomp() supplies a regmust only if the r.e. contains something
+ * potentially expensive (at present, the only such thing detected is * or +
+ * at the start of the r.e., which can involve a lot of backup). Regmlen is
+ * supplied because the test in regexec() needs it and regcomp() is computing
+ * it anyway.
+ * [regmust is now supplied always. The tests that use regmust have a
+ * heuristic that disables the test if it usually matches.]
+ *
+ * [In fact, we now use regmust in many cases to locate where the search
+ * starts in the string, so if regback is >= 0, the regmust search is never
+ * wasted effort. The regback variable says how many characters back from
+ * where regmust matched is the earliest possible start of the match.
+ * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.]
+ */
+
+/*
+ * Structure for regexp "program". This is essentially a linear encoding
+ * of a nondeterministic finite-state machine (aka syntax charts or
+ * "railroad normal form" in parsing technology). Each node is an opcode
+ * plus a "next" pointer, possibly plus an operand. "Next" pointers of
+ * all nodes except BRANCH implement concatenation; a "next" pointer with
+ * a BRANCH on both ends of it is connecting two alternatives. (Here we
+ * have one of the subtle syntax dependencies: an individual BRANCH (as
+ * opposed to a collection of them) is never concatenated with anything
+ * because of operator precedence.) The operand of some types of node is
+ * a literal string; for others, it is a node leading into a sub-FSM. In
+ * particular, the operand of a BRANCH node is the first node of the branch.
+ * (NB this is *not* a tree structure: the tail of the branch connects
+ * to the thing following the set of BRANCHes.) The opcodes are:
+ */
+
+/* definition number opnd? meaning */
+#define END 0 /* no End of program. */
+#define BOL 1 /* no Match "" at beginning of line. */
+#define EOL 2 /* no Match "" at end of line. */
+#define ANY 3 /* no Match any one character. */
+#define ANYOF 4 /* str Match any character in this string. */
+#define ANYBUT 5 /* str Match any character not in this string. */
+#define BRANCH 6 /* node Match this alternative, or the next... */
+#define BACK 7 /* no Match "", "next" ptr points backward. */
+#define EXACTLY 8 /* str Match this string (preceded by length). */
+#define NOTHING 9 /* no Match empty string. */
+#define STAR 10 /* node Match this (simple) thing 0 or more times. */
+#define PLUS 11 /* node Match this (simple) thing 1 or more times. */
+#define ALNUM 12 /* no Match any alphanumeric character */
+#define NALNUM 13 /* no Match any non-alphanumeric character */
+#define BOUND 14 /* no Match "" at any word boundary */
+#define NBOUND 15 /* no Match "" at any word non-boundary */
+#define SPACE 16 /* no Match any whitespace character */
+#define NSPACE 17 /* no Match any non-whitespace character */
+#define DIGIT 18 /* no Match any numeric character */
+#define NDIGIT 19 /* no Match any non-numeric character */
+#define REF 20 /* no Match some already matched string */
+#define OPEN 30 /* no Mark this point in input as start of #n. */
+ /* OPEN+1 is number 1, etc. */
+#define CLOSE 40 /* no Analogous to OPEN. */
+/* CLOSE must be last one! see regmust finder */
+
+/*
+ * Opcode notes:
+ *
+ * BRANCH The set of branches constituting a single choice are hooked
+ * together with their "next" pointers, since precedence prevents
+ * anything being concatenated to any individual branch. The
+ * "next" pointer of the last BRANCH in a choice points to the
+ * thing following the whole choice. This is also where the
+ * final "next" pointer of each individual branch points; each
+ * branch starts with the operand node of a BRANCH node.
+ *
+ * BACK Normal "next" pointers all implicitly point forward; BACK
+ * exists to make loop structures possible.
+ *
+ * STAR,PLUS '?', and complex '*' and '+', are implemented as circular
+ * BRANCH structures using BACK. Simple cases (one character
+ * per match) are implemented with STAR and PLUS for speed
+ * and to minimize recursive plunges.
+ *
+ * OPEN,CLOSE ...are numbered at compile time.
+ */
+
+/* The following have no fixed length. */
+#ifndef DOINIT
+extern char varies[];
+#else
+char varies[] = {BRANCH,BACK,STAR,PLUS,
+ REF+1,REF+2,REF+3,REF+4,REF+5,REF+6,REF+7,REF+8,REF+9,0};
+#endif
+
+/* The following always have a length of 1. */
+#ifndef DOINIT
+extern char simple[];
+#else
+char simple[] = {ANY,ANYOF,ANYBUT,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0};
+#endif
+
+EXT char regdummy;
+
+/*
+ * A node is one char of opcode followed by two chars of "next" pointer.
+ * "Next" pointers are stored as two 8-bit pieces, high order first. The
+ * value is a positive offset from the opcode of the node containing it.
+ * An operand, if any, simply follows the node. (Note that much of the
+ * code generation knows about this implicit relationship.)
+ *
+ * Using two bytes for the "next" pointer is vast overkill for most things,
+ * but allows patterns to get big without disasters.
+ *
+ * [If REGALIGN is defined, the "next" pointer is always aligned on an even
+ * boundary, and reads the offset directly as a short. Also, there is no
+ * special test to reverse the sign of BACK pointers since the offset is
+ * stored negative.]
+ */
+
+#ifndef gould
+#ifndef cray
+#define REGALIGN
+#endif
+#endif
+
+#define OP(p) (*(p))
+
+#ifndef lint
+#ifdef REGALIGN
+#define NEXT(p) (*(short*)(p+1))
+#else
+#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377))
+#endif
+#else /* lint */
+#define NEXT(p) 0
+#endif /* lint */
+
+#define OPERAND(p) ((p) + 3)
+
+#ifdef REGALIGN
+#define NEXTOPER(p) ((p) + 4)
+#else
+#define NEXTOPER(p) ((p) + 3)
+#endif
+
+#define MAGIC 0234
+
+/*
+ * Utility definitions.
+ */
+#ifndef lint
+#ifndef CHARBITS
+#define UCHARAT(p) ((int)*(unsigned char *)(p))
+#else
+#define UCHARAT(p) ((int)*(p)&CHARBITS)
+#endif
+#else /* lint */
+#define UCHARAT(p) regdummy
+#endif /* lint */
+
+#define FAIL(m) fatal("/%s/: %s",regprecomp,m)
+
+char *regnext();
+#ifdef DEBUGGING
+void regdump();
+char *regprop();
+#endif
+
--- /dev/null
+/* NOTE: this is derived from Henry Spencer's regexp code, and should not
+ * confused with the original package (see point 3 below). Thanks, Henry!
+ */
+
+/* Additional note: this code is very heavily munged from Henry's version
+ * in places. In some spots I've traded clarity for efficiency, so don't
+ * blame Henry for some of the lack of readability.
+ */
+
+/* $Header: regexec.c,v 3.0 89/10/18 15:22:53 lwall Locked $
+ *
+ * $Log: regexec.c,v $
+ * Revision 3.0 89/10/18 15:22:53 lwall
+ * 3.0 baseline
+ *
+ */
+
+/*
+ * regcomp and regexec -- regsub and regerror are not used in perl
+ *
+ * Copyright (c) 1986 by University of Toronto.
+ * Written by Henry Spencer. Not derived from licensed software.
+ *
+ * Permission is granted to anyone to use this software for any
+ * purpose on any computer system, and to redistribute it freely,
+ * subject to the following restrictions:
+ *
+ * 1. The author is not responsible for the consequences of use of
+ * this software, no matter how awful, even if they arise
+ * from defects in it.
+ *
+ * 2. The origin of this software must not be misrepresented, either
+ * by explicit claim or by omission.
+ *
+ * 3. Altered versions must be plainly marked as such, and must not
+ * be misrepresented as being the original software.
+ *
+ **** Alterations to Henry's code are...
+ ****
+ **** 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.
+ *
+ * Beware that some of this code is subtly aware of the way operator
+ * precedence is structured in regular expressions. Serious changes in
+ * regular-expression syntax might require a total rethink.
+ */
+#include "EXTERN.h"
+#include "perl.h"
+#include "regcomp.h"
+
+#ifndef STATIC
+#define STATIC static
+#endif
+
+#ifdef DEBUGGING
+int regnarrate = 0;
+#endif
+
+/*
+ * regexec and friends
+ */
+
+/*
+ * Global work variables for regexec().
+ */
+static char *regprecomp;
+static char *reginput; /* String-input pointer. */
+static char *regbol; /* Beginning of input, for ^ check. */
+static char *regeol; /* End of input, for $ check. */
+static char **regstartp; /* Pointer to startp array. */
+static char **regendp; /* Ditto for endp. */
+static char *reglastparen; /* Similarly for lastparen. */
+static char *regtill;
+
+static char *regmystartp[10]; /* For remembering backreferences. */
+static char *regmyendp[10];
+
+/*
+ * Forwards.
+ */
+STATIC int regtry();
+STATIC int regmatch();
+STATIC int regrepeat();
+
+extern int multiline;
+
+/*
+ - regexec - match a regexp against a string
+ */
+int
+regexec(prog, stringarg, strend, strbeg, minend, screamer, safebase)
+register regexp *prog;
+char *stringarg;
+register char *strend; /* pointer to null at end of string */
+char *strbeg; /* real beginning of string */
+int minend; /* end of match must be at least minend after stringarg */
+STR *screamer;
+int safebase; /* no need to remember string in subbase */
+{
+ register char *s;
+ register int i;
+ register char *c;
+ register char *string = stringarg;
+ register int tmp;
+ int minlen = 0; /* must match at least this many chars */
+ int dontbother = 0; /* how many characters not to try at end */
+ int beginning = (string == strbeg); /* is ^ valid at stringarg? */
+
+ /* Be paranoid... */
+ if (prog == NULL || string == NULL) {
+ fatal("NULL regexp parameter");
+ return(0);
+ }
+
+ regprecomp = prog->precomp;
+ /* Check validity of program. */
+ if (UCHARAT(prog->program) != MAGIC) {
+ FAIL("corrupted regexp program");
+ }
+
+ if (prog->do_folding) {
+ safebase = FALSE;
+ i = strend - string;
+ New(1101,c,i+1,char);
+ (void)bcopy(string, c, i+1);
+ string = c;
+ strend = string + i;
+ for (s = string; s < strend; s++)
+ if (isupper(*s))
+ *s = tolower(*s);
+ }
+
+ /* If there is a "must appear" string, look for it. */
+ s = string;
+ if (prog->regmust != Nullstr) {
+ if (beginning && screamer) {
+ if (screamfirst[prog->regmust->str_rare] >= 0)
+ s = screaminstr(screamer,prog->regmust);
+ else
+ s = Nullch;
+ }
+#ifndef lint
+ else
+ s = fbminstr((unsigned char*)s, (unsigned char*)strend,
+ prog->regmust);
+#endif
+ if (!s) {
+ ++prog->regmust->str_u.str_useful; /* hooray */
+ goto phooey; /* not present */
+ }
+ else if (prog->regback >= 0) {
+ s -= prog->regback;
+ if (s < string)
+ s = string;
+ minlen = prog->regback + prog->regmust->str_cur;
+ }
+ else if (--prog->regmust->str_u.str_useful < 0) { /* boo */
+ str_free(prog->regmust);
+ prog->regmust = Nullstr; /* disable regmust */
+ s = string;
+ }
+ else {
+ s = string;
+ minlen = prog->regmust->str_cur;
+ }
+ }
+
+ /* Mark beginning of line for ^ . */
+ if (beginning)
+ regbol = string;
+ else
+ regbol = NULL;
+
+ /* Mark end of line for $ (and such) */
+ regeol = strend;
+
+ /* see how far we have to get to not match where we matched before */
+ regtill = string+minend;
+
+ /* Simplest case: anchored match need be tried only once. */
+ /* [unless multiline is set] */
+ if (prog->reganch) {
+ if (regtry(prog, string))
+ goto got_it;
+ else if (multiline) {
+ if (minlen)
+ dontbother = minlen - 1;
+ strend -= dontbother;
+ /* for multiline we only have to try after newlines */
+ if (s > string)
+ s--;
+ for (; s < strend; s++) {
+ if (*s == '\n') {
+ if (++s < strend && regtry(prog, s))
+ goto got_it;
+ }
+ }
+ }
+ goto phooey;
+ }
+
+ /* Messy cases: unanchored match. */
+ if (prog->regstart) {
+ /* We know what string it must start with. */
+ if (prog->regstart->str_pok == 3) {
+#ifndef lint
+ while ((s = fbminstr((unsigned char*)s,
+ (unsigned char*)strend, prog->regstart)) != NULL)
+#else
+ while (s = Nullch)
+#endif
+ {
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ }
+ else {
+ c = prog->regstart->str_ptr;
+ while ((s = ninstr(s, strend,
+ c, c + prog->regstart->str_cur )) != NULL) {
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ }
+ goto phooey;
+ }
+ if (c = prog->regstclass) {
+ if (minlen)
+ dontbother = minlen - 1;
+ strend -= dontbother; /* don't bother with what can't match */
+ /* We know what class it must start with. */
+ switch (OP(c)) {
+ case ANYOF: case ANYBUT:
+ c = OPERAND(c);
+ while (s < strend) {
+ i = *s;
+ if (!(c[i >> 3] & (1 << (i&7))))
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ break;
+ case BOUND:
+ if (minlen)
+ dontbother++,strend--;
+ if (s != string) {
+ i = s[-1];
+ tmp = (isalpha(i) || isdigit(i) || i == '_');
+ }
+ else
+ tmp = 0; /* assume not alphanumeric */
+ while (s < strend) {
+ i = *s;
+ if (tmp != (isalpha(i) || isdigit(i) || i == '_')) {
+ tmp = !tmp;
+ if (regtry(prog, s))
+ goto got_it;
+ }
+ s++;
+ }
+ if (tmp && regtry(prog,s))
+ goto got_it;
+ break;
+ case NBOUND:
+ if (minlen)
+ dontbother++,strend--;
+ if (s != string) {
+ i = s[-1];
+ tmp = (isalpha(i) || isdigit(i) || i == '_');
+ }
+ else
+ tmp = 0; /* assume not alphanumeric */
+ while (s < strend) {
+ i = *s;
+ if (tmp != (isalpha(i) || isdigit(i) || i == '_'))
+ tmp = !tmp;
+ else if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ if (!tmp && regtry(prog,s))
+ goto got_it;
+ break;
+ case ALNUM:
+ while (s < strend) {
+ i = *s;
+ if (isalpha(i) || isdigit(i) || i == '_')
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ break;
+ case NALNUM:
+ while (s < strend) {
+ i = *s;
+ if (!isalpha(i) && !isdigit(i) && i != '_')
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ break;
+ case SPACE:
+ while (s < strend) {
+ if (isspace(*s))
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ break;
+ case NSPACE:
+ while (s < strend) {
+ if (!isspace(*s))
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ break;
+ case DIGIT:
+ while (s < strend) {
+ if (isdigit(*s))
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ break;
+ case NDIGIT:
+ while (s < strend) {
+ if (!isdigit(*s))
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ break;
+ }
+ }
+ else {
+ dontbother = minend;
+ strend -= dontbother;
+ /* We don't know much -- general case. */
+ do {
+ if (regtry(prog, s))
+ goto got_it;
+ } while (s++ < strend);
+ }
+
+ /* Failure. */
+ goto phooey;
+
+ got_it:
+ if ((!safebase && (prog->nparens || sawampersand)) || prog->do_folding){
+ strend += dontbother; /* uncheat */
+ if (safebase) /* no need for $digit later */
+ s = strbeg;
+ else if (strbeg != prog->subbase) {
+ i = strend - string + (stringarg - strbeg);
+ s = nsavestr(strbeg,i); /* so $digit will work later */
+ if (prog->subbase)
+ Safefree(prog->subbase);
+ prog->subbase = s;
+ }
+ else
+ s = prog->subbase;
+ s += (stringarg - strbeg);
+ for (i = 0; i <= prog->nparens; i++) {
+ if (prog->endp[i]) {
+ prog->startp[i] = s + (prog->startp[i] - string);
+ prog->endp[i] = s + (prog->endp[i] - string);
+ }
+ }
+ if (prog->do_folding)
+ Safefree(string);
+ }
+ return(1);
+
+ phooey:
+ if (prog->do_folding)
+ Safefree(string);
+ return(0);
+}
+
+/*
+ - regtry - try match at specific point
+ */
+static int /* 0 failure, 1 success */
+regtry(prog, string)
+regexp *prog;
+char *string;
+{
+ register int i;
+ register char **sp;
+ register char **ep;
+
+ reginput = string;
+ regstartp = prog->startp;
+ regendp = prog->endp;
+ reglastparen = &prog->lastparen;
+ prog->lastparen = 0;
+
+ sp = prog->startp;
+ ep = prog->endp;
+ if (prog->nparens) {
+ for (i = NSUBEXP; i > 0; i--) {
+ *sp++ = NULL;
+ *ep++ = NULL;
+ }
+ }
+ if (regmatch(prog->program + 1) && reginput >= regtill) {
+ prog->startp[0] = string;
+ prog->endp[0] = reginput;
+ return(1);
+ } else
+ return(0);
+}
+
+/*
+ - regmatch - main matching routine
+ *
+ * Conceptually the strategy is simple: check to see whether the current
+ * node matches, call self recursively to see whether the rest matches,
+ * and then act accordingly. In practice we make some effort to avoid
+ * recursion, in particular by going through "ordinary" nodes (that don't
+ * need to know whether the rest of the match failed) by a loop instead of
+ * by recursion.
+ */
+/* [lwall] I've hoisted the register declarations to the outer block in order to
+ * maybe save a little bit of pushing and popping on the stack. It also takes
+ * advantage of machines that use a register save mask on subroutine entry.
+ */
+static int /* 0 failure, 1 success */
+regmatch(prog)
+char *prog;
+{
+ register char *scan; /* Current node. */
+ char *next; /* Next node. */
+ register int nextchar;
+ register int n; /* no or next */
+ register int ln; /* len or last */
+ register char *s; /* operand or save */
+ register char *locinput = reginput;
+
+ nextchar = *locinput;
+ scan = prog;
+#ifdef DEBUGGING
+ if (scan != NULL && regnarrate)
+ fprintf(stderr, "%s(\n", regprop(scan));
+#endif
+ while (scan != NULL) {
+#ifdef DEBUGGING
+ if (regnarrate)
+ fprintf(stderr, "%s...\n", regprop(scan));
+#endif
+
+#ifdef REGALIGN
+ next = scan + NEXT(scan);
+ if (next == scan)
+ next = NULL;
+#else
+ next = regnext(scan);
+#endif
+
+ switch (OP(scan)) {
+ case BOL:
+ if (locinput == regbol ||
+ ((nextchar || locinput < regeol) &&
+ locinput[-1] == '\n') )
+ {
+ regtill--;
+ break;
+ }
+ return(0);
+ case EOL:
+ if ((nextchar || locinput < regeol) && nextchar != '\n')
+ return(0);
+ regtill--;
+ break;
+ case ANY:
+ if ((nextchar == '\0' && locinput >= regeol) ||
+ nextchar == '\n')
+ return(0);
+ nextchar = *++locinput;
+ break;
+ case EXACTLY:
+ s = OPERAND(scan);
+ ln = *s++;
+ /* Inline the first character, for speed. */
+ if (*s != nextchar)
+ return(0);
+ if (locinput + ln > regeol)
+ return 0;
+ if (ln > 1 && bcmp(s, locinput, ln) != 0)
+ return(0);
+ locinput += ln;
+ nextchar = *locinput;
+ break;
+ case ANYOF:
+ case ANYBUT:
+ s = OPERAND(scan);
+ if (nextchar < 0)
+ nextchar = UCHARAT(locinput);
+ if (s[nextchar >> 3] & (1 << (nextchar&7)))
+ return(0);
+ nextchar = *++locinput;
+ if (!nextchar && locinput > regeol)
+ return 0;
+ break;
+ case ALNUM:
+ if (!nextchar)
+ return(0);
+ if (!isalpha(nextchar) && !isdigit(nextchar) &&
+ nextchar != '_')
+ return(0);
+ nextchar = *++locinput;
+ break;
+ case NALNUM:
+ if (!nextchar && locinput >= regeol)
+ return(0);
+ if (isalpha(nextchar) || isdigit(nextchar) ||
+ nextchar == '_')
+ return(0);
+ nextchar = *++locinput;
+ break;
+ case NBOUND:
+ case BOUND:
+ if (locinput == regbol) /* was last char in word? */
+ ln = 0;
+ else
+ ln = (isalpha(locinput[-1]) ||
+ isdigit(locinput[-1]) ||
+ locinput[-1] == '_' );
+ n = (isalpha(nextchar) || isdigit(nextchar) ||
+ nextchar == '_' ); /* is next char in word? */
+ if ((ln == n) == (OP(scan) == BOUND))
+ return(0);
+ break;
+ case SPACE:
+ if (!nextchar && locinput >= regeol)
+ return(0);
+ if (!isspace(nextchar))
+ return(0);
+ nextchar = *++locinput;
+ break;
+ case NSPACE:
+ if (!nextchar)
+ return(0);
+ if (isspace(nextchar))
+ return(0);
+ nextchar = *++locinput;
+ break;
+ case DIGIT:
+ if (!isdigit(nextchar))
+ return(0);
+ nextchar = *++locinput;
+ break;
+ case NDIGIT:
+ if (!nextchar && locinput >= regeol)
+ return(0);
+ if (isdigit(nextchar))
+ return(0);
+ nextchar = *++locinput;
+ break;
+ case REF:
+ case REF+1:
+ case REF+2:
+ case REF+3:
+ case REF+4:
+ case REF+5:
+ case REF+6:
+ case REF+7:
+ case REF+8:
+ case REF+9:
+ n = OP(scan) - REF;
+ s = regmystartp[n];
+ if (!s)
+ return(0);
+ if (!regmyendp[n])
+ return(0);
+ if (s == regmyendp[n])
+ break;
+ /* Inline the first character, for speed. */
+ if (*s != nextchar)
+ return(0);
+ ln = regmyendp[n] - s;
+ if (locinput + ln > regeol)
+ return 0;
+ if (ln > 1 && bcmp(s, locinput, ln) != 0)
+ return(0);
+ locinput += ln;
+ nextchar = *locinput;
+ break;
+
+ case NOTHING:
+ break;
+ case BACK:
+ break;
+ case OPEN+1:
+ case OPEN+2:
+ case OPEN+3:
+ case OPEN+4:
+ case OPEN+5:
+ case OPEN+6:
+ case OPEN+7:
+ case OPEN+8:
+ case OPEN+9:
+ n = OP(scan) - OPEN;
+ reginput = locinput;
+
+ regmystartp[n] = locinput; /* for REF */
+ if (regmatch(next)) {
+ /*
+ * Don't set startp if some later
+ * invocation of the same parentheses
+ * already has.
+ */
+ if (regstartp[n] == NULL)
+ regstartp[n] = locinput;
+ return(1);
+ } else
+ return(0);
+ /* NOTREACHED */
+ case CLOSE+1:
+ case CLOSE+2:
+ case CLOSE+3:
+ case CLOSE+4:
+ case CLOSE+5:
+ case CLOSE+6:
+ case CLOSE+7:
+ case CLOSE+8:
+ case CLOSE+9: {
+ n = OP(scan) - CLOSE;
+ reginput = locinput;
+
+ regmyendp[n] = locinput; /* for REF */
+ if (regmatch(next)) {
+ /*
+ * Don't set endp if some later
+ * invocation of the same parentheses
+ * already has.
+ */
+ if (regendp[n] == NULL) {
+ regendp[n] = locinput;
+ if (n > *reglastparen)
+ *reglastparen = n;
+ }
+ return(1);
+ } else
+ return(0);
+ }
+ /*NOTREACHED*/
+ case BRANCH: {
+ if (OP(next) != BRANCH) /* No choice. */
+ next = NEXTOPER(scan); /* Avoid recursion. */
+ else {
+ do {
+ reginput = locinput;
+ if (regmatch(NEXTOPER(scan)))
+ return(1);
+#ifdef REGALIGN
+ if (n = NEXT(scan))
+ scan += n;
+ else
+ scan = NULL;
+#else
+ scan = regnext(scan);
+#endif
+ } while (scan != NULL && OP(scan) == BRANCH);
+ return(0);
+ /* NOTREACHED */
+ }
+ }
+ break;
+ case STAR:
+ case PLUS:
+ /*
+ * Lookahead to avoid useless match attempts
+ * when we know what character comes next.
+ */
+ if (OP(next) == EXACTLY)
+ nextchar = *(OPERAND(next)+1);
+ else
+ nextchar = -1000;
+ ln = (OP(scan) == STAR) ? 0 : 1;
+ reginput = locinput;
+ n = regrepeat(NEXTOPER(scan));
+ while (n >= ln) {
+ /* If it could work, try it. */
+ if (nextchar == -1000 || *reginput == nextchar)
+ if (regmatch(next))
+ return(1);
+ /* Couldn't or didn't -- back up. */
+ n--;
+ reginput = locinput + n;
+ }
+ return(0);
+ case END:
+ reginput = locinput; /* put where regtry can find it */
+ return(1); /* Success! */
+ default:
+ printf("%x %d\n",scan,scan[1]);
+ FAIL("regexp memory corruption");
+ }
+
+ scan = next;
+ }
+
+ /*
+ * We get here only if there's trouble -- normally "case END" is
+ * the terminating point.
+ */
+ FAIL("corrupted regexp pointers");
+ /*NOTREACHED*/
+#ifdef lint
+ return 0;
+#endif
+}
+
+/*
+ - regrepeat - repeatedly match something simple, report how many
+ */
+/*
+ * [This routine now assumes that it will only match on things of length 1.
+ * That was true before, but now we assume scan - reginput is the count,
+ * rather than incrementing count on every character.]
+ */
+static int
+regrepeat(p)
+char *p;
+{
+ register char *scan;
+ register char *opnd;
+ register int c;
+ register char *loceol = regeol;
+
+ scan = reginput;
+ opnd = OPERAND(p);
+ switch (OP(p)) {
+ case ANY:
+ while (scan < loceol && *scan != '\n')
+ scan++;
+ break;
+ case EXACTLY: /* length of string is 1 */
+ opnd++;
+ while (scan < loceol && *opnd == *scan)
+ scan++;
+ break;
+ case ANYOF:
+ case ANYBUT:
+ c = UCHARAT(scan);
+ while (scan < loceol && !(opnd[c >> 3] & (1 << (c & 7)))) {
+ scan++;
+ c = UCHARAT(scan);
+ }
+ break;
+ case ALNUM:
+ while (isalpha(*scan) || isdigit(*scan) || *scan == '_')
+ scan++;
+ break;
+ case NALNUM:
+ while (scan < loceol && (!isalpha(*scan) && !isdigit(*scan) &&
+ *scan != '_'))
+ scan++;
+ break;
+ case SPACE:
+ while (scan < loceol && isspace(*scan))
+ scan++;
+ break;
+ case NSPACE:
+ while (scan < loceol && !isspace(*scan))
+ scan++;
+ break;
+ case DIGIT:
+ while (isdigit(*scan))
+ scan++;
+ break;
+ case NDIGIT:
+ while (scan < loceol && !isdigit(*scan))
+ scan++;
+ break;
+ default: /* Oh dear. Called inappropriately. */
+ FAIL("internal regexp foulup");
+ /* NOTREACHED */
+ }
+
+ c = scan - reginput;
+ reginput = scan;
+
+ return(c);
+}
+
+/*
+ - regnext - dig the "next" pointer out of a node
+ *
+ * [Note, when REGALIGN is defined there are two places in regmatch()
+ * that bypass this code for speed.]
+ */
+char *
+regnext(p)
+register char *p;
+{
+ register int offset;
+
+ if (p == ®dummy)
+ return(NULL);
+
+ offset = NEXT(p);
+ if (offset == 0)
+ return(NULL);
+
+#ifdef REGALIGN
+ return(p+offset);
+#else
+ if (OP(p) == BACK)
+ return(p-offset);
+ else
+ return(p+offset);
+#endif
+}
+++ /dev/null
-/* NOTE: this is derived from Henry Spencer's regexp code, and should not
- * confused with the original package (see point 3 below). Thanks, Henry!
- */
-
-/* Additional note: this code is very heavily munged from Henry's version
- * in places. In some spots I've traded clarity for efficiency, so don't
- * blame Henry for some of the lack of readability.
- */
-
-/* $Header: regexp.c,v 2.0.1.1 88/06/28 16:37:19 root Exp $
- *
- * $Log: regexp.c,v $
- * Revision 2.0.1.1 88/06/28 16:37:19 root
- * patch1: removed redundant debugging code
- *
- * Revision 2.0 88/06/05 00:10:45 root
- * Baseline version 2.0.
- *
- */
-
-/*
- * regcomp and regexec -- regsub and regerror are not used in perl
- *
- * Copyright (c) 1986 by University of Toronto.
- * Written by Henry Spencer. Not derived from licensed software.
- *
- * Permission is granted to anyone to use this software for any
- * purpose on any computer system, and to redistribute it freely,
- * subject to the following restrictions:
- *
- * 1. The author is not responsible for the consequences of use of
- * this software, no matter how awful, even if they arise
- * from defects in it.
- *
- * 2. The origin of this software must not be misrepresented, either
- * by explicit claim or by omission.
- *
- * 3. Altered versions must be plainly marked as such, and must not
- * be misrepresented as being the original software.
- *
- * Beware that some of this code is subtly aware of the way operator
- * precedence is structured in regular expressions. Serious changes in
- * regular-expression syntax might require a total rethink.
- */
-#include "EXTERN.h"
-#include "perl.h"
-
-/*
- * The "internal use only" fields in regexp.h are present to pass info from
- * compile to execute that permits the execute phase to run lots faster on
- * simple cases. They are:
- *
- * regstart str that must begin a match; Nullch if none obvious
- * reganch is the match anchored (at beginning-of-line only)?
- * regmust string (pointer into program) that match must include, or NULL
- * [regmust changed to STR* for bminstr()--law]
- * regmlen length of regmust string
- * [regmlen not used currently]
- *
- * Regstart and reganch permit very fast decisions on suitable starting points
- * for a match, cutting down the work a lot. Regmust permits fast rejection
- * of lines that cannot possibly match. The regmust tests are costly enough
- * that regcomp() supplies a regmust only if the r.e. contains something
- * potentially expensive (at present, the only such thing detected is * or +
- * at the start of the r.e., which can involve a lot of backup). Regmlen is
- * supplied because the test in regexec() needs it and regcomp() is computing
- * it anyway.
- * [regmust is now supplied always. The tests that use regmust have a
- * heuristic that disables the test if it usually matches.]
- *
- * [In fact, we now use regmust in many cases to locate where the search
- * starts in the string, so if regback is >= 0, the regmust search is never
- * wasted effort. The regback variable says how many characters back from
- * where regmust matched is the earliest possible start of the match.
- * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.]
- */
-
-/*
- * Structure for regexp "program". This is essentially a linear encoding
- * of a nondeterministic finite-state machine (aka syntax charts or
- * "railroad normal form" in parsing technology). Each node is an opcode
- * plus a "next" pointer, possibly plus an operand. "Next" pointers of
- * all nodes except BRANCH implement concatenation; a "next" pointer with
- * a BRANCH on both ends of it is connecting two alternatives. (Here we
- * have one of the subtle syntax dependencies: an individual BRANCH (as
- * opposed to a collection of them) is never concatenated with anything
- * because of operator precedence.) The operand of some types of node is
- * a literal string; for others, it is a node leading into a sub-FSM. In
- * particular, the operand of a BRANCH node is the first node of the branch.
- * (NB this is *not* a tree structure: the tail of the branch connects
- * to the thing following the set of BRANCHes.) The opcodes are:
- */
-
-/* definition number opnd? meaning */
-#define END 0 /* no End of program. */
-#define BOL 1 /* no Match "" at beginning of line. */
-#define EOL 2 /* no Match "" at end of line. */
-#define ANY 3 /* no Match any one character. */
-#define ANYOF 4 /* str Match any character in this string. */
-#define ANYBUT 5 /* str Match any character not in this string. */
-#define BRANCH 6 /* node Match this alternative, or the next... */
-#define BACK 7 /* no Match "", "next" ptr points backward. */
-#define EXACTLY 8 /* str Match this string (preceded by length). */
-#define NOTHING 9 /* no Match empty string. */
-#define STAR 10 /* node Match this (simple) thing 0 or more times. */
-#define PLUS 11 /* node Match this (simple) thing 1 or more times. */
-#define ALNUM 12 /* no Match any alphanumeric character */
-#define NALNUM 13 /* no Match any non-alphanumeric character */
-#define BOUND 14 /* no Match "" at any word boundary */
-#define NBOUND 15 /* no Match "" at any word non-boundary */
-#define SPACE 16 /* no Match any whitespace character */
-#define NSPACE 17 /* no Match any non-whitespace character */
-#define DIGIT 18 /* no Match any numeric character */
-#define NDIGIT 19 /* no Match any non-numeric character */
-#define REF 20 /* no Match some already matched string */
-#define OPEN 30 /* no Mark this point in input as start of #n. */
- /* OPEN+1 is number 1, etc. */
-#define CLOSE 40 /* no Analogous to OPEN. */
-
-/*
- * Opcode notes:
- *
- * BRANCH The set of branches constituting a single choice are hooked
- * together with their "next" pointers, since precedence prevents
- * anything being concatenated to any individual branch. The
- * "next" pointer of the last BRANCH in a choice points to the
- * thing following the whole choice. This is also where the
- * final "next" pointer of each individual branch points; each
- * branch starts with the operand node of a BRANCH node.
- *
- * BACK Normal "next" pointers all implicitly point forward; BACK
- * exists to make loop structures possible.
- *
- * STAR,PLUS '?', and complex '*' and '+', are implemented as circular
- * BRANCH structures using BACK. Simple cases (one character
- * per match) are implemented with STAR and PLUS for speed
- * and to minimize recursive plunges.
- *
- * OPEN,CLOSE ...are numbered at compile time.
- */
-
-/* The following have no fixed length. */
-char varies[] = {BRANCH,BACK,STAR,PLUS,REF,0};
-
-/* The following always have a length of 1. */
-char simple[] = {ANY,ANYOF,ANYBUT,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0};
-
-/*
- * A node is one char of opcode followed by two chars of "next" pointer.
- * "Next" pointers are stored as two 8-bit pieces, high order first. The
- * value is a positive offset from the opcode of the node containing it.
- * An operand, if any, simply follows the node. (Note that much of the
- * code generation knows about this implicit relationship.)
- *
- * Using two bytes for the "next" pointer is vast overkill for most things,
- * but allows patterns to get big without disasters.
- *
- * [If ALIGN is defined, the "next" pointer is always aligned on an even
- * boundary, and reads the offset directly as a short. Also, there is no
- * special test to reverse the sign of BACK pointers since the offset is
- * stored negative.]
- */
-
-#ifndef STATIC
-#define STATIC static
-#endif
-
-#define ALIGN
-#define FASTANY
-#ifdef DEBUG
-#undef DEBUG
-#endif
-#ifdef DEBUGGING
-#define DEBUG
-#endif
-
-#ifdef DEBUG
-int regnarrate = 0;
-void regdump();
-STATIC char *regprop();
-#endif
-
-
-#define OP(p) (*(p))
-
-#ifdef ALIGN
-#define NEXT(p) (*(short*)(p+1))
-#else
-#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377))
-#endif
-
-#define OPERAND(p) ((p) + 3)
-
-#ifdef ALIGN
-#define NEXTOPER(p) ((p) + 4)
-#else
-#define NEXTOPER(p) ((p) + 3)
-#endif
-
-#define MAGIC 0234
-
-/*
- * Utility definitions.
- */
-#ifndef CHARBITS
-#define UCHARAT(p) ((int)*(unsigned char *)(p))
-#else
-#define UCHARAT(p) ((int)*(p)&CHARBITS)
-#endif
-
-#define FAIL(m) fatal("/%s/: %s",regprecomp,m)
-#define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?')
-#define META "^$.[()|?+*\\"
-
-/*
- * Flags to be passed up and down.
- */
-#define HASWIDTH 01 /* Known never to match null string. */
-#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */
-#define SPSTART 04 /* Starts with * or +. */
-#define WORST 0 /* Worst case. */
-
-/*
- * Global work variables for regcomp().
- */
-static char *regprecomp; /* uncompiled string. */
-static char *regparse; /* Input-scan pointer. */
-static int regnpar; /* () count. */
-static char regdummy;
-static char *regcode; /* Code-emit pointer; ®dummy = don't. */
-static long regsize; /* Code size. */
-static int regfold;
-
-/*
- * Forward declarations for regcomp()'s friends.
- */
-STATIC char *reg();
-STATIC char *regbranch();
-STATIC char *regpiece();
-STATIC char *regatom();
-STATIC char *regclass();
-STATIC char *regchar();
-STATIC char *regnode();
-STATIC char *regnext();
-STATIC void regc();
-STATIC void reginsert();
-STATIC void regtail();
-STATIC void regoptail();
-#ifndef STRCSPN
-STATIC int strcspn();
-#endif
-
-/*
- - regcomp - compile a regular expression into internal code
- *
- * We can't allocate space until we know how big the compiled form will be,
- * but we can't compile it (and thus know how big it is) until we've got a
- * place to put the code. So we cheat: we compile it twice, once with code
- * generation turned off and size counting turned on, and once "for real".
- * This also means that we don't allocate space until we are sure that the
- * thing really will compile successfully, and we never have to move the
- * code and thus invalidate pointers into it. (Note that it has to be in
- * one piece because free() must be able to free it all.) [NB: not true in perl]
- *
- * Beware that the optimization-preparation code in here knows about some
- * of the structure of the compiled regexp. [I'll say.]
- */
-regexp *
-regcomp(exp,fold,rare)
-char *exp;
-int fold;
-int rare;
-{
- register regexp *r;
- register char *scan;
- register STR *longest;
- register int len;
- register char *first;
- int flags;
- int back;
- int curback;
- extern char *safemalloc();
- extern char *savestr();
-
- if (exp == NULL)
- fatal("NULL regexp argument");
-
- /* First pass: determine size, legality. */
- regfold = fold;
- regparse = exp;
- regprecomp = savestr(exp);
- regnpar = 1;
- regsize = 0L;
- regcode = ®dummy;
- regc(MAGIC);
- if (reg(0, &flags) == NULL) {
- safefree(regprecomp);
- return(NULL);
- }
-
- /* Small enough for pointer-storage convention? */
- if (regsize >= 32767L) /* Probably could be 65535L. */
- FAIL("regexp too big");
-
- /* Allocate space. */
- r = (regexp *)safemalloc(sizeof(regexp) + (unsigned)regsize);
- if (r == NULL)
- FAIL("regexp out of space");
-
- /* Second pass: emit code. */
- r->precomp = regprecomp;
- r->subbase = NULL;
- regparse = exp;
- regnpar = 1;
- regcode = r->program;
- regc(MAGIC);
- if (reg(0, &flags) == NULL)
- return(NULL);
-
- /* Dig out information for optimizations. */
- r->regstart = Nullstr; /* Worst-case defaults. */
- r->reganch = 0;
- r->regmust = Nullstr;
- r->regback = -1;
- r->regstclass = Nullch;
- scan = r->program+1; /* First BRANCH. */
- if (!fold && OP(regnext(scan)) == END) {/* Only one top-level choice. */
- scan = NEXTOPER(scan);
-
- first = scan;
- while ((OP(first) > OPEN && OP(first) < CLOSE) ||
- (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
- (OP(first) == PLUS) )
- first = NEXTOPER(first);
-
- /* Starting-point info. */
- if (OP(first) == EXACTLY)
- r->regstart = str_make(OPERAND(first)+1);
- else if ((exp = index(simple,OP(first))) && exp > simple)
- r->regstclass = first;
- else if (OP(first) == BOUND || OP(first) == NBOUND)
- r->regstclass = first;
- else if (OP(first) == BOL)
- r->reganch++;
-
-#ifdef DEBUGGING
- if (debug & 512)
- fprintf(stderr,"first %d next %d offset %d\n",
- OP(first), OP(NEXTOPER(first)), first - scan);
-#endif
- /*
- * If there's something expensive in the r.e., find the
- * longest literal string that must appear and make it the
- * regmust. Resolve ties in favor of later strings, since
- * the regstart check works with the beginning of the r.e.
- * and avoiding duplication strengthens checking. Not a
- * strong reason, but sufficient in the absence of others.
- * [Now we resolve ties in favor of the earlier string if
- * it happens that curback has been invalidated, since the
- * earlier string may buy us something the later one won't.]
- */
- longest = str_new(10);
- len = 0;
- curback = 0;
- while (scan != NULL) {
- if (OP(scan) == BRANCH) {
- if (OP(regnext(scan)) == BRANCH) {
- curback = -30000;
- while (OP(scan) == BRANCH)
- scan = regnext(scan);
- }
- else /* single branch is ok */
- scan = NEXTOPER(scan);
- }
- if (OP(scan) == EXACTLY) {
- if (curback - back == len) {
- str_cat(longest, OPERAND(scan)+1);
- len += *OPERAND(scan);
- curback += *OPERAND(scan);
- }
- else if (*OPERAND(scan) >= len + (curback >= 0)) {
- str_set(longest, OPERAND(scan)+1);
- len = *OPERAND(scan);
- back = curback;
- curback += len;
- }
- else
- curback += *OPERAND(scan);
- }
- else if (index(varies,OP(scan)))
- curback = -30000;
- else if (index(simple,OP(scan)))
- curback++;
- scan = regnext(scan);
- }
- if (len) {
- r->regmust = longest;
- if (back < 0)
- back = -1;
- r->regback = back;
- if (len > !(sawstudy))
- fbmcompile(r->regmust);
- *(long*)&r->regmust->str_nval = 100;
- }
- else
- str_free(longest);
- }
-
- r->do_folding = fold;
- r->nparens = regnpar - 1;
-#ifdef DEBUG
- if (debug & 512)
- regdump(r);
-#endif
- return(r);
-}
-
-/*
- - reg - regular expression, i.e. main body or parenthesized thing
- *
- * Caller must absorb opening parenthesis.
- *
- * Combining parenthesis handling with the base level of regular expression
- * is a trifle forced, but the need to tie the tails of the branches to what
- * follows makes it hard to avoid.
- */
-static char *
-reg(paren, flagp)
-int paren; /* Parenthesized? */
-int *flagp;
-{
- register char *ret;
- register char *br;
- register char *ender;
- register int parno;
- int flags;
-
- *flagp = HASWIDTH; /* Tentatively. */
-
- /* Make an OPEN node, if parenthesized. */
- if (paren) {
- if (regnpar >= NSUBEXP)
- FAIL("too many () in regexp");
- parno = regnpar;
- regnpar++;
- ret = regnode(OPEN+parno);
- } else
- ret = NULL;
-
- /* Pick up the branches, linking them together. */
- br = regbranch(&flags);
- if (br == NULL)
- return(NULL);
- if (ret != NULL)
- regtail(ret, br); /* OPEN -> first. */
- else
- ret = br;
- if (!(flags&HASWIDTH))
- *flagp &= ~HASWIDTH;
- *flagp |= flags&SPSTART;
- while (*regparse == '|') {
- regparse++;
- br = regbranch(&flags);
- if (br == NULL)
- return(NULL);
- regtail(ret, br); /* BRANCH -> BRANCH. */
- if (!(flags&HASWIDTH))
- *flagp &= ~HASWIDTH;
- *flagp |= flags&SPSTART;
- }
-
- /* Make a closing node, and hook it on the end. */
- ender = regnode((paren) ? CLOSE+parno : END);
- regtail(ret, ender);
-
- /* Hook the tails of the branches to the closing node. */
- for (br = ret; br != NULL; br = regnext(br))
- regoptail(br, ender);
-
- /* Check for proper termination. */
- if (paren && *regparse++ != ')') {
- FAIL("unmatched () in regexp");
- } else if (!paren && *regparse != '\0') {
- if (*regparse == ')') {
- FAIL("unmatched () in regexp");
- } else
- FAIL("junk on end of regexp"); /* "Can't happen". */
- /* NOTREACHED */
- }
-
- return(ret);
-}
-
-/*
- - regbranch - one alternative of an | operator
- *
- * Implements the concatenation operator.
- */
-static char *
-regbranch(flagp)
-int *flagp;
-{
- register char *ret;
- register char *chain;
- register char *latest;
- int flags;
-
- *flagp = WORST; /* Tentatively. */
-
- ret = regnode(BRANCH);
- chain = NULL;
- while (*regparse != '\0' && *regparse != '|' && *regparse != ')') {
- latest = regpiece(&flags);
- if (latest == NULL)
- return(NULL);
- *flagp |= flags&HASWIDTH;
- if (chain == NULL) /* First piece. */
- *flagp |= flags&SPSTART;
- else
- regtail(chain, latest);
- chain = latest;
- }
- if (chain == NULL) /* Loop ran zero times. */
- (void) regnode(NOTHING);
-
- return(ret);
-}
-
-/*
- - regpiece - something followed by possible [*+?]
- *
- * Note that the branching code sequences used for ? and the general cases
- * of * and + are somewhat optimized: they use the same NOTHING node as
- * both the endmarker for their branch list and the body of the last branch.
- * It might seem that this node could be dispensed with entirely, but the
- * endmarker role is not redundant.
- */
-static char *
-regpiece(flagp)
-int *flagp;
-{
- register char *ret;
- register char op;
- register char *next;
- int flags;
-
- ret = regatom(&flags);
- if (ret == NULL)
- return(NULL);
-
- op = *regparse;
- if (!ISMULT(op)) {
- *flagp = flags;
- return(ret);
- }
-
- if (!(flags&HASWIDTH) && op != '?')
- FAIL("regexp *+ operand could be empty");
- *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH);
-
- if (op == '*' && (flags&SIMPLE))
- reginsert(STAR, ret);
- else if (op == '*') {
- /* Emit x* as (x&|), where & means "self". */
- reginsert(BRANCH, ret); /* Either x */
- regoptail(ret, regnode(BACK)); /* and loop */
- regoptail(ret, ret); /* back */
- regtail(ret, regnode(BRANCH)); /* or */
- regtail(ret, regnode(NOTHING)); /* null. */
- } else if (op == '+' && (flags&SIMPLE))
- reginsert(PLUS, ret);
- else if (op == '+') {
- /* Emit x+ as x(&|), where & means "self". */
- next = regnode(BRANCH); /* Either */
- regtail(ret, next);
- regtail(regnode(BACK), ret); /* loop back */
- regtail(next, regnode(BRANCH)); /* or */
- regtail(ret, regnode(NOTHING)); /* null. */
- } else if (op == '?') {
- /* Emit x? as (x|) */
- reginsert(BRANCH, ret); /* Either x */
- regtail(ret, regnode(BRANCH)); /* or */
- next = regnode(NOTHING); /* null. */
- regtail(ret, next);
- regoptail(ret, next);
- }
- regparse++;
- if (ISMULT(*regparse))
- FAIL("nested *?+ in regexp");
-
- return(ret);
-}
-
-static int foo;
-
-/*
- - regatom - the lowest level
- *
- * Optimization: gobbles an entire sequence of ordinary characters so that
- * it can turn them into a single node, which is smaller to store and
- * faster to run. Backslashed characters are exceptions, each becoming a
- * separate node; the code is simpler that way and it's not worth fixing.
- *
- * [Yes, it is worth fixing, some scripts can run twice the speed.]
- */
-static char *
-regatom(flagp)
-int *flagp;
-{
- register char *ret;
- int flags;
-
- *flagp = WORST; /* Tentatively. */
-
- switch (*regparse++) {
- case '^':
- ret = regnode(BOL);
- break;
- case '$':
- ret = regnode(EOL);
- break;
- case '.':
- ret = regnode(ANY);
- *flagp |= HASWIDTH|SIMPLE;
- break;
- case '[':
- ret = regclass();
- *flagp |= HASWIDTH|SIMPLE;
- break;
- case '(':
- ret = reg(1, &flags);
- if (ret == NULL)
- return(NULL);
- *flagp |= flags&(HASWIDTH|SPSTART);
- break;
- case '\0':
- case '|':
- case ')':
- FAIL("internal urp in regexp"); /* Supposed to be caught earlier. */
- break;
- case '?':
- case '+':
- case '*':
- FAIL("?+* follows nothing in regexp");
- break;
- case '\\':
- switch (*regparse) {
- case '\0':
- FAIL("trailing \\ in regexp");
- case 'w':
- ret = regnode(ALNUM);
- *flagp |= HASWIDTH|SIMPLE;
- regparse++;
- break;
- case 'W':
- ret = regnode(NALNUM);
- *flagp |= HASWIDTH|SIMPLE;
- regparse++;
- break;
- case 'b':
- ret = regnode(BOUND);
- *flagp |= SIMPLE;
- regparse++;
- break;
- case 'B':
- ret = regnode(NBOUND);
- *flagp |= SIMPLE;
- regparse++;
- break;
- case 's':
- ret = regnode(SPACE);
- *flagp |= HASWIDTH|SIMPLE;
- regparse++;
- break;
- case 'S':
- ret = regnode(NSPACE);
- *flagp |= HASWIDTH|SIMPLE;
- regparse++;
- break;
- case 'd':
- ret = regnode(DIGIT);
- *flagp |= HASWIDTH|SIMPLE;
- regparse++;
- break;
- case 'D':
- ret = regnode(NDIGIT);
- *flagp |= HASWIDTH|SIMPLE;
- regparse++;
- break;
- case 'n':
- case 'r':
- case 't':
- case 'f':
- goto defchar;
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- if (isdigit(regparse[1]))
- goto defchar;
- else {
- ret = regnode(REF + *regparse++ - '0');
- *flagp |= SIMPLE;
- }
- break;
- default:
- goto defchar;
- }
- break;
- default: {
- register int len;
- register char ender;
- register char *p;
- char *oldp;
- int foo;
-
- defchar:
- ret = regnode(EXACTLY);
- regc(0); /* save spot for len */
- for (len=0, p=regparse-1; len < 127 && *p; len++) {
- oldp = p;
- switch (*p) {
- case '^':
- case '$':
- case '.':
- case '[':
- case '(':
- case ')':
- case '|':
- goto loopdone;
- case '\\':
- switch (*++p) {
- case '\0':
- FAIL("trailing \\ in regexp");
- case 'w':
- case 'W':
- case 'b':
- case 'B':
- case 's':
- case 'S':
- case 'd':
- case 'D':
- --p;
- goto loopdone;
- case 'n':
- ender = '\n';
- p++;
- break;
- case 'r':
- ender = '\r';
- p++;
- break;
- case 't':
- ender = '\t';
- p++;
- break;
- case 'f':
- ender = '\f';
- p++;
- break;
- case '0': case '1': case '2': case '3':case '4':
- case '5': case '6': case '7': case '8':case '9':
- if (isdigit(p[1])) {
- foo = *p++ - '0';
- foo <<= 3;
- foo += *p - '0';
- if (isdigit(p[1]))
- foo = (foo<<3) + *++p - '0';
- ender = foo;
- p++;
- }
- else {
- --p;
- goto loopdone;
- }
- break;
- default:
- ender = *p++;
- break;
- }
- break;
- default:
- ender = *p++;
- break;
- }
- if (regfold && isupper(ender))
- ender = tolower(ender);
- if (ISMULT(*p)) { /* Back off on ?+*. */
- if (len)
- p = oldp;
- else {
- len++;
- regc(ender);
- }
- break;
- }
- regc(ender);
- }
- loopdone:
- regparse = p;
- if (len <= 0)
- FAIL("internal disaster in regexp");
- *flagp |= HASWIDTH;
- if (len == 1)
- *flagp |= SIMPLE;
- *OPERAND(ret) = len;
- regc('\0');
- }
- break;
- }
-
- return(ret);
-}
-
-#ifdef FASTANY
-static void
-regset(bits,def,c)
-char *bits;
-int def;
-register int c;
-{
- if (regcode == ®dummy)
- return;
- if (def)
- bits[c >> 3] &= ~(1 << (c & 7));
- else
- bits[c >> 3] |= (1 << (c & 7));
-}
-
-static char *
-regclass()
-{
- register char *bits;
- register int class;
- register int lastclass;
- register int range = 0;
- register char *ret;
- register int def;
-
- if (*regparse == '^') { /* Complement of range. */
- ret = regnode(ANYBUT);
- regparse++;
- def = 0;
- } else {
- ret = regnode(ANYOF);
- def = 255;
- }
- bits = regcode;
- for (class = 0; class < 32; class++)
- regc(def);
- if (*regparse == ']' || *regparse == '-')
- regset(bits,def,lastclass = *regparse++);
- while (*regparse != '\0' && *regparse != ']') {
- class = UCHARAT(regparse++);
- if (class == '\\') {
- class = UCHARAT(regparse++);
- switch (class) {
- case 'w':
- for (class = 'a'; class <= 'z'; class++)
- regset(bits,def,class);
- for (class = 'A'; class <= 'Z'; class++)
- regset(bits,def,class);
- for (class = '0'; class <= '9'; class++)
- regset(bits,def,class);
- regset(bits,def,'_');
- lastclass = 1234;
- continue;
- case 's':
- regset(bits,def,' ');
- regset(bits,def,'\t');
- regset(bits,def,'\r');
- regset(bits,def,'\f');
- regset(bits,def,'\n');
- lastclass = 1234;
- continue;
- case 'd':
- for (class = '0'; class <= '9'; class++)
- regset(bits,def,class);
- lastclass = 1234;
- continue;
- case 'n':
- class = '\n';
- break;
- case 'r':
- class = '\r';
- break;
- case 't':
- class = '\t';
- break;
- case 'f':
- class = '\f';
- break;
- case 'b':
- class = '\b';
- break;
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- class -= '0';
- if (isdigit(*regparse)) {
- class <<= 3;
- class += *regparse++ - '0';
- }
- if (isdigit(*regparse)) {
- class <<= 3;
- class += *regparse++ - '0';
- }
- break;
- }
- }
- if (!range && class == '-' && *regparse && *regparse != ']') {
- range = 1;
- continue;
- }
- if (range) {
- if (lastclass > class)
- FAIL("invalid [] range in regexp");
- }
- else
- lastclass = class - 1;
- range = 0;
- for (lastclass++; lastclass <= class; lastclass++) {
- regset(bits,def,lastclass);
- if (regfold && isupper(lastclass))
- regset(bits,def,tolower(lastclass));
- }
- lastclass = class;
- }
- if (*regparse != ']')
- FAIL("unmatched [] in regexp");
- regset(bits,0,0); /* always bomb out on null */
- regparse++;
- return ret;
-}
-
-#else /* !FASTANY */
-static char *
-regclass()
-{
- register int class;
- register int lastclass;
- register int range = 0;
- register char *ret;
-
- if (*regparse == '^') { /* Complement of range. */
- ret = regnode(ANYBUT);
- regparse++;
- } else
- ret = regnode(ANYOF);
- if (*regparse == ']' || *regparse == '-')
- regc(lastclass = *regparse++);
- while (*regparse != '\0' && *regparse != ']') {
- class = UCHARAT(regparse++);
- if (class == '\\') {
- class = UCHARAT(regparse++);
- switch (class) {
- case 'w':
- for (class = 'a'; class <= 'z'; class++)
- regc(class);
- for (class = 'A'; class <= 'Z'; class++)
- regc(class);
- for (class = '0'; class <= '9'; class++)
- regc(class);
- regc('_');
- lastclass = 1234;
- continue;
- case 's':
- regc(' ');
- regc('\t');
- regc('\r');
- regc('\f');
- regc('\n');
- lastclass = 1234;
- continue;
- case 'd':
- for (class = '0'; class <= '9'; class++)
- regc(class);
- lastclass = 1234;
- continue;
- case 'n':
- class = '\n';
- break;
- case 'r':
- class = '\r';
- break;
- case 't':
- class = '\t';
- break;
- case 'f':
- class = '\f';
- break;
- case 'b':
- class = '\b';
- break;
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- class -= '0';
- if (isdigit(*regparse)) {
- class <<= 3;
- class += *regparse++ - '0';
- }
- if (isdigit(*regparse)) {
- class <<= 3;
- class += *regparse++ - '0';
- }
- break;
- }
- }
- if (!range && class == '-' && *regparse && *regparse != ']') {
- range = 1;
- continue;
- }
- if (range) {
- if (lastclass > class)
- FAIL("invalid [] range in regexp");
- }
- else
- lastclass = class - 1;
- range = 0;
- for (lastclass++; lastclass <= class; lastclass++) {
- regc(lastclass);
- if (regfold && isupper(lastclass))
- regc(tolower(lastclass));
- }
- lastclass = class;
- }
- regc('\0');
- if (*regparse != ']')
- FAIL("unmatched [] in regexp");
- regparse++;
- return ret;
-}
-#endif /* NOTDEF */
-
-static char *
-regchar(ch,flagp)
-int ch;
-int *flagp;
-{
- char *ret;
-
- ret = regnode(EXACTLY);
- regc(1);
- regc(ch);
- regc('\0');
- regparse++;
- *flagp |= HASWIDTH|SIMPLE;
- return ret;
-}
-
-/*
- - regnode - emit a node
- */
-static char * /* Location. */
-regnode(op)
-char op;
-{
- register char *ret;
- register char *ptr;
-
- ret = regcode;
- if (ret == ®dummy) {
-#ifdef ALIGN
- if (!(regsize & 1))
- regsize++;
-#endif
- regsize += 3;
- return(ret);
- }
-
-#ifdef ALIGN
- if (!((long)ret & 1))
- *ret++ = 127;
-#endif
- ptr = ret;
- *ptr++ = op;
- *ptr++ = '\0'; /* Null "next" pointer. */
- *ptr++ = '\0';
- regcode = ptr;
-
- return(ret);
-}
-
-/*
- - regc - emit (if appropriate) a byte of code
- */
-static void
-regc(b)
-char b;
-{
- if (regcode != ®dummy)
- *regcode++ = b;
- else
- regsize++;
-}
-
-/*
- - reginsert - insert an operator in front of already-emitted operand
- *
- * Means relocating the operand.
- */
-static void
-reginsert(op, opnd)
-char op;
-char *opnd;
-{
- register char *src;
- register char *dst;
- register char *place;
-
- if (regcode == ®dummy) {
-#ifdef ALIGN
- regsize += 4;
-#else
- regsize += 3;
-#endif
- return;
- }
-
- src = regcode;
-#ifdef ALIGN
- regcode += 4;
-#else
- regcode += 3;
-#endif
- dst = regcode;
- while (src > opnd)
- *--dst = *--src;
-
- place = opnd; /* Op node, where operand used to be. */
- *place++ = op;
- *place++ = '\0';
- *place++ = '\0';
-}
-
-/*
- - regtail - set the next-pointer at the end of a node chain
- */
-static void
-regtail(p, val)
-char *p;
-char *val;
-{
- register char *scan;
- register char *temp;
- register int offset;
-
- if (p == ®dummy)
- return;
-
- /* Find last node. */
- scan = p;
- for (;;) {
- temp = regnext(scan);
- if (temp == NULL)
- break;
- scan = temp;
- }
-
-#ifdef ALIGN
- offset = val - scan;
- *(short*)(scan+1) = offset;
-#else
- if (OP(scan) == BACK)
- offset = scan - val;
- else
- offset = val - scan;
- *(scan+1) = (offset>>8)&0377;
- *(scan+2) = offset&0377;
-#endif
-}
-
-/*
- - regoptail - regtail on operand of first argument; nop if operandless
- */
-static void
-regoptail(p, val)
-char *p;
-char *val;
-{
- /* "Operandless" and "op != BRANCH" are synonymous in practice. */
- if (p == NULL || p == ®dummy || OP(p) != BRANCH)
- return;
- regtail(NEXTOPER(p), val);
-}
-
-/*
- * regexec and friends
- */
-
-/*
- * Global work variables for regexec().
- */
-static char *reginput; /* String-input pointer. */
-static char *regbol; /* Beginning of input, for ^ check. */
-static char **regstartp; /* Pointer to startp array. */
-static char **regendp; /* Ditto for endp. */
-static char *reglastparen; /* Similarly for lastparen. */
-static char *regtill;
-
-static char *regmystartp[10]; /* For remembering backreferences. */
-static char *regmyendp[10];
-
-/*
- * Forwards.
- */
-STATIC int regtry();
-STATIC int regmatch();
-STATIC int regrepeat();
-
-extern char sawampersand;
-extern int multiline;
-
-/*
- - regexec - match a regexp against a string
- */
-int
-regexec(prog, stringarg, strend, beginning, minend, screamer)
-register regexp *prog;
-char *stringarg;
-char *strend; /* pointer to null at end of string */
-int beginning; /* is ^ valid at the beginning of stringarg? */
-int minend; /* end of match must be at least minend after stringarg */
-STR *screamer;
-{
- register char *s;
- extern char *index();
- register int tmp, i;
- register char *string = stringarg;
- register char *c;
- extern char *savestr();
-
- /* Be paranoid... */
- if (prog == NULL || string == NULL) {
- fatal("NULL regexp parameter");
- return(0);
- }
-
- regprecomp = prog->precomp;
- /* Check validity of program. */
- if (UCHARAT(prog->program) != MAGIC) {
- FAIL("corrupted regexp program");
- }
-
- if (prog->do_folding) {
- i = strend - string;
- string = savestr(string);
- strend = string + i;
- for (s = string; *s; s++)
- if (isupper(*s))
- *s = tolower(*s);
- }
-
- /* If there is a "must appear" string, look for it. */
- s = string;
- if (prog->regmust != Nullstr) {
- if (beginning && screamer) {
- if (screamfirst[prog->regmust->str_rare] >= 0)
- s = screaminstr(screamer,prog->regmust);
- else
- s = Nullch;
- }
- else
- s = fbminstr(s,strend,prog->regmust);
- if (!s) {
- ++*(long*)&prog->regmust->str_nval; /* hooray */
- goto phooey; /* not present */
- }
- else if (prog->regback >= 0) {
- s -= prog->regback;
- if (s < string)
- s = string;
- }
- else if (--*(long*)&prog->regmust->str_nval < 0) { /* boo */
- str_free(prog->regmust);
- prog->regmust = Nullstr; /* disable regmust */
- s = string;
- }
- else
- s = string;
- }
-
- /* Mark beginning of line for ^ . */
- if (beginning)
- regbol = string;
- else
- regbol = NULL;
-
- /* see how far we have to get to not match where we matched before */
- regtill = string+minend;
-
- /* Simplest case: anchored match need be tried only once. */
- /* [unless multiline is set] */
- if (prog->reganch) {
- if (regtry(prog, string))
- goto got_it;
- else if (multiline) {
- /* for multiline we only have to try after newlines */
- if (s > string)
- s--;
- while ((s = index(s, '\n')) != NULL) {
- if (*++s && regtry(prog, s))
- goto got_it;
- }
- }
- goto phooey;
- }
-
- /* Messy cases: unanchored match. */
- if (prog->regstart) {
- /* We know what string it must start with. */
- if (prog->regstart->str_pok == 3) {
- while ((s = fbminstr(s, strend, prog->regstart)) != NULL) {
- if (regtry(prog, s))
- goto got_it;
- s++;
- }
- }
- else {
- c = prog->regstart->str_ptr;
- while ((s = instr(s, c)) != NULL) {
- if (regtry(prog, s))
- goto got_it;
- s++;
- }
- }
- }
- else if (c = prog->regstclass) {
- /* We know what class it must start with. */
- switch (OP(c)) {
- case ANYOF: case ANYBUT:
- c = OPERAND(c);
- while (i = *s) {
- if (!(c[i >> 3] & (1 << (i&7))))
- if (regtry(prog, s))
- goto got_it;
- s++;
- }
- break;
- case BOUND:
- tmp = 0;
- while (i = *s) {
- if (tmp != (isalpha(i) || isdigit(i) || i == '_')) {
- tmp = !tmp;
- if (regtry(prog, s))
- goto got_it;
- }
- s++;
- }
- if (tmp && regtry(prog,s))
- goto got_it;
- break;
- case NBOUND:
- tmp = 0;
- while (i = *s) {
- if (tmp != (isalpha(i) || isdigit(i) || i == '_'))
- tmp = !tmp;
- else if (regtry(prog, s))
- goto got_it;
- s++;
- }
- if (!tmp && regtry(prog,s))
- goto got_it;
- break;
- case ALNUM:
- while (i = *s) {
- if (isalpha(i) || isdigit(i) || i == '_')
- if (regtry(prog, s))
- goto got_it;
- s++;
- }
- break;
- case NALNUM:
- while (i = *s) {
- if (!isalpha(i) && !isdigit(i) && i != '_')
- if (regtry(prog, s))
- goto got_it;
- s++;
- }
- break;
- case SPACE:
- while (i = *s) {
- if (isspace(i))
- if (regtry(prog, s))
- goto got_it;
- s++;
- }
- break;
- case NSPACE:
- while (i = *s) {
- if (!isspace(i))
- if (regtry(prog, s))
- goto got_it;
- s++;
- }
- break;
- case DIGIT:
- while (i = *s) {
- if (isdigit(i))
- if (regtry(prog, s))
- goto got_it;
- s++;
- }
- break;
- case NDIGIT:
- while (i = *s) {
- if (!isdigit(i))
- if (regtry(prog, s))
- goto got_it;
- s++;
- }
- break;
- }
- }
- else
- /* We don't know much -- general case. */
- do {
- if (regtry(prog, s))
- goto got_it;
- } while (*s++ != '\0');
-
- /* Failure. */
- goto phooey;
-
- got_it:
- if (prog->nparens || sawampersand || prog->do_folding) {
- s = savestr(stringarg); /* so $digit will always work */
- if (prog->subbase)
- safefree(prog->subbase);
- prog->subbase = s;
- tmp = prog->subbase - string;
- for (i = 0; i <= prog->nparens; i++) {
- if (prog->endp[i]) {
- prog->startp[i] += tmp;
- prog->endp[i] += tmp;
- }
- }
- if (prog->do_folding) {
- safefree(string);
- }
- }
- return(1);
-
- phooey:
- if (prog->do_folding) {
- safefree(string);
- }
- return(0);
-}
-
-/*
- - regtry - try match at specific point
- */
-static int /* 0 failure, 1 success */
-regtry(prog, string)
-regexp *prog;
-char *string;
-{
- register int i;
- register char **sp;
- register char **ep;
-
- reginput = string;
- regstartp = prog->startp;
- regendp = prog->endp;
- reglastparen = &prog->lastparen;
-
- sp = prog->startp;
- ep = prog->endp;
- if (prog->nparens) {
- for (i = NSUBEXP; i > 0; i--) {
- *sp++ = NULL;
- *ep++ = NULL;
- }
- }
- if (regmatch(prog->program + 1) && reginput >= regtill) {
- prog->startp[0] = string;
- prog->endp[0] = reginput;
- return(1);
- } else
- return(0);
-}
-
-/*
- - regmatch - main matching routine
- *
- * Conceptually the strategy is simple: check to see whether the current
- * node matches, call self recursively to see whether the rest matches,
- * and then act accordingly. In practice we make some effort to avoid
- * recursion, in particular by going through "ordinary" nodes (that don't
- * need to know whether the rest of the match failed) by a loop instead of
- * by recursion.
- */
-/* [lwall] I've hoisted the register declarations to the outer block in order to
- * maybe save a little bit of pushing and popping on the stack. It also takes
- * advantage of machines that use a register save mask on subroutine entry.
- */
-static int /* 0 failure, 1 success */
-regmatch(prog)
-char *prog;
-{
- register char *scan; /* Current node. */
- char *next; /* Next node. */
- extern char *index();
- register int nextchar;
- register int n; /* no or next */
- register int ln; /* len or last */
- register char *s; /* operand or save */
- register char *locinput = reginput;
-
- nextchar = *reginput;
- scan = prog;
-#ifdef DEBUG
- if (scan != NULL && regnarrate)
- fprintf(stderr, "%s(\n", regprop(scan));
-#endif
- while (scan != NULL) {
-#ifdef DEBUG
- if (regnarrate)
- fprintf(stderr, "%s...\n", regprop(scan));
-#endif
-
-#ifdef ALIGN
- next = scan + NEXT(scan);
- if (next == scan)
- next = NULL;
-#else
- next = regnext(scan);
-#endif
-
- switch (OP(scan)) {
- case BOL:
- if (locinput == regbol ||
- (nextchar && locinput[-1] == '\n') ) {
- regtill--;
- break;
- }
- return(0);
- case EOL:
- if (nextchar != '\0' && nextchar != '\n')
- return(0);
- regtill--;
- break;
- case ANY:
- if (nextchar == '\0' || nextchar == '\n')
- return(0);
- nextchar = *++locinput;
- break;
- case EXACTLY:
- s = OPERAND(scan);
- ln = *s++;
- /* Inline the first character, for speed. */
- if (*s != nextchar)
- return(0);
- if (ln > 1 && strncmp(s, locinput, ln) != 0)
- return(0);
- locinput += ln;
- nextchar = *locinput;
- break;
- case ANYOF:
- case ANYBUT:
- s = OPERAND(scan);
- if (nextchar < 0)
- nextchar = UCHARAT(locinput);
- if (s[nextchar >> 3] & (1 << (nextchar&7)))
- return(0);
- nextchar = *++locinput;
- break;
-#ifdef NOTDEF
- case ANYOF:
- if (nextchar == '\0' || index(OPERAND(scan), nextchar) == NULL)
- return(0);
- nextchar = *++locinput;
- break;
- case ANYBUT:
- if (nextchar == '\0' || index(OPERAND(scan), nextchar) != NULL)
- return(0);
- nextchar = *++locinput;
- break;
-#endif
- case ALNUM:
- if (!nextchar)
- return(0);
- if (!isalpha(nextchar) && !isdigit(nextchar) &&
- nextchar != '_')
- return(0);
- nextchar = *++locinput;
- break;
- case NALNUM:
- if (!nextchar)
- return(0);
- if (isalpha(nextchar) || isdigit(nextchar) ||
- nextchar == '_')
- return(0);
- nextchar = *++locinput;
- break;
- case NBOUND:
- case BOUND:
- if (locinput == regbol) /* was last char in word? */
- ln = 0;
- else
- ln = (isalpha(locinput[-1]) ||
- isdigit(locinput[-1]) ||
- locinput[-1] == '_' );
- n = (isalpha(nextchar) || isdigit(nextchar) ||
- nextchar == '_' ); /* is next char in word? */
- if ((ln == n) == (OP(scan) == BOUND))
- return(0);
- break;
- case SPACE:
- if (!nextchar)
- return(0);
- if (!isspace(nextchar))
- return(0);
- nextchar = *++locinput;
- break;
- case NSPACE:
- if (!nextchar)
- return(0);
- if (isspace(nextchar))
- return(0);
- nextchar = *++locinput;
- break;
- case DIGIT:
- if (!isdigit(nextchar))
- return(0);
- nextchar = *++locinput;
- break;
- case NDIGIT:
- if (!nextchar)
- return(0);
- if (isdigit(nextchar))
- return(0);
- nextchar = *++locinput;
- break;
- case REF:
- case REF+1:
- case REF+2:
- case REF+3:
- case REF+4:
- case REF+5:
- case REF+6:
- case REF+7:
- case REF+8:
- case REF+9:
- n = OP(scan) - REF;
- s = regmystartp[n];
- if (!s)
- return(0);
- if (!regmyendp[n])
- return(0);
- if (s == regmyendp[n])
- break;
- /* Inline the first character, for speed. */
- if (*s != nextchar)
- return(0);
- ln = regmyendp[n] - s;
- if (ln > 1 && strncmp(s, locinput, ln) != 0)
- return(0);
- locinput += ln;
- nextchar = *locinput;
- break;
-
- case NOTHING:
- break;
- case BACK:
- break;
- case OPEN+1:
- case OPEN+2:
- case OPEN+3:
- case OPEN+4:
- case OPEN+5:
- case OPEN+6:
- case OPEN+7:
- case OPEN+8:
- case OPEN+9:
- n = OP(scan) - OPEN;
- reginput = locinput;
-
- regmystartp[n] = locinput; /* for REF */
- if (regmatch(next)) {
- /*
- * Don't set startp if some later
- * invocation of the same parentheses
- * already has.
- */
- if (regstartp[n] == NULL)
- regstartp[n] = locinput;
- return(1);
- } else
- return(0);
- /* NOTREACHED */
- case CLOSE+1:
- case CLOSE+2:
- case CLOSE+3:
- case CLOSE+4:
- case CLOSE+5:
- case CLOSE+6:
- case CLOSE+7:
- case CLOSE+8:
- case CLOSE+9: {
- n = OP(scan) - CLOSE;
- reginput = locinput;
-
- regmyendp[n] = locinput; /* for REF */
- if (regmatch(next)) {
- /*
- * Don't set endp if some later
- * invocation of the same parentheses
- * already has.
- */
- if (regendp[n] == NULL) {
- regendp[n] = locinput;
- *reglastparen = n;
- }
- return(1);
- } else
- return(0);
- }
- break;
- case BRANCH: {
- if (OP(next) != BRANCH) /* No choice. */
- next = NEXTOPER(scan); /* Avoid recursion. */
- else {
- do {
- reginput = locinput;
- if (regmatch(NEXTOPER(scan)))
- return(1);
-#ifdef ALIGN
- if (n = NEXT(scan))
- scan += n;
- else
- scan = NULL;
-#else
- scan = regnext(scan);
-#endif
- } while (scan != NULL && OP(scan) == BRANCH);
- return(0);
- /* NOTREACHED */
- }
- }
- break;
- case STAR:
- case PLUS:
- /*
- * Lookahead to avoid useless match attempts
- * when we know what character comes next.
- */
- if (OP(next) == EXACTLY)
- nextchar = *(OPERAND(next)+1);
- else
- nextchar = '\0';
- ln = (OP(scan) == STAR) ? 0 : 1;
- reginput = locinput;
- n = regrepeat(NEXTOPER(scan));
- while (n >= ln) {
- /* If it could work, try it. */
- if (nextchar == '\0' || *reginput == nextchar)
- if (regmatch(next))
- return(1);
- /* Couldn't or didn't -- back up. */
- n--;
- reginput = locinput + n;
- }
- return(0);
- case END:
- reginput = locinput; /* put where regtry can find it */
- return(1); /* Success! */
- default:
- printf("%x %d\n",scan,scan[1]);
- FAIL("regexp memory corruption");
- }
-
- scan = next;
- }
-
- /*
- * We get here only if there's trouble -- normally "case END" is
- * the terminating point.
- */
- FAIL("corrupted regexp pointers");
- /*NOTREACHED*/
-}
-
-/*
- - regrepeat - repeatedly match something simple, report how many
- */
-/*
- * [This routine now assumes that it will only match on things of length 1.
- * That was true before, but now we assume scan - reginput is the count,
- * rather than incrementing count on every character.]
- */
-static int
-regrepeat(p)
-char *p;
-{
- register char *scan;
- register char *opnd;
- register int c;
-
- scan = reginput;
- opnd = OPERAND(p);
- switch (OP(p)) {
- case ANY:
- while (*scan && *scan != '\n')
- scan++;
- break;
- case EXACTLY: /* length of string is 1 */
- opnd++;
- while (*opnd == *scan)
- scan++;
- break;
-#ifdef FASTANY
- case ANYOF:
- case ANYBUT:
- c = UCHARAT(scan);
- while (!(opnd[c >> 3] & (1 << (c & 7)))) {
- scan++;
- c = UCHARAT(scan);
- }
- break;
-#else
- case ANYOF:
- while (*scan != '\0' && index(opnd, *scan) != NULL)
- scan++;
- break;
- case ANYBUT:
- while (*scan != '\0' && index(opnd, *scan) == NULL)
- scan++;
- break;
-#endif /* FASTANY */
- case ALNUM:
- while (*scan && (isalpha(*scan) || isdigit(*scan) ||
- *scan == '_'))
- scan++;
- break;
- case NALNUM:
- while (*scan && (!isalpha(*scan) && !isdigit(*scan) &&
- *scan != '_'))
- scan++;
- break;
- case SPACE:
- while (*scan && isspace(*scan))
- scan++;
- break;
- case NSPACE:
- while (*scan && !isspace(*scan))
- scan++;
- break;
- case DIGIT:
- while (*scan && isdigit(*scan))
- scan++;
- break;
- case NDIGIT:
- while (*scan && !isdigit(*scan))
- scan++;
- break;
- default: /* Oh dear. Called inappropriately. */
- FAIL("internal regexp foulup");
- /* NOTREACHED */
- }
-
- c = scan - reginput;
- reginput = scan;
-
- return(c);
-}
-
-/*
- - regnext - dig the "next" pointer out of a node
- *
- * [Note, when ALIGN is defined there are two places in regmatch() that bypass
- * this code for speed.]
- */
-static char *
-regnext(p)
-register char *p;
-{
- register int offset;
-
- if (p == ®dummy)
- return(NULL);
-
- offset = NEXT(p);
- if (offset == 0)
- return(NULL);
-
-#ifdef ALIGN
- return(p+offset);
-#else
- if (OP(p) == BACK)
- return(p-offset);
- else
- return(p+offset);
-#endif
-}
-
-#ifdef DEBUG
-
-STATIC char *regprop();
-
-/*
- - regdump - dump a regexp onto stdout in vaguely comprehensible form
- */
-void
-regdump(r)
-regexp *r;
-{
- register char *s;
- register char op = EXACTLY; /* Arbitrary non-END op. */
- register char *next;
- extern char *index();
-
-
- s = r->program + 1;
- while (op != END) { /* While that wasn't END last time... */
-#ifdef ALIGN
- if (!((long)s & 1))
- s++;
-#endif
- op = OP(s);
- printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */
- next = regnext(s);
- if (next == NULL) /* Next ptr. */
- printf("(0)");
- else
- printf("(%d)", (s-r->program)+(next-s));
- s += 3;
- if (op == ANYOF || op == ANYBUT) {
- s += 32;
- }
- if (op == EXACTLY) {
- /* Literal string, where present. */
- s++;
- while (*s != '\0') {
- putchar(*s);
- s++;
- }
- s++;
- }
- putchar('\n');
- }
-
- /* Header fields of interest. */
- if (r->regstart)
- printf("start `%s' ", r->regstart->str_ptr);
- if (r->regstclass)
- printf("stclass `%s' ", regprop(OP(r->regstclass)));
- if (r->reganch)
- printf("anchored ");
- if (r->regmust != NULL)
- printf("must have \"%s\" back %d ", r->regmust->str_ptr,
- r->regback);
- printf("\n");
-}
-
-/*
- - regprop - printable representation of opcode
- */
-static char *
-regprop(op)
-char *op;
-{
- register char *p;
- static char buf[50];
-
- (void) strcpy(buf, ":");
-
- switch (OP(op)) {
- case BOL:
- p = "BOL";
- break;
- case EOL:
- p = "EOL";
- break;
- case ANY:
- p = "ANY";
- break;
- case ANYOF:
- p = "ANYOF";
- break;
- case ANYBUT:
- p = "ANYBUT";
- break;
- case BRANCH:
- p = "BRANCH";
- break;
- case EXACTLY:
- p = "EXACTLY";
- break;
- case NOTHING:
- p = "NOTHING";
- break;
- case BACK:
- p = "BACK";
- break;
- case END:
- p = "END";
- break;
- case ALNUM:
- p = "ALNUM";
- break;
- case NALNUM:
- p = "NALNUM";
- break;
- case BOUND:
- p = "BOUND";
- break;
- case NBOUND:
- p = "NBOUND";
- break;
- case SPACE:
- p = "SPACE";
- break;
- case NSPACE:
- p = "NSPACE";
- break;
- case DIGIT:
- p = "DIGIT";
- break;
- case NDIGIT:
- p = "NDIGIT";
- break;
- case REF:
- case REF+1:
- case REF+2:
- case REF+3:
- case REF+4:
- case REF+5:
- case REF+6:
- case REF+7:
- case REF+8:
- case REF+9:
- sprintf(buf+strlen(buf), "REF%d", OP(op)-REF);
- p = NULL;
- break;
- case OPEN+1:
- case OPEN+2:
- case OPEN+3:
- case OPEN+4:
- case OPEN+5:
- case OPEN+6:
- case OPEN+7:
- case OPEN+8:
- case OPEN+9:
- sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
- p = NULL;
- break;
- case CLOSE+1:
- case CLOSE+2:
- case CLOSE+3:
- case CLOSE+4:
- case CLOSE+5:
- case CLOSE+6:
- case CLOSE+7:
- case CLOSE+8:
- case CLOSE+9:
- sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
- p = NULL;
- break;
- case STAR:
- p = "STAR";
- break;
- case PLUS:
- p = "PLUS";
- break;
- default:
- FAIL("corrupted regexp opcode");
- }
- if (p != NULL)
- (void) strcat(buf, p);
- return(buf);
-}
-#endif
-
-#ifdef NOTDEF
-/*
- * The following is provided for those people who do not have strcspn() in
- * their C libraries. They should get off their butts and do something
- * about it; at least one public-domain implementation of those (highly
- * useful) string routines has been published on Usenet.
- */
-#ifndef STRCSPN
-/*
- * strcspn - find length of initial segment of s1 consisting entirely
- * of characters not from s2
- */
-
-static int
-strcspn(s1, s2)
-char *s1;
-char *s2;
-{
- register char *scan1;
- register char *scan2;
- register int count;
-
- count = 0;
- for (scan1 = s1; *scan1 != '\0'; scan1++) {
- for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */
- if (*scan1 == *scan2++)
- return(count);
- count++;
- }
- return(count);
-}
-#endif
-#endif /* NOTDEF */
-
-regfree(r)
-struct regexp *r;
-{
- if (r->precomp)
- safefree(r->precomp);
- if (r->subbase)
- safefree(r->subbase);
- if (r->regmust)
- str_free(r->regmust);
- if (r->regstart)
- str_free(r->regstart);
- safefree((char*)r);
-}
* not the System V one.
*/
-/* $Header: regexp.h,v 2.0 88/06/05 00:10:53 root Exp $
+/* $Header: regexp.h,v 3.0 89/10/18 15:22:46 lwall Locked $
*
* $Log: regexp.h,v $
- * Revision 2.0 88/06/05 00:10:53 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:22:46 lwall
+ * 3.0 baseline
*
*/
-#define ALIGN
-
#define NSUBEXP 10
typedef struct regexp {
char program[1]; /* Unwarranted chumminess with compiler. */
} regexp;
-extern regexp *regcomp();
-extern int regexec();
-extern void regsub();
-extern void regerror();
+regexp *regcomp();
+int regexec();
--- /dev/null
+#!./perl
+
+$pat = 'S n C4 x8';
+$inet = 2;
+$echo = 7;
+$smtp = 25;
+$nntp = 119;
+
+$this = pack($pat,$inet,2345, 0,0,0,0);
+select(NS); $| = 1; select(stdout);
+
+if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; }
+if (bind(S,$this)) { print "bind ok\n"; } else { die $!; }
+if (listen(S,5)) { print "listen ok\n"; } else { die $!; }
+for (;;) {
+ print "Listening again\n";
+ if ($addr = accept(NS,S)) { print "accept ok\n"; } else { die $!; }
+
+ @ary = unpack($pat,$addr);
+ $, = ' ';
+ print @ary; print "\n";
+
+ while (<NS>) {
+ print;
+ print NS;
+ }
+}
-/* $Header: spat.h,v 2.0 88/06/05 00:10:58 root Exp $
+/* $Header: spat.h,v 3.0 89/10/18 15:23:14 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: spat.h,v $
- * Revision 2.0 88/06/05 00:10:58 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:23:14 lwall
+ * 3.0 baseline
*
*/
};
#define SPAT_USED 1 /* spat has been used once already */
-#define SPAT_ONCE 2 /* use pattern only once per article */
+#define SPAT_ONCE 2 /* use pattern only once per reset */
#define SPAT_SCANFIRST 4 /* initial constant not anchored */
#define SPAT_ALL 8 /* initial constant is whole pat */
#define SPAT_SKIPWHITE 16 /* skip leading whitespace for split */
#define SPAT_FOLD 32 /* case insensitivity */
+#define SPAT_CONST 64 /* subst replacement is constant */
+#define SPAT_KEEP 128 /* keep 1st runtime pattern forever */
-EXT SPAT *spat_root; /* list of all spats */
EXT SPAT *curspat; /* what to do \ interps from */
EXT SPAT *lastspat; /* what to use in place of null pattern */
-/* $Header: stab.c,v 2.0 88/06/05 00:11:01 root Exp $
+/* $Header: stab.c,v 3.0 89/10/18 15:23: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: stab.c,v $
- * Revision 2.0 88/06/05 00:11:01 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:23:23 lwall
+ * 3.0 baseline
*
*/
#include <signal.h>
+/* This oughta be generated by Configure. */
+
static char *sig_name[] = {
- "",
- "HUP",
- "INT",
- "QUIT",
- "ILL",
- "TRAP",
- "IOT",
- "EMT",
- "FPE",
- "KILL",
- "BUS",
- "SEGV",
- "SYS",
- "PIPE",
- "ALRM",
- "TERM",
- "???"
-#ifdef SIGTSTP
- ,"STOP",
- "TSTP",
- "CONT",
- "CHLD",
- "TTIN",
- "TTOU",
- "TINT",
- "XCPU",
- "XFSZ"
-#ifdef SIGPROF
- ,"VTALARM",
- "PROF"
-#ifdef SIGWINCH
- ,"WINCH"
-#ifdef SIGLOST
- ,"LOST"
-#ifdef SIGUSR1
- ,"USR1"
-#endif
-#ifdef SIGUSR2
- ,"USR2"
-#endif /* SIGUSR2 */
-#endif /* SIGLOST */
-#endif /* SIGWINCH */
-#endif /* SIGPROF */
-#endif /* SIGTSTP */
- ,0
- };
+ SIG_NAME,0
+};
extern int errno;
extern int sys_nerr;
extern char *sys_errlist[];
STR *
-stab_str(stab)
-STAB *stab;
+stab_str(str)
+STR *str;
{
+ STAB *stab = str->str_u.str_stab;
register int paren;
register char *s;
register int i;
- switch (*stab->stab_name) {
+ if (str->str_rare)
+ return stab_val(stab);
+
+ switch (*stab->str_magic->str_ptr) {
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
if (curspat) {
- paren = atoi(stab->stab_name);
+ paren = atoi(stab_name(stab));
getparen:
if (curspat->spat_regexp &&
paren <= curspat->spat_regexp->nparens &&
(s = curspat->spat_regexp->startp[paren]) ) {
i = curspat->spat_regexp->endp[paren] - s;
if (i >= 0)
- str_nset(stab->stab_val,s,i);
+ str_nset(stab_val(stab),s,i);
else
- str_nset(stab->stab_val,"",0);
+ str_sset(stab_val(stab),&str_undef);
}
else
- str_nset(stab->stab_val,"",0);
+ str_sset(stab_val(stab),&str_undef);
}
break;
case '+':
goto getparen;
}
break;
+ case '`':
+ if (curspat) {
+ if (curspat->spat_regexp &&
+ (s = curspat->spat_regexp->subbase) ) {
+ i = curspat->spat_regexp->startp[0] - s;
+ if (i >= 0)
+ str_nset(stab_val(stab),s,i);
+ else
+ str_nset(stab_val(stab),"",0);
+ }
+ else
+ str_nset(stab_val(stab),"",0);
+ }
+ break;
+ case '\'':
+ if (curspat) {
+ if (curspat->spat_regexp &&
+ (s = curspat->spat_regexp->endp[0]) ) {
+ str_set(stab_val(stab),s);
+ }
+ else
+ str_nset(stab_val(stab),"",0);
+ }
+ break;
case '.':
+#ifndef lint
if (last_in_stab) {
- str_numset(stab->stab_val,(double)last_in_stab->stab_io->lines);
+ str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
}
+#endif
break;
case '?':
- str_numset(stab->stab_val,(double)statusvalue);
+ str_numset(stab_val(stab),(double)statusvalue);
break;
case '^':
- s = curoutstab->stab_io->top_name;
- str_set(stab->stab_val,s);
+ s = stab_io(curoutstab)->top_name;
+ str_set(stab_val(stab),s);
break;
case '~':
- s = curoutstab->stab_io->fmt_name;
- str_set(stab->stab_val,s);
+ s = stab_io(curoutstab)->fmt_name;
+ str_set(stab_val(stab),s);
break;
+#ifndef lint
case '=':
- str_numset(stab->stab_val,(double)curoutstab->stab_io->page_len);
+ str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
break;
case '-':
- str_numset(stab->stab_val,(double)curoutstab->stab_io->lines_left);
+ str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
break;
case '%':
- str_numset(stab->stab_val,(double)curoutstab->stab_io->page);
+ str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
break;
+#endif
case '/':
*tokenbuf = record_separator;
tokenbuf[1] = '\0';
- str_set(stab->stab_val,tokenbuf);
+ str_nset(stab_val(stab),tokenbuf,rslen);
break;
case '[':
- str_numset(stab->stab_val,(double)arybase);
+ str_numset(stab_val(stab),(double)arybase);
break;
case '|':
- str_numset(stab->stab_val,
- (double)((curoutstab->stab_io->flags & IOF_FLUSH) != 0) );
+ str_numset(stab_val(stab),
+ (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
break;
case ',':
- str_set(stab->stab_val,ofs);
+ str_nset(stab_val(stab),ofs,ofslen);
break;
case '\\':
- str_set(stab->stab_val,ors);
+ str_nset(stab_val(stab),ors,orslen);
break;
case '#':
- str_set(stab->stab_val,ofmt);
+ str_set(stab_val(stab),ofmt);
break;
case '!':
- str_numset(stab->stab_val, (double)errno);
- str_set(stab->stab_val,
+ str_numset(stab_val(stab), (double)errno);
+ str_set(stab_val(stab),
errno < 0 || errno > sys_nerr ? "(unknown)" : sys_errlist[errno]);
- stab->stab_val->str_nok = 1; /* what a wonderful hack! */
+ stab_val(stab)->str_nok = 1; /* what a wonderful hack! */
break;
case '<':
- str_numset(stab->stab_val,(double)uid);
+ str_numset(stab_val(stab),(double)uid);
break;
case '>':
- str_numset(stab->stab_val,(double)euid);
+ str_numset(stab_val(stab),(double)euid);
break;
case '(':
- s = tokenbuf;
- sprintf(s,"%d",(int)getgid());
+ s = buf;
+ (void)sprintf(s,"%d",(int)gid);
goto add_groups;
case ')':
- s = tokenbuf;
- sprintf(s,"%d",(int)getegid());
+ s = buf;
+ (void)sprintf(s,"%d",(int)egid);
add_groups:
while (*s) s++;
#ifdef GETGROUPS
i = getgroups(NGROUPS,gary);
while (--i >= 0) {
- sprintf(s," %ld", (long)gary[i]);
+ (void)sprintf(s," %ld", (long)gary[i]);
while (*s) s++;
}
}
#endif
- str_set(stab->stab_val,tokenbuf);
+ str_set(stab_val(stab),buf);
break;
}
- return stab->stab_val;
+ return stab_val(stab);
}
-stabset(stab,str)
-register STAB *stab;
+stabset(mstr,str)
+register STR *mstr;
STR *str;
{
+ STAB *stab = mstr->str_u.str_stab;
char *s;
int i;
int sighandler();
- if (stab->stab_flags & SF_VMAGIC) {
- switch (stab->stab_name[0]) {
+ switch (mstr->str_rare) {
+ case 'E':
+ setenv(mstr->str_ptr,str_get(str));
+ /* And you'll never guess what the dog had */
+ break; /* in its mouth... */
+ case 'S':
+ s = str_get(str);
+ i = whichsig(mstr->str_ptr); /* ...no, a brick */
+ if (strEQ(s,"IGNORE"))
+#ifndef lint
+ (void)signal(i,SIG_IGN);
+#else
+ ;
+#endif
+ else if (strEQ(s,"DEFAULT") || !*s)
+ (void)signal(i,SIG_DFL);
+ else
+ (void)signal(i,sighandler);
+ break;
+#ifdef SOME_DBM
+ case 'D':
+ hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
+ break;
+#endif
+ case '#':
+ afill(stab_array(stab), (int)str_gnum(str) - arybase);
+ break;
+ case 'X': /* merely a copy of a * string */
+ break;
+ case '*':
+ s = str_get(str);
+ if (strnNE(s,"Stab",4) || str->str_cur != sizeof(STBP)) {
+ if (!*s) {
+ STBP *stbp;
+
+ (void)savenostab(stab); /* schedule a free of this stab */
+ if (stab->str_len)
+ Safefree(stab->str_ptr);
+ Newz(601,stbp, 1, STBP);
+ stab->str_ptr = stbp;
+ stab->str_len = stab->str_cur = sizeof(STBP);
+ stab->str_pok = 1;
+ strncpy(stab_magic(stab),"Stab",4);
+ stab_val(stab) = Str_new(70,0);
+ stab_line(stab) = line;
+ }
+ else
+ stab = stabent(s,TRUE);
+ str_sset(str,stab);
+ }
+ break;
+ case 's': {
+ struct lstring *lstr = (struct lstring*)str;
+
+ mstr->str_rare = 0;
+ str->str_magic = Nullstr;
+ str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
+ str->str_ptr,str->str_cur);
+ }
+ break;
+
+ case 'v':
+ do_vecset(mstr,str);
+ break;
+
+ case 0:
+ switch (*stab->str_magic->str_ptr) {
case '^':
- safefree(curoutstab->stab_io->top_name);
- curoutstab->stab_io->top_name = s = savestr(str_get(str));
- curoutstab->stab_io->top_stab = stabent(s,TRUE);
+ Safefree(stab_io(curoutstab)->top_name);
+ stab_io(curoutstab)->top_name = s = savestr(str_get(str));
+ stab_io(curoutstab)->top_stab = stabent(s,TRUE);
break;
case '~':
- safefree(curoutstab->stab_io->fmt_name);
- curoutstab->stab_io->fmt_name = s = savestr(str_get(str));
- curoutstab->stab_io->fmt_stab = stabent(s,TRUE);
+ Safefree(stab_io(curoutstab)->fmt_name);
+ stab_io(curoutstab)->fmt_name = s = savestr(str_get(str));
+ stab_io(curoutstab)->fmt_stab = stabent(s,TRUE);
break;
case '=':
- curoutstab->stab_io->page_len = (long)str_gnum(str);
+ stab_io(curoutstab)->page_len = (long)str_gnum(str);
break;
case '-':
- curoutstab->stab_io->lines_left = (long)str_gnum(str);
+ stab_io(curoutstab)->lines_left = (long)str_gnum(str);
+ if (stab_io(curoutstab)->lines_left < 0L)
+ stab_io(curoutstab)->lines_left = 0L;
break;
case '%':
- curoutstab->stab_io->page = (long)str_gnum(str);
+ stab_io(curoutstab)->page = (long)str_gnum(str);
break;
case '|':
- curoutstab->stab_io->flags &= ~IOF_FLUSH;
+ stab_io(curoutstab)->flags &= ~IOF_FLUSH;
if (str_gnum(str) != 0.0) {
- curoutstab->stab_io->flags |= IOF_FLUSH;
+ stab_io(curoutstab)->flags |= IOF_FLUSH;
}
break;
case '*':
- multiline = (int)str_gnum(str) != 0;
+ i = (int)str_gnum(str);
+ multiline = (i != 0);
break;
case '/':
record_separator = *str_get(str);
+ rslen = str->str_cur;
break;
case '\\':
if (ors)
- safefree(ors);
+ Safefree(ors);
ors = savestr(str_get(str));
+ orslen = str->str_cur;
break;
case ',':
if (ofs)
- safefree(ofs);
+ Safefree(ofs);
ofs = savestr(str_get(str));
+ ofslen = str->str_cur;
break;
case '#':
if (ofmt)
- safefree(ofmt);
+ Safefree(ofmt);
ofmt = savestr(str_get(str));
break;
case '[':
errno = (int)str_gnum(str); /* will anyone ever use this? */
break;
case '<':
-#ifdef SETRUID
uid = (int)str_gnum(str);
- if (setruid(uid) < 0)
+#ifdef SETREUID
+ if (delaymagic) {
+ delaymagic |= DM_REUID;
+ break; /* don't do magic till later */
+ }
+#endif /* SETREUID */
+#ifdef SETRUID
+ if (setruid((UIDTYPE)uid) < 0)
+ uid = (int)getuid();
+#else
+#ifdef SETREUID
+ if (setreuid((UIDTYPE)uid, (UIDTYPE)-1) < 0)
uid = (int)getuid();
#else
fatal("setruid() not implemented");
#endif
+#endif
break;
case '>':
-#ifdef SETEUID
euid = (int)str_gnum(str);
- if (seteuid(euid) < 0)
+#ifdef SETREUID
+ if (delaymagic) {
+ delaymagic |= DM_REUID;
+ break; /* don't do magic till later */
+ }
+#endif /* SETREUID */
+#ifdef SETEUID
+ if (seteuid((UIDTYPE)euid) < 0)
+ euid = (int)geteuid();
+#else
+#ifdef SETREUID
+ if (setreuid((UIDTYPE)-1, (UIDTYPE)euid) < 0)
euid = (int)geteuid();
#else
fatal("seteuid() not implemented");
#endif
+#endif
break;
case '(':
+ gid = (int)str_gnum(str);
+#ifdef SETREGID
+ if (delaymagic) {
+ delaymagic |= DM_REGID;
+ break; /* don't do magic till later */
+ }
+#endif /* SETREGID */
#ifdef SETRGID
- setrgid((int)str_gnum(str));
+ (void)setrgid((GIDTYPE)gid);
+#else
+#ifdef SETREGID
+ (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
#else
fatal("setrgid() not implemented");
#endif
+#endif
break;
case ')':
+ egid = (int)str_gnum(str);
+#ifdef SETREGID
+ if (delaymagic) {
+ delaymagic |= DM_REGID;
+ break; /* don't do magic till later */
+ }
+#endif /* SETREGID */
#ifdef SETEGID
- setegid((int)str_gnum(str));
+ (void)setegid((GIDTYPE)egid);
+#else
+#ifdef SETREGID
+ (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
#else
fatal("setegid() not implemented");
#endif
+#endif
+ break;
+ case ':':
+ chopset = str_get(str);
break;
- case '.':
- case '+':
- case '&':
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- break; /* "read-only" registers */
}
- }
- else if (stab == envstab && envname) {
- setenv(envname,str_get(str));
- /* And you'll never guess what the dog had */
- safefree(envname); /* in its mouth... */
- envname = Nullch;
- }
- else if (stab == sigstab && signame) {
- s = str_get(str);
- i = whichsig(signame); /* ...no, a brick */
- if (strEQ(s,"IGNORE"))
- signal(i,SIG_IGN);
- else if (strEQ(s,"DEFAULT") || !*s)
- signal(i,SIG_DFL);
- else
- signal(i,sighandler);
- safefree(signame);
- signame = Nullch;
- }
- else if (stab->stab_array) {
- afill(stab->stab_array, (int)str_gnum(str) - arybase);
+ break;
}
}
for (sigv = sig_name+1; *sigv; sigv++)
if (strEQ(sig,*sigv))
return sigv - sig_name;
+#ifdef SIGCLD
+ if (strEQ(sig,"CHLD"))
+ return SIGCLD;
+#endif
+#ifdef SIGCHLD
+ if (strEQ(sig,"CLD"))
+ return SIGCHLD;
+#endif
return 0;
}
STR *str;
char *oldfile = filename;
int oldsave = savestack->ary_fill;
+ ARRAY *oldstack = stack;
SUBR *sub;
- stab = stabent(str_get(hfetch(sigstab->stab_hash,sig_name[sig])),TRUE);
- sub = stab->stab_sub;
+ stab = stabent(
+ str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
+ TRUE)), TRUE);
+ sub = stab_sub(stab);
+ if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
+ if (sig_name[sig][1] == 'H')
+ stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)),
+ TRUE);
+ else
+ stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)),
+ TRUE);
+ sub = stab_sub(stab); /* gag */
+ }
if (!sub) {
if (dowarn)
warn("SIG%s handler \"%s\" not defined.\n",
- sig_name[sig], stab->stab_name );
+ sig_name[sig], stab_name(stab) );
return;
}
- savearray = defstab->stab_array;
- defstab->stab_array = anew(defstab);
- str = str_new(0);
+ savearray = stab_xarray(defstab);
+ stab_xarray(defstab) = stack = anew(defstab);
+ stack->ary_flags = 0;
+ str = Str_new(71,0);
str_set(str,sig_name[sig]);
- apush(defstab->stab_array,str);
+ (void)apush(stab_xarray(defstab),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);
+ warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
}
filename = sub->filename;
- str = cmd_exec(sub->cmd); /* so do it already */
+ (void)cmd_exec(sub->cmd,G_SCALAR,1); /* so do it already */
sub->depth--; /* assuming no longjumps out of here */
- afree(defstab->stab_array); /* put back old $_[] */
- defstab->stab_array = savearray;
+ str_free(stack->ary_array[0]); /* free the one real string */
+ afree(stab_xarray(defstab)); /* put back old $_[] */
+ stab_xarray(defstab) = savearray;
+ stack = oldstack;
filename = oldfile;
if (savestack->ary_fill > oldsave)
restorelist(oldsave);
}
-char *
-reg_get(name)
-char *name;
-{
- return STAB_GET(stabent(name,TRUE));
-}
-
-#ifdef NOTUSED
-reg_set(name,value)
-char *name;
-char *value;
-{
- str_set(STAB_STR(stabent(name,TRUE)),value);
-}
-#endif
-
STAB *
aadd(stab)
register STAB *stab;
{
- if (!stab->stab_array)
- stab->stab_array = anew(stab);
+ if (!stab_xarray(stab))
+ stab_xarray(stab) = anew(stab);
return stab;
}
hadd(stab)
register STAB *stab;
{
- if (!stab->stab_hash)
- stab->stab_hash = hnew();
+ if (!stab_xhash(stab))
+ stab_xhash(stab) = hnew(COEFFSIZE);
return stab;
}
int add;
{
register STAB *stab;
+ register STBP *stbp;
+ int len;
+ register char *namend;
+ HASH *stash;
+ char *sawquote = Nullch;
+ char *prevquote = Nullch;
+ bool global = FALSE;
- for (stab = stab_index[*name]; stab; stab = stab->stab_next) {
- if (strEQ(name,stab->stab_name)) {
- stab->stab_flags |= SF_MULTI; /* is okay, probably */
- return stab;
+ if (isascii(*name) && isupper(*name)) {
+ if (*name > 'I') {
+ if (*name == 'S' && (
+ strEQ(name, "SIG") ||
+ strEQ(name, "STDIN") ||
+ strEQ(name, "STDOUT") ||
+ strEQ(name, "STDERR") ))
+ global = TRUE;
}
+ else if (*name > 'E') {
+ if (*name == 'I' && strEQ(name, "INC"))
+ global = TRUE;
+ }
+ else if (*name >= 'A') {
+ if (*name == 'E' && strEQ(name, "ENV"))
+ global = TRUE;
+ }
+ else if (*name == 'A' && (
+ strEQ(name, "ARGV") ||
+ strEQ(name, "ARGVOUT") ))
+ global = TRUE;
+ }
+ for (namend = name; *namend; namend++) {
+ if (*namend == '\'' && namend[1])
+ prevquote = sawquote, sawquote = namend;
+ }
+ if (sawquote == name && name[1]) {
+ stash = defstash;
+ sawquote = Nullch;
+ name++;
+ }
+ else if (!isalpha(*name) || global)
+ stash = defstash;
+ else
+ stash = curstash;
+ if (sawquote) {
+ char tmpbuf[256];
+ char *s, *d;
+
+ *sawquote = '\0';
+ if (s = prevquote) {
+ strncpy(tmpbuf,name,s-name+1);
+ d = tmpbuf+(s-name+1);
+ *d++ = '_';
+ strcpy(d,s+1);
+ }
+ else {
+ *tmpbuf = '_';
+ strcpy(tmpbuf+1,name);
+ }
+ stab = stabent(tmpbuf,TRUE);
+ if (!(stash = stab_xhash(stab)))
+ stash = stab_xhash(stab) = hnew(0);
+ name = sawquote+1;
+ *sawquote = '\'';
}
-
- /* no entry--should we add one? */
-
- if (add) {
- stab = (STAB *) safemalloc(sizeof(STAB));
- bzero((char*)stab, sizeof(STAB));
- stab->stab_name = savestr(name);
- stab->stab_val = str_new(0);
- stab->stab_next = stab_index[*name];
- stab_index[*name] = stab;
+ len = namend - name;
+ stab = (STAB*)hfetch(stash,name,len,add);
+ if (!stab)
+ return Nullstab;
+ if (stab->str_pok) {
+ stab->str_pok |= SP_MULTI;
+ return stab;
+ }
+ else {
+ if (stab->str_len)
+ Safefree(stab->str_ptr);
+ Newz(602,stbp, 1, STBP);
+ stab->str_ptr = stbp;
+ stab->str_len = stab->str_cur = sizeof(STBP);
+ stab->str_pok = 1;
+ strncpy(stab_magic(stab),"Stab",4);
+ stab_val(stab) = Str_new(72,0);
+ stab_line(stab) = line;
+ str_magic(stab,stab,'*',name,len);
return stab;
}
- return Nullstab;
}
STIO *
stio_new()
{
- STIO *stio = (STIO *) safemalloc(sizeof(STIO));
+ STIO *stio;
- bzero((char*)stio, sizeof(STIO));
+ Newz(603,stio,1,STIO);
stio->page_len = 60;
return stio;
}
int min;
register int max;
{
+ register HENT *entry;
register int i;
register STAB *stab;
for (i = min; i <= max; i++) {
- for (stab = stab_index[i]; stab; stab = stab->stab_next) {
- if (stab->stab_flags & SF_MULTI)
- continue;
- if (i == 'A' && strEQ(stab->stab_name, "ARGV"))
- continue;
- if (i == 'E' && strEQ(stab->stab_name, "ENV"))
+ for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
+ stab = (STAB*)entry->hent_val;
+ if (stab->str_pok & SP_MULTI)
continue;
- if (i == 'S' && strEQ(stab->stab_name, "SIG"))
- continue;
- if (i == 'I' && strEQ(stab->stab_name, "INC"))
- continue;
- warn("Possible typo: %s,", stab->stab_name);
+ line = stab_line(stab);
+ warn("Possible typo: \"%s\"", stab_name(stab));
}
}
}
+
+static int gensym = 0;
+
+STAB *
+genstab()
+{
+ (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
+ return stabent(tokenbuf,TRUE);
+}
+
+/* hopefully this is only called on local symbol table entries */
+
+void
+stab_clear(stab)
+register STAB *stab;
+{
+ STIO *stio;
+ SUBR *sub;
+
+ afree(stab_xarray(stab));
+ (void)hfree(stab_xhash(stab));
+ str_free(stab_val(stab));
+ if (stio = stab_io(stab)) {
+ do_close(stab,FALSE);
+ Safefree(stio->top_name);
+ Safefree(stio->fmt_name);
+ }
+ if (sub = stab_sub(stab)) {
+ afree(sub->tosave);
+ cmd_free(sub->cmd);
+ }
+ Safefree(stab->str_ptr);
+ stab->str_ptr = Null(STBP*);
+ stab->str_len = 0;
+ stab->str_cur = 0;
+}
+
-/* $Header: stab.h,v 2.0 88/06/05 00:11:05 root Exp $
+/* $Header: stab.h,v 3.0 89/10/18 15:23: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: stab.h,v $
- * Revision 2.0 88/06/05 00:11:05 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:23:30 lwall
+ * 3.0 baseline
*
*/
-struct stab {
- struct stab *stab_next;
- char *stab_name;
- STR *stab_val;
- struct stio *stab_io;
- FCMD *stab_form;
- ARRAY *stab_array;
- HASH *stab_hash;
- SUBR *stab_sub;
- char stab_flags;
+struct stabptrs {
+ char stbp_magic[4];
+ STR *stbp_val; /* scalar value */
+ struct stio *stbp_io; /* filehandle value */
+ FCMD *stbp_form; /* format value */
+ ARRAY *stbp_array; /* array value */
+ HASH *stbp_hash; /* associative array value */
+ SUBR *stbp_sub; /* subroutine value */
+ int stbp_lastexpr; /* used by nothing_in_common() */
+ line_t stbp_line; /* line first declared at (for -w) */
+ char stbp_flags;
};
+#define stab_magic(stab) (((STBP*)(stab->str_ptr))->stbp_magic)
+#define stab_val(stab) (((STBP*)(stab->str_ptr))->stbp_val)
+#define stab_io(stab) (((STBP*)(stab->str_ptr))->stbp_io)
+#define stab_form(stab) (((STBP*)(stab->str_ptr))->stbp_form)
+#define stab_xarray(stab) (((STBP*)(stab->str_ptr))->stbp_array)
+#define stab_array(stab) (((STBP*)(stab->str_ptr))->stbp_array ? \
+ ((STBP*)(stab->str_ptr))->stbp_array : \
+ ((STBP*)(aadd(stab)->str_ptr))->stbp_array)
+#define stab_xhash(stab) (((STBP*)(stab->str_ptr))->stbp_hash)
+#define stab_hash(stab) (((STBP*)(stab->str_ptr))->stbp_hash ? \
+ ((STBP*)(stab->str_ptr))->stbp_hash : \
+ ((STBP*)(hadd(stab)->str_ptr))->stbp_hash)
+#define stab_sub(stab) (((STBP*)(stab->str_ptr))->stbp_sub)
+#define stab_lastexpr(stab) (((STBP*)(stab->str_ptr))->stbp_lastexpr)
+#define stab_line(stab) (((STBP*)(stab->str_ptr))->stbp_line)
+#define stab_flags(stab) (((STBP*)(stab->str_ptr))->stbp_flags)
+#define stab_name(stab) (stab->str_magic->str_ptr)
+
#define SF_VMAGIC 1 /* call routine to dereference STR val */
#define SF_MULTI 2 /* seen more than once */
struct stio {
- FILE *fp;
- long lines;
- long page;
- long page_len;
- long lines_left;
- char *top_name;
- STAB *top_stab;
- char *fmt_name;
- STAB *fmt_stab;
- short subprocess;
+ FILE *ifp; /* ifp and ofp are normally the same */
+ FILE *ofp; /* but sockets need separate streams */
+#if defined(I_DIRENT) || defined(I_SYSDIR)
+ DIR *dirp; /* for opendir, readdir, etc */
+#endif
+ long lines; /* $. */
+ long page; /* $% */
+ long page_len; /* $= */
+ long lines_left; /* $- */
+ char *top_name; /* $^ */
+ STAB *top_stab; /* $^ */
+ char *fmt_name; /* $~ */
+ STAB *fmt_stab; /* $~ */
+ short subprocess; /* -| or |- */
char type;
char flags;
};
#define Nullstab Null(STAB*)
-#define STAB_STR(s) (tmpstab = (s), tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val)
-#define STAB_GET(s) (tmpstab = (s), str_get(tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val))
-#define STAB_GNUM(s) (tmpstab = (s), str_gnum(tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val))
+#define STAB_STR(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_str(stab_val(tmpstab)->str_magic) : stab_val(tmpstab))
+#define STAB_GET(s) (tmpstab = (s), str_get(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
+#define STAB_GNUM(s) (tmpstab = (s), str_gnum(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
EXT STAB *tmpstab;
EXT STAB *stab_index[128];
-EXT char *envname; /* place for ENV name being assigned--gross cheat */
-EXT char *signame; /* place for SIG name being assigned--gross cheat */
-
EXT unsigned short statusvalue;
+EXT int delaymagic INIT(0);
+#define DM_DELAY 1
+#define DM_REUID 2
+#define DM_REGID 4
+
STAB *aadd();
STAB *hadd();
-/* $Header: str.c,v 2.0.1.1 88/06/28 16:38:11 root Exp $
+/* $Header: str.c,v 3.0 89/10/18 15:23:38 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: str.c,v $
- * Revision 2.0.1.1 88/06/28 16:38:11 root
- * patch1: autoincrement of '' didn't work right.
- *
- * Revision 2.0 88/06/05 00:11:07 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:23:38 lwall
+ * 3.0 baseline
*
*/
#include "EXTERN.h"
#include "perl.h"
+#include "perly.h"
-str_reset(s)
-register char *s;
+extern char **environ;
+
+#ifndef str_get
+char *
+str_get(str)
+STR *str;
{
- register STAB *stab;
- register STR *str;
- register int i;
- register int max;
- register SPAT *spat;
+#ifdef TAINT
+ tainted |= str->str_tainted;
+#endif
+ return str->str_pok ? str->str_ptr : str_2ptr(str);
+}
+#endif
- if (!*s) { /* reset ?? searches */
- for (spat = spat_root; spat != Nullspat; spat = spat->spat_next) {
- spat->spat_flags &= ~SPAT_USED;
+/* dlb ... guess we have a "crippled cc".
+ * dlb the following functions are usually macros.
+ */
+#ifndef str_true
+str_true(Str)
+STR *Str;
+{
+ if (Str->str_pok) {
+ if (*Str->str_ptr > '0' ||
+ Str->str_cur > 1 ||
+ (Str->str_cur && *Str->str_ptr != '0'))
+ return 1;
+ return 0;
}
- return;
- }
+ if (Str->str_nok)
+ return (Str->str_u.str_nval != 0.0);
+ return 0;
+}
+#endif /* str_true */
- /* reset variables */
+#ifndef str_gnum
+double str_gnum(Str)
+STR *Str;
+{
+#ifdef TAINT
+ tainted |= Str->str_tainted;
+#endif /* TAINT*/
+ if (Str->str_nok)
+ return Str->str_u.str_nval;
+ return str_2num(Str);
+}
+#endif /* str_gnum */
+/* dlb ... end of crutch */
- while (*s) {
- i = *s;
- if (s[1] == '-') {
- s += 2;
- }
- max = *s++;
- for ( ; i <= max; i++) {
- for (stab = stab_index[i]; stab; stab = stab->stab_next) {
- str = stab->stab_val;
- str->str_cur = 0;
- str->str_nok = 0;
- if (str->str_ptr != Nullch)
- str->str_ptr[0] = '\0';
- if (stab->stab_array) {
- aclear(stab->stab_array);
- }
- if (stab->stab_hash) {
- hclear(stab->stab_hash);
- }
- }
- }
+char *
+str_grow(str,newlen)
+register STR *str;
+register int newlen;
+{
+ register char *s = str->str_ptr;
+
+ if (str->str_state == SS_INCR) { /* data before str_ptr? */
+ str->str_len += str->str_u.str_useful;
+ str->str_ptr -= str->str_u.str_useful;
+ str->str_u.str_useful = 0L;
+ bcopy(s, str->str_ptr, str->str_cur+1);
+ s = str->str_ptr;
+ str->str_state = SS_NORM; /* normal again */
+ if (newlen > str->str_len)
+ newlen += 10 * (newlen - str->str_cur); /* avoid copy each time */
+ }
+ if (newlen > str->str_len) { /* need more room? */
+ if (str->str_len)
+ Renew(s,newlen,char);
+ else
+ New(703,s,newlen,char);
+ str->str_ptr = s;
+ str->str_len = newlen;
}
+ return s;
}
str_numset(str,num)
register STR *str;
double num;
{
- str->str_nval = num;
- str->str_pok = 0; /* invalidate pointer */
- str->str_nok = 1; /* validate number */
+ str->str_u.str_nval = num;
+ str->str_state = SS_NORM;
+ str->str_pok = 0; /* invalidate pointer */
+ str->str_nok = 1; /* validate number */
+#ifdef TAINT
+ str->str_tainted = tainted;
+#endif
}
extern int errno;
if (!str)
return "";
- GROWSTR(&(str->str_ptr), &(str->str_len), 24);
- s = str->str_ptr;
if (str->str_nok) {
+ STR_GROW(str, 24);
+ s = str->str_ptr;
olderrno = errno; /* some Xenix systems wipe out errno here */
#if defined(scs) && defined(ns32000)
- gcvt(str->str_nval,20,s);
+ gcvt(str->str_u.str_nval,20,s);
#else
#ifdef apollo
- if (str->str_nval == 0.0)
- strcpy(s,"0");
+ if (str->str_u.str_nval == 0.0)
+ (void)strcpy(s,"0");
else
#endif /*apollo*/
- sprintf(s,"%.20g",str->str_nval);
+ (void)sprintf(s,"%.20g",str->str_u.str_nval);
#endif /*scs*/
errno = olderrno;
while (*s) s++;
}
- else if (dowarn)
- warn("Use of uninitialized variable");
+ else {
+ if (str == &str_undef)
+ return No;
+ if (dowarn)
+ warn("Use of uninitialized variable");
+ STR_GROW(str, 24);
+ s = str->str_ptr;
+ }
*s = '\0';
str->str_cur = s - str->str_ptr;
str->str_pok = 1;
{
if (!str)
return 0.0;
+ str->str_state = SS_NORM;
if (str->str_len && str->str_pok)
- str->str_nval = atof(str->str_ptr);
- else {
+ str->str_u.str_nval = atof(str->str_ptr);
+ else {
+ if (str == &str_undef)
+ return 0.0;
if (dowarn)
- fprintf(stderr,"Use of uninitialized variable in %s line %ld.\n",
- filename,(long)line);
- str->str_nval = 0.0;
+ warn("Use of uninitialized variable");
+ str->str_u.str_nval = 0.0;
}
str->str_nok = 1;
#ifdef DEBUGGING
if (debug & 32)
- fprintf(stderr,"0x%lx num(%g)\n",str,str->str_nval);
+ fprintf(stderr,"0x%lx num(%g)\n",str,str->str_u.str_nval);
#endif
- return str->str_nval;
+ return str->str_u.str_nval;
}
str_sset(dstr,sstr)
STR *dstr;
register STR *sstr;
{
+#ifdef TAINT
+ tainted |= sstr->str_tainted;
+#endif
if (!sstr)
- str_nset(dstr,No,0);
- else if (sstr->str_nok)
- str_numset(dstr,sstr->str_nval);
- else if (sstr->str_pok)
+ dstr->str_pok = dstr->str_nok = 0;
+ else if (sstr->str_pok) {
str_nset(dstr,sstr->str_ptr,sstr->str_cur);
+ if (sstr->str_nok) {
+ dstr->str_u.str_nval = sstr->str_u.str_nval;
+ dstr->str_nok = 1;
+ dstr->str_state = SS_NORM;
+ }
+ else if (sstr->str_cur == sizeof(STBP)) {
+ char *tmps = sstr->str_ptr;
+
+ if (*tmps == 'S' && bcmp(tmps,"Stab",4) == 0) {
+ dstr->str_magic = str_smake(sstr->str_magic);
+ dstr->str_magic->str_rare = 'X';
+ }
+ }
+ }
+ else if (sstr->str_nok)
+ str_numset(dstr,sstr->str_u.str_nval);
else
- str_nset(dstr,"",0);
+ dstr->str_pok = dstr->str_nok = 0;
}
str_nset(str,ptr,len)
register char *ptr;
register int len;
{
- GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
- bcopy(ptr,str->str_ptr,len);
+ STR_GROW(str, len + 1);
+ (void)bcopy(ptr,str->str_ptr,len);
str->str_cur = len;
*(str->str_ptr+str->str_cur) = '\0';
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
+#ifdef TAINT
+ str->str_tainted = tainted;
+#endif
}
str_set(str,ptr)
if (!ptr)
ptr = "";
len = strlen(ptr);
- GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
- bcopy(ptr,str->str_ptr,len+1);
+ STR_GROW(str, len + 1);
+ (void)bcopy(ptr,str->str_ptr,len+1);
str->str_cur = len;
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
+#ifdef TAINT
+ str->str_tainted = tainted;
+#endif
}
str_chop(str,ptr) /* like set but assuming ptr is in str */
register STR *str;
register char *ptr;
{
+ register int delta;
+
if (!(str->str_pok))
- str_2ptr(str);
- str->str_cur -= (ptr - str->str_ptr);
- bcopy(ptr,str->str_ptr, str->str_cur + 1);
+ fatal("str_chop: internal inconsistency");
+ delta = ptr - str->str_ptr;
+ str->str_len -= delta;
+ str->str_cur -= delta;
+ str->str_ptr += delta;
+ if (str->str_state == SS_INCR)
+ str->str_u.str_useful += delta;
+ else {
+ str->str_u.str_useful = delta;
+ str->str_state = SS_INCR;
+ }
str->str_nok = 0; /* invalidate number */
- str->str_pok = 1; /* validate pointer */
+ str->str_pok = 1; /* validate pointer (and unstudy str) */
}
str_ncat(str,ptr,len)
register int len;
{
if (!(str->str_pok))
- str_2ptr(str);
- GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
- bcopy(ptr,str->str_ptr+str->str_cur,len);
+ (void)str_2ptr(str);
+ STR_GROW(str, str->str_cur + len + 1);
+ (void)bcopy(ptr,str->str_ptr+str->str_cur,len);
str->str_cur += len;
*(str->str_ptr+str->str_cur) = '\0';
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
+#ifdef TAINT
+ str->str_tainted |= tainted;
+#endif
}
str_scat(dstr,sstr)
STR *dstr;
register STR *sstr;
{
+#ifdef TAINT
+ tainted |= sstr->str_tainted;
+#endif
if (!sstr)
return;
if (!(sstr->str_pok))
- str_2ptr(sstr);
+ (void)str_2ptr(sstr);
if (sstr)
str_ncat(dstr,sstr->str_ptr,sstr->str_cur);
}
if (!ptr)
return;
if (!(str->str_pok))
- str_2ptr(str);
+ (void)str_2ptr(str);
len = strlen(ptr);
- GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
- bcopy(ptr,str->str_ptr+str->str_cur,len+1);
+ STR_GROW(str, str->str_cur + len + 1);
+ (void)bcopy(ptr,str->str_ptr+str->str_cur,len+1);
str->str_cur += len;
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
+#ifdef TAINT
+ str->str_tainted |= tainted;
+#endif
}
char *
-str_append_till(str,from,delim,keeplist)
+str_append_till(str,from,fromend,delim,keeplist)
register STR *str;
register char *from;
+register char *fromend;
register int delim;
char *keeplist;
{
if (!from)
return Nullch;
- len = strlen(from);
- GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
+ len = fromend - from;
+ STR_GROW(str, str->str_cur + len + 1);
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
to = str->str_ptr+str->str_cur;
- for (; *from; from++,to++) {
- if (*from == '\\' && from[1] && delim != '\\') {
+ for (; from < fromend; from++,to++) {
+ if (*from == '\\' && from+1 < fromend && delim != '\\') {
if (!keeplist) {
if (from[1] == delim || from[1] == '\\')
from++;
else
*to++ = *from++;
}
- else if (index(keeplist,from[1]))
+ else if (from[1] && index(keeplist,from[1]))
*to++ = *from++;
else
from++;
}
STR *
+#ifdef LEAKTEST
+str_new(x,len)
+int x;
+#else
str_new(len)
+#endif
int len;
{
register STR *str;
if (freestrroot) {
str = freestrroot;
- freestrroot = str->str_link.str_next;
- str->str_link.str_magic = Nullstab;
+ freestrroot = str->str_magic;
+ str->str_magic = Nullstr;
+ str->str_state = SS_NORM;
}
else {
- str = (STR *) safemalloc(sizeof(STR));
- bzero((char*)str,sizeof(STR));
+ Newz(700+x,str,1,STR);
}
if (len)
- GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+ STR_GROW(str, len + 1);
return str;
}
void
-str_grow(str,len)
+str_magic(str, stab, how, name, namlen)
register STR *str;
+STAB *stab;
+int how;
+char *name;
+int namlen;
+{
+ if (str->str_magic)
+ return;
+ str->str_magic = Str_new(75,namlen);
+ str = str->str_magic;
+ str->str_u.str_stab = stab;
+ str->str_rare = how;
+ if (name)
+ str_nset(str,name,namlen);
+}
+
+void
+str_insert(bigstr,offset,len,little,littlelen)
+STR *bigstr;
+int offset;
int len;
+char *little;
+int littlelen;
{
- if (len && str)
- GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+ register char *big;
+ register char *mid;
+ register char *midend;
+ register char *bigend;
+ register int i;
+
+ i = littlelen - len;
+ if (i > 0) { /* string might grow */
+ STR_GROW(bigstr, bigstr->str_cur + i + 1);
+ big = bigstr->str_ptr;
+ mid = big + offset + len;
+ midend = bigend = big + bigstr->str_cur;
+ bigend += i;
+ *bigend = '\0';
+ while (midend > mid) /* shove everything down */
+ *--bigend = *--midend;
+ (void)bcopy(little,big+offset,littlelen);
+ bigstr->str_cur += i;
+ return;
+ }
+ else if (i == 0) {
+ (void)bcopy(little,bigstr->str_ptr+offset,len);
+ return;
+ }
+
+ big = bigstr->str_ptr;
+ mid = big + offset;
+ midend = mid + len;
+ bigend = big + bigstr->str_cur;
+
+ if (midend > bigend)
+ fatal("panic: str_insert");
+
+ bigstr->str_pok = SP_VALID; /* disable possible screamer */
+
+ if (mid - big > bigend - midend) { /* faster to shorten from end */
+ if (littlelen) {
+ (void)bcopy(little, mid, littlelen);
+ mid += littlelen;
+ }
+ i = bigend - midend;
+ if (i > 0) {
+ (void)bcopy(midend, mid, i);
+ mid += i;
+ }
+ *mid = '\0';
+ bigstr->str_cur = mid - big;
+ }
+ else if (i = mid - big) { /* faster from front */
+ midend -= littlelen;
+ mid = midend;
+ str_chop(bigstr,midend-i);
+ big += i;
+ while (i--)
+ *--midend = *--big;
+ if (littlelen)
+ (void)bcopy(little, mid, littlelen);
+ }
+ else if (littlelen) {
+ midend -= littlelen;
+ str_chop(bigstr,midend);
+ (void)bcopy(little,midend,littlelen);
+ }
+ else {
+ str_chop(bigstr,midend);
+ }
+ STABSET(bigstr);
}
/* make str point to what nstr did */
register STR *str;
register STR *nstr;
{
- safefree(str->str_ptr);
+ if (str->str_state == SS_INCR)
+ str_grow(str,0); /* just force copy down */
+ if (nstr->str_state == SS_INCR)
+ str_grow(nstr,0);
+ if (str->str_ptr)
+ Safefree(str->str_ptr);
str->str_ptr = nstr->str_ptr;
str->str_len = nstr->str_len;
str->str_cur = nstr->str_cur;
str->str_pok = nstr->str_pok;
- if (str->str_nok = nstr->str_nok)
- str->str_nval = nstr->str_nval;
- safefree((char*)nstr);
+ str->str_nok = nstr->str_nok;
+#ifdef STRUCTCOPY
+ str->str_u = nstr->str_u;
+#else
+ str->str_u.str_nval = nstr->str_u.str_nval;
+#endif
+#ifdef TAINT
+ str->str_tainted = nstr->str_tainted;
+#endif
+ Safefree(nstr);
}
void
{
if (!str)
return;
+ if (str->str_state) {
+ if (str->str_state == SS_FREE) /* already freed */
+ return;
+ if (str->str_state == SS_INCR && !(str->str_pok & 2)) {
+ str->str_ptr -= str->str_u.str_useful;
+ str->str_len += str->str_u.str_useful;
+ }
+ }
+ if (str->str_magic)
+ str_free(str->str_magic);
+#ifdef LEAKTEST
if (str->str_len)
- str->str_ptr[0] = '\0';
+ Safefree(str->str_ptr);
+ if ((str->str_pok & SP_INTRP) && str->str_u.str_args)
+ arg_free(str->str_u.str_args);
+ Safefree(str);
+#else /* LEAKTEST */
+ if (str->str_len) {
+ if (str->str_len > 127) { /* next user not likely to want more */
+ Safefree(str->str_ptr); /* so give it back to malloc */
+ str->str_ptr = Nullch;
+ str->str_len = 0;
+ }
+ else
+ str->str_ptr[0] = '\0';
+ }
+ if ((str->str_pok & SP_INTRP) && str->str_u.str_args)
+ arg_free(str->str_u.str_args);
str->str_cur = 0;
str->str_nok = 0;
str->str_pok = 0;
- str->str_link.str_next = freestrroot;
+ str->str_state = SS_FREE;
+#ifdef TAINT
+ str->str_tainted = 0;
+#endif
+ str->str_magic = freestrroot;
freestrroot = str;
+#endif /* LEAKTEST */
}
str_len(str)
if (!str)
return 0;
if (!(str->str_pok))
- str_2ptr(str);
- if (str->str_len)
+ (void)str_2ptr(str);
+ if (str->str_ptr)
return str->str_cur;
else
return 0;
}
+str_eq(str1,str2)
+register STR *str1;
+register STR *str2;
+{
+ if (!str1)
+ return str2 == Nullstr;
+ if (!str2)
+ return 0;
+
+ if (!str1->str_pok)
+ (void)str_2ptr(str1);
+ if (!str2->str_pok)
+ (void)str_2ptr(str2);
+
+ if (str1->str_cur != str2->str_cur)
+ return 0;
+
+ return !bcmp(str1->str_ptr, str2->str_ptr, str1->str_cur);
+}
+
+str_cmp(str1,str2)
+register STR *str1;
+register STR *str2;
+{
+ int retval;
+
+ if (!str1)
+ return str2 == Nullstr;
+ if (!str2)
+ return 0;
+
+ if (!str1->str_pok)
+ (void)str_2ptr(str1);
+ if (!str2->str_pok)
+ (void)str_2ptr(str2);
+
+ 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;
+}
+
char *
-str_gets(str,fp)
+str_gets(str,fp,append)
register STR *str;
register FILE *fp;
+int append;
{
#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */
register int get_paragraph;
register char *oldbp;
- if (get_paragraph = !newline) { /* yes, that's an assignment */
+ if (get_paragraph = !rslen) { /* yes, that's an assignment */
newline = '\n';
oldbp = Nullch; /* remember last \n position (none) */
}
cnt = fp->_cnt; /* get count into register */
str->str_nok = 0; /* invalidate number */
str->str_pok = 1; /* validate pointer */
- if (str->str_len <= cnt) /* make sure we have the room */
- GROWSTR(&(str->str_ptr), &(str->str_len), cnt+1);
- bp = str->str_ptr; /* move these two too to registers */
+ if (str->str_len <= cnt + 1) /* make sure we have the room */
+ STR_GROW(str, append+cnt+2); /* (remembering cnt can be -1) */
+ bp = str->str_ptr + append; /* move these two too to registers */
ptr = fp->_ptr;
for (;;) {
screamer:
bpx = bp - str->str_ptr; /* prepare for possible relocation */
if (get_paragraph && oldbp)
obpx = oldbp - str->str_ptr;
- GROWSTR(&(str->str_ptr), &(str->str_len), bpx + cnt + 2);
+ STR_GROW(str, bpx + cnt + 2);
bp = str->str_ptr + bpx; /* reconstitute our pointer */
if (get_paragraph && oldbp)
oldbp = str->str_ptr + obpx;
#else /* !STDSTDIO */ /* The big, slow, and stupid way */
- static char buf[4192];
+ static char buf[8192];
- if (fgets(buf, sizeof buf, fp) != Nullch)
- str_set(str, buf);
+ if (fgets(buf, sizeof buf, fp) != Nullch) {
+ if (append)
+ str_cat(str, buf);
+ else
+ str_set(str, buf);
+ }
else
str_set(str, No);
#endif /* STDSTDIO */
- return str->str_cur ? str->str_ptr : Nullch;
+ return str->str_cur - append ? str->str_ptr : Nullch;
}
+ARG *
+parselist(str)
+STR *str;
+{
+ register CMD *cmd;
+ register ARG *arg;
+ line_t oldline = line;
+ int retval;
-STR *
-interp(str,s)
-register STR *str;
-register char *s;
+ str_sset(linestr,str);
+ in_eval++;
+ oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
+ bufend = bufptr + linestr->str_cur;
+ if (setjmp(eval_env)) {
+ in_eval = 0;
+ fatal("%s\n",stab_val(stabent("@",TRUE))->str_ptr);
+ }
+ error_count = 0;
+ retval = yyparse();
+ in_eval--;
+ if (retval || error_count)
+ fatal("Invalid component in string or format");
+ cmd = eval_root;
+ arg = cmd->c_expr;
+ if (cmd->c_type != C_EXPR || cmd->c_next || arg->arg_type != O_LIST)
+ fatal("panic: error in parselist %d %x %d", cmd->c_type,
+ cmd->c_next, arg ? arg->arg_type : -1);
+ line = oldline;
+ Safefree(cmd);
+ return arg;
+}
+
+void
+intrpcompile(src)
+STR *src;
{
- register char *t = s;
- char *envsave = envname;
- envname = Nullch;
+ register char *s = str_get(src);
+ register char *send = s + src->str_cur;
+ register STR *str;
+ register char *t;
+ STR *toparse;
+ int len;
+ register int brackets;
+ register char *d;
+ STAB *stab;
+ char *checkpoint;
- str_set(str,"");
- while (*s) {
- if (*s == '\\' && s[1] == '\\') {
- str_ncat(str, t, s++ - t);
- t = s++;
- }
- else if (*s == '\\' && s[1] == '$') {
- str_ncat(str, t, s++ - t);
- t = s++;
+ toparse = Str_new(76,0);
+ str = Str_new(77,0);
+
+ str_nset(str,"",0);
+ str_nset(toparse,"",0);
+ t = s;
+ while (s < send) {
+ if (*s == '\\' && s[1] && index("$@[{\\]}",s[1])) {
+ str_ncat(str, t, s - t);
+ ++s;
+ if (*nointrp && s+1 < send)
+ if (*s != '@' && (*s != '$' || index(nointrp,s[1])))
+ str_ncat(str,s-1,1);
+ str_ncat(str, "$b", 2);
+ str_ncat(str, s, 1);
+ ++s;
+ t = s;
}
- else if (*s == '$' && s[1] && s[1] != '|') {
+ else if ((*s == '@' || (*s == '$' && !index(nointrp,s[1]))) &&
+ s+1 < send) {
str_ncat(str,t,s-t);
- s = scanreg(s,tokenbuf);
- str_cat(str,reg_get(tokenbuf));
t = s;
+ if (*s == '$' && s[1] == '#' && isalpha(s[2]) || s[2] == '_')
+ s++;
+ s = scanreg(s,send,tokenbuf);
+ if (*t == '@' &&
+ (!(stab = stabent(tokenbuf,FALSE)) || !stab_xarray(stab)) ) {
+ str_ncat(str,"@",1);
+ s = ++t;
+ continue; /* grandfather @ from old scripts */
+ }
+ str_ncat(str,"$a",2);
+ str_ncat(toparse,",",1);
+ if (t[1] != '{' && (*s == '[' || *s == '{' /* }} */ ) &&
+ (stab = stabent(tokenbuf,FALSE)) &&
+ ((*s == '[') ? (stab_xarray(stab) != 0) : (stab_xhash(stab) != 0)) ) {
+ brackets = 0;
+ checkpoint = s;
+ do {
+ switch (*s) {
+ case '[': case '{':
+ brackets++;
+ break;
+ case ']': case '}':
+ brackets--;
+ break;
+ case '\'':
+ case '"':
+ if (s[-1] != '$') {
+ s = cpytill(tokenbuf,s+1,send,*s,&len);
+ if (s >= send)
+ fatal("Unterminated string");
+ }
+ break;
+ }
+ s++;
+ } while (brackets > 0 && s < send);
+ if (s > send)
+ fatal("Unmatched brackets in string");
+ if (*nointrp) { /* we're in a regular expression */
+ d = checkpoint;
+ if (*d == '{' && s[-1] == '}') { /* maybe {n,m} */
+ ++d;
+ if (isdigit(*d)) { /* matches /^{\d,?\d*}$/ */
+ if (*++d == ',')
+ ++d;
+ while (isdigit(*d))
+ d++;
+ if (d == s - 1)
+ s = checkpoint; /* Is {n,m}! Backoff! */
+ }
+ }
+ else if (*d == '[' && s[-1] == ']') { /* char class? */
+ int weight = 2; /* let's weigh the evidence */
+ char seen[256];
+ unsigned char uchar = 0, lastuchar;
+
+ Zero(seen,256,char);
+ *--s = '\0';
+ if (d[1] == '^')
+ weight += 150;
+ else if (d[1] == '$')
+ weight -= 3;
+ if (isdigit(d[1])) {
+ if (d[2]) {
+ if (isdigit(d[2]) && !d[3])
+ weight -= 10;
+ }
+ else
+ weight -= 100;
+ }
+ for (d++; d < s; d++) {
+ lastuchar = uchar;
+ uchar = (unsigned char)*d;
+ switch (*d) {
+ case '&':
+ case '$':
+ weight -= seen[uchar] * 10;
+ if (isalpha(d[1]) || isdigit(d[1]) ||
+ d[1] == '_') {
+ d = scanreg(d,s,tokenbuf);
+ if (stabent(tokenbuf,FALSE))
+ weight -= 100;
+ else
+ weight -= 10;
+ }
+ else if (*d == '$' && d[1] &&
+ index("[#!%*<>()-=",d[1])) {
+ if (!d[2] || /*{*/ index("])} =",d[2]))
+ weight -= 10;
+ else
+ weight -= 1;
+ }
+ break;
+ case '\\':
+ uchar = 254;
+ if (d[1]) {
+ if (index("wds",d[1]))
+ weight += 100;
+ else if (seen['\''] || seen['"'])
+ weight += 1;
+ else if (index("rnftb",d[1]))
+ weight += 40;
+ else if (isdigit(d[1])) {
+ weight += 40;
+ while (d[1] && isdigit(d[1]))
+ d++;
+ }
+ }
+ else
+ weight += 100;
+ break;
+ case '-':
+ if (lastuchar < d[1] || d[1] == '\\') {
+ if (index("aA01! ",lastuchar))
+ weight += 30;
+ if (index("zZ79~",d[1]))
+ weight += 30;
+ }
+ else
+ weight -= 1;
+ default:
+ if (isalpha(*d) && d[1] && isalpha(d[1])) {
+ bufptr = d;
+ if (yylex() != WORD)
+ weight -= 150;
+ d = bufptr;
+ }
+ if (uchar == lastuchar + 1)
+ weight += 5;
+ weight -= seen[uchar];
+ break;
+ }
+ seen[uchar]++;
+ }
+#ifdef DEBUGGING
+ if (debug & 512)
+ fprintf(stderr,"[%s] weight %d\n",
+ checkpoint+1,weight);
+#endif
+ *s++ = ']';
+ if (weight >= 0) /* probably a character class */
+ s = checkpoint;
+ }
+ }
+ }
+ if (*t == '@')
+ str_ncat(toparse, "join($\",", 8);
+ if (t[1] == '{' && s[-1] == '}') {
+ str_ncat(toparse, t, 1);
+ str_ncat(toparse, t+2, s - t - 3);
+ }
+ else
+ str_ncat(toparse, t, s - t);
+ if (*t == '@')
+ str_ncat(toparse, ")", 1);
+ t = s;
+ }
+ else
+ s++;
+ }
+ str_ncat(str,t,s-t);
+ if (toparse->str_ptr && *toparse->str_ptr == ',') {
+ *toparse->str_ptr = '(';
+ str_ncat(toparse,",$$);",5);
+ str->str_u.str_args = parselist(toparse);
+ str->str_u.str_args->arg_len--; /* ignore $$ reference */
+ }
+ else
+ str->str_u.str_args = Nullarg;
+ str_free(toparse);
+ str->str_pok |= SP_INTRP;
+ str->str_nok = 0;
+ str_replace(src,str);
+}
+
+STR *
+interp(str,src,sp)
+register STR *str;
+STR *src;
+int sp;
+{
+ register char *s;
+ register char *t;
+ register char *send;
+ register STR **elem;
+
+ if (!(src->str_pok & SP_INTRP)) {
+ int oldsave = savestack->ary_fill;
+
+ (void)savehptr(&curstash);
+ curstash = src->str_u.str_hash; /* so stabent knows right package */
+ intrpcompile(src);
+ restorelist(oldsave);
+ }
+ s = src->str_ptr; /* assumed valid since str_pok set */
+ t = s;
+ send = s + src->str_cur;
+
+ if (src->str_u.str_args) {
+ (void)eval(src->str_u.str_args,G_ARRAY,sp);
+ /* Assuming we have correct # of args */
+ elem = stack->ary_array + sp;
+ }
+
+ str_nset(str,"",0);
+ while (s < send) {
+ if (*s == '$' && s+1 < send) {
+ str_ncat(str,t,s-t);
+ switch(*++s) {
+ case 'a':
+ str_scat(str,*++elem);
+ break;
+ case 'b':
+ str_ncat(str,++s,1);
+ break;
+ }
+ t = ++s;
}
else
s++;
}
- envname = envsave;
str_ncat(str,t,s-t);
return str;
}
if (!str)
return;
if (str->str_nok) {
- str->str_nval += 1.0;
+ str->str_u.str_nval += 1.0;
str->str_pok = 0;
return;
}
if (!str->str_pok || !*str->str_ptr) {
- str->str_nval = 1.0;
+ str->str_u.str_nval = 1.0;
str->str_nok = 1;
str->str_pok = 0;
return;
}
}
/* oh,oh, the number grew */
- GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + 2);
+ STR_GROW(str, str->str_cur + 2);
str->str_cur++;
for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--)
*d = d[-1];
if (!str)
return;
if (str->str_nok) {
- str->str_nval -= 1.0;
+ str->str_u.str_nval -= 1.0;
str->str_pok = 0;
return;
}
if (!str->str_pok) {
- str->str_nval = -1.0;
+ str->str_u.str_nval = -1.0;
str->str_nok = 1;
return;
}
str_numset(str,atof(str->str_ptr) - 1.0);
}
-/* make a string that will exist for the duration of the expression eval */
+/* Make a string that will exist for the duration of the expression
+ * evaluation. Actually, it may have to last longer than that, but
+ * hopefully cmd_exec won't free it until it has been assigned to a
+ * permanent location. */
+
+static long tmps_size = -1;
STR *
str_static(oldstr)
STR *oldstr;
{
- register STR *str = str_new(0);
- static long tmps_size = -1;
+ register STR *str = Str_new(78,0);
str_sset(str,oldstr);
if (++tmps_max > tmps_size) {
tmps_size = tmps_max;
if (!(tmps_size & 127)) {
if (tmps_size)
- tmps_list = (STR**)saferealloc((char*)tmps_list,
- (MEM_SIZE)((tmps_size + 128) * sizeof(STR*)) );
+ Renew(tmps_list, tmps_size + 128, STR*);
else
- tmps_list = (STR**)safemalloc(128 * sizeof(char*));
+ New(702,tmps_list, 128, STR*);
}
}
tmps_list[tmps_max] = str;
return str;
}
+/* same thing without the copying */
+
STR *
-str_make(s)
+str_2static(str)
+register STR *str;
+{
+ if (++tmps_max > tmps_size) {
+ tmps_size = tmps_max;
+ if (!(tmps_size & 127)) {
+ if (tmps_size)
+ Renew(tmps_list, tmps_size + 128, STR*);
+ else
+ New(704,tmps_list, 128, STR*);
+ }
+ }
+ tmps_list[tmps_max] = str;
+ return str;
+}
+
+STR *
+str_make(s,len)
char *s;
+int len;
{
- register STR *str = str_new(0);
+ register STR *str = Str_new(79,0);
- str_set(str,s);
+ if (!len)
+ len = strlen(s);
+ str_nset(str,s,len);
return str;
}
str_nmake(n)
double n;
{
- register STR *str = str_new(0);
+ register STR *str = Str_new(80,0);
str_numset(str,n);
return str;
}
+
+/* make an exact duplicate of old */
+
+STR *
+str_smake(old)
+register STR *old;
+{
+ register STR *new = Str_new(81,0);
+
+ if (!old)
+ return Nullstr;
+ if (old->str_state == SS_FREE) {
+ warn("semi-panic: attempt to dup freed string");
+ return Nullstr;
+ }
+ if (old->str_state == SS_INCR && !(old->str_pok & 2))
+ str_grow(old,0);
+ if (new->str_ptr)
+ Safefree(new->str_ptr);
+ Copy(old,new,1,STR);
+ if (old->str_ptr)
+ new->str_ptr = nsavestr(old->str_ptr,old->str_len);
+ return new;
+}
+
+str_reset(s,stash)
+register char *s;
+HASH *stash;
+{
+ register HENT *entry;
+ register STAB *stab;
+ register STR *str;
+ register int i;
+ register SPAT *spat;
+ register int max;
+
+ if (!*s) { /* reset ?? searches */
+ for (spat = stash->tbl_spatroot;
+ spat != Nullspat;
+ spat = spat->spat_next) {
+ spat->spat_flags &= ~SPAT_USED;
+ }
+ return;
+ }
+
+ /* reset variables */
+
+ while (*s) {
+ i = *s;
+ if (s[1] == '-') {
+ s += 2;
+ }
+ max = *s++;
+ for ( ; i <= max; i++) {
+ for (entry = stash->tbl_array[i];
+ entry;
+ entry = entry->hent_next) {
+ stab = (STAB*)entry->hent_val;
+ str = stab_val(stab);
+ str->str_cur = 0;
+ str->str_nok = 0;
+#ifdef TAINT
+ str->str_tainted = tainted;
+#endif
+ if (str->str_ptr != Nullch)
+ str->str_ptr[0] = '\0';
+ if (stab_xarray(stab)) {
+ aclear(stab_xarray(stab));
+ }
+ if (stab_xhash(stab)) {
+ hclear(stab_xhash(stab));
+ if (stab == envstab)
+ environ[0] = Nullch;
+ }
+ }
+ }
+ }
+}
+
+#ifdef TAINT
+taintproper(s)
+char *s;
+{
+#ifdef DEBUGGING
+ if (debug & 2048)
+ fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid);
+#endif
+ if (tainted && (!euid || euid != uid)) {
+ if (!unsafe)
+ fatal("%s", s);
+ else if (dowarn)
+ warn("%s", s);
+ }
+}
+
+taintenv()
+{
+ register STR *envstr;
+
+ envstr = hfetch(stab_hash(envstab),"PATH",4,FALSE);
+ if (!envstr || envstr->str_tainted) {
+ tainted = 1;
+ taintproper("Insecure PATH");
+ }
+ envstr = hfetch(stab_hash(envstab),"IFS",3,FALSE);
+ if (envstr && envstr->str_tainted) {
+ tainted = 1;
+ taintproper("Insecure IFS");
+ }
+}
+#endif /* TAINT */
-/* $Header: str.h,v 2.0 88/06/05 00:11:11 root Exp $
+/* $Header: str.h,v 3.0 89/10/18 15:23:49 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: str.h,v $
- * Revision 2.0 88/06/05 00:11:11 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:23:49 lwall
+ * 3.0 baseline
*
*/
struct string {
char * str_ptr; /* pointer to malloced string */
- double str_nval; /* numeric value, if any */
+ union {
+ double str_nval; /* numeric value, if any */
+ STAB *str_stab; /* magic stab for magic "key" string */
+ long str_useful; /* is this search optimization effective? */
+ ARG *str_args; /* list of args for interpreted string */
+ HASH *str_hash; /* string represents an assoc array (stab?) */
+ ARRAY *str_array; /* string represents an array */
+ } str_u;
int str_len; /* allocated size */
int str_cur; /* length of str_ptr as a C string */
+ STR *str_magic; /* while free, link to next free str */
+ /* while in use, ptr to "key" for magic items */
+ char str_pok; /* state of str_ptr */
+ char str_nok; /* state of str_nval */
+ unsigned char str_rare; /* used by search strings */
+ unsigned char str_state; /* one of SS_* below */
+ /* also used by search strings for backoff */
+#ifdef TAINT
+ bool str_tainted; /* 1 if possibly under control of $< */
+#endif
+};
+
+struct stab { /* should be identical, except for str_ptr */
+ STBP * str_ptr; /* pointer to malloced string */
union {
- STR *str_next; /* while free, link to next free str */
- STAB *str_magic; /* while in use, ptr to magic stab, if any */
- } str_link;
+ double str_nval; /* numeric value, if any */
+ STAB *str_stab; /* magic stab for magic "key" string */
+ long str_useful; /* is this search optimization effective? */
+ ARG *str_args; /* list of args for interpreted string */
+ HASH *str_hash; /* string represents an assoc array (stab?) */
+ ARRAY *str_array; /* string represents an array */
+ } str_u;
+ int str_len; /* allocated size */
+ int str_cur; /* length of str_ptr as a C string */
+ STR *str_magic; /* while free, link to next free str */
+ /* while in use, ptr to "key" for magic items */
char str_pok; /* state of str_ptr */
char str_nok; /* state of str_nval */
- char str_rare; /* used by search strings */
- char str_prev; /* also used by search strings */
+ unsigned char str_rare; /* used by search strings */
+ unsigned char str_state; /* one of SS_* below */
+ /* also used by search strings for backoff */
+#ifdef TAINT
+ bool str_tainted; /* 1 if possibly under control of $< */
+#endif
+};
+
+/* some extra info tacked to some lvalue strings */
+
+struct lstring {
+ struct string lstr;
+ int lstr_offset;
+ int lstr_len;
};
+/* These are the values of str_pok: */
+#define SP_VALID 1 /* str_ptr is valid */
+#define SP_FBM 2 /* string was compiled for fbm search */
+#define SP_STUDIED 4 /* string was studied */
+#define SP_CASEFOLD 8 /* case insensitive fbm search */
+#define SP_INTRP 16 /* string was compiled for interping */
+#define SP_TAIL 32 /* fbm string is tail anchored: /foo$/ */
+#define SP_MULTI 64 /* symbol table entry probably isn't a typo */
+
#define Nullstr Null(STR*)
+/* These are the values of str_state: */
+#define SS_NORM 0 /* normal string */
+#define SS_INCR 1 /* normal string, incremented ptr */
+#define SS_SARY 2 /* array on save stack */
+#define SS_SHASH 3 /* associative array on save stack */
+#define SS_SINT 4 /* integer on save stack */
+#define SS_SLONG 5 /* long on save stack */
+#define SS_SSTRP 6 /* STR* on save stack */
+#define SS_SHPTR 7 /* HASH* on save stack */
+#define SS_SNSTAB 8 /* non-stab on save stack */
+#define SS_HASH 253 /* carrying an hash */
+#define SS_ARY 254 /* carrying an array */
+#define SS_FREE 255 /* in free list */
+/* str_state may have any value 0-255 when used to hold fbm pattern, in which */
+/* case it indicates offset to rarest character in screaminstr key */
+
/* the following macro updates any magic values this str is associated with */
-#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x))
+#ifdef TAINT
+#define STABSET(x) \
+ (x)->str_tainted |= tainted; \
+ if ((x)->str_magic) \
+ stabset((x)->str_magic,(x))
+#else
+#define STABSET(x) \
+ if ((x)->str_magic) \
+ stabset((x)->str_magic,(x))
+#endif
+
+#define STR_SSET(dst,src) if (dst != src) str_sset(dst,src)
EXT STR **tmps_list;
EXT int tmps_max INIT(-1);
char *str_2ptr();
double str_2num();
STR *str_static();
+STR *str_2static();
STR *str_make();
STR *str_nmake();
+STR *str_smake();
+int str_cmp();
+int str_eq();
+void str_magic();
+void str_insert();
#!./perl
-# $Header: TEST,v 2.0 88/06/05 00:11:47 root Exp $
+# $Header: TEST,v 3.0 89/10/18 15:24:06 lwall Locked $
# This is written in a peculiar style, since we're trying to avoid
# most of the constructs we'll be testing for.
+$| = 1;
+
if ($ARGV[0] eq '-v') {
$verbose = 1;
shift;
if ($test =~ /\.orig$/) {
next;
}
- print "$test...";
+ if ($test =~ /~$/) {
+ next;
+ }
+ print "$test" . '.' x (16 - length($test));
if ($sharpbang) {
open(results,"./$test|") || (print "can't run.\n");
} else {
#!./perl
-# $Header: base.cond,v 2.0 88/06/05 00:11:52 root Exp $
+# $Header: base.cond,v 3.0 89/10/18 15:24:11 lwall Locked $
# make sure conditional operators work
#!./perl
-# $Header: base.if,v 2.0 88/06/05 00:12:02 root Exp $
+# $Header: base.if,v 3.0 89/10/18 15:24:17 lwall Locked $
print "1..2\n";
#!./perl
-# $Header: base.lex,v 2.0 88/06/05 00:12:06 root Exp $
+# $Header: base.lex,v 3.0 89/10/18 15:24:24 lwall Locked $
-print "1..7\n";
+print "1..18\n";
$ # this is the register <space>
= 'x';
$foo = int($foo * 100 + .5);
if ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7\n";}
+
+print <<'EOF';
+ok 8
+EOF
+
+$foo = 'ok 9';
+print <<EOF;
+$foo
+EOF
+
+eval <<\EOE, print $@;
+print <<'EOF';
+ok 10
+EOF
+
+$foo = 'ok 11';
+print <<EOF;
+$foo
+EOF
+EOE
+
+print <<`EOS` . <<\EOF;
+echo ok 12
+EOS
+ok 13
+EOF
+
+print qq/ok 14\n/;
+print qq(ok 15\n);
+
+print qq
+ok 16\n
+;
+
+print q<ok 17
+>;
+
+print <<; # Yow!
+ok 18
+
+# previous line intentionally left blank.
#!./perl
-# $Header: base.pat,v 2.0 88/06/05 00:12:08 root Exp $
+# $Header: base.pat,v 3.0 89/10/18 15:24:30 lwall Locked $
print "1..2\n";
#!./perl
-# $Header: base.term,v 2.0 88/06/05 00:12:13 root Exp $
+# $Header: base.term,v 3.0 89/10/18 15:24:34 lwall Locked $
print "1..6\n";
#!./perl
-# $Header: cmd.elsif,v 2.0 88/06/05 00:12:16 root Exp $
+# $Header: cmd.elsif,v 3.0 89/10/18 15:24:38 lwall Locked $
sub foo {
if ($_[0] == 1) {
print "1..4\n";
-if (($x = do foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1\n";}
-if (($x = do foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2\n";}
-if (($x = do foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3\n";}
-if (($x = do foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4\n";}
+if (($x = do foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1 '$x'\n";}
+if (($x = do foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2 '$x'\n";}
+if (($x = do foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3 '$x'\n";}
+if (($x = do foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4 '$x'\n";}
#!./perl
-# $Header: cmd.for,v 2.0 88/06/05 00:12:19 root Exp $
+# $Header: cmd.for,v 3.0 89/10/18 15:24:43 lwall Locked $
print "1..7\n";
for (split(' ','a b c d e')) {
$foo .= $_;
}
-if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5\n";}
+if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";}
foreach $foo (("ok 6\n","ok 7\n")) {
print $foo;
#!./perl
-# $Header: cmd.mod,v 2.0 88/06/05 00:12:23 root Exp $
+# $Header: cmd.mod,v 3.0 89/10/18 15:24:48 lwall Locked $
-print "1..6\n";
+print "1..7\n";
print "ok 1\n" if 1;
print "not ok 1\n" unless 1;
$x = 15;
$x = 10 while $x < 10;
if ($x == 15) {print "ok 6\n";} else {print "not ok 6\n";}
+
+open(foo,'TEST') || open(foo,'t/TEST');
+$x = 0;
+$x++ while <foo>;
+print $x > 50 && $x < 1000 ? "ok 7\n" : "not ok 7\n";
#!./perl
-# $Header: cmd.subval,v 2.0 88/06/05 00:12:26 root Exp $
+# $Header: cmd.subval,v 3.0 89/10/18 15:24:52 lwall Locked $
sub foo1 {
'true1';
sub foo2 {
'true1';
- if ($_[0]) { 'true2'; } else { 'true3'; }
+ if ($_[0]) { return 'true2'; } else { return 'true3'; }
+ 'true0';
}
sub foo3 {
'true2' unless $_[0];
}
-print "1..22\n";
+print "1..26\n";
-if (do foo1(0) eq '') {print "ok 1\n";} else {print "not ok 1\n";}
+if (do foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
if (do foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";}
if (do foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";}
if (do foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";}
if (do foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";}
-if (do foo3(1) eq '') {print "ok 6\n";} else {print "not ok 6\n";}
+if (do foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";}
if (do foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";}
if (do foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";}
-if (do foo5(0) eq '') {print "ok 9\n";} else {print "not ok 9\n";}
+if (do foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";}
if (do foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";}
if (do foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";}
-if (do foo6(1) eq '') {print "ok 12\n";} else {print "not ok 12\n";}
+if (do foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\n";}
# Now test to see that recursion works using a Fibonacci number generator
print "not ok $foo\n";
}
}
+
+sub ary1 {
+ (1,2,3);
+}
+
+print &ary1 eq 3 ? "ok 23\n" : "not ok 23\n";
+
+print join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n";
+
+sub ary2 {
+ do {
+ return (1,2,3);
+ (3,2,1);
+ };
+ 0;
+}
+
+print &ary2 eq 3 ? "ok 25\n" : "not ok 25\n";
+
+$x = join(':',&ary2);
+print $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n";
+
--- /dev/null
+#!./perl
+
+# $Header: cmd.switch,v 3.0 89/10/18 15:25:00 lwall Locked $
+
+print "1..18\n";
+
+sub foo1 {
+ $_ = shift(@_);
+ $a = 0;
+ until ($a++) {
+ next if $_ eq 1;
+ next if $_ eq 2;
+ next if $_ eq 3;
+ next if $_ eq 4;
+ return 20;
+ }
+ continue {
+ return $_;
+ }
+}
+
+print do foo1(0) == 20 ? "ok 1\n" : "not ok 1\n";
+print do foo1(1) == 1 ? "ok 2\n" : "not ok 2\n";
+print do foo1(2) == 2 ? "ok 3\n" : "not ok 3\n";
+print do foo1(3) == 3 ? "ok 4\n" : "not ok 4\n";
+print do foo1(4) == 4 ? "ok 5\n" : "not ok 5\n";
+print do foo1(5) == 20 ? "ok 6\n" : "not ok 6\n";
+
+sub foo2 {
+ $_ = shift(@_);
+ {
+ last if $_ == 1;
+ last if $_ == 2;
+ last if $_ == 3;
+ last if $_ == 4;
+ }
+ continue {
+ return 20;
+ }
+ return $_;
+}
+
+print do foo2(0) == 20 ? "ok 7\n" : "not ok 1\n";
+print do foo2(1) == 1 ? "ok 8\n" : "not ok 8\n";
+print do foo2(2) == 2 ? "ok 9\n" : "not ok 9\n";
+print do foo2(3) == 3 ? "ok 10\n" : "not ok 10\n";
+print do foo2(4) == 4 ? "ok 11\n" : "not ok 11\n";
+print do foo2(5) == 20 ? "ok 12\n" : "not ok 12\n";
+
+sub foo3 {
+ $_ = shift(@_);
+ if (/^1/) {
+ return 1;
+ }
+ elsif (/^2/) {
+ return 2;
+ }
+ elsif (/^3/) {
+ return 3;
+ }
+ elsif (/^4/) {
+ return 4;
+ }
+ else {
+ return 20;
+ }
+ return 40;
+}
+
+print do foo3(0) == 20 ? "ok 13\n" : "not ok 13\n";
+print do foo3(1) == 1 ? "ok 14\n" : "not ok 14\n";
+print do foo3(2) == 2 ? "ok 15\n" : "not ok 15\n";
+print do foo3(3) == 3 ? "ok 16\n" : "not ok 16\n";
+print do foo3(4) == 4 ? "ok 17\n" : "not ok 17\n";
+print do foo3(5) == 20 ? "ok 18\n" : "not ok 18\n";
#!./perl
-# $Header: cmd.while,v 2.0 88/06/05 00:12:31 root Exp $
+# $Header: cmd.while,v 3.0 89/10/18 15:25:07 lwall Locked $
print "1..10\n";
while (<fh>) {
last if /vt100/;
}
-if (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1\n";}
+if (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1 $_\n";}
# test "next" command
#!./perl
-# $Header: comp.cmdopt,v 2.0 88/06/05 00:12:34 root Exp $
+# $Header: comp.cmdopt,v 3.0 89/10/18 15:25:13 lwall Locked $
print "1..40\n";
#!./perl -P
-# $Header: comp.cpp,v 2.0 88/06/05 00:12:37 root Exp $
+# $Header: comp.cpp,v 3.0 89/10/18 15:25:19 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: comp.decl,v 2.0 88/06/05 00:12:40 root Exp $
+# $Header: comp.decl,v 3.0 89/10/18 15:25:25 lwall Locked $
# check to see if subroutine declarations work everwhere
#!./perl
-# $Header: comp.multiline,v 2.0 88/06/05 00:12:44 root Exp $
+# $Header: comp.multiline,v 3.0 89/10/18 15:25:39 lwall Locked $
print "1..5\n";
--- /dev/null
+#!./perl
+
+print "1..7\n";
+
+$blurfl = 123;
+$foo = 3;
+
+package XYZ;
+
+$bar = 4;
+
+{
+ package ABC;
+ $blurfl = 5;
+ $main'a = $'b;
+}
+
+$ABC'dyick = 6;
+
+$xyz = 2;
+
+$main = join(':', sort(keys _main));
+$XYZ = join(':', sort(keys _XYZ));
+$ABC = join(':', sort(keys _ABC));
+
+print $XYZ eq 'ABC:XYZ:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$XYZ'\n";
+print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2\n";
+print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n";
+package ABC;
+print $blurfl == 5 ? "ok 4\n" : "not ok 4\n";
+eval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";';
+eval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";';
+print $blurfl == 5 ? "ok 7\n" : "not ok 7\n";
#!./perl
-# $Header: comp.script,v 2.0 88/06/05 00:12:49 root Exp $
+# $Header: comp.script,v 3.0 89/10/18 15:25:55 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: comp.term,v 2.0 88/06/05 00:12:52 root Exp $
+# $Header: comp.term,v 3.0 89/10/18 15:26:04 lwall Locked $
# tests that aren't important enough for base.term
-print "1..10\n";
+print "1..14\n";
$x = "\\n";
print "#1\t:$x: eq " . ':\n:' . "\n";
if (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";}
if (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";}
+if ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";}
+
+@foo = (1,2,3);
+if ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";}
+if ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";}
+$" = '::';
+if ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";}
#!./perl
-# $Header: io.argv,v 2.0 88/06/05 00:12:55 root Exp $
+# $Header: io.argv,v 3.0 89/10/18 15:26:10 lwall Locked $
print "1..5\n";
#!./perl
-# $Header: io.dup,v 2.0 88/06/05 00:12:57 root Exp $
+# $Header: io.dup,v 3.0 89/10/18 15:26:15 lwall Locked $
print "1..6\n";
print "ok 1\n";
-open(dupout,">&stdout");
-open(duperr,">&stderr");
+open(dupout,">&STDOUT");
+open(duperr,">&STDERR");
-open(stdout,">Io.dup") || die "Can't open stdout";
-open(stderr,">&stdout") || die "Can't open stderr";
+open(STDOUT,">Io.dup") || die "Can't open stdout";
+open(STDERR,">&STDOUT") || die "Can't open stderr";
-select(stderr); $| = 1;
-select(stdout); $| = 1;
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
-print stdout "ok 2\n";
-print stderr "ok 3\n";
+print STDOUT "ok 2\n";
+print STDERR "ok 3\n";
system 'echo ok 4';
system 'echo ok 5 1>&2';
-close(stdout);
-close(stderr);
+close(STDOUT);
+close(STDERR);
-open(stdout,">&dupout");
-open(stderr,">&duperr");
+open(STDOUT,">&dupout");
+open(STDERR,">&duperr");
system 'cat Io.dup';
unlink 'Io.dup';
-print stdout "ok 6\n";
+print STDOUT "ok 6\n";
#!./perl
-# $Header: io.fs,v 2.0 88/06/05 00:12:59 root Exp $
+# $Header: io.fs,v 3.0 89/10/18 15:26:20 lwall Locked $
print "1..22\n";
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('a');
if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";}
-$foo = (utime 0,1,'b');
+$foo = (utime 500000000,500000001,'b');
if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('b');
if ($ino) {print "ok 17\n";} else {print "not ok 17\n";}
-if ($atime == 0 && $mtime == 1) {print "ok 18\n";} else {print "not ok 18 $atime $mtime\n";}
+if ($atime == 500000000 && $mtime == 500000001)
+ {print "ok 18\n";} else {print "not ok 18 $atime $mtime\n";}
if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
#!./perl -i.bak
-# $Header: io.inplace,v 2.0 88/06/05 00:13:02 root Exp $
+# $Header: io.inplace,v 3.0 89/10/18 15:26:25 lwall Locked $
print "1..2\n";
#!./perl
-# $Header: io.pipe,v 2.0 88/06/05 00:13:05 root Exp $
+# $Header: io.pipe,v 3.0 89/10/18 15:26:30 lwall Locked $
$| = 1;
print "1..4\n";
}
}
else {
- print stdout "ok 3\n";
+ print STDOUT "ok 3\n";
exec 'echo', 'ok 4';
}
#!./perl
-# $Header: io.print,v 2.0 88/06/05 00:13:11 root Exp $
+# $Header: io.print,v 3.0 89/10/18 15:26:36 lwall Locked $
print "1..16\n";
-$foo = 'stdout';
+$foo = 'STDOUT';
print $foo "ok 1\n";
print "ok 2\n","ok 3\n","ok 4\n";
-print stdout "ok 5\n";
+print STDOUT "ok 5\n";
open(foo,">-");
print foo "ok 6\n";
printf @a;
$a[1] = 10;
-printf stdout @a;
+printf STDOUT @a;
$, = ' ';
$\ = "\n";
#!./perl
-# $Header: io.tell,v 2.0 88/06/05 00:13:14 root Exp $
+# $Header: io.tell,v 3.0 89/10/18 15:26:45 lwall Locked $
print "1..13\n";
#!./perl
-# $Header: op.append,v 2.0 88/06/05 00:13:16 root Exp $
+# $Header: op.append,v 3.0 89/10/18 15:26:51 lwall Locked $
print "1..3\n";
--- /dev/null
+#!./perl
+
+# $Header: op.array,v 3.0 89/10/18 15:26:55 lwall Locked $
+
+print "1..30\n";
+
+@ary = (1,2,3,4,5);
+if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$tmp = $ary[$#ary]; --$#ary;
+if ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";}
+if ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";}
+if (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$[ = 1;
+@ary = (1,2,3,4,5);
+if (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";}
+
+$tmp = $ary[$#ary]; --$#ary;
+if ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";}
+if ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";}
+if (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";}
+
+if ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";}
+
+$#ary += 1; # see if we can recover element 5
+if ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";}
+if ($ary[5] == 5) {print "ok 11\n";} else {print "not ok 11\n";}
+
+$[ = 0;
+@foo = ();
+$r = join(',', $#foo, @foo);
+if ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";}
+$foo[0] = '0';
+$r = join(',', $#foo, @foo);
+if ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";}
+$foo[2] = '2';
+$r = join(',', $#foo, @foo);
+if ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";}
+@bar = ();
+$bar[0] = '0';
+$bar[1] = '1';
+$r = join(',', $#bar, @bar);
+if ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";}
+@bar = ();
+$r = join(',', $#bar, @bar);
+if ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";}
+$bar[0] = '0';
+$r = join(',', $#bar, @bar);
+if ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";}
+$bar[2] = '2';
+$r = join(',', $#bar, @bar);
+if ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";}
+reset 'b';
+@bar = ();
+$bar[0] = '0';
+$r = join(',', $#bar, @bar);
+if ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";}
+$bar[2] = '2';
+$r = join(',', $#bar, @bar);
+if ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";}
+
+$foo = 'now is the time';
+if (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) {
+ if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') {
+ print "ok 21\n";
+ }
+ else {
+ print "not ok 21\n";
+ }
+}
+else {
+ print "not ok 21\n";
+}
+
+$foo = 'lskjdf';
+if ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) {
+ print "not ok 22 $cnt $F1:$F2:$Etc\n";
+}
+else {
+ print "ok 22\n";
+}
+
+%foo = ('blurfl','dyick','foo','bar','etc.','etc.');
+%bar = %foo;
+print $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n";
+%bar = ();
+print $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n";
+(%bar,$a,$b) = (%foo,'how','now');
+print $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n";
+print $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n";
+@bar{keys %foo} = values %foo;
+print $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n";
+print $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n";
+
+@foo = grep(/e/,split(' ','now is the time for all good men to come to'));
+print join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n";
+
+@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
+print join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n";
#!./perl
-# $Header: op.auto,v 2.0 88/06/05 00:13:19 root Exp $
+# $Header: op.auto,v 3.0 89/10/18 15:27:00 lwall Locked $
print "1..34\n";
#!./perl
-# $Header: op.chop,v 2.0 88/06/05 00:13:22 root Exp $
+# $Header: op.chop,v 3.0 89/10/18 15:28:19 lwall Locked $
-print "1..2\n";
+print "1..4\n";
# optimized
$_ = 'abc';
$c = do foo();
-if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1\n";}
+if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1 $c$_\n";}
# unoptimized
sub foo {
chop;
}
+
+@foo = ("hi \n","there\n","!\n");
+@bar = @foo;
+chop(@bar);
+print join('',@bar) eq 'hi there!' ? "ok 3\n" : "not ok 3\n";
+
+$foo = "\n";
+chop($foo,@foo);
+print join('',$foo,@foo) eq 'hi there!' ? "ok 4\n" : "not ok 4\n";
#!./perl
-# $Header: op.cond,v 2.0 88/06/05 00:13:26 root Exp $
+# $Header: op.cond,v 3.0 89/10/18 15:28:26 lwall Locked $
print "1..4\n";
--- /dev/null
+#!./perl
+
+# $Header: op.dbm,v 3.0 89/10/18 15:28:31 lwall Locked $
+
+if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') {
+ print "1..0\n";
+ exit;
+}
+
+print "1..9\n";
+
+unlink 'Op.dbmx.dir', 'Op.dbmx.pag';
+umask(0);
+print (dbmopen(h,'Op.dbmx',0640) ? "ok 1\n" : "not ok 1\n");
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('Op.dbmx.pag');
+print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+while (($key,$value) = each(h)) {
+ $i++;
+}
+print (!$i ? "ok 3\n" : "not ok 3\n");
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+$h{'b'} = 'B';
+$h{'c'} = 'C';
+$h{'d'} = 'D';
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'G';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+dbmclose(h);
+print (dbmopen(h,'Op.dbmx',0640) ? "ok 4\n" : "not ok 4\n");
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+delete $h{'goner3'};
+
+@keys = keys(%h);
+@values = values(%h);
+
+if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+while (($key,$value) = each(h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+@keys = ('blurfl', keys(h), 'dyick');
+if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+# check cache overflow and numeric keys and contents
+$ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+print ($ok ? "ok 8\n" : "not ok 8\n");
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('Op.dbmx.pag');
+print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+unlink 'Op.dbmx.dir', 'Op.dbmx.pag';
#!./perl
-# $Header: op.delete,v 2.0 88/06/05 00:13:30 root Exp $
+# $Header: op.delete,v 3.0 89/10/18 15:28:36 lwall Locked $
print "1..6\n";
$foo = delete $foo{2};
-if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1\n";}
-if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2\n";}
+if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
+if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";}
if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";}
if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";}
$foo = join('',values(foo));
if ($foo eq 'ac' || $foo eq 'ca') {print "ok 5\n";} else {print "not ok 5\n";}
-foreach $key (keys(foo)) {
+foreach $key (keys foo) {
delete $foo{$key};
}
#!./perl
-# $Header: op.do,v 2.0 88/06/05 00:13:36 root Exp $
+# $Header: op.do,v 3.0 89/10/18 15:28:43 lwall Locked $
sub foo1
{
#!./perl
-# $Header: op.each,v 2.0 88/06/05 00:13:38 root Exp $
+# $Header: op.each,v 3.0 89/10/18 15:28:48 lwall Locked $
print "1..3\n";
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
-$h{'jkl'} = 'JKL';
-$h{'xyz'} = 'XYZ';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
$h{'a'} = 'A';
$h{'b'} = 'B';
$h{'c'} = 'C';
$h{'y'} = 'Y';
$h{'z'} = 'Z';
-@keys = keys(h);
-@values = values(h);
+@keys = keys %h;
+@values = values %h;
if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";}
if ($i == 30) {print "ok 2\n";} else {print "not ok 2\n";}
-@keys = ('blurfl', keys(h), 'dyick');
+@keys = ('blurfl', keys(%h), 'dyick');
if ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";}
#!./perl
-# $Header: op.eval,v 2.0 88/06/05 00:13:40 root Exp $
+# $Header: op.eval,v 3.0 89/10/18 15:28:53 lwall Locked $
print "1..10\n";
if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
$foo = 5;
-$fact = 'local($foo); $foo <= 1 ? 1 : $foo-- * (eval $fact);';
+$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
$ans = eval $fact;
if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
#!./perl
-# $Header: op.exec,v 2.0 88/06/05 00:13:46 root Exp $
+# $Header: op.exec,v 3.0 89/10/18 15:28:57 lwall Locked $
$| = 1; # flush stdout
print "1..8\n";
#!./perl
-# $Header: op.exp,v 2.0 88/06/05 00:13:48 root Exp $
+# $Header: op.exp,v 3.0 89/10/18 15:29:01 lwall Locked $
print "1..6\n";
#!./perl
-# $Header: op.flip,v 2.0 88/06/05 00:13:51 root Exp $
+# $Header: op.flip,v 3.0 89/10/18 15:29:07 lwall Locked $
print "1..8\n";
#!./perl
-# $Header: op.fork,v 2.0 88/06/05 00:13:53 root Exp $
+# $Header: op.fork,v 3.0 89/10/18 15:29:12 lwall Locked $
$| = 1;
print "1..2\n";
--- /dev/null
+#!./perl
+
+# $Header: op.glob,v 3.0 89/10/18 15:29:19 lwall Locked $
+
+print "1..4\n";
+
+@ops = <op.*>;
+$list = join(' ',@ops);
+
+chop($otherway = `echo op.*`);
+
+print $list eq $otherway ? "ok 1\n" : "not ok 1\n$list\n$otherway\n";
+
+print $/ eq "\n" ? "ok 2\n" : "not ok 2\n";
+
+while (<jskdfjskdfj* op.* jskdjfjkosvk*>) {
+ $not = "not " unless $_ eq shift @ops;
+ $not = "not at all " if $/ eq "\0";
+}
+print "${not}ok 3\n";
+
+print $/ eq "\n" ? "ok 4\n" : "not ok 4\n";
#!./perl
-# $Header: op.goto,v 2.0 88/06/05 00:13:58 root Exp $
+# $Header: op.goto,v 3.0 89/10/18 15:29:24 lwall Locked $
print "1..3\n";
--- /dev/null
+#!./perl
+
+# $Header: op.index,v 3.0 89/10/18 15:29:29 lwall Locked $
+
+print "1..6\n";
+
+
+$foo = 'Now is the time for all good men to come to the aid of their country.';
+
+$first = substr($foo,0,index($foo,'the'));
+print ($first eq "Now is " ? "ok 1\n" : "not ok 1\n");
+
+$last = substr($foo,rindex($foo,'the'),100);
+print ($last eq "their country." ? "ok 2\n" : "not ok 2\n");
+
+$last = substr($foo,index($foo,'Now'),2);
+print ($last eq "No" ? "ok 3\n" : "not ok 3\n");
+
+$last = substr($foo,rindex($foo,'Now'),2);
+print ($last eq "No" ? "ok 4\n" : "not ok 4\n");
+
+$last = substr($foo,index($foo,'.'),100);
+print ($last eq "." ? "ok 5\n" : "not ok 5\n");
+
+$last = substr($foo,rindex($foo,'.'),100);
+print ($last eq "." ? "ok 6\n" : "not ok 6\n");
#!./perl
-# $Header: op.int,v 2.0 88/06/05 00:14:01 root Exp $
+# $Header: op.int,v 3.0 89/10/18 15:29:33 lwall Locked $
print "1..4\n";
#!./perl
-# $Header: op.join,v 2.0 88/06/05 00:14:05 root Exp $
+# $Header: op.join,v 3.0 89/10/18 15:29:38 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: op.list,v 2.0 88/06/05 00:14:09 root Exp $
+# $Header: op.list,v 3.0 89/10/18 15:29:44 lwall Locked $
-print "1..18\n";
+print "1..27\n";
@foo = (1, 2, 3, 4);
if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";}
-$_ = join(foo,':');
+$_ = join(':',@foo);
if ($_ eq '1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
($a,$b,$c,$d) = (1,2,3,4);
if ("$a;$b;$c" eq '333;222;111') {print "ok 4\n";} else {print "not ok 4\n";}
($a,$b,$c) = ($c,$b,$a);
-if ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5\n";}
+if ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5 $a;$b;$c\n";}
($a, $b) = ($b, $a);
if ("$a;$b;$c" eq '222;111;333') {print "ok 6\n";} else {print "not ok 6\n";}
print "#11 $a;$b;$c;$d eq 1;2;3;4\n";
if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";}
-@foo = (1);
-if (join(':',@foo) eq '1') {print "ok 12\n";} else {print "not ok 12\n";}
+@foo = @bar = (1);
+if (join(':',@foo,@bar) eq '1:1') {print "ok 12\n";} else {print "not ok 12\n";}
@foo = ();
@foo = 1+2+3;
@a = ($x == $x || (4,5,6));
if (join('',@a) eq '1') {print "ok 18\n";} else {print "not ok 18\n";}
+
+if (join('',1,2,(3,4,5)) eq '12345'){print "ok 19\n";}else{print "not ok 19\n";}
+if (join('',(1,2,3,4,5)) eq '12345'){print "ok 20\n";}else{print "not ok 20\n";}
+if (join('',(1,2,3,4),5) eq '12345'){print "ok 21\n";}else{print "not ok 21\n";}
+if (join('',1,(2,3,4),5) eq '12345'){print "ok 22\n";}else{print "not ok 22\n";}
+if (join('',1,2,(3,4),5) eq '12345'){print "ok 23\n";}else{print "not ok 23\n";}
+if (join('',1,2,3,(4),5) eq '12345'){print "ok 24\n";}else{print "not ok 24\n";}
+
+for ($x = 0; $x < 3; $x++) {
+ ($a, $b, $c) = do {
+ if ($x == 0) {
+ ('ok ', 25, "\n");
+ }
+ elsif ($x == 1) {
+ ('ok ', 26, "\n");
+ }
+ else {
+ ('ok ', 27, "\n");
+ }
+ };
+
+ print $a,$b,$c;
+}
+
--- /dev/null
+#!./perl
+
+# $Header: op.local,v 3.0 89/10/18 15:29:49 lwall Locked $
+
+print "1..20\n";
+
+sub foo {
+ local($a, $b) = @_;
+ local($c, $d);
+ $c = "ok 3\n";
+ $d = "ok 4\n";
+ { local($a,$c) = ("ok 9\n", "ok 10\n"); ($x, $y) = ($a, $c); }
+ print $a, $b;
+ $c . $d;
+}
+
+$a = "ok 5\n";
+$b = "ok 6\n";
+$c = "ok 7\n";
+$d = "ok 8\n";
+
+print do foo("ok 1\n","ok 2\n");
+
+print $a,$b,$c,$d,$x,$y;
+
+# same thing, only with arrays and associative arrays
+
+sub foo2 {
+ local($a, @b) = @_;
+ local(@c, %d);
+ @c = "ok 13\n";
+ $d{''} = "ok 14\n";
+ { local($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); }
+ print $a, @b;
+ $c[0] . $d{''};
+}
+
+$a = "ok 15\n";
+@b = "ok 16\n";
+@c = "ok 17\n";
+$d{''} = "ok 18\n";
+
+print do foo2("ok 11\n","ok 12\n");
+
+print $a,@b,@c,%d,$x,$y;
#!./perl
-# $Header: op.magic,v 2.0 88/06/05 00:14:11 root Exp $
+# $Header: op.magic,v 3.0 89/10/18 15:29:54 lwall Locked $
$| = 1; # command buffering
-print "1..4\n";
+print "1..5\n";
eval '$ENV{"foo"} = "hi there";'; # check that ENV is inited inside eval
if (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";}
'-e', '$SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";',
'-e', 'sub ok3 { print "ok 3\n" if pop(@_) eq "INT"; }';
+
+@val1 = @ENV{keys(%ENV)}; # can we slice ENV?
+@val2 = values(%ENV);
+
+print join(':',@val1) eq join(':',@val2) ? "ok 5\n" : "not ok 5\n";
--- /dev/null
+#!./perl
+
+# $Header: op.mkdir,v 3.0 89/10/18 15:30:05 lwall Locked $
+
+print "1..7\n";
+
+`rm -rf blurfl`;
+
+print (mkdir('blurfl',0666) ? "ok 1\n" : "not ok 1\n");
+print (mkdir('blurfl',0666) ? "not ok 2\n" : "ok 2\n");
+print ($! == 17 ? "ok 3\n" : "not ok 3\n");
+print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n");
+print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n");
+print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n");
+print ($! == 2 ? "ok 7\n" : "not ok 7\n");
#!./perl
-# $Header: op.oct,v 2.0 88/06/05 00:14:14 root Exp $
+# $Header: op.oct,v 3.0 89/10/18 15:30:15 lwall Locked $
print "1..3\n";
#!./perl
-# $Header: op.ord,v 2.0 88/06/05 00:14:17 root Exp $
+# $Header: op.ord,v 3.0 89/10/18 15:30:29 lwall Locked $
print "1..2\n";
--- /dev/null
+#!./perl
+
+# $Header: op.pack,v 3.0 89/10/18 15:30:39 lwall Locked $
+
+print "1..3\n";
+
+$format = "c2x5CCxsila6";
+@ary = (1,-100,127,128,32767,12345,123456,"abcdef");
+$foo = pack($format,@ary);
+@ary2 = unpack($format,$foo);
+
+print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n");
+
+$out1=join(':',@ary);
+$out2=join(':',@ary2);
+print ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n");
+
+print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n");
#!./perl
-# $Header: op.pat,v 2.0 88/06/05 00:14:20 root Exp $
+# $Header: op.pat,v 3.0 89/10/18 15:30:44 lwall Locked $
-print "1..30\n";
+print "1..43\n";
$x = "abc\ndef\n";
'cde' =~ /$foo/;
'xyz' =~ /$null/;
if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";}
+
+$_ = 'abcdefghi';
+/def/; # optimized up to cmd
+if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";}
+
+/cde/ + 0; # optimized only to spat
+if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";}
+
+/[d][e][f]/; # not optimized
+if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";}
+
+$_ = 'now is the {time for all} good men to come to.';
+/ {([^}]*)}/;
+if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";}
+
+$_ = 'xxx {3,4} yyy zzz';
+print /( {3,4})/ ? "ok 35\n" : "not ok 35\n";
+print $1 eq ' ' ? "ok 36\n" : "not ok 36\n";
+print /( {4,})/ ? "not ok 37\n" : "ok 37\n";
+print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n";
+print $1 eq ' y' ? "ok 39\n" : "not ok 39\n";
+print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n";
+print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n";
+print /x {3,4}/ ? "not ok 42\n" : "ok 42\n";
+print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n";
#!./perl
-# $Header: op.push,v 2.0 88/06/05 00:14:23 root Exp $
+# $Header: op.push,v 3.0 89/10/18 15:30:48 lwall Locked $
print "1..2\n";
@x = (1,2,3);
push(@x,@x);
-if (join(x,':') eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
+if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
push(x,4);
-if (join(x,':') eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
+if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
--- /dev/null
+#!./perl
+
+# $Header: op.range,v 3.0 89/10/18 15:30:53 lwall Locked $
+
+print "1..6\n";
+
+print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n";
+
+@foo = (1,2,3,4,5,6,7,8,9);
+@foo[2..4] = ('c','d','e');
+
+print join(':',@foo[$foo[0]..5]) eq '2:c:d:e:6' ? "ok 2\n" : "not ok 2\n";
+
+@bar[2..4] = ('c','d','e');
+print join(':',@bar[1..5]) eq ':c:d:e:' ? "ok 3\n" : "not ok 3\n";
+
+($a,@bcd[0..2],$e) = ('a','b','c','d','e');
+print join(':',$a,@bcd[0..2],$e) eq 'a:b:c:d:e' ? "ok 4\n" : "not ok 4\n";
+
+$x = 0;
+for (1..100) {
+ $x += $_;
+}
+print $x == 5050 ? "ok 5\n" : "not ok 5 $x\n";
+
+$x = 0;
+for ((100,2..99,1)) {
+ $x += $_;
+}
+print $x == 5050 ? "ok 6\n" : "not ok 6 $x\n";
--- /dev/null
+#!./perl
+
+# $Header: op.read,v 3.0 89/10/18 15:30:58 lwall Locked $
+
+print "1..4\n";
+
+
+open(FOO,'op.read') || open(FOO,'t/op.read') || die "Can't open op.read";
+seek(FOO,4,0);
+$got = read(FOO,$buf,4);
+
+print ($got == 4 ? "ok 1\n" : "not ok 1\n");
+print ($buf eq "perl" ? "ok 2\n" : "not ok 2 :$buf:\n");
+
+seek(FOO,20000,0);
+$got = read(FOO,$buf,4);
+
+print ($got == 0 ? "ok 3\n" : "not ok 3\n");
+print ($buf eq "" ? "ok 4\n" : "not ok 4\n");
#!./perl
-# $Header: op.regexp,v 2.0 88/06/05 00:14:27 root Exp $
+# $Header: op.regexp,v 3.0 89/10/18 15:31:02 lwall Locked $
open(TESTS,'re_tests') || open(TESTS,'t/re_tests') || die "Can't open re_tests";
while (<TESTS>) { }
#!./perl
-# $Header: op.repeat,v 2.0 88/06/05 00:14:31 root Exp $
+# $Header: op.repeat,v 3.0 89/10/18 15:31:07 lwall Locked $
print "1..11\n";
#!./perl
-# $Header: op.sleep,v 2.0 88/06/05 00:14:35 root Exp $
+# $Header: op.sleep,v 3.0 89/10/18 15:31:15 lwall Locked $
print "1..1\n";
--- /dev/null
+#!./perl
+
+# $Header: op.sort,v 3.0 89/10/18 15:31:19 lwall Locked $
+
+print "1..3\n";
+
+sub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; }
+
+@harry = ('dog','cat','x','Cain','Abel');
+@george = ('gone','chased','yz','Punished','Axed');
+
+$x = join('', sort @harry);
+print ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n");
+
+$x = join('', sort reverse @harry);
+print ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n");
+
+$x = join('', sort @george, 'to', @harry);
+print ($x eq 'AbelAxedCainPunishedcatchaseddoggonetoxyz'?"ok 3\n":"not ok 3\n");
#!./perl
-# $Header: op.split,v 2.0 88/06/05 00:14:37 root Exp $
+# $Header: op.split,v 3.0 89/10/18 15:31:24 lwall Locked $
-print "1..7\n";
+print "1..12\n";
$FS = ':';
if (join("$_",@ary) eq 'aa:b:cc') {print "ok 2\n";} else {print "not ok 2\n";}
$_ = "abc\n";
-@ary = split(//);
+@xyz = (@ary = split(//));
if (join(".",@ary) eq "a.b.c.\n") {print "ok 3\n";} else {print "not ok 3\n";}
$_ = "a:b:c::::";
$_ = join(':', 'foo', split(/ /,'a b c'), 'bar');
if ($_ eq "foo:a:b::c:bar") {print "ok 7\n";} else {print "not ok 7 $_\n";}
+# Can we say how many fields to split to?
+$_ = join(':', split(' ','1 2 3 4 5 6', 3));
+print $_ eq '1:2:3 4 5 6' ? "ok 8\n" : "not ok 8 $_\n";
+
+# Can we do it as a variable?
+$x = 4;
+$_ = join(':', split(' ','1 2 3 4 5 6', $x));
+print $_ eq '1:2:3:4 5 6' ? "ok 9\n" : "not ok 9 $_\n";
+
+# Does the 999 suppress null field chopping?
+$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999));
+print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n";
+
+# Does assignment to a list imply split to one more field than that?
+$foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`;
+print $foo eq '' || $foo =~ /num\(3\)/ ? "ok 11\n" : "not ok 11\n";
+
+# Can we say how many fields to split to when assigning to a list?
+($a,$b) = split(' ','1 2 3 4 5 6', 2);
+$_ = join(':',$a,$b);
+print $_ eq '1:2 3 4 5 6' ? "ok 12\n" : "not ok 12 $_\n";
+
#!./perl
-# $Header: op.sprintf,v 2.0 88/06/05 00:14:40 root Exp $
+# $Header: op.sprintf,v 3.0 89/10/18 15:31:28 lwall Locked $
print "1..1\n";
-$x = sprintf("%3s %-4s foo %5d%c%3.1f","hi",123,456,65,3.0999);
-if ($x eq ' hi 123 foo 456A3.1') {print "ok 1\n";} else {print "not ok 1\n";}
+$x = sprintf("%3s %-4s%%foo %5d%c%3.1f","hi",123,456,65,3.0999);
+if ($x eq ' hi 123 %foo 456A3.1') {print "ok 1\n";} else {print "not ok 1 '$x'\n";}
#!./perl
-# $Header: op.stat,v 2.0 88/06/05 00:14:43 root Exp $
+# $Header: op.stat,v 3.0 89/10/18 15:31:33 lwall Locked $
print "1..56\n";
+unlink "Op.stat.tmp";
open(foo, ">Op.stat.tmp");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
if ($uid > 0 && $uid < $cnt) {print "ok 35\n";} else {print "not ok 35\n";}
unless (open(tty,"/dev/tty")) {
- print stderr "Can't open /dev/tty--run t/TEST outside of make.\n";
+ print STDERR "Can't open /dev/tty--run t/TEST outside of make.\n";
}
if (-t tty) {print "ok 36\n";} else {print "not ok 36\n";}
if (-c tty) {print "ok 37\n";} else {print "not ok 37\n";}
close(tty);
if (! -t tty) {print "ok 38\n";} else {print "not ok 38\n";}
open(null,"/dev/null");
-if (! -t null) {print "ok 39\n";} else {print "not ok 39\n";}
+if (! -t null || -e '/xenix') {print "ok 39\n";} else {print "not ok 39\n";}
close(null);
if (-t) {print "ok 40\n";} else {print "not ok 40\n";}
#!./perl
-# $Header: op.study,v 2.0 88/06/05 00:14:45 root Exp $
+# $Header: op.study,v 3.0 89/10/18 15:31:38 lwall Locked $
print "1..24\n";
#!./perl
-# $Header: op.subst,v 2.0 88/06/05 00:14:49 root Exp $
+# $Header: op.subst,v 3.0 89/10/18 15:31:43 lwall Locked $
-print "1..13\n";
+print "1..42\n";
$x = 'foo';
$_ = "x";
{print "ok 5\n";} else {print "not ok 5\n";}
if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx')
- {print "ok 6\n";} else {print "not ok 6\n";}
+ {print "ok 6\n";} else {print "not ok 6 $a\n";}
if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx')
{print "ok 7\n";} else {print "not ok 7 $a\n";}
$_ = 'ABACADA';
-if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8\n";}
+if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";}
$_ = '\\' x 4;
if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";}
s/\//\/\//g;
if ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";}
if (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";}
+
+$_ = 'aaaXXXXbbb';
+s/^a//;
+print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n";
+
+$_ = 'aaaXXXXbbb';
+s/a//;
+print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n";
+
+$_ = 'aaaXXXXbbb';
+s/^a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n";
+
+$_ = 'aaaXXXXbbb';
+s/a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n";
+
+$_ = 'aaaXXXXbbb';
+s/aa//;
+print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n";
+
+$_ = 'aaaXXXXbbb';
+s/aa/b/;
+print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n";
+
+$_ = 'aaaXXXXbbb';
+s/b$//;
+print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n";
+
+$_ = 'aaaXXXXbbb';
+s/b//;
+print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n";
+
+$_ = 'aaaXXXXbbb';
+s/bb//;
+print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n";
+
+$_ = 'aaaXXXXbbb';
+s/aX/y/;
+print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n";
+
+$_ = 'aaaXXXXbbb';
+s/Xb/z/;
+print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n";
+
+$_ = 'aaaXXXXbbb';
+s/aaX.*Xbb//;
+print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n";
+
+$_ = 'aaaXXXXbbb';
+s/bb/x/;
+print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n";
+
+# now for some unoptimized versions of the same.
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/^a//;
+print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/a//;
+print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/^a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aa//;
+print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aa/b/;
+print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/b$//;
+print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/b//;
+print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/bb//;
+print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aX/y/;
+print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/Xb/z/;
+print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aaX.*Xbb//;
+print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/bb/x/;
+print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n";
+
+$_ = 'abc123xyz';
+s/\d+/$&*2/e; # yields 'abc246xyz'
+print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n";
+s/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz'
+print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n";
+s/\w/$& x 2/eg; # yields 'aabbcc 224466xxyyzz'
+print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n";
--- /dev/null
+#!./perl
+
+# $Header: op.substr,v 3.0 89/10/18 15:31:52 lwall Locked $
+
+print "1..19\n";
+
+$a = 'abcdefxyz';
+
+print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n");
+print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n");
+print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n");
+print (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n");
+print (substr($a,6,-1) eq '' ? "ok 5\n" : "not ok 5\n");
+print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n");
+
+$[ = 1;
+
+print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n");
+print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n");
+print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n");
+print (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n");
+print (substr($a,7,-1) eq '' ? "ok 11\n" : "not ok 11\n");
+print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n");
+
+$[ = 0;
+
+substr($a,3,3) = 'XYZ';
+print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n";
+substr($a,0,2) = '';
+print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n";
+y/a/a/;
+substr($a,0,0) = 'ab';
+print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n";
+substr($a,0,0) = '12345678';
+print $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n";
+substr($a,-3,3) = 'def';
+print $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n";
+substr($a,-3,3) = '<';
+print $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n";
+substr($a,-1,1) = '12345678';
+print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n";
+
#!./perl
-# $Header: op.time,v 2.0 88/06/05 00:14:58 root Exp $
+# $Header: op.time,v 3.0 89/10/18 15:31:56 lwall Locked $
print "1..5\n";
--- /dev/null
+#!./perl
+
+# $Header: op.undef,v 3.0 89/10/18 15:32:01 lwall Locked $
+
+print "1..21\n";
+
+print defined($a) ? "not ok 1\n" : "ok 1\n";
+
+$a = 1+1;
+print defined($a) ? "ok 2\n" : "not ok 2\n";
+
+undef $a;
+print defined($a) ? "not ok 3\n" : "ok 3\n";
+
+$a = "hi";
+print defined($a) ? "ok 4\n" : "not ok 4\n";
+
+$a = $b;
+print defined($a) ? "not ok 5\n" : "ok 5\n";
+
+@ary = ("1arg");
+$a = pop(@ary);
+print defined($a) ? "ok 6\n" : "not ok 6\n";
+$a = pop(@ary);
+print defined($a) ? "not ok 7\n" : "ok 7\n";
+
+@ary = ("1arg");
+$a = shift(@ary);
+print defined($a) ? "ok 8\n" : "not ok 8\n";
+$a = shift(@ary);
+print defined($a) ? "not ok 9\n" : "ok 9\n";
+
+$ary{'foo'} = 'hi';
+print defined($ary{'foo'}) ? "ok 10\n" : "not ok 10\n";
+print defined($ary{'bar'}) ? "not ok 11\n" : "ok 11\n";
+undef $ary{'foo'};
+print defined($ary{'foo'}) ? "not ok 12\n" : "ok 12\n";
+
+print defined(@ary) ? "ok 13\n" : "not ok 13\n";
+print defined(%ary) ? "ok 14\n" : "not ok 14\n";
+undef @ary;
+print defined(@ary) ? "not ok 15\n" : "ok 15\n";
+undef %ary;
+print defined(%ary) ? "not ok 16\n" : "ok 16\n";
+@ary = (1);
+print defined @ary ? "ok 17\n" : "not ok 18\n";
+%ary = (1,1);
+print defined %ary ? "ok 18\n" : "not ok 18\n";
+
+sub foo { print "ok 19\n"; }
+
+&foo || print "not ok 19\n";
+
+print defined &foo ? "ok 20\n" : "not ok 20\n";
+undef &foo;
+print defined(&foo) ? "not ok 21\n" : "ok 21\n";
#!./perl
-# $Header: op.unshift,v 2.0 88/06/05 00:15:00 root Exp $
+# $Header: op.unshift,v 3.0 89/10/18 15:32:06 lwall Locked $
print "1..2\n";
--- /dev/null
+#!./perl
+
+# $Header: op.vec,v 3.0 89/10/18 15:32:11 lwall Locked $
+
+print "1..13\n";
+
+print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n";
+print length($foo) == 0 ? "ok 2\n" : "not ok 2\n";
+vec($foo,0,1) = 1;
+print length($foo) == 1 ? "ok 3\n" : "not ok 3\n";
+print ord($foo) == 1 ? "ok 4\n" : "not ok 4\n";
+print vec($foo,0,1) == 1 ? "ok 5\n" : "not ok 5\n";
+
+print vec($foo,20,1) == 0 ? "ok 6\n" : "not ok 6\n";
+vec($foo,20,1) = 1;
+print vec($foo,20,1) == 1 ? "ok 7\n" : "not ok 7\n";
+print length($foo) == 3 ? "ok 8\n" : "not ok 8\n";
+print vec($foo,1,8) == 0 ? "ok 9\n" : "not ok 9\n";
+vec($foo,1,8) = 0xf1;
+print vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n";
+print ((ord(substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n");
+print vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n";
+print vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n";
+
--- /dev/null
+#!./perl
+
+# $Header: op.write,v 3.0 89/10/18 15:32:16 lwall Locked $
+
+print "1..2\n";
+
+format OUT =
+the quick brown @<<
+$fox
+jumped
+@*
+$multiline
+^<<<<<<<<<
+$foo
+^<<<<<<<<<
+$foo
+^<<<<<<...
+$foo
+now @<<the@>>>> for all@|||||men to come @<<<<
+'i' . 's', "time\n", $good, 'to'
+.
+
+open(OUT, '>Op.write.tmp') || die "Can't create Op.write.tmp";
+
+$fox = 'foxiness';
+$good = 'good';
+$multiline = "forescore\nand\nseven years\n";
+$foo = 'when in the course of human events it becomes necessary';
+write(OUT);
+close OUT;
+
+$right =
+"the quick brown fox
+jumped
+forescore
+and
+seven years
+when in
+the course
+of huma...
+now is the time for all good men to come to\n";
+
+if (`cat Op.write.tmp` eq $right)
+ { print "ok 1\n"; unlink 'Op.write.tmp'; }
+else
+ { print "not ok 1\n"; }
+
+format OUT2 =
+the quick brown @<<
+$fox
+jumped
+@*
+$multiline
+^<<<<<<<<< ~~
+$foo
+now @<<the@>>>> for all@|||||men to come @<<<<
+'i' . 's', "time\n", $good, 'to'
+.
+
+open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp";
+
+$fox = 'foxiness';
+$good = 'good';
+$multiline = "forescore\nand\nseven years\n";
+$foo = 'when in the course of human events it becomes necessary';
+write(OUT2);
+close OUT2;
+
+$right =
+"the quick brown fox
+jumped
+forescore
+and
+seven years
+when in
+the course
+of human
+events it
+becomes
+necessary
+now is the time for all good men to come to\n";
+
+if (`cat Op.write.tmp` eq $right)
+ { print "ok 2\n"; unlink 'Op.write.tmp'; }
+else
+ { print "not ok 2\n"; }
+
ab*bc abc y $& abc
ab*bc abbc y $& abbc
ab*bc abbbbc y $& abbbbc
+ab{0,}bc abbbbc y $& abbbbc
ab+bc abbc y $& abbc
ab+bc abc n - -
ab+bc abq n - -
+ab{1,}bc abq n - -
ab+bc abbbbc y $& abbbbc
+ab{1,}bc abbbbc y $& abbbbc
+ab{1,3}bc abbbbc y $& abbbbc
+ab{3,4}bc abbbbc y $& abbbbc
+ab{4,5}bc abbbbc n - -
ab?bc abbc y $& abbc
ab?bc abc y $& abc
+ab{0,1}bc abc y $& abc
ab?bc abbbbc n - -
ab?c abc y $& abc
+ab{0,1}c abc y $& abc
^abc$ abc y $& abc
^abc$ abcc n - -
^abc abcc y $& abc
((a)) abc y $&-$1-$2 a-a-a
(a)b(c) abc y $&-$1-$2 abc-a-c
a+b+c aabbabc y $& abc
+a{1,}b{1,}c aabbabc y $& abc
a** - c - -
a*? - c - -
(a*)* - c - -
(a|)* - c - -
(a*|b)* - c - -
(a+|b)* ab y $&-$1 ab-b
+(a+|b){0,} ab y $&-$1 ab-b
(a+|b)+ ab y $&-$1 ab-b
+(a+|b){1,} ab y $&-$1 ab-b
(a+|b)? ab y $&-$1 a-a
+(a+|b){0,1} ab y $&-$1 a-a
(^)* - c - -
(ab|)* - c - -
)( - c - -
-/* $Header: toke.c,v 2.0.1.1 88/06/28 16:39:50 root Exp $
+/* $Header: toke.c,v 3.0 89/10/18 15:32: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: toke.c,v $
- * Revision 2.0.1.1 88/06/28 16:39:50 root
- * patch1: tr/x/y/ can dump core if y is shorter than x
- *
- * Revision 2.0 88/06/05 00:11:16 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:32:33 lwall
+ * 3.0 baseline
*
*/
#include "perl.h"
#include "perly.h"
+char *reparse; /* if non-null, scanreg found ${foo[$bar]} */
+
#define CLINE (cmdline = (line < cmdline ? line : cmdline))
+#define META(c) ((c) | 128)
+
#define RETURN(retval) return (bufptr = s,(int)retval)
#define OPERATOR(retval) return (expectterm = TRUE,bufptr = s,(int)retval)
#define TERM(retval) return (CLINE, expectterm = FALSE,bufptr = s,(int)retval)
#define LOOPX(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)LOOPEX)
-#define UNI(f) return(yylval.ival = f,expectterm = TRUE,bufptr = s,(int)UNIOP)
#define FTST(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)FILETEST)
#define FUN0(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC0)
#define FUN1(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC1)
#define FUN2(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2)
#define FUN3(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC3)
-#define SFUN(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)STABFUN)
-#define LFUN(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)LVALFUN)
+#define FL(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST)
+#define FL2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST2)
+#define HFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)HSHFUN)
+#define HFUN3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)HSHFUN3)
+#define LFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LVALFUN)
+#define LFUN4(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)LFUNC4)
+#define AOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)ADDOP)
+#define MOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)MULOP)
+#define EOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)EQOP)
+#define ROP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)RELOP)
+#define FOP(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP)
+#define FOP2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP2)
+#define FOP3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP3)
+#define FOP4(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP4)
+#define FOP22(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP22)
+#define FOP25(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP25)
+
+/* This bit of chicanery makes a unary function followed by
+ * a parenthesis into a function with one argument, highest precedence.
+ */
+#define UNI(f) return(yylval.ival = f,expectterm = TRUE,bufptr = s, \
+ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
+
+/* This does similarly for list operators, merely by pretending that the
+ * paren came before the listop rather than after.
+ */
+#define LOP(f) return(*s == '(' || (s = skipspace(s), *s == '(') ? \
+ (*s = META('('), bufptr = oldbufptr, '(') : \
+ (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
+
+char *
+skipspace(s)
+register char *s;
+{
+ while (s < bufend && isascii(*s) && isspace(*s))
+ s++;
+ return s;
+}
yylex()
{
register int tmp;
static bool in_format = FALSE;
static bool firstline = TRUE;
+ extern int yychar; /* last token */
+
+ oldoldbufptr = oldbufptr;
+ oldbufptr = s;
retry:
#ifdef YYDEBUG
#endif
switch (*s) {
default:
- fprintf(stderr,
- "Unrecognized character %c in file %s line %ld--ignoring.\n",
- *s++,filename,(long)line);
+ if ((*s & 127) == '(')
+ *s++ = '(';
+ else
+ warn("Unrecognized character \\%03o ignored", *s++);
goto retry;
case 0:
- s = str_get(linestr);
- *s = '\0';
- if (firstline && (minus_n || minus_p)) {
- firstline = FALSE;
- str_set(linestr,"line: while (<>) {");
- if (minus_a)
- str_cat(linestr,"@F=split(' ');");
- s = str_get(linestr);
- goto retry;
- }
if (!rsfp)
RETURN(0);
+ if (s++ < bufend)
+ goto retry; /* ignore stray nulls */
+ if (firstline) {
+ firstline = FALSE;
+ if (minus_n || minus_p || perldb) {
+ str_set(linestr,"");
+ if (perldb)
+ str_cat(linestr,"do 'perldb.pl'; print $@;");
+ if (minus_n || minus_p) {
+ str_cat(linestr,"line: while (<>) {");
+ if (minus_a)
+ str_cat(linestr,"@F=split(' ');");
+ }
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ goto retry;
+ }
+ }
if (in_format) {
- yylval.formval = load_format(); /* leaves . in buffer */
+ yylval.formval = load_format();
in_format = FALSE;
- s = str_get(linestr);
+ oldoldbufptr = oldbufptr = s = str_get(linestr) + 1;
+ bufend = linestr->str_ptr + linestr->str_cur;
TERM(FORMLIST);
}
line++;
- if ((s = str_gets(linestr, rsfp)) == Nullch) {
+ if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
if (preprocess)
- pclose(rsfp);
+ (void)mypclose(rsfp);
else if (rsfp != stdin)
- fclose(rsfp);
+ (void)fclose(rsfp);
rsfp = Nullfp;
if (minus_n || minus_p) {
str_set(linestr,minus_p ? "}continue{print;" : "");
str_cat(linestr,"}");
- s = str_get(linestr);
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
+ bufend = linestr->str_ptr + linestr->str_cur;
goto retry;
}
- s = str_get(linestr);
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
+ str_set(linestr,"");
RETURN(0);
}
+ oldoldbufptr = oldbufptr = bufptr = s;
+ if (perldb) {
+ STR *str = Str_new(85,0);
+
+ str_sset(str,linestr);
+ astore(lineary,(int)line,str);
+ }
#ifdef DEBUG
- else if (firstline) {
+ if (firstline) {
char *showinput();
s = showinput();
}
#endif
+ bufend = linestr->str_ptr + linestr->str_cur;
firstline = FALSE;
goto retry;
case ' ': case '\t': case '\f':
s[1] == ' ' && isdigit(s[2])) {
line = atoi(s+2)-1;
for (s += 2; isdigit(*s); s++) ;
- while (*s && isspace(*s)) s++;
+ d = bufend;
+ while (s < d && isspace(*s)) s++;
if (filename)
- safefree(filename);
+ Safefree(filename);
s[strlen(s)-1] = '\0'; /* wipe out newline */
if (*s == '"') {
s++;
filename = savestr(s);
else
filename = savestr(origfilename);
- s = str_get(linestr);
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
}
- if (in_eval) {
- while (*s && *s != '\n')
+ if (in_eval && !rsfp) {
+ d = bufend;
+ while (s < d && *s != '\n')
s++;
- if (*s)
+ if (s < d) {
s++;
- line++;
+ line++;
+ }
}
- else
+ else {
*s = '\0';
- if (lex_newlines)
- RETURN('\n');
+ bufend = s;
+ }
goto retry;
case '-':
if (s[1] && isalpha(s[1]) && !isalpha(s[2])) {
break;
}
}
- /*FALL THROUGH*/
+ tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ RETURN(DEC);
+ }
+ if (expectterm)
+ OPERATOR('-');
+ else
+ AOP(O_SUBTRACT);
case '+':
- if (s[1] == *s) {
+ tmp = *s++;
+ if (*s == tmp) {
s++;
- if (*s++ == '+')
- RETURN(INC);
- else
- RETURN(DEC);
+ RETURN(INC);
}
- /* FALL THROUGH */
+ if (expectterm)
+ OPERATOR('+');
+ else
+ AOP(O_ADD);
+
case '*':
+ if (expectterm) {
+ s = scanreg(s,bufend,tokenbuf);
+ yylval.stabval = stabent(tokenbuf,TRUE);
+ TERM(STAR);
+ }
+ tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ OPERATOR(POW);
+ }
+ MOP(O_MULTIPLY);
case '%':
+ if (expectterm) {
+ s = scanreg(s,bufend,tokenbuf);
+ yylval.stabval = stabent(tokenbuf,TRUE);
+ TERM(HSH);
+ }
+ s++;
+ MOP(O_MODULO);
+
case '^':
case '~':
case '(':
if (tmp == '&')
OPERATOR(ANDAND);
s--;
+ if (expectterm) {
+ d = bufend;
+ while (s < d && isspace(*s))
+ s++;
+ if (isalpha(*s) || *s == '_' || *s == '\'')
+ *(--s) = '\\'; /* force next ident to WORD */
+ OPERATOR(AMPER);
+ }
OPERATOR('&');
case '|':
s++;
s++;
tmp = *s++;
if (tmp == '=')
- OPERATOR(EQ);
+ EOP(O_EQ);
if (tmp == '~')
OPERATOR(MATCH);
s--;
s++;
tmp = *s++;
if (tmp == '=')
- OPERATOR(NE);
+ EOP(O_NE);
if (tmp == '~')
OPERATOR(NMATCH);
s--;
if (tmp == '<')
OPERATOR(LS);
if (tmp == '=')
- OPERATOR(LE);
+ ROP(O_LE);
s--;
- OPERATOR('<');
+ ROP(O_LT);
case '>':
s++;
tmp = *s++;
if (tmp == '>')
OPERATOR(RS);
if (tmp == '=')
- OPERATOR(GE);
+ ROP(O_GE);
s--;
- OPERATOR('>');
+ ROP(O_GT);
#define SNARFWORD \
d = tokenbuf; \
- while (isalpha(*s) || isdigit(*s) || *s == '_') \
+ while (isascii(*s) && \
+ (isalpha(*s) || isdigit(*s) || *s == '_' || *s == '\'')) \
*d++ = *s++; \
+ if (d[-1] == '\'') \
+ d--,s--; \
*d = '\0'; \
d = tokenbuf;
case '$':
if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) {
s++;
- s = scanreg(s,tokenbuf);
+ s = scanreg(s,bufend,tokenbuf);
yylval.stabval = aadd(stabent(tokenbuf,TRUE));
TERM(ARYLEN);
}
- s = scanreg(s,tokenbuf);
+ d = s;
+ s = scanreg(s,bufend,tokenbuf);
+ if (reparse) { /* turn ${foo[bar]} into ($foo[bar]) */
+ do_reparse:
+ s[-1] = ')';
+ s = d;
+ s[1] = s[0];
+ s[0] = '(';
+ goto retry;
+ }
yylval.stabval = stabent(tokenbuf,TRUE);
TERM(REG);
case '@':
- s = scanreg(s,tokenbuf);
- yylval.stabval = aadd(stabent(tokenbuf,TRUE));
+ d = s;
+ s = scanreg(s,bufend,tokenbuf);
+ if (reparse)
+ goto do_reparse;
+ yylval.stabval = stabent(tokenbuf,TRUE);
TERM(ARY);
case '/': /* may either be division or pattern */
TERM(PATTERN);
}
tmp = *s++;
+ if (tmp == '/')
+ MOP(O_DIVIDE);
OPERATOR(tmp);
case '.':
if (!expectterm || !isdigit(s[1])) {
- s++;
tmp = *s++;
- if (tmp == '.')
+ if (*s == tmp) {
+ s++;
OPERATOR(DOTDOT);
- s--;
- OPERATOR('.');
+ }
+ AOP(O_CONCAT);
}
/* FALL THROUGH */
case '0': case '1': case '2': case '3': case '4':
s = scanstr(s);
TERM(RSTRING);
+ case '\\': /* some magic to force next word to be a WORD */
+ s++; /* used by do and sub to force a separate namespace */
+ /* FALL THROUGH */
case '_':
SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ break;
case 'a': case 'A':
SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"accept"))
+ FOP22(O_ACCEPT);
+ if (strEQ(d,"atan2"))
+ FUN2(O_ATAN2);
+ break;
case 'b': case 'B':
SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"bind"))
+ FOP2(O_BIND);
+ break;
case 'c': case 'C':
SNARFWORD;
+ if (strEQ(d,"chop"))
+ LFUN(O_CHOP);
if (strEQ(d,"continue"))
OPERATOR(CONTINUE);
if (strEQ(d,"chdir"))
UNI(O_CHDIR);
if (strEQ(d,"close"))
- OPERATOR(CLOSE);
- if (strEQ(d,"crypt"))
+ FOP(O_CLOSE);
+ if (strEQ(d,"closedir"))
+ FOP(O_CLOSEDIR);
+ if (strEQ(d,"crypt")) {
+#ifdef FCRYPT
+ init_des();
+#endif
FUN2(O_CRYPT);
- if (strEQ(d,"chop"))
- LFUN(O_CHOP);
- if (strEQ(d,"chmod")) {
- yylval.ival = O_CHMOD;
- OPERATOR(LISTOP);
}
- if (strEQ(d,"chown")) {
- yylval.ival = O_CHOWN;
- OPERATOR(LISTOP);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"chmod"))
+ LOP(O_CHMOD);
+ if (strEQ(d,"chown"))
+ LOP(O_CHOWN);
+ if (strEQ(d,"connect"))
+ FOP2(O_CONNECT);
+ if (strEQ(d,"cos"))
+ UNI(O_COS);
+ if (strEQ(d,"chroot"))
+ UNI(O_CHROOT);
+ break;
case 'd': case 'D':
SNARFWORD;
- if (strEQ(d,"do"))
+ if (strEQ(d,"do")) {
+ d = bufend;
+ while (s < d && isspace(*s))
+ s++;
+ if (isalpha(*s) || *s == '_')
+ *(--s) = '\\'; /* force next ident to WORD */
OPERATOR(DO);
+ }
if (strEQ(d,"die"))
- UNI(O_DIE);
+ LOP(O_DIE);
+ if (strEQ(d,"defined"))
+ LFUN(O_DEFINED);
if (strEQ(d,"delete"))
OPERATOR(DELETE);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"dbmopen"))
+ HFUN3(O_DBMOPEN);
+ if (strEQ(d,"dbmclose"))
+ HFUN(O_DBMCLOSE);
+ if (strEQ(d,"dump"))
+ LOOPX(O_DUMP);
+ break;
case 'e': case 'E':
SNARFWORD;
if (strEQ(d,"else"))
OPERATOR(ELSIF);
}
if (strEQ(d,"eq") || strEQ(d,"EQ"))
- OPERATOR(SEQ);
+ EOP(O_SEQ);
if (strEQ(d,"exit"))
UNI(O_EXIT);
if (strEQ(d,"eval")) {
UNI(O_EVAL); /* we don't know what will be used */
}
if (strEQ(d,"eof"))
- TERM(FEOF);
+ FOP(O_EOF);
if (strEQ(d,"exp"))
- FUN1(O_EXP);
+ UNI(O_EXP);
if (strEQ(d,"each"))
- SFUN(O_EACH);
+ HFUN(O_EACH);
if (strEQ(d,"exec")) {
- yylval.ival = O_EXEC;
- OPERATOR(LISTOP);
+ set_csh();
+ LOP(O_EXEC);
}
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"endhostent"))
+ FUN0(O_EHOSTENT);
+ if (strEQ(d,"endnetent"))
+ FUN0(O_ENETENT);
+ if (strEQ(d,"endservent"))
+ FUN0(O_ESERVENT);
+ if (strEQ(d,"endprotoent"))
+ FUN0(O_EPROTOENT);
+ if (strEQ(d,"endpwent"))
+ FUN0(O_EPWENT);
+ if (strEQ(d,"endgrent"))
+ FUN0(O_EGRENT);
+ break;
case 'f': case 'F':
SNARFWORD;
if (strEQ(d,"for"))
if (strEQ(d,"foreach"))
OPERATOR(FOR);
if (strEQ(d,"format")) {
+ d = bufend;
+ while (s < d && isspace(*s))
+ s++;
+ if (isalpha(*s) || *s == '_')
+ *(--s) = '\\'; /* force next ident to WORD */
in_format = TRUE;
- OPERATOR(FORMAT);
+ allstabs = TRUE; /* must initialize everything since */
+ OPERATOR(FORMAT); /* we don't know what will be used */
}
if (strEQ(d,"fork"))
FUN0(O_FORK);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"fcntl"))
+ FOP3(O_FCNTL);
+ if (strEQ(d,"fileno"))
+ FOP(O_FILENO);
+ if (strEQ(d,"flock"))
+ FOP2(O_FLOCK);
+ break;
case 'g': case 'G':
SNARFWORD;
if (strEQ(d,"gt") || strEQ(d,"GT"))
- OPERATOR(SGT);
+ ROP(O_SGT);
if (strEQ(d,"ge") || strEQ(d,"GE"))
- OPERATOR(SGE);
+ ROP(O_SGE);
+ if (strEQ(d,"grep"))
+ FL2(O_GREP);
if (strEQ(d,"goto"))
LOOPX(O_GOTO);
if (strEQ(d,"gmtime"))
- FUN1(O_GMTIME);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ UNI(O_GMTIME);
+ if (strEQ(d,"getc"))
+ FOP(O_GETC);
+ if (strnEQ(d,"get",3)) {
+ d += 3;
+ if (*d == 'p') {
+ if (strEQ(d,"ppid"))
+ FUN0(O_GETPPID);
+ if (strEQ(d,"pgrp"))
+ UNI(O_GETPGRP);
+ if (strEQ(d,"priority"))
+ FUN2(O_GETPRIORITY);
+ if (strEQ(d,"protobyname"))
+ UNI(O_GPBYNAME);
+ if (strEQ(d,"protobynumber"))
+ FUN1(O_GPBYNUMBER);
+ if (strEQ(d,"protoent"))
+ FUN0(O_GPROTOENT);
+ if (strEQ(d,"pwent"))
+ FUN0(O_GPWENT);
+ if (strEQ(d,"pwnam"))
+ FUN1(O_GPWNAM);
+ if (strEQ(d,"pwuid"))
+ FUN1(O_GPWUID);
+ if (strEQ(d,"peername"))
+ FOP(O_GETPEERNAME);
+ }
+ else if (*d == 'h') {
+ if (strEQ(d,"hostbyname"))
+ UNI(O_GHBYNAME);
+ if (strEQ(d,"hostbyaddr"))
+ FUN2(O_GHBYADDR);
+ if (strEQ(d,"hostent"))
+ FUN0(O_GHOSTENT);
+ }
+ else if (*d == 'n') {
+ if (strEQ(d,"netbyname"))
+ UNI(O_GNBYNAME);
+ if (strEQ(d,"netbyaddr"))
+ FUN2(O_GNBYADDR);
+ if (strEQ(d,"netent"))
+ FUN0(O_GNETENT);
+ }
+ else if (*d == 's') {
+ if (strEQ(d,"servbyname"))
+ FUN2(O_GSBYNAME);
+ if (strEQ(d,"servbyport"))
+ FUN2(O_GSBYPORT);
+ if (strEQ(d,"servent"))
+ FUN0(O_GSERVENT);
+ if (strEQ(d,"sockname"))
+ FOP(O_GETSOCKNAME);
+ if (strEQ(d,"sockopt"))
+ FOP3(O_GSOCKOPT);
+ }
+ else if (*d == 'g') {
+ if (strEQ(d,"grent"))
+ FUN0(O_GGRENT);
+ if (strEQ(d,"grnam"))
+ FUN1(O_GGRNAM);
+ if (strEQ(d,"grgid"))
+ FUN1(O_GGRGID);
+ }
+ else if (*d == 'l') {
+ if (strEQ(d,"login"))
+ FUN0(O_GETLOGIN);
+ }
+ d -= 3;
+ }
+ break;
case 'h': case 'H':
SNARFWORD;
if (strEQ(d,"hex"))
- FUN1(O_HEX);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ UNI(O_HEX);
+ break;
case 'i': case 'I':
SNARFWORD;
if (strEQ(d,"if")) {
if (strEQ(d,"index"))
FUN2(O_INDEX);
if (strEQ(d,"int"))
- FUN1(O_INT);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ UNI(O_INT);
+ if (strEQ(d,"ioctl"))
+ FOP3(O_IOCTL);
+ break;
case 'j': case 'J':
SNARFWORD;
if (strEQ(d,"join"))
- OPERATOR(JOIN);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ FL2(O_JOIN);
+ break;
case 'k': case 'K':
SNARFWORD;
if (strEQ(d,"keys"))
- SFUN(O_KEYS);
- if (strEQ(d,"kill")) {
- yylval.ival = O_KILL;
- OPERATOR(LISTOP);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ HFUN(O_KEYS);
+ if (strEQ(d,"kill"))
+ LOP(O_KILL);
+ break;
case 'l': case 'L':
SNARFWORD;
if (strEQ(d,"last"))
if (strEQ(d,"local"))
OPERATOR(LOCAL);
if (strEQ(d,"length"))
- FUN1(O_LENGTH);
+ UNI(O_LENGTH);
if (strEQ(d,"lt") || strEQ(d,"LT"))
- OPERATOR(SLT);
+ ROP(O_SLT);
if (strEQ(d,"le") || strEQ(d,"LE"))
- OPERATOR(SLE);
+ ROP(O_SLE);
if (strEQ(d,"localtime"))
- FUN1(O_LOCALTIME);
+ UNI(O_LOCALTIME);
if (strEQ(d,"log"))
- FUN1(O_LOG);
+ UNI(O_LOG);
if (strEQ(d,"link"))
FUN2(O_LINK);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"listen"))
+ FOP2(O_LISTEN);
+ if (strEQ(d,"lstat"))
+ FOP(O_LSTAT);
+ break;
case 'm': case 'M':
SNARFWORD;
if (strEQ(d,"m")) {
s = scanpat(s-1);
- TERM(PATTERN);
+ if (yylval.arg)
+ TERM(PATTERN);
+ else
+ RETURN(1); /* force error */
}
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"mkdir"))
+ FUN2(O_MKDIR);
+ break;
case 'n': case 'N':
SNARFWORD;
if (strEQ(d,"next"))
LOOPX(O_NEXT);
if (strEQ(d,"ne") || strEQ(d,"NE"))
- OPERATOR(SNE);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ EOP(O_SNE);
+ break;
case 'o': case 'O':
SNARFWORD;
if (strEQ(d,"open"))
OPERATOR(OPEN);
if (strEQ(d,"ord"))
- FUN1(O_ORD);
+ UNI(O_ORD);
if (strEQ(d,"oct"))
- FUN1(O_OCT);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ UNI(O_OCT);
+ if (strEQ(d,"opendir"))
+ FOP2(O_OPENDIR);
+ break;
case 'p': case 'P':
SNARFWORD;
if (strEQ(d,"print")) {
- yylval.ival = O_PRINT;
- OPERATOR(LISTOP);
+ checkcomma(s,"filehandle");
+ LOP(O_PRINT);
}
if (strEQ(d,"printf")) {
- yylval.ival = O_PRTF;
- OPERATOR(LISTOP);
+ checkcomma(s,"filehandle");
+ LOP(O_PRTF);
}
if (strEQ(d,"push")) {
yylval.ival = O_PUSH;
}
if (strEQ(d,"pop"))
OPERATOR(POP);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"pack"))
+ FL2(O_PACK);
+ if (strEQ(d,"package"))
+ OPERATOR(PACKAGE);
+ break;
case 'q': case 'Q':
SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"q")) {
+ s = scanstr(s-1);
+ TERM(RSTRING);
+ }
+ if (strEQ(d,"qq")) {
+ s = scanstr(s-2);
+ TERM(RSTRING);
+ }
+ break;
case 'r': case 'R':
SNARFWORD;
+ if (strEQ(d,"return"))
+ LOP(O_RETURN);
if (strEQ(d,"reset"))
UNI(O_RESET);
if (strEQ(d,"redo"))
LOOPX(O_REDO);
if (strEQ(d,"rename"))
FUN2(O_RENAME);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"rand"))
+ UNI(O_RAND);
+ if (strEQ(d,"rmdir"))
+ UNI(O_RMDIR);
+ if (strEQ(d,"rindex"))
+ FUN2(O_RINDEX);
+ if (strEQ(d,"read"))
+ FOP3(O_READ);
+ if (strEQ(d,"readdir"))
+ FOP(O_READDIR);
+ if (strEQ(d,"rewinddir"))
+ FOP(O_REWINDDIR);
+ if (strEQ(d,"recv"))
+ FOP4(O_RECV);
+ if (strEQ(d,"reverse"))
+ LOP(O_REVERSE);
+ if (strEQ(d,"readlink"))
+ UNI(O_READLINK);
+ break;
case 's': case 'S':
SNARFWORD;
if (strEQ(d,"s")) {
s = scansubst(s);
- TERM(SUBST);
- }
- if (strEQ(d,"shift"))
- TERM(SHIFT);
- if (strEQ(d,"split"))
- TERM(SPLIT);
- if (strEQ(d,"substr"))
- FUN3(O_SUBSTR);
- if (strEQ(d,"sprintf"))
- OPERATOR(SPRINTF);
- if (strEQ(d,"sub"))
- OPERATOR(SUB);
- if (strEQ(d,"select"))
- OPERATOR(SELECT);
- if (strEQ(d,"seek"))
- OPERATOR(SEEK);
- if (strEQ(d,"stat"))
- OPERATOR(STAT);
- if (strEQ(d,"study")) {
- sawstudy++;
- LFUN(O_STUDY);
- }
- if (strEQ(d,"sqrt"))
- FUN1(O_SQRT);
- if (strEQ(d,"sleep"))
- UNI(O_SLEEP);
- if (strEQ(d,"system")) {
- yylval.ival = O_SYSTEM;
- OPERATOR(LISTOP);
- }
- if (strEQ(d,"symlink"))
- FUN2(O_SYMLINK);
- if (strEQ(d,"sort")) {
- yylval.ival = O_SORT;
- OPERATOR(LISTOP);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (yylval.arg)
+ TERM(SUBST);
+ else
+ RETURN(1); /* force error */
+ }
+ switch (d[1]) {
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ break;
+ case 'e':
+ if (strEQ(d,"select"))
+ OPERATOR(SELECT);
+ if (strEQ(d,"seek"))
+ FOP3(O_SEEK);
+ if (strEQ(d,"send"))
+ FOP3(O_SEND);
+ if (strEQ(d,"setpgrp"))
+ FUN2(O_SETPGRP);
+ if (strEQ(d,"setpriority"))
+ FUN3(O_SETPRIORITY);
+ if (strEQ(d,"sethostent"))
+ FUN1(O_SHOSTENT);
+ if (strEQ(d,"setnetent"))
+ FUN1(O_SNETENT);
+ if (strEQ(d,"setservent"))
+ FUN1(O_SSERVENT);
+ if (strEQ(d,"setprotoent"))
+ FUN1(O_SPROTOENT);
+ if (strEQ(d,"setpwent"))
+ FUN0(O_SPWENT);
+ if (strEQ(d,"setgrent"))
+ FUN0(O_SGRENT);
+ if (strEQ(d,"seekdir"))
+ FOP2(O_SEEKDIR);
+ if (strEQ(d,"setsockopt"))
+ FOP4(O_SSOCKOPT);
+ break;
+ case 'f':
+ case 'g':
+ break;
+ case 'h':
+ if (strEQ(d,"shift"))
+ TERM(SHIFT);
+ if (strEQ(d,"shutdown"))
+ FOP2(O_SHUTDOWN);
+ break;
+ case 'i':
+ if (strEQ(d,"sin"))
+ UNI(O_SIN);
+ break;
+ case 'j':
+ case 'k':
+ break;
+ case 'l':
+ if (strEQ(d,"sleep"))
+ UNI(O_SLEEP);
+ break;
+ case 'm':
+ case 'n':
+ break;
+ case 'o':
+ if (strEQ(d,"socket"))
+ FOP4(O_SOCKET);
+ if (strEQ(d,"socketpair"))
+ FOP25(O_SOCKETPAIR);
+ if (strEQ(d,"sort")) {
+ checkcomma(s,"subroutine name");
+ d = bufend;
+ while (s < d && isascii(*s) && isspace(*s)) s++;
+ if (*s == ';' || *s == ')') /* probably a close */
+ fatal("sort is now a reserved word");
+ if (isascii(*s) && (isalpha(*s) || *s == '_')) {
+ for (d = s; isalpha(*d) || isdigit(*d) || *d == '_'; d++) ;
+ if (d >= bufend || isspace(*d))
+ *(--s) = '\\'; /* force next ident to WORD */
+ }
+ LOP(O_SORT);
+ }
+ break;
+ case 'p':
+ if (strEQ(d,"split"))
+ TERM(SPLIT);
+ if (strEQ(d,"sprintf"))
+ FL(O_SPRINTF);
+ break;
+ case 'q':
+ if (strEQ(d,"sqrt"))
+ UNI(O_SQRT);
+ break;
+ case 'r':
+ if (strEQ(d,"srand"))
+ UNI(O_SRAND);
+ break;
+ case 's':
+ break;
+ case 't':
+ if (strEQ(d,"stat"))
+ FOP(O_STAT);
+ if (strEQ(d,"study")) {
+ sawstudy++;
+ LFUN(O_STUDY);
+ }
+ break;
+ case 'u':
+ if (strEQ(d,"substr"))
+ FUN3(O_SUBSTR);
+ if (strEQ(d,"sub")) {
+ subline = line;
+ d = bufend;
+ while (s < d && isspace(*s))
+ s++;
+ if (isalpha(*s) || *s == '_' || *s == '\'') {
+ if (perldb) {
+ str_sset(subname,curstname);
+ str_ncat(subname,"'",1);
+ for (d = s+1;
+ isalpha(*d) || isdigit(*d) || *d == '_' || *d == '\'';
+ d++);
+ if (d[-1] == '\'')
+ d--;
+ str_ncat(subname,s,d-s);
+ }
+ *(--s) = '\\'; /* force next ident to WORD */
+ }
+ else if (perldb)
+ str_set(subname,"?");
+ OPERATOR(SUB);
+ }
+ break;
+ case 'v':
+ case 'w':
+ case 'x':
+ break;
+ case 'y':
+ if (strEQ(d,"system")) {
+ set_csh();
+ LOP(O_SYSTEM);
+ }
+ if (strEQ(d,"symlink"))
+ FUN2(O_SYMLINK);
+ if (strEQ(d,"syscall"))
+ LOP(O_SYSCALL);
+ break;
+ case 'z':
+ break;
+ }
+ break;
case 't': case 'T':
SNARFWORD;
if (strEQ(d,"tr")) {
s = scantrans(s);
- TERM(TRANS);
+ if (yylval.arg)
+ TERM(TRANS);
+ else
+ RETURN(1); /* force error */
}
if (strEQ(d,"tell"))
- TERM(TELL);
+ FOP(O_TELL);
+ if (strEQ(d,"telldir"))
+ FOP(O_TELLDIR);
if (strEQ(d,"time"))
FUN0(O_TIME);
if (strEQ(d,"times"))
FUN0(O_TMS);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ break;
case 'u': case 'U':
SNARFWORD;
if (strEQ(d,"using"))
yylval.ival = line;
OPERATOR(UNLESS);
}
+ if (strEQ(d,"unlink"))
+ LOP(O_UNLINK);
+ if (strEQ(d,"undef"))
+ LFUN(O_UNDEF);
+ if (strEQ(d,"unpack"))
+ FUN2(O_UNPACK);
+ if (strEQ(d,"utime"))
+ LOP(O_UTIME);
if (strEQ(d,"umask"))
- FUN1(O_UMASK);
+ UNI(O_UMASK);
if (strEQ(d,"unshift")) {
yylval.ival = O_UNSHIFT;
OPERATOR(PUSH);
}
- if (strEQ(d,"unlink")) {
- yylval.ival = O_UNLINK;
- OPERATOR(LISTOP);
- }
- if (strEQ(d,"utime")) {
- yylval.ival = O_UTIME;
- OPERATOR(LISTOP);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ break;
case 'v': case 'V':
SNARFWORD;
if (strEQ(d,"values"))
- SFUN(O_VALUES);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ HFUN(O_VALUES);
+ if (strEQ(d,"vec")) {
+ sawvec = TRUE;
+ FUN3(O_VEC);
+ }
+ break;
case 'w': case 'W':
SNARFWORD;
- if (strEQ(d,"write"))
- TERM(WRITE);
if (strEQ(d,"while")) {
yylval.ival = line;
OPERATOR(WHILE);
}
+ if (strEQ(d,"warn"))
+ LOP(O_WARN);
if (strEQ(d,"wait"))
FUN0(O_WAIT);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ if (strEQ(d,"wantarray")) {
+ yylval.arg = op_new(1);
+ yylval.arg->arg_type = O_ITEM;
+ yylval.arg[1].arg_type = A_WANTARRAY;
+ TERM(RSTRING);
+ }
+ if (strEQ(d,"write"))
+ FOP(O_WRITE);
+ break;
case 'x': case 'X':
SNARFWORD;
if (!expectterm && strEQ(d,"x"))
- OPERATOR('x');
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ MOP(O_REPEAT);
+ break;
case 'y': case 'Y':
SNARFWORD;
if (strEQ(d,"y")) {
s = scantrans(s);
TERM(TRANS);
}
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ break;
case 'z': case 'Z':
SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
+ break;
+ }
+ yylval.cval = savestr(d);
+ expectterm = FALSE;
+ if (oldoldbufptr && oldoldbufptr < bufptr) {
+ while (isspace(*oldoldbufptr))
+ oldoldbufptr++;
+ if (*oldoldbufptr == 'p' && strnEQ(oldoldbufptr,"print",5))
+ expectterm = TRUE;
+ else if (*oldoldbufptr == 's' && strnEQ(oldoldbufptr,"sort",4))
+ expectterm = TRUE;
+ }
+ return (CLINE, bufptr = s, (int)WORD);
+}
+
+int
+checkcomma(s,what)
+register char *s;
+char *what;
+{
+ if (*s == '(')
+ s++;
+ while (s < bufend && isascii(*s) && isspace(*s))
+ s++;
+ if (isascii(*s) && (isalpha(*s) || *s == '_')) {
+ s++;
+ while (isalpha(*s) || isdigit(*s) || *s == '_')
+ s++;
+ while (s < bufend && isspace(*s))
+ s++;
+ if (*s == ',')
+ fatal("No comma allowed after %s", what);
}
}
char *
-scanreg(s,dest)
+scanreg(s,send,dest)
register char *s;
+register char *send;
char *dest;
{
register char *d;
+ int brackets = 0;
+ reparse = Nullch;
s++;
d = dest;
if (isdigit(*s)) {
- while (isdigit(*s) || *s == '_')
+ while (isdigit(*s))
*d++ = *s++;
}
else {
- while (isalpha(*s) || isdigit(*s) || *s == '_')
+ while (isalpha(*s) || isdigit(*s) || *s == '_' || *s == '\'')
*d++ = *s++;
}
+ if (d > dest+1 && d[-1] == '\'')
+ d--,s--;
*d = '\0';
d = dest;
if (!*d) {
*d = *s++;
- if (*d == '{') {
+ if (*d == '{' /* } */ ) {
d = dest;
- while (*s && *s != '}')
- *d++ = *s++;
+ brackets++;
+ while (s < send && brackets) {
+ if (!reparse && (d == dest || (*s && isascii(*s) &&
+ (isalpha(*s) || isdigit(*s) || *s == '_') ))) {
+ *d++ = *s++;
+ continue;
+ }
+ else if (!reparse)
+ reparse = s;
+ switch (*s++) {
+ /* { */
+ case '}':
+ brackets--;
+ if (reparse && reparse == s - 1)
+ reparse = Nullch;
+ break;
+ case '{': /* } */
+ brackets++;
+ break;
+ }
+ }
*d = '\0';
d = dest;
- if (*s)
- s++;
}
else
d[1] = '\0';
}
STR *
-scanconst(string)
+scanconst(string,len)
char *string;
+int len;
{
register STR *retstr;
register char *t;
register char *d;
+ register char *e;
if (index(string,'|')) {
return Nullstr;
}
- retstr = str_make(string);
+ retstr = Str_new(86,len);
+ str_nset(retstr,string,len);
t = str_get(retstr);
- *(long*)&retstr->str_nval = 100;
- for (d=t; *d; ) {
+ e = t + len;
+ retstr->str_u.str_useful = 100;
+ for (d=t; d < e; ) {
switch (*d) {
- case '.': case '[': case '$': case '(': case ')': case '|':
- *d = '\0';
+ case '{':
+ if (isdigit(d[1]))
+ e = d;
+ else
+ goto defchar;
+ break;
+ case '.': case '[': case '$': case '(': case ')': case '|': case '+':
+ e = d;
break;
case '\\':
- if (index("wWbB0123456789sSdD",d[1])) {
- *d = '\0';
+ if (d[1] && index("wWbB0123456789sSdD",d[1])) {
+ e = d;
break;
}
- strcpy(d,d+1);
+ (void)bcopy(d+1,d,e-d);
+ e--;
switch(*d) {
case 'n':
*d = '\n';
}
/* FALL THROUGH */
default:
- if (d[1] == '*' || d[1] == '+' || d[1] == '?') {
- *d = '\0';
+ defchar:
+ if (d[1] == '*' || (d[1] == '{' && d[2] == '0') || d[1] == '?') {
+ e = d;
break;
}
d++;
}
}
- if (!*t) {
+ if (d == t) {
str_free(retstr);
return Nullstr;
}
- retstr->str_cur = strlen(retstr->str_ptr);
+ *d = '\0';
+ retstr->str_cur = d - t;
return retstr;
}
scanpat(s)
register char *s;
{
- register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
+ register SPAT *spat;
register char *d;
+ register char *e;
+ int len;
+ SPAT savespat;
- bzero((char *)spat, sizeof(SPAT));
- spat->spat_next = spat_root; /* link into spat list */
- spat_root = spat;
+ Newz(801,spat,1,SPAT);
+ spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
+ curstash->tbl_spatroot = spat;
switch (*s++) {
case 'm':
default:
fatal("panic: scanpat");
}
- s = cpytill(tokenbuf,s,s[-1]);
- if (!*s)
- fatal("Search pattern not terminated");
+ s = cpytill(tokenbuf,s,bufend,s[-1],&len);
+ if (s >= bufend) {
+ yyerror("Search pattern not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
s++;
- if (*s == 'i') {
- s++;
- spat->spat_flags |= SPAT_FOLD;
+ while (*s == 'i' || *s == 'o') {
+ if (*s == 'i') {
+ s++;
+ sawi = TRUE;
+ spat->spat_flags |= SPAT_FOLD;
+ }
+ if (*s == 'o') {
+ s++;
+ spat->spat_flags |= SPAT_KEEP;
+ }
}
- for (d=tokenbuf; *d; d++) {
- if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+ e = tokenbuf + len;
+ for (d=tokenbuf; d < e; d++) {
+ if ((*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') ||
+ (*d == '@' && d[-1] != '\\')) {
register ARG *arg;
spat->spat_runtime = arg = op_new(1);
arg->arg_type = O_ITEM;
arg[1].arg_type = A_DOUBLE;
- arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf,len);
+ arg[1].arg_ptr.arg_str->str_u.str_hash = curstash;
+ d = scanreg(d,bufend,buf);
+ (void)stabent(buf,TRUE); /* make sure it's created */
+ for (; d < e; d++) {
+ if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+ d = scanreg(d,bufend,buf);
+ (void)stabent(buf,TRUE);
+ }
+ else if (*d == '@' && d[-1] != '\\') {
+ d = scanreg(d,bufend,buf);
+ if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
+ strEQ(buf,"SIG") || strEQ(buf,"INC"))
+ (void)stabent(buf,TRUE);
+ }
+ }
goto got_pat; /* skip compiling for now */
}
}
- if (!(spat->spat_flags & SPAT_FOLD)) {
- if (*tokenbuf == '^') {
- spat->spat_short = scanconst(tokenbuf+1);
- if (spat->spat_short) {
- spat->spat_slen = strlen(spat->spat_short->str_ptr);
- if (spat->spat_slen == strlen(tokenbuf+1))
- spat->spat_flags |= SPAT_ALL;
- }
+ if (spat->spat_flags & SPAT_FOLD)
+#ifdef STRUCTCOPY
+ savespat = *spat;
+#else
+ (void)bcopy((char *)spat, (char *)&savespat, sizeof(SPAT));
+#endif
+ if (*tokenbuf == '^') {
+ spat->spat_short = scanconst(tokenbuf+1,len-1);
+ if (spat->spat_short) {
+ spat->spat_slen = spat->spat_short->str_cur;
+ if (spat->spat_slen == len - 1)
+ spat->spat_flags |= SPAT_ALL;
}
- else {
- spat->spat_flags |= SPAT_SCANFIRST;
- spat->spat_short = scanconst(tokenbuf);
- if (spat->spat_short) {
- spat->spat_slen = strlen(spat->spat_short->str_ptr);
- if (spat->spat_slen == strlen(tokenbuf))
- spat->spat_flags |= SPAT_ALL;
- }
- }
}
- spat->spat_regexp = regcomp(tokenbuf,spat->spat_flags & SPAT_FOLD,1);
- hoistmust(spat);
+ else {
+ spat->spat_flags |= SPAT_SCANFIRST;
+ spat->spat_short = scanconst(tokenbuf,len);
+ if (spat->spat_short) {
+ spat->spat_slen = spat->spat_short->str_cur;
+ if (spat->spat_slen == len)
+ spat->spat_flags |= SPAT_ALL;
+ }
+ }
+ if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) {
+ fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
+ spat->spat_regexp = regcomp(tokenbuf,tokenbuf+len,
+ spat->spat_flags & SPAT_FOLD,1);
+ /* Note that this regexp can still be used if someone says
+ * something like /a/ && s//b/; so we can't delete it.
+ */
+ }
+ else {
+ if (spat->spat_flags & SPAT_FOLD)
+#ifdef STRUCTCOPY
+ *spat = savespat;
+#else
+ (void)bcopy((char *)&savespat, (char *)spat, sizeof(SPAT));
+#endif
+ if (spat->spat_short)
+ fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
+ spat->spat_regexp = regcomp(tokenbuf,tokenbuf+len,
+ spat->spat_flags & SPAT_FOLD,1);
+ hoistmust(spat);
+ }
got_pat:
yylval.arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
return s;
scansubst(s)
register char *s;
{
- register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
+ register SPAT *spat;
register char *d;
+ register char *e;
+ int len;
- bzero((char *)spat, sizeof(SPAT));
- spat->spat_next = spat_root; /* link into spat list */
- spat_root = spat;
+ Newz(802,spat,1,SPAT);
+ spat->spat_next = curstash->tbl_spatroot; /* link into spat list */
+ curstash->tbl_spatroot = spat;
- s = cpytill(tokenbuf,s+1,*s);
- if (!*s)
- fatal("Substitution pattern not terminated");
- for (d=tokenbuf; *d; d++) {
- if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+ s = cpytill(tokenbuf,s+1,bufend,*s,&len);
+ if (s >= bufend) {
+ yyerror("Substitution pattern not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
+ e = tokenbuf + len;
+ for (d=tokenbuf; d < e; d++) {
+ if ((*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') ||
+ (*d == '@' && d[-1] != '\\')) {
register ARG *arg;
spat->spat_runtime = arg = op_new(1);
arg->arg_type = O_ITEM;
arg[1].arg_type = A_DOUBLE;
- arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf,len);
+ arg[1].arg_ptr.arg_str->str_u.str_hash = curstash;
+ d = scanreg(d,bufend,buf);
+ (void)stabent(buf,TRUE); /* make sure it's created */
+ for (; *d; d++) {
+ if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+ d = scanreg(d,bufend,buf);
+ (void)stabent(buf,TRUE);
+ }
+ else if (*d == '@' && d[-1] != '\\') {
+ d = scanreg(d,bufend,buf);
+ if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
+ strEQ(buf,"SIG") || strEQ(buf,"INC"))
+ (void)stabent(buf,TRUE);
+ }
+ }
goto get_repl; /* skip compiling for now */
}
}
if (*tokenbuf == '^') {
- spat->spat_short = scanconst(tokenbuf+1);
+ spat->spat_short = scanconst(tokenbuf+1,len-1);
if (spat->spat_short)
- spat->spat_slen = strlen(spat->spat_short->str_ptr);
+ spat->spat_slen = spat->spat_short->str_cur;
}
else {
spat->spat_flags |= SPAT_SCANFIRST;
- spat->spat_short = scanconst(tokenbuf);
+ spat->spat_short = scanconst(tokenbuf,len);
if (spat->spat_short)
- spat->spat_slen = strlen(spat->spat_short->str_ptr);
- }
- d = savestr(tokenbuf);
+ spat->spat_slen = spat->spat_short->str_cur;
+ }
+ d = nsavestr(tokenbuf,len);
get_repl:
s = scanstr(s);
- if (!*s)
- fatal("Substitution replacement not terminated");
+ if (s >= bufend) {
+ yyerror("Substitution replacement not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
spat->spat_repl = yylval.arg;
spat->spat_flags |= SPAT_ONCE;
- while (*s == 'g' || *s == 'i') {
+ if ((spat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
+ spat->spat_flags |= SPAT_CONST;
+ else if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) {
+ STR *tmpstr;
+ register char *t;
+
+ spat->spat_flags |= SPAT_CONST;
+ tmpstr = spat->spat_repl[1].arg_ptr.arg_str;
+ e = tmpstr->str_ptr + tmpstr->str_cur;
+ for (t = tmpstr->str_ptr; t < e; t++) {
+ if (*t == '$' && t[1] && index("`'&+0123456789",t[1]))
+ spat->spat_flags &= ~SPAT_CONST;
+ }
+ }
+ while (*s == 'g' || *s == 'i' || *s == 'e' || *s == 'o') {
+ if (*s == 'e') {
+ s++;
+ if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE)
+ spat->spat_repl[1].arg_type = A_SINGLE;
+ spat->spat_repl = fixeval(make_op(O_EVAL,2,
+ spat->spat_repl,
+ Nullarg,
+ Nullarg));
+ spat->spat_flags &= ~SPAT_CONST;
+ }
if (*s == 'g') {
s++;
spat->spat_flags &= ~SPAT_ONCE;
}
if (*s == 'i') {
s++;
+ sawi = TRUE;
spat->spat_flags |= SPAT_FOLD;
+ if (!(spat->spat_flags & SPAT_SCANFIRST)) {
+ str_free(spat->spat_short); /* anchored opt doesn't do */
+ spat->spat_short = Nullstr; /* case insensitive match */
+ spat->spat_slen = 0;
+ }
+ }
+ if (*s == 'o') {
+ s++;
+ spat->spat_flags |= SPAT_KEEP;
}
}
+ if (spat->spat_short && (spat->spat_flags & SPAT_SCANFIRST))
+ fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
if (!spat->spat_runtime) {
- spat->spat_regexp = regcomp(d, spat->spat_flags & SPAT_FOLD,1);
+ spat->spat_regexp = regcomp(d,d+len,spat->spat_flags & SPAT_FOLD,1);
hoistmust(spat);
- safefree(d);
- }
- if (spat->spat_flags & SPAT_FOLD) { /* Oops, disable optimization */
- str_free(spat->spat_short);
- spat->spat_short = Nullstr;
- spat->spat_slen = 0;
+ Safefree(d);
}
yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat);
return s;
{
if (spat->spat_regexp->regmust) { /* is there a better short-circuit? */
if (spat->spat_short &&
- strEQ(spat->spat_short->str_ptr,spat->spat_regexp->regmust->str_ptr)){
+ str_eq(spat->spat_short,spat->spat_regexp->regmust))
+ {
if (spat->spat_flags & SPAT_SCANFIRST) {
str_free(spat->spat_short);
spat->spat_short = Nullstr;
}
char *
-expand_charset(s)
+expand_charset(s,len,retlen)
register char *s;
+int len;
+int *retlen;
{
char t[512];
register char *d = t;
register int i;
+ register char *send = s + len;
- while (*s) {
- if (s[1] == '-' && s[2]) {
+ while (s < send) {
+ if (s[1] == '-' && s+2 < send) {
for (i = s[0]; i <= s[2]; i++)
*d++ = i;
s += 3;
*d++ = *s++;
}
*d = '\0';
- return savestr(t);
+ *retlen = d - t;
+ return nsavestr(t,d-t);
}
char *
register char *s;
{
ARG *arg =
- l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg,0));
+ l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg));
register char *t;
register char *r;
- register char *tbl = safemalloc(256);
+ register char *tbl;
register int i;
register int j;
+ int tlen, rlen;
+ Newz(803,tbl,256,char);
arg[2].arg_type = A_NULL;
arg[2].arg_ptr.arg_cval = tbl;
- for (i=0; i<256; i++)
- tbl[i] = 0;
s = scanstr(s);
- if (!*s)
- fatal("Translation pattern not terminated");
- t = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str));
+ if (s >= bufend) {
+ yyerror("Translation pattern not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
+ t = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr,
+ yylval.arg[1].arg_ptr.arg_str->str_cur,&tlen);
free_arg(yylval.arg);
s = scanstr(s-1);
- if (!*s)
- fatal("Translation replacement not terminated");
- r = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str));
+ if (s >= bufend) {
+ yyerror("Translation replacement not terminated");
+ yylval.arg = Nullarg;
+ return s;
+ }
+ r = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr,
+ yylval.arg[1].arg_ptr.arg_str->str_cur,&rlen);
free_arg(yylval.arg);
yylval.arg = arg;
if (!*r) {
- safefree(r);
+ Safefree(r);
r = t;
}
- for (i = 0, j = 0; t[i]; i++,j++) {
- if (!r[j])
+ for (i = 0, j = 0; i < tlen; i++,j++) {
+ if (j >= rlen)
--j;
tbl[t[i] & 0377] = r[j];
}
if (r != t)
- safefree(r);
- safefree(t);
+ Safefree(r);
+ Safefree(t);
return s;
}
register char term;
register char *d;
register ARG *arg;
+ register char *send;
register bool makesingle = FALSE;
register STAB *stab;
- char *leave = "\\$nrtfb0123456789"; /* which backslash sequences to keep */
+ bool alwaysdollar = FALSE;
+ bool hereis = FALSE;
+ STR *herewas;
+ char *leave = "\\$@nrtfb0123456789[{]}"; /* which backslash sequences to keep */
+ int len;
arg = op_new(1);
yylval.arg = arg;
goto out;
case '8': case '9':
if (shift != 4)
- fatal("Illegal octal digit");
+ yyerror("Illegal octal digit");
/* FALL THROUGH */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7':
}
}
out:
- sprintf(tokenbuf,"%ld",i);
- arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ (void)sprintf(tokenbuf,"%ld",i);
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
+ (void)str_2num(arg[1].arg_ptr.arg_str);
}
break;
case '1': case '2': case '3': case '4': case '5':
else
*d++ = *s++;
}
- if (*s == '.' && index("0123456789eE",s[1])) {
+ if (*s == '.' && s[1] && index("0123456789eE ;",s[1])) {
*d++ = *s++;
while (isdigit(*s) || *s == '_') {
if (*s == '_')
*d++ = *s++;
}
}
- if (index("eE",*s) && index("+-0123456789",s[1])) {
+ if (*s && index("eE",*s) && index("+-0123456789",s[1])) {
*d++ = *s++;
if (*s == '+' || *s == '-')
*d++ = *s++;
*d++ = *s++;
}
*d = '\0';
- arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf, d - tokenbuf);
+ (void)str_2num(arg[1].arg_ptr.arg_str);
break;
- case '\'':
- arg[1].arg_type = A_SINGLE;
- term = *s;
- leave = Nullch;
- goto snarf_it;
-
case '<':
+ if (*++s == '<') {
+ hereis = TRUE;
+ d = tokenbuf;
+ if (!rsfp)
+ *d++ = '\n';
+ if (*++s && index("`'\"",*s)) {
+ term = *s++;
+ s = cpytill(d,s,bufend,term,&len);
+ if (s < bufend)
+ s++;
+ d += len;
+ }
+ else {
+ if (*s == '\\')
+ s++, term = '\'';
+ else
+ term = '"';
+ while (isascii(*s) && (isalpha(*s) || isdigit(*s) || *s == '_'))
+ *d++ = *s++;
+ } /* assuming tokenbuf won't clobber */
+ *d++ = '\n';
+ *d = '\0';
+ len = d - tokenbuf;
+ d = "\n";
+ if (rsfp || !(d=ninstr(s,bufend,d,d+1)))
+ herewas = str_make(s,bufend-s);
+ else
+ s--, herewas = str_make(s,d-s);
+ s += herewas->str_cur;
+ if (term == '\'')
+ goto do_single;
+ if (term == '`')
+ goto do_back;
+ goto do_double;
+ }
d = tokenbuf;
- s = cpytill(d,s+1,'>');
- if (*s)
+ s = cpytill(d,s,bufend,'>',&len);
+ if (s < bufend)
s++;
if (*d == '$') d++;
- while (*d && (isalpha(*d) || isdigit(*d) || *d == '_')) d++;
- if (*d) {
+ while (*d &&
+ (isalpha(*d) || isdigit(*d) || *d == '_' || *d == '\''))
+ d++;
+ if (d - tokenbuf != len) {
d = tokenbuf;
arg[1].arg_type = A_GLOB;
- d = savestr(d);
+ d = nsavestr(d,len);
arg[1].arg_ptr.arg_stab = stab = genstab();
- stab->stab_io = stio_new();
- stab->stab_val = str_make(d);
+ stab_io(stab) = stio_new();
+ stab_val(stab) = str_make(d,len);
+ stab_val(stab)->str_u.str_hash = curstash;
+ Safefree(d);
+ set_csh();
}
else {
d = tokenbuf;
- if (!*d)
- strcpy(d,"ARGV");
+ if (!len)
+ (void)strcpy(d,"ARGV");
if (*d == '$') {
arg[1].arg_type = A_INDREAD;
arg[1].arg_ptr.arg_stab = stabent(d+1,TRUE);
}
else {
arg[1].arg_type = A_READ;
- if (rsfp == stdin && strEQ(d,"stdin"))
- fatal("Can't get both program and data from <stdin>");
+ if (rsfp == stdin && (strEQ(d,"stdin") || strEQ(d,"STDIN")))
+ yyerror("Can't get both program and data from <STDIN>");
arg[1].arg_ptr.arg_stab = stabent(d,TRUE);
- arg[1].arg_ptr.arg_stab->stab_io = stio_new();
+ if (!stab_io(arg[1].arg_ptr.arg_stab))
+ stab_io(arg[1].arg_ptr.arg_stab) = stio_new();
if (strEQ(d,"ARGV")) {
- aadd(arg[1].arg_ptr.arg_stab);
- arg[1].arg_ptr.arg_stab->stab_io->flags |=
+ (void)aadd(arg[1].arg_ptr.arg_stab);
+ stab_io(arg[1].arg_ptr.arg_stab)->flags |=
IOF_ARGV|IOF_START;
}
}
}
break;
+
+ case 'q':
+ s++;
+ if (*s == 'q') {
+ s++;
+ goto do_double;
+ }
+ /* FALL THROUGH */
+ case '\'':
+ do_single:
+ term = *s;
+ arg[1].arg_type = A_SINGLE;
+ leave = Nullch;
+ goto snarf_it;
+
case '"':
+ do_double:
+ term = *s;
arg[1].arg_type = A_DOUBLE;
makesingle = TRUE; /* maybe disable runtime scanning */
- term = *s;
+ alwaysdollar = TRUE; /* treat $) and $| as variables */
goto snarf_it;
case '`':
- arg[1].arg_type = A_BACKTICK;
+ do_back:
term = *s;
+ arg[1].arg_type = A_BACKTICK;
+ set_csh();
+ alwaysdollar = TRUE; /* treat $) and $| as variables */
snarf_it:
{
STR *tmpstr;
- int sqstart = line;
char *tmps;
- tmpstr = str_new(strlen(s));
- s = str_append_till(tmpstr,s+1,term,leave);
- while (!*s) { /* multiple line string? */
- s = str_gets(linestr, rsfp);
- if (!s) {
- line = sqstart;
+ multi_start = line;
+ if (hereis)
+ multi_open = multi_close = '<';
+ else {
+ multi_open = term;
+ if (tmps = index("([{< )]}> )]}>",term))
+ term = tmps[5];
+ multi_close = term;
+ }
+ tmpstr = Str_new(87,0);
+ if (hereis) {
+ term = *tokenbuf;
+ if (!rsfp) {
+ d = s;
+ while (s < bufend &&
+ (*s != term || bcmp(s,tokenbuf,len) != 0) ) {
+ if (*s++ == '\n')
+ line++;
+ }
+ if (s >= bufend) {
+ line = multi_start;
+ fatal("EOF in string");
+ }
+ str_nset(tmpstr,d+1,s-d);
+ s += len - 1;
+ str_ncat(herewas,s,bufend-s);
+ str_replace(linestr,herewas);
+ oldoldbufptr = oldbufptr = bufptr = s = str_get(linestr);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ hereis = FALSE;
+ }
+ }
+ else
+ s = str_append_till(tmpstr,s+1,bufend,term,leave);
+ while (s >= bufend) { /* multiple line string? */
+ if (!rsfp ||
+ !(oldoldbufptr = oldbufptr = s = str_gets(linestr, rsfp, 0))) {
+ line = multi_start;
fatal("EOF in string");
}
line++;
- s = str_append_till(tmpstr,s,term,leave);
+ if (perldb) {
+ STR *str = Str_new(88,0);
+
+ str_sset(str,linestr);
+ astore(lineary,(int)line,str);
+ }
+ bufend = linestr->str_ptr + linestr->str_cur;
+ if (hereis) {
+ if (*s == term && bcmp(s,tokenbuf,len) == 0) {
+ s = bufend - 1;
+ *s = ' ';
+ str_scat(linestr,herewas);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ }
+ else {
+ s = bufend;
+ str_scat(tmpstr,linestr);
+ }
+ }
+ else
+ s = str_append_till(tmpstr,s,bufend,term,leave);
}
+ multi_end = line;
s++;
- if (term == '\'') {
+ if (tmpstr->str_cur + 5 < tmpstr->str_len) {
+ tmpstr->str_len = tmpstr->str_cur + 1;
+ Renew(tmpstr->str_ptr, tmpstr->str_len, char);
+ }
+ if ((arg[1].arg_type & A_MASK) == A_SINGLE) {
arg[1].arg_ptr.arg_str = tmpstr;
break;
}
tmps = s;
s = tmpstr->str_ptr;
- while (*s) { /* see if we can make SINGLE */
+ send = s + tmpstr->str_cur;
+ while (s < send) { /* see if we can make SINGLE */
if (*s == '\\' && s[1] && isdigit(s[1]) && !isdigit(s[2]) &&
- !index("`\"",term) )
+ !alwaysdollar )
*s = '$'; /* grandfather \digit in subst */
- if (*s == '$' && s[1] && s[1] != ')' && s[1] != '|') {
+ if ((*s == '$' || *s == '@') && s+1 < send &&
+ (alwaysdollar || (s[1] != ')' && s[1] != '|'))) {
makesingle = FALSE; /* force interpretation */
}
- else if (*s == '\\' && s[1]) {
+ else if (*s == '\\' && s+1 < send) {
s++;
}
s++;
}
s = d = tmpstr->str_ptr; /* assuming shrinkage only */
- while (*s) {
- if (*s == '$' && s[1] && s[1] != ')' && s[1] != '|') {
- int len;
-
- len = scanreg(s,tokenbuf) - s;
- stabent(tokenbuf,TRUE); /* make sure it's created */
+ while (s < send) {
+ if ((*s == '$' && s+1 < send &&
+ (alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) ||
+ (*s == '@' && s+1 < send) ) {
+ len = scanreg(s,bufend,tokenbuf) - s;
+ if (*s == '$' || strEQ(tokenbuf,"ARGV")
+ || strEQ(tokenbuf,"ENV")
+ || strEQ(tokenbuf,"SIG")
+ || strEQ(tokenbuf,"INC") )
+ (void)stabent(tokenbuf,TRUE); /* make sure it exists */
while (len--)
*d++ = *s++;
continue;
}
- else if (*s == '\\' && s[1]) {
+ else if (*s == '\\' && s+1 < send) {
s++;
switch (*s) {
default:
- if (!makesingle && (!leave || index(leave,*s)))
+ if (!makesingle && (!leave || (*s && index(leave,*s))))
*d++ = '\\';
*d++ = *s++;
continue;
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
*d = *s++ - '0';
- if (index("01234567",*s)) {
+ if (s < send && *s && index("01234567",*s)) {
*d <<= 3;
*d += *s++ - '0';
}
- if (index("01234567",*s)) {
+ if (s < send && *s && index("01234567",*s)) {
*d <<= 3;
*d += *s++ - '0';
}
}
*d = '\0';
- if (arg[1].arg_type == A_DOUBLE && makesingle)
- arg[1].arg_type = A_SINGLE; /* now we can optimize on it */
+ if ((arg[1].arg_type & A_MASK) == A_DOUBLE && makesingle)
+ arg[1].arg_type = A_SINGLE; /* now we can optimize on it */
+
+ tmpstr->str_u.str_hash = curstash; /* so interp knows package */
- tmpstr->str_cur = d - tmpstr->str_ptr; /* XXX cheat */
+ tmpstr->str_cur = d - tmpstr->str_ptr;
arg[1].arg_ptr.arg_str = tmpstr;
s = tmps;
break;
}
}
+ if (hereis)
+ str_free(herewas);
return s;
}
register FCMD *fcmd;
register char *s;
register char *t;
- register char tmpchar;
+ register STR *str;
bool noblank;
+ bool repeater;
- while ((s = str_gets(linestr,rsfp)) != Nullch) {
+ Zero(&froot, 1, FCMD);
+ while ((s = str_gets(linestr,rsfp, 0)) != Nullch) {
line++;
+ if (perldb) {
+ STR *tmpstr = Str_new(89,0);
+
+ str_sset(tmpstr,linestr);
+ astore(lineary,(int)line,tmpstr);
+ }
+ bufend = linestr->str_ptr + linestr->str_cur;
if (strEQ(s,".\n")) {
bufptr = s;
return froot.f_next;
continue;
flinebeg = Nullfcmd;
noblank = FALSE;
- while (*s) {
- fcmd = (FCMD *)safemalloc(sizeof (FCMD));
- bzero((char*)fcmd, sizeof (FCMD));
+ repeater = FALSE;
+ while (s < bufend) {
+ Newz(804,fcmd,1,FCMD);
fprev->f_next = fcmd;
fprev = fcmd;
- for (t=s; *t && *t != '@' && *t != '^'; t++) {
+ for (t=s; t < bufend && *t != '@' && *t != '^'; t++) {
if (*t == '~') {
noblank = TRUE;
*t = ' ';
+ if (t[1] == '~') {
+ repeater = TRUE;
+ t[1] = ' ';
+ }
}
}
- tmpchar = *t;
- *t = '\0';
- fcmd->f_pre = savestr(s);
- fcmd->f_presize = strlen(s);
- *t = tmpchar;
+ fcmd->f_pre = nsavestr(s, t-s);
+ fcmd->f_presize = t-s;
s = t;
- if (!*s) {
+ if (s >= bufend) {
if (noblank)
fcmd->f_flags |= FC_NOBLANK;
+ if (repeater)
+ fcmd->f_flags |= FC_REPEAT;
break;
}
if (!flinebeg)
}
if (flinebeg) {
again:
- if ((bufptr = str_gets(linestr ,rsfp)) == Nullch)
+ if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
goto badform;
line++;
- if (strEQ(bufptr,".\n")) {
+ if (perldb) {
+ STR *tmpstr = Str_new(90,0);
+
+ str_sset(tmpstr,linestr);
+ astore(lineary,(int)line,tmpstr);
+ }
+ if (strEQ(s,".\n")) {
+ bufptr = s;
yyerror("Missing values line");
return froot.f_next;
}
- if (*bufptr == '#')
+ if (*s == '#')
goto again;
- lex_newlines = TRUE;
- while (flinebeg || *bufptr) {
- switch(yylex()) {
- default:
- yyerror("Bad value in format");
- *bufptr = '\0';
- break;
- case '\n':
- if (flinebeg)
- yyerror("Missing value in format");
- *bufptr = '\0';
- break;
- case REG:
- yylval.arg = stab2arg(A_LVAL,yylval.stabval);
- /* FALL THROUGH */
- case RSTRING:
- if (!flinebeg)
- yyerror("Extra value in format");
- else {
- flinebeg->f_expr = yylval.arg;
- do {
- flinebeg = flinebeg->f_next;
- } while (flinebeg && flinebeg->f_size == 0);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ str = flinebeg->f_unparsed = Str_new(91,bufend - bufptr);
+ str->str_u.str_hash = curstash;
+ str_nset(str,"(",1);
+ flinebeg->f_line = line;
+ if (!flinebeg->f_next->f_type || index(linestr->str_ptr, ',')) {
+ str_scat(str,linestr);
+ str_ncat(str,",$$);",5);
+ }
+ else {
+ while (s < bufend && isspace(*s))
+ s++;
+ t = s;
+ while (s < bufend) {
+ switch (*s) {
+ case ' ': case '\t': case '\n': case ';':
+ str_ncat(str, t, s - t);
+ str_ncat(str, "," ,1);
+ while (s < bufend && (isspace(*s) || *s == ';'))
+ s++;
+ t = s;
+ break;
+ case '$':
+ str_ncat(str, t, s - t);
+ t = s;
+ s = scanreg(s,bufend,tokenbuf);
+ str_ncat(str, t, s - t);
+ t = s;
+ if (s < bufend && *s && index("$'\"",*s))
+ str_ncat(str, ",", 1);
+ break;
+ case '"': case '\'':
+ str_ncat(str, t, s - t);
+ t = s;
+ s++;
+ while (s < bufend && (*s != *t || s[-1] == '\\'))
+ s++;
+ if (s < bufend)
+ s++;
+ str_ncat(str, t, s - t);
+ t = s;
+ if (s < bufend && *s && index("$'\"",*s))
+ str_ncat(str, ",", 1);
+ break;
+ default:
+ yyerror("Please use commas to separate fields");
}
- break;
- case ',': case ';':
- continue;
}
+ str_ncat(str,"$$);",4);
}
- lex_newlines = FALSE;
}
}
badform:
yyerror("Format not terminated");
return froot.f_next;
}
+
+set_csh()
+{
+ if (!csh) {
+ if (stat("/bin/csh",&statbuf) < 0)
+ csh = -1;
+ else
+ csh = 1;
+ }
+}
-/* $Header: util.c,v 2.0 88/06/05 00:15:11 root Exp $
+/* $Header: util.c,v 3.0 89/10/18 15:32:43 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: util.c,v $
- * Revision 2.0 88/06/05 00:15:11 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:32:43 lwall
+ * 3.0 baseline
*
*/
#include "EXTERN.h"
#include "perl.h"
+#include "errno.h"
+#include <signal.h>
+
+#ifdef I_VFORK
+# include <vfork.h>
+#endif
+
+#ifdef I_VARARGS
+# include <varargs.h>
+#endif
#define FLUSH
static int an = 0;
#endif
+/* NOTE: Do not call the next three routines directly. Use the macros
+ * in handy.h, so that we can easily redefine everything to do tracking of
+ * allocated hunks back to the original New to track down any memory leaks.
+ */
+
char *
safemalloc(size)
MEM_SIZE size;
ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
#ifdef DEBUGGING
+# ifndef I286
if (debug & 128)
fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size);
+# else
+ if (debug & 128)
+ fprintf(stderr,"0x%lx: (%05d) malloc %d bytes\n",ptr,an++,size);
+# endif
#endif
if (ptr != Nullch)
return ptr;
exit(1);
}
/*NOTREACHED*/
+#ifdef lint
+ return ptr;
+#endif
}
/* paranoid version of realloc */
fatal("Null realloc");
ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
#ifdef DEBUGGING
+# ifndef I286
if (debug & 128) {
fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size);
}
+# else
+ if (debug & 128) {
+ fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++);
+ fprintf(stderr,"0x%lx: (%05d) realloc %d bytes\n",ptr,an++,size);
+ }
+# endif
#endif
if (ptr != Nullch)
return ptr;
exit(1);
}
/*NOTREACHED*/
+#ifdef lint
+ return ptr;
+#endif
}
/* safe version of free */
+void
safefree(where)
char *where;
{
#ifdef DEBUGGING
+# ifndef I286
if (debug & 128)
fprintf(stderr,"0x%x: (%05d) free\n",where,an++);
+# else
+ if (debug & 128)
+ fprintf(stderr,"0x%lx: (%05d) free\n",where,an++);
+# endif
#endif
if (where) {
free(where);
}
}
-#ifdef NOTDEF
-/* safe version of string copy */
+#ifdef LEAKTEST
+
+#define ALIGN sizeof(long)
char *
-safecpy(to,from,len)
-char *to;
-register char *from;
-register int len;
+safexmalloc(x,size)
+int x;
+MEM_SIZE size;
{
- register char *dest = to;
+ register char *where;
- if (from != Nullch)
- for (len--; len && (*dest++ = *from++); len--) ;
- *dest = '\0';
- return to;
+ where = safemalloc(size + ALIGN);
+ xcount[x]++;
+ where[0] = x % 100;
+ where[1] = x / 100;
+ return where + ALIGN;
}
-#endif /*NOTDEF*/
-
-#ifdef undef
-/* safe version of string concatenate, with \n deletion and space padding */
char *
-safecat(to,from,len)
-char *to;
-register char *from;
-register int len;
+safexrealloc(where,size)
+char *where;
+MEM_SIZE size;
+{
+ return saferealloc(where - ALIGN, size + ALIGN) + ALIGN;
+}
+
+void
+safexfree(where)
+char *where;
+{
+ int x;
+
+ if (!where)
+ return;
+ where -= ALIGN;
+ x = where[0] + 100 * where[1];
+ xcount[x]--;
+ safefree(where);
+}
+
+xstat()
{
- register char *dest = to;
+ register int i;
- len--; /* leave room for null */
- if (*dest) {
- while (len && *dest++) len--;
- if (len) {
- len--;
- *(dest-1) = ' ';
+ for (i = 0; i < MAXXCOUNT; i++) {
+ if (xcount[i] != lastxcount[i]) {
+ fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
+ lastxcount[i] = xcount[i];
}
}
- if (from != Nullch)
- while (len && (*dest++ = *from++)) len--;
- if (len)
- dest--;
- if (*(dest-1) == '\n')
- dest--;
- *dest = '\0';
- return to;
}
-#endif
+
+#endif /* LEAKTEST */
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-cpytill(to,from,delim)
+cpytill(to,from,fromend,delim,retlen)
register char *to, *from;
+register char *fromend;
register int delim;
+int *retlen;
{
- for (; *from; from++,to++) {
+ char *origto = to;
+
+ for (; from < fromend; from++,to++) {
if (*from == '\\') {
if (from[1] == delim)
from++;
*to = *from;
}
*to = '\0';
+ *retlen = to - origto;
return from;
}
register char *little;
{
register char *s, *x;
- register int first = *little++;
+ register int first;
+ if (!little)
+ return big;
+ first = *little++;
if (!first)
return big;
while (*big) {
return Nullch;
}
-#ifdef NOTDEF
-void
-bmcompile(str)
-STR *str;
+/* same as instr but allow embedded nulls */
+
+char *
+ninstr(big, bigend, little, lend)
+register char *big;
+register char *bigend;
+char *little;
+char *lend;
{
- register char *s;
- register char *table;
- register int i;
- register int len = str->str_cur;
+ register char *s, *x;
+ register int first = *little;
+ register char *littleend = lend;
- str_grow(str,len+128);
- s = str->str_ptr;
- table = s + len;
- for (i = 1; i < 128; i++) {
- table[i] = len;
+ if (!first && little > littleend)
+ return big;
+ bigend -= littleend - little++;
+ while (big <= bigend) {
+ if (*big++ != first)
+ continue;
+ for (x=big,s=little; s < littleend; /**/ ) {
+ if (*s++ != *x++) {
+ s--;
+ break;
+ }
+ }
+ if (s >= littleend)
+ return big-1;
}
- i = 0;
- while (*s) {
- if (!isascii(*s))
- return;
- if (table[*s] == len)
- table[*s] = i;
- s++,i++;
+ return Nullch;
+}
+
+/* reverse of the above--find last substring */
+
+char *
+rninstr(big, bigend, little, lend)
+register char *big;
+char *bigend;
+char *little;
+char *lend;
+{
+ register char *bigbeg;
+ register char *s, *x;
+ register int first = *little;
+ register char *littleend = lend;
+
+ if (!first && little > littleend)
+ return bigend;
+ bigbeg = big;
+ big = bigend - (littleend - little++);
+ while (big >= bigbeg) {
+ if (*big-- != first)
+ continue;
+ for (x=big+2,s=little; s < littleend; /**/ ) {
+ if (*s++ != *x++) {
+ s--;
+ break;
+ }
+ }
+ if (s >= littleend)
+ return big+1;
}
- str->str_pok |= 2; /* deep magic */
+ return Nullch;
}
-#endif /* NOTDEF */
+
+unsigned char fold[] = {
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
+ 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
+ 'x', 'y', 'z', 91, 92, 93, 94, 95,
+ 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 193, 194, 195, 196, 197, 198, 199,
+ 200, 201, 202, 203, 204, 205, 206, 207,
+ 208, 209, 210, 211, 212, 213, 214, 215,
+ 216, 217, 218, 219, 220, 221, 222, 223,
+ 224, 225, 226, 227, 228, 229, 230, 231,
+ 232, 233, 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
+};
static unsigned char freq[] = {
1, 2, 84, 151, 154, 155, 156, 157,
};
void
-fbmcompile(str)
+fbmcompile(str, iflag)
STR *str;
+int iflag;
{
- register char *s;
- register char *table;
+ register unsigned char *s;
+ register unsigned char *table;
register int i;
register int len = str->str_cur;
int rarest = 0;
int frequency = 256;
- str_grow(str,len+128);
- table = str->str_ptr + len; /* actually points at final '\0' */
- s = table - 1;
- for (i = 1; i < 128; i++) {
+ str_grow(str,len+258);
+#ifndef lint
+ table = (unsigned char*)(str->str_ptr + len + 1);
+#else
+ table = Null(unsigned char*);
+#endif
+ s = table - 2;
+ for (i = 0; i < 256; i++) {
table[i] = len;
}
i = 0;
- while (s >= str->str_ptr) {
- if (!isascii(*s))
- return;
- if (table[*s] == len)
- table[*s] = i;
+#ifndef lint
+ while (s >= (unsigned char*)(str->str_ptr))
+#endif
+ {
+ if (table[*s] == len) {
+#ifndef pdp11
+ if (iflag)
+ table[*s] = table[fold[*s]] = i;
+#else
+ if (iflag) {
+ int j;
+ j = fold[*s];
+ table[j] = i;
+ table[*s] = i;
+ }
+#endif /* pdp11 */
+ else
+ table[*s] = i;
+ }
s--,i++;
}
- str->str_pok |= 2; /* deep magic */
+ str->str_pok |= SP_FBM; /* deep magic */
- s = str->str_ptr; /* deeper magic */
- for (i = 0; i < len; i++) {
- if (freq[s[i]] < frequency) {
- rarest = i;
- frequency = freq[s[i]];
+#ifndef lint
+ s = (unsigned char*)(str->str_ptr); /* deeper magic */
+#else
+ s = Null(unsigned char*);
+#endif
+ if (iflag) {
+ register int tmp, foldtmp;
+ str->str_pok |= SP_CASEFOLD;
+ for (i = 0; i < len; i++) {
+ tmp=freq[s[i]];
+ foldtmp=freq[fold[s[i]]];
+ if (tmp < frequency && foldtmp < frequency) {
+ rarest = i;
+ /* choose most frequent among the two */
+ frequency = (tmp > foldtmp) ? tmp : foldtmp;
+ }
+ }
+ }
+ else {
+ for (i = 0; i < len; i++) {
+ if (freq[s[i]] < frequency) {
+ rarest = i;
+ frequency = freq[s[i]];
+ }
}
}
str->str_rare = s[rarest];
- str->str_prev = rarest;
+ str->str_state = rarest;
#ifdef DEBUGGING
if (debug & 512)
- fprintf(stderr,"rarest char %c at %d\n",str->str_rare, str->str_prev);
+ fprintf(stderr,"rarest char %c at %d\n",str->str_rare, str->str_state);
#endif
}
-#ifdef NOTDEF
-char *
-bminstr(big, biglen, littlestr)
-register char *big;
-int biglen;
-STR *littlestr;
-{
- register char *s;
- register int tmp;
- register char *little = littlestr->str_ptr;
- int littlelen = littlestr->str_cur;
- register char *table = little + littlelen;
-
- s = big + biglen - littlelen;
- while (s >= big) {
- if (tmp = table[*s]) {
- s -= tmp;
- }
- else {
- if (strnEQ(s,little,littlelen))
- return s;
- s--;
- }
- }
- return Nullch;
-}
-#endif /* NOTDEF */
-
char *
fbminstr(big, bigend, littlestr)
-char *big;
-register char *bigend;
+unsigned char *big;
+register unsigned char *bigend;
STR *littlestr;
{
- register char *s;
+ register unsigned char *s;
register int tmp;
register int littlelen;
- register char *little;
- register char *table;
- register char *olds;
- register char *oldlittle;
- register int min;
- char *screaminstr();
+ register unsigned char *little;
+ register unsigned char *table;
+ register unsigned char *olds;
+ register unsigned char *oldlittle;
- if (littlestr->str_pok != 3)
- return instr(big,littlestr->str_ptr);
+#ifndef lint
+ if (!(littlestr->str_pok & SP_FBM))
+ return instr((char*)big,littlestr->str_ptr);
+#endif
littlelen = littlestr->str_cur;
- table = littlestr->str_ptr + littlelen;
- s = big + --littlelen;
- oldlittle = little = table - 1;
- while (s < bigend) {
- top:
- if (tmp = table[*s]) {
- s += tmp;
+#ifndef lint
+ if (littlestr->str_pok & SP_TAIL && !multiline) { /* tail anchored? */
+ little = (unsigned char*)littlestr->str_ptr;
+ if (littlestr->str_pok & SP_CASEFOLD) { /* oops, fake it */
+ big = bigend - littlelen; /* just start near end */
+ if (bigend[-1] == '\n' && little[littlelen-1] != '\n')
+ big--;
}
else {
- tmp = littlelen; /* less expensive than calling strncmp() */
- olds = s;
- while (tmp--) {
- if (*--s == *--little)
- continue;
- s = olds + 1; /* here we pay the price for failure */
- little = oldlittle;
- if (s < bigend) /* fake up continue to outer loop */
- goto top;
- return Nullch;
+ s = bigend - littlelen;
+ if (*s == *little && bcmp(s,little,littlelen)==0)
+ return (char*)s; /* how sweet it is */
+ else if (bigend[-1] == '\n' && little[littlelen-1] != '\n') {
+ s--;
+ if (*s == *little && bcmp(s,little,littlelen)==0)
+ return (char*)s;
+ }
+ return Nullch;
+ }
+ }
+ table = (unsigned char*)(littlestr->str_ptr + littlelen + 1);
+#else
+ table = Null(unsigned char*);
+#endif
+ s = big + --littlelen;
+ oldlittle = little = table - 2;
+ if (littlestr->str_pok & SP_CASEFOLD) { /* case insensitive? */
+ while (s < bigend) {
+ top1:
+ if (tmp = table[*s]) {
+ s += tmp;
+ }
+ else {
+ tmp = littlelen; /* less expensive than calling strncmp() */
+ olds = s;
+ while (tmp--) {
+ if (*--s == *--little || fold[*s] == *little)
+ continue;
+ s = olds + 1; /* here we pay the price for failure */
+ little = oldlittle;
+ if (s < bigend) /* fake up continue to outer loop */
+ goto top1;
+ return Nullch;
+ }
+#ifndef lint
+ return (char *)s;
+#endif
+ }
+ }
+ }
+ else {
+ while (s < bigend) {
+ top2:
+ if (tmp = table[*s]) {
+ s += tmp;
+ }
+ else {
+ tmp = littlelen; /* less expensive than calling strncmp() */
+ olds = s;
+ while (tmp--) {
+ if (*--s == *--little)
+ continue;
+ s = olds + 1; /* here we pay the price for failure */
+ little = oldlittle;
+ if (s < bigend) /* fake up continue to outer loop */
+ goto top2;
+ return Nullch;
+ }
+#ifndef lint
+ return (char *)s;
+#endif
}
- return s;
}
}
return Nullch;
STR *bigstr;
STR *littlestr;
{
- register char *s, *x;
- register char *big = bigstr->str_ptr;
+ register unsigned char *s, *x;
+ register unsigned char *big;
register int pos;
register int previous;
register int first;
- register char *little;
+ register unsigned char *little;
+ register unsigned char *bigend;
+ register unsigned char *littleend;
if ((pos = screamfirst[littlestr->str_rare]) < 0)
return Nullch;
- little = littlestr->str_ptr;
+#ifndef lint
+ little = (unsigned char *)(littlestr->str_ptr);
+#else
+ little = Null(unsigned char *);
+#endif
+ littleend = little + littlestr->str_cur;
first = *little++;
- previous = littlestr->str_prev;
+ previous = littlestr->str_state;
+#ifndef lint
+ big = (unsigned char *)(bigstr->str_ptr);
+#else
+ big = Null(unsigned char*);
+#endif
+ bigend = big + bigstr->str_cur;
big -= previous;
while (pos < previous) {
+#ifndef lint
if (!(pos += screamnext[pos]))
+#endif
return Nullch;
}
- do {
- if (big[pos] != first)
- continue;
- for (x=big+pos+1,s=little; *s; /**/ ) {
- if (!*x)
+ if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */
+ do {
+ if (big[pos] != first && big[pos] != fold[first])
+ continue;
+ for (x=big+pos+1,s=little; s < littleend; /**/ ) {
+ if (x >= bigend)
+ return Nullch;
+ if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
+ s--;
+ break;
+ }
+ }
+ if (s == littleend)
+#ifndef lint
+ return (char *)(big+pos);
+#else
return Nullch;
- if (*s++ != *x++) {
- s--;
- break;
+#endif
+ } while (
+#ifndef lint
+ pos += screamnext[pos] /* does this goof up anywhere? */
+#else
+ pos += screamnext[0]
+#endif
+ );
+ }
+ else {
+ do {
+ if (big[pos] != first)
+ continue;
+ for (x=big+pos+1,s=little; s < littleend; /**/ ) {
+ if (x >= bigend)
+ return Nullch;
+ if (*s++ != *x++) {
+ s--;
+ break;
+ }
}
- }
- if (!*s)
- return big+pos;
- } while (pos += screamnext[pos]);
+ if (s == littleend)
+#ifndef lint
+ return (char *)(big+pos);
+#else
+ return Nullch;
+#endif
+ } while (
+#ifndef lint
+ pos += screamnext[pos]
+#else
+ pos += screamnext[0]
+#endif
+ );
+ }
return Nullch;
}
savestr(str)
char *str;
{
- register char *newaddr = safemalloc((MEM_SIZE)(strlen(str)+1));
+ register char *newaddr;
+ New(902,newaddr,strlen(str)+1,char);
(void)strcpy(newaddr,str);
return newaddr;
}
+/* same thing but with a known length */
+
+char *
+nsavestr(str, len)
+char *str;
+register int len;
+{
+ register char *newaddr;
+
+ New(903,newaddr,len+1,char);
+ (void)bcopy(str,newaddr,len); /* might not be null terminated */
+ newaddr[len] = '\0'; /* is now */
+ return newaddr;
+}
+
/* grow a static string to at least a certain length */
void
{
if (newlen > *curlen) { /* need more room? */
if (*curlen)
- *strptr = saferealloc(*strptr,(MEM_SIZE)newlen);
+ Renew(*strptr,newlen,char);
else
- *strptr = safemalloc((MEM_SIZE)newlen);
+ New(905,*strptr,newlen,char);
*curlen = newlen;
}
}
extern int errno;
+#ifndef VARARGS
/*VARARGS1*/
mess(pat,a1,a2,a3,a4)
char *pat;
+long a1, a2, a3, a4;
{
char *s;
- s = tokenbuf;
- sprintf(s,pat,a1,a2,a3,a4);
+ s = buf;
+ (void)sprintf(s,pat,a1,a2,a3,a4);
s += strlen(s);
if (s[-1] != '\n') {
if (line) {
- sprintf(s," at %s line %ld",
+ (void)sprintf(s," at %s line %ld",
in_eval?filename:origfilename, (long)line);
s += strlen(s);
}
if (last_in_stab &&
- last_in_stab->stab_io &&
- last_in_stab->stab_io->lines ) {
- sprintf(s,", <%s> line %ld",
- last_in_stab == argvstab ? "" : last_in_stab->stab_name,
- (long)last_in_stab->stab_io->lines);
+ stab_io(last_in_stab) &&
+ stab_io(last_in_stab)->lines ) {
+ (void)sprintf(s,", <%s> line %ld",
+ last_in_stab == argvstab ? "" : stab_name(last_in_stab),
+ (long)stab_io(last_in_stab)->lines);
s += strlen(s);
}
- strcpy(s,".\n");
+ (void)strcpy(s,".\n");
}
}
/*VARARGS1*/
fatal(pat,a1,a2,a3,a4)
char *pat;
+long a1, a2, a3, a4;
{
extern FILE *e_fp;
extern char *e_tmpname;
mess(pat,a1,a2,a3,a4);
if (in_eval) {
- str_set(stabent("@",TRUE)->stab_val,tokenbuf);
+ str_set(stab_val(stabent("@",TRUE)),buf);
longjmp(eval_env,1);
}
- fputs(tokenbuf,stderr);
- fflush(stderr);
+ fputs(buf,stderr);
+ (void)fflush(stderr);
if (e_fp)
- UNLINK(e_tmpname);
+ (void)UNLINK(e_tmpname);
statusvalue >>= 8;
exit(errno?errno:(statusvalue?statusvalue:255));
}
/*VARARGS1*/
warn(pat,a1,a2,a3,a4)
char *pat;
+long a1, a2, a3, a4;
{
mess(pat,a1,a2,a3,a4);
- fputs(tokenbuf,stderr);
- fflush(stderr);
+ fputs(buf,stderr);
+#ifdef LEAKTEST
+#ifdef DEBUGGING
+ if (debug & 4096)
+ xstat();
+#endif
+#endif
+ (void)fflush(stderr);
}
+#else
+/*VARARGS0*/
+mess(args)
+va_list args;
+{
+ char *pat;
+ char *s;
+#ifdef CHARVSPRINTF
+ char *vsprintf();
+#else
+ int vsprintf();
+#endif
+
+ s = buf;
+#ifdef lint
+ pat = Nullch;
+#else
+ pat = va_arg(args, char *);
+#endif
+ (void) vsprintf(s,pat,args);
+
+ s += strlen(s);
+ if (s[-1] != '\n') {
+ if (line) {
+ (void)sprintf(s," at %s line %ld",
+ in_eval?filename:origfilename, (long)line);
+ s += strlen(s);
+ }
+ if (last_in_stab &&
+ stab_io(last_in_stab) &&
+ stab_io(last_in_stab)->lines ) {
+ (void)sprintf(s,", <%s> line %ld",
+ last_in_stab == argvstab ? "" : last_in_stab->str_magic->str_ptr,
+ (long)stab_io(last_in_stab)->lines);
+ s += strlen(s);
+ }
+ (void)strcpy(s,".\n");
+ }
+}
+
+/*VARARGS0*/
+fatal(va_alist)
+va_dcl
+{
+ va_list args;
+ extern FILE *e_fp;
+ extern char *e_tmpname;
+
+#ifndef lint
+ va_start(args);
+#else
+ args = 0;
+#endif
+ mess(args);
+ va_end(args);
+ if (in_eval) {
+ str_set(stab_val(stabent("@",TRUE)),buf);
+ longjmp(eval_env,1);
+ }
+ fputs(buf,stderr);
+ (void)fflush(stderr);
+ if (e_fp)
+ (void)UNLINK(e_tmpname);
+ statusvalue >>= 8;
+ exit((int)(errno?errno:(statusvalue?statusvalue:255)));
+}
+
+/*VARARGS0*/
+warn(va_alist)
+va_dcl
+{
+ va_list args;
+
+#ifndef lint
+ va_start(args);
+#else
+ args = 0;
+#endif
+ mess(args);
+ va_end(args);
+
+ fputs(buf,stderr);
+#ifdef LEAKTEST
+#ifdef DEBUGGING
+ if (debug & 4096)
+ xstat();
+#endif
+#endif
+ (void)fflush(stderr);
+}
+#endif
static bool firstsetenv = TRUE;
extern char **environ;
{
register int i=envix(nam); /* where does it go? */
+ if (!val) {
+ while (environ[i]) {
+ environ[i] = environ[i+1];
+ i++;
+ }
+ return;
+ }
if (!environ[i]) { /* does not exist yet */
if (firstsetenv) { /* need we copy environment? */
int j;
-#ifndef lint
- char **tmpenv = (char**) /* point our wand at memory */
- safemalloc((i+2) * sizeof(char*));
-#else
- char **tmpenv = Null(char **);
-#endif /* lint */
-
+ char **tmpenv;
+
+ New(901,tmpenv, i+2, char*);
firstsetenv = FALSE;
for (j=0; j<i; j++) /* copy environment */
tmpenv[j] = environ[j];
environ = tmpenv; /* tell exec where it is now */
}
-#ifndef lint
else
- environ = (char**) saferealloc((char*) environ,
- (i+2) * sizeof(char*));
- /* just expand it a bit */
-#endif /* lint */
+ Renew(environ, i+2, char*); /* just expand it a bit */
environ[i+1] = Nullch; /* make sure it's null terminated */
}
- environ[i] = safemalloc((MEM_SIZE)(strlen(nam) + strlen(val) + 2));
+ New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
/* this may or may not be in */
/* the old environ structure */
- sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
+ (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
}
int
}
#endif
#endif
+
+#ifdef VARARGS
+#ifndef VPRINTF
+
+#ifdef CHARVSPRINTF
+char *
+#else
+int
+#endif
+vsprintf(dest, pat, args)
+char *dest, *pat, *args;
+{
+ FILE fakebuf;
+
+ fakebuf._ptr = dest;
+ fakebuf._cnt = 32767;
+ fakebuf._flag = _IOWRT|_IOSTRG;
+ _doprnt(pat, args, &fakebuf); /* what a kludge */
+ (void)putc('\0', &fakebuf);
+#ifdef CHARVSPRINTF
+ return(dest);
+#else
+ return 0; /* perl doesn't use return value */
+#endif
+}
+
+#ifdef DEBUGGING
+int
+vfprintf(fd, pat, args)
+FILE *fd;
+char *pat, *args;
+{
+ _doprnt(pat, args, fd);
+ return 0; /* wrong, but perl doesn't use the return value */
+}
+#endif
+#endif /* VPRINTF */
+#endif /* VARARGS */
+
+#ifdef MYSWAP
+#if BYTEORDER != 04321
+short
+my_swap(s)
+short s;
+{
+#if (BYTEORDER & 1) == 0
+ short result;
+
+ result = ((s & 255) << 8) + ((s >> 8) & 255);
+ return result;
+#else
+ return s;
+#endif
+}
+
+long
+htonl(l)
+register long l;
+{
+ union {
+ long result;
+ char c[4];
+ } u;
+
+#if BYTEORDER == 01234
+ u.c[0] = (l >> 24) & 255;
+ u.c[1] = (l >> 16) & 255;
+ u.c[2] = (l >> 8) & 255;
+ u.c[3] = l & 255;
+ return u.result;
+#else
+#if ((BYTEORDER - 01111) & 0444) || !(BYTEORDER & 7)
+ fatal("Unknown BYTEORDER\n");
+#else
+ register int o;
+ register int s;
+
+ for (o = BYTEORDER - 01111, s = 0; s < 32; o >>= 3, s += 8) {
+ u.c[o & 7] = (l >> s) & 255;
+ }
+ return u.result;
+#endif
+#endif
+}
+
+long
+ntohl(l)
+register long l;
+{
+ union {
+ long l;
+ char c[4];
+ } u;
+
+#if BYTEORDER == 01234
+ u.c[0] = (l >> 24) & 255;
+ u.c[1] = (l >> 16) & 255;
+ u.c[2] = (l >> 8) & 255;
+ u.c[3] = l & 255;
+ return u.l;
+#else
+#if ((BYTEORDER - 01111) & 0444) || !(BYTEORDER & 7)
+ fatal("Unknown BYTEORDER\n");
+#else
+ register int o;
+ register int s;
+
+ u.l = l;
+ l = 0;
+ for (o = BYTEORDER - 01111, s = 0; s < 32; o >>= 3, s += 8) {
+ l |= (u.c[o & 7] & 255) << s;
+ }
+ return l;
+#endif
+#endif
+}
+
+#endif /* BYTEORDER != 04321 */
+#endif /* HTONS */
+
+FILE *
+mypopen(cmd,mode)
+char *cmd;
+char *mode;
+{
+ int p[2];
+ register int this, that;
+ register int pid;
+ STR *str;
+ int doexec = strNE(cmd,"-");
+
+ if (pipe(p) < 0)
+ return Nullfp;
+ this = (*mode == 'w');
+ that = !this;
+ while ((pid = (doexec?vfork():fork())) < 0) {
+ if (errno != EAGAIN) {
+ close(p[this]);
+ if (!doexec)
+ fatal("Can't fork");
+ return Nullfp;
+ }
+ sleep(5);
+ }
+ if (pid == 0) {
+#define THIS that
+#define THAT this
+ close(p[THAT]);
+ if (p[THIS] != (*mode == 'r')) {
+ dup2(p[THIS], *mode == 'r');
+ close(p[THIS]);
+ }
+ if (doexec) {
+ do_exec(cmd); /* may or may not use the shell */
+ _exit(1);
+ }
+ if (tmpstab = stabent("$",allstabs))
+ str_numset(STAB_STR(tmpstab),(double)getpid());
+ return Nullfp;
+#undef THIS
+#undef THAT
+ }
+ close(p[that]);
+ str = afetch(pidstatary,p[this],TRUE);
+ str_numset(str,(double)pid);
+ str->str_cur = 0;
+ forkprocess = pid;
+ return fdopen(p[this], mode);
+}
+
+#ifndef DUP2
+dup2(oldfd,newfd)
+int oldfd;
+int newfd;
+{
+ close(newfd);
+ while (dup(oldfd) != newfd) ; /* good enough for our purposes */
+}
+#endif
+
+int
+mypclose(ptr)
+FILE *ptr;
+{
+ register int result;
+#ifdef VOIDSIG
+ void (*hstat)(), (*istat)(), (*qstat)();
+#else
+ int (*hstat)(), (*istat)(), (*qstat)();
+#endif
+ int status;
+ STR *str;
+ register int pid;
+
+ str = afetch(pidstatary,fileno(ptr),TRUE);
+ fclose(ptr);
+ pid = (int)str_gnum(str);
+ if (!pid)
+ return -1;
+ hstat = signal(SIGHUP, SIG_IGN);
+ istat = signal(SIGINT, SIG_IGN);
+ qstat = signal(SIGQUIT, SIG_IGN);
+#ifdef WAIT4
+ if (wait4(pid,&status,0,Null(struct rusage *)) < 0)
+ status = -1;
+#else
+ if (pid < 0) /* already exited? */
+ status = str->str_cur;
+ else {
+ while ((result = wait(&status)) != pid && result >= 0)
+ pidgone(result,status);
+ if (result < 0)
+ status = -1;
+ }
+#endif
+ signal(SIGHUP, hstat);
+ signal(SIGINT, istat);
+ signal(SIGQUIT, qstat);
+ str_numset(str,0.0);
+ return(status);
+}
+
+pidgone(pid,status)
+int pid;
+int status;
+{
+#ifdef WAIT4
+ return;
+#else
+ register int count;
+ register STR *str;
+
+ for (count = pidstatary->ary_fill; count >= 0; --count) {
+ if ((str = afetch(pidstatary,count,FALSE)) &&
+ ((int)str->str_u.str_nval) == pid) {
+ str_numset(str, -str->str_u.str_nval);
+ str->str_cur = status;
+ return;
+ }
+ }
+#endif
+}
+
+#ifndef MEMCMP
+memcmp(s1,s2,len)
+register unsigned char *s1;
+register unsigned char *s2;
+register int len;
+{
+ register int tmp;
+
+ while (len--) {
+ if (tmp = *s1++ - *s2++)
+ return tmp;
+ }
+ return 0;
+}
+#endif /* MEMCMP */
-/* $Header: util.h,v 2.0 88/06/05 00:15:15 root Exp $
+/* $Header: util.h,v 3.0 89/10/18 15:33:18 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: util.h,v $
- * Revision 2.0 88/06/05 00:15:15 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:33:18 lwall
+ * 3.0 baseline
*
*/
-int *screamfirst INIT(Null(int*));
-int *screamnext INIT(Null(int*));
-int *screamcount INIT(Null(int*));
+EXT int *screamfirst INIT(Null(int*));
+EXT int *screamnext INIT(Null(int*));
char *safemalloc();
char *saferealloc();
char *cpytill();
char *instr();
-char *bminstr();
char *fbminstr();
char *screaminstr();
-void bmcompile();
void fbmcompile();
-char *get_a_line();
char *savestr();
void setenv();
int envix();
void growstr();
+char *ninstr();
+char *rninstr();
+char *nsavestr();
+FILE *mypopen();
+int mypclose();
+++ /dev/null
-/* $Header: version.c,v 2.0 88/06/05 00:15:21 root Exp $
- *
- * $Log: version.c,v $
- * Revision 2.0 88/06/05 00:15:21 root
- * Baseline version 2.0.
- *
- */
-
-#include "patchlevel.h"
-
-/* Print out the version number. */
-
-version()
-{
- extern char rcsid[];
-
- printf("%s\r\nPatch level: %d\r\n", rcsid, PATCHLEVEL);
-}
-/* $Header: EXTERN.h,v 2.0 88/06/05 00:15:24 root Exp $
+/* $Header: EXTERN.h,v 3.0 89/10/18 15:33:37 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:15:24 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:33:37 lwall
+ * 3.0 baseline
*
*/
-/* $Header: INTERN.h,v 2.0 88/06/05 00:15:27 root Exp $
+/* $Header: INTERN.h,v 3.0 89/10/18 15:33:45 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:15:27 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:33:45 lwall
+ * 3.0 baseline
*
*/
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
case $CONFIG in
'')
if test ! -f config.sh; then
. ./config.sh
;;
esac
-case "$0" in
-*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
-esac
case "$mallocsrc" in
'') ;;
*) mallocsrc="../$mallocsrc";;
esac
echo "Extracting x2p/Makefile (with variable substitutions)"
cat >Makefile <<!GROK!THIS!
-# $Header: Makefile.SH,v 2.0 88/06/05 00:15:31 root Exp $
+# $Header: Makefile.SH,v 3.0 89/10/18 15:33:52 lwall Locked $
#
# $Log: Makefile.SH,v $
+# Revision 3.0 89/10/18 15:33:52 lwall
+# 3.0 baseline
+#
+# Revision 2.0.1.2 88/09/07 17:13:30 lwall
+# patch14: added redirection of stderr to /dev/null
+#
+# Revision 2.0.1.1 88/07/11 23:13:39 root
+# patch2: now expects more shift/reduce errors
+#
# Revision 2.0 88/06/05 00:15:31 root
# Baseline version 2.0.
#
lib = $lib
mansrc = $mansrc
manext = $manext
-CFLAGS = $ccflags -O
+CFLAGS = $ccflags $optimize
LDFLAGS = $ldflags
SMALL = $small
LARGE = $large $split
mallocsrc = $mallocsrc
mallocobj = $mallocobj
-libs = $libnm -lm
+libs = $libnm -lm $libs
!GROK!THIS!
cat >>Makefile <<'!NO!SUBS!'
touch all
a2p: $(obj) a2p.o
- $(CC) $(LDFLAGS) $(LARGE) $(obj) a2p.o $(libs) -o a2p
+ $(CC) $(LARGE) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p
a2p.c: a2p.y
- @ echo Expect 103 shift/reduce errors...
+ @ echo Expect 208 shift/reduce conflicts...
yacc a2p.y
mv y.tab.c a2p.c
a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h
$(CC) -c $(CFLAGS) $(LARGE) a2p.c
-# if a .h file depends on another .h file...
-$(h):
- touch $@
install: a2p s2p
# won't work with csh
export PATH || exit 1
- mv $(bin)/a2p $(bin)/a2p.old 2>/dev/null
- - mv $(bin)/s2p $(bin)/s2p.old
+ - mv $(bin)/s2p $(bin)/s2p.old 2>/dev/null
- if test `pwd` != $(bin); then cp $(public) $(bin); fi
cd $(bin); \
for pub in $(public); do \
-/* $Header: a2p.h,v 2.0 88/06/05 00:15:33 root Exp $
+/* $Header: a2p.h,v 3.0 89/10/18 15:34:14 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: a2p.h,v $
- * Revision 2.0 88/06/05 00:15:33 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:34:14 lwall
+ * 3.0 baseline
*
*/
#define OCONCAT 19
#define OASSIGN 20
#define OADD 21
-#define OSUB 22
+#define OSUBTRACT 22
#define OMULT 23
#define ODIV 24
#define OMOD 25
#define OEXP 67
#define OSQRT 68
#define OINT 69
+#define ODO 70
+#define OPOW 71
+#define OSUB 72
+#define OGSUB 73
+#define OMATCH 74
+#define OUSERFUN 75
+#define OUSERDEF 76
+#define OCLOSE 77
+#define OATAN2 78
+#define OSIN 79
+#define OCOS 80
+#define ORAND 81
+#define OSRAND 82
+#define ODELETE 83
+#define OSYSTEM 84
+#define OCOND 85
+#define ORETURN 86
+#define ODEFINED 87
+#define OSTAR 88
#ifdef DOINIT
char *opname[] = {
"CONCAT",
"ASSIGN",
"ADD",
- "SUB",
+ "SUBTRACT",
"MULT",
"DIV",
"MOD",
"EXP",
"SQRT",
"INT",
- "70"
+ "DO",
+ "POW",
+ "SUB",
+ "GSUB",
+ "MATCH",
+ "USERFUN",
+ "USERDEF",
+ "CLOSE",
+ "ATAN2",
+ "SIN",
+ "COS",
+ "RAND",
+ "SRAND",
+ "DELETE",
+ "SYSTEM",
+ "COND",
+ "RETURN",
+ "DEFINED",
+ "STAR",
+ "89"
};
#else
extern char *opname[];
#endif
+EXT int mop INIT(1);
+
+#define OPSMAX 50000
union {
int ival;
char *cval;
-} ops[50000]; /* hope they have 200k to spare */
-
-EXT int mop INIT(1);
+} ops[OPSMAX]; /* hope they have 200k to spare */
#define DEBUGGING
EXT bool do_chop INIT(FALSE);
EXT bool need_entire INIT(FALSE);
EXT bool absmaxfld INIT(FALSE);
+EXT bool saw_altinput INIT(FALSE);
EXT char const_FS INIT(0);
EXT char *namelist INIT(Nullch);
EXT STR *opens;
EXT HASH *symtab;
+EXT HASH *curarghash;
+
+#define P_MIN 0
+#define P_LISTOP 5
+#define P_COMMA 10
+#define P_ASSIGN 15
+#define P_COND 20
+#define P_DOTDOT 25
+#define P_OROR 30
+#define P_ANDAND 35
+#define P_OR 40
+#define P_AND 45
+#define P_EQ 50
+#define P_REL 55
+#define P_UNI 60
+#define P_FILETEST 65
+#define P_SHIFT 70
+#define P_ADD 75
+#define P_MUL 80
+#define P_MATCH 85
+#define P_UNARY 90
+#define P_POW 95
+#define P_AUTO 100
+#define P_MAX 999
.rn '' }`
-''' $Header: a2p.man,v 2.0 88/06/05 00:15:36 root Exp $
+''' $Header: a2p.man,v 3.0 89/10/18 15:34:22 lwall Locked $
'''
''' $Log: a2p.man,v $
+''' Revision 3.0 89/10/18 15:34:22 lwall
+''' 3.0 baseline
+'''
+''' Revision 2.0.1.1 88/07/11 23:16:25 root
+''' patch2: changes related to 1985 awk
+'''
''' Revision 2.0 88/06/05 00:15:36 root
''' Baseline version 2.0.
'''
.sp
a2p -7 -nlogin.password.uid.gid.gcos.shell.home
.sp
-Any delimiter will do to separate the field names.
+Any delimiter can be used to separate the field names.
.TP 5
.B \-<number>
causes a2p to assume that input will always have that many fields.
and tweak it some.
Here are some of them, in no particular order.
.PP
-The split operator in perl always strips off all null fields from the end.
-Awk does NOT do this, if you've set FS.
-If the perl script splits to an array, the field count may not reflect
-what you expect.
-Ordinarily this isn't a problem, since nonexistent array elements have a null
-value, but if you rely on NF in awk, you could be in for trouble.
-Either force the number of fields with \-<number>, or count the number of
-delimiters another way, e.g. with y/:/:/.
-Or add something non-null to the end before you split, and then pop it off
-the resulting array.
-.PP
There is an awk idiom of putting int() around a string expression to force
numeric interpretation, even though the argument is always integer anyway.
This is generally unneeded in perl, but a2p can't tell if the argument
It's almost always right, but it can be spoofed.
All such guesses are marked with the comment \*(L"#???\*(R".
You should go through and check them.
+You might want to run at least once with the \-w switch to perl, which
+will warn you if you use == where you should have used eq.
.PP
Perl does not attempt to emulate the behavior of awk in which nonexistent
array elements spring into existence simply by being referenced.
Awk arrays are usually translated to associative arrays, but if you happen
to know that the index is always going to be numeric you could change
the {...} to [...].
-Iteration over an associative array is done with each(), but
+Iteration over an associative array is done using the keys() function, but
iteration over a numeric array is NOT.
-You need a for loop, or while loop with a pop() or shift(), so you might
-need to modify any loop that is iterating over the array in question.
-.PP
-Arrays which have been split into are assumed to be numerically indexed.
-The usual perl idiom for iterating over such arrays is to use pop() or shift()
-and assign the resulting value to a variable inside the conditional of the
-while loop.
-This is destructive to the array, however, so a2p can't assume this is
-reasonable.
-A2p will write a standard for loop with a scratch variable.
-You may wish to change it to a pop() loop for more efficiency, presuming
-you don't want to keep the array around.
+You might need to modify any loop that is iterating over the array in question.
.PP
Awk starts by assuming OFMT has the value %.6g.
Perl starts by assuming its equivalent, $#, to have the value %.20g.
There are times when you can move this down past some conditionals that
test the entire record so that the split is not done as often.
.PP
-There may occasionally be extra parentheses that you can remove.
-.PP
For aesthetic reasons you may wish to change the array base $[ from 1 back
-to the default of 0, but remember to change all array subscripts AND
+to perl's default of 0, but remember to change all array subscripts AND
all substr() and index() operations to match.
.PP
-Cute comments that say "# Here is a workaround because awk is dumb" are not
-translated.
+Cute comments that say "# Here is a workaround because awk is dumb" are passed
+through unmodified.
.PP
Awk scripts are often embedded in a shell script that pipes stuff into and
out of awk.
Often the shell script wrapper can be incorporated into the perl script, since
perl can start up pipes into and out of itself, and can do other things that
awk can't do by itself.
+.PP
+Scripts that refer to the special variables RSTART and RLENGTH can often
+be simplified by referring to the variables $`, $& and $', as long as they
+are within the scope of the pattern match that sets them.
+.PP
+The produced perl script may have subroutines defined to deal with awk's
+semantics regarding getline and print.
+Since a2p usually picks correctness over efficiency.
+it is almost always possible to rewrite such code to be more efficient by
+discarding the semantic sugar.
+.PP
+For efficiency, you may wish to remove the keyword from any return statement
+that is the last statement executed in a subroutine.
+A2p catches the most common case, but doesn't analyze embedded blocks for
+subtler cases.
+.PP
+ARGV[0] translates to $ARGV0, but ARGV[n] translates to $ARGV[$n].
+A loop that tries to iterate over ARGV[0] won't find it.
.SH ENVIRONMENT
A2p uses no environment variables.
.SH AUTHOR
-Larry Wall <lwall@devvax.Jpl.Nasa.Gov>
+Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
.SH FILES
.SH SEE ALSO
perl The perl compiler/interpreter
%{
-/* $Header: a2p.y,v 2.0 88/06/05 00:15:38 root Exp $
+/* $Header: a2p.y,v 3.0 89/10/18 15:34:29 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: a2p.y,v $
- * Revision 2.0 88/06/05 00:15:38 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:34:29 lwall
+ * 3.0 baseline
*
*/
#include "a2p.h"
int root;
+int begins = Nullop;
+int ends = Nullop;
%}
%token BEGIN END
%token REGEX
%token SEMINEW NEWLINE COMMENT
-%token FUN1 GRGR
+%token FUN1 FUNN GRGR
%token PRINT PRINTF SPRINTF SPLIT
%token IF ELSE WHILE FOR IN
-%token EXIT NEXT BREAK CONTINUE
+%token EXIT NEXT BREAK CONTINUE RET
+%token GETLINE DO SUB GSUB MATCH
+%token FUNCTION USERFUN DELETE
%right ASGNOP
+%right '?' ':'
%left OROR
%left ANDAND
-%left NOT
+%left IN
%left NUMBER VAR SUBSTR INDEX
-%left GETLINE
-%nonassoc RELOP MATCHOP
+%left MATCHOP
+%left RELOP '<' '>'
%left OR
%left STRING
%left '+' '-'
%left '*' '/' '%'
%right UMINUS
+%left NOT
+%right '^'
%left INCR DECR
%left FIELD VFIELD
%%
-program : junk begin hunks end
- { root = oper4(OPROG,$1,$2,$3,$4); }
+program : junk hunks
+ { root = oper4(OPROG,$1,begins,$2,ends); }
;
begin : BEGIN '{' maybe states '}' junk
- { $$ = oper3(OJUNK,$3,$4,$6); in_begin = FALSE; }
- | /* NULL */
- { $$ = Nullop; }
+ { begins = oper4(OJUNK,begins,$3,$4,$6); in_begin = FALSE;
+ $$ = Nullop; }
;
end : END '{' maybe states '}'
- { $$ = oper2(OJUNK,$3,$4); }
+ { ends = oper3(OJUNK,ends,$3,$4); $$ = Nullop; }
| end NEWLINE
{ $$ = $1; }
- | /* NULL */
- { $$ = Nullop; }
;
hunks : hunks hunk junk
{ $$ = oper1(OHUNK,$1); need_entire = TRUE; }
| patpat '{' maybe states '}'
{ $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); }
+ | FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}'
+ { fixfargs($2,$4,0); $$ = oper5(OUSERDEF,$2,$4,$6,$8,$9); }
| '{' maybe states '}'
{ $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); }
+ | begin
+ | end
+ ;
+
+arg_list: expr_list
+ { $$ = rememberargs($$); }
;
patpat : pat
{ $$ = oper2(ORANGE,$1,$3); }
;
-pat : REGEX
- { $$ = oper1(OREGEX,$1); }
- | match
+pat : match
| rel
| compound_pat
;
compound_pat
: '(' compound_pat ')'
{ $$ = oper1(OPPAREN,$2); }
- | pat ANDAND pat
- { $$ = oper2(OPANDAND,$1,$3); }
- | pat OROR pat
- { $$ = oper2(OPOROR,$1,$3); }
+ | pat ANDAND maybe pat
+ { $$ = oper3(OPANDAND,$1,$3,$4); }
+ | pat OROR maybe pat
+ { $$ = oper3(OPOROR,$1,$3,$4); }
| NOT pat
{ $$ = oper1(OPNOT,$2); }
;
compound_cond
: '(' compound_cond ')'
{ $$ = oper1(OCPAREN,$2); }
- | cond ANDAND cond
- { $$ = oper2(OCANDAND,$1,$3); }
- | cond OROR cond
- { $$ = oper2(OCOROR,$1,$3); }
+ | cond ANDAND maybe cond
+ { $$ = oper3(OCANDAND,$1,$3,$4); }
+ | cond OROR maybe cond
+ { $$ = oper3(OCOROR,$1,$3,$4); }
| NOT cond
{ $$ = oper1(OCNOT,$2); }
;
rel : expr RELOP expr
{ $$ = oper3(ORELOP,$2,$1,$3); }
+ | expr '>' expr
+ { $$ = oper3(ORELOP,string(">",1),$1,$3); }
+ | expr '<' expr
+ { $$ = oper3(ORELOP,string("<",1),$1,$3); }
| '(' rel ')'
{ $$ = oper1(ORPAREN,$2); }
;
-match : expr MATCHOP REGEX
+match : expr MATCHOP expr
+ { $$ = oper3(OMATCHOP,$2,$1,$3); }
+ | expr MATCHOP REGEX
{ $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); }
+ | REGEX %prec MATCHOP
+ { $$ = oper1(OREGEX,$1); }
| '(' match ')'
{ $$ = oper1(OMPAREN,$2); }
;
term : variable
{ $$ = $1; }
+ | NUMBER
+ { $$ = oper1(ONUM,$1); }
+ | STRING
+ { $$ = oper1(OSTR,$1); }
| term '+' term
{ $$ = oper2(OADD,$1,$3); }
| term '-' term
- { $$ = oper2(OSUB,$1,$3); }
+ { $$ = oper2(OSUBTRACT,$1,$3); }
| term '*' term
{ $$ = oper2(OMULT,$1,$3); }
| term '/' term
{ $$ = oper2(ODIV,$1,$3); }
| term '%' term
{ $$ = oper2(OMOD,$1,$3); }
+ | term '^' term
+ { $$ = oper2(OPOW,$1,$3); }
+ | term IN VAR
+ { $$ = oper2(ODEFINED,aryrefarg($3),$1); }
+ | term '?' term ':' term
+ { $$ = oper2(OCOND,$1,$3,$5); }
| variable INCR
{ $$ = oper1(OPOSTINCR,$1); }
| variable DECR
{ $$ = oper1(OPAREN,$2); }
| GETLINE
{ $$ = oper0(OGETLINE); }
+ | GETLINE VAR
+ { $$ = oper1(OGETLINE,$2); }
+ | GETLINE '<' expr
+ { $$ = oper3(OGETLINE,Nullop,string("<",1),$3);
+ if (ops[$3].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | GETLINE VAR '<' expr
+ { $$ = oper3(OGETLINE,$2,string("<",1),$4);
+ if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | term 'p' GETLINE
+ { $$ = oper3(OGETLINE,Nullop,string("|",1),$1);
+ if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | term 'p' GETLINE VAR
+ { $$ = oper3(OGETLINE,$4,string("|",1),$1);
+ if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
| FUN1
{ $$ = oper0($1); need_entire = do_chop = TRUE; }
| FUN1 '(' ')'
{ $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; }
| FUN1 '(' expr ')'
{ $$ = oper1($1,$3); }
- | SPRINTF print_list
+ | FUNN '(' expr_list ')'
+ { $$ = oper1($1,$3); }
+ | USERFUN '(' expr_list ')'
+ { $$ = oper2(OUSERFUN,$1,$3); }
+ | SPRINTF expr_list
{ $$ = oper1(OSPRINTF,$2); }
| SUBSTR '(' expr ',' expr ',' expr ')'
{ $$ = oper3(OSUBSTR,$3,$5,$7); }
| SUBSTR '(' expr ',' expr ')'
{ $$ = oper2(OSUBSTR,$3,$5); }
| SPLIT '(' expr ',' VAR ',' expr ')'
- { $$ = oper3(OSPLIT,$3,numary($5),$7); }
+ { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),$7); }
| SPLIT '(' expr ',' VAR ')'
- { $$ = oper2(OSPLIT,$3,numary($5)); }
+ { $$ = oper2(OSPLIT,$3,aryrefarg(numary($5))); }
| INDEX '(' expr ',' expr ')'
{ $$ = oper2(OINDEX,$3,$5); }
+ | MATCH '(' expr ',' REGEX ')'
+ { $$ = oper2(OMATCH,$3,oper1(OREGEX,$5)); }
+ | MATCH '(' expr ',' expr ')'
+ { $$ = oper2(OMATCH,$3,$5); }
+ | SUB '(' expr ',' expr ')'
+ { $$ = oper2(OSUB,$3,$5); }
+ | SUB '(' REGEX ',' expr ')'
+ { $$ = oper2(OSUB,oper1(OREGEX,$3),$5); }
+ | GSUB '(' expr ',' expr ')'
+ { $$ = oper2(OGSUB,$3,$5); }
+ | GSUB '(' REGEX ',' expr ')'
+ { $$ = oper2(OGSUB,oper1(OREGEX,$3),$5); }
+ | SUB '(' expr ',' expr ',' expr ')'
+ { $$ = oper3(OSUB,$3,$5,$7); }
+ | SUB '(' REGEX ',' expr ',' expr ')'
+ { $$ = oper3(OSUB,oper1(OREGEX,$3),$5,$7); }
+ | GSUB '(' expr ',' expr ',' expr ')'
+ { $$ = oper3(OGSUB,$3,$5,$7); }
+ | GSUB '(' REGEX ',' expr ',' expr ')'
+ { $$ = oper3(OGSUB,oper1(OREGEX,$3),$5,$7); }
;
-variable: NUMBER
- { $$ = oper1(ONUM,$1); }
- | STRING
- { $$ = oper1(OSTR,$1); }
- | VAR
+variable: VAR
{ $$ = oper1(OVAR,$1); }
- | VAR '[' expr ']'
- { $$ = oper2(OVAR,$1,$3); }
+ | VAR '[' expr_list ']'
+ { $$ = oper2(OVAR,aryrefarg($1),$3); }
| FIELD
{ $$ = oper1(OFLD,$1); }
| VFIELD term
{ $$ = oper1(OVFLD,$2); }
;
-print_list
+expr_list
: expr
| clist
| /* NULL */
{ $$ = Nullop; }
;
-clist : expr ',' expr
- { $$ = oper2(OCOMMA,$1,$3); }
- | clist ',' expr
- { $$ = oper2(OCOMMA,$1,$3); }
+clist : expr ',' maybe expr
+ { $$ = oper3(OCOMMA,$1,$3,$4); }
+ | clist ',' maybe expr
+ { $$ = oper3(OCOMMA,$1,$3,$4); }
| '(' clist ')' /* these parens are invisible */
{ $$ = $2; }
;
;
hunksep : ';'
- { $$ = oper0(OSEMICOLON); }
+ { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
| SEMINEW
- { $$ = oper0(OSEMICOLON); }
+ { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
| NEWLINE
{ $$ = oper0(ONEWLINE); }
| COMMENT
simple
: expr
- | PRINT print_list redir expr
+ | PRINT expr_list redir expr
{ $$ = oper3(OPRINT,$2,$3,$4);
do_opens = TRUE;
saw_ORS = saw_OFS = TRUE;
if (!$2) need_entire = TRUE;
if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
- | PRINT print_list
+ | PRINT expr_list
{ $$ = oper1(OPRINT,$2);
if (!$2) need_entire = TRUE;
saw_ORS = saw_OFS = TRUE;
}
- | PRINTF print_list redir expr
+ | PRINTF expr_list redir expr
{ $$ = oper3(OPRINTF,$2,$3,$4);
do_opens = TRUE;
if (!$2) need_entire = TRUE;
if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
- | PRINTF print_list
+ | PRINTF expr_list
{ $$ = oper1(OPRINTF,$2);
if (!$2) need_entire = TRUE;
}
{ $$ = oper1(OEXIT,$2); }
| CONTINUE
{ $$ = oper0(OCONTINUE); }
+ | RET
+ { $$ = oper0(ORETURN); }
+ | RET expr
+ { $$ = oper1(ORETURN,$2); }
+ | DELETE VAR '[' expr ']'
+ { $$ = oper2(ODELETE,aryrefarg($2),$4); }
;
-redir : RELOP
- { $$ = oper1(OREDIR,string(">",1)); }
+redir : '>' %prec FIELD
+ { $$ = oper1(OREDIR,$1); }
| GRGR
{ $$ = oper1(OREDIR,string(">>",2)); }
| '|'
{ $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); }
| WHILE '(' cond ')' maybe statement
{ $$ = oper2(OWHILE,$3,bl($6,$5)); }
+ | DO maybe statement WHILE '(' cond ')'
+ { $$ = oper2(ODO,bl($3,$2),$6); }
| FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement
{ $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); }
| FOR '(' simpnull ';' ';' simpnull ')' maybe statement
{ $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); }
- | FOR '(' VAR IN VAR ')' maybe statement
- { $$ = oper3(OFORIN,$3,$5,bl($8,$7)); }
+ | FOR '(' expr ')' maybe statement
+ { $$ = oper2(OFORIN,$3,bl($6,$5)); }
| '{' maybe states '}' maybe
{ $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); }
;
-/* $Header: a2py.c,v 2.0 88/06/05 00:15:41 root Exp $
+/* $Header: a2py.c,v 3.0 89/10/18 15:34:35 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: a2py.c,v $
- * Revision 2.0 88/06/05 00:15:41 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:34:35 lwall
+ * 3.0 baseline
*
*/
char *filename;
int checkers = 0;
+STR *walk();
main(argc,argv,env)
register int argc;
register STR *str;
register char *s;
int i;
- STR *walk();
STR *tmpstr;
linestr = str_new(80);
bufptr = str_get(linestr);
symtab = hnew();
+ curarghash = hnew();
/* now parse the report spec */
/* second pass to produce new program */
- tmpstr = walk(0,0,root,&i);
- str = str_make("#!/usr/bin/perl\neval \"exec /usr/bin/perl -S $0 $*\"\n\
+ tmpstr = walk(0,0,root,&i,P_MIN);
+ str = str_make("#!");
+ str_cat(str, BIN);
+ str_cat(str, "/perl\neval \"exec ");
+ str_cat(str, BIN);
+ str_cat(str, "/perl -S $0 $*\"\n\
if $running_under_some_shell;\n\
# this emulates #! processing on NIH machines.\n\
# (remove #! line above if indigestible)\n\n");
#define RETURN(retval) return (bufptr = s,retval)
#define XTERM(retval) return (expectterm = TRUE,bufptr = s,retval)
#define XOP(retval) return (expectterm = FALSE,bufptr = s,retval)
-#define ID(x) return (yylval=string(x,0),expectterm = FALSE,bufptr = s,VAR)
+#define ID(x) return (yylval=string(x,0),expectterm = FALSE,bufptr = s,idtype)
+
+int idtype;
yylex()
{
}
XTERM(tmp);
case '(':
+ tmp = *s++;
+ XTERM(tmp);
case '{':
case '[':
case ')':
case ']':
+ case '?':
+ case ':':
tmp = *s++;
XOP(tmp);
case 127:
/* FALL THROUGH */
case '*':
case '%':
+ case '^':
tmp = *s++;
if (*s == '=') {
- yylval = string(s-1,2);
+ if (tmp == '^')
+ yylval = string("**=",3);
+ else
+ yylval = string(s-1,2);
s++;
XTERM(ASGNOP);
}
if (tmp == '|')
XTERM(OROR);
s--;
- XTERM('|');
+ while (*s == ' ' || *s == '\t')
+ s++;
+ if (strnEQ(s,"getline",7))
+ XTERM('p');
+ else
+ XTERM('|');
case '=':
s++;
tmp = *s++;
XTERM(RELOP);
}
s--;
- yylval = string("<",1);
- XTERM(RELOP);
+ XTERM('<');
case '>':
s++;
tmp = *s++;
XTERM(RELOP);
}
s--;
- yylval = string(">",1);
- XTERM(RELOP);
+ XTERM('>');
#define SNARFWORD \
d = tokenbuf; \
while (isalpha(*s) || isdigit(*s) || *s == '_') \
*d++ = *s++; \
*d = '\0'; \
- d = tokenbuf;
+ d = tokenbuf; \
+ if (*s == '(') \
+ idtype = USERFUN; \
+ else \
+ idtype = VAR;
case '$':
s++;
s++;
do_chop = TRUE;
need_entire = TRUE;
+ idtype = VAR;
ID("0");
}
do_split = TRUE;
XTERM(tmp);
case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
+ case '5': case '6': case '7': case '8': case '9': case '.':
s = scannum(s);
XOP(NUMBER);
case '"':
case 'a': case 'A':
SNARFWORD;
+ if (strEQ(d,"ARGC"))
+ set_array_base = TRUE;
+ if (strEQ(d,"ARGV")) {
+ yylval=numary(string("ARGV",0));
+ XOP(VAR);
+ }
+ if (strEQ(d,"atan2")) {
+ yylval = OATAN2;
+ XTERM(FUNN);
+ }
ID(d);
case 'b': case 'B':
SNARFWORD;
SNARFWORD;
if (strEQ(d,"continue"))
XTERM(CONTINUE);
+ if (strEQ(d,"cos")) {
+ yylval = OCOS;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"close")) {
+ do_fancy_opens = 1;
+ yylval = OCLOSE;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"chdir"))
+ *d = toupper(*d);
+ else if (strEQ(d,"crypt"))
+ *d = toupper(*d);
+ else if (strEQ(d,"chop"))
+ *d = toupper(*d);
+ else if (strEQ(d,"chmod"))
+ *d = toupper(*d);
+ else if (strEQ(d,"chown"))
+ *d = toupper(*d);
ID(d);
case 'd': case 'D':
SNARFWORD;
+ if (strEQ(d,"do"))
+ XTERM(DO);
+ if (strEQ(d,"delete"))
+ XTERM(DELETE);
+ if (strEQ(d,"die"))
+ *d = toupper(*d);
ID(d);
case 'e': case 'E':
SNARFWORD;
yylval = OEXP;
XTERM(FUN1);
}
+ if (strEQ(d,"elsif"))
+ *d = toupper(*d);
+ else if (strEQ(d,"eq"))
+ *d = toupper(*d);
+ else if (strEQ(d,"eval"))
+ *d = toupper(*d);
+ else if (strEQ(d,"eof"))
+ *d = toupper(*d);
+ else if (strEQ(d,"each"))
+ *d = toupper(*d);
+ else if (strEQ(d,"exec"))
+ *d = toupper(*d);
ID(d);
case 'f': case 'F':
SNARFWORD;
}
ID(tokenbuf);
}
- if (strEQ(d,"FILENAME"))
- d = "ARGV";
if (strEQ(d,"for"))
XTERM(FOR);
+ else if (strEQ(d,"function"))
+ XTERM(FUNCTION);
+ if (strEQ(d,"FILENAME"))
+ d = "ARGV";
+ if (strEQ(d,"foreach"))
+ *d = toupper(*d);
+ else if (strEQ(d,"format"))
+ *d = toupper(*d);
+ else if (strEQ(d,"fork"))
+ *d = toupper(*d);
+ else if (strEQ(d,"fh"))
+ *d = toupper(*d);
ID(d);
case 'g': case 'G':
SNARFWORD;
if (strEQ(d,"getline"))
XTERM(GETLINE);
+ if (strEQ(d,"gsub"))
+ XTERM(GSUB);
+ if (strEQ(d,"ge"))
+ *d = toupper(*d);
+ else if (strEQ(d,"gt"))
+ *d = toupper(*d);
+ else if (strEQ(d,"goto"))
+ *d = toupper(*d);
+ else if (strEQ(d,"gmtime"))
+ *d = toupper(*d);
ID(d);
case 'h': case 'H':
SNARFWORD;
+ if (strEQ(d,"hex"))
+ *d = toupper(*d);
ID(d);
case 'i': case 'I':
SNARFWORD;
ID(d);
case 'j': case 'J':
SNARFWORD;
+ if (strEQ(d,"join"))
+ *d = toupper(*d);
ID(d);
case 'k': case 'K':
SNARFWORD;
+ if (strEQ(d,"keys"))
+ *d = toupper(*d);
+ else if (strEQ(d,"kill"))
+ *d = toupper(*d);
ID(d);
case 'l': case 'L':
SNARFWORD;
yylval = OLOG;
XTERM(FUN1);
}
+ if (strEQ(d,"last"))
+ *d = toupper(*d);
+ else if (strEQ(d,"local"))
+ *d = toupper(*d);
+ else if (strEQ(d,"lt"))
+ *d = toupper(*d);
+ else if (strEQ(d,"le"))
+ *d = toupper(*d);
+ else if (strEQ(d,"locatime"))
+ *d = toupper(*d);
+ else if (strEQ(d,"link"))
+ *d = toupper(*d);
ID(d);
case 'm': case 'M':
SNARFWORD;
+ if (strEQ(d,"match")) {
+ set_array_base = TRUE;
+ XTERM(MATCH);
+ }
+ if (strEQ(d,"m"))
+ *d = toupper(*d);
ID(d);
case 'n': case 'N':
SNARFWORD;
saw_line_op = TRUE;
XTERM(NEXT);
}
+ if (strEQ(d,"ne"))
+ *d = toupper(*d);
ID(d);
case 'o': case 'O':
SNARFWORD;
if (strEQ(d,"ORS")) {
saw_ORS = TRUE;
- d = "$\\";
+ d = "\\";
}
if (strEQ(d,"OFS")) {
saw_OFS = TRUE;
- d = "$,";
+ d = ",";
}
if (strEQ(d,"OFMT")) {
- d = "$#";
+ d = "#";
}
+ if (strEQ(d,"open"))
+ *d = toupper(*d);
+ else if (strEQ(d,"ord"))
+ *d = toupper(*d);
+ else if (strEQ(d,"oct"))
+ *d = toupper(*d);
ID(d);
case 'p': case 'P':
SNARFWORD;
if (strEQ(d,"printf")) {
XTERM(PRINTF);
}
+ if (strEQ(d,"push"))
+ *d = toupper(*d);
+ else if (strEQ(d,"pop"))
+ *d = toupper(*d);
ID(d);
case 'q': case 'Q':
SNARFWORD;
case 'r': case 'R':
SNARFWORD;
if (strEQ(d,"RS")) {
- d = "$/";
+ d = "/";
saw_RS = TRUE;
}
+ if (strEQ(d,"rand")) {
+ yylval = ORAND;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"return"))
+ XTERM(RET);
+ if (strEQ(d,"reset"))
+ *d = toupper(*d);
+ else if (strEQ(d,"redo"))
+ *d = toupper(*d);
+ else if (strEQ(d,"rename"))
+ *d = toupper(*d);
ID(d);
case 's': case 'S':
SNARFWORD;
set_array_base = TRUE;
XTERM(SUBSTR);
}
+ if (strEQ(d,"sub"))
+ XTERM(SUB);
if (strEQ(d,"sprintf"))
XTERM(SPRINTF);
if (strEQ(d,"sqrt")) {
yylval = OSQRT;
XTERM(FUN1);
}
+ if (strEQ(d,"SUBSEP")) {
+ d = ";";
+ }
+ if (strEQ(d,"sin")) {
+ yylval = OSIN;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"srand")) {
+ yylval = OSRAND;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"system")) {
+ yylval = OSYSTEM;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"s"))
+ *d = toupper(*d);
+ else if (strEQ(d,"shift"))
+ *d = toupper(*d);
+ else if (strEQ(d,"select"))
+ *d = toupper(*d);
+ else if (strEQ(d,"seek"))
+ *d = toupper(*d);
+ else if (strEQ(d,"stat"))
+ *d = toupper(*d);
+ else if (strEQ(d,"study"))
+ *d = toupper(*d);
+ else if (strEQ(d,"sleep"))
+ *d = toupper(*d);
+ else if (strEQ(d,"symlink"))
+ *d = toupper(*d);
+ else if (strEQ(d,"sort"))
+ *d = toupper(*d);
ID(d);
case 't': case 'T':
SNARFWORD;
+ if (strEQ(d,"tr"))
+ *d = toupper(*d);
+ else if (strEQ(d,"tell"))
+ *d = toupper(*d);
+ else if (strEQ(d,"time"))
+ *d = toupper(*d);
+ else if (strEQ(d,"times"))
+ *d = toupper(*d);
ID(d);
case 'u': case 'U':
SNARFWORD;
+ if (strEQ(d,"until"))
+ *d = toupper(*d);
+ else if (strEQ(d,"unless"))
+ *d = toupper(*d);
+ else if (strEQ(d,"umask"))
+ *d = toupper(*d);
+ else if (strEQ(d,"unshift"))
+ *d = toupper(*d);
+ else if (strEQ(d,"unlink"))
+ *d = toupper(*d);
+ else if (strEQ(d,"utime"))
+ *d = toupper(*d);
ID(d);
case 'v': case 'V':
SNARFWORD;
+ if (strEQ(d,"values"))
+ *d = toupper(*d);
ID(d);
case 'w': case 'W':
SNARFWORD;
if (strEQ(d,"while"))
XTERM(WHILE);
+ if (strEQ(d,"write"))
+ *d = toupper(*d);
+ else if (strEQ(d,"wait"))
+ *d = toupper(*d);
ID(d);
case 'x': case 'X':
SNARFWORD;
+ if (strEQ(d,"x"))
+ *d = toupper(*d);
ID(d);
case 'y': case 'Y':
SNARFWORD;
+ if (strEQ(d,"y"))
+ *d = toupper(*d);
ID(d);
case 'z': case 'Z':
SNARFWORD;
ops[mop].cval = safemalloc(len+1);
strncpy(ops[mop].cval,ptr,len);
ops[mop++].cval[len] = '\0';
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
return retval;
}
if (type > 255)
fatal("type > 255 (%d)\n",type);
ops[mop++].ival = type;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
return retval;
}
fatal("type > 255 (%d)\n",type);
ops[mop++].ival = type + (1<<8);
ops[mop++].ival = arg1;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
return retval;
}
ops[mop++].ival = type + (2<<8);
ops[mop++].ival = arg1;
ops[mop++].ival = arg2;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
return retval;
}
ops[mop++].ival = arg1;
ops[mop++].ival = arg2;
ops[mop++].ival = arg3;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
return retval;
}
ops[mop++].ival = arg2;
ops[mop++].ival = arg3;
ops[mop++].ival = arg4;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
return retval;
}
ops[mop++].ival = arg3;
ops[mop++].ival = arg4;
ops[mop++].ival = arg5;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
return retval;
}
STR *key;
int dummy;
- key = walk(0,0,arg,&dummy);
+ key = walk(0,0,arg,&dummy,P_MIN);
str_cat(key,"[]");
hstore(symtab,key->str_ptr,str_make("1"));
str_free(key);
set_array_base = TRUE;
return arg;
}
+
+rememberargs(arg)
+int arg;
+{
+ int type;
+ STR *str;
+
+ if (!arg)
+ return arg;
+ type = ops[arg].ival & 255;
+ if (type == OCOMMA) {
+ rememberargs(ops[arg+1].ival);
+ rememberargs(ops[arg+3].ival);
+ }
+ else if (type == OVAR) {
+ str = str_new(0);
+ hstore(curarghash,ops[ops[arg+1].ival+1].cval,str);
+ }
+ else
+ fatal("panic: unknown argument type %d, line %d\n",type,line);
+ return arg;
+}
+
+aryrefarg(arg)
+int arg;
+{
+ int type = ops[arg].ival & 255;
+ STR *str;
+
+ if (type != OSTRING)
+ fatal("panic: aryrefarg %d, line %d\n",type,line);
+ str = hfetch(curarghash,ops[arg+1].cval);
+ if (str)
+ str_set(str,"*");
+ return arg;
+}
+
+fixfargs(name,arg,prevargs)
+int name;
+int arg;
+int prevargs;
+{
+ int type;
+ STR *str;
+ int numargs;
+
+ if (!arg)
+ return prevargs;
+ type = ops[arg].ival & 255;
+ if (type == OCOMMA) {
+ numargs = fixfargs(name,ops[arg+1].ival,prevargs);
+ numargs = fixfargs(name,ops[arg+3].ival,numargs);
+ }
+ else if (type == OVAR) {
+ str = hfetch(curarghash,ops[ops[arg+1].ival+1].cval);
+ if (strEQ(str_get(str),"*")) {
+ char tmpbuf[128];
+
+ str_set(str,""); /* in case another routine has this */
+ ops[arg].ival &= ~255;
+ ops[arg].ival |= OSTAR;
+ sprintf(tmpbuf,"%s:%d",ops[name+1].cval,prevargs);
+ fprintf(stderr,"Adding %s\n",tmpbuf);
+ str = str_new(0);
+ str_set(str,"*");
+ hstore(curarghash,tmpbuf,str);
+ }
+ numargs = prevargs + 1;
+ }
+ else
+ fatal("panic: unknown argument type %d, arg %d, line %d\n",
+ type,numargs+1,line);
+ return numargs;
+}
+
+fixrargs(name,arg,prevargs)
+char *name;
+int arg;
+int prevargs;
+{
+ int type;
+ STR *str;
+ int numargs;
+
+ if (!arg)
+ return prevargs;
+ type = ops[arg].ival & 255;
+ if (type == OCOMMA) {
+ numargs = fixrargs(name,ops[arg+1].ival,prevargs);
+ numargs = fixrargs(name,ops[arg+3].ival,numargs);
+ }
+ else {
+ char tmpbuf[128];
+
+ sprintf(tmpbuf,"%s:%d",name,prevargs);
+ str = hfetch(curarghash,tmpbuf);
+ fprintf(stderr,"Looking for %s\n",tmpbuf);
+ if (str && strEQ(str->str_ptr,"*")) {
+ if (type == OVAR || type == OSTAR) {
+ ops[arg].ival &= ~255;
+ ops[arg].ival |= OSTAR;
+ }
+ else
+ fatal("Can't pass expression by reference as arg %d of %s\n",
+ prevargs+1, name);
+ }
+ numargs = prevargs + 1;
+ }
+ return numargs;
+}
+
-/* $Header: handy.h,v 2.0 88/06/05 00:15:47 root Exp $
+/* $Header: handy.h,v 3.0 89/10/18 15:34:44 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:15:47 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:34:44 lwall
+ * 3.0 baseline
*
*/
-/* $Header: hash.c,v 2.0 88/06/05 00:15:50 root Exp $
+/* $Header: hash.c,v 3.0 89/10/18 15:34:50 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:15:50 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:34:50 lwall
+ * 3.0 baseline
*
*/
-/* $Header: hash.h,v 2.0 88/06/05 00:15:52 root Exp $
+/* $Header: hash.h,v 3.0 89/10/18 15:34:57 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:15:52 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:34:57 lwall
+ * 3.0 baseline
*
*/
-#!/usr/bin/perl
-
-# $Header: s2p,v 2.0 88/06/05 00:15:55 root Exp $
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+case $CONFIG in
+'')
+ if test ! -f config.sh; then
+ ln ../config.sh . || \
+ ln ../../config.sh . || \
+ ln ../../../config.sh . || \
+ (echo "Can't find config.sh."; exit 1)
+ fi
+ . config.sh
+ ;;
+esac
+echo "Extracting s2p (with variable substitutions)"
+: This section of the file will have variable substitutions done on it.
+: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
+: Protect any dollar signs and backticks that you do not want interpreted
+: by putting a backslash in front. You may delete these comments.
+$spitshell >s2p <<!GROK!THIS!
+#!$bin/perl
+
+\$bin = '$bin';
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>s2p <<'!NO!SUBS!'
+
+# $Header: s2p.SH,v 3.0 89/10/18 15:35:02 lwall Locked $
#
-# $Log: s2p,v $
+# $Log: s2p.SH,v $
+# Revision 3.0 89/10/18 15:35:02 lwall
+# 3.0 baseline
+#
+# Revision 2.0.1.1 88/07/11 23:26:23 root
+# patch2: s2p didn't put a proper prologue on output script
+#
# Revision 2.0 88/06/05 00:15:55 root
# Baseline version 2.0.
#
$addr1 = 'eof()';
}
elsif (s|^/||) {
- $addr1 = '/';
- delim: while (s:^([^(|)\\/]*)([(|)\\/])::) {
- $prefix = $1;
- $delim = $2;
- if ($delim eq '\\') {
- s/(.)(.*)/$2/;
- $ch = $1;
- $delim = '' if index("(|)",$ch) >= 0;
- $delim .= $1;
- }
- elsif ($delim ne '/') {
- $delim = '\\' . $delim;
- }
- $addr1 .= $prefix;
- $addr1 .= $delim;
- if ($delim eq '/') {
- last delim;
- }
- }
+ $addr1 = do fetchpat('/');
}
if (s/^,//) {
if (s/^([0-9]+)//) {
} elsif (s/^\$//) {
$addr2 = "eof()";
} elsif (s|^/||) {
- $addr2 = '/';
- delim: while (s:^([^(|)\\/]*)([(|)\\/])::) {
- $prefix = $1;
- $delim = $2;
- if ($delim eq '\\') {
- s/(.)(.*)/$2/;
- $ch = $1;
- $delim = '' if index("(|)",$ch) >= 0;
- $delim .= $1;
- }
- elsif ($delim ne '/') {
- $delim = '\\' . $delim;
- }
- $addr2 .= $prefix;
- $addr2 .= $delim;
- if ($delim eq '/') {
- last delim;
- }
- }
+ $addr2 = do fetchpat('/');
} else {
do Die("Invalid second address at line $.\n");
}
} else {
$rmaybe = "\n$r";
if ($addr2 || $addr1) {
- $space = substr(' ',0,$shiftwidth);
+ $space = ' ' x $shiftwidth;
} else {
$space = '';
}
while ($#lines >= 0) {
$_ = shift(lines);
unless (s/^ *<<--//) {
- print body substr("\t\t\t\t\t\t\t\t\t\t\t\t",0,$indent / 8),
- substr(' ',0,$indent % 8);
+ print body "\t" x ($indent / 8), ' ' x ($indent % 8);
}
print body $_, "\n";
}
}
close head;
- print "#!/bin/perl\n\n";
+ print "#!$bin/perl
+eval \"exec $bin/perl -S \$0 \$*\"
+ if \$running_under_some_shell;
+
+";
open(body,"cc -E /tmp/sperl2$$.c |") ||
do Die("Can't reopen temp file");
while (<body>) {
$label =~ s/[^a-zA-Z0-9]/_/g;
if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
$label = substr($label,0,8);
- if ($label =~ /^([a-z])([a-z]*)$/) {
+ if ($label =~ /^([a-z])([a-z]*)$/) { # could be reserved word
$first = $1;
$rest = $2;
- $first =~ y/a-z/A-Z/;
+ $first =~ y/a-z/A-Z/; # so capitalize it
$label = $first . $rest;
}
$label;
$delim = substr($_,1,1);
$len = length($_);
$repl = $end = 0;
+ $inbracket = 0;
for ($i = 2; $i < $len; $i++) {
$c = substr($_,$i,1);
- if ($c eq '\\') {
+ if ($c eq $delim) {
+ if ($inbracket) {
+ $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
+ $i++;
+ $len++;
+ }
+ else {
+ if ($repl) {
+ $end = $i;
+ last;
+ } else {
+ $repl = $i;
+ }
+ }
+ }
+ elsif ($c eq '\\') {
$i++;
if ($i >= $len) {
$_ .= 'n';
$len = length($_);
$_ = substr($_,0,--$len);
}
- elsif (!$repl && index("(|)",substr($_,$i,1)) >= 0) {
+ elsif (!$repl && substr($_,$i,1) =~ /^[(){}\w]$/) {
$i--;
$len--;
$_ = substr($_,0,$i) . substr($_,$i+1,10000);
}
}
- elsif ($c eq $delim) {
- if ($repl) {
- $end = $i;
- last;
- } else {
- $repl = $i;
- }
+ elsif ($c eq '[' && !$repl) {
+ $i++ if substr($_,$i,1) eq '^';
+ $i++ if substr($_,$i,1) eq ']';
+ $inbracket = 1;
}
- elsif (!$repl && index("(|)",$c) >= 0) {
+ elsif ($c eq ']') {
+ $inbracket = 0;
+ }
+ elsif (!$repl && index("()",$c) >= 0) {
$_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
$i++;
$len++;
}
do Die("Unrecognized substitution command ($end) at line $.\n");
}
- $_ = $subst . $cmd . ';';
+ $_ =
+"<<--#ifdef TSEEN
+$subst && \$tflag++$cmd;
+<<--#else
+$subst$cmd;
+<<--#endif";
next;
}
}
if (/^P/) {
- $_ =
-'if (/(^[^\n]*\n)/) {
- print $1;
-}';
+ $_ = 'print $1 if /(^.*\n)/;';
next;
}
if (/^D/) {
$_ =
-'s/^[^\n]*\n//;
-if ($_) {redo line;}
+'s/^.*\n//;
+redo line if $_;
next line;';
next;
}
$_;
}
+sub fetchpat {
+ local($outer) = @_;
+ local($addr) = $outer;
+ local($inbracket);
+ local($prefix,$delim,$ch);
+
+ delim: while (s:^([^\](|)[\\/]*)([](|)[\\/])::) {
+ $prefix = $1;
+ $delim = $2;
+ print "$prefix\t$delim\t$_\n";
+ if ($delim eq '\\') {
+ s/(.)//;
+ $ch = $1;
+ $delim = '' if $ch =~ /^[(){}\w]$/;
+ $delim .= $1;
+ }
+ elsif ($delim eq '[') {
+ $inbracket = 1;
+ s/^\^// && ($delim .= '^');
+ s/^]// && ($delim .= ']');
+ print "$prefix\t$delim\t$_\n";
+ }
+ elsif ($delim eq ']') {
+ $inbracket = 0;
+ }
+ elsif ($inbracket || $delim ne $outer) {
+ print "Adding\n";
+ $delim = '\\' . $delim;
+ }
+ $addr .= $prefix;
+ $addr .= $delim;
+ if ($delim eq $outer && !$inbracket) {
+ last delim;
+ }
+ }
+ $addr;
+}
+
+!NO!SUBS!
+chmod 755 s2p
+$eunicefix s2p
.rn '' }`
-''' $Header: s2p.man,v 2.0 88/06/05 00:15:59 root Exp $
+''' $Header: s2p.man,v 3.0 89/10/18 15:35:09 lwall Locked $
'''
''' $Log: s2p.man,v $
+''' Revision 3.0 89/10/18 15:35:09 lwall
+''' 3.0 baseline
+'''
''' Revision 2.0 88/06/05 00:15:59 root
''' Baseline version 2.0.
'''
-/* $Header: str.c,v 2.0 88/06/05 00:16:02 root Exp $
+/* $Header: str.c,v 3.0 89/10/18 15:35:18 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: str.c,v $
- * Revision 2.0 88/06/05 00:16:02 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:35:18 lwall
+ * 3.0 baseline
*
*/
-/* $Header: str.h,v 2.0 88/06/05 00:16:05 root Exp $
+/* $Header: str.h,v 3.0 89/10/18 15:35: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: str.h,v $
- * Revision 2.0 88/06/05 00:16:05 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:35:27 lwall
+ * 3.0 baseline
*
*/
-/* $Header: util.c,v 2.0 88/06/05 00:16:07 root Exp $
+/* $Header: util.c,v 3.0 89/10/18 15:35:35 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: util.c,v $
- * Revision 2.0 88/06/05 00:16:07 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:35:35 lwall
+ * 3.0 baseline
*
*/
exit(1);
}
+/*VARARGS1*/
+warn(pat,a1,a2,a3,a4)
+char *pat;
+{
+ fprintf(stderr,pat,a1,a2,a3,a4);
+}
+
static bool firstsetenv = TRUE;
extern char **environ;
-/* $Header: util.h,v 2.0 88/06/05 00:16:10 root Exp $
+/* $Header: util.h,v 3.0 89/10/18 15:35: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: util.h,v $
- * Revision 2.0 88/06/05 00:16:10 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:35:41 lwall
+ * 3.0 baseline
*
*/
-/* $Header: walk.c,v 2.0 88/06/05 00:16:12 root Exp $
+/* $Header: walk.c,v 3.0 89/10/18 15:35:48 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: walk.c,v $
- * Revision 2.0 88/06/05 00:16:12 root
- * Baseline version 2.0.
+ * Revision 3.0 89/10/18 15:35:48 lwall
+ * 3.0 baseline
*
*/
bool exitval = FALSE;
bool realexit = FALSE;
bool saw_getline = FALSE;
+bool subretnum = FALSE;
+bool saw_FNR = FALSE;
+bool saw_argv0 = FALSE;
int maxtmp = 0;
char *lparen;
char *rparen;
+STR *subs;
+STR *curargs = Nullstr;
STR *
-walk(useval,level,node,numericptr)
+walk(useval,level,node,numericptr,minprec)
int useval;
int level;
register int node;
int *numericptr;
+int minprec; /* minimum precedence without parens */
{
register int len;
register STR *str;
register int i;
register STR *tmpstr;
STR *tmp2str;
+ STR *tmp3str;
char *t;
char *d, *s;
int numarg;
int numeric = FALSE;
STR *fstr;
+ int prec = P_MAX; /* assume no parens needed */
char *index();
if (!node) {
type &= 255;
switch (type) {
case OPROG:
- str = walk(0,level,ops[node+1].ival,&numarg);
opens = str_new(0);
+ subs = str_new(0);
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
if (do_split && need_entire && !absmaxfld)
split_to_array = TRUE;
if (do_split && split_to_array)
if (saw_ORS) {
str_cat(str,"$\\ = \"\\n\";\t\t# set output record separator\n");
}
+ if (saw_argv0) {
+ str_cat(str,"$ARGV0 = $0;\t\t# remember what we ran as\n");
+ }
if (str->str_cur > 20)
str_cat(str,"\n");
if (ops[node+2].ival) {
- str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,"\n\n");
}
- if (saw_line_op)
- str_cat(str,"line: ");
- str_cat(str,"while (<>) {\n");
- tab(str,++level);
- if (saw_FS && !const_FS)
- do_chop = TRUE;
- if (do_chop) {
- str_cat(str,"chop;\t# strip record separator\n");
- tab(str,level);
- }
- arymax = 0;
- if (namelist) {
- while (isalpha(*namelist)) {
- for (d = tokenbuf,s=namelist;
- isalpha(*s) || isdigit(*s) || *s == '_';
- *d++ = *s++) ;
- *d = '\0';
- while (*s && !isalpha(*s)) s++;
- namelist = s;
- nameary[++arymax] = savestr(tokenbuf);
+ fstr = walk(0,level+1,ops[node+3].ival,&numarg,P_MIN);
+ if (*fstr->str_ptr) {
+ if (saw_line_op)
+ str_cat(str,"line: ");
+ str_cat(str,"while (<>) {\n");
+ tab(str,++level);
+ if (saw_FS && !const_FS)
+ do_chop = TRUE;
+ if (do_chop) {
+ str_cat(str,"chop;\t# strip record separator\n");
+ tab(str,level);
}
+ arymax = 0;
+ if (namelist) {
+ while (isalpha(*namelist)) {
+ for (d = tokenbuf,s=namelist;
+ isalpha(*s) || isdigit(*s) || *s == '_';
+ *d++ = *s++) ;
+ *d = '\0';
+ while (*s && !isalpha(*s)) s++;
+ namelist = s;
+ nameary[++arymax] = savestr(tokenbuf);
+ }
+ }
+ if (maxfld < arymax)
+ maxfld = arymax;
+ if (do_split)
+ emit_split(str,level);
+ str_scat(str,fstr);
+ str_free(fstr);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ if (saw_FNR)
+ str_cat(str,"continue {\n $FNRbase = $. if eof;\n}\n");
}
- if (maxfld < arymax)
- maxfld = arymax;
- if (do_split)
- emit_split(str,level);
- str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
- str_free(fstr);
- fixtab(str,--level);
- str_cat(str,"}\n");
+ else
+ str_cat(str,"# (no line actions)\n");
if (ops[node+4].ival) {
realexit = TRUE;
str_cat(str,"\n");
tab(str,level);
- str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,"\n");
}
if (exitval)
str_cat(str,"exit ExitValue;\n");
+ if (subs->str_ptr) {
+ str_cat(str,"\n");
+ str_scat(str,subs);
+ }
if (saw_getline) {
- str_cat(str,"\nsub Getline {\n $_ = <>;\n");
- tab(str,++level);
- if (do_chop) {
- str_cat(str,"chop;\t# strip record separator\n");
- tab(str,level);
+ for (len = 0; len < 4; len++) {
+ if (saw_getline & (1 << len)) {
+ sprintf(tokenbuf,"\nsub Getline%d {\n",len);
+ str_cat(str, tokenbuf);
+ if (len & 2) {
+ if (do_fancy_opens)
+ str_cat(str," &Pick('',@_);\n");
+ else
+ str_cat(str," ($fh) = @_;\n");
+ }
+ else {
+ if (saw_FNR)
+ str_cat(str," $FNRbase = $. if eof;\n");
+ }
+ if (len & 1)
+ str_cat(str," local($_)\n");
+ if (len & 2)
+ str_cat(str,
+ " if ($getline_ok = (($_ = <$fh>) ne ''))");
+ else
+ str_cat(str,
+ " if ($getline_ok = (($_ = <>) ne ''))");
+ str_cat(str, " {\n");
+ level += 2;
+ tab(str,level);
+ i = 0;
+ if (do_chop) {
+ i++;
+ str_cat(str,"chop;\t# strip record separator\n");
+ tab(str,level);
+ }
+ if (do_split && !(len & 1)) {
+ i++;
+ emit_split(str,level);
+ }
+ if (!i)
+ str_cat(str,";\n");
+ fixtab(str,--level);
+ str_cat(str,"}\n $_;\n}\n");
+ --level;
+ }
}
- if (do_split)
- emit_split(str,level);
- fixtab(str,--level);
- str_cat(str,"}\n");
}
if (do_fancy_opens) {
str_cat(str,"\n\
sub Pick {\n\
- ($name) = @_;\n\
+ local($mode,$name,$pipe) = @_;\n\
$fh = $opened{$name};\n\
if (!$fh) {\n\
- $nextfh == 0 && open(fh_0,$name);\n\
- $nextfh == 1 && open(fh_1,$name);\n\
- $nextfh == 2 && open(fh_2,$name);\n\
- $nextfh == 3 && open(fh_3,$name);\n\
- $nextfh == 4 && open(fh_4,$name);\n\
- $nextfh == 5 && open(fh_5,$name);\n\
- $nextfh == 6 && open(fh_6,$name);\n\
- $nextfh == 7 && open(fh_7,$name);\n\
- $nextfh == 8 && open(fh_8,$name);\n\
- $nextfh == 9 && open(fh_9,$name);\n\
- $fh = $opened{$name} = 'fh_' . $nextfh++;\n\
+ $fh = $opened{$name} = 'fh_' . ($nextfh++ + 0);\n\
+ open($fh,$mode.$name.$pipe);\n\
}\n\
- select($fh);\n\
}\n\
");
}
break;
case OHUNKS:
- str = walk(0,level,ops[node+1].ival,&numarg);
- str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
str_free(fstr);
if (len == 3) {
- str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN));
str_free(fstr);
}
else {
}
break;
case ORANGE:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_DOTDOT;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
str_cat(str," .. ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
str_free(fstr);
break;
case OPAT:
case OREGEX:
str = str_new(0);
str_set(str,"/");
- tmpstr=walk(0,level,ops[node+1].ival,&numarg);
+ tmpstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN);
/* translate \nnn to [\nnn] */
for (s = tmpstr->str_ptr, d = tokenbuf; *s; s++, d++) {
- if (*s == '\\' && isdigit(s[1]) && isdigit(s[2]) && isdigit(s[3])) {
+ if (*s == '\\' && isdigit(s[1]) && isdigit(s[2]) && isdigit(s[3])){
*d++ = '[';
*d++ = *s++;
*d++ = *s++;
case OHUNK:
if (len == 1) {
str = str_new(0);
- str = walk(0,level,oper1(OPRINT,0),&numarg);
+ str = walk(0,level,oper1(OPRINT,0),&numarg,P_MIN);
str_cat(str," if ");
- str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,";");
}
else {
- tmpstr = walk(0,level,ops[node+1].ival,&numarg);
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
if (*tmpstr->str_ptr) {
str = str_new(0);
str_set(str,"if (");
str_scat(str,tmpstr);
str_cat(str,") {\n");
tab(str,++level);
- str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
str_free(fstr);
fixtab(str,--level);
str_cat(str,"}\n");
tab(str,level);
}
else {
- str = walk(0,level,ops[node+2].ival,&numarg);
+ str = walk(0,level,ops[node+2].ival,&numarg,P_MIN);
}
}
break;
case OPPAREN:
str = str_new(0);
str_set(str,"(");
- str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,")");
break;
case OPANDAND:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_ANDAND;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
str_cat(str," && ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
str_free(fstr);
break;
case OPOROR:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_OROR;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
str_cat(str," || ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
str_free(fstr);
break;
case OPNOT:
+ prec = P_UNARY;
str = str_new(0);
str_set(str,"!");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec));
str_free(fstr);
break;
case OCPAREN:
str = str_new(0);
str_set(str,"(");
- str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
numeric |= numarg;
str_cat(str,")");
break;
case OCANDAND:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_ANDAND;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
numeric = 1;
str_cat(str," && ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
str_free(fstr);
break;
case OCOROR:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_OROR;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
numeric = 1;
str_cat(str," || ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
str_free(fstr);
break;
case OCNOT:
+ prec = P_UNARY;
str = str_new(0);
str_set(str,"!");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec));
str_free(fstr);
numeric = 1;
break;
case ORELOP:
- str = walk(1,level,ops[node+2].ival,&numarg);
+ prec = P_REL;
+ str = walk(1,level,ops[node+2].ival,&numarg,prec+1);
numeric |= numarg;
- tmpstr = walk(0,level,ops[node+1].ival,&numarg);
- tmp2str = walk(1,level,ops[node+3].ival,&numarg);
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ tmp2str = walk(1,level,ops[node+3].ival,&numarg,prec+1);
numeric |= numarg;
- if (!numeric) {
+ if (!numeric ||
+ (!numarg && (*tmp2str->str_ptr == '"' || *tmp2str->str_ptr == '\''))) {
t = tmpstr->str_ptr;
if (strEQ(t,"=="))
str_set(tmpstr,"eq");
case ORPAREN:
str = str_new(0);
str_set(str,"(");
- str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
numeric |= numarg;
str_cat(str,")");
break;
case OMATCHOP:
- str = walk(1,level,ops[node+2].ival,&numarg);
+ prec = P_MATCH;
+ str = walk(1,level,ops[node+2].ival,&numarg,prec+1);
str_cat(str," ");
- tmpstr = walk(0,level,ops[node+1].ival,&numarg);
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
if (strEQ(tmpstr->str_ptr,"~"))
str_cat(str,"=~");
else {
str_free(tmpstr);
}
str_cat(str," ");
- str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
str_free(fstr);
numeric = 1;
break;
case OMPAREN:
str = str_new(0);
str_set(str,"(");
- str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg));
+ str_scat(str,
+ fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
numeric |= numarg;
str_cat(str,")");
break;
case OCONCAT:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_ADD;
+ type = ops[ops[node+1].ival].ival & 255;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+(type != OCONCAT));
str_cat(str," . ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ type = ops[ops[node+2].ival].ival & 255;
+ str_scat(str,
+ fstr=walk(1,level,ops[node+2].ival,&numarg,prec+(type != OCONCAT)));
str_free(fstr);
break;
case OASSIGN:
- str = walk(0,level,ops[node+2].ival,&numarg);
+ prec = P_ASSIGN;
+ str = walk(0,level,ops[node+2].ival,&numarg,prec+1);
str_cat(str," ");
- tmpstr = walk(0,level,ops[node+1].ival,&numarg);
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
str_scat(str,tmpstr);
if (str_len(tmpstr) > 1)
numeric = 1;
str_free(tmpstr);
str_cat(str," ");
- str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec));
str_free(fstr);
numeric |= numarg;
break;
case OADD:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_ADD;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
str_cat(str," + ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
str_free(fstr);
numeric = 1;
break;
- case OSUB:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ case OSUBTRACT:
+ prec = P_ADD;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
str_cat(str," - ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
str_free(fstr);
numeric = 1;
break;
case OMULT:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_MUL;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
str_cat(str," * ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
str_free(fstr);
numeric = 1;
break;
case ODIV:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_MUL;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
str_cat(str," / ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OPOW:
+ prec = P_POW;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
+ str_cat(str," ** ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec));
str_free(fstr);
numeric = 1;
break;
case OMOD:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_MUL;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
str_cat(str," % ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
str_free(fstr);
numeric = 1;
break;
case OPOSTINCR:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_AUTO;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
str_cat(str,"++");
numeric = 1;
break;
case OPOSTDECR:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_AUTO;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
str_cat(str,"--");
numeric = 1;
break;
case OPREINCR:
+ prec = P_AUTO;
str = str_new(0);
str_set(str,"++");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1));
str_free(fstr);
numeric = 1;
break;
case OPREDECR:
+ prec = P_AUTO;
str = str_new(0);
str_set(str,"--");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1));
str_free(fstr);
numeric = 1;
break;
case OUMINUS:
+ prec = P_UNARY;
str = str_new(0);
str_set(str,"-");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec));
str_free(fstr);
numeric = 1;
break;
case OPAREN:
str = str_new(0);
str_set(str,"(");
- str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg));
+ str_scat(str,
+ fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,")");
numeric |= numarg;
break;
case OGETLINE:
str = str_new(0);
- str_set(str,"do Getline()");
- saw_getline = TRUE;
+ if (useval)
+ str_cat(str,"(");
+ if (len > 0) {
+ str_cat(str,"$");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ if (!*fstr->str_ptr) {
+ str_cat(str,"_");
+ len = 2; /* a legal fiction */
+ }
+ str_free(fstr);
+ }
+ else
+ str_cat(str,"$_");
+ if (len > 1) {
+ tmpstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN);
+ fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ if (!do_fancy_opens) {
+ t = tmpstr->str_ptr;
+ if (*t == '"' || *t == '\'')
+ t = cpytill(tokenbuf,t+1,*t);
+ else
+ fatal("Internal error: OGETLINE %s", t);
+ d = savestr(t);
+ s = savestr(tokenbuf);
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (!isalpha(*t) && !isdigit(*t))
+ *t = '_';
+ }
+ if (!index(tokenbuf,'_'))
+ strcpy(t,"_fh");
+ tmp3str = hfetch(symtab,tokenbuf);
+ if (!tmp3str) {
+ do_opens = TRUE;
+ str_cat(opens,"open(");
+ str_cat(opens,tokenbuf);
+ str_cat(opens,", ");
+ d[1] = '\0';
+ str_cat(opens,d);
+ str_cat(opens,tmpstr->str_ptr+1);
+ opens->str_cur--;
+ if (*fstr->str_ptr == '|')
+ str_cat(opens,"|");
+ str_cat(opens,d);
+ if (*fstr->str_ptr == '|')
+ str_cat(opens,") || die 'Cannot pipe from \"");
+ else
+ str_cat(opens,") || die 'Cannot open file \"");
+ if (*d == '"')
+ str_cat(opens,"'.\"");
+ str_cat(opens,s);
+ if (*d == '"')
+ str_cat(opens,"\".'");
+ str_cat(opens,"\".';\n");
+ hstore(symtab,tokenbuf,str_make("x"));
+ }
+ safefree(s);
+ safefree(d);
+ str_set(tmpstr,"'");
+ str_cat(tmpstr,tokenbuf);
+ str_cat(tmpstr,"'");
+ }
+ if (*fstr->str_ptr == '|')
+ str_cat(tmpstr,", '|'");
+ str_free(fstr);
+ }
+ else
+ tmpstr = str_make("");
+ sprintf(tokenbuf," = &Getline%d(%s)",len,tmpstr->str_ptr);
+ str_cat(str,tokenbuf);
+ str_free(tmpstr);
+ if (useval)
+ str_cat(str,",$getline_ok)");
+ saw_getline |= 1 << len;
break;
case OSPRINTF:
str = str_new(0);
str_set(str,"sprintf(");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,")");
break;
case OSUBSTR:
str = str_new(0);
str_set(str,"substr(");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1));
str_free(fstr);
str_cat(str,", ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_COMMA+1));
str_free(fstr);
str_cat(str,", ");
if (len == 3) {
- str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_COMMA+1));
str_free(fstr);
}
else
case OSPLIT:
str = str_new(0);
numeric = 1;
- tmpstr = walk(1,level,ops[node+2].ival,&numarg);
+ tmpstr = walk(1,level,ops[node+2].ival,&numarg,P_MIN);
if (useval)
str_set(str,"(@");
else
str_scat(str,tmpstr);
str_cat(str," = split(");
if (len == 3) {
- fstr = walk(1,level,ops[node+3].ival,&numarg);
+ fstr = walk(1,level,ops[node+3].ival,&numarg,P_COMMA+1);
if (str_len(fstr) == 3 && *fstr->str_ptr == '\'') {
i = fstr->str_ptr[1] & 127;
if (index("*+?.[]()|^$\\",i))
else
str_cat(str,"' '");
str_cat(str,", ");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1));
str_free(fstr);
- str_cat(str,")");
+ str_cat(str,", 999)");
if (useval) {
str_cat(str,")");
}
case OINDEX:
str = str_new(0);
str_set(str,"index(");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1));
str_free(fstr);
str_cat(str,", ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_COMMA+1));
str_free(fstr);
str_cat(str,")");
numeric = 1;
break;
+ case OMATCH:
+ str = str_new(0);
+ prec = P_ANDAND;
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MATCH+1));
+ str_free(fstr);
+ str_cat(str," =~ ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MATCH+1));
+ str_free(fstr);
+ str_cat(str," && ($RLENGTH = length($&), $RSTART = length($`)+1)");
+ numeric = 1;
+ break;
+ case OUSERDEF:
+ str = str_new(0);
+ subretnum = FALSE;
+ fstr=walk(1,level-1,ops[node+2].ival,&numarg,P_MIN);
+ curargs = str_new(0);
+ str_sset(curargs,fstr);
+ str_cat(curargs,",");
+ tmp2str=walk(1,level,ops[node+5].ival,&numarg,P_MIN);
+ str_free(curargs);
+ curargs = Nullstr;
+ level--;
+ subretnum |= numarg;
+ s = Nullch;
+ t = tmp2str->str_ptr;
+ while (t = instr(t,"return "))
+ s = t++;
+ if (s) {
+ i = 0;
+ for (t = s+7; *t; t++) {
+ if (*t == ';' || *t == '}')
+ i++;
+ }
+ if (i == 1) {
+ strcpy(s,s+7);
+ tmp2str->str_cur -= 7;
+ }
+ }
+ str_set(str,"\n");
+ tab(str,level);
+ str_cat(str,"sub ");
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_cat(str," {\n");
+ tab(str,++level);
+ if (fstr->str_cur) {
+ str_cat(str,"local(");
+ str_scat(str,fstr);
+ str_cat(str,") = @_;");
+ }
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ fixtab(str,level);
+ str_scat(str,fstr=walk(1,level,ops[node+4].ival,&numarg,P_MIN));
+ str_free(fstr);
+ fixtab(str,level);
+ str_scat(str,tmp2str);
+ str_free(tmp2str);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ tab(str,level);
+ str_scat(subs,str);
+ str_set(str,"");
+ str_cat(tmpstr,"(");
+ tmp2str = str_new(0);
+ if (subretnum)
+ str_set(tmp2str,"1");
+ hstore(symtab,tmpstr->str_ptr,tmp2str);
+ str_free(tmpstr);
+ level++;
+ break;
+ case ORETURN:
+ str = str_new(0);
+ if (len > 0) {
+ str_cat(str,"return ");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_UNI+1));
+ str_free(fstr);
+ if (numarg)
+ subretnum = TRUE;
+ }
+ else
+ str_cat(str,"return");
+ break;
+ case OUSERFUN:
+ str = str_new(0);
+ str_set(str,"&");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,"(");
+ tmpstr = hfetch(symtab,str->str_ptr+3);
+ if (tmpstr && tmpstr->str_ptr)
+ numeric |= atoi(tmpstr->str_ptr);
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,")");
+ break;
+ case OGSUB:
+ case OSUB:
+ if (type == OGSUB)
+ s = "g";
+ else
+ s = "";
+ str = str_new(0);
+ tmpstr = str_new(0);
+ i = 0;
+ if (len == 3) {
+ tmpstr = walk(1,level,ops[node+3].ival,&numarg,P_MATCH+1);
+ if (strNE(tmpstr->str_ptr,"$_")) {
+ str_cat(tmpstr, " =~ s");
+ i++;
+ }
+ else
+ str_set(tmpstr, "s");
+ }
+ else
+ str_set(tmpstr, "s");
+ type = ops[ops[node+2].ival].ival;
+ len = type >> 8;
+ type &= 255;
+ tmp3str = str_new(0);
+ if (type == OSTR) {
+ tmp2str=walk(1,level,ops[ops[node+2].ival+1].ival,&numarg,P_MIN);
+ for (t = tmp2str->str_ptr, d=tokenbuf; *t; d++,t++) {
+ if (*t == '&')
+ *d++ = '$' + 128;
+ else if (*t == '$')
+ *d++ = '\\' + 128;
+ *d = *t + 128;
+ }
+ *d = '\0';
+ str_set(tmp2str,tokenbuf);
+ }
+ else {
+ tmp2str=walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ str_set(tmp3str,"($s_ = '\"'.(");
+ str_scat(tmp3str,tmp2str);
+ str_cat(tmp3str,").'\"') =~ s/&/\\$&/g, ");
+ str_set(tmp2str,"eval $s_");
+ s = (*s == 'g' ? "ge" : "e");
+ i++;
+ }
+ type = ops[ops[node+1].ival].ival;
+ len = type >> 8;
+ type &= 255;
+ fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ if (type == OREGEX) {
+ if (useval && i)
+ str_cat(str,"(");
+ str_scat(str,tmp3str);
+ str_scat(str,tmpstr);
+ str_scat(str,fstr);
+ str_scat(str,tmp2str);
+ str_cat(str,"/");
+ str_cat(str,s);
+ }
+ else if ((type == OFLD && !split_to_array) || (type == OVAR && len == 1)) {
+ if (useval && i)
+ str_cat(str,"(");
+ str_scat(str,tmp3str);
+ str_scat(str,tmpstr);
+ str_cat(str,"/");
+ str_scat(str,fstr);
+ str_cat(str,"/");
+ str_scat(str,tmp2str);
+ str_cat(str,"/");
+ str_cat(str,s);
+ }
+ else {
+ i++;
+ if (useval)
+ str_cat(str,"(");
+ str_cat(str,"$s = ");
+ str_scat(str,fstr);
+ str_cat(str,", ");
+ str_scat(str,tmp3str);
+ str_scat(str,tmpstr);
+ str_cat(str,"/$s/");
+ str_scat(str,tmp2str);
+ str_cat(str,"/");
+ str_cat(str,s);
+ }
+ if (useval && i)
+ str_cat(str,")");
+ str_free(fstr);
+ str_free(tmpstr);
+ str_free(tmp2str);
+ str_free(tmp3str);
+ numeric = 1;
+ break;
case ONUM:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ str = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
numeric = 1;
break;
case OSTR:
- tmpstr = walk(1,level,ops[node+1].ival,&numarg);
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
s = "'";
for (t = tmpstr->str_ptr, d=tokenbuf; *t; d++,t++) {
if (*t == '\'')
str_free(tmpstr);
str_cat(str,s);
break;
+ case ODEFINED:
+ prec = P_UNI;
+ str = str_new(0);
+ str_set(str,"defined $");
+ goto addvar;
+ case ODELETE:
+ str = str_new(0);
+ str_set(str,"delete $");
+ goto addvar;
+ case OSTAR:
+ str = str_new(0);
+ str_set(str,"*");
+ goto addvar;
case OVAR:
str = str_new(0);
str_set(str,"$");
- str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg));
+ addvar:
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
if (len == 1) {
tmp2str = hfetch(symtab,tmpstr->str_ptr);
if (tmp2str && atoi(tmp2str->str_ptr))
numeric = 2;
- if (strEQ(str->str_ptr,"$NR")) {
+ if (strEQ(str->str_ptr,"$FNR")) {
+ numeric = 1;
+ saw_FNR++;
+ str_set(str,"($.-$FNRbase)");
+ }
+ else if (strEQ(str->str_ptr,"$NR")) {
numeric = 1;
str_set(str,"$.");
}
}
else if (strEQ(str->str_ptr,"$0"))
str_set(str,"$_");
+ else if (strEQ(str->str_ptr,"$ARGC"))
+ str_set(str,"($#ARGV+1)");
}
else {
+#ifdef NOTDEF
+ if (curargs) {
+ sprintf(tokenbuf,"$%s,",tmpstr->str_ptr);
+ ??? if (instr(curargs->str_ptr,tokenbuf))
+ str_cat(str,"\377"); /* can't translate yet */
+ }
+#endif
str_cat(tmpstr,"[]");
tmp2str = hfetch(symtab,tmpstr->str_ptr);
if (tmp2str && atoi(tmp2str->str_ptr))
str_cat(str,"[");
else
str_cat(str,"{");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN));
str_free(fstr);
- if (tmp2str && atoi(tmp2str->str_ptr))
- strcpy(tokenbuf,"]");
- else
- strcpy(tokenbuf,"}");
- *tokenbuf += 128;
- str_cat(str,tokenbuf);
+ if (strEQ(str->str_ptr,"$ARGV[0")) {
+ str_set(str,"$ARGV0");
+ saw_argv0++;
+ }
+ else {
+ if (tmp2str && atoi(tmp2str->str_ptr))
+ strcpy(tokenbuf,"]");
+ else
+ strcpy(tokenbuf,"}");
+ *tokenbuf += 128;
+ str_cat(str,tokenbuf);
+ }
}
str_free(tmpstr);
break;
if (split_to_array) {
str_set(str,"$Fld");
str_cat(str,"[");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,"]");
}
else {
- i = atoi(walk(1,level,ops[node+1].ival,&numarg)->str_ptr);
+ i = atoi(walk(1,level,ops[node+1].ival,&numarg,P_MIN)->str_ptr);
if (i <= arymax)
sprintf(tokenbuf,"$%s",nameary[i]);
else
i = ops[node+1].ival;
if ((ops[i].ival & 255) == OPAREN)
i = ops[i+1].ival;
- tmpstr=walk(1,level,i,&numarg);
+ tmpstr=walk(1,level,i,&numarg,P_MIN);
str_scat(str,tmpstr);
str_free(tmpstr);
str_cat(str,"]");
case OSCOMMENT:
str = str_new(0);
str_set(str,";");
- tmpstr = walk(0,level,ops[node+1].ival,&numarg);
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
for (s = tmpstr->str_ptr; *s && *s != '\n'; s++)
*s += 128;
str_scat(str,tmpstr);
break;
case OCOMMENT:
str = str_new(0);
- tmpstr = walk(0,level,ops[node+1].ival,&numarg);
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
for (s = tmpstr->str_ptr; *s && *s != '\n'; s++)
*s += 128;
str_scat(str,tmpstr);
tab(str,level);
break;
case OCOMMA:
- str = walk(1,level,ops[node+1].ival,&numarg);
+ prec = P_COMMA;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
str_cat(str,", ");
- str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
str_free(fstr);
break;
case OSEMICOLON:
str = str_new(1);
- str_set(str,"; ");
+ str_set(str,";\n");
+ tab(str,level);
break;
case OSTATES:
- str = walk(0,level,ops[node+1].ival,&numarg);
- str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
str_free(fstr);
break;
case OSTATE:
str = str_new(0);
if (len >= 1) {
- str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
if (len >= 2) {
- tmpstr = walk(0,level,ops[node+2].ival,&numarg);
+ tmpstr = walk(0,level,ops[node+2].ival,&numarg,P_MIN);
if (*tmpstr->str_ptr == ';') {
addsemi(str);
str_cat(str,tmpstr->str_ptr+1);
}
}
break;
+ case OCLOSE:
+ str = str_make("close(");
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ if (!do_fancy_opens) {
+ t = tmpstr->str_ptr;
+ if (*t == '"' || *t == '\'')
+ t = cpytill(tokenbuf,t+1,*t);
+ else
+ fatal("Internal error: OCLOSE %s",t);
+ s = savestr(tokenbuf);
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (!isalpha(*t) && !isdigit(*t))
+ *t = '_';
+ }
+ if (!index(tokenbuf,'_'))
+ strcpy(t,"_fh");
+ str_free(tmpstr);
+ safefree(s);
+ str_set(str,"close ");
+ str_cat(str,tokenbuf);
+ }
+ else {
+ sprintf(tokenbuf,"$fh = delete $opened{%s} && close($fh)",
+ tmpstr->str_ptr);
+ str_free(tmpstr);
+ str_set(str,tokenbuf);
+ }
+ break;
case OPRINTF:
case OPRINT:
lparen = ""; /* set to parens if necessary */
rparen = "";
str = str_new(0);
if (len == 3) { /* output redirection */
- tmpstr = walk(1,level,ops[node+3].ival,&numarg);
- tmp2str = walk(1,level,ops[node+2].ival,&numarg);
+ tmpstr = walk(1,level,ops[node+3].ival,&numarg,P_MIN);
+ tmp2str = walk(1,level,ops[node+2].ival,&numarg,P_MIN);
if (!do_fancy_opens) {
t = tmpstr->str_ptr;
if (*t == '"' || *t == '\'')
}
if (!index(tokenbuf,'_'))
strcpy(t,"_fh");
- str_cat(opens,"open(");
- str_cat(opens,tokenbuf);
- str_cat(opens,", ");
- d[1] = '\0';
- str_cat(opens,d);
- str_scat(opens,tmp2str);
- str_cat(opens,tmpstr->str_ptr+1);
- if (*tmp2str->str_ptr == '|')
- str_cat(opens,") || die 'Cannot pipe to \"");
- else
- str_cat(opens,") || die 'Cannot create file \"");
- if (*d == '"')
- str_cat(opens,"'.\"");
- str_cat(opens,s);
- if (*d == '"')
- str_cat(opens,"\".'");
- str_cat(opens,"\".';\n");
+ tmp3str = hfetch(symtab,tokenbuf);
+ if (!tmp3str) {
+ str_cat(opens,"open(");
+ str_cat(opens,tokenbuf);
+ str_cat(opens,", ");
+ d[1] = '\0';
+ str_cat(opens,d);
+ str_scat(opens,tmp2str);
+ str_cat(opens,tmpstr->str_ptr+1);
+ if (*tmp2str->str_ptr == '|')
+ str_cat(opens,") || die 'Cannot pipe to \"");
+ else
+ str_cat(opens,") || die 'Cannot create file \"");
+ if (*d == '"')
+ str_cat(opens,"'.\"");
+ str_cat(opens,s);
+ if (*d == '"')
+ str_cat(opens,"\".'");
+ str_cat(opens,"\".';\n");
+ hstore(symtab,tokenbuf,str_make("x"));
+ }
str_free(tmpstr);
str_free(tmp2str);
safefree(s);
safefree(d);
}
else {
- sprintf(tokenbuf,"do Pick('%s' . (%s)) &&\n",
+ sprintf(tokenbuf,"&Pick('%s', %s) &&\n",
tmp2str->str_ptr, tmpstr->str_ptr);
str_cat(str,tokenbuf);
tab(str,level+1);
- *tokenbuf = '\0';
+ strcpy(tokenbuf,"$fh");
str_free(tmpstr);
str_free(tmp2str);
lparen = "(";
}
}
else
- strcpy(tokenbuf,"stdout");
+ strcpy(tokenbuf,"");
str_cat(str,lparen); /* may be null */
if (type == OPRINTF)
str_cat(str,"printf");
str_cat(str," ");
str_cat(str,tokenbuf);
}
- tmpstr = walk(1+(type==OPRINT),level,ops[node+1].ival,&numarg);
+ tmpstr = walk(1+(type==OPRINT),level,ops[node+1].ival,&numarg,P_MIN);
if (!*tmpstr->str_ptr && lval_field) {
t = saw_OFS ? "$," : "' '";
if (split_to_array) {
str_cat(str,rparen); /* may be null */
str_free(tmpstr);
break;
+ case ORAND:
+ str = str_make("rand(1)");
+ break;
+ case OSRAND:
+ str = str_make("srand(");
+ goto maybe0;
+ case OATAN2:
+ str = str_make("atan2(");
+ goto maybe0;
+ case OSIN:
+ str = str_make("sin(");
+ goto maybe0;
+ case OCOS:
+ str = str_make("cos(");
+ goto maybe0;
+ case OSYSTEM:
+ str = str_make("system(");
+ goto maybe0;
case OLENGTH:
str = str_make("length(");
goto maybe0;
maybe0:
numeric = 1;
if (len > 0)
- tmpstr = walk(1,level,ops[node+1].ival,&numarg);
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
else
tmpstr = str_new(0);;
if (!*tmpstr->str_ptr) {
case OEXIT:
str = str_new(0);
if (realexit) {
+ prec = P_UNI;
str_set(str,"exit");
if (len == 1) {
str_cat(str," ");
exitval = TRUE;
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,
+ fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1));
str_free(fstr);
}
}
if (len == 1) {
str_set(str,"ExitValue = ");
exitval = TRUE;
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,
+ fstr=walk(1,level,ops[node+1].ival,&numarg,P_ASSIGN));
str_free(fstr);
str_cat(str,"; ");
}
case OIF:
str = str_new(0);
str_set(str,"if (");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,") ");
- str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
str_free(fstr);
if (len == 3) {
i = ops[node+3].ival;
}
if (i) {
str_cat(str,"els");
- str_scat(str,fstr=walk(0,level,i,&numarg));
+ str_scat(str,fstr=walk(0,level,i,&numarg,P_MIN));
str_free(fstr);
}
else {
str_cat(str,"else ");
- str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN));
str_free(fstr);
}
}
case OWHILE:
str = str_new(0);
str_set(str,"while (");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,") ");
- str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
str_free(fstr);
break;
case OFOR:
str = str_new(0);
str_set(str,"for (");
- str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg));
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
i = numarg;
if (i) {
t = s = tmpstr->str_ptr;
i = 0;
}
str_cat(str,"; ");
- fstr=walk(1,level,ops[node+2].ival,&numarg);
+ fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN);
if (i && (t = index(fstr->str_ptr,0377))) {
if (strnEQ(fstr->str_ptr,s,i))
*t = ' ';
str_free(fstr);
str_free(tmpstr);
str_cat(str,"; ");
- str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg));
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN));
str_free(fstr);
str_cat(str,") ");
- str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg,P_MIN));
str_free(fstr);
break;
case OFORIN:
- tmpstr=walk(0,level,ops[node+2].ival,&numarg);
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ d = index(tmpstr->str_ptr,'$');
+ if (!d)
+ fatal("Illegal for loop: %s",tmpstr->str_ptr);
+ s = index(d,'{');
+ if (!s)
+ s = index(d,'[');
+ if (!s)
+ fatal("Illegal for loop: %s",d);
+ *s++ = '\0';
+ t = index(s,'}' + 128);
+ if (!t)
+ t = index(s,']' + 128);
+ if (t)
+ *t = '\0';
str = str_new(0);
- str_sset(str,tmpstr);
+ str_set(str,d+1);
str_cat(str,"[]");
tmp2str = hfetch(symtab,str->str_ptr);
if (tmp2str && atoi(tmp2str->str_ptr)) {
- fstr=walk(1,level,ops[node+1].ival,&numarg);
sprintf(tokenbuf,
- "foreach $%s (@%s) ",
- fstr->str_ptr,
- tmpstr->str_ptr);
- str_set(str,tokenbuf);
- str_free(fstr);
- str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
- str_free(fstr);
+ "foreach %s (@%s) ",
+ s,
+ d+1);
}
else {
- str_set(str,"while (($");
- str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg));
- str_free(fstr);
- str_cat(str,",$junkval) = each(");
- str_scat(str,tmpstr);
- str_cat(str,")) ");
- str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
- str_free(fstr);
+ sprintf(tokenbuf,
+ "foreach %s (keys %%%s) ",
+ s,
+ d+1);
}
+ str_set(str,tokenbuf);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
str_free(tmpstr);
break;
case OBLOCK:
str = str_new(0);
str_set(str,"{");
if (len >= 2 && ops[node+2].ival) {
- str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
str_free(fstr);
}
fixtab(str,++level);
- str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN));
str_free(fstr);
addsemi(str);
fixtab(str,--level);
str_cat(str,"}\n");
tab(str,level);
if (len >= 3) {
- str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN));
str_free(fstr);
}
break;
if (len) {
if (len > 5)
fatal("Garbage length in walk");
- str = walk(0,level,ops[node+1].ival,&numarg);
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
for (i = 2; i<= len; i++) {
- str_scat(str,fstr=walk(0,level,ops[node+i].ival,&numarg));
+ str_scat(str,fstr=walk(0,level,ops[node+i].ival,&numarg,P_MIN));
str_free(fstr);
}
}
}
if (!str)
str = str_new(0);
+
+ if (useval && prec < minprec) { /* need parens? */
+ fstr = str_new(str->str_cur+2);
+ str_nset(fstr,"(",1);
+ str_scat(fstr,str);
+ str_ncat(fstr,")",1);
+ str_free(str);
+ str = fstr;
+ }
+
*numericptr = numeric;
#ifdef DEBUGGING
if (debug & 4) {
/* strip trailing white space */
s = str->str_ptr+str->str_cur - 1;
- while (s >= str->str_ptr && (*s == ' ' || *s == '\t'))
+ while (s >= str->str_ptr && (*s == ' ' || *s == '\t' || *s == '\n'))
s--;
s[1] = '\0';
str->str_cur = s + 1 - str->str_ptr;
str_cat(str,tokenbuf);
}
if (const_FS) {
- sprintf(tokenbuf," = split(/[%c\\n]/);\n",const_FS);
+ sprintf(tokenbuf," = split(/[%c\\n]/, $_, 999);\n",const_FS);
str_cat(str,tokenbuf);
}
else if (saw_FS)
- str_cat(str," = split($FS);\n");
+ str_cat(str," = split($FS, $_, 999);\n");
else
- str_cat(str," = split(' ');\n");
+ str_cat(str," = split(' ', $_, 999);\n");
tab(str,level);
}
char *d, *s;
int numarg;
int numeric = FALSE;
+ STR *tmpstr;
+ STR *tmp2str;
if (!node) {
*numericptr = 0;
prewalk(1,level,ops[node+2].ival,&numarg);
numeric = 1;
break;
- case OSUB:
+ case OSUBTRACT:
prewalk(1,level,ops[node+1].ival,&numarg);
prewalk(1,level,ops[node+2].ival,&numarg);
numeric = 1;
prewalk(1,level,ops[node+2].ival,&numarg);
numeric = 1;
break;
+ case OPOW:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
case OMOD:
prewalk(1,level,ops[node+1].ival,&numarg);
prewalk(1,level,ops[node+2].ival,&numarg);
prewalk(0,level,ops[node+2].ival,&numarg);
numeric = 1;
break;
+ case OMATCH:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OUSERDEF:
+ subretnum = FALSE;
+ --level;
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ ++level;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+4].ival,&numarg);
+ prewalk(0,level,ops[node+5].ival,&numarg);
+ --level;
+ str_cat(tmpstr,"(");
+ tmp2str = str_new(0);
+ if (subretnum || numarg)
+ str_set(tmp2str,"1");
+ hstore(symtab,tmpstr->str_ptr,tmp2str);
+ str_free(tmpstr);
+ level++;
+ break;
+ case ORETURN:
+ if (len > 0) {
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ if (numarg)
+ subretnum = TRUE;
+ }
+ break;
+ case OUSERFUN:
+ tmp2str = str_new(0);
+ str_scat(tmp2str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ fixrargs(tmpstr->str_ptr,ops[node+2],0);
+ str_free(tmpstr);
+ str_cat(tmp2str,"(");
+ tmpstr = hfetch(symtab,tmp2str->str_ptr);
+ if (tmpstr && tmpstr->str_ptr)
+ numeric |= atoi(tmpstr->str_ptr);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ str_free(tmp2str);
+ break;
+ case OGSUB:
+ case OSUB:
+ if (len >= 3)
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ prewalk(0,level,ops[ops[node+2].ival+1].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
case ONUM:
prewalk(0,level,ops[node+1].ival,&numarg);
numeric = 1;
case OSTR:
prewalk(0,level,ops[node+1].ival,&numarg);
break;
+ case ODEFINED:
+ case ODELETE:
+ case OSTAR:
case OVAR:
prewalk(0,level,ops[node+1].ival,&numarg);
if (len == 1) {
case OCOMMA:
prewalk(0,level,ops[node+1].ival,&numarg);
prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
break;
case OSEMICOLON:
break;
}
}
break;
+ case OCLOSE:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
case OPRINTF:
case OPRINT:
if (len == 3) { /* output redirection */
}
prewalk(0+(type==OPRINT),level,ops[node+1].ival,&numarg);
break;
+ case ORAND:
+ break;
+ case OSRAND:
+ goto maybe0;
+ case OATAN2:
+ goto maybe0;
+ case OSIN:
+ goto maybe0;
+ case OCOS:
+ goto maybe0;
+ case OSYSTEM:
+ goto maybe0;
case OLENGTH:
goto maybe0;
case OLOG:
maybe0:
numeric = 1;
if (len > 0)
- prewalk(type != OLENGTH,level,ops[node+1].ival,&numarg);
+ prewalk(type != OLENGTH && type != OSYSTEM,
+ level,ops[node+1].ival,&numarg);
break;
case OBREAK:
break;
case OFORIN:
prewalk(0,level,ops[node+2].ival,&numarg);
prewalk(0,level,ops[node+1].ival,&numarg);
- prewalk(0,level,ops[node+3].ival,&numarg);
break;
case OBLOCK:
if (len == 2) {
len = type >> 8;
type &= 255;
if (type == OVAR && len == 1) {
- tmpstr=walk(0,0,ops[node+1].ival,&numarg);
+ tmpstr=walk(0,0,ops[node+1].ival,&numarg,P_MIN);
tmp2str = str_make("1");
hstore(symtab,tmpstr->str_ptr,tmp2str);
}
https://perl5.git.perl.org / perl5.git / commitdiff