--- /dev/null
+New regexp routines derived from Henry Spencer's.
+ Support for /(foo|bar)/.
+ Support for /(foo)*/ and /(foo)+/.
+ \s for whitespace, \S nonwhitespace
+ \d for digit, \D nondigit
+
+Local variables in blocks, subroutines and evals.
+
+Recursive subroutine calls are now supported.
+
+Array values may now be interpolated into lists:
+ unlink 'foo', 'bar', @trashcan, 'tmp';
+
+File globbing via <*.foo>.
+
+Use of <> in array contexts returns the whole file or glob list:
+ unlink <*.foo>;
+
+New iterator for normal arrays, foreach, that allows both read and write:
+ foreach $elem ($array) {
+ $elem =~ s/foo/bar/;
+ }
+
+Ability to open pipe to a forked off script for secure pipes in setuid scripts.
+
+File inclusion via
+ do 'foo.pl';
+
+More file tests, including -t to see if, for instance, stdin is
+a terminal. File tests now behave in a more correct manner. You can do
+file tests on filehandles as well as filenames. The special filetests
+-T and -B test a file to see if it's text or binary.
+
+An eof can now be used on each file of the <> input for such purposes
+as resetting the line numbers or appending to each file of an inplace edit.
+
+Assignments can now function as lvalues, so you can say things like
+ ($HOST = $host) =~ tr/a-z/A-Z/;
+ ($obj = $src) =~ s/\.c$/.o/;
+
+You can now do certain file operations with a variable which holds the name
+of a filehandle, e.g. open(++$incl,$includefilename); $foo = <$incl>;
+
+You can now a subroutine indirectly through a scalar variable:
+ $which = 'xyz';
+ do $which('foo'); # calls xyz
+
+Warnings are now available (with -w) on use of uninitialized variables and on
+identifiers that are mentioned only once, and on reference to various
+undefined things.
+
+The -S switch causes perl to search the PATH for the script so that you can say
+ eval "exec /usr/bin/perl -S $0 $*"
+ if $running_under_some_shell;
+
+Reset now resets arrays and associative arrays as well as string variables.
+
+Assigning off the end of an array now nulls out any intervening values.
+
+$#foo is now an lvalue. You can preallocate or truncate arrays, or recover
+values lost to prior truncation.
+
+$#foo is now indexed to $[ properly.
+
+s/foo/bar/i optimization bug fixed.
+
+The $x = "...$x..."; bug is fixed.
+
+The @ary = (1); bug is now fixed. You can even say @ary = 1;
+
+$= now returns the correct value.
+
+Several of the larger files are now split into smaller pieces for easier
+compilation.
+
+Pattern matches evaluated in an array context now return ($1, $2...).
+
+There is now a wait operator.
+
+There is now a sort operator.
+
+The requirement of parens around certain expressions when taking their value
+has been lifted. In particular, you can say
+ $x = print "foo","bar";
+ $x = unlink "foo","bar";
+ chdir "foo" || die "Can't chdir to foo\n";
+
+The manual is now not lying when it says that perl is generally faster than
+sed. I hope.
# and edit it to reflect your system. Some packages may include samples
# of config.h for certain machines, so you might look for one of those.)
#
-# $Header: Configure,v 1.0.1.6 88/02/02 11:20:07 root Exp $
+# $Header: Configure,v 2.0 88/06/05 00:07:37 root Exp $
#
# Yes, you may rip this off to use in other distribution packages.
# (Note: this Configure script was generated automatically. Rather than
# working with this copy of Configure, you may wish to get metaconfig.)
: sanity checks
-PATH='.:/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/local:/usr/lbin:/etc'
+PATH='.:/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/local:/usr/lbin:/etc:/usr/new:/usr/new/bin:/usr/nbin'
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0; kill $$)
if test ! -t 0; then
cd UU
fi
+case "$1" in
+-d) shift; fastread='yes';;
+esac
+
d_eunice=''
eunicefix=''
define=''
vi=''
mailx=''
mail=''
+cpp=''
Log=''
Header=''
bin=''
cc=''
contains=''
-cpp=''
+cppstdin=''
cppminus=''
d_bcopy=''
d_charsprf=''
d_crypt=''
+d_fchmod=''
+d_fchown=''
+d_getgrps=''
d_index=''
+d_killpg=''
+d_memcpy=''
+d_rename=''
+d_setegid=''
+d_seteuid=''
+d_setrgid=''
+d_setruid=''
d_statblks=''
d_stdstdio=''
+d_strcspn=''
d_strctcpy=''
d_symlink=''
d_tminsys=''
d_vfork=''
d_voidsig=''
+gidtype=''
libc=''
libnm=''
mallocsrc=''
sharpbang=''
startsh=''
stdchar=''
+uidtype=''
voidflags=''
defvoidused=''
+privlib=''
CONFIG=''
: set package name
smallmach='pdp11 i8086 z8000 i80286 iAPX286'
rmlist='kit[1-9]isdone kit[1-9][0-9]isdone'
trap 'echo " "; rm -f $rmlist; exit 1' 1 2 3
+
+: We must find out about Eunice early
+eunicefix=':'
+if test -f /etc/unixtovms; then
+ eunicefix=/etc/unixtovms
+fi
+if test -f /etc/unixtovms.exe; then
+ eunicefix=/etc/unixtovms.exe
+fi
+
attrlist="mc68000 sun gcos unix ibm gimpel interdata tss os mert pyr"
attrlist="$attrlist vax pdp11 i8086 z8000 u3b2 u3b5 u3b20 u3b200"
attrlist="$attrlist ns32000 ns16000 iAPX286 mc300 mc500 mc700 sparc"
-pth="/usr/ucb /bin /usr/bin /usr/local /usr/local/bin /usr/lbin /etc /usr/lib"
+attrlist="$attrlist nsc32000 sinix xenix venix posix ansi M_XENIX"
+attrlist="$attrlist $mc68k __STDC__"
+pth="/usr/ucb /bin /usr/bin /usr/local /usr/local/bin /usr/lbin /etc /usr/lib /lib"
+d_newshome="../../NeWS"
defvoidused=7
: some greps do not return status, grrr.
cat >contains <<'EOSS'
grep "$1" "$2" >.greptmp && cat .greptmp && test -s .greptmp
EOSS
-chmod 755 contains
+chmod +x contains
esac
: first determine how to suppress newline on echo command
: now set up to do reads with possible shell escape and default assignment
cat <<EOSC >myread
-ans='!'
+case "\$fastread" in
+yes) ans=''; echo " " ;;
+*) ans='!';;
+esac
while expr "X\$ans" : "X!" >/dev/null; do
read ans
case "\$ans" in
if test -f \$dir/\$thing; then
echo \$dir/\$thing
exit 0
+ elif test -f \$dir/\$thing.exe; then
+ : on Eunice apparently
+ echo \$dir/\$thing
+ exit 0
fi
;;
esac
echo \$dflt
exit 1
EOSC
-chmod 755 loc
+chmod +x loc
$eunicefix loc
loclist="
expr
test
egrep
Mcc
+cpp
"
for file in $loclist; do
xxx=`loc $file $file $pth`
libc=/lib/libc.a
else
ans=`loc libc.a blurfl/dyick $libpth`
+ if test ! -f $ans; then
+ ans=`loc clib blurfl/dyick $libpth`
+ fi
+ if test ! -f $ans; then
+ ans=`loc libc blurfl/dyick $libpth`
+ fi
if test -f $ans; then
echo "Your C library is in $ans, of all places."
libc=$ans
fi
echo " "
$echo $n "Extracting names from $libc for later perusal...$c"
-if ar t $libc > libc.list; then
+nm $libc 2>/dev/null | sed -n -e 's/^.* T _//p' -e 's/^.* T //p' > libc.list
+if $contains '^printf$' libc.list >/dev/null 2>&1; then
echo "done"
else
- echo " "
- echo "The archiver doesn't think $libc is a reasonable library."
- echo "Trying nm instead..."
- if nm -g $libc > libc.list; then
- echo "Done. Maybe this is Unicos, or an Apollo?"
+ nm $libc 2>/dev/null | sed -n -e 's/^.* D _//p' -e 's/^.* D //p' > libc.list
+ if $contains '^printf$' libc.list >/dev/null 2>&1; then
+ echo "done"
else
- echo "That didn't work either. Giving up."
- exit 1
+ echo " "
+ echo "nm didn't seem to work right."
+ echo "Trying ar instead..."
+ if ar t $libc | sed -e 's/\.o$//' > libc.list; then
+ echo "Ok."
+ else
+ echo "That didn't work either. Giving up."
+ exit 1
+ fi
fi
fi
rmlist="$rmlist libc.list"
echo exit 0 >bsd
echo exit 1 >usg
echo exit 1 >v7
-elif $contains fcntl libc.list >/dev/null 2>&1 ; then
+elif $contains '^fcntl$' libc.list >/dev/null 2>&1 ; then
echo "Looks kind of like a USG system, but we'll see..."
echo exit 1 >bsd
echo exit 0 >usg
echo exit 1 >usg
echo exit 0 >v7
fi
-if $contains vmssystem libc.list >/dev/null 2>&1 ; then
+if $contains '^vmssystem$' libc.list >/dev/null 2>&1 ; then
cat <<'EOI'
There is, however, a strange, musty smell in the air that reminds me of
something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit.
echo "It's not Xenix..."
echo "exit 1" >xenix
fi
-chmod 755 xenix
+chmod +x xenix
+$eunicefix xenix
if test -f /venix; then
echo "Actually, this looks more like a VENIX system..."
echo "exit 0" >venix
fi
echo "exit 1" >venix
fi
-chmod 755 bsd usg v7 eunice venix xenix
-$eunicefix bsd usg v7 eunice venix xenix
+chmod +x bsd usg v7 eunice venix
+$eunicefix bsd usg v7 eunice venix
rmlist="$rmlist bsd usg v7 eunice venix xenix"
: see if sh knows # comments
echo "Okay, let's see if #! works on this system..."
echo "#!/bin/echo hi" > try
$eunicefix try
- chmod 755 try
+ chmod +x try
try > today
- if test -s today; then
+ if $contains hi today >/dev/null 2>&1; then
echo "It does."
sharpbang='#!'
else
echo "#! /bin/echo hi" > try
$eunicefix try
- chmod 755 try
+ chmod +x try
try > today
if test -s today; then
echo "It does."
echo "Your sh doesn't grok # comments--I will strip them later on."
shsharp=false
echo "exec grep -v '^#'" >spitshell
- chmod 755 spitshell
+ chmod +x spitshell
$eunicefix spitshell
spitshell=`pwd`/spitshell
echo "I presume that if # doesn't work, #! won't work either!"
test "$?abc" != 1
EOSS
-chmod 755 try
+chmod +x try
$eunicefix try
if try; then
echo "Yup, it does."
#define XYZ xyz
ABC.XYZ
EOT
-echo 'Maybe "/lib/cpp" will work...'
-/lib/cpp <testcpp.c >testcpp.out 2>&1
+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."
- cpp='/lib/cpp'
+ cppstdin="$cpp"
cppminus='';
else
- echo 'Nope, maybe "/lib/cpp -" will work...'
- /lib/cpp - <testcpp.c >testcpp.out 2>&1
+ 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."
- cpp='/lib/cpp'
+ cppstdin="$cpp"
cppminus='-';
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!"
- cpp='cc -E'
+ 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."
- cpp='cc -E'
+ 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."
- cpp='cc -P'
+ 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."
- cpp='cc -P'
+ cppstdin='cc -P'
cppminus='-';
else
echo 'Hmm...perhaps you already told me...'
- case "$cpp" in
+ case "$cppstdin" in
'') ;;
- *) $cpp $cppminus <testcpp.c >testcpp.out 2>&1;;
+ *) $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)'
- cpp='(cat >/tmp/$$.c; cc -E /tmp/$$.c; rm /tmp/$$.c)'
+ cppstdin='(cat >/tmp/$$.c; cc -E /tmp/$$.c; rm /tmp/$$.c)'
cppminus='';
- $cpp <testcpp.c >testcpp.out 2>&1
+ $cppstdin <testcpp.c >testcpp.out 2>&1
if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
echo "Eureka!."
else
$echo $n "No dice. I can't find a C preprocessor. Name one: $c"
rp='Name a C preprocessor:'
. myread
- cpp="$ans"
- $cpp <testcpp.c >testcpp.out 2>&1
+ 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
: see if bcopy exists
echo " "
-if $contains bcopy libc.list >/dev/null 2>&1; then
+if $contains '^bcopy$' libc.list >/dev/null 2>&1; then
echo 'bcopy() found.'
d_bcopy="$define"
else
: see if sprintf is declared as int or pointer to char
echo " "
-if $contains 'char.*sprintf' /usr/include/stdio.h >/dev/null 2>&1 ; then
- echo "Your sprintf() returns (char*)."
- d_charsprf="$define"
-else
+cat >.ucbsprf.c <<'EOF'
+main() { char buf[10]; exit((unsigned long)sprintf(buf,"%s","foo") > 10L); }
+EOF
+if cc .ucbsprf.c -o .ucbsprf >/dev/null 2>&1 && .ucbsprf; then
echo "Your sprintf() returns (int)."
d_charsprf="$undef"
+else
+ echo "Your sprintf() returns (char*)."
+ d_charsprf="$define"
fi
+/bin/rm -f .ucbsprf.c .ucbsprf
: see if crypt exists
echo " "
-if $contains crypt libc.list >/dev/null 2>&1; then
+if $contains '^crypt$' libc.list >/dev/null 2>&1; then
echo 'crypt() found.'
d_crypt="$define"
else
d_crypt="$undef"
fi
+: 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 " "
-dflt=y
-if $contains index libc.list >/dev/null 2>&1 ; then
- echo "Your system appears to use index() and rindex() rather than strchr()"
- $echo $n "and strrchr(). Is this correct? [$dflt] $c"
- rp='index() rather than strchr()? [$dflt]'
- . myread
- case "$ans" in
- n*|f*) d_index="$define" ;;
- *) d_index="$undef" ;;
- esac
+case "$d_index" in
+n) dflt=n;;
+*) dflt=y;;
+esac
+if $contains '^index$' libc.list >/dev/null 2>&1 ; then
+ if $contains '^strchr$' libc.list >/dev/null 2>&1 ; then
+ echo "Your system has both index() and strchr(). Shall I use"
+ rp="index() rather than strchr()? [$dflt]"
+ $echo $n "$rp $c"
+ . myread
+ case "$ans" in
+ n*) d_index="$define" ;;
+ *) d_index="$undef" ;;
+ esac
+ else
+ d_index="$undef"
+ echo "index() found."
+ fi
else
- echo "Your system appears to use strchr() and strrchr() rather than index()"
- $echo $n "and rindex(). Is this correct? [$dflt] $c"
- rp='strchr() rather than index()? [$dflt]'
- . myread
- case "$ans" in
- n*|f*) d_index="$undef" ;;
- *) d_index="$define" ;;
- esac
+ if $contains '^strchr$' libc.list >/dev/null 2>&1 ; then
+ d_index="$define"
+ echo "strchr() found."
+ else
+ echo "No index() or strchr() found!"
+ d_index="$undef"
+ fi
+fi
+
+: see if killpg exists
+echo " "
+if $contains '^killpg$' libc.list >/dev/null 2>&1; then
+ echo 'killpg() found.'
+ d_killpg="$define"
+else
+ echo 'killpg() not found.'
+ d_killpg="$undef"
+fi
+
+: see if memcpy exists
+echo " "
+if $contains '^memcpy$' libc.list >/dev/null 2>&1; then
+ echo 'memcpy() found.'
+ d_memcpy="$define"
+else
+ echo 'memcpy() not found.'
+ d_memcpy="$undef"
+fi
+
+: see if rename exists
+echo " "
+if $contains '^rename$' libc.list >/dev/null 2>&1; then
+ echo 'rename() found.'
+ d_rename="$define"
+else
+ echo 'rename() not found.'
+ d_rename="$undef"
+fi
+
+: see if setegid exists
+echo " "
+if $contains '^setegid$' libc.list >/dev/null 2>&1; then
+ echo 'setegid() found.'
+ d_setegid="$define"
+else
+ echo 'setegid() not found.'
+ d_setegid="$undef"
+fi
+
+: see if seteuid exists
+echo " "
+if $contains '^seteuid$' libc.list >/dev/null 2>&1; then
+ echo 'seteuid() found.'
+ d_seteuid="$define"
+else
+ echo 'seteuid() not found.'
+ d_seteuid="$undef"
+fi
+
+: see if setrgid exists
+echo " "
+if $contains '^setrgid$' libc.list >/dev/null 2>&1; then
+ echo 'setrgid() found.'
+ d_setrgid="$define"
+else
+ echo 'setrgid() not found.'
+ d_setrgid="$undef"
+fi
+
+: see if setruid exists
+echo " "
+if $contains '^setruid$' libc.list >/dev/null 2>&1; then
+ echo 'setruid() found.'
+ d_setruid="$define"
+else
+ echo 'setruid() not found.'
+ d_setruid="$undef"
fi
: see if stat knows about block sizes
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..."
fi
$rm -f try.*
+: see if symlink exists
+echo " "
+if $contains '^symlink$' libc.list >/dev/null 2>&1; then
+ echo 'symlink() found.'
+ d_symlink="$define"
+else
+ echo 'symlink() not found.'
+ d_symlink="$undef"
+fi
+
: see if struct tm is defined in sys/time.h
echo " "
if $contains 'struct tm' /usr/include/time.h >/dev/null 2>&1 ; then
: see if there is a vfork
echo " "
-if $contains vfork libc.list >/dev/null 2>&1 ; then
+if $contains '^vfork$' libc.list >/dev/null 2>&1 ; then
echo "vfork() found."
d_vfork="$undef"
else
main() {
#endif
extern void *moo();
- void (*goo)();
+ void *(*goo)();
#if TRY & 2
void (*foo[10])();
#endif
#if TRY & 4
- if(goo == moo) {
+ if(*goo == moo) {
exit(0);
}
#endif
voidflags="$ans"
$rm -f try.* .out
-: see what type of char stdio uses.
+: see what type gids are declared as in the kernel
+case "$gidtype" in
+'')
+ if $contains 'gid_t;' /usr/include/sys/types.h >/dev/null 2>&1 ; then
+ dflt='gid_t';
+ else
+ set `grep 'groups\[NGROUPS\];' /usr/include/sys/user.h 2>/dev/null` unsigned short
+ case $1 in
+ unsigned) dflt="$1 $2" ;;
+ *) dflt="$1" ;;
+ esac
+ fi
+ ;;
+*) dflt="$gidtype"
+ ;;
+esac
+cont=true
echo " "
-if $contains 'unsigned.*char.*_ptr;' /usr/include/stdio.h >/dev/null 2>&1 ; then
- echo "Your stdio uses unsigned chars."
- stdchar="unsigned char"
-else
- echo "Your stdio uses signed chars."
- stdchar="char"
-fi
-
-: preserve RCS keywords in files with variable substitution, grrr
-Log='$Log'
-Header='$Header'
+rp="What type are group ids on this system declared as? [$dflt]"
+$echo $n "$rp $c"
+. myread
+gidtype="$ans"
: set up shell script to do ~ expansion
cat >filexp <<EOSS
;;
esac
EOSS
-chmod 755 filexp
+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
+
+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 what type of char stdio uses.
+echo " "
+if $contains 'unsigned.*char.*_ptr;' /usr/include/stdio.h >/dev/null 2>&1 ; then
+ echo "Your stdio uses unsigned chars."
+ stdchar="unsigned char"
+else
+ echo "Your stdio uses signed chars."
+ stdchar="char"
+fi
+
+: see what type uids are declared as in the kernel
+case "$uidtype" in
+'')
+ if $contains 'uid_t;' /usr/include/sys/types.h >/dev/null 2>&1 ; then
+ dflt='uid_t';
+ else
+ set `grep '_ruid;' /usr/include/sys/user.h 2>/dev/null` unsigned short
+ case $1 in
+ unsigned) dflt="$1 $2" ;;
+ *) dflt="$1" ;;
+ esac
+ fi
+ ;;
+*) dflt="$uidtype"
+ ;;
+esac
+cont=true
+echo " "
+rp="What type are user ids on this system declared as? [$dflt]"
+$echo $n "$rp $c"
+. myread
+uidtype="$ans"
+
+: preserve RCS keywords in files with variable substitution, grrr
+Log='$Log'
+Header='$Header'
+
: determine where public executables go
case "$bin" in
'')
*n)
manext=n
;;
+*C)
+ manext=C
+ ;;
*)
manext=1
;;
#endif\\
/' >/tmp/Cppsym\$\$
echo exit 1 >>/tmp/Cppsym\$\$
-$cpp $cppminus </tmp/Cppsym\$\$ >/tmp/Cppsym2\$\$
+$cppstdin $cppminus </tmp/Cppsym\$\$ >/tmp/Cppsym2\$\$
case "\$list" in
true) awk 'NF > 5 {print substr(\$6,2,100)}' </tmp/Cppsym2\$\$ ;;
*)
$rm -f /tmp/Cppsym\$\$ /tmp/Cppsym2\$\$
exit \$status
EOSS
-chmod 755 Cppsym
+chmod +x Cppsym
$eunicefix Cppsym
echo "Your C preprocessor defines the following symbols:"
Cppsym -l $attrlist >Cppsym.true
cc=cc
fi
-: see if symlink exists
-echo " "
-if $contains symlink libc.list >/dev/null 2>&1; then
- echo 'symlink() found.'
- d_symlink="$define"
-else
- echo 'symlink() not found.'
- d_symlink="$undef"
-fi
-
: see if we should include -lnm
echo " "
if $test -r /usr/lib/libnm.a || $test -r /usr/local/lib/libnm.a ; then
vi='$vi'
mailx='$mailx'
mail='$mail'
+cpp='$cpp'
Log='$Log'
Header='$Header'
bin='$bin'
cc='$cc'
contains='$contains'
-cpp='$cpp'
+cppstdin='$cppstdin'
cppminus='$cppminus'
d_bcopy='$d_bcopy'
d_charsprf='$d_charsprf'
d_crypt='$d_crypt'
+d_fchmod='$d_fchmod'
+d_fchown='$d_fchown'
+d_getgrps='$d_getgrps'
d_index='$d_index'
+d_killpg='$d_killpg'
+d_memcpy='$d_memcpy'
+d_rename='$d_rename'
+d_setegid='$d_setegid'
+d_seteuid='$d_seteuid'
+d_setrgid='$d_setrgid'
+d_setruid='$d_setruid'
d_statblks='$d_statblks'
d_stdstdio='$d_stdstdio'
+d_strcspn='$d_strcspn'
d_strctcpy='$d_strctcpy'
d_symlink='$d_symlink'
d_tminsys='$d_tminsys'
d_vfork='$d_vfork'
d_voidsig='$d_voidsig'
+gidtype='$gidtype'
libc='$libc'
libnm='$libnm'
mallocsrc='$mallocsrc'
sharpbang='$sharpbang'
startsh='$startsh'
stdchar='$stdchar'
+uidtype='$uidtype'
voidflags='$voidflags'
defvoidused='$defvoidused'
+privlib='$privlib'
CONFIG=true
EOT
echo " "
dflt=''
+fastread=''
echo "If you didn't make any mistakes, then just type a carriage return here."
rp="If you need to edit config.sh, do it as a shell escape here:"
$echo $n "$rp $c"
*) : in case they cannot read
eval $ans;;
esac
+. ./config.sh
echo " "
echo "Doing variable substitutions on .SH files..."
-/* $Header: EXTERN.h,v 1.0 87/12/18 13:02:26 root Exp $
+/* $Header: EXTERN.h,v 2.0 88/06/05 00:07:46 root Exp $
*
* $Log: EXTERN.h,v $
- * Revision 1.0 87/12/18 13:02:26 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:07:46 root
+ * Baseline version 2.0.
*
*/
-/* $Header: INTERN.h,v 1.0 87/12/18 13:02:39 root Exp $
+/* $Header: INTERN.h,v 2.0 88/06/05 00:07:49 root Exp $
*
* $Log: INTERN.h,v $
- * Revision 1.0 87/12/18 13:02:39 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:07:49 root
+ * Baseline version 2.0.
*
*/
Filename Kit Description
-------- --- -----------
-Configure 6 Run this first
-EXTERN.h 10 Included before foreign .h files
-INTERN.h 10 Included before domestic .h files
-MANIFEST 8 This list of files
-Makefile.SH 4 Precursor to Makefile
-README 1 The Instructions
-Wishlist 10 Some things that may or may not happen
-arg.c 3 Expression evaluation
-arg.h 8 Public declarations for the above
-array.c 6 Numerically subscripted arrays
-array.h 10 Public declarations for the above
-cmd.c 7 Command interpreter
-cmd.h 9 Public declarations for the above
-config.H 9 Sample config.h
-config.h.SH 9 Produces config.h.
-dump.c 8 Debugging output
-form.c 8 Format processing
-form.h 10 Public declarations for the above
-handy.h 10 Handy definitions
-hash.c 9 Associative arrays
-hash.h 10 Public declarations for the above
-makedepend.SH 9 Precursor to makedepend
-makedir.SH 10 Precursor to makedir
-malloc.c 7 A version of malloc you might not want
-patchlevel.h 1 The current patch level of perl
-perl.h 9 Global declarations
-perl.man.1 5 The manual page(s), first half
-perl.man.2 4 The manual page(s), second half
-perl.y 5 Yacc grammar for perl
-perly.c 2 The perl compiler
-search.c 6 String matching
-search.h 10 Public declarations for the above
-spat.h 10 Search pattern declarations
-stab.c 8 Symbol table stuff
-stab.h 10 Public declarations for the above
-str.c 4 String handling package
-str.h 10 Public declarations for the above
-t/README 10 Instructions for regression tests
-t/TEST 10 The regression tester
-t/base.cond 10 See if conditionals work
-t/base.if 10 See if if works
-t/base.lex 10 See if lexical items work
-t/base.pat 10 See if pattern matching works
-t/base.term 10 See if various terms work
-t/cmd.elsif 10 See if else-if works
-t/cmd.for 10 See if for loops work
-t/cmd.mod 10 See if statement modifiers work
-t/cmd.subval 10 See if subroutine values work
-t/cmd.while 7 See if while loops work
-t/comp.cmdopt 9 See if command optimization works
-t/comp.cpp 10 See if C preprocessor works
-t/comp.decl 10 See if declarations work
-t/comp.multiline 10 See if multiline strings work
-t/comp.script 10 See if script invokation works
-t/comp.term 10 See if more terms work
-t/io.argv 10 See if ARGV stuff works
-t/io.fs 5 See if directory manipulations work
-t/io.inplace 10 See if inplace editing works
-t/io.print 10 See if print commands work
-t/io.tell 10 See if file seeking works
-t/op.append 10 See if . works
-t/op.auto 9 See if autoincrement et all work
-t/op.chop 10 See if chop works
-t/op.cond 10 See if conditional expressions work
-t/op.crypt 10 See if crypt works
-t/op.do 10 See if subroutines work
-t/op.each 10 See if associative iterators work
-t/op.exec 10 See if exec and system work
-t/op.exp 10 See if math functions work
-t/op.flip 10 See if range operator works
-t/op.fork 10 See if fork works
-t/op.goto 10 See if goto works
-t/op.int 10 See if int works
-t/op.join 10 See if join works
-t/op.list 10 See if array lists work
-t/op.magic 10 See if magic variables work
-t/op.oct 10 See if oct and hex work
-t/op.ord 10 See if ord works
-t/op.pat 9 See if esoteric patterns work
-t/op.push 7 See if push and pop work
-t/op.repeat 10 See if x operator works
-t/op.sleep 6 See if sleep works
-t/op.split 10 See if split works
-t/op.sprintf 10 See if sprintf work
-t/op.stat 10 See if stat work
-t/op.subst 10 See if substitutions work
-t/op.time 10 See if time functions work
-t/op.unshift 10 See if unshift works
-util.c 9 Utility routines
-util.h 10 Public declarations for the above
-version.c 10 Prints version of perl
-x2p/EXTERN.h 10 Same as above
-x2p/INTERN.h 10 Same as above
-x2p/Makefile.SH 9 Precursor to Makefile
-x2p/a2p.h 8 Global declarations
-x2p/a2p.man 8 Manual page for awk to perl translator
-x2p/a2p.y 8 A yacc grammer for awk
-x2p/a2py.c 7 Awk compiler, sort of
-x2p/handy.h 10 Handy definitions
-x2p/hash.c 9 Associative arrays again
-x2p/hash.h 10 Public declarations for the above
-x2p/s2p 1 Sed to perl translator
-x2p/s2p.man 10 Manual page for sed to perl translator
-x2p/str.c 7 String handling package
-x2p/str.h 10 Public declarations for the above
-x2p/util.c 9 Utility routines
-x2p/util.h 10 Public declarations for the above
-x2p/walk.c 1 Parse tree walker
+Changes 13 Differences between 1.0 level 29 and 2.0 level 0
+Configure 6 Run this first
+EXTERN.h 6 Included before foreign .h files
+INTERN.h 15 Included before domestic .h files
+MANIFEST 11 This list of files
+Makefile.SH 13 Precursor to Makefile
+README 1 The Instructions
+Wishlist 4 Some things that may or may not happen
+arg.c 1 Expression evaluation
+arg.h 12 Public declarations for the above
+array.c 13 Numerically subscripted arrays
+array.h 15 Public declarations for the above
+cmd.c 10 Command interpreter
+cmd.h 13 Public declarations for the above
+config.H 13 Sample config.h
+config.h.SH 11 Produces config.h.
+dump.c 12 Debugging output
+eg/ADB 15 An adb wrapper to put in your crash dir
+eg/README 1 Intro to example perl scripts
+eg/changes 15 A program to list recently changed files
+eg/dus 15 A program to do du -s on non-mounted dirs
+eg/findcp 14 A find wrapper that implements a -cp switch
+eg/findtar 15 A find wrapper that pumps out a tar file
+eg/g/gcp 14 A program to do a global rcp
+eg/g/gcp.man 14 Manual page for gcp
+eg/g/ged 1 A program to do a global edit
+eg/g/ghosts 15 A sample /etc/ghosts file
+eg/g/gsh 10 A program to do a global rsh
+eg/g/gsh.man 14 Manual page for gsh
+eg/myrup 15 A program to find lightly loaded machines
+eg/nih 15 Script to insert #! workaround
+eg/rmfrom 15 A program to feed doomed filenames to
+eg/scan/scan_df 14 Scan for filesystem anomalies
+eg/scan/scan_last 14 Scan for login anomalies
+eg/scan/scan_messages 13 Scan for console message anomalies
+eg/scan/scan_passwd 15 Scan for passwd file anomalies
+eg/scan/scan_ps 15 Scan for process anomalies
+eg/scan/scan_sudo 14 Scan for sudo anomalies
+eg/scan/scan_suid 8 Scan for setuid anomalies
+eg/scan/scanner 14 An anomaly reporter
+eg/shmkill 15 A program to remove unused shared memory
+eg/van/empty 15 A program to empty the trashcan
+eg/van/unvanish 14 A program to undo what vanish does
+eg/van/vanexp 15 A program to expire vanished files
+eg/van/vanish 14 A program to put files in a trashcan
+eval.c 8 The expression evaluator
+form.c 12 Format processing
+form.h 15 Public declarations for the above
+handy.h 15 Handy definitions
+hash.c 12 Associative arrays
+hash.h 14 Public declarations for the above
+lib/getopt.pl 14 Perl library supporting option parsing
+lib/importenv.pl 15 Perl routine to get environment into variables.
+lib/stat.pl 15 Perl library supporting stat function
+makedepend.SH 5 Precursor to makedepend
+makedir.SH 14 Precursor to makedir
+malloc.c 11 A version of malloc you might not want
+patchlevel.h 12 The current patch level of perl
+perl.h 12 Global declarations
+perl.man.1 5 The manual page(s), first half
+perl.man.2 3 The manual page(s), second half
+perl.y 10 Yacc grammar for perl
+perldb 11 Perl symbolic debugger
+perldb.man 13 Manual page for perl debugger
+perlsh 15 A poor man's perl shell.
+perly.c 4 The perl compiler
+regexp.c 2 String matching
+regexp.h 14 Public declarations for the above
+spat.h 14 Search pattern declarations
+stab.c 6 Symbol table stuff
+stab.h 3 Public declarations for the above
+str.c 7 String handling package
+str.h 14 Public declarations for the above
+t/README 1 Instructions for regression tests
+t/TEST 14 The regression tester
+t/base.cond 15 See if conditionals work
+t/base.if 15 See if if works
+t/base.lex 15 See if lexical items work
+t/base.pat 15 See if pattern matching works
+t/base.term 15 See if various terms work
+t/cmd.elsif 15 See if else-if works
+t/cmd.for 15 See if for loops work
+t/cmd.mod 15 See if statement modifiers work
+t/cmd.subval 14 See if subroutine values work
+t/cmd.while 14 See if while loops work
+t/comp.cmdopt 13 See if command optimization works
+t/comp.cpp 15 See if C preprocessor works
+t/comp.decl 15 See if declarations work
+t/comp.multiline 15 See if multiline strings work
+t/comp.script 14 See if script invokation works
+t/comp.term 15 See if more terms work
+t/io.argv 15 See if ARGV stuff works
+t/io.dup 15 See if >& works right
+t/io.fs 12 See if directory manipulations work
+t/io.inplace 15 See if inplace editing works
+t/io.pipe 15 See if secure pipes work
+t/io.print 15 See if print commands work
+t/io.tell 13 See if file seeking works
+t/op.append 15 See if . works
+t/op.auto 14 See if autoincrement et all work
+t/op.chop 15 See if chop works
+t/op.cond 5 See if conditional expressions work
+t/op.delete 15 See if delete works
+t/op.do 14 See if subroutines work
+t/op.each 14 See if associative iterators work
+t/op.eval 14 See if eval operator works
+t/op.exec 15 See if exec and system work
+t/op.exp 15 See if math functions work
+t/op.flip 15 See if range operator works
+t/op.fork 15 See if fork works
+t/op.goto 15 See if goto works
+t/op.int 15 See if int works
+t/op.join 15 See if join works
+t/op.list 14 See if array lists work
+t/op.magic 15 See if magic variables work
+t/op.oct 15 See if oct and hex work
+t/op.ord 15 See if ord works
+t/op.pat 14 See if esoteric patterns work
+t/op.push 15 See if push and pop work
+t/op.regexp 15 See if regular expressions work
+t/op.repeat 15 See if x operator works
+t/op.sleep 15 See if sleep works
+t/op.split 7 See if split works
+t/op.sprintf 15 See if sprintf works
+t/op.stat 11 See if stat works
+t/op.study 14 See if study works
+t/op.subst 14 See if substitutions work
+t/op.time 14 See if time functions work
+t/op.unshift 15 See if unshift works
+t/re_tests 13 Input file for op.regexp
+toke.c 9 The tokener
+util.c 8 Utility routines
+util.h 15 Public declarations for the above
+version.c 15 Prints version of perl
+x2p/EXTERN.h 15 Same as above
+x2p/INTERN.h 15 Same as above
+x2p/Makefile.SH 4 Precursor to Makefile
+x2p/a2p.h 13 Global declarations
+x2p/a2p.man 12 Manual page for awk to perl translator
+x2p/a2p.y 12 A yacc grammer for awk
+x2p/a2py.c 9 Awk compiler, sort of
+x2p/handy.h 15 Handy definitions
+x2p/hash.c 13 Associative arrays again
+x2p/hash.h 14 Public declarations for the above
+x2p/s2p 10 Sed to perl translator
+x2p/s2p.man 9 Manual page for sed to perl translator
+x2p/str.c 11 String handling package
+x2p/str.h 15 Public declarations for the above
+x2p/util.c 13 Utility routines
+x2p/util.h 15 Public declarations for the above
+x2p/walk.c 7 Parse tree walker
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
fi
- . config.sh
+ . ./config.sh
;;
esac
case "$0" in
echo "Extracting Makefile (with variable substitutions)"
cat >Makefile <<!GROK!THIS!
-# $Header: Makefile.SH,v 1.0.1.5 88/02/02 11:20:49 root Exp $
+# $Header: Makefile.SH,v 2.0 88/06/05 00:07:54 root Exp $
#
# $Log: Makefile.SH,v $
-# Revision 1.0.1.5 88/02/02 11:20:49 root
-# patch13: added d_symlink dependency, changed TEST to ./perl TEST.
+# Revision 2.0 88/06/05 00:07:54 root
+# Baseline version 2.0.
#
-# Revision 1.0.1.4 88/01/28 10:17:59 root
-# patch8: added perldb.man
-#
-# Revision 1.0.1.3 88/01/26 14:14:52 root
-# Added mallocsrc stuff.
-#
-# Revision 1.0.1.2 88/01/26 08:46:04 root
-# patch 4: make depend didn't work right if . wasn't in PATH.
-#
-# Revision 1.0.1.1 88/01/24 03:55:18 root
-# patch 2: remove extra Log lines.
-#
-# Revision 1.0 87/12/18 16:11:50 root
-# Initial revision
#
CC = $cc
bin = $bin
-lib = $lib
+lib = $privlib
mansrc = $mansrc
manext = $manext
CFLAGS = $ccflags -O
sh = Makefile.SH makedepend.SH
h1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h form.h handy.h
-h2 = hash.h perl.h search.h spat.h stab.h str.h util.h
+h2 = hash.h perl.h regexp.h spat.h stab.h str.h util.h
h = $(h1) $(h2)
-c1 = arg.c array.c cmd.c dump.c form.c hash.c $(mallocsrc)
-c2 = search.c stab.c str.c util.c version.c
+c1 = arg.c array.c cmd.c dump.c eval.c form.c hash.c $(mallocsrc)
+c2 = perly.c regexp.c stab.c str.c toke.c util.c version.c
c = $(c1) $(c2)
-obj1 = arg.o array.o cmd.o dump.o form.o hash.o $(mallocobj)
-obj2 = search.o stab.o str.o util.o version.o
+obj1 = arg.o array.o cmd.o dump.o eval.o form.o hash.o $(mallocobj)
+obj2 = perly.o regexp.o stab.o str.o toke.o util.o version.o
obj = $(obj1) $(obj2)
perl: $(obj) perl.o
$(CC) $(LDFLAGS) $(LARGE) $(obj) perl.o $(libs) -o perl
-perl.c: perl.y
- @ echo Expect 2 shift/reduce errors...
- yacc perl.y
+perl.c perly.h: perl.y
+ @ echo Expect 37 shift/reduce errors...
+ yacc -d perl.y
mv y.tab.c perl.c
+ mv y.tab.h perly.h
-perl.o: perl.c perly.c perl.h EXTERN.h search.h util.h INTERN.h handy.h
+perl.o: perl.c perly.h perl.h EXTERN.h regexp.h util.h INTERN.h handy.h config.h
$(CC) -c $(CFLAGS) $(LARGE) perl.c
# if a .h file depends on another .h file...
install: perl perl.man
# won't work with csh
export PATH || exit 1
- - mv $(bin)/perl $(bin)/perl.old
+ - mv $(bin)/perl $(bin)/perl.old 2>/dev/null
- if test `pwd` != $(bin); then cp $(public) $(bin); fi
cd $(bin); \
for pub in $(public); do \
-chmod 755 `basename $$pub`; \
+chmod +x `basename $$pub`; \
done
- - test $(bin) = /bin || rm -f /bin/perl
- - test $(bin) = /bin || ln -s $(bin)/perl /bin || cp $(bin)/perl /bin
-# chmod 755 makedir
-# - makedir `filexp $(lib)`
-# - \
-#if test `pwd` != `filexp $(lib)`; then \
-#cp $(private) `filexp $(lib)`; \
-#fi
-# cd `filexp $(lib)`; \
+ - test $(bin) = /usr/bin || rm -f /usr/bin/perl
+ - test $(bin) = /usr/bin || $(SLN) $(bin)/perl /usr/bin || cp $(bin)/perl /usr/bin
+ chmod +x makedir
+ - ./makedir $(lib)
+ - \
+if test `pwd` != $(lib); then \
+cp $(private) lib/*.pl $(lib); \
+fi
+# cd $(lib); \
#for priv in $(private); do \
-#chmod 755 `basename $$priv`; \
+#chmod +x `basename $$priv`; \
#done
- if test `pwd` != $(mansrc); then \
for page in $(manpages); do \
# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
# for that spot.
-lint:
- lint $(lintflags) $(defs) $(c) > perl.fuzz
+lint: perl.c $(c)
+ lint $(lintflags) $(defs) perl.c $(c) > perl.fuzz
depend: makedepend
+ - test -f perly.h || cp /dev/null perly.h
./makedepend
+ - test -s perly.h || /bin/rm -f perly.h
test: perl
- chmod 755 t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.*
+ chmod +x t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.*
cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST
clist:
- Perl Kit, Version 1.0
+ Perl Kit, Version 2.0
- Copyright (c) 1987, Larry Wall
+ Copyright (c) 1988, Larry Wall
You may copy the perl kit in whole or in part as long as you don't try to
make money off it, or pretend that you wrote it.
This will run the regression tests on the perl you just made.
If it doesn't say "All tests successful" then something went wrong.
- See the README in the t subdirectory.
+ See the README in the t subdirectory. Note that you can't run it
+ in background if this disables opening of /dev/tty. If in doubt, just
+ cd to the t directory and run TEST by hand.
6) make install
case statement
ioctl() support
random numbers
-directory reading via <>
-/* $Header: arg.c,v 1.0.1.7 88/02/02 11:22:19 root Exp $
+/* $Header: arg.c,v 2.0 88/06/05 00:08:04 root Exp $
*
* $Log: arg.c,v $
- * Revision 1.0.1.7 88/02/02 11:22:19 root
- * patch13: fixed split(' ') to work right second time. Added CRYPT dependency.
- *
- * Revision 1.0.1.6 88/02/01 17:32:26 root
- * patch12: made split(' ') behave like awk in ignoring leading white space.
- *
- * Revision 1.0.1.5 88/01/30 08:53:16 root
- * patch9: fixed some missing right parens introduced (?) by patch 2
- *
- * Revision 1.0.1.4 88/01/28 10:22:06 root
- * patch8: added eval operator.
- *
- * Revision 1.0.1.2 88/01/24 03:52:34 root
- * patch 2: added STATBLKS dependencies.
- *
- * Revision 1.0.1.1 88/01/21 21:27:10 root
- * Now defines signal return values correctly using VOIDSIG.
- *
- * Revision 1.0 87/12/18 13:04:33 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:08:04 root
+ * Baseline version 2.0.
*
*/
-#include <signal.h>
-#include "handy.h"
#include "EXTERN.h"
-#include "search.h"
-#include "util.h"
#include "perl.h"
-ARG *debarg;
+#include <signal.h>
+#include <errno.h>
+
+extern int errno;
-bool
-do_match(s,arg)
-register char *s;
+STR *
+do_match(arg,retary,sarg,ptrmaxsarg,sargoff,cushion)
register ARG *arg;
+STR ***retary;
+register STR **sarg;
+int *ptrmaxsarg;
+int sargoff;
+int cushion;
{
register SPAT *spat = arg[2].arg_ptr.arg_spat;
- register char *d;
register char *t;
+ register char *s = str_get(sarg[1]);
+ char *strend = s + sarg[1]->str_cur;
- if (!spat || !s)
- fatal("panic: do_match\n");
+ if (!spat)
+ return &str_yes;
+ if (!s)
+ fatal("panic: do_match");
+ if (retary) {
+ *retary = sarg; /* assume no match */
+ *ptrmaxsarg = sargoff;
+ }
if (spat->spat_flags & SPAT_USED) {
#ifdef DEBUGGING
if (debug & 8)
deb("2.SPAT USED\n");
#endif
- return FALSE;
+ return &str_no;
}
if (spat->spat_runtime) {
- t = str_get(eval(spat->spat_runtime,Null(STR***)));
+ t = str_get(eval(spat->spat_runtime,Null(STR***),-1));
#ifdef DEBUGGING
if (debug & 8)
deb("2.SPAT /%s/\n",t);
#endif
- if (d = compile(&spat->spat_compex,t,TRUE,FALSE)) {
-#ifdef DEBUGGING
- deb("/%s/: %s\n", t, d);
-#endif
- return FALSE;
- }
- if (spat->spat_compex.complen <= 1 && curspat)
- spat = curspat;
- if (execute(&spat->spat_compex, s, TRUE, 0)) {
- if (spat->spat_compex.numsubs)
+ spat->spat_regexp = regcomp(t,spat->spat_flags & SPAT_FOLD,1);
+ if (!*spat->spat_regexp->precomp && lastspat)
+ spat = lastspat;
+ if (regexec(spat->spat_regexp, s, strend, TRUE, 0,
+ sarg[1]->str_pok & 4 ? sarg[1] : Nullstr)) {
+ if (spat->spat_regexp->subbase)
curspat = spat;
- return TRUE;
+ lastspat = spat;
+ goto gotcha;
}
else
- return FALSE;
+ return &str_no;
}
else {
#ifdef DEBUGGING
if (debug & 8) {
char ch;
- if (spat->spat_flags & SPAT_USE_ONCE)
+ if (spat->spat_flags & SPAT_ONCE)
ch = '?';
else
ch = '/';
- deb("2.SPAT %c%s%c\n",ch,spat->spat_compex.precomp,ch);
+ deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
}
#endif
- if (spat->spat_compex.complen <= 1 && curspat)
- spat = curspat;
- if (spat->spat_first) {
+ if (!*spat->spat_regexp->precomp && lastspat)
+ spat = lastspat;
+ t = s;
+ if (hint) {
+ if (hint < s || hint > strend)
+ fatal("panic: hint in do_match");
+ s = hint;
+ hint = Nullch;
+ if (spat->spat_regexp->regback >= 0) {
+ s -= spat->spat_regexp->regback;
+ if (s < t)
+ s = t;
+ }
+ else
+ s = t;
+ }
+ else if (spat->spat_short) {
if (spat->spat_flags & SPAT_SCANFIRST) {
- str_free(spat->spat_first);
- spat->spat_first = Nullstr; /* disable optimization */
+ if (sarg[1]->str_pok == 5) {
+ if (screamfirst[spat->spat_short->str_rare] < 0)
+ goto nope;
+ else if (!(s = screaminstr(sarg[1],spat->spat_short)))
+ goto nope;
+ else if (spat->spat_flags & SPAT_ALL)
+ goto yup;
+ }
+ else if (!(s = fbminstr(s, strend, spat->spat_short)))
+ goto nope;
+ else if (spat->spat_flags & SPAT_ALL)
+ goto yup;
+ else if (spat->spat_regexp->regback >= 0) {
+ ++*(long*)&spat->spat_short->str_nval;
+ s -= spat->spat_regexp->regback;
+ if (s < t)
+ s = t;
+ }
+ else
+ s = t;
+ }
+ else if (!multiline && (*spat->spat_short->str_ptr != *s ||
+ strnNE(spat->spat_short->str_ptr, s, spat->spat_slen) ))
+ goto nope;
+ if (--*(long*)&spat->spat_short->str_nval < 0) {
+ str_free(spat->spat_short);
+ spat->spat_short = Nullstr; /* opt is being useless */
}
- else if (*spat->spat_first->str_ptr != *s ||
- strnNE(spat->spat_first->str_ptr, s, spat->spat_flen) )
- return FALSE;
}
- if (execute(&spat->spat_compex, s, TRUE, 0)) {
- if (spat->spat_compex.numsubs)
+ if (regexec(spat->spat_regexp, s, strend, s == t, 0,
+ sarg[1]->str_pok & 4 ? sarg[1] : Nullstr)) {
+ if (spat->spat_regexp->subbase)
curspat = spat;
- if (spat->spat_flags & SPAT_USE_ONCE)
+ lastspat = spat;
+ if (spat->spat_flags & SPAT_ONCE)
spat->spat_flags |= SPAT_USED;
- return TRUE;
+ goto gotcha;
}
else
- return FALSE;
+ return &str_no;
}
/*NOTREACHED*/
+
+ gotcha:
+ if (retary && curspat == spat) {
+ int iters, i, len;
+
+ iters = spat->spat_regexp->nparens;
+ *ptrmaxsarg = iters + sargoff;
+ sarg = (STR**)saferealloc((char*)(sarg - sargoff),
+ (iters+2+cushion+sargoff)*sizeof(STR*)) + sargoff;
+
+ for (i = 1; i <= iters; i++) {
+ sarg[i] = str_static(&str_no);
+ if (s = spat->spat_regexp->startp[i]) {
+ len = spat->spat_regexp->endp[i] - s;
+ if (len > 0)
+ str_nset(sarg[i],s,len);
+ }
+ }
+ *retary = sarg;
+ }
+ return &str_yes;
+
+yup:
+ ++*(long*)&spat->spat_short->str_nval;
+ return &str_yes;
+
+nope:
+ ++*(long*)&spat->spat_short->str_nval;
+ return &str_no;
}
int
{
register SPAT *spat;
register STR *dstr;
- register char *s;
+ register char *s = str_get(str);
+ char *strend = s + str->str_cur;
register char *m;
spat = arg[2].arg_ptr.arg_spat;
- s = str_get(str);
if (!spat || !s)
- fatal("panic: do_subst\n");
+ fatal("panic: do_subst");
else if (spat->spat_runtime) {
- char *d;
-
- m = str_get(eval(spat->spat_runtime,Null(STR***)));
- if (d = compile(&spat->spat_compex,m,TRUE,FALSE)) {
-#ifdef DEBUGGING
- deb("/%s/: %s\n", m, d);
-#endif
- return 0;
- }
+ m = str_get(eval(spat->spat_runtime,Null(STR***),-1));
+ spat->spat_regexp = regcomp(m,spat->spat_flags & SPAT_FOLD,1);
}
#ifdef DEBUGGING
if (debug & 8) {
- deb("2.SPAT /%s/\n",spat->spat_compex.precomp);
+ deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
}
#endif
- if (spat->spat_compex.complen <= 1 && curspat)
- spat = curspat;
- if (spat->spat_first) {
+ if (!*spat->spat_regexp->precomp && lastspat)
+ spat = lastspat;
+ m = s;
+ if (hint) {
+ if (hint < s || hint > strend)
+ fatal("panic: hint in do_match");
+ s = hint;
+ hint = Nullch;
+ if (spat->spat_regexp->regback >= 0) {
+ s -= spat->spat_regexp->regback;
+ if (s < m)
+ s = m;
+ }
+ else
+ s = m;
+ }
+ else if (spat->spat_short) {
if (spat->spat_flags & SPAT_SCANFIRST) {
- str_free(spat->spat_first);
- spat->spat_first = Nullstr; /* disable optimization */
+ if (str->str_pok == 5) {
+ if (screamfirst[spat->spat_short->str_rare] < 0)
+ goto nope;
+ else if (!(s = screaminstr(str,spat->spat_short)))
+ goto nope;
+ }
+ else if (!(s = fbminstr(s, strend, spat->spat_short)))
+ goto nope;
+ else if (spat->spat_regexp->regback >= 0) {
+ ++*(long*)&spat->spat_short->str_nval;
+ s -= spat->spat_regexp->regback;
+ if (s < m)
+ s = m;
+ }
+ else
+ s = m;
+ }
+ else if (!multiline && (*spat->spat_short->str_ptr != *s ||
+ strnNE(spat->spat_short->str_ptr, s, spat->spat_slen) ))
+ goto nope;
+ if (--*(long*)&spat->spat_short->str_nval < 0) {
+ str_free(spat->spat_short);
+ spat->spat_short = Nullstr; /* opt is being useless */
}
- else if (*spat->spat_first->str_ptr != *s ||
- strnNE(spat->spat_first->str_ptr, s, spat->spat_flen) )
- return 0;
}
- if (m = execute(&spat->spat_compex, s, TRUE, 1)) {
+ if (regexec(spat->spat_regexp, s, strend, s == m, 1,
+ str->str_pok & 4 ? str : Nullstr)) {
int iters = 0;
dstr = str_new(str_len(str));
- if (spat->spat_compex.numsubs)
+ str_nset(dstr,m,s-m);
+ if (spat->spat_regexp->subbase)
curspat = spat;
+ lastspat = spat;
do {
+ m = spat->spat_regexp->startp[0];
if (iters++ > 10000)
- fatal("Substitution loop?\n");
- if (spat->spat_compex.numsubs)
- s = spat->spat_compex.subbase;
+ fatal("Substitution loop");
+ if (spat->spat_regexp->subbase)
+ s = spat->spat_regexp->subbase;
str_ncat(dstr,s,m-s);
- s = spat->spat_compex.subend[0];
- str_scat(dstr,eval(spat->spat_repl,Null(STR***)));
- if (spat->spat_flags & SPAT_USE_ONCE)
+ s = spat->spat_regexp->endp[0];
+ str_scat(dstr,eval(spat->spat_repl,Null(STR***),-1));
+ if (spat->spat_flags & SPAT_ONCE)
break;
- } while (m = execute(&spat->spat_compex, s, FALSE, 1));
+ } while (regexec(spat->spat_regexp, s, strend, FALSE, 1, Nullstr));
str_cat(dstr,s);
str_replace(str,dstr);
STABSET(str);
return iters;
}
return 0;
+
+nope:
+ ++*(long*)&spat->spat_short->str_nval;
+ return 0;
}
int
tbl = arg[2].arg_ptr.arg_cval;
s = str_get(str);
if (!tbl || !s)
- fatal("panic: do_trans\n");
+ fatal("panic: do_trans");
#ifdef DEBUGGING
if (debug & 8) {
deb("2.TBL\n");
}
int
-do_split(s,spat,retary)
-register char *s;
+do_split(spat,retary,sarg,ptrmaxsarg,sargoff,cushion)
register SPAT *spat;
STR ***retary;
+register STR **sarg;
+int *ptrmaxsarg;
+int sargoff;
+int cushion;
{
+ register char *s = str_get(sarg[1]);
+ char *strend = s + sarg[1]->str_cur;
register STR *dstr;
register char *m;
register ARRAY *ary;
static ARRAY *myarray = Null(ARRAY*);
int iters = 0;
- STR **sarg;
- register char *e;
int i;
if (!spat || !s)
- fatal("panic: do_split\n");
+ fatal("panic: do_split");
else if (spat->spat_runtime) {
- char *d;
-
- m = str_get(eval(spat->spat_runtime,Null(STR***)));
+ m = str_get(eval(spat->spat_runtime,Null(STR***),-1));
if (!*m || (*m == ' ' && !m[1])) {
- m = "[ \\t\\n]+";
+ m = "\\s+";
spat->spat_flags |= SPAT_SKIPWHITE;
}
if (spat->spat_runtime->arg_type == O_ITEM &&
arg_free(spat->spat_runtime); /* it won't change, so */
spat->spat_runtime = Nullarg; /* no point compiling again */
}
- if (d = compile(&spat->spat_compex,m,TRUE,FALSE)) {
-#ifdef DEBUGGING
- deb("/%s/: %s\n", m, d);
-#endif
- return FALSE;
- }
+ spat->spat_regexp = regcomp(m,spat->spat_flags & SPAT_FOLD,1);
}
#ifdef DEBUGGING
if (debug & 8) {
- deb("2.SPAT /%s/\n",spat->spat_compex.precomp);
+ deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
}
#endif
if (retary)
else
ary = spat->spat_repl[1].arg_ptr.arg_stab->stab_array;
if (!ary)
- myarray = ary = anew();
+ myarray = ary = anew(Nullstab);
ary->ary_fill = -1;
if (spat->spat_flags & SPAT_SKIPWHITE) {
while (isspace(*s))
s++;
}
- while (*s && (m = execute(&spat->spat_compex, s, (iters == 0), 1))) {
- if (spat->spat_compex.numsubs)
- s = spat->spat_compex.subbase;
- dstr = str_new(m-s);
- str_nset(dstr,s,m-s);
- astore(ary, iters++, dstr);
- if (iters > 10000)
- fatal("Substitution loop?\n");
- s = spat->spat_compex.subend[0];
+ if (spat->spat_short) {
+ i = spat->spat_short->str_cur;
+ while (*s && (m = fbminstr(s, strend, spat->spat_short))) {
+ dstr = str_new(m-s);
+ str_nset(dstr,s,m-s);
+ astore(ary, iters++, dstr);
+ if (iters > 10000)
+ fatal("Substitution loop");
+ s = m + i;
+ }
+ }
+ else {
+ while (*s && regexec(spat->spat_regexp, s, strend, (iters == 0), 1,
+ Nullstr)) {
+ m = spat->spat_regexp->startp[0];
+ if (spat->spat_regexp->subbase)
+ s = spat->spat_regexp->subbase;
+ dstr = str_new(m-s);
+ str_nset(dstr,s,m-s);
+ astore(ary, iters++, dstr);
+ if (iters > 10000)
+ fatal("Substitution loop");
+ s = spat->spat_regexp->endp[0];
+ }
}
if (*s) { /* ignore field after final "whitespace" */
dstr = str_new(0); /* if they interpolate, it's null anyway */
iters--;
}
if (retary) {
- sarg = (STR**)safemalloc((iters+2)*sizeof(STR*));
+ *ptrmaxsarg = iters + sargoff;
+ sarg = (STR**)saferealloc((char*)(sarg - sargoff),
+ (iters+2+cushion+sargoff)*sizeof(STR*)) + sargoff;
- sarg[0] = Nullstr;
- sarg[iters+1] = Nullstr;
for (i = 1; i <= iters; i++)
sarg[i] = afetch(ary,i-1);
*retary = sarg;
{
STR **tmpary; /* must not be register */
register STR **elem;
+ register int items;
- (void)eval(arg[2].arg_ptr.arg_arg,&tmpary);
+ (void)eval(arg[2].arg_ptr.arg_arg,&tmpary,-1);
+ items = (int)str_gnum(*tmpary);
elem = tmpary+1;
- if (*elem)
- str_sset(str,*elem++);
- for (; *elem; elem++) {
+ if (items-- > 0)
+ str_sset(str,*elem++);
+ for (; items > 0; items--,elem++) {
str_cat(str,delim);
str_scat(str,*elem);
}
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;
FILE *fp;
int len = strlen(name);
register STIO *stio = stab->stab_io;
+ char *myname = savestr(name);
+ int result;
+ int fd;
+ name = myname;
+ forkprocess = 1; /* assume true if no fork */
while (len && isspace(name[len-1]))
name[--len] = '\0';
if (!stio)
stio = stab->stab_io = stio_new();
if (stio->fp) {
+ fd = fileno(stio->fp);
if (stio->type == '|')
- pclose(stio->fp);
+ result = pclose(stio->fp);
else if (stio->type != '-')
- fclose(stio->fp);
+ result = fclose(stio->fp);
+ else
+ result = 0;
+ if (result == EOF && fd > 2)
+ fprintf(stderr,"Warning: unable to close filehandle %s properly.\n",
+ stab->stab_name);
stio->fp = Nullfp;
}
stio->type = *name;
if (*name == '|') {
for (name++; isspace(*name); name++) ;
- fp = popen(name,"w");
+ if (strNE(name,"-"))
+ fp = popen(name,"w");
+ else {
+ fp = forkopen(name,"w");
+ stio->subprocess = forkprocess;
+ stio->type = '%';
+ }
}
else if (*name == '>' && name[1] == '>') {
+ stio->type = 'a';
for (name += 2; isspace(*name); name++) ;
fp = fopen(name,"a");
}
+ else if (*name == '>' && name[1] == '&') {
+ for (name += 2; isspace(*name); name++) ;
+ if (isdigit(*name))
+ fd = atoi(name);
+ else {
+ stab = stabent(name,FALSE);
+ if (stab->stab_io && stab->stab_io->fp) {
+ fd = fileno(stab->stab_io->fp);
+ stio->type = stab->stab_io->type;
+ }
+ else
+ fd = -1;
+ }
+ fp = fdopen(dup(fd),stio->type == 'a' ? "a" :
+ (stio->type == '<' ? "r" : "w") );
+ }
else if (*name == '>') {
for (name++; isspace(*name); name++) ;
if (strEQ(name,"-")) {
while (len && isspace(name[len-1]))
name[--len] = '\0';
for (; isspace(*name); name++) ;
- fp = popen(name,"r");
- stio->type = '|';
+ if (strNE(name,"-")) {
+ fp = popen(name,"r");
+ stio->type = '|';
+ }
+ else {
+ fp = forkopen(name,"r");
+ stio->subprocess = forkprocess;
+ stio->type = '%';
+ }
}
else {
stio->type = '<';
fp = fopen(name,"r");
}
}
+ safefree(myname);
if (!fp)
return FALSE;
- if (stio->type != '|' && stio->type != '-') {
+ if (stio->type &&
+ stio->type != '|' && stio->type != '-' && stio->type != '%') {
if (fstat(fileno(fp),&statbuf) < 0) {
fclose(fp);
return FALSE;
{
register STR *str;
char *oldname;
+ int filemode,fileuid,filegid;
- while (alen(stab->stab_array) >= 0L) {
+ while (alen(stab->stab_array) >= 0) {
str = ashift(stab->stab_array);
str_sset(stab->stab_val,str);
STABSET(stab->stab_val);
oldname = str_get(stab->stab_val);
if (do_open(stab,oldname)) {
if (inplace) {
+ filemode = statbuf.st_mode;
+ fileuid = statbuf.st_uid;
+ filegid = statbuf.st_gid;
if (*inplace) {
str_cat(str,inplace);
#ifdef RENAME
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;
{
bool retval = FALSE;
register STIO *stio = stab->stab_io;
+ int status;
+ int tmp;
- if (!stio) /* never opened */
+ if (!stio) { /* never opened */
+ if (dowarn && explicit)
+ warn("Close on unopened file <%s>",stab->stab_name);
return FALSE;
+ }
if (stio->fp) {
if (stio->type == '|')
retval = (pclose(stio->fp) >= 0);
else if (stio->type == '-')
retval = TRUE;
- else
+ else {
retval = (fclose(stio->fp) != EOF);
+ if (stio->type == '%' && stio->subprocess) {
+ while ((tmp = wait(&status)) != stio->subprocess && tmp != -1)
+ ;
+ if (tmp == -1)
+ statusvalue = -1;
+ else
+ statusvalue = (unsigned)status & 0xffff;
+ }
+ }
stio->fp = Nullfp;
}
if (explicit)
register STIO *stio;
int ch;
- if (!stab)
- return TRUE;
+ if (!stab) /* eof() */
+ stio = argvstab->stab_io;
+ else
+ stio = stab->stab_io;
- stio = stab->stab_io;
if (!stio)
return TRUE;
ungetc(ch, stio->fp);
return FALSE;
}
- if (stio->flags & IOF_ARGV) { /* not necessarily a real EOF yet? */
- if (!nextargv(stab)) /* get another fp handy */
+ if (!stab) { /* not necessarily a real EOF yet? */
+ if (!nextargv(argvstab)) /* get another fp handy */
return TRUE;
}
else
STAB *stab;
{
register STIO *stio;
- int ch;
if (!stab)
- return -1L;
+ goto phooey;
stio = stab->stab_io;
if (!stio || !stio->fp)
- return -1L;
+ goto phooey;
return ftell(stio->fp);
+
+phooey:
+ if (dowarn)
+ warn("tell() on unopened file");
+ return -1L;
}
bool
register STIO *stio;
if (!stab)
- return FALSE;
+ goto nuts;
stio = stab->stab_io;
if (!stio || !stio->fp)
- return FALSE;
+ goto nuts;
return fseek(stio->fp, pos, whence) >= 0;
+
+nuts:
+ if (dowarn)
+ warn("seek() on unopened file");
+ return FALSE;
}
-do_stat(arg,sarg,retary)
+static CMD *sortcmd;
+static STAB *firststab = Nullstab;
+static STAB *secondstab = Nullstab;
+
+do_sort(arg,stab,retary,sarg,ptrmaxsarg,sargoff,cushion)
register ARG *arg;
+STAB *stab;
+STR ***retary;
register STR **sarg;
+int *ptrmaxsarg;
+int sargoff;
+int cushion;
+{
+ STR **tmpary; /* must not be register */
+ register STR **elem;
+ register bool retval;
+ register int max;
+ register int i;
+ int sortcmp();
+ int sortsub();
+ STR *oldfirst;
+ STR *oldsecond;
+
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1);
+ max = (int)str_gnum(*tmpary);
+
+ if (retary) {
+ sarg = (STR**)saferealloc((char*)(sarg - sargoff),
+ (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff;
+ for (i = 1; i <= max; i++)
+ sarg[i] = tmpary[i];
+ *retary = sarg;
+ if (max > 1) {
+ if (stab->stab_sub && (sortcmd = stab->stab_sub->cmd)) {
+ if (!firststab) {
+ firststab = stabent("a",TRUE);
+ secondstab = stabent("b",TRUE);
+ }
+ oldfirst = firststab->stab_val;
+ oldsecond = secondstab->stab_val;
+ qsort((char*)(sarg+1),max,sizeof(STR*),sortsub);
+ firststab->stab_val = oldfirst;
+ secondstab->stab_val = oldsecond;
+ }
+ else
+ qsort((char*)(sarg+1),max,sizeof(STR*),sortcmp);
+ }
+ while (max > 0 && !sarg[max])
+ max--;
+ *ptrmaxsarg = max + sargoff;
+ }
+ safefree((char*)tmpary);
+ return max;
+}
+
+int
+sortcmp(str1,str2)
+STR **str1;
+STR **str2;
+{
+ char *tmps;
+
+ if (!*str1)
+ return -1;
+ if (!*str2)
+ return 1;
+ tmps = str_get(*str1);
+ return strcmp(tmps,str_get(*str2));
+}
+
+int
+sortsub(str1,str2)
+STR **str1;
+STR **str2;
+{
+ STR *str;
+
+ if (!*str1)
+ return -1;
+ if (!*str2)
+ return 1;
+ firststab->stab_val = *str1;
+ secondstab->stab_val = *str2;
+ return (int)str_gnum(cmd_exec(sortcmd));
+}
+
+do_stat(arg,retary,sarg,ptrmaxsarg,sargoff,cushion)
+register ARG *arg;
STR ***retary;
+register STR **sarg;
+int *ptrmaxsarg;
+int sargoff;
+int cushion;
{
register ARRAY *ary;
static ARRAY *myarray = Null(ARRAY*);
ary = myarray;
if (!ary)
- myarray = ary = anew();
+ myarray = ary = anew(Nullstab);
ary->ary_fill = -1;
if (arg[1].arg_type == A_LVAL) {
tmpstab = arg[1].arg_ptr.arg_stab;
apush(ary,str_make(""));
#endif
}
- sarg = (STR**)safemalloc((max+2)*sizeof(STR*));
- sarg[0] = Nullstr;
- sarg[max+1] = Nullstr;
+ *ptrmaxsarg = max + sargoff;
+ sarg = (STR**)saferealloc((char*)(sarg - sargoff),
+ (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff;
for (i = 1; i <= max; i++)
sarg[i] = afetch(ary,i-1);
*retary = sarg;
return max;
}
-do_tms(retary)
+do_tms(retary,sarg,ptrmaxsarg,sargoff,cushion)
STR ***retary;
+STR **sarg;
+int *ptrmaxsarg;
+int sargoff;
+int cushion;
{
register ARRAY *ary;
static ARRAY *myarray = Null(ARRAY*);
- register STR **sarg;
int max = 4;
register int i;
ary = myarray;
if (!ary)
- myarray = ary = anew();
+ myarray = ary = anew(Nullstab);
ary->ary_fill = -1;
- if (times(×buf) < 0)
- max = 0;
+ times(×buf);
+
+#ifndef HZ
+#define HZ 60
+#endif
if (retary) {
if (max) {
- apush(ary,str_nmake(((double)timesbuf.tms_utime)/60.0));
- apush(ary,str_nmake(((double)timesbuf.tms_stime)/60.0));
- apush(ary,str_nmake(((double)timesbuf.tms_cutime)/60.0));
- apush(ary,str_nmake(((double)timesbuf.tms_cstime)/60.0));
- }
- sarg = (STR**)safemalloc((max+2)*sizeof(STR*));
- sarg[0] = Nullstr;
- sarg[max+1] = Nullstr;
+ apush(ary,str_nmake(((double)timesbuf.tms_utime)/HZ));
+ apush(ary,str_nmake(((double)timesbuf.tms_stime)/HZ));
+ apush(ary,str_nmake(((double)timesbuf.tms_cutime)/HZ));
+ apush(ary,str_nmake(((double)timesbuf.tms_cstime)/HZ));
+ }
+ *ptrmaxsarg = max + sargoff;
+ sarg = (STR**)saferealloc((char*)(sarg - sargoff),
+ (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff;
for (i = 1; i <= max; i++)
sarg[i] = afetch(ary,i-1);
*retary = sarg;
return max;
}
-do_time(tmbuf,retary)
+do_time(tmbuf,retary,sarg,ptrmaxsarg,sargoff,cushion)
struct tm *tmbuf;
STR ***retary;
+STR **sarg;
+int *ptrmaxsarg;
+int sargoff;
+int cushion;
{
register ARRAY *ary;
static ARRAY *myarray = Null(ARRAY*);
- register STR **sarg;
int max = 9;
register int i;
- STR *str;
ary = myarray;
if (!ary)
- myarray = ary = anew();
+ myarray = ary = anew(Nullstab);
ary->ary_fill = -1;
if (!tmbuf)
max = 0;
apush(ary,str_nmake((double)tmbuf->tm_yday));
apush(ary,str_nmake((double)tmbuf->tm_isdst));
}
- sarg = (STR**)safemalloc((max+2)*sizeof(STR*));
- sarg[0] = Nullstr;
- sarg[max+1] = Nullstr;
+ *ptrmaxsarg = max + sargoff;
+ sarg = (STR**)saferealloc((char*)(sarg - sargoff),
+ (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff;
for (i = 1; i <= max; i++)
sarg[i] = afetch(ary,i-1);
*retary = sarg;
for (t++; *sarg && *t && t != s; t++) {
switch (*t) {
case '\0':
+ t--;
break;
case '%':
ch = *(++t);
case 'D': case 'X': case 'O':
dolong = TRUE;
/* FALL THROUGH */
- case 'd': case 'x': case 'o': case 'c':
+ case 'd': case 'x': case 'o': case 'c': case 'u':
ch = *(++t);
*t = '\0';
if (dolong)
case 's':
ch = *(++t);
*t = '\0';
- sprintf(buf,s,str_get(*(sarg++)));
+ if (strEQ(s,"%s")) { /* some printfs fail on >128 chars */
+ *buf = '\0';
+ str_scat(str,*(sarg++)); /* so handle simple case */
+ }
+ else
+ sprintf(buf,s,str_get(*(sarg++)));
s = t;
*(t--) = ch;
break;
}
bool
-do_print(s,fp)
-char *s;
+do_print(str,fp)
+register STR *str;
FILE *fp;
{
- if (!fp || !s)
+ if (!fp) {
+ if (dowarn)
+ warn("print to unopened file");
+ return FALSE;
+ }
+ if (!str)
return FALSE;
- fputs(s,fp);
+ if (ofmt &&
+ ((str->str_nok && str->str_nval != 0.0) || str_gnum(str) != 0.0) )
+ fprintf(fp, ofmt, str->str_nval);
+ else
+ fputs(str_get(str),fp);
return TRUE;
}
STR **tmpary; /* must not be register */
register STR **elem;
register bool retval;
- double value;
+ register int items;
- (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
+ if (!fp) {
+ if (dowarn)
+ warn("print to unopened file");
+ return FALSE;
+ }
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1);
+ items = (int)str_gnum(*tmpary);
if (arg->arg_type == O_PRTF) {
- do_sprintf(arg->arg_ptr.arg_str,32767,tmpary);
- retval = do_print(str_get(arg->arg_ptr.arg_str),fp);
+ do_sprintf(arg->arg_ptr.arg_str,items,tmpary);
+ retval = do_print(arg->arg_ptr.arg_str,fp);
}
else {
retval = FALSE;
- for (elem = tmpary+1; *elem; elem++) {
+ for (elem = tmpary+1; items > 0; items--,elem++) {
if (retval && ofs)
- do_print(ofs, fp);
- if (ofmt && fp) {
- if ((*elem)->str_nok || str_gnum(*elem) != 0.0)
- fprintf(fp, ofmt, str_gnum(*elem));
- retval = TRUE;
- }
- else
- retval = do_print(str_get(*elem), fp);
+ fputs(ofs, fp);
+ retval = do_print(*elem, fp);
if (!retval)
break;
}
if (ors)
- retval = do_print(ors, fp);
+ fputs(ors, fp);
}
safefree((char*)tmpary);
return retval;
STR **tmpary; /* must not be register */
register STR **elem;
register char **a;
- register int i;
+ register int items;
char **argv;
- (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
- i = 0;
- for (elem = tmpary+1; *elem; elem++)
- i++;
- if (i) {
- argv = (char**)safemalloc((i+1)*sizeof(char*));
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1);
+ items = (int)str_gnum(*tmpary);
+ if (items) {
+ argv = (char**)safemalloc((items+1)*sizeof(char*));
a = argv;
- for (elem = tmpary+1; *elem; elem++) {
- *a++ = str_get(*elem);
+ for (elem = tmpary+1; items > 0; items--,elem++) {
+ if (*elem)
+ *a++ = str_get(*elem);
+ else
+ *a++ = "";
}
*a = Nullch;
execvp(argv[0],argv);
}
bool
-do_exec(cmd)
-char *cmd;
+do_exec(str)
+STR *str;
{
- STR **tmpary; /* must not be register */
register char **a;
register char *s;
char **argv;
+ char *cmd = str_get(str);
/* see if there are shell metacharacters in it */
for (s = cmd; *s; s++) {
if (*s != ' ' && !isalpha(*s) && index("$&*(){}[]'\";\\|?<>~`",*s)) {
- execl("/bin/sh","sh","-c",cmd,0);
+ execl("/bin/sh","sh","-c",cmd,(char*)0);
return FALSE;
}
}
STR **tmpary; /* must not be register */
register STR **elem;
register STR *str = &str_no;
+ register int items;
- (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
- for (elem = tmpary+1; *elem; elem++) {
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1);
+ items = (int)str_gnum(*tmpary);
+ for (elem = tmpary+1; items > 0; items--,elem++) {
str = str_new(0);
- str_sset(str,*elem);
+ if (*elem)
+ str_sset(str,*elem);
apush(ary,str);
}
safefree((char*)tmpary);
register STR **elem;
register STR *str = &str_no;
register int i;
+ register int items;
- (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
- i = 0;
- for (elem = tmpary+1; *elem; elem++)
- i++;
- aunshift(ary,i);
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1);
+ items = (int)str_gnum(*tmpary);
+ aunshift(ary,items);
i = 0;
- for (elem = tmpary+1; *elem; elem++) {
+ for (elem = tmpary+1; i < items; i++,elem++) {
str = str_new(0);
str_sset(str,*elem);
- astore(ary,i++,str);
+ astore(ary,i,str);
}
safefree((char*)tmpary);
}
{
STR **tmpary; /* must not be register */
register STR **elem;
- register int i;
+ register int items;
register int val;
register int val2;
+ char *s;
- if (sarg)
+ if (sarg) {
tmpary = sarg;
- else
- (void)eval(arg[1].arg_ptr.arg_arg,&tmpary);
- i = 0;
- for (elem = tmpary+1; *elem; elem++)
- i++;
+ items = 0;
+ for (elem = tmpary+1; *elem; elem++)
+ items++;
+ }
+ else {
+ (void)eval(arg[1].arg_ptr.arg_arg,&tmpary,-1);
+ items = (int)str_gnum(*tmpary);
+ }
switch (type) {
case O_CHMOD:
- if (--i > 0) {
+ if (--items > 0) {
val = (int)str_gnum(tmpary[1]);
for (elem = tmpary+2; *elem; elem++)
if (chmod(str_get(*elem),val))
- i--;
+ items--;
}
break;
case O_CHOWN:
- if (i > 2) {
- i -= 2;
+ if (items > 2) {
+ items -= 2;
val = (int)str_gnum(tmpary[1]);
val2 = (int)str_gnum(tmpary[2]);
for (elem = tmpary+3; *elem; elem++)
if (chown(str_get(*elem),val,val2))
- i--;
+ items--;
}
else
- i = 0;
+ items = 0;
break;
case O_KILL:
- if (--i > 0) {
+ if (--items > 0) {
val = (int)str_gnum(tmpary[1]);
- if (val < 0)
+ if (val < 0) {
val = -val;
- for (elem = tmpary+2; *elem; elem++)
- if (kill(atoi(str_get(*elem)),val))
- i--;
+ for (elem = tmpary+2; *elem; elem++)
+#ifdef KILLPG
+ if (killpg((int)(str_gnum(*elem)),val)) /* BSD */
+#else
+ if (kill(-(int)(str_gnum(*elem)),val)) /* SYSV */
+#endif
+ items--;
+ }
+ else {
+ for (elem = tmpary+2; *elem; elem++)
+ if (kill((int)(str_gnum(*elem)),val))
+ items--;
+ }
}
break;
case O_UNLINK:
- for (elem = tmpary+1; *elem; elem++)
- if (UNLINK(str_get(*elem)))
- i--;
+ for (elem = tmpary+1; *elem; elem++) {
+ s = str_get(*elem);
+ if (euid || unsafe) {
+ if (UNLINK(s))
+ items--;
+ }
+ else { /* don't let root wipe out directories without -U */
+ if (stat(s,&statbuf) < 0 ||
+ (statbuf.st_mode & S_IFMT) == S_IFDIR )
+ items--;
+ else {
+ if (UNLINK(s))
+ items--;
+ }
+ }
+ }
+ break;
+ case O_UTIME:
+ if (items > 2) {
+ struct {
+ long atime,
+ mtime;
+ } utbuf;
+
+ utbuf.atime = (long)str_gnum(tmpary[1]); /* time accessed */
+ utbuf.mtime = (long)str_gnum(tmpary[2]); /* time modified */
+ items -= 2;
+ for (elem = tmpary+3; *elem; elem++)
+ if (utime(str_get(*elem),&utbuf))
+ items--;
+ }
+ else
+ items = 0;
break;
}
if (!sarg)
safefree((char*)tmpary);
- return i;
+ return items;
}
STR *
do_subr(arg,sarg)
register ARG *arg;
-register char **sarg;
+register STR **sarg;
{
+ register SUBR *sub;
ARRAY *savearray;
STR *str;
+ STAB *stab;
+ char *oldfile = filename;
+ int oldsave = savestack->ary_fill;
+ int oldtmps_base = tmps_base;
+ if (arg[2].arg_type == A_WORD)
+ stab = arg[2].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(arg[2].arg_ptr.arg_stab->stab_val),TRUE);
+ if (!stab) {
+ if (dowarn)
+ warn("Undefined subroutine called");
+ return &str_no;
+ }
+ sub = stab->stab_sub;
+ if (!sub) {
+ if (dowarn)
+ warn("Undefined subroutine \"%s\" called", stab->stab_name);
+ return &str_no;
+ }
savearray = defstab->stab_array;
- defstab->stab_array = anew();
+ defstab->stab_array = anew(defstab);
if (arg[1].arg_flags & AF_SPECIAL)
(void)do_push(arg,defstab->stab_array);
else if (arg[1].arg_type != A_NULL) {
str_sset(str,sarg[1]);
apush(defstab->stab_array,str);
}
- str = cmd_exec(arg[2].arg_ptr.arg_stab->stab_sub);
+ sub->depth++;
+ if (sub->depth >= 2) { /* save temporaries on recursion? */
+ if (sub->depth == 100 && dowarn)
+ warn("Deep recursion on subroutine \"%s\"",stab->stab_name);
+ savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
+ }
+ filename = sub->filename;
+ tmps_base = tmps_max;
+
+ str = cmd_exec(sub->cmd); /* so do it already */
+
+ sub->depth--; /* assuming no longjumps out of here */
afree(defstab->stab_array); /* put back old $_[] */
defstab->stab_array = savearray;
+ filename = oldfile;
+ tmps_base = oldtmps_base;
+ if (savestack->ary_fill > oldsave) {
+ str = str_static(str); /* in case restore wipes old str */
+ restorelist(oldsave);
+ }
return str;
}
void
-do_assign(retstr,arg)
+do_assign(retstr,arg,sarg)
STR *retstr;
register ARG *arg;
+register STR **sarg;
{
STR **tmpary; /* must not be register */
register ARG *larg = arg[1].arg_ptr.arg_arg;
register STR *str;
register ARRAY *ary;
register int i;
- register int lasti;
- char *s;
+ register int items;
+ STR *tmpstr;
- (void)eval(arg[2].arg_ptr.arg_arg,&tmpary);
+ if (arg[2].arg_flags & AF_SPECIAL) {
+ (void)eval(arg[2].arg_ptr.arg_arg,&tmpary,-1);
+ items = (int)str_gnum(*tmpary);
+ }
+ else {
+ tmpary = sarg;
+ sarg[1] = sarg[2];
+ sarg[2] = Nullstr;
+ items = 1;
+ }
- if (arg->arg_flags & AF_COMMON) {
+ if (arg->arg_flags & AF_COMMON) { /* always true currently, alas */
if (*(tmpary+1)) {
- for (elem=tmpary+2; *elem; elem++) {
+ for (i=2,elem=tmpary+2; i <= items; i++,elem++) {
*elem = str_static(*elem);
}
}
}
if (larg->arg_type == O_LIST) {
- lasti = larg->arg_len;
- for (i=1,elem=tmpary+1; i <= lasti; i++) {
- if (*elem)
- s = str_get(*(elem++));
- else
- s = "";
+ for (i=1,elem=tmpary+1; i <= larg->arg_len; i++) {
switch (larg[i].arg_type) {
case A_STAB:
case A_LVAL:
str = STAB_STR(larg[i].arg_ptr.arg_stab);
break;
case A_LEXPR:
- str = eval(larg[i].arg_ptr.arg_arg,Null(STR***));
+ str = eval(larg[i].arg_ptr.arg_arg,Null(STR***),-1);
break;
}
- str_set(str,s);
+ if (larg->arg_flags & AF_LOCAL) {
+ apush(savestack,str); /* save pointer */
+ tmpstr = str_new(0);
+ str_sset(tmpstr,str);
+ apush(savestack,tmpstr); /* save value */
+ }
+ if (*elem)
+ str_sset(str,*(elem++));
+ else
+ str_set(str,"");
STABSET(str);
}
- i = elem - tmpary - 1;
}
else { /* should be an array name */
ary = larg[1].arg_ptr.arg_stab->stab_array;
- for (i=0,elem=tmpary+1; *elem; i++) {
+ for (i=0,elem=tmpary+1; i < items; i++) {
str = str_new(0);
if (*elem)
str_sset(str,*(elem++));
astore(ary,i,str);
}
- ary->ary_fill = i - 1; /* they can get the extra ones back by */
- } /* setting an element larger than old fill */
- str_numset(retstr,(double)i);
+ ary->ary_fill = items - 1;/* they can get the extra ones back by */
+ } /* setting $#ary larger than old fill */
+ str_numset(retstr,(double)items);
STABSET(retstr);
- safefree((char*)tmpary);
+ if (tmpary != sarg);
+ safefree((char*)tmpary);
}
int
-do_kv(hash,kv,sarg,retary)
+do_kv(hash,kv,retary,sarg,ptrmaxsarg,sargoff,cushion)
HASH *hash;
int kv;
-register STR **sarg;
STR ***retary;
+register STR **sarg;
+int *ptrmaxsarg;
+int sargoff;
+int cushion;
{
register ARRAY *ary;
int max = 0;
ary = myarray;
if (!ary)
- myarray = ary = anew();
+ myarray = ary = anew(Nullstab);
ary->ary_fill = -1;
hiterinit(hash);
apush(ary,str_make(str_get(hiterval(entry))));
}
if (retary) { /* array wanted */
- sarg = (STR**)saferealloc((char*)sarg,(max+2)*sizeof(STR*));
- sarg[0] = Nullstr;
- sarg[max+1] = Nullstr;
+ *ptrmaxsarg = max + sargoff;
+ sarg = (STR**)saferealloc((char*)(sarg - sargoff),
+ (max+2+cushion+sargoff)*sizeof(STR*)) + sargoff;
for (i = 1; i <= max; i++)
sarg[i] = afetch(ary,i-1);
*retary = sarg;
}
STR *
-do_each(hash,sarg,retary)
+do_each(hash,retary,sarg,ptrmaxsarg,sargoff,cushion)
HASH *hash;
-register STR **sarg;
STR ***retary;
+STR **sarg;
+int *ptrmaxsarg;
+int sargoff;
+int cushion;
{
static STR *mystr = Nullstr;
STR *retstr;
if (retary) { /* array wanted */
if (entry) {
- sarg = (STR**)saferealloc((char*)sarg,4*sizeof(STR*));
- sarg[0] = Nullstr;
- sarg[3] = Nullstr;
+ *ptrmaxsarg = 2 + sargoff;
+ sarg = (STR**)saferealloc((char*)(sarg - sargoff),
+ (2+2+cushion+sargoff)*sizeof(STR*)) + sargoff;
sarg[1] = mystr = str_make(hiterkey(entry));
retstr = sarg[2] = hiterval(entry);
*retary = sarg;
}
else {
- sarg = (STR**)saferealloc((char*)sarg,2*sizeof(STR*));
- sarg[0] = Nullstr;
- sarg[1] = retstr = Nullstr;
+ *ptrmaxsarg = sargoff;
+ sarg = (STR**)saferealloc((char*)(sarg - sargoff),
+ (2+cushion+sargoff)*sizeof(STR*)) + sargoff;
+ retstr = Nullstr;
*retary = sarg;
}
}
return retstr;
}
-init_eval()
+int
+mystat(arg,str)
+ARG *arg;
+STR *str;
{
- register int i;
+ STIO *stio;
-#define A(e1,e2,e3) (e1+(e2<<1)+(e3<<2))
- opargs[O_ITEM] = A(1,0,0);
- opargs[O_ITEM2] = A(0,0,0);
- opargs[O_ITEM3] = A(0,0,0);
- opargs[O_CONCAT] = A(1,1,0);
- opargs[O_MATCH] = A(1,0,0);
- opargs[O_NMATCH] = A(1,0,0);
- opargs[O_SUBST] = A(1,0,0);
- opargs[O_NSUBST] = A(1,0,0);
- opargs[O_ASSIGN] = A(1,1,0);
- opargs[O_MULTIPLY] = A(1,1,0);
- opargs[O_DIVIDE] = A(1,1,0);
- opargs[O_MODULO] = A(1,1,0);
- opargs[O_ADD] = A(1,1,0);
- opargs[O_SUBTRACT] = A(1,1,0);
- opargs[O_LEFT_SHIFT] = A(1,1,0);
- opargs[O_RIGHT_SHIFT] = A(1,1,0);
- opargs[O_LT] = A(1,1,0);
- opargs[O_GT] = A(1,1,0);
- opargs[O_LE] = A(1,1,0);
- opargs[O_GE] = A(1,1,0);
- opargs[O_EQ] = A(1,1,0);
+ if (arg[1].arg_flags & AF_SPECIAL) {
+ stio = arg[1].arg_ptr.arg_stab->stab_io;
+ if (stio && stio->fp)
+ return fstat(fileno(stio->fp), &statbuf);
+ else {
+ if (dowarn)
+ warn("Stat on unopened file <%s>",
+ arg[1].arg_ptr.arg_stab->stab_name);
+ return -1;
+ }
+ }
+ else
+ return stat(str_get(str),&statbuf);
+}
+
+STR *
+do_fttext(arg,str)
+register ARG *arg;
+STR *str;
+{
+ int i;
+ int len;
+ int odd = 0;
+ STDCHAR tbuf[512];
+ register STDCHAR *s;
+ register STIO *stio;
+
+ if (arg[1].arg_flags & AF_SPECIAL) {
+ stio = arg[1].arg_ptr.arg_stab->stab_io;
+ if (stio && stio->fp) {
+#ifdef STDSTDIO
+ if (stio->fp->_cnt <= 0) {
+ i = getc(stio->fp);
+ ungetc(i,stio->fp);
+ }
+ if (stio->fp->_cnt <= 0) /* null file is anything */
+ return &str_yes;
+ len = stio->fp->_cnt + (stio->fp->_ptr - stio->fp->_base);
+ s = stio->fp->_base;
+#else
+ fatal("-T and -B not implemented on filehandles\n");
+#endif
+ }
+ else {
+ if (dowarn)
+ warn("Test on unopened file <%s>",
+ arg[1].arg_ptr.arg_stab->stab_name);
+ return &str_no;
+ }
+ }
+ else {
+ i = open(str_get(str),0);
+ if (i < 0)
+ return &str_no;
+ len = read(i,tbuf,512);
+ if (len <= 0) /* null file is anything */
+ return &str_yes;
+ close(i);
+ s = tbuf;
+ }
+
+ /* now scan s to look for textiness */
+
+ for (i = 0; i < len; i++,s++) {
+ if (!*s) { /* null never allowed in text */
+ odd += len;
+ break;
+ }
+ else if (*s & 128)
+ odd++;
+ else if (*s < 32 &&
+ *s != '\n' && *s != '\r' && *s != '\b' &&
+ *s != '\t' && *s != '\f' && *s != 27)
+ odd++;
+ }
+
+ if ((odd * 10 > len) == (arg->arg_type == O_FTTEXT)) /* allow 10% odd */
+ return &str_no;
+ else
+ return &str_yes;
+}
+
+int
+do_study(str)
+STR *str;
+{
+ register char *s = str_get(str);
+ register int pos = str->str_cur;
+ register int ch;
+ register int *sfirst;
+ register int *snext;
+ static int maxscream = -1;
+ static STR *lastscream = Nullstr;
+
+ if (lastscream && lastscream->str_pok == 5)
+ lastscream->str_pok &= ~4;
+ lastscream = str;
+ if (pos <= 0)
+ return 0;
+ if (pos > maxscream) {
+ if (maxscream < 0) {
+ maxscream = pos + 80;
+ screamfirst = (int*)safemalloc((MEM_SIZE)(256 * sizeof(int)));
+ screamnext = (int*)safemalloc((MEM_SIZE)(maxscream * sizeof(int)));
+ }
+ else {
+ maxscream = pos + pos / 4;
+ screamnext = (int*)saferealloc((char*)screamnext,
+ (MEM_SIZE)(maxscream * sizeof(int)));
+ }
+ }
+
+ sfirst = screamfirst;
+ snext = screamnext;
+
+ if (!sfirst || !snext)
+ fatal("do_study: out of memory");
+
+ for (ch = 256; ch; --ch)
+ *sfirst++ = -1;
+ sfirst -= 256;
+
+ while (--pos >= 0) {
+ ch = s[pos];
+ if (sfirst[ch] >= 0)
+ snext[pos] = sfirst[ch] - pos;
+ else
+ snext[pos] = -pos;
+ sfirst[ch] = pos;
+ }
+
+ str->str_pok |= 4;
+ return 1;
+}
+
+init_eval()
+{
+#define A(e1,e2,e3) (e1+(e2<<1)+(e3<<2))
+ opargs[O_ITEM] = A(1,0,0);
+ opargs[O_ITEM2] = A(0,0,0);
+ opargs[O_ITEM3] = A(0,0,0);
+ opargs[O_CONCAT] = A(1,1,0);
+ opargs[O_MATCH] = A(1,0,0);
+ opargs[O_NMATCH] = A(1,0,0);
+ opargs[O_SUBST] = A(1,0,0);
+ opargs[O_NSUBST] = A(1,0,0);
+ opargs[O_ASSIGN] = A(1,1,0);
+ opargs[O_MULTIPLY] = A(1,1,0);
+ opargs[O_DIVIDE] = A(1,1,0);
+ opargs[O_MODULO] = A(1,1,0);
+ opargs[O_ADD] = A(1,1,0);
+ opargs[O_SUBTRACT] = A(1,1,0);
+ opargs[O_LEFT_SHIFT] = A(1,1,0);
+ opargs[O_RIGHT_SHIFT] = A(1,1,0);
+ opargs[O_LT] = A(1,1,0);
+ opargs[O_GT] = A(1,1,0);
+ opargs[O_LE] = A(1,1,0);
+ opargs[O_GE] = A(1,1,0);
+ opargs[O_EQ] = A(1,1,0);
opargs[O_NE] = A(1,1,0);
opargs[O_BIT_AND] = A(1,1,0);
opargs[O_XOR] = A(1,1,0);
opargs[O_SEQ] = A(1,1,0);
opargs[O_SNE] = A(1,1,0);
opargs[O_SUBR] = A(1,0,0);
- opargs[O_PRINT] = A(1,0,0);
+ opargs[O_PRINT] = A(1,1,0);
opargs[O_CHDIR] = A(1,0,0);
opargs[O_DIE] = A(1,0,0);
opargs[O_EXIT] = A(1,0,0);
opargs[O_RESET] = A(1,0,0);
opargs[O_LIST] = A(0,0,0);
- opargs[O_EOF] = A(0,0,0);
- opargs[O_TELL] = A(0,0,0);
- opargs[O_SEEK] = A(0,1,1);
+ opargs[O_EOF] = A(1,0,0);
+ opargs[O_TELL] = A(1,0,0);
+ opargs[O_SEEK] = A(1,1,1);
opargs[O_LAST] = A(1,0,0);
opargs[O_NEXT] = A(1,0,0);
opargs[O_REDO] = A(1,0,0);
opargs[O_LOG] = A(1,0,0);
opargs[O_SQRT] = A(1,0,0);
opargs[O_INT] = A(1,0,0);
- opargs[O_PRTF] = A(1,0,0);
+ opargs[O_PRTF] = A(1,1,0);
opargs[O_ORD] = A(1,0,0);
opargs[O_SLEEP] = A(1,0,0);
opargs[O_FLIP] = A(1,0,0);
opargs[O_LINK] = A(1,1,0);
opargs[O_REPEAT] = A(1,1,0);
opargs[O_EVAL] = A(1,0,0);
-}
-
-#ifdef VOIDSIG
-static void (*ihand)();
-static void (*qhand)();
-#else
-static int (*ihand)();
-static int (*qhand)();
-#endif
-
-STR *
-eval(arg,retary)
-register ARG *arg;
-STR ***retary; /* where to return an array to, null if nowhere */
-{
- register STR *str;
- register int anum;
- register int optype;
- register int maxarg;
- double value;
- STR *quicksarg[5];
- register STR **sarg = quicksarg;
- register char *tmps;
- char *tmps2;
- int argflags;
- long tmplong;
- FILE *fp;
- STR *tmpstr;
- FCMD *form;
- STAB *stab;
- ARRAY *ary;
- bool assigning = FALSE;
- double exp(), log(), sqrt(), modf();
- char *crypt(), *getenv();
-
- if (!arg)
- return &str_no;
- str = arg->arg_ptr.arg_str;
- optype = arg->arg_type;
- maxarg = arg->arg_len;
- if (maxarg > 3 || retary) {
- sarg = (STR **)safemalloc((maxarg+2) * sizeof(STR*));
- }
-#ifdef DEBUGGING
- if (debug & 8) {
- deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg);
- }
- debname[dlevel] = opname[optype][0];
- debdelim[dlevel++] = ':';
-#endif
- for (anum = 1; anum <= maxarg; anum++) {
- argflags = arg[anum].arg_flags;
- if (argflags & AF_SPECIAL)
- continue;
- re_eval:
- switch (arg[anum].arg_type) {
- default:
- sarg[anum] = &str_no;
-#ifdef DEBUGGING
- tmps = "NULL";
-#endif
- break;
- case A_EXPR:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "EXPR";
- deb("%d.EXPR =>\n",anum);
- }
-#endif
- sarg[anum] = eval(arg[anum].arg_ptr.arg_arg, Null(STR***));
- break;
- case A_CMD:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "CMD";
- deb("%d.CMD (%lx) =>\n",anum,arg[anum].arg_ptr.arg_cmd);
- }
-#endif
- sarg[anum] = cmd_exec(arg[anum].arg_ptr.arg_cmd);
- break;
- case A_STAB:
- sarg[anum] = STAB_STR(arg[anum].arg_ptr.arg_stab);
-#ifdef DEBUGGING
- if (debug & 8) {
- sprintf(buf,"STAB $%s ==",arg[anum].arg_ptr.arg_stab->stab_name);
- tmps = buf;
- }
-#endif
- break;
- case A_LEXPR:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "LEXPR";
- deb("%d.LEXPR =>\n",anum);
- }
-#endif
- str = eval(arg[anum].arg_ptr.arg_arg,Null(STR***));
- if (!str)
- fatal("panic: A_LEXPR\n");
- goto do_crement;
- case A_LVAL:
-#ifdef DEBUGGING
- if (debug & 8) {
- sprintf(buf,"LVAL $%s ==",arg[anum].arg_ptr.arg_stab->stab_name);
- tmps = buf;
- }
-#endif
- str = STAB_STR(arg[anum].arg_ptr.arg_stab);
- if (!str)
- fatal("panic: A_LVAL\n");
- do_crement:
- assigning = TRUE;
- if (argflags & AF_PRE) {
- if (argflags & AF_UP)
- str_inc(str);
- else
- str_dec(str);
- STABSET(str);
- sarg[anum] = str;
- str = arg->arg_ptr.arg_str;
- }
- else if (argflags & AF_POST) {
- sarg[anum] = str_static(str);
- if (argflags & AF_UP)
- str_inc(str);
- else
- str_dec(str);
- STABSET(str);
- str = arg->arg_ptr.arg_str;
- }
- else {
- sarg[anum] = str;
- }
- break;
- case A_ARYLEN:
- sarg[anum] = str_static(&str_no);
- str_numset(sarg[anum],
- (double)alen(arg[anum].arg_ptr.arg_stab->stab_array));
-#ifdef DEBUGGING
- tmps = "ARYLEN";
-#endif
- break;
- case A_SINGLE:
- sarg[anum] = arg[anum].arg_ptr.arg_str;
-#ifdef DEBUGGING
- tmps = "SINGLE";
-#endif
- break;
- case A_DOUBLE:
- (void) interp(str,str_get(arg[anum].arg_ptr.arg_str));
- sarg[anum] = str;
-#ifdef DEBUGGING
- tmps = "DOUBLE";
-#endif
- break;
- case A_BACKTICK:
- tmps = str_get(arg[anum].arg_ptr.arg_str);
- fp = popen(str_get(interp(str,tmps)),"r");
- tmpstr = str_new(80);
- str_set(str,"");
- if (fp) {
- while (str_gets(tmpstr,fp) != Nullch) {
- str_scat(str,tmpstr);
- }
- statusvalue = pclose(fp);
- }
- else
- statusvalue = -1;
- str_free(tmpstr);
-
- sarg[anum] = str;
-#ifdef DEBUGGING
- tmps = "BACK";
-#endif
- break;
- case A_READ:
- fp = Nullfp;
- last_in_stab = arg[anum].arg_ptr.arg_stab;
- if (last_in_stab->stab_io) {
- fp = last_in_stab->stab_io->fp;
- if (!fp && (last_in_stab->stab_io->flags & IOF_ARGV)) {
- if (last_in_stab->stab_io->flags & IOF_START) {
- last_in_stab->stab_io->flags &= ~IOF_START;
- last_in_stab->stab_io->lines = 0;
- if (alen(last_in_stab->stab_array) < 0L) {
- tmpstr = str_make("-"); /* assume stdin */
- apush(last_in_stab->stab_array, tmpstr);
- }
- }
- fp = nextargv(last_in_stab);
- if (!fp) /* Note: fp != last_in_stab->stab_io->fp */
- do_close(last_in_stab,FALSE); /* now it does */
- }
- }
- keepgoing:
- if (!fp)
- sarg[anum] = &str_no;
- else if (!str_gets(str,fp)) {
- if (last_in_stab->stab_io->flags & IOF_ARGV) {
- fp = nextargv(last_in_stab);
- if (fp)
- goto keepgoing;
- do_close(last_in_stab,FALSE);
- last_in_stab->stab_io->flags |= IOF_START;
- }
- if (fp == stdin) {
- clearerr(fp);
- }
- sarg[anum] = &str_no;
- break;
- }
- else {
- last_in_stab->stab_io->lines++;
- sarg[anum] = str;
- }
-#ifdef DEBUGGING
- tmps = "READ";
-#endif
- break;
- }
-#ifdef DEBUGGING
- if (debug & 8)
- deb("%d.%s = '%s'\n",anum,tmps,str_peek(sarg[anum]));
-#endif
- }
- switch (optype) {
- case O_ITEM:
- if (str != sarg[1])
- str_sset(str,sarg[1]);
- STABSET(str);
- break;
- case O_ITEM2:
- if (str != sarg[2])
- str_sset(str,sarg[2]);
- STABSET(str);
- break;
- case O_ITEM3:
- if (str != sarg[3])
- str_sset(str,sarg[3]);
- STABSET(str);
- break;
- case O_CONCAT:
- if (str != sarg[1])
- str_sset(str,sarg[1]);
- str_scat(str,sarg[2]);
- STABSET(str);
- break;
- case O_REPEAT:
- if (str != sarg[1])
- str_sset(str,sarg[1]);
- anum = (long)str_gnum(sarg[2]);
- if (anum >= 1) {
- tmpstr = str_new(0);
- str_sset(tmpstr,str);
- for (anum--; anum; anum--)
- str_scat(str,tmpstr);
- }
- else
- str_sset(str,&str_no);
- STABSET(str);
- break;
- case O_MATCH:
- str_set(str, do_match(str_get(sarg[1]),arg) ? Yes : No);
- STABSET(str);
- break;
- case O_NMATCH:
- str_set(str, do_match(str_get(sarg[1]),arg) ? No : Yes);
- STABSET(str);
- break;
- case O_SUBST:
- value = (double) do_subst(str, arg);
- str = arg->arg_ptr.arg_str;
- goto donumset;
- case O_NSUBST:
- str_set(arg->arg_ptr.arg_str, do_subst(str, arg) ? No : Yes);
- str = arg->arg_ptr.arg_str;
- break;
- case O_ASSIGN:
- if (arg[2].arg_flags & AF_SPECIAL)
- do_assign(str,arg);
- else {
- if (str != sarg[2])
- str_sset(str, sarg[2]);
- STABSET(str);
- }
- break;
- case O_CHOP:
- tmps = str_get(str);
- tmps += str->str_cur - (str->str_cur != 0);
- str_set(arg->arg_ptr.arg_str,tmps); /* remember last char */
- *tmps = '\0'; /* wipe it out */
- str->str_cur = tmps - str->str_ptr;
- str->str_nok = 0;
- str = arg->arg_ptr.arg_str;
- break;
- case O_MULTIPLY:
- value = str_gnum(sarg[1]);
- value *= str_gnum(sarg[2]);
- goto donumset;
- case O_DIVIDE:
- value = str_gnum(sarg[1]);
- value /= str_gnum(sarg[2]);
- goto donumset;
- case O_MODULO:
- value = str_gnum(sarg[1]);
- value = (double)(((long)value) % (long)str_gnum(sarg[2]));
- goto donumset;
- case O_ADD:
- value = str_gnum(sarg[1]);
- value += str_gnum(sarg[2]);
- goto donumset;
- case O_SUBTRACT:
- value = str_gnum(sarg[1]);
- value -= str_gnum(sarg[2]);
- goto donumset;
- case O_LEFT_SHIFT:
- value = str_gnum(sarg[1]);
- value = (double)(((long)value) << (long)str_gnum(sarg[2]));
- goto donumset;
- case O_RIGHT_SHIFT:
- value = str_gnum(sarg[1]);
- value = (double)(((long)value) >> (long)str_gnum(sarg[2]));
- goto donumset;
- case O_LT:
- value = str_gnum(sarg[1]);
- value = (double)(value < str_gnum(sarg[2]));
- goto donumset;
- case O_GT:
- value = str_gnum(sarg[1]);
- value = (double)(value > str_gnum(sarg[2]));
- goto donumset;
- case O_LE:
- value = str_gnum(sarg[1]);
- value = (double)(value <= str_gnum(sarg[2]));
- goto donumset;
- case O_GE:
- value = str_gnum(sarg[1]);
- value = (double)(value >= str_gnum(sarg[2]));
- goto donumset;
- case O_EQ:
- value = str_gnum(sarg[1]);
- value = (double)(value == str_gnum(sarg[2]));
- goto donumset;
- case O_NE:
- value = str_gnum(sarg[1]);
- value = (double)(value != str_gnum(sarg[2]));
- goto donumset;
- case O_BIT_AND:
- value = str_gnum(sarg[1]);
- value = (double)(((long)value) & (long)str_gnum(sarg[2]));
- goto donumset;
- case O_XOR:
- value = str_gnum(sarg[1]);
- value = (double)(((long)value) ^ (long)str_gnum(sarg[2]));
- goto donumset;
- case O_BIT_OR:
- value = str_gnum(sarg[1]);
- value = (double)(((long)value) | (long)str_gnum(sarg[2]));
- goto donumset;
- case O_AND:
- if (str_true(sarg[1])) {
- anum = 2;
- optype = O_ITEM2;
- maxarg = 0;
- argflags = arg[anum].arg_flags;
- goto re_eval;
- }
- else {
- if (assigning) {
- str_sset(str, sarg[1]);
- STABSET(str);
- }
- else
- str = sarg[1];
- break;
- }
- case O_OR:
- if (str_true(sarg[1])) {
- if (assigning) {
- str_set(str, sarg[1]);
- STABSET(str);
- }
- else
- str = sarg[1];
- break;
- }
- else {
- anum = 2;
- optype = O_ITEM2;
- maxarg = 0;
- argflags = arg[anum].arg_flags;
- goto re_eval;
- }
- case O_COND_EXPR:
- anum = (str_true(sarg[1]) ? 2 : 3);
- optype = (anum == 2 ? O_ITEM2 : O_ITEM3);
- maxarg = 0;
- argflags = arg[anum].arg_flags;
- goto re_eval;
- case O_COMMA:
- str = sarg[2];
- break;
- case O_NEGATE:
- value = -str_gnum(sarg[1]);
- goto donumset;
- case O_NOT:
- value = (double) !str_true(sarg[1]);
- goto donumset;
- case O_COMPLEMENT:
- value = (double) ~(long)str_gnum(sarg[1]);
- goto donumset;
- case O_SELECT:
- if (arg[1].arg_type == A_LVAL)
- defoutstab = arg[1].arg_ptr.arg_stab;
- else
- defoutstab = stabent(str_get(sarg[1]),TRUE);
- if (!defoutstab->stab_io)
- defoutstab->stab_io = stio_new();
- curoutstab = defoutstab;
- str_set(str,curoutstab->stab_io->fp ? Yes : No);
- STABSET(str);
- break;
- case O_WRITE:
- if (maxarg == 0)
- stab = defoutstab;
- else if (arg[1].arg_type == A_LVAL)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(sarg[1]),TRUE);
- if (!stab->stab_io) {
- str_set(str, No);
- STABSET(str);
- break;
- }
- curoutstab = stab;
- fp = stab->stab_io->fp;
- debarg = arg;
- if (stab->stab_io->fmt_stab)
- form = stab->stab_io->fmt_stab->stab_form;
- else
- form = stab->stab_form;
- if (!form || !fp) {
- str_set(str, No);
- STABSET(str);
- break;
- }
- format(&outrec,form);
- do_write(&outrec,stab->stab_io);
- if (stab->stab_io->flags & IOF_FLUSH)
- fflush(fp);
- str_set(str, Yes);
- STABSET(str);
- break;
- case O_OPEN:
- if (do_open(arg[1].arg_ptr.arg_stab,str_get(sarg[2]))) {
- str_set(str, Yes);
- arg[1].arg_ptr.arg_stab->stab_io->lines = 0;
- }
- else
- str_set(str, No);
- STABSET(str);
- break;
- case O_TRANS:
- value = (double) do_trans(str,arg);
- str = arg->arg_ptr.arg_str;
- goto donumset;
- case O_NTRANS:
- str_set(arg->arg_ptr.arg_str, do_trans(str,arg) == 0 ? Yes : No);
- str = arg->arg_ptr.arg_str;
- break;
- case O_CLOSE:
- str_set(str,
- do_close(arg[1].arg_ptr.arg_stab,TRUE) ? Yes : No );
- STABSET(str);
- break;
- case O_EACH:
- str_sset(str,do_each(arg[1].arg_ptr.arg_stab->stab_hash,sarg,retary));
- retary = Null(STR***); /* do_each already did retary */
- STABSET(str);
- break;
- case O_VALUES:
- case O_KEYS:
- value = (double) do_kv(arg[1].arg_ptr.arg_stab->stab_hash,
- optype,sarg,retary);
- retary = Null(STR***); /* do_keys already did retary */
- goto donumset;
- case O_ARRAY:
- if (maxarg == 1) {
- ary = arg[1].arg_ptr.arg_stab->stab_array;
- maxarg = ary->ary_fill;
- if (retary) { /* array wanted */
- sarg =
- (STR **)saferealloc((char*)sarg,(maxarg+3)*sizeof(STR*));
- for (anum = 0; anum <= maxarg; anum++) {
- sarg[anum+1] = str = afetch(ary,anum);
- }
- maxarg++;
- }
- else
- str = afetch(ary,maxarg);
- }
- else
- str = afetch(arg[2].arg_ptr.arg_stab->stab_array,
- ((int)str_gnum(sarg[1])) - arybase);
- if (!str)
- return &str_no;
- break;
- case O_HASH:
- tmpstab = arg[2].arg_ptr.arg_stab; /* XXX */
- str = hfetch(tmpstab->stab_hash,str_get(sarg[1]));
- if (!str)
- return &str_no;
- break;
- case O_LARRAY:
- anum = ((int)str_gnum(sarg[1])) - arybase;
- str = afetch(arg[2].arg_ptr.arg_stab->stab_array,anum);
- if (!str || str == &str_no) {
- str = str_new(0);
- astore(arg[2].arg_ptr.arg_stab->stab_array,anum,str);
- }
- break;
- case O_LHASH:
- tmpstab = arg[2].arg_ptr.arg_stab;
- str = hfetch(tmpstab->stab_hash,str_get(sarg[1]));
- if (!str) {
- str = str_new(0);
- hstore(tmpstab->stab_hash,str_get(sarg[1]),str);
- }
- if (tmpstab == envstab) { /* heavy wizardry going on here */
- str->str_link.str_magic = tmpstab;/* str is now magic */
- envname = savestr(str_get(sarg[1]));
- /* he threw the brick up into the air */
- }
- else if (tmpstab == sigstab) { /* same thing, only different */
- str->str_link.str_magic = tmpstab;
- signame = savestr(str_get(sarg[1]));
- }
- break;
- case O_PUSH:
- if (arg[1].arg_flags & AF_SPECIAL)
- str = do_push(arg,arg[2].arg_ptr.arg_stab->stab_array);
- else {
- str = str_new(0); /* must copy the STR */
- str_sset(str,sarg[1]);
- apush(arg[2].arg_ptr.arg_stab->stab_array,str);
- }
- break;
- case O_POP:
- str = apop(arg[1].arg_ptr.arg_stab->stab_array);
- if (!str)
- return &str_no;
-#ifdef STRUCTCOPY
- *(arg->arg_ptr.arg_str) = *str;
-#else
- bcopy((char*)str, (char*)arg->arg_ptr.arg_str, sizeof *str);
-#endif
- safefree((char*)str);
- str = arg->arg_ptr.arg_str;
- break;
- case O_SHIFT:
- str = ashift(arg[1].arg_ptr.arg_stab->stab_array);
- if (!str)
- return &str_no;
-#ifdef STRUCTCOPY
- *(arg->arg_ptr.arg_str) = *str;
-#else
- bcopy((char*)str, (char*)arg->arg_ptr.arg_str, sizeof *str);
-#endif
- safefree((char*)str);
- str = arg->arg_ptr.arg_str;
- break;
- case O_SPLIT:
- value = (double) do_split(str_get(sarg[1]),arg[2].arg_ptr.arg_spat,retary);
- retary = Null(STR***); /* do_split already did retary */
- goto donumset;
- case O_LENGTH:
- value = (double) str_len(sarg[1]);
- goto donumset;
- case O_SPRINTF:
- sarg[maxarg+1] = Nullstr;
- do_sprintf(str,arg->arg_len,sarg);
- break;
- case O_SUBSTR:
- anum = ((int)str_gnum(sarg[2])) - arybase;
- for (tmps = str_get(sarg[1]); *tmps && anum > 0; tmps++,anum--) ;
- anum = (int)str_gnum(sarg[3]);
- if (anum >= 0 && strlen(tmps) > anum)
- str_nset(str, tmps, anum);
- else
- str_set(str, tmps);
- break;
- case O_JOIN:
- if (arg[2].arg_flags & AF_SPECIAL && arg[2].arg_type == A_EXPR)
- do_join(arg,str_get(sarg[1]),str);
- else
- ajoin(arg[2].arg_ptr.arg_stab->stab_array,str_get(sarg[1]),str);
- break;
- case O_SLT:
- tmps = str_get(sarg[1]);
- value = (double) strLT(tmps,str_get(sarg[2]));
- goto donumset;
- case O_SGT:
- tmps = str_get(sarg[1]);
- value = (double) strGT(tmps,str_get(sarg[2]));
- goto donumset;
- case O_SLE:
- tmps = str_get(sarg[1]);
- value = (double) strLE(tmps,str_get(sarg[2]));
- goto donumset;
- case O_SGE:
- tmps = str_get(sarg[1]);
- value = (double) strGE(tmps,str_get(sarg[2]));
- goto donumset;
- case O_SEQ:
- tmps = str_get(sarg[1]);
- value = (double) strEQ(tmps,str_get(sarg[2]));
- goto donumset;
- case O_SNE:
- tmps = str_get(sarg[1]);
- value = (double) strNE(tmps,str_get(sarg[2]));
- goto donumset;
- case O_SUBR:
- str_sset(str,do_subr(arg,sarg));
- STABSET(str);
- break;
- case O_PRTF:
- case O_PRINT:
- if (maxarg <= 1)
- stab = defoutstab;
- else {
- stab = arg[2].arg_ptr.arg_stab;
- if (!stab)
- stab = defoutstab;
- }
- if (!stab->stab_io)
- value = 0.0;
- else if (arg[1].arg_flags & AF_SPECIAL)
- value = (double)do_aprint(arg,stab->stab_io->fp);
- else {
- value = (double)do_print(str_get(sarg[1]),stab->stab_io->fp);
- if (ors && optype == O_PRINT)
- do_print(ors, stab->stab_io->fp);
- }
- if (stab->stab_io->flags & IOF_FLUSH)
- fflush(stab->stab_io->fp);
- goto donumset;
- case O_CHDIR:
- tmps = str_get(sarg[1]);
- if (!tmps || !*tmps)
- tmps = getenv("HOME");
- if (!tmps || !*tmps)
- tmps = getenv("LOGDIR");
- value = (double)(chdir(tmps) >= 0);
- goto donumset;
- case O_DIE:
- tmps = str_get(sarg[1]);
- if (!tmps || !*tmps)
- exit(1);
- fatal("%s\n",str_get(sarg[1]));
- value = 0.0;
- goto donumset;
- case O_EXIT:
- exit((int)str_gnum(sarg[1]));
- value = 0.0;
- goto donumset;
- case O_RESET:
- str_reset(str_get(sarg[1]));
- value = 1.0;
- goto donumset;
- case O_LIST:
- if (maxarg > 0)
- str = sarg[maxarg]; /* unwanted list, return last item */
- else
- str = &str_no;
- break;
- case O_EOF:
- str_set(str, do_eof(maxarg > 0 ? arg[1].arg_ptr.arg_stab : last_in_stab) ? Yes : No);
- STABSET(str);
- break;
- case O_TELL:
- value = (double)do_tell(maxarg > 0 ? arg[1].arg_ptr.arg_stab : last_in_stab);
- goto donumset;
- break;
- case O_SEEK:
- value = str_gnum(sarg[2]);
- str_set(str, do_seek(arg[1].arg_ptr.arg_stab,
- (long)value, (int)str_gnum(sarg[3]) ) ? Yes : No);
- STABSET(str);
- break;
- case O_REDO:
- case O_NEXT:
- case O_LAST:
- if (maxarg > 0) {
- tmps = str_get(sarg[1]);
- while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label ||
- strNE(tmps,loop_stack[loop_ptr].loop_label) )) {
-#ifdef DEBUGGING
- if (debug & 4) {
- deb("(Skipping label #%d %s)\n",loop_ptr,
- loop_stack[loop_ptr].loop_label);
- }
-#endif
- loop_ptr--;
- }
-#ifdef DEBUGGING
- if (debug & 4) {
- deb("(Found label #%d %s)\n",loop_ptr,
- loop_stack[loop_ptr].loop_label);
- }
-#endif
- }
- if (loop_ptr < 0)
- fatal("Bad label: %s\n", maxarg > 0 ? tmps : "<null>");
- longjmp(loop_stack[loop_ptr].loop_env, optype);
- case O_GOTO:/* shudder */
- goto_targ = str_get(sarg[1]);
- longjmp(top_env, 1);
- case O_INDEX:
- tmps = str_get(sarg[1]);
- if (!(tmps2 = instr(tmps,str_get(sarg[2]))))
- value = (double)(-1 + arybase);
- else
- value = (double)(tmps2 - tmps + arybase);
- goto donumset;
- case O_TIME:
- value = (double) time(0);
- goto donumset;
- case O_TMS:
- value = (double) do_tms(retary);
- retary = Null(STR***); /* do_tms already did retary */
- goto donumset;
- case O_LOCALTIME:
- tmplong = (long) str_gnum(sarg[1]);
- value = (double) do_time(localtime(&tmplong),retary);
- retary = Null(STR***); /* do_localtime already did retary */
- goto donumset;
- case O_GMTIME:
- tmplong = (long) str_gnum(sarg[1]);
- value = (double) do_time(gmtime(&tmplong),retary);
- retary = Null(STR***); /* do_gmtime already did retary */
- goto donumset;
- case O_STAT:
- value = (double) do_stat(arg,sarg,retary);
- retary = Null(STR***); /* do_stat already did retary */
- goto donumset;
- case O_CRYPT:
-#ifdef CRYPT
- tmps = str_get(sarg[1]);
- str_set(str,crypt(tmps,str_get(sarg[2])));
-#else
- fatal(
- "The crypt() function is unimplemented due to excessive paranoia.");
-#endif
- break;
- case O_EXP:
- value = exp(str_gnum(sarg[1]));
- goto donumset;
- case O_LOG:
- value = log(str_gnum(sarg[1]));
- goto donumset;
- case O_SQRT:
- value = sqrt(str_gnum(sarg[1]));
- goto donumset;
- case O_INT:
- modf(str_gnum(sarg[1]),&value);
- goto donumset;
- case O_ORD:
- value = (double) *str_get(sarg[1]);
- goto donumset;
- case O_SLEEP:
- tmps = str_get(sarg[1]);
- time(&tmplong);
- if (!tmps || !*tmps)
- sleep((32767<<16)+32767);
- else
- sleep(atoi(tmps));
- value = (double)tmplong;
- time(&tmplong);
- value = ((double)tmplong) - value;
- goto donumset;
- case O_FLIP:
- if (str_true(sarg[1])) {
- str_numset(str,0.0);
- anum = 2;
- arg->arg_type = optype = O_FLOP;
- maxarg = 0;
- arg[2].arg_flags &= ~AF_SPECIAL;
- arg[1].arg_flags |= AF_SPECIAL;
- argflags = arg[anum].arg_flags;
- goto re_eval;
- }
- str_set(str,"");
- break;
- case O_FLOP:
- str_inc(str);
- if (str_true(sarg[2])) {
- arg->arg_type = O_FLIP;
- arg[1].arg_flags &= ~AF_SPECIAL;
- arg[2].arg_flags |= AF_SPECIAL;
- str_cat(str,"E0");
- }
- break;
- case O_FORK:
- value = (double)fork();
- goto donumset;
- case O_SYSTEM:
- if (anum = vfork()) {
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
- while ((maxarg = wait(&argflags)) != anum && maxarg != -1)
- ;
- if (maxarg == -1)
- argflags = -1;
- signal(SIGINT, ihand);
- signal(SIGQUIT, qhand);
- value = (double)argflags;
- goto donumset;
- }
- /* FALL THROUGH */
- case O_EXEC:
- if (arg[1].arg_flags & AF_SPECIAL)
- value = (double)do_aexec(arg);
- else {
- value = (double)do_exec(str_get(sarg[1]));
- }
- goto donumset;
- case O_HEX:
- maxarg = 4;
- goto snarfnum;
-
- case O_OCT:
- maxarg = 3;
-
- snarfnum:
- anum = 0;
- tmps = str_get(sarg[1]);
- for (;;) {
- switch (*tmps) {
- default:
- goto out;
- case '8': case '9':
- if (maxarg != 4)
- goto out;
- /* FALL THROUGH */
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7':
- anum <<= maxarg;
- anum += *tmps++ & 15;
- break;
- case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
- case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
- if (maxarg != 4)
- goto out;
- anum <<= 4;
- anum += (*tmps++ & 7) + 9;
- break;
- case 'x':
- maxarg = 4;
- tmps++;
- break;
- }
- }
- out:
- value = (double)anum;
- goto donumset;
- case O_CHMOD:
- case O_CHOWN:
- case O_KILL:
- case O_UNLINK:
- if (arg[1].arg_flags & AF_SPECIAL)
- value = (double)apply(optype,arg,Null(STR**));
- else {
- sarg[2] = Nullstr;
- value = (double)apply(optype,arg,sarg);
- }
- goto donumset;
- case O_UMASK:
- value = (double)umask((int)str_gnum(sarg[1]));
- goto donumset;
- case O_RENAME:
- tmps = str_get(sarg[1]);
-#ifdef RENAME
- value = (double)(rename(tmps,str_get(sarg[2])) >= 0);
-#else
- tmps2 = str_get(sarg[2]);
- UNLINK(tmps2);
- if (!(anum = link(tmps,tmps2)))
- anum = UNLINK(tmps);
- value = (double)(anum >= 0);
-#endif
- goto donumset;
- case O_LINK:
- tmps = str_get(sarg[1]);
- value = (double)(link(tmps,str_get(sarg[2])) >= 0);
- goto donumset;
- case O_UNSHIFT:
- ary = arg[2].arg_ptr.arg_stab->stab_array;
- if (arg[1].arg_flags & AF_SPECIAL)
- do_unshift(arg,ary);
- else {
- str = str_new(0); /* must copy the STR */
- str_sset(str,sarg[1]);
- aunshift(ary,1);
- astore(ary,0,str);
- }
- value = (double)(ary->ary_fill + 1);
- break;
- case O_EVAL:
- str_sset(str,
- do_eval(arg[1].arg_type != A_NULL ? sarg[1] : defstab->stab_val) );
- STABSET(str);
- break;
- }
-#ifdef DEBUGGING
- dlevel--;
- if (debug & 8)
- deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str));
-#endif
- goto freeargs;
-
-donumset:
- str_numset(str,value);
- STABSET(str);
-#ifdef DEBUGGING
- dlevel--;
- if (debug & 8)
- deb("%s RETURNS \"%f\"\n",opname[optype],value);
-#endif
-
-freeargs:
- if (sarg != quicksarg) {
- if (retary) {
- if (optype == O_LIST)
- sarg[0] = &str_no;
- else
- sarg[0] = Nullstr;
- sarg[maxarg+1] = Nullstr;
- *retary = sarg; /* up to them to free it */
- }
- else
- safefree(sarg);
- }
- return str;
-
-nullarray:
- maxarg = 0;
-#ifdef DEBUGGING
- dlevel--;
- if (debug & 8)
- deb("%s RETURNS ()\n",opname[optype],value);
-#endif
- goto freeargs;
+ opargs[O_FTEREAD] = A(1,0,0);
+ opargs[O_FTEWRITE] = A(1,0,0);
+ opargs[O_FTEEXEC] = A(1,0,0);
+ opargs[O_FTEOWNED] = A(1,0,0);
+ opargs[O_FTRREAD] = A(1,0,0);
+ opargs[O_FTRWRITE] = A(1,0,0);
+ opargs[O_FTREXEC] = A(1,0,0);
+ opargs[O_FTROWNED] = A(1,0,0);
+ opargs[O_FTIS] = A(1,0,0);
+ opargs[O_FTZERO] = A(1,0,0);
+ opargs[O_FTSIZE] = A(1,0,0);
+ opargs[O_FTFILE] = A(1,0,0);
+ opargs[O_FTDIR] = A(1,0,0);
+ opargs[O_FTLINK] = A(1,0,0);
+ opargs[O_SYMLINK] = A(1,1,0);
+ opargs[O_FTPIPE] = A(1,0,0);
+ opargs[O_FTSUID] = A(1,0,0);
+ opargs[O_FTSGID] = A(1,0,0);
+ opargs[O_FTSVTX] = A(1,0,0);
+ opargs[O_FTCHR] = A(1,0,0);
+ opargs[O_FTBLK] = A(1,0,0);
+ opargs[O_FTSOCK] = A(1,0,0);
+ opargs[O_FTTTY] = A(1,0,0);
+ opargs[O_DOFILE] = A(1,0,0);
+ opargs[O_FTTEXT] = A(1,0,0);
+ opargs[O_FTBINARY] = A(1,0,0);
+ opargs[O_UTIME] = A(1,0,0);
+ opargs[O_WAIT] = A(0,0,0);
+ opargs[O_SORT] = A(1,0,0);
+ opargs[O_STUDY] = A(1,0,0);
+ opargs[O_DELETE] = A(1,0,0);
}
-/* $Header: arg.h,v 1.0.1.1 88/01/28 10:22:40 root Exp $
+/* $Header: arg.h,v 2.0 88/06/05 00:08:14 root Exp $
*
* $Log: arg.h,v $
- * Revision 1.0.1.1 88/01/28 10:22:40 root
- * patch8: added eval operator.
- *
- * Revision 1.0 87/12/18 13:04:39 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:08:14 root
+ * Baseline version 2.0.
*
*/
#define O_LINK 103
#define O_REPEAT 104
#define O_EVAL 105
-#define MAXO 106
+#define O_FTEREAD 106
+#define O_FTEWRITE 107
+#define O_FTEEXEC 108
+#define O_FTEOWNED 109
+#define O_FTRREAD 110
+#define O_FTRWRITE 111
+#define O_FTREXEC 112
+#define O_FTROWNED 113
+#define O_FTIS 114
+#define O_FTZERO 115
+#define O_FTSIZE 116
+#define O_FTFILE 117
+#define O_FTDIR 118
+#define O_FTLINK 119
+#define O_SYMLINK 120
+#define O_FTPIPE 121
+#define O_FTSOCK 122
+#define O_FTBLK 123
+#define O_FTCHR 124
+#define O_FTSUID 125
+#define O_FTSGID 126
+#define O_FTSVTX 127
+#define O_FTTTY 128
+#define O_DOFILE 129
+#define O_FTTEXT 130
+#define O_FTBINARY 131
+#define O_UTIME 132
+#define O_WAIT 133
+#define O_SORT 134
+#define O_DELETE 135
+#define O_STUDY 136
+#define MAXO 137
#ifndef DOINIT
extern char *opname[];
"LINK",
"REPEAT",
"EVAL",
- "106"
+ "FTEREAD",
+ "FTEWRITE",
+ "FTEEXEC",
+ "FTEOWNED",
+ "FTRREAD",
+ "FTRWRITE",
+ "FTREXEC",
+ "FTROWNED",
+ "FTIS",
+ "FTZERO",
+ "FTSIZE",
+ "FTFILE",
+ "FTDIR",
+ "FTLINK",
+ "SYMLINK",
+ "FTPIPE",
+ "FTSOCK",
+ "FTBLK",
+ "FTCHR",
+ "FTSUID",
+ "FTSGID",
+ "FTSVTX",
+ "FTTTY",
+ "DOFILE",
+ "FTTEXT",
+ "FTBINARY",
+ "UTIME",
+ "WAIT",
+ "SORT",
+ "DELETE",
+ "STUDY",
+ "135"
};
#endif
#define A_LEXPR 10
#define A_ARYLEN 11
#define A_NUMBER 12
+#define A_LARYLEN 13
+#define A_GLOB 14
+#define A_WORD 15
+#define A_INDREAD 16
#ifndef DOINIT
extern char *argname[];
"LEXPR",
"ARYLEN",
"NUMBER",
- "13"
+ "LARYLEN",
+ "GLOB",
+ "WORD",
+ "INDREAD",
+ "17"
};
#endif
#ifndef DOINIT
extern bool hoistable[];
#else
-bool hoistable[] = {0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0};
+bool hoistable[] = {0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0};
#endif
+union argptr {
+ ARG *arg_arg;
+ char *arg_cval;
+ STAB *arg_stab;
+ SPAT *arg_spat;
+ CMD *arg_cmd;
+ STR *arg_str;
+ double arg_nval;
+};
+
struct arg {
- union argptr {
- ARG *arg_arg;
- char *arg_cval;
- STAB *arg_stab;
- SPAT *arg_spat;
- CMD *arg_cmd;
- STR *arg_str;
- double arg_nval;
- } arg_ptr;
+ union argptr arg_ptr;
short arg_len;
- char arg_type;
- char arg_flags;
+ unsigned char arg_type;
+ unsigned char arg_flags;
};
#define AF_SPECIAL 1 /* op wants to evaluate this arg itself */
#define AF_COMMON 16 /* left and right have symbols in common */
#define AF_NUMERIC 32 /* return as numeric rather than string */
#define AF_LISTISH 64 /* turn into list if important */
+#define AF_LOCAL 128 /* list of local variables */
/*
* Most of the ARG pointers are used as pointers to arrays of ARG. When
int do_tms();
int do_time();
int do_stat();
+STR *do_push();
+FILE *nextargv();
+STR *do_fttext();
-/* $Header: array.c,v 1.0 87/12/18 13:04:42 root Exp $
+/* $Header: array.c,v 2.0 88/06/05 00:08:17 root Exp $
*
* $Log: array.c,v $
- * Revision 1.0 87/12/18 13:04:42 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:08:17 root
+ * Baseline version 2.0.
*
*/
-#include <stdio.h>
#include "EXTERN.h"
-#include "handy.h"
-#include "util.h"
-#include "search.h"
#include "perl.h"
STR *
register ARRAY *ar;
int key;
{
- if (key < 0 || key > ar->ary_max)
+ if (key < 0 || key > ar->ary_fill)
return Nullstr;
return ar->ary_array[key];
}
(newmax - ar->ary_max) * sizeof(STR*));
ar->ary_max = newmax;
}
- if (key > ar->ary_fill)
- ar->ary_fill = key;
+ while (ar->ary_fill < key) {
+ if (++ar->ary_fill < key && ar->ary_array[ar->ary_fill] != Nullstr) {
+ str_free(ar->ary_array[ar->ary_fill]);
+ ar->ary_array[ar->ary_fill] = Nullstr;
+ }
+ }
retval = (ar->ary_array[key] != Nullstr);
if (retval)
str_free(ar->ary_array[key]);
}
ARRAY *
-anew()
+anew(stab)
+STAB *stab;
{
register ARRAY *ar = (ARRAY*)safemalloc(sizeof(ARRAY));
ar->ary_array = (STR**) safemalloc(5 * sizeof(STR*));
+ ar->ary_magic = str_new(0);
+ ar->ary_magic->str_link.str_magic = stab;
ar->ary_fill = -1;
+ ar->ary_index = -1;
ar->ary_max = 4;
bzero((char*)ar->ary_array, 5 * sizeof(STR*));
return ar;
}
void
+aclear(ar)
+register ARRAY *ar;
+{
+ register int key;
+
+ if (!ar)
+ return;
+ for (key = 0; key <= ar->ary_max; key++)
+ str_free(ar->ary_array[key]);
+ ar->ary_fill = -1;
+ bzero((char*)ar->ary_array, (ar->ary_max+1) * sizeof(STR*));
+}
+
+void
afree(ar)
register ARRAY *ar;
{
if (!ar)
return;
- for (key = 0; key <= ar->ary_fill; key++)
+ for (key = 0; key <= ar->ary_max; key++)
str_free(ar->ary_array[key]);
+ str_free(ar->ary_magic);
safefree((char*)ar->ary_array);
safefree((char*)ar);
}
if (num <= 0)
return;
astore(ar,ar->ary_fill+num,(STR*)0); /* maybe extend array */
- sstr = ar->ary_array + ar->ary_fill;
- dstr = sstr + num;
+ dstr = ar->ary_array + ar->ary_fill;
+ sstr = dstr - num;
for (i = ar->ary_fill; i >= 0; i--) {
*dstr-- = *sstr--;
}
return retval;
}
-long
+int
alen(ar)
register ARRAY *ar;
{
- return (long)ar->ary_fill;
+ return ar->ary_fill;
+}
+
+afill(ar, fill)
+register ARRAY *ar;
+int fill;
+{
+ if (fill < 0)
+ fill = -1;
+ if (fill <= ar->ary_max)
+ ar->ary_fill = fill;
+ else
+ astore(ar,fill,Nullstr);
}
void
-/* $Header: array.h,v 1.0 87/12/18 13:04:46 root Exp $
+/* $Header: array.h,v 2.0 88/06/05 00:08:21 root Exp $
*
* $Log: array.h,v $
- * Revision 1.0 87/12/18 13:04:46 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:08:21 root
+ * Baseline version 2.0.
*
*/
struct atbl {
STR **ary_array;
- int ary_max;
- int ary_fill;
+ STR *ary_magic;
+ int ary_max;
+ int ary_fill;
+ int ary_index;
};
STR *afetch();
bool adelete();
STR *apop();
STR *ashift();
+void afree();
+void aclear();
bool apush();
-long alen();
+int alen();
ARRAY *anew();
-/* $Header: cmd.c,v 1.0.1.1 88/01/21 21:24:16 root Exp $
+/* $Header: cmd.c,v 2.0 88/06/05 00:08:24 root Exp $
*
* $Log: cmd.c,v $
- * Revision 1.0.1.1 88/01/21 21:24:16 root
- * The redo cmd got a segmentation fault because trace context stack overflowed.
- *
- * Revision 1.0 87/12/18 13:04:51 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:08:24 root
+ * Baseline version 2.0.
*
*/
-#include "handy.h"
#include "EXTERN.h"
-#include "search.h"
-#include "util.h"
#include "perl.h"
static STR str_chop;
STR *
cmd_exec(cmd)
+#ifdef cray /* nobody else has complained yet */
+CMD *cmd;
+#else
register CMD *cmd;
+#endif
{
SPAT *oldspat;
+ int oldsave;
#ifdef DEBUGGING
int olddlevel;
int entdlevel;
register STR *retstr;
register char *tmps;
register int cmdflags;
- register bool match;
+ register int match;
register char *go_to = goto_targ;
- ARG *arg;
FILE *fp;
+ ARRAY *ar;
retstr = &str_no;
#ifdef DEBUGGING
switch (cmd->c_type) {
case C_IF:
oldspat = curspat;
+ oldsave = savestack->ary_fill;
#ifdef DEBUGGING
olddlevel = dlevel;
#endif
retstr = &str_yes;
if (cmd->ucmd.ccmd.cc_true) {
#ifdef DEBUGGING
- debname[dlevel] = 't';
- debdelim[dlevel++] = '_';
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel++] = '_';
+ }
#endif
retstr = cmd_exec(cmd->ucmd.ccmd.cc_true);
}
retstr = &str_no;
if (cmd->ucmd.ccmd.cc_alt) {
#ifdef DEBUGGING
- debname[dlevel] = 'e';
- debdelim[dlevel++] = '_';
+ if (debug) {
+ debname[dlevel] = 'e';
+ debdelim[dlevel++] = '_';
+ }
#endif
retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt);
}
if (!goto_targ)
go_to = Nullch;
curspat = oldspat;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
#ifdef DEBUGGING
dlevel = olddlevel;
#endif
olddlevel = dlevel;
#endif
curspat = oldspat;
-#ifdef DEBUGGING
- if (debug & 4) {
- deb("(Popping label #%d %s)\n",loop_ptr,
- loop_stack[loop_ptr].loop_label);
- }
-#endif
- loop_ptr--;
- cmd = cmd->c_next;
- goto tail_recursion_entry;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
+ goto next_cmd;
case O_NEXT: /* not done unless go_to found */
go_to = Nullch;
goto next_iter;
goto doit;
}
oldspat = curspat;
+ oldsave = savestack->ary_fill;
#ifdef DEBUGGING
olddlevel = dlevel;
#endif
if (cmd->ucmd.ccmd.cc_true) {
#ifdef DEBUGGING
- debname[dlevel] = 't';
- debdelim[dlevel++] = '_';
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel++] = '_';
+ }
#endif
cmd_exec(cmd->ucmd.ccmd.cc_true);
}
#endif
if (cmd->ucmd.ccmd.cc_alt) {
#ifdef DEBUGGING
- debname[dlevel] = 'a';
- debdelim[dlevel++] = '_';
+ if (debug) {
+ debname[dlevel] = 'a';
+ debdelim[dlevel++] = '_';
+ }
#endif
cmd_exec(cmd->ucmd.ccmd.cc_alt);
}
goto finish_while;
}
cmd = cmd->c_next;
- if (cmd && cmd->c_head == cmd) /* reached end of while loop */
+ if (cmd && cmd->c_head == cmd)
+ /* reached end of while loop */
return retstr; /* targ isn't in this block */
+ if (cmdflags & CF_ONCE) {
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Popping label #%d %s)\n",loop_ptr,
+ loop_stack[loop_ptr].loop_label);
+ }
+#endif
+ loop_ptr--;
+ }
goto tail_recursion_entry;
}
}
until_loop:
+ /* Set line number so run-time errors can be located */
+
+ line = cmd->c_line;
+
#ifdef DEBUGGING
- if (debug & 2) {
- deb("%s (%lx) r%lx t%lx a%lx n%lx cs%lx\n",
- cmdname[cmd->c_type],cmd,cmd->c_expr,
- cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt,cmd->c_next,curspat);
+ if (debug) {
+ if (debug & 2) {
+ deb("%s (%lx) r%lx t%lx a%lx n%lx cs%lx\n",
+ cmdname[cmd->c_type],cmd,cmd->c_expr,
+ cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt,cmd->c_next,
+ curspat);
+ }
+ debname[dlevel] = cmdname[cmd->c_type][0];
+ debdelim[dlevel++] = '!';
}
- debname[dlevel] = cmdname[cmd->c_type][0];
- debdelim[dlevel++] = '!';
#endif
- while (tmps_max >= 0) /* clean up after last eval */
+ while (tmps_max > tmps_base) /* clean up after last eval */
str_free(tmps_list[tmps_max--]);
/* Here is some common optimization */
switch (cmdflags & CF_OPTIMIZE) {
case CFT_FALSE:
- retstr = cmd->c_first;
+ retstr = cmd->c_short;
match = FALSE;
if (cmdflags & CF_NESURE)
goto maybe;
break;
case CFT_TRUE:
- retstr = cmd->c_first;
+ retstr = cmd->c_short;
match = TRUE;
if (cmdflags & CF_EQSURE)
goto flipmaybe;
case CFT_ANCHOR: /* /^pat/ optimization */
if (multiline) {
- if (*cmd->c_first->str_ptr && !(cmdflags & CF_EQSURE))
+ if (*cmd->c_short->str_ptr && !(cmdflags & CF_EQSURE))
goto scanner; /* just unanchor it */
else
break; /* must evaluate */
/* FALL THROUGH */
case CFT_STROP: /* string op optimization */
retstr = STAB_STR(cmd->c_stab);
- if (*cmd->c_first->str_ptr == *str_get(retstr) &&
- strnEQ(cmd->c_first->str_ptr, str_get(retstr),
- cmd->c_flen) ) {
+ if (*cmd->c_short->str_ptr == *str_get(retstr) &&
+ strnEQ(cmd->c_short->str_ptr, str_get(retstr),
+ cmd->c_slen) ) {
if (cmdflags & CF_EQSURE) {
match = !(cmdflags & CF_FIRSTNEG);
retstr = &str_yes;
case CFT_SCAN: /* non-anchored search */
scanner:
retstr = STAB_STR(cmd->c_stab);
- if (instr(str_get(retstr),cmd->c_first->str_ptr)) {
+ if (retstr->str_pok == 5)
+ if (screamfirst[cmd->c_short->str_rare] >= 0)
+ tmps = screaminstr(retstr, cmd->c_short);
+ else
+ tmps = Nullch;
+ else {
+ tmps = str_get(retstr); /* make sure it's pok */
+ tmps = fbminstr(tmps, tmps + retstr->str_cur, cmd->c_short);
+ }
+ if (tmps) {
if (cmdflags & CF_EQSURE) {
+ ++*(long*)&cmd->c_short->str_nval;
match = !(cmdflags & CF_FIRSTNEG);
retstr = &str_yes;
goto flipmaybe;
}
+ else
+ hint = tmps;
+ }
+ else {
+ if (cmdflags & CF_NESURE) {
+ ++*(long*)&cmd->c_short->str_nval;
+ match = cmdflags & CF_FIRSTNEG;
+ retstr = &str_no;
+ goto flipmaybe;
+ }
+ }
+ if (--*(long*)&cmd->c_short->str_nval < 0) {
+ str_free(cmd->c_short);
+ cmd->c_short = Nullstr;
+ cmdflags &= ~CF_OPTIMIZE;
+ cmdflags |= CFT_EVAL; /* never try this optimization again */
+ cmd->c_flags = cmdflags;
+ }
+ break; /* must evaluate */
+
+ case CFT_NUMOP: /* numeric op optimization */
+ retstr = STAB_STR(cmd->c_stab);
+ switch (cmd->c_slen) {
+ case O_EQ:
+ match = (str_gnum(retstr) == cmd->c_short->str_nval);
+ break;
+ case O_NE:
+ match = (str_gnum(retstr) != cmd->c_short->str_nval);
+ break;
+ case O_LT:
+ match = (str_gnum(retstr) < cmd->c_short->str_nval);
+ break;
+ case O_LE:
+ match = (str_gnum(retstr) <= cmd->c_short->str_nval);
+ break;
+ case O_GT:
+ match = (str_gnum(retstr) > cmd->c_short->str_nval);
+ break;
+ case O_GE:
+ match = (str_gnum(retstr) >= cmd->c_short->str_nval);
+ break;
+ }
+ if (match) {
+ if (cmdflags & CF_EQSURE) {
+ retstr = &str_yes;
+ goto flipmaybe;
+ }
}
else if (cmdflags & CF_NESURE) {
- match = cmdflags & CF_FIRSTNEG;
retstr = &str_no;
goto flipmaybe;
}
break; /* must evaluate */
+ case CFT_INDGETS: /* while (<$foo>) */
+ last_in_stab = stabent(str_get(STAB_STR(cmd->c_stab)),TRUE);
+ if (!last_in_stab->stab_io)
+ last_in_stab->stab_io = stio_new();
+ goto dogets;
case CFT_GETS: /* really a while (<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])
+ match = FALSE;
+ else
+ match = TRUE;
last_in_stab->stab_io->lines++;
- match = TRUE;
}
else if (last_in_stab->stab_io->flags & IOF_ARGV)
goto doeval; /* doesn't necessarily count as EOF yet */
case CFT_EVAL:
break;
case CFT_UNFLIP:
- retstr = eval(cmd->c_expr,Null(char***));
+ retstr = eval(cmd->c_expr,Null(STR***),-1);
match = str_true(retstr);
if (cmd->c_expr->arg_type == O_FLIP) /* undid itself? */
cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd);
retstr->str_cur = tmps - retstr->str_ptr;
retstr = &str_chop;
goto flipmaybe;
+ case CFT_ARRAY:
+ ar = cmd->c_expr[1].arg_ptr.arg_stab->stab_array;
+ match = ar->ary_index; /* just to get register */
+
+ if (match < 0) /* first time through here? */
+ cmd->c_short = cmd->c_stab->stab_val;
+
+ if (match >= ar->ary_fill) {
+ ar->ary_index = -1;
+/* cmd->c_stab->stab_val = cmd->c_short; - Can't be done in LAST */
+ match = FALSE;
+ }
+ else {
+ match++;
+ retstr = cmd->c_stab->stab_val = ar->ary_array[match];
+ ar->ary_index = match;
+ match = TRUE;
+ }
+ goto maybe;
}
/* we have tried to make this normal case as abnormal as possible */
doeval:
- retstr = eval(cmd->c_expr,Null(char***));
+ lastretstr = retstr;
+ retstr = eval(cmd->c_expr,Null(STR***),-1);
match = str_true(retstr);
goto maybe;
flipmaybe:
if (match && cmdflags & CF_FLIP) {
if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */
- retstr = eval(cmd->c_expr,Null(char***)); /* let eval undo it */
+ retstr = eval(cmd->c_expr,Null(STR***),-1);/*let eval undo it*/
cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd);
}
else {
- retstr = eval(cmd->c_expr,Null(char***)); /* let eval do it */
+ retstr = eval(cmd->c_expr,Null(STR***),-1);/* let eval do it */
if (cmd->c_expr->arg_type == O_FLOP) /* still toggled? */
cmdflags = copyopt(cmd,cmd->c_expr[4].arg_ptr.arg_cmd);
}
maybe:
if (cmdflags & CF_INVERT)
match = !match;
- if (!match && cmd->c_type != C_IF) {
- cmd = cmd->c_next;
- goto tail_recursion_entry;
- }
+ if (!match && cmd->c_type != C_IF)
+ goto next_cmd;
}
/* now to do the actual command, if any */
switch (cmd->c_type) {
case C_NULL:
- fatal("panic: cmd_exec\n");
+ fatal("panic: cmd_exec");
case C_EXPR: /* evaluated for side effects */
if (cmd->ucmd.acmd.ac_expr) { /* more to do? */
- retstr = eval(cmd->ucmd.acmd.ac_expr,Null(char***));
+ lastretstr = retstr;
+ retstr = eval(cmd->ucmd.acmd.ac_expr,Null(STR***),-1);
}
break;
case C_IF:
oldspat = curspat;
+ oldsave = savestack->ary_fill;
#ifdef DEBUGGING
olddlevel = dlevel;
#endif
retstr = &str_yes;
if (cmd->ucmd.ccmd.cc_true) {
#ifdef DEBUGGING
- debname[dlevel] = 't';
- debdelim[dlevel++] = '_';
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel++] = '_';
+ }
#endif
retstr = cmd_exec(cmd->ucmd.ccmd.cc_true);
}
retstr = &str_no;
if (cmd->ucmd.ccmd.cc_alt) {
#ifdef DEBUGGING
- debname[dlevel] = 'e';
- debdelim[dlevel++] = '_';
+ if (debug) {
+ debname[dlevel] = 'e';
+ debdelim[dlevel++] = '_';
+ }
#endif
retstr = cmd_exec(cmd->ucmd.ccmd.cc_alt);
}
}
curspat = oldspat;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
#ifdef DEBUGGING
dlevel = olddlevel;
#endif
}
switch (setjmp(loop_stack[loop_ptr].loop_env)) {
case O_LAST:
- retstr = &str_no;
+ retstr = lastretstr;
curspat = oldspat;
-#ifdef DEBUGGING
- if (debug & 4) {
- deb("(Popping label #%d %s)\n",loop_ptr,
- loop_stack[loop_ptr].loop_label);
- }
-#endif
- loop_ptr--;
- cmd = cmd->c_next;
- goto tail_recursion_entry;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
+ goto next_cmd;
case O_NEXT:
goto next_iter;
case O_REDO:
goto doit;
}
oldspat = curspat;
+ oldsave = savestack->ary_fill;
#ifdef DEBUGGING
olddlevel = dlevel;
#endif
doit:
if (cmd->ucmd.ccmd.cc_true) {
#ifdef DEBUGGING
- debname[dlevel] = 't';
- debdelim[dlevel++] = '_';
+ if (debug) {
+ debname[dlevel] = 't';
+ debdelim[dlevel++] = '_';
+ }
#endif
cmd_exec(cmd->ucmd.ccmd.cc_true);
}
- /* actually, this spot is never reached anymore since the above
+ /* actually, this spot is rarely reached anymore since the above
* cmd_exec() returns through longjmp(). Hooray for structure.
*/
next_iter:
#endif
if (cmd->ucmd.ccmd.cc_alt) {
#ifdef DEBUGGING
- debname[dlevel] = 'a';
- debdelim[dlevel++] = '_';
+ if (debug) {
+ debname[dlevel] = 'a';
+ debdelim[dlevel++] = '_';
+ }
#endif
cmd_exec(cmd->ucmd.ccmd.cc_alt);
}
finish_while:
curspat = oldspat;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
#ifdef DEBUGGING
dlevel = olddlevel - 1;
#endif
}
if (cmdflags & CF_LOOP) {
cmdflags |= CF_COND; /* now test the condition */
+#ifdef DEBUGGING
+ dlevel = entdlevel;
+#endif
goto until_loop;
}
+ next_cmd:
+ if (cmdflags & CF_ONCE) {
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Popping label #%d %s)\n",loop_ptr,
+ loop_stack[loop_ptr].loop_label);
+ }
+#endif
+ loop_ptr--;
+ if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY) {
+ cmd->c_stab->stab_val = cmd->c_short;
+ }
+ }
cmd = cmd->c_next;
goto tail_recursion_entry;
}
{
register int i;
+ fprintf(stderr,"%-4ld",(long)line);
for (i=0; i<dlevel; i++)
fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
fprintf(stderr,pat,a1,a2,a3,a4,a5,a6,a7,a8);
{
cmd->c_flags &= CF_ONCE|CF_COND|CF_LOOP;
cmd->c_flags |= which->c_flags;
- cmd->c_first = which->c_first;
- cmd->c_flen = which->c_flen;
+ cmd->c_short = which->c_short;
+ cmd->c_slen = which->c_slen;
cmd->c_stab = which->c_stab;
return cmd->c_flags;
}
+
+void
+savelist(sarg,maxsarg)
+register STR **sarg;
+int maxsarg;
+{
+ register STR *str;
+ register int i;
+
+ for (i = 1; i <= maxsarg; i++) {
+ apush(savestack,sarg[i]); /* remember the pointer */
+ str = str_new(0);
+ str_sset(str,sarg[i]);
+ apush(savestack,str); /* remember the value */
+ }
+}
+
+void
+restorelist(base)
+int base;
+{
+ register STR *str;
+ register STR *value;
+
+ while (savestack->ary_fill > base) {
+ value = apop(savestack);
+ str = apop(savestack);
+ str_sset(str,value);
+ STABSET(str);
+ str_free(value);
+ }
+}
-/* $Header: cmd.h,v 1.0.1.1 88/01/28 10:23:07 root Exp $
+/* $Header: cmd.h,v 2.0 88/06/05 00:08:28 root Exp $
*
* $Log: cmd.h,v $
- * Revision 1.0.1.1 88/01/28 10:23:07 root
- * patch8: added eval_root for eval operator.
- *
- * Revision 1.0 87/12/18 13:04:59 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:08:28 root
+ * Baseline version 2.0.
*
*/
#define C_EXPR 3
#define C_BLOCK 4
+#ifdef DEBUGGING
#ifndef DOINIT
extern char *cmdname[];
#else
"16"
};
#endif
+#endif /* DEBUGGING */
#define CF_OPTIMIZE 077 /* type of optimization */
#define CF_FIRSTNEG 0100/* conditional is ($register NE 'string') */
-#define CF_NESURE 0200 /* if first doesn't match we're sure */
-#define CF_EQSURE 0400 /* if first does match we're sure */
+#define CF_NESURE 0200 /* if short doesn't match we're sure */
+#define CF_EQSURE 0400 /* if short does match we're sure */
#define CF_COND 01000 /* test c_expr as conditional first, if not null. */
/* Set for everything except do {} while currently */
#define CF_LOOP 02000 /* loop on the c_expr conditional (loop modifiers) */
#define CFT_ANCHOR 3 /* c_expr is an anchored search /^.../ */
#define CFT_STROP 4 /* c_expr is a string comparison */
#define CFT_SCAN 5 /* c_expr is an unanchored search /.../ */
-#define CFT_GETS 6 /* c_expr is $reg = <filehandle> */
+#define CFT_GETS 6 /* c_expr is <filehandle> */
#define CFT_EVAL 7 /* c_expr is not optimized, so call eval() */
#define CFT_UNFLIP 8 /* 2nd half of range not optimized */
#define CFT_CHOP 9 /* c_expr is a chop on a register */
+#define CFT_ARRAY 10 /* this is a foreach loop */
+#define CFT_INDGETS 11 /* c_expr is <$variable> */
+#define CFT_NUMOP 12 /* c_expr is a numeric comparison */
+#ifdef DEBUGGING
#ifndef DOINIT
extern char *cmdopt[];
#else
"EVAL",
"UNFLIP",
"CHOP",
- "10"
+ "ARRAY",
+ "INDGETS",
+ "NUMOP",
+ "13"
};
#endif
+#endif /* DEBUGGING */
struct acmd {
STAB *ac_stab; /* a symbol table entry */
CMD *c_next; /* the next command at this level */
ARG *c_expr; /* conditional expression */
CMD *c_head; /* head of this command list */
- STR *c_first; /* head of string to match as shortcut */
+ STR *c_short; /* string to match as shortcut */
STAB *c_stab; /* a symbol table entry, mostly for fp */
SPAT *c_spat; /* pattern used by optimization */
char *c_label; /* label for this construct */
struct acmd acmd; /* normal command */
struct ccmd ccmd; /* compound command */
} ucmd;
- short c_flen; /* len of c_first, if not null */
+ short c_slen; /* len of c_short, if not null */
short c_flags; /* optimization flags--see above */
+ char *c_file; /* file the following line # is from */
+ line_t c_line; /* line # of this command */
char c_type; /* what this command does */
};
CMD *comp_alt;
};
-#ifndef DOINIT
-extern struct compcmd Nullccmd;
-#else
-struct compcmd Nullccmd = {Nullcmd, Nullcmd};
-#endif
void opt_arg();
void evalstatic();
STR *cmd_exec();
(echo "Can't find config.sh."; exit 1)
echo "Using config.sh from above..."
fi
- . config.sh
+ . ./config.sh
;;
esac
echo "Extracting config.h (with variable substitutions)"
#$d_eunice EUNICE /**/
#$d_eunice VMS /**/
-/* CPP:
+/* CPPSTDIN:
* This symbol contains the first part of the string which will invoke
* the C preprocessor on the standard input and produce to standard
* output. Typical value of "cc -E" or "/lib/cpp".
/* CPPMINUS:
* This symbol contains the second part of the string which will invoke
* the C preprocessor on the standard input and produce to standard
- * output. This symbol will have the value "-" if CPP needs a minus
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
* to specify standard input, otherwise the value is "".
*/
-#define CPP "$cpp"
+#define CPPSTDIN "$cppstdin"
#define CPPMINUS "$cppminus"
/* BCOPY:
*/
#$d_crypt CRYPT /**/
+/* FCHMOD:
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+#$d_fchmod FCHMOD /**/
+
+/* FCHOWN:
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+#$d_fchown FCHOWN /**/
+
+/* GETGROUPS:
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+#$d_getgrps GETGROUPS /**/
+
/* index:
* This preprocessor symbol is defined, along with rindex, if the system
* uses the strchr and strrchr routines instead.
#$d_index index strchr /* cultural */
#$d_index rindex strrchr /* differences? */
+/* KILLPG:
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+#$d_killpg KILLPG /**/
+
+/* MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy blocks of memory. Otherwise you should probably use bcopy().
+ * If neither is defined, roll your own.
+ */
+#$d_memcpy MEMCPY /**/
+
+/* RENAME:
+ * This symbol, if defined, indicates that the rename routine is available
+ * to rename files. Otherwise you should do the unlink(), link(), unlink()
+ * trick.
+ */
+#$d_rename RENAME /**/
+
+/* SETEGID:
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+#$d_setegid SETEGID /**/
+
+/* SETEUID:
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+#$d_seteuid SETEUID /**/
+
+/* SETRGID:
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+#$d_setrgid SETRGID /**/
+
+/* SETRUID:
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+#$d_setruid SETRUID /**/
+
/* STATBLOCKS:
* This symbol is defined if this system has a stat structure declaring
* st_blksize and st_blocks.
*/
#$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_voidsig VOIDSIG /**/
+/* GIDTYPE:
+ * This symbol has a value like gid_t, int, ushort, or whatever type is
+ * used to declare group ids in the kernel.
+ */
+#define GIDTYPE $gidtype /**/
+
/* STDCHAR:
* This symbol is defined to be the type of char used in stdio.h.
* It has the values "unsigned char" or "char".
*/
#define STDCHAR $stdchar /**/
+/* UIDTYPE:
+ * This symbol has a value like uid_t, int, ushort, or whatever type is
+ * used to declare user ids in the kernel.
+ */
+#define UIDTYPE $uidtype /**/
+
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
#$define M_VOID /* Xenix strikes again */
#endif
+/* PRIVLIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world.
+ */
+#define PRIVLIB "$privlib" /**/
+
!GROK!THIS!
-/* $Header: dump.c,v 1.0 87/12/18 13:05:03 root Exp $
+/* $Header: dump.c,v 2.0 88/06/05 00:08:44 root Exp $
*
* $Log: dump.c,v $
- * Revision 1.0 87/12/18 13:05:03 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:08:44 root
+ * Baseline version 2.0.
*
*/
-#include "handy.h"
#include "EXTERN.h"
-#include "search.h"
-#include "util.h"
#include "perl.h"
#ifdef DEBUGGING
while (cmd) {
dumplvl++;
dump("C_TYPE = %s\n",cmdname[cmd->c_type]);
+ if (cmd->c_line)
+ dump("C_LINE = %d\n",cmd->c_line);
if (cmd->c_label)
dump("C_LABEL = \"%s\"\n",cmd->c_label);
dump("C_OPT = CFT_%s\n",cmdopt[cmd->c_flags & CF_OPTIMIZE]);
if (*buf)
buf[strlen(buf)-1] = '\0';
dump("C_FLAGS = (%s)\n",buf);
- if (cmd->c_first) {
- dump("C_FIRST = \"%s\"\n",str_peek(cmd->c_first));
- dump("C_FLEN = \"%d\"\n",cmd->c_flen);
+ if (cmd->c_short) {
+ dump("C_SHORT = \"%s\"\n",str_peek(cmd->c_short));
+ dump("C_SLEN = \"%d\"\n",cmd->c_slen);
}
if (cmd->c_stab) {
dump("C_STAB = ");
case C_EXPR:
if (cmd->ucmd.acmd.ac_stab) {
dump("AC_STAB = ");
- dump_arg(cmd->ucmd.acmd.ac_stab);
+ dump_stab(cmd->ucmd.acmd.ac_stab);
} else
dump("AC_STAB = NULL\n");
if (cmd->ucmd.acmd.ac_expr) {
dumplvl++;
dump("OP_TYPE = %s\n",opname[arg->arg_type]);
dump("OP_LEN = %d\n",arg->arg_len);
+ if (arg->arg_flags) {
+ dump_flags(buf,arg->arg_flags);
+ dump("OP_FLAGS = (%s)\n",buf);
+ }
for (i = 1; i <= arg->arg_len; i++) {
dump("[%d]ARG_TYPE = %s\n",i,argname[arg[i].arg_type]);
if (arg[i].arg_len)
dump("[%d]ARG_LEN = %d\n",i,arg[i].arg_len);
- *buf = '\0';
- if (arg[i].arg_flags & AF_SPECIAL)
- strcat(buf,"SPECIAL,");
- if (arg[i].arg_flags & AF_POST)
- strcat(buf,"POST,");
- if (arg[i].arg_flags & AF_PRE)
- strcat(buf,"PRE,");
- if (arg[i].arg_flags & AF_UP)
- strcat(buf,"UP,");
- if (arg[i].arg_flags & AF_COMMON)
- strcat(buf,"COMMON,");
- if (arg[i].arg_flags & AF_NUMERIC)
- strcat(buf,"NUMERIC,");
- if (*buf)
- buf[strlen(buf)-1] = '\0';
- dump("[%d]ARG_FLAGS = (%s)\n",i,buf);
+ if (arg[i].arg_flags) {
+ dump_flags(buf,arg[i].arg_flags);
+ dump("[%d]ARG_FLAGS = (%s)\n",i,buf);
+ }
switch (arg[i].arg_type) {
case A_NULL:
break;
dump("[%d]ARG_CMD = ",i);
dump_cmd(arg[i].arg_ptr.arg_cmd,Nullcmd);
break;
+ case A_WORD:
case A_STAB:
case A_LVAL:
case A_READ:
+ case A_GLOB:
case A_ARYLEN:
dump("[%d]ARG_STAB = ",i);
dump_stab(arg[i].arg_ptr.arg_stab);
dump("}\n");
}
+dump_flags(b,flags)
+char *b;
+unsigned flags;
+{
+ *b = '\0';
+ if (flags & AF_SPECIAL)
+ strcat(b,"SPECIAL,");
+ if (flags & AF_POST)
+ strcat(b,"POST,");
+ if (flags & AF_PRE)
+ strcat(b,"PRE,");
+ if (flags & AF_UP)
+ strcat(b,"UP,");
+ if (flags & AF_COMMON)
+ strcat(b,"COMMON,");
+ if (flags & AF_NUMERIC)
+ strcat(b,"NUMERIC,");
+ if (flags & AF_LISTISH)
+ strcat(b,"LISTISH,");
+ if (flags & AF_LOCAL)
+ strcat(b,"LOCAL,");
+ if (*b)
+ b[strlen(b)-1] = '\0';
+}
+
dump_stab(stab)
register STAB *stab;
{
+ if (!stab) {
+ fprintf(stderr,"{}\n");
+ return;
+ }
dumplvl++;
fprintf(stderr,"{\n");
dump("STAB_NAME = %s\n",stab->stab_name);
{
char ch;
+ if (!spat) {
+ fprintf(stderr,"{}\n");
+ return;
+ }
fprintf(stderr,"{\n");
dumplvl++;
if (spat->spat_runtime) {
dump("SPAT_RUNTIME = ");
dump_arg(spat->spat_runtime);
} else {
- if (spat->spat_flags & SPAT_USE_ONCE)
+ if (spat->spat_flags & SPAT_ONCE)
ch = '?';
else
ch = '/';
- dump("SPAT_PRE %c%s%c\n",ch,spat->spat_compex.precomp,ch);
+ dump("SPAT_PRE %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
}
if (spat->spat_repl) {
dump("SPAT_REPL = ");
dump_arg(spat->spat_repl);
}
+ if (spat->spat_short) {
+ dump("SPAT_SHORT = \"%s\"\n",str_peek(spat->spat_short));
+ }
dumplvl--;
dump("}\n");
}
+/* VARARGS1 */
dump(arg1,arg2,arg3,arg4,arg5)
-char *arg1, *arg2, *arg3, *arg4, *arg5;
+char *arg1;
+long arg2, arg3, arg4, arg5;
{
int i;
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: ADB,v 2.0 88/06/05 00:16:39 root Exp $
+
+# This script is only useful when used in your crash directory.
+
+$num = shift;
+exec 'adb', '-k', "vmunix.$num", "vmcore.$num";
--- /dev/null
+This stuff is supplied on an as-is basis--little attempt has been made to make
+any of it portable. It's mostly here to give you an idea of what perl code
+looks like, and what tricks and idioms are used.
+
+System administrators responsible for many computers will enjoy the items
+down in the g directory very much. The scan directory contains the beginnings
+of a system to check on and report various kinds of anomalies.
+
+If you machine doesn't support #!, the first thing you'll want to do is
+replace the #! with a couple of lines that look like this:
+
+ eval "exec /usr/bin/perl -S $0 $*"
+ if $running_under_some_shell;
+
+being sure to include any flags that were on the #! line. A supplied script
+called "nih" will translate perl scripts in place for you:
+
+ nih g/g??
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: changes,v 2.0 88/06/05 00:16:41 root Exp $
+
+($dir, $days) = @ARGV;
+$dir = '/' if $dir eq '';
+$days = '14' if $days eq '';
+
+# Masscomps do things differently from Suns
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+open(Find, "find $dir -mtime -$days -print |") ||
+ die "changes: can't run find";
+#else
+open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") ||
+ die "changes: can't run find";
+#endif
+
+while (<Find>) {
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+ $x = `/bin/ls -ild $_`;
+ $_ = $x;
+ ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
+ = split(' ');
+#else
+ ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
+ = split(' ');
+#endif
+
+ printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n",
+ $perm,$links,$owner,$group,$size,$month,$day,$name);
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: dus,v 2.0 88/06/05 00:16:44 root Exp $
+
+# This script does a du -s on any directories in the current directory that
+# are not mount points for another filesystem.
+
+($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('.');
+
+open(ls,'ls -F1|');
+
+while (<ls>) {
+ chop;
+ next unless s|/$||;
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($_);
+ next unless $dev == $mydev;
+ push(@ary,$_);
+}
+
+exec 'du', '-s', @ary;
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: findcp,v 2.0 88/06/05 00:16:47 root Exp $
+
+# This is a wrapper around the find command that pretends find has a switch
+# of the form -cp host:destination. It presumes your find implements -ls.
+# It uses tar to do the actual copy. If your tar knows about the I switch
+# you may prefer to use findtar, since this one has to do the tar in batches.
+
+sub copy {
+ `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`;
+}
+
+$sourcedir = $ARGV[0];
+if ($sourcedir =~ /^\//) {
+ $ARGV[0] = '.';
+ unless (chdir($sourcedir)) { die "Can't find directory: $sourcedir"; }
+}
+
+$args = join(' ',@ARGV);
+if ($args =~ s/-cp *([^ ]+)/-ls/) {
+ $dest = $1;
+ if ($dest =~ /(.*):(.*)/) {
+ $desthost = $1;
+ $destdir = $2;
+ }
+ else {
+ die "Malformed destination--should be host:directory";
+ }
+}
+else {
+ die("No destination specified");
+}
+
+open(find,"find $args |") || die "Can't run find for you.";
+
+while (<find>) {
+ @x = split(' ');
+ if ($x[2] =~ /^d/) { next;}
+ chop($filename = $x[10]);
+ if (length($list) > 5000) {
+ do copy();
+ $list = '';
+ }
+ else {
+ $list .= ' ';
+ }
+ $list .= $filename;
+}
+
+if ($list) {
+ do copy();
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: findtar,v 2.0 88/06/05 00:16:49 root Exp $
+
+# findtar takes find-style arguments and spits out a tarfile on stdout.
+# It won't work unless your find supports -ls and your tar the I flag.
+
+$args = join(' ',@ARGV);
+open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you.";
+
+open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you.";
+
+while (<find>) {
+ @x = split(' ');
+ if ($x[2] =~ /^d/) { print tar '-d ';}
+ print tar $x[10],"\n";
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: gcp,v 2.0 88/06/05 00:17:02 root Exp $
+
+# Here is a script to do global rcps. See man page.
+
+$#ARGV >= 1 || die "Not enough arguments.\n";
+
+if ($ARGV[0] eq '-r') {
+ $rcp = 'rcp -r';
+ shift;
+} else {
+ $rcp = 'rcp';
+}
+$args = $rcp;
+$dest = $ARGV[$#ARGV];
+
+$SIG{'QUIT'} = 'CLEANUP';
+$SIG{'INT'} = 'CONT';
+
+while ($arg = shift) {
+ if ($arg =~ /^([-a-zA-Z0-9_+]+):/) {
+ if ($systype && $systype ne $1) {
+ die "Can't mix system type specifers ($systype vs $1).\n";
+ }
+ $#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n";
+ $systype = $1;
+ $args .= " $arg";
+ } else {
+ if ($#ARGV >= 0) {
+ if ($arg =~ /^[\/~]/) {
+ $arg =~ /^(.*)\// && ($dir = $1);
+ } else {
+ if (!$pwd) {
+ chop($pwd = `pwd`);
+ }
+ $dir = $pwd;
+ }
+ }
+ if ($olddir && $dir ne $olddir && $dest =~ /:$/) {
+ $args .= " $dest$olddir; $rcp";
+ }
+ $olddir = $dir;
+ $args .= " $arg";
+ }
+}
+
+die "No system type specified.\n" unless $systype;
+
+$args =~ s/:$/:$olddir/;
+
+chop($thishost = `hostname`);
+
+$one_of_these = ":$systype:";
+if ($systype =~ s/\+/[+]/g) {
+ $one_of_these =~ s/\+/:/g;
+}
+$one_of_these =~ s/-/:-/g;
+
+@ARGV = ();
+push(@ARGV,'.grem') if -f '.grem';
+push(@ARGV,'.ghosts') if -f '.ghosts';
+push(@ARGV,'/etc/ghosts');
+
+$remainder = '';
+
+line: while (<>) {
+ s/[ \t]*\n//;
+ if (!$_ || /^#/) {
+ next line;
+ }
+ if (/^([a-zA-Z_0-9]+)=(.+)/) {
+ $name = $1; $repl = $2;
+ $repl =~ s/\+/:/g;
+ $repl =~ s/-/:-/g;
+ $one_of_these =~ s/:$name:/:$repl:/;
+ $repl =~ s/:/:-/g;
+ $one_of_these =~ s/:-$name:/:-$repl:/g;
+ next line;
+ }
+ @gh = split(' ');
+ $host = $gh[0];
+ next line if $host eq $thishost; # should handle aliases too
+ $wanted = 0;
+ foreach $class (@gh) {
+ $wanted++ if index($one_of_these,":$class:") >= 0;
+ $wanted = -9999 if index($one_of_these,":-$class:") >= 0;
+ }
+ if ($wanted > 0) {
+ ($cmd = $args) =~ s/[ \t]$systype:/ $host:/g;
+ print "$cmd\n";
+ $result = `$cmd 2>&1`;
+ $remainder .= "$host+" if
+ $result =~ /Connection timed out|Permission denied/;
+ print $result;
+ }
+}
+
+if ($remainder) {
+ chop($remainder);
+ open(grem,">.grem") || (printf stderr "Can't create .grem\n");
+ print grem 'rem=', $remainder, "\n";
+ close(grem);
+ print 'rem=', $remainder, "\n";
+}
+
+sub CLEANUP {
+ exit;
+}
+
+sub CONT {
+ print "Continuing...\n"; # Just ignore the signal that kills rcp
+ $remainder .= "$host+";
+}
--- /dev/null
+.\" $Header: gcp.man,v 2.0 88/06/05 00:17:05 root Exp $
+.TH GCP 1C "13 May 1988"
+.SH NAME
+gcp \- global file copy
+.SH SYNOPSIS
+.B gcp
+file1 file2
+.br
+.B gcp
+[
+.B \-r
+] file ... directory
+.SH DESCRIPTION
+.I gcp
+works just like rcp(1C) except that you may specify a set of hosts to copy files
+from or to.
+The host sets are defined in the file /etc/ghosts.
+(An individual host name can be used as a set containing one member.)
+You can give a command like
+
+ gcp /etc/motd sun:
+
+to copy your /etc/motd file to /etc/motd on all the Suns.
+If, on the other hand, you say
+
+ gcp /a/foo /b/bar sun:/tmp
+
+then your files will be copied to /tmp on all the Suns.
+The general rule is that if you don't specify the destination directory,
+files go to the same directory they are in currently.
+.P
+You may specify the union of two or more sets by using + as follows:
+
+ gcp /a/foo /b/bar 750+mc:
+
+which will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy
+/b/bar to /b/bar on all 750's and Masscomps.
+.P
+Commonly used sets should be defined in /etc/ghosts.
+For example, you could add a line that says
+
+ pep=manny+moe+jack
+
+Another way to do that would be to add the word "pep" after each of the host
+entries:
+
+ manny sun3 pep
+.br
+ moe sun3 pep
+.br
+ jack sun3 pep
+
+Hosts and sets of host can also be excluded:
+
+ foo=sun-sun2
+
+Any host so excluded will never be included, even if a subsequent set on the
+line includes it:
+
+ foo=abc+def
+.br
+ bar=xyz-abc+foo
+
+comes out to xyz+def.
+
+You can define private host sets by creating .ghosts in your current directory
+with entries just like /etc/ghosts.
+Also, if there is a file .grem, it defines "rem" to be the remaining hosts
+from the last gsh or gcp that didn't succeed everywhere.
+.PP
+Interrupting with a SIGINT will cause the rcp to the current host to be skipped
+and execution resumed with the next host.
+To stop completely, send a SIGQUIT.
+.SH SEE ALSO
+rcp(1C)
+.SH BUGS
+All the bugs of rcp, since it calls rcp.
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: ged,v 2.0 88/06/05 00:17:08 root Exp $
+
+# Does inplace edits on a set of files on a set of machines.
+#
+# Typical invokation:
+#
+# ged vax+sun /etc/passwd
+# s/Freddy/Freddie/;
+# ^D
+#
+
+$class = shift;
+$files = join(' ',@ARGV);
+
+die "Usage: ged class files <perlcmds\n" unless $files;
+
+exec "gsh", $class, "-d", "perl -pi.bak - $files";
+
+die "Couldn't execute gsh for some reason, stopped";
--- /dev/null
+# This first section gives alternate sets defined in terms of the sets given
+# by the second section. The order is important--all references must be
+# forward references.
+
+Nnd=sun-nd
+all=sun+mc+vax
+baseline=sun+mc
+sun=sun2+sun3
+vax=750+8600
+pep=manny+moe+jack
+
+# This second section defines the basic sets. Each host should have a line
+# that specifies which sets it is a member of. Extra sets should be separated
+# by white space. (The first section isn't strictly necessary, since all sets
+# could be defined in the second section, but then it wouldn't be so readable.)
+
+basvax 8600 src
+cdb0 sun3 sys
+cdb1 sun3 sys
+cdb2 sun3 sys
+chief sun3 src
+tis0 sun3
+manny sun3 sys
+moe sun3 sys
+jack sun3 sys
+disney sun3 sys
+huey sun3 nd
+dewey sun3 nd
+louie sun3 nd
+bizet sun2 src sys
+gif0 mc src
+mc0 mc
+dtv0 mc
--- /dev/null
+#!/bin/perl
+
+# $Header: gsh,v 2.0 88/06/05 00:17:20 root Exp $
+
+# Do rsh globally--see man page
+
+$SIG{'QUIT'} = 'quit'; # install signal handler for SIGQUIT
+
+sub getswitches {
+ while ($ARGV[0] =~ /^-/) { # parse switches
+ $ARGV[0] =~ /^-h/ && ($showhost++,$silent++,shift,next);
+ $ARGV[0] =~ /^-s/ && ($silent++,shift,next);
+ $ARGV[0] =~ /^-d/ && ($dodist++,shift,next);
+ $ARGV[0] =~ /^-n/ && ($n=' -n',shift,next);
+ $ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift,shift,next);
+ last;
+ }
+}
+
+do getswitches(); # get any switches before class
+$systype = shift; # get name representing set of hosts
+do getswitches(); # same switches allowed after class
+
+if ($dodist) { # distribute input over all rshes?
+ `cat >/tmp/gsh$$`; # get input into a handy place
+ $dist = " </tmp/gsh$$"; # each rsh takes input from there
+}
+
+$cmd = join(' ',@ARGV); # remaining args constitute the command
+$cmd =~ s/'/'"'"'/g; # quote any embedded single quotes
+
+$one_of_these = ":$systype:"; # prepare to expand "macros"
+$one_of_these =~ s/\+/:/g; # we hope to end up with list of
+$one_of_these =~ s/-/:-/g; # colon separated attributes
+
+@ARGV = ();
+push(@ARGV,'.grem') if -f '.grem';
+push(@ARGV,'.ghosts') if -f '.ghosts';
+push(@ARGV,'/etc/ghosts');
+
+$remainder = '';
+
+line: while (<>) { # for each line of ghosts
+
+ s/[ \t]*\n//; # trim trailing whitespace
+ if (!$_ || /^#/) { # skip blank line or comment
+ next line;
+ }
+
+ if (/^(\w+)=(.+)/) { # a macro line?
+ $name = $1; $repl = $2;
+ $repl =~ s/\+/:/g;
+ $repl =~ s/-/:-/g;
+ $one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list
+ $repl =~ s/:/:-/g;
+ $one_of_these =~ s/:-$name:/:-$repl:/;
+ next line;
+ }
+
+ # we have a normal line
+
+ @attr = split(' '); # a list of attributes to match against
+ # which we put into an array
+ $host = $attr[0]; # the first attribute is the host name
+ if ($showhost) {
+ $showhost = "$host:\t";
+ }
+
+ $wanted = 0;
+ foreach $attr (@attr) { # iterate over attribute array
+ $wanted++ if index($one_of_these,":$attr:") >= 0;
+ $wanted = -9999 if index($one_of_these,":-$attr:") >= 0;
+ }
+ if ($wanted > 0) {
+ print "rsh $host$l$n '$cmd'\n" unless $silent;
+ $SIG{'INT'} = 'DEFAULT';
+ if (open(pipe,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh
+ $SIG{'INT'} = 'cont';
+ for ($iter=0; <pipe>; $iter++) {
+ unless ($iter) {
+ $remainder .= "$host+"
+ if /Connection timed out|Permission denied/;
+ }
+ print $showhost,$_;
+ }
+ close(pipe);
+ } else {
+ $SIG{'INT'} = 'cont';
+ print "(Can't execute rsh.)\n";
+ }
+ }
+}
+
+unlink "/tmp/gsh$$" if $dodist;
+
+if ($remainder) {
+ chop($remainder);
+ open(grem,">.grem") || (printf stderr "Can't make a .grem file\n");
+ print grem 'rem=', $remainder, "\n";
+ close(grem);
+ print 'rem=', $remainder, "\n";
+}
+
+# here are a couple of subroutines that serve as signal handlers
+
+sub cont {
+ print "\rContinuing...\n";
+ $remainder .= "$host+";
+}
+
+sub quit {
+ $| = 1;
+ print "\r";
+ $SIG{'INT'} = '';
+ kill 2, $$;
+}
--- /dev/null
+.\" $Header: gsh.man,v 2.0 88/06/05 00:17:23 root Exp $
+.TH GSH 8 "13 May 1988"
+.SH NAME
+gsh \- global shell
+.SH SYNOPSIS
+.B gsh
+[options]
+.I host
+[options]
+.I command
+.SH DESCRIPTION
+.I gsh
+works just like rsh(1C) except that you may specify a set of hosts to execute
+the command on.
+The host sets are defined in the file /etc/ghosts.
+(An individual host name can be used as a set containing one member.)
+You can give a command like
+
+ gsh sun /etc/mungmotd
+
+to run /etc/mungmotd on all your Suns.
+.P
+You may specify the union of two or more sets by using + as follows:
+
+ gsh 750+mc /etc/mungmotd
+
+which will run mungmotd on all 750's and Masscomps.
+.P
+Commonly used sets should be defined in /etc/ghosts.
+For example, you could add a line that says
+
+ pep=manny+moe+jack
+
+Another way to do that would be to add the word "pep" after each of the host
+entries:
+
+ manny sun3 pep
+.br
+ moe sun3 pep
+.br
+ jack sun3 pep
+
+Hosts and sets of host can also be excluded:
+
+ foo=sun-sun2
+
+Any host so excluded will never be included, even if a subsequent set on the
+line includes it:
+
+ foo=abc+def
+ bar=xyz-abc+foo
+
+comes out to xyz+def.
+
+You can define private host sets by creating .ghosts in your current directory
+with entries just like /etc/ghosts.
+Also, if there is a file .grem, it defines "rem" to be the remaining hosts
+from the last gsh or gcp that didn't succeed everywhere.
+
+Options include all those defined by rsh, as well as
+
+.IP "\-d" 8
+Causes gsh to collect input till end of file, and then distribute that input
+to each invokation of rsh.
+.IP "\-h" 8
+Rather than print out the command followed by the output, merely prepends the
+host name to each line of output.
+.IP "\-s" 8
+Do work silently.
+.PP
+Interrupting with a SIGINT will cause the rsh to the current host to be skipped
+and execution resumed with the next host.
+To stop completely, send a SIGQUIT.
+.SH SEE ALSO
+rsh(1C)
+.SH BUGS
+All the bugs of rsh, since it calls rsh.
+
+Also, will not properly return data from the remote execution that contains
+null characters.
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: myrup,v 2.0 88/06/05 00:16:51 root Exp $
+
+# This was a customization of ruptime requested by someone here who wanted
+# to be able to find the least loaded machine easily. It uses the
+# /etc/ghosts file that's defined for gsh and gcp to prune down the
+# number of entries to those hosts we have administrative control over.
+
+print "node load (u)\n------- --------\n";
+
+open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts";
+line: while (<ghosts>) {
+ next line if /^#/;
+ next line if /^$/;
+ next line if /=/;
+ ($host) = split;
+ $wanted{$host} = 1;
+}
+
+open(ruptime,'ruptime|') || die "Can't run ruptime";
+open(sort,'|sort +1n');
+
+while (<ruptime>) {
+ ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/);
+ if ($wanted{$host} && $upness eq 'up') {
+ printf sort "%s\t%s (%d)\n", $host, $load, $users;
+ }
+}
--- /dev/null
+eval "exec /usr/bin/perl -Spi.bak $0 $*"
+ if $running_under_some_shell;
+
+# $Header: nih,v 2.0 88/06/05 00:16:54 root Exp $
+
+# This script makes #! scripts directly executable on machines that don't
+# support #!. It edits in place any scripts mentioned on the command line.
+
+s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;|
+ if $. == 1;
--- /dev/null
+#!/usr/bin/perl -n
+
+# $Header: rmfrom,v 2.0 88/06/05 00:16:57 root Exp $
+
+# A handy (but dangerous) script to put after a find ... -print.
+
+chop; unlink;
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_df,v 2.0 88/06/05 00:17:56 root Exp $
+
+# This report points out filesystems that are in danger of overflowing.
+
+(chdir '/usr/adm/private/memories') || die "Can't cd.";
+`df >newdf`;
+open(Df, 'olddf');
+
+while (<Df>) {
+ ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
+ next if $fs =~ /:/;
+ next if $fs eq '';
+ $oldused{$fs} = $used;
+}
+
+open(Df, 'newdf') || die "scan_df: can't open newdf";
+
+while (<Df>) {
+ ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
+ next if $fs =~ /:/;
+ next if $fs eq '';
+ $oldused = $oldused{$fs};
+ next if ($oldused == $used && $capacity < 99); # inactive filesystem
+ if ($capacity >= 90) {
+#if defined(mc300) || defined(mc500) || defined(mc700)
+ $_ = substr($_,0,13) . ' ' . substr($_,13,1000);
+ $kbytes /= 2; # translate blocks to K
+ $used /= 2;
+ $oldused /= 2;
+ $avail /= 2;
+#endif
+ $diff = int($used - $oldused);
+ if ($avail < $diff * 2) { # mark specially if in danger
+ $mounted_on .= ' *';
+ }
+ next if $diff < 50 && $mounted_on eq '/';
+ $fs =~ s|/dev/||;
+ if ($diff >= 0) {
+ $diff = '(+' . $diff . ')';
+ }
+ else {
+ $diff = '(' . $diff . ')';
+ }
+ printf "%-8s%8d%8d %-8s%8d%7s %s\n",
+ $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on;
+ }
+}
+
+rename('newdf','olddf');
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_last,v 2.0 88/06/05 00:17:58 root Exp $
+
+# This reports who was logged on at weird hours
+
+($dy, $mo, $lastdt) = split(/ +/,`date`);
+
+open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last";
+
+while (<Last>) {
+#if defined(mc300) || defined(mc500) || defined(mc700)
+ $_ = substr($_,0,19) . substr($_,23,100);
+#endif
+ next if /^$/;
+ (print),next if m|^/|;
+ $login = substr($_,0,8);
+ $tty = substr($_,10,7);
+ $from = substr($_,19,15);
+ $day = substr($_,36,3);
+ $mo = substr($_,40,3);
+ $dt = substr($_,44,2);
+ $hr = substr($_,47,2);
+ $min = substr($_,50,2);
+ $dash = substr($_,53,1);
+ $tohr = substr($_,55,2);
+ $tomin = substr($_,58,2);
+ $durhr = substr($_,63,2);
+ $durmin = substr($_,66,2);
+
+ next unless $hr;
+ next if $login eq 'reboot ';
+ next if $login eq 'shutdown';
+
+ if ($dt != $lastdt) {
+ if ($lastdt < $dt) {
+ $seen += $dt - $lastdt;
+ }
+ else {
+ $seen++;
+ }
+ $lastdt = $dt;
+ }
+
+ $inat = $hr + $min / 60;
+ if ($tohr =~ /^[a-z]/) {
+ $outat = 12; # something innocuous
+ } else {
+ $outat = $tohr + $tomin / 60;
+ }
+
+ last if $seen + ($inat < 8) > 1;
+
+ if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) {
+ print;
+ }
+}
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_messages,v 2.0 88/06/05 00:17:46 root Exp $
+
+# This prints out extraordinary console messages. You'll need to customize.
+
+chdir('/usr/adm/private/memories') || die "Can't cd.";
+
+$maxpos = `cat oldmsgs 2>&1`;
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+open(Msgs, '/dev/null') || die "scan_messages: can't open messages";
+#else
+open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages";
+#endif
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat(Msgs);
+
+if ($size < $maxpos) { # Did somebody truncate messages file?
+ $maxpos = 0;
+}
+
+seek(Msgs,$maxpos,0); # Start where we left off last time.
+
+while (<Msgs>) {
+ s/\[(\d+)\]/#/ && s/$1/#/g;
+#ifdef vax
+ $_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//;
+ next if /root@.*:/;
+ next if /^vmunix: 4.3 BSD UNIX/;
+ next if /^vmunix: Copyright/;
+ next if /^vmunix: avail mem =/;
+ next if /^vmunix: SBIA0 at /;
+ next if /^vmunix: disk ra81 is/;
+ next if /^vmunix: dmf. at uba/;
+ next if /^vmunix: dmf.:.*asynch/;
+ next if /^vmunix: ex. at uba/;
+ next if /^vmunix: ex.: HW/;
+ next if /^vmunix: il. at uba/;
+ next if /^vmunix: il.: hardware/;
+ next if /^vmunix: ra. at uba/;
+ next if /^vmunix: ra.: media/;
+ next if /^vmunix: real mem/;
+ next if /^vmunix: syncing disks/;
+ next if /^vmunix: tms/;
+ next if /^vmunix: tmscp. at uba/;
+ next if /^vmunix: uba. at /;
+ next if /^vmunix: uda. at /;
+ next if /^vmunix: uda.: unit . ONLIN/;
+ next if /^vmunix: .*buffers containing/;
+ next if /^syslogd: .*newslog/;
+#endif
+ next if /unknown service/;
+ next if /^\.\.\.$/;
+ if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) {
+ $pfx = '';
+ next;
+ }
+ next if /^[ \t]*$/;
+ next if /^[ 0-9]*done$/;
+ if (/^A/) {
+ next if /^Accounting [sr]/;
+ }
+ elsif (/^C/) {
+ next if /^Called from/;
+ next if /^Copyright/;
+ }
+ elsif (/^E/) {
+ next if /^End traceback/;
+ next if /^Ethernet address =/;
+ }
+ elsif (/^K/) {
+ next if /^KERNEL MODE/;
+ }
+ elsif (/^R/) {
+ next if /^Rebooting Unix/;
+ }
+ elsif (/^S/) {
+ next if /^Sun UNIX 4\.2 Release/;
+ }
+ elsif (/^W/) {
+ next if /^WARNING: clock gained/;
+ }
+ elsif (/^a/) {
+ next if /^arg /;
+ next if /^avail mem =/;
+ }
+ elsif (/^b/) {
+ next if /^bwtwo[0-9] at /;
+ }
+ elsif (/^c/) {
+ next if /^cgone[0-9] at /;
+ next if /^cdp[0-9] at /;
+ next if /^csr /;
+ }
+ elsif (/^d/) {
+ next if /^dcpa: init/;
+ next if /^done$/;
+ next if /^dts/;
+ next if /^dump i\/o error/;
+ next if /^dumping to dev/;
+ next if /^dump succeeded/;
+ $pfx = '*' if /^dev = /;
+ }
+ elsif (/^e/) {
+ next if /^end \*\*/;
+ next if /^error in copy/;
+ }
+ elsif (/^f/) {
+ next if /^found /;
+ }
+ elsif (/^i/) {
+ next if /^ib[0-9] at /;
+ next if /^ie[0-9] at /;
+ }
+ elsif (/^l/) {
+ next if /^le[0-9] at /;
+ }
+ elsif (/^m/) {
+ next if /^mem = /;
+ next if /^mt[0-9] at /;
+ next if /^mti[0-9] at /;
+ $pfx = '*' if /^mode = /;
+ }
+ elsif (/^n/) {
+ next if /^not found /;
+ }
+ elsif (/^p/) {
+ next if /^page map /;
+ next if /^pi[0-9] at /;
+ $pfx = '*' if /^panic/;
+ }
+ elsif (/^q/) {
+ next if /^qqq /;
+ }
+ elsif (/^r/) {
+ next if /^read /;
+ next if /^revarp: Requesting/;
+ next if /^root [od]/;
+ }
+ elsif (/^s/) {
+ next if /^sc[0-9] at /;
+ next if /^sd[0-9] at /;
+ next if /^sd[0-9]: </;
+ next if /^si[0-9] at /;
+ next if /^si_getstatus/;
+ next if /^sk[0-9] at /;
+ next if /^skioctl/;
+ next if /^skopen/;
+ next if /^skprobe/;
+ next if /^skread/;
+ next if /^skwrite/;
+ next if /^sky[0-9] at /;
+ next if /^st[0-9] at /;
+ next if /^st0:.*load/;
+ next if /^stat1 = /;
+ next if /^syncing disks/;
+ next if /^syslogd: going down on signal 15/;
+ }
+ elsif (/^t/) {
+ next if /^timeout [0-9]/;
+ next if /^tm[0-9] at /;
+ next if /^tod[0-9] at /;
+ next if /^tv [0-9]/;
+ $pfx = '*' if /^trap address/;
+ }
+ elsif (/^u/) {
+ next if /^unit nsk/;
+ next if /^use one of/;
+ $pfx = '' if /^using/;
+ next if /^using [0-9]+ buffers/;
+ }
+ elsif (/^x/) {
+ next if /^xy[0-9] at /;
+ next if /^write [0-9]/;
+ next if /^xy[0-9]: </;
+ next if /^xyc[0-9] at /;
+ }
+ elsif (/^y/) {
+ next if /^yyy [0-9]/;
+ }
+ elsif (/^z/) {
+ next if /^zs[0-9] at /;
+ }
+ $pfx = '*' if /^[a-z]+:$/;
+ s/pid [0-9]+: //;
+ if (/last message repeated ([0-9]+) time/) {
+ $seen{$last} += $1;
+ next;
+ }
+ s/^/$pfx/ if $pfx;
+ unless ($seen{$_}++) {
+ push(@seen,$_);
+ }
+ $last = $_;
+}
+$max = tell(Msgs);
+
+open(tmp,'|sort >oldmsgs.tmp') || die "Can't create tmp file.";
+while ($_ = pop(@seen)) {
+ print tmp $_;
+}
+close(tmp);
+open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file.";
+while (<tmp>) {
+ if (/^nd:/) {
+ next if $seen{$_} < 20;
+ }
+ if (/NFS/) {
+ next if $seen{$_} < 20;
+ }
+ if (/no carrier/) {
+ next if $seen{$_} < 20;
+ }
+ if (/silo overflow/) {
+ next if $seen{$_} < 20;
+ }
+ print $seen{$_},":\t",$_;
+}
+
+print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`;
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: scan_passwd,v 2.0 88/06/05 00:17:49 root Exp $
+
+# This scans passwd file for security holes.
+
+open(Pass,'/etc/passwd') || die "Can't open passwd file";
+# $dotriv = (`date` =~ /^Mon/);
+$dotriv = 1;
+
+while (<Pass>) {
+ ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/);
+ if ($shell eq '') {
+ print "Short: $_";
+ }
+ next if /^[+]/;
+ if ($pass eq '') {
+ if (index(":sync:lpq:+:", ":$login:") < 0) {
+ print "No pass: $login\t$gcos\n";
+ }
+ }
+ elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) {
+ print "Trivial: $login\t$gcos\n";
+ }
+ if ($uid == 0) {
+ if ($login !~ /^.?root$/ && $pass ne '*') {
+ print "Extra root: $_";
+ }
+ }
+}
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_ps,v 2.0 88/06/05 00:17:51 root Exp $
+
+# This looks for looping processes.
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps";
+
+while (<Ps>) {
+ next if /rwhod/;
+ print if index(' T', substr($_,62,1)) < 0;
+}
+#else
+open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps";
+
+while (<Ps>) {
+ next if /dataserver/;
+ next if /nfsd/;
+ next if /update/;
+ next if /ypserv/;
+ next if /rwhod/;
+ next if /routed/;
+ next if /pagedaemon/;
+#ifdef vax
+ ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split;
+#else
+ ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split;
+#endif
+ print if length($time) > 4;
+}
+#endif
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_sudo,v 2.0 88/06/05 00:18:01 root Exp $
+
+# Analyze the sudo log.
+
+chdir('/usr/adm/private/memories') || die "Can't cd.";
+
+if (open(Oldsudo,'oldsudo')) {
+ $maxpos = <Oldsudo>;
+ close Oldsudo;
+}
+else {
+ $maxpos = 0;
+ `echo 0 >oldsudo`;
+}
+
+unless (open(Sudo, '/usr/adm/sudo.log')) {
+ print "Somebody removed sudo.log!!!\n" if $maxpos;
+ exit 0;
+}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat(Sudo);
+
+if ($size < $maxpos) {
+ $maxpos = 0;
+ print "Somebody reset sudo.log!!!\n";
+}
+
+seek(Sudo,$maxpos,0);
+
+while (<Sudo>) {
+ s/^.* :[ \t]+//;
+ s/ipcrm.*/ipcrm/;
+ s/kill.*/kill/;
+ unless ($seen{$_}++) {
+ push(@seen,$_);
+ }
+ $last = $_;
+}
+$max = tell(Sudo);
+
+open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file.";
+while ($_ = pop(@seen)) {
+ print tmp $_;
+}
+close(tmp);
+open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file.";
+while (<tmp>) {
+ print $seen{$_},":\t",$_;
+}
+
+print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`;
--- /dev/null
+#!/usr/bin/perl -P
+
+# $Header: scan_suid,v 2.0 88/06/05 00:17:54 root Exp $
+
+# Look for new setuid root files.
+
+chdir '/usr/adm/private/memories' || die "Can't cd.";
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('oldsuid');
+if ($nlink) {
+ $lasttime = $mtime;
+ $tmp = $ctime - $atime;
+ if ($tmp <= 0 || $tmp >= 10) {
+ print "WARNING: somebody has read oldsuid!\n";
+ }
+ $tmp = $ctime - $mtime;
+ if ($tmp <= 0 || $tmp >= 10) {
+ print "WARNING: somebody has modified oldsuid!!!\n";
+ }
+} else {
+ $lasttime = time - 60 * 60 * 24; # one day ago
+}
+$thistime = time;
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+open(Find, 'find / -perm -04000 -print |') ||
+ die "scan_find: can't run find";
+#else
+open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') ||
+ die "scan_find: can't run find";
+#endif
+
+open(suid, '>newsuid.tmp');
+
+while (<Find>) {
+
+#if defined(mc300) || defined(mc500) || defined(mc700)
+ $x = `/bin/ls -il $_`;
+ $_ = $x;
+ s/^ *//;
+ ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
+ = split;
+#else
+ s/^ *//;
+ ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
+ = split;
+#endif
+
+ if ($perm =~ /[sS]/ && $owner eq 'root') {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($name);
+ $foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n",
+ $perm,$links,$owner,$group,$size,$month,$day,$name,$inode);
+ print suid $foo;
+ if ($ctime > $lasttime) {
+ if ($ctime > $thistime) {
+ print "Future file: $foo";
+ }
+ else {
+ $ct .= $foo;
+ }
+ }
+ }
+}
+close(suid);
+
+print `sort +7 -8 newsuid.tmp >newsuid 2>&1`;
+$foo = `/bin/diff oldsuid newsuid 2>&1`;
+print "Differences in suid info:\n",$foo if $foo;
+print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`;
+print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`;
+print `rm -f newsuid.tmp 2>&1`;
+
+@ct = split(/\n/,$ct);
+$ct = '';
+$* = 1;
+while ($#ct >= 0) {
+ $tmp = shift(@ct);
+ unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; }
+}
+
+print "Inode changed since last time:\n",$ct if $ct;
+
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: scanner,v 2.0 88/06/05 00:17:42 root Exp $
+
+# This runs all the scan_* routines on all the machines in /etc/ghosts.
+# We run this every morning at about 6 am:
+
+# !/bin/sh
+# cd /usr/adm/private
+# decrypt scanner | perl >scan.out 2>&1
+# mail admin <scan.out
+
+# Note that the scan_* files should be encrypted with the key "-inquire", and
+# scanner should be encrypted somehow so that people can't find that key.
+# I leave it up to you to figure out how to unencrypt it before executing.
+
+$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.';
+
+$| = 1; # command buffering on stdout
+
+print "Subject: bizarre happenings\n\n";
+
+(chdir '/usr/adm/private') || die "Can't cd.";
+
+if ($#ARGV >= 0) {
+ @scanlist = @ARGV;
+} else {
+ @scanlist = split(/[ \t\n]+/,`echo scan_*`);
+}
+
+scan: while ($scan = shift(@scanlist)) {
+ print "\n********** $scan **********\n";
+ $showhost++;
+
+ $systype = 'all';
+
+ open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file';
+
+ $one_of_these = ":$systype:";
+ if ($systype =~ s/\+/[+]/g) {
+ $one_of_these =~ s/\+/:/g;
+ }
+
+ line: while (<ghosts>) {
+ s/[ \t]*\n//;
+ if (!$_ || /^#/) {
+ next line;
+ }
+ if (/^([a-zA-Z_0-9]+)=(.+)/) {
+ $name = $1; $repl = $2;
+ $repl =~ s/\+/:/g;
+ $one_of_these =~ s/:$name:/:$repl:/;
+ next line;
+ }
+ @gh = split;
+ $host = $gh[0];
+ if ($showhost) { $showhost = "$host:\t"; }
+ class: while ($class = pop(gh)) {
+ if (index($one_of_these,":$class:") >=0) {
+ $iter = 0;
+ `exec crypt -inquire <$scan >.x 2>/dev/null`;
+ unless (open(scan,'.x')) {
+ print "Can't run $scan.";
+ next scan;
+ }
+ $cmd = <scan>;
+ unless ($cmd =~ s/#!(.*)\n/$1/) {
+ $cmd = '/usr/bin/perl';
+ }
+ close(scan);
+ if (open(pipe,"exec rsh $host '$cmd' <.x|")) {
+ sleep(5);
+ unlink '.x';
+ while (<pipe>) {
+ last if $iter++ > 1000; # must be looping
+ next if /^[0-9.]+u [0-9.]+s/;
+ print $showhost,$_;
+ }
+ close(pipe);
+ } else {
+ print "(Can't execute rsh.)\n";
+ }
+ last class;
+ }
+ }
+ }
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: shmkill,v 2.0 88/06/05 00:16:59 root Exp $
+
+# A script to call from crontab periodically when people are leaving shared
+# memory sitting around unattached.
+
+open(ipcs,'ipcs -m -o|') || die "Can't run ipcs";
+
+while (<ipcs>) {
+ $tmp = index($_,'NATTCH');
+ $pos = $tmp if $tmp >= 0;
+ if (/^m/) {
+ ($m,$id,$key,$mode,$owner,$group,$attach) = split;
+ if ($attach != substr($_,$pos,6)) {
+ die "Different ipcs format--can't parse!";
+ }
+ if ($attach == 0) {
+ push(@goners,'-m',$id);
+ }
+ }
+}
+
+exec 'ipcrm', @goners if $#goners >= 0;
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: empty,v 2.0 88/06/05 00:17:39 root Exp $
+
+# This script empties a trashcan.
+
+$recursive = shift if $ARGV[0] eq '-r';
+
+@ARGV = '.' if $#ARGV < 0;
+
+chop($pwd = `pwd`);
+
+dir: foreach $dir (@ARGV) {
+ unless (chdir $dir) {
+ print stderr "Can't find directory $dir\n";
+ next dir;
+ }
+ if ($recursive) {
+ do cmd('find . -name .deleted -exec /bin/rm -rf {} ;');
+ }
+ else {
+ if (-d '.deleted') {
+ do cmd('rm -rf .deleted');
+ }
+ else {
+ if ($dir eq '.' && $pwd =~ m|/\.deleted$|) {
+ chdir '..';
+ do cmd('rm -rf .deleted');
+ }
+ else {
+ print stderr "No trashcan found in directory $dir\n";
+ }
+ }
+ }
+}
+continue {
+ chdir $pwd;
+}
+
+# force direct execution with no shell
+
+sub cmd {
+ system split(' ',join(' ',@_));
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: unvanish,v 2.0 88/06/05 00:17:30 root Exp $
+
+sub it {
+ if ($olddir ne '.') {
+ chop($pwd = `pwd`) if $pwd eq '';
+ (chdir $olddir) || die "Directory $olddir is not accesible";
+ }
+ unless ($olddir eq '.deleted') {
+ if (-d '.deleted') {
+ chdir '.deleted' || die "Directory .deleted is not accesible";
+ }
+ else {
+ chop($pwd = `pwd`) if $pwd eq '';
+ die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/;
+ }
+ }
+ print `mv $startfiles$filelist..$force`;
+ if ($olddir ne '.') {
+ (chdir $pwd) || die "Can't get back to original directory: $pwd";
+ }
+}
+
+if ($#ARGV < 0) {
+ open(lastcmd,'.deleted/.lastcmd') ||
+ open(lastcmd,'.lastcmd') ||
+ die "No previous vanish in this dir";
+ $ARGV = <lastcmd>;
+ close(lastcmd);
+ @ARGV = split(/[\n ]+/,$ARGV);
+}
+
+while ($ARGV[0] =~ /^-/) {
+ $_ = shift;
+ /^-f/ && ($force = ' >/dev/null 2>&1');
+ /^-i/ && ($interactive = 1);
+ if (/^-+$/) {
+ $startfiles = '- ';
+ last;
+ }
+}
+
+while ($file = shift) {
+ if ($file =~ s|^(.*)/||) {
+ $dir = $1;
+ }
+ else {
+ $dir = '.';
+ }
+
+ if ($dir ne $olddir) {
+ do it() if $olddir;
+ $olddir = $dir;
+ }
+
+ if ($interactive) {
+ print "unvanish: restore $dir/$file? ";
+ next unless <stdin> =~ /^y/i;
+ }
+
+ $filelist .= $file; $filelist .= ' ';
+
+}
+
+do it() if $olddir;
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: vanexp,v 2.0 88/06/05 00:17:34 root Exp $
+
+# This is for running from a find at night to expire old .deleteds
+
+$can = $ARGV[0];
+
+exit 1 unless $can =~ /.deleted$/;
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($can);
+
+exit 0 unless $size;
+
+if (time - $mtime > 2 * 24 * 60 * 60) {
+ `/bin/rm -rf $can`;
+}
+else {
+ `find $can -ctime +2 -exec rm -f {} \;`;
+}
--- /dev/null
+#!/usr/bin/perl
+
+# $Header: vanish,v 2.0 88/06/05 00:17:36 root Exp $
+
+sub it {
+ if ($olddir ne '.') {
+ chop($pwd = `pwd`) if $pwd eq '';
+ (chdir $olddir) || die "Directory $olddir is not accesible";
+ }
+ if (!-d .deleted) {
+ print `mkdir .deleted; chmod 775 .deleted`;
+ die "You can't remove files from $olddir" if $?;
+ }
+ $filelist =~ s/ $//;
+ $filelist =~ s/#/\\#/g;
+ if ($filelist !~ /^[ \t]*$/) {
+ open(lastcmd,'>.deleted/.lastcmd');
+ print lastcmd $filelist,"\n";
+ close(lastcmd);
+ print `/bin/mv $startfiles$filelist .deleted$force`;
+ }
+ if ($olddir ne '.') {
+ (chdir $pwd) || die "Can't get back to original directory: $pwd";
+ }
+}
+
+while ($ARGV[0] =~ /^-/) {
+ $_ = shift;
+ /^-f/ && ($force = ' >/dev/null 2>&1');
+ /^-i/ && ($interactive = 1);
+ if (/^-+$/) {
+ $startfiles = '- ';
+ last;
+ }
+}
+
+chop($pwd = `pwd`);
+
+while ($file = shift) {
+ if ($file =~ s|^(.*)/||) {
+ $dir = $1;
+ }
+ else {
+ $dir = '.';
+ }
+
+ if ($interactive) {
+ print "vanish: remove $dir/$file? ";
+ next unless <stdin> =~ /^y/i;
+ }
+
+ if ($file eq '.deleted') {
+ print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n";
+ next;
+ }
+
+ if ($dir ne $olddir) {
+ do it() if $olddir;
+ $olddir = $dir;
+ }
+
+ $filelist .= $file; $filelist .= ' ';
+}
+
+do it() if $olddir;
--- /dev/null
+/* $Header: eval.c,v 2.0 88/06/05 00:08:48 root Exp $
+ *
+ * $Log: eval.c,v $
+ * Revision 2.0 88/06/05 00:08:48 root
+ * Baseline version 2.0.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#include <signal.h>
+#include <errno.h>
+
+extern int errno;
+
+#ifdef VOIDSIG
+static void (*ihand)();
+static void (*qhand)();
+#else
+static int (*ihand)();
+static int (*qhand)();
+#endif
+
+ARG *debarg;
+STR str_args;
+
+STR *
+eval(arg,retary,sargoff)
+register ARG *arg;
+STR ***retary; /* where to return an array to, null if nowhere */
+int sargoff; /* how many elements in sarg are already assigned */
+{
+ register STR *str;
+ register int anum;
+ register int optype;
+ int maxarg;
+ int maxsarg;
+ double value;
+ STR *quicksarg[5];
+ register STR **sarg = quicksarg;
+ register char *tmps;
+ char *tmps2;
+ int argflags;
+ int argtype;
+ union argptr argptr;
+ int cushion;
+ unsigned long tmplong;
+ long when;
+ FILE *fp;
+ STR *tmpstr;
+ FCMD *form;
+ STAB *stab;
+ ARRAY *ary;
+ bool assigning = FALSE;
+ double exp(), log(), sqrt(), modf();
+ char *crypt(), *getenv();
+
+ if (!arg)
+ return &str_no;
+ str = arg->arg_ptr.arg_str;
+ optype = arg->arg_type;
+ maxsarg = maxarg = arg->arg_len;
+ if (maxsarg > 3 || retary) {
+ if (sargoff >= 0) { /* array already exists, just append to it */
+ cushion = 10;
+ sarg = (STR **)saferealloc((char*)*retary,
+ (maxsarg+sargoff+2+cushion) * sizeof(STR*)) + sargoff;
+ /* Note that sarg points into the middle of the array */
+ }
+ else {
+ sargoff = cushion = 0;
+ sarg = (STR **)safemalloc((maxsarg+2) * sizeof(STR*));
+ }
+ }
+ else
+ sargoff = 0;
+#ifdef DEBUGGING
+ if (debug) {
+ if (debug & 8) {
+ deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg);
+ }
+ debname[dlevel] = opname[optype][0];
+ debdelim[dlevel++] = ':';
+ }
+#endif
+ for (anum = 1; anum <= maxarg; anum++) {
+ argflags = arg[anum].arg_flags;
+ if (argflags & AF_SPECIAL)
+ continue;
+ argtype = arg[anum].arg_type;
+ argptr = arg[anum].arg_ptr;
+ re_eval:
+ switch (argtype) {
+ default:
+ sarg[anum] = &str_no;
+#ifdef DEBUGGING
+ tmps = "NULL";
+#endif
+ break;
+ case A_EXPR:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ tmps = "EXPR";
+ deb("%d.EXPR =>\n",anum);
+ }
+#endif
+ if (retary &&
+ (optype == O_LIST || optype == O_ITEM2 || optype == O_ITEM3)) {
+ *retary = sarg - sargoff;
+ eval(argptr.arg_arg, retary, anum - 1 + sargoff);
+ sarg = *retary; /* they do realloc it... */
+ argtype = maxarg - anum; /* how many left? */
+ maxsarg = (int)(str_gnum(sarg[0])) + argtype;
+ sargoff = maxsarg - maxarg;
+ if (argtype > 9 - cushion) { /* we don't have room left */
+ sarg = (STR **)saferealloc((char*)sarg,
+ (maxsarg+2+cushion) * sizeof(STR*));
+ }
+ sarg += sargoff;
+ }
+ else
+ sarg[anum] = eval(argptr.arg_arg, Null(STR***),-1);
+ break;
+ case A_CMD:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ tmps = "CMD";
+ deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd);
+ }
+#endif
+ sarg[anum] = cmd_exec(argptr.arg_cmd);
+ break;
+ case A_STAB:
+ sarg[anum] = STAB_STR(argptr.arg_stab);
+#ifdef DEBUGGING
+ if (debug & 8) {
+ sprintf(buf,"STAB $%s",argptr.arg_stab->stab_name);
+ tmps = buf;
+ }
+#endif
+ break;
+ case A_LEXPR:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ tmps = "LEXPR";
+ deb("%d.LEXPR =>\n",anum);
+ }
+#endif
+ str = eval(argptr.arg_arg,Null(STR***),-1);
+ if (!str)
+ fatal("panic: A_LEXPR");
+ goto do_crement;
+ case A_LVAL:
+#ifdef DEBUGGING
+ if (debug & 8) {
+ sprintf(buf,"LVAL $%s",argptr.arg_stab->stab_name);
+ tmps = buf;
+ }
+#endif
+ str = STAB_STR(argptr.arg_stab);
+ if (!str)
+ fatal("panic: A_LVAL");
+ do_crement:
+ assigning = TRUE;
+ if (argflags & AF_PRE) {
+ if (argflags & AF_UP)
+ str_inc(str);
+ else
+ str_dec(str);
+ STABSET(str);
+ sarg[anum] = str;
+ str = arg->arg_ptr.arg_str;
+ }
+ else if (argflags & AF_POST) {
+ sarg[anum] = str_static(str);
+ if (argflags & AF_UP)
+ str_inc(str);
+ else
+ str_dec(str);
+ STABSET(str);
+ str = arg->arg_ptr.arg_str;
+ }
+ else {
+ sarg[anum] = str;
+ }
+ break;
+ case A_LARYLEN:
+ str = sarg[anum] =
+ argptr.arg_stab->stab_array->ary_magic;
+#ifdef DEBUGGING
+ tmps = "LARYLEN";
+#endif
+ if (!str)
+ fatal("panic: A_LEXPR");
+ goto do_crement;
+ case A_ARYLEN:
+ stab = argptr.arg_stab;
+ sarg[anum] = stab->stab_array->ary_magic;
+ str_numset(sarg[anum],(double)(stab->stab_array->ary_fill+arybase));
+#ifdef DEBUGGING
+ tmps = "ARYLEN";
+#endif
+ break;
+ case A_SINGLE:
+ sarg[anum] = argptr.arg_str;
+#ifdef DEBUGGING
+ tmps = "SINGLE";
+#endif
+ break;
+ case A_DOUBLE:
+ (void) interp(str,str_get(argptr.arg_str));
+ sarg[anum] = str;
+#ifdef DEBUGGING
+ tmps = "DOUBLE";
+#endif
+ break;
+ case A_BACKTICK:
+ tmps = str_get(argptr.arg_str);
+ fp = popen(str_get(interp(str,tmps)),"r");
+ tmpstr = str_new(80);
+ str_set(str,"");
+ if (fp) {
+ while (str_gets(tmpstr,fp) != Nullch) {
+ str_scat(str,tmpstr);
+ }
+ statusvalue = pclose(fp);
+ }
+ else
+ statusvalue = -1;
+ str_free(tmpstr);
+
+ sarg[anum] = str;
+#ifdef DEBUGGING
+ tmps = "BACK";
+#endif
+ break;
+ case A_INDREAD:
+ last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE);
+ goto do_read;
+ case A_GLOB:
+ argflags |= AF_POST; /* enable newline chopping */
+ case A_READ:
+ last_in_stab = argptr.arg_stab;
+ do_read:
+ fp = Nullfp;
+ if (last_in_stab->stab_io) {
+ fp = last_in_stab->stab_io->fp;
+ if (!fp) {
+ if (last_in_stab->stab_io->flags & IOF_ARGV) {
+ if (last_in_stab->stab_io->flags & IOF_START) {
+ last_in_stab->stab_io->flags &= ~IOF_START;
+ last_in_stab->stab_io->lines = 0;
+ if (alen(last_in_stab->stab_array) < 0) {
+ tmpstr = str_make("-"); /* assume stdin */
+ apush(last_in_stab->stab_array, tmpstr);
+ }
+ }
+ fp = nextargv(last_in_stab);
+ if (!fp) /* Note: fp != last_in_stab->stab_io->fp */
+ do_close(last_in_stab,FALSE); /* now it does */
+ }
+ else if (argtype == A_GLOB) {
+ (void) interp(str,str_get(last_in_stab->stab_val));
+ tmps = str->str_ptr;
+ if (*tmps == '!')
+ sprintf(tokenbuf,"%s|",tmps+1);
+ else {
+ if (*tmps == ';')
+ sprintf(tokenbuf, "%s", tmps+1);
+ else
+ sprintf(tokenbuf, "echo %s", tmps);
+ strcat(tokenbuf,
+ "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
+ }
+ do_open(last_in_stab,tokenbuf);
+ fp = last_in_stab->stab_io->fp;
+ }
+ }
+ }
+ if (!fp && dowarn)
+ warn("Read on closed filehandle <%s>",last_in_stab->stab_name);
+ keepgoing:
+ if (!fp)
+ sarg[anum] = &str_no;
+ else if (!str_gets(str,fp)) {
+ if (last_in_stab->stab_io->flags & IOF_ARGV) {
+ fp = nextargv(last_in_stab);
+ if (fp)
+ goto keepgoing;
+ do_close(last_in_stab,FALSE);
+ last_in_stab->stab_io->flags |= IOF_START;
+ }
+ else if (argflags & AF_POST) {
+ do_close(last_in_stab,FALSE);
+ }
+ if (fp == stdin) {
+ clearerr(fp);
+ }
+ sarg[anum] = &str_no;
+ if (retary) {
+ maxarg = anum - 1;
+ maxsarg = maxarg + sargoff;
+ }
+ break;
+ }
+ else {
+ last_in_stab->stab_io->lines++;
+ sarg[anum] = str;
+ if (argflags & AF_POST) {
+ if (str->str_cur > 0)
+ str->str_cur--;
+ str->str_ptr[str->str_cur] = '\0';
+ }
+ if (retary) {
+ sarg[anum] = str_static(sarg[anum]);
+ anum++;
+ if (anum > maxarg) {
+ maxarg = anum + anum;
+ maxsarg = maxarg + sargoff;
+ sarg = (STR **)saferealloc((char*)(sarg-sargoff),
+ (maxsarg+2+cushion) * sizeof(STR*)) + sargoff;
+ }
+ goto keepgoing;
+ }
+ }
+ if (retary) {
+ maxarg = anum - 1;
+ maxsarg = maxarg + sargoff;
+ }
+#ifdef DEBUGGING
+ tmps = "READ";
+#endif
+ break;
+ }
+#ifdef DEBUGGING
+ if (debug & 8)
+ deb("%d.%s = '%s'\n",anum,tmps,str_peek(sarg[anum]));
+#endif
+ }
+ switch (optype) {
+ case O_ITEM:
+ if (maxarg > arg->arg_len)
+ goto array_return;
+ if (str != sarg[1])
+ str_sset(str,sarg[1]);
+ STABSET(str);
+ break;
+ case O_ITEM2:
+ if (str != sarg[--anum])
+ str_sset(str,sarg[anum]);
+ STABSET(str);
+ break;
+ case O_ITEM3:
+ if (str != sarg[--anum])
+ str_sset(str,sarg[anum]);
+ STABSET(str);
+ break;
+ case O_CONCAT:
+ if (str != sarg[1])
+ str_sset(str,sarg[1]);
+ str_scat(str,sarg[2]);
+ STABSET(str);
+ break;
+ case O_REPEAT:
+ if (str != sarg[1])
+ str_sset(str,sarg[1]);
+ anum = (int)str_gnum(sarg[2]);
+ if (anum >= 1) {
+ tmpstr = str_new(0);
+ str_sset(tmpstr,str);
+ while (--anum > 0)
+ str_scat(str,tmpstr);
+ }
+ else
+ str_sset(str,&str_no);
+ STABSET(str);
+ break;
+ case O_MATCH:
+ str_sset(str, do_match(arg,
+ retary,sarg,&maxsarg,sargoff,cushion));
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return;
+ }
+ STABSET(str);
+ break;
+ case O_NMATCH:
+ str_sset(str, do_match(arg,
+ retary,sarg,&maxsarg,sargoff,cushion));
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return; /* ignore negation */
+ }
+ str_set(str, str_true(str) ? No : Yes);
+ STABSET(str);
+ break;
+ case O_SUBST:
+ value = (double) do_subst(str, arg);
+ str = arg->arg_ptr.arg_str;
+ goto donumset;
+ case O_NSUBST:
+ str_set(arg->arg_ptr.arg_str, do_subst(str, arg) ? No : Yes);
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_ASSIGN:
+ if (arg[1].arg_flags & AF_SPECIAL)
+ do_assign(str,arg,sarg);
+ else {
+ if (str != sarg[2])
+ str_sset(str, sarg[2]);
+ STABSET(str);
+ }
+ break;
+ case O_CHOP:
+ tmps = str_get(str);
+ tmps += str->str_cur - (str->str_cur != 0);
+ str_set(arg->arg_ptr.arg_str,tmps); /* remember last char */
+ *tmps = '\0'; /* wipe it out */
+ str->str_cur = tmps - str->str_ptr;
+ str->str_nok = 0;
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_STUDY:
+ value = (double)do_study(str);
+ str = arg->arg_ptr.arg_str;
+ goto donumset;
+ case O_MULTIPLY:
+ value = str_gnum(sarg[1]);
+ value *= str_gnum(sarg[2]);
+ goto donumset;
+ case O_DIVIDE:
+ if ((value = str_gnum(sarg[2])) == 0.0)
+ fatal("Illegal division by zero");
+ value = str_gnum(sarg[1]) / value;
+ goto donumset;
+ case O_MODULO:
+ if ((tmplong = (unsigned long) str_gnum(sarg[2])) == 0L)
+ fatal("Illegal modulus zero");
+ value = str_gnum(sarg[1]);
+ value = (double)(((unsigned long)value) % tmplong);
+ goto donumset;
+ case O_ADD:
+ value = str_gnum(sarg[1]);
+ value += str_gnum(sarg[2]);
+ goto donumset;
+ case O_SUBTRACT:
+ value = str_gnum(sarg[1]);
+ value -= str_gnum(sarg[2]);
+ goto donumset;
+ case O_LEFT_SHIFT:
+ value = str_gnum(sarg[1]);
+ anum = (int)str_gnum(sarg[2]);
+ value = (double)(((unsigned long)value) << anum);
+ goto donumset;
+ case O_RIGHT_SHIFT:
+ value = str_gnum(sarg[1]);
+ anum = (int)str_gnum(sarg[2]);
+ value = (double)(((unsigned long)value) >> anum);
+ goto donumset;
+ case O_LT:
+ value = str_gnum(sarg[1]);
+ value = (double)(value < str_gnum(sarg[2]));
+ goto donumset;
+ case O_GT:
+ value = str_gnum(sarg[1]);
+ value = (double)(value > str_gnum(sarg[2]));
+ goto donumset;
+ case O_LE:
+ value = str_gnum(sarg[1]);
+ value = (double)(value <= str_gnum(sarg[2]));
+ goto donumset;
+ case O_GE:
+ value = str_gnum(sarg[1]);
+ value = (double)(value >= str_gnum(sarg[2]));
+ goto donumset;
+ case O_EQ:
+ value = str_gnum(sarg[1]);
+ value = (double)(value == str_gnum(sarg[2]));
+ goto donumset;
+ case O_NE:
+ value = str_gnum(sarg[1]);
+ value = (double)(value != str_gnum(sarg[2]));
+ goto donumset;
+ case O_BIT_AND:
+ value = str_gnum(sarg[1]);
+ value = (double)(((unsigned long)value) &
+ (unsigned long)str_gnum(sarg[2]));
+ goto donumset;
+ case O_XOR:
+ value = str_gnum(sarg[1]);
+ value = (double)(((unsigned long)value) ^
+ (unsigned long)str_gnum(sarg[2]));
+ goto donumset;
+ case O_BIT_OR:
+ value = str_gnum(sarg[1]);
+ value = (double)(((unsigned long)value) |
+ (unsigned long)str_gnum(sarg[2]));
+ goto donumset;
+ case O_AND:
+ if (str_true(sarg[1])) {
+ anum = 2;
+ optype = O_ITEM2;
+ argflags = arg[anum].arg_flags;
+ argtype = arg[anum].arg_type;
+ argptr = arg[anum].arg_ptr;
+ maxarg = anum = 1;
+ goto re_eval;
+ }
+ else {
+ if (assigning) {
+ str_sset(str, sarg[1]);
+ STABSET(str);
+ }
+ else
+ str = sarg[1];
+ break;
+ }
+ case O_OR:
+ if (str_true(sarg[1])) {
+ if (assigning) {
+ str_sset(str, sarg[1]);
+ STABSET(str);
+ }
+ else
+ str = sarg[1];
+ break;
+ }
+ else {
+ anum = 2;
+ optype = O_ITEM2;
+ argflags = arg[anum].arg_flags;
+ argtype = arg[anum].arg_type;
+ argptr = arg[anum].arg_ptr;
+ maxarg = anum = 1;
+ goto re_eval;
+ }
+ case O_COND_EXPR:
+ anum = (str_true(sarg[1]) ? 2 : 3);
+ optype = (anum == 2 ? O_ITEM2 : O_ITEM3);
+ argflags = arg[anum].arg_flags;
+ argtype = arg[anum].arg_type;
+ argptr = arg[anum].arg_ptr;
+ maxarg = anum = 1;
+ goto re_eval;
+ case O_COMMA:
+ str = sarg[2];
+ break;
+ case O_NEGATE:
+ value = -str_gnum(sarg[1]);
+ goto donumset;
+ case O_NOT:
+ value = (double) !str_true(sarg[1]);
+ goto donumset;
+ case O_COMPLEMENT:
+ value = (double) ~(long)str_gnum(sarg[1]);
+ goto donumset;
+ case O_SELECT:
+ if (arg[1].arg_type == A_LVAL)
+ defoutstab = arg[1].arg_ptr.arg_stab;
+ else
+ defoutstab = stabent(str_get(sarg[1]),TRUE);
+ if (!defoutstab->stab_io)
+ defoutstab->stab_io = stio_new();
+ curoutstab = defoutstab;
+ str_set(str,curoutstab->stab_io->fp ? Yes : No);
+ STABSET(str);
+ break;
+ case O_WRITE:
+ if (maxarg == 0)
+ stab = defoutstab;
+ else if (arg[1].arg_type == A_LVAL)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sarg[1]),TRUE);
+ if (!stab->stab_io) {
+ str_set(str, No);
+ STABSET(str);
+ break;
+ }
+ curoutstab = stab;
+ fp = stab->stab_io->fp;
+ debarg = arg;
+ if (stab->stab_io->fmt_stab)
+ form = stab->stab_io->fmt_stab->stab_form;
+ else
+ form = stab->stab_form;
+ if (!form || !fp) {
+ str_set(str, No);
+ STABSET(str);
+ break;
+ }
+ format(&outrec,form);
+ do_write(&outrec,stab->stab_io);
+ if (stab->stab_io->flags & IOF_FLUSH)
+ fflush(fp);
+ str_set(str, Yes);
+ STABSET(str);
+ break;
+ case O_OPEN:
+ if (arg[1].arg_type == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sarg[1]),TRUE);
+ if (do_open(stab,str_get(sarg[2]))) {
+ value = (double)forkprocess;
+ stab->stab_io->lines = 0;
+ goto donumset;
+ }
+ else
+ str_set(str, No);
+ STABSET(str);
+ break;
+ case O_TRANS:
+ value = (double) do_trans(str,arg);
+ str = arg->arg_ptr.arg_str;
+ goto donumset;
+ case O_NTRANS:
+ str_set(arg->arg_ptr.arg_str, do_trans(str,arg) == 0 ? Yes : No);
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_CLOSE:
+ if (arg[1].arg_type == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sarg[1]),TRUE);
+ str_set(str, do_close(stab,TRUE) ? Yes : No );
+ STABSET(str);
+ break;
+ case O_EACH:
+ str_sset(str,do_each(arg[1].arg_ptr.arg_stab->stab_hash,
+ retary,sarg,&maxsarg,sargoff,cushion));
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return;
+ }
+ STABSET(str);
+ break;
+ case O_VALUES:
+ case O_KEYS:
+ value = (double) do_kv(arg[1].arg_ptr.arg_stab->stab_hash, optype,
+ retary,sarg,&maxsarg,sargoff,cushion);
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return;
+ }
+ goto donumset;
+ case O_ARRAY:
+ if (maxarg == 1) {
+ ary = arg[1].arg_ptr.arg_stab->stab_array;
+ maxarg = ary->ary_fill;
+ maxsarg = maxarg + sargoff;
+ if (retary) { /* array wanted */
+ sarg = (STR **)saferealloc((char*)(sarg-sargoff),
+ (maxsarg+3+cushion)*sizeof(STR*)) + sargoff;
+ for (anum = 0; anum <= maxarg; anum++) {
+ sarg[anum+1] = str = afetch(ary,anum);
+ }
+ maxarg++;
+ maxsarg++;
+ goto array_return;
+ }
+ else
+ str = afetch(ary,maxarg);
+ }
+ else
+ str = afetch(arg[2].arg_ptr.arg_stab->stab_array,
+ ((int)str_gnum(sarg[1])) - arybase);
+ if (!str)
+ str = &str_no;
+ break;
+ case O_DELETE:
+ tmpstab = arg[2].arg_ptr.arg_stab; /* XXX */
+ str = hdelete(tmpstab->stab_hash,str_get(sarg[1]));
+ if (!str)
+ str = &str_no;
+ break;
+ case O_HASH:
+ tmpstab = arg[2].arg_ptr.arg_stab; /* XXX */
+ str = hfetch(tmpstab->stab_hash,str_get(sarg[1]));
+ if (!str)
+ str = &str_no;
+ break;
+ case O_LARRAY:
+ anum = ((int)str_gnum(sarg[1])) - arybase;
+ str = afetch(arg[2].arg_ptr.arg_stab->stab_array,anum);
+ if (!str || str == &str_no) {
+ str = str_new(0);
+ astore(arg[2].arg_ptr.arg_stab->stab_array,anum,str);
+ }
+ break;
+ case O_LHASH:
+ tmpstab = arg[2].arg_ptr.arg_stab;
+ str = hfetch(tmpstab->stab_hash,str_get(sarg[1]));
+ if (!str) {
+ str = str_new(0);
+ hstore(tmpstab->stab_hash,str_get(sarg[1]),str);
+ }
+ if (tmpstab == envstab) { /* heavy wizardry going on here */
+ str->str_link.str_magic = tmpstab;/* str is now magic */
+ envname = savestr(str_get(sarg[1]));
+ /* he threw the brick up into the air */
+ }
+ else if (tmpstab == sigstab) { /* same thing, only different */
+ str->str_link.str_magic = tmpstab;
+ signame = savestr(str_get(sarg[1]));
+ }
+ break;
+ case O_PUSH:
+ if (arg[1].arg_flags & AF_SPECIAL)
+ str = do_push(arg,arg[2].arg_ptr.arg_stab->stab_array);
+ else {
+ str = str_new(0); /* must copy the STR */
+ str_sset(str,sarg[1]);
+ apush(arg[2].arg_ptr.arg_stab->stab_array,str);
+ }
+ break;
+ case O_POP:
+ str = apop(arg[1].arg_ptr.arg_stab->stab_array);
+ if (!str) {
+ str = &str_no;
+ break;
+ }
+#ifdef STRUCTCOPY
+ *(arg->arg_ptr.arg_str) = *str;
+#else
+ bcopy((char*)str, (char*)arg->arg_ptr.arg_str, sizeof *str);
+#endif
+ safefree((char*)str);
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_SHIFT:
+ str = ashift(arg[1].arg_ptr.arg_stab->stab_array);
+ if (!str) {
+ str = &str_no;
+ break;
+ }
+#ifdef STRUCTCOPY
+ *(arg->arg_ptr.arg_str) = *str;
+#else
+ bcopy((char*)str, (char*)arg->arg_ptr.arg_str, sizeof *str);
+#endif
+ safefree((char*)str);
+ str = arg->arg_ptr.arg_str;
+ break;
+ case O_SPLIT:
+ value = (double) do_split(arg[2].arg_ptr.arg_spat,
+ retary,sarg,&maxsarg,sargoff,cushion);
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return;
+ }
+ goto donumset;
+ case O_LENGTH:
+ value = (double) str_len(sarg[1]);
+ goto donumset;
+ case O_SPRINTF:
+ sarg[maxsarg+1] = Nullstr;
+ do_sprintf(str,arg->arg_len,sarg);
+ break;
+ case O_SUBSTR:
+ anum = ((int)str_gnum(sarg[2])) - arybase;
+ for (tmps = str_get(sarg[1]); *tmps && anum > 0; tmps++,anum--) ;
+ anum = (int)str_gnum(sarg[3]);
+ if (anum >= 0 && strlen(tmps) > anum)
+ str_nset(str, tmps, anum);
+ else
+ str_set(str, tmps);
+ break;
+ case O_JOIN:
+ if (arg[2].arg_flags & AF_SPECIAL && arg[2].arg_type == A_EXPR)
+ do_join(arg,str_get(sarg[1]),str);
+ else
+ ajoin(arg[2].arg_ptr.arg_stab->stab_array,str_get(sarg[1]),str);
+ break;
+ case O_SLT:
+ tmps = str_get(sarg[1]);
+ value = (double) strLT(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SGT:
+ tmps = str_get(sarg[1]);
+ value = (double) strGT(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SLE:
+ tmps = str_get(sarg[1]);
+ value = (double) strLE(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SGE:
+ tmps = str_get(sarg[1]);
+ value = (double) strGE(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SEQ:
+ tmps = str_get(sarg[1]);
+ value = (double) strEQ(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SNE:
+ tmps = str_get(sarg[1]);
+ value = (double) strNE(tmps,str_get(sarg[2]));
+ goto donumset;
+ case O_SUBR:
+ str_sset(str,do_subr(arg,sarg));
+ STABSET(str);
+ break;
+ case O_SORT:
+ if (maxarg <= 1)
+ stab = defoutstab;
+ else {
+ if (arg[2].arg_type == A_WORD)
+ stab = arg[2].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sarg[2]),TRUE);
+ if (!stab)
+ stab = defoutstab;
+ }
+ value = (double)do_sort(arg,stab,
+ retary,sarg,&maxsarg,sargoff,cushion);
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return;
+ }
+ goto donumset;
+ case O_PRTF:
+ case O_PRINT:
+ if (maxarg <= 1)
+ stab = defoutstab;
+ else {
+ if (arg[2].arg_type == A_WORD)
+ stab = arg[2].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sarg[2]),TRUE);
+ if (!stab)
+ stab = defoutstab;
+ }
+ if (!stab->stab_io || !(fp = stab->stab_io->fp))
+ value = 0.0;
+ else {
+ if (arg[1].arg_flags & AF_SPECIAL)
+ value = (double)do_aprint(arg,fp);
+ else {
+ value = (double)do_print(sarg[1],fp);
+ if (ors && optype == O_PRINT)
+ fputs(ors, fp);
+ }
+ if (stab->stab_io->flags & IOF_FLUSH)
+ fflush(fp);
+ }
+ goto donumset;
+ case O_CHDIR:
+ tmps = str_get(sarg[1]);
+ if (!tmps || !*tmps)
+ tmps = getenv("HOME");
+ if (!tmps || !*tmps)
+ tmps = getenv("LOGDIR");
+ value = (double)(chdir(tmps) >= 0);
+ goto donumset;
+ case O_DIE:
+ tmps = str_get(sarg[1]);
+ if (!tmps || !*tmps)
+ exit(1);
+ fatal("%s",str_get(sarg[1]));
+ value = 0.0;
+ goto donumset;
+ case O_EXIT:
+ exit((int)str_gnum(sarg[1]));
+ value = 0.0;
+ goto donumset;
+ case O_RESET:
+ str_reset(str_get(sarg[1]));
+ value = 1.0;
+ goto donumset;
+ case O_LIST:
+ if (arg->arg_flags & AF_LOCAL)
+ savelist(sarg,maxsarg);
+ if (maxarg > 0)
+ str = sarg[maxsarg]; /* unwanted list, return last item */
+ else
+ str = &str_no;
+ if (retary)
+ goto array_return;
+ break;
+ case O_EOF:
+ if (maxarg <= 0)
+ stab = last_in_stab;
+ else if (arg[1].arg_type == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sarg[1]),TRUE);
+ str_set(str, do_eof(stab) ? Yes : No);
+ STABSET(str);
+ break;
+ case O_TELL:
+ if (maxarg <= 0)
+ stab = last_in_stab;
+ else if (arg[1].arg_type == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sarg[1]),TRUE);
+ value = (double)do_tell(stab);
+ goto donumset;
+ case O_SEEK:
+ if (arg[1].arg_type == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(sarg[1]),TRUE);
+ value = str_gnum(sarg[2]);
+ str_set(str, do_seek(stab,
+ (long)value, (int)str_gnum(sarg[3]) ) ? Yes : No);
+ STABSET(str);
+ break;
+ case O_REDO:
+ case O_NEXT:
+ case O_LAST:
+ if (maxarg > 0) {
+ tmps = str_get(sarg[1]);
+ while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label ||
+ strNE(tmps,loop_stack[loop_ptr].loop_label) )) {
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Skipping label #%d %s)\n",loop_ptr,
+ loop_stack[loop_ptr].loop_label);
+ }
+#endif
+ loop_ptr--;
+ }
+#ifdef DEBUGGING
+ if (debug & 4) {
+ deb("(Found label #%d %s)\n",loop_ptr,
+ loop_stack[loop_ptr].loop_label);
+ }
+#endif
+ }
+ if (loop_ptr < 0)
+ fatal("Bad label: %s", maxarg > 0 ? tmps : "<null>");
+ longjmp(loop_stack[loop_ptr].loop_env, optype);
+ case O_GOTO:/* shudder */
+ goto_targ = str_get(sarg[1]);
+ longjmp(top_env, 1);
+ case O_INDEX:
+ tmps = str_get(sarg[1]);
+ if (!(tmps2 = fbminstr(tmps, tmps + sarg[1]->str_cur, sarg[2])))
+ value = (double)(-1 + arybase);
+ else
+ value = (double)(tmps2 - tmps + arybase);
+ goto donumset;
+ case O_TIME:
+ value = (double) time(Null(long*));
+ goto donumset;
+ case O_TMS:
+ value = (double) do_tms(retary,sarg,&maxsarg,sargoff,cushion);
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return;
+ }
+ goto donumset;
+ case O_LOCALTIME:
+ when = (long)str_gnum(sarg[1]);
+ value = (double)do_time(localtime(&when),
+ retary,sarg,&maxsarg,sargoff,cushion);
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return;
+ }
+ goto donumset;
+ case O_GMTIME:
+ when = (long)str_gnum(sarg[1]);
+ value = (double)do_time(gmtime(&when),
+ retary,sarg,&maxsarg,sargoff,cushion);
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return;
+ }
+ goto donumset;
+ case O_STAT:
+ value = (double) do_stat(arg,
+ retary,sarg,&maxsarg,sargoff,cushion);
+ if (retary) {
+ sarg = *retary; /* they realloc it */
+ goto array_return;
+ }
+ goto donumset;
+ case O_CRYPT:
+#ifdef CRYPT
+ tmps = str_get(sarg[1]);
+ str_set(str,crypt(tmps,str_get(sarg[2])));
+#else
+ fatal(
+ "The crypt() function is unimplemented due to excessive paranoia.");
+#endif
+ break;
+ case O_EXP:
+ value = exp(str_gnum(sarg[1]));
+ goto donumset;
+ case O_LOG:
+ value = log(str_gnum(sarg[1]));
+ goto donumset;
+ case O_SQRT:
+ value = sqrt(str_gnum(sarg[1]));
+ goto donumset;
+ case O_INT:
+ value = str_gnum(sarg[1]);
+ if (value >= 0.0)
+ modf(value,&value);
+ else {
+ modf(-value,&value);
+ value = -value;
+ }
+ goto donumset;
+ case O_ORD:
+ value = (double) *str_get(sarg[1]);
+ goto donumset;
+ case O_SLEEP:
+ tmps = str_get(sarg[1]);
+ time(&when);
+ if (!tmps || !*tmps)
+ sleep((32767<<16)+32767);
+ else
+ sleep((unsigned)atoi(tmps));
+ value = (double)when;
+ time(&when);
+ value = ((double)when) - value;
+ goto donumset;
+ case O_FLIP:
+ if (str_true(sarg[1])) {
+ str_numset(str,0.0);
+ anum = 2;
+ arg->arg_type = optype = O_FLOP;
+ arg[2].arg_flags &= ~AF_SPECIAL;
+ arg[1].arg_flags |= AF_SPECIAL;
+ argflags = arg[2].arg_flags;
+ argtype = arg[2].arg_type;
+ argptr = arg[2].arg_ptr;
+ goto re_eval;
+ }
+ str_set(str,"");
+ break;
+ case O_FLOP:
+ str_inc(str);
+ if (str_true(sarg[2])) {
+ arg->arg_type = O_FLIP;
+ arg[1].arg_flags &= ~AF_SPECIAL;
+ arg[2].arg_flags |= AF_SPECIAL;
+ str_cat(str,"E0");
+ }
+ break;
+ case O_FORK:
+ value = (double)fork();
+ goto donumset;
+ case O_WAIT:
+ ihand = signal(SIGINT, SIG_IGN);
+ qhand = signal(SIGQUIT, SIG_IGN);
+ value = (double)wait(&argflags);
+ signal(SIGINT, ihand);
+ signal(SIGQUIT, qhand);
+ statusvalue = (unsigned short)argflags;
+ goto donumset;
+ case O_SYSTEM:
+ while ((anum = vfork()) == -1) {
+ if (errno != EAGAIN) {
+ value = -1.0;
+ goto donumset;
+ }
+ sleep(5);
+ }
+ if (anum > 0) {
+ ihand = signal(SIGINT, SIG_IGN);
+ qhand = signal(SIGQUIT, SIG_IGN);
+ while ((argtype = wait(&argflags)) != anum && argtype != -1)
+ ;
+ signal(SIGINT, ihand);
+ signal(SIGQUIT, qhand);
+ statusvalue = (unsigned short)argflags;
+ if (argtype == -1)
+ value = -1.0;
+ else {
+ value = (double)((unsigned int)argflags & 0xffff);
+ }
+ goto donumset;
+ }
+ if (arg[1].arg_flags & AF_SPECIAL)
+ value = (double)do_aexec(arg);
+ else {
+ value = (double)do_exec(str_static(sarg[1]));
+ }
+ _exit(-1);
+ case O_EXEC:
+ if (arg[1].arg_flags & AF_SPECIAL)
+ value = (double)do_aexec(arg);
+ else {
+ value = (double)do_exec(str_static(sarg[1]));
+ }
+ goto donumset;
+ case O_HEX:
+ argtype = 4;
+ goto snarfnum;
+
+ case O_OCT:
+ argtype = 3;
+
+ snarfnum:
+ anum = 0;
+ tmps = str_get(sarg[1]);
+ for (;;) {
+ switch (*tmps) {
+ default:
+ goto out;
+ case '8': case '9':
+ if (argtype != 4)
+ goto out;
+ /* FALL THROUGH */
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7':
+ anum <<= argtype;
+ anum += *tmps++ & 15;
+ break;
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ if (argtype != 4)
+ goto out;
+ anum <<= 4;
+ anum += (*tmps++ & 7) + 9;
+ break;
+ case 'x':
+ argtype = 4;
+ tmps++;
+ break;
+ }
+ }
+ out:
+ value = (double)anum;
+ goto donumset;
+ case O_CHMOD:
+ case O_CHOWN:
+ case O_KILL:
+ case O_UNLINK:
+ case O_UTIME:
+ if (arg[1].arg_flags & AF_SPECIAL)
+ value = (double)apply(optype,arg,Null(STR**));
+ else {
+ sarg[2] = Nullstr;
+ value = (double)apply(optype,arg,sarg);
+ }
+ goto donumset;
+ case O_UMASK:
+ value = (double)umask((int)str_gnum(sarg[1]));
+ goto donumset;
+ case O_RENAME:
+ tmps = str_get(sarg[1]);
+#ifdef RENAME
+ value = (double)(rename(tmps,str_get(sarg[2])) >= 0);
+#else
+ tmps2 = str_get(sarg[2]);
+ if (euid || stat(tmps2,&statbuf) < 0 ||
+ (statbuf.st_mode & S_IFMT) != S_IFDIR )
+ UNLINK(tmps2); /* avoid unlinking a directory */
+ if (!(anum = link(tmps,tmps2)))
+ anum = UNLINK(tmps);
+ value = (double)(anum >= 0);
+#endif
+ goto donumset;
+ case O_LINK:
+ tmps = str_get(sarg[1]);
+ value = (double)(link(tmps,str_get(sarg[2])) >= 0);
+ goto donumset;
+ case O_UNSHIFT:
+ ary = arg[2].arg_ptr.arg_stab->stab_array;
+ if (arg[1].arg_flags & AF_SPECIAL)
+ do_unshift(arg,ary);
+ else {
+ str = str_new(0); /* must copy the STR */
+ str_sset(str,sarg[1]);
+ aunshift(ary,1);
+ astore(ary,0,str);
+ }
+ value = (double)(ary->ary_fill + 1);
+ break;
+ case O_DOFILE:
+ case O_EVAL:
+ str_sset(str,
+ do_eval(arg[1].arg_type != A_NULL ? sarg[1] : defstab->stab_val,
+ optype) );
+ STABSET(str);
+ break;
+
+ case O_FTRREAD:
+ argtype = 0;
+ anum = S_IREAD;
+ goto check_perm;
+ case O_FTRWRITE:
+ argtype = 0;
+ anum = S_IWRITE;
+ goto check_perm;
+ case O_FTREXEC:
+ argtype = 0;
+ anum = S_IEXEC;
+ goto check_perm;
+ case O_FTEREAD:
+ argtype = 1;
+ anum = S_IREAD;
+ goto check_perm;
+ case O_FTEWRITE:
+ argtype = 1;
+ anum = S_IWRITE;
+ goto check_perm;
+ case O_FTEEXEC:
+ argtype = 1;
+ anum = S_IEXEC;
+ check_perm:
+ str = &str_no;
+ if (mystat(arg,sarg[1]) < 0)
+ break;
+ if (cando(anum,argtype))
+ str = &str_yes;
+ break;
+
+ case O_FTIS:
+ if (mystat(arg,sarg[1]) >= 0)
+ str = &str_yes;
+ else
+ str = &str_no;
+ break;
+ case O_FTEOWNED:
+ case O_FTROWNED:
+ if (mystat(arg,sarg[1]) >= 0 &&
+ statbuf.st_uid == (optype == O_FTEOWNED ? euid : uid) )
+ str = &str_yes;
+ else
+ str = &str_no;
+ break;
+ case O_FTZERO:
+ if (mystat(arg,sarg[1]) >= 0 && !statbuf.st_size)
+ str = &str_yes;
+ else
+ str = &str_no;
+ break;
+ case O_FTSIZE:
+ if (mystat(arg,sarg[1]) >= 0 && statbuf.st_size)
+ str = &str_yes;
+ else
+ str = &str_no;
+ break;
+
+ case O_FTSOCK:
+#ifdef S_IFSOCK
+ anum = S_IFSOCK;
+ goto check_file_type;
+#else
+ str = &str_no;
+ break;
+#endif
+ case O_FTCHR:
+ anum = S_IFCHR;
+ goto check_file_type;
+ case O_FTBLK:
+ anum = S_IFBLK;
+ goto check_file_type;
+ case O_FTFILE:
+ anum = S_IFREG;
+ goto check_file_type;
+ case O_FTDIR:
+ anum = S_IFDIR;
+ check_file_type:
+ if (mystat(arg,sarg[1]) >= 0 &&
+ (statbuf.st_mode & S_IFMT) == anum )
+ str = &str_yes;
+ else
+ str = &str_no;
+ break;
+ case O_FTPIPE:
+#ifdef S_IFIFO
+ anum = S_IFIFO;
+ goto check_file_type;
+#else
+ str = &str_no;
+ break;
+#endif
+ case O_FTLINK:
+#ifdef S_IFLNK
+ if (lstat(str_get(sarg[1]),&statbuf) >= 0 &&
+ (statbuf.st_mode & S_IFMT) == S_IFLNK )
+ str = &str_yes;
+ else
+#endif
+ str = &str_no;
+ break;
+ case O_SYMLINK:
+#ifdef SYMLINK
+ tmps = str_get(sarg[1]);
+ value = (double)(symlink(tmps,str_get(sarg[2])) >= 0);
+ goto donumset;
+#else
+ fatal("Unsupported function symlink()");
+#endif
+ case O_FTSUID:
+ anum = S_ISUID;
+ goto check_xid;
+ case O_FTSGID:
+ anum = S_ISGID;
+ goto check_xid;
+ case O_FTSVTX:
+ anum = S_ISVTX;
+ check_xid:
+ if (mystat(arg,sarg[1]) >= 0 && statbuf.st_mode & anum)
+ str = &str_yes;
+ else
+ str = &str_no;
+ break;
+ case O_FTTTY:
+ if (arg[1].arg_flags & AF_SPECIAL) {
+ stab = arg[1].arg_ptr.arg_stab;
+ tmps = "";
+ }
+ else
+ stab = stabent(tmps = str_get(sarg[1]),FALSE);
+ if (stab && stab->stab_io && stab->stab_io->fp)
+ anum = fileno(stab->stab_io->fp);
+ else if (isdigit(*tmps))
+ anum = atoi(tmps);
+ else
+ anum = -1;
+ if (isatty(anum))
+ str = &str_yes;
+ else
+ str = &str_no;
+ break;
+ case O_FTTEXT:
+ case O_FTBINARY:
+ str = do_fttext(arg,sarg[1]);
+ break;
+ }
+ if (retary) {
+ sarg[1] = str;
+ maxsarg = sargoff + 1;
+ }
+#ifdef DEBUGGING
+ if (debug) {
+ dlevel--;
+ if (debug & 8)
+ deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str));
+ }
+#endif
+ goto freeargs;
+
+array_return:
+#ifdef DEBUGGING
+ if (debug) {
+ dlevel--;
+ if (debug & 8)
+ deb("%s RETURNS ARRAY OF %d ARGS\n",opname[optype],maxsarg-sargoff);
+ }
+#endif
+ goto freeargs;
+
+donumset:
+ str_numset(str,value);
+ STABSET(str);
+ if (retary) {
+ sarg[1] = str;
+ maxsarg = sargoff + 1;
+ }
+#ifdef DEBUGGING
+ if (debug) {
+ dlevel--;
+ if (debug & 8)
+ deb("%s RETURNS \"%f\"\n",opname[optype],value);
+ }
+#endif
+
+freeargs:
+ sarg -= sargoff;
+ if (sarg != quicksarg) {
+ if (retary) {
+ sarg[0] = &str_args;
+ str_numset(sarg[0], (double)(maxsarg));
+ sarg[maxsarg+1] = Nullstr;
+ *retary = sarg; /* up to them to free it */
+ }
+ else
+ safefree((char*)sarg);
+ }
+ return str;
+}
+
+int
+ingroup(gid,effective)
+int gid;
+int effective;
+{
+ if (gid == (effective ? getegid() : getgid()))
+ return TRUE;
+#ifdef GETGROUPS
+#ifndef NGROUPS
+#define NGROUPS 32
+#endif
+ {
+ GIDTYPE gary[NGROUPS];
+ int anum;
+
+ anum = getgroups(NGROUPS,gary);
+ while (--anum >= 0)
+ if (gary[anum] == gid)
+ return TRUE;
+ }
+#endif
+ return FALSE;
+}
+
+/* Do the permissions allow some operation? Assumes statbuf already set. */
+
+int
+cando(bit, effective)
+int bit;
+int effective;
+{
+ if ((effective ? euid : uid) == 0) { /* root is special */
+ if (bit == S_IEXEC) {
+ if (statbuf.st_mode & 0111 ||
+ (statbuf.st_mode & S_IFMT) == S_IFDIR )
+ return TRUE;
+ }
+ else
+ return TRUE; /* root reads and writes anything */
+ return FALSE;
+ }
+ if (statbuf.st_uid == (effective ? euid : uid) ) {
+ if (statbuf.st_mode & bit)
+ return TRUE; /* ok as "user" */
+ }
+ else if (ingroup((int)statbuf.st_gid,effective)) {
+ if (statbuf.st_mode & bit >> 3)
+ return TRUE; /* ok as "group" */
+ }
+ else if (statbuf.st_mode & bit >> 6)
+ return TRUE; /* ok as "other" */
+ return FALSE;
+}
-/* $Header: form.c,v 1.0 87/12/18 13:05:07 root Exp $
+/* $Header: form.c,v 2.0 88/06/05 00:08:57 root Exp $
*
* $Log: form.c,v $
- * Revision 1.0 87/12/18 13:05:07 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:08:57 root
+ * Baseline version 2.0.
*
*/
-#include "handy.h"
#include "EXTERN.h"
-#include "search.h"
-#include "util.h"
#include "perl.h"
/* Forms stuff */
orec->o_lines++;
break;
case F_LEFT:
- str = eval(fcmd->f_expr,Null(char***),(double*)0);
+ str = eval(fcmd->f_expr,Null(STR***),-1);
s = str_get(str);
size = fcmd->f_size;
CHKLEN(size);
}
break;
case F_RIGHT:
- t = s = str_get(eval(fcmd->f_expr,Null(char***),(double*)0));
+ t = s = str_get(eval(fcmd->f_expr,Null(STR***),-1));
size = fcmd->f_size;
CHKLEN(size);
chophere = Nullch;
case F_CENTER: {
int halfsize;
- t = s = str_get(eval(fcmd->f_expr,Null(char***),(double*)0));
+ t = s = str_get(eval(fcmd->f_expr,Null(STR***),-1));
size = fcmd->f_size;
CHKLEN(size);
chophere = Nullch;
break;
}
case F_LINES:
- str = eval(fcmd->f_expr,Null(char***),(double*)0);
+ str = eval(fcmd->f_expr,Null(STR***),-1);
s = str_get(str);
size = str_len(str);
CHKLEN(size);
#ifdef DEBUGGING
if (debug & 256)
- fprintf(stderr,"left=%d, todo=%d\n",stio->lines_left, orec->o_lines);
+ fprintf(stderr,"left=%ld, todo=%ld\n",
+ (long)stio->lines_left, (long)orec->o_lines);
#endif
if (stio->lines_left < orec->o_lines) {
if (!stio->top_stab) {
-/* $Header: form.h,v 1.0 87/12/18 13:05:10 root Exp $
+/* $Header: form.h,v 2.0 88/06/05 00:09:01 root Exp $
*
* $Log: form.h,v $
- * Revision 1.0 87/12/18 13:05:10 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:09:01 root
+ * Baseline version 2.0.
*
*/
-/* $Header: handy.h,v 1.0 87/12/18 13:05:14 root Exp $
+/* $Header: handy.h,v 2.0 88/06/05 00:09:03 root Exp $
*
* $Log: handy.h,v $
- * Revision 1.0 87/12/18 13:05:14 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:09:03 root
+ * Baseline version 2.0.
*
*/
-#define Null(type) ((type)0)
+#ifdef NULL
+#undef NULL
+#endif
+#define NULL 0
+#define Null(type) ((type)NULL)
#define Nullch Null(char*)
#define Nullfp Null(FILE*)
#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
+
+#define MEM_SIZE unsigned int
+
+/* Line numbers are unsigned, 16 bits. */
+typedef unsigned short line_t;
+#ifdef lint
+#define NOLINE ((line_t)0)
+#else
+#define NOLINE ((line_t) 65535)
+#endif
+
-/* $Header: hash.c,v 1.0 87/12/18 13:05:17 root Exp $
+/* $Header: hash.c,v 2.0 88/06/05 00:09:06 root Exp $
*
* $Log: hash.c,v $
- * Revision 1.0 87/12/18 13:05:17 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:09:06 root
+ * Baseline version 2.0.
*
*/
-#include <stdio.h>
#include "EXTERN.h"
-#include "handy.h"
-#include "util.h"
-#include "search.h"
#include "perl.h"
STR *
if (!tb)
return Nullstr;
for (s=key, i=0, hash = 0;
- /* while */ *s;
+ /* while */ *s && i < COEFFSIZE;
s++, i++, hash *= 5) {
hash += *s * coeff[i];
}
if (!tb)
return FALSE;
for (s=key, i=0, hash = 0;
- /* while */ *s;
+ /* while */ *s && i < COEFFSIZE;
s++, i++, hash *= 5) {
hash += *s * coeff[i];
}
return FALSE;
}
-#ifdef NOTUSED
-bool
+STR *
hdelete(tb,key)
register HASH *tb;
char *key;
register int hash;
register HENT *entry;
register HENT **oentry;
+ STR *str;
if (!tb)
- return FALSE;
+ return Nullstr;
for (s=key, i=0, hash = 0;
- /* while */ *s;
+ /* while */ *s && i < COEFFSIZE;
s++, i++, hash *= 5) {
hash += *s * coeff[i];
}
oentry = &(tb->tbl_array[hash & tb->tbl_max]);
entry = *oentry;
i = 1;
- for (; entry; i=0, oentry = &entry->hent_next, entry = entry->hent_next) {
+ for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) {
if (entry->hent_hash != hash) /* strings can't be equal */
continue;
if (strNE(entry->hent_key,key)) /* is this it? */
continue;
- safefree((char*)entry->hent_val);
- safefree(entry->hent_key);
*oentry = entry->hent_next;
- safefree((char*)entry);
+ str = str_static(entry->hent_val);
+ hentfree(entry);
if (i)
tb->tbl_fill--;
- return TRUE;
+ return str;
}
- return FALSE;
+ return Nullstr;
}
-#endif
hsplit(tb)
HASH *tb;
return tb;
}
+void
+hentfree(hent)
+register HENT *hent;
+{
+ if (!hent)
+ return;
+ str_free(hent->hent_val);
+ safefree(hent->hent_key);
+ safefree((char*)hent);
+}
+
+void
+hclear(tb)
+register HASH *tb;
+{
+ register HENT *hent;
+ register HENT *ohent = Null(HENT*);
+
+ if (!tb)
+ return;
+ hiterinit(tb);
+ while (hent = hiternext(tb)) { /* concise but not very efficient */
+ hentfree(ohent);
+ ohent = hent;
+ }
+ hentfree(ohent);
+ tb->tbl_fill = 0;
+ bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*));
+}
+
+#ifdef NOTUSED
+void
+hfree(tb)
+HASH *tb;
+{
+ if (!tb)
+ return
+ hiterinit(tb);
+ while (hent = hiternext(tb)) {
+ hentfree(ohent);
+ ohent = hent;
+ }
+ hentfree(ohent);
+ safefree((char*)tb->tbl_array);
+ safefree((char*)tb);
+}
+#endif
+
#ifdef NOTUSED
hshow(tb)
register HASH *tb;
-/* $Header: hash.h,v 1.0 87/12/18 13:05:20 root Exp $
+/* $Header: hash.h,v 2.0 88/06/05 00:09:08 root Exp $
*
* $Log: hash.h,v $
- * Revision 1.0 87/12/18 13:05:20 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:09:08 root
+ * Baseline version 2.0.
*
*/
#define FILLPCT 60 /* don't make greater than 99 */
+#define COEFFSIZE (16 * 8) /* size of array below */
#ifdef DOINIT
char coeff[] = {
61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
STR *hfetch();
bool hstore();
-bool hdelete();
+STR *hdelete();
HASH *hnew();
+void hclear();
+void hfree();
+void hentfree();
int hiterinit();
HENT *hiternext();
char *hiterkey();
--- /dev/null
+;# $Header: getopt.pl,v 2.0 88/06/05 00:16:22 root Exp $
+
+;# Process single-character switches with switch clustering. Pass one argument
+;# which is a string containing all switches that take an argument. For each
+;# switch found, sets $opt_x (where x is the switch name) to the value of the
+;# argument, or 1 if no argument. Switches which take an argument don't care
+;# whether there is a space between the switch and the argument.
+
+;# Usage:
+;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
+
+sub Getopt {
+ local($argumentative) = @_;
+ local($_,$first,$rest);
+
+ while (($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ if (index($argumentative,$first) >= $[) {
+ if ($rest ne '') {
+ shift;
+ }
+ else {
+ shift;
+ $rest = shift;
+ }
+ eval "\$opt_$first = \$rest;";
+ }
+ else {
+ eval "\$opt_$first = 1;";
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift;
+ }
+ }
+ }
+}
--- /dev/null
+;# $Header: importenv.pl,v 2.0 88/06/05 00:16:17 root Exp $
+
+;# This file, when interpreted, pulls the environment into normal variables.
+;# Usage:
+;# do 'importenv.pl';
+;# or
+;# #include <importenv.pl>
+
+local($tmp,$key) = '';
+
+foreach $key (keys(ENV)) {
+ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
+}
+eval $tmp;
--- /dev/null
+;# $Header: stat.pl,v 2.0 88/06/05 00:16:29 root Exp $
+
+;# Usage:
+;# @ary = stat(foo);
+;# $st_dev = @ary[$ST_DEV];
+;#
+$ST_DEV = 0 + $[;
+$ST_INO = 1 + $[;
+$ST_MODE = 2 + $[;
+$ST_NLINK = 3 + $[;
+$ST_UID = 4 + $[;
+$ST_GID = 5 + $[;
+$ST_RDEV = 6 + $[;
+$ST_SIZE = 7 + $[;
+$ST_ATIME = 8 + $[;
+$ST_MTIME = 9 + $[;
+$ST_CTIME = 10 + $[;
+$ST_BLKSIZE = 11 + $[;
+$ST_BLOCKS = 12 + $[;
+
+;# Usage:
+;# do Stat('foo'); # sets st_* as a side effect
+;#
+sub Stat {
+ ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size,
+ $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_));
+}
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
fi
- . config.sh
+ . ./config.sh
;;
esac
case "$0" in
echo "Extracting makedepend (with variable substitutions)"
$spitshell >makedepend <<!GROK!THIS!
$startsh
-# $Header: makedepend.SH,v 1.0.1.1 88/02/02 11:24:05 root Exp $
+# $Header: makedepend.SH,v 2.0 88/06/05 00:09:11 root Exp $
#
# $Log: makedepend.SH,v $
-# Revision 1.0.1.1 88/02/02 11:24:05 root
-# patch13: removed spurious -I./h.
-#
-# Revision 1.0 87/12/18 17:54:32 root
-# Initial revision
+# Revision 2.0 88/06/05 00:09:11 root
+# Baseline version 2.0.
#
#
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
cat='$cat'
+ccflags='$ccflags'
cp='$cp'
-cpp='$cpp'
+cpp='$cppstdin'
echo='$echo'
egrep='$egrep'
expr='$expr'
$spitshell >>makedepend <<'!NO!SUBS!'
+: the following weeds options from ccflags that are of no interest to cpp
+case "$ccflags" in
+'');;
+*) set X $ccflags
+ ccflags=''
+ for flag do
+ case $flag in
+ -D*|-I*) ccflags="$ccflags $flag";;
+ esac
+ done
+ ;;
+esac
+
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
-e 's|\\$||' \
-e p \
-e '}'
- $cpp -I/usr/local/include -I. $file.c | \
+ $cpp -I/usr/local/include -I. $ccflags $file.c | \
$sed \
-e '/^# *[0-9]/!d' \
-e 's/^.*"\(.*\)".*$/'$filebase'.o: \1/' \
!NO!SUBS!
$eunicefix makedepend
-chmod 755 makedepend
+chmod +x makedepend
case `pwd` in
*SH)
$rm -f ../makedepend
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
fi
- . config.sh
+ . ./config.sh
;;
esac
case "$0" in
echo "Extracting makedir (with variable substitutions)"
$spitshell >makedir <<!GROK!THIS!
$startsh
-# $Header: makedir.SH,v 1.0 87/12/18 13:05:32 root Exp $
+# $Header: makedir.SH,v 2.0 88/06/05 00:09:13 root Exp $
#
# $Log: makedir.SH,v $
-# Revision 1.0 87/12/18 13:05:32 root
-# Initial revision
+# Revision 2.0 88/06/05 00:09:13 root
+# Baseline version 2.0.
#
-# Revision 4.3.1.1 85/05/10 11:35:14 lwall
-# Branch for patches.
-#
-# Revision 4.3 85/05/01 11:42:31 lwall
-# Baseline for release with 4.3bsd.
#
export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
done
!GROK!THIS!
$eunicefix makedir
-chmod 755 makedir
+chmod +x makedir
-/* $Header: malloc.c,v 1.0.1.1 88/01/24 03:53:23 root Exp $
+/* $Header: malloc.c,v 2.0 88/06/05 00:09:16 root Exp $
*
* $Log: malloc.c,v $
- * Revision 1.0.1.1 88/01/24 03:53:23 root
- * patch 2: made depend on perl.h.
- *
- * Revision 1.0 87/12/18 13:05:35 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:09:16 root
+ * Baseline version 2.0.
*
*/
#ifndef lint
static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83";
#endif
-#include <stdio.h>
#define RCHECK
/*
*/
#include "EXTERN.h"
-#include "handy.h"
-#include "search.h"
#include "perl.h"
/* I don't much care whether these are defined in sys/types.h--LAW */
#define u_int unsigned int
#define u_short unsigned short
-#define NULL 0
-
/*
* The overhead on a block is at least 4 bytes. When free, this space
* contains a pointer to the next free block, and the bottom two bits must
};
#define MAGIC 0xff /* magic # on accounting info */
+#define OLDMAGIC 0x7f /* same after a free() */
#define RMAGIC 0x55555555 /* magic # on range info */
#ifdef RCHECK
#define RSLOP sizeof (u_int)
#ifdef debug
ASSERT(op->ov_magic == MAGIC); /* make sure it was in use */
#else
- if (op->ov_magic != MAGIC)
+ if (op->ov_magic != MAGIC) {
+ fprintf(stderr,"%s free() ignored\n",
+ op->ov_magic == OLDMAGIC ? "Duplicate" : "Bad");
return; /* sanity */
+ }
+ op->ov_magic = OLDMAGIC;
#endif
#ifdef RCHECK
ASSERT(op->ov_rmagic == RMAGIC);
* back. We have to search all the free lists for the block in order
* to determine its bucket: 1st we make one pass thru the lists
* checking only the first block in each; if that fails we search
- * ``realloc_srchlen'' blocks in each list for a match (the variable
+ * ``reall_srchlen'' blocks in each list for a match (the variable
* is extern so the caller can modify it). If that fails we just copy
* however many bytes was given to realloc() and hope it's not huge.
*/
-int realloc_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */
+int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */
char *
realloc(cp, nbytes)
* Search for the old block of memory on the
* free list. First, check the most common
* case (last element free'd), then (this failing)
- * the last ``realloc_srchlen'' items free'd.
+ * the last ``reall_srchlen'' items free'd.
* If all lookups fail, then assume the size of
* the memory block being realloc'd is the
* smallest possible.
*/
if ((i = findbucket(op, 1)) < 0 &&
- (i = findbucket(op, realloc_srchlen)) < 0)
+ (i = findbucket(op, reall_srchlen)) < 0)
i = 0;
}
onb = (1 << (i + 3)) - sizeof (*op) - RSLOP;
-#define PATCHLEVEL 14
+#define PATCHLEVEL 0
-/* $Header: perl.h,v 1.0.1.4 88/01/30 08:54:00 root Exp $
+/* $Header: perl.h,v 2.0 88/06/05 00:09:21 root Exp $
*
* $Log: perl.h,v $
- * Revision 1.0.1.4 88/01/30 08:54:00 root
- * patch9: changed #define YYDEBUG; to #define YYDEBUG 1
- *
- * Revision 1.0.1.3 88/01/28 10:24:17 root
- * patch8: added eval operator.
- *
- * Revision 1.0.1.2 88/01/24 03:53:47 root
- * patch 2: hid str_peek() in #ifdef DEBUGGING.
- *
- * Revision 1.0.1.1 88/01/21 21:29:23 root
- * No longer defines STDSTDIO--gets it from config.h now.
- *
- * Revision 1.0 87/12/18 13:05:38 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:09:21 root
+ * Baseline version 2.0.
*
*/
+#ifndef lint
#define DEBUGGING
+#endif
#define VOIDUSED 1
#include "config.h"
-#ifndef BCOPY
-# define bcopy(s1,s2,l) memcpy(s2,s1,l);
-# define bzero(s,l) memset(s,0,l);
+#ifdef MEMCPY
+extern char *memcpy(), *memset();
+#define bcopy(s1,s2,l) memcpy(s2,s1,l);
+#define bzero(s,l) memset(s,0,l);
#endif
#include <stdio.h>
#include <ctype.h>
#include <setjmp.h>
+#include <sys/param.h> /* if this needs types.h we're still wrong */
+
+#ifndef _TYPES_ /* If types.h defines this it's easy. */
+#ifndef major /* Does everyone's types.h define this? */
#include <sys/types.h>
+#endif
+#endif
+
#include <sys/stat.h>
#ifdef TMINSYS
typedef struct scanpat SPAT;
typedef struct stab STAB;
typedef struct stio STIO;
+typedef struct sub SUBR;
typedef struct string STR;
typedef struct atbl ARRAY;
typedef struct htbl HASH;
+typedef struct regexp REGEXP;
+#include "handy.h"
+#include "regexp.h"
#include "str.h"
+#include "util.h"
#include "form.h"
#include "stab.h"
#include "spat.h"
#define str_true(str) (Str = (str), (Str->str_pok ? True(Str->str_ptr) : (Str->str_nok ? (Str->str_nval != 0.0) : 0 )))
#ifdef DEBUGGING
-#define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),buf) : "" )))
+#define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),(char*)buf) : "" )))
#endif
#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
CMD *addcond();
CMD *addloop();
CMD *wopt();
+CMD *over();
-SPAT *stab_to_spat();
+SPAT *stab2spat();
STAB *stabent();
+STAB *genstab();
-ARG *stab_to_arg();
+ARG *stab2arg();
ARG *op_new();
ARG *make_op();
ARG *make_lval();
ARG *make_match();
ARG *make_split();
ARG *flipflip();
+ARG *listish();
+ARG *localize();
+ARG *l();
+ARG *mod_match();
+ARG *make_list();
+ARG *cmd_to_arg();
+ARG *addflags();
+ARG *hide_ary();
+ARG *cval_to_arg();
STR *arg_to_str();
STR *str_new();
STR *stab_str();
STR *eval(); /* this evaluates expressions */
STR *do_eval(); /* this evaluates eval operator */
+STR *do_each();
+STR *do_subr();
+STR *do_match();
+
+SUBR *make_sub();
FCMD *load_format();
char *str_append_till();
char *str_gets();
-bool do_match();
bool do_open();
bool do_close();
bool do_print();
+bool do_aprint();
+bool do_exec();
+bool do_aexec();
int do_subst();
+int cando();
+int ingroup();
+void str_grow();
+void str_replace();
+void str_inc();
+void str_dec();
void str_free();
void freearg();
-
-EXT int line INIT(0);
+void savelist();
+void restorelist();
+void ajoin();
+void do_join();
+void do_assign();
+void do_sprintf();
+
+EXT line_t line INIT(0);
EXT int arybase INIT(0);
struct outrec {
- int o_lines;
- char *o_str;
- int o_len;
+ line_t o_lines;
+ char *o_str;
+ int o_len;
};
EXT struct outrec outrec;
EXT STAB *defoutstab INIT(Nullstab);
EXT STAB *curoutstab INIT(Nullstab);
EXT STAB *argvoutstab INIT(Nullstab);
+EXT STAB *incstab INIT(Nullstab);
EXT STR *freestrroot INIT(Nullstr);
+EXT STR *lastretstr INIT(Nullstr);
+EXT char *filename;
+EXT char *origfilename;
EXT FILE *rsfp;
EXT char buf[1024];
EXT char *bufptr INIT(buf);
EXT char *ofmt INIT(Nullch);
EXT char *inplace INIT(Nullch);
+EXT bool preprocess INIT(FALSE);
+EXT bool minus_n INIT(FALSE);
+EXT bool minus_p INIT(FALSE);
+EXT bool minus_a INIT(FALSE);
+EXT bool doswitches INIT(FALSE);
+EXT bool dowarn INIT(FALSE);
+EXT bool allstabs INIT(FALSE); /* init all customary symbols in symbol table?*/
+EXT bool sawampersand INIT(FALSE); /* must save all match strings */
+EXT bool sawstudy INIT(FALSE); /* do fbminstr on all strings */
+
+#define TMPPATH "/tmp/perl-eXXXXXX"
+EXT char *e_tmpname;
+EXT FILE *e_fp INIT(Nullfp);
+
EXT char tokenbuf[256];
EXT int expectterm INIT(TRUE);
EXT int lex_newlines INIT(FALSE);
EXT int in_eval INIT(FALSE);
+EXT int multiline INIT(0);
+EXT int forkprocess;
FILE *popen();
/* char *str_get(); */
EXT struct stat statbuf;
EXT struct tms timesbuf;
+EXT int uid;
+EXT int euid;
+UIDTYPE getuid();
+UIDTYPE geteuid();
+GIDTYPE getgid();
+GIDTYPE getegid();
+EXT int unsafe;
#ifdef DEBUGGING
EXT int debug INIT(0);
EXT int dlevel INIT(0);
-EXT char debname[40];
-EXT char debdelim[40];
+EXT char debname[128];
+EXT char debdelim[128];
#define YYDEBUG 1
extern int yydebug;
#endif
+EXT line_t cmdline INIT(NOLINE);
+
EXT STR str_no;
EXT STR str_yes;
EXT struct loop {
char *loop_label;
jmp_buf loop_env;
-} loop_stack[32];
+} loop_stack[64];
EXT int loop_ptr INIT(-1);
EXT char *goto_targ INIT(Nullch); /* cmd_exec gets strange when set */
+EXT ARRAY *savestack; /* to save non-local values on */
+
+EXT ARRAY *tosave; /* strings to save on recursive subroutine */
+
double atof();
-long time();
+unsigned sleep();
+long time(), times();
struct tm *gmtime(), *localtime();
+char *mktemp();
+char *index(), *rindex();
+char *strcpy(), *strcat();
#ifdef EUNICE
-#define UNLINK(f) while (unlink(f) >= 0)
+#define UNLINK unlnk
+int unlnk();
#else
#define UNLINK unlink
#endif
.rn '' }`
-''' $Header: perl.man.1,v 1.0.1.2 88/01/30 17:04:07 root Exp $
+''' $Header: perl.man.1,v 2.0 88/06/05 00:09:23 root Exp $
'''
''' $Log: perl.man.1,v $
-''' Revision 1.0.1.2 88/01/30 17:04:07 root
-''' patch 11: random cleanup
-'''
-''' Revision 1.0.1.1 88/01/28 10:24:44 root
-''' patch8: added eval operator.
-'''
-''' Revision 1.0 87/12/18 16:18:16 root
-''' Initial revision
+''' Revision 2.0 88/06/05 00:09:23 root
+''' Baseline version 2.0.
'''
'''
.de Sh
''' string Tr holds user defined translation string.
''' Bell System Logo is used as a dummy character.
'''
-.tr \(bs-|\(bv\*(Tr
+.tr \(*W-|\(bv\*(Tr
.ie n \{\
-.ds -- \(bs-
-.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch
-.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\h'-8u'-\" diablo 12 pitch
+.ds -- \(*W-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
.ds L" ""
.ds R" ""
.ds L' '
Contained in the file specified by the first filename on the command line.
(Note that systems supporting the #! notation invoke interpreters this way.)
.Ip 3. 4 2
-Passed in via standard input.
+Passed in implicity via standard input.
+This only works if there are no filename arguments\*(--to pass
+arguments to a stdin script you must explicitly specify a - for the script name.
.PP
After locating your script,
.I perl
.nf
.ne 2
- #!/bin/perl -spi.bak # same as -s -p -i.bak
+ #!/usr/bin/perl -spi.bak # same as -s -p -i.bak
.\|.\|.
.fi
Options include:
.TP 5
+.B \-a
+turns on autosplit mode when used with a \-n or \-p.
+An implicit split command to the @F array
+is done as the first thing inside the implicit while loop produced by
+the \-n or \-p.
+.nf
+
+ perl -ane 'print pop(@F),"\en";'
+
+is equivalent to
+
+ while (<>) {
+ @F = split(' ');
+ print pop(@F),"\en";
+ }
+
+.fi
+.TP 5
.B \-D<number>
sets debugging flags.
To watch how it executes your script, use
The extension, if supplied, is added to the name of the
old file to make a backup copy.
If no extension is supplied, no backup is made.
-Saying \*(L"perl -p -i.bak -e "s/foo/bar/;" ... \*(R" is the same as using
+Saying \*(L"perl -p -i.bak -e "s/foo/bar/;" .\|.\|. \*(R" is the same as using
the script:
.nf
.ne 2
- #!/bin/perl -pi.bak
+ #!/usr/bin/perl -pi.bak
s/foo/bar/;
which is equivalent to
.ne 14
- #!/bin/perl
+ #!/usr/bin/perl
while (<>) {
if ($ARGV ne $oldargv) {
rename($ARGV,$ARGV . '.bak');
the filename has changed.
It does, however, use ARGVOUT for the selected filehandle.
Note that stdout is restored as the default output filehandle after the loop.
+.Sp
+You can use eof to locate the end of each input file, in case you want
+to append to each file, or reset line numbering (see example under eof).
.TP 5
.B \-I<directory>
may be used in conjunction with
.ne 3
while (<>) {
- ... # your script goes here
+ .\|.\|. # your script goes here
}
.fi
See
.B \-p
to have lines printed.
+Here is an efficient way to delete all files older than a week:
+.nf
+
+ find . -mtime +7 -print | perl -ne 'chop;unlink;'
+
+.fi
+This is faster than using the -exec switch find because you don't have to
+start a process on every filename found.
.TP 5
.B \-p
causes
.ne 5
while (<>) {
- ... # your script goes here
+ .\|.\|. # your script goes here
} continue {
print;
}
.nf
.ne 2
- #!/bin/perl -s
+ #!/usr/bin/perl -s
if ($xyz) { print "true\en"; }
.fi
+.TP 5
+.B \-S
+makes perl use the PATH environment variable to search for the script
+(unless the name of the script starts with a slash).
+Typically this is used to emulate #! startup on machines that don't
+support #!, in the following manner:
+.nf
+
+ #!/usr/bin/perl
+ eval "exec /usr/bin/perl -S $0 $*"
+ if $running_under_some_shell;
+
+.fi
+The system ignores the first line and feeds the script to /bin/sh,
+which proceeds to try to execute the perl script as a shell script.
+The shell executes the second line as a normal shell command, and thus
+starts up the perl interpreter.
+On some systems $0 doesn't always contain the full pathname,
+so the -S tells perl to search for the script if necessary.
+After perl locates the script, it parses the lines and ignores them because
+the variable $running_under_some_shell is never true.
+.TP 5
+.B \-U
+allows perl to do unsafe operations.
+Currently the only "unsafe" operation is the unlinking of directories while
+running as superuser.
+.TP 5
+.B \-v
+prints the version and patchlevel of your perl executable.
+.TP 5
+.B \-w
+prints warnings about identifiers that are mentioned only once, and scalar
+variables that are used before being set.
+Also warns about redefined subroutines, and references to undefined
+subroutines and filehandles.
.Sh "Data Types and Objects"
.PP
-Perl has about two and a half data types: strings, arrays of strings, and
+Perl has about two and a half data types: scalars, arrays of scalars, and
associative arrays.
-Strings and arrays of strings are first class objects, for the most part,
+Scalars and arrays of scalars are first class objects, for the most part,
in the sense that they can be used as a whole as values in an expression.
Associative arrays can only be accessed on an association by association basis;
they don't have a value as a whole (at least not yet).
.PP
-Strings are interpreted numerically as appropriate.
-A string is interpreted as TRUE in the boolean sense if it is not the null
+Scalars are interpreted as strings or numbers as appropriate.
+A scalar is interpreted as TRUE in the boolean sense if it is not the null
string or 0.
Booleans returned by operators are 1 for true and '0' or '' (the null
string) for false.
.PP
-References to string variables always begin with \*(L'$\*(R', even when referring
-to a string that is part of an array.
+References to scalar variables always begin with \*(L'$\*(R', even when referring
+to a scalar that is part of an array.
Thus:
.nf
.ne 3
- $days \h'|2i'# a simple string variable
+ $days \h'|2i'# a simple scalar variable
$days[28] \h'|2i'# 29th element of array @days
$days{'Feb'}\h'|2i'# one value from an associative array
+ $#days \h'|2i'# last index of array @days
but entire arrays are denoted by \*(L'@\*(R':
.fi
.PP
-Any of these four constructs may be assigned to (in compiler lingo, may serve
-as an lvalue).
-(Additionally, you may find the length of array @days by evaluating
+Any of these five constructs may server as an lvalue,
+that is, may be assigned to.
+(You may also use an assignment to one of these lvalues as an lvalue in
+certain contexts\*(--see s, tr and chop.)
+You may find the length of array @days by evaluating
\*(L"$#days\*(R", as in
.IR csh .
-[Actually, it's not the length of the array, it's the subscript of the last element, since there is (ordinarily) a 0th element.])
+(Actually, it's not the length of the array, it's the subscript of the last element, since there is (ordinarily) a 0th element.)
+Assigning to $#days changes the length of the array.
+Shortening an array by this method does not actually destroy any values.
+Lengthening an array that was previously shortened recovers the values that
+were in those elements.
+You can also gain some measure of efficiency by preextending an array that
+is going to get big.
+(You can also extend an array by assigning to an element that is off the
+end of the array.
+This differs from assigning to $#whatever in that intervening values
+are set to null rather than recovered.)
+You can truncate an array down to nothing by assigning the null list () to
+it.
+The following are exactly equivalent
+.nf
+
+ @whatever = ();
+ $#whatever = $[ \- 1;
+
+.fi
.PP
Every data type has its own namespace.
-You can, without fear of conflict, use the same name for a string variable,
+You can, without fear of conflict, use the same name for a scalar variable,
an array, an associative array, a filehandle, a subroutine name, and/or
a label.
Since variable and array references always start with \*(L'$\*(R'
or \*(L'@\*(R', the \*(L"reserved\*(R" words aren't in fact reserved
with respect to variable names.
(They ARE reserved with respect to labels and filehandles, however, which
-don't have an initial special character.)
+don't have an initial special character.
+Hint: you could say open(LOG,'logfile') rather than open(log,'logfile').)
Case IS significant\*(--\*(L"FOO\*(R", \*(L"Foo\*(R" and \*(L"foo\*(R" are all
different names.
Names which start with a letter may also contain digits and underscores.
This is nice, but if you forget your trailing quote, the error will not be
reported until perl finds another line containing the quote character, which
may be much further on in the script.
-Variable substitution inside strings is limited (currently) to simple string variables.
+Variable substitution inside strings is limited (currently) to simple scalar variables.
The following code segment prints out \*(L"The price is $100.\*(R"
.nf
($map{'red'}, $map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00);
.fi
+Array assignment returns the number of elements assigned.
.PP
Numeric literals are specified in any of the usual floating point or
integer formats.
.PP
There are several other pseudo-literals that you should know about.
-If a string is enclosed by backticks (grave accents), it is interpreted as
-a command, and the output of that command is the value of the pseudo-literal,
-just like in any of the standard shells.
+If a string is enclosed by backticks (grave accents), it first undergoes
+variable substitution just like a double quoted string.
+It is then interpreted as a command, and the output of that command
+is the value of the pseudo-literal, like in a shell.
The command is executed each time the pseudo-literal is evaluated.
-Unlike in \f2csh\f1, no interpretation is done on the
+The status value of the command is returned in $? (see Predefined Names
+for the interpretation of $?).
+Unlike in \f2csh\f1, no translation is done on the return
data\*(--newlines remain newlines.
-The status value of the command is returned in $?.
+Unlike in any of the shells, single quotes do not hide variable names
+in the command from interpretation.
+To pass a $ through to the shell you need to hide it with a backslash.
.PP
Evaluating a filehandle in angle brackets yields the next line
from that file (newline included, so it's never false until EOF).
.I open
function.
.PP
+If a <FILEHANDLE> is used in a context that is looking for an array, an array
+consisting of all the input lines is returned, one line per array element.
+It's easy to make a LARGE data space this way, so use with care.
+.PP
The null filehandle <> is special and can be used to emulate the behavior of
\fIsed\fR and \fIawk\fR.
Input from <> comes either from standard input, or from each file listed on
You can modify @ARGV before the first <> as long as you leave the first
filename at the beginning of the array.
Line numbers ($.) continue as if the input was one big happy file.
+(But see example under eof for how to reset line numbers on each file.)
.PP
.ne 5
-If you want to set @ARGV to you own list of files, go right ahead.
+If you want to set @ARGV to your own list of files, go right ahead.
If you want to pass switches into your script, you can
put a loop on the front like this:
.nf
The <> symbol will return FALSE only once.
If you call it again after this it will assume you are processing another
@ARGV list, and if you haven't set @ARGV, will input from stdin.
+.PP
+If the string inside the angle brackets is a reference to a scalar variable
+(e.g. <$foo>),
+then that variable contains the name of the filehandle to input from.
+.PP
+If the string inside angle brackets is not a filehandle, it is interpreted
+as a filename pattern to be globbed, and either an array of filenames or the
+next filename in the list is returned, depending on context.
+One level of $ interpretation is done first, but you can't say <$foo>
+because that's an indirect filehandle as explained in the previous
+paragraph.
+You could insert curly brackets to force interpretation as a
+filename glob: <${foo}>.
+Example:
+.nf
+
+.ne 3
+ while (<*.c>) {
+ chmod 0644,$_;
+ }
+
+is equivalent to
+
+.ne 5
+ open(foo,"echo *.c | tr -s ' \et\er\ef' '\e\e012\e\e012\e\e012\e\e012'|");
+ while (<foo>) {
+ chop;
+ chmod 0644,$_;
+ }
+
+.fi
+In fact, it's currently implemented that way.
+(Which means it will not work on filenames with spaces in them.)
+Of course, the shortest way to do the above is:
+.nf
+
+ chmod 0644,<*.c>;
+
+.fi
.Sh "Syntax"
.PP
A
.ne 4
if (EXPR) BLOCK
if (EXPR) BLOCK else BLOCK
- if (EXPR) BLOCK elsif (EXPR) BLOCK ... else BLOCK
+ if (EXPR) BLOCK elsif (EXPR) BLOCK .\|.\|. else BLOCK
LABEL while (EXPR) BLOCK
LABEL while (EXPR) BLOCK continue BLOCK
LABEL for (EXPR; EXPR; EXPR) BLOCK
+ LABEL foreach VAR (ARRAY) BLOCK
LABEL BLOCK continue BLOCK
.fi
}
.fi
.PP
+The foreach loop iterates over a normal array value and sets the variable
+VAR to be each element of the array in turn.
+The "foreach" keyword is actually identical to the "for" keyword,
+so you can use "foreach" for readability or "for" for brevity.
+If VAR is omitted, $_ is set to each value.
+If ARRAY is an actual array (as opposed to an expression returning an array
+value), you can modify each element of the array
+by modifying VAR inside the loop.
+Examples:
+.nf
+
+.ne 5
+ for (@ary) { s/foo/bar/; }
+
+ foreach $elem (@elements) {
+ $elem *= 2;
+ }
+
+ for ((10,9,8,7,6,5,4,3,2,1,'BOOM')) {
+ print $_,"\en"; sleep(1);
+ }
+
+.ne 3
+ foreach $item (split(/:[\e\e\en:]*/,$ENV{'TERMCAP'}) {
+ print "Item: $item\en";
+ }
+.fi
+.PP
The BLOCK by itself (labeled or not) is equivalent to a loop that executes
once.
Thus you can use any of the loop control statements in it to leave or
}
.fi
+It's also nice for exiting subroutines early.
+Note the double curly brackets:
+.nf
+
+.ne 8
+ sub tokenize {{
+ .\|.\|.
+ if (/foo/) {
+ 23; # return value
+ last;
+ }
+ .\|.\|.
+ }}
+
+.fi
.Sh "Simple statements"
The only kind of simple statement is an expression evaluated for its side
effects.
The
.I while
and
-.I unless
+.I until
modifiers also have the expected semantics (conditional evaluated first),
except when applied to a do-BLOCK command,
in which case the block executes once before the conditional is evaluated.
The corresponding assignment operator.
.Ip .. 8
The range operator, which is bistable.
-It is false as long as its left argument is false.
-Once the left argument is true, it stays true until the right argument is true,
-AFTER which it becomes false again.
-(It doesn't become false till the next time it's evaluated.
+Each .. operator maintains its own boolean state.
+It is false as long as its left operand is false.
+Once the left operand is true, the range operator stays true
+until the right operand is true,
+AFTER which the range operator becomes false again.
+(It doesn't become false till the next time the range operator evaluated.
It can become false on the same evaluation it became true, but it still returns
true once.)
+The right operand is not evaluated while the operator is in the "false" state,
+and the left operand is not evaluated while the operator is in the "true" state.
The .. operator is primarily intended for doing line number ranges after
the fashion of \fIsed\fR or \fIawk\fR.
The precedence is a little lower than || and &&.
want to exclude the endpoint.
You can exclude the beginning point by waiting for the sequence number to be
greater than 1.
-If either argument to .. is static, that argument is implicitly compared to
+If either operand of .. is static, that operand is implicitly compared to
the $. variable, the current line number.
Examples:
.nf
s/^/> / if (/^$/ .. eof()); # quote body
.fi
+.Ip \-x 8
+A file test.
+This unary operator takes one argument, either a filename or a filehandle,
+and tests the associated file to see if something is true about it.
+If the argument is omitted, tests $_, except for \-t, which tests stdin.
+It returns 1 for true and '' for false.
+Precedence is higher than logical and relational operators, but lower than
+arithmetic operators.
+The operator may be any of:
+.nf
+ \-r File is readable by effective uid.
+ \-w File is writeable by effective uid.
+ \-x File is executable by effective uid.
+ \-o File is owned by effective uid.
+ \-R File is readable by real uid.
+ \-W File is writeable by real uid.
+ \-X File is executable by real uid.
+ \-O File is owned by real uid.
+ \-e File exists.
+ \-z File has zero size.
+ \-s File has non-zero size.
+ \-f File is a plain file.
+ \-d File is a directory.
+ \-l File is a symbolic link.
+ \-p File is a named pipe (FIFO).
+ \-S File is a socket.
+ \-b File is a block special file.
+ \-c File is a character special file.
+ \-u File has setuid bit set.
+ \-g File has setgid bit set.
+ \-k File has sticky bit set.
+ \-t Filehandle is opened to a tty.
+ \-T File is a text file.
+ \-B File is a binary file (opposite of \-T).
+
+.fi
+The interpretation of the file permission operators \-r, \-R, \-w, \-W, \-x and \-X
+is based solely on the mode of the file and the uids and gids of the user.
+There may be other reasons you can't actually read, write or execute the file.
+Also note that, for the superuser, \-r, \-R, \-w and \-W always return 1, and
+\-x and \-X return 1 if any execute bit is set in the mode.
+Scripts run by the superuser may thus need to do a stat() in order to determine
+the actual mode of the file, or temporarily set the uid to something else.
+.Sp
+Example:
+.nf
+.ne 7
+
+ while (<>) {
+ chop;
+ next unless \-f $_; # ignore specials
+ .\|.\|.
+ }
+
+.fi
+Note that -s/a/b/ does not do a negated substitution.
+Saying -exp($foo) still works as expected, however\*(--only single letters
+following a minus are interpreted as file tests.
+.Sp
+The \-T and \-B switches work as follows.
+The first block or so of the file is examined for odd characters such as
+strange control codes or metacharacters.
+If too many odd characters (>10%) are found, it's a \-B file, otherwise it's a \-T file.
+Also, any file containing null in the first block is considered a binary file.
+If \-T or \-B is used on a filehandle, the current stdio buffer is examined
+rather than the first block.
+Since input doesn't work well on binary files you should probably test a
+filehandle before doing any input if you're unsure of the nature of the
+filehandle you've been handed (usually via stdin).
+Both \-T and \-B return TRUE on a null file, or a file at EOF when testing
+a filehandle.
.PP
Here is what C has that
.I perl
Address-of operator.
.Ip "unary *" 12
Dereference-address operator.
+.Ip "(TYPE)" 12
+Type casting operator.
.PP
Like C,
.I perl
.fi
and this all reduces to one string internally.
.PP
+The autoincrement operator has a little extra built-in magic to it.
+If you increment a variable that is numeric, or that has ever been used in
+a numeric context, you get a normal increment.
+If, however, the variable has only been used in string contexts since it
+was set, and has a value that is not null and matches the
+pattern /^[a-zA-Z]*[0-9]*$/, the increment is done
+as a string, preserving each character within its range, with carry:
+.nf
+
+ print ++($foo = '99'); # prints '100'
+ print ++($foo = 'a0'); # prints 'a1'
+ print ++($foo = 'Az'); # prints 'Ba'
+ print ++($foo = 'zz'); # prints 'aaa'
+
+.fi
+The autodecrement is not magical.
+.PP
Along with the literals and variables mentioned earlier,
-the following operations can serve as terms in an expression:
-.Ip "/PATTERN/" 8 4
+the following operations can serve as terms in an expression.
+Some of these operations take a LIST as an argument.
+Such a list can consist of any combination of scalar arguments or arrays;
+the arrays will be included in the list as if each individual element were
+interpolated at that point in the list.
+.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.
.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> \|=~ \|/\|^[Yy]\|/ \|&& \|do foo(\|); # do foo if desired
+ <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 of a set of files, for instance.
+something in each file of a set of files, for instance.
.Ip "chdir EXPR" 8 2
-Changes the working director to EXPR, if possible.
+Changes the working directory to EXPR, if possible.
Returns 1 upon success, 0 otherwise.
See example under die().
.Ip "chmod LIST" 8 2
Changes the permissions of a list of files.
The first element of the list must be the numerical mode.
-LIST may be an array, in which case you may wish to use the unshift()
-command to put the mode on the front of the array.
Returns the number of files successfully changed.
-Note: in order to use the value you must put the whole thing in parentheses.
.nf
- $cnt = (chmod 0755,'foo','bar');
+.ne 2
+ $cnt = chmod 0755,'foo','bar';
+ chmod 0755,@executables;
.fi
.Ip "chop(VARIABLE)" 8 5
}
.fi
+You can actually chop anything that's an lvalue, including an assignment:
+.nf
+
+ chop($cwd = `pwd`);
+
+.fi
.Ip "chown LIST" 8 2
Changes the owner (and group) of a list of files.
-LIST may be an array.
-The first two elements of the list must be the NUMERICAL uid and gid, in that order.
+The first two elements of the list must be the NUMERICAL uid and gid,
+in that order.
Returns the number of files successfully changed.
-Note: in order to use the value you must put the whole thing in parentheses.
.nf
- $cnt = (chown $uid,$gid,'foo');
+.ne 2
+ $cnt = chown $uid,$gid,'foo','bar';
+ chown $uid,$gid,@filenames;
.fi
-.ne 18
+.ne 23
Here's an example of looking up non-numeric uids:
.nf
print "User: ";
$user = <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 = ('foo','bar','bie','doll');
+ @ary = <$pattern>; # get filenames
if ($uid{$user} eq '') {
die "$user not in passwd file";
}
.ne 4
open(output,'|sort >foo'); # pipe to sort
- ... # print stuff to output
+ .\|.\|. # print stuff to output
close(output); # wait for sort to finish
open(input,'foo'); # get sort's results
.fi
+FILEHANDLE may be an expression whose value gives the real filehandle name.
.Ip "crypt(PLAINTEXT,SALT)" 8 6
Encrypts a string exactly like the crypt() function in the C library.
Useful for checking the password file for lousy passwords.
Only the guys wearing white hats should do this.
+.Ip "delete $ASSOC{KEY}" 8 6
+Deletes the specified value from the specified associative array.
+Returns the deleted value;
+The following deletes all the values of an associative array:
+.nf
+
+.ne 3
+ foreach $key (keys(ARRAY)) {
+ delete $ARRAY{$key};
+ }
+
+.fi
+(But it would be faster to use the reset command.)
.Ip "die EXPR" 8 6
-Prints the value of EXPR to stderr and exits with a non-zero status.
+Prints the value of EXPR to stderr and exits with the current value of $!
+(errno).
+If $! is 0, exits with the value of ($? >> 8) (`command` status).
+If ($? >> 8) is 0, exits with 255.
Equivalent examples:
.nf
.ne 3
- die "Can't cd to spool." unless chdir '/usr/spool/news';
+ die "Can't cd to spool.\en" unless chdir '/usr/spool/news';
+
+ chdir '/usr/spool/news' || die "Can't cd to spool.\en"
+
+.fi
+.Sp
+If the value of EXPR does not end in a newline, the current script line
+number and input line number (if any) are also printed, and a newline is
+supplied.
+Hint: sometimes appending ", stopped" to your message will cause it to make
+better sense when the string "at foo line 123" is appended.
+Suppose you are running script "canasta".
+.nf
+
+.ne 7
+ die "/etc/games is no good";
+ die "/etc/games is no good, stopped";
+
+produce, respectively
- (chdir '/usr/spool/news') || die "Can't cd to spool."
+ /etc/games is no good at canasta line 123.
+ /etc/games is no good, stopped at canasta line 123.
.fi
-Note that the parens are necessary above due to precedence.
See also
.IR exit .
.Ip "do BLOCK" 8 4
.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 "do".
+.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 ";#" 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.
assigned produces a FALSE (0) value).
The next call to each() after that will start iterating again.
The iterator can be reset only by reading all the elements from the array.
-You should not modify the array while iterating over it.
+You must not modify the array while iterating over it.
+There is a single iterator for each associative array, shared by all
+each(), keys() and values() function calls in the program.
The following prints out your environment like the printenv program, only
in a different order:
.nf
.Ip "eof" 8
Returns 1 if the next read on FILEHANDLE will return end of file, or if
FILEHANDLE is not open.
-If (FILEHANDLE) is omitted, the eof status is returned for the last file read.
-The null filehandle may be used to indicate the pseudo file formed of the
+FILEHANDLE may be an expression whose value gives the real filehandle name.
+An eof without an argument returns the eof status for the last file read.
+Empty parentheses () may be used to indicate the pseudo file formed of the
files listed on the command line, i.e. eof() is reasonable to use inside
-a while (<>) loop.
-Example:
+a while (<>) loop to detect the end of only the last file.
+Use eof(ARGV) or eof without the parens to test EACH file in a while (<>) loop.
+Examples:
.nf
.ne 7
- # insert dashes just before last line
+ # insert dashes just before last line of last file
while (<>) {
if (eof()) {
print "--------------\en";
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.
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.
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:
= gmtime(time);
.fi
-All array elements are numeric.
+All array elements are numeric, and come straight out of a struct tm.
+In particular this means that $mon has the range 0..11 and $wday has the
+range 0..6.
''' End of part 1
''' Beginning of part 2
-''' $Header: perl.man.2,v 1.0.1.3 88/02/01 17:33:03 root Exp $
+''' $Header: perl.man.2,v 2.0 88/06/05 00:09:30 root Exp $
'''
''' $Log: perl.man.2,v $
-''' Revision 1.0.1.3 88/02/01 17:33:03 root
-''' patch12: documented split more adequately.
-'''
-''' Revision 1.0.1.2 88/01/30 17:04:28 root
-''' patch 11: random cleanup
-'''
-''' Revision 1.0.1.1 88/01/28 10:25:11 root
-''' patch8: added $@ variable.
-'''
-''' Revision 1.0 87/12/18 16:18:41 root
-''' Initial revision
+''' Revision 2.0 88/06/05 00:09:30 root
+''' Baseline version 2.0.
'''
'''
.Ip "goto LABEL" 8 6
@keys = keys(ENV);
@values = values(ENV);
while ($#keys >= 0) {
- print pop(keys),'=',pop(values),"\n";
+ print pop(keys),'=',pop(values),"\en";
+ }
+
+or how about sorted by key:
+
+.ne 3
+ foreach $key (sort keys(ENV)) {
+ print $key,'=',$ENV{$key},"\en";
}
.fi
.Ip "kill LIST" 8 2
Sends a signal to a list of processes.
The first element of the list must be the (numerical) signal to send.
-LIST may be an array, in which case you may wish to use the unshift
-command to put the signal on the front of the array.
Returns the number of processes successfully signaled.
-Note: in order to use the value you must put the whole thing in parentheses:
.nf
- $cnt = (kill 9,$child1,$child2);
+ $cnt = kill 1,$child1,$child2;
+ kill 9,@goners;
.fi
+If the signal is negative, kills process groups instead of processes.
+(On System V, a negative \fIprocess\fR number will also kill process groups,
+but that's not portable.)
.Ip "last LABEL" 8 8
.Ip "last" 8
The
}
.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 "do 'filename';" operator also counts as an eval.)
+This operator works by saving the current values of those variables in LIST
+on a hidden stack and restoring them upon exiting the block, subroutine or eval.
+The LIST may be assigned to if desired, which allows you to initialize
+your local variables.
+Commonly this is used to name the parameters to a subroutine.
+Examples:
+.nf
+
+.ne 13
+ sub RANGEVAL {
+ local($min, $max, $thunk) = @_;
+ local($result) = '';
+ local($i);
+
+ # Presumably $thunk makes reference to $i
+
+ for ($i = $min; $i < $max; $i++) {
+ $result .= eval $thunk;
+ }
+
+ $result;
+ }
+
+.fi
.Ip "localtime(EXPR)" 8 4
Converts a time as returned by the time function to a 9-element array with
the time analyzed for the local timezone.
= localtime(time);
.fi
-All array elements are numeric.
+All array elements are numeric, and come straight out of a struct tm.
+In particular this means that $mon has the range 0..11 and $wday has the
+range 0..6.
.Ip "log(EXPR)" 8 3
Returns logarithm (base e) of EXPR.
.Ip "next LABEL" 8 8
.I continue
block on the above, it would get executed even on discarded lines.
If the LABEL is omitted, the command refers to the innermost enclosing loop.
-.Ip "length(EXPR)" 8 2
-Returns the length in characters of the value of EXPR.
-.Ip "link(OLDFILE,NEWFILE)" 8 2
-Creates a new filename linked to the old filename.
-Returns 1 for success, 0 otherwise.
.Ip "oct(EXPR)" 8 2
Returns the decimal value of EXPR interpreted as an octal string.
(If EXPR happens to start off with 0x, interprets it as a hex string instead.)
.Ip "open FILEHANDLE" 8
Opens the file whose filename is given by EXPR, and associates it with
FILEHANDLE.
-If EXPR is omitted, the string variable of the same name as the FILEHANDLE
+If FILEHANDLE is an expression, its value is used as the name of the
+real filehandle wanted.
+If EXPR is omitted, the scalar variable of the same name as the FILEHANDLE
contains the filename.
If the filename begins with \*(L">\*(R", the file is opened for output.
If the filename begins with \*(L">>\*(R", the file is opened for appending.
.nf
.ne 3
- $article = 100;
- open article || die "Can't find article $article";
- while (<article>) {\|.\|.\|.
+ $article = 100;
+ open article || die "Can't find article $article";
+ while (<article>) {\|.\|.\|.
+
+ open(LOG, '>>/usr/spool/news/twitlog'\|); # (log is reserved)
- open(log, '>>/usr/spool/news/twitlog'\|);
+ open(article, "caeser <$article |"\|); # decrypt article
- open(article, "caeser <$article |"\|); # decrypt article
+ open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process#
- open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process#
+.ne 7
+ # process argument list of files along with any includes
+
+ foreach $file (@ARGV) {
+ do process($file,'fh00'); # no pun intended
+ }
+
+ sub process {{
+ local($filename,$input) = @_;
+ $input++; # this is a string increment
+ unless (open($input,$filename)) {
+ print stderr "Can't open $filename\en";
+ last; # note block inside sub
+ }
+ while (<$input>) { # note the use of indirection
+ if (/^#include "(.*)"/) {
+ do process($1,$input);
+ next;
+ }
+ .\|.\|. # whatever
+ }
+ }}
+
+.fi
+You may also, in the Bourne shell tradition, specify an EXPR beginning
+with ">&", in which case the rest of the string
+is interpreted as the name of a filehandle
+(or file descriptor, if numeric) which is to be duped and opened.
+Here is a script that saves, redirects, and restores stdout and stdin:
+.nf
+
+.ne 21
+ #!/usr/bin/perl
+ open(saveout,">&stdout");
+ open(saveerr,">&stderr");
+
+ open(stdout,">foo.out") || die "Can't redirect stdout";
+ open(stderr,">&stdout") || die "Can't dup stdout";
+
+ select(stderr); $| = 1; # make unbuffered
+ select(stdout); $| = 1; # make unbuffered
+
+ print stdout "stdout 1\en"; # this works for
+ print stderr "stderr 1\en"; # subprocesses too
+
+ close(stdout);
+ close(stderr);
+
+ open(stdout,">&saveout");
+ open(stderr,">&saveerr");
+
+ print stdout "stdout 2\en";
+ print stderr "stderr 2\en";
.fi
+If you open a pipe on the command "-", i.e. either "|-" or "-|",
+then there is an implicit fork done, and the return value of open
+is the pid of the child within the parent process, and 0 within the child
+process.
+The filehandle behaves normally for the parent, but i/o to that
+filehandle is piped from/to the stdout/stdin of the child process.
+In the child process the filehandle isn't opened--i/o happens from/to
+the new stdout or stdin.
+Typically this is used like the normal piped open when you want to exercise
+more control over just how the pipe command gets executed, such as when
+you are running setuid, and don't want to have to scan shell commands
+for metacharacters.
+The following pairs are equivalent:
+.nf
+
+.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 the filehandle causes the parent process to wait for the
+child to finish, and returns the status value in $?.
.Ip "ord(EXPR)" 8 3
Returns the ascii value of the first character of EXPR.
.Ip "pop ARRAY" 8 6
.Ip "pop(ARRAY)" 8
Pops and returns the last value of the array, shortening the array by 1.
-''' $tmp = $ARRAY[$#ARRAY--]
+Has the same effect as
+.nf
+
+ $tmp = $ARRAY[$#ARRAY]; $#ARRAY--;
+
+.fi
.Ip "print FILEHANDLE LIST" 8 9
.Ip "print LIST" 8
.Ip "print" 8
-Prints a string or comma-separated list of strings.
+Prints a string or a comma-separated list of strings.
+FILEHANDLE may be a scalar variable name, in which case the variable contains
+the name of the filehandle, thus introducing one level of indirection.
If FILEHANDLE is omitted, prints by default to standard output (or to the
last selected output channel\*(--see select()).
If LIST is also omitted, prints $_ to stdout.
-LIST may also be an array value.
To set the default output channel to something other than stdout use the select operation.
.Ip "printf FILEHANDLE LIST" 8 9
.Ip "printf LIST" 8
Equivalent to a "print FILEHANDLE sprintf(LIST)".
-.Ip "push(ARRAY,EXPR)" 8 7
-Treats ARRAY (@ is optional) as a stack, and pushes the value of EXPR
+.Ip "push(ARRAY,LIST)" 8 7
+Treats ARRAY (@ is optional) as a stack, and pushes the values of LIST
onto the end of ARRAY.
-The length of ARRAY increases by 1.
+The length of ARRAY increases by the length of LIST.
Has the same effect as
.nf
- $ARRAY[$#ARRAY+1] = EXPR;
+ for $value (LIST) {
+ $ARRAY[$#ARRAY+1] = $value;
+ }
.fi
but is more efficient.
so that they work again.
The expression is interpreted as a list of single characters (hyphens allowed
for ranges).
-All string variables beginning with one of those letters are set to the null
-string.
+All variables and arrays beginning with one of those letters are reset to
+their pristine state.
If the expression is omitted, one-match searches (?pattern?) are reset to
match again.
Always returns 1.
reset; \h'|2i'# just reset ?? searches
.fi
-.Ip "s/PATTERN/REPLACEMENT/g" 8 3
+Note: resetting "A-Z" is not recommended since you'll wipe out your ARGV and ENV
+arrays.
+.Ip "s/PATTERN/REPLACEMENT/gi" 8 3
Searches a string for a pattern, and if found, replaces that pattern with the
replacement text and returns the number of substitutions made.
Otherwise it returns false (0).
The \*(L"g\*(R" is optional, and if present, indicates that all occurences
of the pattern are to be replaced.
+The \*(L"i\*(R" is also optional, and if present, indicates that matching
+is to be done in a case-insensitive manner.
Any delimiter may replace the slashes; if single quotes are used, no
interpretation is done on the replacement string.
If no string is specified via the =~ or !~ operator,
the $_ string is searched and modified.
-(The string specified with =~ must be a string variable or array element,
-i.e. an lvalue.)
+(The string specified with =~ must be a scalar variable, an array element,
+or an assignment to one of those, i.e. an lvalue.)
If the pattern contains a $ that looks like a variable rather than an
end-of-string test, the variable will be interpolated into the pattern at
run-time.
s/\|([^ \|]*\|) *\|([^ \|]*\|)\|/\|$2 $1/; # reverse 1st two fields
+ ($foo = $bar) =~ s/bar/foo/;
+
.fi
(Note the use of $ instead of \|\e\| in the last example. See section
on regular expressions.)
.Ip "seek(FILEHANDLE,POSITION,WHENCE)" 8 3
Randomly positions the file pointer for FILEHANDLE, just like the fseek()
call of stdio.
+FILEHANDLE may be an expression whose value gives the name of the filehandle.
Returns 1 upon success, 0 otherwise.
.Ip "select(FILEHANDLE)" 8 3
Sets the current default filehandle for output.
.fi
Select happens to return TRUE if the file is currently open and FALSE otherwise,
but this has no effect on its operation.
+FILEHANDLE may be an expression whose value gives the name of the actual filehandle.
.Ip "shift(ARRAY)" 8 6
.Ip "shift ARRAY" 8
.Ip "shift" 8
-Shifts the first value of the array off, shortening the array by 1 and
-moving everything down.
+Shifts the first value of the array off and returns it,
+shortening the array by 1 and moving everything down.
If ARRAY is omitted, shifts the ARGV array.
See also unshift(), push() and pop().
Shift() and unshift() do the same thing to the left end of an array that push()
Causes the script to sleep for EXPR seconds, or forever if no EXPR.
May be interrupted by sending the process a SIGALARM.
Returns the number of seconds actually slept.
+.Ip "sort SUBROUTINE LIST" 8 7
+.Ip "sort LIST" 8
+Sorts the LIST and returns the sorted array value.
+Nonexistent values of arrays are stripped out.
+If SUBROUTINE is omitted, sorts in standard string comparison order.
+If SUBROUTINE is specified, gives the name of a subroutine that returns
+a -1, 0, or 1, depending on how the elements of the array are to be ordered.
+In the interests of efficiency the normal calling code for subroutines
+is bypassed, with the following effects: the subroutine may not be a recursive
+subroutine, and the two elements to be compared are passed into the subroutine
+not via @_ but as $a and $b (see example below).
+SUBROUTINE may be a scalar variable name, in which case the value provides
+the name of the subroutine to use.
+Examples:
+.nf
+
+.ne 4
+ sub byage {
+ $age{$a} < $age{$b} ? -1 : $age{$a} > $age{$b} ? 1 : 0;
+ }
+ @sortedclass = sort byage @class;
+
+.ne 9
+ sub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; }
+ @harry = ('dog','cat','x','Cain','Abel');
+ @george = ('gone','chased','yz','Punished','Axed');
+ print sort @harry;
+ # prints AbelCaincatdogx
+ print sort reverse @harry;
+ # prints xdogcatCainAbel
+ print sort @george,'to',@harry;
+ # prints AbelAxedCainPunishedcatchaseddoggonetoxyz
+
+.fi
.Ip "split(/PATTERN/,EXPR)" 8 8
.Ip "split(/PATTERN/)" 8
.Ip "split" 8
= stat($filename);
.fi
+.Ip "study(SCALAR)" 8 6
+.Ip "study"
+Takes extra time to study SCALAR ($_ if unspecified) in anticipation of
+doing many pattern matches on the string before it is next modified.
+This may or may not save time, depending on the nature and number of patterns
+you are searching on\*(--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.
+For example, a loop which inserts index producing entries before an line
+containing a certain pattern:
+.nf
+
+.ne 8
+ while (<>) {
+ study;
+ print ".IX foo\en" if /\ebfoo\eb/;
+ print ".IX bar\en" if /\ebbar\eb/;
+ print ".IX blurfl\en" if /\ebblurfl\eb/;
+ .\|.\|.
+ print;
+ }
+
+.fi
.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.
Does exactly the same thing as \*(L"exec LIST\*(R" except that a fork
is done first, and the parent process waits for the child process to complete.
Note that argument processing varies depending on the number of arguments.
-The return value is the exit status of the program.
-See exec.
+The return value is the exit status of the program as returned by the wait()
+call.
+To get the actual exit value divide by 256.
+See also exec.
+.Ip "symlink(OLDFILE,NEWFILE)" 8 2
+Creates a new filename symbolically linked to the old filename.
+Returns 1 for success, 0 otherwise.
+On systems that don't support symbolic links, produces a fatal error at
+run time.
+To check for that, use eval:
+.nf
+
+ $symlink_exists = (eval 'symlink("","");', $@ eq '');
+
+.fi
.Ip "tell(FILEHANDLE)" 8 6
.Ip "tell" 8
Returns the current file position for FILEHANDLE.
+FILEHANDLE may be an expression whose value gives the name of the actual
+filehandle.
If FILEHANDLE is omitted, assumes the file last read.
.Ip "time" 8 4
Returns the number of seconds since January 1, 1970.
It returns the number of characters replaced.
If no string is specified via the =~ or !~ operator,
the $_ string is translated.
-(The string specified with =~ must be a string variable or array element,
-i.e. an lvalue.)
+(The string specified with =~ must be a scalar variable, an array element,
+or an assignment to one of those, i.e. an lvalue.)
For
.I sed
devotees,
$cnt = tr/*/*/; \h'|3i'# count the stars in $_
+ ($HOST = $host) =~ tr/a-z/A-Z/;
+
.fi
.Ip "umask(EXPR)" 8 3
Sets the umask for the process and returns the old one.
.Ip "unlink LIST" 8 2
Deletes a list of files.
-LIST may be an array.
Returns the number of files successfully deleted.
-Note: in order to use the value you must put the whole thing in parentheses:
.nf
- $cnt = (unlink 'a','b','c');
+.ne 2
+ $cnt = unlink 'a','b','c';
+ unlink @goners;
.fi
+Note: unlink will not delete directories unless you are superuser and the \-U
+flag is supplied to perl.
.ne 7
.Ip "unshift(ARRAY,LIST)" 8 4
Does the opposite of a shift.
+Or the opposite of a push, depending on how you look at it.
Prepends list to the front of the array, and returns the number of elements
in the new array.
.nf
unshift(ARGV,'-e') unless $ARGV[0] =~ /^-/;
.fi
+.Ip "utime LIST" 8 2
+Changes the access and modification times on each file of a list of files.
+The first two elements of the list must be the NUMERICAL access and
+modification times, in that order.
+Returns the number of files successfully changed.
+The inode modification time of each file is set to the current time.
+Example of a "touch" command:
+.nf
+
+.ne 3
+ #!/usr/bin/perl
+ $now = time;
+ utime $now,$now,@ARGV;
+
+.fi
.Ip "values(ASSOC_ARRAY)" 8 6
Returns a normal array consisting of all the values of the named associative
array.
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
If the FILEHANDLE is an EXPR, then the expression is evaluated and the
resulting string is used to look up the name of the FILEHANDLE at run time.
For more on formats, see the section on formats later on.
+.Sh "Precedence"
+Perl operators have the following associativity and precedence:
+.nf
+
+nonassoc\h'|1i'print printf exec system sort
+\h'1.5i'chmod chown kill unlink utime
+left\h'|1i',
+right\h'|1i'=
+right\h'|1i'?:
+nonassoc\h'|1i'..
+left\h'|1i'||
+left\h'|1i'&&
+left\h'|1i'| ^
+left\h'|1i'&
+nonassoc\h'|1i'== != eq ne
+nonassoc\h'|1i'< > <= >= lt gt le ge
+nonassoc\h'|1i'chdir die exit eval reset sleep
+nonassoc\h'|1i'-r -w -x etc.
+left\h'|1i'<< >>
+left\h'|1i'+ - .
+left\h'|1i'* / % x
+left\h'|1i'=~ !~
+right\h'|1i'! ~ and unary minus
+nonassoc\h'|1i'++ --
+left\h'|1i''('
+
+.fi
+Actually, the precedence of list operators such as print, sort or chmod is
+either very high or very low depending on whether you look at the left
+side of operator or the right side of it.
+For example, in
+
+ @ary = (1, 3, sort 4, 2);
+ print @ary; # prints 1324
+
+the commas on the right of the sort are evaluated before the sort, but
+the commas on the left are evaluated after.
+In other words, list operators tend to gobble up all the arguments that
+follow them, and then act like a simple term with regard to the preceding
+expression.
.Sh "Subroutines"
A subroutine may be declared as follows:
.nf
that is ($_[0], $_[1], .\|.\|.).
The return value of the subroutine is the value of the last expression
evaluated.
-There are no local variables\*(--everything is a global variable.
+To create local variables see the "local" operator.
.PP
A subroutine is called using the
.I do
operator.
-(CAVEAT: For efficiency reasons recursive subroutine calls are not currently
-supported.
-This restriction may go away in the future. Then again, it may not.)
.nf
.ne 12
Example:
sub MAX {
- $max = pop(@_);
- while ($foo = pop(@_)) {
+ local($max) = pop(@_);
+ foreach $foo (@_) {
$max = $foo \|if \|$max < $foo;
}
$max;
.fi
.nf
.ne 6
-Use array assignment to name your formal arguments:
+Use array assignment to local list to name your formal arguments:
sub maybeset {
- ($key,$value) = @_;
+ local($key,$value) = @_;
$foo{$key} = $value unless $foo{$key};
}
.fi
+Subroutines may be called recursively.
.Sh "Regular Expressions"
The patterns used in pattern matching are regular expressions such as
-those used by
-.IR egrep (1).
-In addition, \ew matches an alphanumeric character and \eW a nonalphanumeric.
+those supplied in the Version 8 regexp routines.
+(In fact, the routines are derived from Henry Spencer's freely redistributable
+reimplementation of the V8 routines.)
+In addition, \ew matches an alphanumeric character (including "_") and \eW a nonalphanumeric.
Word boundaries may be matched by \eb, and non-boundaries by \eB.
-The bracketing construct \|(\ .\|.\|.\ \|) may also be used, $<digit>
+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.
-(You can also use the old standby \e<digit> in search patterns,
-but $<digit> also works in replacement patterns and in the block controlled
-by the current conditional.)
+(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.
-Up to 10 alternatives may given in a pattern, separated by |, with the
-caveat that \|(\ .\|.\|.\ |\ .\|.\|.\ \|) is illegal.
+($0 normally returns the same thing, but don't depend on it.)
+Alternatives may be separated by |.
Examples:
.nf
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
.PP
The values are specified on the following line, in the same order as
the picture fields.
-They must currently be either string variable names or string literals (or
+They must currently be either scalar variable names or literals (or
pseudo-literals).
Currently you can separate values with spaces, but commas may be placed
between values to prepare for possible future versions in which full expressions
are allowed as values.
.PP
Picture fields that begin with ^ rather than @ are treated specially.
-The value supplied must be a string variable name which contains a text
+The value supplied must be a scalar variable name which contains a text
string.
.I Perl
puts as much text as it can into the field, and then chops off the front
-of the string so that the next time the string variable is referenced,
+of the string so that the next time the variable is referenced,
more of the text can be printed.
Normally you would use a sequence of fields in a vertical stack to print
out a block of text.
.fi
(Mnemonic: underline is understood in certain operations.)
.Ip $. 8
-The current input line number of the last file that was read.
+The current input line number of the last filehandle that was read.
Readonly.
+Remember that only an explicit close on the filehandle resets the line number.
+Since <> never does an explicit close, line numbers increase across ARGV files
+(but see examples under eof).
(Mnemonic: many programs use . to mean the current line number.)
.Ip $/ 8
The input record separator, newline by default.
running this script.
(Mnemonic: same as shells.)
.Ip $? 8
-The status returned by the last backtick (``) command.
-(Mnemonic: same as sh and ksh.)
+The status returned by the last backtick (``) command or system operator.
+Note that this is the status word returned by the wait() system
+call, so the exit value of the subprocess is actually ($? >> 8).
+$? & 255 gives which signal, if any, the process died from, and whether
+there was a core dump.
+(Mnemonic: similar to sh and ksh.)
+.Ip $& 8 4
+The string matched by the last pattern match.
+(Mnemonic: like & in some editors.)
.Ip $+ 8 4
The last bracket matched by the last search pattern.
This is useful if you don't know which of a set of alternative patterns
when subscripting and when evaluating the index() and substr() functions.
(Mnemonic: [ begins subscripts.)
.Ip $! 8 2
-The current value of errno, with all the usual caveats.
+If used in a numeric context, yields the current value of errno, with all the
+usual caveats.
+If used in a string context, yields the corresponding system error string.
+You can assign to $! in order to set errno
+if, for instance, you want $! to return the string for error n, or you want
+to set the exit value for the die operator.
(Mnemonic: What just went bang?)
.Ip $@ 8 2
The error message from the last eval command.
If null, the last eval parsed and executed correctly.
(Mnemonic: Where was the syntax error "at"?)
+.Ip $< 8 2
+The real uid of this process.
+(Mnemonic: it's the uid you came FROM, if you're running setuid.)
+.Ip $> 8 2
+The effective uid of this process.
+Example:
+.nf
+
+ $< = $>; # set real uid to the effective uid
+
+.fi
+(Mnemonic: it's the uid you went TO, if you're running setuid.)
+.Ip $( 8 2
+The real gid of this process.
+If you are on a machine that supports membership in multiple groups
+simultaneously, gives a space separated list of groups you are in.
+The first number is the one returned by getgid(), and the subsequent ones
+by getgroups(), one of which may be the same as the first number.
+(Mnemonic: parens are used to GROUP things.
+The real gid is the group you LEFT, if you're running setgid.)
+.Ip $) 8 2
+The effective gid of this process.
+If you are on a machine that supports membership in multiple groups
+simultaneously, gives a space separated list of groups you are in.
+The first number is the one returned by getegid(), and the subsequent ones
+by getgroups(), one of which may be the same as the first number.
+(Mnemonic: parens are used to GROUP things.
+The effective gid is the group that's RIGHT for you, if you're running setgid.)
+.Sp
+Note: $<, $>, $( and $) can only be set on machines that support the
+corresponding set[re][ug]id() routine.
.Ip @ARGV 8 3
The array ARGV contains the command line arguments intended for the script.
Note that $#ARGV is the generally number of arguments minus one, since
$ARGV[0] is the first argument, NOT the command name.
See $0 for the command name.
+.Ip @INC 8 3
+The array INC contains the list of places to look for perl scripts to be
+evaluated by the "do EXPR" command.
+It initially consists of the arguments to any -I command line switches, followed
+by the default perl library, probably "/usr/local/lib/perl".
.Ip $ENV{expr} 8 2
The associative array ENV contains your current environment.
Setting a value in ENV changes the environment for child processes.
.ne 12
sub handler { # 1st argument is signal name
- ($sig) = @_;
- print "Caught a SIG$sig--shutting down\n";
- close(log);
+ local($sig) = @_;
+ print "Caught a SIG$sig--shutting down\en";
+ close(LOG);
exit(0);
}
$SIG{'INT'} = 'handler';
$SIG{'QUIT'} = 'handler';
- ...
+ .\|.\|.
$SIG{'INT'} = 'DEFAULT'; # restore default action
$SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT
.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
tokener is in fact slightly context sensitive for operators like /, ?, and <.
And in fact, . itself can be the beginning of a number.)
.Ip * 4 2
-The \ennn construct in patterns must be given as [\ennn] to avoid interpretation
-as a backreference.
-.Ip * 4 2
Next, exit, and continue work differently.
.Ip * 4 2
When in doubt, run the awk construct through a2p and see what it gives you.
.Ip * 4 2
You can't take the address of anything.
.Ip * 4 2
-Subroutines are not reentrant.
-.Ip * 4 2
ARGV must be capitalized.
.Ip * 4 2
-The \*(L"system\*(R" calls link, unlink, rename, etc. return 1 for success, not 0.
+The \*(L"system\*(R" calls link, unlink, rename, etc. return nonzero for success, not 0.
.Ip * 4 2
Signal handlers deal with signal names, not numbers.
.PP
Backreferences in substitutions use $ rather than \e.
.Ip * 4 2
The pattern matching metacharacters (, ), and | do not have backslashes in front.
+.Ip * 4 2
+The range operator is .. rather than comma.
+.PP
+Sharp shell programmers should take note of the following:
+.Ip * 4 2
+The backtick operator does variable interpretation without regard to the
+presence of single quotes in the command.
+.Ip * 4 2
+The backtick operator does no translation of the return value, unlike csh.
+.Ip * 4 2
+Shells (especially csh) do several levels of substitution on each command line.
+Perl does substitution only in certain constructs such as double quotes,
+backticks, angle brackets and search patterns.
+.Ip * 4 2
+Shells interpret scripts a little bit at a time.
+Perl compiles the whole program before executing it.
+.Ip * 4 2
+The arguments are available via @ARGV, not $1, $2, etc.
+.Ip * 4 2
+The environment is not automatically made available as variables.
.SH BUGS
.PP
-You can't currently dereference array elements inside a double-quoted string.
-You must assign them to a temporary and interpolate that.
+You can't currently dereference arrays or array elements inside a
+double-quoted string.
+You must assign them to a scalar and interpolate that.
.PP
Associative arrays really ought to be first class objects.
.PP
-Recursive subroutines are not currently supported, due to the way temporary
-values are stored in the syntax tree.
-.PP
-Arrays ought to be passable to subroutines just as strings are.
-.PP
-The array literal consisting of one element is currently misinterpreted, i.e.
-.nf
-
- @array = (123);
-
-.fi
-doesn't work right.
+Perl is at the mercy of the C compiler's definitions of various operations
+such as % and atof().
+In particular, don't trust % on negative numbers.
.PP
.I Perl
actually stands for Pathologically Eclectic Rubbish Lister, but don't tell
-/* $Header: perl.y,v 1.0.1.1 88/01/28 10:25:31 root Exp $
+/* $Header: perl.y,v 2.0 88/06/05 00:09:36 root Exp $
*
* $Log: perl.y,v $
- * Revision 1.0.1.1 88/01/28 10:25:31 root
- * patch8: added eval operator.
- *
- * Revision 1.0 87/12/18 15:48:59 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:09:36 root
+ * Baseline version 2.0.
*
*/
%{
-#include "handy.h"
-#include "EXTERN.h"
-#include "search.h"
-#include "util.h"
#include "INTERN.h"
#include "perl.h"
+
char *tokename[] = {
"256",
"word",
"append","open","write","select","close","loopctl",
-"using","format","do","shift","push","pop","chop",
+"using","format","do","shift","push","pop","chop/study",
"while","until","if","unless","else","elsif","continue","split","sprintf",
"for", "eof", "tell", "seek", "stat",
"function(no args)","function(1 arg)","function(2 args)","function(3 args)","array function",
-"join", "sub",
+"join", "sub", "file test", "local", "delete",
"format lines",
"register","array_length", "array",
"s","pattern",
-"string","y",
-"print", "unary operation",
+"string","tr",
+"list operator",
"..",
"||",
"&&",
"==","!=", "EQ", "NE",
"<=",">=", "LT", "GT", "LE", "GE",
+"unary operation",
+"file test",
"<<",">>",
"=~","!~",
"unary -",
"???"
};
+STAB *scrstab;
+
%}
%start prog
%token <cval> WORD
%token <ival> APPEND OPEN WRITE SELECT CLOSE LOOPEX
-%token <ival> USING FORMAT DO SHIFT PUSH POP CHOP
+%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
+%token <ival> JOIN SUB FILETEST LOCAL DELETE
%token <formval> FORMLIST
%token <stabval> REG ARYLEN ARY
%token <arg> SUBST PATTERN
%type <stabval>
%type <cmdval> block lineseq line loop cond sideff nexpr else
%type <arg> expr sexpr term
-%type <arg> condmod loopmod cexpr
-%type <arg> texpr print
+%type <arg> condmod loopmod
+%type <arg> texpr listop
%type <cval> label
%type <compval> compblock
-%nonassoc <ival> PRINT
+%nonassoc <ival> LISTOP
%left ','
-%nonassoc <ival> UNIOP
%right '='
%right '?' ':'
%nonassoc DOTDOT
%left '&'
%nonassoc EQ NE SEQ SNE
%nonassoc '<' '>' LE GE SLT SGT SLE SGE
+%nonassoc <ival> UNIOP
+%nonassoc FILETEST
%left LS RS
%left '+' '-' '.'
%left '*' '/' '%' 'x'
| ELSE block
{ $$ = $2; }
| ELSIF '(' expr ')' compblock
- { $$ = make_ccmd(C_IF,$3,$5); }
+ { cmdline = $1;
+ $$ = make_ccmd(C_IF,$3,$5); }
;
block : '{' lineseq '}'
| loop /* loops add their own labels */
| label ';'
{ if ($1 != Nullch) {
- $$ = add_label(make_acmd(C_EXPR, Nullstab,
+ $$ = add_label($1, make_acmd(C_EXPR, Nullstab,
Nullarg, Nullarg) );
} else
$$ = Nullcmd; }
;
cond : IF '(' expr ')' compblock
- { $$ = make_ccmd(C_IF,$3,$5); }
+ { cmdline = $1;
+ $$ = make_ccmd(C_IF,$3,$5); }
| UNLESS '(' expr ')' compblock
- { $$ = invert(make_ccmd(C_IF,$3,$5)); }
+ { cmdline = $1;
+ $$ = invert(make_ccmd(C_IF,$3,$5)); }
| IF block compblock
- { $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); }
+ { cmdline = $1;
+ $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); }
| UNLESS block compblock
- { $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); }
+ { cmdline = $1;
+ $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); }
;
loop : label WHILE '(' texpr ')' compblock
- { $$ = wopt(add_label($1,
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
make_ccmd(C_WHILE,$4,$6) )); }
| label UNTIL '(' expr ')' compblock
- { $$ = wopt(add_label($1,
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
invert(make_ccmd(C_WHILE,$4,$6)) )); }
| label WHILE block compblock
- { $$ = wopt(add_label($1,
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
make_ccmd(C_WHILE, cmd_to_arg($3),$4) )); }
| label UNTIL block compblock
- { $$ = wopt(add_label($1,
+ { cmdline = $2;
+ $$ = wopt(add_label($1,
invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); }
+ | label FOR REG '(' expr ')' compblock
+ { cmdline = $2;
+ /*
+ * The following gobbledygook catches EXPRs that
+ * aren't explicit array refs and translates
+ * foreach VAR (EXPR) {
+ * into
+ * @ary = EXPR;
+ * foreach VAR (@ary) {
+ * where @ary is a hidden array made by genstab().
+ */
+ if ($5->arg_type != O_ARRAY) {
+ scrstab = aadd(genstab());
+ $$ = append_line(
+ make_acmd(C_EXPR, Nullstab,
+ l(make_op(O_ASSIGN,2,
+ listish(make_op(O_ARRAY, 1,
+ stab2arg(A_STAB,scrstab),
+ Nullarg,Nullarg, 1)),
+ listish($5),
+ Nullarg,1)),
+ Nullarg),
+ wopt(over($3,add_label($1,
+ make_ccmd(C_WHILE,
+ make_op(O_ARRAY, 1,
+ stab2arg(A_STAB,scrstab),
+ Nullarg,Nullarg, 1 ),
+ $7)))));
+ }
+ else {
+ $$ = wopt(over($3,add_label($1,
+ make_ccmd(C_WHILE,$5,$7) )));
+ }
+ }
+ | label FOR '(' expr ')' compblock
+ { cmdline = $2;
+ if ($4->arg_type != O_ARRAY) {
+ scrstab = aadd(genstab());
+ $$ = append_line(
+ make_acmd(C_EXPR, Nullstab,
+ l(make_op(O_ASSIGN,2,
+ listish(make_op(O_ARRAY, 1,
+ stab2arg(A_STAB,scrstab),
+ Nullarg,Nullarg, 1 )),
+ listish($4),
+ Nullarg,1)),
+ Nullarg),
+ wopt(over(defstab,add_label($1,
+ make_ccmd(C_WHILE,
+ make_op(O_ARRAY, 1,
+ stab2arg(A_STAB,scrstab),
+ Nullarg,Nullarg, 1 ),
+ $6)))));
+ }
+ else { /* lisp, anyone? */
+ $$ = wopt(over(defstab,add_label($1,
+ make_ccmd(C_WHILE,$4,$6) )));
+ }
+ }
| label FOR '(' nexpr ';' texpr ';' nexpr ')' block
/* basically fake up an initialize-while lineseq */
{ yyval.compval.comp_true = $10;
yyval.compval.comp_alt = $8;
+ cmdline = $2;
$$ = append_line($4,wopt(add_label($1,
make_ccmd(C_WHILE,$6,yyval.compval) ))); }
| label compblock /* a block is a loop that happens once */
;
subrout : SUB WORD block
- { stabent($2,TRUE)->stab_sub = $3; }
- ;
-
-expr : print
- | cexpr
+ { make_sub($2,$3); }
;
-cexpr : sexpr ',' cexpr
+expr : sexpr ',' expr
{ $$ = make_op(O_COMMA, 2, $1, $3, Nullarg,0); }
| sexpr
;
{ $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg,0); }
| '~' term
{ $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg,0);}
+ | FILETEST WORD
+ { opargs[$1] = 0; /* force it special */
+ $$ = make_op($1, 1,
+ stab2arg(A_STAB,stabent($2,TRUE)),
+ Nullarg, Nullarg,0);
+ }
+ | FILETEST sexpr
+ { opargs[$1] = 1;
+ $$ = make_op($1, 1, $2, Nullarg, Nullarg,0); }
+ | FILETEST
+ { opargs[$1] = ($1 != O_FTTTY);
+ $$ = make_op($1, 1,
+ stab2arg(A_STAB,
+ $1 == O_FTTTY?stabent("stdin",TRUE):defstab),
+ Nullarg, Nullarg,0); }
+ | LOCAL '(' expr ')'
+ { $$ = localize(listish(make_list(hide_ary($3)))); }
| '(' expr ')'
{ $$ = make_list(hide_ary($2)); }
| '(' ')'
{ $$ = make_list(Nullarg); }
+ | DO sexpr %prec FILETEST
+ { $$ = make_op(O_DOFILE,1,$2,Nullarg,Nullarg,0);
+ allstabs = TRUE;}
| DO block %prec '('
{ $$ = cmd_to_arg($2); }
| REG %prec '('
- { $$ = stab_to_arg(A_STAB,$1); }
+ { $$ = stab2arg(A_STAB,$1); }
| REG '[' expr ']' %prec '('
{ $$ = make_op(O_ARRAY, 2,
- $3, stab_to_arg(A_STAB,aadd($1)), Nullarg,0); }
+ $3, stab2arg(A_STAB,aadd($1)), Nullarg,0); }
| ARY %prec '('
{ $$ = make_op(O_ARRAY, 1,
- stab_to_arg(A_STAB,$1),
+ stab2arg(A_STAB,$1),
Nullarg, Nullarg, 1); }
| REG '{' expr '}' %prec '('
{ $$ = make_op(O_HASH, 2,
- $3, stab_to_arg(A_STAB,hadd($1)), Nullarg,0); }
+ $3, stab2arg(A_STAB,hadd($1)), Nullarg,0); }
+ | DELETE REG '{' expr '}' %prec '('
+ { $$ = make_op(O_DELETE, 2,
+ $4, stab2arg(A_STAB,hadd($2)), Nullarg,0); }
| ARYLEN %prec '('
- { $$ = stab_to_arg(A_ARYLEN,$1); }
+ { $$ = stab2arg(A_ARYLEN,$1); }
| RSTRING %prec '('
{ $$ = $1; }
| PATTERN %prec '('
| DO WORD '(' expr ')'
{ $$ = make_op(O_SUBR, 2,
make_list($4),
- stab_to_arg(A_STAB,stabent($2,TRUE)),
+ stab2arg(A_WORD,stabent($2,TRUE)),
Nullarg,1); }
| DO WORD '(' ')'
{ $$ = make_op(O_SUBR, 2,
make_list(Nullarg),
- stab_to_arg(A_STAB,stabent($2,TRUE)),
+ stab2arg(A_WORD,stabent($2,TRUE)),
+ Nullarg,1); }
+ | DO REG '(' expr ')'
+ { $$ = make_op(O_SUBR, 2,
+ make_list($4),
+ stab2arg(A_STAB,$2),
+ Nullarg,1); }
+ | DO REG '(' ')'
+ { $$ = make_op(O_SUBR, 2,
+ make_list(Nullarg),
+ stab2arg(A_STAB,$2),
Nullarg,1); }
| LOOPEX
{ $$ = make_op($1,0,Nullarg,Nullarg,Nullarg,0); }
Nullarg, Nullarg, Nullarg,0); }
| WRITE '(' WORD ')'
{ $$ = l(make_op(O_WRITE, 1,
- stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab2arg(A_STAB,stabent($3,TRUE)),
Nullarg, Nullarg,0)); safefree($3); }
| WRITE '(' expr ')'
{ $$ = make_op(O_WRITE, 1, $3, Nullarg, Nullarg,0); }
| SELECT '(' WORD ')'
{ $$ = l(make_op(O_SELECT, 1,
- stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab2arg(A_STAB,stabent($3,TRUE)),
Nullarg, Nullarg,0)); safefree($3); }
| SELECT '(' expr ')'
{ $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg,0); }
| OPEN WORD %prec '('
{ $$ = make_op(O_OPEN, 2,
- stab_to_arg(A_STAB,stabent($2,TRUE)),
- stab_to_arg(A_STAB,stabent($2,TRUE)),
+ stab2arg(A_WORD,stabent($2,TRUE)),
+ stab2arg(A_STAB,stabent($2,TRUE)),
Nullarg,0); }
| OPEN '(' WORD ')'
{ $$ = make_op(O_OPEN, 2,
- stab_to_arg(A_STAB,stabent($3,TRUE)),
- stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab2arg(A_WORD,stabent($3,TRUE)),
+ stab2arg(A_STAB,stabent($3,TRUE)),
Nullarg,0); }
| OPEN '(' WORD ',' expr ')'
{ $$ = make_op(O_OPEN, 2,
- stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab2arg(A_WORD,stabent($3,TRUE)),
+ $5, Nullarg,0); }
+ | OPEN '(' sexpr ',' expr ')'
+ { $$ = make_op(O_OPEN, 2,
+ $3,
$5, Nullarg,0); }
| CLOSE '(' WORD ')'
{ $$ = make_op(O_CLOSE, 1,
- stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab2arg(A_WORD,stabent($3,TRUE)),
+ Nullarg, Nullarg,0); }
+ | CLOSE '(' expr ')'
+ { $$ = make_op(O_CLOSE, 1,
+ $3,
Nullarg, Nullarg,0); }
| CLOSE WORD %prec '('
{ $$ = make_op(O_CLOSE, 1,
- stab_to_arg(A_STAB,stabent($2,TRUE)),
+ stab2arg(A_WORD,stabent($2,TRUE)),
Nullarg, Nullarg,0); }
| FEOF '(' WORD ')'
{ $$ = make_op(O_EOF, 1,
- stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab2arg(A_WORD,stabent($3,TRUE)),
+ Nullarg, Nullarg,0); }
+ | FEOF '(' expr ')'
+ { $$ = make_op(O_EOF, 1,
+ $3,
Nullarg, Nullarg,0); }
| FEOF '(' ')'
- { $$ = make_op(O_EOF, 0,
- stab_to_arg(A_STAB,stabent("ARGV",TRUE)),
+ { $$ = make_op(O_EOF, 1,
+ stab2arg(A_WORD,Nullstab),
Nullarg, Nullarg,0); }
| FEOF
{ $$ = make_op(O_EOF, 0,
Nullarg, Nullarg, Nullarg,0); }
| TELL '(' WORD ')'
{ $$ = make_op(O_TELL, 1,
- stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab2arg(A_WORD,stabent($3,TRUE)),
+ Nullarg, Nullarg,0); }
+ | TELL '(' expr ')'
+ { $$ = make_op(O_TELL, 1,
+ $3,
Nullarg, Nullarg,0); }
| TELL
{ $$ = make_op(O_TELL, 0,
Nullarg, Nullarg, Nullarg,0); }
| SEEK '(' WORD ',' sexpr ',' expr ')'
{ $$ = make_op(O_SEEK, 3,
- stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab2arg(A_WORD,stabent($3,TRUE)),
+ $5, $7,1); }
+ | SEEK '(' sexpr ',' sexpr ',' expr ')'
+ { $$ = make_op(O_SEEK, 3,
+ $3,
$5, $7,1); }
| PUSH '(' WORD ',' expr ')'
{ $$ = make_op($1, 2,
make_list($5),
- stab_to_arg(A_STAB,aadd(stabent($3,TRUE))),
+ stab2arg(A_STAB,aadd(stabent($3,TRUE))),
Nullarg,1); }
| PUSH '(' ARY ',' expr ')'
{ $$ = make_op($1, 2,
make_list($5),
- stab_to_arg(A_STAB,$3),
+ stab2arg(A_STAB,$3),
Nullarg,1); }
| POP WORD %prec '('
{ $$ = make_op(O_POP, 1,
- stab_to_arg(A_STAB,aadd(stabent($2,TRUE))),
+ stab2arg(A_STAB,aadd(stabent($2,TRUE))),
Nullarg, Nullarg,0); }
| POP '(' WORD ')'
{ $$ = make_op(O_POP, 1,
- stab_to_arg(A_STAB,aadd(stabent($3,TRUE))),
+ stab2arg(A_STAB,aadd(stabent($3,TRUE))),
Nullarg, Nullarg,0); }
| POP ARY %prec '('
{ $$ = make_op(O_POP, 1,
- stab_to_arg(A_STAB,$2),
+ stab2arg(A_STAB,$2),
Nullarg,
Nullarg,
0); }
| POP '(' ARY ')'
{ $$ = make_op(O_POP, 1,
- stab_to_arg(A_STAB,$3),
+ stab2arg(A_STAB,$3),
Nullarg,
Nullarg,
0); }
| SHIFT WORD %prec '('
{ $$ = make_op(O_SHIFT, 1,
- stab_to_arg(A_STAB,aadd(stabent($2,TRUE))),
+ stab2arg(A_STAB,aadd(stabent($2,TRUE))),
Nullarg, Nullarg,0); }
| SHIFT '(' WORD ')'
{ $$ = make_op(O_SHIFT, 1,
- stab_to_arg(A_STAB,aadd(stabent($3,TRUE))),
+ stab2arg(A_STAB,aadd(stabent($3,TRUE))),
Nullarg, Nullarg,0); }
| SHIFT ARY %prec '('
{ $$ = make_op(O_SHIFT, 1,
- stab_to_arg(A_STAB,$2), Nullarg, Nullarg,0); }
+ stab2arg(A_STAB,$2), Nullarg, Nullarg,0); }
| SHIFT '(' ARY ')'
{ $$ = make_op(O_SHIFT, 1,
- stab_to_arg(A_STAB,$3), Nullarg, Nullarg,0); }
+ stab2arg(A_STAB,$3), Nullarg, Nullarg,0); }
| SHIFT %prec '('
{ $$ = make_op(O_SHIFT, 1,
- stab_to_arg(A_STAB,aadd(stabent("ARGV",TRUE))),
+ stab2arg(A_STAB,aadd(stabent("ARGV",TRUE))),
Nullarg, Nullarg,0); }
| SPLIT %prec '('
- { scanpat("/[ \t\n]+/");
+ { scanpat("/\\s+/");
$$ = make_split(defstab,yylval.arg); }
| SPLIT '(' WORD ')'
- { scanpat("/[ \t\n]+/");
+ { scanpat("/\\s+/");
$$ = make_split(stabent($3,TRUE),yylval.arg); }
| SPLIT '(' WORD ',' PATTERN ')'
{ $$ = make_split(stabent($3,TRUE),$5); }
{ $$ = mod_match(O_MATCH, $5, make_split(defstab,$3) ); }
| SPLIT '(' sexpr ')'
{ $$ = mod_match(O_MATCH,
- stab_to_arg(A_STAB,defstab),
+ stab2arg(A_STAB,defstab),
make_split(defstab,$3) ); }
| JOIN '(' WORD ',' expr ')'
{ $$ = make_op(O_JOIN, 2,
$5,
- stab_to_arg(A_STAB,aadd(stabent($3,TRUE))),
+ stab2arg(A_STAB,aadd(stabent($3,TRUE))),
Nullarg,0); }
| JOIN '(' sexpr ',' expr ')'
{ $$ = make_op(O_JOIN, 2,
Nullarg,1); }
| STAT '(' WORD ')'
{ $$ = l(make_op(O_STAT, 1,
- stab_to_arg(A_STAB,stabent($3,TRUE)),
+ stab2arg(A_STAB,stabent($3,TRUE)),
Nullarg, Nullarg,0)); }
| STAT '(' expr ')'
{ $$ = make_op(O_STAT, 1, $3, Nullarg, Nullarg,0); }
- | CHOP
- { $$ = l(make_op(O_CHOP, 1,
- stab_to_arg(A_STAB,defstab),
+ | LVALFUN
+ { $$ = l(make_op($1, 1,
+ stab2arg(A_STAB,defstab),
Nullarg, Nullarg,0)); }
- | CHOP '(' expr ')'
- { $$ = l(make_op(O_CHOP, 1, $3, Nullarg, Nullarg,0)); }
+ | LVALFUN '(' expr ')'
+ { $$ = l(make_op($1, 1, $3, Nullarg, Nullarg,0)); }
| FUNC0
{ $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg,0); }
| FUNC1 '(' expr ')'
{ $$ = make_op($1, 1, $3, Nullarg, Nullarg,0); }
| FUNC2 '(' sexpr ',' expr ')'
- { $$ = make_op($1, 2, $3, $5, Nullarg, 0); }
+ { $$ = make_op($1, 2, $3, $5, Nullarg, 0);
+ if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE)
+ fbmcompile($$[2].arg_ptr.arg_str); }
| FUNC3 '(' sexpr ',' sexpr ',' expr ')'
{ $$ = make_op($1, 3, $3, $5, $7, 0); }
| STABFUN '(' WORD ')'
{ $$ = make_op($1, 1,
- stab_to_arg(A_STAB,hadd(stabent($3,TRUE))),
+ stab2arg(A_STAB,hadd(stabent($3,TRUE))),
Nullarg,
Nullarg, 0); }
+ | listop
;
-print : PRINT
+listop : LISTOP
{ $$ = make_op($1,2,
- stab_to_arg(A_STAB,defstab),
- stab_to_arg(A_STAB,Nullstab),
+ stab2arg(A_STAB,defstab),
+ stab2arg(A_WORD,Nullstab),
Nullarg,0); }
- | PRINT expr
+ | LISTOP expr
{ $$ = make_op($1,2,make_list($2),
- stab_to_arg(A_STAB,Nullstab),
+ stab2arg(A_WORD,Nullstab),
Nullarg,1); }
- | PRINT WORD
+ | LISTOP WORD
{ $$ = make_op($1,2,
- stab_to_arg(A_STAB,defstab),
- stab_to_arg(A_STAB,stabent($2,TRUE)),
+ stab2arg(A_STAB,defstab),
+ stab2arg(A_WORD,stabent($2,TRUE)),
+ Nullarg,1); }
+ | LISTOP WORD expr
+ { $$ = make_op($1,2,make_list($3),
+ stab2arg(A_WORD,stabent($2,TRUE)),
Nullarg,1); }
- | PRINT WORD expr
+ | LISTOP REG expr
{ $$ = make_op($1,2,make_list($3),
- stab_to_arg(A_STAB,stabent($2,TRUE)),
+ stab2arg(A_STAB,$2),
Nullarg,1); }
;
%% /* PROGRAM */
-#include "perly.c"
-#!/bin/perl
+#!/usr/bin/perl
-# $Header: perldb,v 1.0.1.1 88/01/28 10:27:16 root Exp $
+# $Header: perldb,v 2.0 88/06/05 00:09:45 root Exp $
#
# $Log: perldb,v $
-# Revision 1.0.1.1 88/01/28 10:27:16 root
-# patch8: created this file.
+# Revision 2.0 88/06/05 00:09:45 root
+# Baseline version 2.0.
#
#
open(tmp, ">$tmp") || die "Can't make temp script";
-$perl = '/bin/perl';
+$perl = '/usr/bin/perl';
$init = 1;
$state = 'statement';
$inform++;
next;
}
- if ($state eq 'statement' && !/^[ \t]*}/) {
+ if ($state eq 'statement' &&
+ !/^[ \t]*}|^[ \t]*else|^[ \t]*continue|^[ \t]*elsif/) {
if (s/^([ \t]*[A-Za-z_0-9]+:)//) {
$label = $1;
}
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//;
die "Illegal character $_";
}
elsif ($ord < 33) {
- next if s/[ \t\n]+//;
+ next if s/[ \t\n\f]+//;
die "Illegal character $_";
}
else {
$state = 'term', next if s/^<[A-Za-z_0-9]*>//;
next if s/^\+\+//;
next if s/^--//;
- $state = 'operator', 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/^"//;
.rn '' }`
-''' $Header: perldb.man,v 1.0.1.2 88/01/30 17:04:48 root Exp $
+''' $Header: perldb.man,v 2.0 88/06/05 00:09:50 root Exp $
'''
''' $Log: perldb.man,v $
-''' Revision 1.0.1.2 88/01/30 17:04:48 root
-''' patch 11: random cleanup
-'''
-''' Revision 1.0.1.1 88/01/28 10:28:19 root
-''' patch8: created this file.
+''' Revision 2.0 88/06/05 00:09:50 root
+''' Baseline version 2.0.
'''
'''
.de Sh
''' string Tr holds user defined translation string.
''' Bell System Logo is used as a dummy character.
'''
-.tr \(bs-|\(bv\*(Tr
+.tr \(*W-|\(bv\*(Tr
.ie n \{\
-.ds -- \(bs-
-.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch
-.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\h'-8u'-\" diablo 12 pitch
+.ds -- \(*W-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
.ds L" ""
.ds R" ""
.ds L' '
--- /dev/null
+#!/usr/bin/perl
+
+# Poor man's perl shell.
+
+# Simply type two carriage returns every time you want to evaluate.
+# Note that it must be a complete perl statement--don't type double
+# carriage return in the middle of a loop.
+
+$/ = ''; # set paragraph mode
+$SHlinesep = "\n";
+while ($SHcmd = <>) {
+ $/ = $SHlinesep;
+ eval $SHcmd; print $@ || "\n";
+ $SHlinesep = $/; $/ = '';
+}
-char rcsid[] = "$Header: perly.c,v 1.0.1.3 88/01/28 10:28:31 root Exp $";
+char rcsid[] = "$Header: perly.c,v 2.0 88/06/05 00:09:56 root Exp $";
/*
* $Log: perly.c,v $
- * Revision 1.0.1.3 88/01/28 10:28:31 root
- * patch8: added eval operator. Also fixed expectterm following right curly.
- *
- * Revision 1.0.1.2 88/01/24 00:06:03 root
- * patch 2: s/(abc)/\1/ grandfathering didn't work right.
- *
- * Revision 1.0.1.1 88/01/21 21:25:57 root
- * Now uses CPP and CPPMINUS symbols from config.h.
- *
- * Revision 1.0 87/12/18 15:53:31 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:09:56 root
+ * Baseline version 2.0.
*
*/
-bool preprocess = FALSE;
-bool assume_n = FALSE;
-bool assume_p = FALSE;
-bool doswitches = FALSE;
-bool allstabs = FALSE; /* init all customary symbols in symbol table?*/
-char *filename;
-char *e_tmpname = "/tmp/perl-eXXXXXX";
-FILE *e_fp = Nullfp;
-ARG *l();
+#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();
main(argc,argv,env)
register int argc;
{
register STR *str;
register char *s;
- char *index();
+ char *index(), *strcpy(), *getenv();
+ bool dosearch = FALSE;
+ uid = (int)getuid();
+ euid = (int)geteuid();
linestr = str_new(80);
- str = str_make("-I/usr/lib/perl "); /* first used for -I flags */
+ str_nset(linestr,"",0);
+ str = str_make(""); /* first used for -I flags */
+ incstab = aadd(stabent("INC",TRUE));
for (argc--,argv++; argc; argc--,argv++) {
if (argv[0][0] != '-' || !argv[0][1])
break;
reswitch:
switch (argv[0][1]) {
+ case 'a':
+ minus_a = TRUE;
+ strcpy(argv[0], argv[0]+1);
+ goto reswitch;
#ifdef DEBUGGING
case 'D':
debug = atoi(argv[0]+2);
#endif
case 'e':
if (!e_fp) {
+ e_tmpname = strcpy(safemalloc(sizeof(TMPPATH)),TMPPATH);
mktemp(e_tmpname);
e_fp = fopen(e_tmpname,"w");
}
case 'I':
str_cat(str,argv[0]);
str_cat(str," ");
- if (!argv[0][2]) {
+ if (argv[0][2]) {
+ apush(incstab->stab_array,str_make(argv[0]+2));
+ }
+ else {
+ apush(incstab->stab_array,str_make(argv[1]));
str_cat(str,argv[1]);
argc--,argv++;
str_cat(str," ");
}
break;
case 'n':
- assume_n = TRUE;
+ minus_n = TRUE;
strcpy(argv[0], argv[0]+1);
goto reswitch;
case 'p':
- assume_p = TRUE;
+ minus_p = TRUE;
strcpy(argv[0], argv[0]+1);
goto reswitch;
case 'P':
doswitches = TRUE;
strcpy(argv[0], argv[0]+1);
goto reswitch;
+ case 'S':
+ dosearch = TRUE;
+ strcpy(argv[0], argv[0]+1);
+ goto reswitch;
+ case 'U':
+ unsafe = TRUE;
+ strcpy(argv[0], argv[0]+1);
+ goto reswitch;
case 'v':
version();
exit(0);
+ case 'w':
+ dowarn = TRUE;
+ strcpy(argv[0], argv[0]+1);
+ goto reswitch;
case '-':
argc--,argv++;
goto switch_end;
case 0:
break;
default:
- fatal("Unrecognized switch: %s\n",argv[0]);
+ fatal("Unrecognized switch: %s",argv[0]);
}
}
switch_end:
argc++,argv--;
argv[0] = e_tmpname;
}
+#ifndef PRIVLIB
+#define PRIVLIB "/usr/local/lib/perl"
+#endif
+ apush(incstab->stab_array,str_make(PRIVLIB));
str_set(&str_no,No);
str_set(&str_yes,Yes);
if (argv[0] == Nullch)
argv[0] = "-";
+ if (dosearch && argv[0][0] != '/' && (s = getenv("PATH"))) {
+ char *xfound = Nullch, *xfailed = Nullch;
+
+ while (*s) {
+ s = cpytill(tokenbuf,s,':');
+ if (*s)
+ s++;
+ if (tokenbuf[0])
+ strcat(tokenbuf,"/");
+ strcat(tokenbuf,argv[0]);
+#ifdef DEBUGGING
+ if (debug & 1)
+ fprintf(stderr,"Looking for %s\n",tokenbuf);
+#endif
+ if (stat(tokenbuf,&statbuf) < 0) /* not there? */
+ continue;
+ if ((statbuf.st_mode & S_IFMT) == S_IFREG
+ && cando(S_IREAD,TRUE) && cando(S_IEXEC,TRUE)) {
+ xfound = tokenbuf; /* bingo! */
+ break;
+ }
+ if (!xfailed)
+ xfailed = savestr(tokenbuf);
+ }
+ if (!xfound)
+ fatal("Can't execute %s", xfailed);
+ if (xfailed)
+ safefree(xfailed);
+ argv[0] = savestr(xfound);
+ }
filename = savestr(argv[0]);
+ origfilename = savestr(filename);
if (strEQ(filename,"-"))
argv[0] = "";
if (preprocess) {
+ str_cat(str,"-I");
+ str_cat(str,PRIVLIB);
sprintf(buf, "\
/bin/sed -e '/^[^#]/b' \
-e '/^#[ ]*include[ ]/b' \
-e '/^#[ ]*define[ ]/b' \
-e '/^#[ ]*if[ ]/b' \
-e '/^#[ ]*ifdef[ ]/b' \
+ -e '/^#[ ]*ifndef[ ]/b' \
-e '/^#[ ]*else/b' \
-e '/^#[ ]*endif/b' \
-e 's/^#.*//' \
- %s | %s -C %s%s",
- argv[0], CPP, str_get(str), CPPMINUS);
+ %s | %s -C %s %s",
+ argv[0], CPPSTDIN, str_get(str), CPPMINUS);
rsfp = popen(buf,"r");
}
else if (!*argv[0])
else
rsfp = fopen(argv[0],"r");
if (rsfp == Nullfp)
- fatal("Perl script \"%s\" doesn't seem to exist.\n",filename);
+ fatal("Perl script \"%s\" doesn't seem to exist",filename);
str_free(str); /* free -I directories */
defstab = stabent("_",TRUE);
if (yyparse())
fatal("Execution aborted due to compilation errors.\n");
+ if (dowarn) {
+ stab_check('A','Z');
+ stab_check('a','z');
+ }
+
+ preprocess = FALSE;
if (e_fp) {
e_fp = Nullfp;
UNLINK(e_tmpname);
}
}
if (argvstab = stabent("ARGV",allstabs)) {
+ aadd(argvstab);
for (; argc > 0; argc--,argv++) {
apush(argvstab->stab_array,str_make(argv[0]));
}
}
if (envstab = stabent("ENV",allstabs)) {
+ hadd(envstab);
for (; *env; env++) {
if (!(s = index(*env,'=')))
continue;
*--s = '=';
}
}
- sigstab = stabent("SIG",allstabs);
+ if (sigstab = stabent("SIG",allstabs))
+ hadd(sigstab);
- magicalize("!#?^~=-%0123456789.+&*(),\\/[|");
+ magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|");
- (tmpstab = stabent("0",allstabs)) && str_set(STAB_STR(tmpstab),filename);
- (tmpstab = stabent("$",allstabs)) &&
+ sawampersand = (stabent("&",FALSE) != Nullstab);
+ if (tmpstab = stabent("0",allstabs))
+ str_set(STAB_STR(tmpstab),origfilename);
+ if (tmpstab = stabent("$",allstabs))
str_numset(STAB_STR(tmpstab),(double)getpid());
tmpstab = stabent("stdin",TRUE);
tmpstab = stabent("stderr",TRUE);
tmpstab->stab_io = stio_new();
tmpstab->stab_io->fp = stderr;
- safefree(filename);
- filename = "(eval)";
+
+ savestack = anew(Nullstab); /* for saving non-local values */
setjmp(top_env); /* sets goto_targ on longjump */
(void) cmd_exec(main_root);
if (goto_targ)
- fatal("Can't find label \"%s\"--aborting.\n",goto_targ);
+ fatal("Can't find label \"%s\"--aborting",goto_targ);
exit(0);
+ /* NOTREACHED */
}
magicalize(list)
}
}
-#define RETURN(retval) return (bufptr = s,retval)
-#define OPERATOR(retval) return (expectterm = TRUE,bufptr = s,retval)
-#define TERM(retval) return (expectterm = FALSE,bufptr = s,retval)
-#define LOOPX(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,LOOPEX)
-#define UNI(f) return (yylval.ival = f,expectterm = TRUE,bufptr = s,UNIOP)
-#define FUN0(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC0)
-#define FUN1(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC1)
-#define FUN2(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC2)
-#define FUN3(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,FUNC3)
-#define SFUN(f) return (yylval.ival = f,expectterm = FALSE,bufptr = s,STABFUN)
-
-yylex()
-{
- register char *s = bufptr;
- register char *d;
- register int tmp;
- static bool in_format = FALSE;
- static bool firstline = TRUE;
-
- retry:
-#ifdef YYDEBUG
- if (yydebug)
- if (index(s,'\n'))
- fprintf(stderr,"Tokener at %s",s);
- else
- fprintf(stderr,"Tokener at %s\n",s);
-#endif
- switch (*s) {
- default:
- fprintf(stderr,
- "Unrecognized character %c in file %s line %d--ignoring.\n",
- *s++,filename,line);
- goto retry;
- case 0:
- s = str_get(linestr);
- *s = '\0';
- if (firstline && (assume_n || assume_p)) {
- firstline = FALSE;
- str_set(linestr,"while (<>) {");
- s = str_get(linestr);
- goto retry;
- }
- if (!rsfp)
- RETURN(0);
- if (in_format) {
- yylval.formval = load_format(); /* leaves . in buffer */
- in_format = FALSE;
- s = str_get(linestr);
- TERM(FORMLIST);
- }
- line++;
- if ((s = str_gets(linestr, rsfp)) == Nullch) {
- if (preprocess)
- pclose(rsfp);
- else if (rsfp != stdin)
- fclose(rsfp);
- rsfp = Nullfp;
- if (assume_n || assume_p) {
- str_set(linestr,assume_p ? "}continue{print;" : "");
- str_cat(linestr,"}");
- s = str_get(linestr);
- goto retry;
- }
- s = str_get(linestr);
- RETURN(0);
- }
-#ifdef DEBUG
- else if (firstline) {
- char *showinput();
- s = showinput();
- }
-#endif
- firstline = FALSE;
- goto retry;
- case ' ': case '\t':
- s++;
- goto retry;
- case '\n':
- case '#':
- if (preprocess && s == str_get(linestr) &&
- s[1] == ' ' && isdigit(s[2])) {
- line = atoi(s+2)-1;
- for (s += 2; isdigit(*s); s++) ;
- while (*s && isspace(*s)) s++;
- if (filename)
- safefree(filename);
- s[strlen(s)-1] = '\0'; /* wipe out newline */
- filename = savestr(s);
- s = str_get(linestr);
- }
- if (in_eval) {
- while (*s && *s != '\n')
- s++;
- if (*s)
- s++;
- line++;
- }
- else
- *s = '\0';
- if (lex_newlines)
- RETURN('\n');
- goto retry;
- case '+':
- case '-':
- if (s[1] == *s) {
- s++;
- if (*s++ == '+')
- RETURN(INC);
- else
- RETURN(DEC);
- }
- /* FALL THROUGH */
- case '*':
- case '%':
- case '^':
- case '~':
- case '(':
- case ',':
- case ':':
- case ';':
- case '{':
- case '[':
- tmp = *s++;
- OPERATOR(tmp);
- case ')':
- case ']':
- tmp = *s++;
- TERM(tmp);
- case '}':
- tmp = *s++;
- for (d = s; *d == ' ' || *d == '\t'; d++) ;
- if (*d == '\n' || *d == '#')
- OPERATOR(tmp); /* block end */
- else
- TERM(tmp); /* associative array end */
- case '&':
- s++;
- tmp = *s++;
- if (tmp == '&')
- OPERATOR(ANDAND);
- s--;
- OPERATOR('&');
- case '|':
- s++;
- tmp = *s++;
- if (tmp == '|')
- OPERATOR(OROR);
- s--;
- OPERATOR('|');
- case '=':
- s++;
- tmp = *s++;
- if (tmp == '=')
- OPERATOR(EQ);
- if (tmp == '~')
- OPERATOR(MATCH);
- s--;
- OPERATOR('=');
- case '!':
- s++;
- tmp = *s++;
- if (tmp == '=')
- OPERATOR(NE);
- if (tmp == '~')
- OPERATOR(NMATCH);
- s--;
- OPERATOR('!');
- case '<':
- if (expectterm) {
- s = scanstr(s);
- TERM(RSTRING);
- }
- s++;
- tmp = *s++;
- if (tmp == '<')
- OPERATOR(LS);
- if (tmp == '=')
- OPERATOR(LE);
- s--;
- OPERATOR('<');
- case '>':
- s++;
- tmp = *s++;
- if (tmp == '>')
- OPERATOR(RS);
- if (tmp == '=')
- OPERATOR(GE);
- s--;
- OPERATOR('>');
-
-#define SNARFWORD \
- d = tokenbuf; \
- while (isalpha(*s) || isdigit(*s) || *s == '_') \
- *d++ = *s++; \
- *d = '\0'; \
- d = tokenbuf;
-
- case '$':
- if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) {
- s++;
- s = scanreg(s,tokenbuf);
- yylval.stabval = aadd(stabent(tokenbuf,TRUE));
- TERM(ARYLEN);
- }
- s = scanreg(s,tokenbuf);
- yylval.stabval = stabent(tokenbuf,TRUE);
- TERM(REG);
-
- case '@':
- s = scanreg(s,tokenbuf);
- yylval.stabval = aadd(stabent(tokenbuf,TRUE));
- TERM(ARY);
-
- case '/': /* may either be division or pattern */
- case '?': /* may either be conditional or pattern */
- if (expectterm) {
- s = scanpat(s);
- TERM(PATTERN);
- }
- tmp = *s++;
- OPERATOR(tmp);
-
- case '.':
- if (!expectterm || !isdigit(s[1])) {
- s++;
- tmp = *s++;
- if (tmp == '.')
- OPERATOR(DOTDOT);
- s--;
- OPERATOR('.');
- }
- /* FALL THROUGH */
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- case '\'': case '"': case '`':
- s = scanstr(s);
- TERM(RSTRING);
-
- case '_':
- SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'a': case 'A':
- SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'b': case 'B':
- SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'c': case 'C':
- SNARFWORD;
- if (strEQ(d,"continue"))
- OPERATOR(CONTINUE);
- if (strEQ(d,"chdir"))
- UNI(O_CHDIR);
- if (strEQ(d,"close"))
- OPERATOR(CLOSE);
- if (strEQ(d,"crypt"))
- FUN2(O_CRYPT);
- if (strEQ(d,"chop"))
- OPERATOR(CHOP);
- if (strEQ(d,"chmod")) {
- yylval.ival = O_CHMOD;
- OPERATOR(PRINT);
- }
- if (strEQ(d,"chown")) {
- yylval.ival = O_CHOWN;
- OPERATOR(PRINT);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'd': case 'D':
- SNARFWORD;
- if (strEQ(d,"do"))
- OPERATOR(DO);
- if (strEQ(d,"die"))
- UNI(O_DIE);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'e': case 'E':
- SNARFWORD;
- if (strEQ(d,"else"))
- OPERATOR(ELSE);
- if (strEQ(d,"elsif"))
- OPERATOR(ELSIF);
- if (strEQ(d,"eq") || strEQ(d,"EQ"))
- OPERATOR(SEQ);
- if (strEQ(d,"exit"))
- UNI(O_EXIT);
- if (strEQ(d,"eval")) {
- allstabs = TRUE; /* must initialize everything since */
- UNI(O_EVAL); /* we don't know what will be used */
- }
- if (strEQ(d,"eof"))
- TERM(FEOF);
- if (strEQ(d,"exp"))
- FUN1(O_EXP);
- if (strEQ(d,"each"))
- SFUN(O_EACH);
- if (strEQ(d,"exec")) {
- yylval.ival = O_EXEC;
- OPERATOR(PRINT);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'f': case 'F':
- SNARFWORD;
- if (strEQ(d,"for"))
- OPERATOR(FOR);
- if (strEQ(d,"format")) {
- in_format = TRUE;
- OPERATOR(FORMAT);
- }
- if (strEQ(d,"fork"))
- FUN0(O_FORK);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'g': case 'G':
- SNARFWORD;
- if (strEQ(d,"gt") || strEQ(d,"GT"))
- OPERATOR(SGT);
- if (strEQ(d,"ge") || strEQ(d,"GE"))
- OPERATOR(SGE);
- if (strEQ(d,"goto"))
- LOOPX(O_GOTO);
- if (strEQ(d,"gmtime"))
- FUN1(O_GMTIME);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'h': case 'H':
- SNARFWORD;
- if (strEQ(d,"hex"))
- FUN1(O_HEX);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'i': case 'I':
- SNARFWORD;
- if (strEQ(d,"if"))
- OPERATOR(IF);
- if (strEQ(d,"index"))
- FUN2(O_INDEX);
- if (strEQ(d,"int"))
- FUN1(O_INT);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'j': case 'J':
- SNARFWORD;
- if (strEQ(d,"join"))
- OPERATOR(JOIN);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'k': case 'K':
- SNARFWORD;
- if (strEQ(d,"keys"))
- SFUN(O_KEYS);
- if (strEQ(d,"kill")) {
- yylval.ival = O_KILL;
- OPERATOR(PRINT);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'l': case 'L':
- SNARFWORD;
- if (strEQ(d,"last"))
- LOOPX(O_LAST);
- if (strEQ(d,"length"))
- FUN1(O_LENGTH);
- if (strEQ(d,"lt") || strEQ(d,"LT"))
- OPERATOR(SLT);
- if (strEQ(d,"le") || strEQ(d,"LE"))
- OPERATOR(SLE);
- if (strEQ(d,"localtime"))
- FUN1(O_LOCALTIME);
- if (strEQ(d,"log"))
- FUN1(O_LOG);
- if (strEQ(d,"link"))
- FUN2(O_LINK);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'm': case 'M':
- SNARFWORD;
- if (strEQ(d,"m")) {
- s = scanpat(s-1);
- TERM(PATTERN);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'n': case 'N':
- SNARFWORD;
- if (strEQ(d,"next"))
- LOOPX(O_NEXT);
- if (strEQ(d,"ne") || strEQ(d,"NE"))
- OPERATOR(SNE);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'o': case 'O':
- SNARFWORD;
- if (strEQ(d,"open"))
- OPERATOR(OPEN);
- if (strEQ(d,"ord"))
- FUN1(O_ORD);
- if (strEQ(d,"oct"))
- FUN1(O_OCT);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'p': case 'P':
- SNARFWORD;
- if (strEQ(d,"print")) {
- yylval.ival = O_PRINT;
- OPERATOR(PRINT);
- }
- if (strEQ(d,"printf")) {
- yylval.ival = O_PRTF;
- OPERATOR(PRINT);
- }
- if (strEQ(d,"push")) {
- yylval.ival = O_PUSH;
- OPERATOR(PUSH);
- }
- if (strEQ(d,"pop"))
- OPERATOR(POP);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'q': case 'Q':
- SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'r': case 'R':
- SNARFWORD;
- if (strEQ(d,"reset"))
- UNI(O_RESET);
- if (strEQ(d,"redo"))
- LOOPX(O_REDO);
- if (strEQ(d,"rename"))
- FUN2(O_RENAME);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 's': case 'S':
- SNARFWORD;
- if (strEQ(d,"s")) {
- s = scansubst(s);
- TERM(SUBST);
- }
- if (strEQ(d,"shift"))
- TERM(SHIFT);
- if (strEQ(d,"split"))
- TERM(SPLIT);
- if (strEQ(d,"substr"))
- FUN3(O_SUBSTR);
- if (strEQ(d,"sprintf"))
- OPERATOR(SPRINTF);
- if (strEQ(d,"sub"))
- OPERATOR(SUB);
- if (strEQ(d,"select"))
- OPERATOR(SELECT);
- if (strEQ(d,"seek"))
- OPERATOR(SEEK);
- if (strEQ(d,"stat"))
- OPERATOR(STAT);
- if (strEQ(d,"sqrt"))
- FUN1(O_SQRT);
- if (strEQ(d,"sleep"))
- UNI(O_SLEEP);
- if (strEQ(d,"system")) {
- yylval.ival = O_SYSTEM;
- OPERATOR(PRINT);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 't': case 'T':
- SNARFWORD;
- if (strEQ(d,"tr")) {
- s = scantrans(s);
- TERM(TRANS);
- }
- if (strEQ(d,"tell"))
- TERM(TELL);
- if (strEQ(d,"time"))
- FUN0(O_TIME);
- if (strEQ(d,"times"))
- FUN0(O_TMS);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'u': case 'U':
- SNARFWORD;
- if (strEQ(d,"using"))
- OPERATOR(USING);
- if (strEQ(d,"until"))
- OPERATOR(UNTIL);
- if (strEQ(d,"unless"))
- OPERATOR(UNLESS);
- if (strEQ(d,"umask"))
- FUN1(O_UMASK);
- if (strEQ(d,"unshift")) {
- yylval.ival = O_UNSHIFT;
- OPERATOR(PUSH);
- }
- if (strEQ(d,"unlink")) {
- yylval.ival = O_UNLINK;
- OPERATOR(PRINT);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'v': case 'V':
- SNARFWORD;
- if (strEQ(d,"values"))
- SFUN(O_VALUES);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'w': case 'W':
- SNARFWORD;
- if (strEQ(d,"write"))
- TERM(WRITE);
- if (strEQ(d,"while"))
- OPERATOR(WHILE);
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'x': case 'X':
- SNARFWORD;
- if (!expectterm && strEQ(d,"x"))
- OPERATOR('x');
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'y': case 'Y':
- SNARFWORD;
- if (strEQ(d,"y")) {
- s = scantrans(s);
- TERM(TRANS);
- }
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- case 'z': case 'Z':
- SNARFWORD;
- yylval.cval = savestr(d);
- OPERATOR(WORD);
- }
-}
-
-STAB *
-stabent(name,add)
-register char *name;
-int add;
-{
- register STAB *stab;
-
- for (stab = stab_index[*name]; stab; stab = stab->stab_next) {
- if (strEQ(name,stab->stab_name))
- return stab;
- }
-
- /* no entry--should we add one? */
-
- if (add) {
- stab = (STAB *) safemalloc(sizeof(STAB));
- bzero((char*)stab, sizeof(STAB));
- stab->stab_name = savestr(name);
- stab->stab_val = str_new(0);
- stab->stab_next = stab_index[*name];
- stab_index[*name] = stab;
- return stab;
- }
- return Nullstab;
-}
-
-STIO *
-stio_new()
-{
- STIO *stio = (STIO *) safemalloc(sizeof(STIO));
-
- bzero((char*)stio, sizeof(STIO));
- stio->page_len = 60;
- return stio;
-}
-
-char *
-scanreg(s,dest)
-register char *s;
-char *dest;
-{
- register char *d;
-
- s++;
- d = dest;
- while (isalpha(*s) || isdigit(*s) || *s == '_')
- *d++ = *s++;
- *d = '\0';
- d = dest;
- if (!*d) {
- *d = *s++;
- if (*d == '{') {
- d = dest;
- while (*s && *s != '}')
- *d++ = *s++;
- *d = '\0';
- d = dest;
- if (*s)
- s++;
- }
- else
- d[1] = '\0';
- }
- if (*d == '^' && !isspace(*s))
- *d = *s++ & 31;
- return s;
-}
-
-STR *
-scanconst(string)
-char *string;
-{
- register STR *retstr;
- register char *t;
- register char *d;
-
- if (index(string,'|')) {
- return Nullstr;
- }
- retstr = str_make(string);
- t = str_get(retstr);
- for (d=t; *d; ) {
- switch (*d) {
- case '.': case '[': case '$': case '(': case ')': case '|':
- *d = '\0';
- break;
- case '\\':
- if (index("wWbB0123456789",d[1])) {
- *d = '\0';
- break;
- }
- strcpy(d,d+1);
- switch(*d) {
- case 'n':
- *d = '\n';
- break;
- case 't':
- *d = '\t';
- break;
- case 'f':
- *d = '\f';
- break;
- case 'r':
- *d = '\r';
- break;
- }
- /* FALL THROUGH */
- default:
- if (d[1] == '*' || d[1] == '+' || d[1] == '?') {
- *d = '\0';
- break;
- }
- d++;
- }
- }
- if (!*t) {
- str_free(retstr);
- return Nullstr;
- }
- retstr->str_cur = strlen(retstr->str_ptr); /* XXX cheating here */
- return retstr;
-}
-
-char *
-scanpat(s)
-register char *s;
-{
- register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
- register char *d;
-
- bzero((char *)spat, sizeof(SPAT));
- spat->spat_next = spat_root; /* link into spat list */
- spat_root = spat;
- init_compex(&spat->spat_compex);
-
- switch (*s++) {
- case 'm':
- s++;
- break;
- case '/':
- break;
- case '?':
- spat->spat_flags |= SPAT_USE_ONCE;
- break;
- default:
- fatal("Search pattern not found:\n%s",str_get(linestr));
- }
- s = cpytill(tokenbuf,s,s[-1]);
- if (!*s)
- fatal("Search pattern not terminated:\n%s",str_get(linestr));
- s++;
- if (*tokenbuf == '^') {
- spat->spat_first = scanconst(tokenbuf+1);
- if (spat->spat_first) {
- spat->spat_flen = strlen(spat->spat_first->str_ptr);
- if (spat->spat_flen == strlen(tokenbuf+1))
- spat->spat_flags |= SPAT_SCANALL;
- }
- }
- else {
- spat->spat_flags |= SPAT_SCANFIRST;
- spat->spat_first = scanconst(tokenbuf);
- if (spat->spat_first) {
- spat->spat_flen = strlen(spat->spat_first->str_ptr);
- if (spat->spat_flen == strlen(tokenbuf))
- spat->spat_flags |= SPAT_SCANALL;
- }
- }
- if (d = compile(&spat->spat_compex,tokenbuf,TRUE,FALSE))
- fatal(d);
- yylval.arg = make_match(O_MATCH,stab_to_arg(A_STAB,defstab),spat);
- return s;
-}
-
-char *
-scansubst(s)
-register char *s;
-{
- register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
- register char *d;
-
- bzero((char *)spat, sizeof(SPAT));
- spat->spat_next = spat_root; /* link into spat list */
- spat_root = spat;
- init_compex(&spat->spat_compex);
-
- s = cpytill(tokenbuf,s+1,*s);
- if (!*s)
- fatal("Substitution pattern not terminated:\n%s",str_get(linestr));
- for (d=tokenbuf; *d; d++) {
- if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
- register ARG *arg;
-
- spat->spat_runtime = arg = op_new(1);
- arg->arg_type = O_ITEM;
- arg[1].arg_type = A_DOUBLE;
- arg[1].arg_ptr.arg_str = str_make(tokenbuf);
- goto get_repl; /* skip compiling for now */
- }
- }
- if (*tokenbuf == '^') {
- spat->spat_first = scanconst(tokenbuf+1);
- if (spat->spat_first)
- spat->spat_flen = strlen(spat->spat_first->str_ptr);
- }
- else {
- spat->spat_flags |= SPAT_SCANFIRST;
- spat->spat_first = scanconst(tokenbuf);
- if (spat->spat_first)
- spat->spat_flen = strlen(spat->spat_first->str_ptr);
- }
- if (d = compile(&spat->spat_compex,tokenbuf,TRUE,FALSE))
- fatal(d);
-get_repl:
- s = scanstr(s);
- if (!*s)
- fatal("Substitution replacement not terminated:\n%s",str_get(linestr));
- spat->spat_repl = yylval.arg;
- if (*s == 'g') {
- s++;
- spat->spat_flags &= ~SPAT_USE_ONCE;
- }
- else
- spat->spat_flags |= SPAT_USE_ONCE;
- yylval.arg = make_match(O_SUBST,stab_to_arg(A_STAB,defstab),spat);
- return s;
-}
-
ARG *
make_split(stab,arg)
register STAB *stab;
register ARG *arg;
{
- if (arg->arg_type != O_MATCH) {
- register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
- register char *d;
+ 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;
- init_compex(&spat->spat_compex);
spat->spat_runtime = arg;
- arg = make_match(O_MATCH,stab_to_arg(A_STAB,defstab),spat);
+ arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
}
arg->arg_type = O_SPLIT;
- arg[2].arg_ptr.arg_spat->spat_repl = stab_to_arg(A_STAB,aadd(stab));
- return arg;
-}
-
-char *
-expand_charset(s)
-register char *s;
-{
- char t[512];
- register char *d = t;
- register int i;
-
- while (*s) {
- if (s[1] == '-' && s[2]) {
- for (i = s[0]; i <= s[2]; i++)
- *d++ = i;
- s += 3;
+ 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;
}
- else
- *d++ = *s++;
}
- *d = '\0';
- return savestr(t);
+ return arg;
}
-char *
-scantrans(s)
-register char *s;
+SUBR *
+make_sub(name,cmd)
+char *name;
+CMD *cmd;
{
- ARG *arg =
- l(make_op(O_TRANS,2,stab_to_arg(A_STAB,defstab),Nullarg,Nullarg,0));
- register char *t;
- register char *r;
- register char *tbl = safemalloc(256);
- register int i;
-
- arg[2].arg_type = A_NULL;
- arg[2].arg_ptr.arg_cval = tbl;
- for (i=0; i<256; i++)
- tbl[i] = 0;
- s = scanstr(s);
- if (!*s)
- fatal("Translation pattern not terminated:\n%s",str_get(linestr));
- t = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str));
- free_arg(yylval.arg);
- s = scanstr(s-1);
- if (!*s)
- fatal("Translation replacement not terminated:\n%s",str_get(linestr));
- r = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str));
- free_arg(yylval.arg);
- yylval.arg = arg;
- if (!*r) {
- safefree(r);
- r = t;
- }
- for (i = 0; t[i]; i++) {
- if (!r[i])
- r[i] = r[i-1];
- tbl[t[i] & 0377] = r[i];
- }
- if (r != t)
- safefree(r);
- safefree(t);
- return s;
+ 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;
+ }
+ 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 *
cmd->ucmd.acmd.ac_expr = arg;
cmd->c_expr = cond;
if (cond) {
- opt_arg(cmd,1);
+ 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->ucmd.ccmd.cc_true = cblock.comp_true;
cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
if (arg) {
- opt_arg(cmd,1);
+ opt_arg(cmd,1,0);
cmd->c_flags |= CF_COND;
}
+ if (cmdline != NOLINE) {
+ cmd->c_line = cmdline;
+ cmdline = NOLINE;
+ }
return cmd;
}
void
-opt_arg(cmd,fliporflop)
+opt_arg(cmd,fliporflop,acmd)
register CMD *cmd;
int fliporflop;
+int acmd;
{
register ARG *arg;
int opt = CFT_EVAL;
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 && arg[1].arg_type == A_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->arg_type == O_AND || arg->arg_type == O_OR) {
if (arg[flp].arg_type == A_SINGLE) {
opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE);
- cmd->c_first = arg[flp].arg_ptr.arg_str;
+ 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) {
}
}
else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST ||
- arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) {
+ arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) {
if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
arg[2].arg_type == A_SPAT &&
- arg[2].arg_ptr.arg_spat->spat_first ) {
+ arg[2].arg_ptr.arg_spat->spat_short ) {
cmd->c_stab = arg[1].arg_ptr.arg_stab;
- cmd->c_first = arg[2].arg_ptr.arg_spat->spat_first;
- cmd->c_flen = arg[2].arg_ptr.arg_spat->spat_flen;
- if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANALL &&
+ 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_first = Nullstr;
- arg[2].arg_ptr.arg_spat->spat_flen = 0; /* only one chk */
+ 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;
&& arg->arg_type == O_MATCH
&& context & 4
&& fliporflop == 1) {
- arg[2].arg_type = A_SINGLE; /* don't do twice */
- arg[2].arg_ptr.arg_str = &str_yes;
+ spat_free(arg[2].arg_ptr.arg_spat);
+ arg[2].arg_ptr.arg_spat = Nullspat; /* don't do twice */
}
cmd->c_flags |= sure;
}
if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
if (arg[2].arg_type == A_SINGLE) {
cmd->c_stab = arg[1].arg_ptr.arg_stab;
- cmd->c_first = arg[2].arg_ptr.arg_str;
- cmd->c_flen = 30000;
+ 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;
}
}
}
+ 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 &&
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);
+ opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd);
arg->arg_len = 2; /* this is a lie */
}
else {
bzero((char *)spat, sizeof(SPAT));
spat->spat_next = spat_root; /* link into spat list */
spat_root = spat;
- init_compex(&spat->spat_compex);
spat->spat_runtime = pat;
newarg = make_op(type,2,left,Nullarg,Nullarg,0);
register ARG *arg;
{
cmd->c_expr = arg;
- opt_arg(cmd,1);
+ opt_arg(cmd,1,0);
cmd->c_flags |= CF_COND;
return cmd;
}
register ARG *arg;
{
cmd->c_expr = arg;
- opt_arg(cmd,1);
+ opt_arg(cmd,1,0);
cmd->c_flags |= CF_COND|CF_LOOP;
if (cmd->c_type == C_BLOCK)
cmd->c_flags &= ~CF_COND;
fputs(tokenbuf,stderr);
}
-char *
-scanstr(s)
-register char *s;
-{
- register char term;
- register char *d;
- register ARG *arg;
- register bool makesingle = FALSE;
- char *leave = "\\$nrtfb0123456789"; /* which backslash sequences to keep */
-
- arg = op_new(1);
- yylval.arg = arg;
- arg->arg_type = O_ITEM;
-
- switch (*s) {
- default: /* a substitution replacement */
- arg[1].arg_type = A_DOUBLE;
- makesingle = TRUE; /* maybe disable runtime scanning */
- term = *s;
- if (term == '\'')
- leave = Nullch;
- goto snarf_it;
- case '0':
- {
- long i;
- int shift;
-
- arg[1].arg_type = A_SINGLE;
- if (s[1] == 'x') {
- shift = 4;
- s += 2;
- }
- else if (s[1] == '.')
- goto decimal;
- else
- shift = 3;
- i = 0;
- for (;;) {
- switch (*s) {
- default:
- goto out;
- case '8': case '9':
- if (shift != 4)
- fatal("Illegal octal digit at line %d",line);
- /* FALL THROUGH */
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7':
- i <<= shift;
- i += *s++ & 15;
- break;
- case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
- case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
- if (shift != 4)
- goto out;
- i <<= 4;
- i += (*s++ & 7) + 9;
- break;
- }
- }
- out:
- sprintf(tokenbuf,"%d",i);
- arg[1].arg_ptr.arg_str = str_make(tokenbuf);
- }
- break;
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9': case '.':
- decimal:
- arg[1].arg_type = A_SINGLE;
- d = tokenbuf;
- while (isdigit(*s) || *s == '_')
- *d++ = *s++;
- if (*s == '.' && index("0123456789eE",s[1]))
- *d++ = *s++;
- while (isdigit(*s) || *s == '_')
- *d++ = *s++;
- if (index("eE",*s) && index("+-0123456789",s[1]))
- *d++ = *s++;
- if (*s == '+' || *s == '-')
- *d++ = *s++;
- while (isdigit(*s))
- *d++ = *s++;
- *d = '\0';
- arg[1].arg_ptr.arg_str = str_make(tokenbuf);
- break;
- case '\'':
- arg[1].arg_type = A_SINGLE;
- term = *s;
- leave = Nullch;
- goto snarf_it;
-
- case '<':
- arg[1].arg_type = A_READ;
- s = cpytill(tokenbuf,s+1,'>');
- if (!*tokenbuf)
- strcpy(tokenbuf,"ARGV");
- if (*s)
- s++;
- if (rsfp == stdin && strEQ(tokenbuf,"stdin"))
- fatal("Can't get both program and data from <stdin>\n");
- arg[1].arg_ptr.arg_stab = stabent(tokenbuf,TRUE);
- arg[1].arg_ptr.arg_stab->stab_io = stio_new();
- if (strEQ(tokenbuf,"ARGV")) {
- aadd(arg[1].arg_ptr.arg_stab);
- arg[1].arg_ptr.arg_stab->stab_io->flags |= IOF_ARGV|IOF_START;
- }
- break;
- case '"':
- arg[1].arg_type = A_DOUBLE;
- makesingle = TRUE; /* maybe disable runtime scanning */
- term = *s;
- goto snarf_it;
- case '`':
- arg[1].arg_type = A_BACKTICK;
- term = *s;
- snarf_it:
- {
- STR *tmpstr;
- int sqstart = line;
- char *tmps;
-
- tmpstr = str_new(strlen(s));
- s = str_append_till(tmpstr,s+1,term,leave);
- while (!*s) { /* multiple line string? */
- s = str_gets(linestr, rsfp);
- if (!*s)
- fatal("EOF in string at line %d\n",sqstart);
- line++;
- s = str_append_till(tmpstr,s,term,leave);
- }
- s++;
- if (term == '\'') {
- arg[1].arg_ptr.arg_str = tmpstr;
- break;
- }
- tmps = s;
- s = d = tmpstr->str_ptr; /* assuming shrinkage only */
- while (*s) {
- if (*s == '$' && s[1]) {
- makesingle = FALSE; /* force interpretation */
- if (!isalpha(s[1])) { /* an internal register? */
- int len;
-
- len = scanreg(s,tokenbuf) - s;
- stabent(tokenbuf,TRUE); /* make sure it's created */
- while (len--)
- *d++ = *s++;
- continue;
- }
- }
- else if (*s == '\\' && s[1]) {
- s++;
- switch (*s) {
- default:
- defchar:
- if (!leave || index(leave,*s))
- *d++ = '\\';
- *d++ = *s++;
- continue;
- case '0': case '1': case '2': case '3':
- case '4': case '5': case '6': case '7':
- *d = *s++ - '0';
- if (index("01234567",*s)) {
- *d <<= 3;
- *d += *s++ - '0';
- }
- else if (!index("`\"",term)) { /* oops, a subpattern */
- s--;
- goto defchar;
- }
- if (index("01234567",*s)) {
- *d <<= 3;
- *d += *s++ - '0';
- }
- d++;
- continue;
- case 'b':
- *d++ = '\b';
- break;
- case 'n':
- *d++ = '\n';
- break;
- case 'r':
- *d++ = '\r';
- break;
- case 'f':
- *d++ = '\f';
- break;
- case 't':
- *d++ = '\t';
- break;
- }
- s++;
- continue;
- }
- *d++ = *s++;
- }
- *d = '\0';
- if (arg[1].arg_type == A_DOUBLE) {
- if (makesingle)
- arg[1].arg_type = A_SINGLE; /* now we can optimize on it */
- else
- leave = "\\";
- for (d = s = tmpstr->str_ptr; *s; *d++ = *s++) {
- if (*s == '\\' && (!leave || index(leave,s[1])))
- s++;
- }
- *d = '\0';
- }
- tmpstr->str_cur = d - tmpstr->str_ptr; /* XXX cheat */
- arg[1].arg_ptr.arg_str = tmpstr;
- s = tmps;
- break;
- }
- }
- return s;
-}
-
ARG *
make_op(type,newlen,arg1,arg2,arg3,dolist)
int type;
arg[1].arg_flags |= AF_SPECIAL;
}
}
- else if (chld->arg_type == O_ARRAY && chld->arg_len == 1)
- 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->arg_type == O_ITEM &&
(hoistable[chld[1].arg_type] ||
(type == O_ASSIGN &&
- (chld[1].arg_type == A_READ ||
- chld[1].arg_type == A_DOUBLE ||
+ ((chld[1].arg_type == A_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;
double value; /* must not be register */
register char *tmps;
int i;
+ unsigned long tmplong;
double exp(), log(), sqrt(), modf();
char *crypt();
break;
case O_REPEAT:
i = (int)str_gnum(s2);
- while (i--)
+ while (i-- > 0)
str_scat(str,s1);
break;
case O_MULTIPLY:
str_numset(str,value * str_gnum(s2));
break;
case O_DIVIDE:
- value = str_gnum(s1);
- str_numset(str,value / str_gnum(s2));
+ 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:
- value = str_gnum(s1);
- str_numset(str,(double)(((long)value) % ((long)str_gnum(s2))));
+ 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);
break;
case O_LEFT_SHIFT:
value = str_gnum(s1);
- str_numset(str,(double)(((long)value) << ((long)str_gnum(s2))));
+ i = (int)str_gnum(s2);
+ str_numset(str,(double)(((unsigned long)value) << i));
break;
case O_RIGHT_SHIFT:
value = str_gnum(s1);
- str_numset(str,(double)(((long)value) >> ((long)str_gnum(s2))));
+ i = (int)str_gnum(s2);
+ str_numset(str,(double)(((unsigned long)value) >> i));
break;
case O_LT:
value = str_gnum(s1);
break;
case O_BIT_AND:
value = str_gnum(s1);
- str_numset(str,(double)(((long)value) & ((long)str_gnum(s2))));
+ str_numset(str,(double)(((unsigned long)value) &
+ ((unsigned long)str_gnum(s2))));
break;
case O_XOR:
value = str_gnum(s1);
- str_numset(str,(double)(((long)value) ^ ((long)str_gnum(s2))));
+ 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)(((long)value) | ((long)str_gnum(s2))));
+ str_numset(str,(double)(((unsigned long)value) |
+ ((unsigned long)str_gnum(s2))));
break;
case O_AND:
if (str_true(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)));
str_numset(str,sqrt(str_gnum(s1)));
break;
case O_INT:
- modf(str_gnum(s1),&value);
+ 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:
{
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 (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) {
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
}
else if (arg1->arg_type == O_HASH)
arg1->arg_type = O_LHASH;
- else {
+ else if (arg1->arg_type != O_ASSIGN) {
sprintf(tokenbuf,
"Illegal expression (%s) as lvalue",opname[arg1->arg_type]);
yyerror(tokenbuf);
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 = *node; /* copy everything except the STR */
arg->arg_ptr.arg_str = tmpstr;
for (j = 1; ; ) {
- arg[j++] = node[1];
+ arg[j] = node[1];
+ ++j; /* Bug in Xenix compiler */
if (j >= i) {
arg[j] = node[2];
free_arg(node);
listish(arg)
ARG *arg;
{
- if (arg->arg_flags & AF_LISTISH)
+ 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 *
-stab_to_arg(atype,stab)
+stab2arg(atype,stab)
int atype;
register STAB *stab;
{
arg[2].arg_ptr.arg_spat = spat;
#ifdef DEBUGGING
if (debug & 16)
- fprintf(stderr,"make_match SPAT=%lx\n",spat);
+ fprintf(stderr,"make_match SPAT=%lx\n",(long)spat);
#endif
if (type == O_SUBST || type == O_NSUBST) {
{
register CMD *tail;
register ARG *arg = cmd->c_expr;
- char *tmps; /* used by True macro */
+ STAB *asgnstab;
/* hoist "while (<channel>)" up into command block */
cmd->c_stab = arg[1].arg_ptr.arg_stab;
if (arg[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV) {
cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */
- stab_to_arg(A_LVAL,defstab), arg, Nullarg,1 ));
+ 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 */
return cmd;
}
-FCMD *
-load_format()
+CMD *
+over(eachstab,cmd)
+STAB *eachstab;
+register CMD *cmd;
{
- FCMD froot;
- FCMD *flinebeg;
- register FCMD *fprev = &froot;
- register FCMD *fcmd;
- register char *s;
- register char *t;
- register char tmpchar;
- bool noblank;
-
- while ((s = str_gets(linestr,rsfp)) != Nullch) {
- line++;
- if (strEQ(s,".\n")) {
- bufptr = s;
- return froot.f_next;
- }
- if (*s == '#')
- continue;
- flinebeg = Nullfcmd;
- noblank = FALSE;
- while (*s) {
- fcmd = (FCMD *)safemalloc(sizeof (FCMD));
- bzero((char*)fcmd, sizeof (FCMD));
- fprev->f_next = fcmd;
- fprev = fcmd;
- for (t=s; *t && *t != '@' && *t != '^'; t++) {
- if (*t == '~') {
- noblank = TRUE;
- *t = ' ';
- }
- }
- tmpchar = *t;
- *t = '\0';
- fcmd->f_pre = savestr(s);
- fcmd->f_presize = strlen(s);
- *t = tmpchar;
- s = t;
- if (!*s) {
- if (noblank)
- fcmd->f_flags |= FC_NOBLANK;
- break;
- }
- if (!flinebeg)
- flinebeg = fcmd; /* start values here */
- if (*s++ == '^')
- fcmd->f_flags |= FC_CHOP; /* for doing text filling */
- switch (*s) {
- case '*':
- fcmd->f_type = F_LINES;
- *s = '\0';
- break;
- case '<':
- fcmd->f_type = F_LEFT;
- while (*s == '<')
- s++;
- break;
- case '>':
- fcmd->f_type = F_RIGHT;
- while (*s == '>')
- s++;
- break;
- case '|':
- fcmd->f_type = F_CENTER;
- while (*s == '|')
- s++;
- break;
- default:
- fcmd->f_type = F_LEFT;
- break;
- }
- if (fcmd->f_flags & FC_CHOP && *s == '.') {
- fcmd->f_flags |= FC_MORE;
- while (*s == '.')
- s++;
- }
- fcmd->f_size = s-t;
- }
- if (flinebeg) {
- again:
- if ((bufptr = str_gets(linestr ,rsfp)) == Nullch)
- goto badform;
- line++;
- if (strEQ(bufptr,".\n")) {
- yyerror("Missing values line");
- return froot.f_next;
- }
- if (*bufptr == '#')
- goto again;
- lex_newlines = TRUE;
- while (flinebeg || *bufptr) {
- switch(yylex()) {
- default:
- yyerror("Bad value in format");
- *bufptr = '\0';
- break;
- case '\n':
- if (flinebeg)
- yyerror("Missing value in format");
- *bufptr = '\0';
- break;
- case REG:
- yylval.arg = stab_to_arg(A_LVAL,yylval.stabval);
- /* FALL THROUGH */
- case RSTRING:
- if (!flinebeg)
- yyerror("Extra value in format");
- else {
- flinebeg->f_expr = yylval.arg;
- do {
- flinebeg = flinebeg->f_next;
- } while (flinebeg && flinebeg->f_size == 0);
- }
- break;
- case ',': case ';':
- continue;
- }
- }
- lex_newlines = FALSE;
- }
- }
- badform:
- bufptr = str_get(linestr);
- yyerror("Format not terminated");
- return froot.f_next;
+ /* 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)
+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;
- in_eval++;
+ tmps_base = tmps_max;
str_set(stabent("@",TRUE)->stab_val,"");
- line = 1;
- str_sset(linestr,str);
+ 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;
if (retval)
str = &str_no;
else {
- str = cmd_exec(eval_root);
+ 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 */
}
in_eval--;
+ filename = oldfile;
+ line = oldline;
+ tmps_base = oldtmps_base;
+ if (savestack->ary_fill > oldsave) /* let them use local() */
+ restorelist(oldsave);
return str;
}
register CMD *head = cmd;
while (cmd) {
- if (cmd->c_label)
- safefree(cmd->c_label);
- if (cmd->c_first)
- str_free(cmd->c_first);
- if (cmd->c_spat)
- spat_free(cmd->c_spat);
- if (cmd->c_expr)
- arg_free(cmd->c_expr);
+ 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:
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,Nullcmd);
+ cmd_free(cmd->ucmd.ccmd.cc_alt);
break;
case C_EXPR:
- if (cmd->ucmd.acmd.ac_stab)
- arg_free(cmd->ucmd.acmd.ac_stab);
if (cmd->ucmd.acmd.ac_expr)
arg_free(cmd->ucmd.acmd.ac_expr);
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:
if (spat->spat_repl) {
arg_free(spat->spat_repl);
}
- free_compex(&spat->spat_compex);
+ 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)
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;
+}
--- /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 88/06/05 00:10:45 root Exp $
+ *
+ * $Log: regexp.c,v $
+ * 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;
+#ifdef DEBUGGING
+ if (debug & 512)
+ fprintf(stderr,"must = '%s' back=%d\n",
+ longest,back);
+#endif
+ }
+ 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);
+}
--- /dev/null
+/*
+ * Definitions etc. for regexp(3) routines.
+ *
+ * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof],
+ * not the System V one.
+ */
+
+/* $Header: regexp.h,v 2.0 88/06/05 00:10:53 root Exp $
+ *
+ * $Log: regexp.h,v $
+ * Revision 2.0 88/06/05 00:10:53 root
+ * Baseline version 2.0.
+ *
+ */
+
+#define ALIGN
+
+#define NSUBEXP 10
+
+typedef struct regexp {
+ char *startp[NSUBEXP];
+ char *endp[NSUBEXP];
+ STR *regstart; /* Internal use only. */
+ char *regstclass;
+ STR *regmust; /* Internal use only. */
+ int regback; /* Can regmust locate first try? */
+ char *precomp; /* pre-compilation regular expression */
+ char *subbase; /* saved string so \digit works forever */
+ char reganch; /* Internal use only. */
+ char do_folding; /* do case-insensitive match? */
+ char lastparen; /* last paren matched */
+ char nparens; /* number of parentheses */
+ char program[1]; /* Unwarranted chumminess with compiler. */
+} regexp;
+
+extern regexp *regcomp();
+extern int regexec();
+extern void regsub();
+extern void regerror();
+++ /dev/null
-/* $Header: search.c,v 1.0.1.2 88/01/28 10:30:46 root Exp $
- *
- * $Log: search.c,v $
- * Revision 1.0.1.2 88/01/28 10:30:46 root
- * patch8: uncommented free_compex for use with eval operator.
- *
- * Revision 1.0.1.1 88/01/24 03:55:05 root
- * patch 2: made depend on perl.h.
- *
- * Revision 1.0 87/12/18 13:05:59 root
- * Initial revision
- *
- */
-
-/* string search routines */
-
-#include "EXTERN.h"
-#include "handy.h"
-#include "util.h"
-#include "INTERN.h"
-#include "search.h"
-#include "EXTERN.h"
-#include "perl.h"
-
-#define VERBOSE
-#define FLUSH
-#define MEM_SIZE int
-
-#ifndef BITSPERBYTE
-#define BITSPERBYTE 8
-#endif
-
-#define BMAPSIZ (127 / BITSPERBYTE + 1)
-
-#define CHAR 0 /* a normal character */
-#define ANY 1 /* . matches anything except newline */
-#define CCL 2 /* [..] character class */
-#define NCCL 3 /* [^..]negated character class */
-#define BEG 4 /* ^ beginning of a line */
-#define END 5 /* $ end of a line */
-#define LPAR 6 /* ( begin sub-match */
-#define RPAR 7 /* ) end sub-match */
-#define REF 8 /* \N backreference to the Nth submatch */
-#define WORD 9 /* \w matches alphanumeric character */
-#define NWORD 10 /* \W matches non-alphanumeric character */
-#define WBOUND 11 /* \b matches word boundary */
-#define NWBOUND 12 /* \B matches non-boundary */
-#define FINIS 13 /* the end of the pattern */
-
-#define CODEMASK 15
-
-/* Quantifiers: */
-
-#define MINZERO 16 /* minimum is 0, not 1 */
-#define MAXINF 32 /* maximum is infinity, not 1 */
-
-#define ASCSIZ 0200
-typedef char TRANSTABLE[ASCSIZ];
-
-static TRANSTABLE trans = {
-0000,0001,0002,0003,0004,0005,0006,0007,
-0010,0011,0012,0013,0014,0015,0016,0017,
-0020,0021,0022,0023,0024,0025,0026,0027,
-0030,0031,0032,0033,0034,0035,0036,0037,
-0040,0041,0042,0043,0044,0045,0046,0047,
-0050,0051,0052,0053,0054,0055,0056,0057,
-0060,0061,0062,0063,0064,0065,0066,0067,
-0070,0071,0072,0073,0074,0075,0076,0077,
-0100,0101,0102,0103,0104,0105,0106,0107,
-0110,0111,0112,0113,0114,0115,0116,0117,
-0120,0121,0122,0123,0124,0125,0126,0127,
-0130,0131,0132,0133,0134,0135,0136,0137,
-0140,0141,0142,0143,0144,0145,0146,0147,
-0150,0151,0152,0153,0154,0155,0156,0157,
-0160,0161,0162,0163,0164,0165,0166,0167,
-0170,0171,0172,0173,0174,0175,0176,0177,
-};
-static bool folding = FALSE;
-
-static int err;
-#define NOERR 0
-#define BEGFAIL 1
-#define FATAL 2
-
-static char *FirstCharacter;
-static char *matchend;
-static char *matchtill;
-
-void
-search_init()
-{
-#ifdef UNDEF
- register int i;
-
- for (i = 0; i < ASCSIZ; i++)
- trans[i] = i;
-#else
- ;
-#endif
-}
-
-void
-init_compex(compex)
-register COMPEX *compex;
-{
- /* the following must start off zeroed */
-
- compex->precomp = Nullch;
- compex->complen = 0;
- compex->subbase = Nullch;
-}
-
-void
-free_compex(compex)
-register COMPEX *compex;
-{
- if (compex->complen) {
- safefree(compex->compbuf);
- compex->complen = 0;
- }
- if (compex->subbase) {
- safefree(compex->subbase);
- compex->subbase = Nullch;
- }
-}
-
-static char *gbr_str = Nullch;
-static int gbr_siz = 0;
-
-char *
-getparen(compex,n)
-register COMPEX *compex;
-int n;
-{
- int length = compex->subend[n] - compex->subbeg[n];
-
- if (!n &&
- (!compex->numsubs || n > compex->numsubs || !compex->subend[n] || length<0))
- return "";
- growstr(&gbr_str, &gbr_siz, length+1);
- safecpy(gbr_str, compex->subbeg[n], length+1);
- return gbr_str;
-}
-
-void
-case_fold(which)
-int which;
-{
- register int i;
-
- if (which != folding) {
- if (which) {
- for (i = 'A'; i <= 'Z'; i++)
- trans[i] = tolower(i);
- }
- else {
- for (i = 'A'; i <= 'Z'; i++)
- trans[i] = i;
- }
- folding = which;
- }
-}
-
-/* Compile the regular expression into internal form */
-
-char *
-compile(compex, sp, regex, fold)
-register COMPEX *compex;
-register char *sp;
-int regex;
-int fold;
-{
- register int c;
- register char *cp;
- char *lastcp;
- char paren[MAXSUB],
- *parenp;
- char **alt = compex->alternatives;
- char *retmes = "Badly formed search string";
-
- case_fold(compex->do_folding = fold);
- if (compex->precomp)
- safefree(compex->precomp);
- compex->precomp = savestr(sp);
- if (!compex->complen) {
- compex->compbuf = safemalloc(84);
- compex->complen = 80;
- }
- cp = compex->compbuf; /* point at compiled buffer */
- *alt++ = cp; /* first alternative starts here */
- parenp = paren; /* first paren goes here */
- if (*sp == 0) { /* nothing to compile? */
-#ifdef NOTDEF
- if (*cp == 0) /* nothing there yet? */
- return "Null search string";
-#endif
- if (*cp)
- return Nullch; /* just keep old expression */
- }
- compex->numsubs = 0; /* no parens yet */
- lastcp = 0;
- for (;;) {
- if (cp - compex->compbuf >= compex->complen) {
- char *ocompbuf = compex->compbuf;
-
- grow_comp(compex);
- if (ocompbuf != compex->compbuf) { /* adjust pointers? */
- char **tmpalt;
-
- cp = compex->compbuf + (cp - ocompbuf);
- if (lastcp)
- lastcp = compex->compbuf + (lastcp - ocompbuf);
- for (tmpalt = compex->alternatives; tmpalt < alt; tmpalt++)
- if (*tmpalt)
- *tmpalt = compex->compbuf + (*tmpalt - ocompbuf);
- }
- }
- c = *sp++; /* get next char of pattern */
- if (c == 0) { /* end of pattern? */
- if (parenp != paren) { /* balanced parentheses? */
-#ifdef VERBOSE
- retmes = "Missing right parenthesis";
-#endif
- goto badcomp;
- }
- *cp++ = FINIS; /* append a stopper */
- *alt++ = 0; /* terminate alternative list */
- /*
- compex->complen = cp - compex->compbuf + 1;
- compex->compbuf = saferealloc(compex->compbuf,compex->complen+4); */
- return Nullch; /* return success */
- }
- if (c != '*' && c != '?' && c != '+')
- lastcp = cp;
- if (!regex) { /* just a normal search string? */
- *cp++ = CHAR; /* everything is a normal char */
- *cp++ = trans[c];
- }
- else /* it is a regular expression */
- switch (c) {
-
- default:
- normal_char:
- *cp++ = CHAR;
- *cp++ = trans[c];
- continue;
-
- case '.':
- *cp++ = ANY;
- continue;
-
- case '[': { /* character class */
- register int i;
-
- if (cp - compex->compbuf >= compex->complen - BMAPSIZ) {
- char *ocompbuf = compex->compbuf;
-
- grow_comp(compex); /* reserve bitmap */
- if (ocompbuf != compex->compbuf) {/* adjust pointers? */
- char **tmpalt;
-
- cp = compex->compbuf + (cp - ocompbuf);
- if (lastcp)
- lastcp = compex->compbuf + (lastcp - ocompbuf);
- for (tmpalt = compex->alternatives; tmpalt < alt;
- tmpalt++)
- if (*tmpalt)
- *tmpalt =
- compex->compbuf + (*tmpalt - ocompbuf);
- }
- }
- for (i = BMAPSIZ; i; --i)
- cp[i] = 0;
-
- if ((c = *sp++) == '^') {
- c = *sp++;
- *cp++ = NCCL; /* negated */
- }
- else
- *cp++ = CCL; /* normal */
-
- i = 0; /* remember oldchar */
- do {
- if (c == '\0') {
-#ifdef VERBOSE
- retmes = "Missing ]";
-#endif
- goto badcomp;
- }
- if (c == '\\' && *sp) {
- switch (*sp) {
- default:
- c = *sp++;
- break;
- case '0': case '1': case '2': case '3':
- case '4': case '5': case '6': case '7':
- c = *sp++ - '0';
- if (index("01234567",*sp)) {
- c <<= 3;
- c += *sp++ - '0';
- }
- if (index("01234567",*sp)) {
- c <<= 3;
- c += *sp++ - '0';
- }
- break;
- case 'b':
- c = '\b';
- sp++;
- break;
- case 'n':
- c = '\n';
- sp++;
- break;
- case 'r':
- c = '\r';
- sp++;
- break;
- case 'f':
- c = '\f';
- sp++;
- break;
- case 't':
- c = '\t';
- sp++;
- break;
- }
- }
- if (*sp == '-' && *(++sp))
- i = *sp++;
- else
- i = c;
- while (c <= i) {
- cp[c / BITSPERBYTE] |= 1 << (c % BITSPERBYTE);
- if (fold && isalpha(c))
- cp[(c ^ 32) / BITSPERBYTE] |=
- 1 << ((c ^ 32) % BITSPERBYTE);
- /* set the other bit too */
- c++;
- }
- } while ((c = *sp++) != ']');
- if (cp[-1] == NCCL)
- cp[0] |= 1;
- cp += BMAPSIZ;
- continue;
- }
-
- case '^':
- if (cp != compex->compbuf && cp[-1] != FINIS)
- goto normal_char;
- *cp++ = BEG;
- continue;
-
- case '$':
- if (isdigit(*sp)) {
- *cp++ = REF;
- *cp++ = *sp - '0';
- break;
- }
- if (*sp && *sp != '|')
- goto normal_char;
- *cp++ = END;
- continue;
-
- case '*': case '?': case '+':
- if (lastcp == 0 ||
- (*lastcp & (MINZERO|MAXINF)) ||
- *lastcp == LPAR ||
- *lastcp == RPAR ||
- *lastcp == BEG ||
- *lastcp == END ||
- *lastcp == WBOUND ||
- *lastcp == NWBOUND )
- goto normal_char;
- if (c != '+')
- *lastcp |= MINZERO;
- if (c != '?')
- *lastcp |= MAXINF;
- continue;
-
- case '(':
- if (compex->numsubs >= MAXSUB) {
-#ifdef VERBOSE
- retmes = "Too many parens";
-#endif
- goto badcomp;
- }
- *parenp++ = ++compex->numsubs;
- *cp++ = LPAR;
- *cp++ = compex->numsubs;
- break;
- case ')':
- if (parenp <= paren) {
-#ifdef VERBOSE
- retmes = "Unmatched right paren";
-#endif
- goto badcomp;
- }
- *cp++ = RPAR;
- *cp++ = *--parenp;
- break;
- case '|':
- if (parenp>paren) {
-#ifdef VERBOSE
- retmes = "No | in subpattern"; /* Sigh! */
-#endif
- goto badcomp;
- }
- *cp++ = FINIS;
- if (alt - compex->alternatives >= MAXALT) {
-#ifdef VERBOSE
- retmes = "Too many alternatives";
-#endif
- goto badcomp;
- }
- *alt++ = cp;
- break;
- case '\\': /* backslashed thingie */
- switch (c = *sp++) {
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- *cp++ = REF;
- *cp++ = c - '0';
- break;
- case 'w':
- *cp++ = WORD;
- break;
- case 'W':
- *cp++ = NWORD;
- break;
- case 'b':
- *cp++ = WBOUND;
- break;
- case 'B':
- *cp++ = NWBOUND;
- break;
- default:
- *cp++ = CHAR;
- if (c == '\0')
- goto badcomp;
- switch (c) {
- case 'n':
- c = '\n';
- break;
- case 'r':
- c = '\r';
- break;
- case 'f':
- c = '\f';
- break;
- case 't':
- c = '\t';
- break;
- }
- *cp++ = c;
- break;
- }
- break;
- }
- }
-badcomp:
- compex->compbuf[0] = 0;
- compex->numsubs = 0;
- return retmes;
-}
-
-void
-grow_comp(compex)
-register COMPEX *compex;
-{
- compex->complen += 80;
- compex->compbuf = saferealloc(compex->compbuf, (MEM_SIZE)compex->complen + 4);
-}
-
-char *
-execute(compex, addr, beginning, minend)
-register COMPEX *compex;
-char *addr;
-bool beginning;
-int minend;
-{
- register char *p1 = addr;
- register char *trt = trans;
- register int c;
- register int scr;
- register int c2;
-
- if (addr == Nullch)
- return Nullch;
- if (compex->numsubs) { /* any submatches? */
- for (c = 0; c <= compex->numsubs; c++)
- compex->subbeg[c] = compex->subend[c] = Nullch;
- }
- case_fold(compex->do_folding); /* make sure table is correct */
- if (beginning)
- FirstCharacter = p1; /* for ^ tests */
- else {
- if (multiline || compex->alternatives[1] || compex->compbuf[0] != BEG)
- FirstCharacter = Nullch;
- else
- return Nullch; /* can't match */
- }
- matchend = Nullch;
- matchtill = addr + minend;
- err = 0;
- if (compex->compbuf[0] == CHAR && !compex->alternatives[1]) {
- if (compex->do_folding) {
- c = compex->compbuf[1]; /* fast check for first character */
- do {
- if (trt[*p1] == c && try(compex, p1, compex->compbuf))
- goto got_it;
- } while (*p1++ && !err);
- }
- else {
- c = compex->compbuf[1]; /* faster check for first character */
- if (compex->compbuf[2] == CHAR)
- c2 = compex->compbuf[3];
- else
- c2 = 0;
- do {
- false_alarm:
- while (scr = *p1++, scr && scr != c) ;
- if (!scr)
- break;
- if (c2 && *p1 != c2) /* and maybe even second character */
- goto false_alarm;
- if (try(compex, p1, compex->compbuf+2)) {
- p1--;
- goto got_it;
- }
- } while (!err);
- }
- return Nullch;
- }
- else { /* normal algorithm */
- do {
- register char **alt = compex->alternatives;
- while (*alt) {
- if (try(compex, p1, *alt++))
- goto got_it;
- }
- } while (*p1++ && err < FATAL);
- return Nullch;
- }
-
-got_it:
- if (compex->numsubs) { /* any parens? */
- trt = savestr(addr); /* in case addr is not static */
- if (compex->subbase)
- safefree(compex->subbase); /* (may be freeing addr!) */
- compex->subbase = trt;
- scr = compex->subbase - addr;
- p1 += scr;
- matchend += scr;
- for (c = 0; c <= compex->numsubs; c++) {
- if (compex->subend[c]) {
- compex->subbeg[c] += scr;
- compex->subend[c] += scr;
- }
- }
- }
- compex->subend[0] = matchend;
- compex->subbeg[0] = p1;
- return p1;
-}
-
-bool
-try(compex, sp, cp)
-COMPEX *compex;
-register char *cp;
-register char *sp;
-{
- register char *basesp;
- register char *trt = trans;
- register int i;
- register int backlen;
- register int code;
-
- while (*sp || (*cp & MAXINF) || *cp == BEG || *cp == RPAR ||
- *cp == WBOUND || *cp == NWBOUND) {
- switch ((code = *cp++) & CODEMASK) {
-
- case CHAR:
- basesp = sp;
- i = *cp++;
- if (code & MAXINF)
- while (*sp && trt[*sp] == i) sp++;
- else
- if (*sp && trt[*sp] == i) sp++;
- backlen = 1;
- goto backoff;
-
- backoff:
- while (sp > basesp) {
- if (try(compex, sp, cp))
- goto right;
- sp -= backlen;
- }
- if (code & MINZERO)
- continue;
- goto wrong;
-
- case ANY:
- basesp = sp;
- if (code & MAXINF)
- while (*sp && *sp != '\n') sp++;
- else
- if (*sp && *sp != '\n') sp++;
- backlen = 1;
- goto backoff;
-
- case CCL:
- basesp = sp;
- if (code & MAXINF)
- while (*sp && cclass(cp, *sp, 1)) sp++;
- else
- if (*sp && cclass(cp, *sp, 1)) sp++;
- cp += BMAPSIZ;
- backlen = 1;
- goto backoff;
-
- case NCCL:
- basesp = sp;
- if (code & MAXINF)
- while (*sp && cclass(cp, *sp, 0)) sp++;
- else
- if (*sp && cclass(cp, *sp, 0)) sp++;
- cp += BMAPSIZ;
- backlen = 1;
- goto backoff;
-
- case END:
- if (!*sp || *sp == '\n') {
- matchtill--;
- continue;
- }
- goto wrong;
-
- case BEG:
- if (sp == FirstCharacter || (
- *sp && sp[-1] == '\n') ) {
- matchtill--;
- continue;
- }
- if (!multiline) /* no point in advancing more */
- err = BEGFAIL;
- goto wrong;
-
- case WORD:
- basesp = sp;
- if (code & MAXINF)
- while (*sp && isalnum(*sp)) sp++;
- else
- if (*sp && isalnum(*sp)) sp++;
- backlen = 1;
- goto backoff;
-
- case NWORD:
- basesp = sp;
- if (code & MAXINF)
- while (*sp && !isalnum(*sp)) sp++;
- else
- if (*sp && !isalnum(*sp)) sp++;
- backlen = 1;
- goto backoff;
-
- case WBOUND:
- if ((sp == FirstCharacter || !isalnum(sp[-1])) !=
- (!*sp || !isalnum(*sp)) )
- continue;
- goto wrong;
-
- case NWBOUND:
- if ((sp == FirstCharacter || !isalnum(sp[-1])) ==
- (!*sp || !isalnum(*sp)))
- continue;
- goto wrong;
-
- case FINIS:
- goto right;
-
- case LPAR:
- compex->subbeg[*cp++] = sp;
- continue;
-
- case RPAR:
- i = *cp++;
- compex->subend[i] = sp;
- compex->lastparen = i;
- continue;
-
- case REF:
- if (compex->subend[i = *cp++] == 0) {
- fputs("Bad subpattern reference\n",stdout) FLUSH;
- err = FATAL;
- goto wrong;
- }
- basesp = sp;
- backlen = compex->subend[i] - compex->subbeg[i];
- if (code & MAXINF)
- while (*sp && subpat(compex, i, sp)) sp += backlen;
- else
- if (*sp && subpat(compex, i, sp)) sp += backlen;
- goto backoff;
-
- default:
- fputs("Botched pattern compilation\n",stdout) FLUSH;
- err = FATAL;
- return -1;
- }
- }
- if (*cp == FINIS || *cp == END) {
-right:
- if (matchend == Nullch || sp > matchend)
- matchend = sp;
- return matchend >= matchtill;
- }
-wrong:
- matchend = Nullch;
- return FALSE;
-}
-
-bool
-subpat(compex, i, sp)
-register COMPEX *compex;
-register int i;
-register char *sp;
-{
- register char *bp;
-
- bp = compex->subbeg[i];
- while (*sp && *bp == *sp) {
- bp++;
- sp++;
- if (bp >= compex->subend[i])
- return TRUE;
- }
- return FALSE;
-}
-
-bool
-cclass(set, c, af)
-register char *set;
-register int c;
-{
- c &= 0177;
-#if BITSPERBYTE == 8
- if (set[c >> 3] & 1 << (c & 7))
-#else
- if (set[c / BITSPERBYTE] & 1 << (c % BITSPERBYTE))
-#endif
- return af;
- return !af;
-}
+++ /dev/null
-/* $Header: search.h,v 1.0 87/12/18 13:06:06 root Exp $
- *
- * $Log: search.h,v $
- * Revision 1.0 87/12/18 13:06:06 root
- * Initial revision
- *
- */
-
-#ifndef MAXSUB
-#define MAXSUB 10 /* how many sub-patterns are allowed */
-#define MAXALT 10 /* how many alternatives are allowed */
-
-typedef struct {
- char *precomp; /* the original pattern, for debug output */
- char *compbuf; /* the compiled pattern */
- int complen; /* length of compbuf */
- char *alternatives[MAXALT]; /* list of alternatives */
- char *subbeg[MAXSUB]; /* subpattern start list */
- char *subend[MAXSUB]; /* subpattern end list */
- char *subbase; /* saved match string after execute() */
- char lastparen; /* which subpattern matched last */
- char numsubs; /* how many subpatterns the compiler saw */
- bool do_folding; /* fold upper and lower case? */
-} COMPEX;
-
-EXT int multiline INIT(0);
-
-void search_init();
-void init_compex();
-void free_compex();
-char *getparen();
-void case_fold();
-char *compile();
-void grow_comp();
-char *execute();
-bool try();
-bool subpat();
-bool cclass();
-#endif
-/* $Header: spat.h,v 1.0.1.1 88/02/02 11:24:37 root Exp $
+/* $Header: spat.h,v 2.0 88/06/05 00:10:58 root Exp $
*
* $Log: spat.h,v $
- * Revision 1.0.1.1 88/02/02 11:24:37 root
- * patch13: added flag for stripping leading spaces on split.
- *
- * Revision 1.0 87/12/18 13:06:10 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:10:58 root
+ * Baseline version 2.0.
*
*/
struct scanpat {
SPAT *spat_next; /* list of all scanpats */
- COMPEX spat_compex; /* compiled expression */
+ REGEXP *spat_regexp; /* compiled expression */
ARG *spat_repl; /* replacement string for subst */
ARG *spat_runtime; /* compile pattern at runtime */
- STR *spat_first; /* for a fast bypass of execute() */
+ STR *spat_short; /* for a fast bypass of execute() */
bool spat_flags;
- char spat_flen;
+ char spat_slen;
};
#define SPAT_USED 1 /* spat has been used once already */
-#define SPAT_USE_ONCE 2 /* use pattern only once per article */
+#define SPAT_ONCE 2 /* use pattern only once per article */
#define SPAT_SCANFIRST 4 /* initial constant not anchored */
-#define SPAT_SCANALL 8 /* initial constant is whole pat */
+#define SPAT_ALL 8 /* initial constant is whole pat */
#define SPAT_SKIPWHITE 16 /* skip leading whitespace for split */
+#define SPAT_FOLD 32 /* case insensitivity */
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 */
+
+EXT char *hint INIT(Nullch); /* hint from cmd_exec to do_match et al */
#define Nullspat Null(SPAT*)
-/* $Header: stab.c,v 1.0.1.2 88/02/02 11:25:53 root Exp $
+/* $Header: stab.c,v 2.0 88/06/05 00:11:01 root Exp $
*
* $Log: stab.c,v $
- * Revision 1.0.1.2 88/02/02 11:25:53 root
- * patch13: moved extern int out of function for a poor Xenix machine.
- *
- * Revision 1.0.1.1 88/01/28 10:35:17 root
- * patch8: changed some stabents to support eval operator.
- *
- * Revision 1.0 87/12/18 13:06:14 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:11:01 root
+ * Baseline version 2.0.
*
*/
-#include <signal.h>
-#include "handy.h"
#include "EXTERN.h"
-#include "search.h"
-#include "util.h"
#include "perl.h"
+#include <signal.h>
+
static char *sig_name[] = {
"",
"HUP",
};
extern int errno;
+extern int sys_nerr;
+extern char *sys_errlist[];
STR *
stab_str(stab)
{
register int paren;
register char *s;
+ register int i;
switch (*stab->stab_name) {
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
if (curspat) {
paren = atoi(stab->stab_name);
- if (curspat->spat_compex.subend[paren] &&
- (s = getparen(&curspat->spat_compex,paren))) {
- curspat->spat_compex.subend[paren] = Nullch;
- str_set(stab->stab_val,s);
+ 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);
+ else
+ str_nset(stab->stab_val,"",0);
}
+ else
+ str_nset(stab->stab_val,"",0);
}
break;
case '+':
if (curspat) {
- paren = curspat->spat_compex.lastparen;
- if (curspat->spat_compex.subend[paren] &&
- (s = getparen(&curspat->spat_compex,paren))) {
- curspat->spat_compex.subend[paren] = Nullch;
- str_set(stab->stab_val,s);
- }
+ paren = curspat->spat_regexp->lastparen;
+ goto getparen;
}
break;
case '.':
str_set(stab->stab_val,s);
break;
case '=':
- str_numset(stab->stab_val,(double)curoutstab->stab_io->lines);
+ str_numset(stab->stab_val,(double)curoutstab->stab_io->page_len);
break;
case '-':
str_numset(stab->stab_val,(double)curoutstab->stab_io->lines_left);
case '%':
str_numset(stab->stab_val,(double)curoutstab->stab_io->page);
break;
- case '(':
- if (curspat) {
- str_numset(stab->stab_val,(double)(curspat->spat_compex.subbeg[0] -
- curspat->spat_compex.subbase));
- }
- break;
- case ')':
- if (curspat) {
- str_numset(stab->stab_val,(double)(curspat->spat_compex.subend[0] -
- curspat->spat_compex.subbeg[0]));
- }
- break;
case '/':
*tokenbuf = record_separator;
tokenbuf[1] = '\0';
str_set(stab->stab_val,ofmt);
break;
case '!':
- str_numset(stab->stab_val,(double)errno);
+ str_numset(stab->stab_val, (double)errno);
+ str_set(stab->stab_val,
+ errno < 0 || errno > sys_nerr ? "(unknown)" : sys_errlist[errno]);
+ stab->stab_val->str_nok = 1; /* what a wonderful hack! */
+ break;
+ case '<':
+ str_numset(stab->stab_val,(double)uid);
+ break;
+ case '>':
+ str_numset(stab->stab_val,(double)euid);
+ break;
+ case '(':
+ s = tokenbuf;
+ sprintf(s,"%d",(int)getgid());
+ goto add_groups;
+ case ')':
+ s = tokenbuf;
+ sprintf(s,"%d",(int)getegid());
+ add_groups:
+ while (*s) s++;
+#ifdef GETGROUPS
+#ifndef NGROUPS
+#define NGROUPS 32
+#endif
+ {
+ GIDTYPE gary[NGROUPS];
+
+ i = getgroups(NGROUPS,gary);
+ while (--i >= 0) {
+ sprintf(s," %ld", (long)gary[i]);
+ while (*s) s++;
+ }
+ }
+#endif
+ str_set(stab->stab_val,tokenbuf);
break;
}
return stab->stab_val;
switch (stab->stab_name[0]) {
case '^':
safefree(curoutstab->stab_io->top_name);
- curoutstab->stab_io->top_name = str_get(str);
- curoutstab->stab_io->top_stab = stabent(str_get(str),TRUE);
+ curoutstab->stab_io->top_name = s = savestr(str_get(str));
+ curoutstab->stab_io->top_stab = stabent(s,TRUE);
break;
case '~':
safefree(curoutstab->stab_io->fmt_name);
- curoutstab->stab_io->fmt_name = str_get(str);
- curoutstab->stab_io->fmt_stab = stabent(str_get(str),TRUE);
+ curoutstab->stab_io->fmt_name = s = savestr(str_get(str));
+ curoutstab->stab_io->fmt_stab = stabent(s,TRUE);
break;
case '=':
curoutstab->stab_io->page_len = (long)str_gnum(str);
case '[':
arybase = (int)str_gnum(str);
break;
+ case '?':
+ statusvalue = (unsigned short)str_gnum(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)
+ uid = (int)getuid();
+#else
+ fatal("setruid() not implemented");
+#endif
+ break;
+ case '>':
+#ifdef SETEUID
+ euid = (int)str_gnum(str);
+ if (seteuid(euid) < 0)
+ euid = (int)geteuid();
+#else
+ fatal("seteuid() not implemented");
+#endif
+ break;
+ case '(':
+#ifdef SETRGID
+ setrgid((int)str_gnum(str));
+#else
+ fatal("setrgid() not implemented");
+#endif
+ break;
+ case ')':
+#ifdef SETEGID
+ setegid((int)str_gnum(str));
+#else
+ fatal("setegid() not implemented");
+#endif
+ break;
case '.':
case '+':
case '&':
case '7':
case '8':
case '9':
- case '(':
- case ')':
break; /* "read-only" registers */
}
}
safefree(signame);
signame = Nullch;
}
+ else if (stab->stab_array) {
+ afill(stab->stab_array, (int)str_gnum(str) - arybase);
+ }
}
-whichsig(signame)
-char *signame;
+whichsig(sig)
+char *sig;
{
register char **sigv;
for (sigv = sig_name+1; *sigv; sigv++)
- if (strEQ(signame,*sigv))
+ if (strEQ(sig,*sigv))
return sigv - sig_name;
return 0;
}
STAB *stab;
ARRAY *savearray;
STR *str;
+ char *oldfile = filename;
+ int oldsave = savestack->ary_fill;
+ SUBR *sub;
stab = stabent(str_get(hfetch(sigstab->stab_hash,sig_name[sig])),TRUE);
+ sub = stab->stab_sub;
+ if (!sub) {
+ if (dowarn)
+ warn("SIG%s handler \"%s\" not defined.\n",
+ sig_name[sig], stab->stab_name );
+ return;
+ }
savearray = defstab->stab_array;
- defstab->stab_array = anew();
+ defstab->stab_array = anew(defstab);
str = str_new(0);
str_set(str,sig_name[sig]);
apush(defstab->stab_array,str);
- str = cmd_exec(stab->stab_sub);
+ sub->depth++;
+ if (sub->depth >= 2) { /* save temporaries on recursion? */
+ if (sub->depth == 100 && dowarn)
+ warn("Deep recursion on subroutine \"%s\"",stab->stab_name);
+ savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
+ }
+ filename = sub->filename;
+
+ 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;
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
}
char *
register STAB *stab;
{
if (!stab->stab_array)
- stab->stab_array = anew();
+ stab->stab_array = anew(stab);
return stab;
}
stab->stab_hash = hnew();
return stab;
}
+
+STAB *
+stabent(name,add)
+register char *name;
+int add;
+{
+ register STAB *stab;
+
+ for (stab = stab_index[*name]; stab; stab = stab->stab_next) {
+ if (strEQ(name,stab->stab_name)) {
+ stab->stab_flags |= SF_MULTI; /* is okay, probably */
+ return stab;
+ }
+ }
+
+ /* no entry--should we add one? */
+
+ if (add) {
+ stab = (STAB *) safemalloc(sizeof(STAB));
+ bzero((char*)stab, sizeof(STAB));
+ stab->stab_name = savestr(name);
+ stab->stab_val = str_new(0);
+ stab->stab_next = stab_index[*name];
+ stab_index[*name] = stab;
+ return stab;
+ }
+ return Nullstab;
+}
+
+STIO *
+stio_new()
+{
+ STIO *stio = (STIO *) safemalloc(sizeof(STIO));
+
+ bzero((char*)stio, sizeof(STIO));
+ stio->page_len = 60;
+ return stio;
+}
+
+stab_check(min,max)
+int min;
+register int max;
+{
+ 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"))
+ 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);
+ }
+ }
+}
-/* $Header: stab.h,v 1.0 87/12/18 13:06:18 root Exp $
+/* $Header: stab.h,v 2.0 88/06/05 00:11:05 root Exp $
*
* $Log: stab.h,v $
- * Revision 1.0 87/12/18 13:06:18 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:11:05 root
+ * Baseline version 2.0.
*
*/
FCMD *stab_form;
ARRAY *stab_array;
HASH *stab_hash;
- CMD *stab_sub;
+ SUBR *stab_sub;
char stab_flags;
};
#define SF_VMAGIC 1 /* call routine to dereference STR val */
+#define SF_MULTI 2 /* seen more than once */
struct stio {
FILE *fp;
STAB *top_stab;
char *fmt_name;
STAB *fmt_stab;
+ short subprocess;
char type;
char flags;
};
#define IOF_START 2 /* check for null ARGV and substitute '-' */
#define IOF_FLUSH 4 /* this fp wants a flush after write op */
+struct sub {
+ CMD *cmd;
+ char *filename;
+ long depth; /* >= 2 indicates recursive call */
+ ARRAY *tosave;
+};
+
#define Nullstab Null(STAB*)
#define STAB_STR(s) (tmpstab = (s), tmpstab->stab_flags & SF_VMAGIC ? stab_str(tmpstab) : tmpstab->stab_val)
EXT char *envname; /* place for ENV name being assigned--gross cheat */
EXT char *signame; /* place for SIG name being assigned--gross cheat */
-EXT int statusvalue;
-EXT int subsvalue;
+EXT unsigned short statusvalue;
STAB *aadd();
STAB *hadd();
-/* $Header: str.c,v 1.0.1.1 88/01/21 21:28:39 root Exp $
+/* $Header: str.c,v 2.0 88/06/05 00:11:07 root Exp $
*
* $Log: str.c,v $
- * Revision 1.0.1.1 88/01/21 21:28:39 root
- * Suppressed warning messages on signed vs unsigned chars in str_gets().
- *
- * Revision 1.0 87/12/18 13:06:22 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:11:07 root
+ * Baseline version 2.0.
*
*/
-#include "handy.h"
#include "EXTERN.h"
-#include "search.h"
-#include "util.h"
#include "perl.h"
str_reset(s)
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);
+ }
}
}
}
str->str_nok = 1; /* validate number */
}
+extern int errno;
+
char *
str_2ptr(str)
register STR *str;
{
register char *s;
+ int olderrno;
if (!str)
return "";
GROWSTR(&(str->str_ptr), &(str->str_len), 24);
s = str->str_ptr;
if (str->str_nok) {
+ olderrno = errno; /* some Xenix systems wipe out errno here */
+#if defined(scs) && defined(ns32000)
+ gcvt(str->str_nval,20,s);
+#else
+#ifdef apollo
+ if (str->str_nval == 0.0)
+ strcpy(s,"0");
+ else
+#endif /*apollo*/
sprintf(s,"%.20g",str->str_nval);
+#endif /*scs*/
+ errno = olderrno;
while (*s) s++;
}
+ else if (dowarn)
+ warn("Use of uninitialized variable");
*s = '\0';
str->str_cur = s - str->str_ptr;
str->str_pok = 1;
return 0.0;
if (str->str_len && str->str_pok)
str->str_nval = atof(str->str_ptr);
- else
+ else {
+ if (dowarn)
+ fprintf(stderr,"Use of uninitialized variable in %s line %ld.\n",
+ filename,(long)line);
str->str_nval = 0.0;
+ }
str->str_nok = 1;
#ifdef DEBUGGING
if (debug & 32)
STR *dstr;
register STR *sstr;
{
+ if (!sstr)
+ return;
if (!(sstr->str_pok))
str_2ptr(sstr);
if (sstr)
bpx = bp - str->str_ptr; /* prepare for possible relocation */
if (get_paragraph && oldbp)
obpx = oldbp - str->str_ptr;
- GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + cnt + 1);
+ GROWSTR(&(str->str_ptr), &(str->str_len), bpx + cnt + 2);
bp = str->str_ptr + bpx; /* reconstitute our pointer */
if (get_paragraph && oldbp)
oldbp = str->str_ptr + obpx;
str_set(str,"");
while (*s) {
- if (*s == '\\' && s[1] == '$') {
+ 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++;
}
str->str_pok = 0;
return;
}
- if (!str->str_pok) {
+ if (!str->str_pok || !*str->str_ptr) {
str->str_nval = 1.0;
str->str_nok = 1;
return;
}
- for (d = str->str_ptr; *d && *d != '.'; d++) ;
- d--;
- if (!isdigit(*str->str_ptr) || !isdigit(*d) ) {
+ d = str->str_ptr;
+ while (isalpha(*d)) d++;
+ while (isdigit(*d)) d++;
+ if (*d) {
str_numset(str,atof(str->str_ptr) + 1.0); /* punt */
return;
}
+ d--;
while (d >= str->str_ptr) {
- if (++*d <= '9')
- return;
- *(d--) = '0';
+ if (isdigit(*d)) {
+ if (++*d <= '9')
+ return;
+ *(d--) = '0';
+ }
+ else {
+ ++*d;
+ if (isalpha(*d))
+ return;
+ *(d--) -= 'z' - 'a' + 1;
+ }
}
/* oh,oh, the number grew */
GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + 2);
str->str_cur++;
for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--)
*d = d[-1];
- *d = '1';
+ if (isdigit(d[1]))
+ *d = '1';
+ else
+ *d = d[1];
}
void
str_dec(str)
register STR *str;
{
- register char *d;
-
if (!str)
return;
if (str->str_nok) {
str->str_nok = 1;
return;
}
- for (d = str->str_ptr; *d && *d != '.'; d++) ;
- d--;
- if (!isdigit(*str->str_ptr) || !isdigit(*d) || (*d == '0' && d == str->str_ptr)) {
- str_numset(str,atof(str->str_ptr) - 1.0); /* punt */
- return;
- }
- while (d >= str->str_ptr) {
- if (--*d >= '0')
- return;
- *(d--) = '9';
- }
+ str_numset(str,atof(str->str_ptr) - 1.0);
}
/* make a string that will exist for the duration of the expression eval */
if (!(tmps_size & 127)) {
if (tmps_size)
tmps_list = (STR**)saferealloc((char*)tmps_list,
- (tmps_size + 128) * sizeof(STR*) );
+ (MEM_SIZE)((tmps_size + 128) * sizeof(STR*)) );
else
tmps_list = (STR**)safemalloc(128 * sizeof(char*));
}
-/* $Header: str.h,v 1.0 87/12/18 13:06:26 root Exp $
+/* $Header: str.h,v 2.0 88/06/05 00:11:11 root Exp $
*
* $Log: str.h,v $
- * Revision 1.0 87/12/18 13:06:26 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:11:11 root
+ * Baseline version 2.0.
*
*/
} str_link;
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 */
};
#define Nullstr Null(STR*)
#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x))
EXT STR **tmps_list;
-EXT long tmps_max INIT(-1);
+EXT int tmps_max INIT(-1);
+EXT int tmps_base INIT(-1);
char *str_2ptr();
double str_2num();
#!./perl
-# $Header: TEST,v 1.0.1.1 88/01/24 03:55:39 root Exp $
+# $Header: TEST,v 2.0 88/06/05 00:11:47 root Exp $
# This is written in a peculiar style, since we're trying to avoid
# most of the constructs we'll be testing for.
shift;
}
+chdir 't' if -f 't/TEST';
+
if ($ARGV[0] eq '') {
@ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.*`);
}
}
$bad = 0;
while ($test = shift) {
+ if ($test =~ /\.orig$/) {
+ next;
+ }
print "$test...";
if ($sharpbang) {
- open(results,"$test|") || (print "can't run.\n");
+ open(results,"./$test|") || (print "can't run.\n");
} else {
- open(script,"$test") || die "Can't run $test";
+ open(script,"$test") || die "Can't run $test.\n";
$_ = <script>;
close(script);
if (/#!..perl(.*)/) {
open(results,"./perl$switch $test|") || (print "can't run.\n");
}
$ok = 0;
+ $next = 0;
while (<results>) {
if ($verbose) {
print $_;
$bad = $bad + 1;
$_ = $test;
if (/^base/) {
- die "Failed a basic test--cannot continue.";
+ die "Failed a basic test--cannot continue.\n";
}
}
}
if ($ok) {
print "All tests successful.\n";
} else {
- die "FAILED--no tests were run for some reason.";
+ die "FAILED--no tests were run for some reason.\n";
}
} else {
if ($bad == 1) {
- die "Failed 1 test.";
+ die "Failed 1 test.\n";
} else {
- die "Failed $bad tests.";
+ die "Failed $bad tests.\n";
}
}
($user,$sys,$cuser,$csys) = times;
#!./perl
-# $Header: base.cond,v 1.0 87/12/18 13:11:41 root Exp $
+# $Header: base.cond,v 2.0 88/06/05 00:11:52 root Exp $
# make sure conditional operators work
#!./perl
-# $Header: base.if,v 1.0 87/12/18 13:11:45 root Exp $
+# $Header: base.if,v 2.0 88/06/05 00:12:02 root Exp $
print "1..2\n";
#!./perl
-# $Header: base.lex,v 1.0.1.1 88/01/28 10:37:00 root Exp $
+# $Header: base.lex,v 2.0 88/06/05 00:12:06 root Exp $
-print "1..6\n";
+print "1..7\n";
$ # this is the register <space>
= 'x';
eval '$foo{1} / 1;';
if (!$@) {print "ok 6\n";} else {print "not ok 6\n";}
+
+eval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
+
+$foo = int($foo * 100 + .5);
+if ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7\n";}
#!./perl
-# $Header: base.pat,v 1.0 87/12/18 13:11:56 root Exp $
+# $Header: base.pat,v 2.0 88/06/05 00:12:08 root Exp $
print "1..2\n";
#!./perl
-# $Header: base.term,v 1.0 87/12/18 13:11:59 root Exp $
+# $Header: base.term,v 2.0 88/06/05 00:12:13 root Exp $
print "1..6\n";
open(try, "/dev/null") || (die "Can't open /dev/null.");
if (<try> eq '') {print "ok 5\n";} else {print "not ok 5\n";}
-open(try, "/etc/termcap") || (die "Can't open /etc/termcap.");
+open(try, "../Makefile") || (die "Can't open ../Makefile.");
if (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";}
#!./perl
-# $Header: cmd.elsif,v 1.0 87/12/18 13:12:02 root Exp $
+# $Header: cmd.elsif,v 2.0 88/06/05 00:12:16 root Exp $
sub foo {
if ($_[0] == 1) {
#!./perl
-# $Header: cmd.for,v 1.0 87/12/18 13:12:05 root Exp $
+# $Header: cmd.for,v 2.0 88/06/05 00:12:19 root Exp $
-print "1..2\n";
+print "1..7\n";
for ($i = 0; $i <= 10; $i++) {
$x[$i] = $i;
last if $i++ > 10;
}
if ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$foo = 3210;
+@ary = (1,2,3,4,5);
+foreach $foo (@ary) {
+ $foo *= 2;
+}
+if (join('',@ary) eq '246810') {print "ok 3\n";} else {print "not ok 3\n";}
+
+for (@ary) {
+ s/(.*)/ok $1\n/;
+}
+
+print $ary[1];
+
+# test for internal scratch array generation
+# this also tests that $foo was restored to 3210 after test 3
+for (split(' ','a b c d e')) {
+ $foo .= $_;
+}
+if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5\n";}
+
+foreach $foo (("ok 6\n","ok 7\n")) {
+ print $foo;
+}
#!./perl
-# $Header: cmd.mod,v 1.0 87/12/18 13:12:09 root Exp $
+# $Header: cmd.mod,v 2.0 88/06/05 00:12:23 root Exp $
print "1..6\n";
#!./perl
-# $Header: cmd.subval,v 1.0 87/12/18 13:12:12 root Exp $
+# $Header: cmd.subval,v 2.0 88/06/05 00:12:26 root Exp $
sub foo1 {
'true1';
'true2' unless $_[0];
}
-print "1..12\n";
+print "1..22\n";
if (do foo1(0) eq '') {print "ok 1\n";} else {print "not ok 1\n";}
if (do foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";}
if (do 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";}
+
+# Now test to see that recursion works using a Fibonacci number generator
+
+sub fib {
+ local($arg) = @_;
+ local($foo);
+ $level++;
+ if ($arg <= 2) {
+ $foo = 1;
+ }
+ else {
+ $foo = do fib($arg-1) + do fib($arg-2);
+ }
+ $level--;
+ $foo;
+}
+
+@good = (0,1,1,2,3,5,8,13,21,34,55,89);
+
+for ($i = 1; $i <= 10; $i++) {
+ $foo = $i + 12;
+ if (do fib($i) == $good[$i]) {
+ print "ok $foo\n";
+ }
+ else {
+ print "not ok $foo\n";
+ }
+}
#!./perl
-# $Header: cmd.while,v 1.0 87/12/18 13:12:15 root Exp $
+# $Header: cmd.while,v 2.0 88/06/05 00:12:31 root Exp $
print "1..10\n";
#!./perl
-# $Header: comp.cmdopt,v 1.0 87/12/18 13:12:19 root Exp $
+# $Header: comp.cmdopt,v 2.0 88/06/05 00:12:34 root Exp $
print "1..40\n";
#!./perl -P
-# $Header: comp.cpp,v 1.0 87/12/18 13:12:22 root Exp $
+# $Header: comp.cpp,v 2.0 88/06/05 00:12:37 root Exp $
print "1..3\n";
#!./perl
-# $Header: comp.decl,v 1.0 87/12/18 13:12:27 root Exp $
+# $Header: comp.decl,v 2.0 88/06/05 00:12:40 root Exp $
# check to see if subroutine declarations work everwhere
#!./perl
-# $Header: comp.multiline,v 1.0 87/12/18 13:12:31 root Exp $
+# $Header: comp.multiline,v 2.0 88/06/05 00:12:44 root Exp $
print "1..5\n";
#!./perl
-# $Header: comp.script,v 1.0 87/12/18 13:12:36 root Exp $
+# $Header: comp.script,v 2.0 88/06/05 00:12:49 root Exp $
print "1..3\n";
#!./perl
-# $Header: comp.term,v 1.0 87/12/18 13:12:40 root Exp $
+# $Header: comp.term,v 2.0 88/06/05 00:12:52 root Exp $
# tests that aren't important enough for base.term
-print "1..9\n";
+print "1..10\n";
$x = "\\n";
print "#1\t:$x: eq " . ':\n:' . "\n";
if (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";}
if (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";}
if (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";}
+if (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";}
#!./perl
-# $Header: io.argv,v 1.0 87/12/18 13:12:44 root Exp $
+# $Header: io.argv,v 2.0 88/06/05 00:12:55 root Exp $
print "1..5\n";
@ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp');
while (<>) {
$y .= $. . $_;
- if (eof) {
+ if (eof()) {
if ($. == 3) {print "ok 4\n";} else {print "not ok 4\n";}
}
}
--- /dev/null
+#!./perl
+
+# $Header: io.dup,v 2.0 88/06/05 00:12:57 root Exp $
+
+print "1..6\n";
+
+print "ok 1\n";
+
+open(dupout,">&stdout");
+open(duperr,">&stderr");
+
+open(stdout,">Io.dup") || die "Can't open stdout";
+open(stderr,">&stdout") || die "Can't open stderr";
+
+select(stderr); $| = 1;
+select(stdout); $| = 1;
+
+print stdout "ok 2\n";
+print stderr "ok 3\n";
+system 'echo ok 4';
+system 'echo ok 5 1>&2';
+
+close(stdout);
+close(stderr);
+
+open(stdout,">&dupout");
+open(stderr,">&duperr");
+
+system 'cat Io.dup';
+unlink 'Io.dup';
+
+print stdout "ok 6\n";
#!./perl
-# $Header: io.fs,v 1.0 87/12/18 13:12:48 root Exp $
+# $Header: io.fs,v 2.0 88/06/05 00:12:59 root Exp $
-print "1..18\n";
+print "1..22\n";
-chdir '/tmp';
+$wd = `pwd`;
+chop($wd);
+
+`rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`;
+chdir './tmp';
`/bin/rm -rf a b c x`;
umask(022);
($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');
+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 16\n";} else {print "not ok 16\n";}
+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 ((unlink 'b') == 1) {print "ok 17\n";} else {print "not ok 17\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,
$blksize,$blocks) = stat('b');
-if ($ino == 0) {print "ok 18\n";} else {print "not ok 18\n";}
+if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";}
+unlink 'c';
+
+chdir $wd || die "Can't cd back to $wd";
+
unlink 'c';
+if (`ls -l perl 2>/dev/null` =~ /^l.*->/) { # we have symbolic links
+ if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";}
+ $foo = `grep perl c`;
+ if ($foo) {print "ok 22\n";} else {print "not ok 22\n";}
+}
+else {
+ print "ok 21\nok 22\n";
+}
#!./perl -i.bak
-# $Header: io.inplace,v 1.0 87/12/18 13:12:51 root Exp $
+# $Header: io.inplace,v 2.0 88/06/05 00:13:02 root Exp $
print "1..2\n";
--- /dev/null
+#!./perl
+
+# $Header: io.pipe,v 2.0 88/06/05 00:13:05 root Exp $
+
+$| = 1;
+print "1..4\n";
+
+open(PIPE, "|-") || (exec 'tr', '[A-Z]', '[a-z]');
+print PIPE "OK 1\n";
+print PIPE "ok 2\n";
+close PIPE;
+
+if (open(PIPE, "-|")) {
+ while(<PIPE>) {
+ print;
+ }
+}
+else {
+ print stdout "ok 3\n";
+ exec 'echo', 'ok 4';
+}
#!./perl
-# $Header: io.print,v 1.0 87/12/18 13:12:55 root Exp $
+# $Header: io.print,v 2.0 88/06/05 00:13:11 root Exp $
-print "1..11\n";
+print "1..16\n";
-print stdout "ok 1\n";
-print "ok 2\n","ok 3\n","ok 4\n","ok 5\n";
+$foo = 'stdout';
+print $foo "ok 1\n";
+
+print "ok 2\n","ok 3\n","ok 4\n";
+print stdout "ok 5\n";
open(foo,">-");
print foo "ok 6\n";
$\ = "\n";
print "ok","11";
+
+@x = ("ok","12\nok","13\nok");
+@y = ("15\nok","16");
+print @x,"14\nok",@y;
#!./perl
-# $Header: io.tell,v 1.0 87/12/18 13:13:02 root Exp $
+# $Header: io.tell,v 2.0 88/06/05 00:13:14 root Exp $
print "1..13\n";
-open(tst, '../Makefile') || (die "Can't open ../Makefile");
+$TST = 'tst';
+
+open($TST, '../Makefile') || (die "Can't open ../Makefile");
if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
-$firstline = <tst>;
+$firstline = <$TST>;
$secondpos = tell;
$x = 0;
unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
-if (seek(tst,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
+if (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
if (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
-if (eof) { print "not ok 9\n"; } else { print "ok 9\n"; }
+if (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; }
if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
#!./perl
-# $Header: op.append,v 1.0 87/12/18 13:13:05 root Exp $
+# $Header: op.append,v 2.0 88/06/05 00:13:16 root Exp $
print "1..3\n";
#!./perl
-# $Header: op.auto,v 1.0 87/12/18 13:13:08 root Exp $
+# $Header: op.auto,v 2.0 88/06/05 00:13:19 root Exp $
-print "1..30\n";
+print "1..34\n";
$x = 10000;
if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";}
if (0 + --$x{0} + 1 == 10000) { print "ok 28\n";} else {print "not ok 28\n";}
if (0 + ++$x{0} + 0 == 10000) { print "ok 29\n";} else {print "not ok 29\n";}
if ($x{0} == 10000) { print "ok 30\n";} else {print "not ok 30\n";}
+
+# test magical autoincrement
+
+if (++($foo = '99') eq '100') {print "ok 31\n";} else {print "not ok 31\n";}
+if (++($foo = 'a0') eq 'a1') {print "ok 32\n";} else {print "not ok 32\n";}
+if (++($foo = 'Az') eq 'Ba') {print "ok 33\n";} else {print "not ok 33\n";}
+if (++($foo = 'zz') eq 'aaa') {print "ok 34\n";} else {print "not ok 34\n";}
#!./perl
-# $Header: op.chop,v 1.0 87/12/18 13:13:11 root Exp $
+# $Header: op.chop,v 2.0 88/06/05 00:13:22 root Exp $
print "1..2\n";
#!./perl
-# $Header: op.cond,v 1.0 87/12/18 13:13:14 root Exp $
+# $Header: op.cond,v 2.0 88/06/05 00:13:26 root Exp $
print "1..4\n";
+++ /dev/null
-#!./perl
-
-# $Header: op.crypt,v 1.0 87/12/18 13:13:17 root Exp $
-
-print "1..2\n";
-
-# this evaluates entirely at compile time!
-if (crypt('uh','oh') eq 'ohPnjpYtoi1NU') {print "ok 1\n";} else {print "not ok 1\n";}
-
-# this doesn't.
-$uh = 'uh';
-if (crypt($uh,'oh') eq 'ohPnjpYtoi1NU') {print "ok 2\n";} else {print "not ok 2\n";}
--- /dev/null
+#!./perl
+
+# $Header: op.delete,v 2.0 88/06/05 00:13:30 root Exp $
+
+print "1..6\n";
+
+$foo{1} = 'a';
+$foo{2} = 'b';
+$foo{3} = 'c';
+
+$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{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)) {
+ delete $foo{$key};
+}
+
+$foo{'foo'} = 'x';
+$foo{'bar'} = 'y';
+
+$foo = join('',values(foo));
+if ($foo eq 'xy' || $foo eq 'yx') {print "ok 6\n";} else {print "not ok 6\n";}
#!./perl
-# $Header: op.do,v 1.0 87/12/18 13:13:20 root Exp $
+# $Header: op.do,v 2.0 88/06/05 00:13:36 root Exp $
+
sub foo1
{
print $_[0];
$x;
}
-print "1..8\n";
+print "1..15\n";
$_[0] = "not ok 1\n";
$result = do foo1("ok 1\n");
$result = do{print "ok 7\n"; 'value';};
print "#8\t:$result: eq :value:\n";
if ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; }
+
+sub blather {
+ print @_;
+}
+
+do blather("ok 9\n","ok 10\n");
+@x = ("ok 11\n", "ok 12\n");
+@y = ("ok 14\n", "ok 15\n");
+do blather(@x,"ok 13\n",@y);
#!./perl
-# $Header: op.each,v 1.0 87/12/18 13:13:23 root Exp $
+# $Header: op.each,v 2.0 88/06/05 00:13:38 root Exp $
-print "1..2\n";
+print "1..3\n";
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
}
if ($i == 30) {print "ok 2\n";} else {print "not ok 2\n";}
+
+@keys = ('blurfl', keys(h), 'dyick');
+if ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";}
#!./perl
-print "1..6\n";
+# $Header: op.eval,v 2.0 88/06/05 00:13:40 root Exp $
+
+print "1..10\n";
eval 'print "ok 1\n";';
eval "\$foo\n = # this is a comment\n'ok 4\n';";
print $foo;
-eval '
+print eval '
$foo ='; # this tests for a call through yyerror()
if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
-eval '$foo = /'; # this tests for a call through fatal()
+print eval '$foo = /'; # this tests for a call through fatal()
if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
+
+print eval '"ok 7\n";';
+
+# calculate a factorial with recursive evals
+
+$foo = 5;
+$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
+$ans = eval $fact;
+if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
+
+$foo = 5;
+$fact = 'local($foo); $foo <= 1 ? 1 : $foo-- * (eval $fact);';
+$ans = eval $fact;
+if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
+
+open(try,'>Op.eval');
+print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
+close try;
+
+do 'Op.eval'; print $@;
#!./perl
-# $Header: op.exec,v 1.0 87/12/18 13:13:26 root Exp $
+# $Header: op.exec,v 2.0 88/06/05 00:13:46 root Exp $
$| = 1; # flush stdout
-print "1..4\n";
+print "1..8\n";
-system "echo ok \\1"; # shell interpreted
-system "echo ok 2"; # split and directly called
-system "echo", "ok", "3"; # directly called
+print "not ok 1\n" if system "echo ok \\1"; # shell interpreted
+print "not ok 2\n" if system "echo ok 2"; # split and directly called
+print "not ok 3\n" if system "echo", "ok", "3"; # directly called
-exec "echo","ok","4";
+if (system "true") {print "not ok 4\n";} else {print "ok 4\n";}
+
+if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; }
+print "ok 5\n";
+
+if ((system "lskdfj") == 255 << 8) {print "ok 6\n";} else {print "not ok 6\n";}
+
+unless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";}
+
+exec "echo","ok","8";
#!./perl
-# $Header: op.exp,v 1.0 87/12/18 13:13:29 root Exp $
+# $Header: op.exp,v 2.0 88/06/05 00:13:48 root Exp $
print "1..6\n";
#!./perl
-# $Header: op.flip,v 1.0 87/12/18 13:13:34 root Exp $
+# $Header: op.flip,v 2.0 88/06/05 00:13:51 root Exp $
print "1..8\n";
@a = ('a','b','c','d','e','f','g');
-open(of,'/etc/termcap');
+open(of,'../Makefile');
while (<of>) {
(3 .. 5) && $foo .= $_;
}
#!./perl
-# $Header: op.fork,v 1.0 87/12/18 13:13:37 root Exp $
+# $Header: op.fork,v 2.0 88/06/05 00:13:53 root Exp $
$| = 1;
print "1..2\n";
#!./perl
-# $Header: op.goto,v 1.0 87/12/18 13:13:40 root Exp $
+# $Header: op.goto,v 2.0 88/06/05 00:13:58 root Exp $
print "1..3\n";
#!./perl
-# $Header: op.int,v 1.0 87/12/18 13:13:43 root Exp $
+# $Header: op.int,v 2.0 88/06/05 00:14:01 root Exp $
print "1..4\n";
#!./perl
-# $Header: op.join,v 1.0 87/12/18 13:13:46 root Exp $
+# $Header: op.join,v 2.0 88/06/05 00:14:05 root Exp $
print "1..3\n";
#!./perl
-# $Header: op.list,v 1.0 87/12/18 13:13:50 root Exp $
+# $Header: op.list,v 2.0 88/06/05 00:14:09 root Exp $
-print "1..11\n";
+print "1..18\n";
@foo = (1, 2, 3, 4);
if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";}
($a, $b, $c, $d) = @foo;
print "#11 $a;$b;$c;$d eq 1;2;3;4\n";
if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";}
+
+@foo = (1);
+if (join(':',@foo) eq '1') {print "ok 12\n";} else {print "not ok 12\n";}
+
+@foo = ();
+@foo = 1+2+3;
+if (join(':',@foo) eq '6') {print "ok 13\n";} else {print "not ok 13\n";}
+
+for ($x = 0; $x < 3; $x++) {
+ ($a, $b, $c) =
+ $x == 0?
+ ('ok ', 14, "\n"):
+ $x == 1?
+ ('ok ', 15, "\n"):
+ # default
+ ('ok ', 16, "\n");
+
+ print $a,$b,$c;
+}
+
+@a = ($x == 12345 || (1,2,3));
+if (join('',@a) eq '123') {print "ok 17\n";} else {print "not ok 17\n";}
+
+@a = ($x == $x || (4,5,6));
+if (join('',@a) eq '1') {print "ok 18\n";} else {print "not ok 18\n";}
#!./perl
-# $Header: op.magic,v 1.0 87/12/18 13:13:54 root Exp $
-
-print "1..4\n";
+# $Header: op.magic,v 2.0 88/06/05 00:14:11 root Exp $
$| = 1; # command buffering
-$ENV{'foo'} = 'hi there';
+print "1..4\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";}
$! = 0;
open(foo,'ajslkdfpqjsjfkslkjdflksd');
if ($! == 2) {print "ok 2\n";} else {print "not ok 2\n";}
-$SIG{'INT'} = 'ok3';
-kill 2,$$;
-$SIG{'INT'} = 'IGNORE';
-kill 2,$$;
-print "ok 4\n";
-$SIG{'INT'} = 'DEFAULT';
-kill 2,$$;
-print "not ok\n";
-
-sub ok3 {
- print "ok 3\n" if pop(@_) eq 'INT';
-}
+# the next tests are embedded inside system simply because sh spits out
+# a newline onto stderr when a child process kills itself with SIGINT.
+
+system './perl',
+'-e', '$| = 1; # command buffering',
+
+'-e', '$SIG{"INT"} = "ok3"; kill 2,$$;',
+'-e', '$SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";',
+'-e', '$SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";',
+
+'-e', 'sub ok3 { print "ok 3\n" if pop(@_) eq "INT"; }';
#!./perl
-# $Header: op.oct,v 1.0 87/12/18 13:13:57 root Exp $
+# $Header: op.oct,v 2.0 88/06/05 00:14:14 root Exp $
print "1..3\n";
#!./perl
-# $Header: op.ord,v 1.0 87/12/18 13:14:01 root Exp $
+# $Header: op.ord,v 2.0 88/06/05 00:14:17 root Exp $
print "1..2\n";
#!./perl
-# $Header: op.pat,v 1.0 87/12/18 13:14:07 root Exp $
-print "1..22\n";
+# $Header: op.pat,v 2.0 88/06/05 00:14:20 root Exp $
+
+print "1..30\n";
$x = "abc\ndef\n";
if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
+
+if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
+
+$* = 1; # test 3 only tested the optimized version--this one is for real
+if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
+$* = 0;
+
+$XXX{123} = 123;
+$XXX{234} = 234;
+$XXX{345} = 345;
+
+@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27');
+while ($_ = shift(XXX)) {
+ ?(.*)? && (print $1,"\n");
+ /not/ && reset;
+ /not ok 26/ && reset 'X';
+}
+
+while (($key,$val) = each(XXX)) {
+ print "not ok 27\n";
+ exit;
+}
+
+print "ok 27\n";
+
+'cde' =~ /[^ab]*/;
+'xyz' =~ //;
+if ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";}
+
+$foo = '[^ab]*';
+'cde' =~ /$foo/;
+'xyz' =~ //;
+if ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";}
+
+$foo = '[^ab]*';
+'cde' =~ /$foo/;
+'xyz' =~ /$null/;
+if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";}
#!./perl
-# $Header: op.push,v 1.0 87/12/18 13:14:10 root Exp $
+# $Header: op.push,v 2.0 88/06/05 00:14:23 root Exp $
print "1..2\n";
--- /dev/null
+#!./perl
+
+# $Header: op.regexp,v 2.0 88/06/05 00:14:27 root Exp $
+
+open(TESTS,'re_tests') || open(TESTS,'t/re_tests') || die "Can't open re_tests";
+while (<TESTS>) { }
+$numtests = $.;
+close(TESTS);
+
+print "1..$numtests\n";
+open(TESTS,'re_tests') || open(TESTS,'t/re_tests') || die "Can't open re_tests";
+while (<TESTS>) {
+ ($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_);
+ $input = join(':',$pat,$subject,$result,$repl,$expect);
+ eval "\$match = (\$subject =~ \$pat); \$got = \"$repl\";";
+ if ($result eq 'c') {
+ if ($@ ne '') {print "ok $.\n";} else {print "not ok $.\n";}
+ }
+ elsif ($result eq 'n') {
+ if (!$match) {print "ok $.\n";} else {print "not ok $. $input => $got\n";}
+ }
+ else {
+ if ($match && $got eq $expect) {
+ print "ok $.\n";
+ }
+ else {
+ print "not ok $. $input => $got\n";
+ }
+ }
+}
+close(TESTS);
#!./perl
-# $Header: op.repeat,v 1.0 87/12/18 13:14:14 root Exp $
+# $Header: op.repeat,v 2.0 88/06/05 00:14:31 root Exp $
print "1..11\n";
#!./perl
-# $Header: op.sleep,v 1.0 87/12/18 13:14:17 root Exp $
+# $Header: op.sleep,v 2.0 88/06/05 00:14:35 root Exp $
print "1..1\n";
#!./perl
-# $Header: op.split,v 1.0.1.1 88/02/02 11:26:37 root Exp $
+# $Header: op.split,v 2.0 88/06/05 00:14:37 root Exp $
-print "1..6\n";
+print "1..7\n";
$FS = ':';
@ary = split(/:/);
if (join(".",@ary) eq "a.b.c") {print "ok 4\n";} else {print "not ok 4\n";}
-$_ = join(':',split(' ',' a b c '));
-if ($_ eq 'a:b:c') {print "ok 5\n";} else {print "not ok 5\n";}
+$_ = join(':',split(' '," a b\tc \t d "));
+if ($_ eq 'a:b:c:d') {print "ok 5\n";} else {print "not ok 5 #$_#\n";}
$_ = join(':',split(/ */,"foo bar bie\tdoll"));
if ($_ eq "f:o:o:b:a:r:b:i:e:\t:d:o:l:l")
{print "ok 6\n";} else {print "not ok 6\n";}
+
+$_ = join(':', 'foo', split(/ /,'a b c'), 'bar');
+if ($_ eq "foo:a:b::c:bar") {print "ok 7\n";} else {print "not ok 7 $_\n";}
+
#!./perl
-# $Header: op.sprintf,v 1.0 87/12/18 13:14:24 root Exp $
+# $Header: op.sprintf,v 2.0 88/06/05 00:14:40 root Exp $
print "1..1\n";
#!./perl
-# $Header: op.stat,v 1.0 87/12/18 13:14:27 root Exp $
+# $Header: op.stat,v 2.0 88/06/05 00:14:43 root Exp $
-print "1..4\n";
+print "1..56\n";
open(foo, ">Op.stat.tmp");
if ($mtime && $mtime != $ctime) {print "ok 4\n";} else {print "not ok 4\n";}
print "#4 :$mtime: != :$ctime:\n";
+`cp /dev/null Op.stat.tmp`;
+
+if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";}
+if (! -s 'Op.stat.tmp') {print "ok 6\n";} else {print "not ok 6\n";}
+
+`echo hi >Op.stat.tmp`;
+if (! -z 'Op.stat.tmp') {print "ok 7\n";} else {print "not ok 7\n";}
+if (-s 'Op.stat.tmp') {print "ok 8\n";} else {print "not ok 8\n";}
+
+chmod 0,'Op.stat.tmp';
+$olduid = $>; # can't test -r if uid == 0
+eval '$> = 1;'; # so switch uid (may not be implemented)
+if (!$> || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";}
+if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";}
+eval '$> = $olduid;'; # switch uid back (may not be implemented)
+if (! -x 'Op.stat.tmp') {print "ok 11\n";} else {print "not ok 11\n";}
+
+foreach ((12,13,14,15,16,17)) {
+ print "ok $_\n"; #deleted tests
+}
+
+chmod 0700,'Op.stat.tmp';
+if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";}
+if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";}
+if (-x 'Op.stat.tmp') {print "ok 20\n";} else {print "not ok 20\n";}
+
+if (-f 'Op.stat.tmp') {print "ok 21\n";} else {print "not ok 21\n";}
+if (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";}
+
+if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";}
+if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";}
+
+if (`ls -l perl` =~ /^l.*->/) {
+ if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";}
+}
+else {
+ print "ok 25\n";
+}
+
+if (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";}
+
+if (-e 'Op.stat.tmp') {print "ok 27\n";} else {print "not ok 27\n";}
`rm -f Op.stat.tmp Op.stat.tmp2`;
+if (! -e 'Op.stat.tmp') {print "ok 28\n";} else {print "not ok 28\n";}
+
+if (-c '/dev/tty') {print "ok 29\n";} else {print "not ok 29\n";}
+if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";}
+
+if (! -e '/dev/printer' || -S '/dev/printer')
+ {print "ok 31\n";}
+else
+ {print "not ok 31\n";}
+if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";}
+
+if (! -e '/dev/mt0' || -b '/dev/mt0')
+ {print "ok 33\n";}
+else
+ {print "not ok 33\n";}
+if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";}
+
+$cnt = $uid = 0;
+
+while (</usr/bin/*>) {
+ $cnt++;
+ $uid++ if -u;
+ last if $uid && $uid < $cnt;
+}
+
+# I suppose this is going to fail somewhere...
+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";
+}
+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";}
+close(null);
+if (-t) {print "ok 40\n";} else {print "not ok 40\n";}
+
+# These aren't strictly "stat" calls, but so what?
+
+if (-T 'op.stat') {print "ok 41\n";} else {print "not ok 41\n";}
+if (! -B 'op.stat') {print "ok 42\n";} else {print "not ok 42\n";}
+
+if (-B './perl') {print "ok 43\n";} else {print "not ok 43\n";}
+if (! -T './perl') {print "ok 44\n";} else {print "not ok 44\n";}
+
+open(foo,'op.stat');
+if (-T foo) {print "ok 45\n";} else {print "not ok 45\n";}
+if (! -B foo) {print "ok 46\n";} else {print "not ok 46\n";}
+$_ = <foo>;
+if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";}
+if (-T foo) {print "ok 48\n";} else {print "not ok 48\n";}
+if (! -B foo) {print "ok 49\n";} else {print "not ok 49\n";}
+close(foo);
+
+open(foo,'op.stat');
+$_ = <foo>;
+if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
+if (-T foo) {print "ok 51\n";} else {print "not ok 51\n";}
+if (! -B foo) {print "ok 52\n";} else {print "not ok 52\n";}
+seek(foo,0,0);
+if (-T foo) {print "ok 53\n";} else {print "not ok 53\n";}
+if (! -B foo) {print "ok 54\n";} else {print "not ok 54\n";}
+close(foo);
+
+if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";}
+if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";}
--- /dev/null
+#!./perl
+
+# $Header: op.study,v 2.0 88/06/05 00:14:45 root Exp $
+
+print "1..24\n";
+
+$x = "abc\ndef\n";
+study($x);
+
+if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
+if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$* = 1;
+if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
+$* = 0;
+
+$_ = '123';
+study;
+if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
+
+if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
+if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
+
+if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
+if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
+
+study($x);
+if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
+if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
+
+if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
+if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
+
+$_ = 'aaabbbccc';
+study;
+if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
+ print "ok 13\n";
+} else {
+ print "not ok 13\n";
+}
+if (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
+ print "ok 14\n";
+} else {
+ print "not ok 14\n";
+}
+
+if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
+
+$_ = 'aaabccc';
+study;
+if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
+if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
+
+$_ = 'aaaccc';
+study;
+if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
+if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
+
+$_ = 'abcdef';
+study;
+if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
+if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
+
+if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
+
+if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
+
+$* = 1; # test 3 only tested the optimized version--this one is for real
+if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
#!./perl
-# $Header: op.subst,v 1.0 87/12/18 13:14:30 root Exp $
+# $Header: op.subst,v 2.0 88/06/05 00:14:49 root Exp $
-print "1..7\n";
+print "1..13\n";
$x = 'foo';
$_ = "x";
print "#3\t:$_: eq :\$x foo:\n";
if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";}
-$a = 'abcdef';
$b = 'cd';
-$a =~ s'(b${b}e)'\n$1';
+($a = 'abcdef') =~ s'(b${b}e)'\n$1';
print "#4\t:$1: eq :bcde:\n";
print "#4\t:$a: eq :a\\n\$1f:\n";
if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";}
{print "ok 6\n";} else {print "not ok 6\n";}
if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx')
- {print "ok 7\n";} else {print "not ok 7\n";}
+ {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";}
+
+$_ = '\\' x 4;
+if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";}
+s/\\/\\\\/g;
+if ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10\n";}
+
+$_ = '\/' x 4;
+if (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\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";}
#!./perl
-# $Header: op.time,v 1.0.1.1 88/01/24 03:56:09 root Exp $
+# $Header: op.time,v 2.0 88/06/05 00:14:58 root Exp $
print "1..5\n";
#!./perl
-# $Header: op.unshift,v 1.0 87/12/18 13:14:37 root Exp $
+# $Header: op.unshift,v 2.0 88/06/05 00:15:00 root Exp $
print "1..2\n";
--- /dev/null
+abc abc y $& abc
+abc xbc n - -
+abc axc n - -
+abc abx n - -
+abc xabcy y $& abc
+abc ababc y $& abc
+ab*c abc y $& abc
+ab*bc abc y $& abc
+ab*bc abbc y $& abbc
+ab*bc abbbbc y $& abbbbc
+ab+bc abbc y $& abbc
+ab+bc abc n - -
+ab+bc abq n - -
+ab+bc abbbbc y $& abbbbc
+ab?bc abbc y $& abbc
+ab?bc abc y $& abc
+ab?bc abbbbc n - -
+ab?c abc y $& abc
+^abc$ abc y $& abc
+^abc$ abcc n - -
+^abc abcc y $& abc
+^abc$ aabc n - -
+abc$ aabc y $& abc
+^ abc y $&
+$ abc y $&
+a.c abc y $& abc
+a.c axc y $& axc
+a.*c axyzc y $& axyzc
+a.*c axyzd n - -
+a[bc]d abc n - -
+a[bc]d abd y $& abd
+a[b-d]e abd n - -
+a[b-d]e ace y $& ace
+a[b-d] aac y $& ac
+a[-b] a- y $& a-
+a[b-] a- y $& a-
+a[b-a] - c - -
+a[]b - c - -
+a[ - c - -
+a] a] y $& a]
+a[]]b a]b y $& a]b
+a[^bc]d aed y $& aed
+a[^bc]d abd n - -
+a[^-b]c adc y $& adc
+a[^-b]c a-c n - -
+a[^]b]c a]c n - -
+a[^]b]c adc y $& adc
+ab|cd abc y $& ab
+ab|cd abcd y $& ab
+()ef def y $&-$1 ef-
+()* - c - -
+*a - c - -
+^* - c - -
+$* - c - -
+(*)b - c - -
+$b b n - -
+a\ - c - -
+a\(b a(b y $&-$1 a(b-
+a\(*b ab y $& ab
+a\(*b a((b y $& a((b
+a\\b a\b y $& a\b
+abc) - c - -
+(abc - c - -
+((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** - c - -
+a*? - c - -
+(a*)* - c - -
+(a*)+ - c - -
+(a|)* - c - -
+(a*|b)* - c - -
+(a+|b)* ab y $&-$1 ab-b
+(a+|b)+ ab y $&-$1 ab-b
+(a+|b)? ab y $&-$1 a-a
+(^)* - c - -
+(ab|)* - c - -
+)( - c - -
+[^ab]* cde y $& cde
+abc n - -
+a* y $&
+([abc])*d abbbcd y $&-$1 abbbcd-c
+([abc])*bcd abcd y $&-$1 abcd-a
+a|b|c|d|e e y $& e
+(a|b|c|d|e)f ef y $&-$1 ef-e
+((a*|b))* - c - -
+abcd*efg abcdefg y $& abcdefg
+ab* xabyabbbz y $& ab
+ab* xayabbbz y $& a
+(ab|cd)e abcde y $&-$1 cde-cd
+[abhgefdc]ij hij y $& hij
+^(ab|cd)e abcde n x$1y xy
+(abc|)ef abcdef y $&-$1 ef-
+(a|b)c*d abcd y $&-$1 bcd-b
+(ab|ab*)bc abc y $&-$1 abc-a
+a([bc]*)c* abc y $&-$1 abc-bc
+a([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d
+a([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d
+a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd
+a[bcd]*dcdcde adcdcde y $& adcdcde
+a[bcd]+dcdcde adcdcde n - -
+(ab|a)b*c abc y $&-$1 abc-ab
+((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d
+[a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha
+^a(bc+|b[eh])g|.h$ abh y $&-$1 bh-
+(bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz-
+(bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j
+(bc+d$|ef*g.|h?i(j|k)) effg n - -
+(bc+d$|ef*g.|h?i(j|k)) bcdd n - -
+(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz-
+((((((((((a)))))))))) - c - -
+(((((((((a))))))))) a y $& a
+multiple words of text uh-uh n - -
+multiple words multiple words, yeah y $& multiple words
+(.*)c(.*) abcde y $&-$1-$2 abcde-ab-de
+\((.*), (.*)\) (a, b) y ($2, $1) (b, a)
+[k] ab n - -
+abcd abcd y $&-\$&-\\$& abcd-$&-\abcd
+a(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc
+a[-]?c ac y $& ac
+(abc)\1 abcabc y $1 abc
+([a-c]*)\1 abcabc y $1 abc
--- /dev/null
+/* $Header: toke.c,v 2.0 88/06/05 00:11:16 root Exp $
+ *
+ * $Log: toke.c,v $
+ * Revision 2.0 88/06/05 00:11:16 root
+ * Baseline version 2.0.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "perly.h"
+
+#define CLINE (cmdline = (line < cmdline ? line : cmdline))
+
+#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)
+
+yylex()
+{
+ register char *s = bufptr;
+ register char *d;
+ register int tmp;
+ static bool in_format = FALSE;
+ static bool firstline = TRUE;
+
+ retry:
+#ifdef YYDEBUG
+ if (yydebug)
+ if (index(s,'\n'))
+ fprintf(stderr,"Tokener at %s",s);
+ else
+ fprintf(stderr,"Tokener at %s\n",s);
+#endif
+ switch (*s) {
+ default:
+ fprintf(stderr,
+ "Unrecognized character %c in file %s line %ld--ignoring.\n",
+ *s++,filename,(long)line);
+ 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 (in_format) {
+ yylval.formval = load_format(); /* leaves . in buffer */
+ in_format = FALSE;
+ s = str_get(linestr);
+ TERM(FORMLIST);
+ }
+ line++;
+ if ((s = str_gets(linestr, rsfp)) == Nullch) {
+ if (preprocess)
+ pclose(rsfp);
+ else if (rsfp != stdin)
+ fclose(rsfp);
+ rsfp = Nullfp;
+ if (minus_n || minus_p) {
+ str_set(linestr,minus_p ? "}continue{print;" : "");
+ str_cat(linestr,"}");
+ s = str_get(linestr);
+ goto retry;
+ }
+ s = str_get(linestr);
+ RETURN(0);
+ }
+#ifdef DEBUG
+ else if (firstline) {
+ char *showinput();
+ s = showinput();
+ }
+#endif
+ firstline = FALSE;
+ goto retry;
+ case ' ': case '\t': case '\f':
+ s++;
+ goto retry;
+ case '\n':
+ case '#':
+ if (preprocess && s == str_get(linestr) &&
+ s[1] == ' ' && isdigit(s[2])) {
+ line = atoi(s+2)-1;
+ for (s += 2; isdigit(*s); s++) ;
+ while (*s && isspace(*s)) s++;
+ if (filename)
+ safefree(filename);
+ s[strlen(s)-1] = '\0'; /* wipe out newline */
+ if (*s == '"') {
+ s++;
+ s[strlen(s)-1] = '\0'; /* wipe out trailing quote */
+ }
+ if (*s)
+ filename = savestr(s);
+ else
+ filename = savestr(origfilename);
+ s = str_get(linestr);
+ }
+ if (in_eval) {
+ while (*s && *s != '\n')
+ s++;
+ if (*s)
+ s++;
+ line++;
+ }
+ else
+ *s = '\0';
+ if (lex_newlines)
+ RETURN('\n');
+ goto retry;
+ case '-':
+ if (s[1] && isalpha(s[1]) && !isalpha(s[2])) {
+ s++;
+ switch (*s++) {
+ case 'r': FTST(O_FTEREAD);
+ case 'w': FTST(O_FTEWRITE);
+ case 'x': FTST(O_FTEEXEC);
+ case 'o': FTST(O_FTEOWNED);
+ case 'R': FTST(O_FTRREAD);
+ case 'W': FTST(O_FTRWRITE);
+ case 'X': FTST(O_FTREXEC);
+ case 'O': FTST(O_FTROWNED);
+ case 'e': FTST(O_FTIS);
+ case 'z': FTST(O_FTZERO);
+ case 's': FTST(O_FTSIZE);
+ case 'f': FTST(O_FTFILE);
+ case 'd': FTST(O_FTDIR);
+ case 'l': FTST(O_FTLINK);
+ case 'p': FTST(O_FTPIPE);
+ case 'S': FTST(O_FTSOCK);
+ case 'u': FTST(O_FTSUID);
+ case 'g': FTST(O_FTSGID);
+ case 'k': FTST(O_FTSVTX);
+ case 'b': FTST(O_FTBLK);
+ case 'c': FTST(O_FTCHR);
+ case 't': FTST(O_FTTTY);
+ case 'T': FTST(O_FTTEXT);
+ case 'B': FTST(O_FTBINARY);
+ default:
+ s -= 2;
+ break;
+ }
+ }
+ /*FALL THROUGH*/
+ case '+':
+ if (s[1] == *s) {
+ s++;
+ if (*s++ == '+')
+ RETURN(INC);
+ else
+ RETURN(DEC);
+ }
+ /* FALL THROUGH */
+ case '*':
+ case '%':
+ case '^':
+ case '~':
+ case '(':
+ case ',':
+ case ':':
+ case '[':
+ tmp = *s++;
+ OPERATOR(tmp);
+ case '{':
+ tmp = *s++;
+ if (isspace(*s) || *s == '#')
+ cmdline = NOLINE; /* invalidate current command line number */
+ OPERATOR(tmp);
+ case ';':
+ if (line < cmdline)
+ cmdline = line;
+ tmp = *s++;
+ OPERATOR(tmp);
+ case ')':
+ case ']':
+ tmp = *s++;
+ TERM(tmp);
+ case '}':
+ tmp = *s++;
+ for (d = s; *d == ' ' || *d == '\t'; d++) ;
+ if (*d == '\n' || *d == '#')
+ OPERATOR(tmp); /* block end */
+ else
+ TERM(tmp); /* associative array end */
+ case '&':
+ s++;
+ tmp = *s++;
+ if (tmp == '&')
+ OPERATOR(ANDAND);
+ s--;
+ OPERATOR('&');
+ case '|':
+ s++;
+ tmp = *s++;
+ if (tmp == '|')
+ OPERATOR(OROR);
+ s--;
+ OPERATOR('|');
+ case '=':
+ s++;
+ tmp = *s++;
+ if (tmp == '=')
+ OPERATOR(EQ);
+ if (tmp == '~')
+ OPERATOR(MATCH);
+ s--;
+ OPERATOR('=');
+ case '!':
+ s++;
+ tmp = *s++;
+ if (tmp == '=')
+ OPERATOR(NE);
+ if (tmp == '~')
+ OPERATOR(NMATCH);
+ s--;
+ OPERATOR('!');
+ case '<':
+ if (expectterm) {
+ s = scanstr(s);
+ TERM(RSTRING);
+ }
+ s++;
+ tmp = *s++;
+ if (tmp == '<')
+ OPERATOR(LS);
+ if (tmp == '=')
+ OPERATOR(LE);
+ s--;
+ OPERATOR('<');
+ case '>':
+ s++;
+ tmp = *s++;
+ if (tmp == '>')
+ OPERATOR(RS);
+ if (tmp == '=')
+ OPERATOR(GE);
+ s--;
+ OPERATOR('>');
+
+#define SNARFWORD \
+ d = tokenbuf; \
+ while (isalpha(*s) || isdigit(*s) || *s == '_') \
+ *d++ = *s++; \
+ *d = '\0'; \
+ d = tokenbuf;
+
+ case '$':
+ if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) {
+ s++;
+ s = scanreg(s,tokenbuf);
+ yylval.stabval = aadd(stabent(tokenbuf,TRUE));
+ TERM(ARYLEN);
+ }
+ s = scanreg(s,tokenbuf);
+ yylval.stabval = stabent(tokenbuf,TRUE);
+ TERM(REG);
+
+ case '@':
+ s = scanreg(s,tokenbuf);
+ yylval.stabval = aadd(stabent(tokenbuf,TRUE));
+ TERM(ARY);
+
+ case '/': /* may either be division or pattern */
+ case '?': /* may either be conditional or pattern */
+ if (expectterm) {
+ s = scanpat(s);
+ TERM(PATTERN);
+ }
+ tmp = *s++;
+ OPERATOR(tmp);
+
+ case '.':
+ if (!expectterm || !isdigit(s[1])) {
+ s++;
+ tmp = *s++;
+ if (tmp == '.')
+ OPERATOR(DOTDOT);
+ s--;
+ OPERATOR('.');
+ }
+ /* FALL THROUGH */
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ case '\'': case '"': case '`':
+ s = scanstr(s);
+ TERM(RSTRING);
+
+ case '_':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'a': case 'A':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'b': case 'B':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'c': case 'C':
+ SNARFWORD;
+ if (strEQ(d,"continue"))
+ OPERATOR(CONTINUE);
+ if (strEQ(d,"chdir"))
+ UNI(O_CHDIR);
+ if (strEQ(d,"close"))
+ OPERATOR(CLOSE);
+ if (strEQ(d,"crypt"))
+ FUN2(O_CRYPT);
+ if (strEQ(d,"chop"))
+ 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);
+ case 'd': case 'D':
+ SNARFWORD;
+ if (strEQ(d,"do"))
+ OPERATOR(DO);
+ if (strEQ(d,"die"))
+ UNI(O_DIE);
+ if (strEQ(d,"delete"))
+ OPERATOR(DELETE);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'e': case 'E':
+ SNARFWORD;
+ if (strEQ(d,"else"))
+ OPERATOR(ELSE);
+ if (strEQ(d,"elsif")) {
+ yylval.ival = line;
+ OPERATOR(ELSIF);
+ }
+ if (strEQ(d,"eq") || strEQ(d,"EQ"))
+ OPERATOR(SEQ);
+ if (strEQ(d,"exit"))
+ UNI(O_EXIT);
+ if (strEQ(d,"eval")) {
+ allstabs = TRUE; /* must initialize everything since */
+ UNI(O_EVAL); /* we don't know what will be used */
+ }
+ if (strEQ(d,"eof"))
+ TERM(FEOF);
+ if (strEQ(d,"exp"))
+ FUN1(O_EXP);
+ if (strEQ(d,"each"))
+ SFUN(O_EACH);
+ if (strEQ(d,"exec")) {
+ yylval.ival = O_EXEC;
+ OPERATOR(LISTOP);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'f': case 'F':
+ SNARFWORD;
+ if (strEQ(d,"for"))
+ OPERATOR(FOR);
+ if (strEQ(d,"foreach"))
+ OPERATOR(FOR);
+ if (strEQ(d,"format")) {
+ in_format = TRUE;
+ OPERATOR(FORMAT);
+ }
+ if (strEQ(d,"fork"))
+ FUN0(O_FORK);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'g': case 'G':
+ SNARFWORD;
+ if (strEQ(d,"gt") || strEQ(d,"GT"))
+ OPERATOR(SGT);
+ if (strEQ(d,"ge") || strEQ(d,"GE"))
+ OPERATOR(SGE);
+ if (strEQ(d,"goto"))
+ LOOPX(O_GOTO);
+ if (strEQ(d,"gmtime"))
+ FUN1(O_GMTIME);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'h': case 'H':
+ SNARFWORD;
+ if (strEQ(d,"hex"))
+ FUN1(O_HEX);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'i': case 'I':
+ SNARFWORD;
+ if (strEQ(d,"if")) {
+ yylval.ival = line;
+ OPERATOR(IF);
+ }
+ if (strEQ(d,"index"))
+ FUN2(O_INDEX);
+ if (strEQ(d,"int"))
+ FUN1(O_INT);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'j': case 'J':
+ SNARFWORD;
+ if (strEQ(d,"join"))
+ OPERATOR(JOIN);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'k': case 'K':
+ SNARFWORD;
+ if (strEQ(d,"keys"))
+ SFUN(O_KEYS);
+ if (strEQ(d,"kill")) {
+ yylval.ival = O_KILL;
+ OPERATOR(LISTOP);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'l': case 'L':
+ SNARFWORD;
+ if (strEQ(d,"last"))
+ LOOPX(O_LAST);
+ if (strEQ(d,"local"))
+ OPERATOR(LOCAL);
+ if (strEQ(d,"length"))
+ FUN1(O_LENGTH);
+ if (strEQ(d,"lt") || strEQ(d,"LT"))
+ OPERATOR(SLT);
+ if (strEQ(d,"le") || strEQ(d,"LE"))
+ OPERATOR(SLE);
+ if (strEQ(d,"localtime"))
+ FUN1(O_LOCALTIME);
+ if (strEQ(d,"log"))
+ FUN1(O_LOG);
+ if (strEQ(d,"link"))
+ FUN2(O_LINK);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'm': case 'M':
+ SNARFWORD;
+ if (strEQ(d,"m")) {
+ s = scanpat(s-1);
+ TERM(PATTERN);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'n': case 'N':
+ SNARFWORD;
+ if (strEQ(d,"next"))
+ LOOPX(O_NEXT);
+ if (strEQ(d,"ne") || strEQ(d,"NE"))
+ OPERATOR(SNE);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'o': case 'O':
+ SNARFWORD;
+ if (strEQ(d,"open"))
+ OPERATOR(OPEN);
+ if (strEQ(d,"ord"))
+ FUN1(O_ORD);
+ if (strEQ(d,"oct"))
+ FUN1(O_OCT);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'p': case 'P':
+ SNARFWORD;
+ if (strEQ(d,"print")) {
+ yylval.ival = O_PRINT;
+ OPERATOR(LISTOP);
+ }
+ if (strEQ(d,"printf")) {
+ yylval.ival = O_PRTF;
+ OPERATOR(LISTOP);
+ }
+ if (strEQ(d,"push")) {
+ yylval.ival = O_PUSH;
+ OPERATOR(PUSH);
+ }
+ if (strEQ(d,"pop"))
+ OPERATOR(POP);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'q': case 'Q':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'r': case 'R':
+ SNARFWORD;
+ if (strEQ(d,"reset"))
+ UNI(O_RESET);
+ if (strEQ(d,"redo"))
+ LOOPX(O_REDO);
+ if (strEQ(d,"rename"))
+ FUN2(O_RENAME);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 's': case 'S':
+ SNARFWORD;
+ if (strEQ(d,"s")) {
+ s = scansubst(s);
+ TERM(SUBST);
+ }
+ if (strEQ(d,"shift"))
+ TERM(SHIFT);
+ if (strEQ(d,"split"))
+ TERM(SPLIT);
+ if (strEQ(d,"substr"))
+ FUN3(O_SUBSTR);
+ if (strEQ(d,"sprintf"))
+ OPERATOR(SPRINTF);
+ if (strEQ(d,"sub"))
+ OPERATOR(SUB);
+ if (strEQ(d,"select"))
+ OPERATOR(SELECT);
+ if (strEQ(d,"seek"))
+ OPERATOR(SEEK);
+ if (strEQ(d,"stat"))
+ OPERATOR(STAT);
+ if (strEQ(d,"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);
+ case 't': case 'T':
+ SNARFWORD;
+ if (strEQ(d,"tr")) {
+ s = scantrans(s);
+ TERM(TRANS);
+ }
+ if (strEQ(d,"tell"))
+ TERM(TELL);
+ if (strEQ(d,"time"))
+ FUN0(O_TIME);
+ if (strEQ(d,"times"))
+ FUN0(O_TMS);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'u': case 'U':
+ SNARFWORD;
+ if (strEQ(d,"using"))
+ OPERATOR(USING);
+ if (strEQ(d,"until")) {
+ yylval.ival = line;
+ OPERATOR(UNTIL);
+ }
+ if (strEQ(d,"unless")) {
+ yylval.ival = line;
+ OPERATOR(UNLESS);
+ }
+ if (strEQ(d,"umask"))
+ FUN1(O_UMASK);
+ if (strEQ(d,"unshift")) {
+ yylval.ival = O_UNSHIFT;
+ OPERATOR(PUSH);
+ }
+ if (strEQ(d,"unlink")) {
+ yylval.ival = O_UNLINK;
+ OPERATOR(LISTOP);
+ }
+ if (strEQ(d,"utime")) {
+ yylval.ival = O_UTIME;
+ OPERATOR(LISTOP);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'v': case 'V':
+ SNARFWORD;
+ if (strEQ(d,"values"))
+ SFUN(O_VALUES);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'w': case 'W':
+ SNARFWORD;
+ if (strEQ(d,"write"))
+ TERM(WRITE);
+ if (strEQ(d,"while")) {
+ yylval.ival = line;
+ OPERATOR(WHILE);
+ }
+ if (strEQ(d,"wait"))
+ FUN0(O_WAIT);
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'x': case 'X':
+ SNARFWORD;
+ if (!expectterm && strEQ(d,"x"))
+ OPERATOR('x');
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'y': case 'Y':
+ SNARFWORD;
+ if (strEQ(d,"y")) {
+ s = scantrans(s);
+ TERM(TRANS);
+ }
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ case 'z': case 'Z':
+ SNARFWORD;
+ yylval.cval = savestr(d);
+ OPERATOR(WORD);
+ }
+}
+
+char *
+scanreg(s,dest)
+register char *s;
+char *dest;
+{
+ register char *d;
+
+ s++;
+ d = dest;
+ if (isdigit(*s)) {
+ while (isdigit(*s) || *s == '_')
+ *d++ = *s++;
+ }
+ else {
+ while (isalpha(*s) || isdigit(*s) || *s == '_')
+ *d++ = *s++;
+ }
+ *d = '\0';
+ d = dest;
+ if (!*d) {
+ *d = *s++;
+ if (*d == '{') {
+ d = dest;
+ while (*s && *s != '}')
+ *d++ = *s++;
+ *d = '\0';
+ d = dest;
+ if (*s)
+ s++;
+ }
+ else
+ d[1] = '\0';
+ }
+ if (*d == '^' && !isspace(*s))
+ *d = *s++ & 31;
+ return s;
+}
+
+STR *
+scanconst(string)
+char *string;
+{
+ register STR *retstr;
+ register char *t;
+ register char *d;
+
+ if (index(string,'|')) {
+ return Nullstr;
+ }
+ retstr = str_make(string);
+ t = str_get(retstr);
+ *(long*)&retstr->str_nval = 100;
+ for (d=t; *d; ) {
+ switch (*d) {
+ case '.': case '[': case '$': case '(': case ')': case '|':
+ *d = '\0';
+ break;
+ case '\\':
+ if (index("wWbB0123456789sSdD",d[1])) {
+ *d = '\0';
+ break;
+ }
+ strcpy(d,d+1);
+ switch(*d) {
+ case 'n':
+ *d = '\n';
+ break;
+ case 't':
+ *d = '\t';
+ break;
+ case 'f':
+ *d = '\f';
+ break;
+ case 'r':
+ *d = '\r';
+ break;
+ }
+ /* FALL THROUGH */
+ default:
+ if (d[1] == '*' || d[1] == '+' || d[1] == '?') {
+ *d = '\0';
+ break;
+ }
+ d++;
+ }
+ }
+ if (!*t) {
+ str_free(retstr);
+ return Nullstr;
+ }
+ retstr->str_cur = strlen(retstr->str_ptr);
+ return retstr;
+}
+
+char *
+scanpat(s)
+register char *s;
+{
+ register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
+ register char *d;
+
+ bzero((char *)spat, sizeof(SPAT));
+ spat->spat_next = spat_root; /* link into spat list */
+ spat_root = spat;
+
+ switch (*s++) {
+ case 'm':
+ s++;
+ break;
+ case '/':
+ break;
+ case '?':
+ spat->spat_flags |= SPAT_ONCE;
+ break;
+ default:
+ fatal("panic: scanpat");
+ }
+ s = cpytill(tokenbuf,s,s[-1]);
+ if (!*s)
+ fatal("Search pattern not terminated");
+ s++;
+ if (*s == 'i') {
+ s++;
+ spat->spat_flags |= SPAT_FOLD;
+ }
+ for (d=tokenbuf; *d; d++) {
+ if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+ register ARG *arg;
+
+ spat->spat_runtime = arg = op_new(1);
+ arg->arg_type = O_ITEM;
+ arg[1].arg_type = A_DOUBLE;
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ goto 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;
+ }
+ }
+ 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);
+ got_pat:
+ yylval.arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
+ return s;
+}
+
+char *
+scansubst(s)
+register char *s;
+{
+ register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
+ register char *d;
+
+ bzero((char *)spat, sizeof(SPAT));
+ spat->spat_next = spat_root; /* link into spat list */
+ spat_root = spat;
+
+ 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] != '|') {
+ register ARG *arg;
+
+ spat->spat_runtime = arg = op_new(1);
+ arg->arg_type = O_ITEM;
+ arg[1].arg_type = A_DOUBLE;
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ goto get_repl; /* skip compiling for now */
+ }
+ }
+ if (*tokenbuf == '^') {
+ spat->spat_short = scanconst(tokenbuf+1);
+ if (spat->spat_short)
+ spat->spat_slen = strlen(spat->spat_short->str_ptr);
+ }
+ else {
+ spat->spat_flags |= SPAT_SCANFIRST;
+ spat->spat_short = scanconst(tokenbuf);
+ if (spat->spat_short)
+ spat->spat_slen = strlen(spat->spat_short->str_ptr);
+ }
+ d = savestr(tokenbuf);
+get_repl:
+ s = scanstr(s);
+ if (!*s)
+ fatal("Substitution replacement not terminated");
+ spat->spat_repl = yylval.arg;
+ spat->spat_flags |= SPAT_ONCE;
+ while (*s == 'g' || *s == 'i') {
+ if (*s == 'g') {
+ s++;
+ spat->spat_flags &= ~SPAT_ONCE;
+ }
+ if (*s == 'i') {
+ s++;
+ spat->spat_flags |= SPAT_FOLD;
+ }
+ }
+ if (!spat->spat_runtime) {
+ spat->spat_regexp = regcomp(d, 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;
+ }
+ yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat);
+ return s;
+}
+
+hoistmust(spat)
+register SPAT *spat;
+{
+ 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)){
+ if (spat->spat_flags & SPAT_SCANFIRST) {
+ str_free(spat->spat_short);
+ spat->spat_short = Nullstr;
+ }
+ else {
+ str_free(spat->spat_regexp->regmust);
+ spat->spat_regexp->regmust = Nullstr;
+ return;
+ }
+ }
+ if (!spat->spat_short || /* promote the better string */
+ ((spat->spat_flags & SPAT_SCANFIRST) &&
+ (spat->spat_short->str_cur < spat->spat_regexp->regmust->str_cur) )){
+ str_free(spat->spat_short); /* ok if null */
+ spat->spat_short = spat->spat_regexp->regmust;
+ spat->spat_regexp->regmust = Nullstr;
+ spat->spat_flags |= SPAT_SCANFIRST;
+ }
+ }
+}
+
+char *
+expand_charset(s)
+register char *s;
+{
+ char t[512];
+ register char *d = t;
+ register int i;
+
+ while (*s) {
+ if (s[1] == '-' && s[2]) {
+ for (i = s[0]; i <= s[2]; i++)
+ *d++ = i;
+ s += 3;
+ }
+ else
+ *d++ = *s++;
+ }
+ *d = '\0';
+ return savestr(t);
+}
+
+char *
+scantrans(s)
+register char *s;
+{
+ ARG *arg =
+ l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg,0));
+ register char *t;
+ register char *r;
+ register char *tbl = safemalloc(256);
+ register int i;
+
+ arg[2].arg_type = A_NULL;
+ arg[2].arg_ptr.arg_cval = tbl;
+ for (i=0; i<256; i++)
+ tbl[i] = 0;
+ s = scanstr(s);
+ if (!*s)
+ fatal("Translation pattern not terminated");
+ t = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str));
+ free_arg(yylval.arg);
+ s = scanstr(s-1);
+ if (!*s)
+ fatal("Translation replacement not terminated");
+ r = expand_charset(str_get(yylval.arg[1].arg_ptr.arg_str));
+ free_arg(yylval.arg);
+ yylval.arg = arg;
+ if (!*r) {
+ safefree(r);
+ r = t;
+ }
+ for (i = 0; t[i]; i++) {
+ if (!r[i])
+ r[i] = r[i-1];
+ tbl[t[i] & 0377] = r[i];
+ }
+ if (r != t)
+ safefree(r);
+ safefree(t);
+ return s;
+}
+
+char *
+scanstr(s)
+register char *s;
+{
+ register char term;
+ register char *d;
+ register ARG *arg;
+ register bool makesingle = FALSE;
+ register STAB *stab;
+ char *leave = "\\$nrtfb0123456789"; /* which backslash sequences to keep */
+
+ arg = op_new(1);
+ yylval.arg = arg;
+ arg->arg_type = O_ITEM;
+
+ switch (*s) {
+ default: /* a substitution replacement */
+ arg[1].arg_type = A_DOUBLE;
+ makesingle = TRUE; /* maybe disable runtime scanning */
+ term = *s;
+ if (term == '\'')
+ leave = Nullch;
+ goto snarf_it;
+ case '0':
+ {
+ long i;
+ int shift;
+
+ arg[1].arg_type = A_SINGLE;
+ if (s[1] == 'x') {
+ shift = 4;
+ s += 2;
+ }
+ else if (s[1] == '.')
+ goto decimal;
+ else
+ shift = 3;
+ i = 0;
+ for (;;) {
+ switch (*s) {
+ default:
+ goto out;
+ case '8': case '9':
+ if (shift != 4)
+ fatal("Illegal octal digit");
+ /* FALL THROUGH */
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7':
+ i <<= shift;
+ i += *s++ & 15;
+ break;
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ if (shift != 4)
+ goto out;
+ i <<= 4;
+ i += (*s++ & 7) + 9;
+ break;
+ }
+ }
+ out:
+ sprintf(tokenbuf,"%ld",i);
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ }
+ break;
+ case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9': case '.':
+ decimal:
+ arg[1].arg_type = A_SINGLE;
+ d = tokenbuf;
+ while (isdigit(*s) || *s == '_') {
+ if (*s == '_')
+ s++;
+ else
+ *d++ = *s++;
+ }
+ if (*s == '.' && index("0123456789eE",s[1])) {
+ *d++ = *s++;
+ while (isdigit(*s) || *s == '_') {
+ if (*s == '_')
+ s++;
+ else
+ *d++ = *s++;
+ }
+ }
+ if (index("eE",*s) && index("+-0123456789",s[1])) {
+ *d++ = *s++;
+ if (*s == '+' || *s == '-')
+ *d++ = *s++;
+ while (isdigit(*s))
+ *d++ = *s++;
+ }
+ *d = '\0';
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf);
+ break;
+ case '\'':
+ arg[1].arg_type = A_SINGLE;
+ term = *s;
+ leave = Nullch;
+ goto snarf_it;
+
+ case '<':
+ d = tokenbuf;
+ s = cpytill(d,s+1,'>');
+ if (*s)
+ s++;
+ if (*d == '$') d++;
+ while (*d && (isalpha(*d) || isdigit(*d) || *d == '_')) d++;
+ if (*d) {
+ d = tokenbuf;
+ arg[1].arg_type = A_GLOB;
+ d = savestr(d);
+ arg[1].arg_ptr.arg_stab = stab = genstab();
+ stab->stab_io = stio_new();
+ stab->stab_val = str_make(d);
+ }
+ else {
+ d = tokenbuf;
+ if (!*d)
+ 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>");
+ arg[1].arg_ptr.arg_stab = stabent(d,TRUE);
+ arg[1].arg_ptr.arg_stab->stab_io = stio_new();
+ if (strEQ(d,"ARGV")) {
+ aadd(arg[1].arg_ptr.arg_stab);
+ arg[1].arg_ptr.arg_stab->stab_io->flags |=
+ IOF_ARGV|IOF_START;
+ }
+ }
+ }
+ break;
+ case '"':
+ arg[1].arg_type = A_DOUBLE;
+ makesingle = TRUE; /* maybe disable runtime scanning */
+ term = *s;
+ goto snarf_it;
+ case '`':
+ arg[1].arg_type = A_BACKTICK;
+ term = *s;
+ snarf_it:
+ {
+ STR *tmpstr;
+ int sqstart = line;
+ char *tmps;
+
+ tmpstr = str_new(strlen(s));
+ s = str_append_till(tmpstr,s+1,term,leave);
+ while (!*s) { /* multiple line string? */
+ s = str_gets(linestr, rsfp);
+ if (!s) {
+ line = sqstart;
+ fatal("EOF in string");
+ }
+ line++;
+ s = str_append_till(tmpstr,s,term,leave);
+ }
+ s++;
+ if (term == '\'') {
+ arg[1].arg_ptr.arg_str = tmpstr;
+ break;
+ }
+ tmps = s;
+ s = tmpstr->str_ptr;
+ while (*s) { /* see if we can make SINGLE */
+ if (*s == '\\' && s[1] && isdigit(s[1]) && !isdigit(s[2]) &&
+ !index("`\"",term) )
+ *s = '$'; /* grandfather \digit in subst */
+ if (*s == '$' && s[1] && s[1] != ')' && s[1] != '|') {
+ makesingle = FALSE; /* force interpretation */
+ }
+ else if (*s == '\\' && s[1]) {
+ 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 (len--)
+ *d++ = *s++;
+ continue;
+ }
+ else if (*s == '\\' && s[1]) {
+ s++;
+ switch (*s) {
+ default:
+ if (!makesingle && (!leave || index(leave,*s)))
+ *d++ = '\\';
+ *d++ = *s++;
+ continue;
+ case '0': case '1': case '2': case '3':
+ case '4': case '5': case '6': case '7':
+ *d = *s++ - '0';
+ if (index("01234567",*s)) {
+ *d <<= 3;
+ *d += *s++ - '0';
+ }
+ if (index("01234567",*s)) {
+ *d <<= 3;
+ *d += *s++ - '0';
+ }
+ d++;
+ continue;
+ case 'b':
+ *d++ = '\b';
+ break;
+ case 'n':
+ *d++ = '\n';
+ break;
+ case 'r':
+ *d++ = '\r';
+ break;
+ case 'f':
+ *d++ = '\f';
+ break;
+ case 't':
+ *d++ = '\t';
+ break;
+ }
+ s++;
+ continue;
+ }
+ *d++ = *s++;
+ }
+ *d = '\0';
+
+ if (arg[1].arg_type == A_DOUBLE && makesingle)
+ arg[1].arg_type = A_SINGLE; /* now we can optimize on it */
+
+ tmpstr->str_cur = d - tmpstr->str_ptr; /* XXX cheat */
+ arg[1].arg_ptr.arg_str = tmpstr;
+ s = tmps;
+ break;
+ }
+ }
+ return s;
+}
+
+FCMD *
+load_format()
+{
+ FCMD froot;
+ FCMD *flinebeg;
+ register FCMD *fprev = &froot;
+ register FCMD *fcmd;
+ register char *s;
+ register char *t;
+ register char tmpchar;
+ bool noblank;
+
+ while ((s = str_gets(linestr,rsfp)) != Nullch) {
+ line++;
+ if (strEQ(s,".\n")) {
+ bufptr = s;
+ return froot.f_next;
+ }
+ if (*s == '#')
+ continue;
+ flinebeg = Nullfcmd;
+ noblank = FALSE;
+ while (*s) {
+ fcmd = (FCMD *)safemalloc(sizeof (FCMD));
+ bzero((char*)fcmd, sizeof (FCMD));
+ fprev->f_next = fcmd;
+ fprev = fcmd;
+ for (t=s; *t && *t != '@' && *t != '^'; t++) {
+ if (*t == '~') {
+ noblank = TRUE;
+ *t = ' ';
+ }
+ }
+ tmpchar = *t;
+ *t = '\0';
+ fcmd->f_pre = savestr(s);
+ fcmd->f_presize = strlen(s);
+ *t = tmpchar;
+ s = t;
+ if (!*s) {
+ if (noblank)
+ fcmd->f_flags |= FC_NOBLANK;
+ break;
+ }
+ if (!flinebeg)
+ flinebeg = fcmd; /* start values here */
+ if (*s++ == '^')
+ fcmd->f_flags |= FC_CHOP; /* for doing text filling */
+ switch (*s) {
+ case '*':
+ fcmd->f_type = F_LINES;
+ *s = '\0';
+ break;
+ case '<':
+ fcmd->f_type = F_LEFT;
+ while (*s == '<')
+ s++;
+ break;
+ case '>':
+ fcmd->f_type = F_RIGHT;
+ while (*s == '>')
+ s++;
+ break;
+ case '|':
+ fcmd->f_type = F_CENTER;
+ while (*s == '|')
+ s++;
+ break;
+ default:
+ fcmd->f_type = F_LEFT;
+ break;
+ }
+ if (fcmd->f_flags & FC_CHOP && *s == '.') {
+ fcmd->f_flags |= FC_MORE;
+ while (*s == '.')
+ s++;
+ }
+ fcmd->f_size = s-t;
+ }
+ if (flinebeg) {
+ again:
+ if ((bufptr = str_gets(linestr ,rsfp)) == Nullch)
+ goto badform;
+ line++;
+ if (strEQ(bufptr,".\n")) {
+ yyerror("Missing values line");
+ return froot.f_next;
+ }
+ if (*bufptr == '#')
+ goto again;
+ lex_newlines = TRUE;
+ while (flinebeg || *bufptr) {
+ switch(yylex()) {
+ default:
+ yyerror("Bad value in format");
+ *bufptr = '\0';
+ break;
+ case '\n':
+ if (flinebeg)
+ yyerror("Missing value in format");
+ *bufptr = '\0';
+ break;
+ case REG:
+ yylval.arg = 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);
+ }
+ break;
+ case ',': case ';':
+ continue;
+ }
+ }
+ lex_newlines = FALSE;
+ }
+ }
+ badform:
+ bufptr = str_get(linestr);
+ yyerror("Format not terminated");
+ return froot.f_next;
+}
-/* $Header: util.c,v 1.0.1.1 88/01/28 11:06:35 root Exp $
+/* $Header: util.c,v 2.0 88/06/05 00:15:11 root Exp $
*
* $Log: util.c,v $
- * Revision 1.0.1.1 88/01/28 11:06:35 root
- * patch8: changed fatal() to support eval operator with exiting.
- *
- * Revision 1.0 87/12/18 13:06:30 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:11 root
+ * Baseline version 2.0.
*
*/
-#include <stdio.h>
-
-#include "handy.h"
#include "EXTERN.h"
-#include "search.h"
#include "perl.h"
-#include "INTERN.h"
-#include "util.h"
#define FLUSH
-#define MEM_SIZE unsigned int
static char nomem[] = "Out of memory!\n";
/* paranoid version of malloc */
+#ifdef DEBUGGING
static int an = 0;
+#endif
char *
safemalloc(size)
char *ptr;
char *realloc();
+ if (!where)
+ fatal("Null realloc");
ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
#ifdef DEBUGGING
if (debug & 128) {
if (debug & 128)
fprintf(stderr,"0x%x: (%05d) free\n",where,an++);
#endif
- free(where);
+ if (where) {
+ free(where);
+ }
}
+#ifdef NOTDEF
/* safe version of string copy */
char *
*dest = '\0';
return to;
}
+#endif /*NOTDEF*/
#ifdef undef
/* safe version of string concatenate, with \n deletion and space padding */
register int delim;
{
for (; *from; from++,to++) {
- if (*from == '\\' && from[1] == delim)
- from++;
+ if (*from == '\\') {
+ if (from[1] == delim)
+ from++;
+ else if (from[1] == '\\')
+ *to++ = *from++;
+ }
else if (*from == delim)
break;
*to = *from;
}
/* return ptr to little string in big string, NULL if not found */
+/* This routine was donated by Corey Satten. */
char *
instr(big, little)
-char *big, *little;
+register char *big;
+register char *little;
+{
+ register char *s, *x;
+ register int first = *little++;
+
+ if (!first)
+ return big;
+ while (*big) {
+ if (*big++ != first)
+ continue;
+ for (x=big,s=little; *s; /**/ ) {
+ if (!*x)
+ return Nullch;
+ if (*s++ != *x++) {
+ s--;
+ break;
+ }
+ }
+ if (!*s)
+ return big-1;
+ }
+ return Nullch;
+}
+#ifdef NOTDEF
+void
+bmcompile(str)
+STR *str;
{
- register char *t, *s, *x;
+ register char *s;
+ register char *table;
+ register int i;
+ register int len = str->str_cur;
+
+ str_grow(str,len+128);
+ s = str->str_ptr;
+ table = s + len;
+ for (i = 1; i < 128; i++) {
+ table[i] = len;
+ }
+ i = 0;
+ while (*s) {
+ if (!isascii(*s))
+ return;
+ if (table[*s] == len)
+ table[*s] = i;
+ s++,i++;
+ }
+ str->str_pok |= 2; /* deep magic */
+}
+#endif /* NOTDEF */
+
+static unsigned char freq[] = {
+ 1, 2, 84, 151, 154, 155, 156, 157,
+ 165, 246, 250, 3, 158, 7, 18, 29,
+ 40, 51, 62, 73, 85, 96, 107, 118,
+ 129, 140, 147, 148, 149, 150, 152, 153,
+ 255, 182, 224, 205, 174, 176, 180, 217,
+ 233, 232, 236, 187, 235, 228, 234, 226,
+ 222, 219, 211, 195, 188, 193, 185, 184,
+ 191, 183, 201, 229, 181, 220, 194, 162,
+ 163, 208, 186, 202, 200, 218, 198, 179,
+ 178, 214, 166, 170, 207, 199, 209, 206,
+ 204, 160, 212, 216, 215, 192, 175, 173,
+ 243, 172, 161, 190, 203, 189, 164, 230,
+ 167, 248, 227, 244, 242, 255, 241, 231,
+ 240, 253, 169, 210, 245, 237, 249, 247,
+ 239, 168, 252, 251, 254, 238, 223, 221,
+ 213, 225, 177, 197, 171, 196, 159, 4,
+ 5, 6, 8, 9, 10, 11, 12, 13,
+ 14, 15, 16, 17, 19, 20, 21, 22,
+ 23, 24, 25, 26, 27, 28, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 41, 42, 43, 44, 45, 46, 47, 48,
+ 49, 50, 52, 53, 54, 55, 56, 57,
+ 58, 59, 60, 61, 63, 64, 65, 66,
+ 67, 68, 69, 70, 71, 72, 74, 75,
+ 76, 77, 78, 79, 80, 81, 82, 83,
+ 86, 87, 88, 89, 90, 91, 92, 93,
+ 94, 95, 97, 98, 99, 100, 101, 102,
+ 103, 104, 105, 106, 108, 109, 110, 111,
+ 112, 113, 114, 115, 116, 117, 119, 120,
+ 121, 122, 123, 124, 125, 126, 127, 128,
+ 130, 131, 132, 133, 134, 135, 136, 137,
+ 138, 139, 141, 142, 143, 144, 145, 146
+};
- for (t = big; *t; t++) {
- for (x=t,s=little; *s; x++,s++) {
+void
+fbmcompile(str)
+STR *str;
+{
+ register char *s;
+ register 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++) {
+ table[i] = len;
+ }
+ i = 0;
+ while (s >= str->str_ptr) {
+ if (!isascii(*s))
+ return;
+ if (table[*s] == len)
+ table[*s] = i;
+ s--,i++;
+ }
+ str->str_pok |= 2; /* 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]];
+ }
+ }
+ str->str_rare = s[rarest];
+ str->str_prev = rarest;
+#ifdef DEBUGGING
+ if (debug & 512)
+ fprintf(stderr,"rarest char %c at %d\n",str->str_rare, str->str_prev);
+#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;
+STR *littlestr;
+{
+ register 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();
+
+ if (littlestr->str_pok != 3)
+ return instr(big,littlestr->str_ptr);
+
+ 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;
+ }
+ 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;
+ }
+ return s;
+ }
+ }
+ return Nullch;
+}
+
+char *
+screaminstr(bigstr, littlestr)
+STR *bigstr;
+STR *littlestr;
+{
+ register char *s, *x;
+ register char *big = bigstr->str_ptr;
+ register int pos;
+ register int previous;
+ register int first;
+ register char *little;
+
+ if ((pos = screamfirst[littlestr->str_rare]) < 0)
+ return Nullch;
+ little = littlestr->str_ptr;
+ first = *little++;
+ previous = littlestr->str_prev;
+ big -= previous;
+ while (pos < previous) {
+ if (!(pos += screamnext[pos]))
+ return Nullch;
+ }
+ do {
+ if (big[pos] != first)
+ continue;
+ for (x=big+pos+1,s=little; *s; /**/ ) {
if (!*x)
return Nullch;
- if (*s != *x)
+ if (*s++ != *x++) {
+ s--;
break;
+ }
}
if (!*s)
- return t;
- }
+ return big+pos;
+ } while (pos += screamnext[pos]);
return Nullch;
}
}
}
+extern int errno;
+
+/*VARARGS1*/
+mess(pat,a1,a2,a3,a4)
+char *pat;
+{
+ char *s;
+
+ s = tokenbuf;
+ sprintf(s,pat,a1,a2,a3,a4);
+ s += strlen(s);
+ if (s[-1] != '\n') {
+ if (line) {
+ 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);
+ s += strlen(s);
+ }
+ strcpy(s,".\n");
+ }
+}
+
/*VARARGS1*/
fatal(pat,a1,a2,a3,a4)
char *pat;
extern FILE *e_fp;
extern char *e_tmpname;
+ mess(pat,a1,a2,a3,a4);
if (in_eval) {
- sprintf(tokenbuf,pat,a1,a2,a3,a4);
str_set(stabent("@",TRUE)->stab_val,tokenbuf);
longjmp(eval_env,1);
}
- fprintf(stderr,pat,a1,a2,a3,a4);
+ fputs(tokenbuf,stderr);
+ fflush(stderr);
if (e_fp)
UNLINK(e_tmpname);
- exit(1);
+ statusvalue >>= 8;
+ exit(errno?errno:(statusvalue?statusvalue:255));
+}
+
+/*VARARGS1*/
+warn(pat,a1,a2,a3,a4)
+char *pat;
+{
+ mess(pat,a1,a2,a3,a4);
+ fputs(tokenbuf,stderr);
+ fflush(stderr);
}
static bool firstsetenv = TRUE;
#endif /* lint */
environ[i+1] = Nullch; /* make sure it's null terminated */
}
- environ[i] = safemalloc(strlen(nam) + strlen(val) + 2);
+ environ[i] = safemalloc((MEM_SIZE)(strlen(nam) + strlen(val) + 2));
/* this may or may not be in */
/* the old environ structure */
sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
} /* potential SEGV's */
return i;
}
+
+#ifdef EUNICE
+unlnk(f) /* unlink all versions of a file */
+char *f;
+{
+ int i;
+
+ for (i = 0; unlink(f) >= 0; i++) ;
+ return i ? 0 : -1;
+}
+#endif
+
+#ifndef BCOPY
+#ifndef MEMCPY
+char *
+bcopy(from,to,len)
+register char *from;
+register char *to;
+register int len;
+{
+ char *retval = to;
+
+ while (len--)
+ *to++ = *from++;
+ return retval;
+}
+
+char *
+bzero(loc,len)
+register char *loc;
+register int len;
+{
+ char *retval = loc;
+
+ while (len--)
+ *loc++ = 0;
+ return retval;
+}
+#endif
+#endif
-/* $Header: util.h,v 1.0 87/12/18 13:06:33 root Exp $
+/* $Header: util.h,v 2.0 88/06/05 00:15:15 root Exp $
*
* $Log: util.h,v $
- * Revision 1.0 87/12/18 13:06:33 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:15 root
+ * Baseline version 2.0.
*
*/
-/* is the string for makedir a directory name or a filename? */
+int *screamfirst INIT(Null(int*));
+int *screamnext INIT(Null(int*));
+int *screamcount INIT(Null(int*));
-#define MD_DIR 0
-#define MD_FILE 1
-
-void util_init();
-int doshell();
char *safemalloc();
char *saferealloc();
-char *safecpy();
-char *safecat();
char *cpytill();
char *instr();
-#ifdef SETUIDGID
- int eaccess();
-#endif
-char *getwd();
-void cat();
-void prexit();
+char *bminstr();
+char *fbminstr();
+char *screaminstr();
+void bmcompile();
+void fbmcompile();
char *get_a_line();
char *savestr();
-int makedir();
void setenv();
int envix();
-void notincl();
-char *getval();
void growstr();
-void setdef();
-/* $Header: version.c,v 1.0 87/12/18 13:06:41 root Exp $
+/* $Header: version.c,v 2.0 88/06/05 00:15:21 root Exp $
*
* $Log: version.c,v $
- * Revision 1.0 87/12/18 13:06:41 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:21 root
+ * Baseline version 2.0.
*
*/
-/* $Header: EXTERN.h,v 1.0 87/12/18 13:06:44 root Exp $
+/* $Header: EXTERN.h,v 2.0 88/06/05 00:15:24 root Exp $
*
* $Log: EXTERN.h,v $
- * Revision 1.0 87/12/18 13:06:44 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:24 root
+ * Baseline version 2.0.
*
*/
-/* $Header: INTERN.h,v 1.0 87/12/18 13:06:48 root Exp $
+/* $Header: INTERN.h,v 2.0 88/06/05 00:15:27 root Exp $
*
* $Log: INTERN.h,v $
- * Revision 1.0 87/12/18 13:06:48 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:27 root
+ * Baseline version 2.0.
*
*/
ln ../../../config.sh . || \
(echo "Can't find config.sh."; exit 1)
fi
- . config.sh
+ . ./config.sh
;;
esac
case "$0" in
esac
echo "Extracting x2p/Makefile (with variable substitutions)"
cat >Makefile <<!GROK!THIS!
-# $Header: Makefile.SH,v 1.0.1.1 88/01/26 14:15:24 root Exp $
+# $Header: Makefile.SH,v 2.0 88/06/05 00:15:31 root Exp $
#
# $Log: Makefile.SH,v $
-# Revision 1.0.1.1 88/01/26 14:15:24 root
-# Added mallocsrc stuff.
-#
-# Revision 1.0 87/12/18 17:50:17 root
-# Initial revision
+# Revision 2.0 88/06/05 00:15:31 root
+# Baseline version 2.0.
#
#
$(CC) $(LDFLAGS) $(LARGE) $(obj) a2p.o $(libs) -o a2p
a2p.c: a2p.y
- @ echo Expect 107 shift/reduce errors...
+ @ echo Expect 103 shift/reduce errors...
yacc a2p.y
mv y.tab.c a2p.c
-a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h
+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...
install: a2p s2p
# won't work with csh
export PATH || exit 1
- - mv $(bin)/a2p $(bin)/a2p.old
+ - mv $(bin)/a2p $(bin)/a2p.old 2>/dev/null
- mv $(bin)/s2p $(bin)/s2p.old
- if test `pwd` != $(bin); then cp $(public) $(bin); fi
cd $(bin); \
for pub in $(public); do \
-chmod 755 `basename $$pub`; \
+chmod +x `basename $$pub`; \
done
- - test $(bin) = /bin || rm -f /bin/a2p
-# chmod 755 makedir
-# - makedir `filexp $(lib)`
+# chmod +x makedir
+# - ./makedir `filexp $(lib)`
# - \
#if test `pwd` != `filexp $(lib)`; then \
#cp $(private) `filexp $(lib)`; \
#fi
# cd `filexp $(lib)`; \
#for priv in $(private); do \
-#chmod 755 `basename $$priv`; \
+#chmod +x `basename $$priv`; \
#done
- if test `pwd` != $(mansrc); then \
for page in $(manpages); do \
-/* $Header: a2p.h,v 1.0.1.2 88/02/01 17:33:40 root Exp $
+/* $Header: a2p.h,v 2.0 88/06/05 00:15:33 root Exp $
*
* $Log: a2p.h,v $
- * Revision 1.0.1.2 88/02/01 17:33:40 root
- * patch12: forgot to fix #define YYDEBUG; bug in a2p.
- *
- * Revision 1.0.1.1 88/01/26 09:52:30 root
- * patch 5: a2p didn't use config.h.
- *
- * Revision 1.0 87/12/18 13:06:58 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:33 root
+ * Baseline version 2.0.
*
*/
#include <stdio.h>
#include <ctype.h>
-#include <setjmp.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <time.h>
-#include <sys/times.h>
typedef struct string STR;
typedef struct htbl HASH;
.rn '' }`
-''' $Header: a2p.man,v 1.0 87/12/18 17:23:56 root Exp $
+''' $Header: a2p.man,v 2.0 88/06/05 00:15:36 root Exp $
'''
''' $Log: a2p.man,v $
-''' Revision 1.0 87/12/18 17:23:56 root
-''' Initial revision
+''' Revision 2.0 88/06/05 00:15:36 root
+''' Baseline version 2.0.
'''
'''
.de Sh
''' string Tr holds user defined translation string.
''' Bell System Logo is used as a dummy character.
'''
-.tr \(bs-|\(bv\*(Tr
+.tr \(*W-|\(bv\*(Tr
.ie n \{\
-.ds -- \(bs-
-.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch
-.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\h'-8u'-\" diablo 12 pitch
+.ds -- \(*W-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
.ds L" ""
.ds R" ""
.ds L' '
%{
-/* $Header: a2p.y,v 1.0 87/12/18 13:07:05 root Exp $
+/* $Header: a2p.y,v 2.0 88/06/05 00:15:38 root Exp $
*
* $Log: a2p.y,v $
- * Revision 1.0 87/12/18 13:07:05 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:38 root
+ * Baseline version 2.0.
*
*/
{ root = oper4(OPROG,$1,$2,$3,$4); }
;
-begin : BEGIN '{' states '}' junk
- { $$ = oper2(OJUNK,$3,$5); in_begin = FALSE; }
+begin : BEGIN '{' maybe states '}' junk
+ { $$ = oper3(OJUNK,$3,$4,$6); in_begin = FALSE; }
| /* NULL */
{ $$ = Nullop; }
;
-end : END '{' states '}'
- { $$ = $3; }
+end : END '{' maybe states '}'
+ { $$ = oper2(OJUNK,$3,$4); }
| end NEWLINE
{ $$ = $1; }
| /* NULL */
hunk : patpat
{ $$ = oper1(OHUNK,$1); need_entire = TRUE; }
- | patpat '{' states '}'
- { $$ = oper2(OHUNK,$1,$3); }
- | '{' states '}'
- { $$ = oper2(OHUNK,Nullop,$2); }
+ | patpat '{' maybe states '}'
+ { $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); }
+ | '{' maybe states '}'
+ { $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); }
;
patpat : pat
;
match : expr MATCHOP REGEX
- { $$ = oper3(OMATCHOP,$2,$1,$3); }
+ { $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); }
| '(' match ')'
{ $$ = oper1(OMPAREN,$2); }
;
{ $$ = oper1(OVFLD,$2); }
;
-maybe : NEWLINE
- { $$ = oper0(ONEWLINE); }
- | /* NULL */
- { $$ = Nullop; }
- | COMMENT
- { $$ = oper1(OCOMMENT,$1); }
- ;
-
print_list
: expr
| clist
{ $$ = oper1(OCOMMENT,$1); }
;
-separator
- : ';'
- { $$ = oper0(OSEMICOLON); }
- | SEMINEW
- { $$ = oper0(OSNEWLINE); }
- | NEWLINE
- { $$ = oper0(OSNEWLINE); }
+maybe : maybe nlstuff
+ { $$ = oper2(OJUNK,$1,$2); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+nlstuff : NEWLINE
+ { $$ = oper0(ONEWLINE); }
| COMMENT
- { $$ = oper1(OSCOMMENT,$1); }
+ { $$ = oper1(OCOMMENT,$1); }
+ ;
+
+separator
+ : ';' maybe
+ { $$ = oper2(OJUNK,oper0(OSEMICOLON),$2); }
+ | SEMINEW maybe
+ { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
+ | NEWLINE maybe
+ { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
+ | COMMENT maybe
+ { $$ = oper2(OJUNK,oper1(OSCOMMENT,$1),$2); }
;
states : states statement
;
statement
- : simple separator
- { $$ = oper2(OSTATE,$1,$2); }
+ : simple separator maybe
+ { $$ = oper2(OJUNK,oper2(OSTATE,$1,$2),$3); }
+ | ';' maybe
+ { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),$2)); }
+ | SEMINEW maybe
+ { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),$2)); }
| compound
;
+simpnull: simple
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
simple
: expr
| PRINT print_list redir expr
{ $$ = oper1(OEXIT,$2); }
| CONTINUE
{ $$ = oper0(OCONTINUE); }
- | /* NULL */
- { $$ = Nullop; }
;
redir : RELOP
{ $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); }
| WHILE '(' cond ')' maybe statement
{ $$ = oper2(OWHILE,$3,bl($6,$5)); }
- | FOR '(' simple ';' cond ';' simple ')' maybe statement
+ | FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement
{ $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); }
- | FOR '(' simple ';' ';' simple ')' maybe statement
+ | 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)); }
- | '{' states '}'
- { $$ = oper1(OBLOCK,$2); }
+ | '{' maybe states '}' maybe
+ { $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); }
;
%%
-/* $Header: a2py.c,v 1.0.1.1 88/01/28 11:07:08 root Exp $
+/* $Header: a2py.c,v 2.0 88/06/05 00:15:41 root Exp $
*
* $Log: a2py.c,v $
- * Revision 1.0.1.1 88/01/28 11:07:08 root
- * patch8: added support for FOO=bar switches using eval.
- *
- * Revision 1.0 87/12/18 17:50:33 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:41 root
+ * Baseline version 2.0.
*
*/
char *filename;
+int checkers = 0;
+
main(argc,argv,env)
register int argc;
register char **argv;
/* second pass to produce new program */
tmpstr = walk(0,0,root,&i);
- str = str_make("#!/bin/perl\n\n");
+ str = str_make("#!/usr/bin/perl\neval \"exec /usr/bin/perl -S $0 $*\"\n\
+ if $running_under_some_shell;\n\
+ # this emulates #! processing on NIH machines.\n\
+ # (remove #! line above if indigestible)\n\n");
str_cat(str,
"eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;\n");
str_cat(str,
#endif
fixup(str);
putlines(str);
+ if (checkers) {
+ fprintf(stderr,
+ "Please check my work on the %d line%s I've marked with \"#???\".\n",
+ checkers, checkers == 1 ? "" : "s" );
+ fprintf(stderr,
+ "The operation I've selected may be wrong for the operand types.\n");
+ }
exit(0);
}
XTERM(tmp);
case '~':
s++;
+ yylval = string("~",1);
XTERM(MATCHOP);
case '+':
case '-':
case '>':
s++;
tmp = *s++;
+ if (tmp == '>') {
+ yylval = string(">>",2);
+ XTERM(GRGR);
+ }
if (tmp == '=') {
yylval = string(">=",2);
XTERM(RELOP);
default:
fatal("Search pattern not found:\n%s",str_get(linestr));
}
- s = cpytill(tokenbuf,s,s[-1]);
+
+ d = tokenbuf;
+ for (; *s; s++,d++) {
+ if (*s == '\\') {
+ if (s[1] == '/')
+ *d++ = *s++;
+ else if (s[1] == '\\')
+ *d++ = *s++;
+ }
+ else if (*s == '[') {
+ *d++ = *s++;
+ do {
+ if (*s == '\\' && s[1])
+ *d++ = *s++;
+ if (*s == '/' || (*s == '-' && s[1] == ']'))
+ *d++ = '\\';
+ *d++ = *s++;
+ } while (*s && *s != ']');
+ }
+ else if (*s == '/')
+ break;
+ *d = *s;
+ }
+ *d = '\0';
+
if (!*s)
fatal("Search pattern not terminated:\n%s",str_get(linestr));
s++;
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9': case '0' : case '.':
d = tokenbuf;
- while (isdigit(*s) || *s == '_')
- *d++ = *s++;
- if (*s == '.' && index("0123456789eE",s[1]))
- *d++ = *s++;
- while (isdigit(*s) || *s == '_')
- *d++ = *s++;
- if (index("eE",*s) && index("+-0123456789",s[1]))
+ while (isdigit(*s)) {
*d++ = *s++;
- if (*s == '+' || *s == '-')
+ }
+ if (*s == '.' && index("0123456789eE",s[1])) {
*d++ = *s++;
- while (isdigit(*s))
+ while (isdigit(*s)) {
+ *d++ = *s++;
+ }
+ }
+ if (index("eE",*s) && index("+-0123456789",s[1])) {
*d++ = *s++;
+ if (*s == '+' || *s == '-')
+ *d++ = *s++;
+ while (isdigit(*s))
+ *d++ = *s++;
+ }
*d = '\0';
yylval = string(tokenbuf,0);
break;
return 0;
else if ((ops[arg].ival & 255) != OBLOCK)
return oper2(OBLOCK,arg,maybe);
- else if ((ops[arg].ival >> 8) != 2)
+ else if ((ops[arg].ival >> 8) < 2)
return oper2(OBLOCK,ops[arg+1].ival,maybe);
else
return arg;
if (*t == 127) {
*t = ' ';
strcpy(t+strlen(t)-1, "\t#???\n");
+ checkers++;
}
}
t = tokenbuf;
if (*t == '#') {
if (strnEQ(t,"#!/bin/awk",10) || strnEQ(t,"#! /bin/awk",11))
return;
+ if (strnEQ(t,"#!/usr/bin/awk",14) || strnEQ(t,"#! /usr/bin/awk",15))
+ return;
}
fputs(tokenbuf,stdout);
}
-/* $Header: handy.h,v 1.0 87/12/18 13:07:15 root Exp $
+/* $Header: handy.h,v 2.0 88/06/05 00:15:47 root Exp $
*
* $Log: handy.h,v $
- * Revision 1.0 87/12/18 13:07:15 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:47 root
+ * Baseline version 2.0.
*
*/
-/* $Header: hash.c,v 1.0 87/12/18 13:07:18 root Exp $
+/* $Header: hash.c,v 2.0 88/06/05 00:15:50 root Exp $
*
* $Log: hash.c,v $
- * Revision 1.0 87/12/18 13:07:18 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:50 root
+ * Baseline version 2.0.
*
*/
-/* $Header: hash.h,v 1.0 87/12/18 13:07:23 root Exp $
+/* $Header: hash.h,v 2.0 88/06/05 00:15:52 root Exp $
*
* $Log: hash.h,v $
- * Revision 1.0 87/12/18 13:07:23 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:15:52 root
+ * Baseline version 2.0.
*
*/
-#!/bin/perl
+#!/usr/bin/perl
+
+# $Header: s2p,v 2.0 88/06/05 00:15:55 root Exp $
+#
+# $Log: s2p,v $
+# Revision 2.0 88/06/05 00:15:55 root
+# Baseline version 2.0.
+#
+#
$indent = 4;
$shiftwidth = 4;
$assumep++;
next;
}
- die "I don't recognize this switch: $_";
+ die "I don't recognize this switch: $_\n";
}
unless ($debug) {
- open(body,">/tmp/sperl$$") || do Die("Can't open temp file.");
+ open(body,">/tmp/sperl$$") || do Die("Can't open temp file");
}
if (!$assumen && !$assumep) {
$nflag++;
next;
}
- die "I don\'t recognize this switch: $_";
+ die "I don\'t recognize this switch: $_\\n";
}
';
}
}
} else {
- do Die("Invalid second address at line $.: $_");
+ do Die("Invalid second address at line $.\n");
}
$addr1 .= " .. $addr2";
}
# a { to keep vi happy
+ s/^[ \t]+//;
if ($_ eq '}') {
$indent -= 4;
next;
close body;
unless ($debug) {
- open(head,">/tmp/sperl2$$") || do Die("Can't open temp file 2.\n");
+ open(head,">/tmp/sperl2$$.c") || do Die("Can't open temp file 2");
print head "#define PRINTIT\n" if ($printit);
print head "#define APPENDSEEN\n" if ($appendseen);
print head "#define TSEEN\n" if ($tseen);
print head "#define ASSUMEN\n" if ($assumen);
print head "#define ASSUMEP\n" if ($assumep);
if ($opens) {print head "$opens\n";}
- open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file.");
+ open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file");
while (<body>) {
print head $_;
}
close head;
print "#!/bin/perl\n\n";
- open(body,"cc -E /tmp/sperl2$$ |") ||
- do Die("Can't reopen temp file.");
+ open(body,"cc -E /tmp/sperl2$$.c |") ||
+ do Die("Can't reopen temp file");
while (<body>) {
/^# [0-9]/ && next;
/^[ \t]*$/ && next;
}
}
-`/bin/rm -f /tmp/sperl$$ /tmp/sperl2$$`;
+unlink "/tmp/sperl$$", "/tmp/sperl2$$";
sub Die {
- `/bin/rm -f /tmp/sperl$$ /tmp/sperl2$$`;
+ unlink "/tmp/sperl$$", "/tmp/sperl2$$";
die $_[0];
}
sub make_filehandle {
$_ = $first . $rest;
}
if (!$seen{$_}) {
- $opens .= "open($_,'>$fname') || die \"Can't create $fname.\";\n";
+ $opens .= "open($_,'>$fname') || die \"Can't create $fname\";\n";
}
$seen{$_} = $_;
}
$len++;
}
}
- print "repl $repl end $end $_\n";
- do Die("Malformed substitution at line $.") unless $end;
+ do Die("Malformed substitution at line $.\n") unless $end;
$pat = substr($_, 0, $repl + 1);
$repl = substr($_, $repl + 1, $end - $repl - 1);
$end = substr($_, $end + 1, 1000);
$dol = '$';
+ $repl =~ s/\$/\\$/;
$repl =~ s'&'$&'g;
$repl =~ s/[\\]([0-9])/$dol$1/g;
$subst = "$pat$repl$delim";
$end = '';
next;
}
- do Die("Unrecognized substitution command ($end) at line $.");
+ do Die("Unrecognized substitution command ($end) at line $.\n");
}
$_ = $subst . $cmd . ';';
next;
.rn '' }`
-''' $Header: s2p.man,v 1.0 87/12/18 17:37:16 root Exp $
+''' $Header: s2p.man,v 2.0 88/06/05 00:15:59 root Exp $
'''
''' $Log: s2p.man,v $
-''' Revision 1.0 87/12/18 17:37:16 root
-''' Initial revision
+''' Revision 2.0 88/06/05 00:15:59 root
+''' Baseline version 2.0.
'''
'''
.de Sh
''' string Tr holds user defined translation string.
''' Bell System Logo is used as a dummy character.
'''
-.tr \(bs-|\(bv\*(Tr
+.tr \(*W-|\(bv\*(Tr
.ie n \{\
-.ds -- \(bs-
-.if (\n(.H=4u)&(1m=24u) .ds -- \(bs\h'-12u'\(bs\h'-12u'-\" diablo 10 pitch
-.if (\n(.H=4u)&(1m=20u) .ds -- \(bs\h'-12u'\(bs\h'-8u'-\" diablo 12 pitch
+.ds -- \(*W-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
.ds L" ""
.ds R" ""
.ds L' '
-/* $Header: str.c,v 1.0 87/12/18 13:07:26 root Exp $
+/* $Header: str.c,v 2.0 88/06/05 00:16:02 root Exp $
*
* $Log: str.c,v $
- * Revision 1.0 87/12/18 13:07:26 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:16:02 root
+ * Baseline version 2.0.
*
*/
register char *bp; /* we're going to steal some values */
register int cnt; /* from the stdio struct and put EVERYTHING */
- register char *ptr; /* in the innermost loop into registers */
+ register STDCHAR *ptr; /* in the innermost loop into registers */
register char newline = '\n'; /* (assuming at least 6 registers) */
int i;
int bpx;
bp = str->str_ptr; /* move these two too to registers */
ptr = fp->_ptr;
for (;;) {
- while (--cnt >= 0) { /* this */ /* eat */
- if ((*bp++ = *ptr++) == newline) /* really */ /* dust */
- goto thats_all_folks; /* screams */ /* sed :-) */
+ while (--cnt >= 0) {
+ if ((*bp++ = *ptr++) == newline)
+ if (bp <= str->str_ptr || bp[-2] != '\\')
+ goto thats_all_folks;
+ else {
+ line++;
+ bp -= 2;
+ }
}
fp->_cnt = cnt; /* deregisterize cnt and ptr */
-/* $Header: str.h,v 1.0 87/12/18 13:07:30 root Exp $
+/* $Header: str.h,v 2.0 88/06/05 00:16:05 root Exp $
*
* $Log: str.h,v $
- * Revision 1.0 87/12/18 13:07:30 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:16:05 root
+ * Baseline version 2.0.
*
*/
-/* $Header: util.c,v 1.0 87/12/18 13:07:34 root Exp $
+/* $Header: util.c,v 2.0 88/06/05 00:16:07 root Exp $
*
* $Log: util.c,v $
- * Revision 1.0 87/12/18 13:07:34 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:16:07 root
+ * Baseline version 2.0.
*
*/
register int delim;
{
for (; *from; from++,to++) {
- if (*from == '\\' && from[1] == delim)
- *to++ = *from++;
+ if (*from == '\\') {
+ if (from[1] == delim)
+ from++;
+ else if (from[1] == '\\')
+ *to++ = *from++;
+ }
else if (*from == delim)
break;
*to = *from;
return from;
}
+
char *
cpy2(to,from,delim)
register char *to, *from;
register int delim;
{
for (; *from; from++,to++) {
- if (*from == '\\' && from[1] == delim)
+ if (*from == '\\')
*to++ = *from++;
else if (*from == '$')
*to++ = '\\';
-/* $Header: util.h,v 1.0 87/12/18 13:07:37 root Exp $
+/* $Header: util.h,v 2.0 88/06/05 00:16:10 root Exp $
*
* $Log: util.h,v $
- * Revision 1.0 87/12/18 13:07:37 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:16:10 root
+ * Baseline version 2.0.
*
*/
-/* $Header: walk.c,v 1.0.1.3 88/02/02 11:54:58 root Exp $
+/* $Header: walk.c,v 2.0 88/06/05 00:16:12 root Exp $
*
* $Log: walk.c,v $
- * Revision 1.0.1.3 88/02/02 11:54:58 root
- * patch14: got return value of each() backwards in translating 'for (a in b)'.
- *
- * Revision 1.0.1.2 88/02/01 17:34:05 root
- * patch12: made a2p take advantage of new awk-compatible split in perl.
- *
- * Revision 1.0.1.1 88/01/28 11:07:56 root
- * patch8: changed some misleading comments.
- *
- * Revision 1.0 87/12/18 13:07:40 root
- * Initial revision
+ * Revision 2.0 88/06/05 00:16:12 root
+ * Baseline version 2.0.
*
*/
bool exitval = FALSE;
bool realexit = FALSE;
+bool saw_getline = FALSE;
int maxtmp = 0;
+char *lparen;
+char *rparen;
STR *
walk(useval,level,node,numericptr)
}
if (exitval)
str_cat(str,"exit ExitValue;\n");
+ 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);
+ }
+ 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\
*d = *s;
}
*d = '\0';
+ for (d=tokenbuf; *d; d++)
+ *d += 128;
str_cat(str,tokenbuf);
str_free(tmpstr);
str_cat(str,"/");
break;
case OGETLINE:
str = str_new(0);
- str_set(str,"$_ = <>;\n");
- tab(str,level);
- if (do_chop) {
- str_cat(str,"chop;\t# strip record separator\n");
- tab(str,level);
- }
- if (do_split)
- emit_split(str,level);
+ str_set(str,"do Getline()");
+ saw_getline = TRUE;
break;
case OSPRINTF:
str = str_new(0);
case OSTR:
tmpstr = walk(1,level,ops[node+1].ival,&numarg);
s = "'";
- for (t = tmpstr->str_ptr; *t; t++) {
- if (*t == '\\' || *t == '\'')
+ for (t = tmpstr->str_ptr, d=tokenbuf; *t; d++,t++) {
+ if (*t == '\'')
+ s = "\"";
+ else if (*t == '\\') {
s = "\"";
- *t += 128;
+ *d++ = *t++ + 128;
+ switch (*t) {
+ case '\\': case '"': case 'n': case 't':
+ break;
+ default: /* hide this from perl */
+ *d++ = '\\' + 128;
+ }
+ }
+ *d = *t + 128;
}
+ *d = '\0';
str = str_new(0);
str_set(str,s);
- str_scat(str,tmpstr);
+ str_cat(str,tokenbuf);
str_free(tmpstr);
str_cat(str,s);
break;
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);
*tokenbuf = '\0';
str_free(tmpstr);
str_free(tmp2str);
+ lparen = "(";
+ rparen = ")";
}
}
else
strcpy(tokenbuf,"stdout");
+ str_cat(str,lparen); /* may be null */
if (type == OPRINTF)
str_cat(str,"printf");
else
else {
str_cat(str," $_");
}
+ str_cat(str,rparen); /* may be null */
str_free(tmpstr);
break;
case OLENGTH:
str_cat(str,"[]");
tmp2str = hfetch(symtab,str->str_ptr);
if (tmp2str && atoi(tmp2str->str_ptr)) {
- maxtmp++;
fstr=walk(1,level,ops[node+1].ival,&numarg);
sprintf(tokenbuf,
- "for ($T_%d = 1; ($%s = $%s[$T_%d]) || $T_%d <= $#%s; $T_%d++)%c",
- maxtmp,
+ "foreach $%s (@%s) ",
fstr->str_ptr,
- tmpstr->str_ptr,
- maxtmp,
- maxtmp,
- tmpstr->str_ptr,
- maxtmp,
- 0377);
+ tmpstr->str_ptr);
str_set(str,tokenbuf);
str_free(fstr);
str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
case OBLOCK:
str = str_new(0);
str_set(str,"{");
- if (len == 2) {
+ if (len >= 2 && ops[node+2].ival) {
str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg));
str_free(fstr);
}
fixtab(str,--level);
str_cat(str,"}\n");
tab(str,level);
+ if (len >= 3) {
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg));
+ str_free(fstr);
+ }
break;
default:
def:
https://perl5.git.perl.org / perl5.git / commitdiff