perl/Configure 755 473 0 163041 4747105015 6744 #! /bin/sh # # If these # comments don't work, trim them. Don't worry about any other # shell scripts, Configure will trim # comments from them for you. # # (If you are trying to port this package to a machine without sh, I would # suggest you cut out the prototypical config.h from the end of Configure # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # # $Header: Configure,v 3.0.1.5 90/02/28 16:17:50 lwall Locked $ # # 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:/usr/new:/usr/new/bin:/usr/nbin:$PATH" export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0; kill $$) if test ! -t 0; then echo "Say 'sh Configure', not 'sh /dev/null 2>&1 && \ echo "(I see you are using the Korn shell. Some ksh's blow up on Configure," && \ echo "especially on exotic machines. If yours does, try the Bourne shell instead.)" if test ! -d ../UU; then if test ! -d UU; then mkdir UU fi cd UU fi case "$1" in -d) shift; fastread='yes';; esac d_eunice='' define='' eunicefix='' loclist='' expr='' sed='' echo='' cat='' rm='' mv='' cp='' tail='' tr='' mkdir='' sort='' uniq='' grep='' trylist='' test='' inews='' egrep='' more='' pg='' Mcc='' vi='' mailx='' mail='' cpp='' perl='' emacs='' ls='' rmail='' sendmail='' shar='' smail='' tbl='' troff='' nroff='' uname='' uuname='' line='' chgrp='' chmod='' lint='' sleep='' pr='' tar='' ln='' lpr='' lp='' touch='' make='' date='' csh='' Log='' Header='' bin='' byteorder='' contains='' cppstdin='' cppminus='' d_bcmp='' d_bcopy='' d_bzero='' d_charsprf='' d_crypt='' cryptlib='' d_csh='' d_dosuid='' d_dup2='' d_fchmod='' d_fchown='' d_fcntl='' d_flock='' d_getgrps='' d_gethent='' d_getpgrp='' d_getpgrp2='' d_getprior='' d_htonl='' d_index='' d_ioctl='' d_killpg='' d_lstat='' d_memcmp='' d_memcpy='' d_mkdir='' d_ndbm='' d_odbm='' d_readdir='' d_rename='' d_rmdir='' d_setegid='' d_seteuid='' d_setpgrp='' d_setpgrp2='' d_setprior='' d_setregid='' d_setresgid='' d_setreuid='' d_setresuid='' d_setrgid='' d_setruid='' d_socket='' d_sockpair='' d_oldsock='' socketlib='' d_statblks='' d_stdstdio='' d_strctcpy='' d_strerror='' d_symlink='' d_syscall='' d_varargs='' d_vfork='' d_voidsig='' d_volatile='' d_vprintf='' d_charvspr='' d_wait4='' gidtype='' i_dirent='' d_dirnamlen='' i_fcntl='' i_grp='' i_niin='' i_pwd='' d_pwquota='' d_pwage='' d_pwchange='' d_pwclass='' d_pwexpire='' i_sysdir='' i_sysioctl='' i_sysndir='' i_time='' i_systime='' d_systimekernel='' i_utime='' i_varargs='' i_vfork='' intsize='' libc='' mallocsrc='' mallocobj='' usemymalloc='' mansrc='' manext='' models='' split='' small='' medium='' large='' huge='' optimize='' ccflags='' cppflags='' ldflags='' cc='' libs='' n='' c='' package='' randbits='' sig_name='' spitshell='' shsharp='' sharpbang='' startsh='' stdchar='' uidtype='' voidflags='' defvoidused='' yacc='' privlib='' lib='' CONFIG='' : set package name package=perl echo " " echo "Beginning of configuration questions for $package kit." : Eunice requires " " instead of "", can you believe it echo " " define='define' undef='undef' : change the next line if compiling for Xenix/286 on Xenix/386 xlibpth='/usr/lib/386 /lib/386' libpth='/usr/lib /usr/local/lib /usr/lib/large /lib '$xlibpth' /lib/large /usr/lib/small /lib/small' smallmach='pdp11 i8086 z8000 i80286 iAPX286' rmlist='kit[1-9]isdone kit[1-9][0-9]isdone' trap 'echo " "; rm -f $rmlist; exit 1' 1 2 3 : 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 : Now test for existence of everything in MANIFEST echo "First let's make sure your kit is complete. Checking..." (cd ..; awk '' `awk '$1 !~ /PACKINGLIST/ {print $1}' MANIFEST` >/dev/null || kill $$) echo "Looks good..." attrlist="mc68000 sun gcos unix ibm gimpel interdata tss os mert pyr" attrlist="$attrlist vax pdp11 i8086 z8000 u3b2 u3b5 u3b20 u3b200" attrlist="$attrlist hpux hp9000s300 hp9000s500 hp9000s800" attrlist="$attrlist ns32000 ns16000 iAPX286 mc300 mc500 mc700 sparc" attrlist="$attrlist nsc32000 sinix xenix venix posix ansi M_XENIX" attrlist="$attrlist $mc68k __STDC__ UTS M_I8086 M_I186 M_I286 M_I386" attrlist="$attrlist i186 __m88k__ m88k DGUX __DGUX__" pth="/usr/ucb /bin /usr/bin /usr/local /usr/local/bin /usr/lbin /usr/plx /usr/5bin /vol/local/bin /etc /usr/lib /lib /usr/local/lib /sys5.3/bin /sys5.3/usr/bin /bsd4.3/bin /bsd4.3/usr/bin /bsd4.3/usr/ucb" d_newshome="/usr/NeWS" defvoidused=7 libswanted="net_s net nsl_s nsl socket nm ndir ndbm dbm sun bsd BSD x c_s PW" inclwanted='/usr/netinclude /usr/include/sun /usr/include/bsd /usr/include/lan' : some greps do not return status, grrr. echo "grimblepritz" >grimble if grep blurfldyick grimble >/dev/null 2>&1 ; then contains=contains elif grep grimblepritz grimble >/dev/null 2>&1 ; then contains=grep else contains=contains fi rm -f grimble : the following should work in any shell case "$contains" in contains*) echo " " echo "AGH! Grep doesn't return a status. Attempting remedial action." cat >contains <<'EOSS' grep "$1" "$2" >.greptmp && cat .greptmp && test -s .greptmp EOSS chmod +x contains esac : see if sh knows # comments echo " " echo "Checking your sh to see if it knows about # comments..." if sh -c '#' >/dev/null 2>&1 ; then echo "Your sh handles # comments correctly." shsharp=true spitshell=cat echo " " echo "Okay, let's see if #! works on this system..." echo "#!/bin/echo hi" > try $eunicefix try chmod +x try ./try > today if $contains hi today >/dev/null 2>&1; then echo "It does." sharpbang='#!' else echo "#! /bin/echo hi" > try $eunicefix try chmod +x try ./try > today if test -s today; then echo "It does." sharpbang='#! ' else echo "It doesn't." sharpbang=': use ' fi fi else echo "Your sh doesn't grok # comments--I will strip them later on." shsharp=false echo "exec grep -v '^#'" >spitshell chmod +x spitshell $eunicefix spitshell spitshell=`pwd`/spitshell echo "I presume that if # doesn't work, #! won't work either!" sharpbang=': use ' fi : figure out how to guarantee sh startup echo " " echo "Checking out how to guarantee sh startup..." startsh=$sharpbang'/bin/sh' echo "Let's see if '$startsh' works..." cat >try <.echotmp if $contains c .echotmp >/dev/null 2>&1 ; then echo "...using -n." n='-n' c='' else cat <<'EOM' ...using \c EOM n='' c='\c' fi echo $n "Type carriage return to continue. Your cursor should be here-->$c" read ans rm -f .echotmp : now set up to do reads with possible shell escape and default assignment cat <myread case "\$fastread" in yes) ans=''; echo " " ;; *) ans='!';; esac while expr "X\$ans" : "X!" >/dev/null; do read ans case "\$ans" in !) sh echo " " echo $n "\$rp $c" ;; !*) set \`expr "X\$ans" : "X!\(.*\)\$"\` sh -c "\$*" echo " " echo $n "\$rp $c" ;; esac done rp='Your answer:' case "\$ans" in '') ans="\$dflt";; esac EOSC : general instructions cat <loc $startsh case \$# in 0) exit 1;; esac thing=\$1 shift dflt=\$1 shift for dir in \$*; do case "\$thing" in .) if test -d \$dir/\$thing; then echo \$dir exit 0 fi ;; *) if test -f \$dir/\$thing; then echo \$dir/\$thing exit 0 elif test -f \$dir/\$thing.exe; then : on Eunice apparently echo \$dir/\$thing exit 0 fi ;; esac done echo \$dflt exit 1 EOSC chmod +x loc $eunicefix loc loclist=" cat cp echo expr grep mkdir mv rm sed sort tr uniq " trylist=" Mcc cpp csh egrep test " for file in $loclist; do xxx=`loc $file $file $pth` eval $file=$xxx eval _$file=$xxx case "$xxx" in /*) echo $file is in $xxx. ;; *) echo "I don't know where $file is. I hope it's in everyone's PATH." ;; esac done echo " " echo "Don't worry if any of the following aren't found..." ans=offhand for file in $trylist; do xxx=`loc $file $file $pth` eval $file=$xxx eval _$file=$xxx case "$xxx" in /*) echo $file is in $xxx. ;; *) echo "I don't see $file out there, $ans." ans=either ;; esac done case "$egrep" in egrep) echo "Substituting grep for egrep." egrep=$grep ;; esac case "$test" in test) echo "Hopefully test is built into your sh." ;; /bin/test) if sh -c "PATH= test true" >/dev/null 2>&1; then echo "Using the test built into your sh." test=test fi ;; *) test=test ;; esac case "$echo" in echo) echo "Hopefully echo is built into your sh." ;; /bin/echo) echo " " echo "Checking compatibility between /bin/echo and builtin echo (if any)..." $echo $n "hi there$c" >foo1 echo $n "hi there$c" >foo2 if cmp foo1 foo2 >/dev/null 2>&1; then echo "They are compatible. In fact, they may be identical." else case "$n" in '-n') n='' c='\c' ans='\c' ;; *) n='-n' c='' ans='-n' ;; esac cat <filexp <&2 exit 1 fi case "\$1" in */*) echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\` ;; *) echo \$dir ;; esac fi ;; *) echo \$1 ;; esac EOSS chmod +x filexp $eunicefix filexp : determine where public executables go case "$bin" in '') dflt=`loc . /bin /usr/local/bin /usr/lbin /usr/local /usr/bin` ;; *) dflt="$bin" ;; esac cont=true while $test "$cont" ; do echo " " rp="Where do you want to put the public executables? [$dflt]" $echo $n "$rp $c" . myread bin="$ans" bin=`filexp $bin` if test -d $bin; then cont='' else case "$fastread" in yes) dflt=y;; *) dflt=n;; esac rp="Directory $bin doesn't exist. Use that name anyway? [$dflt]" $echo $n "$rp $c" . myread dflt='' case "$ans" in y*) cont='';; esac fi done : determine where manual pages go $cat <foo if test `echo abc | tr a-z A-Z` = Abc ; then echo "Looks kind of like a USG system, but we'll see..." echo exit 1 >bsd echo exit 0 >usg echo exit 1 >v7 elif $contains SIGTSTP foo >/dev/null 2>&1 ; then echo "Looks kind of like a BSD system, but we'll see..." echo exit 0 >bsd echo exit 1 >usg echo exit 1 >v7 else echo "Looks kind of like a version 7 system, but we'll see..." echo exit 1 >bsd echo exit 1 >usg echo exit 0 >v7 fi case "$eunicefix" in *unixtovms*) cat <<'EOI' There is, however, a strange, musty smell in the air that reminds me of something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit. EOI echo "exit 0" >eunice d_eunice="$define" ;; *) echo " " echo "Congratulations. You aren't running Eunice." d_eunice="$undef" echo "exit 1" >eunice ;; esac if test -f /xenix; then echo "Actually, this looks more like a XENIX system..." echo "exit 0" >xenix else echo " " echo "It's not Xenix..." echo "exit 1" >xenix fi chmod +x xenix $eunicefix xenix if test -f /venix; then echo "Actually, this looks more like a VENIX system..." echo "exit 0" >venix else echo " " if xenix; then : null else echo "Nor is it Venix..." fi echo "exit 1" >venix fi chmod +x bsd usg v7 eunice venix $eunicefix bsd usg v7 eunice venix rm -rf foo rmlist="$rmlist bsd usg v7 eunice venix xenix" : see what memory models we can support case "$models" in '') : We may not use Cppsym or we get a circular dependency through cc. : But this should work regardless of which cc we eventually use. cat >pdp11.c <<'EOP' main() { #ifdef pdp11 exit(0); #else exit(1); #endif } EOP cc -o pdp11 pdp11.c >/dev/null 2>&1 if pdp11 2>/dev/null; then dflt='unsplit split' else ans=`loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge` case "$ans" in X) dflt='none';; *) if $test -d /lib/small || $test -d /usr/lib/small; then dflt='small' else dflt='' fi if $test -d /lib/medium || $test -d /usr/lib/medium; then dflt="$dflt medium" fi if $test -d /lib/large || $test -d /usr/lib/large; then dflt="$dflt large" fi if $test -d /lib/huge || $test -d /usr/lib/huge; then dflt="$dflt huge" fi esac fi ;; *) dflt="$models" ;; esac $cat </dev/null 2>&1 || \ $contains '\-i' $mansrc/man1/cc.1 >/dev/null 2>&1; then dflt='-i' else dflt='none' fi ;; *) dflt="$split";; esac rp="What flag indicates separate I and D space? [$dflt]" $echo $n "$rp $c" . myread case "$ans" in none) ans='';; esac split="$ans" unsplit='' ;; *large*|*small*|*medium*|*huge*) case "$models" in *large*) case "$large" in '') dflt='-Ml';; *) dflt="$large";; esac rp="What flag indicates large model? [$dflt]" $echo $n "$rp $c" . myread case "$ans" in none) ans=''; esac large="$ans" ;; *) large='';; esac case "$models" in *huge*) case "$huge" in '') dflt='-Mh';; *) dflt="$huge";; esac rp="What flag indicates huge model? [$dflt]" $echo $n "$rp $c" . myread case "$ans" in none) ans=''; esac huge="$ans" ;; *) huge="$large";; esac case "$models" in *medium*) case "$medium" in '') dflt='-Mm';; *) dflt="$medium";; esac rp="What flag indicates medium model? [$dflt]" $echo $n "$rp $c" . myread case "$ans" in none) ans=''; esac medium="$ans" ;; *) medium="$large";; esac case "$models" in *small*) case "$small" in '') dflt='none';; *) dflt="$small";; esac rp="What flag indicates small model? [$dflt]" $echo $n "$rp $c" . myread case "$ans" in none) ans=''; esac small="$ans" ;; *) small='';; esac ;; *) echo "Unrecognized memory models--you may have to edit Makefile.SH" ;; esac : see if we need a special compiler echo " " if usg; then case "$cc" in '') case "$Mcc" in /*) dflt='Mcc' ;; *) case "$large" in -M*) dflt='cc' ;; *) if $contains '\-M' $mansrc/cc.1 >/dev/null 2>&1 ; then dflt='cc -M' else dflt='cc' fi ;; esac ;; esac ;; *) dflt="$cc";; esac $cat <<'EOM' On some systems the default C compiler will not resolve multiple global references that happen to have the same name. On some such systems the "Mcc" command may be used to force these to be resolved. On other systems a "cc -M" command is required. (Note that the -M flag on other systems indicates a memory model to use!) If you have the Gnu C compiler, you might wish to use that instead. What command will force resolution on EOM $echo $n "this system? [$dflt] $c" rp="Command to resolve multiple refs? [$dflt]" . myread cc="$ans" else case "$cc" in '') dflt=cc;; *) dflt="$cc";; esac rp="Use which C compiler? [$dflt]" $echo $n "$rp $c" . myread cc="$ans" fi case "$cc" in gcc*) cpp=`loc gcc-cpp $cpp $pth`;; esac : determine optimize, if desired, or use for debug flag also case "$optimize" in ' ') dflt="none" ;; '') dflt="-O"; ;; *) dflt="$optimize" ;; esac cat </dev/null 2>&1; then case "$dflt" in *LANGUAGE_C*);; *) dflt="$dflt -DLANGUAGE_C";; esac fi case "$dflt" in '') dflt=none;; esac cat <try.c <<'EOCP' #include main() { int i; union { unsigned long l; char c[sizeof(long)]; } u; if (sizeof(long) > 4) u.l = 0x0807060504030201; else u.l = 0x04030201; for (i=0; i < sizeof(long); i++) printf("%c",u.c[i]+'0'); printf("\n"); } EOCP if $cc try.c -o try >/dev/null 2>&1 ; then dflt=`./try` case "$dflt" in ????|????????) echo "(The test program ran ok.)";; *) echo "(The test program didn't run right for some reason.)";; esac else dflt='4321' echo "(I can't seem to compile the test program. Guessing big-endian...)" fi ;; *) echo " " dflt="$byteorder" ;; esac rp="What is the order of bytes in a long? [$dflt]" $echo $n "$rp $c" . myread byteorder="$ans" $rm -f try.c try : see how we invoke the C preprocessor echo " " echo "Now, how can we feed standard input to your C preprocessor..." cat <<'EOT' >testcpp.c #define ABC abc #define XYZ xyz ABC.XYZ EOT echo 'Maybe "'"$cc"' -E" will work...' $cc -E testcpp.out 2>&1 : try to force gcc preprocessor if that is the compiler they are using case $? in 0) cppstdin="$cc -E";; *) case "$cc" in *gcc*) cd .. echo 'Trying (cat >/tmp/$$.c; '"$cc"' -E /tmp/$$.c; rm /tmp/$$.c)' echo 'cat >/tmp/$$.c; '"$cc"' -E /tmp/$$.c; rm /tmp/$$.c' >cppstdin chmod 755 cppstdin cppstdin=`pwd`/cppstdin cppminus=''; cd UU $cppstdin testcpp.out 2>&1 ;; esac ;; esac if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, it does." cppstdin="$cc -E" cppminus=''; else echo 'Nope, maybe "'$cpp'" will work...' $cpp testcpp.out 2>&1 if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, it does." cppstdin="$cpp" cppminus=''; else echo 'No such luck...maybe "'$cpp' -" will work...' $cpp - testcpp.out 2>&1 if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "It works!" cppstdin="$cpp" cppminus='-'; else echo 'Nixed again...maybe "'"$cc"' -E -" will work...' $cc -E - testcpp.out 2>&1 if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Hooray, it works! I was beginning to wonder." cppstdin="$cc -E" cppminus='-'; else echo 'Nope...maybe "'"$cc"' -P" will work...' $cc -P testcpp.out 2>&1 if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, that does." cppstdin="$cc -P" cppminus=''; else echo 'Nope...maybe "'"$cc"' -P -" will work...' $cc -P - testcpp.out 2>&1 if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Yup, that does." cppstdin="$cc -P" cppminus='-'; else echo 'Hmm...perhaps you already told me...' case "$cppstdin" in '') ;; *) $cppstdin $cppminus testcpp.out 2>&1;; esac if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Hooray, you did! I was beginning to wonder." else echo 'Uh-uh. Time to get fancy...' cd .. echo 'Trying (cat >/tmp/$$.c; '"$cc"' -E /tmp/$$.c; rm /tmp/$$.c)' echo 'cat >/tmp/$$.c; '"$cc"' -E /tmp/$$.c; rm /tmp/$$.c' >cppstdin chmod 755 cppstdin cppstdin=`pwd`/cppstdin cppminus=''; cd UU $cppstdin testcpp.out 2>&1 if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "Eureka!." else dflt=blurfl $echo $n "No dice. I can't find a C preprocessor. Name one: $c" rp='Name a C preprocessor:' . myread cppstdin="$ans" $cppstdin testcpp.out 2>&1 if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then echo "OK, that will do." else echo "Sorry, I can't get that to work. Go find one." exit 1 fi fi fi fi fi fi fi fi fi rm -f testcpp.c testcpp.out : get list of predefined functions in a handy place echo " " case "$libc" in '') libc=unknown;; esac case "$libpth" in '') libpth='/lib /usr/lib /usr/local/lib';; esac case "$libs" in *-lc_s*) libc=`loc libc_s.a $libc $libpth` esac libnames=''; case "$libs" in '') ;; *) for thislib in $libs; do case "$thislib" in -l*) thislib=`expr X$thislib : 'X-l\(.*\)'` try=`loc lib$thislib.a blurfl/dyick $libpth` if test ! -f $try; then try=`loc lib$thislib blurfl/dyick $libpth` if test ! -f $try; then try=`loc $thislib blurfl/dyick $libpth` if test ! -f $try; then try=`loc Slib$thislib.a blurfl/dyick $xlibpth` if test ! -f $try; then try='' fi fi fi fi libnames="$libnames $try" ;; *) libnames="$libnames $thislib" ;; esac done ;; esac set /usr/lib/libc.so.[0-9]* eval set \$$# if test -f "$1"; then echo "Your shared C library is in $1." libc="$1" elif test -f $libc; then echo "Your C library is in $libc, like you said before." elif test -f /lib/libc.a; then echo "Your C library is in /lib/libc.a. You're normal." libc=/lib/libc.a else ans=`loc libc.a blurfl/dyick $libpth` if test ! -f "$ans"; then ans=`loc libc blurfl/dyick $libpth` fi if test ! -f "$ans"; then ans=`loc clib blurfl/dyick $libpth` fi if test ! -f "$ans"; then ans=`loc Slibc.a blurfl/dyick $xlibpth` fi if test ! -f "$ans"; then ans=`loc Mlibc.a blurfl/dyick $xlibpth` fi if test ! -f "$ans"; then ans=`loc Llibc.a blurfl/dyick $xlibpth` fi if test -f "$ans"; then echo "Your C library is in $ans, of all places." libc=$ans else cat </dev/null >libc.tmp $sed -n -e 's/^.* [AT] *_[_.]*//p' -e 's/^.* [AT] //p' libc.list if $contains '^printf$' libc.list >/dev/null 2>&1; then echo "done" else $sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p' libc.list $contains '^printf$' libc.list >/dev/null 2>&1 || \ $sed -n -e 's/^.* D __*//p' -e 's/^.* D //p' libc.list $contains '^printf$' libc.list >/dev/null 2>&1 || \ $sed -n -e 's/^_//' \ -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p' libc.list $contains '^printf$' libc.list >/dev/null 2>&1 || \ $sed -n -e 's/^.*|FUNC |GLOB .*|//p' libc.list if $contains '^printf$' libc.list >/dev/null 2>&1; then echo "done" else echo " " echo "nm didn't seem to work right." echo "Trying ar instead..." if ar t $libc > libc.tmp; then for thisname in $libnames; do ar t $thisname >>libc.tmp done $sed -e 's/\.o$//' < libc.tmp > libc.list echo "Ok." else echo "ar didn't seem to work right." echo "Maybe this is a Cray...trying bld instead..." if bld t $libc | $sed -e 's/.*\///' -e 's/\.o:.*$//' > libc.list; then for thisname in $libnames; do bld t $libnames | \ $sed -e 's/.*\///' -e 's/\.o:.*$//' >>libc.list ar t $thisname >>libc.tmp done echo "Ok." else echo "That didn't work either. Giving up." exit 1 fi fi fi fi inlibc='echo " "; if $contains "^$1\$" libc.list >/dev/null 2>&1; then echo "$1() found"; eval "$2=$define"; else echo "$1() not found"; eval "$2=$undef"; fi' rmlist="$rmlist libc.tmp libc.list" : see if bcmp exists set bcmp d_bcmp eval $inlibc : see if bcopy exists set bcopy d_bcopy eval $inlibc : see if bzero exists set bzero d_bzero eval $inlibc : see if sprintf is declared as int or pointer to char echo " " cat >.ucbsprf.c <<'EOF' main() { char buf[10]; exit((unsigned long)sprintf(buf,"%s","foo") > 10L); } EOF if $cc $ccflags .ucbsprf.c -o .ucbsprf >/dev/null 2>&1 && .ucbsprf; then echo "Your sprintf() returns (int)." d_charsprf="$undef" else echo "Your sprintf() returns (char*)." d_charsprf="$define" fi /bin/rm -f .ucbsprf.c .ucbsprf : see if vprintf exists echo " " if $contains '^vprintf$' libc.list >/dev/null 2>&1; then echo 'vprintf() found.' d_vprintf="$define" cat >.ucbsprf.c <<'EOF' #include main() { xxx("foo"); } xxx(va_alist) va_dcl { va_list args; char buf[10]; va_start(args); exit((unsigned long)vsprintf(buf,"%s",args) > 10L); } EOF if $cc $ccflags .ucbsprf.c -o .ucbsprf >/dev/null 2>&1 && .ucbsprf; then echo "Your vsprintf() returns (int)." d_charvspr="$undef" else echo "Your vsprintf() returns (char*)." d_charvspr="$define" fi /bin/rm -f .ucbsprf.c .ucbsprf else echo 'vprintf() not found.' d_vprintf="$undef" d_charvspr="$undef" fi : see if crypt exists echo " " if $contains '^crypt$' libc.list >/dev/null 2>&1; then echo 'crypt() found.' d_crypt="$define" cryptlib='' else cryptlib=`loc Slibcrypt.a "" $xlibpth` if $test -z "$cryptlib"; then cryptlib=`loc Mlibcrypt.a "" $xlibpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then cryptlib=`loc Llibcrypt.a "" $xlibpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then cryptlib=`loc libcrypt.a "" $libpth` else cryptlib=-lcrypt fi if $test -z "$cryptlib"; then echo 'crypt() not found.' d_crypt="$undef" else d_crypt="$define" fi fi : get csh whereabouts case "$csh" in 'csh') d_csh="$undef" ;; *) d_csh="$define" ;; esac : see if this is a dirent system echo " " if $test -r /usr/include/dirent.h ; then i_dirent="$define" echo "dirent.h found." if $contains 'd_namlen' /usr/include/sys/dirent.h >/dev/null 2>&1; then d_dirnamlen="$define" else d_dirnamlen="$undef" fi else i_dirent="$undef" if $contains 'd_namlen' /usr/include/sys/dir.h >/dev/null 2>&1; then d_dirnamlen="$define" else d_dirnamlen="$undef" fi echo "No dirent.h found." fi : now see if they want to do setuid emulation case "$d_dosuid" in '') dflt=n;; *undef*) dflt=n;; *) dflt=y;; esac cat </dev/null 2>&1 ; then 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 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 ioctl defs are in sgtty/termio or sys/ioctl echo " " if $test -r /usr/include/sys/ioctl.h ; then d_ioctl="$define" echo "sys/ioctl.h found." else d_ioctl="$undef" echo "sys/ioctl.h not found, assuming ioctl args are defined in sgtty.h." fi : see if killpg exists set killpg d_killpg eval $inlibc : see if lstat exists set lstat d_lstat eval $inlibc : see if memcmp exists set memcmp d_memcmp eval $inlibc : see if memcpy exists set memcpy d_memcpy eval $inlibc : see if mkdir exists set mkdir d_mkdir eval $inlibc : see if ndbm is available echo " " xxx=`loc ndbm.h x /usr/include /usr/local/include $inclwanted` if test -f $xxx; then d_ndbm="$define" echo "ndbm.h found." else d_ndbm="$undef" echo "ndbm.h not found." fi : see if we have the old dbm echo " " xxx=`loc dbm.h x /usr/include /usr/local/include $inclwanted` if test -f $xxx; then d_odbm="$define" echo "dbm.h found." else d_odbm="$undef" echo "dbm.h not found." fi : see if this is a pwd system echo " " if $test -r /usr/include/pwd.h ; then i_pwd="$define" echo "pwd.h found." $cppstdin $cppflags $$.h if $contains 'pw_quota' $$.h >/dev/null 2>&1; then d_pwquota="$define" else d_pwquota="$undef" fi if $contains 'pw_age' $$.h >/dev/null 2>&1; then d_pwage="$define" else d_pwage="$undef" fi if $contains 'pw_change' $$.h >/dev/null 2>&1; then d_pwchange="$define" else d_pwchange="$undef" fi if $contains 'pw_class' $$.h >/dev/null 2>&1; then d_pwclass="$define" else d_pwclass="$undef" fi if $contains 'pw_expire' $$.h >/dev/null 2>&1; then d_pwexpire="$define" else d_pwexpire="$undef" fi rm -f $$.h else i_pwd="$undef" d_pwquota="$undef" d_pwage="$undef" d_pwchange="$undef" d_pwclass="$undef" d_pwexpire="$undef" echo "No pwd.h found." fi : see if readdir exists set readdir d_readdir eval $inlibc : see if rename exists set rename d_rename eval $inlibc : see if rmdir exists set rmdir d_rmdir eval $inlibc : see if setegid exists set setegid d_setegid eval $inlibc : see if seteuid exists set seteuid d_seteuid eval $inlibc : see if setpgrp exists set setpgrp d_setpgrp eval $inlibc : see if setpgrp2 exists set setpgrp2 d_setpgrp2 eval $inlibc : see if setpriority exists set setpriority d_setprior eval $inlibc : see if setregid exists set setregid d_setregid eval $inlibc set setresgid d_setresgid eval $inlibc : see if setreuid exists set setreuid d_setreuid eval $inlibc set setresuid d_setresuid eval $inlibc : see if setrgid exists set setrgid d_setrgid eval $inlibc : see if setruid exists set setruid d_setruid eval $inlibc socketlib='' : see whether socket exists echo " " if $contains socket libc.list >/dev/null 2>&1; then echo "Looks like you have Berkeley networking support." d_socket="$define" : now check for advanced features if $contains setsockopt libc.list >/dev/null 2>&1; then d_oldsock="$undef" else echo "...but it uses the old 4.1c interface, rather than 4.2" d_oldsock="$define" fi else : hpux, for one, puts all the socket stuff in socklib.o if $contains socklib libc.list >/dev/null 2>&1; then echo "Looks like you have Berkeley networking support." d_socket="$define" : we will have to assume that it supports the 4.2 BSD interface d_oldsock="$undef" else echo "Hmmm...you don't have Berkeley networking in libc.a..." : look for an optional networking library if test -f /usr/lib/libnet.a; then (ar t /usr/lib/libnet.a || nm -g /usr/lib/libnet.a) 2>/dev/null >> libc.list if $contains socket libc.list >/dev/null 2>&1; then echo "but the Wollongong group seems to have hacked it in." socketlib="-lnet" d_socket="$define" : now check for advanced features if $contains setsockopt libc.list >/dev/null 2>&1; then d_oldsock="$undef" else echo "...using the old 4.1c interface, rather than 4.2" d_oldsock="$define" fi else echo "or even in libnet.a, which is peculiar." d_socket="$undef" d_oldsock="$undef" fi else echo "or anywhere else I see." d_socket="$undef" d_oldsock="$undef" fi fi fi if $contains socketpair libc.list >/dev/null 2>&1; then d_sockpair="$define" else d_sockpair="$undef" fi : see if stat knows about block sizes echo " " if $contains 'st_blocks;' /usr/include/sys/stat.h >/dev/null 2>&1 ; then if $contains 'st_blksize;' /usr/include/sys/stat.h >/dev/null 2>&1 ; then echo "Your stat knows about block sizes." d_statblks="$define" else echo "Your stat doesn't know about block sizes." d_statblks="$undef" fi else echo "Your stat doesn't know about block sizes." d_statblks="$undef" fi : see if stdio is really std echo " " if $contains 'char.*_ptr.*;' /usr/include/stdio.h >/dev/null 2>&1 ; then if $contains '_cnt;' /usr/include/stdio.h >/dev/null 2>&1 ; then echo "Your stdio is pretty std." d_stdstdio="$define" else echo "Your stdio isn't very std." d_stdstdio="$undef" fi else echo "Your stdio isn't very std." d_stdstdio="$undef" fi : check for structure copying echo " " echo "Checking to see if your C compiler can copy structs..." $cat >try.c <<'EOCP' main() { struct blurfl { int dyick; } foo, bar; foo = bar; } EOCP if $cc -c try.c >/dev/null 2>&1 ; then d_strctcpy="$define" echo "Yup, it can." else d_strctcpy="$undef" echo "Nope, it can't." fi $rm -f try.* : see if strerror exists set strerror d_strerror eval $inlibc : see if symlink exists set symlink d_symlink eval $inlibc : see if syscall exists set syscall d_syscall eval $inlibc : see if we should include time.h, sys/time.h, or both cat <<'EOM' Testing to see if we should include , or both. I'm now running the test program... EOM $cat >try.c <<'EOCP' #ifdef I_TIME #include #endif #ifdef I_SYSTIME #ifdef SYSTIMEKERNEL #define KERNEL #endif #include #endif main() { struct tm foo; #ifdef S_TIMEVAL struct timeval bar; #endif if (foo.tm_sec == foo.tm_sec) exit(0); #ifdef S_TIMEVAL if (bar.tv_sec == bar.tv_sec) exit(0); #endif exit(1); } EOCP flags='' for s_timeval in '-DS_TIMEVAL' ''; do for d_systimekernel in '' '-DSYSTIMEKERNEL'; do for i_time in '' '-DI_TIME'; do for i_systime in '-DI_SYSTIME' ''; do case "$flags" in '') echo Trying $i_time $i_systime $d_systimekernel $s_timeval if $cc try.c $ccflags \ $i_time $i_systime $d_systimekernel $s_timeval \ -o try >/dev/null 2>&1 ; then set X $i_time $i_systime $d_systimekernel $s_timeval shift flags="$*" echo Succeeded with $flags fi ;; esac done done done done case "$flags" in *SYSTIMEKERNEL*) d_systimekernel="$define";; *) d_systimekernel="$undef";; esac case "$flags" in *I_TIME*) i_time="$define";; *) i_time="$undef";; esac case "$flags" in *I_SYSTIME*) i_systime="$define";; *) i_systime="$undef";; esac $rm -f try.c try : see if this is a varargs system echo " " if $test -r /usr/include/varargs.h ; then d_varargs="$define" echo "varargs.h found." else d_varargs="$undef" echo "No varargs.h found, but that's ok (I hope)." fi : see if there is a vfork set vfork d_vfork eval $inlibc : see if signal is declared as pointer to function returning int or void echo " " $cppstdin $cppflags < /usr/include/signal.h >$$.tmp if $contains 'void.*signal' $$.tmp >/dev/null 2>&1 ; then echo "You have void (*signal())() instead of int." d_voidsig="$define" else echo "You have int (*signal())() instead of void." d_voidsig="$undef" fi rm -f $$.tmp : check for volatile keyword echo " " echo 'Checking to see if your C compiler knows about "volatile"...' $cat >try.c <<'EOCP' main() { volatile int foo; foo = foo; } EOCP if $cc -c try.c >/dev/null 2>&1 ; then d_volatile="$define" echo "Yup, it does." else d_volatile="$undef" echo "Nope, it doesn't." fi $rm -f try.* : see if there is a wait4 set wait4 d_wait4 eval $inlibc : check for void type echo " " $cat <try.c <<'EOCP' #if TRY & 1 void main() { #else main() { #endif extern void moo(); /* function returning void */ void (*goo)(); /* ptr to func returning void */ #if TRY & 2 void (*foo[10])(); #endif #if TRY & 4 if(goo == moo) { exit(0); } #endif exit(0); } EOCP if $cc -S -DTRY=$defvoidused try.c >.out 2>&1 ; then voidflags=$defvoidused echo "It appears to support void." if $contains warning .out >/dev/null 2>&1; then echo "However, you might get some warnings that look like this:" $cat .out fi else echo "Hmm, your compiler has some difficulty with void. Checking further..." if $cc -S -DTRY=1 try.c >/dev/null 2>&1 ; then echo "It supports 1..." if $cc -S -DTRY=3 try.c >/dev/null 2>&1 ; then voidflags=3 echo "And it supports 2 but not 4." else echo "It doesn't support 2..." if $cc -S -DTRY=5 try.c >/dev/null 2>&1 ; then voidflags=5 echo "But it supports 4." else voidflags=1 echo "And it doesn't support 4." fi fi else echo "There is no support at all for void." voidflags=0 fi fi esac dflt="$voidflags"; rp="Your void support flags add up to what? [$dflt]" $echo $n "$rp $c" . myread voidflags="$ans" $rm -f try.* .out : see what type gids are declared as in the kernel echo " " case "$gidtype" in '') if $contains 'getgroups.*short' /usr/lib/lint/llib-lc >/dev/null 2>&1; then dflt='short' elif $contains 'getgroups.*int' /usr/lib/lint/llib-lc >/dev/null 2>&1; then dflt='int' elif $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 "(The following only matters if you have getgroups().)" rp="What type are the group ids returned by getgroups()? [$dflt]" $echo $n "$rp $c" . myread gidtype="$ans" : see if this is an fcntl system echo " " if $test -r /usr/include/fcntl.h ; then i_fcntl="$define" echo "fcntl.h found." else i_fcntl="$undef" echo "No fcntl.h found, but that's ok." fi : see if this is an grp system echo " " if $test -r /usr/include/grp.h ; then i_grp="$define" echo "grp.h found." else i_grp="$undef" echo "No grp.h found." fi : see if this is a netinet/in.h system echo " " xxx=`loc netinet/in.h x /usr/include /usr/local/include $inclwanted` if test -f $xxx; then i_niin="$define" echo "netinet/in.h found." else i_niin="$undef" echo "No netinet/in.h found." fi : see if this is a sys/dir.h system echo " " if $test -r /usr/include/sys/dir.h ; then i_sysdir="$define" echo "sys/dir.h found." else i_sysdir="$undef" echo "No sys/dir.h found." fi : see if ioctl defs are in sgtty/termio or sys/ioctl echo " " if $test -r /usr/include/sys/ioctl.h ; then i_sysioctl="$define" echo "sys/ioctl.h found." else i_sysioctl="$undef" echo "sys/ioctl.h not found, assuming ioctl args are defined in sgtty.h." fi : see if this is a sys/ndir.h system echo " " xxx=`loc sys/ndir.h x /usr/include /usr/local/include $inclwanted` if test -f $xxx; then i_sysndir="$define" echo "sys/ndir.h found." else i_sysndir="$undef" echo "No sys/ndir.h found." fi : see if we should include utime.h echo " " if $test -r /usr/include/utime.h ; then i_utime="$define" echo "utime.h found." else i_utime="$undef" echo "No utime.h found, but that's ok." fi : see if this is a varargs system echo " " if $test -r /usr/include/varargs.h ; then i_varargs="$define" echo "varargs.h found." else i_varargs="$undef" echo "No varargs.h found, but that's ok (I hope)." fi : see if this is a vfork system echo " " if $test -r /usr/include/vfork.h ; then i_vfork="$define" echo "vfork.h found." else i_vfork="$undef" echo "No vfork.h found." fi : check for length of integer echo " " case "$intsize" in '') echo "Checking to see how big your integers are..." $cat >try.c <<'EOCP' #include main() { printf("%d\n", sizeof(int)); } EOCP if $cc try.c -o try >/dev/null 2>&1 ; then dflt=`./try` else dflt='4' echo "(I can't seem to compile the test program. Guessing...)" fi ;; *) dflt="$intsize" ;; esac rp="What is the size of an integer (in bytes)? [$dflt]" $echo $n "$rp $c" . myread intsize="$ans" $rm -f try.c try : determine where private executables go case "$privlib" in '') dflt=/usr/lib/$package test -d /usr/local/lib && dflt=/usr/local/lib/$package ;; *) dflt="$privlib" ;; esac $cat <try.c <<'EOCP' #include main() { register int i; register unsigned long tmp; register unsigned long max = 0L; for (i=1000; i; i--) { tmp = (unsigned long)rand(); if (tmp > max) max = tmp; } for (i=0; max; i++) max /= 2; printf("%d\n",i); } EOCP if $cc try.c -o try >/dev/null 2>&1 ; then dflt=`./try` else dflt='?' echo "(I can't seem to compile the test program...)" fi ;; *) dflt="$randbits" ;; esac rp="How many bits does your rand() function produce? [$dflt]" $echo $n "$rp $c" . myread randbits="$ans" $rm -f try.c try : generate list of signal names echo " " case "$sig_name" in '') echo "Generating a list of signal names..." set X `cat /usr/include/signal.h /usr/include/sys/signal.h 2>&1 | awk ' $1 ~ /^#define$/ && $2 ~ /^SIG[A-Z0-9]*$/ && $3 ~ /^[1-9][0-9]*$/ { sig[$3] = substr($2,4,20) if (max < $3 && $3 < 60) { max = $3 } } END { for (i=1; i<=max; i++) { if (sig[i] == "") printf "%d", i else printf "%s", sig[i] if (i < max) printf " " } printf "\n" } '` shift case $# in 0) echo 'kill -l' >/tmp/foo$$ set X `$csh -f /dev/null 2>&1 ; then echo "Your stdio uses unsigned chars." stdchar="unsigned char" else echo "Your stdio uses signed chars." stdchar="char" fi : 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 returned by getuid(), etc.? [$dflt]" $echo $n "$rp $c" . myread uidtype="$ans" : preserve RCS keywords in files with variable substitution, grrr Log='$Log' Header='$Header' : determine which malloc to compile in echo " " case "$usemymalloc" in '') if bsd || v7; then dflt='y' else dflt='n' fi ;; *) dflt="$usemymalloc" ;; esac rp="Do you wish to attempt to use the malloc that comes with $package? [$dflt]" $echo $n "$rp $c" . myread case "$ans" in '') ans=$dflt;; esac usemymalloc="$ans" case "$ans" in y*) mallocsrc='malloc.c'; mallocobj='malloc.o';; *) mallocsrc=''; mallocobj='';; esac : determine compiler compiler case "$yacc" in '') dflt=yacc;; *) dflt="$yacc";; esac cont=true echo " " rp="Which compiler compiler (yacc or bison -y) will you use? [$dflt]" $echo $n "$rp $c" . myread case "$ans" in '') ans="$dflt";; esac yacc="$ans" echo " " echo "End of configuration questions." echo " " : create config.sh file echo " " if test -d ../UU; then cd .. fi echo "Creating config.sh..." $spitshell <config.sh $startsh # config.sh # This file was produced by running the Configure script. d_eunice='$d_eunice' define='$define' eunicefix='$eunicefix' loclist='$loclist' expr='$expr' sed='$sed' echo='$echo' cat='$cat' rm='$rm' mv='$mv' cp='$cp' tail='$tail' tr='$tr' mkdir='$mkdir' sort='$sort' uniq='$uniq' grep='$grep' trylist='$trylist' test='$test' inews='$inews' egrep='$egrep' more='$more' pg='$pg' Mcc='$Mcc' vi='$vi' mailx='$mailx' mail='$mail' cpp='$cpp' perl='$perl' emacs='$emacs' ls='$ls' rmail='$rmail' sendmail='$sendmail' shar='$shar' smail='$smail' tbl='$tbl' troff='$troff' nroff='$nroff' uname='$uname' uuname='$uuname' line='$line' chgrp='$chgrp' chmod='$chmod' lint='$lint' sleep='$sleep' pr='$pr' tar='$tar' ln='$ln' lpr='$lpr' lp='$lp' touch='$touch' make='$make' date='$date' csh='$csh' Log='$Log' Header='$Header' bin='$bin' byteorder='$byteorder' contains='$contains' cppstdin='$cppstdin' cppminus='$cppminus' d_bcmp='$d_bcmp' d_bcopy='$d_bcopy' d_bzero='$d_bzero' d_charsprf='$d_charsprf' d_crypt='$d_crypt' cryptlib='$cryptlib' d_csh='$d_csh' d_dosuid='$d_dosuid' d_dup2='$d_dup2' d_fchmod='$d_fchmod' d_fchown='$d_fchown' d_fcntl='$d_fcntl' d_flock='$d_flock' d_getgrps='$d_getgrps' d_gethent='$d_gethent' d_getpgrp='$d_getpgrp' d_getpgrp2='$d_getpgrp2' d_getprior='$d_getprior' d_htonl='$d_htonl' d_index='$d_index' d_ioctl='$d_ioctl' d_killpg='$d_killpg' d_lstat='$d_lstat' d_memcmp='$d_memcmp' d_memcpy='$d_memcpy' d_mkdir='$d_mkdir' d_ndbm='$d_ndbm' d_odbm='$d_odbm' d_readdir='$d_readdir' d_rename='$d_rename' d_rmdir='$d_rmdir' d_setegid='$d_setegid' d_seteuid='$d_seteuid' d_setpgrp='$d_setpgrp' d_setpgrp2='$d_setpgrp2' d_setprior='$d_setprior' d_setregid='$d_setregid' d_setresgid='$d_setresgid' d_setreuid='$d_setreuid' d_setresuid='$d_setresuid' d_setrgid='$d_setrgid' d_setruid='$d_setruid' d_socket='$d_socket' d_sockpair='$d_sockpair' d_oldsock='$d_oldsock' socketlib='$socketlib' d_statblks='$d_statblks' d_stdstdio='$d_stdstdio' d_strctcpy='$d_strctcpy' d_strerror='$d_strerror' d_symlink='$d_symlink' d_syscall='$d_syscall' d_varargs='$d_varargs' d_vfork='$d_vfork' d_voidsig='$d_voidsig' d_volatile='$d_volatile' d_vprintf='$d_vprintf' d_charvspr='$d_charvspr' d_wait4='$d_wait4' gidtype='$gidtype' i_dirent='$i_dirent' d_dirnamlen='$d_dirnamlen' i_fcntl='$i_fcntl' i_grp='$i_grp' i_niin='$i_niin' i_pwd='$i_pwd' d_pwquota='$d_pwquota' d_pwage='$d_pwage' d_pwchange='$d_pwchange' d_pwclass='$d_pwclass' d_pwexpire='$d_pwexpire' i_sysdir='$i_sysdir' i_sysioctl='$i_sysioctl' i_sysndir='$i_sysndir' i_time='$i_time' i_systime='$i_systime' d_systimekernel='$d_systimekernel' i_utime='$i_utime' i_varargs='$i_varargs' i_vfork='$i_vfork' intsize='$intsize' libc='$libc' mallocsrc='$mallocsrc' mallocobj='$mallocobj' usemymalloc='$usemymalloc' mansrc='$mansrc' manext='$manext' models='$models' split='$split' small='$small' medium='$medium' large='$large' huge='$huge' optimize='$optimize' ccflags='$ccflags' cppflags='$cppflags' ldflags='$ldflags' cc='$cc' libs='$libs' n='$n' c='$c' package='$package' randbits='$randbits' sig_name='$sig_name' spitshell='$spitshell' shsharp='$shsharp' sharpbang='$sharpbang' startsh='$startsh' stdchar='$stdchar' uidtype='$uidtype' voidflags='$voidflags' defvoidused='$defvoidused' yacc='$yacc' privlib='$privlib' lib='$lib' CONFIG=true EOT CONFIG=true echo " " dflt='' fastread='' echo "If you didn't make any mistakes, then just type a carriage return here." rp="If you need to edit config.sh, do it as a shell escape here:" $echo $n "$rp $c" . UU/myread case "$ans" in '') ;; *) : in case they cannot read eval $ans;; esac : if this fails, just run all the .SH files by hand . ./config.sh echo " " echo "Doing variable substitutions on .SH files..." set x `awk '{print $1}' /dev/null 2>&1; then dflt=n $cat < makedepend.out &" It can take a while, so you might not want to run it right now. EOM rp="Run make depend now? [$dflt]" $echo $n "$rp $c" . UU/myread case "$ans" in y*) make depend && echo "Now you must run a make." ;; *) echo "You must run 'make depend' then 'make'." ;; esac elif test -f Makefile; then echo " " echo "Now you must run a make." else echo "Done." fi $rm -f kit*isdone : the following is currently useless cd UU && $rm -f $rmlist : since this removes it all anyway cd .. && $rm -rf UU : end of Configure ot want to run it right now. EOM rp="Run make depend now? [$dflt]" $echo $n "$rp $c" . UU/myread case "$ans" in y*) make depend && echo "Now you must run a make." ;; *) echo "You must run 'make depend' then 'make'." ;; esac elif test -f Makefile; then echo " " echo "Now you must run a make." else echo "Done." fi $rm -f kit*isdone : the following is currently useless cd UU && $rm -f $rmlist : since this removes it all anyway cd .. perl/eval.c 644 473 0 144141 4747105016 6171 /* $Header: eval.c,v 3.0.1.4 90/02/28 17:36:59 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: eval.c,v $ * Revision 3.0.1.4 90/02/28 17:36:59 lwall * patch9: added pipe function * patch9: a return in scalar context wouldn't return array * patch9: !~ now always returns scalar even in array context * patch9: some machines can't cast float to long with high bit set * patch9: piped opens returned undef in child * patch9: @array in scalar context now returns length of array * patch9: chdir; coredumped * patch9: wait no longer ignores signals * patch9: mkdir now handles odd versions of /bin/mkdir * patch9: -l FILEHANDLE now disallowed * * Revision 3.0.1.3 89/12/21 20:03:05 lwall * patch7: errno may now be a macro with an lvalue * patch7: ANSI strerror() is now supported * patch7: send() didn't allow a TO argument * patch7: ord() now always returns positive even on signed char machines * * Revision 3.0.1.2 89/11/17 15:19:34 lwall * patch5: constant numeric subscripts get lost inside ?: * * Revision 3.0.1.1 89/11/11 04:31:51 lwall * patch2: mkdir and rmdir needed to quote argument when passed to shell * patch2: mkdir and rmdir now return better error codes * patch2: fileno, seekdir, rewinddir and closedir now disallow defaults * * Revision 3.0 89/10/18 15:17:04 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" #include #ifdef I_VFORK # include #endif #ifdef VOIDSIG static void (*ihand)(); static void (*qhand)(); #else static int (*ihand)(); static int (*qhand)(); #endif ARG *debarg; STR str_args; static STAB *stab2; static STIO *stio; static struct lstring *lstr; static char old_record_separator; extern int wantarray; double sin(), cos(), atan2(), pow(); char *getlogin(); int eval(arg,gimme,sp) register ARG *arg; int gimme; register int sp; { register STR *str; register int anum; register int optype; register STR **st; int maxarg; double value; register char *tmps; char *tmps2; int argflags; int argtype; union argptr argptr; int arglast[8]; /* highest sp for arg--valid only for non-O_LIST args */ 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(); extern void grow_dlevel(); if (!arg) goto say_undef; optype = arg->arg_type; maxarg = arg->arg_len; arglast[0] = sp; str = arg->arg_ptr.arg_str; if (sp + maxarg > stack->ary_max) astore(stack, sp + maxarg, Nullstr); st = stack->ary_array; #ifdef DEBUGGING if (debug) { if (debug & 8) { deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg); } debname[dlevel] = opname[optype][0]; debdelim[dlevel] = ':'; if (++dlevel >= dlmax) grow_dlevel(); } #endif #include "evalargs.xc" st += arglast[0]; switch (optype) { case O_RCAT: STABSET(str); break; case O_ITEM: if (gimme == G_ARRAY) goto array_return; STR_SSET(str,st[1]); STABSET(str); break; case O_ITEM2: if (gimme == G_ARRAY) goto array_return; --anum; STR_SSET(str,st[arglast[anum]-arglast[0]]); STABSET(str); break; case O_ITEM3: if (gimme == G_ARRAY) goto array_return; --anum; STR_SSET(str,st[arglast[anum]-arglast[0]]); STABSET(str); break; case O_CONCAT: STR_SSET(str,st[1]); str_scat(str,st[2]); STABSET(str); break; case O_REPEAT: STR_SSET(str,st[1]); anum = (int)str_gnum(st[2]); if (anum >= 1) { tmpstr = Str_new(50, 0); str_sset(tmpstr,str); tmps = str_get(tmpstr); /* force to be string */ STR_GROW(str, (anum * str->str_cur) + 1); repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum); str->str_cur *= anum; str->str_ptr[str->str_cur] = '\0'; } else str_sset(str,&str_no); STABSET(str); break; case O_MATCH: sp = do_match(str,arg, gimme,arglast); if (gimme == G_ARRAY) goto array_return; STABSET(str); break; case O_NMATCH: sp = do_match(str,arg, G_SCALAR,arglast); str_sset(str, str_true(str) ? &str_no : &str_yes); STABSET(str); break; case O_SUBST: sp = do_subst(str,arg,arglast[0]); goto array_return; case O_NSUBST: sp = do_subst(str,arg,arglast[0]); str = arg->arg_ptr.arg_str; str_set(str, str_true(str) ? No : Yes); goto array_return; case O_ASSIGN: if (arg[1].arg_flags & AF_ARYOK) { if (arg->arg_len == 1) { arg->arg_type = O_LOCAL; goto local; } else { arg->arg_type = O_AASSIGN; goto aassign; } } else { arg->arg_type = O_SASSIGN; goto sassign; } case O_LOCAL: local: arglast[2] = arglast[1]; /* push a null array */ /* FALL THROUGH */ case O_AASSIGN: aassign: sp = do_assign(arg, gimme,arglast); goto array_return; case O_SASSIGN: sassign: STR_SSET(str, st[2]); STABSET(str); break; case O_CHOP: st -= arglast[0]; str = arg->arg_ptr.arg_str; for (sp = arglast[0] + 1; sp <= arglast[1]; sp++) do_chop(str,st[sp]); st += arglast[0]; break; case O_DEFINED: if (arg[1].arg_type & A_DONT) { sp = do_defined(str,arg, gimme,arglast); goto array_return; } else if (str->str_pok || str->str_nok) goto say_yes; goto say_no; case O_UNDEF: if (arg[1].arg_type & A_DONT) { sp = do_undef(str,arg, gimme,arglast); goto array_return; } else if (str != stab_val(defstab)) { str->str_pok = str->str_nok = 0; STABSET(str); } goto say_undef; case O_STUDY: sp = do_study(str,arg, gimme,arglast); goto array_return; case O_POW: value = str_gnum(st[1]); value = pow(value,str_gnum(st[2])); goto donumset; case O_MULTIPLY: value = str_gnum(st[1]); value *= str_gnum(st[2]); goto donumset; case O_DIVIDE: if ((value = str_gnum(st[2])) == 0.0) fatal("Illegal division by zero"); value = str_gnum(st[1]) / value; goto donumset; case O_MODULO: tmplong = (long) str_gnum(st[2]); if (tmplong == 0L) fatal("Illegal modulus zero"); when = (long)str_gnum(st[1]); #ifndef lint if (when >= 0) value = (double)(when % tmplong); else value = (double)(tmplong - (-when % tmplong)); #endif goto donumset; case O_ADD: value = str_gnum(st[1]); value += str_gnum(st[2]); goto donumset; case O_SUBTRACT: value = str_gnum(st[1]); value -= str_gnum(st[2]); goto donumset; case O_LEFT_SHIFT: value = str_gnum(st[1]); anum = (int)str_gnum(st[2]); #ifndef lint value = (double)(((unsigned long)value) << anum); #endif goto donumset; case O_RIGHT_SHIFT: value = str_gnum(st[1]); anum = (int)str_gnum(st[2]); #ifndef lint value = (double)(((unsigned long)value) >> anum); #endif goto donumset; case O_LT: value = str_gnum(st[1]); value = (value < str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_GT: value = str_gnum(st[1]); value = (value > str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_LE: value = str_gnum(st[1]); value = (value <= str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_GE: value = str_gnum(st[1]); value = (value >= str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_EQ: if (dowarn) { if ((!st[1]->str_nok && !looks_like_number(st[1])) || (!st[2]->str_nok && !looks_like_number(st[2])) ) warn("Possible use of == on string value"); } value = str_gnum(st[1]); value = (value == str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_NE: value = str_gnum(st[1]); value = (value != str_gnum(st[2])) ? 1.0 : 0.0; goto donumset; case O_BIT_AND: if (!sawvec || st[1]->str_nok || st[2]->str_nok) { value = str_gnum(st[1]); #ifndef lint value = (double)(((unsigned long)value) & (unsigned long)str_gnum(st[2])); #endif goto donumset; } else do_vop(optype,str,st[1],st[2]); break; case O_XOR: if (!sawvec || st[1]->str_nok || st[2]->str_nok) { value = str_gnum(st[1]); #ifndef lint value = (double)(((unsigned long)value) ^ (unsigned long)str_gnum(st[2])); #endif goto donumset; } else do_vop(optype,str,st[1],st[2]); break; case O_BIT_OR: if (!sawvec || st[1]->str_nok || st[2]->str_nok) { value = str_gnum(st[1]); #ifndef lint value = (double)(((unsigned long)value) | (unsigned long)str_gnum(st[2])); #endif goto donumset; } else do_vop(optype,str,st[1],st[2]); break; /* use register in evaluating str_true() */ case O_AND: if (str_true(st[1])) { anum = 2; optype = O_ITEM2; argflags = arg[anum].arg_flags; if (gimme == G_ARRAY) argflags |= AF_ARYOK; argtype = arg[anum].arg_type & A_MASK; argptr = arg[anum].arg_ptr; maxarg = anum = 1; sp = arglast[0]; st -= sp; goto re_eval; } else { if (assigning) { str_sset(str, st[1]); STABSET(str); } else str = st[1]; break; } case O_OR: if (str_true(st[1])) { if (assigning) { str_sset(str, st[1]); STABSET(str); } else str = st[1]; break; } else { anum = 2; optype = O_ITEM2; argflags = arg[anum].arg_flags; if (gimme == G_ARRAY) argflags |= AF_ARYOK; argtype = arg[anum].arg_type & A_MASK; argptr = arg[anum].arg_ptr; maxarg = anum = 1; sp = arglast[0]; st -= sp; goto re_eval; } case O_COND_EXPR: anum = (str_true(st[1]) ? 2 : 3); optype = (anum == 2 ? O_ITEM2 : O_ITEM3); argflags = arg[anum].arg_flags; if (gimme == G_ARRAY) argflags |= AF_ARYOK; argtype = arg[anum].arg_type & A_MASK; argptr = arg[anum].arg_ptr; maxarg = anum = 1; sp = arglast[0]; st -= sp; goto re_eval; case O_COMMA: if (gimme == G_ARRAY) goto array_return; str = st[2]; break; case O_NEGATE: value = -str_gnum(st[1]); goto donumset; case O_NOT: value = (double) !str_true(st[1]); goto donumset; case O_COMPLEMENT: #ifndef lint value = (double) ~(unsigned long)str_gnum(st[1]); #endif goto donumset; case O_SELECT: tmps = stab_name(defoutstab); if (maxarg > 0) { if ((arg[1].arg_type & A_MASK) == A_WORD) defoutstab = arg[1].arg_ptr.arg_stab; else defoutstab = stabent(str_get(st[1]),TRUE); if (!stab_io(defoutstab)) stab_io(defoutstab) = stio_new(); curoutstab = defoutstab; } str_set(str, tmps); STABSET(str); break; case O_WRITE: if (maxarg == 0) stab = defoutstab; else if ((arg[1].arg_type & A_MASK) == A_WORD) { if (!(stab = arg[1].arg_ptr.arg_stab)) stab = defoutstab; } else stab = stabent(str_get(st[1]),TRUE); if (!stab_io(stab)) { str_set(str, No); STABSET(str); break; } curoutstab = stab; fp = stab_io(stab)->ofp; debarg = arg; if (stab_io(stab)->fmt_stab) form = stab_form(stab_io(stab)->fmt_stab); else form = stab_form(stab); if (!form || !fp) { if (dowarn) { if (form) warn("No format for filehandle"); else { if (stab_io(stab)->ifp) warn("Filehandle only opened for input"); else warn("Write on closed filehandle"); } } str_set(str, No); STABSET(str); break; } format(&outrec,form,sp); do_write(&outrec,stab_io(stab),sp); if (stab_io(stab)->flags & IOF_FLUSH) (void)fflush(fp); str_set(str, Yes); STABSET(str); break; case O_DBMOPEN: #ifdef SOME_DBM if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); anum = (int)str_gnum(st[3]); value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum); goto donumset; #else fatal("No dbm or ndbm on this machine"); #endif case O_DBMCLOSE: #ifdef SOME_DBM if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); hdbmclose(stab_hash(stab)); goto say_yes; #else fatal("No dbm or ndbm on this machine"); #endif case O_OPEN: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); tmps = str_get(st[2]); if (do_open(stab,tmps,st[2]->str_cur)) { value = (double)forkprocess; stab_io(stab)->lines = 0; goto donumset; } else if (forkprocess == 0) /* we are a new child */ goto say_zero; else goto say_undef; 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 (maxarg == 0) stab = defoutstab; else if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); str_set(str, do_close(stab,TRUE) ? Yes : No ); STABSET(str); break; case O_EACH: sp = do_each(str,stab_hash(arg[1].arg_ptr.arg_stab), gimme,arglast); goto array_return; case O_VALUES: case O_KEYS: sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype, gimme,arglast); goto array_return; case O_LARRAY: str->str_nok = str->str_pok = 0; str->str_u.str_stab = arg[1].arg_ptr.arg_stab; str->str_state = SS_ARY; break; case O_ARRAY: ary = stab_array(arg[1].arg_ptr.arg_stab); maxarg = ary->ary_fill + 1; if (gimme == G_ARRAY) { /* array wanted */ sp = arglast[0]; st -= sp; if (maxarg > 0 && sp + maxarg > stack->ary_max) { astore(stack,sp + maxarg, Nullstr); st = stack->ary_array; } Copy(ary->ary_array, &st[sp+1], maxarg, STR*); sp += maxarg; goto array_return; } else { value = (double)maxarg; goto donumset; } case O_AELEM: anum = ((int)str_gnum(st[2])) - arybase; str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,FALSE); if (!str) goto say_undef; break; case O_DELETE: tmpstab = arg[1].arg_ptr.arg_stab; tmps = str_get(st[2]); str = hdelete(stab_hash(tmpstab),tmps,st[2]->str_cur); if (tmpstab == envstab) setenv(tmps,Nullch); if (!str) goto say_undef; break; case O_LHASH: str->str_nok = str->str_pok = 0; str->str_u.str_stab = arg[1].arg_ptr.arg_stab; str->str_state = SS_HASH; break; case O_HASH: if (gimme == G_ARRAY) { /* array wanted */ sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype, gimme,arglast); goto array_return; } else { tmpstab = arg[1].arg_ptr.arg_stab; sprintf(buf,"%d/%d",stab_hash(tmpstab)->tbl_fill, stab_hash(tmpstab)->tbl_max+1); str_set(str,buf); } break; case O_HELEM: tmpstab = arg[1].arg_ptr.arg_stab; tmps = str_get(st[2]); str = hfetch(stab_hash(tmpstab),tmps,st[2]->str_cur,FALSE); if (!str) goto say_undef; break; case O_LAELEM: anum = ((int)str_gnum(st[2])) - arybase; str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,TRUE); if (!str) fatal("Assignment to non-creatable value, subscript %d",anum); break; case O_LHELEM: tmpstab = arg[1].arg_ptr.arg_stab; tmps = str_get(st[2]); anum = st[2]->str_cur; str = hfetch(stab_hash(tmpstab),tmps,anum,TRUE); if (!str) fatal("Assignment to non-creatable value, subscript \"%s\"",tmps); if (tmpstab == envstab) /* heavy wizardry going on here */ str_magic(str, tmpstab, 'E', tmps, anum); /* str is now magic */ /* he threw the brick up into the air */ else if (tmpstab == sigstab) str_magic(str, tmpstab, 'S', tmps, anum); #ifdef SOME_DBM else if (stab_hash(tmpstab)->tbl_dbm) str_magic(str, tmpstab, 'D', tmps, anum); #endif break; case O_ASLICE: anum = TRUE; argtype = FALSE; goto do_slice_already; case O_HSLICE: anum = FALSE; argtype = FALSE; goto do_slice_already; case O_LASLICE: anum = TRUE; argtype = TRUE; goto do_slice_already; case O_LHSLICE: anum = FALSE; argtype = TRUE; do_slice_already: sp = do_slice(arg[1].arg_ptr.arg_stab,anum,argtype, gimme,arglast); goto array_return; case O_PUSH: if (arglast[2] - arglast[1] != 1) str = do_push(stab_array(arg[1].arg_ptr.arg_stab),arglast); else { str = Str_new(51,0); /* must copy the STR */ str_sset(str,st[2]); (void)apush(stab_array(arg[1].arg_ptr.arg_stab),str); } break; case O_POP: str = apop(ary = stab_array(arg[1].arg_ptr.arg_stab)); goto staticalization; case O_SHIFT: str = ashift(ary = stab_array(arg[1].arg_ptr.arg_stab)); staticalization: if (!str) goto say_undef; if (ary->ary_flags & ARF_REAL) (void)str_2static(str); break; case O_UNPACK: sp = do_unpack(str,gimme,arglast); goto array_return; case O_SPLIT: value = str_gnum(st[3]); sp = do_split(str, arg[2].arg_ptr.arg_spat, (int)value, gimme,arglast); goto array_return; case O_LENGTH: if (maxarg < 1) value = (double)str_len(stab_val(defstab)); else value = (double)str_len(st[1]); goto donumset; case O_SPRINTF: do_sprintf(str, sp-arglast[0], st+1); break; case O_SUBSTR: anum = ((int)str_gnum(st[2])) - arybase; /* anum=where to start*/ tmps = str_get(st[1]); /* force conversion to string */ if (argtype = (str == st[1])) str = arg->arg_ptr.arg_str; if (anum < 0) anum += st[1]->str_cur + arybase; if (anum < 0 || anum > st[1]->str_cur) str_nset(str,"",0); else { optype = (int)str_gnum(st[3]); if (optype < 0) optype = 0; tmps += anum; anum = st[1]->str_cur - anum; /* anum=how many bytes left*/ if (anum > optype) anum = optype; str_nset(str, tmps, anum); if (argtype) { /* it's an lvalue! */ lstr = (struct lstring*)str; str->str_magic = st[1]; st[1]->str_rare = 's'; lstr->lstr_offset = tmps - str_get(st[1]); lstr->lstr_len = anum; } } break; case O_PACK: (void)do_pack(str,arglast); break; case O_GREP: sp = do_grep(arg,str,gimme,arglast); goto array_return; case O_JOIN: do_join(str,arglast); break; case O_SLT: tmps = str_get(st[1]); value = (double) (str_cmp(st[1],st[2]) < 0); goto donumset; case O_SGT: tmps = str_get(st[1]); value = (double) (str_cmp(st[1],st[2]) > 0); goto donumset; case O_SLE: tmps = str_get(st[1]); value = (double) (str_cmp(st[1],st[2]) <= 0); goto donumset; case O_SGE: tmps = str_get(st[1]); value = (double) (str_cmp(st[1],st[2]) >= 0); goto donumset; case O_SEQ: tmps = str_get(st[1]); value = (double) str_eq(st[1],st[2]); goto donumset; case O_SNE: tmps = str_get(st[1]); value = (double) !str_eq(st[1],st[2]); goto donumset; case O_SUBR: sp = do_subr(arg,gimme,arglast); st = stack->ary_array + arglast[0]; /* maybe realloced */ goto array_return; case O_DBSUBR: sp = do_dbsubr(arg,gimme,arglast); st = stack->ary_array + arglast[0]; /* maybe realloced */ goto array_return; case O_SORT: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); if (!stab) stab = defoutstab; sp = do_sort(str,stab, gimme,arglast); goto array_return; case O_REVERSE: sp = do_reverse(str, gimme,arglast); goto array_return; case O_WARN: if (arglast[2] - arglast[1] != 1) { do_join(str,arglast); tmps = str_get(st[1]); } else { str = st[2]; tmps = str_get(st[2]); } if (!tmps || !*tmps) tmps = "Warning: something's wrong"; warn("%s",tmps); goto say_yes; case O_DIE: if (arglast[2] - arglast[1] != 1) { do_join(str,arglast); tmps = str_get(st[1]); } else { str = st[2]; tmps = str_get(st[2]); } if (!tmps || !*tmps) exit(1); fatal("%s",tmps); goto say_zero; case O_PRTF: case O_PRINT: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); if (!stab) stab = defoutstab; if (!stab_io(stab)) { if (dowarn) warn("Filehandle never opened"); goto say_zero; } if (!(fp = stab_io(stab)->ofp)) { if (dowarn) { if (stab_io(stab)->ifp) warn("Filehandle opened only for input"); else warn("Print on closed filehandle"); } goto say_zero; } else { if (optype == O_PRTF || arglast[2] - arglast[1] != 1) value = (double)do_aprint(arg,fp,arglast); else { value = (double)do_print(st[2],fp); if (orslen && optype == O_PRINT) if (fwrite(ors, 1, orslen, fp) == 0) goto say_zero; } if (stab_io(stab)->flags & IOF_FLUSH) if (fflush(fp) == EOF) goto say_zero; } goto donumset; case O_CHDIR: if (maxarg < 1) tmps = Nullch; else tmps = str_get(st[1]); if (!tmps || !*tmps) { tmpstr = hfetch(stab_hash(envstab),"HOME",4,FALSE); if (tmpstr) tmps = str_get(tmpstr); } if (!tmps || !*tmps) { tmpstr = hfetch(stab_hash(envstab),"LOGDIR",6,FALSE); if (tmpstr) tmps = str_get(tmpstr); } #ifdef TAINT taintproper("Insecure dependency in chdir"); #endif value = (double)(chdir(tmps) >= 0); goto donumset; case O_EXIT: if (maxarg < 1) anum = 0; else anum = (int)str_gnum(st[1]); exit(anum); goto say_zero; case O_RESET: if (maxarg < 1) tmps = ""; else tmps = str_get(st[1]); str_reset(tmps,arg[2].arg_ptr.arg_hash); value = 1.0; goto donumset; case O_LIST: if (gimme == G_ARRAY) goto array_return; if (maxarg > 0) str = st[sp - arglast[0]]; /* unwanted list, return last item */ else str = &str_undef; break; case O_EOF: if (maxarg <= 0) stab = last_in_stab; else if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); str_set(str, do_eof(stab) ? Yes : No); STABSET(str); break; case O_GETC: if (maxarg <= 0) stab = stdinstab; else if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); if (do_eof(stab)) /* make sure we have fp with something */ str_set(str, No); else { #ifdef TAINT tainted = 1; #endif str_set(str," "); *str->str_ptr = getc(stab_io(stab)->ifp); /* should never be EOF */ } STABSET(str); break; case O_TELL: if (maxarg <= 0) stab = last_in_stab; else if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); #ifndef lint value = (double)do_tell(stab); #else (void)do_tell(stab); #endif goto donumset; case O_RECV: case O_READ: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); tmps = str_get(st[2]); anum = (int)str_gnum(st[3]); STR_GROW(st[2], anum+1), (tmps = str_get(st[2])); /* sneaky */ errno = 0; if (!stab_io(stab) || !stab_io(stab)->ifp) goto say_zero; #ifdef SOCKET else if (optype == O_RECV) { argtype = sizeof buf; optype = (int)str_gnum(st[4]); anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, optype, buf, &argtype); if (anum >= 0) { st[2]->str_cur = anum; st[2]->str_ptr[anum] = '\0'; str_nset(str,buf,argtype); } else str_sset(str,&str_undef); break; } else if (stab_io(stab)->type == 's') { argtype = sizeof buf; anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, 0, buf, &argtype); } #else else if (optype == O_RECV) goto badsock; #endif else anum = fread(tmps, 1, anum, stab_io(stab)->ifp); if (anum < 0) goto say_undef; st[2]->str_cur = anum; st[2]->str_ptr[anum] = '\0'; value = (double)anum; goto donumset; case O_SEND: #ifdef SOCKET if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); tmps = str_get(st[2]); anum = (int)str_gnum(st[3]); optype = sp - arglast[0]; errno = 0; if (optype > 4) warn("Too many args on send"); stio = stab_io(stab); if (!stio || !stio->ifp) { anum = -1; if (dowarn) warn("Send on closed socket"); } else if (optype >= 4) { tmps2 = str_get(st[4]); anum = sendto(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, anum, tmps2, st[4]->str_cur); } else anum = send(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, anum); if (anum < 0) goto say_undef; value = (double)anum; goto donumset; #else goto badsock; #endif case O_SEEK: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); value = str_gnum(st[2]); str_set(str, do_seek(stab, (long)value, (int)str_gnum(st[3]) ) ? Yes : No); STABSET(str); break; case O_RETURN: tmps = "_SUB_"; /* just fake up a "last _SUB_" */ optype = O_LAST; if (wantarray == G_ARRAY) { lastretstr = Nullstr; lastspbase = arglast[1]; lastsize = arglast[2] - arglast[1]; } else lastretstr = str_static(st[arglast[2] - arglast[0]]); goto dopop; case O_REDO: case O_NEXT: case O_LAST: if (maxarg > 0) { tmps = str_get(arg[1].arg_ptr.arg_str); dopop: while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label || strNE(tmps,loop_stack[loop_ptr].loop_label) )) { #ifdef DEBUGGING if (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 : ""); if (!lastretstr && optype == O_LAST && lastsize) { st -= arglast[0]; st += lastspbase + 1; optype = loop_stack[loop_ptr].loop_sp - lastspbase; /* negative */ if (optype) { for (anum = lastsize; anum > 0; anum--,st++) st[optype] = str_static(st[0]); } longjmp(loop_stack[loop_ptr].loop_env, O_LAST); } longjmp(loop_stack[loop_ptr].loop_env, optype); case O_DUMP: case O_GOTO:/* shudder */ goto_targ = str_get(arg[1].arg_ptr.arg_str); if (!*goto_targ) goto_targ = Nullch; /* just restart from top */ if (optype == O_DUMP) { do_undump = 1; abort(); } longjmp(top_env, 1); case O_INDEX: tmps = str_get(st[1]); #ifndef lint if (!(tmps2 = fbminstr((unsigned char*)tmps, (unsigned char*)tmps + st[1]->str_cur, st[2]))) #else if (tmps2 = fbminstr(Null(unsigned char*),Null(unsigned char*),Nullstr)) #endif value = (double)(-1 + arybase); else value = (double)(tmps2 - tmps + arybase); goto donumset; case O_RINDEX: tmps = str_get(st[1]); tmps2 = str_get(st[2]); #ifndef lint if (!(tmps2 = rninstr(tmps, tmps + st[1]->str_cur, tmps2, tmps2 + st[2]->str_cur))) #else if (tmps2 = rninstr(Nullch,Nullch,Nullch,Nullch)) #endif value = (double)(-1 + arybase); else value = (double)(tmps2 - tmps + arybase); goto donumset; case O_TIME: #ifndef lint value = (double) time(Null(long*)); #endif goto donumset; case O_TMS: sp = do_tms(str,gimme,arglast); goto array_return; case O_LOCALTIME: if (maxarg < 1) (void)time(&when); else when = (long)str_gnum(st[1]); sp = do_time(str,localtime(&when), gimme,arglast); goto array_return; case O_GMTIME: if (maxarg < 1) (void)time(&when); else when = (long)str_gnum(st[1]); sp = do_time(str,gmtime(&when), gimme,arglast); goto array_return; case O_LSTAT: case O_STAT: sp = do_stat(str,arg, gimme,arglast); goto array_return; case O_CRYPT: #ifdef CRYPT tmps = str_get(st[1]); #ifdef FCRYPT str_set(str,fcrypt(tmps,str_get(st[2]))); #else str_set(str,crypt(tmps,str_get(st[2]))); #endif #else fatal( "The crypt() function is unimplemented due to excessive paranoia."); #endif break; case O_ATAN2: value = str_gnum(st[1]); value = atan2(value,str_gnum(st[2])); goto donumset; case O_SIN: if (maxarg < 1) value = str_gnum(stab_val(defstab)); else value = str_gnum(st[1]); value = sin(value); goto donumset; case O_COS: if (maxarg < 1) value = str_gnum(stab_val(defstab)); else value = str_gnum(st[1]); value = cos(value); goto donumset; case O_RAND: if (maxarg < 1) value = 1.0; else value = str_gnum(st[1]); if (value == 0.0) value = 1.0; #if RANDBITS == 31 value = rand() * value / 2147483648.0; #else #if RANDBITS == 16 value = rand() * value / 65536.0; #else #if RANDBITS == 15 value = rand() * value / 32768.0; #else value = rand() * value / (double)(((unsigned long)1) << RANDBITS); #endif #endif #endif goto donumset; case O_SRAND: if (maxarg < 1) { (void)time(&when); anum = when; } else anum = (int)str_gnum(st[1]); (void)srand(anum); goto say_yes; case O_EXP: if (maxarg < 1) value = str_gnum(stab_val(defstab)); else value = str_gnum(st[1]); value = exp(value); goto donumset; case O_LOG: if (maxarg < 1) value = str_gnum(stab_val(defstab)); else value = str_gnum(st[1]); value = log(value); goto donumset; case O_SQRT: if (maxarg < 1) value = str_gnum(stab_val(defstab)); else value = str_gnum(st[1]); value = sqrt(value); goto donumset; case O_INT: if (maxarg < 1) value = str_gnum(stab_val(defstab)); else value = str_gnum(st[1]); if (value >= 0.0) (void)modf(value,&value); else { (void)modf(-value,&value); value = -value; } goto donumset; case O_ORD: if (maxarg < 1) tmps = str_get(stab_val(defstab)); else tmps = str_get(st[1]); #ifndef I286 value = (double) (*tmps & 255); #else anum = (int) *tmps; value = (double) (anum & 255); #endif goto donumset; case O_SLEEP: if (maxarg < 1) tmps = Nullch; else tmps = str_get(st[1]); (void)time(&when); if (!tmps || !*tmps) sleep((32767<<16)+32767); else sleep((unsigned int)atoi(tmps)); #ifndef lint value = (double)when; (void)time(&when); value = ((double)when) - value; #endif goto donumset; case O_RANGE: sp = do_range(gimme,arglast); goto array_return; case O_F_OR_R: if (gimme == G_ARRAY) { /* it's a range */ /* can we optimize to constant array? */ if ((arg[1].arg_type & A_MASK) == A_SINGLE && (arg[2].arg_type & A_MASK) == A_SINGLE) { st[2] = arg[2].arg_ptr.arg_str; sp = do_range(gimme,arglast); st = stack->ary_array; maxarg = sp - arglast[0]; str_free(arg[1].arg_ptr.arg_str); str_free(arg[2].arg_ptr.arg_str); arg->arg_type = O_ARRAY; arg[1].arg_type = A_STAB|A_DONT; arg->arg_len = 1; stab = arg[1].arg_ptr.arg_stab = aadd(genstab()); ary = stab_array(stab); afill(ary,maxarg - 1); st += arglast[0]+1; while (maxarg-- > 0) ary->ary_array[maxarg] = str_smake(st[maxarg]); goto array_return; } arg->arg_type = optype = O_RANGE; maxarg = arg->arg_len = 2; anum = 2; arg[anum].arg_flags &= ~AF_ARYOK; argflags = arg[anum].arg_flags; argtype = arg[anum].arg_type & A_MASK; arg[anum].arg_type = argtype; argptr = arg[anum].arg_ptr; sp = arglast[0]; st -= sp; sp++; goto re_eval; } arg->arg_type = O_FLIP; /* FALL THROUGH */ case O_FLIP: if ((arg[1].arg_type & A_MASK) == A_SINGLE ? last_in_stab && (int)str_gnum(st[1]) == stab_io(last_in_stab)->lines : str_true(st[1]) ) { str_numset(str,0.0); anum = 2; arg->arg_type = optype = O_FLOP; arg[2].arg_type &= ~A_DONT; arg[1].arg_type |= A_DONT; argflags = arg[2].arg_flags; argtype = arg[2].arg_type & A_MASK; argptr = arg[2].arg_ptr; sp = arglast[0]; st -= sp; goto re_eval; } str_set(str,""); break; case O_FLOP: str_inc(str); if ((arg[2].arg_type & A_MASK) == A_SINGLE ? last_in_stab && (int)str_gnum(st[2]) == stab_io(last_in_stab)->lines : str_true(st[2]) ) { arg->arg_type = O_FLIP; arg[1].arg_type &= ~A_DONT; arg[2].arg_type |= A_DONT; str_cat(str,"E0"); } break; case O_FORK: anum = fork(); if (!anum && (tmpstab = stabent("$",allstabs))) str_numset(STAB_STR(tmpstab),(double)getpid()); value = (double)anum; goto donumset; case O_WAIT: #ifndef lint /* ihand = signal(SIGINT, SIG_IGN); */ /* qhand = signal(SIGQUIT, SIG_IGN); */ anum = wait(&argflags); if (anum > 0) pidgone(anum,argflags); value = (double)anum; #else /* ihand = qhand = 0; */ #endif /* (void)signal(SIGINT, ihand); */ /* (void)signal(SIGQUIT, qhand); */ statusvalue = (unsigned short)argflags; goto donumset; case O_SYSTEM: #ifdef TAINT if (arglast[2] - arglast[1] == 1) { taintenv(); tainted |= st[2]->str_tainted; taintproper("Insecure dependency in system"); } #endif while ((anum = vfork()) == -1) { if (errno != EAGAIN) { value = -1.0; goto donumset; } sleep(5); } if (anum > 0) { #ifndef lint ihand = signal(SIGINT, SIG_IGN); qhand = signal(SIGQUIT, SIG_IGN); while ((argtype = wait(&argflags)) != anum && argtype >= 0) pidgone(argtype,argflags); #else ihand = qhand = 0; #endif (void)signal(SIGINT, ihand); (void)signal(SIGQUIT, qhand); statusvalue = (unsigned short)argflags; if (argtype == -1) value = -1.0; else { value = (double)((unsigned int)argflags & 0xffff); } goto donumset; } if ((arg[1].arg_type & A_MASK) == A_STAB) value = (double)do_aexec(st[1],arglast); else if (arglast[2] - arglast[1] != 1) value = (double)do_aexec(Nullstr,arglast); else { value = (double)do_exec(str_get(str_static(st[2]))); } _exit(-1); case O_EXEC: if ((arg[1].arg_type & A_MASK) == A_STAB) value = (double)do_aexec(st[1],arglast); else if (arglast[2] - arglast[1] != 1) value = (double)do_aexec(Nullstr,arglast); else { value = (double)do_exec(str_get(str_static(st[2]))); } goto donumset; case O_HEX: argtype = 4; goto snarfnum; case O_OCT: argtype = 3; snarfnum: anum = 0; if (maxarg < 1) tmps = str_get(stab_val(defstab)); else tmps = str_get(st[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: value = (double)apply(optype,arglast); goto donumset; case O_UMASK: if (maxarg < 1) { anum = umask(0); (void)umask(anum); } else anum = umask((int)str_gnum(st[1])); value = (double)anum; #ifdef TAINT taintproper("Insecure dependency in umask"); #endif goto donumset; case O_RENAME: tmps = str_get(st[1]); tmps2 = str_get(st[2]); #ifdef TAINT taintproper("Insecure dependency in rename"); #endif #ifdef RENAME value = (double)(rename(tmps,tmps2) >= 0); #else if (euid || stat(tmps2,&statbuf) < 0 || (statbuf.st_mode & S_IFMT) != S_IFDIR ) (void)UNLINK(tmps2); /* avoid unlinking a directory */ if (!(anum = link(tmps,tmps2))) anum = UNLINK(tmps); value = (double)(anum >= 0); #endif goto donumset; case O_LINK: tmps = str_get(st[1]); tmps2 = str_get(st[2]); #ifdef TAINT taintproper("Insecure dependency in link"); #endif value = (double)(link(tmps,tmps2) >= 0); goto donumset; case O_MKDIR: tmps = str_get(st[1]); anum = (int)str_gnum(st[2]); #ifdef TAINT taintproper("Insecure dependency in mkdir"); #endif #ifdef MKDIR value = (double)(mkdir(tmps,anum) >= 0); goto donumset; #else (void)strcpy(buf,"mkdir "); #endif #if !defined(MKDIR) || !defined(RMDIR) one_liner: for (tmps2 = buf+6; *tmps; ) { *tmps2++ = '\\'; *tmps2++ = *tmps++; } (void)strcpy(tmps2," 2>&1"); rsfp = mypopen(buf,"r"); if (rsfp) { *buf = '\0'; tmps2 = fgets(buf,sizeof buf,rsfp); (void)mypclose(rsfp); if (tmps2 != Nullch) { for (errno = 1; errno < sys_nerr; errno++) { if (instr(buf,sys_errlist[errno])) /* you don't see this */ goto say_zero; } errno = 0; #ifndef EACCES #define EACCES EPERM #endif if (instr(buf,"cannot make")) errno = EEXIST; else if (instr(buf,"non-exist")) errno = ENOENT; else if (instr(buf,"does not exist")) errno = ENOENT; else if (instr(buf,"not empty")) errno = EBUSY; else if (instr(buf,"cannot access")) errno = EACCES; else errno = EPERM; goto say_zero; } else { /* some mkdirs return no failure indication */ tmps = str_get(st[1]); anum = (stat(tmps,&statbuf) >= 0); if (optype == O_RMDIR) anum = !anum; if (anum) errno = 0; else errno = EACCES; /* a guess */ value = (double)anum; } goto donumset; } else goto say_zero; #endif case O_RMDIR: if (maxarg < 1) tmps = str_get(stab_val(defstab)); else tmps = str_get(st[1]); #ifdef TAINT taintproper("Insecure dependency in rmdir"); #endif #ifdef RMDIR value = (double)(rmdir(tmps) >= 0); goto donumset; #else (void)strcpy(buf,"rmdir "); goto one_liner; /* see above in MKDIR */ #endif case O_GETPPID: value = (double)getppid(); goto donumset; case O_GETPGRP: #ifdef GETPGRP if (maxarg < 1) anum = 0; else anum = (int)str_gnum(st[1]); value = (double)getpgrp(anum); goto donumset; #else fatal("The getpgrp() function is unimplemented on this machine"); break; #endif case O_SETPGRP: #ifdef SETPGRP argtype = (int)str_gnum(st[1]); anum = (int)str_gnum(st[2]); #ifdef TAINT taintproper("Insecure dependency in setpgrp"); #endif value = (double)(setpgrp(argtype,anum) >= 0); goto donumset; #else fatal("The setpgrp() function is unimplemented on this machine"); break; #endif case O_GETPRIORITY: #ifdef GETPRIORITY argtype = (int)str_gnum(st[1]); anum = (int)str_gnum(st[2]); value = (double)getpriority(argtype,anum); goto donumset; #else fatal("The getpriority() function is unimplemented on this machine"); break; #endif case O_SETPRIORITY: #ifdef SETPRIORITY argtype = (int)str_gnum(st[1]); anum = (int)str_gnum(st[2]); optype = (int)str_gnum(st[3]); #ifdef TAINT taintproper("Insecure dependency in setpriority"); #endif value = (double)(setpriority(argtype,anum,optype) >= 0); goto donumset; #else fatal("The setpriority() function is unimplemented on this machine"); break; #endif case O_CHROOT: if (maxarg < 1) tmps = str_get(stab_val(defstab)); else tmps = str_get(st[1]); #ifdef TAINT taintproper("Insecure dependency in chroot"); #endif value = (double)(chroot(tmps) >= 0); goto donumset; case O_FCNTL: case O_IOCTL: if (maxarg <= 0) stab = last_in_stab; else if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); argtype = (unsigned int)str_gnum(st[2]); #ifdef TAINT taintproper("Insecure dependency in ioctl"); #endif anum = do_ctl(optype,stab,argtype,st[3]); if (anum == -1) goto say_undef; if (anum != 0) goto donumset; str_set(str,"0 but true"); STABSET(str); break; case O_FLOCK: #ifdef FLOCK if (maxarg <= 0) stab = last_in_stab; else if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); if (stab && stab_io(stab)) fp = stab_io(stab)->ifp; else fp = Nullfp; if (fp) { argtype = (int)str_gnum(st[2]); value = (double)(flock(fileno(fp),argtype) >= 0); } else value = 0; goto donumset; #else fatal("The flock() function is unimplemented on this machine"); break; #endif case O_UNSHIFT: ary = stab_array(arg[1].arg_ptr.arg_stab); if (arglast[2] - arglast[1] != 1) do_unshift(ary,arglast); else { str = Str_new(52,0); /* must copy the STR */ str_sset(str,st[2]); aunshift(ary,1); (void)astore(ary,0,str); } value = (double)(ary->ary_fill + 1); break; case O_DOFILE: case O_EVAL: if (maxarg < 1) tmpstr = stab_val(defstab); else tmpstr = (arg[1].arg_type & A_MASK) != A_NULL ? st[1] : stab_val(defstab); #ifdef TAINT tainted |= tmpstr->str_tainted; taintproper("Insecure dependency in eval"); #endif sp = do_eval(tmpstr, optype, arg[2].arg_ptr.arg_hash, gimme,arglast); goto array_return; case O_FTRREAD: argtype = 0; 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: if (mystat(arg,st[1]) < 0) goto say_undef; if (cando(anum,argtype,&statcache)) goto say_yes; goto say_no; case O_FTIS: if (mystat(arg,st[1]) < 0) goto say_undef; goto say_yes; case O_FTEOWNED: case O_FTROWNED: if (mystat(arg,st[1]) < 0) goto say_undef; if (statcache.st_uid == (optype == O_FTEOWNED ? euid : uid) ) goto say_yes; goto say_no; case O_FTZERO: if (mystat(arg,st[1]) < 0) goto say_undef; if (!statcache.st_size) goto say_yes; goto say_no; case O_FTSIZE: if (mystat(arg,st[1]) < 0) goto say_undef; if (statcache.st_size) goto say_yes; goto say_no; case O_FTSOCK: #ifdef S_IFSOCK anum = S_IFSOCK; goto check_file_type; #else goto say_no; #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,st[1]) < 0) goto say_undef; if ((statcache.st_mode & S_IFMT) == anum ) goto say_yes; goto say_no; case O_FTPIPE: #ifdef S_IFIFO anum = S_IFIFO; goto check_file_type; #else goto say_no; #endif case O_FTLINK: if (arg[1].arg_type & A_DONT) fatal("You must supply explicit filename with -l"); #ifdef LSTAT if (lstat(str_get(st[1]),&statcache) < 0) goto say_undef; if ((statcache.st_mode & S_IFMT) == S_IFLNK ) goto say_yes; #endif goto say_no; case O_SYMLINK: #ifdef SYMLINK tmps = str_get(st[1]); tmps2 = str_get(st[2]); #ifdef TAINT taintproper("Insecure dependency in symlink"); #endif value = (double)(symlink(tmps,tmps2) >= 0); goto donumset; #else fatal("Unsupported function symlink()"); #endif case O_READLINK: #ifdef SYMLINK if (maxarg < 1) tmps = str_get(stab_val(defstab)); else tmps = str_get(st[1]); anum = readlink(tmps,buf,sizeof buf); if (anum < 0) goto say_undef; str_nset(str,buf,anum); break; #else fatal("Unsupported function readlink()"); #endif case O_FTSUID: anum = S_ISUID; goto check_xid; case O_FTSGID: anum = S_ISGID; goto check_xid; case O_FTSVTX: anum = S_ISVTX; check_xid: if (mystat(arg,st[1]) < 0) goto say_undef; if (statcache.st_mode & anum) goto say_yes; goto say_no; case O_FTTTY: if (arg[1].arg_type & A_DONT) { stab = arg[1].arg_ptr.arg_stab; tmps = ""; } else stab = stabent(tmps = str_get(st[1]),FALSE); if (stab && stab_io(stab) && stab_io(stab)->ifp) anum = fileno(stab_io(stab)->ifp); else if (isdigit(*tmps)) anum = atoi(tmps); else goto say_undef; if (isatty(anum)) goto say_yes; goto say_no; case O_FTTEXT: case O_FTBINARY: str = do_fttext(arg,st[1]); break; #ifdef SOCKET case O_SOCKET: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); #ifndef lint value = (double)do_socket(stab,arglast); #else (void)do_socket(stab,arglast); #endif goto donumset; case O_BIND: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); #ifndef lint value = (double)do_bind(stab,arglast); #else (void)do_bind(stab,arglast); #endif goto donumset; case O_CONNECT: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); #ifndef lint value = (double)do_connect(stab,arglast); #else (void)do_connect(stab,arglast); #endif goto donumset; case O_LISTEN: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); #ifndef lint value = (double)do_listen(stab,arglast); #else (void)do_listen(stab,arglast); #endif goto donumset; case O_ACCEPT: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); if ((arg[2].arg_type & A_MASK) == A_WORD) stab2 = arg[2].arg_ptr.arg_stab; else stab2 = stabent(str_get(st[2]),TRUE); do_accept(str,stab,stab2); STABSET(str); break; case O_GHBYNAME: if (maxarg < 1) goto say_undef; case O_GHBYADDR: case O_GHOSTENT: sp = do_ghent(optype, gimme,arglast); goto array_return; case O_GNBYNAME: if (maxarg < 1) goto say_undef; case O_GNBYADDR: case O_GNETENT: sp = do_gnent(optype, gimme,arglast); goto array_return; case O_GPBYNAME: if (maxarg < 1) goto say_undef; case O_GPBYNUMBER: case O_GPROTOENT: sp = do_gpent(optype, gimme,arglast); goto array_return; case O_GSBYNAME: if (maxarg < 1) goto say_undef; case O_GSBYPORT: case O_GSERVENT: sp = do_gsent(optype, gimme,arglast); goto array_return; case O_SHOSTENT: value = (double) sethostent((int)str_gnum(st[1])); goto donumset; case O_SNETENT: value = (double) setnetent((int)str_gnum(st[1])); goto donumset; case O_SPROTOENT: value = (double) setprotoent((int)str_gnum(st[1])); goto donumset; case O_SSERVENT: value = (double) setservent((int)str_gnum(st[1])); goto donumset; case O_EHOSTENT: value = (double) endhostent(); goto donumset; case O_ENETENT: value = (double) endnetent(); goto donumset; case O_EPROTOENT: value = (double) endprotoent(); goto donumset; case O_ESERVENT: value = (double) endservent(); goto donumset; case O_SSELECT: sp = do_select(gimme,arglast); goto array_return; case O_SOCKETPAIR: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); if ((arg[2].arg_type & A_MASK) == A_WORD) stab2 = arg[2].arg_ptr.arg_stab; else stab2 = stabent(str_get(st[2]),TRUE); #ifndef lint value = (double)do_spair(stab,stab2,arglast); #else (void)do_spair(stab,stab2,arglast); #endif goto donumset; case O_SHUTDOWN: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); #ifndef lint value = (double)do_shutdown(stab,arglast); #else (void)do_shutdown(stab,arglast); #endif goto donumset; case O_GSOCKOPT: case O_SSOCKOPT: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); sp = do_sopt(optype,stab,arglast); goto array_return; case O_GETSOCKNAME: case O_GETPEERNAME: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); sp = do_getsockname(optype,stab,arglast); goto array_return; #else /* SOCKET not defined */ case O_SOCKET: case O_BIND: case O_CONNECT: case O_LISTEN: case O_ACCEPT: case O_SSELECT: case O_SOCKETPAIR: case O_GHBYNAME: case O_GHBYADDR: case O_GHOSTENT: case O_GNBYNAME: case O_GNBYADDR: case O_GNETENT: case O_GPBYNAME: case O_GPBYNUMBER: case O_GPROTOENT: case O_GSBYNAME: case O_GSBYPORT: case O_GSERVENT: case O_SHOSTENT: case O_SNETENT: case O_SPROTOENT: case O_SSERVENT: case O_EHOSTENT: case O_ENETENT: case O_EPROTOENT: case O_ESERVENT: case O_SHUTDOWN: case O_GSOCKOPT: case O_SSOCKOPT: case O_GETSOCKNAME: case O_GETPEERNAME: badsock: fatal("Unsupported socket function"); #endif /* SOCKET */ case O_FILENO: if (maxarg < 1) goto say_undef; if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp)) goto say_undef; value = fileno(fp); goto donumset; case O_VEC: sp = do_vec(str == st[1], arg->arg_ptr.arg_str, arglast); goto array_return; case O_GPWNAM: case O_GPWUID: case O_GPWENT: sp = do_gpwent(optype, gimme,arglast); goto array_return; case O_SPWENT: value = (double) setpwent(); goto donumset; case O_EPWENT: value = (double) endpwent(); goto donumset; case O_GGRNAM: case O_GGRGID: case O_GGRENT: sp = do_ggrent(optype, gimme,arglast); goto array_return; case O_SGRENT: value = (double) setgrent(); goto donumset; case O_EGRENT: value = (double) endgrent(); goto donumset; case O_GETLOGIN: if (!(tmps = getlogin())) goto say_undef; str_set(str,tmps); break; case O_OPENDIR: case O_READDIR: case O_TELLDIR: case O_SEEKDIR: case O_REWINDDIR: case O_CLOSEDIR: if (maxarg < 1) goto say_undef; if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); sp = do_dirop(optype,stab,gimme,arglast); goto array_return; case O_SYSCALL: value = (double)do_syscall(arglast); goto donumset; case O_PIPE: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else stab = stabent(str_get(st[1]),TRUE); if ((arg[2].arg_type & A_MASK) == A_WORD) stab2 = arg[2].arg_ptr.arg_stab; else stab2 = stabent(str_get(st[2]),TRUE); do_pipe(str,stab,stab2); STABSET(str); break; } normal_return: st[1] = str; #ifdef DEBUGGING if (debug) { dlevel--; if (debug & 8) deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str)); } #endif return arglast[0] + 1; array_return: #ifdef DEBUGGING if (debug) { dlevel--; if (debug & 8) { anum = sp - arglast[0]; switch (anum) { case 0: deb("%s RETURNS ()\n",opname[optype]); break; case 1: deb("%s RETURNS (\"%s\")\n",opname[optype],str_get(st[1])); break; default: deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\"\n",opname[optype],anum, str_get(st[1]),anum==2?"":"...,",str_get(st[anum])); break; } } } #endif return sp; say_yes: str = &str_yes; goto normal_return; say_no: str = &str_no; goto normal_return; say_undef: str = &str_undef; goto normal_return; say_zero: value = 0.0; /* FALL THROUGH */ donumset: str_numset(str,value); STABSET(str); st[1] = str; #ifdef DEBUGGING if (debug) { dlevel--; if (debug & 8) deb("%s RETURNS \"%f\"\n",opname[optype],value); } #endif return arglast[0] + 1; } str_get(st[anum])); break; } } } #endif return sp; say_yes: str = &str_yes; goto normal_return; say_no: str = &str_no; goto normal_return; say_undef: str = &str_undef; goto normal_return; say_zero: value = 0.0; /* FALL THROUGH */ donumset: str_numset(str,value); STABSET(str); st[1] = str; #ifdef DEBUGGING if (debug) { dlevel--; if (debug & 8)perl/x2p/walk.c 644 473 0 135616 4747105017 6721 /* $Header: walk.c,v 3.0.1.4 90/03/01 10:32:45 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: walk.c,v $ * Revision 3.0.1.4 90/03/01 10:32:45 lwall * patch9: a2p didn't put a $ on ExitValue * * Revision 3.0.1.3 89/12/21 20:32:35 lwall * patch7: in a2p, user-defined functions didn't work on some machines * * Revision 3.0.1.2 89/11/17 15:53:00 lwall * patch5: on Pyramids, index(s, '}' + 128) doesn't find meta-} * * Revision 3.0.1.1 89/11/11 05:09:33 lwall * patch2: in a2p, awk script with no line actions still needs main loop * * Revision 3.0 89/10/18 15:35:48 lwall * 3.0 baseline * */ #include "handy.h" #include "EXTERN.h" #include "util.h" #include "a2p.h" bool exitval = FALSE; bool realexit = FALSE; bool saw_getline = FALSE; bool subretnum = FALSE; bool saw_FNR = FALSE; bool saw_argv0 = FALSE; int maxtmp = 0; char *lparen; char *rparen; STR *subs; STR *curargs = Nullstr; STR * walk(useval,level,node,numericptr,minprec) int useval; int level; register int node; int *numericptr; int minprec; /* minimum precedence without parens */ { register int len; register STR *str; register int type; register int i; register STR *tmpstr; STR *tmp2str; STR *tmp3str; char *t; char *d, *s; int numarg; int numeric = FALSE; STR *fstr; int prec = P_MAX; /* assume no parens needed */ char *index(); if (!node) { *numericptr = 0; return str_make(""); } type = ops[node].ival; len = type >> 8; type &= 255; switch (type) { case OPROG: opens = str_new(0); subs = str_new(0); str = walk(0,level,ops[node+1].ival,&numarg,P_MIN); if (do_split && need_entire && !absmaxfld) split_to_array = TRUE; if (do_split && split_to_array) set_array_base = TRUE; if (set_array_base) { str_cat(str,"$[ = 1;\t\t\t# set array base to 1\n"); } if (fswitch && !const_FS) const_FS = fswitch; if (saw_FS > 1 || saw_RS) const_FS = 0; if (saw_ORS && need_entire) do_chop = TRUE; if (fswitch) { str_cat(str,"$FS = '"); if (index("*+?.[]()|^$\\",fswitch)) str_cat(str,"\\"); sprintf(tokenbuf,"%c",fswitch); str_cat(str,tokenbuf); str_cat(str,"';\t\t# field separator from -F switch\n"); } else if (saw_FS && !const_FS) { str_cat(str,"$FS = ' ';\t\t# set field separator\n"); } if (saw_OFS) { str_cat(str,"$, = ' ';\t\t# set output field separator\n"); } if (saw_ORS) { str_cat(str,"$\\ = \"\\n\";\t\t# set output record separator\n"); } if (saw_argv0) { str_cat(str,"$ARGV0 = $0;\t\t# remember what we ran as\n"); } if (str->str_cur > 20) str_cat(str,"\n"); if (ops[node+2].ival) { str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,"\n\n"); } fstr = walk(0,level+1,ops[node+3].ival,&numarg,P_MIN); if (*fstr->str_ptr) { if (saw_line_op) str_cat(str,"line: "); str_cat(str,"while (<>) {\n"); tab(str,++level); if (saw_FS && !const_FS) do_chop = TRUE; if (do_chop) { str_cat(str,"chop;\t# strip record separator\n"); tab(str,level); } arymax = 0; if (namelist) { while (isalpha(*namelist)) { for (d = tokenbuf,s=namelist; isalpha(*s) || isdigit(*s) || *s == '_'; *d++ = *s++) ; *d = '\0'; while (*s && !isalpha(*s)) s++; namelist = s; nameary[++arymax] = savestr(tokenbuf); } } if (maxfld < arymax) maxfld = arymax; if (do_split) emit_split(str,level); str_scat(str,fstr); str_free(fstr); fixtab(str,--level); str_cat(str,"}\n"); if (saw_FNR) str_cat(str,"continue {\n $FNRbase = $. if eof;\n}\n"); } else str_cat(str,"while (<>) { } # (no line actions)\n"); if (ops[node+4].ival) { realexit = TRUE; str_cat(str,"\n"); tab(str,level); str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,"\n"); } if (exitval) str_cat(str,"exit $ExitValue;\n"); if (subs->str_ptr) { str_cat(str,"\n"); str_scat(str,subs); } if (saw_getline) { for (len = 0; len < 4; len++) { if (saw_getline & (1 << len)) { sprintf(tokenbuf,"\nsub Getline%d {\n",len); str_cat(str, tokenbuf); if (len & 2) { if (do_fancy_opens) str_cat(str," &Pick('',@_);\n"); else str_cat(str," ($fh) = @_;\n"); } else { if (saw_FNR) str_cat(str," $FNRbase = $. if eof;\n"); } if (len & 1) str_cat(str," local($_)\n"); if (len & 2) str_cat(str, " if ($getline_ok = (($_ = <$fh>) ne ''))"); else str_cat(str, " if ($getline_ok = (($_ = <>) ne ''))"); str_cat(str, " {\n"); level += 2; tab(str,level); i = 0; if (do_chop) { i++; str_cat(str,"chop;\t# strip record separator\n"); tab(str,level); } if (do_split && !(len & 1)) { i++; emit_split(str,level); } if (!i) str_cat(str,";\n"); fixtab(str,--level); str_cat(str,"}\n $_;\n}\n"); --level; } } } if (do_fancy_opens) { str_cat(str,"\n\ sub Pick {\n\ local($mode,$name,$pipe) = @_;\n\ $fh = $opened{$name};\n\ if (!$fh) {\n\ $fh = $opened{$name} = 'fh_' . ($nextfh++ + 0);\n\ open($fh,$mode.$name.$pipe);\n\ }\n\ }\n\ "); } break; case OHUNKS: str = walk(0,level,ops[node+1].ival,&numarg,P_MIN); str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); if (len == 3) { str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN)); str_free(fstr); } else { } break; case ORANGE: prec = P_DOTDOT; str = walk(1,level,ops[node+1].ival,&numarg,prec+1); str_cat(str," .. "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); break; case OPAT: goto def; case OREGEX: str = str_new(0); str_set(str,"/"); tmpstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN); /* translate \nnn to [\nnn] */ for (s = tmpstr->str_ptr, d = tokenbuf; *s; s++, d++) { if (*s == '\\' && isdigit(s[1]) && isdigit(s[2]) && isdigit(s[3])){ *d++ = '['; *d++ = *s++; *d++ = *s++; *d++ = *s++; *d++ = *s; *d = ']'; } else *d = *s; } *d = '\0'; for (d=tokenbuf; *d; d++) *d += 128; str_cat(str,tokenbuf); str_free(tmpstr); str_cat(str,"/"); break; case OHUNK: if (len == 1) { str = str_new(0); str = walk(0,level,oper1(OPRINT,0),&numarg,P_MIN); str_cat(str," if "); str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,";"); } else { tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN); if (*tmpstr->str_ptr) { str = str_new(0); str_set(str,"if ("); str_scat(str,tmpstr); str_cat(str,") {\n"); tab(str,++level); str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); fixtab(str,--level); str_cat(str,"}\n"); tab(str,level); } else { str = walk(0,level,ops[node+2].ival,&numarg,P_MIN); } } break; case OPPAREN: str = str_new(0); str_set(str,"("); str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,")"); break; case OPANDAND: prec = P_ANDAND; str = walk(1,level,ops[node+1].ival,&numarg,prec); str_cat(str," && "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1)); str_free(fstr); break; case OPOROR: prec = P_OROR; str = walk(1,level,ops[node+1].ival,&numarg,prec); str_cat(str," || "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1)); str_free(fstr); break; case OPNOT: prec = P_UNARY; str = str_new(0); str_set(str,"!"); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec)); str_free(fstr); break; case OCPAREN: str = str_new(0); str_set(str,"("); str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); numeric |= numarg; str_cat(str,")"); break; case OCANDAND: prec = P_ANDAND; str = walk(1,level,ops[node+1].ival,&numarg,prec); numeric = 1; str_cat(str," && "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1)); str_free(fstr); break; case OCOROR: prec = P_OROR; str = walk(1,level,ops[node+1].ival,&numarg,prec); numeric = 1; str_cat(str," || "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1)); str_free(fstr); break; case OCNOT: prec = P_UNARY; str = str_new(0); str_set(str,"!"); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec)); str_free(fstr); numeric = 1; break; case ORELOP: prec = P_REL; str = walk(1,level,ops[node+2].ival,&numarg,prec+1); numeric |= numarg; tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN); tmp2str = walk(1,level,ops[node+3].ival,&numarg,prec+1); numeric |= numarg; if (!numeric || (!numarg && (*tmp2str->str_ptr == '"' || *tmp2str->str_ptr == '\''))) { t = tmpstr->str_ptr; if (strEQ(t,"==")) str_set(tmpstr,"eq"); else if (strEQ(t,"!=")) str_set(tmpstr,"ne"); else if (strEQ(t,"<")) str_set(tmpstr,"lt"); else if (strEQ(t,"<=")) str_set(tmpstr,"le"); else if (strEQ(t,">")) str_set(tmpstr,"gt"); else if (strEQ(t,">=")) str_set(tmpstr,"ge"); if (!index(tmpstr->str_ptr,'\'') && !index(tmpstr->str_ptr,'"') && !index(tmp2str->str_ptr,'\'') && !index(tmp2str->str_ptr,'"') ) numeric |= 2; } if (numeric & 2) { if (numeric & 1) /* numeric is very good guess */ str_cat(str," "); else str_cat(str,"\377"); numeric = 1; } else str_cat(str," "); str_scat(str,tmpstr); str_free(tmpstr); str_cat(str," "); str_scat(str,tmp2str); str_free(tmp2str); numeric = 1; break; case ORPAREN: str = str_new(0); str_set(str,"("); str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); numeric |= numarg; str_cat(str,")"); break; case OMATCHOP: prec = P_MATCH; str = walk(1,level,ops[node+2].ival,&numarg,prec+1); str_cat(str," "); tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN); if (strEQ(tmpstr->str_ptr,"~")) str_cat(str,"=~"); else { str_scat(str,tmpstr); str_free(tmpstr); } str_cat(str," "); str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1)); str_free(fstr); numeric = 1; break; case OMPAREN: str = str_new(0); str_set(str,"("); str_scat(str, fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); numeric |= numarg; str_cat(str,")"); break; case OCONCAT: prec = P_ADD; type = ops[ops[node+1].ival].ival & 255; str = walk(1,level,ops[node+1].ival,&numarg,prec+(type != OCONCAT)); str_cat(str," . "); type = ops[ops[node+2].ival].ival & 255; str_scat(str, fstr=walk(1,level,ops[node+2].ival,&numarg,prec+(type != OCONCAT))); str_free(fstr); break; case OASSIGN: prec = P_ASSIGN; str = walk(0,level,ops[node+2].ival,&numarg,prec+1); str_cat(str," "); tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN); str_scat(str,tmpstr); if (str_len(tmpstr) > 1) numeric = 1; str_free(tmpstr); str_cat(str," "); str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec)); str_free(fstr); numeric |= numarg; break; case OADD: prec = P_ADD; str = walk(1,level,ops[node+1].ival,&numarg,prec); str_cat(str," + "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); numeric = 1; break; case OSUBTRACT: prec = P_ADD; str = walk(1,level,ops[node+1].ival,&numarg,prec); str_cat(str," - "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); numeric = 1; break; case OMULT: prec = P_MUL; str = walk(1,level,ops[node+1].ival,&numarg,prec); str_cat(str," * "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); numeric = 1; break; case ODIV: prec = P_MUL; str = walk(1,level,ops[node+1].ival,&numarg,prec); str_cat(str," / "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); numeric = 1; break; case OPOW: prec = P_POW; str = walk(1,level,ops[node+1].ival,&numarg,prec+1); str_cat(str," ** "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec)); str_free(fstr); numeric = 1; break; case OMOD: prec = P_MUL; str = walk(1,level,ops[node+1].ival,&numarg,prec); str_cat(str," % "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1)); str_free(fstr); numeric = 1; break; case OPOSTINCR: prec = P_AUTO; str = walk(1,level,ops[node+1].ival,&numarg,prec+1); str_cat(str,"++"); numeric = 1; break; case OPOSTDECR: prec = P_AUTO; str = walk(1,level,ops[node+1].ival,&numarg,prec+1); str_cat(str,"--"); numeric = 1; break; case OPREINCR: prec = P_AUTO; str = str_new(0); str_set(str,"++"); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1)); str_free(fstr); numeric = 1; break; case OPREDECR: prec = P_AUTO; str = str_new(0); str_set(str,"--"); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1)); str_free(fstr); numeric = 1; break; case OUMINUS: prec = P_UNARY; str = str_new(0); str_set(str,"-"); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec)); str_free(fstr); numeric = 1; break; case OUPLUS: numeric = 1; goto def; case OPAREN: str = str_new(0); str_set(str,"("); str_scat(str, fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,")"); numeric |= numarg; break; case OGETLINE: str = str_new(0); if (useval) str_cat(str,"("); if (len > 0) { str_cat(str,"$"); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); if (!*fstr->str_ptr) { str_cat(str,"_"); len = 2; /* a legal fiction */ } str_free(fstr); } else str_cat(str,"$_"); if (len > 1) { tmpstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN); fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN); if (!do_fancy_opens) { t = tmpstr->str_ptr; if (*t == '"' || *t == '\'') t = cpytill(tokenbuf,t+1,*t); else fatal("Internal error: OGETLINE %s", t); d = savestr(t); s = savestr(tokenbuf); for (t = tokenbuf; *t; t++) { *t &= 127; if (!isalpha(*t) && !isdigit(*t)) *t = '_'; } if (!index(tokenbuf,'_')) strcpy(t,"_fh"); tmp3str = hfetch(symtab,tokenbuf); if (!tmp3str) { do_opens = TRUE; str_cat(opens,"open("); str_cat(opens,tokenbuf); str_cat(opens,", "); d[1] = '\0'; str_cat(opens,d); str_cat(opens,tmpstr->str_ptr+1); opens->str_cur--; if (*fstr->str_ptr == '|') str_cat(opens,"|"); str_cat(opens,d); if (*fstr->str_ptr == '|') str_cat(opens,") || die 'Cannot pipe from \""); else str_cat(opens,") || die 'Cannot open file \""); if (*d == '"') str_cat(opens,"'.\""); str_cat(opens,s); if (*d == '"') str_cat(opens,"\".'"); str_cat(opens,"\".';\n"); hstore(symtab,tokenbuf,str_make("x")); } safefree(s); safefree(d); str_set(tmpstr,"'"); str_cat(tmpstr,tokenbuf); str_cat(tmpstr,"'"); } if (*fstr->str_ptr == '|') str_cat(tmpstr,", '|'"); str_free(fstr); } else tmpstr = str_make(""); sprintf(tokenbuf," = &Getline%d(%s)",len,tmpstr->str_ptr); str_cat(str,tokenbuf); str_free(tmpstr); if (useval) str_cat(str,",$getline_ok)"); saw_getline |= 1 << len; break; case OSPRINTF: str = str_new(0); str_set(str,"sprintf("); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,")"); break; case OSUBSTR: str = str_new(0); str_set(str,"substr("); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1)); str_free(fstr); str_cat(str,", "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_COMMA+1)); str_free(fstr); str_cat(str,", "); if (len == 3) { str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_COMMA+1)); str_free(fstr); } else str_cat(str,"999999"); str_cat(str,")"); break; case OSTRING: str = str_new(0); str_set(str,ops[node+1].cval); break; case OSPLIT: str = str_new(0); numeric = 1; tmpstr = walk(1,level,ops[node+2].ival,&numarg,P_MIN); if (useval) str_set(str,"(@"); else str_set(str,"@"); str_scat(str,tmpstr); str_cat(str," = split("); if (len == 3) { fstr = walk(1,level,ops[node+3].ival,&numarg,P_COMMA+1); if (str_len(fstr) == 3 && *fstr->str_ptr == '\'') { i = fstr->str_ptr[1] & 127; if (index("*+?.[]()|^$\\",i)) sprintf(tokenbuf,"/\\%c/",i); else sprintf(tokenbuf,"/%c/",i); str_cat(str,tokenbuf); } else str_scat(str,fstr); str_free(fstr); } else if (const_FS) { sprintf(tokenbuf,"/[%c\\n]/",const_FS); str_cat(str,tokenbuf); } else if (saw_FS) str_cat(str,"$FS"); else str_cat(str,"' '"); str_cat(str,", "); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1)); str_free(fstr); str_cat(str,", 999)"); if (useval) { str_cat(str,")"); } str_free(tmpstr); break; case OINDEX: str = str_new(0); str_set(str,"index("); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1)); str_free(fstr); str_cat(str,", "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_COMMA+1)); str_free(fstr); str_cat(str,")"); numeric = 1; break; case OMATCH: str = str_new(0); prec = P_ANDAND; str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MATCH+1)); str_free(fstr); str_cat(str," =~ "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MATCH+1)); str_free(fstr); str_cat(str," && ($RLENGTH = length($&), $RSTART = length($`)+1)"); numeric = 1; break; case OUSERDEF: str = str_new(0); subretnum = FALSE; fstr=walk(1,level-1,ops[node+2].ival,&numarg,P_MIN); curargs = str_new(0); str_sset(curargs,fstr); str_cat(curargs,","); tmp2str=walk(1,level,ops[node+5].ival,&numarg,P_MIN); str_free(curargs); curargs = Nullstr; level--; subretnum |= numarg; s = Nullch; t = tmp2str->str_ptr; while (t = instr(t,"return ")) s = t++; if (s) { i = 0; for (t = s+7; *t; t++) { if (*t == ';' || *t == '}') i++; } if (i == 1) { strcpy(s,s+7); tmp2str->str_cur -= 7; } } str_set(str,"\n"); tab(str,level); str_cat(str,"sub "); str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); str_cat(str," {\n"); tab(str,++level); if (fstr->str_cur) { str_cat(str,"local("); str_scat(str,fstr); str_cat(str,") = @_;"); } str_free(fstr); str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN)); str_free(fstr); fixtab(str,level); str_scat(str,fstr=walk(1,level,ops[node+4].ival,&numarg,P_MIN)); str_free(fstr); fixtab(str,level); str_scat(str,tmp2str); str_free(tmp2str); fixtab(str,--level); str_cat(str,"}\n"); tab(str,level); str_scat(subs,str); str_set(str,""); str_cat(tmpstr,"("); tmp2str = str_new(0); if (subretnum) str_set(tmp2str,"1"); hstore(symtab,tmpstr->str_ptr,tmp2str); str_free(tmpstr); level++; break; case ORETURN: str = str_new(0); if (len > 0) { str_cat(str,"return "); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_UNI+1)); str_free(fstr); if (numarg) subretnum = TRUE; } else str_cat(str,"return"); break; case OUSERFUN: str = str_new(0); str_set(str,"&"); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,"("); tmpstr = hfetch(symtab,str->str_ptr+3); if (tmpstr && tmpstr->str_ptr) numeric |= atoi(tmpstr->str_ptr); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,")"); break; case OGSUB: case OSUB: if (type == OGSUB) s = "g"; else s = ""; str = str_new(0); tmpstr = str_new(0); i = 0; if (len == 3) { tmpstr = walk(1,level,ops[node+3].ival,&numarg,P_MATCH+1); if (strNE(tmpstr->str_ptr,"$_")) { str_cat(tmpstr, " =~ s"); i++; } else str_set(tmpstr, "s"); } else str_set(tmpstr, "s"); type = ops[ops[node+2].ival].ival; len = type >> 8; type &= 255; tmp3str = str_new(0); if (type == OSTR) { tmp2str=walk(1,level,ops[ops[node+2].ival+1].ival,&numarg,P_MIN); for (t = tmp2str->str_ptr, d=tokenbuf; *t; d++,t++) { if (*t == '&') *d++ = '$' + 128; else if (*t == '$') *d++ = '\\' + 128; *d = *t + 128; } *d = '\0'; str_set(tmp2str,tokenbuf); } else { tmp2str=walk(1,level,ops[node+2].ival,&numarg,P_MIN); str_set(tmp3str,"($s_ = '\"'.("); str_scat(tmp3str,tmp2str); str_cat(tmp3str,").'\"') =~ s/&/\\$&/g, "); str_set(tmp2str,"eval $s_"); s = (*s == 'g' ? "ge" : "e"); i++; } type = ops[ops[node+1].ival].ival; len = type >> 8; type &= 255; fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN); if (type == OREGEX) { if (useval && i) str_cat(str,"("); str_scat(str,tmp3str); str_scat(str,tmpstr); str_scat(str,fstr); str_scat(str,tmp2str); str_cat(str,"/"); str_cat(str,s); } else if ((type == OFLD && !split_to_array) || (type == OVAR && len == 1)) { if (useval && i) str_cat(str,"("); str_scat(str,tmp3str); str_scat(str,tmpstr); str_cat(str,"/"); str_scat(str,fstr); str_cat(str,"/"); str_scat(str,tmp2str); str_cat(str,"/"); str_cat(str,s); } else { i++; if (useval) str_cat(str,"("); str_cat(str,"$s = "); str_scat(str,fstr); str_cat(str,", "); str_scat(str,tmp3str); str_scat(str,tmpstr); str_cat(str,"/$s/"); str_scat(str,tmp2str); str_cat(str,"/"); str_cat(str,s); } if (useval && i) str_cat(str,")"); str_free(fstr); str_free(tmpstr); str_free(tmp2str); str_free(tmp3str); numeric = 1; break; case ONUM: str = walk(1,level,ops[node+1].ival,&numarg,P_MIN); numeric = 1; break; case OSTR: tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN); s = "'"; for (t = tmpstr->str_ptr, d=tokenbuf; *t; d++,t++) { if (*t == '\'') s = "\""; else if (*t == '\\') { s = "\""; *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_cat(str,tokenbuf); str_free(tmpstr); str_cat(str,s); break; case ODEFINED: prec = P_UNI; str = str_new(0); str_set(str,"defined $"); goto addvar; case ODELETE: str = str_new(0); str_set(str,"delete $"); goto addvar; case OSTAR: str = str_new(0); str_set(str,"*"); goto addvar; case OVAR: str = str_new(0); str_set(str,"$"); addvar: str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); if (len == 1) { tmp2str = hfetch(symtab,tmpstr->str_ptr); if (tmp2str && atoi(tmp2str->str_ptr)) numeric = 2; if (strEQ(str->str_ptr,"$FNR")) { numeric = 1; saw_FNR++; str_set(str,"($.-$FNRbase)"); } else if (strEQ(str->str_ptr,"$NR")) { numeric = 1; str_set(str,"$."); } else if (strEQ(str->str_ptr,"$NF")) { numeric = 1; str_set(str,"$#Fld"); } else if (strEQ(str->str_ptr,"$0")) str_set(str,"$_"); else if (strEQ(str->str_ptr,"$ARGC")) str_set(str,"($#ARGV+1)"); } else { #ifdef NOTDEF if (curargs) { sprintf(tokenbuf,"$%s,",tmpstr->str_ptr); ??? if (instr(curargs->str_ptr,tokenbuf)) str_cat(str,"\377"); /* can't translate yet */ } #endif str_cat(tmpstr,"[]"); tmp2str = hfetch(symtab,tmpstr->str_ptr); if (tmp2str && atoi(tmp2str->str_ptr)) str_cat(str,"["); else str_cat(str,"{"); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); if (strEQ(str->str_ptr,"$ARGV[0")) { str_set(str,"$ARGV0"); saw_argv0++; } else { if (tmp2str && atoi(tmp2str->str_ptr)) strcpy(tokenbuf,"]"); else strcpy(tokenbuf,"}"); *tokenbuf += 128; str_cat(str,tokenbuf); } } str_free(tmpstr); break; case OFLD: str = str_new(0); if (split_to_array) { str_set(str,"$Fld"); str_cat(str,"["); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,"]"); } else { i = atoi(walk(1,level,ops[node+1].ival,&numarg,P_MIN)->str_ptr); if (i <= arymax) sprintf(tokenbuf,"$%s",nameary[i]); else sprintf(tokenbuf,"$Fld%d",i); str_set(str,tokenbuf); } break; case OVFLD: str = str_new(0); str_set(str,"$Fld["); i = ops[node+1].ival; if ((ops[i].ival & 255) == OPAREN) i = ops[i+1].ival; tmpstr=walk(1,level,i,&numarg,P_MIN); str_scat(str,tmpstr); str_free(tmpstr); str_cat(str,"]"); break; case OJUNK: goto def; case OSNEWLINE: str = str_new(2); str_set(str,";\n"); tab(str,level); break; case ONEWLINE: str = str_new(1); str_set(str,"\n"); tab(str,level); break; case OSCOMMENT: str = str_new(0); str_set(str,";"); tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN); for (s = tmpstr->str_ptr; *s && *s != '\n'; s++) *s += 128; str_scat(str,tmpstr); str_free(tmpstr); tab(str,level); break; case OCOMMENT: str = str_new(0); tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN); for (s = tmpstr->str_ptr; *s && *s != '\n'; s++) *s += 128; str_scat(str,tmpstr); str_free(tmpstr); tab(str,level); break; case OCOMMA: prec = P_COMMA; str = walk(1,level,ops[node+1].ival,&numarg,prec); str_cat(str,", "); str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1)); str_free(fstr); break; case OSEMICOLON: str = str_new(1); str_set(str,";\n"); tab(str,level); break; case OSTATES: str = walk(0,level,ops[node+1].ival,&numarg,P_MIN); str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); break; case OSTATE: str = str_new(0); if (len >= 1) { str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); if (len >= 2) { tmpstr = walk(0,level,ops[node+2].ival,&numarg,P_MIN); if (*tmpstr->str_ptr == ';') { addsemi(str); str_cat(str,tmpstr->str_ptr+1); } str_free(tmpstr); } } break; case OCLOSE: str = str_make("close("); tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN); if (!do_fancy_opens) { t = tmpstr->str_ptr; if (*t == '"' || *t == '\'') t = cpytill(tokenbuf,t+1,*t); else fatal("Internal error: OCLOSE %s",t); s = savestr(tokenbuf); for (t = tokenbuf; *t; t++) { *t &= 127; if (!isalpha(*t) && !isdigit(*t)) *t = '_'; } if (!index(tokenbuf,'_')) strcpy(t,"_fh"); str_free(tmpstr); safefree(s); str_set(str,"close "); str_cat(str,tokenbuf); } else { sprintf(tokenbuf,"$fh = delete $opened{%s} && close($fh)", tmpstr->str_ptr); str_free(tmpstr); str_set(str,tokenbuf); } break; case OPRINTF: case OPRINT: lparen = ""; /* set to parens if necessary */ rparen = ""; str = str_new(0); if (len == 3) { /* output redirection */ tmpstr = walk(1,level,ops[node+3].ival,&numarg,P_MIN); tmp2str = walk(1,level,ops[node+2].ival,&numarg,P_MIN); if (!do_fancy_opens) { t = tmpstr->str_ptr; if (*t == '"' || *t == '\'') t = cpytill(tokenbuf,t+1,*t); else fatal("Internal error: OPRINT"); d = savestr(t); s = savestr(tokenbuf); for (t = tokenbuf; *t; t++) { *t &= 127; if (!isalpha(*t) && !isdigit(*t)) *t = '_'; } if (!index(tokenbuf,'_')) strcpy(t,"_fh"); tmp3str = hfetch(symtab,tokenbuf); if (!tmp3str) { str_cat(opens,"open("); str_cat(opens,tokenbuf); str_cat(opens,", "); d[1] = '\0'; str_cat(opens,d); str_scat(opens,tmp2str); str_cat(opens,tmpstr->str_ptr+1); if (*tmp2str->str_ptr == '|') str_cat(opens,") || die 'Cannot pipe to \""); else str_cat(opens,") || die 'Cannot create file \""); if (*d == '"') str_cat(opens,"'.\""); str_cat(opens,s); if (*d == '"') str_cat(opens,"\".'"); str_cat(opens,"\".';\n"); hstore(symtab,tokenbuf,str_make("x")); } str_free(tmpstr); str_free(tmp2str); safefree(s); safefree(d); } else { sprintf(tokenbuf,"&Pick('%s', %s) &&\n", tmp2str->str_ptr, tmpstr->str_ptr); str_cat(str,tokenbuf); tab(str,level+1); strcpy(tokenbuf,"$fh"); str_free(tmpstr); str_free(tmp2str); lparen = "("; rparen = ")"; } } else strcpy(tokenbuf,""); str_cat(str,lparen); /* may be null */ if (type == OPRINTF) str_cat(str,"printf"); else str_cat(str,"print"); if (len == 3 || do_fancy_opens) { if (*tokenbuf) str_cat(str," "); str_cat(str,tokenbuf); } tmpstr = walk(1+(type==OPRINT),level,ops[node+1].ival,&numarg,P_MIN); if (!*tmpstr->str_ptr && lval_field) { t = saw_OFS ? "$," : "' '"; if (split_to_array) { sprintf(tokenbuf,"join(%s,@Fld)",t); str_cat(tmpstr,tokenbuf); } else { for (i = 1; i < maxfld; i++) { if (i <= arymax) sprintf(tokenbuf,"$%s, ",nameary[i]); else sprintf(tokenbuf,"$Fld%d, ",i); str_cat(tmpstr,tokenbuf); } if (maxfld <= arymax) sprintf(tokenbuf,"$%s",nameary[maxfld]); else sprintf(tokenbuf,"$Fld%d",maxfld); str_cat(tmpstr,tokenbuf); } } if (*tmpstr->str_ptr) { str_cat(str," "); str_scat(str,tmpstr); } else { str_cat(str," $_"); } str_cat(str,rparen); /* may be null */ str_free(tmpstr); break; case ORAND: str = str_make("rand(1)"); break; case OSRAND: str = str_make("srand("); goto maybe0; case OATAN2: str = str_make("atan2("); goto maybe0; case OSIN: str = str_make("sin("); goto maybe0; case OCOS: str = str_make("cos("); goto maybe0; case OSYSTEM: str = str_make("system("); goto maybe0; case OLENGTH: str = str_make("length("); goto maybe0; case OLOG: str = str_make("log("); goto maybe0; case OEXP: str = str_make("exp("); goto maybe0; case OSQRT: str = str_make("sqrt("); goto maybe0; case OINT: str = str_make("int("); maybe0: numeric = 1; if (len > 0) tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN); else tmpstr = str_new(0);; if (!*tmpstr->str_ptr) { if (lval_field) { t = saw_OFS ? "$," : "' '"; if (split_to_array) { sprintf(tokenbuf,"join(%s,@Fld)",t); str_cat(tmpstr,tokenbuf); } else { sprintf(tokenbuf,"join(%s, ",t); str_cat(tmpstr,tokenbuf); for (i = 1; i < maxfld; i++) { if (i <= arymax) sprintf(tokenbuf,"$%s,",nameary[i]); else sprintf(tokenbuf,"$Fld%d,",i); str_cat(tmpstr,tokenbuf); } if (maxfld <= arymax) sprintf(tokenbuf,"$%s)",nameary[maxfld]); else sprintf(tokenbuf,"$Fld%d)",maxfld); str_cat(tmpstr,tokenbuf); } } else str_cat(tmpstr,"$_"); } if (strEQ(tmpstr->str_ptr,"$_")) { if (type == OLENGTH && !do_chop) { str = str_make("(length("); str_cat(tmpstr,") - 1"); } } str_scat(str,tmpstr); str_free(tmpstr); str_cat(str,")"); break; case OBREAK: str = str_new(0); str_set(str,"last"); break; case ONEXT: str = str_new(0); str_set(str,"next line"); break; case OEXIT: str = str_new(0); if (realexit) { prec = P_UNI; str_set(str,"exit"); if (len == 1) { str_cat(str," "); exitval = TRUE; str_scat(str, fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1)); str_free(fstr); } } else { if (len == 1) { str_set(str,"$ExitValue = "); exitval = TRUE; str_scat(str, fstr=walk(1,level,ops[node+1].ival,&numarg,P_ASSIGN)); str_free(fstr); str_cat(str,"; "); } str_cat(str,"last line"); } break; case OCONTINUE: str = str_new(0); str_set(str,"next"); break; case OREDIR: goto def; case OIF: str = str_new(0); str_set(str,"if ("); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,") "); str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); if (len == 3) { i = ops[node+3].ival; if (i) { if ((ops[i].ival & 255) == OBLOCK) { i = ops[i+1].ival; if (i) { if ((ops[i].ival & 255) != OIF) i = 0; } } else i = 0; } if (i) { str_cat(str,"els"); str_scat(str,fstr=walk(0,level,i,&numarg,P_MIN)); str_free(fstr); } else { str_cat(str,"else "); str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN)); str_free(fstr); } } break; case OWHILE: str = str_new(0); str_set(str,"while ("); str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,") "); str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); break; case OFOR: str = str_new(0); str_set(str,"for ("); str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); i = numarg; if (i) { t = s = tmpstr->str_ptr; while (isalpha(*t) || isdigit(*t) || *t == '$' || *t == '_') t++; i = t - s; if (i < 2) i = 0; } str_cat(str,"; "); fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN); if (i && (t = index(fstr->str_ptr,0377))) { if (strnEQ(fstr->str_ptr,s,i)) *t = ' '; } str_scat(str,fstr); str_free(fstr); str_free(tmpstr); str_cat(str,"; "); str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN)); str_free(fstr); str_cat(str,") "); str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg,P_MIN)); str_free(fstr); break; case OFORIN: tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN); d = index(tmpstr->str_ptr,'$'); if (!d) fatal("Illegal for loop: %s",tmpstr->str_ptr); s = index(d,'{'); if (!s) s = index(d,'['); if (!s) fatal("Illegal for loop: %s",d); *s++ = '\0'; for (t = s; i = *t; t++) { i &= 127; if (i == '}' || i == ']') break; } if (*t) *t = '\0'; str = str_new(0); str_set(str,d+1); str_cat(str,"[]"); tmp2str = hfetch(symtab,str->str_ptr); if (tmp2str && atoi(tmp2str->str_ptr)) { sprintf(tokenbuf, "foreach %s (@%s) ", s, d+1); } else { sprintf(tokenbuf, "foreach %s (keys %%%s) ", s, d+1); } str_set(str,tokenbuf); str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); str_free(tmpstr); break; case OBLOCK: str = str_new(0); str_set(str,"{"); if (len >= 2 && ops[node+2].ival) { str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN)); str_free(fstr); } fixtab(str,++level); str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN)); str_free(fstr); addsemi(str); fixtab(str,--level); str_cat(str,"}\n"); tab(str,level); if (len >= 3) { str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN)); str_free(fstr); } break; default: def: if (len) { if (len > 5) fatal("Garbage length in walk"); str = walk(0,level,ops[node+1].ival,&numarg,P_MIN); for (i = 2; i<= len; i++) { str_scat(str,fstr=walk(0,level,ops[node+i].ival,&numarg,P_MIN)); str_free(fstr); } } else { str = Nullstr; } break; } if (!str) str = str_new(0); if (useval && prec < minprec) { /* need parens? */ fstr = str_new(str->str_cur+2); str_nset(fstr,"(",1); str_scat(fstr,str); str_ncat(fstr,")",1); str_free(str); str = fstr; } *numericptr = numeric; #ifdef DEBUGGING if (debug & 4) { printf("%3d %5d %15s %d %4d ",level,node,opname[type],len,str->str_cur); for (t = str->str_ptr; *t && t - str->str_ptr < 40; t++) if (*t == '\n') printf("\\n"); else if (*t == '\t') printf("\\t"); else putchar(*t); putchar('\n'); } #endif return str; } tab(str,lvl) register STR *str; register int lvl; { while (lvl > 1) { str_cat(str,"\t"); lvl -= 2; } if (lvl) str_cat(str," "); } fixtab(str,lvl) register STR *str; register int lvl; { register char *s; /* strip trailing white space */ s = str->str_ptr+str->str_cur - 1; while (s >= str->str_ptr && (*s == ' ' || *s == '\t' || *s == '\n')) s--; s[1] = '\0'; str->str_cur = s + 1 - str->str_ptr; if (s >= str->str_ptr && *s != '\n') str_cat(str,"\n"); tab(str,lvl); } addsemi(str) register STR *str; { register char *s; s = str->str_ptr+str->str_cur - 1; while (s >= str->str_ptr && (*s == ' ' || *s == '\t' || *s == '\n')) s--; if (s >= str->str_ptr && *s != ';' && *s != '}') str_cat(str,";"); } emit_split(str,level) register STR *str; int level; { register int i; if (split_to_array) str_cat(str,"@Fld"); else { str_cat(str,"("); for (i = 1; i < maxfld; i++) { if (i <= arymax) sprintf(tokenbuf,"$%s,",nameary[i]); else sprintf(tokenbuf,"$Fld%d,",i); str_cat(str,tokenbuf); } if (maxfld <= arymax) sprintf(tokenbuf,"$%s)",nameary[maxfld]); else sprintf(tokenbuf,"$Fld%d)",maxfld); str_cat(str,tokenbuf); } if (const_FS) { sprintf(tokenbuf," = split(/[%c\\n]/, $_, 999);\n",const_FS); str_cat(str,tokenbuf); } else if (saw_FS) str_cat(str," = split($FS, $_, 999);\n"); else str_cat(str," = split(' ', $_, 999);\n"); tab(str,level); } prewalk(numit,level,node,numericptr) int numit; int level; register int node; int *numericptr; { register int len; register int type; register int i; char *t; char *d, *s; int numarg; int numeric = FALSE; STR *tmpstr; STR *tmp2str; if (!node) { *numericptr = 0; return 0; } type = ops[node].ival; len = type >> 8; type &= 255; switch (type) { case OPROG: prewalk(0,level,ops[node+1].ival,&numarg); if (ops[node+2].ival) { prewalk(0,level,ops[node+2].ival,&numarg); } ++level; prewalk(0,level,ops[node+3].ival,&numarg); --level; if (ops[node+3].ival) { prewalk(0,level,ops[node+4].ival,&numarg); } break; case OHUNKS: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); if (len == 3) { prewalk(0,level,ops[node+3].ival,&numarg); } break; case ORANGE: prewalk(1,level,ops[node+1].ival,&numarg); prewalk(1,level,ops[node+2].ival,&numarg); break; case OPAT: goto def; case OREGEX: prewalk(0,level,ops[node+1].ival,&numarg); break; case OHUNK: if (len == 1) { prewalk(0,level,ops[node+1].ival,&numarg); } else { i = prewalk(0,level,ops[node+1].ival,&numarg); if (i) { ++level; prewalk(0,level,ops[node+2].ival,&numarg); --level; } else { prewalk(0,level,ops[node+2].ival,&numarg); } } break; case OPPAREN: prewalk(0,level,ops[node+1].ival,&numarg); break; case OPANDAND: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); break; case OPOROR: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); break; case OPNOT: prewalk(0,level,ops[node+1].ival,&numarg); break; case OCPAREN: prewalk(0,level,ops[node+1].ival,&numarg); numeric |= numarg; break; case OCANDAND: prewalk(0,level,ops[node+1].ival,&numarg); numeric = 1; prewalk(0,level,ops[node+2].ival,&numarg); break; case OCOROR: prewalk(0,level,ops[node+1].ival,&numarg); numeric = 1; prewalk(0,level,ops[node+2].ival,&numarg); break; case OCNOT: prewalk(0,level,ops[node+1].ival,&numarg); numeric = 1; break; case ORELOP: prewalk(0,level,ops[node+2].ival,&numarg); numeric |= numarg; prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+3].ival,&numarg); numeric |= numarg; numeric = 1; break; case ORPAREN: prewalk(0,level,ops[node+1].ival,&numarg); numeric |= numarg; break; case OMATCHOP: prewalk(0,level,ops[node+2].ival,&numarg); prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+3].ival,&numarg); numeric = 1; break; case OMPAREN: prewalk(0,level,ops[node+1].ival,&numarg); numeric |= numarg; break; case OCONCAT: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); break; case OASSIGN: prewalk(0,level,ops[node+2].ival,&numarg); prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+3].ival,&numarg); if (numarg || strlen(ops[ops[node+1].ival+1].cval) > 1) { numericize(ops[node+2].ival); if (!numarg) numericize(ops[node+3].ival); } numeric |= numarg; break; case OADD: prewalk(1,level,ops[node+1].ival,&numarg); prewalk(1,level,ops[node+2].ival,&numarg); numeric = 1; break; case OSUBTRACT: prewalk(1,level,ops[node+1].ival,&numarg); prewalk(1,level,ops[node+2].ival,&numarg); numeric = 1; break; case OMULT: prewalk(1,level,ops[node+1].ival,&numarg); prewalk(1,level,ops[node+2].ival,&numarg); numeric = 1; break; case ODIV: prewalk(1,level,ops[node+1].ival,&numarg); prewalk(1,level,ops[node+2].ival,&numarg); numeric = 1; break; case OPOW: prewalk(1,level,ops[node+1].ival,&numarg); prewalk(1,level,ops[node+2].ival,&numarg); numeric = 1; break; case OMOD: prewalk(1,level,ops[node+1].ival,&numarg); prewalk(1,level,ops[node+2].ival,&numarg); numeric = 1; break; case OPOSTINCR: prewalk(1,level,ops[node+1].ival,&numarg); numeric = 1; break; case OPOSTDECR: prewalk(1,level,ops[node+1].ival,&numarg); numeric = 1; break; case OPREINCR: prewalk(1,level,ops[node+1].ival,&numarg); numeric = 1; break; case OPREDECR: prewalk(1,level,ops[node+1].ival,&numarg); numeric = 1; break; case OUMINUS: prewalk(1,level,ops[node+1].ival,&numarg); numeric = 1; break; case OUPLUS: prewalk(1,level,ops[node+1].ival,&numarg); numeric = 1; break; case OPAREN: prewalk(0,level,ops[node+1].ival,&numarg); numeric |= numarg; break; case OGETLINE: break; case OSPRINTF: prewalk(0,level,ops[node+1].ival,&numarg); break; case OSUBSTR: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(1,level,ops[node+2].ival,&numarg); if (len == 3) { prewalk(1,level,ops[node+3].ival,&numarg); } break; case OSTRING: break; case OSPLIT: numeric = 1; prewalk(0,level,ops[node+2].ival,&numarg); if (len == 3) prewalk(0,level,ops[node+3].ival,&numarg); prewalk(0,level,ops[node+1].ival,&numarg); break; case OINDEX: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); numeric = 1; break; case OMATCH: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); numeric = 1; break; case OUSERDEF: subretnum = FALSE; --level; tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN); ++level; prewalk(0,level,ops[node+2].ival,&numarg); prewalk(0,level,ops[node+4].ival,&numarg); prewalk(0,level,ops[node+5].ival,&numarg); --level; str_cat(tmpstr,"("); tmp2str = str_new(0); if (subretnum || numarg) str_set(tmp2str,"1"); hstore(symtab,tmpstr->str_ptr,tmp2str); str_free(tmpstr); level++; break; case ORETURN: if (len > 0) { prewalk(0,level,ops[node+1].ival,&numarg); if (numarg) subretnum = TRUE; } break; case OUSERFUN: tmp2str = str_new(0); str_scat(tmp2str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN)); fixrargs(tmpstr->str_ptr,ops[node+2].ival,0); str_free(tmpstr); str_cat(tmp2str,"("); tmpstr = hfetch(symtab,tmp2str->str_ptr); if (tmpstr && tmpstr->str_ptr) numeric |= atoi(tmpstr->str_ptr); prewalk(0,level,ops[node+2].ival,&numarg); str_free(tmp2str); break; case OGSUB: case OSUB: if (len >= 3) prewalk(0,level,ops[node+3].ival,&numarg); prewalk(0,level,ops[ops[node+2].ival+1].ival,&numarg); prewalk(0,level,ops[node+1].ival,&numarg); numeric = 1; break; case ONUM: prewalk(0,level,ops[node+1].ival,&numarg); numeric = 1; break; case OSTR: prewalk(0,level,ops[node+1].ival,&numarg); break; case ODEFINED: case ODELETE: case OSTAR: case OVAR: prewalk(0,level,ops[node+1].ival,&numarg); if (len == 1) { if (numit) numericize(node); } else { prewalk(0,level,ops[node+2].ival,&numarg); } break; case OFLD: prewalk(0,level,ops[node+1].ival,&numarg); break; case OVFLD: i = ops[node+1].ival; prewalk(0,level,i,&numarg); break; case OJUNK: goto def; case OSNEWLINE: break; case ONEWLINE: break; case OSCOMMENT: break; case OCOMMENT: break; case OCOMMA: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); prewalk(0,level,ops[node+3].ival,&numarg); break; case OSEMICOLON: break; case OSTATES: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); break; case OSTATE: if (len >= 1) { prewalk(0,level,ops[node+1].ival,&numarg); if (len >= 2) { prewalk(0,level,ops[node+2].ival,&numarg); } } break; case OCLOSE: prewalk(0,level,ops[node+1].ival,&numarg); break; case OPRINTF: case OPRINT: if (len == 3) { /* output redirection */ prewalk(0,level,ops[node+3].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); } prewalk(0+(type==OPRINT),level,ops[node+1].ival,&numarg); break; case ORAND: break; case OSRAND: goto maybe0; case OATAN2: goto maybe0; case OSIN: goto maybe0; case OCOS: goto maybe0; case OSYSTEM: goto maybe0; case OLENGTH: goto maybe0; case OLOG: goto maybe0; case OEXP: goto maybe0; case OSQRT: goto maybe0; case OINT: maybe0: numeric = 1; if (len > 0) prewalk(type != OLENGTH && type != OSYSTEM, level,ops[node+1].ival,&numarg); break; case OBREAK: break; case ONEXT: break; case OEXIT: if (len == 1) { prewalk(1,level,ops[node+1].ival,&numarg); } break; case OCONTINUE: break; case OREDIR: goto def; case OIF: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); if (len == 3) { prewalk(0,level,ops[node+3].ival,&numarg); } break; case OWHILE: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); break; case OFOR: prewalk(0,level,ops[node+1].ival,&numarg); prewalk(0,level,ops[node+2].ival,&numarg); prewalk(0,level,ops[node+3].ival,&numarg); prewalk(0,level,ops[node+4].ival,&numarg); break; case OFORIN: prewalk(0,level,ops[node+2].ival,&numarg); prewalk(0,level,ops[node+1].ival,&numarg); break; case OBLOCK: if (len == 2) { prewalk(0,level,ops[node+2].ival,&numarg); } ++level; prewalk(0,level,ops[node+1].ival,&numarg); --level; break; default: def: if (len) { if (len > 5) fatal("Garbage length in prewalk"); prewalk(0,level,ops[node+1].ival,&numarg); for (i = 2; i<= len; i++) { prewalk(0,level,ops[node+i].ival,&numarg); } } break; } *numericptr = numeric; return 1; } numericize(node) register int node; { register int len; register int type; register int i; STR *tmpstr; STR *tmp2str; int numarg; type = ops[node].ival; len = type >> 8; type &= 255; if (type == OVAR && len == 1) { tmpstr=walk(0,0,ops[node+1].ival,&numarg,P_MIN); tmp2str = str_make("1"); hstore(symtab,tmpstr->str_ptr,tmp2str); } } ; i<= len; i++) { prewalk(0,level,ops[node+i].ival,&numarg); } } break; } *numericptr = numeric; perl/x2p/util.c 644 473 0 12443 4747105017 6710 /* $Header: util.c,v 3.0 89/10/18 15:35:35 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: util.c,v $ * Revision 3.0 89/10/18 15:35:35 lwall * 3.0 baseline * */ #include #include "handy.h" #include "EXTERN.h" #include "a2p.h" #include "INTERN.h" #include "util.h" #define FLUSH #define MEM_SIZE unsigned int static char nomem[] = "Out of memory!\n"; /* paranoid version of malloc */ static int an = 0; char * safemalloc(size) MEM_SIZE size; { char *ptr; char *malloc(); ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ #ifdef DEBUGGING if (debug & 128) fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size); #endif if (ptr != Nullch) return ptr; else { fputs(nomem,stdout) FLUSH; exit(1); } /*NOTREACHED*/ } /* paranoid version of realloc */ char * saferealloc(where,size) char *where; MEM_SIZE size; { char *ptr; char *realloc(); ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ #ifdef DEBUGGING if (debug & 128) { fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++); fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size); } #endif if (ptr != Nullch) return ptr; else { fputs(nomem,stdout) FLUSH; exit(1); } /*NOTREACHED*/ } /* safe version of free */ safefree(where) char *where; { #ifdef DEBUGGING if (debug & 128) fprintf(stderr,"0x%x: (%05d) free\n",where,an++); #endif free(where); } /* safe version of string copy */ char * safecpy(to,from,len) char *to; register char *from; register int len; { register char *dest = to; if (from != Nullch) for (len--; len && (*dest++ = *from++); len--) ; *dest = '\0'; return to; } #ifdef undef /* safe version of string concatenate, with \n deletion and space padding */ char * safecat(to,from,len) char *to; register char *from; register int len; { register char *dest = to; len--; /* leave room for null */ if (*dest) { while (len && *dest++) len--; if (len) { len--; *(dest-1) = ' '; } } if (from != Nullch) while (len && (*dest++ = *from++)) len--; if (len) dest--; if (*(dest-1) == '\n') dest--; *dest = '\0'; return to; } #endif /* copy a string up to some (non-backslashed) delimiter, if any */ char * cpytill(to,from,delim) register char *to, *from; register int delim; { for (; *from; from++,to++) { if (*from == '\\') { if (from[1] == delim) from++; else if (from[1] == '\\') *to++ = *from++; } else if (*from == delim) break; *to = *from; } *to = '\0'; return from; } char * cpy2(to,from,delim) register char *to, *from; register int delim; { for (; *from; from++,to++) { if (*from == '\\') *to++ = *from++; else if (*from == '$') *to++ = '\\'; else if (*from == delim) break; *to = *from; } *to = '\0'; return from; } /* return ptr to little string in big string, NULL if not found */ char * instr(big, little) char *big, *little; { register char *t, *s, *x; for (t = big; *t; t++) { for (x=t,s=little; *s; x++,s++) { if (!*x) return Nullch; if (*s != *x) break; } if (!*s) return t; } return Nullch; } /* copy a string to a safe spot */ char * savestr(str) char *str; { register char *newaddr = safemalloc((MEM_SIZE)(strlen(str)+1)); (void)strcpy(newaddr,str); return newaddr; } /* grow a static string to at least a certain length */ void growstr(strptr,curlen,newlen) char **strptr; int *curlen; int newlen; { if (newlen > *curlen) { /* need more room? */ if (*curlen) *strptr = saferealloc(*strptr,(MEM_SIZE)newlen); else *strptr = safemalloc((MEM_SIZE)newlen); *curlen = newlen; } } /*VARARGS1*/ fatal(pat,a1,a2,a3,a4) char *pat; { fprintf(stderr,pat,a1,a2,a3,a4); exit(1); } /*VARARGS1*/ warn(pat,a1,a2,a3,a4) char *pat; { fprintf(stderr,pat,a1,a2,a3,a4); } static bool firstsetenv = TRUE; extern char **environ; void setenv(nam,val) char *nam, *val; { register int i=envix(nam); /* where does it go? */ if (!environ[i]) { /* does not exist yet */ if (firstsetenv) { /* need we copy environment? */ int j; #ifndef lint char **tmpenv = (char**) /* point our wand at memory */ safemalloc((i+2) * sizeof(char*)); #else char **tmpenv = Null(char **); #endif /* lint */ firstsetenv = FALSE; for (j=0; j> 8; type &= 255; printf("%d\t%d\t%d\t%-10s",i++,type,len,opname[type]); if (type == OSTRING) printf("\t\"%s\"\n",ops[i].cval),i++; else { while (len--) { printf("\t%d",ops[i].ival),i++; } putchar('\n'); } } } if (debug & 8) dump(root); #endif /* first pass to look for numeric variables */ prewalk(0,0,root,&i); /* second pass to produce new program */ tmpstr = walk(0,0,root,&i,P_MIN); str = str_make("#!"); str_cat(str, BIN); str_cat(str, "/perl\neval \"exec "); str_cat(str, BIN); str_cat(str, "/perl -S $0 $*\"\n\ if $running_under_some_shell;\n\ # this emulates #! processing on NIH machines.\n\ # (remove #! line above if indigestible)\n\n"); str_cat(str, "eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;\n"); str_cat(str, " # process any FOO=bar switches\n\n"); if (do_opens && opens) { str_scat(str,opens); str_free(opens); str_cat(str,"\n"); } str_scat(str,tmpstr); str_free(tmpstr); #ifdef DEBUGGING if (!(debug & 16)) #endif fixup(str); putlines(str); 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); } #define RETURN(retval) return (bufptr = s,retval) #define XTERM(retval) return (expectterm = TRUE,bufptr = s,retval) #define XOP(retval) return (expectterm = FALSE,bufptr = s,retval) #define ID(x) return (yylval=string(x,0),expectterm = FALSE,bufptr = s,idtype) int idtype; yylex() { register char *s = bufptr; register char *d; register int tmp; retry: #ifdef YYDEBUG if (yydebug) if (index(s,'\n')) fprintf(stderr,"Tokener at %s",s); else fprintf(stderr,"Tokener at %s\n",s); #endif switch (*s) { default: fprintf(stderr, "Unrecognized character %c in file %s line %d--ignoring.\n", *s++,filename,line); goto retry; case '\\': case 0: s = str_get(linestr); *s = '\0'; if (!rsfp) RETURN(0); line++; if ((s = str_gets(linestr, rsfp)) == Nullch) { if (rsfp != stdin) fclose(rsfp); rsfp = Nullfp; s = str_get(linestr); RETURN(0); } goto retry; case ' ': case '\t': s++; goto retry; case '\n': *s = '\0'; XTERM(NEWLINE); case '#': yylval = string(s,0); *s = '\0'; XTERM(COMMENT); case ';': tmp = *s++; if (*s == '\n') { s++; XTERM(SEMINEW); } XTERM(tmp); case '(': tmp = *s++; XTERM(tmp); case '{': case '[': case ')': case ']': case '?': case ':': tmp = *s++; XOP(tmp); case 127: s++; XTERM('}'); case '}': for (d = s + 1; isspace(*d); d++) ; if (!*d) s = d - 1; *s = 127; XTERM(';'); case ',': tmp = *s++; XTERM(tmp); case '~': s++; yylval = string("~",1); XTERM(MATCHOP); case '+': case '-': if (s[1] == *s) { s++; if (*s++ == '+') XTERM(INCR); else XTERM(DECR); } /* FALL THROUGH */ case '*': case '%': case '^': tmp = *s++; if (*s == '=') { if (tmp == '^') yylval = string("**=",3); else yylval = string(s-1,2); s++; XTERM(ASGNOP); } XTERM(tmp); case '&': s++; tmp = *s++; if (tmp == '&') XTERM(ANDAND); s--; XTERM('&'); case '|': s++; tmp = *s++; if (tmp == '|') XTERM(OROR); s--; while (*s == ' ' || *s == '\t') s++; if (strnEQ(s,"getline",7)) XTERM('p'); else XTERM('|'); case '=': s++; tmp = *s++; if (tmp == '=') { yylval = string("==",2); XTERM(RELOP); } s--; yylval = string("=",1); XTERM(ASGNOP); case '!': s++; tmp = *s++; if (tmp == '=') { yylval = string("!=",2); XTERM(RELOP); } if (tmp == '~') { yylval = string("!~",2); XTERM(MATCHOP); } s--; XTERM(NOT); case '<': s++; tmp = *s++; if (tmp == '=') { yylval = string("<=",2); XTERM(RELOP); } s--; XTERM('<'); case '>': s++; tmp = *s++; if (tmp == '>') { yylval = string(">>",2); XTERM(GRGR); } if (tmp == '=') { yylval = string(">=",2); XTERM(RELOP); } s--; XTERM('>'); #define SNARFWORD \ d = tokenbuf; \ while (isalpha(*s) || isdigit(*s) || *s == '_') \ *d++ = *s++; \ *d = '\0'; \ d = tokenbuf; \ if (*s == '(') \ idtype = USERFUN; \ else \ idtype = VAR; case '$': s++; if (*s == '0') { s++; do_chop = TRUE; need_entire = TRUE; idtype = VAR; ID("0"); } do_split = TRUE; if (isdigit(*s)) { for (d = s; isdigit(*s); s++) ; yylval = string(d,s-d); tmp = atoi(d); if (tmp > maxfld) maxfld = tmp; XOP(FIELD); } split_to_array = set_array_base = TRUE; XOP(VFIELD); case '/': /* may either be division or pattern */ if (expectterm) { s = scanpat(s); XTERM(REGEX); } tmp = *s++; if (*s == '=') { yylval = string("/=",2); s++; XTERM(ASGNOP); } XTERM(tmp); case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '.': s = scannum(s); XOP(NUMBER); case '"': s++; s = cpy2(tokenbuf,s,s[-1]); if (!*s) fatal("String not terminated:\n%s",str_get(linestr)); s++; yylval = string(tokenbuf,0); XOP(STRING); case 'a': case 'A': SNARFWORD; if (strEQ(d,"ARGC")) set_array_base = TRUE; if (strEQ(d,"ARGV")) { yylval=numary(string("ARGV",0)); XOP(VAR); } if (strEQ(d,"atan2")) { yylval = OATAN2; XTERM(FUNN); } ID(d); case 'b': case 'B': SNARFWORD; if (strEQ(d,"break")) XTERM(BREAK); if (strEQ(d,"BEGIN")) XTERM(BEGIN); ID(d); case 'c': case 'C': SNARFWORD; if (strEQ(d,"continue")) XTERM(CONTINUE); if (strEQ(d,"cos")) { yylval = OCOS; XTERM(FUN1); } if (strEQ(d,"close")) { do_fancy_opens = 1; yylval = OCLOSE; XTERM(FUN1); } if (strEQ(d,"chdir")) *d = toupper(*d); else if (strEQ(d,"crypt")) *d = toupper(*d); else if (strEQ(d,"chop")) *d = toupper(*d); else if (strEQ(d,"chmod")) *d = toupper(*d); else if (strEQ(d,"chown")) *d = toupper(*d); ID(d); case 'd': case 'D': SNARFWORD; if (strEQ(d,"do")) XTERM(DO); if (strEQ(d,"delete")) XTERM(DELETE); if (strEQ(d,"die")) *d = toupper(*d); ID(d); case 'e': case 'E': SNARFWORD; if (strEQ(d,"END")) XTERM(END); if (strEQ(d,"else")) XTERM(ELSE); if (strEQ(d,"exit")) { saw_line_op = TRUE; XTERM(EXIT); } if (strEQ(d,"exp")) { yylval = OEXP; XTERM(FUN1); } if (strEQ(d,"elsif")) *d = toupper(*d); else if (strEQ(d,"eq")) *d = toupper(*d); else if (strEQ(d,"eval")) *d = toupper(*d); else if (strEQ(d,"eof")) *d = toupper(*d); else if (strEQ(d,"each")) *d = toupper(*d); else if (strEQ(d,"exec")) *d = toupper(*d); ID(d); case 'f': case 'F': SNARFWORD; if (strEQ(d,"FS")) { saw_FS++; if (saw_FS == 1 && in_begin) { for (d = s; *d && isspace(*d); d++) ; if (*d == '=') { for (d++; *d && isspace(*d); d++) ; if (*d == '"' && d[2] == '"') const_FS = d[1]; } } ID(tokenbuf); } if (strEQ(d,"for")) XTERM(FOR); else if (strEQ(d,"function")) XTERM(FUNCTION); if (strEQ(d,"FILENAME")) d = "ARGV"; if (strEQ(d,"foreach")) *d = toupper(*d); else if (strEQ(d,"format")) *d = toupper(*d); else if (strEQ(d,"fork")) *d = toupper(*d); else if (strEQ(d,"fh")) *d = toupper(*d); ID(d); case 'g': case 'G': SNARFWORD; if (strEQ(d,"getline")) XTERM(GETLINE); if (strEQ(d,"gsub")) XTERM(GSUB); if (strEQ(d,"ge")) *d = toupper(*d); else if (strEQ(d,"gt")) *d = toupper(*d); else if (strEQ(d,"goto")) *d = toupper(*d); else if (strEQ(d,"gmtime")) *d = toupper(*d); ID(d); case 'h': case 'H': SNARFWORD; if (strEQ(d,"hex")) *d = toupper(*d); ID(d); case 'i': case 'I': SNARFWORD; if (strEQ(d,"if")) XTERM(IF); if (strEQ(d,"in")) XTERM(IN); if (strEQ(d,"index")) { set_array_base = TRUE; XTERM(INDEX); } if (strEQ(d,"int")) { yylval = OINT; XTERM(FUN1); } ID(d); case 'j': case 'J': SNARFWORD; if (strEQ(d,"join")) *d = toupper(*d); ID(d); case 'k': case 'K': SNARFWORD; if (strEQ(d,"keys")) *d = toupper(*d); else if (strEQ(d,"kill")) *d = toupper(*d); ID(d); case 'l': case 'L': SNARFWORD; if (strEQ(d,"length")) { yylval = OLENGTH; XTERM(FUN1); } if (strEQ(d,"log")) { yylval = OLOG; XTERM(FUN1); } if (strEQ(d,"last")) *d = toupper(*d); else if (strEQ(d,"local")) *d = toupper(*d); else if (strEQ(d,"lt")) *d = toupper(*d); else if (strEQ(d,"le")) *d = toupper(*d); else if (strEQ(d,"locatime")) *d = toupper(*d); else if (strEQ(d,"link")) *d = toupper(*d); ID(d); case 'm': case 'M': SNARFWORD; if (strEQ(d,"match")) { set_array_base = TRUE; XTERM(MATCH); } if (strEQ(d,"m")) *d = toupper(*d); ID(d); case 'n': case 'N': SNARFWORD; if (strEQ(d,"NF")) do_split = split_to_array = set_array_base = TRUE; if (strEQ(d,"next")) { saw_line_op = TRUE; XTERM(NEXT); } if (strEQ(d,"ne")) *d = toupper(*d); ID(d); case 'o': case 'O': SNARFWORD; if (strEQ(d,"ORS")) { saw_ORS = TRUE; d = "\\"; } if (strEQ(d,"OFS")) { saw_OFS = TRUE; d = ","; } if (strEQ(d,"OFMT")) { d = "#"; } if (strEQ(d,"open")) *d = toupper(*d); else if (strEQ(d,"ord")) *d = toupper(*d); else if (strEQ(d,"oct")) *d = toupper(*d); ID(d); case 'p': case 'P': SNARFWORD; if (strEQ(d,"print")) { XTERM(PRINT); } if (strEQ(d,"printf")) { XTERM(PRINTF); } if (strEQ(d,"push")) *d = toupper(*d); else if (strEQ(d,"pop")) *d = toupper(*d); ID(d); case 'q': case 'Q': SNARFWORD; ID(d); case 'r': case 'R': SNARFWORD; if (strEQ(d,"RS")) { d = "/"; saw_RS = TRUE; } if (strEQ(d,"rand")) { yylval = ORAND; XTERM(FUN1); } if (strEQ(d,"return")) XTERM(RET); if (strEQ(d,"reset")) *d = toupper(*d); else if (strEQ(d,"redo")) *d = toupper(*d); else if (strEQ(d,"rename")) *d = toupper(*d); ID(d); case 's': case 'S': SNARFWORD; if (strEQ(d,"split")) { set_array_base = TRUE; XOP(SPLIT); } if (strEQ(d,"substr")) { set_array_base = TRUE; XTERM(SUBSTR); } if (strEQ(d,"sub")) XTERM(SUB); if (strEQ(d,"sprintf")) XTERM(SPRINTF); if (strEQ(d,"sqrt")) { yylval = OSQRT; XTERM(FUN1); } if (strEQ(d,"SUBSEP")) { d = ";"; } if (strEQ(d,"sin")) { yylval = OSIN; XTERM(FUN1); } if (strEQ(d,"srand")) { yylval = OSRAND; XTERM(FUN1); } if (strEQ(d,"system")) { yylval = OSYSTEM; XTERM(FUN1); } if (strEQ(d,"s")) *d = toupper(*d); else if (strEQ(d,"shift")) *d = toupper(*d); else if (strEQ(d,"select")) *d = toupper(*d); else if (strEQ(d,"seek")) *d = toupper(*d); else if (strEQ(d,"stat")) *d = toupper(*d); else if (strEQ(d,"study")) *d = toupper(*d); else if (strEQ(d,"sleep")) *d = toupper(*d); else if (strEQ(d,"symlink")) *d = toupper(*d); else if (strEQ(d,"sort")) *d = toupper(*d); ID(d); case 't': case 'T': SNARFWORD; if (strEQ(d,"tr")) *d = toupper(*d); else if (strEQ(d,"tell")) *d = toupper(*d); else if (strEQ(d,"time")) *d = toupper(*d); else if (strEQ(d,"times")) *d = toupper(*d); ID(d); case 'u': case 'U': SNARFWORD; if (strEQ(d,"until")) *d = toupper(*d); else if (strEQ(d,"unless")) *d = toupper(*d); else if (strEQ(d,"umask")) *d = toupper(*d); else if (strEQ(d,"unshift")) *d = toupper(*d); else if (strEQ(d,"unlink")) *d = toupper(*d); else if (strEQ(d,"utime")) *d = toupper(*d); ID(d); case 'v': case 'V': SNARFWORD; if (strEQ(d,"values")) *d = toupper(*d); ID(d); case 'w': case 'W': SNARFWORD; if (strEQ(d,"while")) XTERM(WHILE); if (strEQ(d,"write")) *d = toupper(*d); else if (strEQ(d,"wait")) *d = toupper(*d); ID(d); case 'x': case 'X': SNARFWORD; if (strEQ(d,"x")) *d = toupper(*d); ID(d); case 'y': case 'Y': SNARFWORD; if (strEQ(d,"y")) *d = toupper(*d); ID(d); case 'z': case 'Z': SNARFWORD; ID(d); } } char * scanpat(s) register char *s; { register char *d; switch (*s++) { case '/': break; default: fatal("Search pattern not found:\n%s",str_get(linestr)); } 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++; yylval = string(tokenbuf,0); return s; } yyerror(s) char *s; { fprintf(stderr,"%s in file %s at line %d\n", s,filename,line); } char * scannum(s) register char *s; { register char *d; switch (*s) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '0' : case '.': d = tokenbuf; while (isdigit(*s)) { *d++ = *s++; } if (*s == '.' && index("0123456789eE",s[1])) { *d++ = *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 s; } string(ptr,len) char *ptr; { int retval = mop; ops[mop++].ival = OSTRING + (1<<8); if (!len) len = strlen(ptr); ops[mop].cval = safemalloc(len+1); strncpy(ops[mop].cval,ptr,len); ops[mop++].cval[len] = '\0'; if (mop >= OPSMAX) fatal("Recompile a2p with larger OPSMAX\n"); return retval; } oper0(type) int type; { int retval = mop; if (type > 255) fatal("type > 255 (%d)\n",type); ops[mop++].ival = type; if (mop >= OPSMAX) fatal("Recompile a2p with larger OPSMAX\n"); return retval; } oper1(type,arg1) int type; int arg1; { int retval = mop; if (type > 255) fatal("type > 255 (%d)\n",type); ops[mop++].ival = type + (1<<8); ops[mop++].ival = arg1; if (mop >= OPSMAX) fatal("Recompile a2p with larger OPSMAX\n"); return retval; } oper2(type,arg1,arg2) int type; int arg1; int arg2; { int retval = mop; if (type > 255) fatal("type > 255 (%d)\n",type); ops[mop++].ival = type + (2<<8); ops[mop++].ival = arg1; ops[mop++].ival = arg2; if (mop >= OPSMAX) fatal("Recompile a2p with larger OPSMAX\n"); return retval; } oper3(type,arg1,arg2,arg3) int type; int arg1; int arg2; int arg3; { int retval = mop; if (type > 255) fatal("type > 255 (%d)\n",type); ops[mop++].ival = type + (3<<8); ops[mop++].ival = arg1; ops[mop++].ival = arg2; ops[mop++].ival = arg3; if (mop >= OPSMAX) fatal("Recompile a2p with larger OPSMAX\n"); return retval; } oper4(type,arg1,arg2,arg3,arg4) int type; int arg1; int arg2; int arg3; int arg4; { int retval = mop; if (type > 255) fatal("type > 255 (%d)\n",type); ops[mop++].ival = type + (4<<8); ops[mop++].ival = arg1; ops[mop++].ival = arg2; ops[mop++].ival = arg3; ops[mop++].ival = arg4; if (mop >= OPSMAX) fatal("Recompile a2p with larger OPSMAX\n"); return retval; } oper5(type,arg1,arg2,arg3,arg4,arg5) int type; int arg1; int arg2; int arg3; int arg4; int arg5; { int retval = mop; if (type > 255) fatal("type > 255 (%d)\n",type); ops[mop++].ival = type + (5<<8); ops[mop++].ival = arg1; ops[mop++].ival = arg2; ops[mop++].ival = arg3; ops[mop++].ival = arg4; ops[mop++].ival = arg5; if (mop >= OPSMAX) fatal("Recompile a2p with larger OPSMAX\n"); return retval; } int depth = 0; dump(branch) int branch; { register int type; register int len; register int i; type = ops[branch].ival; len = type >> 8; type &= 255; for (i=depth; i; i--) printf(" "); if (type == OSTRING) { printf("%-5d\"%s\"\n",branch,ops[branch+1].cval); } else { printf("(%-5d%s %d\n",branch,opname[type],len); depth++; for (i=1; i<=len; i++) dump(ops[branch+i].ival); depth--; for (i=depth; i; i--) printf(" "); printf(")\n"); } } bl(arg,maybe) int arg; int maybe; { if (!arg) return 0; else if ((ops[arg].ival & 255) != OBLOCK) return oper2(OBLOCK,arg,maybe); else if ((ops[arg].ival >> 8) < 2) return oper2(OBLOCK,ops[arg+1].ival,maybe); else return arg; } fixup(str) STR *str; { register char *s; register char *t; for (s = str->str_ptr; *s; s++) { if (*s == ';' && s[1] == ' ' && s[2] == '\n') { strcpy(s+1,s+2); s++; } else if (*s == '\n') { for (t = s+1; isspace(*t & 127); t++) ; t--; while (isspace(*t & 127) && *t != '\n') t--; if (*t == '\n' && t-s > 1) { if (s[-1] == '{') s--; strcpy(s+1,t); } s++; } } } putlines(str) STR *str; { register char *d, *s, *t, *e; register int pos, newpos; d = tokenbuf; pos = 0; for (s = str->str_ptr; *s; s++) { *d++ = *s; pos++; if (*s == '\n') { *d = '\0'; d = tokenbuf; pos = 0; putone(); } else if (*s == '\t') pos += 7; if (pos > 78) { /* split a long line? */ *d-- = '\0'; newpos = 0; for (t = tokenbuf; isspace(*t & 127); t++) { if (*t == '\t') newpos += 8; else newpos += 1; } e = d; while (d > tokenbuf && (*d != ' ' || d[-1] != ';')) d--; if (d < t+10) { d = e; while (d > tokenbuf && (*d != ' ' || d[-1] != '|' || d[-2] != '|') ) d--; } if (d < t+10) { d = e; while (d > tokenbuf && (*d != ' ' || d[-1] != '&' || d[-2] != '&') ) d--; } if (d < t+10) { d = e; while (d > tokenbuf && (*d != ' ' || d[-1] != ',')) d--; } if (d < t+10) { d = e; while (d > tokenbuf && *d != ' ') d--; } if (d > t+3) { *d = '\0'; putone(); putchar('\n'); if (d[-1] != ';' && !(newpos % 4)) { *t++ = ' '; *t++ = ' '; newpos += 2; } strcpy(t,d+1); newpos += strlen(t); d = t + strlen(t); pos = newpos; } else d = e + 1; } } } putone() { register char *t; for (t = tokenbuf; *t; t++) { *t &= 127; if (*t == 127) { *t = ' '; strcpy(t+strlen(t)-1, "\t#???\n"); 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); } numary(arg) int arg; { STR *key; int dummy; key = walk(0,0,arg,&dummy,P_MIN); str_cat(key,"[]"); hstore(symtab,key->str_ptr,str_make("1")); str_free(key); set_array_base = TRUE; return arg; } rememberargs(arg) int arg; { int type; STR *str; if (!arg) return arg; type = ops[arg].ival & 255; if (type == OCOMMA) { rememberargs(ops[arg+1].ival); rememberargs(ops[arg+3].ival); } else if (type == OVAR) { str = str_new(0); hstore(curarghash,ops[ops[arg+1].ival+1].cval,str); } else fatal("panic: unknown argument type %d, line %d\n",type,line); return arg; } aryrefarg(arg) int arg; { int type = ops[arg].ival & 255; STR *str; if (type != OSTRING) fatal("panic: aryrefarg %d, line %d\n",type,line); str = hfetch(curarghash,ops[arg+1].cval); if (str) str_set(str,"*"); return arg; } fixfargs(name,arg,prevargs) int name; int arg; int prevargs; { int type; STR *str; int numargs; if (!arg) return prevargs; type = ops[arg].ival & 255; if (type == OCOMMA) { numargs = fixfargs(name,ops[arg+1].ival,prevargs); numargs = fixfargs(name,ops[arg+3].ival,numargs); } else if (type == OVAR) { str = hfetch(curarghash,ops[ops[arg+1].ival+1].cval); if (strEQ(str_get(str),"*")) { char tmpbuf[128]; str_set(str,""); /* in case another routine has this */ ops[arg].ival &= ~255; ops[arg].ival |= OSTAR; sprintf(tmpbuf,"%s:%d",ops[name+1].cval,prevargs); fprintf(stderr,"Adding %s\n",tmpbuf); str = str_new(0); str_set(str,"*"); hstore(curarghash,tmpbuf,str); } numargs = prevargs + 1; } else fatal("panic: unknown argument type %d, arg %d, line %d\n", type,numargs+1,line); return numargs; } fixrargs(name,arg,prevargs) char *name; int arg; int prevargs; { int type; STR *str; int numargs; if (!arg) return prevargs; type = ops[arg].ival & 255; if (type == OCOMMA) { numargs = fixrargs(name,ops[arg+1].ival,prevargs); numargs = fixrargs(name,ops[arg+3].ival,numargs); } else { char tmpbuf[128]; sprintf(tmpbuf,"%s:%d",name,prevargs); str = hfetch(curarghash,tmpbuf); fprintf(stderr,"Looking for %s\n",tmpbuf); if (str && strEQ(str->str_ptr,"*")) { if (type == OVAR || type == OSTAR) { ops[arg].ival &= ~255; ops[arg].ival |= OSTAR; } else fatal("Can't pass expression by reference as arg %d of %s\n", prevargs+1, name); } numargs = prevargs + 1; } return numargs; } prevargs); numargs = fixrargs(name,ops[arg+3].ival,numargs); } else { char tmpbuf[128]; sprintf(tmpbuf,"%s:%d",name,prevargs); str = hfetch(curarghash,tmpbuf); fprintf(stderr,"Looking for %s\n",tmpbuf); if (str && strEQ(str->str_ptr,"*")) { if (type == OVAR || type == OSTAR) { ops[arg].ival &= ~255; ops[arg].ival |= OSTAR; } else fatal("Can't pass expressionperl/x2p/s2p.SH 644 473 0 27656 4747105020 6535 : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac case $CONFIG in '') if test ! -f config.sh; then ln ../config.sh . || \ ln ../../config.sh . || \ ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) fi . config.sh ;; esac echo "Extracting s2p (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >s2p <>s2p <<'!NO!SUBS!' # $Header: s2p.SH,v 3.0.1.3 90/03/01 10:31:21 lwall Locked $ # # $Log: s2p.SH,v $ # Revision 3.0.1.3 90/03/01 10:31:21 lwall # patch9: s2p didn't handle \< and \> # # Revision 3.0.1.2 89/11/17 15:51:27 lwall # patch5: in s2p, line labels without a subsequent statement were done wrong # patch5: s2p left residue in /tmp # # Revision 3.0.1.1 89/11/11 05:08:25 lwall # patch2: in s2p, + within patterns needed backslashing # patch2: s2p was printing out some debugging info to the output file # # Revision 3.0 89/10/18 15:35:02 lwall # 3.0 baseline # # Revision 2.0.1.1 88/07/11 23:26:23 root # patch2: s2p didn't put a proper prologue on output script # # Revision 2.0 88/06/05 00:15:55 root # Baseline version 2.0. # # $indent = 4; $shiftwidth = 4; $l = '{'; $r = '}'; $tempvar = '1'; while ($ARGV[0] =~ '^-') { $_ = shift; last if /^--/; if (/^-D/) { $debug++; open(body,'>-'); next; } if (/^-n/) { $assumen++; next; } if (/^-p/) { $assumep++; next; } die "I don't recognize this switch: $_\n"; } unless ($debug) { open(body,">/tmp/sperl$$") || do Die("Can't open temp file"); } if (!$assumen && !$assumep) { print body 'while ($ARGV[0] =~ /^-/) { $_ = shift; last if /^--/; if (/^-n/) { $nflag++; next; } die "I don\'t recognize this switch: $_\\n"; } '; } print body ' #ifdef PRINTIT #ifdef ASSUMEP $printit++; #else $printit++ unless $nflag; #endif #endif line: while (<>) { '; line: while (<>) { s/[ \t]*(.*)\n$/$1/; if (/^:/) { s/^:[ \t]*//; $label = do make_label($_); if ($. == 1) { $toplabel = $label; } $_ = "$label:"; if ($lastlinewaslabel++) { $indent += 4; print body "\t" x ($indent / 8), ' ' x ($indent % 8), ";\n"; $indent -= 4; } if ($indent >= 2) { $indent -= 2; $indmod = 2; } next; } else { $lastlinewaslabel = ''; } $addr1 = ''; $addr2 = ''; if (s/^([0-9]+)//) { $addr1 = "$1"; } elsif (s/^\$//) { $addr1 = 'eof()'; } elsif (s|^/||) { $addr1 = do fetchpat('/'); } if (s/^,//) { if (s/^([0-9]+)//) { $addr2 = "$1"; } elsif (s/^\$//) { $addr2 = "eof()"; } elsif (s|^/||) { $addr2 = do fetchpat('/'); } else { do Die("Invalid second address at line $.\n"); } $addr1 .= " .. $addr2"; } # a { to keep vi happy s/^[ \t]+//; if ($_ eq '}') { $indent -= 4; next; } if (s/^!//) { $if = 'unless'; $else = "$r else $l\n"; } else { $if = 'if'; $else = ''; } if (s/^{//) { # a } to keep vi happy $indmod = 4; $redo = $_; $_ = ''; $rmaybe = ''; } else { $rmaybe = "\n$r"; if ($addr2 || $addr1) { $space = ' ' x $shiftwidth; } else { $space = ''; } $_ = do transmogrify(); } if ($addr1) { if ($_ !~ /[\n{}]/ && $rmaybe && !$change && $_ !~ / if / && $_ !~ / unless /) { s/;$/ $if $addr1;/; $_ = substr($_,$shiftwidth,1000); } else { $command = $_; $_ = "$if ($addr1) $l\n$change$command$rmaybe"; } $change = ''; next line; } } continue { @lines = split(/\n/,$_); while ($#lines >= 0) { $_ = shift(lines); unless (s/^ *<<--//) { print body "\t" x ($indent / 8), ' ' x ($indent % 8); } print body $_, "\n"; } $indent += $indmod; $indmod = 0; if ($redo) { $_ = $redo; $redo = ''; redo line; } } if ($lastlinewaslabel++) { $indent += 4; print body "\t" x ($indent / 8), ' ' x ($indent % 8), ";\n"; $indent -= 4; } print body "}\n"; if ($appendseen || $tseen || !$assumen) { $printit++ if $dseen || (!$assumen && !$assumep); print body ' continue { #ifdef PRINTIT #ifdef DSEEN #ifdef ASSUMEP print if $printit++; #else if ($printit) { print;} else { $printit++ unless $nflag; } #endif #else print if $printit; #endif #else print; #endif #ifdef TSEEN $tflag = \'\'; #endif #ifdef APPENDSEEN if ($atext) { print $atext; $atext = \'\'; } #endif } '; } close body; unless ($debug) { open(head,">/tmp/sperl2$$.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 DSEEN\n" if ($dseen); print head "#define ASSUMEN\n" if ($assumen); print head "#define ASSUMEP\n" if ($assumep); if ($opens) {print head "$opens\n";} open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file"); while () { print head $_; } close head; print "#!$bin/perl eval \"exec $bin/perl -S \$0 \$*\" if \$running_under_some_shell; "; open(body,"cc -E /tmp/sperl2$$.c |") || do Die("Can't reopen temp file"); while () { /^# [0-9]/ && next; /^[ \t]*$/ && next; s/^<><>//; print; } } unlink "/tmp/sperl$$", "/tmp/sperl2$$", "/tmp/sperl2$$.c"; sub Die { unlink "/tmp/sperl$$", "/tmp/sperl2$$", "/tmp/sperl2$$.c"; die $_[0]; } sub make_filehandle { $fname = $_ = $_[0]; s/[^a-zA-Z]/_/g; s/^_*//; if (/^([a-z])([a-z]*)$/) { $first = $1; $rest = $2; $first =~ y/a-z/A-Z/; $_ = $first . $rest; } if (!$seen{$_}) { $opens .= "open($_,'>$fname') || die \"Can't create $fname\";\n"; } $seen{$_} = $_; } sub make_label { $label = $_[0]; $label =~ s/[^a-zA-Z0-9]/_/g; if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } $label = substr($label,0,8); if ($label =~ /^([a-z])([a-z]*)$/) { # could be reserved word $first = $1; $rest = $2; $first =~ y/a-z/A-Z/; # so capitalize it $label = $first . $rest; } $label; } sub transmogrify { { # case if (/^d/) { $dseen++; $_ = ' <<--#ifdef PRINTIT $printit = \'\'; <<--#endif next line;'; next; } if (/^n/) { $_ = '<<--#ifdef PRINTIT <<--#ifdef DSEEN <<--#ifdef ASSUMEP print if $printit++; <<--#else if ($printit) { print;} else { $printit++ unless $nflag; } <<--#endif <<--#else print if $printit; <<--#endif <<--#else print; <<--#endif <<--#ifdef APPENDSEEN if ($atext) {print $atext; $atext = \'\';} <<--#endif $_ = <>; <<--#ifdef TSEEN $tflag = \'\'; <<--#endif'; next; } if (/^a/) { $appendseen++; $command = $space . '$atext .=' . "\n<<--'"; $lastline = 0; while (<>) { s/^[ \t]*//; s/^[\\]//; unless (s|\\$||) { $lastline = 1;} s/'/\\'/g; s/^([ \t]*\n)/<><>$1/; $command .= $_; $command .= '<<--'; last if $lastline; } $_ = $command . "';"; last; } if (/^[ic]/) { if (/^c/) { $change = 1; } $addr1 = '$iter = (' . $addr1 . ')'; $command = $space . 'if ($iter == 1) { print' . "\n<<--'"; $lastline = 0; while (<>) { s/^[ \t]*//; s/^[\\]//; unless (s/\\$//) { $lastline = 1;} s/'/\\'/g; s/^([ \t]*\n)/<><>$1/; $command .= $_; $command .= '<<--'; last if $lastline; } $_ = $command . "';}"; if ($change) { $dseen++; $change = "$_\n"; $_ = " <<--#ifdef PRINTIT $space\$printit = ''; <<--#endif ${space}next line;"; } last; } if (/^s/) { $delim = substr($_,1,1); $len = length($_); $repl = $end = 0; $inbracket = 0; for ($i = 2; $i < $len; $i++) { $c = substr($_,$i,1); if ($c eq $delim) { if ($inbracket) { $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000); $i++; $len++; } else { if ($repl) { $end = $i; last; } else { $repl = $i; } } } elsif ($c eq '\\') { $i++; if ($i >= $len) { $_ .= 'n'; $_ .= <>; $len = length($_); $_ = substr($_,0,--$len); } elsif (!$repl && substr($_,$i,1) =~ /^[(){}\w]$/) { $i--; $len--; $_ = substr($_,0,$i) . substr($_,$i+1,10000); } elsif (!$repl && substr($_,$i,1) =~ /^[<>]$/) { substr($_,$i,1) = 'b'; } } elsif ($c eq '[' && !$repl) { $i++ if substr($_,$i,1) eq '^'; $i++ if substr($_,$i,1) eq ']'; $inbracket = 1; } elsif ($c eq ']') { $inbracket = 0; } elsif (!$repl && index("()+",$c) >= 0) { $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000); $i++; $len++; } } 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"; $cmd = ''; while ($end) { if ($end =~ s/^g//) { $subst .= 'g'; next; } if ($end =~ s/^p//) { $cmd .= ' && (print)'; next; } if ($end =~ s/^w[ \t]*//) { $fh = do make_filehandle($end); $cmd .= " && (print $fh \$_)"; $end = ''; next; } do Die("Unrecognized substitution command ($end) at line $.\n"); } $_ = "<<--#ifdef TSEEN $subst && \$tflag++$cmd; <<--#else $subst$cmd; <<--#endif"; next; } if (/^p/) { $_ = 'print;'; next; } if (/^w/) { s/^w[ \t]*//; $fh = do make_filehandle($_); $_ = "print $fh \$_;"; next; } if (/^r/) { $appendseen++; s/^r[ \t]*//; $file = $_; $_ = "\$atext .= `cat $file 2>/dev/null`;"; next; } if (/^P/) { $_ = 'print $1 if /(^.*\n)/;'; next; } if (/^D/) { $_ = 's/^.*\n//; redo line if $_; next line;'; next; } if (/^N/) { $_ = ' $_ .= <>; <<--#ifdef TSEEN $tflag = \'\'; <<--#endif'; next; } if (/^h/) { $_ = '$hold = $_;'; next; } if (/^H/) { $_ = '$hold .= $_ ? $_ : "\n";'; next; } if (/^g/) { $_ = '$_ = $hold;'; next; } if (/^G/) { $_ = '$_ .= $hold ? $hold : "\n";'; next; } if (/^x/) { $_ = '($_, $hold) = ($hold, $_);'; next; } if (/^b$/) { $_ = 'next line;'; next; } if (/^b/) { s/^b[ \t]*//; $lab = do make_label($_); if ($lab eq $toplabel) { $_ = 'redo line;'; } else { $_ = "goto $lab;"; } next; } if (/^t$/) { $_ = 'next line if $tflag;'; $tseen++; next; } if (/^t/) { s/^t[ \t]*//; $lab = do make_label($_); if ($lab eq $toplabel) { $_ = 'if ($tflag) {$tflag = \'\'; redo line;}'; } else { $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}"; } $tseen++; next; } if (/^=/) { $_ = 'print "$.\n";'; next; } if (/^q/) { $_ = 'close(ARGV); @ARGV = (); next line;'; next; } } continue { if ($space) { s/^/$space/; s/(\n)(.)/$1$space$2/g; } last; } $_; } sub fetchpat { local($outer) = @_; local($addr) = $outer; local($inbracket); local($prefix,$delim,$ch); delim: while (s:^([^\]+(|)[\\/]*)([]+(|)[\\/])::) { $prefix = $1; $delim = $2; if ($delim eq '\\') { s/(.)//; $ch = $1; $delim = '' if $ch =~ /^[(){}\w]$/; $ch = 'b' if $ch =~ /^[<>]$/; $delim .= $ch; } elsif ($delim eq '[') { $inbracket = 1; s/^\^// && ($delim .= '^'); s/^]// && ($delim .= ']'); } elsif ($delim eq ']') { $inbracket = 0; } elsif ($inbracket || $delim ne $outer) { $delim = '\\' . $delim; } $addr .= $prefix; $addr .= $delim; if ($delim eq $outer && !$inbracket) { last delim; } } $addr; } !NO!SUBS! chmod 755 s2p $eunicefix s2p )//; $ch = $1; $delim = '' if $ch =~ /^[(){}\w]$/; $ch = 'b' if $chperl/x2p/str.c 644 473 0 22727 4747105020 6543 /* $Header: str.c,v 3.0 89/10/18 15:35:18 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: str.c,v $ * Revision 3.0 89/10/18 15:35:18 lwall * 3.0 baseline * */ #include "handy.h" #include "EXTERN.h" #include "util.h" #include "a2p.h" str_numset(str,num) register STR *str; double num; { str->str_nval = num; str->str_pok = 0; /* invalidate pointer */ str->str_nok = 1; /* validate number */ } char * str_2ptr(str) register STR *str; { register char *s; if (!str) return ""; GROWSTR(&(str->str_ptr), &(str->str_len), 24); s = str->str_ptr; if (str->str_nok) { sprintf(s,"%.20g",str->str_nval); while (*s) s++; } *s = '\0'; str->str_cur = s - str->str_ptr; str->str_pok = 1; #ifdef DEBUGGING if (debug & 32) fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr); #endif return str->str_ptr; } double str_2num(str) register STR *str; { if (!str) return 0.0; if (str->str_len && str->str_pok) str->str_nval = atof(str->str_ptr); else str->str_nval = 0.0; str->str_nok = 1; #ifdef DEBUGGING if (debug & 32) fprintf(stderr,"0x%lx num(%g)\n",str,str->str_nval); #endif return str->str_nval; } str_sset(dstr,sstr) STR *dstr; register STR *sstr; { if (!sstr) str_nset(dstr,No,0); else if (sstr->str_nok) str_numset(dstr,sstr->str_nval); else if (sstr->str_pok) str_nset(dstr,sstr->str_ptr,sstr->str_cur); else str_nset(dstr,"",0); } str_nset(str,ptr,len) register STR *str; register char *ptr; register int len; { GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); bcopy(ptr,str->str_ptr,len); str->str_cur = len; *(str->str_ptr+str->str_cur) = '\0'; str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ } str_set(str,ptr) register STR *str; register char *ptr; { register int len; if (!ptr) ptr = ""; len = strlen(ptr); GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); bcopy(ptr,str->str_ptr,len+1); str->str_cur = len; str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ } str_chop(str,ptr) /* like set but assuming ptr is in str */ register STR *str; register char *ptr; { if (!(str->str_pok)) str_2ptr(str); str->str_cur -= (ptr - str->str_ptr); bcopy(ptr,str->str_ptr, str->str_cur + 1); str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ } str_ncat(str,ptr,len) register STR *str; register char *ptr; register int len; { if (!(str->str_pok)) str_2ptr(str); GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); bcopy(ptr,str->str_ptr+str->str_cur,len); str->str_cur += len; *(str->str_ptr+str->str_cur) = '\0'; str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ } str_scat(dstr,sstr) STR *dstr; register STR *sstr; { if (!(sstr->str_pok)) str_2ptr(sstr); if (sstr) str_ncat(dstr,sstr->str_ptr,sstr->str_cur); } str_cat(str,ptr) register STR *str; register char *ptr; { register int len; if (!ptr) return; if (!(str->str_pok)) str_2ptr(str); len = strlen(ptr); GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); bcopy(ptr,str->str_ptr+str->str_cur,len+1); str->str_cur += len; str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ } char * str_append_till(str,from,delim,keeplist) register STR *str; register char *from; register int delim; char *keeplist; { register char *to; register int len; if (!from) return Nullch; len = strlen(from); GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ to = str->str_ptr+str->str_cur; for (; *from; from++,to++) { if (*from == '\\' && from[1] && delim != '\\') { if (!keeplist) { if (from[1] == delim || from[1] == '\\') from++; else *to++ = *from++; } else if (index(keeplist,from[1])) *to++ = *from++; else from++; } else if (*from == delim) break; *to = *from; } *to = '\0'; str->str_cur = to - str->str_ptr; return from; } STR * str_new(len) int len; { register STR *str; if (freestrroot) { str = freestrroot; freestrroot = str->str_link.str_next; } else { str = (STR *) safemalloc(sizeof(STR)); bzero((char*)str,sizeof(STR)); } if (len) GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); return str; } void str_grow(str,len) register STR *str; int len; { if (len && str) GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); } /* make str point to what nstr did */ void str_replace(str,nstr) register STR *str; register STR *nstr; { safefree(str->str_ptr); str->str_ptr = nstr->str_ptr; str->str_len = nstr->str_len; str->str_cur = nstr->str_cur; str->str_pok = nstr->str_pok; if (str->str_nok = nstr->str_nok) str->str_nval = nstr->str_nval; safefree((char*)nstr); } void str_free(str) register STR *str; { if (!str) return; if (str->str_len) str->str_ptr[0] = '\0'; str->str_cur = 0; str->str_nok = 0; str->str_pok = 0; str->str_link.str_next = freestrroot; freestrroot = str; } str_len(str) register STR *str; { if (!str) return 0; if (!(str->str_pok)) str_2ptr(str); if (str->str_len) return str->str_cur; else return 0; } char * str_gets(str,fp) register STR *str; register FILE *fp; { #ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */ register char *bp; /* we're going to steal some values */ register int cnt; /* from the stdio struct and put EVERYTHING */ register STDCHAR *ptr; /* in the innermost loop into registers */ register char newline = '\n'; /* (assuming at least 6 registers) */ int i; int bpx; cnt = fp->_cnt; /* get count into register */ str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ if (str->str_len <= cnt) /* make sure we have the room */ GROWSTR(&(str->str_ptr), &(str->str_len), cnt+1); bp = str->str_ptr; /* move these two too to registers */ ptr = fp->_ptr; for (;;) { while (--cnt >= 0) { 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 */ fp->_ptr = ptr; i = _filbuf(fp); /* get more characters */ cnt = fp->_cnt; ptr = fp->_ptr; /* reregisterize cnt and ptr */ bpx = bp - str->str_ptr; /* prepare for possible relocation */ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + cnt + 1); bp = str->str_ptr + bpx; /* reconstitute our pointer */ if (i == newline) { /* all done for now? */ *bp++ = i; goto thats_all_folks; } else if (i == EOF) /* all done for ever? */ goto thats_all_folks; *bp++ = i; /* now go back to screaming loop */ } thats_all_folks: fp->_cnt = cnt; /* put these back or we're in trouble */ fp->_ptr = ptr; *bp = '\0'; str->str_cur = bp - str->str_ptr; /* set length */ #else /* !STDSTDIO */ /* The big, slow, and stupid way */ static char buf[4192]; if (fgets(buf, sizeof buf, fp) != Nullch) str_set(str, buf); else str_set(str, No); #endif /* STDSTDIO */ return str->str_cur ? str->str_ptr : Nullch; } void str_inc(str) register STR *str; { register char *d; if (!str) return; if (str->str_nok) { str->str_nval += 1.0; str->str_pok = 0; return; } if (!str->str_pok) { str->str_nval = 1.0; str->str_nok = 1; return; } for (d = str->str_ptr; *d && *d != '.'; d++) ; d--; if (!isdigit(*str->str_ptr) || !isdigit(*d) ) { str_numset(str,atof(str->str_ptr) + 1.0); /* punt */ return; } while (d >= str->str_ptr) { if (++*d <= '9') return; *(d--) = '0'; } /* oh,oh, the number grew */ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + 2); str->str_cur++; for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--) *d = d[-1]; *d = '1'; } void str_dec(str) register STR *str; { register char *d; if (!str) return; if (str->str_nok) { str->str_nval -= 1.0; str->str_pok = 0; return; } if (!str->str_pok) { str->str_nval = -1.0; str->str_nok = 1; return; } for (d = str->str_ptr; *d && *d != '.'; d++) ; d--; if (!isdigit(*str->str_ptr) || !isdigit(*d) || (*d == '0' && d == str->str_ptr)) { str_numset(str,atof(str->str_ptr) - 1.0); /* punt */ return; } while (d >= str->str_ptr) { if (--*d >= '0') return; *(d--) = '9'; } } /* make a string that will exist for the duration of the expression eval */ STR * str_static(oldstr) STR *oldstr; { register STR *str = str_new(0); static long tmps_size = -1; str_sset(str,oldstr); if (++tmps_max > tmps_size) { tmps_size = tmps_max; if (!(tmps_size & 127)) { if (tmps_size) tmps_list = (STR**)saferealloc((char*)tmps_list, (tmps_size + 128) * sizeof(STR*) ); else tmps_list = (STR**)safemalloc(128 * sizeof(char*)); } } tmps_list[tmps_max] = str; return str; } STR * str_make(s) char *s; { register STR *str = str_new(0); str_set(str,s); return str; } STR * str_nmake(n) double n; { register STR *str = str_new(0); str_numset(str,n); return str; } mps_size) { tmps_size = tmps_max; if (!perl/x2p/a2p.y 644 473 0 22307 4747105020 6435 %{ /* $Header: a2p.y,v 3.0.1.1 90/03/01 10:30:08 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: a2p.y,v $ * Revision 3.0.1.1 90/03/01 10:30:08 lwall * patch9: a2p didn't allow logical expressions everywhere it should * * Revision 3.0 89/10/18 15:34:29 lwall * 3.0 baseline * */ #include "INTERN.h" #include "a2p.h" int root; int begins = Nullop; int ends = Nullop; %} %token BEGIN END %token REGEX %token SEMINEW NEWLINE COMMENT %token FUN1 FUNN GRGR %token PRINT PRINTF SPRINTF SPLIT %token IF ELSE WHILE FOR IN %token EXIT NEXT BREAK CONTINUE RET %token GETLINE DO SUB GSUB MATCH %token FUNCTION USERFUN DELETE %right ASGNOP %right '?' ':' %left OROR %left ANDAND %left IN %left NUMBER VAR SUBSTR INDEX %left MATCHOP %left RELOP '<' '>' %left OR %left STRING %left '+' '-' %left '*' '/' '%' %right UMINUS %left NOT %right '^' %left INCR DECR %left FIELD VFIELD %% program : junk hunks { root = oper4(OPROG,$1,begins,$2,ends); } ; begin : BEGIN '{' maybe states '}' junk { begins = oper4(OJUNK,begins,$3,$4,$6); in_begin = FALSE; $$ = Nullop; } ; end : END '{' maybe states '}' { ends = oper3(OJUNK,ends,$3,$4); $$ = Nullop; } | end NEWLINE { $$ = $1; } ; hunks : hunks hunk junk { $$ = oper3(OHUNKS,$1,$2,$3); } | /* NULL */ { $$ = Nullop; } ; hunk : patpat { $$ = oper1(OHUNK,$1); need_entire = TRUE; } | patpat '{' maybe states '}' { $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); } | FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}' { fixfargs($2,$4,0); $$ = oper5(OUSERDEF,$2,$4,$6,$8,$9); } | '{' maybe states '}' { $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); } | begin | end ; arg_list: expr_list { $$ = rememberargs($$); } ; patpat : cond { $$ = oper1(OPAT,$1); } | cond ',' cond { $$ = oper2(ORANGE,$1,$3); } ; cond : expr | match | rel | compound_cond ; compound_cond : '(' compound_cond ')' { $$ = oper1(OCPAREN,$2); } | cond ANDAND maybe cond { $$ = oper3(OCANDAND,$1,$3,$4); } | cond OROR maybe cond { $$ = oper3(OCOROR,$1,$3,$4); } | NOT cond { $$ = oper1(OCNOT,$2); } ; rel : expr RELOP expr { $$ = oper3(ORELOP,$2,$1,$3); } | expr '>' expr { $$ = oper3(ORELOP,string(">",1),$1,$3); } | expr '<' expr { $$ = oper3(ORELOP,string("<",1),$1,$3); } | '(' rel ')' { $$ = oper1(ORPAREN,$2); } ; match : expr MATCHOP expr { $$ = oper3(OMATCHOP,$2,$1,$3); } | expr MATCHOP REGEX { $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); } | REGEX %prec MATCHOP { $$ = oper1(OREGEX,$1); } | '(' match ')' { $$ = oper1(OMPAREN,$2); } ; expr : term { $$ = $1; } | expr term { $$ = oper2(OCONCAT,$1,$2); } | variable ASGNOP expr { $$ = oper3(OASSIGN,$2,$1,$3); if ((ops[$1].ival & 255) == OFLD) lval_field = TRUE; if ((ops[$1].ival & 255) == OVFLD) lval_field = TRUE; } ; term : variable { $$ = $1; } | NUMBER { $$ = oper1(ONUM,$1); } | STRING { $$ = oper1(OSTR,$1); } | term '+' term { $$ = oper2(OADD,$1,$3); } | term '-' term { $$ = oper2(OSUBTRACT,$1,$3); } | term '*' term { $$ = oper2(OMULT,$1,$3); } | term '/' term { $$ = oper2(ODIV,$1,$3); } | term '%' term { $$ = oper2(OMOD,$1,$3); } | term '^' term { $$ = oper2(OPOW,$1,$3); } | term IN VAR { $$ = oper2(ODEFINED,aryrefarg($3),$1); } | term '?' term ':' term { $$ = oper2(OCOND,$1,$3,$5); } | variable INCR { $$ = oper1(OPOSTINCR,$1); } | variable DECR { $$ = oper1(OPOSTDECR,$1); } | INCR variable { $$ = oper1(OPREINCR,$2); } | DECR variable { $$ = oper1(OPREDECR,$2); } | '-' term %prec UMINUS { $$ = oper1(OUMINUS,$2); } | '+' term %prec UMINUS { $$ = oper1(OUPLUS,$2); } | '(' cond ')' { $$ = oper1(OPAREN,$2); } | GETLINE { $$ = oper0(OGETLINE); } | GETLINE VAR { $$ = oper1(OGETLINE,$2); } | GETLINE '<' expr { $$ = oper3(OGETLINE,Nullop,string("<",1),$3); if (ops[$3].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } | GETLINE VAR '<' expr { $$ = oper3(OGETLINE,$2,string("<",1),$4); if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } | term 'p' GETLINE { $$ = oper3(OGETLINE,Nullop,string("|",1),$1); if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } | term 'p' GETLINE VAR { $$ = oper3(OGETLINE,$4,string("|",1),$1); if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } | FUN1 { $$ = oper0($1); need_entire = do_chop = TRUE; } | FUN1 '(' ')' { $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; } | FUN1 '(' expr ')' { $$ = oper1($1,$3); } | FUNN '(' expr_list ')' { $$ = oper1($1,$3); } | USERFUN '(' expr_list ')' { $$ = oper2(OUSERFUN,$1,$3); } | SPRINTF expr_list { $$ = oper1(OSPRINTF,$2); } | SUBSTR '(' expr ',' expr ',' expr ')' { $$ = oper3(OSUBSTR,$3,$5,$7); } | SUBSTR '(' expr ',' expr ')' { $$ = oper2(OSUBSTR,$3,$5); } | SPLIT '(' expr ',' VAR ',' expr ')' { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),$7); } | SPLIT '(' expr ',' VAR ')' { $$ = oper2(OSPLIT,$3,aryrefarg(numary($5))); } | INDEX '(' expr ',' expr ')' { $$ = oper2(OINDEX,$3,$5); } | MATCH '(' expr ',' REGEX ')' { $$ = oper2(OMATCH,$3,oper1(OREGEX,$5)); } | MATCH '(' expr ',' expr ')' { $$ = oper2(OMATCH,$3,$5); } | SUB '(' expr ',' expr ')' { $$ = oper2(OSUB,$3,$5); } | SUB '(' REGEX ',' expr ')' { $$ = oper2(OSUB,oper1(OREGEX,$3),$5); } | GSUB '(' expr ',' expr ')' { $$ = oper2(OGSUB,$3,$5); } | GSUB '(' REGEX ',' expr ')' { $$ = oper2(OGSUB,oper1(OREGEX,$3),$5); } | SUB '(' expr ',' expr ',' expr ')' { $$ = oper3(OSUB,$3,$5,$7); } | SUB '(' REGEX ',' expr ',' expr ')' { $$ = oper3(OSUB,oper1(OREGEX,$3),$5,$7); } | GSUB '(' expr ',' expr ',' expr ')' { $$ = oper3(OGSUB,$3,$5,$7); } | GSUB '(' REGEX ',' expr ',' expr ')' { $$ = oper3(OGSUB,oper1(OREGEX,$3),$5,$7); } ; variable: VAR { $$ = oper1(OVAR,$1); } | VAR '[' expr_list ']' { $$ = oper2(OVAR,aryrefarg($1),$3); } | FIELD { $$ = oper1(OFLD,$1); } | VFIELD term { $$ = oper1(OVFLD,$2); } ; expr_list : expr | clist | /* NULL */ { $$ = Nullop; } ; clist : expr ',' maybe expr { $$ = oper3(OCOMMA,$1,$3,$4); } | clist ',' maybe expr { $$ = oper3(OCOMMA,$1,$3,$4); } | '(' clist ')' /* these parens are invisible */ { $$ = $2; } ; junk : junk hunksep { $$ = oper2(OJUNK,$1,$2); } | /* NULL */ { $$ = Nullop; } ; hunksep : ';' { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } | SEMINEW { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } | NEWLINE { $$ = oper0(ONEWLINE); } | COMMENT { $$ = oper1(OCOMMENT,$1); } ; maybe : maybe nlstuff { $$ = oper2(OJUNK,$1,$2); } | /* NULL */ { $$ = Nullop; } ; nlstuff : NEWLINE { $$ = oper0(ONEWLINE); } | COMMENT { $$ = 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 { $$ = oper2(OSTATES,$1,$2); } | /* NULL */ { $$ = Nullop; } ; statement : 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 expr_list redir expr { $$ = oper3(OPRINT,$2,$3,$4); do_opens = TRUE; saw_ORS = saw_OFS = TRUE; if (!$2) need_entire = TRUE; if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } | PRINT expr_list { $$ = oper1(OPRINT,$2); if (!$2) need_entire = TRUE; saw_ORS = saw_OFS = TRUE; } | PRINTF expr_list redir expr { $$ = oper3(OPRINTF,$2,$3,$4); do_opens = TRUE; if (!$2) need_entire = TRUE; if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } | PRINTF expr_list { $$ = oper1(OPRINTF,$2); if (!$2) need_entire = TRUE; } | BREAK { $$ = oper0(OBREAK); } | NEXT { $$ = oper0(ONEXT); } | EXIT { $$ = oper0(OEXIT); } | EXIT expr { $$ = oper1(OEXIT,$2); } | CONTINUE { $$ = oper0(OCONTINUE); } | RET { $$ = oper0(ORETURN); } | RET expr { $$ = oper1(ORETURN,$2); } | DELETE VAR '[' expr ']' { $$ = oper2(ODELETE,aryrefarg($2),$4); } ; redir : '>' %prec FIELD { $$ = oper1(OREDIR,$1); } | GRGR { $$ = oper1(OREDIR,string(">>",2)); } | '|' { $$ = oper1(OREDIR,string("|",1)); } ; compound : IF '(' cond ')' maybe statement { $$ = oper2(OIF,$3,bl($6,$5)); } | IF '(' cond ')' maybe statement ELSE maybe statement { $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); } | WHILE '(' cond ')' maybe statement { $$ = oper2(OWHILE,$3,bl($6,$5)); } | DO maybe statement WHILE '(' cond ')' { $$ = oper2(ODO,bl($3,$2),$6); } | FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); } | FOR '(' simpnull ';' ';' simpnull ')' maybe statement { $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); } | FOR '(' expr ')' maybe statement { $$ = oper2(OFORIN,$3,bl($6,$5)); } | '{' maybe states '}' maybe { $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); } ; %% #include "a2py.c" = oper2(OWHILE,$3,bl($6,$5)); } | DO maybe statement WHILE '(' cond ')' { $$ = oper2(ODO,bl($3,$2),$6); } | FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); } | FOR '(' simpnull ';' ';' simpnull ')' maybe statement { $$ = oper4(OFOR,$3,string("",0),$6,perl/x2p/a2p.man 644 473 0 14621 4747105021 6741 .rn '' }` ''' $Header: a2p.man,v 3.0 89/10/18 15:34:22 lwall Locked $ ''' ''' $Log: a2p.man,v $ ''' Revision 3.0 89/10/18 15:34:22 lwall ''' 3.0 baseline ''' ''' Revision 2.0.1.1 88/07/11 23:16:25 root ''' patch2: changes related to 1985 awk ''' ''' Revision 2.0 88/06/05 00:15:36 root ''' Baseline version 2.0. ''' ''' .de Sh .br .ne 5 .PP \fB\\$1\fR .PP .. .de Sp .if t .sp .5v .if n .sp .. .de Ip .br .ie \\n.$>=3 .ne \\$3 .el .ne 3 .IP "\\$1" \\$2 .. ''' ''' Set up \*(-- to give an unbreakable dash; ''' string Tr holds user defined translation string. ''' Bell System Logo is used as a dummy character. ''' .tr \(*W-|\(bv\*(Tr .ie n \{\ .ds -- \(*W- .if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch .if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch .ds L" "" .ds R" "" .ds L' ' .ds R' ' 'br\} .el\{\ .ds -- \(em\| .tr \*(Tr .ds L" `` .ds R" '' .ds L' ` .ds R' ' 'br\} .TH A2P 1 LOCAL .SH NAME a2p - Awk to Perl translator .SH SYNOPSIS .B a2p [options] filename .SH DESCRIPTION .I A2p takes an awk script specified on the command line (or from standard input) and produces a comparable .I perl script on the standard output. .Sh "Options" Options include: .TP 5 .B \-D sets debugging flags. .TP 5 .B \-F tells a2p that this awk script is always invoked with this -F switch. .TP 5 .B \-n specifies the names of the input fields if input does not have to be split into an array. If you were translating an awk script that processes the password file, you might say: .sp a2p -7 -nlogin.password.uid.gid.gcos.shell.home .sp Any delimiter can be used to separate the field names. .TP 5 .B \- causes a2p to assume that input will always have that many fields. .Sh "Considerations" A2p cannot do as good a job translating as a human would, but it usually does pretty well. There are some areas where you may want to examine the perl script produced and tweak it some. Here are some of them, in no particular order. .PP There is an awk idiom of putting int() around a string expression to force numeric interpretation, even though the argument is always integer anyway. This is generally unneeded in perl, but a2p can't tell if the argument is always going to be integer, so it leaves it in. You may wish to remove it. .PP Perl differentiates numeric comparison from string comparison. Awk has one operator for both that decides at run time which comparison to do. A2p does not try to do a complete job of awk emulation at this point. Instead it guesses which one you want. It's almost always right, but it can be spoofed. All such guesses are marked with the comment \*(L"#???\*(R". You should go through and check them. You might want to run at least once with the \-w switch to perl, which will warn you if you use == where you should have used eq. .PP Perl does not attempt to emulate the behavior of awk in which nonexistent array elements spring into existence simply by being referenced. If somehow you are relying on this mechanism to create null entries for a subsequent for...in, they won't be there in perl. .PP If a2p makes a split line that assigns to a list of variables that looks like (Fld1, Fld2, Fld3...) you may want to rerun a2p using the \-n option mentioned above. This will let you name the fields throughout the script. If it splits to an array instead, the script is probably referring to the number of fields somewhere. .PP The exit statement in awk doesn't necessarily exit; it goes to the END block if there is one. Awk scripts that do contortions within the END block to bypass the block under such circumstances can be simplified by removing the conditional in the END block and just exiting directly from the perl script. .PP Perl has two kinds of array, numerically-indexed and associative. Awk arrays are usually translated to associative arrays, but if you happen to know that the index is always going to be numeric you could change the {...} to [...]. Iteration over an associative array is done using the keys() function, but iteration over a numeric array is NOT. You might need to modify any loop that is iterating over the array in question. .PP Awk starts by assuming OFMT has the value %.6g. Perl starts by assuming its equivalent, $#, to have the value %.20g. You'll want to set $# explicitly if you use the default value of OFMT. .PP Near the top of the line loop will be the split operation that is implicit in the awk script. There are times when you can move this down past some conditionals that test the entire record so that the split is not done as often. .PP For aesthetic reasons you may wish to change the array base $[ from 1 back to perl's default of 0, but remember to change all array subscripts AND all substr() and index() operations to match. .PP Cute comments that say "# Here is a workaround because awk is dumb" are passed through unmodified. .PP Awk scripts are often embedded in a shell script that pipes stuff into and out of awk. Often the shell script wrapper can be incorporated into the perl script, since perl can start up pipes into and out of itself, and can do other things that awk can't do by itself. .PP Scripts that refer to the special variables RSTART and RLENGTH can often be simplified by referring to the variables $`, $& and $', as long as they are within the scope of the pattern match that sets them. .PP The produced perl script may have subroutines defined to deal with awk's semantics regarding getline and print. Since a2p usually picks correctness over efficiency. it is almost always possible to rewrite such code to be more efficient by discarding the semantic sugar. .PP For efficiency, you may wish to remove the keyword from any return statement that is the last statement executed in a subroutine. A2p catches the most common case, but doesn't analyze embedded blocks for subtler cases. .PP ARGV[0] translates to $ARGV0, but ARGV[n] translates to $ARGV[$n]. A loop that tries to iterate over ARGV[0] won't find it. .SH ENVIRONMENT A2p uses no environment variables. .SH AUTHOR Larry Wall .SH FILES .SH SEE ALSO perl The perl compiler/interpreter .br s2p sed to perl translator .SH DIAGNOSTICS .SH BUGS It would be possible to emulate awk's behavior in selecting string versus numeric operations at run time by inspection of the operands, but it would be gross and inefficient. Besides, a2p almost always guesses right. .PP Storage for the awk syntax tree is currently static, and can run out. .rn }` '' RONMENT A2p uses no environment variables. .SH AUTHOR Larry Wall .SH FILES .SH perl/x2p/a2p.h 644 473 0 14436 4747105021 6421 /* $Header: a2p.h,v 3.0.1.3 90/03/01 10:29:29 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: a2p.h,v $ * Revision 3.0.1.3 90/03/01 10:29:29 lwall * patch9: a2p.h had bzero() definition depending on BCOPY * * Revision 3.0.1.2 89/12/21 20:30:29 lwall * patch7: arranged so a2p has a chance of running on a 286 * * Revision 3.0.1.1 89/11/11 05:07:00 lwall * patch2: Configure may now set -DDEBUGGING * * Revision 3.0 89/10/18 15:34:14 lwall * 3.0 baseline * */ #define VOIDUSED 1 #include "../config.h" #ifndef BCOPY # define bcopy(s1,s2,l) memcpy(s2,s1,l) #endif #ifndef BZERO # define bzero(s,l) memset(s,0,l) #endif #include "handy.h" #define Nullop 0 #define OPROG 1 #define OJUNK 2 #define OHUNKS 3 #define ORANGE 4 #define OPAT 5 #define OHUNK 6 #define OPPAREN 7 #define OPANDAND 8 #define OPOROR 9 #define OPNOT 10 #define OCPAREN 11 #define OCANDAND 12 #define OCOROR 13 #define OCNOT 14 #define ORELOP 15 #define ORPAREN 16 #define OMATCHOP 17 #define OMPAREN 18 #define OCONCAT 19 #define OASSIGN 20 #define OADD 21 #define OSUBTRACT 22 #define OMULT 23 #define ODIV 24 #define OMOD 25 #define OPOSTINCR 26 #define OPOSTDECR 27 #define OPREINCR 28 #define OPREDECR 29 #define OUMINUS 30 #define OUPLUS 31 #define OPAREN 32 #define OGETLINE 33 #define OSPRINTF 34 #define OSUBSTR 35 #define OSTRING 36 #define OSPLIT 37 #define OSNEWLINE 38 #define OINDEX 39 #define ONUM 40 #define OSTR 41 #define OVAR 42 #define OFLD 43 #define ONEWLINE 44 #define OCOMMENT 45 #define OCOMMA 46 #define OSEMICOLON 47 #define OSCOMMENT 48 #define OSTATES 49 #define OSTATE 50 #define OPRINT 51 #define OPRINTF 52 #define OBREAK 53 #define ONEXT 54 #define OEXIT 55 #define OCONTINUE 56 #define OREDIR 57 #define OIF 58 #define OWHILE 59 #define OFOR 60 #define OFORIN 61 #define OVFLD 62 #define OBLOCK 63 #define OREGEX 64 #define OLENGTH 65 #define OLOG 66 #define OEXP 67 #define OSQRT 68 #define OINT 69 #define ODO 70 #define OPOW 71 #define OSUB 72 #define OGSUB 73 #define OMATCH 74 #define OUSERFUN 75 #define OUSERDEF 76 #define OCLOSE 77 #define OATAN2 78 #define OSIN 79 #define OCOS 80 #define ORAND 81 #define OSRAND 82 #define ODELETE 83 #define OSYSTEM 84 #define OCOND 85 #define ORETURN 86 #define ODEFINED 87 #define OSTAR 88 #ifdef DOINIT char *opname[] = { "0", "PROG", "JUNK", "HUNKS", "RANGE", "PAT", "HUNK", "PPAREN", "PANDAND", "POROR", "PNOT", "CPAREN", "CANDAND", "COROR", "CNOT", "RELOP", "RPAREN", "MATCHOP", "MPAREN", "CONCAT", "ASSIGN", "ADD", "SUBTRACT", "MULT", "DIV", "MOD", "POSTINCR", "POSTDECR", "PREINCR", "PREDECR", "UMINUS", "UPLUS", "PAREN", "GETLINE", "SPRINTF", "SUBSTR", "STRING", "SPLIT", "SNEWLINE", "INDEX", "NUM", "STR", "VAR", "FLD", "NEWLINE", "COMMENT", "COMMA", "SEMICOLON", "SCOMMENT", "STATES", "STATE", "PRINT", "PRINTF", "BREAK", "NEXT", "EXIT", "CONTINUE", "REDIR", "IF", "WHILE", "FOR", "FORIN", "VFLD", "BLOCK", "REGEX", "LENGTH", "LOG", "EXP", "SQRT", "INT", "DO", "POW", "SUB", "GSUB", "MATCH", "USERFUN", "USERDEF", "CLOSE", "ATAN2", "SIN", "COS", "RAND", "SRAND", "DELETE", "SYSTEM", "COND", "RETURN", "DEFINED", "STAR", "89" }; #else extern char *opname[]; #endif EXT int mop INIT(1); union u_ops { int ival; char *cval; }; #if defined(iAPX286) || defined(M_I286) || defined(I80286) /* 80286 hack */ #define OPSMAX (64000/sizeof(union u_ops)) /* approx. max segment size */ #else #define OPSMAX 50000 #endif /* 80286 hack */ union u_ops ops[OPSMAX]; #include #include typedef struct string STR; typedef struct htbl HASH; #include "str.h" #include "hash.h" /* A string is TRUE if not "" or "0". */ #define True(val) (tmps = (val), (*tmps && !(*tmps == '0' && !tmps[1]))) EXT char *Yes INIT("1"); EXT char *No INIT(""); #define str_true(str) (Str = (str), (Str->str_pok ? True(Str->str_ptr) : (Str->str_nok ? (Str->str_nval != 0.0) : 0 ))) #define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),buf) : "" ))) #define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str))) #define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_nval : str_2num(Str))) EXT STR *Str; #define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len) STR *str_new(); char *scanpat(); char *scannum(); void str_free(); EXT int line INIT(0); EXT FILE *rsfp; EXT char buf[1024]; EXT char *bufptr INIT(buf); EXT STR *linestr INIT(Nullstr); EXT char tokenbuf[256]; EXT int expectterm INIT(TRUE); #ifdef DEBUGGING EXT int debug INIT(0); EXT int dlevel INIT(0); #define YYDEBUG 1 extern int yydebug; #endif EXT STR *freestrroot INIT(Nullstr); EXT STR str_no; EXT STR str_yes; EXT bool do_split INIT(FALSE); EXT bool split_to_array INIT(FALSE); EXT bool set_array_base INIT(FALSE); EXT bool saw_RS INIT(FALSE); EXT bool saw_OFS INIT(FALSE); EXT bool saw_ORS INIT(FALSE); EXT bool saw_line_op INIT(FALSE); EXT bool in_begin INIT(TRUE); EXT bool do_opens INIT(FALSE); EXT bool do_fancy_opens INIT(FALSE); EXT bool lval_field INIT(FALSE); EXT bool do_chop INIT(FALSE); EXT bool need_entire INIT(FALSE); EXT bool absmaxfld INIT(FALSE); EXT bool saw_altinput INIT(FALSE); EXT char const_FS INIT(0); EXT char *namelist INIT(Nullch); EXT char fswitch INIT(0); EXT int saw_FS INIT(0); EXT int maxfld INIT(0); EXT int arymax INIT(0); char *nameary[100]; EXT STR *opens; EXT HASH *symtab; EXT HASH *curarghash; #define P_MIN 0 #define P_LISTOP 5 #define P_COMMA 10 #define P_ASSIGN 15 #define P_COND 20 #define P_DOTDOT 25 #define P_OROR 30 #define P_ANDAND 35 #define P_OR 40 #define P_AND 45 #define P_EQ 50 #define P_REL 55 #define P_UNI 60 #define P_FILETEST 65 #define P_SHIFT 70 #define P_ADD 75 #define P_MUL 80 #define P_MATCH 85 #define P_UNARY 90 #define P_POW 95 #define P_AUTO 100 #define P_MAX 999 arymax INIT(0); char *nameary[100]; EXT STR *opens; EXT HASH *symtab; EXT HASH *curarghash; #define P_MIN 0 #define P_LISTOP 5 #define P_COMMA 10 #define P_ASSIGN 15 #define P_COND 20 #define P_DOTDOT 25 #define P_OROR perl/x2p/hash.c 644 473 0 11347 4747105021 6653 /* $Header: hash.c,v 3.0 89/10/18 15:34:50 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: hash.c,v $ * Revision 3.0 89/10/18 15:34:50 lwall * 3.0 baseline * */ #include #include "EXTERN.h" #include "handy.h" #include "util.h" #include "a2p.h" STR * hfetch(tb,key) register HASH *tb; char *key; { register char *s; register int i; register int hash; register HENT *entry; if (!tb) return Nullstr; for (s=key, i=0, hash = 0; /* while */ *s; s++, i++, hash *= 5) { hash += *s * coeff[i]; } entry = tb->tbl_array[hash & tb->tbl_max]; for (; entry; entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (strNE(entry->hent_key,key)) /* is this it? */ continue; return entry->hent_val; } return Nullstr; } bool hstore(tb,key,val) register HASH *tb; char *key; STR *val; { register char *s; register int i; register int hash; register HENT *entry; register HENT **oentry; if (!tb) return FALSE; for (s=key, i=0, hash = 0; /* while */ *s; s++, i++, hash *= 5) { hash += *s * coeff[i]; } oentry = &(tb->tbl_array[hash & tb->tbl_max]); i = 1; for (entry = *oentry; entry; i=0, entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (strNE(entry->hent_key,key)) /* is this it? */ continue; safefree((char*)entry->hent_val); entry->hent_val = val; return TRUE; } entry = (HENT*) safemalloc(sizeof(HENT)); entry->hent_key = savestr(key); entry->hent_val = val; entry->hent_hash = hash; entry->hent_next = *oentry; *oentry = entry; if (i) { /* initial entry? */ tb->tbl_fill++; if ((tb->tbl_fill * 100 / (tb->tbl_max + 1)) > FILLPCT) hsplit(tb); } return FALSE; } #ifdef NOTUSED bool hdelete(tb,key) register HASH *tb; char *key; { register char *s; register int i; register int hash; register HENT *entry; register HENT **oentry; if (!tb) return FALSE; for (s=key, i=0, hash = 0; /* while */ *s; s++, i++, hash *= 5) { hash += *s * coeff[i]; } oentry = &(tb->tbl_array[hash & tb->tbl_max]); entry = *oentry; i = 1; for (; entry; i=0, oentry = &entry->hent_next, entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (strNE(entry->hent_key,key)) /* is this it? */ continue; safefree((char*)entry->hent_val); safefree(entry->hent_key); *oentry = entry->hent_next; safefree((char*)entry); if (i) tb->tbl_fill--; return TRUE; } return FALSE; } #endif hsplit(tb) HASH *tb; { int oldsize = tb->tbl_max + 1; register int newsize = oldsize * 2; register int i; register HENT **a; register HENT **b; register HENT *entry; register HENT **oentry; a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*)); bzero((char*)&a[oldsize], oldsize * sizeof(HENT*)); /* zero second half */ tb->tbl_max = --newsize; tb->tbl_array = a; for (i=0; ihent_hash & newsize) != i) { *oentry = entry->hent_next; entry->hent_next = *b; if (!*b) tb->tbl_fill++; *b = entry; continue; } else oentry = &entry->hent_next; } if (!*a) /* everything moved */ tb->tbl_fill--; } } HASH * hnew() { register HASH *tb = (HASH*)safemalloc(sizeof(HASH)); tb->tbl_array = (HENT**) safemalloc(8 * sizeof(HENT*)); tb->tbl_fill = 0; tb->tbl_max = 7; hiterinit(tb); /* so each() will start off right */ bzero((char*)tb->tbl_array, 8 * sizeof(HENT*)); return tb; } #ifdef NOTUSED hshow(tb) register HASH *tb; { fprintf(stderr,"%5d %4d (%2d%%)\n", tb->tbl_max+1, tb->tbl_fill, tb->tbl_fill * 100 / (tb->tbl_max+1)); } #endif hiterinit(tb) register HASH *tb; { tb->tbl_riter = -1; tb->tbl_eiter = Null(HENT*); return tb->tbl_fill; } HENT * hiternext(tb) register HASH *tb; { register HENT *entry; entry = tb->tbl_eiter; do { if (entry) entry = entry->hent_next; if (!entry) { tb->tbl_riter++; if (tb->tbl_riter > tb->tbl_max) { tb->tbl_riter = -1; break; } entry = tb->tbl_array[tb->tbl_riter]; } } while (!entry); tb->tbl_eiter = entry; return entry; } char * hiterkey(entry) register HENT *entry; { return entry->hent_key; } STR * hiterval(entry) register HENT *entry; { return entry->hent_val; } egister HASH *tb; { register HENT *entry; entry = tb->tbl_eiter; do { if (entry) entry = entry->hent_next; if (!entry) { tb->tbl_riter++; if (tb->tbl_riter > tb->tbl_max) { tb->tbl_riter = -1; break; } entry = tb->tbl_array[tb->tbl_riterperl/x2p/Makefile.SH 644 473 0 7364 4747105021 7521 case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac case $CONFIG in '') if test ! -f config.sh; then ln ../config.sh . || \ ln ../../config.sh . || \ ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) fi . ./config.sh ;; esac case "$mallocsrc" in '') ;; *) mallocsrc="../$mallocsrc";; esac echo "Extracting x2p/Makefile (with variable substitutions)" cat >Makefile <>Makefile <<'!NO!SUBS!' public = a2p s2p private = manpages = a2p.man s2p.man util = sh = Makefile.SH makedepend.SH h = EXTERN.h INTERN.h config.h handy.h hash.h a2p.h str.h util.h c = hash.c $(mallocsrc) str.c util.c walk.c obj = hash.o $(mallocobj) str.o util.o walk.o lintflags = -phbvxac addedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 # grrr SHELL = /bin/sh .c.o: $(CC) -c $(CFLAGS) $(LARGE) $*.c all: $(public) $(private) $(util) touch all a2p: $(obj) a2p.o $(CC) $(LARGE) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p a2p.c: a2p.y @ echo Expect 232 shift/reduce conflicts... $(YACC) a2p.y mv y.tab.c a2p.c a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h $(CC) -c $(CFLAGS) $(LARGE) a2p.c install: a2p s2p # won't work with csh export PATH || exit 1 - mv $(bin)/a2p $(bin)/a2p.old 2>/dev/null - mv $(bin)/s2p $(bin)/s2p.old 2>/dev/null - if test `pwd` != $(bin); then cp $(public) $(bin); fi cd $(bin); \ for pub in $(public); do \ chmod +x `basename $$pub`; \ done # chmod +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 +x `basename $$priv`; \ #done - if test `pwd` != $(mansrc); then \ for page in $(manpages); do \ cp $$page $(mansrc)/`basename $$page .man`.$(manext); \ done; \ fi clean: rm -f *.o realclean: rm -f a2p *.orig */*.orig *.o core $(addedbyconf) # The following lint has practically everything turned on. Unfortunately, # you have to wade through a lot of mumbo jumbo that can't be suppressed. # If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message # for that spot. lint: lint $(lintflags) $(defs) $(c) > a2p.fuzz depend: ../makedepend ../makedepend clist: echo $(c) | tr ' ' '\012' >.clist hlist: echo $(h) | tr ' ' '\012' >.hlist shlist: echo $(sh) | tr ' ' '\012' >.shlist config.sh: ../config.sh rm -f config.sh ln ../config.sh . # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE $(obj): @ echo "You haven't done a "'"make depend" yet!'; exit 1 makedepend: makedepend.SH /bin/sh makedepend.SH !NO!SUBS! $eunicefix Makefile case `pwd` in *SH) $rm -f ../Makefile ln Makefile ../Makefile ;; esac nd ../makedepend clist: echo $(c) | tr ' ' '\012' >.clist hlist: echo $(h) | tr ' ' '\012' >.hlist shlist: echo $(sh) | tr ' ' '\012' >.shlist config.sh: ../config.sh rm -f config.sh ln ../config.sh . # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHINGperl/x2p/s2p.man 644 473 0 4203 4747105022 6737 .rn '' }` ''' $Header: s2p.man,v 3.0 89/10/18 15:35:09 lwall Locked $ ''' ''' $Log: s2p.man,v $ ''' Revision 3.0 89/10/18 15:35:09 lwall ''' 3.0 baseline ''' ''' Revision 2.0 88/06/05 00:15:59 root ''' Baseline version 2.0. ''' ''' .de Sh .br .ne 5 .PP \fB\\$1\fR .PP .. .de Sp .if t .sp .5v .if n .sp .. .de Ip .br .ie \\n.$>=3 .ne \\$3 .el .ne 3 .IP "\\$1" \\$2 .. ''' ''' Set up \*(-- to give an unbreakable dash; ''' string Tr holds user defined translation string. ''' Bell System Logo is used as a dummy character. ''' .tr \(*W-|\(bv\*(Tr .ie n \{\ .ds -- \(*W- .if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch .if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch .ds L" "" .ds R" "" .ds L' ' .ds R' ' 'br\} .el\{\ .ds -- \(em\| .tr \*(Tr .ds L" `` .ds R" '' .ds L' ` .ds R' ' 'br\} .TH S2P 1 NEW .SH NAME s2p - Sed to Perl translator .SH SYNOPSIS .B s2p [options] filename .SH DESCRIPTION .I S2p takes a sed script specified on the command line (or from standard input) and produces a comparable .I perl script on the standard output. .Sh "Options" Options include: .TP 5 .B \-D sets debugging flags. .TP 5 .B \-n specifies that this sed script was always invoked with a sed -n. Otherwise a switch parser is prepended to the front of the script. .TP 5 .B \-p specifies that this sed script was never invoked with a sed -n. Otherwise a switch parser is prepended to the front of the script. .Sh "Considerations" The perl script produced looks very sed-ish, and there may very well be better ways to express what you want to do in perl. For instance, s2p does not make any use of the split operator, but you might want to. .PP The perl script you end up with may be either faster or slower than the original sed script. If you're only interested in speed you'll just have to try it both ways. Of course, if you want to do something sed doesn't do, you have no choice. .SH ENVIRONMENT S2p uses no environment variables. .SH AUTHOR Larry Wall .SH FILES .SH SEE ALSO perl The perl compiler/interpreter .br a2p awk to perl translator .SH DIAGNOSTICS .SH BUGS .rn }` '' plit operator, but you might want to. .PP The perl script you end up with may be either faster or slower than the original sed script. If you're only interested in speed you'll just have to try it both ways. Of course, if you want to do something sed doesn't do, you have no choice. .SH ENVIRONMENT S2p uses no environment variables. .SH AUTHOR Larry Wall str_link.str_magic && stabset(x->str_link.str_magic,x)) EXT STR **tmps_list; EXT long tmps_max INIT(-1); char *str_2ptr(); double str_2num(); STR *str_static(); STR *str_make(); STR *str_nmake(); char *str_gets(); on { STR *str_next; /* while free, link to next free str */ } str_link; char str_pok; /* state of str_ptr */ char str_nok; /* state of str_nval */ }; #define Nullstr Null(STR*) /* the following macro updates any magic values this str is associated with */ #define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x)) EXT STR **tmps_list; EXT long tmps_max INIT(-1); char *str_2ptr(); double str_2num(); STR *str_static(); STR *strperl/x2p/handy.h 644 473 0 1503 4747105022 7012 /* $Header: handy.h,v 3.0 89/10/18 15:34:44 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: handy.h,v $ * Revision 3.0 89/10/18 15:34:44 lwall * 3.0 baseline * */ #define Null(type) ((type)0) #define Nullch Null(char*) #define Nullfp Null(FILE*) #define bool char #define TRUE (1) #define FALSE (0) #define Ctl(ch) (ch & 037) #define strNE(s1,s2) (strcmp(s1,s2)) #define strEQ(s1,s2) (!strcmp(s1,s2)) #define strLT(s1,s2) (strcmp(s1,s2) < 0) #define strLE(s1,s2) (strcmp(s1,s2) <= 0) #define strGT(s1,s2) (strcmp(s1,s2) > 0) #define strGE(s1,s2) (strcmp(s1,s2) >= 0) #define strnNE(s1,s2,l) (strncmp(s1,s2,l)) #define strnEQ(s1,s2,l) (!strncmp(s1,s2,l)) baseline * */ #define Null(type) ((type)0) #define Nullch Null(char*) #define Nullfp Null(FILE*) #define bool char #define TRUE (1) #define FALSE (0) #define Ctl(ch) (ch & 037) #defiperl/x2p/util.h 644 473 0 1467 4747105023 6676 /* $Header: util.h,v 3.0 89/10/18 15:35:41 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: util.h,v $ * Revision 3.0 89/10/18 15:35:41 lwall * 3.0 baseline * */ /* is the string for makedir a directory name or a filename? */ #define MD_DIR 0 #define MD_FILE 1 void util_init(); int doshell(); char *safemalloc(); char *saferealloc(); char *safecpy(); char *safecat(); char *cpytill(); char *cpy2(); char *instr(); #ifdef SETUIDGID int eaccess(); #endif char *getwd(); void cat(); void prexit(); char *get_a_line(); char *savestr(); int makedir(); void setenv(); int envix(); void notincl(); char *getval(); void growstr(); void setdef(); ll * 3.0 baseline * */ /* is the string for makedir a directory name or a filename? */ #define MD_DIR 0 #define MD_FILE 1 void util_init(); int doshell(); char *safemalloc(); char *saferealloc()perl/x2p/EXTERN.h 644 473 0 641 4747105023 6677 /* $Header: EXTERN.h,v 3.0 89/10/18 15:33:37 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: EXTERN.h,v $ * Revision 3.0 89/10/18 15:33:37 lwall * 3.0 baseline * */ #undef EXT #define EXT extern #undef INIT #define INIT(x) #undef DOINIT R 0 #define MD_FILE 1 void util_init(); int doshell(); char *safemalloc(); char *saferealloc()perl/x2p/INTERN.h 644 473 0 637 4747105023 6676 /* $Header: INTERN.h,v 3.0 89/10/18 15:33:45 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: INTERN.h,v $ * Revision 3.0 89/10/18 15:33:45 lwall * 3.0 baseline * */ #undef EXT #define EXT #undef INIT #define INIT(x) = x #define DOINIT T R 0 #define MD_FILE 1 void util_init(); int doshell(); char *safemalloc(); char *saferealloc()perl/x2p/s2p 755 473 0 26032 4747105615 6224 #!/usr/local/bin/perl $bin = '/usr/local/bin'; # $Header: s2p.SH,v 3.0.1.3 90/03/01 10:31:21 lwall Locked $ # # $Log: s2p.SH,v $ # Revision 3.0.1.3 90/03/01 10:31:21 lwall # patch9: s2p didn't handle \< and \> # # Revision 3.0.1.2 89/11/17 15:51:27 lwall # patch5: in s2p, line labels without a subsequent statement were done wrong # patch5: s2p left residue in /tmp # # Revision 3.0.1.1 89/11/11 05:08:25 lwall # patch2: in s2p, + within patterns needed backslashing # patch2: s2p was printing out some debugging info to the output file # # Revision 3.0 89/10/18 15:35:02 lwall # 3.0 baseline # # Revision 2.0.1.1 88/07/11 23:26:23 root # patch2: s2p didn't put a proper prologue on output script # # Revision 2.0 88/06/05 00:15:55 root # Baseline version 2.0. # # $indent = 4; $shiftwidth = 4; $l = '{'; $r = '}'; $tempvar = '1'; while ($ARGV[0] =~ '^-') { $_ = shift; last if /^--/; if (/^-D/) { $debug++; open(body,'>-'); next; } if (/^-n/) { $assumen++; next; } if (/^-p/) { $assumep++; next; } die "I don't recognize this switch: $_\n"; } unless ($debug) { open(body,">/tmp/sperl$$") || do Die("Can't open temp file"); } if (!$assumen && !$assumep) { print body 'while ($ARGV[0] =~ /^-/) { $_ = shift; last if /^--/; if (/^-n/) { $nflag++; next; } die "I don\'t recognize this switch: $_\\n"; } '; } print body ' #ifdef PRINTIT #ifdef ASSUMEP $printit++; #else $printit++ unless $nflag; #endif #endif line: while (<>) { '; line: while (<>) { s/[ \t]*(.*)\n$/$1/; if (/^:/) { s/^:[ \t]*//; $label = do make_label($_); if ($. == 1) { $toplabel = $label; } $_ = "$label:"; if ($lastlinewaslabel++) { $indent += 4; print body "\t" x ($indent / 8), ' ' x ($indent % 8), ";\n"; $indent -= 4; } if ($indent >= 2) { $indent -= 2; $indmod = 2; } next; } else { $lastlinewaslabel = ''; } $addr1 = ''; $addr2 = ''; if (s/^([0-9]+)//) { $addr1 = "$1"; } elsif (s/^\$//) { $addr1 = 'eof()'; } elsif (s|^/||) { $addr1 = do fetchpat('/'); } if (s/^,//) { if (s/^([0-9]+)//) { $addr2 = "$1"; } elsif (s/^\$//) { $addr2 = "eof()"; } elsif (s|^/||) { $addr2 = do fetchpat('/'); } else { do Die("Invalid second address at line $.\n"); } $addr1 .= " .. $addr2"; } # a { to keep vi happy s/^[ \t]+//; if ($_ eq '}') { $indent -= 4; next; } if (s/^!//) { $if = 'unless'; $else = "$r else $l\n"; } else { $if = 'if'; $else = ''; } if (s/^{//) { # a } to keep vi happy $indmod = 4; $redo = $_; $_ = ''; $rmaybe = ''; } else { $rmaybe = "\n$r"; if ($addr2 || $addr1) { $space = ' ' x $shiftwidth; } else { $space = ''; } $_ = do transmogrify(); } if ($addr1) { if ($_ !~ /[\n{}]/ && $rmaybe && !$change && $_ !~ / if / && $_ !~ / unless /) { s/;$/ $if $addr1;/; $_ = substr($_,$shiftwidth,1000); } else { $command = $_; $_ = "$if ($addr1) $l\n$change$command$rmaybe"; } $change = ''; next line; } } continue { @lines = split(/\n/,$_); while ($#lines >= 0) { $_ = shift(lines); unless (s/^ *<<--//) { print body "\t" x ($indent / 8), ' ' x ($indent % 8); } print body $_, "\n"; } $indent += $indmod; $indmod = 0; if ($redo) { $_ = $redo; $redo = ''; redo line; } } if ($lastlinewaslabel++) { $indent += 4; print body "\t" x ($indent / 8), ' ' x ($indent % 8), ";\n"; $indent -= 4; } print body "}\n"; if ($appendseen || $tseen || !$assumen) { $printit++ if $dseen || (!$assumen && !$assumep); print body ' continue { #ifdef PRINTIT #ifdef DSEEN #ifdef ASSUMEP print if $printit++; #else if ($printit) { print;} else { $printit++ unless $nflag; } #endif #else print if $printit; #endif #else print; #endif #ifdef TSEEN $tflag = \'\'; #endif #ifdef APPENDSEEN if ($atext) { print $atext; $atext = \'\'; } #endif } '; } close body; unless ($debug) { open(head,">/tmp/sperl2$$.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 DSEEN\n" if ($dseen); print head "#define ASSUMEN\n" if ($assumen); print head "#define ASSUMEP\n" if ($assumep); if ($opens) {print head "$opens\n";} open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file"); while () { print head $_; } close head; print "#!$bin/perl eval \"exec $bin/perl -S \$0 \$*\" if \$running_under_some_shell; "; open(body,"cc -E /tmp/sperl2$$.c |") || do Die("Can't reopen temp file"); while () { /^# [0-9]/ && next; /^[ \t]*$/ && next; s/^<><>//; print; } } unlink "/tmp/sperl$$", "/tmp/sperl2$$", "/tmp/sperl2$$.c"; sub Die { unlink "/tmp/sperl$$", "/tmp/sperl2$$", "/tmp/sperl2$$.c"; die $_[0]; } sub make_filehandle { $fname = $_ = $_[0]; s/[^a-zA-Z]/_/g; s/^_*//; if (/^([a-z])([a-z]*)$/) { $first = $1; $rest = $2; $first =~ y/a-z/A-Z/; $_ = $first . $rest; } if (!$seen{$_}) { $opens .= "open($_,'>$fname') || die \"Can't create $fname\";\n"; } $seen{$_} = $_; } sub make_label { $label = $_[0]; $label =~ s/[^a-zA-Z0-9]/_/g; if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } $label = substr($label,0,8); if ($label =~ /^([a-z])([a-z]*)$/) { # could be reserved word $first = $1; $rest = $2; $first =~ y/a-z/A-Z/; # so capitalize it $label = $first . $rest; } $label; } sub transmogrify { { # case if (/^d/) { $dseen++; $_ = ' <<--#ifdef PRINTIT $printit = \'\'; <<--#endif next line;'; next; } if (/^n/) { $_ = '<<--#ifdef PRINTIT <<--#ifdef DSEEN <<--#ifdef ASSUMEP print if $printit++; <<--#else if ($printit) { print;} else { $printit++ unless $nflag; } <<--#endif <<--#else print if $printit; <<--#endif <<--#else print; <<--#endif <<--#ifdef APPENDSEEN if ($atext) {print $atext; $atext = \'\';} <<--#endif $_ = <>; <<--#ifdef TSEEN $tflag = \'\'; <<--#endif'; next; } if (/^a/) { $appendseen++; $command = $space . '$atext .=' . "\n<<--'"; $lastline = 0; while (<>) { s/^[ \t]*//; s/^[\\]//; unless (s|\\$||) { $lastline = 1;} s/'/\\'/g; s/^([ \t]*\n)/<><>$1/; $command .= $_; $command .= '<<--'; last if $lastline; } $_ = $command . "';"; last; } if (/^[ic]/) { if (/^c/) { $change = 1; } $addr1 = '$iter = (' . $addr1 . ')'; $command = $space . 'if ($iter == 1) { print' . "\n<<--'"; $lastline = 0; while (<>) { s/^[ \t]*//; s/^[\\]//; unless (s/\\$//) { $lastline = 1;} s/'/\\'/g; s/^([ \t]*\n)/<><>$1/; $command .= $_; $command .= '<<--'; last if $lastline; } $_ = $command . "';}"; if ($change) { $dseen++; $change = "$_\n"; $_ = " <<--#ifdef PRINTIT $space\$printit = ''; <<--#endif ${space}next line;"; } last; } if (/^s/) { $delim = substr($_,1,1); $len = length($_); $repl = $end = 0; $inbracket = 0; for ($i = 2; $i < $len; $i++) { $c = substr($_,$i,1); if ($c eq $delim) { if ($inbracket) { $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000); $i++; $len++; } else { if ($repl) { $end = $i; last; } else { $repl = $i; } } } elsif ($c eq '\\') { $i++; if ($i >= $len) { $_ .= 'n'; $_ .= <>; $len = length($_); $_ = substr($_,0,--$len); } elsif (!$repl && substr($_,$i,1) =~ /^[(){}\w]$/) { $i--; $len--; $_ = substr($_,0,$i) . substr($_,$i+1,10000); } elsif (!$repl && substr($_,$i,1) =~ /^[<>]$/) { substr($_,$i,1) = 'b'; } } elsif ($c eq '[' && !$repl) { $i++ if substr($_,$i,1) eq '^'; $i++ if substr($_,$i,1) eq ']'; $inbracket = 1; } elsif ($c eq ']') { $inbracket = 0; } elsif (!$repl && index("()+",$c) >= 0) { $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000); $i++; $len++; } } 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"; $cmd = ''; while ($end) { if ($end =~ s/^g//) { $subst .= 'g'; next; } if ($end =~ s/^p//) { $cmd .= ' && (print)'; next; } if ($end =~ s/^w[ \t]*//) { $fh = do make_filehandle($end); $cmd .= " && (print $fh \$_)"; $end = ''; next; } do Die("Unrecognized substitution command ($end) at line $.\n"); } $_ = "<<--#ifdef TSEEN $subst && \$tflag++$cmd; <<--#else $subst$cmd; <<--#endif"; next; } if (/^p/) { $_ = 'print;'; next; } if (/^w/) { s/^w[ \t]*//; $fh = do make_filehandle($_); $_ = "print $fh \$_;"; next; } if (/^r/) { $appendseen++; s/^r[ \t]*//; $file = $_; $_ = "\$atext .= `cat $file 2>/dev/null`;"; next; } if (/^P/) { $_ = 'print $1 if /(^.*\n)/;'; next; } if (/^D/) { $_ = 's/^.*\n//; redo line if $_; next line;'; next; } if (/^N/) { $_ = ' $_ .= <>; <<--#ifdef TSEEN $tflag = \'\'; <<--#endif'; next; } if (/^h/) { $_ = '$hold = $_;'; next; } if (/^H/) { $_ = '$hold .= $_ ? $_ : "\n";'; next; } if (/^g/) { $_ = '$_ = $hold;'; next; } if (/^G/) { $_ = '$_ .= $hold ? $hold : "\n";'; next; } if (/^x/) { $_ = '($_, $hold) = ($hold, $_);'; next; } if (/^b$/) { $_ = 'next line;'; next; } if (/^b/) { s/^b[ \t]*//; $lab = do make_label($_); if ($lab eq $toplabel) { $_ = 'redo line;'; } else { $_ = "goto $lab;"; } next; } if (/^t$/) { $_ = 'next line if $tflag;'; $tseen++; next; } if (/^t/) { s/^t[ \t]*//; $lab = do make_label($_); if ($lab eq $toplabel) { $_ = 'if ($tflag) {$tflag = \'\'; redo line;}'; } else { $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}"; } $tseen++; next; } if (/^=/) { $_ = 'print "$.\n";'; next; } if (/^q/) { $_ = 'close(ARGV); @ARGV = (); next line;'; next; } } continue { if ($space) { s/^/$space/; s/(\n)(.)/$1$space$2/g; } last; } $_; } sub fetchpat { local($outer) = @_; local($addr) = $outer; local($inbracket); local($prefix,$delim,$ch); delim: while (s:^([^\]+(|)[\\/]*)([]+(|)[\\/])::) { $prefix = $1; $delim = $2; if ($delim eq '\\') { s/(.)//; $ch = $1; $delim = '' if $ch =~ /^[(){}\w]$/; $ch = 'b' if $ch =~ /^[<>]$/; $delim .= $ch; } elsif ($delim eq '[') { $inbracket = 1; s/^\^// && ($delim .= '^'); s/^]// && ($delim .= ']'); } elsif ($delim eq ']') { $inbracket = 0; } elsif ($inbracket || $delim ne $outer) { $delim = '\\' . $delim; } $addr .= $prefix; $addr .= $delim; if ($delim eq $outer && !$inbracket) { last delim; } } $addr; } = $2; if ($delim eq '\\') { s/(.)//; $ch = $1; $delim = '' if $ch =~ /^[(){}\w]$/; $ch = 'b' if $ch =~ /^[<>]$/; $delim .= $ch; } elsif ($delim eq '[') { $inbracket = 1; s/^\^// && ($delim .= '^'); s/^]// && ($delim .= ']'); } elsif ($delim eq ']') { $inbracket = 0; } elsif ($inbracket || $delim ne $outer) { $delim = '\\' . $delim; } $addr .= $prefix; $addr .= $delim; if ($delim eq $outer && !$inbracket) { last deliperl/x2p/alloca.c 644 473 0 12075 4747276166 7205 /* alloca -- (mostly) portable public-domain implementation -- D A Gwyn last edit: 86/05/30 rms include config.h, since on VMS it renames some symbols. This implementation of the PWB library alloca() function, which is used to allocate space off the run-time stack so that it is automatically reclaimed upon procedure exit, was inspired by discussions with J. Q. Johnson of Cornell. It should work under any C implementation that uses an actual procedure stack (as opposed to a linked list of frames). There are some preprocessor constants that can be defined when compiling for your specific system, for improved efficiency; however, the defaults should be okay. The general concept of this implementation is to keep track of all alloca()-allocated blocks, and reclaim any that are found to be deeper in the stack than the current invocation. This heuristic does not reclaim storage as soon as it becomes invalid, but it will do so eventually. As a special case, alloca(0) reclaims storage without allocating any. It is a good idea to use alloca(0) in your main control loop, etc. to force garbage collection. */ #ifndef lint static char SCCSid[] = "@(#)alloca.c 1.1"; /* for the "what" utility */ #endif #ifdef emacs #include "config.h" #ifdef static /* actually, only want this if static is defined as "" -- this is for usg, in which emacs must undefine static in order to make unexec workable */ #ifndef STACK_DIRECTION you lose -- must know STACK_DIRECTION at compile-time #endif /* STACK_DIRECTION undefined */ #endif static #endif emacs #ifdef X3J11 typedef void *pointer; /* generic pointer type */ #else typedef char *pointer; /* generic pointer type */ #endif #define NULL 0 /* null pointer constant */ extern void free(); extern pointer malloc(); /* Define STACK_DIRECTION if you know the direction of stack growth for your system; otherwise it will be automatically deduced at run-time. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown */ #ifndef STACK_DIRECTION #define STACK_DIRECTION 0 /* direction unknown */ #endif #if STACK_DIRECTION != 0 #define STACK_DIR STACK_DIRECTION /* known at compile-time */ #else /* STACK_DIRECTION == 0; need run-time code */ static int stack_dir; /* 1 or -1 once known */ #define STACK_DIR stack_dir static void find_stack_direction (/* void */) { static char *addr = NULL; /* address of first `dummy', once known */ auto char dummy; /* to get stack address */ if (addr == NULL) { /* initial entry */ addr = &dummy; find_stack_direction (); /* recurse once */ } else /* second entry */ if (&dummy > addr) stack_dir = 1; /* stack grew upward */ else stack_dir = -1; /* stack grew downward */ } #endif /* STACK_DIRECTION == 0 */ /* An "alloca header" is used to: (a) chain together all alloca()ed blocks; (b) keep track of stack depth. It is very important that sizeof(header) agree with malloc() alignment chunk size. The following default should work okay. */ #ifndef ALIGN_SIZE #define ALIGN_SIZE sizeof(double) #endif typedef union hdr { char align[ALIGN_SIZE]; /* to force sizeof(header) */ struct { union hdr *next; /* for chaining headers */ char *deep; /* for stack depth measure */ } h; } header; /* alloca( size ) returns a pointer to at least `size' bytes of storage which will be automatically reclaimed upon exit from the procedure that called alloca(). Originally, this space was supposed to be taken from the current stack frame of the caller, but that method cannot be made to work for some implementations of C, for example under Gould's UTX/32. */ static header *last_alloca_header = NULL; /* -> last alloca header */ pointer alloca (size) /* returns pointer to storage */ unsigned size; /* # bytes to allocate */ { auto char probe; /* probes stack depth: */ register char *depth = &probe; #if STACK_DIRECTION == 0 if (STACK_DIR == 0) /* unknown growth direction */ find_stack_direction (); #endif /* Reclaim garbage, defined as all alloca()ed storage that was allocated from deeper in the stack than currently. */ { register header *hp; /* traverses linked list */ for (hp = last_alloca_header; hp != NULL;) if (STACK_DIR > 0 && hp->h.deep > depth || STACK_DIR < 0 && hp->h.deep < depth) { register header *np = hp->h.next; free ((pointer) hp); /* collect garbage */ hp = np; /* -> next header */ } else break; /* rest are not deeper */ last_alloca_header = hp; /* -> last valid storage */ } if (size == 0) return NULL; /* no allocation required */ /* Allocate combined header + user data storage. */ { register pointer new = malloc (sizeof (header) + size); /* address of header */ ((header *)new)->h.next = last_alloca_header; ((header *)new)->h.deep = depth; last_alloca_header = (header *)new; /* User storage begins just after header. */ return (pointer)((char *)new + sizeof(header)); } } last_alloca_header = hp; /* -> last valid storage */ } if (size == 0) return NULL; /* no allocation required */ /* Allocate combined header + user data storage. */ { register pointer new = malloc (sizeof (header) + size); /* address of header */ ((header *)new)->h.next = last_alloca_header; ((header *)new)->h.deep = depth; last_alloca_header = (header *)new; /* User storage begins just after header. */perl/x2p/.,resv.vak 664 473 0 767 4747276227 7367 macro f Li "for (;;) { Cd 10Cl Li Cd Li "} 2Cu 4Cr . macro q "# include 2Rt "main (argc, argv) Rt "char **argv; Rt "{ Rt Tr "for (--argc; *++argv; --argc) Rt 2Tr "if (**argv == '-') { Rt 3Tr "/* parse flags */ Rt 2Tr "} else { Rt 3Tr "/* parse command arguments */ Rt 2Tr "} Rt Tr "return (0); Rt "} Rt . macro 0 Cu 2Ld Cl En "" . macro 1 Go "$1" . tabset -1 "" 9 17 *8 set keys "-el+i-I+s-af+tT-S+zF" set search "sleep" set indentcol 6 status P0,-1,0,-2,1,0 PZ,0 f33,0,6,17, Makefile C1 Z0 . eader. */perl/README 644 473 0 13006 4747105024 5730 Perl Kit, Version 3.0 Copyright (c) 1989, Larry Wall This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -------------------------------------------------------------------------- Perl is a language that combines some of the features of C, sed, awk and shell. See the manual page for more hype. Perl will probably not run on machines with a small address space. Please read all the directions below before you proceed any further, and then follow them carefully. After you have unpacked your kit, you should have all the files listed in MANIFEST. Installation 1) Run Configure. This will figure out various things about your system. Some things Configure will figure out for itself, other things it will ask you about. It will then proceed to make config.h, config.sh, and Makefile. You might possibly have to trim # comments from the front of Configure if your sh doesn't handle them, but all other # comments will be taken care of. (If you don't have sh, you'll have to copy the sample file config.H to config.h and edit the config.h to reflect your system's peculiarities.) 2) Glance through config.h to make sure system dependencies are correct. Most of them should have been taken care of by running the Configure script. If you have any additional changes to make to the C definitions, they can be done in the Makefile, or in config.h. Bear in mind that they will get undone next time you run Configure. 3) make depend This will look for all the includes and modify Makefile accordingly. Configure will offer to do this for you. 4) make This will attempt to make perl in the current directory. If you can't compile successfully, try adding a -DCRIPPLED_CC flag. (Just because you get no errors doesn't mean it compiled right!) This simplifies some complicated expressions for compilers that get indigestion easily. If that has no effect, try turning off optimization. If you have missing routines, you probably need to add some library or other, or you need to undefine some feature that Configure thought was there but is defective or incomplete. Some compilers will not compile or optimize the larger files without some extra switches to use larger jump offsets or allocate larger internal tables. It's okay to insert rules for specific files into Makefile.SH, since a default rule only take effect in the absence of a specific rule. The 3b2 needs to turn off -O. AIX/RT may need a -a switch and -DCRIPPLED_CC. SGI machines may need -Ddouble="long float". Ultrix (2.3) may need to hand assemble teval.s with a -J switch. Ultrix on MIPS machines may need -DLANGUAGE_C. SCO Xenix may need -m25000 for yacc. Genix needs to use libc rather than libc_s, or #undef VARARGS. NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR. Machines with half-implemented dbm routines will need to #undef ODBM & NDBM. C's that don't try to restore registers on longjmp() may need -DJMPCLOBBER. (Try this if you get random glitches.) 5) make test This will run the regression tests on the perl you just made. If it doesn't say "All tests successful" then something went wrong. See the README in the t subdirectory. Note that you can't run it in background if this disables opening of /dev/tty. If "make test" bombs out, just cd to the t directory and run TEST by hand to see if it makes any difference. 6) make install This will put perl into a public directory (such as /usr/local/bin). It will also try to put the man pages in a reasonable place. It will not nroff the man page, however. You may need to be root to do this. If you are not root, you must own the directories in question and you should ignore any messages about chown not working. 7) Read the manual entry before running perl. 8) IMPORTANT! Help save the world! Communicate any problems and suggested patches to me, lwall@jpl-devvax.jpl.nasa.gov (Larry Wall), so we can keep the world in sync. If you have a problem, there's someone else out there who either has had or will have the same problem. If possible, send in patches such that the patch program will apply them. Context diffs are the best, then normal diffs. Don't send ed scripts-- I've probably changed my copy since the version you have. Watch for perl patches in comp.lang.perl. Patches will generally be in a form usable by the patch program. If you are just now bringing up perl and aren't sure how many patches there are, write to me and I'll send any you don't have. Your current patch level is shown in patchlevel.h. Just a personal note: I want you to know that I create nice things like this because it pleases the Author of my story. If this bothers you, then your notion of Authorship needs some revision. But you can use perl anyway. :-) The author. l. Patches will generally be in a form usable by the patch program. If you are just now bringing up perl and aren't sure how many patches there are, write to me and I'll send any you don't have. Your current patch level is shown in patchlevel.h. Just a personal note: I want you to know that I create nice things like this because it pleases the Author of my story. If this bothers you, then your notion of Authorship needs some revision. But you can use perl anyway. :-) The auperl/toke.c 644 473 0 142557 4747105025 6215 /* $Header: toke.c,v 3.0.1.5 90/02/28 18:47:06 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: toke.c,v $ * Revision 3.0.1.5 90/02/28 18:47:06 lwall * patch9: return grandfathered to never be function call * patch9: non-existent perldb.pl now gives reasonable error message * patch9: perl can now start up other interpreters scripts * patch9: line numbers were bogus during certain portions of foreach evaluation * patch9: null hereis core dumped * * Revision 3.0.1.4 89/12/21 20:26:56 lwall * patch7: -d switch incompatible with -p or -n * patch7: " ''$foo'' " didn't parse right * patch7: grandfathered m'pat' and s'pat'repl' to not be package qualifiers * * Revision 3.0.1.3 89/11/17 15:43:15 lwall * patch5: IBM PC/RT compiler can't deal with UNI() and LOP() macros * patch5: } misadjusted expection of subsequent term or operator * patch5: y/abcde// didn't work * * Revision 3.0.1.2 89/11/11 05:04:42 lwall * patch2: fixed a CLINE macro conflict * * Revision 3.0.1.1 89/10/26 23:26:21 lwall * patch1: disambiguated word after "sort" better * * Revision 3.0 89/10/18 15:32:33 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" #include "perly.h" char *reparse; /* if non-null, scanreg found ${foo[$bar]} */ #ifdef CLINE #undef CLINE #endif #define CLINE (cmdline = (line < cmdline ? line : cmdline)) #define META(c) ((c) | 128) #define RETURN(retval) return (bufptr = s,(int)retval) #define OPERATOR(retval) return (expectterm = TRUE,bufptr = s,(int)retval) #define TERM(retval) return (CLINE, expectterm = FALSE,bufptr = s,(int)retval) #define LOOPX(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)LOOPEX) #define 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 FL(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST) #define FL2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST2) #define HFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)HSHFUN) #define HFUN3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)HSHFUN3) #define LFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LVALFUN) #define LFUN4(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)LFUNC4) #define AOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)ADDOP) #define MOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)MULOP) #define EOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)EQOP) #define ROP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)RELOP) #define FOP(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP) #define FOP2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP2) #define FOP3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP3) #define FOP4(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP4) #define FOP22(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP22) #define FOP25(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP25) /* This bit of chicanery makes a unary function followed by * a parenthesis into a function with one argument, highest precedence. */ #define UNI(f) return(yylval.ival = f,expectterm = TRUE,bufptr = s, \ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) ) /* This does similarly for list operators, merely by pretending that the * paren came before the listop rather than after. */ #define LOP(f) return(*s == '(' || (s = skipspace(s), *s == '(') ? \ (*s = META('('), bufptr = oldbufptr, '(') : \ (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP)) /* grandfather return to old style */ #define OLDLOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP) char * skipspace(s) register char *s; { while (s < bufend && isascii(*s) && isspace(*s)) s++; return s; } #ifdef CRIPPLED_CC #undef UNI #undef LOP #define UNI(f) return uni(f,s) #define LOP(f) return lop(f,s) int uni(f,s) int f; char *s; { yylval.ival = f; expectterm = TRUE; bufptr = s; if (*s == '(') return FUNC1; s = skipspace(s); if (*s == '(') return FUNC1; else return UNIOP; } int lop(f,s) int f; char *s; { if (*s != '(') s = skipspace(s); if (*s == '(') { *s = META('('); bufptr = oldbufptr; return '('; } else { yylval.ival=f; expectterm = TRUE; bufptr = s; return LISTOP; } } #endif /* CRIPPLED_CC */ yylex() { register char *s = bufptr; register char *d; register int tmp; static bool in_format = FALSE; static bool firstline = TRUE; extern int yychar; /* last token */ oldoldbufptr = oldbufptr; oldbufptr = s; retry: #ifdef YYDEBUG if (debug & 1) if (index(s,'\n')) fprintf(stderr,"Tokener at %s",s); else fprintf(stderr,"Tokener at %s\n",s); #endif switch (*s) { default: if ((*s & 127) == '(') *s++ = '('; else warn("Unrecognized character \\%03o ignored", *s++); goto retry; case 0: if (!rsfp) RETURN(0); if (s++ < bufend) goto retry; /* ignore stray nulls */ if (firstline) { firstline = FALSE; if (minus_n || minus_p || perldb) { str_set(linestr,""); if (perldb) str_cat(linestr, "do 'perldb.pl' || die \"Can't find perldb.pl in @INC\"; print $@;"); if (minus_n || minus_p) { str_cat(linestr,"line: while (<>) {"); if (minus_a) str_cat(linestr,"@F=split(' ');"); } oldoldbufptr = oldbufptr = s = str_get(linestr); bufend = linestr->str_ptr + linestr->str_cur; goto retry; } } if (in_format) { yylval.formval = load_format(); in_format = FALSE; oldoldbufptr = oldbufptr = s = str_get(linestr) + 1; bufend = linestr->str_ptr + linestr->str_cur; TERM(FORMLIST); } line++; if ((s = str_gets(linestr, rsfp, 0)) == Nullch) { if (preprocess) (void)mypclose(rsfp); else if (rsfp != stdin) (void)fclose(rsfp); rsfp = Nullfp; if (minus_n || minus_p) { str_set(linestr,minus_p ? "}continue{print;" : ""); str_cat(linestr,"}"); oldoldbufptr = oldbufptr = s = str_get(linestr); bufend = linestr->str_ptr + linestr->str_cur; minus_n = minus_p = 0; goto retry; } oldoldbufptr = oldbufptr = s = str_get(linestr); str_set(linestr,""); RETURN(0); } oldoldbufptr = oldbufptr = bufptr = s; if (perldb) { STR *str = Str_new(85,0); str_sset(str,linestr); astore(lineary,(int)line,str); } #ifdef DEBUG if (firstline) { char *showinput(); s = showinput(); } #endif bufend = linestr->str_ptr + linestr->str_cur; if (line == 1) { if (*s == '#' && s[1] == '!') { if (!in_eval && !instr(s,"perl") && instr(origargv[0],"perl")) { char **newargv; char *cmd; s += 2; if (*s == ' ') s++; cmd = s; while (s < bufend && !isspace(*s)) s++; *s++ = '\0'; while (s < bufend && isspace(*s)) s++; if (s < bufend) { Newz(899,newargv,origargc+3,char*); newargv[1] = s; while (s < bufend && !isspace(*s)) s++; *s = '\0'; Copy(origargv+1, newargv+2, origargc+1, char*); } else newargv = origargv; newargv[0] = cmd; execv(cmd,newargv); fatal("Can't exec %s", cmd); } } else { while (s < bufend && isspace(*s)) s++; if (*s == ':') /* for csh's that have to exec sh scripts */ s++; } } 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++) ; d = bufend; while (s < d && 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); oldoldbufptr = oldbufptr = s = str_get(linestr); } if (in_eval && !rsfp) { d = bufend; while (s < d && *s != '\n') s++; if (s < d) { s++; line++; } } else { *s = '\0'; bufend = s; } 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; } } tmp = *s++; if (*s == tmp) { s++; RETURN(DEC); } if (expectterm) OPERATOR('-'); else AOP(O_SUBTRACT); case '+': tmp = *s++; if (*s == tmp) { s++; RETURN(INC); } if (expectterm) OPERATOR('+'); else AOP(O_ADD); case '*': if (expectterm) { s = scanreg(s,bufend,tokenbuf); yylval.stabval = stabent(tokenbuf,TRUE); TERM(STAR); } tmp = *s++; if (*s == tmp) { s++; OPERATOR(POW); } MOP(O_MULTIPLY); case '%': if (expectterm) { s = scanreg(s,bufend,tokenbuf); yylval.stabval = stabent(tokenbuf,TRUE); TERM(HSH); } s++; MOP(O_MODULO); case '^': case '~': case '(': 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++; RETURN(tmp); case '&': s++; tmp = *s++; if (tmp == '&') OPERATOR(ANDAND); s--; if (expectterm) { d = bufend; while (s < d && isspace(*s)) s++; if (isalpha(*s) || *s == '_' || *s == '\'') *(--s) = '\\'; /* force next ident to WORD */ OPERATOR(AMPER); } OPERATOR('&'); case '|': s++; tmp = *s++; if (tmp == '|') OPERATOR(OROR); s--; OPERATOR('|'); case '=': s++; tmp = *s++; if (tmp == '=') EOP(O_EQ); if (tmp == '~') OPERATOR(MATCH); s--; OPERATOR('='); case '!': s++; tmp = *s++; if (tmp == '=') EOP(O_NE); if (tmp == '~') OPERATOR(NMATCH); s--; OPERATOR('!'); case '<': if (expectterm) { s = scanstr(s); TERM(RSTRING); } s++; tmp = *s++; if (tmp == '<') OPERATOR(LS); if (tmp == '=') ROP(O_LE); s--; ROP(O_LT); case '>': s++; tmp = *s++; if (tmp == '>') OPERATOR(RS); if (tmp == '=') ROP(O_GE); s--; ROP(O_GT); #define SNARFWORD \ d = tokenbuf; \ while (isascii(*s) && \ (isalpha(*s) || isdigit(*s) || *s == '_' || *s == '\'')) \ *d++ = *s++; \ while (d[-1] == '\'') \ d--,s--; \ *d = '\0'; \ d = tokenbuf; case '$': if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) { s++; s = scanreg(s,bufend,tokenbuf); yylval.stabval = aadd(stabent(tokenbuf,TRUE)); TERM(ARYLEN); } d = s; s = scanreg(s,bufend,tokenbuf); if (reparse) { /* turn ${foo[bar]} into ($foo[bar]) */ do_reparse: s[-1] = ')'; s = d; s[1] = s[0]; s[0] = '('; goto retry; } yylval.stabval = stabent(tokenbuf,TRUE); TERM(REG); case '@': d = s; s = scanreg(s,bufend,tokenbuf); if (reparse) goto do_reparse; yylval.stabval = stabent(tokenbuf,TRUE); TERM(ARY); case '/': /* may either be division or pattern */ case '?': /* may either be conditional or pattern */ if (expectterm) { s = scanpat(s); TERM(PATTERN); } tmp = *s++; if (tmp == '/') MOP(O_DIVIDE); OPERATOR(tmp); case '.': if (!expectterm || !isdigit(s[1])) { tmp = *s++; if (*s == tmp) { s++; OPERATOR(DOTDOT); } AOP(O_CONCAT); } /* 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 '\\': /* some magic to force next word to be a WORD */ s++; /* used by do and sub to force a separate namespace */ /* FALL THROUGH */ case '_': SNARFWORD; break; case 'a': case 'A': SNARFWORD; if (strEQ(d,"accept")) FOP22(O_ACCEPT); if (strEQ(d,"atan2")) FUN2(O_ATAN2); break; case 'b': case 'B': SNARFWORD; if (strEQ(d,"bind")) FOP2(O_BIND); break; case 'c': case 'C': SNARFWORD; if (strEQ(d,"chop")) LFUN(O_CHOP); if (strEQ(d,"continue")) OPERATOR(CONTINUE); if (strEQ(d,"chdir")) { (void)stabent("ENV",TRUE); /* may use HOME */ UNI(O_CHDIR); } if (strEQ(d,"close")) FOP(O_CLOSE); if (strEQ(d,"closedir")) FOP(O_CLOSEDIR); if (strEQ(d,"crypt")) { #ifdef FCRYPT init_des(); #endif FUN2(O_CRYPT); } if (strEQ(d,"chmod")) LOP(O_CHMOD); if (strEQ(d,"chown")) LOP(O_CHOWN); if (strEQ(d,"connect")) FOP2(O_CONNECT); if (strEQ(d,"cos")) UNI(O_COS); if (strEQ(d,"chroot")) UNI(O_CHROOT); break; case 'd': case 'D': SNARFWORD; if (strEQ(d,"do")) { d = bufend; while (s < d && isspace(*s)) s++; if (isalpha(*s) || *s == '_') *(--s) = '\\'; /* force next ident to WORD */ OPERATOR(DO); } if (strEQ(d,"die")) LOP(O_DIE); if (strEQ(d,"defined")) LFUN(O_DEFINED); if (strEQ(d,"delete")) OPERATOR(DELETE); if (strEQ(d,"dbmopen")) HFUN3(O_DBMOPEN); if (strEQ(d,"dbmclose")) HFUN(O_DBMCLOSE); if (strEQ(d,"dump")) LOOPX(O_DUMP); break; case 'e': case 'E': SNARFWORD; if (strEQ(d,"else")) OPERATOR(ELSE); if (strEQ(d,"elsif")) { yylval.ival = line; OPERATOR(ELSIF); } if (strEQ(d,"eq") || strEQ(d,"EQ")) EOP(O_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")) FOP(O_EOF); if (strEQ(d,"exp")) UNI(O_EXP); if (strEQ(d,"each")) HFUN(O_EACH); if (strEQ(d,"exec")) { set_csh(); LOP(O_EXEC); } if (strEQ(d,"endhostent")) FUN0(O_EHOSTENT); if (strEQ(d,"endnetent")) FUN0(O_ENETENT); if (strEQ(d,"endservent")) FUN0(O_ESERVENT); if (strEQ(d,"endprotoent")) FUN0(O_EPROTOENT); if (strEQ(d,"endpwent")) FUN0(O_EPWENT); if (strEQ(d,"endgrent")) FUN0(O_EGRENT); break; case 'f': case 'F': SNARFWORD; if (strEQ(d,"for") || strEQ(d,"foreach")) { yylval.ival = line; OPERATOR(FOR); } if (strEQ(d,"format")) { d = bufend; while (s < d && isspace(*s)) s++; if (isalpha(*s) || *s == '_') *(--s) = '\\'; /* force next ident to WORD */ in_format = TRUE; allstabs = TRUE; /* must initialize everything since */ OPERATOR(FORMAT); /* we don't know what will be used */ } if (strEQ(d,"fork")) FUN0(O_FORK); if (strEQ(d,"fcntl")) FOP3(O_FCNTL); if (strEQ(d,"fileno")) FOP(O_FILENO); if (strEQ(d,"flock")) FOP2(O_FLOCK); break; case 'g': case 'G': SNARFWORD; if (strEQ(d,"gt") || strEQ(d,"GT")) ROP(O_SGT); if (strEQ(d,"ge") || strEQ(d,"GE")) ROP(O_SGE); if (strEQ(d,"grep")) FL2(O_GREP); if (strEQ(d,"goto")) LOOPX(O_GOTO); if (strEQ(d,"gmtime")) UNI(O_GMTIME); if (strEQ(d,"getc")) FOP(O_GETC); if (strnEQ(d,"get",3)) { d += 3; if (*d == 'p') { if (strEQ(d,"ppid")) FUN0(O_GETPPID); if (strEQ(d,"pgrp")) UNI(O_GETPGRP); if (strEQ(d,"priority")) FUN2(O_GETPRIORITY); if (strEQ(d,"protobyname")) UNI(O_GPBYNAME); if (strEQ(d,"protobynumber")) FUN1(O_GPBYNUMBER); if (strEQ(d,"protoent")) FUN0(O_GPROTOENT); if (strEQ(d,"pwent")) FUN0(O_GPWENT); if (strEQ(d,"pwnam")) FUN1(O_GPWNAM); if (strEQ(d,"pwuid")) FUN1(O_GPWUID); if (strEQ(d,"peername")) FOP(O_GETPEERNAME); } else if (*d == 'h') { if (strEQ(d,"hostbyname")) UNI(O_GHBYNAME); if (strEQ(d,"hostbyaddr")) FUN2(O_GHBYADDR); if (strEQ(d,"hostent")) FUN0(O_GHOSTENT); } else if (*d == 'n') { if (strEQ(d,"netbyname")) UNI(O_GNBYNAME); if (strEQ(d,"netbyaddr")) FUN2(O_GNBYADDR); if (strEQ(d,"netent")) FUN0(O_GNETENT); } else if (*d == 's') { if (strEQ(d,"servbyname")) FUN2(O_GSBYNAME); if (strEQ(d,"servbyport")) FUN2(O_GSBYPORT); if (strEQ(d,"servent")) FUN0(O_GSERVENT); if (strEQ(d,"sockname")) FOP(O_GETSOCKNAME); if (strEQ(d,"sockopt")) FOP3(O_GSOCKOPT); } else if (*d == 'g') { if (strEQ(d,"grent")) FUN0(O_GGRENT); if (strEQ(d,"grnam")) FUN1(O_GGRNAM); if (strEQ(d,"grgid")) FUN1(O_GGRGID); } else if (*d == 'l') { if (strEQ(d,"login")) FUN0(O_GETLOGIN); } d -= 3; } break; case 'h': case 'H': SNARFWORD; if (strEQ(d,"hex")) UNI(O_HEX); break; 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")) UNI(O_INT); if (strEQ(d,"ioctl")) FOP3(O_IOCTL); break; case 'j': case 'J': SNARFWORD; if (strEQ(d,"join")) FL2(O_JOIN); break; case 'k': case 'K': SNARFWORD; if (strEQ(d,"keys")) HFUN(O_KEYS); if (strEQ(d,"kill")) LOP(O_KILL); break; case 'l': case 'L': SNARFWORD; if (strEQ(d,"last")) LOOPX(O_LAST); if (strEQ(d,"local")) OPERATOR(LOCAL); if (strEQ(d,"length")) UNI(O_LENGTH); if (strEQ(d,"lt") || strEQ(d,"LT")) ROP(O_SLT); if (strEQ(d,"le") || strEQ(d,"LE")) ROP(O_SLE); if (strEQ(d,"localtime")) UNI(O_LOCALTIME); if (strEQ(d,"log")) UNI(O_LOG); if (strEQ(d,"link")) FUN2(O_LINK); if (strEQ(d,"listen")) FOP2(O_LISTEN); if (strEQ(d,"lstat")) FOP(O_LSTAT); break; case 'm': case 'M': if (s[1] == '\'') { d = "m"; s++; } else { SNARFWORD; } if (strEQ(d,"m")) { s = scanpat(s-1); if (yylval.arg) TERM(PATTERN); else RETURN(1); /* force error */ } if (strEQ(d,"mkdir")) FUN2(O_MKDIR); break; case 'n': case 'N': SNARFWORD; if (strEQ(d,"next")) LOOPX(O_NEXT); if (strEQ(d,"ne") || strEQ(d,"NE")) EOP(O_SNE); break; case 'o': case 'O': SNARFWORD; if (strEQ(d,"open")) OPERATOR(OPEN); if (strEQ(d,"ord")) UNI(O_ORD); if (strEQ(d,"oct")) UNI(O_OCT); if (strEQ(d,"opendir")) FOP2(O_OPENDIR); break; case 'p': case 'P': SNARFWORD; if (strEQ(d,"print")) { checkcomma(s,"filehandle"); LOP(O_PRINT); } if (strEQ(d,"printf")) { checkcomma(s,"filehandle"); LOP(O_PRTF); } if (strEQ(d,"push")) { yylval.ival = O_PUSH; OPERATOR(PUSH); } if (strEQ(d,"pop")) OPERATOR(POP); if (strEQ(d,"pack")) FL2(O_PACK); if (strEQ(d,"package")) OPERATOR(PACKAGE); if (strEQ(d,"pipe")) FOP22(O_PIPE); break; case 'q': case 'Q': SNARFWORD; if (strEQ(d,"q")) { s = scanstr(s-1); TERM(RSTRING); } if (strEQ(d,"qq")) { s = scanstr(s-2); TERM(RSTRING); } break; case 'r': case 'R': SNARFWORD; if (strEQ(d,"return")) OLDLOP(O_RETURN); if (strEQ(d,"reset")) UNI(O_RESET); if (strEQ(d,"redo")) LOOPX(O_REDO); if (strEQ(d,"rename")) FUN2(O_RENAME); if (strEQ(d,"rand")) UNI(O_RAND); if (strEQ(d,"rmdir")) UNI(O_RMDIR); if (strEQ(d,"rindex")) FUN2(O_RINDEX); if (strEQ(d,"read")) FOP3(O_READ); if (strEQ(d,"readdir")) FOP(O_READDIR); if (strEQ(d,"rewinddir")) FOP(O_REWINDDIR); if (strEQ(d,"recv")) FOP4(O_RECV); if (strEQ(d,"reverse")) LOP(O_REVERSE); if (strEQ(d,"readlink")) UNI(O_READLINK); break; case 's': case 'S': if (s[1] == '\'') { d = "s"; s++; } else { SNARFWORD; } if (strEQ(d,"s")) { s = scansubst(s); if (yylval.arg) TERM(SUBST); else RETURN(1); /* force error */ } switch (d[1]) { case 'a': case 'b': case 'c': case 'd': break; case 'e': if (strEQ(d,"select")) OPERATOR(SELECT); if (strEQ(d,"seek")) FOP3(O_SEEK); if (strEQ(d,"send")) FOP3(O_SEND); if (strEQ(d,"setpgrp")) FUN2(O_SETPGRP); if (strEQ(d,"setpriority")) FUN3(O_SETPRIORITY); if (strEQ(d,"sethostent")) FUN1(O_SHOSTENT); if (strEQ(d,"setnetent")) FUN1(O_SNETENT); if (strEQ(d,"setservent")) FUN1(O_SSERVENT); if (strEQ(d,"setprotoent")) FUN1(O_SPROTOENT); if (strEQ(d,"setpwent")) FUN0(O_SPWENT); if (strEQ(d,"setgrent")) FUN0(O_SGRENT); if (strEQ(d,"seekdir")) FOP2(O_SEEKDIR); if (strEQ(d,"setsockopt")) FOP4(O_SSOCKOPT); break; case 'f': case 'g': break; case 'h': if (strEQ(d,"shift")) TERM(SHIFT); if (strEQ(d,"shutdown")) FOP2(O_SHUTDOWN); break; case 'i': if (strEQ(d,"sin")) UNI(O_SIN); break; case 'j': case 'k': break; case 'l': if (strEQ(d,"sleep")) UNI(O_SLEEP); break; case 'm': case 'n': break; case 'o': if (strEQ(d,"socket")) FOP4(O_SOCKET); if (strEQ(d,"socketpair")) FOP25(O_SOCKETPAIR); if (strEQ(d,"sort")) { checkcomma(s,"subroutine name"); d = bufend; while (s < d && isascii(*s) && isspace(*s)) s++; if (*s == ';' || *s == ')') /* probably a close */ fatal("sort is now a reserved word"); if (isascii(*s) && (isalpha(*s) || *s == '_')) { for (d = s; isalpha(*d) || isdigit(*d) || *d == '_'; d++) ; strncpy(tokenbuf,s,d-s); if (strNE(tokenbuf,"keys") && strNE(tokenbuf,"values") && strNE(tokenbuf,"split") && strNE(tokenbuf,"grep") && strNE(tokenbuf,"readdir") && strNE(tokenbuf,"unpack") && strNE(tokenbuf,"do") && (d >= bufend || isspace(*d)) ) *(--s) = '\\'; /* force next ident to WORD */ } LOP(O_SORT); } break; case 'p': if (strEQ(d,"split")) TERM(SPLIT); if (strEQ(d,"sprintf")) FL(O_SPRINTF); break; case 'q': if (strEQ(d,"sqrt")) UNI(O_SQRT); break; case 'r': if (strEQ(d,"srand")) UNI(O_SRAND); break; case 's': break; case 't': if (strEQ(d,"stat")) FOP(O_STAT); if (strEQ(d,"study")) { sawstudy++; LFUN(O_STUDY); } break; case 'u': if (strEQ(d,"substr")) FUN3(O_SUBSTR); if (strEQ(d,"sub")) { subline = line; d = bufend; while (s < d && isspace(*s)) s++; if (isalpha(*s) || *s == '_' || *s == '\'') { if (perldb) { str_sset(subname,curstname); str_ncat(subname,"'",1); for (d = s+1; isalpha(*d) || isdigit(*d) || *d == '_' || *d == '\''; d++); if (d[-1] == '\'') d--; str_ncat(subname,s,d-s); } *(--s) = '\\'; /* force next ident to WORD */ } else if (perldb) str_set(subname,"?"); OPERATOR(SUB); } break; case 'v': case 'w': case 'x': break; case 'y': if (strEQ(d,"system")) { set_csh(); LOP(O_SYSTEM); } if (strEQ(d,"symlink")) FUN2(O_SYMLINK); if (strEQ(d,"syscall")) LOP(O_SYSCALL); break; case 'z': break; } break; case 't': case 'T': SNARFWORD; if (strEQ(d,"tr")) { s = scantrans(s); if (yylval.arg) TERM(TRANS); else RETURN(1); /* force error */ } if (strEQ(d,"tell")) FOP(O_TELL); if (strEQ(d,"telldir")) FOP(O_TELLDIR); if (strEQ(d,"time")) FUN0(O_TIME); if (strEQ(d,"times")) FUN0(O_TMS); break; 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,"unlink")) LOP(O_UNLINK); if (strEQ(d,"undef")) LFUN(O_UNDEF); if (strEQ(d,"unpack")) FUN2(O_UNPACK); if (strEQ(d,"utime")) LOP(O_UTIME); if (strEQ(d,"umask")) UNI(O_UMASK); if (strEQ(d,"unshift")) { yylval.ival = O_UNSHIFT; OPERATOR(PUSH); } break; case 'v': case 'V': SNARFWORD; if (strEQ(d,"values")) HFUN(O_VALUES); if (strEQ(d,"vec")) { sawvec = TRUE; FUN3(O_VEC); } break; case 'w': case 'W': SNARFWORD; if (strEQ(d,"while")) { yylval.ival = line; OPERATOR(WHILE); } if (strEQ(d,"warn")) LOP(O_WARN); if (strEQ(d,"wait")) FUN0(O_WAIT); if (strEQ(d,"wantarray")) { yylval.arg = op_new(1); yylval.arg->arg_type = O_ITEM; yylval.arg[1].arg_type = A_WANTARRAY; TERM(RSTRING); } if (strEQ(d,"write")) FOP(O_WRITE); break; case 'x': case 'X': SNARFWORD; if (!expectterm && strEQ(d,"x")) MOP(O_REPEAT); break; case 'y': case 'Y': if (s[1] == '\'') { d = "y"; s++; } else { SNARFWORD; } if (strEQ(d,"y")) { s = scantrans(s); TERM(TRANS); } break; case 'z': case 'Z': SNARFWORD; break; } yylval.cval = savestr(d); expectterm = FALSE; if (oldoldbufptr && oldoldbufptr < bufptr) { while (isspace(*oldoldbufptr)) oldoldbufptr++; if (*oldoldbufptr == 'p' && strnEQ(oldoldbufptr,"print",5)) expectterm = TRUE; else if (*oldoldbufptr == 's' && strnEQ(oldoldbufptr,"sort",4)) expectterm = TRUE; } return (CLINE, bufptr = s, (int)WORD); } int checkcomma(s,what) register char *s; char *what; { if (*s == '(') s++; while (s < bufend && isascii(*s) && isspace(*s)) s++; if (isascii(*s) && (isalpha(*s) || *s == '_')) { s++; while (isalpha(*s) || isdigit(*s) || *s == '_') s++; while (s < bufend && isspace(*s)) s++; if (*s == ',') fatal("No comma allowed after %s", what); } } char * scanreg(s,send,dest) register char *s; register char *send; char *dest; { register char *d; int brackets = 0; reparse = Nullch; s++; d = dest; if (isdigit(*s)) { while (isdigit(*s)) *d++ = *s++; } else { while (isalpha(*s) || isdigit(*s) || *s == '_' || *s == '\'') *d++ = *s++; } while (d > dest+1 && d[-1] == '\'') d--,s--; *d = '\0'; d = dest; if (!*d) { *d = *s++; if (*d == '{' /* } */ ) { d = dest; brackets++; while (s < send && brackets) { if (!reparse && (d == dest || (*s && isascii(*s) && (isalpha(*s) || isdigit(*s) || *s == '_') ))) { *d++ = *s++; continue; } else if (!reparse) reparse = s; switch (*s++) { /* { */ case '}': brackets--; if (reparse && reparse == s - 1) reparse = Nullch; break; case '{': /* } */ brackets++; break; } } *d = '\0'; d = dest; } else d[1] = '\0'; } if (*d == '^' && !isspace(*s)) *d = *s++ & 31; return s; } STR * scanconst(string,len) char *string; int len; { register STR *retstr; register char *t; register char *d; register char *e; if (index(string,'|')) { return Nullstr; } retstr = Str_new(86,len); str_nset(retstr,string,len); t = str_get(retstr); e = t + len; retstr->str_u.str_useful = 100; for (d=t; d < e; ) { switch (*d) { case '{': if (isdigit(d[1])) e = d; else goto defchar; break; case '.': case '[': case '$': case '(': case ')': case '|': case '+': e = d; break; case '\\': if (d[1] && index("wWbB0123456789sSdD",d[1])) { e = d; break; } (void)bcopy(d+1,d,e-d); e--; 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: defchar: if (d[1] == '*' || (d[1] == '{' && d[2] == '0') || d[1] == '?') { e = d; break; } d++; } } if (d == t) { str_free(retstr); return Nullstr; } *d = '\0'; retstr->str_cur = d - t; return retstr; } char * scanpat(s) register char *s; { register SPAT *spat; register char *d; register char *e; int len; SPAT savespat; Newz(801,spat,1,SPAT); spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ curstash->tbl_spatroot = spat; switch (*s++) { case 'm': s++; break; case '/': break; case '?': spat->spat_flags |= SPAT_ONCE; break; default: fatal("panic: scanpat"); } s = cpytill(tokenbuf,s,bufend,s[-1],&len); if (s >= bufend) { yyerror("Search pattern not terminated"); yylval.arg = Nullarg; return s; } s++; while (*s == 'i' || *s == 'o') { if (*s == 'i') { s++; sawi = TRUE; spat->spat_flags |= SPAT_FOLD; } if (*s == 'o') { s++; spat->spat_flags |= SPAT_KEEP; } } e = tokenbuf + len; for (d=tokenbuf; d < e; d++) { if ((*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') || (*d == '@' && d[-1] != '\\')) { register ARG *arg; spat->spat_runtime = arg = op_new(1); arg->arg_type = O_ITEM; arg[1].arg_type = A_DOUBLE; arg[1].arg_ptr.arg_str = str_make(tokenbuf,len); arg[1].arg_ptr.arg_str->str_u.str_hash = curstash; d = scanreg(d,bufend,buf); (void)stabent(buf,TRUE); /* make sure it's created */ for (; d < e; d++) { if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') { d = scanreg(d,bufend,buf); (void)stabent(buf,TRUE); } else if (*d == '@' && d[-1] != '\\') { d = scanreg(d,bufend,buf); if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") || strEQ(buf,"SIG") || strEQ(buf,"INC")) (void)stabent(buf,TRUE); } } goto got_pat; /* skip compiling for now */ } } if (spat->spat_flags & SPAT_FOLD) #ifdef STRUCTCOPY savespat = *spat; #else (void)bcopy((char *)spat, (char *)&savespat, sizeof(SPAT)); #endif if (*tokenbuf == '^') { spat->spat_short = scanconst(tokenbuf+1,len-1); if (spat->spat_short) { spat->spat_slen = spat->spat_short->str_cur; if (spat->spat_slen == len - 1) spat->spat_flags |= SPAT_ALL; } } else { spat->spat_flags |= SPAT_SCANFIRST; spat->spat_short = scanconst(tokenbuf,len); if (spat->spat_short) { spat->spat_slen = spat->spat_short->str_cur; if (spat->spat_slen == len) spat->spat_flags |= SPAT_ALL; } } if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) { fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD); spat->spat_regexp = regcomp(tokenbuf,tokenbuf+len, spat->spat_flags & SPAT_FOLD,1); /* Note that this regexp can still be used if someone says * something like /a/ && s//b/; so we can't delete it. */ } else { if (spat->spat_flags & SPAT_FOLD) #ifdef STRUCTCOPY *spat = savespat; #else (void)bcopy((char *)&savespat, (char *)spat, sizeof(SPAT)); #endif if (spat->spat_short) fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD); spat->spat_regexp = regcomp(tokenbuf,tokenbuf+len, spat->spat_flags & SPAT_FOLD,1); hoistmust(spat); } got_pat: yylval.arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat); return s; } char * scansubst(s) register char *s; { register SPAT *spat; register char *d; register char *e; int len; Newz(802,spat,1,SPAT); spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ curstash->tbl_spatroot = spat; s = cpytill(tokenbuf,s+1,bufend,*s,&len); if (s >= bufend) { yyerror("Substitution pattern not terminated"); yylval.arg = Nullarg; return s; } e = tokenbuf + len; for (d=tokenbuf; d < e; d++) { if ((*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') || (*d == '@' && d[-1] != '\\')) { register ARG *arg; spat->spat_runtime = arg = op_new(1); arg->arg_type = O_ITEM; arg[1].arg_type = A_DOUBLE; arg[1].arg_ptr.arg_str = str_make(tokenbuf,len); arg[1].arg_ptr.arg_str->str_u.str_hash = curstash; d = scanreg(d,bufend,buf); (void)stabent(buf,TRUE); /* make sure it's created */ for (; *d; d++) { if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') { d = scanreg(d,bufend,buf); (void)stabent(buf,TRUE); } else if (*d == '@' && d[-1] != '\\') { d = scanreg(d,bufend,buf); if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") || strEQ(buf,"SIG") || strEQ(buf,"INC")) (void)stabent(buf,TRUE); } } goto get_repl; /* skip compiling for now */ } } if (*tokenbuf == '^') { spat->spat_short = scanconst(tokenbuf+1,len-1); if (spat->spat_short) spat->spat_slen = spat->spat_short->str_cur; } else { spat->spat_flags |= SPAT_SCANFIRST; spat->spat_short = scanconst(tokenbuf,len); if (spat->spat_short) spat->spat_slen = spat->spat_short->str_cur; } d = nsavestr(tokenbuf,len); get_repl: s = scanstr(s); if (s >= bufend) { yyerror("Substitution replacement not terminated"); yylval.arg = Nullarg; return s; } spat->spat_repl = yylval.arg; spat->spat_flags |= SPAT_ONCE; if ((spat->spat_repl[1].arg_type & A_MASK) == A_SINGLE) spat->spat_flags |= SPAT_CONST; else if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) { STR *tmpstr; register char *t; spat->spat_flags |= SPAT_CONST; tmpstr = spat->spat_repl[1].arg_ptr.arg_str; e = tmpstr->str_ptr + tmpstr->str_cur; for (t = tmpstr->str_ptr; t < e; t++) { if (*t == '$' && t[1] && (index("`'&+0123456789",t[1]) || (t[1] == '{' /*}*/ && isdigit(t[2])) )) spat->spat_flags &= ~SPAT_CONST; } } while (*s == 'g' || *s == 'i' || *s == 'e' || *s == 'o') { if (*s == 'e') { s++; if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) spat->spat_repl[1].arg_type = A_SINGLE; spat->spat_repl = fixeval(make_op(O_EVAL,2, spat->spat_repl, Nullarg, Nullarg)); spat->spat_flags &= ~SPAT_CONST; } if (*s == 'g') { s++; spat->spat_flags &= ~SPAT_ONCE; } if (*s == 'i') { s++; sawi = TRUE; spat->spat_flags |= SPAT_FOLD; if (!(spat->spat_flags & SPAT_SCANFIRST)) { str_free(spat->spat_short); /* anchored opt doesn't do */ spat->spat_short = Nullstr; /* case insensitive match */ spat->spat_slen = 0; } } if (*s == 'o') { s++; spat->spat_flags |= SPAT_KEEP; } } if (spat->spat_short && (spat->spat_flags & SPAT_SCANFIRST)) fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD); if (!spat->spat_runtime) { spat->spat_regexp = regcomp(d,d+len,spat->spat_flags & SPAT_FOLD,1); hoistmust(spat); Safefree(d); } 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 && str_eq(spat->spat_short,spat->spat_regexp->regmust)) { 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,len,retlen) register char *s; int len; int *retlen; { char t[512]; register char *d = t; register int i; register char *send = s + len; while (s < send) { if (s[1] == '-' && s+2 < send) { for (i = s[0]; i <= s[2]; i++) *d++ = i; s += 3; } else *d++ = *s++; } *d = '\0'; *retlen = d - t; return nsavestr(t,d-t); } char * scantrans(s) register char *s; { ARG *arg = l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg)); register char *t; register char *r; register char *tbl; register int i; register int j; int tlen, rlen; Newz(803,tbl,256,char); arg[2].arg_type = A_NULL; arg[2].arg_ptr.arg_cval = tbl; s = scanstr(s); if (s >= bufend) { yyerror("Translation pattern not terminated"); yylval.arg = Nullarg; return s; } t = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr, yylval.arg[1].arg_ptr.arg_str->str_cur,&tlen); free_arg(yylval.arg); s = scanstr(s-1); if (s >= bufend) { yyerror("Translation replacement not terminated"); yylval.arg = Nullarg; return s; } r = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr, yylval.arg[1].arg_ptr.arg_str->str_cur,&rlen); free_arg(yylval.arg); yylval.arg = arg; if (!*r) { Safefree(r); r = t; rlen = tlen; } for (i = 0, j = 0; i < tlen; i++,j++) { if (j >= rlen) --j; tbl[t[i] & 0377] = r[j]; } if (r != t) Safefree(r); Safefree(t); return s; } char * scanstr(s) register char *s; { register char term; register char *d; register ARG *arg; register char *send; register bool makesingle = FALSE; register STAB *stab; bool alwaysdollar = FALSE; bool hereis = FALSE; STR *herewas; char *leave = "\\$@nrtfb0123456789[{]}"; /* which backslash sequences to keep */ int len; arg = op_new(1); yylval.arg = arg; 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) yyerror("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: (void)sprintf(tokenbuf,"%ld",i); arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf)); #ifdef MICROPORT /* Microport 2.4 hack */ { double zz = str_2num(arg[1].arg_ptr.arg_str); } #else (void)str_2num(arg[1].arg_ptr.arg_str); #endif /* Microport 2.4 hack */ } 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 == '.' && s[1] && index("0123456789eE ;",s[1])) { *d++ = *s++; while (isdigit(*s) || *s == '_') { if (*s == '_') s++; else *d++ = *s++; } } if (*s && 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, d - tokenbuf); #ifdef MICROPORT /* Microport 2.4 hack */ { double zz = str_2num(arg[1].arg_ptr.arg_str); } #else (void)str_2num(arg[1].arg_ptr.arg_str); #endif /* Microport 2.4 hack */ break; case '<': if (*++s == '<') { hereis = TRUE; d = tokenbuf; if (!rsfp) *d++ = '\n'; if (*++s && index("`'\"",*s)) { term = *s++; s = cpytill(d,s,bufend,term,&len); if (s < bufend) s++; d += len; } else { if (*s == '\\') s++, term = '\''; else term = '"'; while (isascii(*s) && (isalpha(*s) || isdigit(*s) || *s == '_')) *d++ = *s++; } /* assuming tokenbuf won't clobber */ *d++ = '\n'; *d = '\0'; len = d - tokenbuf; d = "\n"; if (rsfp || !(d=ninstr(s,bufend,d,d+1))) herewas = str_make(s,bufend-s); else s--, herewas = str_make(s,d-s); s += herewas->str_cur; if (term == '\'') goto do_single; if (term == '`') goto do_back; goto do_double; } d = tokenbuf; s = cpytill(d,s,bufend,'>',&len); if (s < bufend) s++; if (*d == '$') d++; while (*d && (isalpha(*d) || isdigit(*d) || *d == '_' || *d == '\'')) d++; if (d - tokenbuf != len) { d = tokenbuf; arg[1].arg_type = A_GLOB; d = nsavestr(d,len); arg[1].arg_ptr.arg_stab = stab = genstab(); stab_io(stab) = stio_new(); stab_val(stab) = str_make(d,len); stab_val(stab)->str_u.str_hash = curstash; Safefree(d); set_csh(); } else { d = tokenbuf; if (!len) (void)strcpy(d,"ARGV"); if (*d == '$') { arg[1].arg_type = A_INDREAD; arg[1].arg_ptr.arg_stab = stabent(d+1,TRUE); } else { arg[1].arg_type = A_READ; if (rsfp == stdin && (strEQ(d,"stdin") || strEQ(d,"STDIN"))) yyerror("Can't get both program and data from "); arg[1].arg_ptr.arg_stab = stabent(d,TRUE); if (!stab_io(arg[1].arg_ptr.arg_stab)) stab_io(arg[1].arg_ptr.arg_stab) = stio_new(); if (strEQ(d,"ARGV")) { (void)aadd(arg[1].arg_ptr.arg_stab); stab_io(arg[1].arg_ptr.arg_stab)->flags |= IOF_ARGV|IOF_START; } } } break; case 'q': s++; if (*s == 'q') { s++; goto do_double; } /* FALL THROUGH */ case '\'': do_single: term = *s; arg[1].arg_type = A_SINGLE; leave = Nullch; goto snarf_it; case '"': do_double: term = *s; arg[1].arg_type = A_DOUBLE; makesingle = TRUE; /* maybe disable runtime scanning */ alwaysdollar = TRUE; /* treat $) and $| as variables */ goto snarf_it; case '`': do_back: term = *s; arg[1].arg_type = A_BACKTICK; set_csh(); alwaysdollar = TRUE; /* treat $) and $| as variables */ snarf_it: { STR *tmpstr; char *tmps; multi_start = line; if (hereis) multi_open = multi_close = '<'; else { multi_open = term; if (tmps = index("([{< )]}> )]}>",term)) term = tmps[5]; multi_close = term; } tmpstr = Str_new(87,80); if (hereis) { term = *tokenbuf; if (!rsfp) { d = s; while (s < bufend && (*s != term || bcmp(s,tokenbuf,len) != 0) ) { if (*s++ == '\n') line++; } if (s >= bufend) { line = multi_start; fatal("EOF in string"); } str_nset(tmpstr,d+1,s-d); s += len - 1; str_ncat(herewas,s,bufend-s); str_replace(linestr,herewas); oldoldbufptr = oldbufptr = bufptr = s = str_get(linestr); bufend = linestr->str_ptr + linestr->str_cur; hereis = FALSE; } } else s = str_append_till(tmpstr,s+1,bufend,term,leave); while (s >= bufend) { /* multiple line string? */ if (!rsfp || !(oldoldbufptr = oldbufptr = s = str_gets(linestr, rsfp, 0))) { line = multi_start; fatal("EOF in string"); } line++; if (perldb) { STR *str = Str_new(88,0); str_sset(str,linestr); astore(lineary,(int)line,str); } bufend = linestr->str_ptr + linestr->str_cur; if (hereis) { if (*s == term && bcmp(s,tokenbuf,len) == 0) { s = bufend - 1; *s = ' '; str_scat(linestr,herewas); bufend = linestr->str_ptr + linestr->str_cur; } else { s = bufend; str_scat(tmpstr,linestr); } } else s = str_append_till(tmpstr,s,bufend,term,leave); } multi_end = line; s++; if (tmpstr->str_cur + 5 < tmpstr->str_len) { tmpstr->str_len = tmpstr->str_cur + 1; Renew(tmpstr->str_ptr, tmpstr->str_len, char); } if ((arg[1].arg_type & A_MASK) == A_SINGLE) { arg[1].arg_ptr.arg_str = tmpstr; break; } tmps = s; s = tmpstr->str_ptr; send = s + tmpstr->str_cur; while (s < send) { /* see if we can make SINGLE */ if (*s == '\\' && s[1] && isdigit(s[1]) && !isdigit(s[2]) && !alwaysdollar ) *s = '$'; /* grandfather \digit in subst */ if ((*s == '$' || *s == '@') && s+1 < send && (alwaysdollar || (s[1] != ')' && s[1] != '|'))) { makesingle = FALSE; /* force interpretation */ } else if (*s == '\\' && s+1 < send) { s++; } s++; } s = d = tmpstr->str_ptr; /* assuming shrinkage only */ while (s < send) { if ((*s == '$' && s+1 < send && (alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) || (*s == '@' && s+1 < send) ) { len = scanreg(s,send,tokenbuf) - s; if (*s == '$' || strEQ(tokenbuf,"ARGV") || strEQ(tokenbuf,"ENV") || strEQ(tokenbuf,"SIG") || strEQ(tokenbuf,"INC") ) (void)stabent(tokenbuf,TRUE); /* make sure it exists */ while (len--) *d++ = *s++; continue; } else if (*s == '\\' && s+1 < send) { s++; switch (*s) { default: if (!makesingle && (!leave || (*s && index(leave,*s)))) *d++ = '\\'; *d++ = *s++; continue; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': *d = *s++ - '0'; if (s < send && *s && index("01234567",*s)) { *d <<= 3; *d += *s++ - '0'; } if (s < send && *s && 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_MASK) == A_DOUBLE && makesingle) arg[1].arg_type = A_SINGLE; /* now we can optimize on it */ tmpstr->str_u.str_hash = curstash; /* so interp knows package */ tmpstr->str_cur = d - tmpstr->str_ptr; arg[1].arg_ptr.arg_str = tmpstr; s = tmps; break; } } if (hereis) str_free(herewas); return s; } FCMD * load_format() { FCMD froot; FCMD *flinebeg; register FCMD *fprev = &froot; register FCMD *fcmd; register char *s; register char *t; register STR *str; bool noblank; bool repeater; Zero(&froot, 1, FCMD); while ((s = str_gets(linestr,rsfp, 0)) != Nullch) { line++; if (perldb) { STR *tmpstr = Str_new(89,0); str_sset(tmpstr,linestr); astore(lineary,(int)line,tmpstr); } bufend = linestr->str_ptr + linestr->str_cur; if (strEQ(s,".\n")) { bufptr = s; return froot.f_next; } if (*s == '#') continue; flinebeg = Nullfcmd; noblank = FALSE; repeater = FALSE; while (s < bufend) { Newz(804,fcmd,1,FCMD); fprev->f_next = fcmd; fprev = fcmd; for (t=s; t < bufend && *t != '@' && *t != '^'; t++) { if (*t == '~') { noblank = TRUE; *t = ' '; if (t[1] == '~') { repeater = TRUE; t[1] = ' '; } } } fcmd->f_pre = nsavestr(s, t-s); fcmd->f_presize = t-s; s = t; if (s >= bufend) { if (noblank) fcmd->f_flags |= FC_NOBLANK; if (repeater) fcmd->f_flags |= FC_REPEAT; 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 ((s = str_gets(linestr, rsfp, 0)) == Nullch) goto badform; line++; if (perldb) { STR *tmpstr = Str_new(90,0); str_sset(tmpstr,linestr); astore(lineary,(int)line,tmpstr); } if (strEQ(s,".\n")) { bufptr = s; yyerror("Missing values line"); return froot.f_next; } if (*s == '#') goto again; bufend = linestr->str_ptr + linestr->str_cur; str = flinebeg->f_unparsed = Str_new(91,bufend - bufptr); str->str_u.str_hash = curstash; str_nset(str,"(",1); flinebeg->f_line = line; if (!flinebeg->f_next->f_type || index(linestr->str_ptr, ',')) { str_scat(str,linestr); str_ncat(str,",$$);",5); } else { while (s < bufend && isspace(*s)) s++; t = s; while (s < bufend) { switch (*s) { case ' ': case '\t': case '\n': case ';': str_ncat(str, t, s - t); str_ncat(str, "," ,1); while (s < bufend && (isspace(*s) || *s == ';')) s++; t = s; break; case '$': str_ncat(str, t, s - t); t = s; s = scanreg(s,bufend,tokenbuf); str_ncat(str, t, s - t); t = s; if (s < bufend && *s && index("$'\"",*s)) str_ncat(str, ",", 1); break; case '"': case '\'': str_ncat(str, t, s - t); t = s; s++; while (s < bufend && (*s != *t || s[-1] == '\\')) s++; if (s < bufend) s++; str_ncat(str, t, s - t); t = s; if (s < bufend && *s && index("$'\"",*s)) str_ncat(str, ",", 1); break; default: yyerror("Please use commas to separate fields"); } } str_ncat(str,"$$);",4); } } } badform: bufptr = str_get(linestr); yyerror("Format not terminated"); return froot.f_next; } set_csh() { #ifdef CSH if (!cshlen) cshlen = strlen(cshname); #endif } < bufend && (*s != *t || s[-1] == '\\')) s++; if (s < bufend) s++; str_ncat(str, t, s - t); t = s; if (s < bufend && *sperl/perl.man.4 644 473 0 136370 4747105026 6705 ''' Beginning of part 4 ''' $Header: perl.man.4,v 3.0.1.5 90/02/28 18:01:52 lwall Locked $ ''' ''' $Log: perl.man.4,v $ ''' Revision 3.0.1.5 90/02/28 18:01:52 lwall ''' patch9: $0 is now always the command name ''' ''' Revision 3.0.1.4 89/12/21 20:12:39 lwall ''' patch7: documented that package'filehandle works as well as $package'variable ''' patch7: documented which identifiers are always in package main ''' ''' Revision 3.0.1.3 89/11/17 15:32:25 lwall ''' patch5: fixed some manual typos and indent problems ''' patch5: clarified difference between $! and $@ ''' ''' Revision 3.0.1.2 89/11/11 04:46:40 lwall ''' patch2: made some line breaks depend on troff vs. nroff ''' patch2: clarified operation of ^ and $ when $* is false ''' ''' Revision 3.0.1.1 89/10/26 23:18:43 lwall ''' patch1: documented the desirability of unnecessary parentheses ''' ''' Revision 3.0 89/10/18 15:21:55 lwall ''' 3.0 baseline ''' .Sh "Precedence" .I Perl operators have the following associativity and precedence: .nf nonassoc\h'|1i'print printf exec system sort reverse \h'1.5i'chmod chown kill unlink utime die return left\h'|1i', right\h'|1i'= += \-= *= etc. right\h'|1i'?: nonassoc\h'|1i'.\|. left\h'|1i'|| left\h'|1i'&& left\h'|1i'| ^ left\h'|1i'& nonassoc\h'|1i'== != eq ne nonassoc\h'|1i'< > <= >= lt gt le ge nonassoc\h'|1i'chdir exit eval reset sleep rand umask nonassoc\h'|1i'\-r \-w \-x etc. left\h'|1i'<< >> left\h'|1i'+ \- . left\h'|1i'* / % x left\h'|1i'=~ !~ right\h'|1i'! ~ and unary minus right\h'|1i'** nonassoc\h'|1i'++ \-\|\- left\h'|1i'\*(L'(\*(R' .fi As mentioned earlier, if any list operator (print, etc.) or any unary operator (chdir, etc.) is followed by a left parenthesis as the next token on the same line, the operator and arguments within parentheses are taken to be of highest precedence, just like a normal function call. Examples: .nf chdir $foo || die;\h'|3i'# (chdir $foo) || die chdir($foo) || die;\h'|3i'# (chdir $foo) || die chdir ($foo) || die;\h'|3i'# (chdir $foo) || die chdir +($foo) || die;\h'|3i'# (chdir $foo) || die but, because * is higher precedence than ||: chdir $foo * 20;\h'|3i'# chdir ($foo * 20) chdir($foo) * 20;\h'|3i'# (chdir $foo) * 20 chdir ($foo) * 20;\h'|3i'# (chdir $foo) * 20 chdir +($foo) * 20;\h'|3i'# chdir ($foo * 20) rand 10 * 20;\h'|3i'# rand (10 * 20) rand(10) * 20;\h'|3i'# (rand 10) * 20 rand (10) * 20;\h'|3i'# (rand 10) * 20 rand +(10) * 20;\h'|3i'# rand (10 * 20) .fi In the absence of parentheses, the precedence of list operators such as print, sort or chmod is either very high or very low depending on whether you look at the left side of operator or the right side of it. For example, in .nf @ary = (1, 3, sort 4, 2); print @ary; # prints 1324 .fi the commas on the right of the sort are evaluated before the sort, but the commas on the left are evaluated after. In other words, list operators tend to gobble up all the arguments that follow them, and then act like a simple term with regard to the preceding expression. Note that you have to be careful with parens: .nf .ne 3 # These evaluate exit before doing the print: print($foo, exit); # Obviously not what you want. print $foo, exit; # Nor is this. .ne 4 # These do the print before evaluating exit: (print $foo), exit; # This is what you want. print($foo), exit; # Or this. print ($foo), exit; # Or even this. Also note that print ($foo & 255) + 1, "\en"; .fi probably doesn't do what you expect at first glance. .Sh "Subroutines" A subroutine may be declared as follows: .nf sub NAME BLOCK .fi .PP Any arguments passed to the routine come in as array @_, that is ($_[0], $_[1], .\|.\|.). The array @_ is a local array, but its values are references to the actual scalar parameters. The return value of the subroutine is the value of the last expression evaluated, and can be either an array value or a scalar value. Alternately, a return statement may be used to specify the returned value and exit the subroutine. To create local variables see the .I local operator. .PP A subroutine is called using the .I do operator or the & operator. .nf .ne 12 Example: sub MAX { local($max) = pop(@_); foreach $foo (@_) { $max = $foo \|if \|$max < $foo; } $max; } .\|.\|. $bestday = &MAX($mon,$tue,$wed,$thu,$fri); .ne 21 Example: # get a line, combining continuation lines # that start with whitespace sub get_line { $thisline = $lookahead; line: while ($lookahead = ) { if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) { $thisline \|.= \|$lookahead; } else { last line; } } $thisline; } $lookahead = ; # get first line while ($_ = do get_line(\|)) { .\|.\|. } .fi .nf .ne 6 Use array assignment to a local list to name your formal arguments: sub maybeset { local($key, $value) = @_; $foo{$key} = $value unless $foo{$key}; } .fi This also has the effect of turning call-by-reference into call-by-value, since the assignment copies the values. .Sp Subroutines may be called recursively. If a subroutine is called using the & form, the argument list is optional. If omitted, no @_ array is set up for the subroutine; the @_ array at the time of the call is visible to subroutine instead. .nf do foo(1,2,3); # pass three arguments &foo(1,2,3); # the same do foo(); # pass a null list &foo(); # the same &foo; # pass no arguments--more efficient .fi .Sh "Passing By Reference" Sometimes you don't want to pass the value of an array to a subroutine but rather the name of it, so that the subroutine can modify the global copy of it rather than working with a local copy. In perl you can refer to all the objects of a particular name by prefixing the name with a star: *foo. When evaluated, it produces a scalar value that represents all the objects of that name. When assigned to within a local() operation, it causes the name mentioned to refer to whatever * value was assigned to it. Example: .nf sub doubleary { local(*someary) = @_; foreach $elem (@someary) { $elem *= 2; } } do doubleary(*foo); do doubleary(*bar); .fi Assignment to *name is currently recommended only inside a local(). You can actually assign to *name anywhere, but the previous referent of *name may be stranded forever. This may or may not bother you. .Sp Note that scalars are already passed by reference, so you can modify scalar arguments without using this mechanism by referring explicitly to the $_[nnn] in question. You can modify all the elements of an array by passing all the elements as scalars, but you have to use the * mechanism to push, pop or change the size of an array. The * mechanism will probably be more efficient in any case. .Sp Since a *name value contains unprintable binary data, if it is used as an argument in a print, or as a %s argument in a printf or sprintf, it then has the value '*name', just so it prints out pretty. .Sh "Regular Expressions" The patterns used in pattern matching are regular expressions such as those supplied in the Version 8 regexp routines. (In fact, the routines are derived from Henry Spencer's freely redistributable reimplementation of the V8 routines.) In addition, \ew matches an alphanumeric character (including \*(L"_\*(R") and \eW a nonalphanumeric. Word boundaries may be matched by \eb, and non-boundaries by \eB. A whitespace character is matched by \es, non-whitespace by \eS. A numeric character is matched by \ed, non-numeric by \eD. You may use \ew, \es and \ed within character classes. Also, \en, \er, \ef, \et and \eNNN have their normal interpretations. Within character classes \eb represents backspace rather than a word boundary. Alternatives may be separated by |. The bracketing construct \|(\ .\|.\|.\ \|) may also be used, in which case \e matches the digit'th substring, where digit can range from 1 to 9. (Outside of the pattern, always use $ instead of \e in front of the digit. The scope of $ (and $\`, $& and $\') extends to the end of the enclosing BLOCK or eval string, or to the next pattern match with subexpressions. The \e notation sometimes works outside the current pattern, but should not be relied upon.) $+ returns whatever the last bracket match matched. $& returns the entire matched string. ($0 used to return the same thing, but not any more.) $\` returns everything before the matched string. $\' returns everything after the matched string. Examples: .nf s/\|^\|([^ \|]*\|) \|*([^ \|]*\|)\|/\|$2 $1\|/; # swap first two words .ne 5 if (/\|Time: \|(.\|.\|):\|(.\|.\|):\|(.\|.\|)\|/\|) { $hours = $1; $minutes = $2; $seconds = $3; } .fi By default, the ^ character is only guaranteed to match at the beginning of the string, the $ character only at the end (or before the newline at the end) and .I perl does certain optimizations with the assumption that the string contains only one line. The behavior of ^ and $ on embedded newlines will be inconsistent. You may, however, wish to treat a string as a multi-line buffer, such that the ^ will match after any newline within the string, and $ will match before any newline. At the cost of a little more overhead, you can do this by setting the variable $* to 1. Setting it back to 0 makes .I perl revert to its old behavior. .PP To facilitate multi-line substitutions, the . character never matches a newline (even when $* is 0). In particular, the following leaves a newline on the $_ string: .nf $_ = ; s/.*(some_string).*/$1/; If the newline is unwanted, try one of s/.*(some_string).*\en/$1/; s/.*(some_string)[^\e000]*/$1/; s/.*(some_string)(.|\en)*/$1/; chop; s/.*(some_string).*/$1/; /(some_string)/ && ($_ = $1); .fi Any item of a regular expression may be followed with digits in curly brackets of the form {n,m}, where n gives the minimum number of times to match the item and m gives the maximum. The form {n} is equivalent to {n,n} and matches exactly n times. The form {n,} matches n or more times. (If a curly bracket occurs in any other context, it is treated as a regular character.) The * modifier is equivalent to {0,}, the + modifier to {1,} and the ? modifier to {0,1}. There is no limit to the size of n or m, but large numbers will chew up more memory. .Sp You will note that all backslashed metacharacters in .I perl are alphanumeric, such as \eb, \ew, \en. Unlike some other regular expression languages, there are no backslashed symbols that aren't alphanumeric. So anything that looks like \e\e, \e(, \e), \e<, \e>, \e{, or \e} is always interpreted as a literal character, not a metacharacter. This makes it simple to quote a string that you want to use for a pattern but that you are afraid might contain metacharacters. Simply quote all the non-alphanumeric characters: .nf $pattern =~ s/(\eW)/\e\e$1/g; .fi .Sh "Formats" Output record formats for use with the .I write operator may declared as follows: .nf .ne 3 format NAME = FORMLIST . .fi If name is omitted, format \*(L"STDOUT\*(R" is defined. FORMLIST consists of a sequence of lines, each of which may be of one of three types: .Ip 1. 4 A comment. .Ip 2. 4 A \*(L"picture\*(R" line giving the format for one output line. .Ip 3. 4 An argument line supplying values to plug into a picture line. .PP Picture lines are printed exactly as they look, except for certain fields that substitute values into the line. Each picture field starts with either @ or ^. The @ field (not to be confused with the array marker @) is the normal case; ^ fields are used to do rudimentary multi-line text block filling. The length of the field is supplied by padding out the field with multiple <, >, or | characters to specify, respectively, left justification, right justification, or centering. If any of the values supplied for these fields contains a newline, only the text up to the newline is printed. The special field @* can be used for printing multi-line values. It should appear by itself on a line. .PP The values are specified on the following line, in the same order as the picture fields. The values should be separated by commas. .PP Picture fields that begin with ^ rather than @ are treated specially. The value supplied must be a scalar variable name which contains a text string. .I Perl puts as much text as it can into the field, and then chops off the front of the string so that the next time the variable is referenced, more of the text can be printed. Normally you would use a sequence of fields in a vertical stack to print out a block of text. If you like, you can end the final field with .\|.\|., which will appear in the output if the text was too long to appear in its entirety. You can change which characters are legal to break on by changing the variable $: to a list of the desired characters. .PP Since use of ^ fields can produce variable length records if the text to be formatted is short, you can suppress blank lines by putting the tilde (~) character anywhere in the line. (Normally you should put it in the front if possible, for visibility.) The tilde will be translated to a space upon output. If you put a second tilde contiguous to the first, the line will be repeated until all the fields on the line are exhausted. (If you use a field of the @ variety, the expression you supply had better not give the same value every time forever!) .PP Examples: .nf .lg 0 .cs R 25 .ft C .ne 10 # a report on the /etc/passwd file format top = \& Passwd File Name Login Office Uid Gid Home ------------------------------------------------------------------ \&. format STDOUT = @<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<< $name, $login, $office,$uid,$gid, $home \&. .ne 29 # a report from a bug report form format top = \& Bug Reports @<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>> $system, $%, $date ------------------------------------------------------------------ \&. format STDOUT = Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< \& $subject Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< \& $index, $description Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< \& $priority, $date, $description From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< \& $from, $description Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< \& $programmer, $description \&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< \& $description \&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< \& $description \&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< \& $description \&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< \& $description \&~ ^<<<<<<<<<<<<<<<<<<<<<<<... \& $description \&. .ft R .cs R .lg .fi It is possible to intermix prints with writes on the same output channel, but you'll have to handle $\- (lines left on the page) yourself. .PP If you are printing lots of fields that are usually blank, you should consider using the reset operator between records. Not only is it more efficient, but it can prevent the bug of adding another field and forgetting to zero it. .Sh "Interprocess Communication" The IPC facilities of perl are built on the Berkeley socket mechanism. If you don't have sockets, you can ignore this section. The calls have the same names as the corresponding system calls, but the arguments tend to differ, for two reasons. First, perl file handles work differently than C file descriptors. Second, perl already knows the length of its strings, so you don't need to pass that information. Here is a sample client (untested): .nf ($them,$port) = @ARGV; $port = 2345 unless $port; $them = 'localhost' unless $them; $SIG{'INT'} = 'dokill'; sub dokill { kill 9,$child if $child; } do 'sys/socket.h' || die "Can't do sys/socket.h: $@"; $sockaddr = 'S n a4 x8'; chop($hostname = `hostname`); ($name, $aliases, $proto) = getprotobyname('tcp'); ($name, $aliases, $port) = getservbyname($port, 'tcp') unless $port =~ /^\ed+$/;; .ie t \{\ ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname); 'br\} .el \{\ ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname); 'br\} ($name, $aliases, $type, $len, $thataddr) = gethostbyname($them); $this = pack($sockaddr, &AF_INET, 0, $thisaddr); $that = pack($sockaddr, &AF_INET, $port, $thataddr); socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; bind(S, $this) || die "bind: $!"; connect(S, $that) || die "connect: $!"; select(S); $| = 1; select(stdout); if ($child = fork) { while (<>) { print S; } sleep 3; do dokill(); } else { while () { print; } } .fi And here's a server: .nf ($port) = @ARGV; $port = 2345 unless $port; do 'sys/socket.h' || die "Can't do sys/socket.h: $@"; $sockaddr = 'S n a4 x8'; ($name, $aliases, $proto) = getprotobyname('tcp'); ($name, $aliases, $port) = getservbyname($port, 'tcp') unless $port =~ /^\ed+$/;; $this = pack($sockaddr, &AF_INET, $port, "\e0\e0\e0\e0"); select(NS); $| = 1; select(stdout); socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; bind(S, $this) || die "bind: $!"; listen(S, 5) || die "connect: $!"; select(S); $| = 1; select(stdout); for (;;) { print "Listening again\en"; ($addr = accept(NS,S)) || die $!; print "accept ok\en"; ($af,$port,$inetaddr) = unpack($sockaddr,$addr); @inetaddr = unpack('C4',$inetaddr); print "$af $port @inetaddr\en"; while () { print; print NS; } } .fi .Sh "Predefined Names" The following names have special meaning to .IR perl . I could have used alphabetic symbols for some of these, but I didn't want to take the chance that someone would say reset \*(L"a\-zA\-Z\*(R" and wipe them all out. You'll just have to suffer along with these silly symbols. Most of them have reasonable mnemonics, or analogues in one of the shells. .Ip $_ 8 The default input and pattern-searching space. The following pairs are equivalent: .nf .ne 2 while (<>) {\|.\|.\|. # only equivalent in while! while ($_ = <>) {\|.\|.\|. .ne 2 /\|^Subject:/ $_ \|=~ \|/\|^Subject:/ .ne 2 y/a\-z/A\-Z/ $_ =~ y/a\-z/A\-Z/ .ne 2 chop chop($_) .fi (Mnemonic: underline is understood in certain operations.) .Ip $. 8 The current input line number of the last filehandle that was read. Readonly. Remember that only an explicit close on the filehandle resets the line number. Since <> never does an explicit close, line numbers increase across ARGV files (but see examples under eof). (Mnemonic: many programs use . to mean the current line number.) .Ip $/ 8 The input record separator, newline by default. Works like .IR awk 's RS variable, including treating blank lines as delimiters if set to the null string. If set to a value longer than one character, only the first character is used. (Mnemonic: / is used to delimit line boundaries when quoting poetry.) .Ip $, 8 The output field separator for the print operator. Ordinarily the print operator simply prints out the comma separated fields you specify. In order to get behavior more like .IR awk , set this variable as you would set .IR awk 's OFS variable to specify what is printed between fields. (Mnemonic: what is printed when there is a , in your print statement.) .Ip $"" 8 This is like $, except that it applies to array values interpolated into a double-quoted string (or similar interpreted string). Default is a space. (Mnemonic: obvious, I think.) .Ip $\e 8 The output record separator for the print operator. Ordinarily the print operator simply prints out the comma separated fields you specify, with no trailing newline or record separator assumed. In order to get behavior more like .IR awk , set this variable as you would set .IR awk 's ORS variable to specify what is printed at the end of the print. (Mnemonic: you set $\e instead of adding \en at the end of the print. Also, it's just like /, but it's what you get \*(L"back\*(R" from .IR perl .) .Ip $# 8 The output format for printed numbers. This variable is a half-hearted attempt to emulate .IR awk 's OFMT variable. There are times, however, when .I awk and .I perl have differing notions of what is in fact numeric. Also, the initial value is %.20g rather than %.6g, so you need to set $# explicitly to get .IR awk 's value. (Mnemonic: # is the number sign.) .Ip $% 8 The current page number of the currently selected output channel. (Mnemonic: % is page number in nroff.) .Ip $= 8 The current page length (printable lines) of the currently selected output channel. Default is 60. (Mnemonic: = has horizontal lines.) .Ip $\- 8 The number of lines left on the page of the currently selected output channel. (Mnemonic: lines_on_page \- lines_printed.) .Ip $~ 8 The name of the current report format for the currently selected output channel. (Mnemonic: brother to $^.) .Ip $^ 8 The name of the current top-of-page format for the currently selected output channel. (Mnemonic: points to top of page.) .Ip $| 8 If set to nonzero, forces a flush after every write or print on the currently selected output channel. Default is 0. Note that .I STDOUT will typically be line buffered if output is to the terminal and block buffered otherwise. Setting this variable is useful primarily when you are outputting to a pipe, such as when you are running a .I perl script under rsh and want to see the output as it's happening. (Mnemonic: when you want your pipes to be piping hot.) .Ip $$ 8 The process number of the .I perl running this script. (Mnemonic: same as shells.) .Ip $? 8 The status returned by the last pipe close, backtick (\`\`) command or .I system operator. Note that this is the status word returned by the wait() system call, so the exit value of the subprocess is actually ($? >> 8). $? & 255 gives which signal, if any, the process died from, and whether there was a core dump. (Mnemonic: similar to sh and ksh.) .Ip $& 8 4 The string matched by the last pattern match (not counting any matches hidden within a BLOCK or eval enclosed by the current BLOCK). (Mnemonic: like & in some editors.) .Ip $\` 8 4 The string preceding whatever was matched by the last pattern match (not counting any matches hidden within a BLOCK or eval enclosed by the current BLOCK). (Mnemonic: \` often precedes a quoted string.) .Ip $\' 8 4 The string following whatever was matched by the last pattern match (not counting any matches hidden within a BLOCK or eval enclosed by the current BLOCK). (Mnemonic: \' often follows a quoted string.) Example: .nf .ne 3 $_ = \'abcdefghi\'; /def/; print "$\`:$&:$\'\en"; # prints abc:def:ghi .fi .Ip $+ 8 4 The last bracket matched by the last search pattern. This is useful if you don't know which of a set of alternative patterns matched. For example: .nf /Version: \|(.*\|)|Revision: \|(.*\|)\|/ \|&& \|($rev = $+); .fi (Mnemonic: be positive and forward looking.) .Ip $* 8 2 Set to 1 to do multiline matching within a string, 0 to tell .I perl that it can assume that strings contain a single line, for the purpose of optimizing pattern matches. Pattern matches on strings containing multiple newlines can produce confusing results when $* is 0. Default is 0. (Mnemonic: * matches multiple things.) .Ip $0 8 Contains the name of the file containing the .I perl script being executed. (Mnemonic: same as sh and ksh.) .Ip $ 8 Contains the subpattern from the corresponding set of parentheses in the last pattern matched, not counting patterns matched in nested blocks that have been exited already. (Mnemonic: like \edigit.) .Ip $[ 8 2 The index of the first element in an array, and of the first character in a substring. Default is 0, but you could set it to 1 to make .I perl behave more like .I awk (or Fortran) when subscripting and when evaluating the index() and substr() functions. (Mnemonic: [ begins subscripts.) .Ip $] 8 2 The string printed out when you say \*(L"perl -v\*(R". It can be used to determine at the beginning of a script whether the perl interpreter executing the script is in the right range of versions. Example: .nf .ne 5 # see if getc is available ($version,$patchlevel) = $] =~ /(\ed+\e.\ed+).*\enPatch level: (\ed+)/; print STDERR "(No filename completion available.)\en" if $version * 1000 + $patchlevel < 2016; .fi (Mnemonic: Is this version of perl in the right bracket?) .Ip $; 8 2 The subscript separator for multi-dimensional array emulation. If you refer to an associative array element as .nf $foo{$a,$b,$c} it really means $foo{join($;, $a, $b, $c)} But don't put @foo{$a,$b,$c} # a slice--note the @ which means ($foo{$a},$foo{$b},$foo{$c}) .fi Default is "\e034", the same as SUBSEP in .IR awk . Note that if your keys contain binary data there might not be any safe value for $;. (Mnemonic: comma (the syntactic subscript separator) is a semi-semicolon. Yeah, I know, it's pretty lame, but $, is already taken for something more important.) .Ip $! 8 2 If used in a numeric context, yields the current value of errno, with all the usual caveats. (This means that you shouldn't depend on the value of $! to be anything in particular unless you've gotten a specific error return indicating a system error.) 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 perl syntax error message from the last eval command. If null, the last eval parsed and executed correctly (although the operations you invoked may have failed in the normal fashion). (Mnemonic: Where was the syntax error \*(L"at\*(R"?) .Ip $< 8 2 The real uid of this process. (Mnemonic: it's the uid you came FROM, if you're running setuid.) .Ip $> 8 2 The effective uid of this process. Example: .nf .ne 2 $< = $>; # set real uid to the effective uid ($<,$>) = ($>,$<); # swap real and effective uid .fi (Mnemonic: it's the uid you went TO, if you're running setuid.) Note: $< and $> can only be swapped on machines supporting setreuid(). .Ip $( 8 2 The real gid of this process. If you are on a machine that supports membership in multiple groups simultaneously, gives a space separated list of groups you are in. The first number is the one returned by getgid(), and the subsequent ones by getgroups(), one of which may be the same as the first number. (Mnemonic: parentheses are used to GROUP things. The real gid is the group you LEFT, if you're running setgid.) .Ip $) 8 2 The effective gid of this process. If you are on a machine that supports membership in multiple groups simultaneously, gives a space separated list of groups you are in. The first number is the one returned by getegid(), and the subsequent ones by getgroups(), one of which may be the same as the first number. (Mnemonic: parentheses are used to GROUP things. The effective gid is the group that's RIGHT for you, if you're running setgid.) .Sp Note: $<, $>, $( and $) can only be set on machines that support the corresponding set[re][ug]id() routine. $( and $) can only be swapped on machines supporting setregid(). .Ip $: 8 2 The current set of characters after which a string may be broken to fill continuation fields (starting with ^) in a format. Default is "\ \en-", to break on whitespace or hyphens. (Mnemonic: a \*(L"colon\*(R" in poetry is a part of a line.) .Ip @ARGV 8 3 The array ARGV contains the command line arguments intended for the script. Note that $#ARGV is the generally number of arguments minus one, since $ARGV[0] is the first argument, NOT the command name. See $0 for the command name. .Ip @INC 8 3 The array INC contains the list of places to look for .I perl scripts to be evaluated by the \*(L"do EXPR\*(R" command. It initially consists of the arguments to any .B \-I command line switches, followed by the default .I perl library, probably \*(L"/usr/local/lib/perl\*(R". .Ip $ENV{expr} 8 2 The associative array ENV contains your current environment. Setting a value in ENV changes the environment for child processes. .Ip $SIG{expr} 8 2 The associative array SIG is used to set signal handlers for various signals. Example: .nf .ne 12 sub handler { # 1st argument is signal name local($sig) = @_; print "Caught a SIG$sig\-\|\-shutting down\en"; close(LOG); exit(0); } $SIG{\'INT\'} = \'handler\'; $SIG{\'QUIT\'} = \'handler\'; .\|.\|. $SIG{\'INT\'} = \'DEFAULT\'; # restore default action $SIG{\'QUIT\'} = \'IGNORE\'; # ignore SIGQUIT .fi The SIG array only contains values for the signals actually set within the perl script. .Sh "Packages" Perl provides a mechanism for alternate namespaces to protect packages from stomping on each others variables. By default, a perl script starts compiling into the package known as \*(L"main\*(R". By use of the .I package declaration, you can switch namespaces. The scope of the package declaration is from the declaration itself to the end of the enclosing block (the same scope as the local() operator). Typically it would be the first declaration in a file to be included by the \*(L"do FILE\*(R" operator. You can switch into a package in more than one place; it merely influences which symbol table is used by the compiler for the rest of that block. You can refer to variables and filehandles in other packages by prefixing the identifier with the package name and a single quote. If the package name is null, the \*(L"main\*(R" package as assumed. .PP Only identifiers starting with letters are stored in the packages symbol table. All other symbols are kept in package \*(L"main\*(R". In addition, the identifiers STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV, INC and SIG are forced to be in package \*(L"main\*(R", even when used for other purposes than their built-in one. Note also that, if you have a package called \*(L"m\*(R", \*(L"s\*(R" or \*(L"y\*(R", the you can't use the qualified form of an identifier since it will be interpreted instead as a pattern match, a substitution or a translation. .PP Eval'ed strings are compiled in the package in which the eval was compiled in. (Assignments to $SIG{}, however, assume the signal handler specified is in the main package. Qualify the signal handler name if you wish to have a signal handler in a package.) For an example, examine perldb.pl in the perl library. It initially switches to the DB package so that the debugger doesn't interfere with variables in the script you are trying to debug. At various points, however, it temporarily switches back to the main package to evaluate various expressions in the context of the main package. .PP The symbol table for a package happens to be stored in the associative array of that name prepended with an underscore. The value in each entry of the associative array is what you are referring to when you use the *name notation. In fact, the following have the same effect (in package main, anyway), though the first is more efficient because it does the symbol table lookups at compile time: .nf .ne 2 local(*foo) = *bar; local($_main{'foo'}) = $_main{'bar'}; .fi You can use this to print out all the variables in a package, for instance. Here is dumpvar.pl from the perl library: .nf .ne 11 package dumpvar; sub main'dumpvar { \& ($package) = @_; \& local(*stab) = eval("*_$package"); \& while (($key,$val) = each(%stab)) { \& { \& local(*entry) = $val; \& if (defined $entry) { \& print "\e$$key = '$entry'\en"; \& } .ne 7 \& if (defined @entry) { \& print "\e@$key = (\en"; \& foreach $num ($[ .. $#entry) { \& print " $num\et'",$entry[$num],"'\en"; \& } \& print ")\en"; \& } .ne 10 \& if ($key ne "_$package" && defined %entry) { \& print "\e%$key = (\en"; \& foreach $key (sort keys(%entry)) { \& print " $key\et'",$entry{$key},"'\en"; \& } \& print ")\en"; \& } \& } \& } } .fi Note that, even though the subroutine is compiled in package dumpvar, the name of the subroutine is qualified so that its name is inserted into package \*(L"main\*(R". .Sh "Style" Each programmer will, of course, have his or her own preferences in regards to formatting, but there are some general guidelines that will make your programs easier to read. .Ip 1. 4 4 Just because you CAN do something a particular way doesn't mean that you SHOULD do it that way. .I Perl is designed to give you several ways to do anything, so consider picking the most readable one. For instance open(FOO,$foo) || die "Can't open $foo: $!"; is better than die "Can't open $foo: $!" unless open(FOO,$foo); because the second way hides the main point of the statement in a modifier. On the other hand print "Starting analysis\en" if $verbose; is better than $verbose && print "Starting analysis\en"; since the main point isn't whether the user typed -v or not. .Sp Similarly, just because an operator lets you assume default arguments doesn't mean that you have to make use of the defaults. The defaults are there for lazy systems programmers writing one-shot programs. If you want your program to be readable, consider supplying the argument. .Sp Along the same lines, just because you .I can omit parentheses in many places doesn't mean that you ought to: .nf return print reverse sort num values array; return print(reverse(sort num (values(%array)))); .fi When in doubt, parenthesize. At the very least it will let some poor schmuck bounce on the % key in vi. .Ip 2. 4 4 Don't go through silly contortions to exit a loop at the top or the bottom, when .I perl provides the "last" operator so you can exit in the middle. Just outdent it a little to make it more visible: .nf .ne 7 line: for (;;) { statements; last line if $foo; next line if /^#/; statements; } .fi .Ip 3. 4 4 Don't be afraid to use loop labels\*(--they're there to enhance readability as well as to allow multi-level loop breaks. See last example. .Ip 4. 4 4 For portability, when using features that may not be implemented on every machine, test the construct in an eval to see if it fails. If you know what version or patchlevel a particular feature was implemented, you can test $] to see if it will be there. .Ip 5. 4 4 Choose mnemonic identifiers. .Ip 6. 4 4 Be consistent. .Sh "Debugging" If you invoke .I perl with a .B \-d switch, your script will be run under a debugging monitor. It will halt before the first executable statement and ask you for a command, such as: .Ip "h" 12 4 Prints out a help message. .Ip "s" 12 4 Single step. Executes until it reaches the beginning of another statement. .Ip "c" 12 4 Continue. Executes until the next breakpoint is reached. .Ip "" 12 4 Repeat last s or c. .Ip "n" 12 4 Single step around subroutine call. .Ip "l min+incr" 12 4 List incr+1 lines starting at min. If min is omitted, starts where last listing left off. If incr is omitted, previous value of incr is used. .Ip "l min-max" 12 4 List lines in the indicated range. .Ip "l line" 12 4 List just the indicated line. .Ip "l" 12 4 List incr+1 more lines after last printed line. .Ip "l subname" 12 4 List subroutine. If it's a long subroutine it just lists the beginning. Use \*(L"l\*(R" to list more. .Ip "L" 12 4 List lines that have breakpoints or actions. .Ip "t" 12 4 Toggle trace mode on or off. .Ip "b line" 12 4 Set a breakpoint. If line is omitted, sets a breakpoint on the current line line that is about to be executed. Breakpoints may only be set on lines that begin an executable statement. .Ip "b subname" 12 4 Set breakpoint at first executable line of subroutine. .Ip "S" 12 4 Lists the names of all subroutines. .Ip "d line" 12 4 Delete breakpoint. If line is omitted, deletes the breakpoint on the current line line that is about to be executed. .Ip "D" 12 4 Delete all breakpoints. .Ip "A" 12 4 Delete all line actions. .Ip "V package" 12 4 List all variables in package. Default is main package. .Ip "a line command" 12 4 Set an action for line. A multi-line command may be entered by backslashing the newlines. .Ip "< command" 12 4 Set an action to happen before every debugger prompt. A multi-line command may be entered by backslashing the newlines. .Ip "> command" 12 4 Set an action to happen after the prompt when you've just given a command to return to executing the script. A multi-line command may be entered by backslashing the newlines. .Ip "! number" 12 4 Redo a debugging command. If number is omitted, redoes the previous command. .Ip "! -number" 12 4 Redo the command that was that many commands ago. .Ip "H -number" 12 4 Display last n commands. Only commands longer than one character are listed. If number is omitted, lists them all. .Ip "q or ^D" 12 4 Quit. .Ip "command" 12 4 Execute command as a perl statement. A missing semicolon will be supplied. .Ip "p expr" 12 4 Same as \*(L"print DB'OUT expr\*(R". The DB'OUT filehandle is opened to /dev/tty, regardless of where STDOUT may be redirected to. .PP If you want to modify the debugger, copy perldb.pl from the perl library to your current directory and modify it as necessary. You can do some customization by setting up a .perldb file which contains initialization code. For instance, you could make aliases like these: .nf $DB'alias{'len'} = 's/^len(.*)/p length($1)/'; $DB'alias{'stop'} = 's/^stop (at|in)/b/'; $DB'alias{'.'} = 's/^\e./p "\e$DB\e'sub(\e$DB\e'line):\et",\e$DB\e'line[\e$DB\e'line]/'; .fi .Sh "Setuid Scripts" .I Perl is designed to make it easy to write secure setuid and setgid scripts. Unlike shells, which are based on multiple substitution passes on each line of the script, .I perl uses a more conventional evaluation scheme with fewer hidden \*(L"gotchas\*(R". Additionally, since the language has more built-in functionality, it has to rely less upon external (and possibly untrustworthy) programs to accomplish its purposes. .PP In an unpatched 4.2 or 4.3bsd kernel, setuid scripts are intrinsically insecure, but this kernel feature can be disabled. If it is, .I perl can emulate the setuid and setgid mechanism when it notices the otherwise useless setuid/gid bits on perl scripts. If the kernel feature isn't disabled, .I perl will complain loudly that your setuid script is insecure. You'll need to either disable the kernel setuid script feature, or put a C wrapper around the script. .PP When perl is executing a setuid script, it takes special precautions to prevent you from falling into any obvious traps. (In some ways, a perl script is more secure than the corresponding C program.) Any command line argument, environment variable, or input is marked as \*(L"tainted\*(R", and may not be used, directly or indirectly, in any command that invokes a subshell, or in any command that modifies files, directories or processes. Any variable that is set within an expression that has previously referenced a tainted value also becomes tainted (even if it is logically impossible for the tainted value to influence the variable). For example: .nf .ne 5 $foo = shift; # $foo is tainted $bar = $foo,\'bar\'; # $bar is also tainted $xxx = <>; # Tainted $path = $ENV{\'PATH\'}; # Tainted, but see below $abc = \'abc\'; # Not tainted .ne 4 system "echo $foo"; # Insecure system "echo", $foo; # Secure (doesn't use sh) system "echo $bar"; # Insecure system "echo $abc"; # Insecure until PATH set .ne 5 $ENV{\'PATH\'} = \'/bin:/usr/bin\'; $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\'; $path = $ENV{\'PATH\'}; # Not tainted system "echo $abc"; # Is secure now! .ne 5 open(FOO,"$foo"); # OK open(FOO,">$foo"); # Not OK open(FOO,"echo $foo|"); # Not OK, but... open(FOO,"-|") || exec \'echo\', $foo; # OK $zzz = `echo $foo`; # Insecure, zzz tainted unlink $abc,$foo; # Insecure umask $foo; # Insecure .ne 3 exec "echo $foo"; # Insecure exec "echo", $foo; # Secure (doesn't use sh) exec "sh", \'-c\', $foo; # Considered secure, alas .fi The taintedness is associated with each scalar value, so some elements of an array can be tainted, and others not. .PP If you try to do something insecure, you will get a fatal error saying something like \*(L"Insecure dependency\*(R" or \*(L"Insecure PATH\*(R". Note that you can still write an insecure system call or exec, but only by explicitly doing something like the last example above. You can also bypass the tainting mechanism by referencing subpatterns\*(--\c .I perl presumes that if you reference a substring using $1, $2, etc, you knew what you were doing when you wrote the pattern: .nf $ARGV[0] =~ /^\-P(\ew+)$/; $printer = $1; # Not tainted .fi This is fairly secure since \ew+ doesn't match shell metacharacters. Use of .+ would have been insecure, but .I perl doesn't check for that, so you must be careful with your patterns. This is the ONLY mechanism for untainting user supplied filenames if you want to do file operations on them (unless you make $> equal to $<). .PP It's also possible to get into trouble with other operations that don't care whether they use tainted values. Make judicious use of the file tests in dealing with any user-supplied filenames. When possible, do opens and such after setting $> = $<. .I Perl doesn't prevent you from opening tainted filenames for reading, so be careful what you print out. The tainting mechanism is intended to prevent stupid mistakes, not to remove the need for thought. .SH ENVIRONMENT .I Perl uses PATH in executing subprocesses, and in finding the script if \-S is used. HOME or LOGDIR are used if chdir has no argument. .PP Apart from these, .I perl uses no environment variables, except to make them available to the script being executed, and to child processes. However, scripts running setuid would do well to execute the following lines before doing anything else, just to keep people honest: .nf .ne 3 $ENV{\'PATH\'} = \'/bin:/usr/bin\'; # or whatever you need $ENV{\'SHELL\'} = \'/bin/sh\' if $ENV{\'SHELL\'} ne \'\'; $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\'; .fi .SH AUTHOR Larry Wall .SH FILES /tmp/perl\-eXXXXXX temporary file for .B \-e commands. .SH SEE ALSO a2p awk to perl translator .br s2p sed to perl translator .SH DIAGNOSTICS Compilation errors will tell you the line number of the error, with an indication of the next token or token type that was to be examined. (In the case of a script passed to .I perl via .B \-e switches, each .B \-e is counted as one line.) .PP Setuid scripts have additional constraints that can produce error messages such as \*(L"Insecure dependency\*(R". See the section on setuid scripts. .SH TRAPS Accustomed .IR awk users should take special note of the following: .Ip * 4 2 Semicolons are required after all simple statements in .IR perl . Newline is not a statement delimiter. .Ip * 4 2 Curly brackets are required on ifs and whiles. .Ip * 4 2 Variables begin with $ or @ in .IR perl . .Ip * 4 2 Arrays index from 0 unless you set $[. Likewise string positions in substr() and index(). .Ip * 4 2 You have to decide whether your array has numeric or string indices. .Ip * 4 2 Associative array values do not spring into existence upon mere reference. .Ip * 4 2 You have to decide whether you want to use string or numeric comparisons. .Ip * 4 2 Reading an input line does not split it for you. You get to split it yourself to an array. And the .I split operator has different arguments. .Ip * 4 2 The current input line is normally in $_, not $0. It generally does not have the newline stripped. ($0 is the name of the program executed.) .Ip * 4 2 $ does not refer to fields\*(--it refers to substrings matched by the last match pattern. .Ip * 4 2 The .I print statement does not add field and record separators unless you set $, and $\e. .Ip * 4 2 You must open your files before you print to them. .Ip * 4 2 The range operator is \*(L".\|.\*(R", not comma. (The comma operator works as in C.) .Ip * 4 2 The match operator is \*(L"=~\*(R", not \*(L"~\*(R". (\*(L"~\*(R" is the one's complement operator, as in C.) .Ip * 4 2 The exponentiation operator is \*(L"**\*(R", not \*(L"^\*(R". (\*(L"^\*(R" is the XOR operator, as in C.) .Ip * 4 2 The concatenation operator is \*(L".\*(R", not the null string. (Using the null string would render \*(L"/pat/ /pat/\*(R" unparsable, since the third slash would be interpreted as a division operator\*(--the tokener is in fact slightly context sensitive for operators like /, ?, and <. And in fact, . itself can be the beginning of a number.) .Ip * 4 2 .IR Next , .I exit and .I continue work differently. .Ip * 4 2 The following variables work differently .nf Awk \h'|2.5i'Perl ARGC \h'|2.5i'$#ARGV ARGV[0] \h'|2.5i'$0 FILENAME\h'|2.5i'$ARGV FNR \h'|2.5i'$. \- something FS \h'|2.5i'(whatever you like) NF \h'|2.5i'$#Fld, or some such NR \h'|2.5i'$. OFMT \h'|2.5i'$# OFS \h'|2.5i'$, ORS \h'|2.5i'$\e RLENGTH \h'|2.5i'length($&) RS \h'|2.5i'$/ RSTART \h'|2.5i'length($\`) SUBSEP \h'|2.5i'$; .fi .Ip * 4 2 When in doubt, run the .I awk construct through a2p and see what it gives you. .PP Cerebral C programmers should take note of the following: .Ip * 4 2 Curly brackets are required on ifs and whiles. .Ip * 4 2 You should use \*(L"elsif\*(R" rather than \*(L"else if\*(R" .Ip * 4 2 .I Break and .I continue become .I last and .IR next , respectively. .Ip * 4 2 There's no switch statement. .Ip * 4 2 Variables begin with $ or @ in .IR perl . .Ip * 4 2 Printf does not implement *. .Ip * 4 2 Comments begin with #, not /*. .Ip * 4 2 You can't take the address of anything. .Ip * 4 2 ARGV must be capitalized. .Ip * 4 2 The \*(L"system\*(R" calls link, unlink, rename, etc. return nonzero for success, not 0. .Ip * 4 2 Signal handlers deal with signal names, not numbers. .Ip * 4 2 You can't subscript array values, only arrays (no $x = (1,2,3)[2];). .PP Seasoned .I sed programmers should take note of the following: .Ip * 4 2 Backreferences in substitutions use $ rather than \e. .Ip * 4 2 The pattern matching metacharacters (, ), and | do not have backslashes in front. .Ip * 4 2 The range operator is .\|. rather than comma. .PP Sharp shell programmers should take note of the following: .Ip * 4 2 The backtick operator does variable interpretation without regard to the presence of single quotes in the command. .Ip * 4 2 The backtick operator does no translation of the return value, unlike csh. .Ip * 4 2 Shells (especially csh) do several levels of substitution on each command line. .I Perl does substitution only in certain constructs such as double quotes, backticks, angle brackets and search patterns. .Ip * 4 2 Shells interpret scripts a little bit at a time. .I Perl compiles the whole program before executing it. .Ip * 4 2 The arguments are available via @ARGV, not $1, $2, etc. .Ip * 4 2 The environment is not automatically made available as variables. .SH BUGS .PP .I Perl is at the mercy of your machine's definitions of various operations such as type casting, atof() and sprintf(). .PP If your stdio requires an seek or eof between reads and writes on a particular stream, so does .IR perl . .PP While none of the built-in data types have any arbitrary size limits (apart from memory size), there are still a few arbitrary limits: a given identifier may not be longer than 255 characters; sprintf is limited on many machines to 128 characters per field (unless the format specifier is exactly %s); and no component of your PATH may be longer than 255 if you use \-S. .PP .I Perl actually stands for Pathologically Eclectic Rubbish Lister, but don't tell anyone I said that. .rn }` '' so does .IR perl . .PP While none of the built-in data types have any arbitrary size limits (apart from memory size), there are still a few arbitrary limits: a given identifier may not be longer than 255 characters; sprintf is limited on many machines to 128 charperl/doio.c 644 473 0 125663 4747105026 6205 /* $Header: doio.c,v 3.0.1.5 90/02/28 17:01:36 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: doio.c,v $ * Revision 3.0.1.5 90/02/28 17:01:36 lwall * patch9: open(FOO,"$filename\0") will now protect trailing spaces in filename * patch9: removed obsolete checks to avoid opening block devices * patch9: removed references to acusec and modusec that some utime.h's have * patch9: added pipe function * * Revision 3.0.1.4 89/12/21 19:55:10 lwall * patch7: select now works on big-endian machines * patch7: errno may now be a macro with an lvalue * patch7: ANSI strerror() is now supported * patch7: Configure now detects DG/UX thingies like [sg]etpgrp2 and utime.h * * Revision 3.0.1.3 89/11/17 15:13:06 lwall * patch5: some systems have symlink() but not lstat() * patch5: some systems have dirent.h but not readdir() * * Revision 3.0.1.2 89/11/11 04:25:51 lwall * patch2: orthogonalized the file modes some so we can have <& +<& etc. * patch2: do_open() now detects sockets passed to process from parent * patch2: fd's above 2 are now closed on exec * patch2: csh code can now use csh from other than /bin * patch2: getsockopt, get{sock,peer}name didn't define result properly * patch2: warn("shutdown") was replicated * patch2: gethostbyname was misdeclared * patch2: telldir() is sometimes a macro * * Revision 3.0.1.1 89/10/26 23:10:05 lwall * patch1: Configure now checks for BSD shadow passwords * * Revision 3.0 89/10/18 15:10:54 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" #ifdef SOCKET #include #include #endif #ifdef I_PWD #include #endif #ifdef I_GRP #include #endif #ifdef I_UTIME #include #endif bool do_open(stab,name,len) STAB *stab; register char *name; int len; { FILE *fp; register STIO *stio = stab_io(stab); char *myname = savestr(name); int result; int fd; int writing = 0; char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ name = myname; forkprocess = 1; /* assume true if no fork */ while (len && isspace(name[len-1])) name[--len] = '\0'; if (!stio) stio = stab_io(stab) = stio_new(); else if (stio->ifp) { fd = fileno(stio->ifp); if (stio->type == '|') result = mypclose(stio->ifp); else if (stio->ifp != stio->ofp) { if (stio->ofp) fclose(stio->ofp); result = fclose(stio->ifp); } else if (stio->type != '-') result = fclose(stio->ifp); else result = 0; if (result == EOF && fd > 2) fprintf(stderr,"Warning: unable to close filehandle %s properly.\n", stab_name(stab)); stio->ofp = stio->ifp = Nullfp; } if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */ mode[1] = *name++; mode[2] = '\0'; --len; writing = 1; } else { mode[1] = '\0'; } stio->type = *name; if (*name == '|') { for (name++; isspace(*name); name++) ; #ifdef TAINT taintenv(); taintproper("Insecure dependency in piped open"); #endif fp = mypopen(name,"w"); writing = 1; } else if (*name == '>') { #ifdef TAINT taintproper("Insecure dependency in open"); #endif name++; if (*name == '>') { mode[0] = stio->type = 'a'; name++; } else mode[0] = 'w'; writing = 1; if (*name == '&') { duplicity: name++; while (isspace(*name)) name++; if (isdigit(*name)) fd = atoi(name); else { stab = stabent(name,FALSE); if (!stab || !stab_io(stab)) return FALSE; if (stab_io(stab) && stab_io(stab)->ifp) { fd = fileno(stab_io(stab)->ifp); if (stab_io(stab)->type == 's') stio->type = 's'; } else fd = -1; } fp = fdopen(dup(fd),mode); } else { while (isspace(*name)) name++; if (strEQ(name,"-")) { fp = stdout; stio->type = '-'; } else { fp = fopen(name,mode); } } } else { if (*name == '<') { mode[0] = 'r'; name++; while (isspace(*name)) name++; if (*name == '&') goto duplicity; if (strEQ(name,"-")) { fp = stdin; stio->type = '-'; } else fp = fopen(name,mode); } else if (name[len-1] == '|') { #ifdef TAINT taintenv(); taintproper("Insecure dependency in piped open"); #endif name[--len] = '\0'; while (len && isspace(name[len-1])) name[--len] = '\0'; for (; isspace(*name); name++) ; fp = mypopen(name,"r"); stio->type = '|'; } else { stio->type = '<'; for (; isspace(*name); name++) ; if (strEQ(name,"-")) { fp = stdin; stio->type = '-'; } else fp = fopen(name,"r"); } } Safefree(myname); if (!fp) return FALSE; if (stio->type && stio->type != '|' && stio->type != '-') { if (fstat(fileno(fp),&statbuf) < 0) { (void)fclose(fp); return FALSE; } result = (statbuf.st_mode & S_IFMT); #ifdef S_IFSOCK if (result == S_IFSOCK || result == 0) stio->type = 's'; /* in case a socket was passed in to us */ #endif } #if defined(FCNTL) && defined(F_SETFD) fd = fileno(fp); if (fd >= 3) fcntl(fd,F_SETFD,1); #endif stio->ifp = fp; if (writing) { if (stio->type != 's') stio->ofp = fp; else stio->ofp = fdopen(fileno(fp),"w"); } return TRUE; } FILE * nextargv(stab) register STAB *stab; { register STR *str; char *oldname; int filemode,fileuid,filegid; while (alen(stab_xarray(stab)) >= 0) { str = ashift(stab_xarray(stab)); str_sset(stab_val(stab),str); STABSET(stab_val(stab)); oldname = str_get(stab_val(stab)); if (do_open(stab,oldname,stab_val(stab)->str_cur)) { if (inplace) { #ifdef TAINT taintproper("Insecure dependency in inplace open"); #endif filemode = statbuf.st_mode; fileuid = statbuf.st_uid; filegid = statbuf.st_gid; if (*inplace) { str_cat(str,inplace); #ifdef RENAME (void)rename(oldname,str->str_ptr); #else (void)UNLINK(str->str_ptr); (void)link(oldname,str->str_ptr); (void)UNLINK(oldname); #endif } else { (void)UNLINK(oldname); } str_nset(str,">",1); str_cat(str,oldname); errno = 0; /* in case sprintf set errno */ if (!do_open(argvoutstab,str->str_ptr,str->str_cur)) fatal("Can't do inplace edit"); defoutstab = argvoutstab; #ifdef FCHMOD (void)fchmod(fileno(stab_io(argvoutstab)->ifp),filemode); #else (void)chmod(oldname,filemode); #endif #ifdef FCHOWN (void)fchown(fileno(stab_io(argvoutstab)->ifp),fileuid,filegid); #else (void)chown(oldname,fileuid,filegid); #endif } str_free(str); return stab_io(stab)->ifp; } else fprintf(stderr,"Can't open %s\n",str_get(str)); str_free(str); } if (inplace) { (void)do_close(argvoutstab,FALSE); defoutstab = stabent("STDOUT",TRUE); } return Nullfp; } void do_pipe(str, rstab, wstab) STR *str; STAB *rstab; STAB *wstab; { register STIO *rstio; register STIO *wstio; int fd[2]; if (!rstab) goto badexit; if (!wstab) goto badexit; rstio = stab_io(rstab); wstio = stab_io(wstab); if (!rstio) rstio = stab_io(rstab) = stio_new(); else if (rstio->ifp) do_close(rstab,FALSE); if (!wstio) wstio = stab_io(wstab) = stio_new(); else if (wstio->ifp) do_close(wstab,FALSE); if (pipe(fd) < 0) goto badexit; rstio->ifp = fdopen(fd[0], "r"); wstio->ofp = fdopen(fd[1], "w"); wstio->ifp = wstio->ofp; rstio->type = '<'; wstio->type = '>'; str_sset(str,&str_yes); return; badexit: str_sset(str,&str_undef); return; } bool do_close(stab,explicit) STAB *stab; bool explicit; { bool retval = FALSE; register STIO *stio = stab_io(stab); int status; if (!stio) { /* never opened */ if (dowarn && explicit) warn("Close on unopened file <%s>",stab_name(stab)); return FALSE; } if (stio->ifp) { if (stio->type == '|') { status = mypclose(stio->ifp); retval = (status >= 0); statusvalue = (unsigned)status & 0xffff; } else if (stio->type == '-') retval = TRUE; else { if (stio->ofp && stio->ofp != stio->ifp) /* a socket */ fclose(stio->ofp); retval = (fclose(stio->ifp) != EOF); } stio->ofp = stio->ifp = Nullfp; } if (explicit) stio->lines = 0; stio->type = ' '; return retval; } bool do_eof(stab) STAB *stab; { register STIO *stio; int ch; if (!stab) { /* eof() */ if (argvstab) stio = stab_io(argvstab); else return TRUE; } else stio = stab_io(stab); if (!stio) return TRUE; while (stio->ifp) { #ifdef STDSTDIO /* (the code works without this) */ if (stio->ifp->_cnt > 0) /* cheat a little, since */ return FALSE; /* this is the most usual case */ #endif ch = getc(stio->ifp); if (ch != EOF) { (void)ungetc(ch, stio->ifp); return FALSE; } if (!stab) { /* not necessarily a real EOF yet? */ if (!nextargv(argvstab)) /* get another fp handy */ return TRUE; } else return TRUE; /* normal fp, definitely end of file */ } return TRUE; } long do_tell(stab) STAB *stab; { register STIO *stio; if (!stab) goto phooey; stio = stab_io(stab); if (!stio || !stio->ifp) goto phooey; if (feof(stio->ifp)) (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */ return ftell(stio->ifp); phooey: if (dowarn) warn("tell() on unopened file"); return -1L; } bool do_seek(stab, pos, whence) STAB *stab; long pos; int whence; { register STIO *stio; if (!stab) goto nuts; stio = stab_io(stab); if (!stio || !stio->ifp) goto nuts; if (feof(stio->ifp)) (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */ return fseek(stio->ifp, pos, whence) >= 0; nuts: if (dowarn) warn("seek() on unopened file"); return FALSE; } int do_ctl(optype,stab,func,argstr) int optype; STAB *stab; int func; STR *argstr; { register STIO *stio; register char *s; int retval; if (!stab || !argstr) return -1; stio = stab_io(stab); if (!stio) return -1; if (argstr->str_pok || !argstr->str_nok) { if (!argstr->str_pok) s = str_get(argstr); #ifdef IOCPARM_MASK #ifndef IOCPARM_LEN #define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK) #endif #endif #ifdef IOCPARM_LEN retval = IOCPARM_LEN(func); /* on BSDish systes we're safe */ #else retval = 256; /* otherwise guess at what's safe */ #endif if (argstr->str_cur < retval) { str_grow(argstr,retval+1); argstr->str_cur = retval; } s = argstr->str_ptr; s[argstr->str_cur] = 17; /* a little sanity check here */ } else { retval = (int)str_gnum(argstr); s = (char*)retval; /* ouch */ } #ifndef lint if (optype == O_IOCTL) retval = ioctl(fileno(stio->ifp), func, s); else #ifdef I_FCNTL retval = fcntl(fileno(stio->ifp), func, s); #else fatal("fcntl is not implemented"); #endif #else /* lint */ retval = 0; #endif /* lint */ if (argstr->str_pok) { if (s[argstr->str_cur] != 17) fatal("Return value overflowed string"); s[argstr->str_cur] = 0; /* put our null back */ } return retval; } int do_stat(str,arg,gimme,arglast) STR *str; register ARG *arg; int gimme; int *arglast; { register ARRAY *ary = stack; register int sp = arglast[0] + 1; int max = 13; register int i; if ((arg[1].arg_type & A_MASK) == A_WORD) { tmpstab = arg[1].arg_ptr.arg_stab; if (tmpstab != defstab) { statstab = tmpstab; str_set(statname,""); if (!stab_io(tmpstab) || fstat(fileno(stab_io(tmpstab)->ifp),&statcache) < 0) { max = 0; } } } else { str_sset(statname,ary->ary_array[sp]); statstab = Nullstab; #ifdef LSTAT if (arg->arg_type == O_LSTAT) i = lstat(str_get(statname),&statcache); else #endif i = stat(str_get(statname),&statcache); if (i < 0) max = 0; } if (gimme != G_ARRAY) { if (max) str_sset(str,&str_yes); else str_sset(str,&str_undef); STABSET(str); ary->ary_array[sp] = str; return sp; } sp--; if (max) { #ifndef lint (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_dev))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_ino))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_mode))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_nlink))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_uid))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_gid))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_rdev))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_size))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_atime))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_mtime))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_ctime))); #ifdef STATBLOCKS (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_blksize))); (void)astore(ary,++sp, str_2static(str_nmake((double)statcache.st_blocks))); #else (void)astore(ary,++sp, str_2static(str_make("",0))); (void)astore(ary,++sp, str_2static(str_make("",0))); #endif #else /* lint */ (void)astore(ary,++sp,str_nmake(0.0)); #endif /* lint */ } return sp; } int looks_like_number(str) STR *str; { register char *s; register char *send; if (!str->str_pok) return TRUE; s = str->str_ptr; send = s + str->str_cur; while (isspace(*s)) s++; if (s >= send) return FALSE; if (*s == '+' || *s == '-') s++; while (isdigit(*s)) s++; if (s == send) return TRUE; if (*s == '.') s++; else if (s == str->str_ptr) return FALSE; while (isdigit(*s)) s++; if (s == send) return TRUE; if (*s == 'e' || *s == 'E') { s++; if (*s == '+' || *s == '-') s++; while (isdigit(*s)) s++; } while (isspace(*s)) s++; if (s >= send) return TRUE; return FALSE; } bool do_print(str,fp) register STR *str; FILE *fp; { register char *tmps; if (!fp) { if (dowarn) warn("print to unopened file"); return FALSE; } if (!str) return FALSE; if (ofmt && ((str->str_nok && str->str_u.str_nval != 0.0) || (looks_like_number(str) && str_gnum(str) != 0.0) ) ) fprintf(fp, ofmt, str->str_u.str_nval); else { tmps = str_get(str); if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'a' && tmps[3] == 'b' && str->str_cur == sizeof(STBP) && strlen(tmps) < str->str_cur) { tmps = stab_name(((STAB*)str)); /* a stab value, be nice */ str = ((STAB*)str)->str_magic; putc('*',fp); } if (str->str_cur && fwrite(tmps,1,str->str_cur,fp) == 0) return FALSE; } return TRUE; } bool do_aprint(arg,fp,arglast) register ARG *arg; register FILE *fp; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int retval; register int items = arglast[2] - sp; if (!fp) { if (dowarn) warn("print to unopened file"); return FALSE; } st += ++sp; if (arg->arg_type == O_PRTF) { do_sprintf(arg->arg_ptr.arg_str,items,st); retval = do_print(arg->arg_ptr.arg_str,fp); } else { retval = (items <= 0); for (; items > 0; items--,st++) { if (retval && ofslen) { if (fwrite(ofs, 1, ofslen, fp) == 0) { retval = FALSE; break; } } if (!(retval = do_print(*st, fp))) break; } if (retval && orslen) if (fwrite(ors, 1, orslen, fp) == 0) retval = FALSE; } return retval; } int mystat(arg,str) ARG *arg; STR *str; { STIO *stio; if (arg[1].arg_type & A_DONT) { stio = stab_io(arg[1].arg_ptr.arg_stab); if (stio && stio->ifp) { statstab = arg[1].arg_ptr.arg_stab; str_set(statname,""); return fstat(fileno(stio->ifp), &statcache); } else { if (arg[1].arg_ptr.arg_stab == defstab) return 0; if (dowarn) warn("Stat on unopened file <%s>", stab_name(arg[1].arg_ptr.arg_stab)); statstab = Nullstab; str_set(statname,""); return -1; } } else { statstab = Nullstab; str_sset(statname,str); return stat(str_get(str),&statcache); } } STR * do_fttext(arg,str) register ARG *arg; STR *str; { int i; int len; int odd = 0; STDCHAR tbuf[512]; register STDCHAR *s; register STIO *stio; if (arg[1].arg_type & A_DONT) { if (arg[1].arg_ptr.arg_stab == defstab) { if (statstab) stio = stab_io(statstab); else { str = statname; goto really_filename; } } else { statstab = arg[1].arg_ptr.arg_stab; str_set(statname,""); stio = stab_io(statstab); } if (stio && stio->ifp) { #ifdef STDSTDIO fstat(fileno(stio->ifp),&statcache); if (stio->ifp->_cnt <= 0) { i = getc(stio->ifp); if (i != EOF) (void)ungetc(i,stio->ifp); } if (stio->ifp->_cnt <= 0) /* null file is anything */ return &str_yes; len = stio->ifp->_cnt + (stio->ifp->_ptr - stio->ifp->_base); s = stio->ifp->_base; #else fatal("-T and -B not implemented on filehandles\n"); #endif } else { if (dowarn) warn("Test on unopened file <%s>", stab_name(arg[1].arg_ptr.arg_stab)); return &str_undef; } } else { statstab = Nullstab; str_sset(statname,str); really_filename: i = open(str_get(str),0); if (i < 0) return &str_undef; fstat(i,&statcache); len = read(i,tbuf,512); if (len <= 0) /* null file is anything */ return &str_yes; (void)close(i); s = tbuf; } /* now scan s to look for textiness */ for (i = 0; i < len; i++,s++) { if (!*s) { /* null never allowed in text */ odd += len; break; } else if (*s & 128) odd++; else if (*s < 32 && *s != '\n' && *s != '\r' && *s != '\b' && *s != '\t' && *s != '\f' && *s != 27) odd++; } if ((odd * 10 > len) == (arg->arg_type == O_FTTEXT)) /* allow 10% odd */ return &str_no; else return &str_yes; } bool do_aexec(really,arglast) STR *really; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int items = arglast[2] - sp; register char **a; char **argv; char *tmps; if (items) { New(401,argv, items+1, char*); a = argv; for (st += ++sp; items > 0; items--,st++) { if (*st) *a++ = str_get(*st); else *a++ = ""; } *a = Nullch; #ifdef TAINT if (*argv[0] != '/') /* will execvp use PATH? */ taintenv(); /* testing IFS here is overkill, probably */ #endif if (really && *(tmps = str_get(really))) execvp(tmps,argv); else execvp(argv[0],argv); Safefree(argv); } return FALSE; } bool do_exec(cmd) char *cmd; { register char **a; register char *s; char **argv; char flags[10]; #ifdef TAINT taintenv(); taintproper("Insecure dependency in exec"); #endif /* save an extra exec if possible */ #ifdef CSH if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) { strcpy(flags,"-c"); s = cmd+cshlen+3; if (*s == 'f') { s++; strcat(flags,"f"); } if (*s == ' ') s++; if (*s++ == '\'') { char *ncmd = s; while (*s) s++; if (s[-1] == '\n') *--s = '\0'; if (s[-1] == '\'') { *--s = '\0'; execl(cshname,"csh", flags,ncmd,(char*)0); *s = '\''; return FALSE; } } } #endif /* CSH */ /* see if there are shell metacharacters in it */ for (s = cmd; *s; s++) { if (*s != ' ' && !isalpha(*s) && index("$&*(){}[]'\";\\|?<>~`\n",*s)) { if (*s == '\n' && !s[1]) { *s = '\0'; break; } doshell: execl("/bin/sh","sh","-c",cmd,(char*)0); return FALSE; } } New(402,argv, (s - cmd) / 2 + 2, char*); a = argv; for (s = cmd; *s;) { while (*s && isspace(*s)) s++; if (*s) *(a++) = s; while (*s && !isspace(*s)) s++; if (*s) *s++ = '\0'; } *a = Nullch; if (argv[0]) { execvp(argv[0],argv); if (errno == ENOEXEC) /* for system V NIH syndrome */ goto doshell; } Safefree(argv); return FALSE; } #ifdef SOCKET int do_socket(stab, arglast) STAB *stab; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register STIO *stio; int domain, type, protocol, fd; if (!stab) return FALSE; stio = stab_io(stab); if (!stio) stio = stab_io(stab) = stio_new(); else if (stio->ifp) do_close(stab,FALSE); domain = (int)str_gnum(st[++sp]); type = (int)str_gnum(st[++sp]); protocol = (int)str_gnum(st[++sp]); #ifdef TAINT taintproper("Insecure dependency in socket"); #endif fd = socket(domain,type,protocol); if (fd < 0) return FALSE; stio->ifp = fdopen(fd, "r"); /* stdio gets confused about sockets */ stio->ofp = fdopen(fd, "w"); stio->type = 's'; return TRUE; } int do_bind(stab, arglast) STAB *stab; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register STIO *stio; char *addr; if (!stab) goto nuts; stio = stab_io(stab); if (!stio || !stio->ifp) goto nuts; addr = str_get(st[++sp]); #ifdef TAINT taintproper("Insecure dependency in bind"); #endif return bind(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0; nuts: if (dowarn) warn("bind() on closed fd"); return FALSE; } int do_connect(stab, arglast) STAB *stab; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register STIO *stio; char *addr; if (!stab) goto nuts; stio = stab_io(stab); if (!stio || !stio->ifp) goto nuts; addr = str_get(st[++sp]); #ifdef TAINT taintproper("Insecure dependency in connect"); #endif return connect(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0; nuts: if (dowarn) warn("connect() on closed fd"); return FALSE; } int do_listen(stab, arglast) STAB *stab; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register STIO *stio; int backlog; if (!stab) goto nuts; stio = stab_io(stab); if (!stio || !stio->ifp) goto nuts; backlog = (int)str_gnum(st[++sp]); return listen(fileno(stio->ifp), backlog) >= 0; nuts: if (dowarn) warn("listen() on closed fd"); return FALSE; } void do_accept(str, nstab, gstab) STR *str; STAB *nstab; STAB *gstab; { register STIO *nstio; register STIO *gstio; int len = sizeof buf; int fd; if (!nstab) goto badexit; if (!gstab) goto nuts; gstio = stab_io(gstab); nstio = stab_io(nstab); if (!gstio || !gstio->ifp) goto nuts; if (!nstio) nstio = stab_io(nstab) = stio_new(); else if (nstio->ifp) do_close(nstab,FALSE); fd = accept(fileno(gstio->ifp),buf,&len); if (fd < 0) goto badexit; nstio->ifp = fdopen(fd, "r"); nstio->ofp = fdopen(fd, "w"); nstio->type = 's'; str_nset(str, buf, len); return; nuts: if (dowarn) warn("accept() on closed fd"); badexit: str_sset(str,&str_undef); return; } int do_shutdown(stab, arglast) STAB *stab; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register STIO *stio; int how; if (!stab) goto nuts; stio = stab_io(stab); if (!stio || !stio->ifp) goto nuts; how = (int)str_gnum(st[++sp]); return shutdown(fileno(stio->ifp), how) >= 0; nuts: if (dowarn) warn("shutdown() on closed fd"); return FALSE; } int do_sopt(optype, stab, arglast) int optype; STAB *stab; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register STIO *stio; int fd; int lvl; int optname; if (!stab) goto nuts; stio = stab_io(stab); if (!stio || !stio->ifp) goto nuts; fd = fileno(stio->ifp); lvl = (int)str_gnum(st[sp+1]); optname = (int)str_gnum(st[sp+2]); switch (optype) { case O_GSOCKOPT: st[sp] = str_2static(str_new(257)); st[sp]->str_cur = 256; st[sp]->str_pok = 1; if (getsockopt(fd, lvl, optname, st[sp]->str_ptr, &st[sp]->str_cur) < 0) goto nuts; break; case O_SSOCKOPT: st[sp] = st[sp+3]; if (setsockopt(fd, lvl, optname, st[sp]->str_ptr, st[sp]->str_cur) < 0) goto nuts; st[sp] = &str_yes; break; } return sp; nuts: if (dowarn) warn("[gs]etsockopt() on closed fd"); st[sp] = &str_undef; return sp; } int do_getsockname(optype, stab, arglast) int optype; STAB *stab; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register STIO *stio; int fd; if (!stab) goto nuts; stio = stab_io(stab); if (!stio || !stio->ifp) goto nuts; st[sp] = str_2static(str_new(257)); st[sp]->str_cur = 256; st[sp]->str_pok = 1; fd = fileno(stio->ifp); switch (optype) { case O_GETSOCKNAME: if (getsockname(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0) goto nuts; break; case O_GETPEERNAME: if (getpeername(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0) goto nuts; break; } return sp; nuts: if (dowarn) warn("get{sock,peer}name() on closed fd"); st[sp] = &str_undef; return sp; } int do_ghent(which,gimme,arglast) int which; int gimme; int *arglast; { register ARRAY *ary = stack; register int sp = arglast[0]; register char **elem; register STR *str; struct hostent *gethostbyname(); struct hostent *gethostbyaddr(); #ifdef GETHOSTENT struct hostent *gethostent(); #endif struct hostent *hent; unsigned long len; if (gimme != G_ARRAY) { astore(ary, ++sp, str_static(&str_undef)); return sp; } if (which == O_GHBYNAME) { char *name = str_get(ary->ary_array[sp+1]); hent = gethostbyname(name); } else if (which == O_GHBYADDR) { STR *addrstr = ary->ary_array[sp+1]; int addrtype = (int)str_gnum(ary->ary_array[sp+2]); char *addr = str_get(addrstr); hent = gethostbyaddr(addr,addrstr->str_cur,addrtype); } else #ifdef GETHOSTENT hent = gethostent(); #else fatal("gethostent not implemented"); #endif if (hent) { #ifndef lint (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, hent->h_name); (void)astore(ary, ++sp, str = str_static(&str_no)); for (elem = hent->h_aliases; *elem; elem++) { str_cat(str, *elem); if (elem[1]) str_ncat(str," ",1); } (void)astore(ary, ++sp, str = str_static(&str_no)); str_numset(str, (double)hent->h_addrtype); (void)astore(ary, ++sp, str = str_static(&str_no)); len = hent->h_length; str_numset(str, (double)len); #ifdef h_addr for (elem = hent->h_addr_list; *elem; elem++) { (void)astore(ary, ++sp, str = str_static(&str_no)); str_nset(str, *elem, len); } #else (void)astore(ary, ++sp, str = str_static(&str_no)); str_nset(str, hent->h_addr, len); #endif /* h_addr */ #else /* lint */ elem = Nullch; elem = elem; (void)astore(ary, ++sp, str_static(&str_no)); #endif /* lint */ } return sp; } int do_gnent(which,gimme,arglast) int which; int gimme; int *arglast; { register ARRAY *ary = stack; register int sp = arglast[0]; register char **elem; register STR *str; struct netent *getnetbyname(); struct netent *getnetbyaddr(); struct netent *getnetent(); struct netent *nent; if (gimme != G_ARRAY) { astore(ary, ++sp, str_static(&str_undef)); return sp; } if (which == O_GNBYNAME) { char *name = str_get(ary->ary_array[sp+1]); nent = getnetbyname(name); } else if (which == O_GNBYADDR) { STR *addrstr = ary->ary_array[sp+1]; int addrtype = (int)str_gnum(ary->ary_array[sp+2]); char *addr = str_get(addrstr); nent = getnetbyaddr(addr,addrtype); } else nent = getnetent(); if (nent) { #ifndef lint (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, nent->n_name); (void)astore(ary, ++sp, str = str_static(&str_no)); for (elem = nent->n_aliases; *elem; elem++) { str_cat(str, *elem); if (elem[1]) str_ncat(str," ",1); } (void)astore(ary, ++sp, str = str_static(&str_no)); str_numset(str, (double)nent->n_addrtype); (void)astore(ary, ++sp, str = str_static(&str_no)); str_numset(str, (double)nent->n_net); #else /* lint */ elem = Nullch; elem = elem; (void)astore(ary, ++sp, str_static(&str_no)); #endif /* lint */ } return sp; } int do_gpent(which,gimme,arglast) int which; int gimme; int *arglast; { register ARRAY *ary = stack; register int sp = arglast[0]; register char **elem; register STR *str; struct protoent *getprotobyname(); struct protoent *getprotobynumber(); struct protoent *getprotoent(); struct protoent *pent; if (gimme != G_ARRAY) { astore(ary, ++sp, str_static(&str_undef)); return sp; } if (which == O_GPBYNAME) { char *name = str_get(ary->ary_array[sp+1]); pent = getprotobyname(name); } else if (which == O_GPBYNUMBER) { int proto = (int)str_gnum(ary->ary_array[sp+1]); pent = getprotobynumber(proto); } else pent = getprotoent(); if (pent) { #ifndef lint (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, pent->p_name); (void)astore(ary, ++sp, str = str_static(&str_no)); for (elem = pent->p_aliases; *elem; elem++) { str_cat(str, *elem); if (elem[1]) str_ncat(str," ",1); } (void)astore(ary, ++sp, str = str_static(&str_no)); str_numset(str, (double)pent->p_proto); #else /* lint */ elem = Nullch; elem = elem; (void)astore(ary, ++sp, str_static(&str_no)); #endif /* lint */ } return sp; } int do_gsent(which,gimme,arglast) int which; int gimme; int *arglast; { register ARRAY *ary = stack; register int sp = arglast[0]; register char **elem; register STR *str; struct servent *getservbyname(); struct servent *getservbynumber(); struct servent *getservent(); struct servent *sent; if (gimme != G_ARRAY) { astore(ary, ++sp, str_static(&str_undef)); return sp; } if (which == O_GSBYNAME) { char *name = str_get(ary->ary_array[sp+1]); char *proto = str_get(ary->ary_array[sp+2]); if (proto && !*proto) proto = Nullch; sent = getservbyname(name,proto); } else if (which == O_GSBYPORT) { int port = (int)str_gnum(ary->ary_array[sp+1]); char *proto = str_get(ary->ary_array[sp+2]); sent = getservbyport(port,proto); } else sent = getservent(); if (sent) { #ifndef lint (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, sent->s_name); (void)astore(ary, ++sp, str = str_static(&str_no)); for (elem = sent->s_aliases; *elem; elem++) { str_cat(str, *elem); if (elem[1]) str_ncat(str," ",1); } (void)astore(ary, ++sp, str = str_static(&str_no)); #ifdef NTOHS str_numset(str, (double)ntohs(sent->s_port)); #else str_numset(str, (double)(sent->s_port)); #endif (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, sent->s_proto); #else /* lint */ elem = Nullch; elem = elem; (void)astore(ary, ++sp, str_static(&str_no)); #endif /* lint */ } return sp; } int do_select(gimme,arglast) int gimme; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[0]; register int i; register int j; register char *s; register STR *str; double value; int maxlen = 0; int nfound; struct timeval timebuf; struct timeval *tbuf = &timebuf; int growsize; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 int masksize; int offset; char *fd_sets[4]; int k; #if BYTEORDER & 0xf0000 #define ORDERBYTE (0x88888888 - BYTEORDER) #else #define ORDERBYTE (0x4444 - BYTEORDER) #endif #endif for (i = 1; i <= 3; i++) { j = st[sp+i]->str_cur; if (maxlen < j) maxlen = j; } #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 growsize = maxlen; /* little endians can use vecs directly */ #else #ifdef NFDBITS #ifndef NBBY #define NBBY 8 #endif masksize = NFDBITS / NBBY; #else masksize = sizeof(long); /* documented int, everyone seems to use long */ #endif growsize = maxlen + (masksize - (maxlen % masksize)); Zero(&fd_sets[0], 4, char*); #endif for (i = 1; i <= 3; i++) { str = st[sp+i]; j = str->str_len; if (j < growsize) { if (str->str_pok) { str_grow(str,growsize); s = str_get(str) + j; while (++j <= growsize) { *s++ = '\0'; } } else if (str->str_ptr) { Safefree(str->str_ptr); str->str_ptr = Nullch; } } #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 s = str->str_ptr; if (s) { New(403, fd_sets[i], growsize, char); for (offset = 0; offset < growsize; offset += masksize) { for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) fd_sets[i][j+offset] = s[(k % masksize) + offset]; } } #endif } str = st[sp+4]; if (str->str_nok || str->str_pok) { value = str_gnum(str); if (value < 0.0) value = 0.0; timebuf.tv_sec = (long)value; value -= (double)timebuf.tv_sec; timebuf.tv_usec = (long)(value * 1000000.0); } else tbuf = Null(struct timeval*); #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 nfound = select( maxlen * 8, st[sp+1]->str_ptr, st[sp+2]->str_ptr, st[sp+3]->str_ptr, tbuf); #else nfound = select( maxlen * 8, fd_sets[1], fd_sets[2], fd_sets[3], tbuf); for (i = 1; i <= 3; i++) { if (fd_sets[i]) { str = st[sp+i]; s = str->str_ptr; for (offset = 0; offset < growsize; offset += masksize) { for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) s[(k % masksize) + offset] = fd_sets[i][j+offset]; } } } #endif st[++sp] = str_static(&str_no); str_numset(st[sp], (double)nfound); if (gimme == G_ARRAY && tbuf) { value = (double)(timebuf.tv_sec) + (double)(timebuf.tv_usec) / 1000000.0; st[++sp] = str_static(&str_no); str_numset(st[sp], value); } return sp; } int do_spair(stab1, stab2, arglast) STAB *stab1; STAB *stab2; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[2]; register STIO *stio1; register STIO *stio2; int domain, type, protocol, fd[2]; if (!stab1 || !stab2) return FALSE; stio1 = stab_io(stab1); stio2 = stab_io(stab2); if (!stio1) stio1 = stab_io(stab1) = stio_new(); else if (stio1->ifp) do_close(stab1,FALSE); if (!stio2) stio2 = stab_io(stab2) = stio_new(); else if (stio2->ifp) do_close(stab2,FALSE); domain = (int)str_gnum(st[++sp]); type = (int)str_gnum(st[++sp]); protocol = (int)str_gnum(st[++sp]); #ifdef TAINT taintproper("Insecure dependency in socketpair"); #endif #ifdef SOCKETPAIR if (socketpair(domain,type,protocol,fd) < 0) return FALSE; #else fatal("Socketpair unimplemented"); #endif stio1->ifp = fdopen(fd[0], "r"); stio1->ofp = fdopen(fd[0], "w"); stio1->type = 's'; stio2->ifp = fdopen(fd[1], "r"); stio2->ofp = fdopen(fd[1], "w"); stio2->type = 's'; return TRUE; } #endif /* SOCKET */ int do_gpwent(which,gimme,arglast) int which; int gimme; int *arglast; { #ifdef I_PWD register ARRAY *ary = stack; register int sp = arglast[0]; register char **elem; register STR *str; struct passwd *getpwnam(); struct passwd *getpwuid(); struct passwd *getpwent(); struct passwd *pwent; unsigned long len; if (gimme != G_ARRAY) { astore(ary, ++sp, str_static(&str_undef)); return sp; } if (which == O_GPWNAM) { char *name = str_get(ary->ary_array[sp+1]); pwent = getpwnam(name); } else if (which == O_GPWUID) { int uid = (int)str_gnum(ary->ary_array[sp+1]); pwent = getpwuid(uid); } else pwent = getpwent(); if (pwent) { (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, pwent->pw_name); (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, pwent->pw_passwd); (void)astore(ary, ++sp, str = str_static(&str_no)); str_numset(str, (double)pwent->pw_uid); (void)astore(ary, ++sp, str = str_static(&str_no)); str_numset(str, (double)pwent->pw_gid); (void)astore(ary, ++sp, str = str_static(&str_no)); #ifdef PWCHANGE str_numset(str, (double)pwent->pw_change); #else #ifdef PWQUOTA str_numset(str, (double)pwent->pw_quota); #else #ifdef PWAGE str_set(str, pwent->pw_age); #endif #endif #endif (void)astore(ary, ++sp, str = str_static(&str_no)); #ifdef PWCLASS str_set(str,pwent->pw_class); #else str_set(str, pwent->pw_comment); #endif (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, pwent->pw_gecos); (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, pwent->pw_dir); (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, pwent->pw_shell); #ifdef PWEXPIRE (void)astore(ary, ++sp, str = str_static(&str_no)); str_numset(str, (double)pwent->pw_expire); #endif } return sp; #else fatal("password routines not implemented"); #endif } int do_ggrent(which,gimme,arglast) int which; int gimme; int *arglast; { #ifdef I_GRP register ARRAY *ary = stack; register int sp = arglast[0]; register char **elem; register STR *str; struct group *getgrnam(); struct group *getgrgid(); struct group *getgrent(); struct group *grent; unsigned long len; if (gimme != G_ARRAY) { astore(ary, ++sp, str_static(&str_undef)); return sp; } if (which == O_GGRNAM) { char *name = str_get(ary->ary_array[sp+1]); grent = getgrnam(name); } else if (which == O_GGRGID) { int gid = (int)str_gnum(ary->ary_array[sp+1]); grent = getgrgid(gid); } else grent = getgrent(); if (grent) { (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, grent->gr_name); (void)astore(ary, ++sp, str = str_static(&str_no)); str_set(str, grent->gr_passwd); (void)astore(ary, ++sp, str = str_static(&str_no)); str_numset(str, (double)grent->gr_gid); (void)astore(ary, ++sp, str = str_static(&str_no)); for (elem = grent->gr_mem; *elem; elem++) { str_cat(str, *elem); if (elem[1]) str_ncat(str," ",1); } } return sp; #else fatal("group routines not implemented"); #endif } int do_dirop(optype,stab,gimme,arglast) int optype; STAB *stab; int gimme; int *arglast; { #if defined(DIRENT) && defined(READDIR) register ARRAY *ary = stack; register STR **st = ary->ary_array; register int sp = arglast[1]; register STIO *stio; long along; #ifndef telldir long telldir(); #endif struct DIRENT *readdir(); register struct DIRENT *dp; if (!stab) goto nope; if (!(stio = stab_io(stab))) stio = stab_io(stab) = stio_new(); if (!stio->dirp && optype != O_OPENDIR) goto nope; st[sp] = &str_yes; switch (optype) { case O_OPENDIR: if (stio->dirp) closedir(stio->dirp); if (!(stio->dirp = opendir(str_get(st[sp+1])))) goto nope; break; case O_READDIR: if (gimme == G_ARRAY) { --sp; while (dp = readdir(stio->dirp)) { #ifdef DIRNAMLEN (void)astore(ary,++sp, str_2static(str_make(dp->d_name,dp->d_namlen))); #else (void)astore(ary,++sp, str_2static(str_make(dp->d_name,0))); #endif } } else { if (!(dp = readdir(stio->dirp))) goto nope; st[sp] = str_static(&str_undef); #ifdef DIRNAMLEN str_nset(st[sp], dp->d_name, dp->d_namlen); #else str_set(st[sp], dp->d_name); #endif } break; case O_TELLDIR: st[sp] = str_static(&str_undef); str_numset(st[sp], (double)telldir(stio->dirp)); break; case O_SEEKDIR: st[sp] = str_static(&str_undef); along = (long)str_gnum(st[sp+1]); (void)seekdir(stio->dirp,along); break; case O_REWINDDIR: st[sp] = str_static(&str_undef); (void)rewinddir(stio->dirp); break; case O_CLOSEDIR: st[sp] = str_static(&str_undef); (void)closedir(stio->dirp); stio->dirp = 0; break; } return sp; nope: st[sp] = &str_undef; return sp; #else fatal("Unimplemented directory operation"); #endif } apply(type,arglast) int type; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int items = arglast[2] - sp; register int val; register int val2; register int tot = 0; char *s; #ifdef TAINT for (st += ++sp; items--; st++) tainted |= (*st)->str_tainted; st = stack->ary_array; sp = arglast[1]; items = arglast[2] - sp; #endif switch (type) { case O_CHMOD: #ifdef TAINT taintproper("Insecure dependency in chmod"); #endif if (--items > 0) { tot = items; val = (int)str_gnum(st[++sp]); while (items--) { if (chmod(str_get(st[++sp]),val)) tot--; } } break; case O_CHOWN: #ifdef TAINT taintproper("Insecure dependency in chown"); #endif if (items > 2) { items -= 2; tot = items; val = (int)str_gnum(st[++sp]); val2 = (int)str_gnum(st[++sp]); while (items--) { if (chown(str_get(st[++sp]),val,val2)) tot--; } } break; case O_KILL: #ifdef TAINT taintproper("Insecure dependency in kill"); #endif if (--items > 0) { tot = items; s = str_get(st[++sp]); if (isupper(*s)) { if (*s == 'S' && s[1] == 'I' && s[2] == 'G') s += 3; if (!(val = whichsig(s))) fatal("Unrecognized signal name \"%s\"",s); } else val = (int)str_gnum(st[sp]); if (val < 0) { val = -val; while (items--) { int proc = (int)str_gnum(st[++sp]); #ifdef KILLPG if (killpg(proc,val)) /* BSD */ #else if (kill(-proc,val)) /* SYSV */ #endif tot--; } } else { while (items--) { if (kill((int)(str_gnum(st[++sp])),val)) tot--; } } } break; case O_UNLINK: #ifdef TAINT taintproper("Insecure dependency in unlink"); #endif tot = items; while (items--) { s = str_get(st[++sp]); if (euid || unsafe) { if (UNLINK(s)) tot--; } else { /* don't let root wipe out directories without -U */ #ifdef LSTAT if (lstat(s,&statbuf) < 0 || #else if (stat(s,&statbuf) < 0 || #endif (statbuf.st_mode & S_IFMT) == S_IFDIR ) tot--; else { if (UNLINK(s)) tot--; } } } break; case O_UTIME: #ifdef TAINT taintproper("Insecure dependency in utime"); #endif if (items > 2) { #ifdef I_UTIME struct utimbuf utbuf; #else struct { long actime; long modtime; } utbuf; #endif Zero(&utbuf, sizeof utbuf, char); utbuf.actime = (long)str_gnum(st[++sp]); /* time accessed */ utbuf.modtime = (long)str_gnum(st[++sp]); /* time modified */ items -= 2; #ifndef lint tot = items; while (items--) { if (utime(str_get(st[++sp]),&utbuf)) tot--; } #endif } else items = 0; break; } return tot; } /* Do the permissions allow some operation? Assumes statcache already set. */ int cando(bit, effective, statbufp) int bit; int effective; register struct stat *statbufp; { if ((effective ? euid : uid) == 0) { /* root is special */ if (bit == S_IEXEC) { if (statbufp->st_mode & 0111 || (statbufp->st_mode & S_IFMT) == S_IFDIR ) return TRUE; } else return TRUE; /* root reads and writes anything */ return FALSE; } if (statbufp->st_uid == (effective ? euid : uid) ) { if (statbufp->st_mode & bit) return TRUE; /* ok as "user" */ } else if (ingroup((int)statbufp->st_gid,effective)) { if (statbufp->st_mode & bit >> 3) return TRUE; /* ok as "group" */ } else if (statbufp->st_mode & bit >> 6) return TRUE; /* ok as "other" */ return FALSE; } int ingroup(testgid,effective) int testgid; int effective; { if (testgid == (effective ? egid : gid)) return TRUE; #ifdef GETGROUPS #ifndef NGROUPS #define NGROUPS 32 #endif { GIDTYPE gary[NGROUPS]; int anum; anum = getgroups(NGROUPS,gary); while (--anum >= 0) if (gary[anum] == testgid) return TRUE; } #endif return FALSE; } de & bit >> 3) return TRUE; /* ok as "group" */ } else if (statbperl/regcomp.h 644 473 0 15356 4747105027 6672 /* $Header: regcomp.h,v 3.0 89/10/18 15:22:39 lwall Locked $ * * $Log: regcomp.h,v $ * Revision 3.0 89/10/18 15:22:39 lwall * 3.0 baseline * */ /* * The "internal use only" fields in regexp.h are present to pass info from * compile to execute that permits the execute phase to run lots faster on * simple cases. They are: * * regstart str that must begin a match; Nullch if none obvious * reganch is the match anchored (at beginning-of-line only)? * regmust string (pointer into program) that match must include, or NULL * [regmust changed to STR* for bminstr()--law] * regmlen length of regmust string * [regmlen not used currently] * * Regstart and reganch permit very fast decisions on suitable starting points * for a match, cutting down the work a lot. Regmust permits fast rejection * of lines that cannot possibly match. The regmust tests are costly enough * that regcomp() supplies a regmust only if the r.e. contains something * potentially expensive (at present, the only such thing detected is * or + * at the start of the r.e., which can involve a lot of backup). Regmlen is * supplied because the test in regexec() needs it and regcomp() is computing * it anyway. * [regmust is now supplied always. The tests that use regmust have a * heuristic that disables the test if it usually matches.] * * [In fact, we now use regmust in many cases to locate where the search * starts in the string, so if regback is >= 0, the regmust search is never * wasted effort. The regback variable says how many characters back from * where regmust matched is the earliest possible start of the match. * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.] */ /* * Structure for regexp "program". This is essentially a linear encoding * of a nondeterministic finite-state machine (aka syntax charts or * "railroad normal form" in parsing technology). Each node is an opcode * plus a "next" pointer, possibly plus an operand. "Next" pointers of * all nodes except BRANCH implement concatenation; a "next" pointer with * a BRANCH on both ends of it is connecting two alternatives. (Here we * have one of the subtle syntax dependencies: an individual BRANCH (as * opposed to a collection of them) is never concatenated with anything * because of operator precedence.) The operand of some types of node is * a literal string; for others, it is a node leading into a sub-FSM. In * particular, the operand of a BRANCH node is the first node of the branch. * (NB this is *not* a tree structure: the tail of the branch connects * to the thing following the set of BRANCHes.) The opcodes are: */ /* definition number opnd? meaning */ #define END 0 /* no End of program. */ #define BOL 1 /* no Match "" at beginning of line. */ #define EOL 2 /* no Match "" at end of line. */ #define ANY 3 /* no Match any one character. */ #define ANYOF 4 /* str Match any character in this string. */ #define ANYBUT 5 /* str Match any character not in this string. */ #define BRANCH 6 /* node Match this alternative, or the next... */ #define BACK 7 /* no Match "", "next" ptr points backward. */ #define EXACTLY 8 /* str Match this string (preceded by length). */ #define NOTHING 9 /* no Match empty string. */ #define STAR 10 /* node Match this (simple) thing 0 or more times. */ #define PLUS 11 /* node Match this (simple) thing 1 or more times. */ #define ALNUM 12 /* no Match any alphanumeric character */ #define NALNUM 13 /* no Match any non-alphanumeric character */ #define BOUND 14 /* no Match "" at any word boundary */ #define NBOUND 15 /* no Match "" at any word non-boundary */ #define SPACE 16 /* no Match any whitespace character */ #define NSPACE 17 /* no Match any non-whitespace character */ #define DIGIT 18 /* no Match any numeric character */ #define NDIGIT 19 /* no Match any non-numeric character */ #define REF 20 /* no Match some already matched string */ #define OPEN 30 /* no Mark this point in input as start of #n. */ /* OPEN+1 is number 1, etc. */ #define CLOSE 40 /* no Analogous to OPEN. */ /* CLOSE must be last one! see regmust finder */ /* * Opcode notes: * * BRANCH The set of branches constituting a single choice are hooked * together with their "next" pointers, since precedence prevents * anything being concatenated to any individual branch. The * "next" pointer of the last BRANCH in a choice points to the * thing following the whole choice. This is also where the * final "next" pointer of each individual branch points; each * branch starts with the operand node of a BRANCH node. * * BACK Normal "next" pointers all implicitly point forward; BACK * exists to make loop structures possible. * * STAR,PLUS '?', and complex '*' and '+', are implemented as circular * BRANCH structures using BACK. Simple cases (one character * per match) are implemented with STAR and PLUS for speed * and to minimize recursive plunges. * * OPEN,CLOSE ...are numbered at compile time. */ /* The following have no fixed length. */ #ifndef DOINIT extern char varies[]; #else char varies[] = {BRANCH,BACK,STAR,PLUS, REF+1,REF+2,REF+3,REF+4,REF+5,REF+6,REF+7,REF+8,REF+9,0}; #endif /* The following always have a length of 1. */ #ifndef DOINIT extern char simple[]; #else char simple[] = {ANY,ANYOF,ANYBUT,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0}; #endif EXT char regdummy; /* * A node is one char of opcode followed by two chars of "next" pointer. * "Next" pointers are stored as two 8-bit pieces, high order first. The * value is a positive offset from the opcode of the node containing it. * An operand, if any, simply follows the node. (Note that much of the * code generation knows about this implicit relationship.) * * Using two bytes for the "next" pointer is vast overkill for most things, * but allows patterns to get big without disasters. * * [If REGALIGN is defined, the "next" pointer is always aligned on an even * boundary, and reads the offset directly as a short. Also, there is no * special test to reverse the sign of BACK pointers since the offset is * stored negative.] */ #ifndef gould #ifndef cray #define REGALIGN #endif #endif #define OP(p) (*(p)) #ifndef lint #ifdef REGALIGN #define NEXT(p) (*(short*)(p+1)) #else #define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) #endif #else /* lint */ #define NEXT(p) 0 #endif /* lint */ #define OPERAND(p) ((p) + 3) #ifdef REGALIGN #define NEXTOPER(p) ((p) + 4) #else #define NEXTOPER(p) ((p) + 3) #endif #define MAGIC 0234 /* * Utility definitions. */ #ifndef lint #ifndef CHARBITS #define UCHARAT(p) ((int)*(unsigned char *)(p)) #else #define UCHARAT(p) ((int)*(p)&CHARBITS) #endif #else /* lint */ #define UCHARAT(p) regdummy #endif /* lint */ #define FAIL(m) fatal("/%s/: %s",regprecomp,m) char *regnext(); #ifdef DEBUGGING void regdump(); char *regprop(); #endif ) 0 #endif /* lint */ #define OPERAND(p) ((p) + 3) #ifdef REGALIGN #define NEXTOPER(p) ((p) + 4) #else #define NEXTOPER(p) ((p) + 3) #endif #define MAGIC 0234 /* * Utility definitions. */ #ifndef lint #ifndef CHARBITS #define UCHARAT(p) ((int)*(unsigned char *)(p)) #eperl/perl.man.3 644 473 0 114233 4747105027 6677 ''' Beginning of part 3 ''' $Header: perl.man.3,v 3.0.1.4 90/02/28 18:00:09 lwall Locked $ ''' ''' $Log: perl.man.3,v $ ''' Revision 3.0.1.4 90/02/28 18:00:09 lwall ''' patch9: added pipe function ''' patch9: documented how to handle arbitrary weird characters in filenames ''' patch9: documented the unflushed buffers problem on piped opens ''' patch9: documented how to force top of page ''' ''' Revision 3.0.1.3 89/12/21 20:10:12 lwall ''' patch7: documented that s`pat`repl` does command substitution on replacement ''' patch7: documented that $timeleft from select() is likely not implemented ''' ''' Revision 3.0.1.2 89/11/17 15:31:05 lwall ''' patch5: fixed some manual typos and indent problems ''' patch5: added warning about print making an array context ''' ''' Revision 3.0.1.1 89/11/11 04:45:06 lwall ''' patch2: made some line breaks depend on troff vs. nroff ''' ''' Revision 3.0 89/10/18 15:21:46 lwall ''' 3.0 baseline ''' .Ip "next LABEL" 8 8 .Ip "next" 8 The .I next command is like the .I continue statement in C; it starts the next iteration of the loop: .nf .ne 4 line: while () { next line if /\|^#/; # discard comments .\|.\|. } .fi Note that if there were a .I continue block on the above, it would get executed even on discarded lines. If the LABEL is omitted, the command refers to the innermost enclosing loop. .Ip "oct(EXPR)" 8 4 .Ip "oct EXPR" 8 Returns the decimal value of EXPR interpreted as an octal string. (If EXPR happens to start off with 0x, interprets it as a hex string instead.) The following will handle decimal, octal and hex in the standard notation: .nf $val = oct($val) if $val =~ /^0/; .fi If EXPR is omitted, uses $_. .Ip "open(FILEHANDLE,EXPR)" 8 8 .Ip "open(FILEHANDLE)" 8 .Ip "open FILEHANDLE" 8 Opens the file whose filename is given by EXPR, and associates it with FILEHANDLE. If FILEHANDLE is an expression, its value is used as the name of the real filehandle wanted. If EXPR is omitted, the scalar variable of the same name as the FILEHANDLE contains the filename. If the filename begins with \*(L"<\*(R" or nothing, the file is opened for input. If the filename begins with \*(L">\*(R", the file is opened for output. If the filename begins with \*(L">>\*(R", the file is opened for appending. (You can put a \'+\' in front of the \'>\' or \'<\' to indicate that you want both read and write access to the file.) If the filename begins with \*(L"|\*(R", the filename is interpreted as a command to which output is to be piped, and if the filename ends with a \*(L"|\*(R", the filename is interpreted as command which pipes input to us. (You may not have a command that pipes both in and out.) Opening \'\-\' opens .I STDIN and opening \'>\-\' opens .IR STDOUT . Open returns non-zero upon success, the undefined value otherwise. If the open involved a pipe, the return value happens to be the pid of the subprocess. Examples: .nf .ne 3 $article = 100; open article || die "Can't find article $article: $!\en"; while (
) {\|.\|.\|. .ie t \{\ open(LOG, \'>>/usr/spool/news/twitlog\'\|); # (log is reserved) 'br\} .el \{\ open(LOG, \'>>/usr/spool/news/twitlog\'\|); # (log is reserved) 'br\} .ie t \{\ open(article, "caesar <$article |"\|); # decrypt article 'br\} .el \{\ open(article, "caesar <$article |"\|); # decrypt article 'br\} .ie t \{\ open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process# 'br\} .el \{\ open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process# 'br\} .ne 7 # process argument list of files along with any includes foreach $file (@ARGV) { do process($file, \'fh00\'); # no pun intended } sub process { local($filename, $input) = @_; $input++; # this is a string increment unless (open($input, $filename)) { print STDERR "Can't open $filename: $!\en"; return; } .ie t \{\ while (<$input>) { # note the use of indirection 'br\} .el \{\ while (<$input>) { # note use of indirection 'br\} if (/^#include "(.*)"/) { do process($1, $input); next; } .\|.\|. # whatever } } .fi You may also, in the Bourne shell tradition, specify an EXPR beginning with \*(L">&\*(R", in which case the rest of the string is interpreted as the name of a filehandle (or file descriptor, if numeric) which is to be duped and opened. You may use & after >, >>, <, +>, +>> and +<. The mode you specify should match the mode of the original filehandle. Here is a script that saves, redirects, and restores .I STDOUT and .IR STDERR : .nf .ne 21 #!/usr/bin/perl open(SAVEOUT, ">&STDOUT"); open(SAVEERR, ">&STDERR"); open(STDOUT, ">foo.out") || die "Can't redirect stdout"; open(STDERR, ">&STDOUT") || die "Can't dup stdout"; select(STDERR); $| = 1; # make unbuffered select(STDOUT); $| = 1; # make unbuffered print STDOUT "stdout 1\en"; # this works for print STDERR "stderr 1\en"; # subprocesses too close(STDOUT); close(STDERR); open(STDOUT, ">&SAVEOUT"); open(STDERR, ">&SAVEERR"); print STDOUT "stdout 2\en"; print STDERR "stderr 2\en"; .fi If you open a pipe on the command \*(L"\-\*(R", i.e. either \*(L"|\-\*(R" or \*(L"\-|\*(R", then there is an implicit fork done, and the return value of open is the pid of the child within the parent process, and 0 within the child process. (Use defined($pid) to determine if the open was successful.) The filehandle behaves normally for the parent, but i/o to that filehandle is piped from/to the .IR STDOUT / STDIN of the child process. In the child process the filehandle isn't opened\*(--i/o happens from/to the new .I STDOUT or .IR STDIN . Typically this is used like the normal piped open when you want to exercise more control over just how the pipe command gets executed, such as when you are running setuid, and don't want to have to scan shell commands for metacharacters. The following pairs are equivalent: .nf .ne 5 open(FOO, "|tr \'[a\-z]\' \'[A\-Z]\'"); open(FOO, "|\-") || exec \'tr\', \'[a\-z]\', \'[A\-Z]\'; open(FOO, "cat \-n $file|"); open(FOO, "\-|") || exec \'cat\', \'\-n\', $file; .fi Explicitly closing any piped filehandle causes the parent process to wait for the child to finish, and returns the status value in $?. Note: on any operation which may do a fork, unflushed buffers remain unflushed in both processes, which means you may need to set $| to avoid duplicate output. .Sp The filename that is passed to open will have leading and trailing whitespace deleted. In order to open a file with arbitrary weird characters in it, it's necessary to protect any leading and trailing whitespace thusly: .nf .ne 2 $file =~ s#^(\es)#./$1#; open(FOO, "< $file\e0"); .fi .Ip "opendir(DIRHANDLE,EXPR)" 8 3 Opens a directory named EXPR for processing by readdir(), telldir(), seekdir(), rewinddir() and closedir(). Returns true if successful. DIRHANDLEs have their own namespace separate from FILEHANDLEs. .Ip "ord(EXPR)" 8 4 .Ip "ord EXPR" 8 Returns the ascii value of the first character of EXPR. If EXPR is omitted, uses $_. .Ip "pack(TEMPLATE,LIST)" 8 4 Takes an array or list of values and packs it into a binary structure, returning the string containing the structure. The TEMPLATE is a sequence of characters that give the order and type of values, as follows: .nf A An ascii string, will be space padded. a An ascii string, will be null padded. c A native char value. C An unsigned char value. s A signed short value. S An unsigned short value. i A signed integer value. I An unsigned integer value. l A signed long value. L An unsigned long value. n A short in \*(L"network\*(R" order. N A long in \*(L"network\*(R" order. p A pointer to a string. x A null byte. .fi Each letter may optionally be followed by a number which gives a repeat count. With all types except "a" and "A" the pack function will gobble up that many values from the LIST. The "a" and "A" types gobble just one value, but pack it as a string that long, padding with nulls or spaces as necessary. (When unpacking, "A" strips trailing spaces and nulls, but "a" does not.) Examples: .nf $foo = pack("cccc",65,66,67,68); # foo eq "ABCD" $foo = pack("c4",65,66,67,68); # same thing $foo = pack("ccxxcc",65,66,67,68); # foo eq "AB\e0\e0CD" $foo = pack("s2",1,2); # "\e1\e0\e2\e0" on little-endian # "\e0\e1\e0\e2" on big-endian $foo = pack("a4","abcd","x","y","z"); # "abcd" $foo = pack("aaaa","abcd","x","y","z"); # "axyz" $foo = pack("a14","abcdefg"); # "abcdefg\e0\e0\e0\e0\e0\e0\e0" $foo = pack("i9pl", gmtime); # a real struct tm (on my system anyway) .fi The same template may generally also be used in the unpack function. .Ip "pipe(READHANDLE,WRITEHANDLE)" 8 3 Opens a pair of connected pipes like the corresponding system call. Note that if you set up a loop of piped processes, deadlock can occur unless you are very careful. In addition, note that perl's pipes use stdio buffering, so you may need to set $| to flush your WRITEHANDLE after each command, depending on the application. [Requires version 3.0 patchlevel 9.] .Ip "pop(ARRAY)" 8 .Ip "pop ARRAY" 8 6 Pops and returns the last value of the array, shortening the array by 1. Has the same effect as .nf $tmp = $ARRAY[$#ARRAY\-\|\-]; .fi If there are no elements in the array, returns the undefined value. .Ip "print(FILEHANDLE LIST)" 8 10 .Ip "print(LIST)" 8 .Ip "print FILEHANDLE LIST" 8 .Ip "print LIST" 8 .Ip "print" 8 Prints a string or a comma-separated list of strings. Returns non-zero if successful. FILEHANDLE may be a scalar variable name, in which case the variable contains the name of the filehandle, thus introducing one level of indirection. If FILEHANDLE is omitted, prints by default to standard output (or to the last selected output channel\*(--see select()). If LIST is also omitted, prints $_ to .IR STDOUT . To set the default output channel to something other than .I STDOUT use the select operation. Note that, because print takes a LIST, anything in the LIST is evaluated in an array context, and any subroutine that you call will have one or more of its expressions evaluated in an array context. .Ip "printf(FILEHANDLE LIST)" 8 10 .Ip "printf(LIST)" 8 .Ip "printf FILEHANDLE LIST" 8 .Ip "printf LIST" 8 Equivalent to a \*(L"print FILEHANDLE sprintf(LIST)\*(R". .Ip "push(ARRAY,LIST)" 8 7 Treats ARRAY (@ is optional) as a stack, and pushes the values of LIST onto the end of ARRAY. The length of ARRAY increases by the length of LIST. Has the same effect as .nf for $value (LIST) { $ARRAY[++$#ARRAY] = $value; } .fi but is more efficient. .Ip "q/STRING/" 8 5 .Ip "qq/STRING/" 8 These are not really functions, but simply syntactic sugar to let you avoid putting too many backslashes into quoted strings. The q operator is a generalized single quote, and the qq operator a generalized double quote. Any delimiter can be used in place of /, including newline. If the delimiter is an opening bracket or parenthesis, the final delimiter will be the corresponding closing bracket or parenthesis. (Embedded occurrences of the closing bracket need to be backslashed as usual.) Examples: .nf .ne 5 $foo = q!I said, "You said, \'She said it.\'"!; $bar = q(\'This is it.\'); $_ .= qq *** The previous line contains the naughty word "$&".\en if /(ibm|apple|awk)/; # :-) .fi .Ip "rand(EXPR)" 8 8 .Ip "rand EXPR" 8 .Ip "rand" 8 Returns a random fractional number between 0 and the value of EXPR. (EXPR should be positive.) If EXPR is omitted, returns a value between 0 and 1. See also srand(). .Ip "read(FILEHANDLE,SCALAR,LENGTH)" 8 5 Attempts to read LENGTH bytes of data into variable SCALAR from the specified FILEHANDLE. Returns the number of bytes actually read. SCALAR will be grown or shrunk to the length actually read. .Ip "readdir(DIRHANDLE)" 8 3 .Ip "readdir DIRHANDLE" 8 Returns the next directory entry for a directory opened by opendir(). If used in an array context, returns all the rest of the entries in the directory. If there are no more entries, returns an undefined value in a scalar context or a null list in an array context. .Ip "readlink(EXPR)" 8 6 .Ip "readlink EXPR" 8 Returns the value of a symbolic link, if symbolic links are implemented. If not, gives a fatal error. If there is some system error, returns the undefined value and sets $! (errno). If EXPR is omitted, uses $_. .Ip "recv(SOCKET,SCALAR,LEN,FLAGS)" 8 4 Receives a message on a socket. Attempts to receive LENGTH bytes of data into variable SCALAR from the specified SOCKET filehandle. Returns the address of the sender, or the undefined value if there's an error. SCALAR will be grown or shrunk to the length actually read. Takes the same flags as the system call of the same name. .Ip "redo LABEL" 8 8 .Ip "redo" 8 The .I redo command restarts the loop block without evaluating the conditional again. The .I continue block, if any, is not executed. If the LABEL is omitted, the command refers to the innermost enclosing loop. This command is normally used by programs that want to lie to themselves about what was just input: .nf .ne 16 # a simpleminded Pascal comment stripper # (warning: assumes no { or } in strings) line: while () { while (s|\|({.*}.*\|){.*}|$1 \||) {} s|{.*}| \||; if (s|{.*| \||) { $front = $_; while () { if (\|/\|}/\|) { # end of comment? s|^|$front{|; redo line; } } } print; } .fi .Ip "rename(OLDNAME,NEWNAME)" 8 2 Changes the name of a file. Returns 1 for success, 0 otherwise. Will not work across filesystem boundaries. .Ip "reset(EXPR)" 8 6 .Ip "reset EXPR" 8 .Ip "reset" 8 Generally used in a .I continue block at the end of a loop to clear variables and reset ?? searches so that they work again. The expression is interpreted as a list of single characters (hyphens allowed for ranges). All variables and arrays beginning with one of those letters are reset to their pristine state. If the expression is omitted, one-match searches (?pattern?) are reset to match again. Only resets variables or searches in the current package. Always returns 1. Examples: .nf .ne 3 reset \'X\'; \h'|2i'# reset all X variables reset \'a\-z\';\h'|2i'# reset lower case variables reset; \h'|2i'# just reset ?? searches .fi Note: resetting \*(L"A\-Z\*(R" is not recommended since you'll wipe out your ARGV and ENV arrays. .Sp The use of reset on dbm associative arrays does not change the dbm file. (It does, however, flush any entries cached by perl, which may be useful if you are sharing the dbm file. Then again, maybe not.) .Ip "return LIST" 8 3 Returns from a subroutine with the value specified. (Note that a subroutine can automatically return the value of the last expression evaluated. That's the preferred method\*(--use of an explicit .I return is a bit slower.) .Ip "reverse(LIST)" 8 4 .Ip "reverse LIST" 8 Returns an array value consisting of the elements of LIST in the opposite order. .Ip "rewinddir(DIRHANDLE)" 8 5 .Ip "rewinddir DIRHANDLE" 8 Sets the current position to the beginning of the directory for the readdir() routine on DIRHANDLE. .Ip "rindex(STR,SUBSTR)" 8 4 Works just like index except that it returns the position of the LAST occurrence of SUBSTR in STR. .Ip "rmdir(FILENAME)" 8 4 .Ip "rmdir FILENAME" 8 Deletes the directory specified by FILENAME if it is empty. If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). If FILENAME is omitted, uses $_. .Ip "s/PATTERN/REPLACEMENT/gieo" 8 3 Searches a string for a pattern, and if found, replaces that pattern with the replacement text and returns the number of substitutions made. Otherwise it returns false (0). The \*(L"g\*(R" is optional, and if present, indicates that all occurrences of the pattern are to be replaced. The \*(L"i\*(R" is also optional, and if present, indicates that matching is to be done in a case-insensitive manner. The \*(L"e\*(R" is likewise optional, and if present, indicates that the replacement string is to be evaluated as an expression rather than just as a double-quoted string. Any delimiter may replace the slashes; if single quotes are used, no interpretation is done on the replacement string (the e modifier overrides this, however); if backquotes are used, the replacement string is a command to execute whose output will be used as the actual replacement text. If no string is specified via the =~ or !~ operator, the $_ string is searched and modified. (The string specified with =~ must be a scalar variable, an array element, or an assignment to one of those, i.e. an lvalue.) If the pattern contains a $ that looks like a variable rather than an end-of-string test, the variable will be interpolated into the pattern at run-time. If you only want the pattern compiled once the first time the variable is interpolated, add an \*(L"o\*(R" at the end. See also the section on regular expressions. Examples: .nf s/\|\e\|bgreen\e\|b/mauve/g; # don't change wintergreen $path \|=~ \|s|\|/usr/bin|\|/usr/local/bin|; s/Login: $foo/Login: $bar/; # run-time pattern ($foo = $bar) =~ s/bar/foo/; $_ = \'abc123xyz\'; s/\ed+/$&*2/e; # yields \*(L'abc246xyz\*(R' s/\ed+/sprintf("%5d",$&)/e; # yields \*(L'abc 246xyz\*(R' s/\ew/$& x 2/eg; # yields \*(L'aabbcc 224466xxyyzz\*(R' s/\|([^ \|]*\|) *\|([^ \|]*\|)\|/\|$2 $1/; # reverse 1st two fields .fi (Note the use of $ instead of \|\e\| in the last example. See section on regular expressions.) .Ip "seek(FILEHANDLE,POSITION,WHENCE)" 8 3 Randomly positions the file pointer for FILEHANDLE, just like the fseek() call of stdio. FILEHANDLE may be an expression whose value gives the name of the filehandle. Returns 1 upon success, 0 otherwise. .Ip "seekdir(DIRHANDLE,POS)" 8 3 Sets the current position for the readdir() routine on DIRHANDLE. POS must be a value returned by seekdir(). Has the same caveats about possible directory compaction as the corresponding system library routine. .Ip "select(FILEHANDLE)" 8 3 .Ip "select" 8 3 Returns the currently selected filehandle. Sets the current default filehandle for output, if FILEHANDLE is supplied. This has two effects: first, a .I write or a .I print without a filehandle will default to this FILEHANDLE. Second, references to variables related to output will refer to this output channel. For example, if you have to set the top of form format for more than one output channel, you might do the following: .nf .ne 4 select(REPORT1); $^ = \'report1_top\'; select(REPORT2); $^ = \'report2_top\'; .fi FILEHANDLE may be an expression whose value gives the name of the actual filehandle. Thus: .nf $oldfh = select(STDERR); $| = 1; select($oldfh); .fi .Ip "select(RBITS,WBITS,EBITS,TIMEOUT)" 8 3 This calls the select system call with the bitmasks specified, which can be constructed using fileno() and vec(), along these lines: .nf $rin = $win = $ein = ''; vec($rin,fileno(STDIN),1) = 1; vec($win,fileno(STDOUT),1) = 1; $ein = $rin | $win; .fi If you want to select on many filehandles you might wish to write a subroutine: .nf sub fhbits { local(@fhlist) = split(' ',$_[0]); local($bits); for (@fhlist) { vec($bits,fileno($_),1) = 1; } $bits; } $rin = &fhbits('STDIN TTY SOCK'); .fi The usual idiom is: .nf ($nfound,$timeleft) = select($rout=$rin, $wout=$win, $eout=$ein, $timeout); or to block until something becomes ready: .ie t \{\ $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef); 'br\} .el \{\ $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef); 'br\} .fi Any of the bitmasks can also be undef. The timeout, if specified, is in seconds, which may be fractional. NOTE: not all implementations are capable of returning the $timeleft. If not, they always return $timeleft equal to the supplied $timeout. .Ip "setpgrp(PID,PGRP)" 8 4 Sets the current process group for the specified PID, 0 for the current process. Will produce a fatal error if used on a machine that doesn't implement setpgrp(2). .Ip "send(SOCKET,MSG,FLAGS,TO)" 8 4 .Ip "send(SOCKET,MSG,FLAGS)" 8 Sends a message on a socket. Takes the same flags as the system call of the same name. On unconnected sockets you must specify a destination to send TO. Returns the number of characters sent, or the undefined value if there is an error. .Ip "setpriority(WHICH,WHO,PRIORITY)" 8 4 Sets the current priority for a process, a process group, or a user. (See setpriority(2).) Will produce a fatal error if used on a machine that doesn't implement setpriority(2). .Ip "setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)" 8 3 Sets the socket option requested. Returns undefined if there is an error. OPTVAL may be specified as undef if you don't want to pass an argument. .Ip "shift(ARRAY)" 8 6 .Ip "shift ARRAY" 8 .Ip "shift" 8 Shifts the first value of the array off and returns it, shortening the array by 1 and moving everything down. If there are no elements in the array, returns the undefined value. If ARRAY is omitted, shifts the @ARGV array in the main program, and the @_ array in subroutines. See also unshift(), push() and pop(). Shift() and unshift() do the same thing to the left end of an array that push() and pop() do to the right end. .Ip "shutdown(SOCKET,HOW)" 8 3 Shuts down a socket connection in the manner indicated by HOW, which has the same interpretation as in the system call of the same name. .Ip "sin(EXPR)" 8 4 .Ip "sin EXPR" 8 Returns the sine of EXPR (expressed in radians). If EXPR is omitted, returns sine of $_. .Ip "sleep(EXPR)" 8 6 .Ip "sleep EXPR" 8 .Ip "sleep" 8 Causes the script to sleep for EXPR seconds, or forever if no EXPR. May be interrupted by sending the process a SIGALARM. Returns the number of seconds actually slept. .Ip "socket(SOCKET,DOMAIN,TYPE,PROTOCOL)" 8 3 Opens a socket of the specified kind and attaches it to filehandle SOCKET. DOMAIN, TYPE and PROTOCOL are specified the same as for the system call of the same name. You may need to run makelib on sys/socket.h to get the proper values handy in a perl library file. Return true if successful. See the example in the section on Interprocess Communication. .Ip "socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)" 8 3 Creates an unnamed pair of sockets in the specified domain, of the specified type. DOMAIN, TYPE and PROTOCOL are specified the same as for the system call of the same name. If unimplemented, yields a fatal error. Return true if successful. .Ip "sort(SUBROUTINE LIST)" 8 9 .Ip "sort(LIST)" 8 .Ip "sort SUBROUTINE LIST" 8 .Ip "sort LIST" 8 Sorts the LIST and returns the sorted array value. Nonexistent values of arrays are stripped out. If SUBROUTINE is omitted, sorts in standard string comparison order. If SUBROUTINE is specified, gives the name of a subroutine that returns an integer less than, equal to, or greater than 0, depending on how the elements of the array are to be ordered. In the interests of efficiency the normal calling code for subroutines is bypassed, with the following effects: the subroutine may not be a recursive subroutine, and the two elements to be compared are passed into the subroutine not via @_ but as $a and $b (see example below). They are passed by reference so don't modify $a and $b. SUBROUTINE may be a scalar variable name, in which case the value provides the name of the subroutine to use. Examples: .nf .ne 4 sub byage { $age{$a} - $age{$b}; # presuming integers } @sortedclass = sort byage @class; .ne 9 sub reverse { $a lt $b ? 1 : $a gt $b ? \-1 : 0; } @harry = (\'dog\',\'cat\',\'x\',\'Cain\',\'Abel\'); @george = (\'gone\',\'chased\',\'yz\',\'Punished\',\'Axed\'); print sort @harry; # prints AbelCaincatdogx print sort reverse @harry; # prints xdogcatCainAbel print sort @george, \'to\', @harry; # prints AbelAxedCainPunishedcatchaseddoggonetoxyz .fi .Ip "split(/PATTERN/,EXPR,LIMIT)" 8 8 .Ip "split(/PATTERN/,EXPR)" 8 8 .Ip "split(/PATTERN/)" 8 .Ip "split" 8 Splits a string into an array of strings, and returns it. (If not in an array context, returns the number of fields found and splits into the @_ array. (In an array context, you can force the split into @_ by using ?? as the pattern delimiters, but it still returns the array value.)) If EXPR is omitted, splits the $_ string. If PATTERN is also omitted, splits on whitespace (/[\ \et\en]+/). Anything matching PATTERN is taken to be a delimiter separating the fields. (Note that the delimiter may be longer than one character.) If LIMIT is specified, splits into no more than that many fields (though it may split into fewer). If LIMIT is unspecified, trailing null fields are stripped (which potential users of pop() would do well to remember). A pattern matching the null string (not to be confused with a null pattern, which is one member of the set of patterns matching a null string) will split the value of EXPR into separate characters at each point it matches that way. For example: .nf print join(\':\', split(/ */, \'hi there\')); .fi produces the output \*(L'h:i:t:h:e:r:e\*(R'. .Sp The LIMIT parameter can be used to partially split a line .nf ($login, $passwd, $remainder) = split(\|/\|:\|/\|, $_, 3); .fi (When assigning to a list, if LIMIT is omitted, perl supplies a LIMIT one larger than the number of variables in the list, to avoid unnecessary work. For the list above LIMIT would have been 4 by default. In time critical applications it behooves you not to split into more fields than you really need.) .Sp If the PATTERN contains parentheses, additional array elements are created from each matching substring in the delimiter. .Sp split(/([,-])/,"1-10,20"); .Sp produces the array value .Sp (1,'-',10,',',20) .Sp The pattern /PATTERN/ may be replaced with an expression to specify patterns that vary at runtime. (To do runtime compilation only once, use /$variable/o.) As a special case, specifying a space (\'\ \') will split on white space just as split with no arguments does, but leading white space does NOT produce a null first field. Thus, split(\'\ \') can be used to emulate .IR awk 's default behavior, whereas split(/\ /) will give you as many null initial fields as there are leading spaces. .Sp Example: .nf .ne 5 open(passwd, \'/etc/passwd\'); while () { .ie t \{\ ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(\|/\|:\|/\|); 'br\} .el \{\ ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(\|/\|:\|/\|); 'br\} .\|.\|. } .fi (Note that $shell above will still have a newline on it. See chop().) See also .IR join . .Ip "sprintf(FORMAT,LIST)" 8 4 Returns a string formatted by the usual printf conventions. The * character is not supported. .Ip "sqrt(EXPR)" 8 4 .Ip "sqrt EXPR" 8 Return the square root of EXPR. If EXPR is omitted, returns square root of $_. .Ip "srand(EXPR)" 8 4 .Ip "srand EXPR" 8 Sets the random number seed for the .I rand operator. If EXPR is omitted, does srand(time). .Ip "stat(FILEHANDLE)" 8 8 .Ip "stat FILEHANDLE" 8 .Ip "stat(EXPR)" 8 .Ip "stat SCALARVARIABLE" 8 Returns a 13-element array giving the statistics for a file, either the file opened via FILEHANDLE, or named by EXPR. Typically used as follows: .nf .ne 3 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($filename); .fi If stat is passed the special filehandle consisting of an underline, no stat is done, but the current contents of the stat structure from the last stat or filetest are returned. Example: .nf .ne 3 if (-x $file && (($d) = stat(_)) && $d < 0) { print "$file is executable NFS file\en"; } .fi .Ip "study(SCALAR)" 8 6 .Ip "study SCALAR" 8 .Ip "study" Takes extra time to study SCALAR ($_ if unspecified) in anticipation of doing many pattern matches on the string before it is next modified. This may or may not save time, depending on the nature and number of patterns you are searching on, and on the distribution of character frequencies in the string to be searched\*(--you probably want to compare runtimes with and without it to see which runs faster. Those loops which scan for many short constant strings (including the constant parts of more complex patterns) will benefit most. You may have only one study active at a time\*(--if you study a different scalar the first is \*(L"unstudied\*(R". (The way study works is this: a linked list of every character in the string to be searched is made, so we know, for example, where all the \*(L'k\*(R' characters are. From each search string, the rarest character is selected, based on some static frequency tables constructed from some C programs and English text. Only those places that contain this \*(L"rarest\*(R" character are examined.) .Sp For example, here is a loop which inserts index producing entries before any line containing a certain pattern: .nf .ne 8 while (<>) { study; print ".IX foo\en" if /\ebfoo\eb/; print ".IX bar\en" if /\ebbar\eb/; print ".IX blurfl\en" if /\ebblurfl\eb/; .\|.\|. print; } .fi In searching for /\ebfoo\eb/, only those locations in $_ that contain \*(L'f\*(R' will be looked at, because \*(L'f\*(R' is rarer than \*(L'o\*(R'. In general, this is a big win except in pathological cases. The only question is whether it saves you more time than it took to build the linked list in the first place. .Sp Note that if you have to look for strings that you don't know till runtime, you can build an entire loop as a string and eval that to avoid recompiling all your patterns all the time. Together with setting $/ to input entire files as one record, this can be very fast, often faster than specialized programs like fgrep. The following scans a list of files (@files) for a list of words (@words), and prints out the names of those files that contain a match: .nf .ne 12 $search = \'while (<>) { study;\'; foreach $word (@words) { $search .= "++\e$seen{\e$ARGV} if /\eb$word\eb/;\en"; } $search .= "}"; @ARGV = @files; $/ = "\e177"; # something that doesn't occur eval $search; # this screams $/ = "\en"; # put back to normal input delim foreach $file (sort keys(%seen)) { print $file, "\en"; } .fi .Ip "substr(EXPR,OFFSET,LEN)" 8 2 Extracts a substring out of EXPR and returns it. First character is at offset 0, or whatever you've set $[ to. If OFFSET is negative, starts that far from the end of the string. You can use the substr() function as an lvalue, in which case EXPR must be an lvalue. If you assign something shorter than LEN, the string will shrink, and if you assign something longer than LEN, the string will grow to accommodate it. To keep the string the same length you may need to pad or chop your value using sprintf(). .Ip "syscall(LIST)" 8 6 .Ip "syscall LIST" 8 Calls the system call specified as the first element of the list, passing the remaining elements as arguments to the system call. If unimplemented, produces a fatal error. The arguments are interpreted as follows: if a given argument is numeric, the argument is passed as an int. If not, the pointer to the string value is passed. You are responsible to make sure a string is pre-extended long enough to receive any result that might be written into a string. If your integer arguments are not literals and have never been interpreted in a numeric context, you may need to add 0 to them to force them to look like numbers. .nf do 'syscall.h'; # may need to run makelib syscall(&SYS_write, fileno(STDOUT), "hi there\en", 9); .fi .Ip "system(LIST)" 8 6 .Ip "system LIST" 8 Does exactly the same thing as \*(L"exec LIST\*(R" except that a fork is done first, and the parent process waits for the child process to complete. Note that argument processing varies depending on the number of arguments. The return value is the exit status of the program as returned by the wait() call. To get the actual exit value divide by 256. See also .IR exec . .Ip "symlink(OLDFILE,NEWFILE)" 8 2 Creates a new filename symbolically linked to the old filename. Returns 1 for success, 0 otherwise. On systems that don't support symbolic links, produces a fatal error at run time. To check for that, use eval: .nf $symlink_exists = (eval \'symlink("","");\', $@ eq \'\'); .fi .Ip "tell(FILEHANDLE)" 8 6 .Ip "tell FILEHANDLE" 8 6 .Ip "tell" 8 Returns the current file position for FILEHANDLE. FILEHANDLE may be an expression whose value gives the name of the actual filehandle. If FILEHANDLE is omitted, assumes the file last read. .Ip "telldir(DIRHANDLE)" 8 5 .Ip "telldir DIRHANDLE" 8 Returns the current position of the readdir() routines on DIRHANDLE. Value may be given to seekdir() to access a particular location in a directory. Has the same caveats about possible directory compaction as the corresponding system library routine. .Ip "time" 8 4 Returns the number of non-leap seconds since January 1, 1970, UTC. Suitable for feeding to gmtime() and localtime(). .Ip "times" 8 4 Returns a four-element array giving the user and system times, in seconds, for this process and the children of this process. .Sp ($user,$system,$cuser,$csystem) = times; .Sp .Ip "tr/SEARCHLIST/REPLACEMENTLIST/" 8 5 .Ip "y/SEARCHLIST/REPLACEMENTLIST/" 8 Translates all occurrences of the characters found in the search list with the corresponding character in the replacement list. It returns the number of characters replaced. If no string is specified via the =~ or !~ operator, the $_ string is translated. (The string specified with =~ must be a scalar variable, an array element, or an assignment to one of those, i.e. an lvalue.) For .I sed devotees, .I y is provided as a synonym for .IR tr . Examples: .nf $ARGV[1] \|=~ \|y/A\-Z/a\-z/; \h'|3i'# canonicalize to lower case $cnt = tr/*/*/; \h'|3i'# count the stars in $_ ($HOST = $host) =~ tr/a\-z/A\-Z/; y/\e001\-@[\-_{\-\e177/ /; \h'|3i'# change non-alphas to space .fi .Ip "umask(EXPR)" 8 4 .Ip "umask EXPR" 8 .Ip "umask" 8 Sets the umask for the process and returns the old one. If EXPR is omitted, merely returns current umask. .Ip "undef(EXPR)" 8 6 .Ip "undef EXPR" 8 .Ip "undef" 8 Undefines the value of EXPR, which must be an lvalue. Use only on a scalar value, an entire array, or a subroutine name (using &). (Undef will probably not do what you expect on most predefined variables or dbm array values.) Always returns the undefined value. You can omit the EXPR, in which case nothing is undefined, but you still get an undefined value that you could, for instance, return from a subroutine. Examples: .nf .ne 6 undef $foo; undef $bar{'blurfl'}; undef @ary; undef %assoc; undef &mysub; return (wantarray ? () : undef) if $they_blew_it; .fi .Ip "unlink(LIST)" 8 4 .Ip "unlink LIST" 8 Deletes a list of files. Returns the number of files successfully deleted. .nf .ne 2 $cnt = unlink \'a\', \'b\', \'c\'; unlink @goners; unlink <*.bak>; .fi Note: unlink will not delete directories unless you are superuser and the .B \-U flag is supplied to .IR perl . Even if these conditions are met, be warned that unlinking a directory can inflict damage on your filesystem. Use rmdir instead. .Ip "unpack(TEMPLATE,EXPR)" 8 4 Unpack does the reverse of pack: it takes a string representing a structure and expands it out into an array value, returning the array value. The TEMPLATE has the same format as in the pack function. Here's a subroutine that does substring: .nf .ne 4 sub substr { local($what,$where,$howmuch) = @_; unpack("x$where a$howmuch", $what); } .ne 3 and then there's sub ord { unpack("c",$_[0]); } .fi .Ip "unshift(ARRAY,LIST)" 8 4 Does the opposite of a .IR shift . Or the opposite of a .IR push , depending on how you look at it. Prepends list to the front of the array, and returns the number of elements in the new array. .nf unshift(ARGV, \'\-e\') unless $ARGV[0] =~ /^\-/; .fi .Ip "utime(LIST)" 8 2 .Ip "utime LIST" 8 2 Changes the access and modification times on each file of a list of files. The first two elements of the list must be the NUMERICAL access and modification times, in that order. Returns the number of files successfully changed. The inode modification time of each file is set to the current time. Example of a \*(L"touch\*(R" command: .nf .ne 3 #!/usr/bin/perl $now = time; utime $now, $now, @ARGV; .fi .Ip "values(ASSOC_ARRAY)" 8 6 .Ip "values ASSOC_ARRAY" 8 Returns a normal array consisting of all the values of the named associative array. The values are returned in an apparently random order, but it is the same order as either the keys() or each() function would produce on the same array. See also keys() and each(). .Ip "vec(EXPR,OFFSET,BITS)" 8 2 Treats a string as a vector of unsigned integers, and returns the value of the bitfield specified. May also be assigned to. BITS must be a power of two from 1 to 32. .Sp Vectors created with vec() can also be manipulated with the logical operators |, & and ^, which will assume a bit vector operation is desired when both operands are strings. This interpretation is not enabled unless there is at least one vec() in your program, to protect older programs. .Ip "wait" 8 6 Waits for a child process to terminate and returns the pid of the deceased process, or -1 if there are no child processes. The status is returned in $?. If you expected a child and didn't find it, you probably had a call to system, a close on a pipe, or backticks between the fork and the wait. These constructs also do a wait and may have harvested your child process. .Ip "wantarray" 8 4 Returns true if the context of the currently executing subroutine is looking for an array value. Returns false if the context is looking for a scalar. .nf return wantarray ? () : undef; .fi .Ip "warn(LIST)" 8 4 .Ip "warn LIST" 8 Produces a message on STDERR just like \*(L"die\*(R", but doesn't exit. .Ip "write(FILEHANDLE)" 8 6 .Ip "write(EXPR)" 8 .Ip "write" 8 Writes a formatted record (possibly multi-line) to the specified file, using the format associated with that file. By default the format for a file is the one having the same name is the filehandle, but the format for the current output channel (see .IR select ) may be set explicitly by assigning the name of the format to the $~ variable. .Sp Top of form processing is handled automatically: if there is insufficient room on the current page for the formatted record, the page is advanced by writing a form feed, a special top-of-page format is used to format the new page header, and then the record is written. By default the top-of-page format is \*(L"top\*(R", but it may be set to the format of your choice by assigning the name to the $^ variable. The number of lines remaining on the current page is in variable $-, which can be set to 0 to force a new page. .Sp If FILEHANDLE is unspecified, output goes to the current default output channel, which starts out as .I STDOUT but may be changed by the .I select operator. If the FILEHANDLE is an EXPR, then the expression is evaluated and the resulting string is used to look up the name of the FILEHANDLE at run time. For more on formats, see the section on formats later on. .Sp Note that write is NOT the opposite of read. ines remaining on the current page is in variable $-, which can be set to 0 to force a new page. .Sp If FILEHANDLE is unspecified, output goes to the current default output channel, which starts out as .I STDOUT but may be changed by the .I select operator. If the FILEHANDLE is an EXPR, then the expression is evaluated and the resulting string is used to perl/perl.man.2 644 473 0 102661 4747105030 6672 ''' Beginning of part 2 ''' $Header: perl.man.2,v 3.0.1.3 90/02/28 17:55:58 lwall Locked $ ''' ''' $Log: perl.man.2,v $ ''' Revision 3.0.1.3 90/02/28 17:55:58 lwall ''' patch9: grep now returns number of items matched in scalar context ''' patch9: documented in-place modification capabilites of grep ''' ''' Revision 3.0.1.2 89/11/17 15:30:16 lwall ''' patch5: fixed some manual typos and indent problems ''' ''' Revision 3.0.1.1 89/11/11 04:43:10 lwall ''' patch2: made some line breaks depend on troff vs. nroff ''' patch2: example of unshift had args backwards ''' ''' Revision 3.0 89/10/18 15:21:37 lwall ''' 3.0 baseline ''' ''' .PP Along with the literals and variables mentioned earlier, the operations in the following section can serve as terms in an expression. Some of these operations take a LIST as an argument. Such a list can consist of any combination of scalar arguments or array values; the array values will be included in the list as if each individual element were interpolated at that point in the list, forming a longer single-dimensional array value. Elements of the LIST should be separated by commas. If an operation is listed both with and without parentheses around its arguments, it means you can either use it as a unary operator or as a function call. To use it as a function call, the next token on the same line must be a left parenthesis. (There may be intervening white space.) Such a function then has highest precedence, as you would expect from a function. If any token other than a left parenthesis follows, then it is a unary operator, with a precedence depending only on whether it is a LIST operator or not. LIST operators have lowest precedence. All other unary operators have a precedence greater than relational operators but less than arithmetic operators. See the section on Precedence. .Ip "/PATTERN/" 8 4 See m/PATTERN/. .Ip "?PATTERN?" 8 4 This is just like the /pattern/ search, except that it matches only once between calls to the .I reset operator. This is a useful optimization when you only want to see the first occurrence of something in each file of a set of files, for instance. Only ?? patterns local to the current package are reset. .Ip "accept(NEWSOCKET,GENERICSOCKET)" 8 2 Does the same thing that the accept system call does. Returns true if it succeeded, false otherwise. See example in section on Interprocess Communication. .Ip "atan2(X,Y)" 8 2 Returns the arctangent of X/Y in the range .if t \-\(*p to \(*p. .if n \-PI to PI. .Ip "bind(SOCKET,NAME)" 8 2 Does the same thing that the bind system call does. Returns true if it succeeded, false otherwise. NAME should be a packed address of the proper type for the socket. See example in section on Interprocess Communication. .Ip "chdir(EXPR)" 8 2 .Ip "chdir EXPR" 8 2 Changes the working directory to EXPR, if possible. If EXPR is omitted, changes to home directory. Returns 1 upon success, 0 otherwise. See example under .IR die . .Ip "chmod(LIST)" 8 2 .Ip "chmod LIST" 8 2 Changes the permissions of a list of files. The first element of the list must be the numerical mode. Returns the number of files successfully changed. .nf .ne 2 $cnt = chmod 0755, \'foo\', \'bar\'; chmod 0755, @executables; .fi .Ip "chop(LIST)" 8 7 .Ip "chop(VARIABLE)" 8 .Ip "chop VARIABLE" 8 .Ip "chop" 8 Chops off the last character of a string and returns the character chopped. It's used primarily to remove the newline from the end of an input record, but is much more efficient than s/\en// because it neither scans nor copies the string. If VARIABLE is omitted, chops $_. Example: .nf .ne 5 while (<>) { chop; # avoid \en on last field @array = split(/:/); .\|.\|. } .fi You can actually chop anything that's an lvalue, including an assignment: .nf chop($cwd = \`pwd\`); chop($answer = ); .fi If you chop a list, each element is chopped. Only the value of the last chop is returned. .Ip "chown(LIST)" 8 2 .Ip "chown LIST" 8 2 Changes the owner (and group) of a list of files. The first two elements of the list must be the NUMERICAL uid and gid, in that order. Returns the number of files successfully changed. .nf .ne 2 $cnt = chown $uid, $gid, \'foo\', \'bar\'; chown $uid, $gid, @filenames; .fi .ne 23 Here's an example of looking up non-numeric uids: .nf print "User: "; $user = ; chop($user); print "Files: " $pattern = ; chop($pattern); .ie t \{\ open(pass, \'/etc/passwd\') || die "Can't open passwd: $!\en"; 'br\} .el \{\ open(pass, \'/etc/passwd\') || die "Can't open passwd: $!\en"; 'br\} while () { ($login,$pass,$uid,$gid) = split(/:/); $uid{$login} = $uid; $gid{$login} = $gid; } @ary = <${pattern}>; # get filenames if ($uid{$user} eq \'\') { die "$user not in passwd file"; } else { chown $uid{$user}, $gid{$user}, @ary; } .fi .Ip "chroot(FILENAME)" 8 5 .Ip "chroot FILENAME" 8 Does the same as the system call of that name. If you don't know what it does, don't worry about it. If FILENAME is omitted, does chroot to $_. .Ip "close(FILEHANDLE)" 8 5 .Ip "close FILEHANDLE" 8 Closes the file or pipe associated with the file handle. You don't have to close FILEHANDLE if you are immediately going to do another open on it, since open will close it for you. (See .IR open .) However, an explicit close on an input file resets the line counter ($.), while the implicit close done by .I open does not. Also, closing a pipe will wait for the process executing on the pipe to complete, in case you want to look at the output of the pipe afterwards. Closing a pipe explicitly also puts the status value of the command into $?. Example: .nf .ne 4 open(OUTPUT, \'|sort >foo\'); # pipe to sort .\|.\|. # print stuff to output close OUTPUT; # wait for sort to finish open(INPUT, \'foo\'); # get sort's results .fi FILEHANDLE may be an expression whose value gives the real filehandle name. .Ip "closedir(DIRHANDLE)" 8 5 .Ip "closedir DIRHANDLE" 8 Closes a directory opened by opendir(). .Ip "connect(SOCKET,NAME)" 8 2 Does the same thing that the connect system call does. Returns true if it succeeded, false otherwise. NAME should be a package address of the proper type for the socket. See example in section on Interprocess Communication. .Ip "cos(EXPR)" 8 6 .Ip "cos EXPR" 8 6 Returns the cosine of EXPR (expressed in radians). If EXPR is omitted takes cosine of $_. .Ip "crypt(PLAINTEXT,SALT)" 8 6 Encrypts a string exactly like the crypt() function in the C library. Useful for checking the password file for lousy passwords. Only the guys wearing white hats should do this. .Ip "dbmclose(ASSOC_ARRAY)" 8 6 .Ip "dbmclose ASSOC_ARRAY" 8 Breaks the binding between a dbm file and an associative array. The values remaining in the associative array are meaningless unless you happen to want to know what was in the cache for the dbm file. This function is only useful if you have ndbm. .Ip "dbmopen(ASSOC,DBNAME,MODE)" 8 6 This binds a dbm or ndbm file to an associative array. ASSOC is the name of the associative array. (Unlike normal open, the first argument is NOT a filehandle, even though it looks like one). DBNAME is the name of the database (without the .dir or .pag extension). If the database does not exist, it is created with protection specified by MODE (as modified by the umask). If your system only supports the older dbm functions, you may only have one dbmopen in your program. If your system has neither dbm nor ndbm, calling dbmopen produces a fatal error. .Sp Values assigned to the associative array prior to the dbmopen are lost. A certain number of values from the dbm file are cached in memory. By default this number is 64, but you can increase it by preallocating that number of garbage entries in the associative array before the dbmopen. You can flush the cache if necessary with the reset command. .Sp If you don't have write access to the dbm file, you can only read associative array variables, not set them. If you want to test whether you can write, either use file tests or try setting a dummy array entry inside an eval, which will trap the error. .Sp Note that functions such as keys() and values() may return huge array values when used on large dbm files. You may prefer to use the each() function to iterate over large dbm files. Example: .nf .ne 6 # print out history file offsets dbmopen(HIST,'/usr/lib/news/history',0666); while (($key,$val) = each %HIST) { print $key, ' = ', unpack('L',$val), "\en"; } dbmclose(HIST); .fi .Ip "defined(EXPR)" 8 6 .Ip "defined EXPR" 8 Returns a boolean value saying whether the lvalue EXPR has a real value or not. Many operations return the undefined value under exceptional conditions, such as end of file, uninitialized variable, system error and such. This function allows you to distinguish between an undefined null string and a defined null string with operations that might return a real null string, in particular referencing elements of an array. You may also check to see if arrays or subroutines exist. Use on predefined variables is not guaranteed to produce intuitive results. Examples: .nf .ne 7 print if defined $switch{'D'}; print "$val\en" while defined($val = pop(@ary)); die "Can't readlink $sym: $!" unless defined($value = readlink $sym); eval '@foo = ()' if defined(@foo); die "No XYZ package defined" unless defined %_XYZ; sub foo { defined &bar ? &bar(@_) : die "No bar"; } .fi See also undef. .Ip "delete $ASSOC{KEY}" 8 6 Deletes the specified value from the specified associative array. Returns the deleted value, or the undefined value if nothing was deleted. Deleting from $ENV{} modifies the environment. Deleting from an array bound to a dbm file deletes the entry from the dbm file. .Sp The following deletes all the values of an associative array: .nf .ne 3 foreach $key (keys %ARRAY) { delete $ARRAY{$key}; } .fi (But it would be faster to use the .I reset command. Saying undef %ARRAY is faster yet.) .Ip "die(LIST)" 8 .Ip "die LIST" 8 Prints the value of LIST to .I STDERR and exits with the current value of $! (errno). If $! is 0, exits with the value of ($? >> 8) (\`command\` status). If ($? >> 8) is 0, exits with 255. Equivalent examples: .nf .ne 3 .ie t \{\ die "Can't cd to spool: $!\en" unless chdir \'/usr/spool/news\'; 'br\} .el \{\ die "Can't cd to spool: $!\en" unless chdir \'/usr/spool/news\'; 'br\} chdir \'/usr/spool/news\' || die "Can't cd to spool: $!\en" .fi .Sp If the value of EXPR does not end in a newline, the current script line number and input line number (if any) are also printed, and a newline is supplied. Hint: sometimes appending \*(L", stopped\*(R" to your message will cause it to make better sense when the string \*(L"at foo line 123\*(R" is appended. Suppose you are running script \*(L"canasta\*(R". .nf .ne 7 die "/etc/games is no good"; die "/etc/games is no good, stopped"; produce, respectively /etc/games is no good at canasta line 123. /etc/games is no good, stopped at canasta line 123. .fi See also .IR exit . .Ip "do BLOCK" 8 4 Returns the value of the last command in the sequence of commands indicated by BLOCK. When modified by a loop modifier, executes the BLOCK once before testing the loop condition. (On other statements the loop modifiers test the conditional first.) .Ip "do SUBROUTINE (LIST)" 8 3 Executes a SUBROUTINE declared by a .I sub declaration, and returns the value of the last expression evaluated in SUBROUTINE. If there is no subroutine by that name, produces a fatal error. (You may use the \*(L"defined\*(R" operator to determine if a subroutine exists.) If you pass arrays as part of LIST you may wish to pass the length of the array in front of each array. (See the section on subroutines later on.) SUBROUTINE may be a scalar variable, in which case the variable contains the name of the subroutine to execute. The parentheses are required to avoid confusion with the \*(L"do EXPR\*(R" form. .Sp As an alternate form, you may call a subroutine by prefixing the name with an ampersand: &foo(@args). If you aren't passing any arguments, you don't have to use parentheses. If you omit the parentheses, no @_ array is passed to the subroutine. The & form is also used to specify subroutines to the defined and undef operators. .Ip "do EXPR" 8 3 Uses the value of EXPR as a filename and executes the contents of the file as a .I perl script. Its primary use is to include subroutines from a .I perl subroutine library. .nf 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 .B \-I libraries if the file isn't in the current directory (see also the @INC array in Predefined Names). It's the same, however, in that it does reparse the file every time you call it, so if you are going to use the file inside a loop you might prefer to use \-P and #include, at the expense of a little more startup time. (The main problem with #include is that cpp doesn't grok # comments\*(--a workaround is to use \*(L";#\*(R" for standalone comments.) Note that the following are NOT equivalent: .nf .ne 2 do $foo; # eval a file do $foo(); # call a subroutine .fi .Ip "dump LABEL" 8 6 This causes an immediate core dump. Primarily this is so that you can use the undump program to turn your core dump into an executable binary after having initialized all your variables at the beginning of the program. When the new binary is executed it will begin by executing a "goto LABEL" (with all the restrictions that goto suffers). Think of it as a goto with an intervening core dump and reincarnation. If LABEL is omitted, restarts the program from the top. WARNING: any files opened at the time of the dump will NOT be open any more when the program is reincarnated, with possible resulting confusion on the part of perl. See also \-u. .Sp Example: .nf .ne 16 #!/usr/bin/perl do 'getopt.pl'; do 'stat.pl'; %days = ( 'Sun',1, 'Mon',2, 'Tue',3, 'Wed',4, 'Thu',5, 'Fri',6, 'Sat',7); dump QUICKSTART if $ARGV[0] eq '-d'; QUICKSTART: do Getopt('f'); .fi .Ip "each(ASSOC_ARRAY)" 8 6 .Ip "each ASSOC_ARRAY" 8 Returns a 2 element array consisting of the key and value for the next value of an associative array, so that you can iterate over it. Entries are returned in an apparently random order. When the array is entirely read, a null array is returned (which when assigned produces a FALSE (0) value). The next call to each() after that will start iterating again. The iterator can be reset only by reading all the elements from the array. You must not modify the array while iterating over it. There is a single iterator for each associative array, shared by all each(), keys() and values() function calls in the program. The following prints out your environment like the printenv program, only in a different order: .nf .ne 3 while (($key,$value) = each %ENV) { print "$key=$value\en"; } .fi See also keys() and values(). .Ip "eof(FILEHANDLE)" 8 8 .Ip "eof()" 8 .Ip "eof" 8 Returns 1 if the next read on FILEHANDLE will return end of file, or if FILEHANDLE is not open. FILEHANDLE may be an expression whose value gives the real filehandle name. An eof without an argument returns the eof status for the last file read. Empty parentheses () may be used to indicate the pseudo file formed of the files listed on the command line, i.e. eof() is reasonable to use inside a while (<>) loop to detect the end of only the last file. Use eof(ARGV) or eof without the parentheses to test EACH file in a while (<>) loop. Examples: .nf .ne 7 # insert dashes just before last line of last file while (<>) { if (eof()) { print "\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\en"; } print; } .ne 7 # reset line numbering on each input file while (<>) { print "$.\et$_"; if (eof) { # Not eof(). close(ARGV); } } .fi .Ip "eval(EXPR)" 8 6 .Ip "eval EXPR" 8 6 EXPR is parsed and executed as if it were a little .I perl program. It is executed in the context of the current .I perl program, so that any variable settings, subroutine or format definitions remain afterwards. The value returned is the value of the last expression evaluated, just as with subroutines. If there is a syntax error or runtime error, a null string is returned by eval, and $@ is set to the error message. If there was no error, $@ is null. If EXPR is omitted, evaluates $_. The final semicolon, if any, may be omitted from the expression. .Sp Note that, since eval traps otherwise-fatal errors, it is useful for determining whether a particular feature (such as dbmopen or symlink) is implemented. .Ip "exec(LIST)" 8 8 .Ip "exec LIST" 8 6 If there is more than one argument in LIST, or if LIST is an array with more than one value, calls execvp() with the arguments in LIST. If there is only one scalar argument, the argument is checked for shell metacharacters. If there are any, the entire argument is passed to \*(L"/bin/sh \-c\*(R" for parsing. If there are none, the argument is split into words and passed directly to execvp(), which is more efficient. Note: exec (and system) do not flush your output buffer, so you may need to set $| to avoid lost output. Examples: .nf exec \'/bin/echo\', \'Your arguments are: \', @ARGV; exec "sort $outfile | uniq"; .fi .Sp If you don't really want to execute the first argument, but want to lie to the program you are executing about its own name, you can specify the program you actually want to run by assigning that to a variable and putting the name of the variable in front of the LIST without a comma. (This always forces interpretation of the LIST as a multi-valued list, even if there is only a single scalar in the list.) Example: .nf .ne 2 $shell = '/bin/csh'; exec $shell '-sh'; # pretend it's a login shell .fi .Ip "exit(EXPR)" 8 6 .Ip "exit EXPR" 8 Evaluates EXPR and exits immediately with that value. Example: .nf .ne 2 $ans = ; exit 0 \|if \|$ans \|=~ \|/\|^[Xx]\|/\|; .fi See also .IR die . If EXPR is omitted, exits with 0 status. .Ip "exp(EXPR)" 8 3 .Ip "exp EXPR" 8 Returns .I e to the power of EXPR. If EXPR is omitted, gives exp($_). .Ip "fcntl(FILEHANDLE,FUNCTION,SCALAR)" 8 4 Implements the fcntl(2) function. You'll probably have to say .nf do "fcntl.h"; # probably /usr/local/lib/perl/fcntl.h .fi first to get the correct function definitions. If fcntl.h doesn't exist or doesn't have the correct definitions you'll have to roll your own, based on your C header files such as . (There is a perl script called makelib that comes with the perl kit which may help you in this.) Argument processing and value return works just like ioctl below. Note that fcntl will produce a fatal error if used on a machine that doesn't implement fcntl(2). .Ip "fileno(FILEHANDLE)" 8 4 .Ip "fileno FILEHANDLE" 8 4 Returns the file descriptor for a filehandle. Useful for constructing bitmaps for select(). If FILEHANDLE is an expression, the value is taken as the name of the filehandle. .Ip "flock(FILEHANDLE,OPERATION)" 8 4 Calls flock(2) on FILEHANDLE. See manual page for flock(2) for definition of OPERATION. Will produce a fatal error if used on a machine that doesn't implement flock(2). Here's a mailbox appender for BSD systems. .nf .ne 20 $LOCK_SH = 1; $LOCK_EX = 2; $LOCK_NB = 4; $LOCK_UN = 8; sub lock { flock(MBOX,$LOCK_EX); # and, in case someone appended # while we were waiting... seek(MBOX, 0, 2); } sub unlock { flock(MBOX,$LOCK_UN); } open(MBOX, ">>/usr/spool/mail/$USER") || die "Can't open mailbox: $!"; do lock(); print MBOX $msg,"\en\en"; do unlock(); .fi .Ip "fork" 8 4 Does a fork() call. Returns the child pid to the parent process and 0 to the child process. Note: unflushed buffers remain unflushed in both processes, which means you may need to set $| to avoid duplicate output. .Ip "getc(FILEHANDLE)" 8 4 .Ip "getc FILEHANDLE" 8 .Ip "getc" 8 Returns the next character from the input file attached to FILEHANDLE, or a null string at EOF. If FILEHANDLE is omitted, reads from STDIN. .Ip "getlogin" 8 3 Returns the current login from /etc/utmp, if any. If null, use getpwuid. ($login = getlogin) || (($login) = getpwuid($<)); .Ip "getpeername(SOCKET)" 8 3 Returns the packed sockaddr address of other end of the SOCKET connection. .nf .ne 4 # An internet sockaddr $sockaddr = 'S n a4 x8'; $hersockaddr = getpeername(S); .ie t \{\ ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr); 'br\} .el \{\ ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr); 'br\} .fi .Ip "getpgrp(PID)" 8 4 .Ip "getpgrp PID" 8 Returns the current process group for the specified PID, 0 for the current process. Will produce a fatal error if used on a machine that doesn't implement getpgrp(2). If EXPR is omitted, returns process group of current process. .Ip "getppid" 8 4 Returns the process id of the parent process. .Ip "getpriority(WHICH,WHO)" 8 4 Returns the current priority for a process, a process group, or a user. (See getpriority(2).) Will produce a fatal error if used on a machine that doesn't implement getpriority(2). .Ip "getpwnam(NAME)" 8 .Ip "getgrnam(NAME)" 8 .Ip "gethostbyname(NAME)" 8 .Ip "getnetbyname(NAME)" 8 .Ip "getprotobyname(NAME)" 8 .Ip "getpwuid(UID)" 8 .Ip "getgrgid(GID)" 8 .Ip "getservbyname(NAME,PROTO)" 8 .Ip "gethostbyaddr(ADDR,ADDRTYPE)" 8 .Ip "getnetbyaddr(ADDR,ADDRTYPE)" 8 .Ip "getprotobynumber(NUMBER)" 8 .Ip "getservbyport(PORT,PROTO)" 8 .Ip "getpwent" 8 .Ip "getgrent" 8 .Ip "gethostent" 8 .Ip "getnetent" 8 .Ip "getprotoent" 8 .Ip "getservent" 8 .Ip "setpwent" 8 .Ip "setgrent" 8 .Ip "sethostent(STAYOPEN)" 8 .Ip "setnetent(STAYOPEN)" 8 .Ip "setprotoent(STAYOPEN)" 8 .Ip "setservent(STAYOPEN)" 8 .Ip "endpwent" 8 .Ip "endgrent" 8 .Ip "endhostent" 8 .Ip "endnetent" 8 .Ip "endprotoent" 8 .Ip "endservent" 8 These routines perform the same functions as their counterparts in the system library. The return values from the various get routines are as follows: .nf ($name,$passwd,$uid,$gid, $quota,$comment,$gcos,$dir,$shell) = getpw.\|.\|. ($name,$passwd,$gid,$members) = getgr.\|.\|. ($name,$aliases,$addrtype,$length,@addrs) = gethost.\|.\|. ($name,$aliases,$addrtype,$net) = getnet.\|.\|. ($name,$aliases,$proto) = getproto.\|.\|. ($name,$aliases,$port,$proto) = getserv.\|.\|. .fi The $members value returned by getgr.\|.\|. is a space separated list of the login names of the members of the group. .Sp The @addrs value returned by the gethost.\|.\|. functions is a list of the raw addresses returned by the corresponding system library call. In the Internet domain, each address is four bytes long and you can unpack it by saying something like: .nf ($a,$b,$c,$d) = unpack('C4',$addr[0]); .fi .Ip "getsockname(SOCKET)" 8 3 Returns the packed sockaddr address of this end of the SOCKET connection. .nf .ne 4 # An internet sockaddr $sockaddr = 'S n a4 x8'; $mysockaddr = getsockname(S); .ie t \{\ ($family, $port, $myaddr) = unpack($sockaddr,$mysockaddr); 'br\} .el \{\ ($family, $port, $myaddr) = unpack($sockaddr,$mysockaddr); 'br\} .fi .Ip "getsockopt(SOCKET,LEVEL,OPTNAME)" 8 3 Returns the socket option requested, or undefined if there is an error. .Ip "gmtime(EXPR)" 8 4 .Ip "gmtime EXPR" 8 Converts a time as returned by the time function to a 9-element array with the time analyzed for the Greenwich timezone. Typically used as follows: .nf .ne 3 .ie t \{\ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); 'br\} .el \{\ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); 'br\} .fi All array elements are numeric, and come straight out of a struct tm. In particular this means that $mon has the range 0.\|.11 and $wday has the range 0.\|.6. If EXPR is omitted, does gmtime(time). .Ip "goto LABEL" 8 6 Finds the statement labeled with LABEL and resumes execution there. Currently you may only go to statements in the main body of the program that are not nested inside a do {} construct. This statement is not implemented very efficiently, and is here only to make the .IR sed -to- perl translator easier. I may change its semantics at any time, consistent with support for translated .I sed scripts. Use it at your own risk. Better yet, don't use it at all. .Ip "grep(EXPR,LIST)" 8 4 Evaluates EXPR for each element of LIST (locally setting $_ to each element) and returns the array value consisting of those elements for which the expression evaluated to true. In a scalar context, returns the number of times the expression was true. .nf @foo = grep(!/^#/, @bar); # weed out comments .fi Note that, since $_ is a reference into the array value, it can be used to modify the elements of the array. While this is useful and supported, it can cause bizarre results if the LIST contains literal values. .Ip "hex(EXPR)" 8 4 .Ip "hex EXPR" 8 Returns the decimal value of EXPR interpreted as an hex string. (To interpret strings that might start with 0 or 0x see oct().) If EXPR is omitted, uses $_. .Ip "ioctl(FILEHANDLE,FUNCTION,SCALAR)" 8 4 Implements the ioctl(2) function. You'll probably have to say .nf do "ioctl.h"; # probably /usr/local/lib/perl/ioctl.h .fi first to get the correct function definitions. If ioctl.h doesn't exist or doesn't have the correct definitions you'll have to roll your own, based on your C header files such as . (There is a perl script called makelib that comes with the perl kit which may help you in this.) SCALAR will be read and/or written depending on the FUNCTION\*(--a pointer to the string value of SCALAR will be passed as the third argument of the actual ioctl call. (If SCALAR has no string value but does have a numeric value, that value will be passed rather than a pointer to the string value. To guarantee this to be true, add a 0 to the scalar before using it.) The pack() and unpack() functions are useful for manipulating the values of structures used by ioctl(). The following example sets the erase character to DEL. .nf .ne 9 do 'ioctl.h'; $sgttyb_t = "ccccs"; # 4 chars and a short if (ioctl(STDIN,$TIOCGETP,$sgttyb)) { @ary = unpack($sgttyb_t,$sgttyb); $ary[2] = 127; $sgttyb = pack($sgttyb_t,@ary); ioctl(STDIN,$TIOCSETP,$sgttyb) || die "Can't ioctl: $!"; } .fi The return value of ioctl (and fcntl) is as follows: .nf .ne 4 if OS returns:\h'|3i'perl returns: -1\h'|3i' undefined value 0\h'|3i' string "0 but true" anything else\h'|3i' that number .fi Thus perl returns true on success and false on failure, yet you can still easily determine the actual value returned by the operating system: .nf ($retval = ioctl(...)) || ($retval = -1); printf "System returned %d\en", $retval; .fi .Ip "index(STR,SUBSTR)" 8 4 Returns the position of the first occurrence of SUBSTR in STR, based at 0, or whatever you've set the $[ variable to. If the substring is not found, returns one less than the base, ordinarily \-1. .Ip "int(EXPR)" 8 4 .Ip "int EXPR" 8 Returns the integer portion of EXPR. If EXPR is omitted, uses $_. .Ip "join(EXPR,LIST)" 8 8 .Ip "join(EXPR,ARRAY)" 8 Joins the separate strings of LIST or ARRAY into a single string with fields separated by the value of EXPR, and returns the string. Example: .nf .ie t \{\ $_ = join(\|\':\', $login,$passwd,$uid,$gid,$gcos,$home,$shell); 'br\} .el \{\ $_ = join(\|\':\', $login,$passwd,$uid,$gid,$gcos,$home,$shell); 'br\} .fi See .IR split . .Ip "keys(ASSOC_ARRAY)" 8 6 .Ip "keys ASSOC_ARRAY" 8 Returns a normal array consisting of all the keys of the named associative array. The keys are returned in an apparently random order, but it is the same order as either the values() or each() function produces (given that the associative array has not been modified). Here is yet another way to print your environment: .nf .ne 5 @keys = keys %ENV; @values = values %ENV; while ($#keys >= 0) { 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 8 .Ip "kill LIST" 8 2 Sends a signal to a list of processes. The first element of the list must be the signal to send. Returns the number of processes successfully signaled. .nf $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.) You may use a signal name in quotes. .Ip "last LABEL" 8 8 .Ip "last" 8 The .I last command is like the .I break statement in C (as used in loops); it immediately exits the loop in question. If the LABEL is omitted, the command refers to the innermost enclosing loop. The .I continue block, if any, is not executed: .nf .ne 4 line: while () { last line if /\|^$/; # exit when done with header .\|.\|. } .fi .Ip "length(EXPR)" 8 4 .Ip "length EXPR" 8 Returns the length in characters of the value of EXPR. If EXPR is omitted, returns length of $_. .Ip "link(OLDFILE,NEWFILE)" 8 2 Creates a new filename linked to the old filename. Returns 1 for success, 0 otherwise. .Ip "listen(SOCKET,QUEUESIZE)" 8 2 Does the same thing that the listen system call does. Returns true if it succeeded, false otherwise. See example in section on Interprocess Communication. .Ip "local(LIST)" 8 4 Declares the listed variables to be local to the enclosing block, subroutine, eval or \*(L"do\*(R". All the listed elements must be legal lvalues. This operator works by saving the current values of those variables in LIST on a hidden stack and restoring them upon exiting the block, subroutine or eval. This means that called subroutines can also reference the local variable, but not the global one. The LIST may be assigned to if desired, which allows you to initialize your local variables. (If no initializer is given, all scalars are initialized to the null string and all arrays and associative arrays to the null array.) Commonly this is used to name the parameters to a subroutine. Examples: .nf .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; } .ne 6 if ($sw eq \'-v\') { # init local array with global array local(@ARGV) = @ARGV; unshift(@ARGV,\'echo\'); system @ARGV; } # @ARGV restored .ne 6 # temporarily add to digits associative array if ($base12) { # (NOTE: not claiming this is efficient!) local(%digits) = (%digits,'t',10,'e',11); do parse_num(); } .fi Note that local() is a run-time command, and so gets executed every time through a loop, using up more stack storage each time until it's all released at once when the loop is exited. .Ip "localtime(EXPR)" 8 4 .Ip "localtime EXPR" 8 Converts a time as returned by the time function to a 9-element array with the time analyzed for the local timezone. Typically used as follows: .nf .ne 3 .ie t \{\ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); 'br\} .el \{\ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); 'br\} .fi All array elements are numeric, and come straight out of a struct tm. In particular this means that $mon has the range 0.\|.11 and $wday has the range 0.\|.6. If EXPR is omitted, does localtime(time). .Ip "log(EXPR)" 8 4 .Ip "log EXPR" 8 Returns logarithm (base .IR e ) of EXPR. If EXPR is omitted, returns log of $_. .Ip "lstat(FILEHANDLE)" 8 6 .Ip "lstat FILEHANDLE" 8 .Ip "lstat(EXPR)" 8 .Ip "lstat SCALARVARIABLE" 8 Does the same thing as the stat() function, but stats a symbolic link instead of the file the symbolic link points to. If symbolic links are unimplemented on your system, a normal stat is done. .Ip "m/PATTERN/io" 8 4 .Ip "/PATTERN/io" 8 Searches a string for a pattern match, and returns true (1) or false (\'\'). If no string is specified via the =~ or !~ operator, the $_ string is searched. (The string specified with =~ need not be an lvalue\*(--it may be the result of an expression evaluation, but remember the =~ binds rather tightly.) See also the section on regular expressions. .Sp If / is the delimiter then the initial \*(L'm\*(R' is optional. With the \*(L'm\*(R' you can use any pair of characters as delimiters. This is particularly useful for matching Unix path names that contain \*(L'/\*(R'. If the final delimiter is followed by the optional letter \*(L'i\*(R', the matching is done in a case-insensitive manner. PATTERN may contain references to scalar variables, which will be interpolated (and the pattern recompiled) every time the pattern search is evaluated. If you want such a pattern to be compiled only once, add an \*(L"o\*(R" after the trailing delimiter. This avoids expensive run-time recompilations, and is useful when the value you are interpolating won't change over the life of the script. .Sp If used in a context that requires an array value, a pattern match returns an array consisting of the subexpressions matched by the parentheses in the pattern, i.e. ($1, $2, $3.\|.\|.). It does NOT actually set $1, $2, etc. in this case, nor does it set $+, $`, $& or $'. If the match fails, a null array is returned. .Sp Examples: .nf .ne 4 open(tty, \'/dev/tty\'); \|=~ \|/\|^y\|/i \|&& \|do foo(\|); # do foo if desired if (/Version: \|*\|([0\-9.]*\|)\|/\|) { $version = $1; } next if m#^/usr/spool/uucp#; .ne 5 # poor man's grep $arg = shift; while (<>) { print if /$arg/o; # compile only once } if (($F1, $F2, $Etc) = ($foo =~ /^(\eS+)\es+(\eS+)\es*(.*)/)) .fi This last example splits $foo into the first two words and the remainder of the line, and assigns those three fields to $F1, $F2 and $Etc. The conditional is true if any variables were assigned, i.e. if the pattern matched. .Ip "mkdir(FILENAME,MODE)" 8 3 Creates the directory specified by FILENAME, with permissions specified by MODE (as modified by umask). If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). e } if (($F1, $F2, $Etc) = ($foo =~ /^(\eS+)\es+(\eS+)\es*(.*)/)) .fiperl/cons.c 644 473 0 100166 4747105031 6200 /* $Header: cons.c,v 3.0.1.4 90/02/28 16:44:00 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: cons.c,v $ * Revision 3.0.1.4 90/02/28 16:44:00 lwall * patch9: subs which return by both mechanisms can clobber local return data * patch9: changed internal SUB label to _SUB_ * patch9: line numbers were bogus during certain portions of foreach evaluation * * Revision 3.0.1.3 89/12/21 19:20:25 lwall * patch7: made nested or recursive foreach work right * * Revision 3.0.1.2 89/11/17 15:08:53 lwall * patch5: nested foreach on same array didn't work * * Revision 3.0.1.1 89/10/26 23:09:01 lwall * patch1: numeric switch optimization was broken * patch1: unless was broken when run under the debugger * * Revision 3.0 89/10/18 15:10:23 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" #include "perly.h" extern char *tokename[]; extern int yychar; static int cmd_tosave(); static int arg_tosave(); static int spat_tosave(); static bool saw_return; SUBR * make_sub(name,cmd) char *name; CMD *cmd; { register SUBR *sub; STAB *stab = stabent(name,TRUE); Newz(101,sub,1,SUBR); if (stab_sub(stab)) { if (dowarn) { line_t oldline = line; if (cmd) line = cmd->c_line; warn("Subroutine %s redefined",name); line = oldline; } cmd_free(stab_sub(stab)->cmd); afree(stab_sub(stab)->tosave); Safefree(stab_sub(stab)); } sub->filename = filename; saw_return = FALSE; tosave = anew(Nullstab); tosave->ary_fill = 0; /* make 1 based */ (void)cmd_tosave(cmd,FALSE); /* this builds the tosave array */ sub->tosave = tosave; if (saw_return) { struct compcmd mycompblock; mycompblock.comp_true = cmd; mycompblock.comp_alt = Nullcmd; cmd = add_label(savestr("_SUB_"),make_ccmd(C_BLOCK,Nullarg,mycompblock)); saw_return = FALSE; if (perldb) cmd->c_next->c_flags |= CF_TERM; else cmd->c_flags |= CF_TERM; } sub->cmd = cmd; stab_sub(stab) = sub; if (perldb) { STR *str = str_nmake((double)subline); str_cat(str,"-"); sprintf(buf,"%ld",(long)line); str_cat(str,buf); name = str_get(subname); hstore(stab_xhash(DBsub),name,strlen(name),str,0); str_set(subname,"main"); } subline = 0; return sub; } CMD * block_head(tail) register CMD *tail; { CMD *head; register int opt; register int last_opt = 0; register STAB *last_stab = Nullstab; register int count = 0; register CMD *switchbeg = Nullcmd; if (tail == Nullcmd) { return tail; } head = tail->c_head; for (tail = head; tail; tail = tail->c_next) { /* save one measly dereference at runtime */ if (tail->c_type == C_IF) { if (!(tail->ucmd.ccmd.cc_alt = tail->ucmd.ccmd.cc_alt->c_next)) tail->c_flags |= CF_TERM; } else if (tail->c_type == C_EXPR) { ARG *arg; if (tail->ucmd.acmd.ac_expr) arg = tail->ucmd.acmd.ac_expr; else arg = tail->c_expr; if (arg) { if (arg->arg_type == O_RETURN) tail->c_flags |= CF_TERM; else if (arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD) tail->c_flags |= CF_TERM; } } if (!tail->c_next) tail->c_flags |= CF_TERM; if (tail->c_expr && (tail->c_flags & CF_OPTIMIZE) == CFT_FALSE) opt_arg(tail,1, tail->c_type == C_EXPR); /* now do a little optimization on case-ish structures */ switch(tail->c_flags & (CF_OPTIMIZE|CF_FIRSTNEG|CF_INVERT)) { case CFT_ANCHOR: if (stabent("*",FALSE)) { /* bad assumption here!!! */ opt = 0; break; } /* FALL THROUGH */ case CFT_STROP: opt = (tail->c_flags & CF_NESURE) ? CFT_STROP : 0; break; case CFT_CCLASS: opt = CFT_STROP; break; case CFT_NUMOP: opt = (tail->c_slen == O_NE ? 0 : CFT_NUMOP); if ((tail->c_flags&(CF_NESURE|CF_EQSURE)) != (CF_NESURE|CF_EQSURE)) opt = 0; break; default: opt = 0; } if (opt && opt == last_opt && tail->c_stab == last_stab) count++; else { if (count >= 3) { /* is this the breakeven point? */ if (last_opt == CFT_NUMOP) make_nswitch(switchbeg,count); else make_cswitch(switchbeg,count); } if (opt) { count = 1; switchbeg = tail; } else count = 0; } last_opt = opt; last_stab = tail->c_stab; } if (count >= 3) { /* is this the breakeven point? */ if (last_opt == CFT_NUMOP) make_nswitch(switchbeg,count); else make_cswitch(switchbeg,count); } return head; } /* We've spotted a sequence of CMDs that all test the value of the same * spat. Thus we can insert a SWITCH in front and jump directly * to the correct one. */ make_cswitch(head,count) register CMD *head; int count; { register CMD *cur; register CMD **loc; register int i; register int min = 255; register int max = 0; /* make a new head in the exact same spot */ New(102,cur, 1, CMD); #ifdef STRUCTCOPY *cur = *head; #else Copy(head,cur,1,CMD); #endif Zero(head,1,CMD); head->c_type = C_CSWITCH; head->c_next = cur; /* insert new cmd at front of list */ head->c_stab = cur->c_stab; Newz(103,loc,258,CMD*); loc++; /* lie a little */ while (count--) { if ((cur->c_flags & CF_OPTIMIZE) == CFT_CCLASS) { for (i = 0; i <= 255; i++) { if (!loc[i] && cur->c_short->str_ptr[i>>3] & (1 << (i&7))) { loc[i] = cur; if (i < min) min = i; if (i > max) max = i; } } } else { i = *cur->c_short->str_ptr & 255; if (!loc[i]) { loc[i] = cur; if (i < min) min = i; if (i > max) max = i; } } cur = cur->c_next; } max++; if (min > 0) Copy(&loc[min],&loc[0], max - min, CMD*); loc--; min--; max -= min; for (i = 0; i <= max; i++) if (!loc[i]) loc[i] = cur; Renew(loc,max+1,CMD*); /* chop it down to size */ head->ucmd.scmd.sc_offset = min; head->ucmd.scmd.sc_max = max; head->ucmd.scmd.sc_next = loc; } make_nswitch(head,count) register CMD *head; int count; { register CMD *cur = head; register CMD **loc; register int i; register int min = 32767; register int max = -32768; int origcount = count; double value; /* or your money back! */ short changed; /* so triple your money back! */ while (count--) { i = (int)str_gnum(cur->c_short); value = (double)i; if (value != cur->c_short->str_u.str_nval) return; /* fractional values--just forget it */ changed = i; if (changed != i) return; /* too big for a short */ if (cur->c_slen == O_LE) i++; else if (cur->c_slen == O_GE) /* we only do < or > here */ i--; if (i < min) min = i; if (i > max) max = i; cur = cur->c_next; } count = origcount; if (max - min > count * 2 + 10) /* too sparse? */ return; /* now make a new head in the exact same spot */ New(104,cur, 1, CMD); #ifdef STRUCTCOPY *cur = *head; #else Copy(head,cur,1,CMD); #endif Zero(head,1,CMD); head->c_type = C_NSWITCH; head->c_next = cur; /* insert new cmd at front of list */ head->c_stab = cur->c_stab; Newz(105,loc, max - min + 3, CMD*); loc++; max -= min; max++; while (count--) { i = (int)str_gnum(cur->c_short); i -= min; switch(cur->c_slen) { case O_LE: i++; case O_LT: for (i--; i >= -1; i--) if (!loc[i]) loc[i] = cur; break; case O_GE: i--; case O_GT: for (i++; i <= max; i++) if (!loc[i]) loc[i] = cur; break; case O_EQ: if (!loc[i]) loc[i] = cur; break; } cur = cur->c_next; } loc--; min--; max++; for (i = 0; i <= max; i++) if (!loc[i]) loc[i] = cur; head->ucmd.scmd.sc_offset = min; head->ucmd.scmd.sc_max = max; head->ucmd.scmd.sc_next = loc; } CMD * append_line(head,tail) register CMD *head; register CMD *tail; { if (tail == Nullcmd) return head; if (!tail->c_head) /* make sure tail is well formed */ tail->c_head = tail; if (head != Nullcmd) { tail = tail->c_head; /* get to start of tail list */ if (!head->c_head) head->c_head = head; /* start a new head list */ while (head->c_next) { head->c_next->c_head = head->c_head; head = head->c_next; /* get to end of head list */ } head->c_next = tail; /* link to end of old list */ tail->c_head = head->c_head; /* propagate head pointer */ } while (tail->c_next) { tail->c_next->c_head = tail->c_head; tail = tail->c_next; } return tail; } CMD * dodb(cur) CMD *cur; { register CMD *cmd; register CMD *head = cur->c_head; register ARG *arg; STR *str; if (!head) head = cur; if (!head->c_line) return cur; str = afetch(lineary,(int)head->c_line,FALSE); if (!str || str->str_nok) return cur; str->str_u.str_nval = (double)head->c_line; str->str_nok = 1; Newz(106,cmd,1,CMD); cmd->c_type = C_EXPR; cmd->ucmd.acmd.ac_stab = Nullstab; cmd->ucmd.acmd.ac_expr = Nullarg; arg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg); arg[1].arg_type = A_SINGLE; arg[1].arg_ptr.arg_str = str_nmake((double)head->c_line); cmd->c_expr = make_op(O_SUBR, 2, stab2arg(A_WORD,DBstab), make_list(arg), Nullarg); cmd->c_flags |= CF_COND|CF_DBSUB; cmd->c_line = head->c_line; cmd->c_label = head->c_label; cmd->c_file = filename; return append_line(cmd, cur); } CMD * make_acmd(type,stab,cond,arg) int type; STAB *stab; ARG *cond; ARG *arg; { register CMD *cmd; Newz(107,cmd,1,CMD); cmd->c_type = type; cmd->ucmd.acmd.ac_stab = stab; cmd->ucmd.acmd.ac_expr = arg; cmd->c_expr = cond; if (cond) cmd->c_flags |= CF_COND; if (cmdline == NOLINE) cmd->c_line = line; else { cmd->c_line = cmdline; cmdline = NOLINE; } cmd->c_file = filename; if (perldb) cmd = dodb(cmd); return cmd; } CMD * make_ccmd(type,arg,cblock) int type; ARG *arg; struct compcmd cblock; { register CMD *cmd; Newz(108,cmd, 1, CMD); cmd->c_type = type; cmd->c_expr = arg; cmd->ucmd.ccmd.cc_true = cblock.comp_true; cmd->ucmd.ccmd.cc_alt = cblock.comp_alt; if (arg) cmd->c_flags |= CF_COND; if (cmdline == NOLINE) cmd->c_line = line; else { cmd->c_line = cmdline; cmdline = NOLINE; } if (perldb) cmd = dodb(cmd); return cmd; } CMD * make_icmd(type,arg,cblock) int type; ARG *arg; struct compcmd cblock; { register CMD *cmd; register CMD *alt; register CMD *cur; register CMD *head; struct compcmd ncblock; Newz(109,cmd, 1, CMD); head = cmd; cmd->c_type = type; cmd->c_expr = arg; cmd->ucmd.ccmd.cc_true = cblock.comp_true; cmd->ucmd.ccmd.cc_alt = cblock.comp_alt; if (arg) cmd->c_flags |= CF_COND; if (cmdline == NOLINE) cmd->c_line = line; else { cmd->c_line = cmdline; cmdline = NOLINE; } cur = cmd; alt = cblock.comp_alt; while (alt && alt->c_type == C_ELSIF) { cur = alt; alt = alt->ucmd.ccmd.cc_alt; } if (alt) { /* a real life ELSE at the end? */ ncblock.comp_true = alt; ncblock.comp_alt = Nullcmd; alt = append_line(cur,make_ccmd(C_ELSE,Nullarg,ncblock)); cur->ucmd.ccmd.cc_alt = alt; } else alt = cur; /* no ELSE, so cur is proxy ELSE */ cur = cmd; while (cmd) { /* now point everyone at the ELSE */ cur = cmd; cmd = cur->ucmd.ccmd.cc_alt; cur->c_head = head; if (cur->c_type == C_ELSIF) cur->c_type = C_IF; if (cur->c_type == C_IF) cur->ucmd.ccmd.cc_alt = alt; if (cur == alt) break; cur->c_next = cmd; } if (perldb) cur = dodb(cur); return cur; } void opt_arg(cmd,fliporflop,acmd) register CMD *cmd; int fliporflop; int acmd; { register ARG *arg; int opt = CFT_EVAL; int sure = 0; ARG *arg2; int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */ int flp = fliporflop; if (!cmd) return; if (!(arg = cmd->c_expr)) { cmd->c_flags &= ~CF_COND; return; } /* Can we turn && and || into if and unless? */ if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM) && (arg->arg_type == O_AND || arg->arg_type == O_OR) ) { dehoist(arg,1); arg[2].arg_type &= A_MASK; /* don't suppress eval */ dehoist(arg,2); cmd->ucmd.acmd.ac_expr = arg[2].arg_ptr.arg_arg; cmd->c_expr = arg[1].arg_ptr.arg_arg; if (arg->arg_type == O_OR) cmd->c_flags ^= CF_INVERT; /* || is like unless */ arg->arg_len = 0; free_arg(arg); arg = cmd->c_expr; } /* Turn "if (!expr)" into "unless (expr)" */ if (!(cmd->c_flags & CF_TERM)) { /* unless return value wanted */ while (arg->arg_type == O_NOT) { dehoist(arg,1); cmd->c_flags ^= CF_INVERT; /* flip sense of cmd */ cmd->c_expr = arg[1].arg_ptr.arg_arg; /* hoist the rest of expr */ free_arg(arg); arg = cmd->c_expr; /* here we go again */ } } if (!arg->arg_len) { /* sanity check */ cmd->c_flags |= opt; return; } /* for "cond .. cond" we set up for the initial check */ if (arg->arg_type == O_FLIP) context |= 4; /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */ morecontext: if (arg->arg_type == O_AND) context |= 1; else if (arg->arg_type == O_OR) context |= 2; if (context && (arg[flp].arg_type & A_MASK) == A_EXPR) { arg = arg[flp].arg_ptr.arg_arg; flp = 1; if (arg->arg_type == O_AND || arg->arg_type == O_OR) goto morecontext; } if ((context & 3) == 3) return; if (arg[flp].arg_flags & (AF_PRE|AF_POST)) { cmd->c_flags |= opt; return; /* side effect, can't optimize */ } if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP || arg->arg_type == O_AND || arg->arg_type == O_OR) { if ((arg[flp].arg_type & A_MASK) == A_SINGLE) { opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE); cmd->c_short = str_smake(arg[flp].arg_ptr.arg_str); goto literal; } else if ((arg[flp].arg_type & A_MASK) == A_STAB || (arg[flp].arg_type & A_MASK) == A_LVAL) { cmd->c_stab = arg[flp].arg_ptr.arg_stab; opt = CFT_REG; literal: if (!context) { /* no && or ||? */ free_arg(arg); cmd->c_expr = Nullarg; } if (!(context & 1)) cmd->c_flags |= CF_EQSURE; if (!(context & 2)) cmd->c_flags |= CF_NESURE; } } else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST || arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) { if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && (arg[2].arg_type & A_MASK) == A_SPAT && arg[2].arg_ptr.arg_spat->spat_short ) { cmd->c_stab = arg[1].arg_ptr.arg_stab; cmd->c_short = str_smake(arg[2].arg_ptr.arg_spat->spat_short); cmd->c_slen = arg[2].arg_ptr.arg_spat->spat_slen; if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ALL && !(arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ONCE) && (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) ) sure |= CF_EQSURE; /* (SUBST must be forced even */ /* if we know it will work.) */ if (arg->arg_type != O_SUBST) { arg[2].arg_ptr.arg_spat->spat_short = Nullstr; arg[2].arg_ptr.arg_spat->spat_slen = 0; /* only one chk */ } sure |= CF_NESURE; /* normally only sure if it fails */ if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) cmd->c_flags |= CF_FIRSTNEG; if (context & 1) { /* only sure if thing is false */ if (cmd->c_flags & CF_FIRSTNEG) sure &= ~CF_NESURE; else sure &= ~CF_EQSURE; } else if (context & 2) { /* only sure if thing is true */ if (cmd->c_flags & CF_FIRSTNEG) sure &= ~CF_EQSURE; else sure &= ~CF_NESURE; } if (sure & (CF_EQSURE|CF_NESURE)) { /* if we know anything*/ if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST) opt = CFT_SCAN; else opt = CFT_ANCHOR; if (sure == (CF_EQSURE|CF_NESURE) /* really sure? */ && arg->arg_type == O_MATCH && context & 4 && fliporflop == 1) { spat_free(arg[2].arg_ptr.arg_spat); arg[2].arg_ptr.arg_spat = Nullspat; /* don't do twice */ } cmd->c_flags |= sure; } } } else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE || arg->arg_type == O_SLT || arg->arg_type == O_SGT) { if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) { if (arg[2].arg_type == A_SINGLE) { cmd->c_stab = arg[1].arg_ptr.arg_stab; cmd->c_short = str_smake(arg[2].arg_ptr.arg_str); cmd->c_slen = cmd->c_short->str_cur+1; switch (arg->arg_type) { case O_SLT: case O_SGT: sure |= CF_EQSURE; cmd->c_flags |= CF_FIRSTNEG; break; case O_SNE: cmd->c_flags |= CF_FIRSTNEG; /* FALL THROUGH */ case O_SEQ: sure |= CF_NESURE|CF_EQSURE; break; } if (context & 1) { /* only sure if thing is false */ if (cmd->c_flags & CF_FIRSTNEG) sure &= ~CF_NESURE; else sure &= ~CF_EQSURE; } else if (context & 2) { /* only sure if thing is true */ if (cmd->c_flags & CF_FIRSTNEG) sure &= ~CF_EQSURE; else sure &= ~CF_NESURE; } if (sure & (CF_EQSURE|CF_NESURE)) { opt = CFT_STROP; cmd->c_flags |= sure; } } } } else if (arg->arg_type == O_EQ || arg->arg_type == O_NE || arg->arg_type == O_LE || arg->arg_type == O_GE || arg->arg_type == O_LT || arg->arg_type == O_GT) { if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) { if (arg[2].arg_type == A_SINGLE) { cmd->c_stab = arg[1].arg_ptr.arg_stab; if (dowarn) { STR *str = arg[2].arg_ptr.arg_str; if ((!str->str_nok && !looks_like_number(str))) warn("Possible use of == on string value"); } cmd->c_short = str_nmake(str_gnum(arg[2].arg_ptr.arg_str)); cmd->c_slen = arg->arg_type; sure |= CF_NESURE|CF_EQSURE; if (context & 1) { /* only sure if thing is false */ sure &= ~CF_EQSURE; } else if (context & 2) { /* only sure if thing is true */ sure &= ~CF_NESURE; } if (sure & (CF_EQSURE|CF_NESURE)) { opt = CFT_NUMOP; cmd->c_flags |= sure; } } } } else if (arg->arg_type == O_ASSIGN && (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && arg[1].arg_ptr.arg_stab == defstab && arg[2].arg_type == A_EXPR ) { arg2 = arg[2].arg_ptr.arg_arg; if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) { opt = CFT_GETS; cmd->c_stab = arg2[1].arg_ptr.arg_stab; if (!(stab_io(arg2[1].arg_ptr.arg_stab)->flags & IOF_ARGV)) { free_arg(arg2); free_arg(arg); cmd->c_expr = Nullarg; } } } else if (arg->arg_type == O_CHOP && (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) { opt = CFT_CHOP; cmd->c_stab = arg[1].arg_ptr.arg_stab; free_arg(arg); cmd->c_expr = Nullarg; } if (context & 4) opt |= CF_FLIP; cmd->c_flags |= opt; if (cmd->c_flags & CF_FLIP) { if (fliporflop == 1) { arg = cmd->c_expr; /* get back to O_FLIP arg */ New(110,arg[3].arg_ptr.arg_cmd, 1, CMD); Copy(cmd, arg[3].arg_ptr.arg_cmd, 1, CMD); New(111,arg[4].arg_ptr.arg_cmd,1,CMD); Copy(cmd, arg[4].arg_ptr.arg_cmd, 1, CMD); opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd); arg->arg_len = 2; /* this is a lie */ } else { if ((opt & CF_OPTIMIZE) == CFT_EVAL) cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP; } } } CMD * add_label(lbl,cmd) char *lbl; register CMD *cmd; { if (cmd) cmd->c_label = lbl; return cmd; } CMD * addcond(cmd, arg) register CMD *cmd; register ARG *arg; { cmd->c_expr = arg; cmd->c_flags |= CF_COND; return cmd; } CMD * addloop(cmd, arg) register CMD *cmd; register ARG *arg; { void while_io(); cmd->c_expr = arg; cmd->c_flags |= CF_COND|CF_LOOP; if (!(cmd->c_flags & CF_INVERT)) while_io(cmd); /* add $_ =, if necessary */ if (cmd->c_type == C_BLOCK) cmd->c_flags &= ~CF_COND; else { arg = cmd->ucmd.acmd.ac_expr; if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD) cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */ if (arg && arg->arg_type == O_SUBR) cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */ } return cmd; } CMD * invert(cmd) CMD *cmd; { register CMD *targ = cmd; if (targ->c_head) targ = targ->c_head; if (targ->c_flags & CF_DBSUB) targ = targ->c_next; targ->c_flags ^= CF_INVERT; return cmd; } yyerror(s) char *s; { char tmpbuf[258]; char tmp2buf[258]; char *tname = tmpbuf; if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 && oldoldbufptr != oldbufptr && oldbufptr != bufptr) { while (isspace(*oldoldbufptr)) oldoldbufptr++; strncpy(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr); tmp2buf[bufptr - oldoldbufptr] = '\0'; sprintf(tname,"next 2 tokens \"%s\"",tmp2buf); } else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 && oldbufptr != bufptr) { while (isspace(*oldbufptr)) oldbufptr++; strncpy(tmp2buf, oldbufptr, bufptr - oldbufptr); tmp2buf[bufptr - oldbufptr] = '\0'; sprintf(tname,"next token \"%s\"",tmp2buf); } else if (yychar > 256) tname = "next token ???"; else if (!yychar) (void)strcpy(tname,"at EOF"); else if (yychar < 32) (void)sprintf(tname,"next char ^%c",yychar+64); else if (yychar == 127) (void)strcpy(tname,"at EOF"); else (void)sprintf(tname,"next char %c",yychar); (void)sprintf(buf, "%s in file %s at line %d, %s\n", s,filename,line,tname); if (line == multi_end && multi_start < multi_end) sprintf(buf+strlen(buf), " (Might be a runaway multi-line %c%c string starting on line %d)\n", multi_open,multi_close,multi_start); if (in_eval) str_cat(stab_val(stabent("@",TRUE)),buf); else fputs(buf,stderr); if (++error_count >= 10) fatal("Too many errors\n"); } void while_io(cmd) register CMD *cmd; { register ARG *arg = cmd->c_expr; STAB *asgnstab; /* hoist "while ()" up into command block */ if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) { cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ cmd->c_flags |= CFT_GETS; /* and set it to do the input */ cmd->c_stab = arg[1].arg_ptr.arg_stab; if (stab_io(arg[1].arg_ptr.arg_stab)->flags & IOF_ARGV) { cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */ stab2arg(A_LVAL,defstab), arg, Nullarg)); } else { free_arg(arg); cmd->c_expr = Nullarg; } } else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) { cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ cmd->c_flags |= CFT_INDGETS; /* and set it to do the input */ cmd->c_stab = arg[1].arg_ptr.arg_stab; free_arg(arg); cmd->c_expr = Nullarg; } else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) { if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY) asgnstab = cmd->c_stab; else asgnstab = defstab; cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$foo =" */ stab2arg(A_LVAL,asgnstab), arg, Nullarg)); cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ } } CMD * wopt(cmd) register CMD *cmd; { register CMD *tail; CMD *newtail; register int i; if (cmd->c_expr && (cmd->c_flags & CF_OPTIMIZE) == CFT_FALSE) opt_arg(cmd,1, cmd->c_type == C_EXPR); while_io(cmd); /* add $_ =, if necessary */ /* First find the end of the true list */ tail = cmd->ucmd.ccmd.cc_true; if (tail == Nullcmd) return cmd; New(112,newtail, 1, CMD); /* guaranteed continue */ for (;;) { /* optimize "next" to point directly to continue block */ if (tail->c_type == C_EXPR && tail->ucmd.acmd.ac_expr && tail->ucmd.acmd.ac_expr->arg_type == O_NEXT && (tail->ucmd.acmd.ac_expr->arg_len == 0 || (cmd->c_label && strEQ(cmd->c_label, tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) ))) { arg_free(tail->ucmd.acmd.ac_expr); tail->c_type = C_NEXT; if (cmd->ucmd.ccmd.cc_alt != Nullcmd) tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt; else tail->ucmd.ccmd.cc_alt = newtail; tail->ucmd.ccmd.cc_true = Nullcmd; } else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) { if (cmd->ucmd.ccmd.cc_alt != Nullcmd) tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt; else tail->ucmd.ccmd.cc_alt = newtail; } else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) { if (cmd->ucmd.ccmd.cc_alt != Nullcmd) { for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) if (!tail->ucmd.scmd.sc_next[i]) tail->ucmd.scmd.sc_next[i] = cmd->ucmd.ccmd.cc_alt; } else { for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) if (!tail->ucmd.scmd.sc_next[i]) tail->ucmd.scmd.sc_next[i] = newtail; } } if (!tail->c_next) break; tail = tail->c_next; } /* if there's a continue block, link it to true block and find end */ if (cmd->ucmd.ccmd.cc_alt != Nullcmd) { tail->c_next = cmd->ucmd.ccmd.cc_alt; tail = tail->c_next; for (;;) { /* optimize "next" to point directly to continue block */ if (tail->c_type == C_EXPR && tail->ucmd.acmd.ac_expr && tail->ucmd.acmd.ac_expr->arg_type == O_NEXT && (tail->ucmd.acmd.ac_expr->arg_len == 0 || (cmd->c_label && strEQ(cmd->c_label, tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) ))) { arg_free(tail->ucmd.acmd.ac_expr); tail->c_type = C_NEXT; tail->ucmd.ccmd.cc_alt = newtail; tail->ucmd.ccmd.cc_true = Nullcmd; } else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) { tail->ucmd.ccmd.cc_alt = newtail; } else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) { for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) if (!tail->ucmd.scmd.sc_next[i]) tail->ucmd.scmd.sc_next[i] = newtail; } if (!tail->c_next) break; tail = tail->c_next; } for ( ; tail->c_next; tail = tail->c_next) ; } /* Here's the real trick: link the end of the list back to the beginning, * inserting a "last" block to break out of the loop. This saves one or * two procedure calls every time through the loop, because of how cmd_exec * does tail recursion. */ tail->c_next = newtail; tail = newtail; if (!cmd->ucmd.ccmd.cc_alt) cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */ #ifndef lint (void)bcopy((char *)cmd, (char *)tail, sizeof(CMD)); #endif tail->c_type = C_EXPR; tail->c_flags ^= CF_INVERT; /* turn into "last unless" */ tail->c_next = tail->ucmd.ccmd.cc_true; /* loop directly back to top */ tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg); tail->ucmd.acmd.ac_stab = Nullstab; return cmd; } CMD * over(eachstab,cmd) STAB *eachstab; register CMD *cmd; { /* hoist "for $foo (@bar)" up into command block */ cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ cmd->c_flags |= CFT_ARRAY; /* and set it to do the iteration */ cmd->c_stab = eachstab; cmd->c_short = str_new(0); /* just to save a field in struct cmd */ cmd->c_short->str_u.str_useful = -1; return cmd; } cmd_free(cmd) register CMD *cmd; { register CMD *tofree; register CMD *head = cmd; while (cmd) { if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */ if (cmd->c_label) Safefree(cmd->c_label); if (cmd->c_short) str_free(cmd->c_short); if (cmd->c_spat) spat_free(cmd->c_spat); if (cmd->c_expr) arg_free(cmd->c_expr); } switch (cmd->c_type) { case C_WHILE: case C_BLOCK: case C_ELSE: case C_IF: if (cmd->ucmd.ccmd.cc_true) cmd_free(cmd->ucmd.ccmd.cc_true); break; case C_EXPR: if (cmd->ucmd.acmd.ac_expr) arg_free(cmd->ucmd.acmd.ac_expr); break; } tofree = cmd; cmd = cmd->c_next; Safefree(tofree); if (cmd && cmd == head) /* reached end of while loop */ break; } } arg_free(arg) register ARG *arg; { register int i; for (i = 1; i <= arg->arg_len; i++) { switch (arg[i].arg_type & A_MASK) { case A_NULL: break; case A_LEXPR: if (arg->arg_type == O_AASSIGN && arg[i].arg_ptr.arg_arg->arg_type == O_LARRAY) { char *name = stab_name(arg[i].arg_ptr.arg_arg[1].arg_ptr.arg_stab); if (strnEQ("_GEN_",name, 5)) /* array for foreach */ hdelete(defstash,name,strlen(name)); } /* FALL THROUGH */ case A_EXPR: arg_free(arg[i].arg_ptr.arg_arg); break; case A_CMD: cmd_free(arg[i].arg_ptr.arg_cmd); break; case A_WORD: case A_STAB: case A_LVAL: case A_READ: case A_GLOB: case A_ARYLEN: case A_LARYLEN: case A_ARYSTAB: case A_LARYSTAB: break; case A_SINGLE: case A_DOUBLE: case A_BACKTICK: str_free(arg[i].arg_ptr.arg_str); break; case A_SPAT: spat_free(arg[i].arg_ptr.arg_spat); break; } } free_arg(arg); } spat_free(spat) register SPAT *spat; { register SPAT *sp; HENT *entry; if (spat->spat_runtime) arg_free(spat->spat_runtime); if (spat->spat_repl) { arg_free(spat->spat_repl); } if (spat->spat_short) { str_free(spat->spat_short); } if (spat->spat_regexp) { regfree(spat->spat_regexp); } /* now unlink from spat list */ for (entry = defstash->tbl_array['_']; entry; entry = entry->hent_next) { register HASH *stash; STAB *stab = (STAB*)entry->hent_val; if (!stab) continue; stash = stab_hash(stab); if (!stash || stash->tbl_spatroot == Null(SPAT*)) continue; if (stash->tbl_spatroot == spat) stash->tbl_spatroot = spat->spat_next; else { for (sp = stash->tbl_spatroot; sp && sp->spat_next != spat; sp = sp->spat_next) ; if (sp) sp->spat_next = spat->spat_next; } } Safefree(spat); } /* Recursively descend a command sequence and push the address of any string * that needs saving on recursion onto the tosave array. */ static int cmd_tosave(cmd,willsave) register CMD *cmd; int willsave; /* willsave passes down the tree */ { register CMD *head = cmd; int shouldsave = FALSE; /* shouldsave passes up the tree */ int tmpsave; register CMD *lastcmd = Nullcmd; while (cmd) { if (cmd->c_spat) shouldsave |= spat_tosave(cmd->c_spat); if (cmd->c_expr) shouldsave |= arg_tosave(cmd->c_expr,willsave); switch (cmd->c_type) { case C_WHILE: if (cmd->ucmd.ccmd.cc_true) { tmpsave = cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave); /* Here we check to see if the temporary array generated for * a foreach needs to be localized because of recursion. */ if (tmpsave && (cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY) { if (lastcmd && lastcmd->c_type == C_EXPR && lastcmd->ucmd.acmd.ac_expr) { ARG *arg = lastcmd->ucmd.acmd.ac_expr; if (arg->arg_type == O_ASSIGN && arg[1].arg_type == A_LEXPR && arg[1].arg_ptr.arg_arg->arg_type == O_LARRAY && strnEQ("_GEN_", stab_name( arg[1].arg_ptr.arg_arg[1].arg_ptr.arg_stab), 5)) { /* array generated for foreach */ (void)localize(arg[1].arg_ptr.arg_arg); } } /* in any event, save the iterator */ (void)apush(tosave,cmd->c_short); } shouldsave |= tmpsave; } break; case C_BLOCK: case C_ELSE: case C_IF: if (cmd->ucmd.ccmd.cc_true) shouldsave |= cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave); break; case C_EXPR: if (cmd->ucmd.acmd.ac_expr) shouldsave |= arg_tosave(cmd->ucmd.acmd.ac_expr,willsave); break; } lastcmd = cmd; cmd = cmd->c_next; if (cmd && cmd == head) /* reached end of while loop */ break; } return shouldsave; } static int arg_tosave(arg,willsave) register ARG *arg; int willsave; { register int i; int shouldsave = FALSE; for (i = arg->arg_len; i >= 1; i--) { switch (arg[i].arg_type & A_MASK) { case A_NULL: break; case A_LEXPR: case A_EXPR: shouldsave |= arg_tosave(arg[i].arg_ptr.arg_arg,shouldsave); break; case A_CMD: shouldsave |= cmd_tosave(arg[i].arg_ptr.arg_cmd,shouldsave); break; case A_WORD: case A_STAB: case A_LVAL: case A_READ: case A_GLOB: case A_ARYLEN: case A_SINGLE: case A_DOUBLE: case A_BACKTICK: break; case A_SPAT: shouldsave |= spat_tosave(arg[i].arg_ptr.arg_spat); break; } } switch (arg->arg_type) { case O_RETURN: saw_return = TRUE; break; case O_EVAL: case O_SUBR: shouldsave = TRUE; break; } if (willsave) (void)apush(tosave,arg->arg_ptr.arg_str); return shouldsave; } static int spat_tosave(spat) register SPAT *spat; { int shouldsave = FALSE; if (spat->spat_runtime) shouldsave |= arg_tosave(spat->spat_runtime,FALSE); if (spat->spat_repl) { shouldsave |= arg_tosave(spat->spat_repl,FALSE); } return shouldsave; } } } switch (arg->arg_type) { case O_RETURN: saw_return = TRUE; break; case O_EVAL: case O_SUBR: shouldsave = TRUE; break; } if (willsave) (void)apush(tosave,arg->arg_ptr.arg_str); return shouldsave; } static int spat_tosave(spat) register SPAT *spat; { int shouldsave = FALSE; if (spat->spat_runtime) shouldsave |= arg_tosave(spat->spat_runtime,perl/Copying 644 473 0 30307 4747105031 6404 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program perl/doarg.c 644 473 0 76262 4747105032 6324 /* $Header: doarg.c,v 3.0.1.3 90/02/28 16:56:58 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: doarg.c,v $ * Revision 3.0.1.3 90/02/28 16:56:58 lwall * patch9: split now can split into more than 10000 elements * patch9: sped up pack and unpack * patch9: pack of unsigned ints and longs blew up some places * patch9: sun3 can't cast negative float to unsigned int or long * patch9: local($.) didn't work * patch9: grep(s/foo/bar/, @abc = @xyz) modified @xyz rather than @abc * patch9: syscall returned stack size rather than value of system call * * Revision 3.0.1.2 89/12/21 19:52:15 lwall * patch7: a pattern wouldn't match a null string before the first character * patch7: certain patterns didn't match correctly at end of string * * Revision 3.0.1.1 89/11/11 04:17:20 lwall * patch2: printf %c, %D, %X and %O didn't work right * patch2: printf of unsigned vs signed needed separate casts on some machines * * Revision 3.0 89/10/18 15:10:41 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" #include extern unsigned char fold[]; int wantarray; int do_subst(str,arg,sp) STR *str; ARG *arg; int sp; { register SPAT *spat; SPAT *rspat; register STR *dstr; register char *s = str_get(str); char *strend = s + str->str_cur; register char *m; char *c; register char *d; int clen; int iters = 0; int maxiters = (strend - s) + 10; register int i; bool once; char *orig; int safebase; rspat = spat = arg[2].arg_ptr.arg_spat; if (!spat || !s) fatal("panic: do_subst"); else if (spat->spat_runtime) { nointrp = "|)"; (void)eval(spat->spat_runtime,G_SCALAR,sp); m = str_get(dstr = stack->ary_array[sp+1]); nointrp = ""; if (spat->spat_regexp) regfree(spat->spat_regexp); spat->spat_regexp = regcomp(m,m+dstr->str_cur, spat->spat_flags & SPAT_FOLD,1); if (spat->spat_flags & SPAT_KEEP) { arg_free(spat->spat_runtime); /* it won't change, so */ spat->spat_runtime = Nullarg; /* no point compiling again */ } } #ifdef DEBUGGING if (debug & 8) { deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); } #endif safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) && !sawampersand); if (!*spat->spat_regexp->precomp && lastspat) spat = lastspat; orig = m = s; if (hint) { if (hint < s || hint > strend) fatal("panic: hint in do_match"); s = hint; hint = Nullch; if (spat->spat_regexp->regback >= 0) { s -= spat->spat_regexp->regback; if (s < m) s = m; } else s = m; } else if (spat->spat_short) { if (spat->spat_flags & SPAT_SCANFIRST) { if (str->str_pok & SP_STUDIED) { if (screamfirst[spat->spat_short->str_rare] < 0) goto nope; else if (!(s = screaminstr(str,spat->spat_short))) goto nope; } #ifndef lint else if (!(s = fbminstr((unsigned char*)s, (unsigned char*)strend, spat->spat_short))) goto nope; #endif if (s && spat->spat_regexp->regback >= 0) { ++spat->spat_short->str_u.str_useful; s -= spat->spat_regexp->regback; if (s < m) s = m; } else s = m; } else if (!multiline && (*spat->spat_short->str_ptr != *s || bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) )) goto nope; if (--spat->spat_short->str_u.str_useful < 0) { str_free(spat->spat_short); spat->spat_short = Nullstr; /* opt is being useless */ } } once = ((rspat->spat_flags & SPAT_ONCE) != 0); if (rspat->spat_flags & SPAT_CONST) { /* known replacement string? */ if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE) dstr = rspat->spat_repl[1].arg_ptr.arg_str; else { /* constant over loop, anyway */ (void)eval(rspat->spat_repl,G_SCALAR,sp); dstr = stack->ary_array[sp+1]; } c = str_get(dstr); clen = dstr->str_cur; if (clen <= spat->spat_slen + spat->spat_regexp->regback) { /* can do inplace substitution */ if (regexec(spat->spat_regexp, s, strend, orig, 0, str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) { if (spat->spat_regexp->subbase) /* oops, no we can't */ goto long_way; d = s; lastspat = spat; str->str_pok = SP_VALID; /* disable possible screamer */ if (once) { m = spat->spat_regexp->startp[0]; d = spat->spat_regexp->endp[0]; s = orig; if (m - s > strend - d) { /* faster to shorten from end */ if (clen) { (void)bcopy(c, m, clen); m += clen; } i = strend - d; if (i > 0) { (void)bcopy(d, m, i); m += i; } *m = '\0'; str->str_cur = m - s; STABSET(str); str_numset(arg->arg_ptr.arg_str, 1.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; return sp; } else if (i = m - s) { /* faster from front */ d -= clen; m = d; str_chop(str,d-i); s += i; while (i--) *--d = *--s; if (clen) (void)bcopy(c, m, clen); STABSET(str); str_numset(arg->arg_ptr.arg_str, 1.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; return sp; } else if (clen) { d -= clen; str_chop(str,d); (void)bcopy(c,d,clen); STABSET(str); str_numset(arg->arg_ptr.arg_str, 1.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; return sp; } else { str_chop(str,d); STABSET(str); str_numset(arg->arg_ptr.arg_str, 1.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; return sp; } /* NOTREACHED */ } do { if (iters++ > maxiters) fatal("Substitution loop"); m = spat->spat_regexp->startp[0]; if (i = m - s) { if (s != d) (void)bcopy(s,d,i); d += i; } if (clen) { (void)bcopy(c,d,clen); d += clen; } s = spat->spat_regexp->endp[0]; } while (regexec(spat->spat_regexp, s, strend, orig, s == m, Nullstr, TRUE)); /* (don't match same null twice) */ if (s != d) { i = strend - s; str->str_cur = d - str->str_ptr + i; (void)bcopy(s,d,i+1); /* include the Null */ } STABSET(str); str_numset(arg->arg_ptr.arg_str, (double)iters); stack->ary_array[++sp] = arg->arg_ptr.arg_str; return sp; } str_numset(arg->arg_ptr.arg_str, 0.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; return sp; } } else c = Nullch; if (regexec(spat->spat_regexp, s, strend, orig, 0, str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) { long_way: dstr = Str_new(25,str_len(str)); str_nset(dstr,m,s-m); if (spat->spat_regexp->subbase) curspat = spat; lastspat = spat; do { if (iters++ > maxiters) fatal("Substitution loop"); if (spat->spat_regexp->subbase && spat->spat_regexp->subbase != orig) { m = s; s = orig; orig = spat->spat_regexp->subbase; s = orig + (m - s); strend = s + (strend - m); } m = spat->spat_regexp->startp[0]; str_ncat(dstr,s,m-s); s = spat->spat_regexp->endp[0]; if (c) { if (clen) str_ncat(dstr,c,clen); } else { (void)eval(rspat->spat_repl,G_SCALAR,sp); str_scat(dstr,stack->ary_array[sp+1]); } if (once) break; } while (regexec(spat->spat_regexp, s, strend, orig, s == m, Nullstr, safebase)); str_ncat(dstr,s,strend - s); str_replace(str,dstr); STABSET(str); str_numset(arg->arg_ptr.arg_str, (double)iters); stack->ary_array[++sp] = arg->arg_ptr.arg_str; return sp; } str_numset(arg->arg_ptr.arg_str, 0.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; return sp; nope: ++spat->spat_short->str_u.str_useful; str_numset(arg->arg_ptr.arg_str, 0.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; return sp; } int do_trans(str,arg) STR *str; register ARG *arg; { register char *tbl; register char *s; register int matches = 0; register int ch; register char *send; tbl = arg[2].arg_ptr.arg_cval; s = str_get(str); send = s + str->str_cur; if (!tbl || !s) fatal("panic: do_trans"); #ifdef DEBUGGING if (debug & 8) { deb("2.TBL\n"); } #endif while (s < send) { if (ch = tbl[*s & 0377]) { matches++; *s = ch; } s++; } STABSET(str); return matches; } void do_join(str,arglast) register STR *str; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int items = arglast[2] - sp; register char *delim = str_get(st[sp]); int delimlen = st[sp]->str_cur; st += ++sp; if (items-- > 0) str_sset(str,*st++); else str_set(str,""); for (; items > 0; items--,st++) { str_ncat(str,delim,delimlen); str_scat(str,*st); } STABSET(str); } void do_pack(str,arglast) register STR *str; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int items; register char *pat = str_get(st[sp]); register char *patend = pat + st[sp]->str_cur; register int len; int datumtype; STR *fromstr; static char *null10 = "\0\0\0\0\0\0\0\0\0\0"; static char *space10 = " "; /* These must not be in registers: */ char achar; short ashort; int aint; unsigned int auint; long along; unsigned long aulong; char *aptr; items = arglast[2] - sp; st += ++sp; str_nset(str,"",0); while (pat < patend) { #define NEXTFROM (items-- > 0 ? *st++ : &str_no) datumtype = *pat++; if (isdigit(*pat)) { len = *pat++ - '0'; while (isdigit(*pat)) len = (len * 10) + (*pat++ - '0'); } else len = 1; switch(datumtype) { default: break; case 'x': while (len >= 10) { str_ncat(str,null10,10); len -= 10; } str_ncat(str,null10,len); break; case 'A': case 'a': fromstr = NEXTFROM; aptr = str_get(fromstr); if (fromstr->str_cur > len) str_ncat(str,aptr,len); else str_ncat(str,aptr,fromstr->str_cur); len -= fromstr->str_cur; if (datumtype == 'A') { while (len >= 10) { str_ncat(str,space10,10); len -= 10; } str_ncat(str,space10,len); } else { while (len >= 10) { str_ncat(str,null10,10); len -= 10; } str_ncat(str,null10,len); } break; case 'C': case 'c': while (len-- > 0) { fromstr = NEXTFROM; aint = (int)str_gnum(fromstr); achar = aint; str_ncat(str,&achar,sizeof(char)); } break; case 'n': while (len-- > 0) { fromstr = NEXTFROM; ashort = (short)str_gnum(fromstr); #ifdef HTONS ashort = htons(ashort); #endif str_ncat(str,(char*)&ashort,sizeof(short)); } break; case 'S': case 's': while (len-- > 0) { fromstr = NEXTFROM; ashort = (short)str_gnum(fromstr); str_ncat(str,(char*)&ashort,sizeof(short)); } break; case 'I': while (len-- > 0) { fromstr = NEXTFROM; auint = (unsigned int)str_gnum(fromstr); str_ncat(str,(char*)&auint,sizeof(unsigned int)); } break; case 'i': while (len-- > 0) { fromstr = NEXTFROM; aint = (int)str_gnum(fromstr); str_ncat(str,(char*)&aint,sizeof(int)); } break; case 'N': while (len-- > 0) { fromstr = NEXTFROM; along = (long)str_gnum(fromstr); #ifdef HTONL along = htonl(along); #endif str_ncat(str,(char*)&along,sizeof(long)); } break; case 'L': while (len-- > 0) { fromstr = NEXTFROM; aulong = (unsigned long)str_gnum(fromstr); str_ncat(str,(char*)&aulong,sizeof(unsigned long)); } break; case 'l': while (len-- > 0) { fromstr = NEXTFROM; along = (long)str_gnum(fromstr); str_ncat(str,(char*)&along,sizeof(long)); } break; case 'p': while (len-- > 0) { fromstr = NEXTFROM; aptr = str_get(fromstr); str_ncat(str,(char*)&aptr,sizeof(char*)); } break; } } STABSET(str); } #undef NEXTFROM void do_sprintf(str,len,sarg) register STR *str; register int len; register STR **sarg; { register char *s; register char *t; bool dolong; char ch; static STR *sargnull = &str_no; register char *send; char *xs; int xlen; double value; str_set(str,""); len--; /* don't count pattern string */ s = str_get(*sarg); send = s + (*sarg)->str_cur; sarg++; for ( ; s < send; len--) { if (len <= 0 || !*sarg) { sarg = &sargnull; len = 0; } dolong = FALSE; for (t = s; t < send && *t != '%'; t++) ; if (t >= send) break; /* not enough % patterns, oh well */ for (t++; *sarg && t < send && t != s; t++) { switch (*t) { default: ch = *(++t); *t = '\0'; (void)sprintf(buf,s); s = t; *(t--) = ch; len++; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '.': case '#': case '-': case '+': break; case 'l': dolong = TRUE; break; case 'c': ch = *(++t); *t = '\0'; xlen = (int)str_gnum(*(sarg++)); if (strEQ(t-2,"%c")) { /* some printfs fail on null chars */ *buf = xlen; str_ncat(str,s,t - s - 2); str_ncat(str,buf,1); /* so handle simple case */ *buf = '\0'; } else (void)sprintf(buf,s,xlen); s = t; *(t--) = ch; break; case 'D': dolong = TRUE; /* FALL THROUGH */ case 'd': ch = *(++t); *t = '\0'; if (dolong) (void)sprintf(buf,s,(long)str_gnum(*(sarg++))); else (void)sprintf(buf,s,(int)str_gnum(*(sarg++))); s = t; *(t--) = ch; break; case 'X': case 'O': dolong = TRUE; /* FALL THROUGH */ case 'x': case 'o': case 'u': ch = *(++t); *t = '\0'; value = str_gnum(*(sarg++)); #if defined(sun) && !defined(sparc) if (value < 0.0) { /* sigh */ if (dolong) (void)sprintf(buf,s,(long)value); else (void)sprintf(buf,s,(int)value); } else #endif if (dolong) (void)sprintf(buf,s,(unsigned long)value); else (void)sprintf(buf,s,(unsigned int)value); s = t; *(t--) = ch; break; case 'E': case 'e': case 'f': case 'G': case 'g': ch = *(++t); *t = '\0'; (void)sprintf(buf,s,str_gnum(*(sarg++))); s = t; *(t--) = ch; break; case 's': ch = *(++t); *t = '\0'; xs = str_get(*sarg); xlen = (*sarg)->str_cur; if (*xs == 'S' && xs[1] == 't' && xs[2] == 'a' && xs[3] == 'b' && xlen == sizeof(STBP) && strlen(xs) < xlen) { xs = stab_name(((STAB*)(*sarg))); /* a stab value! */ sprintf(tokenbuf,"*%s",xs); /* reformat to non-binary */ xs = tokenbuf; xlen = strlen(tokenbuf); } if (strEQ(t-2,"%s")) { /* some printfs fail on >128 chars */ *buf = '\0'; str_ncat(str,s,t - s - 2); str_ncat(str,xs,xlen); /* so handle simple case */ } else (void)sprintf(buf,s,xs); sarg++; s = t; *(t--) = ch; break; } } if (s < t && t >= send) { str_cat(str,s); s = t; break; } str_cat(str,buf); } if (*s) { (void)sprintf(buf,s,0,0,0,0); str_cat(str,buf); } STABSET(str); } STR * do_push(ary,arglast) register ARRAY *ary; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int items = arglast[2] - sp; register STR *str = &str_undef; for (st += ++sp; items > 0; items--,st++) { str = Str_new(26,0); if (*st) str_sset(str,*st); (void)apush(ary,str); } return str; } int do_unshift(ary,arglast) register ARRAY *ary; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int items = arglast[2] - sp; register STR *str; register int i; aunshift(ary,items); i = 0; for (st += ++sp; i < items; i++,st++) { str = Str_new(27,0); str_sset(str,*st); (void)astore(ary,i,str); } } int do_subr(arg,gimme,arglast) register ARG *arg; int gimme; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int items = arglast[2] - sp; register SUBR *sub; ARRAY *savearray; STAB *stab; char *oldfile = filename; int oldsave = savestack->ary_fill; int oldtmps_base = tmps_base; if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else { STR *tmpstr = stab_val(arg[1].arg_ptr.arg_stab); if (tmpstr) stab = stabent(str_get(tmpstr),TRUE); else stab = Nullstab; } if (!stab) fatal("Undefined subroutine called"); sub = stab_sub(stab); if (!sub) fatal("Undefined subroutine \"%s\" called", stab_name(stab)); if ((arg[2].arg_type & A_MASK) != A_NULL) { savearray = stab_xarray(defstab); stab_xarray(defstab) = afake(defstab, items, &st[sp+1]); } savelong(&sub->depth); sub->depth++; saveint(&wantarray); wantarray = gimme; if (sub->depth >= 2) { /* save temporaries on recursion? */ if (sub->depth == 100 && dowarn) warn("Deep recursion on subroutine \"%s\"",stab_name(stab)); savelist(sub->tosave->ary_array,sub->tosave->ary_fill); } filename = sub->filename; tmps_base = tmps_max; sp = cmd_exec(sub->cmd,gimme,--sp); /* so do it already */ st = stack->ary_array; if ((arg[2].arg_type & A_MASK) != A_NULL) { afree(stab_xarray(defstab)); /* put back old $_[] */ stab_xarray(defstab) = savearray; } filename = oldfile; tmps_base = oldtmps_base; if (savestack->ary_fill > oldsave) { for (items = arglast[0] + 1; items <= sp; items++) st[items] = str_static(st[items]); /* in case restore wipes old str */ restorelist(oldsave); } return sp; } int do_dbsubr(arg,gimme,arglast) register ARG *arg; int gimme; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int items = arglast[2] - sp; register SUBR *sub; ARRAY *savearray; STR *str; STAB *stab; char *oldfile = filename; int oldsave = savestack->ary_fill; int oldtmps_base = tmps_base; if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else { STR *tmpstr = stab_val(arg[1].arg_ptr.arg_stab); if (tmpstr) stab = stabent(str_get(tmpstr),TRUE); else stab = Nullstab; } if (!stab) fatal("Undefined subroutine called"); sub = stab_sub(stab); if (!sub) fatal("Undefined subroutine \"%s\" called", stab_name(stab)); /* begin differences */ str = stab_val(DBsub); saveitem(str); str_set(str,stab_name(stab)); sub = stab_sub(DBsub); if (!sub) fatal("No DBsub routine"); /* end differences */ if ((arg[2].arg_type & A_MASK) != A_NULL) { savearray = stab_xarray(defstab); stab_xarray(defstab) = afake(defstab, items, &st[sp+1]); } savelong(&sub->depth); sub->depth++; saveint(&wantarray); wantarray = gimme; if (sub->depth >= 2) { /* save temporaries on recursion? */ if (sub->depth == 100 && dowarn) warn("Deep recursion on subroutine \"%s\"",stab_name(stab)); savelist(sub->tosave->ary_array,sub->tosave->ary_fill); } filename = sub->filename; tmps_base = tmps_max; sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */ st = stack->ary_array; if ((arg[2].arg_type & A_MASK) != A_NULL) { afree(stab_xarray(defstab)); /* put back old $_[] */ stab_xarray(defstab) = savearray; } filename = oldfile; tmps_base = oldtmps_base; if (savestack->ary_fill > oldsave) { for (items = arglast[0] + 1; items <= sp; items++) st[items] = str_static(st[items]); /* in case restore wipes old str */ restorelist(oldsave); } return sp; } int do_assign(arg,gimme,arglast) register ARG *arg; int gimme; int *arglast; { register STR **st = stack->ary_array; STR **firstrelem = st + arglast[1] + 1; STR **firstlelem = st + arglast[0] + 1; STR **lastrelem = st + arglast[2]; STR **lastlelem = st + arglast[1]; register STR **relem; register STR **lelem; register STR *str; register ARRAY *ary; register int makelocal; HASH *hash; int i; makelocal = (arg->arg_flags & AF_LOCAL); localizing = makelocal; delaymagic = DM_DELAY; /* catch simultaneous items */ /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. */ if (arg->arg_flags & AF_COMMON) { for (relem = firstrelem; relem <= lastrelem; relem++) { if (str = *relem) *relem = str_static(str); } } relem = firstrelem; lelem = firstlelem; ary = Null(ARRAY*); hash = Null(HASH*); while (lelem <= lastlelem) { str = *lelem++; if (str->str_state >= SS_HASH) { if (str->str_state == SS_ARY) { if (makelocal) ary = saveary(str->str_u.str_stab); else { ary = stab_array(str->str_u.str_stab); ary->ary_fill = -1; } i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ str = Str_new(28,0); if (*relem) str_sset(str,*relem); *(relem++) = str; (void)astore(ary,i++,str); } } else if (str->str_state == SS_HASH) { char *tmps; STR *tmpstr; if (makelocal) hash = savehash(str->str_u.str_stab); else { hash = stab_hash(str->str_u.str_stab); hclear(hash); } while (relem < lastrelem) { /* gobble up all the rest */ if (*relem) str = *(relem++); else str = &str_no, relem++; tmps = str_get(str); tmpstr = Str_new(29,0); if (*relem) str_sset(tmpstr,*relem); /* value */ *(relem++) = tmpstr; (void)hstore(hash,tmps,str->str_cur,tmpstr,0); } } else fatal("panic: do_assign"); } else { if (makelocal) saveitem(str); if (relem <= lastrelem) { str_sset(str, *relem); *(relem++) = str; } else { str_nset(str, "", 0); if (gimme == G_ARRAY) { i = ++lastrelem - firstrelem; relem++; /* tacky, I suppose */ astore(stack,i,str); if (st != stack->ary_array) { st = stack->ary_array; firstrelem = st + arglast[1] + 1; firstlelem = st + arglast[0] + 1; lastlelem = st + arglast[1]; lastrelem = st + i; relem = lastrelem + 1; } } } STABSET(str); } } if (delaymagic > 1) { #ifdef SETREUID if (delaymagic & DM_REUID) setreuid(uid,euid); #endif #ifdef SETREGID if (delaymagic & DM_REGID) setregid(gid,egid); #endif } delaymagic = 0; localizing = FALSE; if (gimme == G_ARRAY) { i = lastrelem - firstrelem + 1; if (ary || hash) Copy(firstrelem, firstlelem, i, STR*); return arglast[0] + i; } else { str_numset(arg->arg_ptr.arg_str,(double)(arglast[2] - arglast[1])); *firstlelem = arg->arg_ptr.arg_str; return arglast[0] + 1; } } int do_study(str,arg,gimme,arglast) STR *str; ARG *arg; int gimme; int *arglast; { register unsigned char *s; register int pos = str->str_cur; register int ch; register int *sfirst; register int *snext; static int maxscream = -1; static STR *lastscream = Nullstr; int retval; int retarg = arglast[0] + 1; #ifndef lint s = (unsigned char*)(str_get(str)); #else s = Null(unsigned char*); #endif if (lastscream) lastscream->str_pok &= ~SP_STUDIED; lastscream = str; if (pos <= 0) { retval = 0; goto ret; } if (pos > maxscream) { if (maxscream < 0) { maxscream = pos + 80; New(301,screamfirst, 256, int); New(302,screamnext, maxscream, int); } else { maxscream = pos + pos / 4; Renew(screamnext, maxscream, int); } } sfirst = screamfirst; snext = screamnext; if (!sfirst || !snext) fatal("do_study: out of memory"); for (ch = 256; ch; --ch) *sfirst++ = -1; sfirst -= 256; while (--pos >= 0) { ch = s[pos]; if (sfirst[ch] >= 0) snext[pos] = sfirst[ch] - pos; else snext[pos] = -pos; sfirst[ch] = pos; /* If there were any case insensitive searches, we must assume they * all are. This speeds up insensitive searches much more than * it slows down sensitive ones. */ if (sawi) sfirst[fold[ch]] = pos; } str->str_pok |= SP_STUDIED; retval = 1; ret: str_numset(arg->arg_ptr.arg_str,(double)retval); stack->ary_array[retarg] = arg->arg_ptr.arg_str; return retarg; } int do_defined(str,arg,gimme,arglast) STR *str; register ARG *arg; int gimme; int *arglast; { register int type; register int retarg = arglast[0] + 1; int retval; if ((arg[1].arg_type & A_MASK) != A_LEXPR) fatal("Illegal argument to defined()"); arg = arg[1].arg_ptr.arg_arg; type = arg->arg_type; if (type == O_ARRAY || type == O_LARRAY) retval = stab_xarray(arg[1].arg_ptr.arg_stab) != 0; else if (type == O_HASH || type == O_LHASH) retval = stab_xhash(arg[1].arg_ptr.arg_stab) != 0; else if (type == O_SUBR || type == O_DBSUBR) retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0; else if (type == O_ASLICE || type == O_LASLICE) retval = stab_xarray(arg[1].arg_ptr.arg_stab) != 0; else if (type == O_HSLICE || type == O_LHSLICE) retval = stab_xhash(arg[1].arg_ptr.arg_stab) != 0; else retval = FALSE; str_numset(str,(double)retval); stack->ary_array[retarg] = str; return retarg; } int do_undef(str,arg,gimme,arglast) STR *str; register ARG *arg; int gimme; int *arglast; { register int type; register STAB *stab; int retarg = arglast[0] + 1; if ((arg[1].arg_type & A_MASK) != A_LEXPR) fatal("Illegal argument to undef()"); arg = arg[1].arg_ptr.arg_arg; type = arg->arg_type; if (type == O_ARRAY || type == O_LARRAY) { stab = arg[1].arg_ptr.arg_stab; afree(stab_xarray(stab)); stab_xarray(stab) = Null(ARRAY*); } else if (type == O_HASH || type == O_LHASH) { stab = arg[1].arg_ptr.arg_stab; (void)hfree(stab_xhash(stab)); stab_xhash(stab) = Null(HASH*); } else if (type == O_SUBR || type == O_DBSUBR) { stab = arg[1].arg_ptr.arg_stab; cmd_free(stab_sub(stab)->cmd); afree(stab_sub(stab)->tosave); Safefree(stab_sub(stab)); stab_sub(stab) = Null(SUBR*); } else fatal("Can't undefine that kind of object"); str_numset(str,0.0); stack->ary_array[retarg] = str; return retarg; } int do_vec(lvalue,astr,arglast) int lvalue; STR *astr; int *arglast; { STR **st = stack->ary_array; int sp = arglast[0]; register STR *str = st[++sp]; register int offset = (int)str_gnum(st[++sp]); register int size = (int)str_gnum(st[++sp]); unsigned char *s = (unsigned char*)str_get(str); unsigned long retnum; int len; sp = arglast[1]; offset *= size; /* turn into bit offset */ len = (offset + size + 7) / 8; if (offset < 0 || size < 1) retnum = 0; else if (!lvalue && len > str->str_cur) retnum = 0; else { if (len > str->str_cur) { STR_GROW(str,len); (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur); str->str_cur = len; } s = (unsigned char*)str_get(str); if (size < 8) retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); else { offset >>= 3; if (size == 8) retnum = s[offset]; else if (size == 16) retnum = (s[offset] << 8) + s[offset+1]; else if (size == 32) retnum = (s[offset] << 24) + (s[offset + 1] << 16) + (s[offset + 2] << 8) + s[offset+3]; } if (lvalue) { /* it's an lvalue! */ struct lstring *lstr = (struct lstring*)astr; astr->str_magic = str; st[sp]->str_rare = 'v'; lstr->lstr_offset = offset; lstr->lstr_len = size; } } str_numset(astr,(double)retnum); st[sp] = astr; return sp; } void do_vecset(mstr,str) STR *mstr; STR *str; { struct lstring *lstr = (struct lstring*)str; register int offset; register int size; register unsigned char *s = (unsigned char*)mstr->str_ptr; register unsigned long lval = (unsigned long)str_gnum(str); int mask; mstr->str_rare = 0; str->str_magic = Nullstr; offset = lstr->lstr_offset; size = lstr->lstr_len; if (size < 8) { mask = (1 << size) - 1; size = offset & 7; lval &= mask; offset >>= 3; s[offset] &= ~(mask << size); s[offset] |= lval << size; } else { if (size == 8) s[offset] = lval & 255; else if (size == 16) { s[offset] = (lval >> 8) & 255; s[offset+1] = lval & 255; } else if (size == 32) { s[offset] = (lval >> 24) & 255; s[offset+1] = (lval >> 16) & 255; s[offset+2] = (lval >> 8) & 255; s[offset+3] = lval & 255; } } } do_chop(astr,str) register STR *astr; register STR *str; { register char *tmps; register int i; ARRAY *ary; HASH *hash; HENT *entry; if (!str) return; if (str->str_state == SS_ARY) { ary = stab_array(str->str_u.str_stab); for (i = 0; i <= ary->ary_fill; i++) do_chop(astr,ary->ary_array[i]); return; } if (str->str_state == SS_HASH) { hash = stab_hash(str->str_u.str_stab); (void)hiterinit(hash); while (entry = hiternext(hash)) do_chop(astr,hiterval(hash,entry)); return; } tmps = str_get(str); if (!tmps) return; tmps += str->str_cur - (str->str_cur != 0); str_nset(astr,tmps,1); /* remember last char */ *tmps = '\0'; /* wipe it out */ str->str_cur = tmps - str->str_ptr; str->str_nok = 0; } do_vop(optype,str,left,right) STR *str; STR *left; STR *right; { register char *s = str_get(str); register char *l = str_get(left); register char *r = str_get(right); register int len; len = left->str_cur; if (len > right->str_cur) len = right->str_cur; if (str->str_cur > len) str->str_cur = len; else if (str->str_cur < len) { STR_GROW(str,len); (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur); str->str_cur = len; s = str_get(str); } switch (optype) { case O_BIT_AND: while (len--) *s++ = *l++ & *r++; break; case O_XOR: while (len--) *s++ = *l++ ^ *r++; goto mop_up; case O_BIT_OR: while (len--) *s++ = *l++ | *r++; mop_up: len = str->str_cur; if (right->str_cur > len) str_ncat(str,right->str_ptr+len,right->str_cur - len); else if (left->str_cur > len) str_ncat(str,left->str_ptr+len,left->str_cur - len); break; } } int do_syscall(arglast) int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int items = arglast[2] - sp; long arg[8]; register int i = 0; int retval = -1; #ifdef SYSCALL #ifdef TAINT for (st += ++sp; items--; st++) tainted |= (*st)->str_tainted; st = stack->ary_array; sp = arglast[1]; items = arglast[2] - sp; #endif #ifdef TAINT taintproper("Insecure dependency in syscall"); #endif /* This probably won't work on machines where sizeof(long) != sizeof(int) * or where sizeof(long) != sizeof(char*). But such machines will * not likely have syscall implemented either, so who cares? */ while (items--) { if (st[++sp]->str_nok || !i) arg[i++] = (long)str_gnum(st[sp]); #ifndef lint else arg[i++] = (long)st[sp]->str_ptr; #endif /* lint */ } sp = arglast[1]; items = arglast[2] - sp; switch (items) { case 0: fatal("Too few args to syscall"); case 1: retval = syscall(arg[0]); break; case 2: retval = syscall(arg[0],arg[1]); break; case 3: retval = syscall(arg[0],arg[1],arg[2]); break; case 4: retval = syscall(arg[0],arg[1],arg[2],arg[3]); break; case 5: retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4]); break; case 6: retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5]); break; case 7: retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6]); break; case 8: retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], arg[7]); break; } return retval; #else fatal("syscall() unimplemented"); #endif } ,arg[2]); break; case 4: retval = syscall(arg[0],arg[1],arg[2],arg[3]); break; case 5: retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4]); break; case 6: retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5]); break; case 7: retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6]); break; perl/regcomp.c 644 473 0 64221 4747105032 6654 /* NOTE: this is derived from Henry Spencer's regexp code, and should not * confused with the original package (see point 3 below). Thanks, Henry! */ /* Additional note: this code is very heavily munged from Henry's version * in places. In some spots I've traded clarity for efficiency, so don't * blame Henry for some of the lack of readability. */ /* $Header: regcomp.c,v 3.0.1.2 90/02/28 18:08:35 lwall Locked $ * * $Log: regcomp.c,v $ * Revision 3.0.1.2 90/02/28 18:08:35 lwall * patch9: /[\200-\377]/ didn't work on machines with signed chars * * Revision 3.0.1.1 89/11/11 04:51:04 lwall * patch2: /[\000]/ didn't work * * Revision 3.0 89/10/18 15:22:29 lwall * 3.0 baseline * */ /* * regcomp and regexec -- regsub and regerror are not used in perl * * Copyright (c) 1986 by University of Toronto. * Written by Henry Spencer. Not derived from licensed software. * * Permission is granted to anyone to use this software for any * purpose on any computer system, and to redistribute it freely, * subject to the following restrictions: * * 1. The author is not responsible for the consequences of use of * this software, no matter how awful, even if they arise * from defects in it. * * 2. The origin of this software must not be misrepresented, either * by explicit claim or by omission. * * 3. Altered versions must be plainly marked as such, and must not * be misrepresented as being the original software. * * **** Alterations to Henry's code are... **** **** Copyright (c) 1989, Larry Wall **** **** You may distribute under the terms of the GNU General Public License **** as specified in the README file that comes with the perl 3.0 kit. * * Beware that some of this code is subtly aware of the way operator * precedence is structured in regular expressions. Serious changes in * regular-expression syntax might require a total rethink. */ #include "EXTERN.h" #include "perl.h" #include "INTERN.h" #include "regcomp.h" #ifndef STATIC #define STATIC static #endif #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?') #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \ ((*s) == '{' && regcurly(s))) #define META "^$.[()|?+*\\" /* * Flags to be passed up and down. */ #define HASWIDTH 01 /* Known never to match null string. */ #define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ #define SPSTART 04 /* Starts with * or +. */ #define WORST 0 /* Worst case. */ /* * Global work variables for regcomp(). */ static char *regprecomp; /* uncompiled string. */ static char *regparse; /* Input-scan pointer. */ static char *regxend; /* End of input for compile */ static int regnpar; /* () count. */ static char *regcode; /* Code-emit pointer; ®dummy = don't. */ static long regsize; /* Code size. */ static int regfold; static int regsawbracket; /* Did we do {d,d} trick? */ /* * Forward declarations for regcomp()'s friends. */ STATIC int regcurly(); STATIC char *reg(); STATIC char *regbranch(); STATIC char *regpiece(); STATIC char *regatom(); STATIC char *regclass(); STATIC char *regnode(); STATIC void regc(); STATIC void reginsert(); STATIC void regtail(); STATIC void regoptail(); /* - regcomp - compile a regular expression into internal code * * We can't allocate space until we know how big the compiled form will be, * but we can't compile it (and thus know how big it is) until we've got a * place to put the code. So we cheat: we compile it twice, once with code * generation turned off and size counting turned on, and once "for real". * This also means that we don't allocate space until we are sure that the * thing really will compile successfully, and we never have to move the * code and thus invalidate pointers into it. (Note that it has to be in * one piece because free() must be able to free it all.) [NB: not true in perl] * * Beware that the optimization-preparation code in here knows about some * of the structure of the compiled regexp. [I'll say.] */ regexp * regcomp(exp,xend,fold,rare) char *exp; char *xend; int fold; int rare; { register regexp *r; register char *scan; register STR *longest; register int len; register char *first; int flags; int back; int curback; extern char *safemalloc(); extern char *savestr(); if (exp == NULL) fatal("NULL regexp argument"); /* First pass: determine size, legality. */ regfold = fold; regparse = exp; regxend = xend; regprecomp = nsavestr(exp,xend-exp); regsawbracket = 0; regnpar = 1; regsize = 0L; regcode = ®dummy; regc(MAGIC); if (reg(0, &flags) == NULL) { Safefree(regprecomp); return(NULL); } /* Small enough for pointer-storage convention? */ if (regsize >= 32767L) /* Probably could be 65535L. */ FAIL("regexp too big"); /* Allocate space. */ Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp); if (r == NULL) FAIL("regexp out of space"); /* Second pass: emit code. */ if (regsawbracket) bcopy(regprecomp,exp,xend-exp); r->precomp = regprecomp; r->subbase = NULL; regparse = exp; regnpar = 1; regcode = r->program; regc(MAGIC); if (reg(0, &flags) == NULL) return(NULL); /* Dig out information for optimizations. */ r->regstart = Nullstr; /* Worst-case defaults. */ r->reganch = 0; r->regmust = Nullstr; r->regback = -1; r->regstclass = Nullch; scan = r->program+1; /* First BRANCH. */ if (OP(regnext(scan)) == END) {/* Only one top-level choice. */ scan = NEXTOPER(scan); first = scan; while ((OP(first) > OPEN && OP(first) < CLOSE) || (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) || (OP(first) == PLUS) ) first = NEXTOPER(first); /* Starting-point info. */ if (OP(first) == EXACTLY) { r->regstart = str_make(OPERAND(first)+1,*OPERAND(first)); if (r->regstart->str_cur > !(sawstudy|fold)) fbmcompile(r->regstart,fold); } else if ((exp = index(simple,OP(first))) && exp > simple) r->regstclass = first; else if (OP(first) == BOUND || OP(first) == NBOUND) r->regstclass = first; else if (OP(first) == BOL) r->reganch++; #ifdef DEBUGGING if (debug & 512) fprintf(stderr,"first %d next %d offset %d\n", OP(first), OP(NEXTOPER(first)), first - scan); #endif /* * If there's something expensive in the r.e., find the * longest literal string that must appear and make it the * regmust. Resolve ties in favor of later strings, since * the regstart check works with the beginning of the r.e. * and avoiding duplication strengthens checking. Not a * strong reason, but sufficient in the absence of others. * [Now we resolve ties in favor of the earlier string if * it happens that curback has been invalidated, since the * earlier string may buy us something the later one won't.] */ longest = str_make("",0); len = 0; curback = 0; back = 0; while (scan != NULL) { if (OP(scan) == BRANCH) { if (OP(regnext(scan)) == BRANCH) { curback = -30000; while (OP(scan) == BRANCH) scan = regnext(scan); } else /* single branch is ok */ scan = NEXTOPER(scan); } if (OP(scan) == EXACTLY) { first = scan; while (OP(regnext(scan)) >= CLOSE) scan = regnext(scan); if (curback - back == len) { str_ncat(longest, OPERAND(first)+1, *OPERAND(first)); len += *OPERAND(first); curback += *OPERAND(first); first = regnext(scan); } else if (*OPERAND(first) >= len + (curback >= 0)) { len = *OPERAND(first); str_nset(longest, OPERAND(first)+1,len); back = curback; curback += len; first = regnext(scan); } else curback += *OPERAND(first); } else if (index(varies,OP(scan))) curback = -30000; else if (index(simple,OP(scan))) curback++; scan = regnext(scan); } if (len) { r->regmust = longest; if (back < 0) back = -1; r->regback = back; if (len > !(sawstudy||fold||OP(first)==EOL)) fbmcompile(r->regmust,fold); r->regmust->str_u.str_useful = 100; if (OP(first) == EOL) /* is match anchored to EOL? */ r->regmust->str_pok |= SP_TAIL; } else str_free(longest); } r->do_folding = fold; r->nparens = regnpar - 1; #ifdef DEBUGGING if (debug & 512) regdump(r); #endif return(r); } /* - reg - regular expression, i.e. main body or parenthesized thing * * Caller must absorb opening parenthesis. * * Combining parenthesis handling with the base level of regular expression * is a trifle forced, but the need to tie the tails of the branches to what * follows makes it hard to avoid. */ static char * reg(paren, flagp) int paren; /* Parenthesized? */ int *flagp; { register char *ret; register char *br; register char *ender; register int parno; int flags; *flagp = HASWIDTH; /* Tentatively. */ /* Make an OPEN node, if parenthesized. */ if (paren) { if (regnpar >= NSUBEXP) FAIL("too many () in regexp"); parno = regnpar; regnpar++; ret = regnode(OPEN+parno); } else ret = NULL; /* Pick up the branches, linking them together. */ br = regbranch(&flags); if (br == NULL) return(NULL); if (ret != NULL) regtail(ret, br); /* OPEN -> first. */ else ret = br; if (!(flags&HASWIDTH)) *flagp &= ~HASWIDTH; *flagp |= flags&SPSTART; while (*regparse == '|') { regparse++; br = regbranch(&flags); if (br == NULL) return(NULL); regtail(ret, br); /* BRANCH -> BRANCH. */ if (!(flags&HASWIDTH)) *flagp &= ~HASWIDTH; *flagp |= flags&SPSTART; } /* Make a closing node, and hook it on the end. */ ender = regnode((paren) ? CLOSE+parno : END); regtail(ret, ender); /* Hook the tails of the branches to the closing node. */ for (br = ret; br != NULL; br = regnext(br)) regoptail(br, ender); /* Check for proper termination. */ if (paren && *regparse++ != ')') { FAIL("unmatched () in regexp"); } else if (!paren && regparse < regxend) { if (*regparse == ')') { FAIL("unmatched () in regexp"); } else FAIL("junk on end of regexp"); /* "Can't happen". */ /* NOTREACHED */ } return(ret); } /* - regbranch - one alternative of an | operator * * Implements the concatenation operator. */ static char * regbranch(flagp) int *flagp; { register char *ret; register char *chain; register char *latest; int flags; *flagp = WORST; /* Tentatively. */ ret = regnode(BRANCH); chain = NULL; while (regparse < regxend && *regparse != '|' && *regparse != ')') { latest = regpiece(&flags); if (latest == NULL) return(NULL); *flagp |= flags&HASWIDTH; if (chain == NULL) /* First piece. */ *flagp |= flags&SPSTART; else regtail(chain, latest); chain = latest; } if (chain == NULL) /* Loop ran zero times. */ (void) regnode(NOTHING); return(ret); } /* - regpiece - something followed by possible [*+?] * * Note that the branching code sequences used for ? and the general cases * of * and + are somewhat optimized: they use the same NOTHING node as * both the endmarker for their branch list and the body of the last branch. * It might seem that this node could be dispensed with entirely, but the * endmarker role is not redundant. */ static char * regpiece(flagp) int *flagp; { register char *ret; register char op; register char *next; int flags; char *origparse = regparse; int orignpar = regnpar; char *max; int iter; char ch; ret = regatom(&flags); if (ret == NULL) return(NULL); op = *regparse; /* Here's a total kludge: if after the atom there's a {\d+,?\d*} * then we decrement the first number by one and reset our * parsing back to the beginning of the same atom. If the first number * is down to 0, decrement the second number instead and fake up * a ? after it. Given the way this compiler doesn't keep track * of offsets on the first pass, this is the only way to replicate * a piece of code. Sigh. */ if (op == '{' && regcurly(regparse)) { next = regparse + 1; max = Nullch; while (isdigit(*next) || *next == ',') { if (*next == ',') { if (max) break; else max = next; } next++; } if (*next == '}') { /* got one */ regsawbracket++; /* remember we clobbered exp */ if (!max) max = next; regparse++; iter = atoi(regparse); if (iter > 0) { ch = *max; sprintf(regparse,"%.*d", max-regparse, iter - 1); *max = ch; if (*max == ',' && atoi(max+1) > 0) { ch = *next; sprintf(max+1,"%.*d", next-(max+1), atoi(max+1) - 1); *next = ch; } if (iter != 1 || (*max == ',' || atoi(max+1))) { regparse = origparse; /* back up input pointer */ regnpar = orignpar; /* don't make more parens */ } else { regparse = next; goto nest_check; } *flagp = flags; return ret; } if (*max == ',') { max++; iter = atoi(max); if (max == next) { /* any number more? */ regparse = next; op = '*'; /* fake up one with a star */ } else if (iter > 0) { op = '?'; /* fake up optional atom */ ch = *next; sprintf(max,"%.*d", next-max, iter - 1); *next = ch; if (iter == 1) regparse = next; else { regparse = origparse - 1; /* offset ++ below */ regnpar = orignpar; } } else fatal("Can't do {n,0}"); } else fatal("Can't do {0}"); } } if (!ISMULT1(op)) { *flagp = flags; return(ret); } if (!(flags&HASWIDTH) && op != '?') FAIL("regexp *+ operand could be empty"); *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); if (op == '*' && (flags&SIMPLE)) reginsert(STAR, ret); else if (op == '*') { /* Emit x* as (x&|), where & means "self". */ reginsert(BRANCH, ret); /* Either x */ regoptail(ret, regnode(BACK)); /* and loop */ regoptail(ret, ret); /* back */ regtail(ret, regnode(BRANCH)); /* or */ regtail(ret, regnode(NOTHING)); /* null. */ } else if (op == '+' && (flags&SIMPLE)) reginsert(PLUS, ret); else if (op == '+') { /* Emit x+ as x(&|), where & means "self". */ next = regnode(BRANCH); /* Either */ regtail(ret, next); regtail(regnode(BACK), ret); /* loop back */ regtail(next, regnode(BRANCH)); /* or */ regtail(ret, regnode(NOTHING)); /* null. */ } else if (op == '?') { /* Emit x? as (x|) */ reginsert(BRANCH, ret); /* Either x */ regtail(ret, regnode(BRANCH)); /* or */ next = regnode(NOTHING); /* null. */ regtail(ret, next); regoptail(ret, next); } nest_check: regparse++; if (ISMULT2(regparse)) FAIL("nested *?+ in regexp"); return(ret); } /* - regatom - the lowest level * * Optimization: gobbles an entire sequence of ordinary characters so that * it can turn them into a single node, which is smaller to store and * faster to run. Backslashed characters are exceptions, each becoming a * separate node; the code is simpler that way and it's not worth fixing. * * [Yes, it is worth fixing, some scripts can run twice the speed.] */ static char * regatom(flagp) int *flagp; { register char *ret; int flags; *flagp = WORST; /* Tentatively. */ switch (*regparse++) { case '^': ret = regnode(BOL); break; case '$': ret = regnode(EOL); break; case '.': ret = regnode(ANY); *flagp |= HASWIDTH|SIMPLE; break; case '[': ret = regclass(); *flagp |= HASWIDTH|SIMPLE; break; case '(': ret = reg(1, &flags); if (ret == NULL) return(NULL); *flagp |= flags&(HASWIDTH|SPSTART); break; case '|': case ')': FAIL("internal urp in regexp"); /* Supposed to be caught earlier. */ break; case '?': case '+': case '*': FAIL("?+* follows nothing in regexp"); break; case '\\': switch (*regparse) { case 'w': ret = regnode(ALNUM); *flagp |= HASWIDTH|SIMPLE; regparse++; break; case 'W': ret = regnode(NALNUM); *flagp |= HASWIDTH|SIMPLE; regparse++; break; case 'b': ret = regnode(BOUND); *flagp |= SIMPLE; regparse++; break; case 'B': ret = regnode(NBOUND); *flagp |= SIMPLE; regparse++; break; case 's': ret = regnode(SPACE); *flagp |= HASWIDTH|SIMPLE; regparse++; break; case 'S': ret = regnode(NSPACE); *flagp |= HASWIDTH|SIMPLE; regparse++; break; case 'd': ret = regnode(DIGIT); *flagp |= HASWIDTH|SIMPLE; regparse++; break; case 'D': ret = regnode(NDIGIT); *flagp |= HASWIDTH|SIMPLE; regparse++; break; case 'n': case 'r': case 't': case 'f': goto defchar; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if (isdigit(regparse[1])) goto defchar; else { ret = regnode(REF + *regparse++ - '0'); *flagp |= SIMPLE; } break; case '\0': if (regparse >= regxend) FAIL("trailing \\ in regexp"); /* FALL THROUGH */ default: goto defchar; } break; default: { register int len; register char ender; register char *p; char *oldp; int foo; defchar: ret = regnode(EXACTLY); regc(0); /* save spot for len */ for (len=0, p=regparse-1; len < 127 && p < regxend; len++) { oldp = p; switch (*p) { case '^': case '$': case '.': case '[': case '(': case ')': case '|': goto loopdone; case '\\': switch (*++p) { case 'w': case 'W': case 'b': case 'B': case 's': case 'S': case 'd': case 'D': --p; goto loopdone; case 'n': ender = '\n'; p++; break; case 'r': ender = '\r'; p++; break; case 't': ender = '\t'; p++; break; case 'f': ender = '\f'; p++; break; case '0': case '1': case '2': case '3':case '4': case '5': case '6': case '7': case '8':case '9': if (isdigit(p[1])) { foo = *p++ - '0'; foo <<= 3; foo += *p - '0'; if (isdigit(p[1])) foo = (foo<<3) + *++p - '0'; ender = foo; p++; } else { --p; goto loopdone; } break; case '\0': if (p >= regxend) FAIL("trailing \\ in regexp"); /* FALL THROUGH */ default: ender = *p++; break; } break; default: ender = *p++; break; } if (regfold && isupper(ender)) ender = tolower(ender); if (ISMULT2(p)) { /* Back off on ?+*. */ if (len) p = oldp; else { len++; regc(ender); } break; } regc(ender); } loopdone: regparse = p; if (len <= 0) FAIL("internal disaster in regexp"); *flagp |= HASWIDTH; if (len == 1) *flagp |= SIMPLE; if (regcode != ®dummy) *OPERAND(ret) = len; regc('\0'); } break; } return(ret); } static void regset(bits,def,c) char *bits; int def; register int c; { if (regcode == ®dummy) return; c &= 255; if (def) bits[c >> 3] &= ~(1 << (c & 7)); else bits[c >> 3] |= (1 << (c & 7)); } static char * regclass() { register char *bits; register int class; register int lastclass; register int range = 0; register char *ret; register int def; if (*regparse == '^') { /* Complement of range. */ ret = regnode(ANYBUT); regparse++; def = 0; } else { ret = regnode(ANYOF); def = 255; } bits = regcode; for (class = 0; class < 32; class++) regc(def); if (*regparse == ']' || *regparse == '-') regset(bits,def,lastclass = *regparse++); while (regparse < regxend && *regparse != ']') { class = UCHARAT(regparse++); if (class == '\\') { class = UCHARAT(regparse++); switch (class) { case 'w': for (class = 'a'; class <= 'z'; class++) regset(bits,def,class); for (class = 'A'; class <= 'Z'; class++) regset(bits,def,class); for (class = '0'; class <= '9'; class++) regset(bits,def,class); regset(bits,def,'_'); lastclass = 1234; continue; case 's': regset(bits,def,' '); regset(bits,def,'\t'); regset(bits,def,'\r'); regset(bits,def,'\f'); regset(bits,def,'\n'); lastclass = 1234; continue; case 'd': for (class = '0'; class <= '9'; class++) regset(bits,def,class); lastclass = 1234; continue; case 'n': class = '\n'; break; case 'r': class = '\r'; break; case 't': class = '\t'; break; case 'f': class = '\f'; break; case 'b': class = '\b'; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': class -= '0'; if (isdigit(*regparse)) { class <<= 3; class += *regparse++ - '0'; } if (isdigit(*regparse)) { class <<= 3; class += *regparse++ - '0'; } break; } } if (!range && class == '-' && regparse < regxend && *regparse != ']') { range = 1; continue; } if (range) { if (lastclass > class) FAIL("invalid [] range in regexp"); } else lastclass = class - 1; range = 0; for (lastclass++; lastclass <= class; lastclass++) { regset(bits,def,lastclass); if (regfold && isupper(lastclass)) regset(bits,def,tolower(lastclass)); } lastclass = class; } if (*regparse != ']') FAIL("unmatched [] in regexp"); regparse++; return ret; } /* - regnode - emit a node */ static char * /* Location. */ regnode(op) char op; { register char *ret; register char *ptr; ret = regcode; if (ret == ®dummy) { #ifdef REGALIGN if (!(regsize & 1)) regsize++; #endif regsize += 3; return(ret); } #ifdef REGALIGN #ifndef lint if (!((long)ret & 1)) *ret++ = 127; #endif #endif ptr = ret; *ptr++ = op; *ptr++ = '\0'; /* Null "next" pointer. */ *ptr++ = '\0'; regcode = ptr; return(ret); } /* - regc - emit (if appropriate) a byte of code */ static void regc(b) char b; { if (regcode != ®dummy) *regcode++ = b; else regsize++; } /* - reginsert - insert an operator in front of already-emitted operand * * Means relocating the operand. */ static void reginsert(op, opnd) char op; char *opnd; { register char *src; register char *dst; register char *place; if (regcode == ®dummy) { #ifdef REGALIGN regsize += 4; #else regsize += 3; #endif return; } src = regcode; #ifdef REGALIGN regcode += 4; #else regcode += 3; #endif dst = regcode; while (src > opnd) *--dst = *--src; place = opnd; /* Op node, where operand used to be. */ *place++ = op; *place++ = '\0'; *place++ = '\0'; } /* - regtail - set the next-pointer at the end of a node chain */ static void regtail(p, val) char *p; char *val; { register char *scan; register char *temp; register int offset; if (p == ®dummy) return; /* Find last node. */ scan = p; for (;;) { temp = regnext(scan); if (temp == NULL) break; scan = temp; } #ifdef REGALIGN offset = val - scan; #ifndef lint *(short*)(scan+1) = offset; #else offset = offset; #endif #else if (OP(scan) == BACK) offset = scan - val; else offset = val - scan; *(scan+1) = (offset>>8)&0377; *(scan+2) = offset&0377; #endif } /* - regoptail - regtail on operand of first argument; nop if operandless */ static void regoptail(p, val) char *p; char *val; { /* "Operandless" and "op != BRANCH" are synonymous in practice. */ if (p == NULL || p == ®dummy || OP(p) != BRANCH) return; regtail(NEXTOPER(p), val); } /* - regcurly - a little FSA that accepts {\d+,?\d*} */ STATIC int regcurly(s) register char *s; { if (*s++ != '{') return FALSE; if (!isdigit(*s)) return FALSE; while (isdigit(*s)) s++; if (*s == ',') s++; while (isdigit(*s)) s++; if (*s != '}') return FALSE; return TRUE; } #ifdef DEBUGGING /* - regdump - dump a regexp onto stderr in vaguely comprehensible form */ void regdump(r) regexp *r; { register char *s; register char op = EXACTLY; /* Arbitrary non-END op. */ register char *next; extern char *index(); s = r->program + 1; while (op != END) { /* While that wasn't END last time... */ #ifdef REGALIGN if (!((long)s & 1)) s++; #endif op = OP(s); fprintf(stderr,"%2d%s", s-r->program, regprop(s)); /* Where, what. */ next = regnext(s); if (next == NULL) /* Next ptr. */ fprintf(stderr,"(0)"); else fprintf(stderr,"(%d)", (s-r->program)+(next-s)); s += 3; if (op == ANYOF || op == ANYBUT) { s += 32; } if (op == EXACTLY) { /* Literal string, where present. */ s++; while (*s != '\0') { (void)putchar(*s); s++; } s++; } (void)putchar('\n'); } /* Header fields of interest. */ if (r->regstart) fprintf(stderr,"start `%s' ", r->regstart->str_ptr); if (r->regstclass) fprintf(stderr,"stclass `%s' ", regprop(r->regstclass)); if (r->reganch) fprintf(stderr,"anchored "); if (r->regmust != NULL) fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr, r->regback); fprintf(stderr,"\n"); } /* - regprop - printable representation of opcode */ char * regprop(op) char *op; { register char *p; (void) strcpy(buf, ":"); switch (OP(op)) { case BOL: p = "BOL"; break; case EOL: p = "EOL"; break; case ANY: p = "ANY"; break; case ANYOF: p = "ANYOF"; break; case ANYBUT: p = "ANYBUT"; break; case BRANCH: p = "BRANCH"; break; case EXACTLY: p = "EXACTLY"; break; case NOTHING: p = "NOTHING"; break; case BACK: p = "BACK"; break; case END: p = "END"; break; case ALNUM: p = "ALNUM"; break; case NALNUM: p = "NALNUM"; break; case BOUND: p = "BOUND"; break; case NBOUND: p = "NBOUND"; break; case SPACE: p = "SPACE"; break; case NSPACE: p = "NSPACE"; break; case DIGIT: p = "DIGIT"; break; case NDIGIT: p = "NDIGIT"; break; case REF: case REF+1: case REF+2: case REF+3: case REF+4: case REF+5: case REF+6: case REF+7: case REF+8: case REF+9: (void)sprintf(buf+strlen(buf), "REF%d", OP(op)-REF); p = NULL; break; case OPEN+1: case OPEN+2: case OPEN+3: case OPEN+4: case OPEN+5: case OPEN+6: case OPEN+7: case OPEN+8: case OPEN+9: (void)sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); p = NULL; break; case CLOSE+1: case CLOSE+2: case CLOSE+3: case CLOSE+4: case CLOSE+5: case CLOSE+6: case CLOSE+7: case CLOSE+8: case CLOSE+9: (void)sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); p = NULL; break; case STAR: p = "STAR"; break; case PLUS: p = "PLUS"; break; default: FAIL("corrupted regexp opcode"); } if (p != NULL) (void) strcat(buf, p); return(buf); } #endif /* DEBUGGING */ regfree(r) struct regexp *r; { if (r->precomp) Safefree(r->precomp); if (r->subbase) Safefree(r->subbase); if (r->regmust) str_free(r->regmust); if (r->regstart) str_free(r->regstart); Safefree(r); } E+8: case CLOSE+9: (void)sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); p = NULL; break; case STAR: p = "STAR"; break; case PLUS: p = "PLUS"; break; default: FAIL("corrupted regexp opcode"); } if (p != NULL) (void) strcat(buf, p); return(buf); } #endif /* DEBUGGING */ regfree(r) struct regexp *r; { if (r->precomp) Safefree(r->precomperl/perl.y 644 473 0 46613 4747105033 6216 /* $Header: perl.y,v 3.0.1.4 90/02/28 18:03:23 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.y,v $ * Revision 3.0.1.4 90/02/28 18:03:23 lwall * patch9: line numbers were bogus during certain portions of foreach evaluation * * Revision 3.0.1.3 89/12/21 20:13:41 lwall * patch7: send() didn't allow a TO argument * * Revision 3.0.1.2 89/11/11 04:49:04 lwall * patch2: moved yydebug to where its type doesn't matter * patch2: !$foo++ was unreasonably illegal * patch2: local(@foo) didn't work * patch2: default args to unary operators didn't work * * Revision 3.0.1.1 89/10/26 23:20:41 lwall * patch1: grandfathered "format stdout" * patch1: operator(); is now normally equivalent to operator; * * Revision 3.0 89/10/18 15:22:04 lwall * 3.0 baseline * */ %{ #include "INTERN.h" #include "perl.h" STAB *scrstab; ARG *arg4; /* rarely used arguments to make_op() */ ARG *arg5; %} %start prog %union { int ival; char *cval; ARG *arg; CMD *cmdval; struct compcmd compval; STAB *stabval; FCMD *formval; } %token WORD %token APPEND OPEN SELECT LOOPEX %token USING FORMAT DO SHIFT PUSH POP LVALFUN %token WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST %token FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25 %token FUNC0 FUNC1 FUNC2 FUNC3 HSHFUN HSHFUN3 %token FLIST2 SUB FILETEST LOCAL DELETE %token RELOP EQOP MULOP ADDOP PACKAGE AMPER LFUNC4 %token FORMLIST %token REG ARYLEN ARY HSH STAR %token SUBST PATTERN %token RSTRING TRANS %type prog decl format remember %type %type block lineseq line loop cond sideff nexpr else %type expr sexpr cexpr csexpr term handle aryword hshword %type texpr listop %type label %type compblock %nonassoc LISTOP %left ',' %right '=' %right '?' ':' %nonassoc DOTDOT %left OROR %left ANDAND %left '|' '^' %left '&' %nonassoc EQOP %nonassoc RELOP %nonassoc UNIOP %nonassoc FILETEST %left LS RS %left ADDOP %left MULOP %left MATCH NMATCH %right '!' '~' UMINUS %right POW %nonassoc INC DEC %left '(' %% /* RULES */ prog : /* NULL */ { #if defined(YYDEBUG) && defined(DEBUGGING) yydebug = (debug & 1); #endif } /*CONTINUED*/ lineseq { if (in_eval) eval_root = block_head($2); else main_root = block_head($2); } ; compblock: block CONTINUE block { $$.comp_true = $1; $$.comp_alt = $3; } | block else { $$.comp_true = $1; $$.comp_alt = $2; } ; else : /* NULL */ { $$ = Nullcmd; } | ELSE block { $$ = $2; } | ELSIF '(' expr ')' compblock { cmdline = $1; $$ = make_ccmd(C_ELSIF,$3,$5); } ; block : '{' remember lineseq '}' { $$ = block_head($3); if (savestack->ary_fill > $2) restorelist($2); } ; remember: /* NULL */ /* in case they push a package name */ { $$ = savestack->ary_fill; } ; lineseq : /* NULL */ { $$ = Nullcmd; } | lineseq line { $$ = append_line($1,$2); } ; line : decl { $$ = Nullcmd; } | label cond { $$ = add_label($1,$2); } | loop /* loops add their own labels */ | label ';' { if ($1 != Nullch) { $$ = add_label($1, make_acmd(C_EXPR, Nullstab, Nullarg, Nullarg) ); } else $$ = Nullcmd; } | label sideff ';' { $$ = add_label($1,$2); } ; sideff : error { $$ = Nullcmd; } | expr { $$ = make_acmd(C_EXPR, Nullstab, $1, Nullarg); } | expr IF expr { $$ = addcond( make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); } | expr UNLESS expr { $$ = addcond(invert( make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); } | expr WHILE expr { $$ = addloop( make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); } | expr UNTIL expr { $$ = addloop(invert( make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); } ; cond : IF '(' expr ')' compblock { cmdline = $1; $$ = make_icmd(C_IF,$3,$5); } | UNLESS '(' expr ')' compblock { cmdline = $1; $$ = invert(make_icmd(C_IF,$3,$5)); } | IF block compblock { cmdline = $1; $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); } | UNLESS block compblock { cmdline = $1; $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); } ; loop : label WHILE '(' texpr ')' compblock { cmdline = $2; $$ = wopt(add_label($1, make_ccmd(C_WHILE,$4,$6) )); } | label UNTIL '(' expr ')' compblock { cmdline = $2; $$ = wopt(add_label($1, invert(make_ccmd(C_WHILE,$4,$6)) )); } | label WHILE block compblock { cmdline = $2; $$ = wopt(add_label($1, make_ccmd(C_WHILE, cmd_to_arg($3),$4) )); } | label UNTIL block compblock { 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(). * (Note that @ary may become a local array if * it is determined that it might be called * recursively. See cmd_tosave().) */ if ($5->arg_type != O_ARRAY) { scrstab = aadd(genstab()); $$ = 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(make_list($5)), Nullarg)), Nullarg), wopt(over($3,add_label($1, make_ccmd(C_WHILE, make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), Nullarg,Nullarg ), $7))))); $$->c_line = $2; $$->c_head->c_line = $2; } 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(make_list($4)), Nullarg)), Nullarg), wopt(over(defstab,add_label($1, make_ccmd(C_WHILE, make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), Nullarg,Nullarg ), $6))))); $$->c_line = $2; $$->c_head->c_line = $2; } 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 */ { $$ = add_label($1,make_ccmd(C_BLOCK,Nullarg,$2)); } ; nexpr : /* NULL */ { $$ = Nullcmd; } | sideff ; texpr : /* NULL means true */ { (void)scanstr("1"); $$ = yylval.arg; } | expr ; label : /* empty */ { $$ = Nullch; } | WORD ':' ; decl : format { $$ = 0; } | subrout { $$ = 0; } | package { $$ = 0; } ; format : FORMAT WORD '=' FORMLIST { if (strEQ($2,"stdout")) stab_form(stabent("STDOUT",TRUE)) = $4; else if (strEQ($2,"stderr")) stab_form(stabent("STDERR",TRUE)) = $4; else stab_form(stabent($2,TRUE)) = $4; Safefree($2);} | FORMAT '=' FORMLIST { stab_form(stabent("STDOUT",TRUE)) = $3; } ; subrout : SUB WORD block { make_sub($2,$3); } ; package : PACKAGE WORD ';' { char tmpbuf[256]; savehptr(&curstash); saveitem(curstname); str_set(curstname,$2); sprintf(tmpbuf,"'_%s",$2); curstash = stab_xhash(hadd(stabent(tmpbuf,TRUE))); curstash->tbl_coeffsize = 0; Safefree($2); } ; cexpr : ',' expr { $$ = $2; } ; expr : expr ',' sexpr { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg); } | sexpr ; csexpr : ',' sexpr { $$ = $2; } ; sexpr : sexpr '=' sexpr { $1 = listish($1); if ($1->arg_type == O_ASSIGN && $1->arg_len == 1) $1->arg_type = O_ITEM; /* a local() */ if ($1->arg_type == O_LIST) $3 = listish($3); $$ = l(make_op(O_ASSIGN, 2, $1, $3, Nullarg)); } | sexpr POW '=' sexpr { $$ = l(make_op(O_POW, 2, $1, $4, Nullarg)); } | sexpr MULOP '=' sexpr { $$ = l(make_op($2, 2, $1, $4, Nullarg)); } | sexpr ADDOP '=' sexpr { $$ = rcatmaybe(l(make_op($2, 2, $1, $4, Nullarg)));} | sexpr LS '=' sexpr { $$ = l(make_op(O_LEFT_SHIFT, 2, $1, $4, Nullarg)); } | sexpr RS '=' sexpr { $$ = l(make_op(O_RIGHT_SHIFT, 2, $1, $4, Nullarg)); } | sexpr '&' '=' sexpr { $$ = l(make_op(O_BIT_AND, 2, $1, $4, Nullarg)); } | sexpr '^' '=' sexpr { $$ = l(make_op(O_XOR, 2, $1, $4, Nullarg)); } | sexpr '|' '=' sexpr { $$ = l(make_op(O_BIT_OR, 2, $1, $4, Nullarg)); } | sexpr POW sexpr { $$ = make_op(O_POW, 2, $1, $3, Nullarg); } | sexpr MULOP sexpr { $$ = make_op($2, 2, $1, $3, Nullarg); } | sexpr ADDOP sexpr { $$ = make_op($2, 2, $1, $3, Nullarg); } | sexpr LS sexpr { $$ = make_op(O_LEFT_SHIFT, 2, $1, $3, Nullarg); } | sexpr RS sexpr { $$ = make_op(O_RIGHT_SHIFT, 2, $1, $3, Nullarg); } | sexpr RELOP sexpr { $$ = make_op($2, 2, $1, $3, Nullarg); } | sexpr EQOP sexpr { $$ = make_op($2, 2, $1, $3, Nullarg); } | sexpr '&' sexpr { $$ = make_op(O_BIT_AND, 2, $1, $3, Nullarg); } | sexpr '^' sexpr { $$ = make_op(O_XOR, 2, $1, $3, Nullarg); } | sexpr '|' sexpr { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg); } | sexpr DOTDOT sexpr { arg4 = Nullarg; $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg); } | sexpr ANDAND sexpr { $$ = make_op(O_AND, 2, $1, $3, Nullarg); } | sexpr OROR sexpr { $$ = make_op(O_OR, 2, $1, $3, Nullarg); } | sexpr '?' sexpr ':' sexpr { $$ = make_op(O_COND_EXPR, 3, $1, $3, $5); } | sexpr MATCH sexpr { $$ = mod_match(O_MATCH, $1, $3); } | sexpr NMATCH sexpr { $$ = mod_match(O_NMATCH, $1, $3); } | term { $$ = $1; } ; term : '-' term %prec UMINUS { $$ = make_op(O_NEGATE, 1, $2, Nullarg, Nullarg); } | '+' term %prec UMINUS { $$ = $2; } | '!' term { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg); } | '~' term { $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg);} | term INC { $$ = addflags(1, AF_POST|AF_UP, l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); } | term DEC { $$ = addflags(1, AF_POST, l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); } | INC term { $$ = addflags(1, AF_PRE|AF_UP, l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); } | DEC term { $$ = addflags(1, AF_PRE, l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); } | FILETEST WORD { opargs[$1] = 0; /* force it special */ $$ = make_op($1, 1, stab2arg(A_STAB,stabent($2,TRUE)), Nullarg, Nullarg); } | FILETEST sexpr { opargs[$1] = 1; $$ = make_op($1, 1, $2, Nullarg, Nullarg); } | FILETEST { opargs[$1] = ($1 != O_FTTTY); $$ = make_op($1, 1, stab2arg(A_STAB, $1 == O_FTTTY?stabent("STDIN",TRUE):defstab), Nullarg, Nullarg); } | LOCAL '(' expr ')' { $$ = l(localize(make_op(O_ASSIGN, 1, localize(listish(make_list($3))), Nullarg,Nullarg))); } | '(' expr ')' { $$ = make_list(hide_ary($2)); } | '(' ')' { $$ = make_list(Nullarg); } | DO sexpr %prec FILETEST { $$ = fixeval( make_op(O_DOFILE,2,$2,Nullarg,Nullarg) ); allstabs = TRUE;} | DO block %prec '(' { $$ = cmd_to_arg($2); } | REG %prec '(' { $$ = stab2arg(A_STAB,$1); } | STAR %prec '(' { $$ = stab2arg(A_STAR,$1); } | REG '[' expr ']' %prec '(' { $$ = make_op(O_AELEM, 2, stab2arg(A_STAB,aadd($1)), $3, Nullarg); } | HSH %prec '(' { $$ = make_op(O_HASH, 1, stab2arg(A_STAB,$1), Nullarg, Nullarg); } | ARY %prec '(' { $$ = make_op(O_ARRAY, 1, stab2arg(A_STAB,$1), Nullarg, Nullarg); } | REG '{' expr '}' %prec '(' { $$ = make_op(O_HELEM, 2, stab2arg(A_STAB,hadd($1)), jmaybe($3), Nullarg); } | ARY '[' expr ']' %prec '(' { $$ = make_op(O_ASLICE, 2, stab2arg(A_STAB,aadd($1)), listish(make_list($3)), Nullarg); } | ARY '{' expr '}' %prec '(' { $$ = make_op(O_HSLICE, 2, stab2arg(A_STAB,hadd($1)), listish(make_list($3)), Nullarg); } | DELETE REG '{' expr '}' %prec '(' { $$ = make_op(O_DELETE, 2, stab2arg(A_STAB,hadd($2)), jmaybe($4), Nullarg); } | ARYLEN %prec '(' { $$ = stab2arg(A_ARYLEN,$1); } | RSTRING %prec '(' { $$ = $1; } | PATTERN %prec '(' { $$ = $1; } | SUBST %prec '(' { $$ = $1; } | TRANS %prec '(' { $$ = $1; } | DO WORD '(' expr ')' { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_WORD,stabent($2,TRUE)), make_list($4), Nullarg); Safefree($2); } | AMPER WORD '(' expr ')' { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_WORD,stabent($2,TRUE)), make_list($4), Nullarg); Safefree($2); } | DO WORD '(' ')' { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_WORD,stabent($2,TRUE)), make_list(Nullarg), Nullarg); } | AMPER WORD '(' ')' { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_WORD,stabent($2,TRUE)), make_list(Nullarg), Nullarg); } | AMPER WORD { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_WORD,stabent($2,TRUE)), Nullarg, Nullarg); } | DO REG '(' expr ')' { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_STAB,$2), make_list($4), Nullarg); } | AMPER REG '(' expr ')' { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_STAB,$2), make_list($4), Nullarg); } | DO REG '(' ')' { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_STAB,$2), make_list(Nullarg), Nullarg); } | AMPER REG '(' ')' { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_STAB,$2), make_list(Nullarg), Nullarg); } | AMPER REG { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, stab2arg(A_STAB,$2), Nullarg, Nullarg); } | LOOPEX { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); } | LOOPEX WORD { $$ = make_op($1,1,cval_to_arg($2), Nullarg,Nullarg); } | UNIOP { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); if ($1 == O_EVAL || $1 == O_RESET) $$ = fixeval($$); } | UNIOP sexpr { $$ = make_op($1,1,$2,Nullarg,Nullarg); if ($1 == O_EVAL || $1 == O_RESET) $$ = fixeval($$); } | SELECT { $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);} | SELECT '(' handle ')' { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg); } | SELECT '(' sexpr csexpr csexpr csexpr ')' { arg4 = $6; $$ = make_op(O_SSELECT, 4, $3, $4, $5); } | OPEN WORD %prec '(' { $$ = make_op(O_OPEN, 2, stab2arg(A_WORD,stabent($2,TRUE)), stab2arg(A_STAB,stabent($2,TRUE)), Nullarg); } | OPEN '(' WORD ')' { $$ = make_op(O_OPEN, 2, stab2arg(A_WORD,stabent($3,TRUE)), stab2arg(A_STAB,stabent($3,TRUE)), Nullarg); } | OPEN '(' handle cexpr ')' { $$ = make_op(O_OPEN, 2, $3, $4, Nullarg); } | FILOP '(' handle ')' { $$ = make_op($1, 1, $3, Nullarg, Nullarg); } | FILOP WORD { $$ = make_op($1, 1, stab2arg(A_WORD,stabent($2,TRUE)), Nullarg, Nullarg); Safefree($2); } | FILOP REG { $$ = make_op($1, 1, stab2arg(A_STAB,$2), Nullarg, Nullarg); } | FILOP '(' ')' { $$ = make_op($1, 1, stab2arg(A_WORD,Nullstab), Nullarg, Nullarg); } | FILOP %prec '(' { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } | FILOP2 '(' handle cexpr ')' { $$ = make_op($1, 2, $3, $4, Nullarg); } | FILOP3 '(' handle csexpr cexpr ')' { $$ = make_op($1, 3, $3, $4, make_list($5)); } | FILOP22 '(' handle ',' handle ')' { $$ = make_op($1, 2, $3, $5, Nullarg); } | FILOP4 '(' handle csexpr csexpr cexpr ')' { arg4 = $6; $$ = make_op($1, 4, $3, $4, $5); } | FILOP25 '(' handle ',' handle csexpr csexpr cexpr ')' { arg4 = $7; arg5 = $8; $$ = make_op($1, 5, $3, $5, $6); } | PUSH '(' aryword cexpr ')' { $$ = make_op($1, 2, $3, make_list($4), Nullarg); } | POP aryword %prec '(' { $$ = make_op(O_POP, 1, $2, Nullarg, Nullarg); } | POP '(' aryword ')' { $$ = make_op(O_POP, 1, $3, Nullarg, Nullarg); } | SHIFT aryword %prec '(' { $$ = make_op(O_SHIFT, 1, $2, Nullarg, Nullarg); } | SHIFT '(' aryword ')' { $$ = make_op(O_SHIFT, 1, $3, Nullarg, Nullarg); } | SHIFT %prec '(' { $$ = make_op(O_SHIFT, 1, stab2arg(A_STAB, aadd(stabent(subline ? "_" : "ARGV", TRUE))), Nullarg, Nullarg); } | SPLIT %prec '(' { (void)scanpat("/\\s+/"); $$ = make_split(defstab,yylval.arg,Nullarg); } | SPLIT '(' sexpr csexpr csexpr ')' { $$ = mod_match(O_MATCH, $4, make_split(defstab,$3,$5));} | SPLIT '(' sexpr csexpr ')' { $$ = mod_match(O_MATCH, $4, make_split(defstab,$3,Nullarg) ); } | SPLIT '(' sexpr ')' { $$ = mod_match(O_MATCH, stab2arg(A_STAB,defstab), make_split(defstab,$3,Nullarg) ); } | FLIST2 '(' sexpr cexpr ')' { $$ = make_op($1, 2, $3, listish(make_list($4)), Nullarg); } | FLIST '(' expr ')' { $$ = make_op($1, 1, make_list($3), Nullarg, Nullarg); } | LVALFUN sexpr %prec '(' { $$ = l(make_op($1, 1, fixl($1,$2), Nullarg, Nullarg)); } | LVALFUN { $$ = l(make_op($1, 1, stab2arg(A_STAB,defstab), Nullarg, Nullarg)); } | FUNC0 { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } | FUNC0 '(' ')' { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } | FUNC1 '(' ')' { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); if ($1 == O_EVAL || $1 == O_RESET) $$ = fixeval($$); } | FUNC1 '(' expr ')' { $$ = make_op($1, 1, $3, Nullarg, Nullarg); if ($1 == O_EVAL || $1 == O_RESET) $$ = fixeval($$); } | FUNC2 '(' sexpr cexpr ')' { $$ = make_op($1, 2, $3, $4, Nullarg); if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE) fbmcompile($$[2].arg_ptr.arg_str,0); } | FUNC3 '(' sexpr csexpr cexpr ')' { $$ = make_op($1, 3, $3, $4, $5); } | LFUNC4 '(' sexpr csexpr csexpr cexpr ')' { arg4 = $6; $$ = make_op($1, 4, l($3), $4, $5); } | HSHFUN '(' hshword ')' { $$ = make_op($1, 1, $3, Nullarg, Nullarg); } | HSHFUN hshword { $$ = make_op($1, 1, $2, Nullarg, Nullarg); } | HSHFUN3 '(' hshword csexpr cexpr ')' { $$ = make_op($1, 3, $3, $4, $5); } | listop ; listop : LISTOP { $$ = make_op($1,2, stab2arg(A_WORD,Nullstab), stab2arg(A_STAB,defstab), Nullarg); } | LISTOP expr { $$ = make_op($1,2, stab2arg(A_WORD,Nullstab), maybelistish($1,make_list($2)), Nullarg); } | LISTOP WORD { $$ = make_op($1,2, stab2arg(A_WORD,stabent($2,TRUE)), stab2arg(A_STAB,defstab), Nullarg); } | LISTOP WORD expr { $$ = make_op($1,2, stab2arg(A_WORD,stabent($2,TRUE)), maybelistish($1,make_list($3)), Nullarg); Safefree($2); } | LISTOP REG expr { $$ = make_op($1,2, stab2arg(A_STAB,$2), maybelistish($1,make_list($3)), Nullarg); } ; handle : WORD { $$ = stab2arg(A_WORD,stabent($1,TRUE)); Safefree($1);} | sexpr ; aryword : WORD { $$ = stab2arg(A_WORD,aadd(stabent($1,TRUE))); Safefree($1); } | ARY { $$ = stab2arg(A_STAB,$1); } ; hshword : WORD { $$ = stab2arg(A_WORD,hadd(stabent($1,TRUE))); Safefree($1); } | HSH { $$ = stab2arg(A_STAB,$1); } ; %% /* PROGRAM */ ; Safefree($2); } | LISTOP REG expr { $$ = make_op($1,2, stab2arg(A_STAB,$2), maybelistish($1,make_list($perl/str.c 644 473 0 70516 4747105035 6037 /* $Header: str.c,v 3.0.1.5 90/02/28 18:30:38 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: str.c,v $ * Revision 3.0.1.5 90/02/28 18:30:38 lwall * patch9: you may now undef $/ to have no input record separator * patch9: nested evals clobbered their longjmp environment * patch9: sometimes perl thought ordinary data was a symbol table entry * patch9: insufficient space allocated for numeric string on sun4 * patch9: underscore in an array name in a double-quoted string not recognized * patch9: "@foo{}" not recognized unless %foo defined * patch9: "$foo[$[]" gives error * * Revision 3.0.1.4 89/12/21 20:21:35 lwall * patch7: errno may now be a macro with an lvalue * patch7: made nested or recursive foreach work right * * Revision 3.0.1.3 89/11/17 15:38:23 lwall * patch5: some machines typedef unchar too * patch5: substitution on leading components occasionally caused <> corruption * * Revision 3.0.1.2 89/11/11 04:56:22 lwall * patch2: uchar gives Crays fits * * Revision 3.0.1.1 89/10/26 23:23:41 lwall * patch1: string ordering tests were wrong * patch1: $/ now works even when STDSTDIO undefined * * Revision 3.0 89/10/18 15:23:38 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" #include "perly.h" extern char **environ; #ifndef str_get char * str_get(str) STR *str; { #ifdef TAINT tainted |= str->str_tainted; #endif return str->str_pok ? str->str_ptr : str_2ptr(str); } #endif /* dlb ... guess we have a "crippled cc". * dlb the following functions are usually macros. */ #ifndef str_true str_true(Str) STR *Str; { if (Str->str_pok) { if (*Str->str_ptr > '0' || Str->str_cur > 1 || (Str->str_cur && *Str->str_ptr != '0')) return 1; return 0; } if (Str->str_nok) return (Str->str_u.str_nval != 0.0); return 0; } #endif /* str_true */ #ifndef str_gnum double str_gnum(Str) STR *Str; { #ifdef TAINT tainted |= Str->str_tainted; #endif /* TAINT*/ if (Str->str_nok) return Str->str_u.str_nval; return str_2num(Str); } #endif /* str_gnum */ /* dlb ... end of crutch */ char * str_grow(str,newlen) register STR *str; register int newlen; { register char *s = str->str_ptr; if (str->str_state == SS_INCR) { /* data before str_ptr? */ str->str_len += str->str_u.str_useful; str->str_ptr -= str->str_u.str_useful; str->str_u.str_useful = 0L; bcopy(s, str->str_ptr, str->str_cur+1); s = str->str_ptr; str->str_state = SS_NORM; /* normal again */ if (newlen > str->str_len) newlen += 10 * (newlen - str->str_cur); /* avoid copy each time */ } if (newlen > str->str_len) { /* need more room? */ if (str->str_len) Renew(s,newlen,char); else New(703,s,newlen,char); str->str_ptr = s; str->str_len = newlen; } return s; } str_numset(str,num) register STR *str; double num; { str->str_u.str_nval = num; str->str_state = SS_NORM; str->str_pok = 0; /* invalidate pointer */ str->str_nok = 1; /* validate number */ #ifdef TAINT str->str_tainted = tainted; #endif } char * str_2ptr(str) register STR *str; { register char *s; int olderrno; if (!str) return ""; if (str->str_nok) { /* this is a problem on the sun 4... 24 bytes is not always enough and the exponent blows away the malloc stack PEJ Wed Jan 31 18:41:34 CST 1990 */ #ifdef sun4 STR_GROW(str, 30); #else STR_GROW(str, 24); #endif /* sun 4 */ s = str->str_ptr; olderrno = errno; /* some Xenix systems wipe out errno here */ #if defined(scs) && defined(ns32000) gcvt(str->str_u.str_nval,20,s); #else #ifdef apollo if (str->str_u.str_nval == 0.0) (void)strcpy(s,"0"); else #endif /*apollo*/ (void)sprintf(s,"%.20g",str->str_u.str_nval); #endif /*scs*/ errno = olderrno; while (*s) s++; #ifdef hcx if (s[-1] == '.') s--; #endif } else { if (str == &str_undef) return No; if (dowarn) warn("Use of uninitialized variable"); #ifdef sun4 STR_GROW(str, 30); #else STR_GROW(str, 24); #endif s = str->str_ptr; } *s = '\0'; str->str_cur = s - str->str_ptr; str->str_pok = 1; #ifdef DEBUGGING if (debug & 32) fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr); #endif return str->str_ptr; } double str_2num(str) register STR *str; { if (!str) return 0.0; str->str_state = SS_NORM; if (str->str_len && str->str_pok) str->str_u.str_nval = atof(str->str_ptr); else { if (str == &str_undef) return 0.0; if (dowarn) warn("Use of uninitialized variable"); str->str_u.str_nval = 0.0; } str->str_nok = 1; #ifdef DEBUGGING if (debug & 32) fprintf(stderr,"0x%lx num(%g)\n",str,str->str_u.str_nval); #endif return str->str_u.str_nval; } str_sset(dstr,sstr) STR *dstr; register STR *sstr; { #ifdef TAINT tainted |= sstr->str_tainted; #endif if (sstr == dstr) return; if (!sstr) dstr->str_pok = dstr->str_nok = 0; else if (sstr->str_pok) { str_nset(dstr,sstr->str_ptr,sstr->str_cur); if (sstr->str_nok) { dstr->str_u.str_nval = sstr->str_u.str_nval; dstr->str_nok = 1; dstr->str_state = SS_NORM; } else if (sstr->str_cur == sizeof(STBP)) { char *tmps = sstr->str_ptr; if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) { dstr->str_magic = str_smake(sstr->str_magic); dstr->str_magic->str_rare = 'X'; } } } else if (sstr->str_nok) str_numset(dstr,sstr->str_u.str_nval); else { #ifdef STRUCTCOPY dstr->str_u = sstr->str_u; #else dstr->str_u.str_nval = sstr->str_u.str_nval; #endif dstr->str_pok = dstr->str_nok = 0; } } str_nset(str,ptr,len) register STR *str; register char *ptr; register int len; { STR_GROW(str, len + 1); (void)bcopy(ptr,str->str_ptr,len); str->str_cur = len; *(str->str_ptr+str->str_cur) = '\0'; str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ #ifdef TAINT str->str_tainted = tainted; #endif } str_set(str,ptr) register STR *str; register char *ptr; { register int len; if (!ptr) ptr = ""; len = strlen(ptr); STR_GROW(str, len + 1); (void)bcopy(ptr,str->str_ptr,len+1); str->str_cur = len; str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ #ifdef TAINT str->str_tainted = tainted; #endif } str_chop(str,ptr) /* like set but assuming ptr is in str */ register STR *str; register char *ptr; { register int delta; if (!(str->str_pok)) fatal("str_chop: internal inconsistency"); delta = ptr - str->str_ptr; str->str_len -= delta; str->str_cur -= delta; str->str_ptr += delta; if (str->str_state == SS_INCR) str->str_u.str_useful += delta; else { str->str_u.str_useful = delta; str->str_state = SS_INCR; } str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer (and unstudy str) */ } str_ncat(str,ptr,len) register STR *str; register char *ptr; register int len; { if (!(str->str_pok)) (void)str_2ptr(str); STR_GROW(str, str->str_cur + len + 1); (void)bcopy(ptr,str->str_ptr+str->str_cur,len); str->str_cur += len; *(str->str_ptr+str->str_cur) = '\0'; str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ #ifdef TAINT str->str_tainted |= tainted; #endif } str_scat(dstr,sstr) STR *dstr; register STR *sstr; { #ifdef TAINT tainted |= sstr->str_tainted; #endif if (!sstr) return; if (!(sstr->str_pok)) (void)str_2ptr(sstr); if (sstr) str_ncat(dstr,sstr->str_ptr,sstr->str_cur); } str_cat(str,ptr) register STR *str; register char *ptr; { register int len; if (!ptr) return; if (!(str->str_pok)) (void)str_2ptr(str); len = strlen(ptr); STR_GROW(str, str->str_cur + len + 1); (void)bcopy(ptr,str->str_ptr+str->str_cur,len+1); str->str_cur += len; str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ #ifdef TAINT str->str_tainted |= tainted; #endif } char * str_append_till(str,from,fromend,delim,keeplist) register STR *str; register char *from; register char *fromend; register int delim; char *keeplist; { register char *to; register int len; if (!from) return Nullch; len = fromend - from; STR_GROW(str, str->str_cur + len + 1); str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ to = str->str_ptr+str->str_cur; for (; from < fromend; from++,to++) { if (*from == '\\' && from+1 < fromend && delim != '\\') { if (!keeplist) { if (from[1] == delim || from[1] == '\\') from++; else *to++ = *from++; } else if (from[1] && index(keeplist,from[1])) *to++ = *from++; else from++; } else if (*from == delim) break; *to = *from; } *to = '\0'; str->str_cur = to - str->str_ptr; return from; } STR * #ifdef LEAKTEST str_new(x,len) int x; #else str_new(len) #endif int len; { register STR *str; if (freestrroot) { str = freestrroot; freestrroot = str->str_magic; str->str_magic = Nullstr; str->str_state = SS_NORM; } else { Newz(700+x,str,1,STR); } if (len) STR_GROW(str, len + 1); return str; } void str_magic(str, stab, how, name, namlen) register STR *str; STAB *stab; int how; char *name; int namlen; { if (str->str_magic) return; str->str_magic = Str_new(75,namlen); str = str->str_magic; str->str_u.str_stab = stab; str->str_rare = how; if (name) str_nset(str,name,namlen); } void str_insert(bigstr,offset,len,little,littlelen) STR *bigstr; int offset; int len; char *little; int littlelen; { register char *big; register char *mid; register char *midend; register char *bigend; register int i; i = littlelen - len; if (i > 0) { /* string might grow */ STR_GROW(bigstr, bigstr->str_cur + i + 1); big = bigstr->str_ptr; mid = big + offset + len; midend = bigend = big + bigstr->str_cur; bigend += i; *bigend = '\0'; while (midend > mid) /* shove everything down */ *--bigend = *--midend; (void)bcopy(little,big+offset,littlelen); bigstr->str_cur += i; return; } else if (i == 0) { (void)bcopy(little,bigstr->str_ptr+offset,len); return; } big = bigstr->str_ptr; mid = big + offset; midend = mid + len; bigend = big + bigstr->str_cur; if (midend > bigend) fatal("panic: str_insert"); bigstr->str_pok = SP_VALID; /* disable possible screamer */ if (mid - big > bigend - midend) { /* faster to shorten from end */ if (littlelen) { (void)bcopy(little, mid, littlelen); mid += littlelen; } i = bigend - midend; if (i > 0) { (void)bcopy(midend, mid, i); mid += i; } *mid = '\0'; bigstr->str_cur = mid - big; } else if (i = mid - big) { /* faster from front */ midend -= littlelen; mid = midend; str_chop(bigstr,midend-i); big += i; while (i--) *--midend = *--big; if (littlelen) (void)bcopy(little, mid, littlelen); } else if (littlelen) { midend -= littlelen; str_chop(bigstr,midend); (void)bcopy(little,midend,littlelen); } else { str_chop(bigstr,midend); } STABSET(bigstr); } /* make str point to what nstr did */ void str_replace(str,nstr) register STR *str; register STR *nstr; { if (str->str_state == SS_INCR) str_grow(str,0); /* just force copy down */ if (nstr->str_state == SS_INCR) str_grow(nstr,0); if (str->str_ptr) Safefree(str->str_ptr); str->str_ptr = nstr->str_ptr; str->str_len = nstr->str_len; str->str_cur = nstr->str_cur; str->str_pok = nstr->str_pok; str->str_nok = nstr->str_nok; #ifdef STRUCTCOPY str->str_u = nstr->str_u; #else str->str_u.str_nval = nstr->str_u.str_nval; #endif #ifdef TAINT str->str_tainted = nstr->str_tainted; #endif Safefree(nstr); } void str_free(str) register STR *str; { if (!str) return; if (str->str_state) { if (str->str_state == SS_FREE) /* already freed */ return; if (str->str_state == SS_INCR && !(str->str_pok & 2)) { str->str_ptr -= str->str_u.str_useful; str->str_len += str->str_u.str_useful; } } if (str->str_magic) str_free(str->str_magic); #ifdef LEAKTEST if (str->str_len) Safefree(str->str_ptr); if ((str->str_pok & SP_INTRP) && str->str_u.str_args) arg_free(str->str_u.str_args); Safefree(str); #else /* LEAKTEST */ if (str->str_len) { if (str->str_len > 127) { /* next user not likely to want more */ Safefree(str->str_ptr); /* so give it back to malloc */ str->str_ptr = Nullch; str->str_len = 0; } else str->str_ptr[0] = '\0'; } if ((str->str_pok & SP_INTRP) && str->str_u.str_args) arg_free(str->str_u.str_args); str->str_cur = 0; str->str_nok = 0; str->str_pok = 0; str->str_state = SS_FREE; #ifdef TAINT str->str_tainted = 0; #endif str->str_magic = freestrroot; freestrroot = str; #endif /* LEAKTEST */ } str_len(str) register STR *str; { if (!str) return 0; if (!(str->str_pok)) (void)str_2ptr(str); if (str->str_ptr) return str->str_cur; else return 0; } str_eq(str1,str2) register STR *str1; register STR *str2; { if (!str1) return str2 == Nullstr; if (!str2) return 0; if (!str1->str_pok) (void)str_2ptr(str1); if (!str2->str_pok) (void)str_2ptr(str2); if (str1->str_cur != str2->str_cur) return 0; return !bcmp(str1->str_ptr, str2->str_ptr, str1->str_cur); } str_cmp(str1,str2) register STR *str1; register STR *str2; { int retval; if (!str1) return str2 == Nullstr; if (!str2) return 0; if (!str1->str_pok) (void)str_2ptr(str1); if (!str2->str_pok) (void)str_2ptr(str2); if (str1->str_cur < str2->str_cur) { if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur)) return retval; else return -1; } else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur)) return retval; else if (str1->str_cur == str2->str_cur) return 0; else return 1; } char * str_gets(str,fp,append) register STR *str; register FILE *fp; int append; { register char *bp; /* we're going to steal some values */ register int cnt; /* from the stdio struct and put EVERYTHING */ register STDCHAR *ptr; /* in the innermost loop into registers */ register int newline = record_separator;/* (assuming >= 6 registers) */ int i; int bpx; int obpx; register int get_paragraph; register char *oldbp; if (get_paragraph = !rslen) { /* yes, that's an assignment */ newline = '\n'; oldbp = Nullch; /* remember last \n position (none) */ } #ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */ cnt = fp->_cnt; /* get count into register */ str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ if (str->str_len <= cnt + 1) /* make sure we have the room */ STR_GROW(str, append+cnt+2); /* (remembering cnt can be -1) */ bp = str->str_ptr + append; /* move these two too to registers */ ptr = fp->_ptr; for (;;) { screamer: while (--cnt >= 0) { /* this */ /* eat */ if ((*bp++ = *ptr++) == newline) /* really */ /* dust */ goto thats_all_folks; /* screams */ /* sed :-) */ } fp->_cnt = cnt; /* deregisterize cnt and ptr */ fp->_ptr = ptr; i = _filbuf(fp); /* get more characters */ cnt = fp->_cnt; ptr = fp->_ptr; /* reregisterize cnt and ptr */ bpx = bp - str->str_ptr; /* prepare for possible relocation */ if (get_paragraph && oldbp) obpx = oldbp - str->str_ptr; str->str_cur = bpx; STR_GROW(str, bpx + cnt + 2); bp = str->str_ptr + bpx; /* reconstitute our pointer */ if (get_paragraph && oldbp) oldbp = str->str_ptr + obpx; if (i == newline) { /* all done for now? */ *bp++ = i; goto thats_all_folks; } else if (i == EOF) /* all done for ever? */ goto thats_really_all_folks; *bp++ = i; /* now go back to screaming loop */ } thats_all_folks: if (get_paragraph && bp - 1 != oldbp) { oldbp = bp; /* remember where this newline was */ goto screamer; /* and go back to the fray */ } thats_really_all_folks: fp->_cnt = cnt; /* put these back or we're in trouble */ fp->_ptr = ptr; *bp = '\0'; str->str_cur = bp - str->str_ptr; /* set length */ #else /* !STDSTDIO */ /* The big, slow, and stupid way */ { static char buf[8192]; char * bpe = buf + sizeof(buf) - 3; screamer: bp = buf; filler: while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe); if (i == newline && get_paragraph && (i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) goto filler; *bp = '\0'; if (append) str_cat(str, buf); else str_set(str, buf); if (i != newline && i != EOF) { append = -1; goto screamer; } } #endif /* STDSTDIO */ return str->str_cur - append ? str->str_ptr : Nullch; } ARG * parselist(str) STR *str; { register CMD *cmd; register ARG *arg; line_t oldline = line; int retval; char *tmps; str_sset(linestr,str); in_eval++; oldoldbufptr = oldbufptr = bufptr = str_get(linestr); bufend = bufptr + linestr->str_cur; if (++loop_ptr >= loop_max) { loop_max += 128; Renew(loop_stack, loop_max, struct loop); } loop_stack[loop_ptr].loop_label = "_EVAL_"; loop_stack[loop_ptr].loop_sp = 0; #ifdef DEBUGGING if (debug & 4) { deb("(Pushing label #%d _EVAL_)\n", loop_ptr); } #endif if (setjmp(loop_stack[loop_ptr].loop_env)) { in_eval--; loop_ptr--; fatal("%s\n",stab_val(stabent("@",TRUE))->str_ptr); } #ifdef DEBUGGING if (debug & 4) { tmps = loop_stack[loop_ptr].loop_label; deb("(Popping label #%d %s)\n",loop_ptr, tmps ? tmps : "" ); } #endif loop_ptr--; error_count = 0; retval = yyparse(); in_eval--; if (retval || error_count) fatal("Invalid component in string or format"); cmd = eval_root; arg = cmd->c_expr; if (cmd->c_type != C_EXPR || cmd->c_next || arg->arg_type != O_LIST) fatal("panic: error in parselist %d %x %d", cmd->c_type, cmd->c_next, arg ? arg->arg_type : -1); line = oldline; Safefree(cmd); return arg; } void intrpcompile(src) STR *src; { register char *s = str_get(src); register char *send = s + src->str_cur; register STR *str; register char *t; STR *toparse; int len; register int brackets; register char *d; STAB *stab; char *checkpoint; toparse = Str_new(76,0); str = Str_new(77,0); str_nset(str,"",0); str_nset(toparse,"",0); t = s; while (s < send) { if (*s == '\\' && s[1] && index("$@[{\\]}",s[1])) { str_ncat(str, t, s - t); ++s; if (*nointrp && s+1 < send) if (*s != '@' && (*s != '$' || index(nointrp,s[1]))) str_ncat(str,s-1,1); str_ncat(str, "$b", 2); str_ncat(str, s, 1); ++s; t = s; } else if ((*s == '@' || (*s == '$' && !index(nointrp,s[1]))) && s+1 < send) { str_ncat(str,t,s-t); t = s; if (*s == '$' && s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) s++; s = scanreg(s,send,tokenbuf); if (*t == '@' && (!(stab = stabent(tokenbuf,FALSE)) || (*s == '{' ? !stab_xhash(stab) : !stab_xarray(stab)) )) { str_ncat(str,"@",1); s = ++t; continue; /* grandfather @ from old scripts */ } str_ncat(str,"$a",2); str_ncat(toparse,",",1); if (t[1] != '{' && (*s == '[' || *s == '{' /* }} */ ) && (stab = stabent(tokenbuf,FALSE)) && ((*s == '[') ? (stab_xarray(stab) != 0) : (stab_xhash(stab) != 0)) ) { brackets = 0; checkpoint = s; do { switch (*s) { case '[': if (s[-1] != '$') brackets++; break; case '{': brackets++; break; case ']': if (s[-1] != '$') brackets--; break; case '}': brackets--; break; case '\'': case '"': if (s[-1] != '$') { s = cpytill(tokenbuf,s+1,send,*s,&len); if (s >= send) fatal("Unterminated string"); } break; } s++; } while (brackets > 0 && s < send); if (s > send) fatal("Unmatched brackets in string"); if (*nointrp) { /* we're in a regular expression */ d = checkpoint; if (*d == '{' && s[-1] == '}') { /* maybe {n,m} */ ++d; if (isdigit(*d)) { /* matches /^{\d,?\d*}$/ */ if (*++d == ',') ++d; while (isdigit(*d)) d++; if (d == s - 1) s = checkpoint; /* Is {n,m}! Backoff! */ } } else if (*d == '[' && s[-1] == ']') { /* char class? */ int weight = 2; /* let's weigh the evidence */ char seen[256]; unsigned char un_char = 0, last_un_char; Zero(seen,256,char); *--s = '\0'; if (d[1] == '^') weight += 150; else if (d[1] == '$') weight -= 3; if (isdigit(d[1])) { if (d[2]) { if (isdigit(d[2]) && !d[3]) weight -= 10; } else weight -= 100; } for (d++; d < s; d++) { last_un_char = un_char; un_char = (unsigned char)*d; switch (*d) { case '&': case '$': weight -= seen[un_char] * 10; if (isalpha(d[1]) || isdigit(d[1]) || d[1] == '_') { d = scanreg(d,s,tokenbuf); if (stabent(tokenbuf,FALSE)) weight -= 100; else weight -= 10; } else if (*d == '$' && d[1] && index("[#!%*<>()-=",d[1])) { if (!d[2] || /*{*/ index("])} =",d[2])) weight -= 10; else weight -= 1; } break; case '\\': un_char = 254; if (d[1]) { if (index("wds",d[1])) weight += 100; else if (seen['\''] || seen['"']) weight += 1; else if (index("rnftb",d[1])) weight += 40; else if (isdigit(d[1])) { weight += 40; while (d[1] && isdigit(d[1])) d++; } } else weight += 100; break; case '-': if (last_un_char < d[1] || d[1] == '\\') { if (index("aA01! ",last_un_char)) weight += 30; if (index("zZ79~",d[1])) weight += 30; } else weight -= 1; default: if (isalpha(*d) && d[1] && isalpha(d[1])) { bufptr = d; if (yylex() != WORD) weight -= 150; d = bufptr; } if (un_char == last_un_char + 1) weight += 5; weight -= seen[un_char]; break; } seen[un_char]++; } #ifdef DEBUGGING if (debug & 512) fprintf(stderr,"[%s] weight %d\n", checkpoint+1,weight); #endif *s++ = ']'; if (weight >= 0) /* probably a character class */ s = checkpoint; } } } if (*t == '@') str_ncat(toparse, "join($\",", 8); if (t[1] == '{' && s[-1] == '}') { str_ncat(toparse, t, 1); str_ncat(toparse, t+2, s - t - 3); } else str_ncat(toparse, t, s - t); if (*t == '@') str_ncat(toparse, ")", 1); t = s; } else s++; } str_ncat(str,t,s-t); if (toparse->str_ptr && *toparse->str_ptr == ',') { *toparse->str_ptr = '('; str_ncat(toparse,",$$);",5); str->str_u.str_args = parselist(toparse); str->str_u.str_args->arg_len--; /* ignore $$ reference */ } else str->str_u.str_args = Nullarg; str_free(toparse); str->str_pok |= SP_INTRP; str->str_nok = 0; str_replace(src,str); } STR * interp(str,src,sp) register STR *str; STR *src; int sp; { register char *s; register char *t; register char *send; register STR **elem; if (!(src->str_pok & SP_INTRP)) { int oldsave = savestack->ary_fill; (void)savehptr(&curstash); curstash = src->str_u.str_hash; /* so stabent knows right package */ intrpcompile(src); restorelist(oldsave); } s = src->str_ptr; /* assumed valid since str_pok set */ t = s; send = s + src->str_cur; if (src->str_u.str_args) { (void)eval(src->str_u.str_args,G_ARRAY,sp); /* Assuming we have correct # of args */ elem = stack->ary_array + sp; } str_nset(str,"",0); while (s < send) { if (*s == '$' && s+1 < send) { str_ncat(str,t,s-t); switch(*++s) { case 'a': str_scat(str,*++elem); break; case 'b': str_ncat(str,++s,1); break; } t = ++s; } else s++; } str_ncat(str,t,s-t); return str; } void str_inc(str) register STR *str; { register char *d; if (!str) return; if (str->str_nok) { str->str_u.str_nval += 1.0; str->str_pok = 0; return; } if (!str->str_pok || !*str->str_ptr) { str->str_u.str_nval = 1.0; str->str_nok = 1; str->str_pok = 0; return; } 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 (isdigit(*d)) { if (++*d <= '9') return; *(d--) = '0'; } else { ++*d; if (isalpha(*d)) return; *(d--) -= 'z' - 'a' + 1; } } /* oh,oh, the number grew */ STR_GROW(str, str->str_cur + 2); str->str_cur++; for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--) *d = d[-1]; if (isdigit(d[1])) *d = '1'; else *d = d[1]; } void str_dec(str) register STR *str; { if (!str) return; if (str->str_nok) { str->str_u.str_nval -= 1.0; str->str_pok = 0; return; } if (!str->str_pok) { str->str_u.str_nval = -1.0; str->str_nok = 1; return; } str_numset(str,atof(str->str_ptr) - 1.0); } /* Make a string that will exist for the duration of the expression * evaluation. Actually, it may have to last longer than that, but * hopefully cmd_exec won't free it until it has been assigned to a * permanent location. */ static long tmps_size = -1; STR * str_static(oldstr) STR *oldstr; { register STR *str = Str_new(78,0); str_sset(str,oldstr); if (++tmps_max > tmps_size) { tmps_size = tmps_max; if (!(tmps_size & 127)) { if (tmps_size) Renew(tmps_list, tmps_size + 128, STR*); else New(702,tmps_list, 128, STR*); } } tmps_list[tmps_max] = str; return str; } /* same thing without the copying */ STR * str_2static(str) register STR *str; { if (++tmps_max > tmps_size) { tmps_size = tmps_max; if (!(tmps_size & 127)) { if (tmps_size) Renew(tmps_list, tmps_size + 128, STR*); else New(704,tmps_list, 128, STR*); } } tmps_list[tmps_max] = str; return str; } STR * str_make(s,len) char *s; int len; { register STR *str = Str_new(79,0); if (!len) len = strlen(s); str_nset(str,s,len); return str; } STR * str_nmake(n) double n; { register STR *str = Str_new(80,0); str_numset(str,n); return str; } /* make an exact duplicate of old */ STR * str_smake(old) register STR *old; { register STR *new = Str_new(81,0); if (!old) return Nullstr; if (old->str_state == SS_FREE) { warn("semi-panic: attempt to dup freed string"); return Nullstr; } if (old->str_state == SS_INCR && !(old->str_pok & 2)) str_grow(old,0); if (new->str_ptr) Safefree(new->str_ptr); Copy(old,new,1,STR); if (old->str_ptr) new->str_ptr = nsavestr(old->str_ptr,old->str_len); return new; } str_reset(s,stash) register char *s; HASH *stash; { register HENT *entry; register STAB *stab; register STR *str; register int i; register SPAT *spat; register int max; if (!*s) { /* reset ?? searches */ for (spat = stash->tbl_spatroot; spat != Nullspat; spat = spat->spat_next) { spat->spat_flags &= ~SPAT_USED; } return; } /* reset variables */ while (*s) { i = *s; if (s[1] == '-') { s += 2; } max = *s++; for ( ; i <= max; i++) { for (entry = stash->tbl_array[i]; entry; entry = entry->hent_next) { stab = (STAB*)entry->hent_val; str = stab_val(stab); str->str_cur = 0; str->str_nok = 0; #ifdef TAINT str->str_tainted = tainted; #endif if (str->str_ptr != Nullch) str->str_ptr[0] = '\0'; if (stab_xarray(stab)) { aclear(stab_xarray(stab)); } if (stab_xhash(stab)) { hclear(stab_xhash(stab)); if (stab == envstab) environ[0] = Nullch; } } } } } #ifdef TAINT taintproper(s) char *s; { #ifdef DEBUGGING if (debug & 2048) fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid); #endif if (tainted && (!euid || euid != uid)) { if (!unsafe) fatal("%s", s); else if (dowarn) warn("%s", s); } } taintenv() { register STR *envstr; envstr = hfetch(stab_hash(envstab),"PATH",4,FALSE); if (!envstr || envstr->str_tainted) { tainted = 1; taintproper("Insecure PATH"); } envstr = hfetch(stab_hash(envstab),"IFS",3,FALSE); if (envstr && envstr->str_tainted) { tainted = 1; taintproper("Insecure IFS"); } } #endif /* TAINT */ s,tainted,uid, euid); #endif if (tainted && (!euid || euid != uid)) { if (!unsafe) fatal("%s", s); else if (dowarn) warn("%s", s); } } taintenv() { regisperl/consarg.c 644 473 0 64714 4747105035 6666 /* $Header: consarg.c,v 3.0.1.3 90/02/28 16:47:54 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: consarg.c,v $ * Revision 3.0.1.3 90/02/28 16:47:54 lwall * patch9: the x operator is now up to 10 times faster * patch9: @_ clobbered by ($foo,$bar) = split * * Revision 3.0.1.2 89/11/17 15:11:34 lwall * patch5: defined $foo{'bar'} should not create element * * Revision 3.0.1.1 89/11/11 04:14:30 lwall * patch2: '-' x 26 made warnings about undefined value * patch2: eval with no args caused strangeness * patch2: local(@foo) didn't work, but local(@foo,$bar) did * * Revision 3.0 89/10/18 15:10:30 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" static int nothing_in_common(); static int arg_common(); static int spat_common(); ARG * make_split(stab,arg,limarg) register STAB *stab; register ARG *arg; ARG *limarg; { register SPAT *spat; if (arg->arg_type != O_MATCH) { Newz(201,spat,1,SPAT); spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ curstash->tbl_spatroot = spat; spat->spat_runtime = arg; arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat); } Renew(arg,4,ARG); arg->arg_len = 3; if (limarg) { if (limarg->arg_type == O_ITEM) { Copy(limarg+1,arg+3,1,ARG); limarg[1].arg_type = A_NULL; arg_free(limarg); } else { arg[3].arg_type = A_EXPR; arg[3].arg_ptr.arg_arg = limarg; } } else arg[3].arg_type = A_NULL; arg->arg_type = O_SPLIT; spat = arg[2].arg_ptr.arg_spat; spat->spat_repl = stab2arg(A_STAB,aadd(stab)); if (spat->spat_short) { /* exact match can bypass regexec() */ if (!((spat->spat_flags & SPAT_SCANFIRST) && (spat->spat_flags & SPAT_ALL) )) { str_free(spat->spat_short); spat->spat_short = Nullstr; } } return arg; } ARG * mod_match(type,left,pat) register ARG *left; register ARG *pat; { register SPAT *spat; register ARG *newarg; if ((pat->arg_type == O_MATCH || pat->arg_type == O_SUBST || pat->arg_type == O_TRANS || pat->arg_type == O_SPLIT ) && pat[1].arg_ptr.arg_stab == defstab ) { switch (pat->arg_type) { case O_MATCH: newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH, pat->arg_len, left,Nullarg,Nullarg); break; case O_SUBST: newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST, pat->arg_len, left,Nullarg,Nullarg)); break; case O_TRANS: newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS, pat->arg_len, left,Nullarg,Nullarg)); break; case O_SPLIT: newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT, pat->arg_len, left,Nullarg,Nullarg); break; } if (pat->arg_len >= 2) { newarg[2].arg_type = pat[2].arg_type; newarg[2].arg_ptr = pat[2].arg_ptr; newarg[2].arg_flags = pat[2].arg_flags; if (pat->arg_len >= 3) { newarg[3].arg_type = pat[3].arg_type; newarg[3].arg_ptr = pat[3].arg_ptr; newarg[3].arg_flags = pat[3].arg_flags; } } Safefree(pat); } else { Newz(202,spat,1,SPAT); spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ curstash->tbl_spatroot = spat; spat->spat_runtime = pat; newarg = make_op(type,2,left,Nullarg,Nullarg); newarg[2].arg_type = A_SPAT | A_DONT; newarg[2].arg_ptr.arg_spat = spat; } return newarg; } ARG * make_op(type,newlen,arg1,arg2,arg3) int type; int newlen; ARG *arg1; ARG *arg2; ARG *arg3; { register ARG *arg; register ARG *chld; register int doarg; extern ARG *arg4; /* should be normal arguments, really */ extern ARG *arg5; arg = op_new(newlen); arg->arg_type = type; doarg = opargs[type]; if (chld = arg1) { if (chld->arg_type == O_ITEM && (hoistable[chld[1].arg_type] || chld[1].arg_type == A_LVAL || (chld[1].arg_type == A_LEXPR && (chld[1].arg_ptr.arg_arg->arg_type == O_LIST || chld[1].arg_ptr.arg_arg->arg_type == O_ARRAY || chld[1].arg_ptr.arg_arg->arg_type == O_HASH )))) { arg[1].arg_type = chld[1].arg_type; arg[1].arg_ptr = chld[1].arg_ptr; arg[1].arg_flags |= chld[1].arg_flags; arg[1].arg_len = chld[1].arg_len; free_arg(chld); } else { arg[1].arg_type = A_EXPR; arg[1].arg_ptr.arg_arg = chld; } if (!(doarg & 1)) arg[1].arg_type |= A_DONT; if (doarg & 2) arg[1].arg_flags |= AF_ARYOK; } doarg >>= 2; if (chld = arg2) { if (chld->arg_type == O_ITEM && (hoistable[chld[1].arg_type] || (type == O_ASSIGN && ((chld[1].arg_type == A_READ && !(arg[1].arg_type & A_DONT)) || (chld[1].arg_type == A_INDREAD && !(arg[1].arg_type & A_DONT)) || (chld[1].arg_type == A_GLOB && !(arg[1].arg_type & A_DONT)) ) ) ) ) { arg[2].arg_type = chld[1].arg_type; arg[2].arg_ptr = chld[1].arg_ptr; arg[2].arg_len = chld[1].arg_len; free_arg(chld); } else { arg[2].arg_type = A_EXPR; arg[2].arg_ptr.arg_arg = chld; } if (!(doarg & 1)) arg[2].arg_type |= A_DONT; if (doarg & 2) arg[2].arg_flags |= AF_ARYOK; } doarg >>= 2; if (chld = arg3) { if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) { arg[3].arg_type = chld[1].arg_type; arg[3].arg_ptr = chld[1].arg_ptr; arg[3].arg_len = chld[1].arg_len; free_arg(chld); } else { arg[3].arg_type = A_EXPR; arg[3].arg_ptr.arg_arg = chld; } if (!(doarg & 1)) arg[3].arg_type |= A_DONT; if (doarg & 2) arg[3].arg_flags |= AF_ARYOK; } if (newlen >= 4 && (chld = arg4)) { if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) { arg[4].arg_type = chld[1].arg_type; arg[4].arg_ptr = chld[1].arg_ptr; arg[4].arg_len = chld[1].arg_len; free_arg(chld); } else { arg[4].arg_type = A_EXPR; arg[4].arg_ptr.arg_arg = chld; } } if (newlen >= 5 && (chld = arg5)) { if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) { arg[5].arg_type = chld[1].arg_type; arg[5].arg_ptr = chld[1].arg_ptr; arg[5].arg_len = chld[1].arg_len; free_arg(chld); } else { arg[5].arg_type = A_EXPR; arg[5].arg_ptr.arg_arg = chld; } } #ifdef DEBUGGING if (debug & 16) { fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]); if (arg1) fprintf(stderr,",%s=%lx", argname[arg[1].arg_type&A_MASK],arg[1].arg_ptr.arg_arg); if (arg2) fprintf(stderr,",%s=%lx", argname[arg[2].arg_type&A_MASK],arg[2].arg_ptr.arg_arg); if (arg3) fprintf(stderr,",%s=%lx", argname[arg[3].arg_type&A_MASK],arg[3].arg_ptr.arg_arg); if (newlen >= 4) fprintf(stderr,",%s=%lx", argname[arg[4].arg_type&A_MASK],arg[4].arg_ptr.arg_arg); if (newlen >= 5) fprintf(stderr,",%s=%lx", argname[arg[5].arg_type&A_MASK],arg[5].arg_ptr.arg_arg); fprintf(stderr,")\n"); } #endif evalstatic(arg); /* see if we can consolidate anything */ return arg; } void evalstatic(arg) register ARG *arg; { register STR *str; register STR *s1; register STR *s2; double value; /* must not be register */ register char *tmps; int i; unsigned long tmplong; long tmp2; double exp(), log(), sqrt(), modf(); char *crypt(); double sin(), cos(), atan2(), pow(); if (!arg || !arg->arg_len) return; if ((arg[1].arg_type == A_SINGLE || arg->arg_type == O_AELEM) && (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) { str = Str_new(20,0); s1 = arg[1].arg_ptr.arg_str; if (arg->arg_len > 1) s2 = arg[2].arg_ptr.arg_str; else s2 = Nullstr; switch (arg->arg_type) { case O_AELEM: i = (int)str_gnum(s2); if (i < 32767 && i >= 0) { arg->arg_type = O_ITEM; arg->arg_len = 1; arg[1].arg_type = A_ARYSTAB; /* $abc[123] is hoistable now */ arg[1].arg_len = i; arg[1].arg_ptr = arg[1].arg_ptr; /* get stab pointer */ str_free(s2); } /* FALL THROUGH */ default: str_free(str); str = Nullstr; /* can't be evaluated yet */ break; case O_CONCAT: str_sset(str,s1); str_scat(str,s2); break; case O_REPEAT: i = (int)str_gnum(s2); tmps = str_get(s1); str_nset(str,"",0); STR_GROW(str, i * s1->str_cur + 1); repeatcpy(str->str_ptr, tmps, s1->str_cur, i); str->str_cur = i * s1->str_cur; str->str_ptr[str->str_cur] = '\0'; break; case O_MULTIPLY: value = str_gnum(s1); str_numset(str,value * str_gnum(s2)); break; case O_DIVIDE: value = str_gnum(s2); if (value == 0.0) yyerror("Illegal division by constant zero"); else str_numset(str,str_gnum(s1) / value); break; case O_MODULO: tmplong = (long)str_gnum(s2); if (tmplong == 0L) { yyerror("Illegal modulus of constant zero"); break; } tmp2 = (long)str_gnum(s1); #ifndef lint if (tmp2 >= 0) str_numset(str,(double)(tmp2 % tmplong)); else str_numset(str,(double)(tmplong - (-tmp2 % tmplong))); #else tmp2 = tmp2; #endif break; case O_ADD: value = str_gnum(s1); str_numset(str,value + str_gnum(s2)); break; case O_SUBTRACT: value = str_gnum(s1); str_numset(str,value - str_gnum(s2)); break; case O_LEFT_SHIFT: value = str_gnum(s1); i = (int)str_gnum(s2); #ifndef lint str_numset(str,(double)(((long)value) << i)); #endif break; case O_RIGHT_SHIFT: value = str_gnum(s1); i = (int)str_gnum(s2); #ifndef lint str_numset(str,(double)(((long)value) >> i)); #endif break; case O_LT: value = str_gnum(s1); str_numset(str,(value < str_gnum(s2)) ? 1.0 : 0.0); break; case O_GT: value = str_gnum(s1); str_numset(str,(value > str_gnum(s2)) ? 1.0 : 0.0); break; case O_LE: value = str_gnum(s1); str_numset(str,(value <= str_gnum(s2)) ? 1.0 : 0.0); break; case O_GE: value = str_gnum(s1); str_numset(str,(value >= str_gnum(s2)) ? 1.0 : 0.0); break; case O_EQ: if (dowarn) { if ((!s1->str_nok && !looks_like_number(s1)) || (!s2->str_nok && !looks_like_number(s2)) ) warn("Possible use of == on string value"); } value = str_gnum(s1); str_numset(str,(value == str_gnum(s2)) ? 1.0 : 0.0); break; case O_NE: value = str_gnum(s1); str_numset(str,(value != str_gnum(s2)) ? 1.0 : 0.0); break; case O_BIT_AND: value = str_gnum(s1); #ifndef lint str_numset(str,(double)(((long)value) & ((long)str_gnum(s2)))); #endif break; case O_XOR: value = str_gnum(s1); #ifndef lint str_numset(str,(double)(((long)value) ^ ((long)str_gnum(s2)))); #endif break; case O_BIT_OR: value = str_gnum(s1); #ifndef lint str_numset(str,(double)(((long)value) | ((long)str_gnum(s2)))); #endif break; case O_AND: if (str_true(s1)) str_sset(str,s2); else str_sset(str,s1); break; case O_OR: if (str_true(s1)) str_sset(str,s1); else str_sset(str,s2); break; case O_COND_EXPR: if ((arg[3].arg_type & A_MASK) != A_SINGLE) { str_free(str); str = Nullstr; } else { if (str_true(s1)) str_sset(str,s2); else str_sset(str,arg[3].arg_ptr.arg_str); str_free(arg[3].arg_ptr.arg_str); } break; case O_NEGATE: str_numset(str,(double)(-str_gnum(s1))); break; case O_NOT: str_numset(str,(double)(!str_true(s1))); break; case O_COMPLEMENT: #ifndef lint str_numset(str,(double)(~(long)str_gnum(s1))); #endif break; case O_SIN: str_numset(str,sin(str_gnum(s1))); break; case O_COS: str_numset(str,cos(str_gnum(s1))); break; case O_ATAN2: value = str_gnum(s1); str_numset(str,atan2(value, str_gnum(s2))); break; case O_POW: value = str_gnum(s1); str_numset(str,pow(value, str_gnum(s2))); break; case O_LENGTH: str_numset(str, (double)str_len(s1)); break; case O_SLT: str_numset(str,(double)(str_cmp(s1,s2) < 0)); break; case O_SGT: str_numset(str,(double)(str_cmp(s1,s2) > 0)); break; case O_SLE: str_numset(str,(double)(str_cmp(s1,s2) <= 0)); break; case O_SGE: str_numset(str,(double)(str_cmp(s1,s2) >= 0)); break; case O_SEQ: str_numset(str,(double)(str_eq(s1,s2))); break; case O_SNE: str_numset(str,(double)(!str_eq(s1,s2))); break; case O_CRYPT: #ifdef CRYPT tmps = str_get(s1); str_set(str,crypt(tmps,str_get(s2))); #else yyerror( "The crypt() function is unimplemented due to excessive paranoia."); #endif break; case O_EXP: str_numset(str,exp(str_gnum(s1))); break; case O_LOG: str_numset(str,log(str_gnum(s1))); break; case O_SQRT: str_numset(str,sqrt(str_gnum(s1))); break; case O_INT: value = str_gnum(s1); if (value >= 0.0) (void)modf(value,&value); else { (void)modf(-value,&value); value = -value; } str_numset(str,value); break; case O_ORD: #ifndef I286 str_numset(str,(double)(*str_get(s1))); #else { int zapc; char *zaps; zaps = str_get(s1); zapc = (int) *zaps; str_numset(str,(double)(zapc)); } #endif break; } if (str) { arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */ str_free(s1); str_free(s2); arg[1].arg_ptr.arg_str = str; } } } ARG * l(arg) register ARG *arg; { register int i; register ARG *arg1; register ARG *arg2; SPAT *spat; int arghog = 0; i = arg[1].arg_type & A_MASK; arg->arg_flags |= AF_COMMON; /* assume something in common */ /* which forces us to copy things */ if (i == A_ARYLEN) { arg[1].arg_type = A_LARYLEN; return arg; } if (i == A_ARYSTAB) { arg[1].arg_type = A_LARYSTAB; return arg; } /* see if it's an array reference */ if (i == A_EXPR || i == A_LEXPR) { arg1 = arg[1].arg_ptr.arg_arg; if (arg1->arg_type == O_LIST || arg1->arg_type == O_ITEM) { /* assign to list */ if (arg->arg_len > 1) { dehoist(arg,2); arg2 = arg[2].arg_ptr.arg_arg; if (nothing_in_common(arg1,arg2)) arg->arg_flags &= ~AF_COMMON; if (arg->arg_type == O_ASSIGN) { if (arg1->arg_flags & AF_LOCAL) arg->arg_flags |= AF_LOCAL; arg[1].arg_flags |= AF_ARYOK; arg[2].arg_flags |= AF_ARYOK; } } else if (arg->arg_type != O_CHOP) arg->arg_type = O_ASSIGN; /* possible local(); */ for (i = arg1->arg_len; i >= 1; i--) { switch (arg1[i].arg_type) { case A_STAR: case A_LSTAR: arg1[i].arg_type = A_LSTAR; break; case A_STAB: case A_LVAL: arg1[i].arg_type = A_LVAL; break; case A_ARYLEN: case A_LARYLEN: arg1[i].arg_type = A_LARYLEN; break; case A_ARYSTAB: case A_LARYSTAB: arg1[i].arg_type = A_LARYSTAB; break; case A_EXPR: case A_LEXPR: arg1[i].arg_type = A_LEXPR; switch(arg1[i].arg_ptr.arg_arg->arg_type) { case O_ARRAY: case O_LARRAY: arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY; arghog = 1; break; case O_AELEM: case O_LAELEM: arg1[i].arg_ptr.arg_arg->arg_type = O_LAELEM; break; case O_HASH: case O_LHASH: arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH; arghog = 1; break; case O_HELEM: case O_LHELEM: arg1[i].arg_ptr.arg_arg->arg_type = O_LHELEM; break; case O_ASLICE: case O_LASLICE: arg1[i].arg_ptr.arg_arg->arg_type = O_LASLICE; break; case O_HSLICE: case O_LHSLICE: arg1[i].arg_ptr.arg_arg->arg_type = O_LHSLICE; break; default: goto ill_item; } break; default: ill_item: (void)sprintf(tokenbuf, "Illegal item (%s) as lvalue", argname[arg1[i].arg_type&A_MASK]); yyerror(tokenbuf); } } if (arg->arg_len > 1) { if (arg2->arg_type == O_SPLIT && !arg2[3].arg_type && !arghog) { arg2[3].arg_type = A_SINGLE; arg2[3].arg_ptr.arg_str = str_nmake((double)arg1->arg_len + 1); /* limit split len*/ } } } else if (arg1->arg_type == O_AELEM || arg1->arg_type == O_LAELEM) if (arg->arg_type == O_DEFINED) arg1->arg_type = O_AELEM; else arg1->arg_type = O_LAELEM; else if (arg1->arg_type == O_ARRAY || arg1->arg_type == O_LARRAY) { arg1->arg_type = O_LARRAY; if (arg->arg_len > 1) { dehoist(arg,2); arg2 = arg[2].arg_ptr.arg_arg; if (arg2->arg_type == O_SPLIT) { /* use split's builtin =?*/ spat = arg2[2].arg_ptr.arg_spat; if (!(spat->spat_flags & SPAT_ONCE) && nothing_in_common(arg1,spat->spat_repl)) { spat->spat_repl[1].arg_ptr.arg_stab = arg1[1].arg_ptr.arg_stab; spat->spat_flags |= SPAT_ONCE; arg_free(arg1); /* recursive */ free_arg(arg); /* non-recursive */ return arg2; /* split has builtin assign */ } } else if (nothing_in_common(arg1,arg2)) arg->arg_flags &= ~AF_COMMON; if (arg->arg_type == O_ASSIGN) { arg[1].arg_flags |= AF_ARYOK; arg[2].arg_flags |= AF_ARYOK; } } else if (arg->arg_type == O_ASSIGN) arg[1].arg_flags |= AF_ARYOK; } else if (arg1->arg_type == O_HELEM || arg1->arg_type == O_LHELEM) if (arg->arg_type == O_DEFINED) arg1->arg_type = O_HELEM; /* avoid creating one */ else arg1->arg_type = O_LHELEM; else if (arg1->arg_type == O_HASH || arg1->arg_type == O_LHASH) { arg1->arg_type = O_LHASH; if (arg->arg_len > 1) { dehoist(arg,2); arg2 = arg[2].arg_ptr.arg_arg; if (nothing_in_common(arg1,arg2)) arg->arg_flags &= ~AF_COMMON; if (arg->arg_type == O_ASSIGN) { arg[1].arg_flags |= AF_ARYOK; arg[2].arg_flags |= AF_ARYOK; } } else if (arg->arg_type == O_ASSIGN) arg[1].arg_flags |= AF_ARYOK; } else if (arg1->arg_type == O_ASLICE) { arg1->arg_type = O_LASLICE; if (arg->arg_type == O_ASSIGN) { arg[1].arg_flags |= AF_ARYOK; arg[2].arg_flags |= AF_ARYOK; } } else if (arg1->arg_type == O_HSLICE) { arg1->arg_type = O_LHSLICE; if (arg->arg_type == O_ASSIGN) { arg[1].arg_flags |= AF_ARYOK; arg[2].arg_flags |= AF_ARYOK; } } else if ((arg->arg_type == O_DEFINED || arg->arg_type == O_UNDEF) && (arg1->arg_type == (perldb ? O_DBSUBR : O_SUBR)) ) { arg[1].arg_type |= A_DONT; } else if (arg1->arg_type == O_SUBSTR || arg1->arg_type == O_VEC) { (void)l(arg1); Renewc(arg1->arg_ptr.arg_str, 1, struct lstring, STR); /* grow string struct to hold an lstring struct */ } else if (arg1->arg_type == O_ASSIGN) { if (arg->arg_type == O_CHOP) arg[1].arg_flags &= ~AF_ARYOK; /* grandfather chop idiom */ } else { (void)sprintf(tokenbuf, "Illegal expression (%s) as lvalue",opname[arg1->arg_type]); yyerror(tokenbuf); } arg[1].arg_type = A_LEXPR | (arg[1].arg_type & A_DONT); if (arg->arg_type == O_ASSIGN && (arg1[1].arg_flags & AF_ARYOK)) { arg[1].arg_flags |= AF_ARYOK; if (arg->arg_len > 1) arg[2].arg_flags |= AF_ARYOK; } #ifdef DEBUGGING if (debug & 16) fprintf(stderr,"lval LEXPR\n"); #endif return arg; } if (i == A_STAR || i == A_LSTAR) { arg[1].arg_type = A_LSTAR | (arg[1].arg_type & A_DONT); return arg; } /* not an array reference, should be a register name */ if (i != A_STAB && i != A_LVAL) { (void)sprintf(tokenbuf, "Illegal item (%s) as lvalue",argname[arg[1].arg_type&A_MASK]); yyerror(tokenbuf); } arg[1].arg_type = A_LVAL | (arg[1].arg_type & A_DONT); #ifdef DEBUGGING if (debug & 16) fprintf(stderr,"lval LVAL\n"); #endif return arg; } ARG * fixl(type,arg) int type; ARG *arg; { if (type == O_DEFINED || type == O_UNDEF) { if (arg->arg_type != O_ITEM) arg = hide_ary(arg); if (arg->arg_type == O_ITEM) { type = arg[1].arg_type & A_MASK; if (type == A_EXPR || type == A_LEXPR) arg[1].arg_type = A_LEXPR|A_DONT; } } return arg; } dehoist(arg,i) ARG *arg; { ARG *tmparg; if (arg[i].arg_type != A_EXPR) { /* dehoist */ tmparg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg); tmparg[1] = arg[i]; arg[i].arg_ptr.arg_arg = tmparg; arg[i].arg_type = A_EXPR; } } ARG * addflags(i,flags,arg) register ARG *arg; { arg[i].arg_flags |= flags; return arg; } ARG * hide_ary(arg) ARG *arg; { if (arg->arg_type == O_ARRAY || arg->arg_type == O_HASH) return make_op(O_ITEM,1,arg,Nullarg,Nullarg); return arg; } /* maybe do a join on multiple array dimensions */ ARG * jmaybe(arg) register ARG *arg; { if (arg && arg->arg_type == O_COMMA) { arg = listish(arg); arg = make_op(O_JOIN, 2, stab2arg(A_STAB,stabent(";",TRUE)), make_list(arg), Nullarg); } return arg; } ARG * make_list(arg) register ARG *arg; { register int i; register ARG *node; register ARG *nxtnode; register int j; STR *tmpstr; if (!arg) { arg = op_new(0); arg->arg_type = O_LIST; } if (arg->arg_type != O_COMMA) { if (arg->arg_type != O_ARRAY) arg->arg_flags |= AF_LISTISH; /* see listish() below */ return arg; } for (i = 2, node = arg; ; i++) { if (node->arg_len < 2) break; if (node[1].arg_type != A_EXPR) break; node = node[1].arg_ptr.arg_arg; if (node->arg_type != O_COMMA) break; } if (i > 2) { node = arg; arg = op_new(i); tmpstr = arg->arg_ptr.arg_str; #ifdef STRUCTCOPY *arg = *node; /* copy everything except the STR */ #else (void)bcopy((char *)node, (char *)arg, sizeof(ARG)); #endif arg->arg_ptr.arg_str = tmpstr; for (j = i; ; ) { #ifdef STRUCTCOPY arg[j] = node[2]; #else (void)bcopy((char *)(node+2), (char *)(arg+j), sizeof(ARG)); #endif arg[j].arg_flags |= AF_ARYOK; --j; /* Bug in Xenix compiler */ if (j < 2) { #ifdef STRUCTCOPY arg[1] = node[1]; #else (void)bcopy((char *)(node+1), (char *)(arg+1), sizeof(ARG)); #endif free_arg(node); break; } nxtnode = node[1].arg_ptr.arg_arg; free_arg(node); node = nxtnode; } } arg[1].arg_flags |= AF_ARYOK; arg[2].arg_flags |= AF_ARYOK; arg->arg_type = O_LIST; arg->arg_len = i; return arg; } /* turn a single item into a list */ ARG * listish(arg) ARG *arg; { if (arg->arg_flags & AF_LISTISH) arg = make_op(O_LIST,1,arg,Nullarg,Nullarg); return arg; } ARG * maybelistish(optype, arg) int optype; ARG *arg; { if (optype == O_PRTF || (arg->arg_type == O_ASLICE || arg->arg_type == O_HSLICE || arg->arg_type == O_F_OR_R) ) arg = listish(arg); return arg; } /* mark list of local variables */ ARG * localize(arg) ARG *arg; { arg->arg_flags |= AF_LOCAL; return arg; } ARG * fixeval(arg) ARG *arg; { Renew(arg, 3, ARG); if (arg->arg_len == 0) arg[1].arg_type = A_NULL; arg->arg_len = 2; arg[2].arg_ptr.arg_hash = curstash; arg[2].arg_type = A_NULL; return arg; } ARG * rcatmaybe(arg) ARG *arg; { if (arg->arg_type == O_CONCAT && arg[2].arg_type == A_READ) { arg->arg_type = O_RCAT; arg[2].arg_type = arg[2].arg_ptr.arg_arg[1].arg_type; arg[2].arg_ptr = arg[2].arg_ptr.arg_arg[1].arg_ptr; free_arg(arg[2].arg_ptr.arg_arg); } return arg; } ARG * stab2arg(atype,stab) int atype; register STAB *stab; { register ARG *arg; arg = op_new(1); arg->arg_type = O_ITEM; arg[1].arg_type = atype; arg[1].arg_ptr.arg_stab = stab; return arg; } ARG * cval_to_arg(cval) register char *cval; { register ARG *arg; arg = op_new(1); arg->arg_type = O_ITEM; arg[1].arg_type = A_SINGLE; arg[1].arg_ptr.arg_str = str_make(cval,0); Safefree(cval); return arg; } ARG * op_new(numargs) int numargs; { register ARG *arg; Newz(203,arg, numargs + 1, ARG); arg->arg_ptr.arg_str = Str_new(21,0); arg->arg_len = numargs; return arg; } void free_arg(arg) ARG *arg; { str_free(arg->arg_ptr.arg_str); Safefree(arg); } ARG * make_match(type,expr,spat) int type; ARG *expr; SPAT *spat; { register ARG *arg; arg = make_op(type,2,expr,Nullarg,Nullarg); arg[2].arg_type = A_SPAT|A_DONT; arg[2].arg_ptr.arg_spat = spat; #ifdef DEBUGGING if (debug & 16) fprintf(stderr,"make_match SPAT=%lx\n",(long)spat); #endif if (type == O_SUBST || type == O_NSUBST) { if (arg[1].arg_type != A_STAB) { yyerror("Illegal lvalue"); } arg[1].arg_type = A_LVAL; } return arg; } ARG * cmd_to_arg(cmd) CMD *cmd; { register ARG *arg; arg = op_new(1); arg->arg_type = O_ITEM; arg[1].arg_type = A_CMD; arg[1].arg_ptr.arg_cmd = cmd; return arg; } /* Check two expressions to see if there is any identifier in common */ static int nothing_in_common(arg1,arg2) ARG *arg1; ARG *arg2; { static int thisexpr = 0; /* I don't care if this wraps */ thisexpr++; if (arg_common(arg1,thisexpr,1)) return 0; /* hit eval or do {} */ if (arg_common(arg2,thisexpr,0)) return 0; /* hit identifier again */ return 1; } /* Recursively descend an expression and mark any identifier or check * it to see if it was marked already. */ static int arg_common(arg,exprnum,marking) register ARG *arg; int exprnum; int marking; { register int i; if (!arg) return 0; for (i = arg->arg_len; i >= 1; i--) { switch (arg[i].arg_type & A_MASK) { case A_NULL: break; case A_LEXPR: case A_EXPR: if (arg_common(arg[i].arg_ptr.arg_arg,exprnum,marking)) return 1; break; case A_CMD: return 1; /* assume hanky panky */ case A_STAR: case A_LSTAR: case A_STAB: case A_LVAL: case A_ARYLEN: case A_LARYLEN: if (marking) stab_lastexpr(arg[i].arg_ptr.arg_stab) = exprnum; else if (stab_lastexpr(arg[i].arg_ptr.arg_stab) == exprnum) return 1; break; case A_DOUBLE: case A_BACKTICK: { register char *s = arg[i].arg_ptr.arg_str->str_ptr; register char *send = s + arg[i].arg_ptr.arg_str->str_cur; register STAB *stab; while (*s) { if (*s == '$' && s[1]) { s = scanreg(s,send,tokenbuf); stab = stabent(tokenbuf,TRUE); if (marking) stab_lastexpr(stab) = exprnum; else if (stab_lastexpr(stab) == exprnum) return 1; continue; } else if (*s == '\\' && s[1]) s++; s++; } } break; case A_SPAT: if (spat_common(arg[i].arg_ptr.arg_spat,exprnum,marking)) return 1; break; case A_READ: case A_INDREAD: case A_GLOB: case A_WORD: case A_SINGLE: break; } } switch (arg->arg_type) { case O_ARRAY: case O_LARRAY: if ((arg[1].arg_type & A_MASK) == A_STAB) (void)aadd(arg[1].arg_ptr.arg_stab); break; case O_HASH: case O_LHASH: if ((arg[1].arg_type & A_MASK) == A_STAB) (void)hadd(arg[1].arg_ptr.arg_stab); break; case O_EVAL: case O_SUBR: case O_DBSUBR: return 1; } return 0; } static int spat_common(spat,exprnum,marking) register SPAT *spat; int exprnum; int marking; { if (spat->spat_runtime) if (arg_common(spat->spat_runtime,exprnum,marking)) return 1; if (spat->spat_repl) { if (arg_common(spat->spat_repl,exprnum,marking)) return 1; } return 0; } e O_HASH: case O_LHASH: if ((arg[1].arg_type & perl/cmd.c 644 473 0 66726 4747105036 6003 /* $Header: cmd.c,v 3.0.1.5 90/02/28 16:38:31 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: cmd.c,v $ * Revision 3.0.1.5 90/02/28 16:38:31 lwall * patch9: volatilized some more variables for super-optimizing compilers * patch9: nested foreach loops didn't reset inner loop on next to outer loop * patch9: returned values were read from obsolete stack * patch9: added sanity check on longjmp() return value * patch9: substitutions that almost always succeed can corrupt label stack * patch9: subs which return by both mechanisms can clobber local return data * * Revision 3.0.1.4 89/12/21 19:17:41 lwall * patch7: arranged for certain registers to be restored after longjmp() * patch7: made nested or recursive foreach work right * * Revision 3.0.1.3 89/11/17 15:04:36 lwall * patch5: nested foreach on same array didn't work * * Revision 3.0.1.2 89/11/11 04:08:56 lwall * patch2: non-BSD machines required two ^D's for <> * patch2: grow_dlevel() not inside #ifdef DEBUGGING * * Revision 3.0.1.1 89/10/26 23:04:21 lwall * patch1: heuristically disabled optimization could cause core dump * * Revision 3.0 89/10/18 15:09:02 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" #ifdef I_VARARGS # include #endif static STR str_chop; void grow_dlevel(); /* do longjmps() clobber register variables? */ #if defined(cray) || defined(__STDC__) #define JMPCLOBBER #endif /* This is the main command loop. We try to spend as much time in this loop * as possible, so lots of optimizations do their activities in here. This * means things get a little sloppy. */ int cmd_exec(cmdparm,gimme,sp) CMD *VOLATILE cmdparm; VOLATILE int gimme; VOLATILE int sp; { register CMD *cmd = cmdparm; SPAT *VOLATILE oldspat; VOLATILE int firstsave = savestack->ary_fill; VOLATILE int oldsave; VOLATILE int aryoptsave; #ifdef DEBUGGING VOLATILE int olddlevel; VOLATILE int entdlevel; #endif register STR *retstr = &str_undef; register char *tmps; register int cmdflags; register int match; register char *go_to = goto_targ; register int newsp = -2; register STR **st = stack->ary_array; VOLATILE FILE *fp; VOLATILE ARRAY *ar; lastsize = 0; #ifdef DEBUGGING entdlevel = dlevel; #endif tail_recursion_entry: #ifdef DEBUGGING dlevel = entdlevel; #endif #ifdef TAINT tainted = 0; /* Each statement is presumed innocent */ #endif if (cmd == Nullcmd) { if (gimme == G_ARRAY && newsp > -2) return newsp; else { st[++sp] = retstr; return sp; } } cmdflags = cmd->c_flags; /* hopefully load register */ if (go_to) { if (cmd->c_label && strEQ(go_to,cmd->c_label)) goto_targ = go_to = Nullch; /* here at last */ else { switch (cmd->c_type) { case C_IF: oldspat = curspat; oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif retstr = &str_yes; newsp = -2; if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING if (debug) { debname[dlevel] = 't'; debdelim[dlevel] = '_'; if (++dlevel >= dlmax) grow_dlevel(); } #endif newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; } if (!goto_targ) go_to = Nullch; curspat = oldspat; if (savestack->ary_fill > oldsave) restorelist(oldsave); #ifdef DEBUGGING dlevel = olddlevel; #endif cmd = cmd->ucmd.ccmd.cc_alt; goto tail_recursion_entry; case C_ELSE: oldspat = curspat; oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif retstr = &str_undef; newsp = -2; if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING if (debug) { debname[dlevel] = 'e'; debdelim[dlevel] = '_'; if (++dlevel >= dlmax) grow_dlevel(); } #endif newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; } if (!goto_targ) go_to = Nullch; curspat = oldspat; if (savestack->ary_fill > oldsave) restorelist(oldsave); #ifdef DEBUGGING dlevel = olddlevel; #endif break; case C_BLOCK: case C_WHILE: if (!(cmdflags & CF_ONCE)) { cmdflags |= CF_ONCE; if (++loop_ptr >= loop_max) { loop_max += 128; Renew(loop_stack, loop_max, struct loop); } loop_stack[loop_ptr].loop_label = cmd->c_label; loop_stack[loop_ptr].loop_sp = sp; #ifdef DEBUGGING if (debug & 4) { deb("(Pushing label #%d %s)\n", loop_ptr, cmd->c_label ? cmd->c_label : ""); } #endif } #ifdef JMPCLOBBER cmdparm = cmd; #endif if (match = setjmp(loop_stack[loop_ptr].loop_env)) { st = stack->ary_array; /* possibly reallocated */ #ifdef JMPCLOBBER cmd = cmdparm; cmdflags = cmd->c_flags|CF_ONCE; #endif if (savestack->ary_fill > oldsave) restorelist(oldsave); switch (match) { default: fatal("longjmp returned bad value (%d)",match); case O_LAST: /* not done unless go_to found */ go_to = Nullch; if (lastretstr) { retstr = lastretstr; newsp = -2; } else { newsp = sp + lastsize; retstr = st[newsp]; } #ifdef DEBUGGING olddlevel = dlevel; #endif curspat = oldspat; goto next_cmd; case O_NEXT: /* not done unless go_to found */ go_to = Nullch; #ifdef JMPCLOBBER newsp = -2; retstr = &str_undef; #endif goto next_iter; case O_REDO: /* not done unless go_to found */ go_to = Nullch; #ifdef JMPCLOBBER newsp = -2; retstr = &str_undef; #endif goto doit; } } oldspat = curspat; oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING if (debug) { debname[dlevel] = 't'; debdelim[dlevel] = '_'; if (++dlevel >= dlmax) grow_dlevel(); } #endif newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; } if (!goto_targ) { go_to = Nullch; goto next_iter; } #ifdef DEBUGGING dlevel = olddlevel; #endif if (cmd->ucmd.ccmd.cc_alt) { #ifdef DEBUGGING if (debug) { debname[dlevel] = 'a'; debdelim[dlevel] = '_'; if (++dlevel >= dlmax) grow_dlevel(); } #endif newsp = cmd_exec(cmd->ucmd.ccmd.cc_alt,gimme,sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; } if (goto_targ) break; go_to = Nullch; goto finish_while; } cmd = cmd->c_next; if (cmd && cmd->c_head == cmd) /* reached end of while loop */ return sp; /* targ isn't in this block */ if (cmdflags & CF_ONCE) { #ifdef DEBUGGING if (debug & 4) { tmps = loop_stack[loop_ptr].loop_label; deb("(Popping label #%d %s)\n",loop_ptr, tmps ? tmps : "" ); } #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) { 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] = '!'; if (++dlevel >= dlmax) grow_dlevel(); } #endif /* Here is some common optimization */ if (cmdflags & CF_COND) { switch (cmdflags & CF_OPTIMIZE) { case CFT_FALSE: retstr = cmd->c_short; newsp = -2; match = FALSE; if (cmdflags & CF_NESURE) goto maybe; break; case CFT_TRUE: retstr = cmd->c_short; newsp = -2; match = TRUE; if (cmdflags & CF_EQSURE) goto flipmaybe; break; case CFT_REG: retstr = STAB_STR(cmd->c_stab); newsp = -2; match = str_true(retstr); /* => retstr = retstr, c2 should fix */ if (cmdflags & (match ? CF_EQSURE : CF_NESURE)) goto flipmaybe; break; case CFT_ANCHOR: /* /^pat/ optimization */ if (multiline) { 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); newsp = -2; #ifndef I286 if (*cmd->c_short->str_ptr == *str_get(retstr) && bcmp(cmd->c_short->str_ptr, str_get(retstr), cmd->c_slen) == 0 ) { if (cmdflags & CF_EQSURE) { if (sawampersand && (cmdflags & CF_OPTIMIZE) != CFT_STROP) { curspat = Nullspat; if (leftstab) str_nset(stab_val(leftstab),"",0); if (amperstab) str_sset(stab_val(amperstab),cmd->c_short); if (rightstab) str_nset(stab_val(rightstab), retstr->str_ptr + cmd->c_slen, retstr->str_cur - cmd->c_slen); } match = !(cmdflags & CF_FIRSTNEG); retstr = &str_yes; goto flipmaybe; } } else if (cmdflags & CF_NESURE) { match = cmdflags & CF_FIRSTNEG; retstr = &str_no; goto flipmaybe; } #else { char *zap1, *zap2, zap1c, zap2c; int zaplen; zap1 = cmd->c_short->str_ptr; zap2 = str_get(retstr); zap1c = *zap1; zap2c = *zap2; zaplen = cmd->c_slen; if ((zap1c == zap2c) && (bcmp(zap1, zap2, zaplen) == 0)) { if (cmdflags & CF_EQSURE) { if (sawampersand && (cmdflags & CF_OPTIMIZE) != CFT_STROP) { curspat = Nullspat; if (leftstab) str_nset(stab_val(leftstab),"",0); if (amperstab) str_sset(stab_val(amperstab),cmd->c_short); if (rightstab) str_nset(stab_val(rightstab), retstr->str_ptr + cmd->c_slen, retstr->str_cur - cmd->c_slen); } match = !(cmdflags & CF_FIRSTNEG); retstr = &str_yes; goto flipmaybe; } } else if (cmdflags & CF_NESURE) { match = cmdflags & CF_FIRSTNEG; retstr = &str_no; goto flipmaybe; } } #endif break; /* must evaluate */ case CFT_SCAN: /* non-anchored search */ scanner: retstr = STAB_STR(cmd->c_stab); newsp = -2; if (retstr->str_pok & SP_STUDIED) if (screamfirst[cmd->c_short->str_rare] >= 0) tmps = screaminstr(retstr, cmd->c_short); else tmps = Nullch; else { tmps = str_get(retstr); /* make sure it's pok */ #ifndef lint tmps = fbminstr((unsigned char*)tmps, (unsigned char*)tmps + retstr->str_cur, cmd->c_short); #endif } if (tmps) { if (cmdflags & CF_EQSURE) { ++cmd->c_short->str_u.str_useful; if (sawampersand) { curspat = Nullspat; if (leftstab) str_nset(stab_val(leftstab),retstr->str_ptr, tmps - retstr->str_ptr); if (amperstab) str_sset(stab_val(amperstab),cmd->c_short); if (rightstab) str_nset(stab_val(rightstab), tmps + cmd->c_short->str_cur, retstr->str_cur - (tmps - retstr->str_ptr) - cmd->c_short->str_cur); } match = !(cmdflags & CF_FIRSTNEG); retstr = &str_yes; goto flipmaybe; } else hint = tmps; } else { if (cmdflags & CF_NESURE) { ++cmd->c_short->str_u.str_useful; match = cmdflags & CF_FIRSTNEG; retstr = &str_no; goto flipmaybe; } } if (--cmd->c_short->str_u.str_useful < 0) { cmdflags &= ~(CF_OPTIMIZE|CF_ONCE); 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); newsp = -2; switch (cmd->c_slen) { case O_EQ: if (dowarn) { if ((!retstr->str_nok && !looks_like_number(retstr))) warn("Possible use of == on string value"); } match = (str_gnum(retstr) == cmd->c_short->str_u.str_nval); break; case O_NE: match = (str_gnum(retstr) != cmd->c_short->str_u.str_nval); break; case O_LT: match = (str_gnum(retstr) < cmd->c_short->str_u.str_nval); break; case O_LE: match = (str_gnum(retstr) <= cmd->c_short->str_u.str_nval); break; case O_GT: match = (str_gnum(retstr) > cmd->c_short->str_u.str_nval); break; case O_GE: match = (str_gnum(retstr) >= cmd->c_short->str_u.str_nval); break; } if (match) { if (cmdflags & CF_EQSURE) { retstr = &str_yes; goto flipmaybe; } } else if (cmdflags & CF_NESURE) { 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 (!stab_io(last_in_stab)) stab_io(last_in_stab) = stio_new(); goto dogets; case CFT_GETS: /* really a while () */ last_in_stab = cmd->c_stab; dogets: fp = stab_io(last_in_stab)->ifp; retstr = stab_val(defstab); newsp = -2; keepgoing: if (fp && str_gets(retstr, fp, 0)) { if (*retstr->str_ptr == '0' && retstr->str_cur == 1) match = FALSE; else match = TRUE; stab_io(last_in_stab)->lines++; } else if (stab_io(last_in_stab)->flags & IOF_ARGV) { if (!fp) goto doeval; /* first time through */ fp = nextargv(last_in_stab); if (fp) goto keepgoing; (void)do_close(last_in_stab,FALSE); stab_io(last_in_stab)->flags |= IOF_START; retstr = &str_undef; match = FALSE; } else { retstr = &str_undef; match = FALSE; } goto flipmaybe; case CFT_EVAL: break; case CFT_UNFLIP: while (tmps_max > tmps_base) /* clean up after last eval */ str_free(tmps_list[tmps_max--]); newsp = eval(cmd->c_expr,gimme && (cmdflags & CF_TERM),sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; match = str_true(retstr); if (cmd->c_expr->arg_type == O_FLIP) /* undid itself? */ cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd); goto maybe; case CFT_CHOP: retstr = stab_val(cmd->c_stab); newsp = -2; match = (retstr->str_cur != 0); tmps = str_get(retstr); tmps += retstr->str_cur - match; str_nset(&str_chop,tmps,match); *tmps = '\0'; retstr->str_nok = 0; retstr->str_cur = tmps - retstr->str_ptr; retstr = &str_chop; goto flipmaybe; case CFT_ARRAY: match = cmd->c_short->str_u.str_useful; /* just to get register */ if (match < 0) { /* first time through here? */ ar = stab_array(cmd->c_expr[1].arg_ptr.arg_stab); aryoptsave = savestack->ary_fill; savesptr(&stab_val(cmd->c_stab)); savelong(&cmd->c_short->str_u.str_useful); } else { ar = stab_xarray(cmd->c_expr[1].arg_ptr.arg_stab); if (cmd->c_type != C_WHILE && savestack->ary_fill > firstsave) restorelist(firstsave); } if (match >= ar->ary_fill) { /* we're in LAST, probably */ retstr = &str_undef; cmd->c_short->str_u.str_useful = -1; /* actually redundant */ match = FALSE; } else { match++; retstr = stab_val(cmd->c_stab) = ar->ary_array[match]; cmd->c_short->str_u.str_useful = match; match = TRUE; } newsp = -2; goto maybe; } /* we have tried to make this normal case as abnormal as possible */ doeval: if (gimme == G_ARRAY) { lastretstr = Nullstr; lastspbase = sp; lastsize = newsp - sp; } else lastretstr = retstr; while (tmps_max > tmps_base) /* clean up after last eval */ str_free(tmps_list[tmps_max--]); newsp = eval(cmd->c_expr,gimme && (cmdflags & CF_TERM),sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; if (newsp > sp && retstr) match = str_true(retstr); else match = FALSE; goto maybe; /* if flipflop was true, flop it */ flipmaybe: if (match && cmdflags & CF_FLIP) { while (tmps_max > tmps_base) /* clean up after last eval */ str_free(tmps_list[tmps_max--]); if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */ newsp = eval(cmd->c_expr,G_SCALAR,sp);/*let eval undo it*/ cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd); } else { newsp = eval(cmd->c_expr,G_SCALAR,sp);/* let eval do it */ if (cmd->c_expr->arg_type == O_FLOP) /* still toggled? */ cmdflags = copyopt(cmd,cmd->c_expr[4].arg_ptr.arg_cmd); } } else if (cmdflags & CF_FLIP) { if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */ match = TRUE; /* force on */ } } /* at this point, match says whether our expression was true */ maybe: if (cmdflags & CF_INVERT) match = !match; if (!match) goto next_cmd; } #ifdef TAINT tainted = 0; /* modifier doesn't affect regular expression */ #endif /* now to do the actual command, if any */ switch (cmd->c_type) { case C_NULL: fatal("panic: cmd_exec"); case C_EXPR: /* evaluated for side effects */ if (cmd->ucmd.acmd.ac_expr) { /* more to do? */ if (gimme == G_ARRAY) { lastretstr = Nullstr; lastspbase = sp; lastsize = newsp - sp; } else lastretstr = retstr; while (tmps_max > tmps_base) /* clean up after last eval */ str_free(tmps_list[tmps_max--]); newsp = eval(cmd->ucmd.acmd.ac_expr,gimme && (cmdflags&CF_TERM),sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; } break; case C_NSWITCH: match = (int)str_gnum(STAB_STR(cmd->c_stab)); goto doswitch; case C_CSWITCH: match = *(str_get(STAB_STR(cmd->c_stab))) & 255; doswitch: match -= cmd->ucmd.scmd.sc_offset; if (match < 0) match = 0; else if (match > cmd->ucmd.scmd.sc_max) match = cmd->c_slen; cmd = cmd->ucmd.scmd.sc_next[match]; goto tail_recursion_entry; case C_NEXT: cmd = cmd->ucmd.ccmd.cc_alt; goto tail_recursion_entry; case C_ELSIF: fatal("panic: ELSIF"); case C_IF: oldspat = curspat; oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif retstr = &str_yes; newsp = -2; if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING if (debug) { debname[dlevel] = 't'; debdelim[dlevel] = '_'; if (++dlevel >= dlmax) grow_dlevel(); } #endif newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; } curspat = oldspat; if (savestack->ary_fill > oldsave) restorelist(oldsave); #ifdef DEBUGGING dlevel = olddlevel; #endif cmd = cmd->ucmd.ccmd.cc_alt; goto tail_recursion_entry; case C_ELSE: oldspat = curspat; oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif retstr = &str_undef; newsp = -2; if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING if (debug) { debname[dlevel] = 'e'; debdelim[dlevel] = '_'; if (++dlevel >= dlmax) grow_dlevel(); } #endif newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; } curspat = oldspat; if (savestack->ary_fill > oldsave) restorelist(oldsave); #ifdef DEBUGGING dlevel = olddlevel; #endif break; case C_BLOCK: case C_WHILE: if (!(cmdflags & CF_ONCE)) { /* first time through here? */ cmdflags |= CF_ONCE; if (++loop_ptr >= loop_max) { loop_max += 128; Renew(loop_stack, loop_max, struct loop); } loop_stack[loop_ptr].loop_label = cmd->c_label; loop_stack[loop_ptr].loop_sp = sp; #ifdef DEBUGGING if (debug & 4) { deb("(Pushing label #%d %s)\n", loop_ptr, cmd->c_label ? cmd->c_label : ""); } #endif } #ifdef JMPCLOBBER cmdparm = cmd; #endif if (match = setjmp(loop_stack[loop_ptr].loop_env)) { st = stack->ary_array; /* possibly reallocated */ #ifdef JMPCLOBBER cmd = cmdparm; cmdflags = cmd->c_flags|CF_ONCE; go_to = goto_targ; #endif if (savestack->ary_fill > oldsave) restorelist(oldsave); switch (match) { default: fatal("longjmp returned bad value (%d)",match); case O_LAST: if (lastretstr) { retstr = lastretstr; newsp = -2; } else { newsp = sp + lastsize; retstr = st[newsp]; } curspat = oldspat; goto next_cmd; case O_NEXT: #ifdef JMPCLOBBER newsp = -2; retstr = &str_undef; #endif goto next_iter; case O_REDO: #ifdef DEBUGGING dlevel = olddlevel; #endif #ifdef JMPCLOBBER newsp = -2; retstr = &str_undef; #endif goto doit; } } oldspat = curspat; oldsave = savestack->ary_fill; #ifdef DEBUGGING olddlevel = dlevel; #endif doit: if (cmd->ucmd.ccmd.cc_true) { #ifdef DEBUGGING if (debug) { debname[dlevel] = 't'; debdelim[dlevel] = '_'; if (++dlevel >= dlmax) grow_dlevel(); } #endif newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme,sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; } /* actually, this spot is rarely reached anymore since the above * cmd_exec() returns through longjmp(). Hooray for structure. */ next_iter: #ifdef DEBUGGING dlevel = olddlevel; #endif if (cmd->ucmd.ccmd.cc_alt) { #ifdef DEBUGGING if (debug) { debname[dlevel] = 'a'; debdelim[dlevel] = '_'; if (++dlevel >= dlmax) grow_dlevel(); } #endif newsp = cmd_exec(cmd->ucmd.ccmd.cc_alt,gimme,sp); st = stack->ary_array; /* possibly reallocated */ retstr = st[newsp]; } finish_while: curspat = oldspat; if (savestack->ary_fill > oldsave) { if (cmdflags & CF_TERM) { for (match = sp + 1; match <= newsp; match++) st[match] = str_static(st[match]); retstr = st[newsp]; } restorelist(oldsave); } #ifdef DEBUGGING dlevel = olddlevel - 1; #endif if (cmd->c_type != C_BLOCK) goto until_loop; /* go back and evaluate conditional again */ } if (cmdflags & CF_LOOP) { cmdflags |= CF_COND; /* now test the condition */ #ifdef DEBUGGING dlevel = entdlevel; #endif goto until_loop; } next_cmd: if (cmdflags & CF_ONCE) { #ifdef DEBUGGING if (debug & 4) { tmps = loop_stack[loop_ptr].loop_label; deb("(Popping label #%d %s)\n",loop_ptr, tmps ? tmps : ""); } #endif loop_ptr--; if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY && savestack->ary_fill > aryoptsave) restorelist(aryoptsave); } cmd = cmd->c_next; goto tail_recursion_entry; } #ifdef DEBUGGING # ifndef VARARGS /*VARARGS1*/ deb(pat,a1,a2,a3,a4,a5,a6,a7,a8) char *pat; { register int i; fprintf(stderr,"%-4ld",(long)line); for (i=0; ic_flags &= CF_ONCE|CF_COND|CF_LOOP; cmd->c_flags |= which->c_flags; cmd->c_short = which->c_short; cmd->c_slen = which->c_slen; cmd->c_stab = which->c_stab; return cmd->c_flags; } ARRAY * saveary(stab) STAB *stab; { register STR *str; str = Str_new(10,0); str->str_state = SS_SARY; str->str_u.str_stab = stab; if (str->str_ptr) { Safefree(str->str_ptr); str->str_len = 0; } str->str_ptr = (char*)stab_array(stab); (void)apush(savestack,str); /* save array ptr */ stab_xarray(stab) = Null(ARRAY*); return stab_xarray(aadd(stab)); } HASH * savehash(stab) STAB *stab; { register STR *str; str = Str_new(11,0); str->str_state = SS_SHASH; str->str_u.str_stab = stab; if (str->str_ptr) { Safefree(str->str_ptr); str->str_len = 0; } str->str_ptr = (char*)stab_hash(stab); (void)apush(savestack,str); /* save hash ptr */ stab_xhash(stab) = Null(HASH*); return stab_xhash(hadd(stab)); } void saveitem(item) register STR *item; { register STR *str; (void)apush(savestack,item); /* remember the pointer */ str = Str_new(12,0); str_sset(str,item); (void)apush(savestack,str); /* remember the value */ } void saveint(intp) int *intp; { register STR *str; str = Str_new(13,0); str->str_state = SS_SINT; str->str_u.str_useful = (long)*intp; /* remember value */ if (str->str_ptr) { Safefree(str->str_ptr); str->str_len = 0; } str->str_ptr = (char*)intp; /* remember pointer */ (void)apush(savestack,str); } void savelong(longp) long *longp; { register STR *str; str = Str_new(14,0); str->str_state = SS_SLONG; str->str_u.str_useful = *longp; /* remember value */ if (str->str_ptr) { Safefree(str->str_ptr); str->str_len = 0; } str->str_ptr = (char*)longp; /* remember pointer */ (void)apush(savestack,str); } void savesptr(sptr) STR **sptr; { register STR *str; str = Str_new(15,0); str->str_state = SS_SSTRP; str->str_magic = *sptr; /* remember value */ if (str->str_ptr) { Safefree(str->str_ptr); str->str_len = 0; } str->str_ptr = (char*)sptr; /* remember pointer */ (void)apush(savestack,str); } void savenostab(stab) STAB *stab; { register STR *str; str = Str_new(16,0); str->str_state = SS_SNSTAB; str->str_magic = (STR*)stab; /* remember which stab to free */ (void)apush(savestack,str); } void savehptr(hptr) HASH **hptr; { register STR *str; str = Str_new(17,0); str->str_state = SS_SHPTR; str->str_u.str_hash = *hptr; /* remember value */ if (str->str_ptr) { Safefree(str->str_ptr); str->str_len = 0; } str->str_ptr = (char*)hptr; /* remember pointer */ (void)apush(savestack,str); } void savelist(sarg,maxsarg) register STR **sarg; int maxsarg; { register STR *str; register int i; for (i = 1; i <= maxsarg; i++) { (void)apush(savestack,sarg[i]); /* remember the pointer */ str = Str_new(18,0); str_sset(str,sarg[i]); (void)apush(savestack,str); /* remember the value */ sarg[i]->str_u.str_useful = -1; } } void restorelist(base) int base; { register STR *str; register STR *value; register STAB *stab; if (base < -1) fatal("panic: corrupt saved stack index"); while (savestack->ary_fill > base) { value = apop(savestack); switch (value->str_state) { case SS_NORM: /* normal string */ case SS_INCR: str = apop(savestack); str_replace(str,value); STABSET(str); break; case SS_SARY: /* array reference */ stab = value->str_u.str_stab; afree(stab_xarray(stab)); stab_xarray(stab) = (ARRAY*)value->str_ptr; value->str_ptr = Nullch; str_free(value); break; case SS_SHASH: /* hash reference */ stab = value->str_u.str_stab; (void)hfree(stab_xhash(stab)); stab_xhash(stab) = (HASH*)value->str_ptr; value->str_ptr = Nullch; str_free(value); break; case SS_SINT: /* int reference */ *((int*)value->str_ptr) = (int)value->str_u.str_useful; value->str_ptr = Nullch; str_free(value); break; case SS_SLONG: /* long reference */ *((long*)value->str_ptr) = value->str_u.str_useful; value->str_ptr = Nullch; str_free(value); break; case SS_SSTRP: /* STR* reference */ *((STR**)value->str_ptr) = value->str_magic; value->str_magic = Nullstr; value->str_ptr = Nullch; str_free(value); break; case SS_SHPTR: /* HASH* reference */ *((HASH**)value->str_ptr) = value->str_u.str_hash; value->str_ptr = Nullch; str_free(value); break; case SS_SNSTAB: stab = (STAB*)value->str_magic; value->str_magic = Nullstr; (void)stab_clear(stab); str_free(value); break; default: fatal("panic: restorelist inconsistency"); } } } #ifdef DEBUGGING void grow_dlevel() { dlmax += 128; Renew(debname, dlmax, char); Renew(debdelim, dlmax, char); } #endif case SS_SHPTR: /* HASH* reference */ perl/dolist.c 644 473 0 60331 4747105037 6521 /* $Header: dolist.c,v 3.0.1.5 90/02/28 17:09:44 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: dolist.c,v $ * Revision 3.0.1.5 90/02/28 17:09:44 lwall * patch9: split now can split into more than 10000 elements * patch9: @_ clobbered by ($foo,$bar) = split * patch9: sped up pack and unpack * patch9: unpack of single item now works in a scalar context * patch9: slices ignored value of $[ * patch9: grep now returns number of items matched in scalar context * patch9: grep iterations no longer in the regexp context of previous iteration * * Revision 3.0.1.4 89/12/21 19:58:46 lwall * patch7: grep(1,@array) didn't work * patch7: /$pat/; //; wrongly freed runtime pattern twice * * Revision 3.0.1.3 89/11/17 15:14:45 lwall * patch5: grep() occasionally loses arguments or dumps core * * Revision 3.0.1.2 89/11/11 04:28:17 lwall * patch2: non-existent slice values are now undefined rather than null * * Revision 3.0.1.1 89/10/26 23:11:51 lwall * patch1: split in a subroutine wrongly freed referenced arguments * patch1: reverse didn't work * * Revision 3.0 89/10/18 15:11:02 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" int do_match(str,arg,gimme,arglast) STR *str; register ARG *arg; int gimme; int *arglast; { register STR **st = stack->ary_array; register SPAT *spat = arg[2].arg_ptr.arg_spat; register char *t; register int sp = arglast[0] + 1; STR *srchstr = st[sp]; register char *s = str_get(st[sp]); char *strend = s + st[sp]->str_cur; STR *tmpstr; if (!spat) { if (gimme == G_ARRAY) return --sp; str_set(str,Yes); STABSET(str); st[sp] = str; return sp; } if (!s) fatal("panic: do_match"); if (spat->spat_flags & SPAT_USED) { #ifdef DEBUGGING if (debug & 8) deb("2.SPAT USED\n"); #endif if (gimme == G_ARRAY) return --sp; str_set(str,No); STABSET(str); st[sp] = str; return sp; } --sp; if (spat->spat_runtime) { nointrp = "|)"; sp = eval(spat->spat_runtime,G_SCALAR,sp); st = stack->ary_array; t = str_get(tmpstr = st[sp--]); nointrp = ""; #ifdef DEBUGGING if (debug & 8) deb("2.SPAT /%s/\n",t); #endif if (spat->spat_regexp) regfree(spat->spat_regexp); spat->spat_regexp = regcomp(t,t+tmpstr->str_cur, spat->spat_flags & SPAT_FOLD,1); if (!*spat->spat_regexp->precomp && lastspat) spat = lastspat; if (spat->spat_flags & SPAT_KEEP) { if (spat->spat_runtime) arg_free(spat->spat_runtime); /* it won't change, so */ spat->spat_runtime = Nullarg; /* no point compiling again */ } if (!spat->spat_regexp->nparens) gimme = G_SCALAR; /* accidental array context? */ if (regexec(spat->spat_regexp, s, strend, s, 0, srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr, gimme == G_ARRAY)) { if (spat->spat_regexp->subbase) curspat = spat; lastspat = spat; goto gotcha; } else { if (gimme == G_ARRAY) return sp; str_sset(str,&str_no); STABSET(str); st[++sp] = str; return sp; } } else { #ifdef DEBUGGING if (debug & 8) { char ch; if (spat->spat_flags & SPAT_ONCE) ch = '?'; else ch = '/'; deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch); } #endif if (!*spat->spat_regexp->precomp && lastspat) spat = lastspat; t = s; if (hint) { if (hint < s || hint > strend) fatal("panic: hint in do_match"); s = hint; hint = Nullch; if (spat->spat_regexp->regback >= 0) { s -= spat->spat_regexp->regback; if (s < t) s = t; } else s = t; } else if (spat->spat_short) { if (spat->spat_flags & SPAT_SCANFIRST) { if (srchstr->str_pok & SP_STUDIED) { if (screamfirst[spat->spat_short->str_rare] < 0) goto nope; else if (!(s = screaminstr(srchstr,spat->spat_short))) goto nope; else if (spat->spat_flags & SPAT_ALL) goto yup; } #ifndef lint else if (!(s = fbminstr((unsigned char*)s, (unsigned char*)strend, spat->spat_short))) goto nope; #endif else if (spat->spat_flags & SPAT_ALL) goto yup; if (s && spat->spat_regexp->regback >= 0) { ++spat->spat_short->str_u.str_useful; s -= spat->spat_regexp->regback; if (s < t) s = t; } else s = t; } else if (!multiline && (*spat->spat_short->str_ptr != *s || bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) )) goto nope; if (--spat->spat_short->str_u.str_useful < 0) { str_free(spat->spat_short); spat->spat_short = Nullstr; /* opt is being useless */ } } if (!spat->spat_regexp->nparens) gimme = G_SCALAR; /* accidental array context? */ if (regexec(spat->spat_regexp, s, strend, t, 0, srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr, gimme == G_ARRAY)) { if (spat->spat_regexp->subbase) curspat = spat; lastspat = spat; if (spat->spat_flags & SPAT_ONCE) spat->spat_flags |= SPAT_USED; goto gotcha; } else { if (gimme == G_ARRAY) return sp; str_sset(str,&str_no); STABSET(str); st[++sp] = str; return sp; } } /*NOTREACHED*/ gotcha: if (gimme == G_ARRAY) { int iters, i, len; iters = spat->spat_regexp->nparens; if (sp + iters >= stack->ary_max) { astore(stack,sp + iters, Nullstr); st = stack->ary_array; /* possibly realloced */ } for (i = 1; i <= iters; i++) { st[++sp] = str_static(&str_no); if (s = spat->spat_regexp->startp[i]) { len = spat->spat_regexp->endp[i] - s; if (len > 0) str_nset(st[sp],s,len); } } return sp; } else { str_sset(str,&str_yes); STABSET(str); st[++sp] = str; return sp; } yup: ++spat->spat_short->str_u.str_useful; lastspat = spat; if (spat->spat_flags & SPAT_ONCE) spat->spat_flags |= SPAT_USED; if (sawampersand) { char *tmps; tmps = spat->spat_regexp->subbase = nsavestr(t,strend-t); tmps = spat->spat_regexp->startp[0] = tmps + (s - t); spat->spat_regexp->endp[0] = tmps + spat->spat_short->str_cur; curspat = spat; } str_sset(str,&str_yes); STABSET(str); st[++sp] = str; return sp; nope: ++spat->spat_short->str_u.str_useful; if (gimme == G_ARRAY) return sp; str_sset(str,&str_no); STABSET(str); st[++sp] = str; return sp; } int do_split(str,spat,limit,gimme,arglast) STR *str; register SPAT *spat; register int limit; int gimme; int *arglast; { register ARRAY *ary = stack; STR **st = ary->ary_array; register int sp = arglast[0] + 1; register char *s = str_get(st[sp]); char *strend = s + st[sp--]->str_cur; register STR *dstr; register char *m; int iters = 0; int maxiters = (strend - s) + 10; int i; char *orig; int origlimit = limit; int realarray = 0; if (!spat || !s) fatal("panic: do_split"); else if (spat->spat_runtime) { nointrp = "|)"; sp = eval(spat->spat_runtime,G_SCALAR,sp); st = stack->ary_array; m = str_get(dstr = st[sp--]); nointrp = ""; if (!dstr->str_cur || (*m == ' ' && dstr->str_cur == 1)) { str_set(dstr,"\\s+"); m = dstr->str_ptr; spat->spat_flags |= SPAT_SKIPWHITE; } if (spat->spat_regexp) regfree(spat->spat_regexp); spat->spat_regexp = regcomp(m,m+dstr->str_cur, spat->spat_flags & SPAT_FOLD,1); if (spat->spat_flags & SPAT_KEEP || (spat->spat_runtime->arg_type == O_ITEM && (spat->spat_runtime[1].arg_type & A_MASK) == A_SINGLE) ) { arg_free(spat->spat_runtime); /* it won't change, so */ spat->spat_runtime = Nullarg; /* no point compiling again */ } } #ifdef DEBUGGING if (debug & 8) { deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); } #endif ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab); if (ary && (gimme != G_ARRAY || (spat->spat_flags & SPAT_ONCE))) { realarray = 1; if (!(ary->ary_flags & ARF_REAL)) { ary->ary_flags |= ARF_REAL; for (i = ary->ary_fill; i >= 0; i--) ary->ary_array[i] = Nullstr; /* don't free mere refs */ } ary->ary_fill = -1; sp = -1; /* temporarily switch stacks */ } else ary = stack; orig = s; if (spat->spat_flags & SPAT_SKIPWHITE) { while (isspace(*s)) s++; } if (!limit) limit = maxiters + 2; if (spat->spat_short) { i = spat->spat_short->str_cur; if (i == 1) { i = *spat->spat_short->str_ptr; while (--limit) { for (m = s; m < strend && *m != i; m++) ; if (m >= strend) break; if (realarray) dstr = Str_new(30,m-s); else dstr = str_static(&str_undef); str_nset(dstr,s,m-s); (void)astore(ary, ++sp, dstr); s = m + 1; } } else { #ifndef lint while (s < strend && --limit && (m=fbminstr((unsigned char*)s, (unsigned char*)strend, spat->spat_short)) ) #endif { if (realarray) dstr = Str_new(31,m-s); else dstr = str_static(&str_undef); str_nset(dstr,s,m-s); (void)astore(ary, ++sp, dstr); s = m + i; } } } else { maxiters += (strend - s) * spat->spat_regexp->nparens; while (s < strend && --limit && regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) { if (spat->spat_regexp->subbase && spat->spat_regexp->subbase != orig) { m = s; s = orig; orig = spat->spat_regexp->subbase; s = orig + (m - s); strend = s + (strend - m); } m = spat->spat_regexp->startp[0]; if (realarray) dstr = Str_new(32,m-s); else dstr = str_static(&str_undef); str_nset(dstr,s,m-s); (void)astore(ary, ++sp, dstr); if (spat->spat_regexp->nparens) { for (i = 1; i <= spat->spat_regexp->nparens; i++) { s = spat->spat_regexp->startp[i]; m = spat->spat_regexp->endp[i]; if (realarray) dstr = Str_new(33,m-s); else dstr = str_static(&str_undef); str_nset(dstr,s,m-s); (void)astore(ary, ++sp, dstr); } } s = spat->spat_regexp->endp[0]; } } if (realarray) iters = sp + 1; else iters = sp - arglast[0]; if (iters > maxiters) fatal("Split loop"); if (s < strend || origlimit) { /* keep field after final delim? */ if (realarray) dstr = Str_new(34,strend-s); else dstr = str_static(&str_undef); str_nset(dstr,s,strend-s); (void)astore(ary, ++sp, dstr); iters++; } else { #ifndef I286 while (iters > 0 && ary->ary_array[sp]->str_cur == 0) iters--,sp--; #else char *zaps; int zapb; if (iters > 0) { zaps = str_get(afetch(ary,sp,FALSE)); zapb = (int) *zaps; } while (iters > 0 && (!zapb)) { iters--,sp--; if (iters > 0) { zaps = str_get(afetch(ary,iters-1,FALSE)); zapb = (int) *zaps; } } #endif } if (realarray) { ary->ary_fill = sp; if (gimme == G_ARRAY) { sp++; astore(stack, arglast[0] + 1 + sp, Nullstr); Copy(ary->ary_array, stack->ary_array + arglast[0] + 1, sp, STR*); return arglast[0] + sp; } } else { if (gimme == G_ARRAY) return sp; } sp = arglast[0] + 1; str_numset(str,(double)iters); STABSET(str); st[sp] = str; return sp; } int do_unpack(str,gimme,arglast) STR *str; int gimme; int *arglast; { STR **st = stack->ary_array; register int sp = arglast[0] + 1; register char *pat = str_get(st[sp++]); register char *s = str_get(st[sp]); char *strend = s + st[sp--]->str_cur; register char *patend = pat + st[sp]->str_cur; int datumtype; register int len; /* These must not be in registers: */ char achar; short ashort; int aint; long along; unsigned char auchar; unsigned short aushort; unsigned int auint; unsigned long aulong; char *aptr; if (gimme != G_ARRAY) { /* arrange to do first one only */ patend = pat+1; if (*pat == 'a' || *pat == 'A') { while (isdigit(*patend)) patend++; } } sp--; while (pat < patend) { datumtype = *pat++; if (isdigit(*pat)) { len = *pat++ - '0'; while (isdigit(*pat)) len = (len * 10) + (*pat++ - '0'); } else len = 1; switch(datumtype) { default: break; case 'x': s += len; break; case 'A': case 'a': if (s + len > strend) len = strend - s; str = Str_new(35,len); str_nset(str,s,len); s += len; if (datumtype == 'A') { aptr = s; /* borrow register */ s = str->str_ptr + len - 1; while (s >= str->str_ptr && (!*s || isspace(*s))) s--; *++s = '\0'; str->str_cur = s - str->str_ptr; s = aptr; /* unborrow register */ } (void)astore(stack, ++sp, str_2static(str)); break; case 'c': while (len-- > 0) { if (s + sizeof(char) > strend) achar = 0; else { bcopy(s,(char*)&achar,sizeof(char)); s += sizeof(char); } str = Str_new(36,0); aint = achar; if (aint >= 128) /* fake up signed chars */ aint -= 256; str_numset(str,(double)aint); (void)astore(stack, ++sp, str_2static(str)); } break; case 'C': while (len-- > 0) { if (s + sizeof(unsigned char) > strend) auchar = 0; else { bcopy(s,(char*)&auchar,sizeof(unsigned char)); s += sizeof(unsigned char); } str = Str_new(37,0); auint = auchar; /* some can't cast uchar to double */ str_numset(str,(double)auint); (void)astore(stack, ++sp, str_2static(str)); } break; case 's': while (len-- > 0) { if (s + sizeof(short) > strend) ashort = 0; else { bcopy(s,(char*)&ashort,sizeof(short)); s += sizeof(short); } str = Str_new(38,0); str_numset(str,(double)ashort); (void)astore(stack, ++sp, str_2static(str)); } break; case 'n': case 'S': while (len-- > 0) { if (s + sizeof(unsigned short) > strend) aushort = 0; else { bcopy(s,(char*)&aushort,sizeof(unsigned short)); s += sizeof(unsigned short); } str = Str_new(39,0); #ifdef NTOHS if (datumtype == 'n') aushort = ntohs(aushort); #endif str_numset(str,(double)aushort); (void)astore(stack, ++sp, str_2static(str)); } break; case 'i': while (len-- > 0) { if (s + sizeof(int) > strend) aint = 0; else { bcopy(s,(char*)&aint,sizeof(int)); s += sizeof(int); } str = Str_new(40,0); str_numset(str,(double)aint); (void)astore(stack, ++sp, str_2static(str)); } break; case 'I': while (len-- > 0) { if (s + sizeof(unsigned int) > strend) auint = 0; else { bcopy(s,(char*)&auint,sizeof(unsigned int)); s += sizeof(unsigned int); } str = Str_new(41,0); str_numset(str,(double)auint); (void)astore(stack, ++sp, str_2static(str)); } break; case 'l': while (len-- > 0) { if (s + sizeof(long) > strend) along = 0; else { bcopy(s,(char*)&along,sizeof(long)); s += sizeof(long); } str = Str_new(42,0); str_numset(str,(double)along); (void)astore(stack, ++sp, str_2static(str)); } break; case 'N': case 'L': while (len-- > 0) { if (s + sizeof(unsigned long) > strend) aulong = 0; else { bcopy(s,(char*)&aulong,sizeof(unsigned long)); s += sizeof(unsigned long); } str = Str_new(43,0); #ifdef NTOHL if (datumtype == 'N') aulong = ntohl(aulong); #endif str_numset(str,(double)aulong); (void)astore(stack, ++sp, str_2static(str)); } break; case 'p': while (len-- > 0) { if (s + sizeof(char*) > strend) aptr = 0; else { bcopy(s,(char*)&aptr,sizeof(char*)); s += sizeof(char*); } str = Str_new(44,0); if (aptr) str_set(str,aptr); (void)astore(stack, ++sp, str_2static(str)); } break; } } return sp; } int do_slice(stab,numarray,lval,gimme,arglast) register STAB *stab; int numarray; int lval; int gimme; int *arglast; { register STR **st = stack->ary_array; register int sp = arglast[1]; register int max = arglast[2]; register char *tmps; register int len; register int magic = 0; if (lval && !numarray) { if (stab == envstab) magic = 'E'; else if (stab == sigstab) magic = 'S'; #ifdef SOME_DBM else if (stab_hash(stab)->tbl_dbm) magic = 'D'; #endif /* SOME_DBM */ } if (gimme == G_ARRAY) { if (numarray) { while (sp < max) { if (st[++sp]) { st[sp-1] = afetch(stab_array(stab), ((int)str_gnum(st[sp])) - arybase, lval); } else st[sp-1] = &str_undef; } } else { while (sp < max) { if (st[++sp]) { tmps = str_get(st[sp]); len = st[sp]->str_cur; st[sp-1] = hfetch(stab_hash(stab),tmps,len, lval); if (magic) str_magic(st[sp-1],stab,magic,tmps,len); } else st[sp-1] = &str_undef; } } sp--; } else { if (numarray) { if (st[max]) st[sp] = afetch(stab_array(stab), ((int)str_gnum(st[max])) - arybase, lval); else st[sp] = &str_undef; } else { if (st[max]) { tmps = str_get(st[max]); len = st[max]->str_cur; st[sp] = hfetch(stab_hash(stab),tmps,len, lval); if (magic) str_magic(st[sp],stab,magic,tmps,len); } else st[sp] = &str_undef; } } return sp; } int do_grep(arg,str,gimme,arglast) register ARG *arg; STR *str; int gimme; int *arglast; { STR **st = stack->ary_array; register int dst = arglast[1]; register int src = dst + 1; register int sp = arglast[2]; register int i = sp - arglast[1]; int oldsave = savestack->ary_fill; SPAT *oldspat = curspat; savesptr(&stab_val(defstab)); if ((arg[1].arg_type & A_MASK) != A_EXPR) { arg[1].arg_type &= A_MASK; dehoist(arg,1); arg[1].arg_type |= A_DONT; } arg = arg[1].arg_ptr.arg_arg; while (i-- > 0) { stab_val(defstab) = st[src]; (void)eval(arg,G_SCALAR,sp); st = stack->ary_array; if (str_true(st[sp+1])) st[dst++] = st[src]; src++; curspat = oldspat; } restorelist(oldsave); if (gimme != G_ARRAY) { str_numset(str,(double)(dst - arglast[1])); STABSET(str); st[arglast[0]+1] = str; return arglast[0]+1; } return arglast[0] + (dst - arglast[1]); } int do_reverse(str,gimme,arglast) STR *str; int gimme; int *arglast; { STR **st = stack->ary_array; register STR **up = &st[arglast[1]]; register STR **down = &st[arglast[2]]; register int i = arglast[2] - arglast[1]; if (gimme != G_ARRAY) { str_sset(str,&str_undef); STABSET(str); st[arglast[0]+1] = str; return arglast[0]+1; } while (i-- > 0) { *up++ = *down; if (i-- > 0) *down-- = *up; } i = arglast[2] - arglast[1]; Copy(down+1,up,i/2,STR*); return arglast[2] - 1; } static CMD *sortcmd; static STAB *firststab = Nullstab; static STAB *secondstab = Nullstab; int do_sort(str,stab,gimme,arglast) STR *str; STAB *stab; int gimme; int *arglast; { STR **st = stack->ary_array; int sp = arglast[1]; register STR **up; register int max = arglast[2] - sp; register int i; int sortcmp(); int sortsub(); STR *oldfirst; STR *oldsecond; ARRAY *oldstack; static ARRAY *sortstack = Null(ARRAY*); if (gimme != G_ARRAY) { str_sset(str,&str_undef); STABSET(str); st[sp] = str; return sp; } up = &st[sp]; for (i = 0; i < max; i++) { if ((*up = up[1]) && !(*up)->str_pok) (void)str_2ptr(*up); up++; } sp--; if (max > 1) { if (stab_sub(stab) && (sortcmd = stab_sub(stab)->cmd)) { int oldtmps_base = tmps_base; if (!sortstack) { sortstack = anew(Nullstab); sortstack->ary_flags = 0; } oldstack = stack; stack = sortstack; tmps_base = tmps_max; if (!firststab) { firststab = stabent("a",TRUE); secondstab = stabent("b",TRUE); } oldfirst = stab_val(firststab); oldsecond = stab_val(secondstab); #ifndef lint qsort((char*)(st+sp+1),max,sizeof(STR*),sortsub); #else qsort(Nullch,max,sizeof(STR*),sortsub); #endif stab_val(firststab) = oldfirst; stab_val(secondstab) = oldsecond; tmps_base = oldtmps_base; stack = oldstack; } #ifndef lint else qsort((char*)(st+sp+1),max,sizeof(STR*),sortcmp); #endif } up = &st[arglast[1]]; while (max > 0 && !*up) max--,up--; return sp+max; } int sortsub(str1,str2) STR **str1; STR **str2; { if (!*str1) return -1; if (!*str2) return 1; stab_val(firststab) = *str1; stab_val(secondstab) = *str2; cmd_exec(sortcmd,G_SCALAR,-1); return (int)str_gnum(*stack->ary_array); } sortcmp(strp1,strp2) STR **strp1; STR **strp2; { register STR *str1 = *strp1; register STR *str2 = *strp2; int retval; if (!str1) return -1; if (!str2) return 1; if (str1->str_cur < str2->str_cur) { if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur)) return retval; else return -1; } else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur)) return retval; else if (str1->str_cur == str2->str_cur) return 0; else return 1; } int do_range(gimme,arglast) int gimme; int *arglast; { STR **st = stack->ary_array; register int sp = arglast[0]; register int i = (int)str_gnum(st[sp+1]); register ARRAY *ary = stack; register STR *str; int max = (int)str_gnum(st[sp+2]); if (gimme != G_ARRAY) fatal("panic: do_range"); while (i <= max) { (void)astore(ary, ++sp, str = str_static(&str_no)); str_numset(str,(double)i++); } return sp; } int do_tms(str,gimme,arglast) STR *str; int gimme; int *arglast; { STR **st = stack->ary_array; register int sp = arglast[0]; if (gimme != G_ARRAY) { str_sset(str,&str_undef); STABSET(str); st[++sp] = str; return sp; } (void)times(×buf); #ifndef HZ #define HZ 60 #endif #ifndef lint (void)astore(stack,++sp, str_2static(str_nmake(((double)timesbuf.tms_utime)/HZ))); (void)astore(stack,++sp, str_2static(str_nmake(((double)timesbuf.tms_stime)/HZ))); (void)astore(stack,++sp, str_2static(str_nmake(((double)timesbuf.tms_cutime)/HZ))); (void)astore(stack,++sp, str_2static(str_nmake(((double)timesbuf.tms_cstime)/HZ))); #else (void)astore(stack,++sp, str_2static(str_nmake(0.0))); #endif return sp; } int do_time(str,tmbuf,gimme,arglast) STR *str; struct tm *tmbuf; int gimme; int *arglast; { register ARRAY *ary = stack; STR **st = ary->ary_array; register int sp = arglast[0]; if (!tmbuf || gimme != G_ARRAY) { str_sset(str,&str_undef); STABSET(str); st[++sp] = str; return sp; } (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_sec))); (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_min))); (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_hour))); (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_mday))); (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_mon))); (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_year))); (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_wday))); (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_yday))); (void)astore(ary,++sp,str_2static(str_nmake((double)tmbuf->tm_isdst))); return sp; } int do_kv(str,hash,kv,gimme,arglast) STR *str; HASH *hash; int kv; int gimme; int *arglast; { register ARRAY *ary = stack; STR **st = ary->ary_array; register int sp = arglast[0]; int i; register HENT *entry; char *tmps; STR *tmpstr; int dokeys = (kv == O_KEYS || kv == O_HASH); int dovalues = (kv == O_VALUES || kv == O_HASH); if (gimme != G_ARRAY) { str_sset(str,&str_undef); STABSET(str); st[++sp] = str; return sp; } (void)hiterinit(hash); while (entry = hiternext(hash)) { if (dokeys) { tmps = hiterkey(entry,&i); (void)astore(ary,++sp,str_2static(str_make(tmps,i))); } if (dovalues) { tmpstr = Str_new(45,0); #ifdef DEBUGGING if (debug & 8192) { sprintf(buf,"%d%%%d=%d\n",entry->hent_hash, hash->tbl_max+1,entry->hent_hash & hash->tbl_max); str_set(tmpstr,buf); } else #endif str_sset(tmpstr,hiterval(hash,entry)); (void)astore(ary,++sp,str_2static(tmpstr)); } } return sp; } int do_each(str,hash,gimme,arglast) STR *str; HASH *hash; int gimme; int *arglast; { STR **st = stack->ary_array; register int sp = arglast[0]; static STR *mystrk = Nullstr; HENT *entry = hiternext(hash); int i; char *tmps; if (mystrk) { str_free(mystrk); mystrk = Nullstr; } if (entry) { if (gimme == G_ARRAY) { tmps = hiterkey(entry, &i); st[++sp] = mystrk = str_make(tmps,i); } st[++sp] = str; str_sset(str,hiterval(hash,entry)); STABSET(str); return sp; } else return sp; } ast) STR *str; HASH *hash; int gimme; int *arglast; { STR **st = stack->ary_array; register int sp = arglast[0]; static STR *mystrk = Nullstr; HENT *entry = hiternext(hash); int i; char *tmps; if (mystrk) { str_free(mystrk); mystrk = Nullstr; } if (entry)perl/util.c 644 473 0 63270 4747105045 6204 /* $Header: util.c,v 3.0.1.4 90/03/01 10:26:48 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: util.c,v $ * Revision 3.0.1.4 90/03/01 10:26:48 lwall * patch9: fbminstr() called instr() rather than ninstr() * patch9: nested evals clobbered their longjmp environment * patch9: piped opens returned undefined rather than 0 in child * patch9: the x operator is now up to 10 times faster * * Revision 3.0.1.3 89/12/21 20:27:41 lwall * patch7: errno may now be a macro with an lvalue * * Revision 3.0.1.2 89/11/17 15:46:35 lwall * patch5: BZERO separate from BCOPY now * patch5: byteorder now is a hex value * * Revision 3.0.1.1 89/11/11 05:06:13 lwall * patch2: made dup2 a little better * * Revision 3.0 89/10/18 15:32:43 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" #include #ifdef I_VFORK # include #endif #ifdef I_VARARGS # include #endif #define FLUSH static char nomem[] = "Out of memory!\n"; /* paranoid version of malloc */ #ifdef DEBUGGING static int an = 0; #endif /* NOTE: Do not call the next three routines directly. Use the macros * in handy.h, so that we can easily redefine everything to do tracking of * allocated hunks back to the original New to track down any memory leaks. */ char * safemalloc(size) MEM_SIZE size; { char *ptr; char *malloc(); ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ #ifdef DEBUGGING # ifndef I286 if (debug & 128) fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size); # else if (debug & 128) fprintf(stderr,"0x%lx: (%05d) malloc %d bytes\n",ptr,an++,size); # endif #endif if (ptr != Nullch) return ptr; else { fputs(nomem,stdout) FLUSH; exit(1); } /*NOTREACHED*/ #ifdef lint return ptr; #endif } /* paranoid version of realloc */ char * saferealloc(where,size) char *where; MEM_SIZE 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 # ifndef I286 if (debug & 128) { fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++); fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size); } # else if (debug & 128) { fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++); fprintf(stderr,"0x%lx: (%05d) realloc %d bytes\n",ptr,an++,size); } # endif #endif if (ptr != Nullch) return ptr; else { fputs(nomem,stdout) FLUSH; exit(1); } /*NOTREACHED*/ #ifdef lint return ptr; #endif } /* safe version of free */ void safefree(where) char *where; { #ifdef DEBUGGING # ifndef I286 if (debug & 128) fprintf(stderr,"0x%x: (%05d) free\n",where,an++); # else if (debug & 128) fprintf(stderr,"0x%lx: (%05d) free\n",where,an++); # endif #endif if (where) { free(where); } } #ifdef LEAKTEST #define ALIGN sizeof(long) char * safexmalloc(x,size) int x; MEM_SIZE size; { register char *where; where = safemalloc(size + ALIGN); xcount[x]++; where[0] = x % 100; where[1] = x / 100; return where + ALIGN; } char * safexrealloc(where,size) char *where; MEM_SIZE size; { return saferealloc(where - ALIGN, size + ALIGN) + ALIGN; } void safexfree(where) char *where; { int x; if (!where) return; where -= ALIGN; x = where[0] + 100 * where[1]; xcount[x]--; safefree(where); } xstat() { register int i; for (i = 0; i < MAXXCOUNT; i++) { if (xcount[i] != lastxcount[i]) { fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); lastxcount[i] = xcount[i]; } } } #endif /* LEAKTEST */ /* copy a string up to some (non-backslashed) delimiter, if any */ char * cpytill(to,from,fromend,delim,retlen) register char *to, *from; register char *fromend; register int delim; int *retlen; { char *origto = to; for (; from < fromend; from++,to++) { if (*from == '\\') { if (from[1] == delim) from++; else if (from[1] == '\\') *to++ = *from++; } else if (*from == delim) break; *to = *from; } *to = '\0'; *retlen = to - origto; return from; } /* return ptr to little string in big string, NULL if not found */ /* This routine was donated by Corey Satten. */ char * instr(big, little) register char *big; register char *little; { register char *s, *x; register int first; if (!little) return big; 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; } /* same as instr but allow embedded nulls */ char * ninstr(big, bigend, little, lend) register char *big; register char *bigend; char *little; char *lend; { register char *s, *x; register int first = *little; register char *littleend = lend; if (!first && little > littleend) return big; bigend -= littleend - little++; while (big <= bigend) { if (*big++ != first) continue; for (x=big,s=little; s < littleend; /**/ ) { if (*s++ != *x++) { s--; break; } } if (s >= littleend) return big-1; } return Nullch; } /* reverse of the above--find last substring */ char * rninstr(big, bigend, little, lend) register char *big; char *bigend; char *little; char *lend; { register char *bigbeg; register char *s, *x; register int first = *little; register char *littleend = lend; if (!first && little > littleend) return bigend; bigbeg = big; big = bigend - (littleend - little++); while (big >= bigbeg) { if (*big-- != first) continue; for (x=big+2,s=little; s < littleend; /**/ ) { if (*s++ != *x++) { s--; break; } } if (s >= littleend) return big+1; } return Nullch; } unsigned char fold[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', 91, 92, 93, 94, 95, 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 }; static unsigned char freq[] = { 1, 2, 84, 151, 154, 155, 156, 157, 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 }; void fbmcompile(str, iflag) STR *str; int iflag; { register unsigned char *s; register unsigned char *table; register int i; register int len = str->str_cur; int rarest = 0; int frequency = 256; str_grow(str,len+258); #ifndef lint table = (unsigned char*)(str->str_ptr + len + 1); #else table = Null(unsigned char*); #endif s = table - 2; for (i = 0; i < 256; i++) { table[i] = len; } i = 0; #ifndef lint while (s >= (unsigned char*)(str->str_ptr)) #endif { if (table[*s] == len) { #ifndef pdp11 if (iflag) table[*s] = table[fold[*s]] = i; #else if (iflag) { int j; j = fold[*s]; table[j] = i; table[*s] = i; } #endif /* pdp11 */ else table[*s] = i; } s--,i++; } str->str_pok |= SP_FBM; /* deep magic */ #ifndef lint s = (unsigned char*)(str->str_ptr); /* deeper magic */ #else s = Null(unsigned char*); #endif if (iflag) { register int tmp, foldtmp; str->str_pok |= SP_CASEFOLD; for (i = 0; i < len; i++) { tmp=freq[s[i]]; foldtmp=freq[fold[s[i]]]; if (tmp < frequency && foldtmp < frequency) { rarest = i; /* choose most frequent among the two */ frequency = (tmp > foldtmp) ? tmp : foldtmp; } } } else { for (i = 0; i < len; i++) { if (freq[s[i]] < frequency) { rarest = i; frequency = freq[s[i]]; } } } str->str_rare = s[rarest]; str->str_state = rarest; #ifdef DEBUGGING if (debug & 512) fprintf(stderr,"rarest char %c at %d\n",str->str_rare, str->str_state); #endif } char * fbminstr(big, bigend, littlestr) unsigned char *big; register unsigned char *bigend; STR *littlestr; { register unsigned char *s; register int tmp; register int littlelen; register unsigned char *little; register unsigned char *table; register unsigned char *olds; register unsigned char *oldlittle; #ifndef lint if (!(littlestr->str_pok & SP_FBM)) return ninstr((char*)big,(char*)bigend, littlestr->str_ptr, littlestr->str_ptr + littlestr->str_cur); #endif littlelen = littlestr->str_cur; #ifndef lint if (littlestr->str_pok & SP_TAIL && !multiline) { /* tail anchored? */ little = (unsigned char*)littlestr->str_ptr; if (littlestr->str_pok & SP_CASEFOLD) { /* oops, fake it */ big = bigend - littlelen; /* just start near end */ if (bigend[-1] == '\n' && little[littlelen-1] != '\n') big--; } else { s = bigend - littlelen; if (*s == *little && bcmp(s,little,littlelen)==0) return (char*)s; /* how sweet it is */ else if (bigend[-1] == '\n' && little[littlelen-1] != '\n') { s--; if (*s == *little && bcmp(s,little,littlelen)==0) return (char*)s; } return Nullch; } } table = (unsigned char*)(littlestr->str_ptr + littlelen + 1); #else table = Null(unsigned char*); #endif s = big + --littlelen; oldlittle = little = table - 2; if (littlestr->str_pok & SP_CASEFOLD) { /* case insensitive? */ while (s < bigend) { top1: if (tmp = table[*s]) { s += tmp; } else { tmp = littlelen; /* less expensive than calling strncmp() */ olds = s; while (tmp--) { if (*--s == *--little || fold[*s] == *little) continue; s = olds + 1; /* here we pay the price for failure */ little = oldlittle; if (s < bigend) /* fake up continue to outer loop */ goto top1; return Nullch; } #ifndef lint return (char *)s; #endif } } } else { while (s < bigend) { top2: if (tmp = table[*s]) { s += tmp; } else { tmp = littlelen; /* less expensive than calling strncmp() */ olds = s; while (tmp--) { if (*--s == *--little) continue; s = olds + 1; /* here we pay the price for failure */ little = oldlittle; if (s < bigend) /* fake up continue to outer loop */ goto top2; return Nullch; } #ifndef lint return (char *)s; #endif } } } return Nullch; } char * screaminstr(bigstr, littlestr) STR *bigstr; STR *littlestr; { register unsigned char *s, *x; register unsigned char *big; register int pos; register int previous; register int first; register unsigned char *little; register unsigned char *bigend; register unsigned char *littleend; if ((pos = screamfirst[littlestr->str_rare]) < 0) return Nullch; #ifndef lint little = (unsigned char *)(littlestr->str_ptr); #else little = Null(unsigned char *); #endif littleend = little + littlestr->str_cur; first = *little++; previous = littlestr->str_state; #ifndef lint big = (unsigned char *)(bigstr->str_ptr); #else big = Null(unsigned char*); #endif bigend = big + bigstr->str_cur; big -= previous; while (pos < previous) { #ifndef lint if (!(pos += screamnext[pos])) #endif return Nullch; } if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */ do { if (big[pos] != first && big[pos] != fold[first]) continue; for (x=big+pos+1,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) { s--; break; } } if (s == littleend) #ifndef lint return (char *)(big+pos); #else return Nullch; #endif } while ( #ifndef lint pos += screamnext[pos] /* does this goof up anywhere? */ #else pos += screamnext[0] #endif ); } else { do { if (big[pos] != first) continue; for (x=big+pos+1,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; if (*s++ != *x++) { s--; break; } } if (s == littleend) #ifndef lint return (char *)(big+pos); #else return Nullch; #endif } while ( #ifndef lint pos += screamnext[pos] #else pos += screamnext[0] #endif ); } return Nullch; } /* copy a string to a safe spot */ char * savestr(str) char *str; { register char *newaddr; New(902,newaddr,strlen(str)+1,char); (void)strcpy(newaddr,str); return newaddr; } /* same thing but with a known length */ char * nsavestr(str, len) char *str; register int len; { register char *newaddr; New(903,newaddr,len+1,char); (void)bcopy(str,newaddr,len); /* might not be null terminated */ newaddr[len] = '\0'; /* is now */ return newaddr; } /* grow a static string to at least a certain length */ void growstr(strptr,curlen,newlen) char **strptr; int *curlen; int newlen; { if (newlen > *curlen) { /* need more room? */ if (*curlen) Renew(*strptr,newlen,char); else New(905,*strptr,newlen,char); *curlen = newlen; } } #ifndef VARARGS /*VARARGS1*/ mess(pat,a1,a2,a3,a4) char *pat; long a1, a2, a3, a4; { char *s; s = buf; (void)sprintf(s,pat,a1,a2,a3,a4); s += strlen(s); if (s[-1] != '\n') { if (line) { (void)sprintf(s," at %s line %ld", in_eval?filename:origfilename, (long)line); s += strlen(s); } if (last_in_stab && stab_io(last_in_stab) && stab_io(last_in_stab)->lines ) { (void)sprintf(s,", <%s> line %ld", last_in_stab == argvstab ? "" : stab_name(last_in_stab), (long)stab_io(last_in_stab)->lines); s += strlen(s); } (void)strcpy(s,".\n"); } } /*VARARGS1*/ fatal(pat,a1,a2,a3,a4) char *pat; long a1, a2, a3, a4; { extern FILE *e_fp; extern char *e_tmpname; char *tmps; mess(pat,a1,a2,a3,a4); if (in_eval) { str_set(stab_val(stabent("@",TRUE)),buf); tmps = "_EVAL_"; 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) { in_eval = 0; fatal("Bad label: %s", tmps); } longjmp(loop_stack[loop_ptr].loop_env, 1); } fputs(buf,stderr); (void)fflush(stderr); if (e_fp) (void)UNLINK(e_tmpname); statusvalue >>= 8; exit(errno?errno:(statusvalue?statusvalue:255)); } /*VARARGS1*/ warn(pat,a1,a2,a3,a4) char *pat; long a1, a2, a3, a4; { mess(pat,a1,a2,a3,a4); fputs(buf,stderr); #ifdef LEAKTEST #ifdef DEBUGGING if (debug & 4096) xstat(); #endif #endif (void)fflush(stderr); } #else /*VARARGS0*/ mess(args) va_list args; { char *pat; char *s; #ifdef CHARVSPRINTF char *vsprintf(); #else int vsprintf(); #endif s = buf; #ifdef lint pat = Nullch; #else pat = va_arg(args, char *); #endif (void) vsprintf(s,pat,args); s += strlen(s); if (s[-1] != '\n') { if (line) { (void)sprintf(s," at %s line %ld", in_eval?filename:origfilename, (long)line); s += strlen(s); } if (last_in_stab && stab_io(last_in_stab) && stab_io(last_in_stab)->lines ) { (void)sprintf(s,", <%s> line %ld", last_in_stab == argvstab ? "" : last_in_stab->str_magic->str_ptr, (long)stab_io(last_in_stab)->lines); s += strlen(s); } (void)strcpy(s,".\n"); } } /*VARARGS0*/ fatal(va_alist) va_dcl { va_list args; extern FILE *e_fp; extern char *e_tmpname; char *tmps; #ifndef lint va_start(args); #else args = 0; #endif mess(args); va_end(args); if (in_eval) { str_set(stab_val(stabent("@",TRUE)),buf); tmps = "_EVAL_"; 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) { in_eval = 0; fatal("Bad label: %s", tmps); } longjmp(loop_stack[loop_ptr].loop_env, 1); } fputs(buf,stderr); (void)fflush(stderr); if (e_fp) (void)UNLINK(e_tmpname); statusvalue >>= 8; exit((int)(errno?errno:(statusvalue?statusvalue:255))); } /*VARARGS0*/ warn(va_alist) va_dcl { va_list args; #ifndef lint va_start(args); #else args = 0; #endif mess(args); va_end(args); fputs(buf,stderr); #ifdef LEAKTEST #ifdef DEBUGGING if (debug & 4096) xstat(); #endif #endif (void)fflush(stderr); } #endif static bool firstsetenv = TRUE; extern char **environ; void setenv(nam,val) char *nam, *val; { register int i=envix(nam); /* where does it go? */ if (!val) { while (environ[i]) { environ[i] = environ[i+1]; i++; } return; } if (!environ[i]) { /* does not exist yet */ if (firstsetenv) { /* need we copy environment? */ int j; char **tmpenv; New(901,tmpenv, i+2, char*); firstsetenv = FALSE; for (j=0; j= 0; i++) ; return i ? 0 : -1; } #endif #ifndef MEMCPY #ifndef BCOPY char * bcopy(from,to,len) register char *from; register char *to; register int len; { char *retval = to; while (len--) *to++ = *from++; return retval; } #endif #ifndef BZERO char * bzero(loc,len) register char *loc; register int len; { char *retval = loc; while (len--) *loc++ = 0; return retval; } #endif #endif #ifdef VARARGS #ifndef VPRINTF #ifdef CHARVSPRINTF char * #else int #endif vsprintf(dest, pat, args) char *dest, *pat, *args; { FILE fakebuf; fakebuf._ptr = dest; fakebuf._cnt = 32767; fakebuf._flag = _IOWRT|_IOSTRG; _doprnt(pat, args, &fakebuf); /* what a kludge */ (void)putc('\0', &fakebuf); #ifdef CHARVSPRINTF return(dest); #else return 0; /* perl doesn't use return value */ #endif } #ifdef DEBUGGING int vfprintf(fd, pat, args) FILE *fd; char *pat, *args; { _doprnt(pat, args, fd); return 0; /* wrong, but perl doesn't use the return value */ } #endif #endif /* VPRINTF */ #endif /* VARARGS */ #ifdef MYSWAP #if BYTEORDER != 0x4321 short my_swap(s) short s; { #if (BYTEORDER & 1) == 0 short result; result = ((s & 255) << 8) + ((s >> 8) & 255); return result; #else return s; #endif } long htonl(l) register long l; { union { long result; char c[sizeof(long)]; } u; #if BYTEORDER == 0x1234 u.c[0] = (l >> 24) & 255; u.c[1] = (l >> 16) & 255; u.c[2] = (l >> 8) & 255; u.c[3] = l & 255; return u.result; #else #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) fatal("Unknown BYTEORDER\n"); #else register int o; register int s; for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { u.c[o & 0xf] = (l >> s) & 255; } return u.result; #endif #endif } long ntohl(l) register long l; { union { long l; char c[sizeof(long)]; } u; #if BYTEORDER == 0x1234 u.c[0] = (l >> 24) & 255; u.c[1] = (l >> 16) & 255; u.c[2] = (l >> 8) & 255; u.c[3] = l & 255; return u.l; #else #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) fatal("Unknown BYTEORDER\n"); #else register int o; register int s; u.l = l; l = 0; for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { l |= (u.c[o & 0xf] & 255) << s; } return l; #endif #endif } #endif /* BYTEORDER != 0x4321 */ #endif /* HTONS */ FILE * mypopen(cmd,mode) char *cmd; char *mode; { int p[2]; register int this, that; register int pid; STR *str; int doexec = strNE(cmd,"-"); if (pipe(p) < 0) return Nullfp; this = (*mode == 'w'); that = !this; while ((pid = (doexec?vfork():fork())) < 0) { if (errno != EAGAIN) { close(p[this]); if (!doexec) fatal("Can't fork"); return Nullfp; } sleep(5); } if (pid == 0) { #define THIS that #define THAT this close(p[THAT]); if (p[THIS] != (*mode == 'r')) { dup2(p[THIS], *mode == 'r'); close(p[THIS]); } if (doexec) { #if !defined(FCNTL) || !defined(F_SETFD) int fd; #ifndef NOFILE #define NOFILE 20 #endif for (fd = 3; fd < NOFILE; fd++) close(fd); #endif do_exec(cmd); /* may or may not use the shell */ _exit(1); } if (tmpstab = stabent("$",allstabs)) str_numset(STAB_STR(tmpstab),(double)getpid()); forkprocess = 0; return Nullfp; #undef THIS #undef THAT } close(p[that]); str = afetch(pidstatary,p[this],TRUE); str_numset(str,(double)pid); str->str_cur = 0; forkprocess = pid; return fdopen(p[this], mode); } #ifdef NOTDEF dumpfds(s) char *s; { int fd; struct stat tmpstatbuf; fprintf(stderr,"%s", s); for (fd = 0; fd < 32; fd++) { if (fstat(fd,&tmpstatbuf) >= 0) fprintf(stderr," %d",fd); } fprintf(stderr,"\n"); } #endif #ifndef DUP2 dup2(oldfd,newfd) int oldfd; int newfd; { int fdtmp[10]; int fdx = 0; int fd; close(newfd); while ((fd = dup(oldfd)) != newfd) /* good enough for low fd's */ fdtmp[fdx++] = fd; while (fdx > 0) close(fdtmp[--fdx]); } #endif int mypclose(ptr) FILE *ptr; { register int result; #ifdef VOIDSIG void (*hstat)(), (*istat)(), (*qstat)(); #else int (*hstat)(), (*istat)(), (*qstat)(); #endif int status; STR *str; register int pid; str = afetch(pidstatary,fileno(ptr),TRUE); fclose(ptr); pid = (int)str_gnum(str); if (!pid) return -1; hstat = signal(SIGHUP, SIG_IGN); istat = signal(SIGINT, SIG_IGN); qstat = signal(SIGQUIT, SIG_IGN); #ifdef WAIT4 if (wait4(pid,&status,0,Null(struct rusage *)) < 0) status = -1; #else if (pid < 0) /* already exited? */ status = str->str_cur; else { while ((result = wait(&status)) != pid && result >= 0) pidgone(result,status); if (result < 0) status = -1; } #endif signal(SIGHUP, hstat); signal(SIGINT, istat); signal(SIGQUIT, qstat); str_numset(str,0.0); return(status); } pidgone(pid,status) int pid; int status; { #ifdef WAIT4 return; #else register int count; register STR *str; for (count = pidstatary->ary_fill; count >= 0; --count) { if ((str = afetch(pidstatary,count,FALSE)) && ((int)str->str_u.str_nval) == pid) { str_numset(str, -str->str_u.str_nval); str->str_cur = status; return; } } #endif } #ifndef MEMCMP memcmp(s1,s2,len) register unsigned char *s1; register unsigned char *s2; register int len; { register int tmp; while (len--) { if (tmp = *s1++ - *s2++) return tmp; } return 0; } #endif /* MEMCMP */ void repeatcpy(to,from,len,count) register char *to; register char *from; int len; register int count; { register int todo; register char *frombase = from; if (len == 1) { todo = *from; while (count-- > 0) *to++ = todo; return; } while (count-- > 0) { for (todo = len; todo > 0; todo--) { *to++ = *from++; } from = frombase; } } r int len; { register int tmp; while (len--) { if (tmp = *s1++ - *s2++) return tmp; } return 0; } #endif /* MEMCMP */ void repeatcpy(to,from,len,count) register char *to; register char *from; int len; register int count; { register int todo; register char *frombase = from; if (len == 1) { perl/perly.c 644 473 0 55625 4747105046 6370 char rcsid[] = "$Header: perly.c,v 3.0.1.4 90/02/28 18:06:41 lwall Locked $\nPatch level: ###\n"; /* * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perly.c,v $ * Revision 3.0.1.4 90/02/28 18:06:41 lwall * patch9: perl can now start up other interpreters scripts * patch9: nested evals clobbered their longjmp environment * patch9: eval could mistakenly return undef in array context * * Revision 3.0.1.3 89/12/21 20:15:41 lwall * patch7: ANSI strerror() is now supported * patch7: errno may now be a macro with an lvalue * patch7: allowed setuid scripts to have a space after #! * * Revision 3.0.1.2 89/11/17 15:34:42 lwall * patch5: fixed possible confusion about current effective gid * * Revision 3.0.1.1 89/11/11 04:50:04 lwall * patch2: moved yydebug to where its type didn't matter * * Revision 3.0 89/10/18 15:22:21 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" #include "perly.h" #include "patchlevel.h" #ifdef IAMSUID #ifndef DOSUID #define DOSUID #endif #endif #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef DOSUID #undef DOSUID #endif #endif main(argc,argv,env) register int argc; register char **argv; register char **env; { register STR *str; register char *s; char *index(), *strcpy(), *getenv(); bool dosearch = FALSE; #ifdef DOSUID char *validarg = ""; #endif #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID #undef IAMSUID fatal("suidperl is no longer needed since the kernel can now execute\n\ setuid perl scripts securely.\n"); #endif #endif origargv = argv; origargc = argc; uid = (int)getuid(); euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); if (do_undump) { do_undump = 0; loop_ptr = -1; /* start label stack again */ goto just_doit; } (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL); linestr = Str_new(65,80); str_nset(linestr,"",0); str = str_make("",0); /* first used for -I flags */ curstash = defstash = hnew(0); curstname = str_make("main",4); stab_xhash(stabent("_main",TRUE)) = defstash; incstab = aadd(stabent("INC",TRUE)); incstab->str_pok |= SP_MULTI; for (argc--,argv++; argc; argc--,argv++) { if (argv[0][0] != '-' || !argv[0][1]) break; #ifdef DOSUID if (*validarg) validarg = " PHOOEY "; else validarg = argv[0]; #endif s = argv[0]+1; reswitch: switch (*s) { case 'a': minus_a = TRUE; s++; goto reswitch; case 'd': #ifdef TAINT if (euid != uid || egid != gid) fatal("No -d allowed in setuid scripts"); #endif perldb = TRUE; s++; goto reswitch; case 'D': #ifdef DEBUGGING #ifdef TAINT if (euid != uid || egid != gid) fatal("No -D allowed in setuid scripts"); #endif debug = atoi(s+1); #else warn("Recompile perl with -DDEBUGGING to use -D switch\n"); #endif break; case 'e': #ifdef TAINT if (euid != uid || egid != gid) fatal("No -e allowed in setuid scripts"); #endif if (!e_fp) { e_tmpname = savestr(TMPPATH); (void)mktemp(e_tmpname); e_fp = fopen(e_tmpname,"w"); } if (argv[1]) fputs(argv[1],e_fp); (void)putc('\n', e_fp); argc--,argv++; break; case 'i': inplace = savestr(s+1); argvoutstab = stabent("ARGVOUT",TRUE); break; case 'I': #ifdef TAINT if (euid != uid || egid != gid) fatal("No -I allowed in setuid scripts"); #endif str_cat(str,"-"); str_cat(str,s); str_cat(str," "); if (*++s) { (void)apush(stab_array(incstab),str_make(s,0)); } else { (void)apush(stab_array(incstab),str_make(argv[1],0)); str_cat(str,argv[1]); argc--,argv++; str_cat(str," "); } break; case 'n': minus_n = TRUE; s++; goto reswitch; case 'p': minus_p = TRUE; s++; goto reswitch; case 'P': #ifdef TAINT if (euid != uid || egid != gid) fatal("No -P allowed in setuid scripts"); #endif preprocess = TRUE; s++; goto reswitch; case 's': #ifdef TAINT if (euid != uid || egid != gid) fatal("No -s allowed in setuid scripts"); #endif doswitches = TRUE; s++; goto reswitch; case 'S': dosearch = TRUE; s++; goto reswitch; case 'u': do_undump = TRUE; s++; goto reswitch; case 'U': unsafe = TRUE; s++; goto reswitch; case 'v': fputs(rcsid,stdout); fputs("\nCopyright (c) 1989, Larry Wall\n\n\ Perl may be copied only under the terms of the GNU General Public License,\n\ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); exit(0); case 'w': dowarn = TRUE; s++; goto reswitch; case '-': argc--,argv++; goto switch_end; case 0: break; default: fatal("Unrecognized switch: -%s",s); } } switch_end: if (e_fp) { (void)fclose(e_fp); argc++,argv--; argv[0] = e_tmpname; } #ifndef PRIVLIB #define PRIVLIB "/usr/local/lib/perl" #endif (void)apush(stab_array(incstab),str_make(PRIVLIB,0)); str_set(&str_no,No); str_set(&str_yes,Yes); /* open script */ if (argv[0] == Nullch) argv[0] = "-"; if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) { char *xfound = Nullch, *xfailed = Nullch; int len; bufend = s + strlen(s); while (*s) { s = cpytill(tokenbuf,s,bufend,':',&len); if (*s) s++; if (len) (void)strcat(tokenbuf+len,"/"); (void)strcat(tokenbuf+len,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,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) { xfound = tokenbuf; /* bingo! */ break; } if (!xfailed) xfailed = savestr(tokenbuf); } if (!xfound) fatal("Can't execute %s", xfailed ? xfailed : argv[0] ); if (xfailed) Safefree(xfailed); argv[0] = savestr(xfound); } pidstatary = anew(Nullstab); /* for remembering popen pids, status */ filename = savestr(argv[0]); origfilename = savestr(filename); if (strEQ(filename,"-")) argv[0] = ""; if (preprocess) { str_cat(str,"-I"); str_cat(str,PRIVLIB); (void)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], CPPSTDIN, str_get(str), CPPMINUS); #ifdef IAMSUID /* actually, this is caught earlier */ if (euid != uid && !euid) /* if running suidperl */ #ifdef SETEUID (void)seteuid(uid); /* musn't stay setuid root */ #else #ifdef SETREUID (void)setreuid(-1, uid); #else setuid(uid); #endif #endif #endif /* IAMSUID */ rsfp = mypopen(buf,"r"); } else if (!*argv[0]) rsfp = stdin; else rsfp = fopen(argv[0],"r"); if (rsfp == Nullfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && stat(filename,&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { (void)sprintf(buf, "%s/%s", BIN, "suidperl"); execv(buf, origargv); /* try again */ fatal("Can't do setuid\n"); } #endif #endif fatal("Can't open perl script \"%s\": %s\n", filename, strerror(errno)); } str_free(str); /* free -I directories */ /* do we need to emulate setuid on scripts? */ /* This code is for those BSD systems that have setuid #! scripts disabled * in the kernel because of a security problem. Merely defining DOSUID * in perl will not fix that problem, but if you have disabled setuid * scripts in the kernel, this will attempt to emulate setuid and setgid * on scripts that have those now-otherwise-useless bits set. The setuid * root version must be called suidperl. If regular perl discovers that * it has opened a setuid script, it calls suidperl with the same argv * that it had. If suidperl finds that the script it has just opened * is NOT setuid root, it sets the effective uid back to the uid. We * don't just make perl setuid root because that loses the effective * uid we had before invoking perl, if it was different from the uid. * * DOSUID must be defined in both perl and suidperl, and IAMSUID must * be defined in suidperl only. suidperl must be setuid root. The * Configure script will set this up for you if you want it. * * There is also the possibility of have a script which is running * set-id due to a C wrapper. We want to do the TAINT checks * on these set-id scripts, but don't want to have the overhead of * them in normal perl, and can't use suidperl because it will lose * the effective uid info, so we have an additional non-setuid root * version called taintperl that just does the TAINT checks. */ #ifdef DOSUID if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ fatal("Can't stat script \"%s\"",filename); if (statbuf.st_mode & (S_ISUID|S_ISGID)) { int len; #ifdef IAMSUID #ifndef SETREUID /* On this access check to make sure the directories are readable, * there is actually a small window that the user could use to make * filename point to an accessible directory. So there is a faint * chance that someone could execute a setuid script down in a * non-accessible directory. I don't know what to do about that. * But I don't think it's too important. The manual lies when * it says access() is useful in setuid programs. */ if (access(filename,1)) /* as a double check */ fatal("Permission denied"); #else /* If we can swap euid and uid, then we can determine access rights * with a simple stat of the file, and then compare device and * inode to make sure we did stat() on the same file we opened. * Then we just have to make sure he or she can execute it. */ { struct stat tmpstatbuf; if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid) fatal("Can't swap uid and euid"); /* really paranoid */ if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */ fatal("Permission denied"); if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { (void)fclose(rsfp); if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */ fprintf(rsfp, "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\ (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n", uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino, statbuf.st_dev, statbuf.st_ino, filename, statbuf.st_uid, statbuf.st_gid); (void)mypclose(rsfp); } fatal("Permission denied\n"); } if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid) fatal("Can't reswap uid and euid"); if (!cando(S_IEXEC,FALSE,&statbuf)) /* can real uid exec? */ fatal("Permission denied\n"); } #endif /* SETREUID */ #endif /* IAMSUID */ if ((statbuf.st_mode & S_IFMT) != S_IFREG) fatal("Permission denied"); if ((statbuf.st_mode >> 6) & S_IWRITE) fatal("Setuid/gid script is writable by world"); doswitches = FALSE; /* -s is insecure in suid */ line++; if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch || strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */ fatal("No #! line"); s = tokenbuf+2; if (*s == ' ') s++; while (!isspace(*s)) s++; if (strnNE(s-4,"perl",4)) /* sanity check */ fatal("Not a perl script"); while (*s == ' ' || *s == '\t') s++; /* * #! arg must be what we saw above. They can invoke it by * mentioning suidperl explicitly, but they may not add any strange * arguments beyond what #! says if they do invoke suidperl that way. */ len = strlen(validarg); if (strEQ(validarg," PHOOEY ") || strnNE(s,validarg,len) || !isspace(s[len])) fatal("Args must match #! line"); #ifndef IAMSUID if (euid != uid && (statbuf.st_mode & S_ISUID) && euid == statbuf.st_uid) if (!do_undump) fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif /* IAMSUID */ if (euid) { /* oops, we're not the setuid root perl */ (void)fclose(rsfp); #ifndef IAMSUID (void)sprintf(buf, "%s/%s", BIN, "suidperl"); execv(buf, origargv); /* try again */ #endif fatal("Can't do setuid\n"); } if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) #ifdef SETEGID (void)setegid(statbuf.st_gid); #else #ifdef SETREGID (void)setregid((GIDTYPE)-1,statbuf.st_gid); #else setgid(statbuf.st_gid); #endif #endif if (statbuf.st_mode & S_ISUID) { if (statbuf.st_uid != euid) #ifdef SETEUID (void)seteuid(statbuf.st_uid); /* all that for this */ #else #ifdef SETREUID (void)setreuid((UIDTYPE)-1,statbuf.st_uid); #else setuid(statbuf.st_uid); #endif #endif } else if (uid) /* oops, mustn't run as root */ #ifdef SETEUID (void)seteuid((UIDTYPE)uid); #else #ifdef SETREUID (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid); #else setuid((UIDTYPE)uid); #endif #endif uid = (int)getuid(); euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); if (!cando(S_IEXEC,TRUE,&statbuf)) fatal("Permission denied\n"); /* they can't do this */ } #ifdef IAMSUID else if (preprocess) fatal("-P not allowed for setuid/setgid script\n"); else fatal("Script is not setuid/setgid in suidperl\n"); #else #ifndef TAINT /* we aren't taintperl or suidperl */ /* script has a wrapper--can't run suidperl or we lose euid */ else if (euid != uid || egid != gid) { (void)fclose(rsfp); (void)sprintf(buf, "%s/%s", BIN, "taintperl"); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } #endif /* TAINT */ #endif /* IAMSUID */ #else /* !DOSUID */ #ifndef TAINT /* we aren't taintperl or suidperl */ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) ) if (!do_undump) fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ /* not set-id, must be wrapped */ (void)fclose(rsfp); (void)sprintf(buf, "%s/%s", BIN, "taintperl"); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } #endif /* TAINT */ #endif /* DOSUID */ defstab = stabent("_",TRUE); if (perldb) { debstash = hnew(0); stab_xhash(stabent("_DB",TRUE)) = debstash; curstash = debstash; lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE)))); tmpstab->str_pok |= SP_MULTI; subname = str_make("main",4); DBstab = stabent("DB",TRUE); DBstab->str_pok |= SP_MULTI; DBsub = hadd(tmpstab = stabent("sub",TRUE)); tmpstab->str_pok |= SP_MULTI; DBsingle = stab_val((tmpstab = stabent("single",TRUE))); tmpstab->str_pok |= SP_MULTI; curstash = defstash; } /* init tokener */ bufend = bufptr = str_get(linestr); savestack = anew(Nullstab); /* for saving non-local values */ stack = anew(Nullstab); /* for saving non-local values */ stack->ary_flags = 0; /* not a real array */ /* now parse the script */ error_count = 0; if (yyparse() || error_count) fatal("Execution aborted due to compilation errors.\n"); New(50,loop_stack,128,struct loop); #ifdef DEBUGGING if (debug) { New(51,debname,128,char); New(52,debdelim,128,char); } #endif curstash = defstash; preprocess = FALSE; if (e_fp) { e_fp = Nullfp; (void)UNLINK(e_tmpname); } /* initialize everything that won't change if we undump */ if (sigstab = stabent("SIG",allstabs)) { sigstab->str_pok |= SP_MULTI; (void)hadd(sigstab); } magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':"); amperstab = stabent("&",allstabs); leftstab = stabent("`",allstabs); rightstab = stabent("'",allstabs); sawampersand = (amperstab || leftstab || rightstab); if (tmpstab = stabent(":",allstabs)) str_set(STAB_STR(tmpstab),chopset); /* these aren't necessarily magical */ if (tmpstab = stabent(";",allstabs)) str_set(STAB_STR(tmpstab),"\034"); #ifdef TAINT tainted = 1; #endif if (tmpstab = stabent("0",allstabs)) str_set(STAB_STR(tmpstab),origfilename); #ifdef TAINT tainted = 0; #endif if (tmpstab = stabent("]",allstabs)) str_set(STAB_STR(tmpstab),rcsid); str_nset(stab_val(stabent("\"", TRUE)), " ", 1); stdinstab = stabent("STDIN",TRUE); stdinstab->str_pok |= SP_MULTI; stab_io(stdinstab) = stio_new(); stab_io(stdinstab)->ifp = stdin; tmpstab = stabent("stdin",TRUE); stab_io(tmpstab) = stab_io(stdinstab); tmpstab->str_pok |= SP_MULTI; tmpstab = stabent("STDOUT",TRUE); tmpstab->str_pok |= SP_MULTI; stab_io(tmpstab) = stio_new(); stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout; defoutstab = tmpstab; tmpstab = stabent("stdout",TRUE); stab_io(tmpstab) = stab_io(defoutstab); tmpstab->str_pok |= SP_MULTI; curoutstab = stabent("STDERR",TRUE); curoutstab->str_pok |= SP_MULTI; stab_io(curoutstab) = stio_new(); stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr; tmpstab = stabent("stderr",TRUE); stab_io(tmpstab) = stab_io(curoutstab); tmpstab->str_pok |= SP_MULTI; curoutstab = defoutstab; /* switch back to STDOUT */ statname = Str_new(66,0); /* last filename we did stat on */ perldb = FALSE; /* don't try to instrument evals */ if (dowarn) { stab_check('A','Z'); stab_check('a','z'); } if (do_undump) abort(); just_doit: /* come here if running an undumped a.out */ argc--,argv++; /* skip name of script */ if (doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { if (argv[0][1] == '-') { argc--,argv++; break; } str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0); } } #ifdef TAINT tainted = 1; #endif if (argvstab = stabent("ARGV",allstabs)) { argvstab->str_pok |= SP_MULTI; (void)aadd(argvstab); for (; argc > 0; argc--,argv++) { (void)apush(stab_array(argvstab),str_make(argv[0],0)); } } #ifdef TAINT (void) stabent("ENV",TRUE); /* must test PATH and IFS */ #endif if (envstab = stabent("ENV",allstabs)) { envstab->str_pok |= SP_MULTI; (void)hadd(envstab); for (; *env; env++) { if (!(s = index(*env,'='))) continue; *s++ = '\0'; str = str_make(s--,0); str_magic(str, envstab, 'E', *env, s - *env); (void)hstore(stab_hash(envstab), *env, s - *env, str, 0); *s = '='; } } #ifdef TAINT tainted = 0; #endif if (tmpstab = stabent("$",allstabs)) str_numset(STAB_STR(tmpstab),(double)getpid()); if (setjmp(top_env)) /* sets goto_targ on longjump */ loop_ptr = -1; /* start label stack again */ #ifdef DEBUGGING if (debug & 1024) dump_all(); if (debug) fprintf(stderr,"\nEXECUTING...\n\n"); #endif /* do it */ (void) cmd_exec(main_root,G_SCALAR,-1); if (goto_targ) fatal("Can't find label \"%s\"--aborting",goto_targ); exit(0); /* NOTREACHED */ } magicalize(list) register char *list; { register STAB *stab; char sym[2]; sym[1] = '\0'; while (*sym = *list++) { if (stab = stabent(sym,allstabs)) { stab_flags(stab) = SF_VMAGIC; str_magic(stab_val(stab), stab, 0, Nullch, 0); } } } /* this routine is in perly.c by virtue of being sort of an alternate main() */ int do_eval(str,optype,stash,gimme,arglast) STR *str; int optype; HASH *stash; int gimme; int *arglast; { STR **st = stack->ary_array; int retval; CMD *myroot; ARRAY *ar; int i; char * VOLATILE oldfile = filename; VOLATILE line_t oldline = line; VOLATILE int oldtmps_base = tmps_base; VOLATILE int oldsave = savestack->ary_fill; SPAT * VOLATILE oldspat = curspat; static char *last_eval = Nullch; static CMD *last_root = Nullcmd; VOLATILE int sp = arglast[0]; char *tmps; tmps_base = tmps_max; if (curstash != stash) { (void)savehptr(&curstash); curstash = stash; } str_set(stab_val(stabent("@",TRUE)),""); if (optype != O_DOFILE) { /* normal eval */ filename = "(eval)"; line = 1; str_sset(linestr,str); str_cat(linestr,";"); /* be kind to them */ } else { if (last_root) { Safefree(last_eval); cmd_free(last_root); last_root = Nullcmd; } filename = savestr(str_get(str)); /* can't free this easily */ str_set(linestr,""); rsfp = fopen(filename,"r"); ar = stab_array(incstab); if (!rsfp && *filename != '/') { for (i = 0; i <= ar->ary_fill; i++) { (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename); rsfp = fopen(buf,"r"); if (rsfp) { filename = savestr(buf); break; } } } if (!rsfp) { filename = oldfile; tmps_base = oldtmps_base; if (gimme != G_ARRAY) st[++sp] = &str_undef; return sp; } line = 0; } in_eval++; oldoldbufptr = oldbufptr = bufptr = str_get(linestr); bufend = bufptr + linestr->str_cur; if (++loop_ptr >= loop_max) { loop_max += 128; Renew(loop_stack, loop_max, struct loop); } loop_stack[loop_ptr].loop_label = "_EVAL_"; loop_stack[loop_ptr].loop_sp = sp; #ifdef DEBUGGING if (debug & 4) { deb("(Pushing label #%d _EVAL_)\n", loop_ptr); } #endif if (setjmp(loop_stack[loop_ptr].loop_env)) { retval = 1; last_root = Nullcmd; } else { error_count = 0; if (rsfp) retval = yyparse(); else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){ retval = 0; eval_root = last_root; /* no point in reparsing */ } else if (in_eval == 1) { if (last_root) { Safefree(last_eval); cmd_free(last_root); } last_eval = savestr(bufptr); last_root = Nullcmd; retval = yyparse(); if (!retval) last_root = eval_root; } else retval = yyparse(); } myroot = eval_root; /* in case cmd_exec does another eval! */ if (retval || error_count) { st = stack->ary_array; sp = arglast[0]; if (gimme != G_ARRAY) st[++sp] = &str_undef; last_root = Nullcmd; /* can't free on error, for some reason */ if (rsfp) { fclose(rsfp); rsfp = 0; } } else { sp = cmd_exec(eval_root,gimme,sp); st = stack->ary_array; for (i = arglast[0] + 1; i <= sp; i++) st[i] = str_static(st[i]); /* if we don't save result, free zaps it */ if (in_eval != 1 && myroot != last_root) cmd_free(myroot); } in_eval--; #ifdef DEBUGGING if (debug & 4) { tmps = loop_stack[loop_ptr].loop_label; deb("(Popping label #%d %s)\n",loop_ptr, tmps ? tmps : "" ); } #endif loop_ptr--; filename = oldfile; line = oldline; tmps_base = oldtmps_base; curspat = oldspat; if (savestack->ary_fill > oldsave) /* let them use local() */ restorelist(oldsave); return sp; } /* if we don't save result, free zaps it */ if (in_eval != 1 && myroot != last_root) cmd_free(myperl/lib/perldb.pl 644 473 0 25051 4747105046 7432 package DB; $header = '$Header: perldb.pl,v 3.0.1.1 89/10/26 23:14:02 lwall Locked $'; # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. # # Perl supplies the values for @line and %sub. It effectively inserts # a do DB'DB(); in front of every place that can # have a breakpoint. It also inserts a do 'perldb.pl' before the first line. # # $Log: perldb.pl,v $ # Revision 3.0.1.1 89/10/26 23:14:02 lwall # patch1: RCS expanded an unintended $Header in lib/perldb.pl # # Revision 3.0 89/10/18 15:19:46 lwall # 3.0 baseline # # Revision 2.0 88/06/05 00:09:45 root # Baseline version 2.0. # # open(IN,"/dev/tty"); # so we don't dingle stdin open(OUT,">/dev/tty"); # so we don't dongle stdout select(OUT); $| = 1; # for DB'OUT select(STDOUT); $| = 1; # for real STDOUT $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; print OUT "\nLoading DB from $header\n\n"; sub DB { local($. ,$@, $!, $[, $,, $/, $\); $[ = 0; $, = ""; $/ = "\n"; $\ = ""; ($line) = @_; if ($stop[$line]) { if ($stop eq '1') { $signal |= 1; } else { package main; $DB'signal |= eval $DB'stop[$DB'line]; print DB'OUT $@; $DB'stop[$DB'line] =~ s/;9$//; } } if ($single || $trace || $signal) { print OUT "$sub($line):\t",$line[$line]; for ($i = $line + 1; $i <= $max && $line[$i] == 0; ++$i) { last if $line[$i] =~ /^\s*(}|#|\n)/; print OUT "$sub($i):\t",$line[$i]; } } if ($action[$line]) { package main; eval $DB'action[$DB'line]; print DB'OUT $@; } if ($single || $signal) { if ($pre) { package main; eval $DB'pre; print DB'OUT $@; } print OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; while ((print OUT " DB<", $#hist+1, "> "), $cmd=) { $single = 0; $signal = 0; $cmd eq '' && exit 0; chop($cmd); $cmd =~ /^q$/ && exit 0; $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; ($i) = split(/\s+/,$cmd); eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; $cmd =~ /^h$/ && do { print OUT " T Stack trace. s Single step. n Next, steps over subroutine calls. f Finish current subroutine. c [line] Continue; optionally inserts a one-time-only breakpoint at the specified line. Repeat last n or s. l min+incr List incr+1 lines starting at min. l min-max List lines. l line List line; l List next window. - List previous window. w line List window around line. l subname List subroutine. /pattern/ Search forwards for pattern; final / is optional. ?pattern? Search backwards for pattern. L List breakpoints and actions. S List subroutine names. t Toggle trace mode. b [line] [condition] Set breakpoint; line defaults to the current execution line; condition breaks if it evaluates to true, defaults to \'1\'. b subname [condition] Set breakpoint at first line of subroutine. d [line] Delete breakpoint. D Delete all breakpoints. a [line] command Set an action to be done before the line is executed. Sequence is: check for breakpoint, print line if necessary, do action, prompt user if breakpoint or step, evaluate line. A Delete all actions. V package List all variables and values in package (default main). < command Define command before prompt. > command Define command after prompt. ! number Redo command (default previous command). ! -number Redo number\'th to last command. H -number Display last number commands (default all). q or ^D Quit. p expr Same as \"package main; print DB'OUT expr\". command Execute as a perl statement. "; next; }; $cmd =~ /^t$/ && do { $trace = !$trace; print OUT "Trace = ".($trace?"on":"off")."\n"; next; }; $cmd =~ /^S$/ && do { foreach $subname (sort(keys %sub)) { if ($subname =~ /^main'(.*)/) { print OUT $1,"\n"; } else { print OUT $subname,"\n"; } } next; }; $cmd =~ /^V$/ && do { $cmd = 'V main'; }; $cmd =~ /^V\s*(['A-Za-z_]['\w]*)$/ && do { $packname = $1; do 'dumpvar.pl' unless defined &main'dumpvar; if (defined &main'dumpvar) { &main'dumpvar($packname); } else { print DB'OUT "dumpvar.pl not available.\n"; } next; }; $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do { $subname = $1; $subname = "main'" . $subname unless $subname =~ /'/; $subrange = $sub{$subname}; if ($subrange) { if (eval($subrange) < -$window) { $subrange =~ s/-.*/+/; } $cmd = "l $subrange"; } else { print OUT "Subroutine $1 not found.\n"; next; } }; $cmd =~ /^w\s*(\d*)$/ && do { $incr = $window - 1; $start = $1 if $1; $start -= $preview; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^-$/ && do { $incr = $window - 1; $cmd = 'l ' . ($start-$window*2) . '+'; }; $cmd =~ /^l$/ && do { $incr = $window - 1; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do { $start = $1 if $1; $incr = $2; $incr = $window - 1 unless $incr; $cmd = 'l ' . $start . '-' . ($start + $incr); }; $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { $end = (!$2) ? $max : ($4 ? $4 : $2); $end = $max if $end > $max; $i = $2; $i = $line if $i eq '.'; $i = 1 if $i < 1; for (; $i <= $end; $i++) { print OUT "$i:\t", $line[$i]; last if $signal; } $start = $i; # remember in case they want more $start = $max if $start > $max; next; }; $cmd =~ /^D$/ && do { print OUT "Deleting all breakpoints...\n"; for ($i = 1; $i <= $max ; $i++) { $stop[$i] = 0; } next; }; $cmd =~ /^L$/ && do { for ($i = 1; $i <= $max; $i++) { if ($stop[$i] || $action[$i]) { print OUT "$i:\t", $line[$i]; print OUT " break if (", $stop[$i], ")\n" if $stop[$i]; print OUT " action: ", $action[$i], "\n" if $action[$i]; last if $signal; } } next; }; $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do { $subname = $1; $subname = "main'" . $subname unless $subname =~ /'/; ($i) = split(/-/, $sub{$subname}); if ($i) { ++$i while $line[$i] == 0 && $i < $#line; $stop[$i] = $2 ? $2 : 1; } else { print OUT "Subroutine $1 not found.\n"; } next; }; $cmd =~ /^b\s*(\d*)\s*(.*)/ && do { $i = ($1?$1:$line); if ($line[$i] == 0) { print OUT "Line $i not breakable.\n"; } else { $stop[$i] = $2 ? $2 : 1; } next; }; $cmd =~ /^d\s*(\d+)?/ && do { $i = ($1?$1:$line); $stop[$i] = ''; next; }; $cmd =~ /^A$/ && do { for ($i = 1; $i <= $max ; $i++) { $action[$i] = ''; } next; }; $cmd =~ /^<\s*(.*)/ && do { $pre = do action($1); next; }; $cmd =~ /^>\s*(.*)/ && do { $post = do action($1); next; }; $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do { $i = $1; if ($line[$i] == 0) { print OUT "Line $i may not have an action.\n"; } else { $action[$i] = do action($3); } next; }; $cmd =~ /^n$/ && do { $single = 2; $laststep = $cmd; last; }; $cmd =~ /^s$/ && do { $single = 1; $laststep = $cmd; last; }; $cmd =~ /^c\s*(\d*)\s*$/ && do { $i = $1; if ($i) { if ($line[$i] == 0) { print OUT "Line $i not breakable.\n"; next; } $stop[$i] .= ";9"; # add one-time-only b.p. } for ($i=0; $i <= $#stack; ) { $stack[$i++] &= ~1; } last; }; $cmd =~ /^f$/ && do { $stack[$#stack] |= 2; last; }; $cmd =~ /^T$/ && do { for ($i=0; $i <= $#sub; ) { print OUT $sub[$i++], "\n"; last if $signal; } next; }; $cmd =~ /^\/(.*)$/ && do { $inpat = $1; $inpat =~ s:([^\\])/$:$1:; if ($inpat ne "") { eval '$inpat =~ m'."\n$inpat\n"; if ($@ ne "") { print OUT "$@"; next; } $pat = $inpat; } $end = $start; eval ' for (;;) { ++$start; $start = 1 if ($start > $max); last if ($start == $end); if ($line[$start] =~ m'."\n$pat\n".'i) { print OUT "$start:\t", $line[$start], "\n"; last; } } '; print OUT "/$pat/: not found\n" if ($start == $end); next; }; $cmd =~ /^\?(.*)$/ && do { $inpat = $1; $inpat =~ s:([^\\])\?$:$1:; if ($inpat ne "") { eval '$inpat =~ m'."\n$inpat\n"; if ($@ ne "") { print OUT "$@"; next; } $pat = $inpat; } $end = $start; eval ' for (;;) { --$start; $start = $max if ($start <= 0); last if ($start == $end); if ($line[$start] =~ m'."\n$pat\n".'i) { print OUT "$start:\t", $line[$start], "\n"; last; } } '; print OUT "?$pat?: not found\n" if ($start == $end); next; }; $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { pop(@hist) if length($cmd) > 1; $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); $cmd = $hist[$i] . "\n"; print OUT $cmd; redo; }; $cmd =~ /^!(.+)$/ && do { $pat = "^$1"; pop(@hist) if length($cmd) > 1; for ($i = $#hist; $i; --$i) { last if $hist[$i] =~ $pat; } if (!$i) { print OUT "No such command!\n\n"; next; } $cmd = $hist[$i] . "\n"; print OUT $cmd; redo; }; $cmd =~ /^H\s*(-(\d+))?/ && do { $end = $2?($#hist-$2):0; $hist = 0 if $hist < 0; for ($i=$#hist; $i>$end; $i--) { print OUT "$i: ",$hist[$i],"\n" unless $hist[$i] =~ /^.?$/; }; next; }; $cmd =~ s/^p( .*)?$/print DB'OUT$1/; { package main; eval $DB'cmd; } print OUT $@,"\n"; } if ($post) { package main; eval $DB'post; print DB'OUT $@; } } } sub action { local($action) = @_; while ($action =~ s/\\$//) { print OUT "+ "; $action .= ; } $action; } sub catch { $signal = 1; } sub sub { push(@stack, $single); $single &= 1; $single |= 4 if $#stack == $deep; local(@args) = @_; for (@args) { if (/^Stab/ && length($_) == length($_main{'_main'})) { $_ = sprintf("%s",$_); print "ARG: $_\n"; } else { s/'/\\'/g; s/(.*)/'$1'/ unless /^-?[\d.]+$/; } } push(@sub, $sub . '(' . join(', ', @args) . ') from ' . $line); if (wantarray) { @i = &$sub; } else { $i = &$sub; @i = $i; } --$#sub; $single |= pop(@stack); @i; } $single = 1; # so it stops on first executable statement $max = $#line; @hist = ('?'); $SIG{'INT'} = "DB'catch"; $deep = 100; # warning if stack gets this deep $window = 10; $preview = 3; @stack = (0); @args = @ARGV; for (@args) { s/'/\\'/g; s/(.*)/'$1'/ unless /^-?[\d.]+$/; } push(@sub, 'main(' . join(', ', @args) . ")" ); $sub = 'main'; if (-f '.perldb') { do './.perldb'; } elsif (-f "$ENV{'LOGDIR'}/.perldb") { do "$ENV{'LOGDIR'}/.perldb"; } elsif (-f "$ENV{'HOME'}/.perldb") { do "$ENV{'HOME'}/.perldb"; } 1; n first executable statement $max = $#line; @hist = ('?'); $SIG{'INT'} = "DB'catch"; $deep = 100; # warning if stack gets this deep $window = 10; $preview = 3; @stack = (0); @args = @ARGV; for (@args) { s/'/\\'/g; s/(.*)/'$1'/ unless /^-?[\d.]+$/; } push(@sub, 'main(' . join(', ', @args) . ")" ); $sub = 'main'; if (-f '.perldb') { do './.perldb'; } elsif (-f "$ENV{'LOGDIR'}/.perldb") { do "$ENV{'LOGDIR'}/.perldb"; } elsif (-f "$ENV{'HOME'}/.perldb"perl/lib/validate.pl 644 473 0 7271 4747105047 7740 ;# $Header: validate.pl,v 3.0 89/10/18 15:20:04 lwall Locked $ ;# The validate routine takes a single multiline string consisting of ;# lines containing a filename plus a file test to try on it. (The ;# file test may also be a 'cd', causing subsequent relative filenames ;# to be interpreted relative to that directory.) After the file test ;# you may put '|| die' to make it a fatal error if the file test fails. ;# The default is '|| warn'. The file test may optionally have a ! prepended ;# to test for the opposite condition. If you do a cd and then list some ;# relative filenames, you may want to indent them slightly for readability. ;# If you supply your own "die" or "warn" message, you can use $file to ;# interpolate the filename. ;# Filetests may be bunched: -rwx tests for all of -r, -w and -x. ;# Only the first failed test of the bunch will produce a warning. ;# The routine returns the number of warnings issued. ;# Usage: ;# $warnings += do validate(' ;# /vmunix -e || die ;# /boot -e || die ;# /bin cd ;# csh -ex ;# csh !-ug ;# sh -ex ;# sh !-ug ;# /usr -d || warn "What happened to $file?\n" ;# '); sub validate { local($file,$test,$warnings,$oldwarnings); foreach $check (split(/\n/,$_[0])) { next if $check =~ /^#/; next if $check =~ /^$/; ($file,$test) = split(' ',$check,2); if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { $testlist = $2; @testlist = split(//,$testlist); } else { @testlist = ('Z'); } $oldwarnings = $warnings; foreach $one (@testlist) { $this = $test; $this =~ s/(-\w\b)/$1 \$file/g; $this =~ s/-Z/-$one/; $this .= ' || warn' unless $this =~ /\|\|/; $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/; $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; eval $this; last if $warnings > $oldwarnings; } } $warnings; } sub valmess { local($disposition,$this) = @_; $file = $cwd . '/' . $file unless $file =~ m|^/|; if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { $neg = $1; $tmp = $2; $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); $tmp eq 'R' && ($mess = "$file is not readable by you."); $tmp eq 'W' && ($mess = "$file is not writable by you."); $tmp eq 'X' && ($mess = "$file is not executable by you."); $tmp eq 'O' && ($mess = "$file is not owned by you."); $tmp eq 'e' && ($mess = "$file does not exist."); $tmp eq 'z' && ($mess = "$file does not have zero size."); $tmp eq 's' && ($mess = "$file does not have non-zero size."); $tmp eq 'f' && ($mess = "$file is not a plain file."); $tmp eq 'd' && ($mess = "$file is not a directory."); $tmp eq 'l' && ($mess = "$file is not a symbolic link."); $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); $tmp eq 'S' && ($mess = "$file is not a socket."); $tmp eq 'b' && ($mess = "$file is not a block special file."); $tmp eq 'c' && ($mess = "$file is not a character special file."); $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); $tmp eq 'T' && ($mess = "$file is not a text file."); $tmp eq 'B' && ($mess = "$file is not a binary file."); if ($neg eq '!') { $mess =~ s/ is not / should not be / || $mess =~ s/ does not / should not / || $mess =~ s/ not / /; } print stderr $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; print stderr "Can't do $this.\n"; } if ($disposition eq 'die') { exit 1; } ++$warnings; } 1; bit set."); $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); $tmp eq 'T' && ($mess = "$file is not a text file."); $tmp eq 'B' && ($mess = "$file is not a binary file."); if ($neg eq '!') { $mess =~ s/ is not / should not be / || $mess =~ s/ does not / should not / || $mess =~ s/ not / /perl/lib/termcap.pl 644 473 0 7110 4747105047 7572 ;# $Header: termcap.pl,v 3.0.1.1 90/02/28 17:46:44 lwall Locked $ ;# ;# Usage: ;# do 'ioctl.pl'; ;# ioctl(TTY,$TIOCGETP,$foo); ;# ($ispeed,$ospeed) = unpack('cc',$foo); ;# do 'termcap.pl' || die "Can't get termcap.pl"; ;# &Tgetent('vt100'); # sets $TC{'cm'}, etc. ;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); ;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); ;# sub Tgetent { local($TERM) = @_; local($TERMCAP,$_,$entry,$loop,$field); warn "Tgetent: no ospeed set" unless $ospeed; foreach $key (keys(TC)) { delete $TC{$key}; } $TERM = $ENV{'TERM'} unless $TERM; $TERMCAP = $ENV{'TERMCAP'}; $TERMCAP = '/etc/termcap' unless $TERMCAP; if ($TERMCAP !~ m:^/:) { if (index($TERMCAP,"|$TERM|") < $[) { $TERMCAP = '/etc/termcap'; } } if ($TERMCAP =~ m:^/:) { $entry = ''; do { $loop = " open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\"; while () { next if /^#/; next if /^\t/; if (/\\|$TERM[:\\|]/) { chop; while (chop eq '\\\\') { \$_ .= ; chop; } \$_ .= ':'; last; } } close TERMCAP; \$entry .= \$_; "; eval $loop; } while s/:tc=([^:]+):/:/ && ($TERM = $1); $TERMCAP = $entry; } foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { if ($field =~ /^\w\w$/) { $TC{$field} = 1; } elsif ($field =~ /^(\w\w)#(.*)/) { $TC{$1} = $2 if $TC{$1} eq ''; } elsif ($field =~ /^(\w\w)=(.*)/) { $entry = $1; $_ = $2; s/\\E/\033/g; s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; s/\\n/\n/g; s/\\r/\r/g; s/\\t/\t/g; s/\\b/\b/g; s/\\f/\f/g; s/\\\^/\377/g; s/\^\?/\177/g; s/\^(.)/pack('c',$1 & 31)/eg; s/\\(.)/$1/g; s/\377/^/g; $TC{$entry} = $_ if $TC{$entry} eq ''; } } $TC{'pc'} = "\0" if $TC{'pc'} eq ''; $TC{'bc'} = "\b" if $TC{'bc'} eq ''; } @Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); sub Tputs { local($string,$affcnt,$FH) = @_; local($ms); if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { $ms = $1; $ms *= $affcnt if $2; $string = $3; $decr = $Tputs[$ospeed]; if ($decr > .1) { $ms += $decr / 2; $string .= $TC{'pc'} x ($ms / $decr); } } print $FH $string if $FH; $string; } sub Tgoto { local($string) = shift(@_); local($result) = ''; local($after) = ''; local($code,$tmp) = @_; local(@tmp); @tmp = ($tmp,$code); local($online) = 0; while ($string =~ /^([^%]*)%(.)(.*)/) { $result .= $1; $code = $2; $string = $3; if ($code eq 'd') { $result .= sprintf("%d",shift(@tmp)); } elsif ($code eq '.') { $tmp = shift(@tmp); if ($tmp == 0 || $tmp == 4 || $tmp == 10) { if ($online) { ++$tmp, $after .= $TC{'up'} if $TC{'up'}; } else { ++$tmp, $after .= $TC{'bc'}; } } $result .= sprintf("%c",$tmp); $online = !$online; } elsif ($code eq '+') { $result .= sprintf("%c",shift(@tmp)+ord($string)); $string = substr($string,1,99); $online = !$online; } elsif ($code eq 'r') { ($code,$tmp) = @tmp; @tmp = ($tmp,$code); $online = !$online; } elsif ($code eq '>') { ($code,$tmp,$string) = unpack("CCa99",$string); if ($tmp[$[] > $code) { $tmp[$[] += $tmp; } } elsif ($code eq '2') { $result .= sprintf("%02d",shift(@tmp)); $online = !$online; } elsif ($code eq '3') { $result .= sprintf("%03d",shift(@tmp)); $online = !$online; } elsif ($code eq 'i') { ($code,$tmp) = @tmp; @tmp = ($code+1,$tmp+1); } else { return "OOPS"; } } $result . $string . $after; } 1; $online = !$online; } elsif ($code eq '>') { ($code,$tmp,$string) = unpack("CCa99",$string); if ($tmp[$[] > $code) { $tmp[$[] += $tmp; } } elsif ($code eq '2') { $result .= sprintf("%02d",shift(@tmp)); $online = !$online; } elsif ($code eq '3') { $result .= sprintf("%03d",shift(@tmp)); $online = !$online; } elsif ($code eq 'i') { ($code,$tmp) = @tmp; @tmp = ($code+1,$tmp+1); } elperl/lib/complete.pl 644 473 0 3661 4747105047 7756 ;# ;# @(#)complete.pl 1.0 (sun!waynet) 11/11/88 ;# ;# Author: Wayne Thompson ;# ;# Description: ;# This routine provides word completion. ;# (TAB) attempts word completion. ;# (^D) prints completion list. ;# ;# Diagnostics: ;# Bell when word completion fails. ;# ;# Dependencies: ;# The tty driver is put into raw mode. ;# ;# Bugs: ;# The erase and kill characters are hard coded. ;# ;# Usage: ;# $input = do Complete('prompt_string', @completion_list); ;# sub Complete { local ($prompt) = shift (@_); local ($c, $cmp, $l, $r, $ret, $return, $test); @_cmp_lst = sort @_; local($[) = 0; system 'stty raw -echo'; loop: { print $prompt, $return; while (($c = getc(stdin)) ne "\r") { if ($c eq "\t") { # (TAB) attempt completion @_match = (); foreach $cmp (@_cmp_lst) { push (@_match, $cmp) if $cmp =~ /^$return/; } $test = $_match[0]; $l = length ($test); unless ($#_match == 0) { shift (@_match); foreach $cmp (@_match) { until (substr ($cmp, 0, $l) eq substr ($test, 0, $l)) { $l--; } } print "\007"; } print $test = substr ($test, $r, $l - $r); $r = length ($return .= $test); } elsif ($c eq "\004") { # (^D) completion list print "\r\n"; foreach $cmp (@_cmp_lst) { print "$cmp\r\n" if $cmp =~ /^$return/; } redo loop; } elsif ($c eq "\025" && $r) { # (^U) kill $return = ''; $r = 0; print "\r\n"; redo loop; } # (DEL) || (BS) erase elsif ($c eq "\177" || $c eq "\010") { if($r) { print "\b \b"; chop ($return); $r--; } } elsif ($c =~ /\S/) { # printable char $return .= $c; $r++; print $c; } } } system 'stty -raw echo'; print "\n"; $return; } 1; ; } redo loop; } elsif ($c eq "\025" && $r) { # (^U) kill perl/lib/look.pl 644 473 0 1772 4747105047 7113 ;# Usage: &look(*FILEHANDLE,$key,$dict,$fold) ;# Sets file position in FILEHANDLE to be first line greater than or equal ;# (stringwise) to $key. Pass flags for dictionary order and case folding. sub look { local(*FH,$key,$fold) = @_; local($max,$min,$mid,$_); local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat(FH); $blksize = 8192 unless $blksize; $key =~ s/[^\w\s]//g if $dict; $key =~ y/A-Z/a-z/ if $fold; $max = int($size / $blksize); while ($max - $min > 1) { $mid = int(($max + $min) / 2); seek(FH,$mid * $blksize,0); $_ = if $mid; # probably a partial line $_ = ; chop; s/[^\w\s]//g if $dict; y/A-Z/a-z/ if $fold; if ($_ lt $key) { $min = $mid; } else { $max = $mid; } } $min *= $blksize; seek(FH,$min,0); if $min; while () { chop; s/[^\w\s]//g if $dict; y/A-Z/a-z/ if $fold; last if $_ ge $key; $min = tell(FH); } seek(FH,$min,0); $min; } 1; $size perl/lib/getopt.pl 644 473 0 2005 4747105050 7431 ;# $Header: getopt.pl,v 3.0.1.1 90/02/28 17:41:59 lwall Locked $ ;# Process single-character switches with switch clustering. Pass one argument ;# which is a string containing all switches that take an argument. For each ;# 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); local($[) = 0; while (($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); if (index($argumentative,$first) >= $[) { if ($rest ne '') { shift(@ARGV); } else { shift(@ARGV); $rest = shift(@ARGV); } eval "\$opt_$first = \$rest;"; } else { eval "\$opt_$first = 1;"; if ($rest ne '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); } } } } 1; a side effect. sub Getopt { local($argumentative) = @_; local($_,$first,$rest); local($[) = 0; while (($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); if (index($argumentative,$first) >= $[) { if ($rest ne '') { shift(@ARGV); } else { shift(@ARGV); $rest = shift(@ARGV); } eval "\$opt_$first = \$rest;"; } else { eval "\$opt_$first = 1;"; if ($rest ne '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); } } } }perl/lib/getopts.pl 644 473 0 1606 4747105050 7622 ;# getopts.pl - a better getopt.pl ;# Usage: ;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a ;# # side effect. sub Getopts { local($argumentative) = @_; local(@args,$_,$first,$rest,$errs); local($[) = 0; @args = split( / */, $argumentative ); while(($_ = $ARGV[0]) =~ /^-(.)(.*)/) { ($first,$rest) = ($1,$2); $pos = index($argumentative,$first); if($pos >= $[) { if($args[$pos+1] eq ':') { shift(@ARGV); if($rest eq '') { $rest = shift(@ARGV); } eval "\$opt_$first = \$rest;"; } else { eval "\$opt_$first = 1"; if($rest eq '') { shift(@ARGV); } else { $ARGV[0] = "-$rest"; } } } else { print STDERR "Unknown option: $first\n"; ++$errs; if($rest ne '') { $ARGV[0] = "-$rest"; } else { shift(@ARGV); } } } $errs == 0; } 1; s = index($argumentative,$first); if($pos >= $[) { if($args[$pos+1] eq ':') { shift(@ARGV); if($rest eq '') { perl/lib/stat.pl 644 473 0 1136 4747105051 7107 ;# $Header: stat.pl,v 3.0 89/10/18 15:19:53 lwall Locked $ ;# 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(@_)); } 1; $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_rperl/lib/dumpvar.pl 644 473 0 1102 4747105051 7603 package dumpvar; sub main'dumpvar { ($package) = @_; local(*stab) = eval("*_$package"); while (($key,$val) = each(%stab)) { { local(*entry) = $val; if (defined $entry) { print "\$$key = '$entry'\n"; } if (defined @entry) { print "\@$key = (\n"; foreach $num ($[ .. $#entry) { print " $num\t'",$entry[$num],"'\n"; } print ")\n"; } if ($key ne "_$package" && defined %entry) { print "\%$key = (\n"; foreach $key (sort keys(%entry)) { print " $key\t'",$entry{$key},"'\n"; } print ")\n"; } } } } l(*stab) = eval("*_$package"); while (($key,$val) = each(%stab)) { { local(*entry) = $val; if (defined $entry) { print "\$$key = '$entry'\n"; } if (defined @entry) { print "\@$key = (\n"; foreach $num ($[ .. $#entry) { print " $num\t'",$entry[$num],"'\n"; } print ")\n"; } if ($key ne "_$package" && defined %entry) { print "\%$key = (\n"; foreach $key (sort keys(%entry)) { print " perl/lib/abbrev.pl 644 473 0 1047 4747105051 7376 ;# Usage: ;# %foo = (); ;# &abbrev(*foo,LIST); ;# ... ;# $long = $foo{$short}; package abbrev; sub main'abbrev { local(*domain) = @_; shift(@_); @cmp = @_; local($[) = 0; foreach $name (@_) { @extra = split(//,$name); $abbrev = shift(@extra); $len = 1; foreach $cmp (@cmp) { next if $cmp eq $name; while (substr($cmp,0,$len) eq $abbrev) { $abbrev .= shift(@extra); ++$len; } } $domain{$abbrev} = $name; while ($#extra >= 0) { $abbrev .= shift(@extra); $domain{$abbrev} = $name; } } } 1; ,LIST); ;# ... ;# $long = $foo{$short}; package abbrev; sub main'abbrev { local(*domain) = @_; shift(@_); @cmp = @_; local($[) = 0; foreach $name (@_) { @extra = split(//,$name); $abbrev = shift(@extra); $len = 1; foreach $cmp (@cmp) { next if $cmp eq $name; while (substr($cmp,0,$len) eq $abbrev) { $abbrev .= shift(@extra); ++$len; } } $domain{$abbrev} = $name; while ($#extra >= 0) { $abbrev .= shift(@extra); $dperl/lib/importenv.pl 644 473 0 526 4747105052 10142 ;# $Header: importenv.pl,v 3.0 89/10/18 15:19:39 lwall Locked $ ;# This file, when interpreted, pulls the environment into normal variables. ;# Usage: ;# do 'importenv.pl'; ;# or ;# #include local($tmp,$key) = ''; foreach $key (keys(ENV)) { $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; } eval $tmp; 1; ubstr($cmp,0,$len) eq $abbrev) { $abbrev .= shift(@extra); ++$len; } } $domain{$abbrev} = $name; while ($#extra >= 0) { $abbrev .= shift(@extra); $dperl/hash.c 644 473 0 26526 4747105052 6153 /* $Header: hash.c,v 3.0.1.2 89/12/21 20:03:39 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: hash.c,v $ * Revision 3.0.1.2 89/12/21 20:03:39 lwall * patch7: errno may now be a macro with an lvalue * * Revision 3.0.1.1 89/11/11 04:34:18 lwall * patch2: CX/UX needed to set the key each time in associative iterators * * Revision 3.0 89/10/18 15:18:32 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" STR * hfetch(tb,key,klen,lval) register HASH *tb; char *key; int klen; int lval; { register char *s; register int i; register int hash; register HENT *entry; register int maxi; STR *str; #ifdef SOME_DBM datum dkey,dcontent; #endif if (!tb) return Nullstr; /* The hash function we use on symbols has to be equal to the first * character when taken modulo 128, so that str_reset() can be implemented * efficiently. We throw in the second character and the last character * (times 128) so that long chains of identifiers starting with the * same letter don't have to be strEQ'ed within hfetch(), since it * compares hash values before trying strEQ(). */ if (!tb->tbl_coeffsize) hash = *key + 128 * key[1] + 128 * key[klen-1]; /* assuming klen > 0 */ else { /* use normal coefficients */ if (klen < tb->tbl_coeffsize) maxi = klen; else maxi = tb->tbl_coeffsize; for (s=key, i=0, hash = 0; i < maxi; s++, i++, hash *= 5) { hash += *s * coeff[i]; } } entry = tb->tbl_array[hash & tb->tbl_max]; for (; entry; entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (entry->hent_klen != klen) continue; if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; return entry->hent_val; } #ifdef SOME_DBM if (tb->tbl_dbm) { dkey.dptr = key; dkey.dsize = klen; dcontent = dbm_fetch(tb->tbl_dbm,dkey); if (dcontent.dptr) { /* found one */ str = Str_new(60,dcontent.dsize); str_nset(str,dcontent.dptr,dcontent.dsize); hstore(tb,key,klen,str,hash); /* cache it */ return str; } } #endif if (lval) { /* gonna assign to this, so it better be there */ str = Str_new(61,0); hstore(tb,key,klen,str,hash); return str; } return Nullstr; } bool hstore(tb,key,klen,val,hash) register HASH *tb; char *key; int klen; STR *val; register int hash; { register char *s; register int i; register HENT *entry; register HENT **oentry; register int maxi; if (!tb) return FALSE; if (hash) ; else if (!tb->tbl_coeffsize) hash = *key + 128 * key[1] + 128 * key[klen-1]; else { /* use normal coefficients */ if (klen < tb->tbl_coeffsize) maxi = klen; else maxi = tb->tbl_coeffsize; for (s=key, i=0, hash = 0; i < maxi; s++, i++, hash *= 5) { hash += *s * coeff[i]; } } oentry = &(tb->tbl_array[hash & tb->tbl_max]); i = 1; for (entry = *oentry; entry; i=0, entry = entry->hent_next) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (entry->hent_klen != klen) continue; if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; Safefree(entry->hent_val); entry->hent_val = val; return TRUE; } New(501,entry, 1, HENT); entry->hent_klen = klen; entry->hent_key = nsavestr(key,klen); entry->hent_val = val; entry->hent_hash = hash; entry->hent_next = *oentry; *oentry = entry; /* hdbmstore not necessary here because it's called from stabset() */ if (i) { /* initial entry? */ tb->tbl_fill++; #ifdef SOME_DBM if (tb->tbl_dbm && tb->tbl_max >= DBM_CACHE_MAX) return FALSE; #endif if (tb->tbl_fill > tb->tbl_dosplit) hsplit(tb); } #ifdef SOME_DBM else if (tb->tbl_dbm) { /* is this just a cache for dbm file? */ entry = tb->tbl_array[hash & tb->tbl_max]; oentry = &entry->hent_next; entry = *oentry; while (entry) { /* trim chain down to 1 entry */ *oentry = entry->hent_next; hentfree(entry); /* no doubt they'll want this next. */ entry = *oentry; } } #endif return FALSE; } STR * hdelete(tb,key,klen) register HASH *tb; char *key; int klen; { register char *s; register int i; register int hash; register HENT *entry; register HENT **oentry; STR *str; int maxi; #ifdef SOME_DBM datum dkey; #endif if (!tb) return Nullstr; if (!tb->tbl_coeffsize) hash = *key + 128 * key[1] + 128 * key[klen-1]; else { /* use normal coefficients */ if (klen < tb->tbl_coeffsize) maxi = klen; else maxi = tb->tbl_coeffsize; for (s=key, i=0, hash = 0; i < maxi; s++, i++, hash *= 5) { hash += *s * coeff[i]; } } oentry = &(tb->tbl_array[hash & tb->tbl_max]); entry = *oentry; i = 1; for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) { if (entry->hent_hash != hash) /* strings can't be equal */ continue; if (entry->hent_klen != klen) continue; if (bcmp(entry->hent_key,key,klen)) /* is this it? */ continue; *oentry = entry->hent_next; str = str_static(entry->hent_val); hentfree(entry); if (i) tb->tbl_fill--; #ifdef SOME_DBM do_dbm_delete: if (tb->tbl_dbm) { dkey.dptr = key; dkey.dsize = klen; dbm_delete(tb->tbl_dbm,dkey); } #endif return str; } #ifdef SOME_DBM str = Nullstr; goto do_dbm_delete; #else return Nullstr; #endif } hsplit(tb) HASH *tb; { int oldsize = tb->tbl_max + 1; register int newsize = oldsize * 2; register int i; register HENT **a; register HENT **b; register HENT *entry; register HENT **oentry; a = tb->tbl_array; Renew(a, newsize, HENT*); Zero(&a[oldsize], oldsize, HENT*); /* zero 2nd half*/ tb->tbl_max = --newsize; tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100; tb->tbl_array = a; for (i=0; ihent_hash & newsize) != i) { *oentry = entry->hent_next; entry->hent_next = *b; if (!*b) tb->tbl_fill++; *b = entry; continue; } else oentry = &entry->hent_next; } if (!*a) /* everything moved */ tb->tbl_fill--; } } HASH * hnew(lookat) unsigned int lookat; { register HASH *tb; Newz(502,tb, 1, HASH); if (lookat) { tb->tbl_coeffsize = lookat; tb->tbl_max = 7; /* it's a normal associative array */ tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100; } else { tb->tbl_max = 127; /* it's a symbol table */ tb->tbl_dosplit = 128; /* so never split */ } Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*); tb->tbl_fill = 0; #ifdef SOME_DBM tb->tbl_dbm = 0; #endif (void)hiterinit(tb); /* so each() will start off right */ return tb; } void hentfree(hent) register HENT *hent; { if (!hent) return; str_free(hent->hent_val); Safefree(hent->hent_key); Safefree(hent); } void hclear(tb) register HASH *tb; { register HENT *hent; register HENT *ohent = Null(HENT*); if (!tb) return; (void)hiterinit(tb); while (hent = hiternext(tb)) { /* concise but not very efficient */ hentfree(ohent); ohent = hent; } hentfree(ohent); tb->tbl_fill = 0; #ifndef lint (void)bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*)); #endif } void hfree(tb) register HASH *tb; { register HENT *hent; register HENT *ohent = Null(HENT*); if (!tb) return; (void)hiterinit(tb); while (hent = hiternext(tb)) { hentfree(ohent); ohent = hent; } hentfree(ohent); Safefree(tb->tbl_array); Safefree(tb); } int hiterinit(tb) register HASH *tb; { tb->tbl_riter = -1; tb->tbl_eiter = Null(HENT*); return tb->tbl_fill; } HENT * hiternext(tb) register HASH *tb; { register HENT *entry; #ifdef SOME_DBM datum key; #endif entry = tb->tbl_eiter; #ifdef SOME_DBM if (tb->tbl_dbm) { if (entry) { #ifdef NDBM #ifdef _CX_UX key.dptr = entry->hent_key; key.dsize = entry->hent_klen; key = dbm_nextkey(tb->tbl_dbm, key); #else key = dbm_nextkey(tb->tbl_dbm); #endif /* _CX_UX */ #else key.dptr = entry->hent_key; key.dsize = entry->hent_klen; key = nextkey(key); #endif } else { Newz(504,entry, 1, HENT); tb->tbl_eiter = entry; key = dbm_firstkey(tb->tbl_dbm); } entry->hent_key = key.dptr; entry->hent_klen = key.dsize; if (!key.dptr) { if (entry->hent_val) str_free(entry->hent_val); Safefree(entry); tb->tbl_eiter = Null(HENT*); return Null(HENT*); } return entry; } #endif do { if (entry) entry = entry->hent_next; if (!entry) { tb->tbl_riter++; if (tb->tbl_riter > tb->tbl_max) { tb->tbl_riter = -1; break; } entry = tb->tbl_array[tb->tbl_riter]; } } while (!entry); tb->tbl_eiter = entry; return entry; } char * hiterkey(entry,retlen) register HENT *entry; int *retlen; { *retlen = entry->hent_klen; return entry->hent_key; } STR * hiterval(tb,entry) register HASH *tb; register HENT *entry; { #ifdef SOME_DBM datum key, content; if (tb->tbl_dbm) { key.dptr = entry->hent_key; key.dsize = entry->hent_klen; content = dbm_fetch(tb->tbl_dbm,key); if (!entry->hent_val) entry->hent_val = Str_new(62,0); str_nset(entry->hent_val,content.dptr,content.dsize); } #endif return entry->hent_val; } #ifdef SOME_DBM #if defined(FCNTL) && ! defined(O_CREAT) #include #endif #ifndef O_RDONLY #define O_RDONLY 0 #endif #ifndef O_RDWR #define O_RDWR 2 #endif #ifndef O_CREAT #define O_CREAT 01000 #endif #ifndef NDBM static int dbmrefcnt = 0; #endif bool hdbmopen(tb,fname,mode) register HASH *tb; char *fname; int mode; { if (!tb) return FALSE; #ifndef NDBM if (tb->tbl_dbm) /* never really closed it */ return TRUE; #endif if (tb->tbl_dbm) hdbmclose(tb); hclear(tb); #ifdef NDBM tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode); if (!tb->tbl_dbm) /* oops, just try reading it */ tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode); #else if (dbmrefcnt++) fatal("Old dbm can only open one database"); sprintf(buf,"%s.dir",fname); if (stat(buf, &statbuf) < 0) { if (close(creat(buf,mode)) < 0) return FALSE; sprintf(buf,"%s.pag",fname); if (close(creat(buf,mode)) < 0) return FALSE; } tb->tbl_dbm = dbminit(fname) >= 0; #endif return tb->tbl_dbm != 0; } void hdbmclose(tb) register HASH *tb; { if (tb && tb->tbl_dbm) { #ifdef NDBM dbm_close(tb->tbl_dbm); tb->tbl_dbm = 0; #else /* dbmrefcnt--; */ /* doesn't work, rats */ #endif } else if (dowarn) warn("Close on unopened dbm file"); } bool hdbmstore(tb,key,klen,str) register HASH *tb; char *key; int klen; register STR *str; { datum dkey, dcontent; int error; if (!tb || !tb->tbl_dbm) return FALSE; dkey.dptr = key; dkey.dsize = klen; dcontent.dptr = str_get(str); dcontent.dsize = str->str_cur; error = dbm_store(tb->tbl_dbm, dkey, dcontent, DBM_REPLACE); if (error) { if (errno == EPERM) fatal("No write permission to dbm file"); warn("dbm store returned %d, errno %d, key \"%s\"",error,errno,key); #ifdef NDBM dbm_clearerr(tb->tbl_dbm); #endif } return !error; } #endif /* SOME_DBM */ dkey, dcontent; int error; if (!tb || !tb->tbl_dbm) return FALSE; dkey.dptr = key; dkey.dsize = klen; dcontent.dptr = str_get(str); dcontent.dsiperl/malloc.c 644 473 0 24552 4747105052 6474 /* $Header: malloc.c,v 3.0.1.2 89/11/11 04:36:37 lwall Locked $ * * $Log: malloc.c,v $ * Revision 3.0.1.2 89/11/11 04:36:37 lwall * patch2: malloc pointer corruption check made more portable * * Revision 3.0.1.1 89/10/26 23:15:05 lwall * patch1: some declarations were missing from malloc.c * patch1: sparc machines had alignment problems in malloc.c * * Revision 3.0 89/10/18 15:20:39 lwall * 3.0 baseline * */ #ifndef lint static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; #ifdef DEBUGGING #define RCHECK #endif /* * malloc.c (Caltech) 2/21/82 * Chris Kingsley, kingsley@cit-20. * * This is a very fast storage allocator. It allocates blocks of a small * number of different sizes, and keeps free lists of each size. Blocks that * don't exactly fit are passed up to the next larger size. In this * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long. * This is designed for use in a program that uses vast quantities of memory, * but bombs when it runs out. */ #include "EXTERN.h" #include "perl.h" static findbucket(), morecore(); /* I don't much care whether these are defined in sys/types.h--LAW */ #define u_char unsigned char #define u_int unsigned int #define u_short unsigned short /* * The overhead on a block is at least 4 bytes. When free, this space * contains a pointer to the next free block, and the bottom two bits must * be zero. When in use, the first byte is set to MAGIC, and the second * byte is the size index. The remaining bytes are for alignment. * If range checking is enabled and the size of the block fits * in two bytes, then the top two bytes hold the size of the requested block * plus the range checking words, and the header word MINUS ONE. */ union overhead { union overhead *ov_next; /* when free */ #if defined (mips) || defined (sparc) double strut; /* alignment problems */ #endif struct { u_char ovu_magic; /* magic number */ u_char ovu_index; /* bucket # */ #ifdef RCHECK u_short ovu_size; /* actual block size */ u_int ovu_rmagic; /* range magic number */ #endif } ovu; #define ov_magic ovu.ovu_magic #define ov_index ovu.ovu_index #define ov_size ovu.ovu_size #define ov_rmagic ovu.ovu_rmagic }; #define MAGIC 0xff /* magic # on accounting info */ #define OLDMAGIC 0x7f /* same after a free() */ #define RMAGIC 0x55555555 /* magic # on range info */ #ifdef RCHECK #define RSLOP sizeof (u_int) #else #define RSLOP 0 #endif /* * nextf[i] is the pointer to the next free block of size 2^(i+3). The * smallest allocatable block is 8 bytes. The overhead information * precedes the data area returned to the user. */ #define NBUCKETS 30 static union overhead *nextf[NBUCKETS]; extern char *sbrk(); #ifdef MSTATS /* * nmalloc[i] is the difference between the number of mallocs and frees * for a given block size. */ static u_int nmalloc[NBUCKETS]; #include #endif #ifdef debug #define ASSERT(p) if (!(p)) botch("p"); else static botch(s) char *s; { printf("assertion botched: %s\n", s); abort(); } #else #define ASSERT(p) #endif char * malloc(nbytes) register unsigned nbytes; { register union overhead *p; register int bucket = 0; register unsigned shiftr; /* * Convert amount of memory requested into * closest block size stored in hash buckets * which satisfies request. Account for * space used per block for accounting. */ nbytes += sizeof (union overhead) + RSLOP; nbytes = (nbytes + 3) &~ 3; shiftr = (nbytes - 1) >> 2; /* apart from this loop, this is O(1) */ while (shiftr >>= 1) bucket++; /* * If nothing in hash bucket right now, * request more memory from the system. */ if (nextf[bucket] == NULL) morecore(bucket); if ((p = (union overhead *)nextf[bucket]) == NULL) return (NULL); /* remove from linked list */ #ifdef RCHECK if (*((int*)p) & (sizeof(union overhead) - 1)) #ifndef I286 fprintf(stderr,"Corrupt malloc ptr 0x%x at 0x%x\n",*((int*)p),p); #else fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",*((int*)p),p); #endif #endif nextf[bucket] = p->ov_next; p->ov_magic = MAGIC; p->ov_index= bucket; #ifdef MSTATS nmalloc[bucket]++; #endif #ifdef RCHECK /* * Record allocated size of block and * bound space with magic numbers. */ if (nbytes <= 0x10000) p->ov_size = nbytes - 1; p->ov_rmagic = RMAGIC; *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC; #endif return ((char *)(p + 1)); } /* * Allocate more memory to the indicated bucket. */ static morecore(bucket) register int bucket; { register union overhead *op; register int rnu; /* 2^rnu bytes will be requested */ register int nblks; /* become nblks blocks of the desired size */ register int siz; if (nextf[bucket]) return; /* * Insure memory is allocated * on a page boundary. Should * make getpageize call? */ op = (union overhead *)sbrk(0); #ifndef I286 if ((int)op & 0x3ff) (void)sbrk(1024 - ((int)op & 0x3ff)); #else /* The sbrk(0) call on the I286 always returns the next segment */ #endif #ifndef I286 /* take 2k unless the block is bigger than that */ rnu = (bucket <= 8) ? 11 : bucket + 3; #else /* take 16k unless the block is bigger than that (80286s like large segments!) */ rnu = (bucket <= 11) ? 14 : bucket + 3; #endif nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */ if (rnu < bucket) rnu = bucket; op = (union overhead *)sbrk(1 << rnu); /* no more room! */ if ((int)op == -1) return; /* * Round up to minimum allocation size boundary * and deduct from block count to reflect. */ #ifndef I286 if ((int)op & 7) { op = (union overhead *)(((int)op + 8) &~ 7); nblks--; } #else /* Again, this should always be ok on an 80286 */ #endif /* * Add new memory allocated to that on * free list for this hash bucket. */ nextf[bucket] = op; siz = 1 << (bucket + 3); while (--nblks > 0) { op->ov_next = (union overhead *)((caddr_t)op + siz); op = (union overhead *)((caddr_t)op + siz); } } free(cp) char *cp; { register int size; register union overhead *op; if (cp == NULL) return; op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); #ifdef debug ASSERT(op->ov_magic == MAGIC); /* make sure it was in use */ #else if (op->ov_magic != MAGIC) { warn("%s free() ignored", op->ov_magic == OLDMAGIC ? "Duplicate" : "Bad"); return; /* sanity */ } op->ov_magic = OLDMAGIC; #endif #ifdef RCHECK ASSERT(op->ov_rmagic == RMAGIC); if (op->ov_index <= 13) ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC); #endif ASSERT(op->ov_index < NBUCKETS); size = op->ov_index; op->ov_next = nextf[size]; nextf[size] = op; #ifdef MSTATS nmalloc[size]--; #endif } /* * When a program attempts "storage compaction" as mentioned in the * old malloc man page, it realloc's an already freed block. Usually * this is the last block it freed; occasionally it might be farther * back. We have to search all the free lists for the block in order * to determine its bucket: 1st we make one pass thru the lists * checking only the first block in each; if that fails we search * ``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 reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */ char * realloc(cp, nbytes) char *cp; unsigned nbytes; { register u_int onb; union overhead *op; char *res; register int i; int was_alloced = 0; if (cp == NULL) return (malloc(nbytes)); op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); if (op->ov_magic == MAGIC) { was_alloced++; i = op->ov_index; } else { /* * Already free, doing "compaction". * * Search for the old block of memory on the * free list. First, check the most common * case (last element free'd), then (this failing) * the last ``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, reall_srchlen)) < 0) i = 0; } onb = (1 << (i + 3)) - sizeof (*op) - RSLOP; /* avoid the copy if same size block */ if (was_alloced && nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) { #ifdef RCHECK /* * Record new allocated size of block and * bound space with magic numbers. */ if (op->ov_index <= 13) { /* * Convert amount of memory requested into * closest block size stored in hash buckets * which satisfies request. Account for * space used per block for accounting. */ nbytes += sizeof (union overhead) + RSLOP; nbytes = (nbytes + 3) &~ 3; op->ov_size = nbytes - 1; *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC; } #endif return(cp); } if ((res = malloc(nbytes)) == NULL) return (NULL); if (cp != res) /* common optimization */ (void)bcopy(cp, res, (int)((nbytes < onb) ? nbytes : onb)); if (was_alloced) free(cp); return (res); } /* * Search ``srchlen'' elements of each free list for a block whose * header starts at ``freep''. If srchlen is -1 search the whole list. * Return bucket number, or -1 if not found. */ static findbucket(freep, srchlen) union overhead *freep; int srchlen; { register union overhead *p; register int i, j; for (i = 0; i < NBUCKETS; i++) { j = 0; for (p = nextf[i]; p && j != srchlen; p = p->ov_next) { if (p == freep) return (i); j++; } } return (-1); } #ifdef MSTATS /* * mstats - print out statistics about malloc * * Prints two lines of numbers, one showing the length of the free list * for each size category, the second showing the number of mallocs - * frees for each size category. */ mstats(s) char *s; { register int i, j; register union overhead *p; int totfree = 0, totused = 0; fprintf(stderr, "Memory allocation statistics %s\nfree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) ; fprintf(stderr, " %d", j); totfree += j * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { fprintf(stderr, " %d", nmalloc[i]); totused += nmalloc[i] * (1 << (i + 3)); } fprintf(stderr, "\n\tTotal in use: %d, total free: %d\n", totused, totfree); } #endif #endif /* lint */ = 0; fprintf(stderr, "Memory allocation statistics %s\nfree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j = 0, p = nextf[i]; p; p = p->perl/Changes 644 473 0 17537 4747105053 6362 Changes to perl --------------- Apart from little bug fixes, here are the new features: Perl can now handle binary data correctly and has functions to pack and unpack binary structures into arrays or lists. You can now do arbitrary ioctl functions. You can do i/o with sockets and select. You can now write packages with their own namespace. You can now pass things to subroutines by reference. The debugger now has hooks in the perl parser so it doesn't get confused. The debugger won't interfere with stdin and stdout. New debugger commands: n Single step around subroutine call. l min+incr List incr+1 lines starting at min. l List incr+1 more lines. l subname List subroutine. b subname Set breakpoint at first line of subroutine. S List subroutine names. D Delete all breakpoints. A List line actions. < command Define command before prompt. > command Define command after prompt. ! number Redo command (default previous command). ! -number Redo numberth to last command. h -number Display last number commands (default all). p expr Same as \"print DBout expr\". The rules are more consistent about where parens are needed and where they are not. In particular, unary operators and list operators now behave like functions if they're called like functions. There are some new quoting mechanisms: $foo = q/"'"'"'"'"'"'"/; $foo = qq/"'"''$bar"''/; $foo = q(hi there); $foo = <<'EOF' x 10; Why, it's the old here-is mechanism! EOF You can now work with array slices (note the initial @): @foo[1,2,3]; @foo{'Sun','Mon','Tue','Wed','Thu','Fri','Sat'} = (1,2,3,4,5,6,7); @foo{split} = (1,1,1,1,1,1,1); There's now a range operator that works in array contexts: for (1..15) { ... @foo[3..5] = ('time','for','all'); @foo{'Sun','Mon','Tue','Wed','Thu','Fri','Sat'} = 1..7; You can now reference associative arrays as a whole: %abc = %def; %foo = ('Sun',1,'Mon',2,'Tue',3,'Wed',4,'Thu',5,'Fri',6,'Sat',7); Associative arrays can now be bound to a dbm or ndbm file. Perl automatically caches references to the dbm file for you. An array or associative array can now be assigned to as part of a list, if it's the last thing in the list: ($a,$b,@rest) = split; An array or associative array may now appear in a local() list. local(%assoc); local(@foo) = @_; Array values may now be interpolated into strings: `echo @ARGV`; print "first three = @list[0..2]\n"; print "@ENV{keys(ENV)}"; ($" is used as the delimiter between array elements) Array sizes may be interpolated into strings: print "The last element is $#foo.\n"; Array values may now be returned from subroutines, evals, and do blocks. Lists of values in formats may now be arbitrary expressions, separated by commas. Subroutine names are now distinguished by prefixing with &. You can call subroutines without using do, and without passing any argument list at all: $foo = &min($a,$b,$c); $num = &myrand; You can use the new -u switch to cause perl to dump core so that you can run undump and produce a binary executable image. Alternately you can use the "dump" operator after initializing any variables and such. Perl now optimizes splits that are assigned directly to an array, or to a list with fewer elements than the split would produce, or that split on a constant string. Perl now optimizes on end matches such as /foo$/; Perl now recognizes {n,m} in patterns to match preceding item at least n times and no more than m times. Also recognizes {n,} and {n} to match n or more times, or exactly n times. If { occurs in other than this context it is still treated as a normal character. Perl now optimizes "next" to avoid unnecessary longjmps and subroutine calls. Perl now optimizes appended input: $_ .= <>; Substitutions are faster if the substituted text is constant, especially when substituting at the beginning of a string. This plus the previous optimization let you run down a file comparing multiple lines more efficiently. (Basically the equivalents of sed's N and D are faster.) Similarly, combinations of shifts and pushes on the same array are much faster now--it doesn't copy all the pointers every time you shift (just every n times, where n is approximately the length of the array plus 10, more if you pre-extend the array), so you can use an array as a shift register much more efficiently: push(@ary,shift(@ary)); or shift(@ary); push(@ary,<>); The shift operator used inside subroutines now defaults to shifting the @_ array. You can still shift ARGV explicitly, of course. The @_ array which is passed to subroutines is a local array, but the elements of it are passed by reference now. This means that if you explicitly modify $_[0], you are actually modifying the first argument to the routine. Assignment to another location (such as the usual local($foo) = @_ trick) causes a copy of the value, so this will not affect most scripts. However, if you've modified @_ values in the subroutine you could be in for a surprise. I don't believe most people will find this a problem, and the long term efficiency gain is worth a little confusion. Perl now detects sequences of references to the same variable and builds switch statements internally wherever reasonable. The substr function can take offsets from the end of the string. The substr function can be assigned to in order to change the interior of a string in place. The split function can return as part of the returned array any substrings matched as part of the delimiter: split(/([-,])/, '1-10,20') returns (1,'-',10,',',20) If you specify a maximum number of fields to split, the truncation of trailing null fields is disabled. You can now chop lists. Perl now uses /bin/csh to do filename globbing, if available. This means that filenames with spaces or other strangenesses work right. Perl can now report multiple syntax errors with a single invocation. Perl syntax errors now give two tokens of context where reasonable. Perl will now report the possibility of a runaway multi-line string if such a string ends on a line with a syntax error. The assumed assignment in a while now works in the while modifier as well as the while statement. Perl can now warn you if you use numeric == on non-numeric string values. New functions: mkdir and rmdir getppid getpgrp and setpgrp getpriority and setpriority chroot ioctl and fcntl flock readlink lstat rindex - find last occurrence of substring pack and unpack - turn structures into arrays and vice versa read - just what you think warn - like die, only not fatal dbmopen and dbmclose - bind a dbm file to an associative array dump - do core dump so you can undump reverse - turns an array value end for end defined - does an object exist? undef - make an object not exist vec - treat string as a vector of small integers fileno - return the file descriptor for a handle wantarray - was subroutine called in array context? opendir readdir telldir seekdir rewinddir closedir syscall socket bind connect listen accept shutdown socketpair getsockname getpeername getsockopt setsockopt getpwnam getpwuid getpwent setpwent endpwent getgrnam getgrgid getgrent setgrent endgrent gethostbyname gethostbyaddr gethostent sethostent endhostent getnetbyname getnetbyaddr getnetent setnetent endnetent getprotobyname getprotobynumber getprotoent setprotoent endprotoent getservbyname getservbyport getservent setservent endservent Changes to s2p -------------- In patterns, s2p now translates \{n,m\} correctly to {n,m}. In patterns, s2p no longer removes backslashes in front of |. In patterns, s2p now removes backslashes in front of [a-zA-Z0-9]. S2p now makes use of the location of perl as determined by Configure. Changes to a2p -------------- A2p can now accurately translate the "in" operator by using perl's new "defined" operator. A2p can now accurately translate the passing of arrays by reference. setservent endservent Changes to s2p -------------- In patterns, s2p now translates \{n,m\} correctly to {n,m}. In patterns, s2p no longer removes backslashperl/array.c 644 473 0 11426 4747105053 6340 /* $Header: array.c,v 3.0.1.1 89/11/17 15:02:52 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: array.c,v $ * Revision 3.0.1.1 89/11/17 15:02:52 lwall * patch5: nested foreach on same array didn't work * * Revision 3.0 89/10/18 15:08:33 lwall * 3.0 baseline * */ #include "EXTERN.h" #include "perl.h" STR * afetch(ar,key,lval) register ARRAY *ar; int key; int lval; { STR *str; if (key < 0 || key > ar->ary_fill) { if (lval && key >= 0) { if (ar->ary_flags & ARF_REAL) str = Str_new(5,0); else str = str_static(&str_undef); (void)astore(ar,key,str); return str; } else return Nullstr; } if (lval && !ar->ary_array[key]) { str = Str_new(6,0); (void)astore(ar,key,str); return str; } return ar->ary_array[key]; } bool astore(ar,key,val) register ARRAY *ar; int key; STR *val; { int retval; if (key < 0) return FALSE; if (key > ar->ary_max) { int newmax; if (ar->ary_alloc != ar->ary_array) { retval = ar->ary_array - ar->ary_alloc; Copy(ar->ary_array, ar->ary_alloc, ar->ary_max+1, STR*); Zero(ar->ary_alloc+ar->ary_max+1, retval, STR*); ar->ary_max += retval; ar->ary_array -= retval; if (key > ar->ary_max - 10) { newmax = key + ar->ary_max; goto resize; } } else { newmax = key + ar->ary_max / 5; resize: Renew(ar->ary_alloc,newmax+1, STR*); Zero(&ar->ary_alloc[ar->ary_max+1], newmax - ar->ary_max, STR*); ar->ary_array = ar->ary_alloc; ar->ary_max = newmax; } } if ((ar->ary_flags & ARF_REAL) && ar->ary_fill < key) { while (++ar->ary_fill < key) { if (ar->ary_array[ar->ary_fill] != Nullstr) { str_free(ar->ary_array[ar->ary_fill]); ar->ary_array[ar->ary_fill] = Nullstr; } } } retval = (ar->ary_array[key] != Nullstr); if (retval && (ar->ary_flags & ARF_REAL)) str_free(ar->ary_array[key]); ar->ary_array[key] = val; return retval; } ARRAY * anew(stab) STAB *stab; { register ARRAY *ar; New(1,ar,1,ARRAY); Newz(2,ar->ary_alloc,5,STR*); ar->ary_array = ar->ary_alloc; ar->ary_magic = Str_new(7,0); str_magic(ar->ary_magic, stab, '#', Nullch, 0); ar->ary_fill = -1; ar->ary_max = 4; ar->ary_flags = ARF_REAL; return ar; } ARRAY * afake(stab,size,strp) STAB *stab; int size; STR **strp; { register ARRAY *ar; New(3,ar,1,ARRAY); New(4,ar->ary_alloc,size+1,STR*); Copy(strp,ar->ary_alloc,size,STR*); ar->ary_array = ar->ary_alloc; ar->ary_magic = Str_new(8,0); str_magic(ar->ary_magic, stab, '#', Nullch, 0); ar->ary_fill = size - 1; ar->ary_max = size - 1; ar->ary_flags = 0; return ar; } void aclear(ar) register ARRAY *ar; { register int key; if (!ar || !(ar->ary_flags & ARF_REAL)) return; if (key = ar->ary_array - ar->ary_alloc) { ar->ary_max += key; ar->ary_array -= key; } for (key = 0; key <= ar->ary_max; key++) str_free(ar->ary_array[key]); ar->ary_fill = -1; Zero(ar->ary_array, ar->ary_max+1, STR*); } void afree(ar) register ARRAY *ar; { register int key; if (!ar) return; if (key = ar->ary_array - ar->ary_alloc) { ar->ary_max += key; ar->ary_array -= key; } if (ar->ary_flags & ARF_REAL) { for (key = 0; key <= ar->ary_max; key++) str_free(ar->ary_array[key]); } str_free(ar->ary_magic); Safefree(ar->ary_alloc); Safefree(ar); } bool apush(ar,val) register ARRAY *ar; STR *val; { return astore(ar,++(ar->ary_fill),val); } STR * apop(ar) register ARRAY *ar; { STR *retval; if (ar->ary_fill < 0) return Nullstr; retval = ar->ary_array[ar->ary_fill]; ar->ary_array[ar->ary_fill--] = Nullstr; return retval; } aunshift(ar,num) register ARRAY *ar; register int num; { register int i; register STR **sstr,**dstr; if (num <= 0) return; if (ar->ary_array - ar->ary_alloc >= num) { ar->ary_max += num; ar->ary_fill += num; while (num--) *--ar->ary_array = Nullstr; } else { (void)astore(ar,ar->ary_fill+num,(STR*)0); /* maybe extend array */ dstr = ar->ary_array + ar->ary_fill; sstr = dstr - num; for (i = ar->ary_fill; i >= 0; i--) { *dstr-- = *sstr--; } Zero(ar->ary_array, num, STR*); } } STR * ashift(ar) register ARRAY *ar; { STR *retval; if (ar->ary_fill < 0) return Nullstr; retval = *ar->ary_array; *(ar->ary_array++) = Nullstr; ar->ary_max--; ar->ary_fill--; return retval; } int alen(ar) register ARRAY *ar; { 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 (void)astore(ar,fill,Nullstr); } sstr--; } Zero(ar->ary_array, num, STR*); } } STR * ashift(ar) register ARRAY *ar; { STR *retval; if (ar->ary_fill < 0) return Nullstr; retval = *ar->ary_array; *(ar->ary_array++) = Nullstr; ar->ary_max--;perl/makelib.SH 644 473 0 10660 4747105053 6715 case $CONFIG in '') if test ! -f config.sh; then ln ../config.sh . || \ ln ../../config.sh . || \ ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) fi . config.sh ;; esac : This forces SH files to create target in same directory as SH file. : This is so that make depend always knows where to find SH derivatives. case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac echo "Extracting makelib (with variable substitutions)" : This section of the file will have variable substitutions done on it. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. : Protect any dollar signs and backticks that you do not want interpreted : by putting a backslash in front. You may delete these comments. $spitshell >makelib <>makelib <<'!NO!SUBS!' chdir '/usr/include' || die "Can't cd /usr/include"; %isatype = ('char',1,'short',1,'int',1,'long',1); foreach $file (@ARGV) { print $file,"\n"; if ($file =~ m|^(.*)/|) { $dir = $1; if (!-d "$perlincl/$dir") { mkdir("$perlincl/$dir",0777); } } open(IN,"$file") || ((warn "Can't open $file: $!\n"),next); open(OUT,">$perlincl/$file") || die "Can't create $file: $!\n"; while () { chop; while (/\\$/) { chop; $_ .= ; chop; } if (s:/\*:\200:g) { s:\*/:\201:g; s/\200[^\201]*\201//g; # delete single line comments if (s/\200.*//) { # begin multi-line comment? $_ .= '/*'; $_ .= ; redo; } } if (s/^#\s*//) { if (s/^define\s+(\w+)//) { $name = $1; $new = ''; s/\s+$//; if (s/^\(([\w,\s]*)\)//) { $args = $1; if ($args ne '') { foreach $arg (split(/,\s*/,$args)) { $curargs{$arg} = 1; } $args =~ s/\b(\w)/\$$1/g; $args = "local($args) = \@_;\n$t "; } s/^\s+//; do expr(); $new =~ s/(["\\])/\\$1/g; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; print OUT $t, "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n"; } else { print OUT "sub $name {\n ${args}eval \"$new\";\n}\n"; } %curargs = (); } else { s/^\s+//; do expr(); $new = 1 if $new eq ''; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; print OUT $t,"eval 'sub $name {",$new,";}';\n"; } else { print OUT $t,"sub $name {",$new,";}\n"; } } } elsif (/^include <(.*)>/) { print OUT $t,"do '$1' || die \"Can't include $1: \$!\";\n"; } elsif (/^ifdef\s+(\w+)/) { print OUT $t,"if (defined &$1) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (/^ifndef\s+(\w+)/) { print OUT $t,"if (!defined &$1) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (s/^if\s+//) { $new = ''; do expr(); print OUT $t,"if ($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (s/^elif\s+//) { $new = ''; do expr(); $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n${t}elsif ($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (/^else/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n${t}else {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (/^endif/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n"; } } } print OUT "1;\n"; } sub expr { while ($_ ne '') { s/^(\s+)// && do {$new .= ' '; next;}; s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; s/^(\d+)// && do {$new .= $1; next;}; s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; s/^'((\\"|[^"])*)'// && do { if ($curargs{$1}) { $new .= "ord('\$$1')"; } else { $new .= "ord('$1')"; } next; }; s/^(struct\s+\w+)// && do {$new .= "'$1'"; next;}; s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { $new .= '$sizeof'; next; }; s/^([_a-zA-Z]\w*)// && do { $id = $1; if ($curargs{$id}) { $new .= '$' . $id; } elsif ($id eq 'defined') { $new .= 'defined'; } elsif (/^\(/) { s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/; # cheat $new .= "&$id"; } elsif ($isatype{$id}) { $new .= "'$id'"; } else { $new .= '&' . $id; } next; }; s/^(.)// && do {$new .= $1; next;}; } } !NO!SUBS! chmod 755 makelib $eunicefix makelib 1}/ && do { $new .= '$sizeof'; next; }; s/^([_a-zA-Z]\w*)// && do { perl/str.h 644 473 0 10511 4747105053 6031 /* $Header: str.h,v 3.0.1.1 89/10/26 23:24:42 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: str.h,v $ * Revision 3.0.1.1 89/10/26 23:24:42 lwall * patch1: rearranged some structures to align doubles better on Gould * * Revision 3.0 89/10/18 15:23:49 lwall * 3.0 baseline * */ struct string { char * str_ptr; /* pointer to malloced string */ int str_len; /* allocated size */ union { double str_nval; /* numeric value, if any */ STAB *str_stab; /* magic stab for magic "key" string */ long str_useful; /* is this search optimization effective? */ ARG *str_args; /* list of args for interpreted string */ HASH *str_hash; /* string represents an assoc array (stab?) */ ARRAY *str_array; /* string represents an array */ } str_u; int str_cur; /* length of str_ptr as a C string */ STR *str_magic; /* while free, link to next free str */ /* while in use, ptr to "key" for magic items */ char str_pok; /* state of str_ptr */ char str_nok; /* state of str_nval */ unsigned char str_rare; /* used by search strings */ unsigned char str_state; /* one of SS_* below */ /* also used by search strings for backoff */ #ifdef TAINT bool str_tainted; /* 1 if possibly under control of $< */ #endif }; struct stab { /* should be identical, except for str_ptr */ STBP * str_ptr; /* pointer to malloced string */ int str_len; /* allocated size */ union { double str_nval; /* numeric value, if any */ STAB *str_stab; /* magic stab for magic "key" string */ long str_useful; /* is this search optimization effective? */ ARG *str_args; /* list of args for interpreted string */ HASH *str_hash; /* string represents an assoc array (stab?) */ ARRAY *str_array; /* string represents an array */ } str_u; int str_cur; /* length of str_ptr as a C string */ STR *str_magic; /* while free, link to next free str */ /* while in use, ptr to "key" for magic items */ char str_pok; /* state of str_ptr */ char str_nok; /* state of str_nval */ unsigned char str_rare; /* used by search strings */ unsigned char str_state; /* one of SS_* below */ /* also used by search strings for backoff */ #ifdef TAINT bool str_tainted; /* 1 if possibly under control of $< */ #endif }; /* some extra info tacked to some lvalue strings */ struct lstring { struct string lstr; int lstr_offset; int lstr_len; }; /* These are the values of str_pok: */ #define SP_VALID 1 /* str_ptr is valid */ #define SP_FBM 2 /* string was compiled for fbm search */ #define SP_STUDIED 4 /* string was studied */ #define SP_CASEFOLD 8 /* case insensitive fbm search */ #define SP_INTRP 16 /* string was compiled for interping */ #define SP_TAIL 32 /* fbm string is tail anchored: /foo$/ */ #define SP_MULTI 64 /* symbol table entry probably isn't a typo */ #define Nullstr Null(STR*) /* These are the values of str_state: */ #define SS_NORM 0 /* normal string */ #define SS_INCR 1 /* normal string, incremented ptr */ #define SS_SARY 2 /* array on save stack */ #define SS_SHASH 3 /* associative array on save stack */ #define SS_SINT 4 /* integer on save stack */ #define SS_SLONG 5 /* long on save stack */ #define SS_SSTRP 6 /* STR* on save stack */ #define SS_SHPTR 7 /* HASH* on save stack */ #define SS_SNSTAB 8 /* non-stab on save stack */ #define SS_HASH 253 /* carrying an hash */ #define SS_ARY 254 /* carrying an array */ #define SS_FREE 255 /* in free list */ /* str_state may have any value 0-255 when used to hold fbm pattern, in which */ /* case it indicates offset to rarest character in screaminstr key */ /* the following macro updates any magic values this str is associated with */ #ifdef TAINT #define STABSET(x) \ (x)->str_tainted |= tainted; \ if ((x)->str_magic) \ stabset((x)->str_magic,(x)) #else #define STABSET(x) \ if ((x)->str_magic) \ stabset((x)->str_magic,(x)) #endif #define STR_SSET(dst,src) if (dst != src) str_sset(dst,src) EXT STR **tmps_list; EXT int tmps_max INIT(-1); EXT int tmps_base INIT(-1); char *str_2ptr(); double str_2num(); STR *str_static(); STR *str_2static(); STR *str_make(); STR *str_nmake(); STR *str_smake(); int str_cmp(); int str_eq(); void str_magic(); void str_insert(); (x)->str_tainted |= tainted; \ if ((x)->str_magic) \ stabset((x)->str_magic,(x)) #else #define STABSET(x) \ if ((x)->str_magic) \ stabset((x)->str_magic,(x)) #endif #defperl/handy.h 644 473 0 5701 4747105054 6312 /* $Header: handy.h,v 3.0.1.1 89/11/17 15:25:55 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: handy.h,v $ * Revision 3.0.1.1 89/11/17 15:25:55 lwall * patch5: some machines already define TRUE and FALSE * * Revision 3.0 89/10/18 15:18:24 lwall * 3.0 baseline * */ #ifdef NULL #undef NULL #endif #ifndef I286 # define NULL 0 #else # define NULL 0L #endif #define Null(type) ((type)NULL) #define Nullch Null(char*) #define Nullfp Null(FILE*) #ifdef UTS #define bool int #else #define bool char #endif #ifdef TRUE #undef TRUE #endif #ifdef FALSE #undef FALSE #endif #define TRUE (1) #define FALSE (0) #define Ctl(ch) (ch & 037) #define strNE(s1,s2) (strcmp(s1,s2)) #define strEQ(s1,s2) (!strcmp(s1,s2)) #define strLT(s1,s2) (strcmp(s1,s2) < 0) #define strLE(s1,s2) (strcmp(s1,s2) <= 0) #define strGT(s1,s2) (strcmp(s1,s2) > 0) #define strGE(s1,s2) (strcmp(s1,s2) >= 0) #define strnNE(s1,s2,l) (strncmp(s1,s2,l)) #define strnEQ(s1,s2,l) (!strncmp(s1,s2,l)) #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 #ifndef lint #ifndef LEAKTEST char *safemalloc(); char *saferealloc(); void safefree(); #define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) #define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) #define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \ bzero((char*)(v), (n) * sizeof(t)) #define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Safefree(d) safefree((char*)d) #define Str_new(x,len) str_new(len) #else /* LEAKTEST */ char *safexmalloc(); char *safexrealloc(); void safexfree(); #define New(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) #define Newc(x,v,n,t,c) (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) #define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \ bzero((char*)(v), (n) * sizeof(t)) #define Renew(v,n,t) (v = (t*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Safefree(d) safexfree((char*)d) #define Str_new(x,len) str_new(x,len) #define MAXXCOUNT 1200 long xcount[MAXXCOUNT]; long lastxcount[MAXXCOUNT]; #endif /* LEAKTEST */ #define Copy(s,d,n,t) (void)bcopy((char*)(s),(char*)(d), (n) * sizeof(t)) #define Zero(d,n,t) (void)bzero((char*)(d), (n) * sizeof(t)) #else /* lint */ #define New(x,v,n,s) (v = Null(s *)) #define Newc(x,v,n,s,c) (v = Null(s *)) #define Newz(x,v,n,s) (v = Null(s *)) #define Renew(v,n,s) (v = Null(s *)) #define Copy(s,d,n,t) #define Zero(d,n,t) #define Safefree(d) d = d #endif /* lint */ ew(x,len) str_new(x,len) #define MAXXCOUNT 1200 long xcount[MAXperl/hash.h 644 473 0 3567 4747105054 6142 /* $Header: hash.h,v 3.0 89/10/18 15:18:39 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: hash.h,v $ * Revision 3.0 89/10/18 15:18:39 lwall * 3.0 baseline * */ #define FILLPCT 80 /* don't make greater than 99 */ #define DBM_CACHE_MAX 63 /* cache 64 entries for dbm file */ /* (resident array acts as a write-thru cache)*/ #define COEFFSIZE (16 * 8) /* size of array below */ #ifdef DOINIT char coeff[] = { 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1}; #else extern char coeff[]; #endif typedef struct hentry HENT; struct hentry { HENT *hent_next; char *hent_key; STR *hent_val; int hent_hash; int hent_klen; }; struct htbl { HENT **tbl_array; int tbl_max; /* subscript of last element of tbl_array */ int tbl_dosplit; /* how full to get before splitting */ int tbl_fill; /* how full tbl_array currently is */ int tbl_riter; /* current root of iterator */ HENT *tbl_eiter; /* current entry of iterator */ SPAT *tbl_spatroot; /* list of spats for this package */ #ifdef SOME_DBM #ifdef NDBM DBM *tbl_dbm; #else int tbl_dbm; #endif #endif unsigned char tbl_coeffsize; /* is 0 for symbol tables */ }; STR *hfetch(); bool hstore(); STR *hdelete(); HASH *hnew(); void hclear(); void hentfree(); int hiterinit(); HENT *hiternext(); char *hiterkey(); STR *hiterval(); bool hdbmopen(); void hdbmclose(); bool hdbmstore(); * current root of iterator */ HENT *tbl_eiter; /* current entry of iterator */ SPAT *tbl_spatroot; /* list of spats for this pacperl/spat.h 644 473 0 2536 4747105054 6161 /* $Header: spat.h,v 3.0 89/10/18 15:23:14 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: spat.h,v $ * Revision 3.0 89/10/18 15:23:14 lwall * 3.0 baseline * */ struct scanpat { SPAT *spat_next; /* list of all scanpats */ REGEXP *spat_regexp; /* compiled expression */ ARG *spat_repl; /* replacement string for subst */ ARG *spat_runtime; /* compile pattern at runtime */ STR *spat_short; /* for a fast bypass of execute() */ bool spat_flags; char spat_slen; }; #define SPAT_USED 1 /* spat has been used once already */ #define SPAT_ONCE 2 /* use pattern only once per reset */ #define SPAT_SCANFIRST 4 /* initial constant not anchored */ #define SPAT_ALL 8 /* initial constant is whole pat */ #define SPAT_SKIPWHITE 16 /* skip leading whitespace for split */ #define SPAT_FOLD 32 /* case insensitivity */ #define SPAT_CONST 64 /* subst replacement is constant */ #define SPAT_KEEP 128 /* keep 1st runtime pattern forever */ EXT SPAT *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*) fine SPAT_ALL 8 /* initial constant is whole pat */ #define SPAT_SKIPWHITE 16 /* skip leading whitespace for split */ #define SPAT_FOLD 32 /* case insensitivperl/form.h 644 473 0 1376 4747105054 6156 /* $Header: form.h,v 3.0 89/10/18 15:17:39 lwall Locked $ * * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: form.h,v $ * Revision 3.0 89/10/18 15:17:39 lwall * 3.0 baseline * */ #define F_NULL 0 #define F_LEFT 1 #define F_RIGHT 2 #define F_CENTER 3 #define F_LINES 4 struct formcmd { struct formcmd *f_next; ARG *f_expr; STR *f_unparsed; line_t f_line; char *f_pre; short f_presize; short f_size; char f_type; char f_flags; }; #define FC_CHOP 1 #define FC_NOBLANK 2 #define FC_MORE 4 #define FC_REPEAT 8 #define Nullfcmd Null(FCMD*) EXT char *chopset INIT(" \n-"); $Log: form.h,v $ * Revision 3.0 89/10/18 15:17:39 lwall * 3.0 baseline * */ #define F_NULL 0 #define F_LEFT 1 #define F_RIGHT 2 #define F_CENTER 3 #define F_LINES 4 struct formcmd { struct formcmd *f_next; ARG *f_expr; STR *f_unparsed; perl/eg/README 644 473 0 1674 4747105055 6317 Although supplied with the perl package, the perl scripts in this eg directory and its subdirectories are placed in the public domain, and you may do anything with them that you wish. 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?? ill enjoy the items down in the g directory very much. The scan dirperl/eg/scan/scan_passwd 644 473 0 1313 4747105056 10602 #!/usr/bin/perl # $Header: scan_passwd,v 3.0 89/10/18 15:15:43 lwall Locked $ # This scans passwd file for security holes. open(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n"; # $dotriv = (`date` =~ /^Mon/); $dotriv = 1; while () { ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/); if ($shell eq '') { print "Short: $_"; } next if /^[+]/; if ($pass eq '') { if (index(":sync:lpq:+:", ":$login:") < 0) { print "No pass: $login\t$gcos\n"; } } elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) { print "Trivial: $login\t$gcos\n"; } if ($uid == 0) { if ($login !~ /^.?root$/ && $pass ne '*') { print "Extra root: $_"; } } } `date` =~ /^Mon/); $dotriv = 1; while () { ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/); if ($shell eq '') { print "Short: $_"; } next if /^[+]/; if ($pass eq '') { if (index(":sync:lpq:+:", ":$login:") < 0) { print "No pass: $login\t$gcos\n"; } } elsif perl/eg/scan/scan_messages 644 473 0 11717 4747105056 11141 #!/usr/bin/perl -P # $Header: scan_messages,v 3.0 89/10/18 15:15:38 lwall Locked $ # This prints out extraordinary console messages. You'll need to customize. chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; $maxpos = `cat oldmsgs 2>&1`; #if defined(mc300) || defined(mc500) || defined(mc700) open(Msgs, '/dev/null') || die "scan_messages: can't open messages"; #else open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages"; #endif ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat(Msgs); if ($size < $maxpos) { # Did somebody truncate messages file? $maxpos = 0; } seek(Msgs,$maxpos,0); # Start where we left off last time. while () { s/\[(\d+)\]/#/ && s/$1/#/g; #ifdef vax $_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//; next if /root@.*:/; next if /^vmunix: 4.3 BSD UNIX/; next if /^vmunix: Copyright/; next if /^vmunix: avail mem =/; next if /^vmunix: SBIA0 at /; next if /^vmunix: disk ra81 is/; next if /^vmunix: dmf. at uba/; next if /^vmunix: dmf.:.*asynch/; next if /^vmunix: ex. at uba/; next if /^vmunix: ex.: HW/; next if /^vmunix: il. at uba/; next if /^vmunix: il.: hardware/; next if /^vmunix: ra. at uba/; next if /^vmunix: ra.: media/; next if /^vmunix: real mem/; next if /^vmunix: syncing disks/; next if /^vmunix: tms/; next if /^vmunix: tmscp. at uba/; next if /^vmunix: uba. at /; next if /^vmunix: uda. at /; next if /^vmunix: uda.: unit . ONLIN/; next if /^vmunix: .*buffers containing/; next if /^syslogd: .*newslog/; #endif next if /unknown service/; next if /^\.\.\.$/; if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) { $pfx = ''; next; } next if /^[ \t]*$/; next if /^[ 0-9]*done$/; if (/^A/) { next if /^Accounting [sr]/; } elsif (/^C/) { next if /^Called from/; next if /^Copyright/; } elsif (/^E/) { next if /^End traceback/; next if /^Ethernet address =/; } elsif (/^K/) { next if /^KERNEL MODE/; } elsif (/^R/) { next if /^Rebooting Unix/; } elsif (/^S/) { next if /^Sun UNIX 4\.2 Release/; } elsif (/^W/) { next if /^WARNING: clock gained/; } elsif (/^a/) { next if /^arg /; next if /^avail mem =/; } elsif (/^b/) { next if /^bwtwo[0-9] at /; } elsif (/^c/) { next if /^cgone[0-9] at /; next if /^cdp[0-9] at /; next if /^csr /; } elsif (/^d/) { next if /^dcpa: init/; next if /^done$/; next if /^dts/; next if /^dump i\/o error/; next if /^dumping to dev/; next if /^dump succeeded/; $pfx = '*' if /^dev = /; } elsif (/^e/) { next if /^end \*\*/; next if /^error in copy/; } elsif (/^f/) { next if /^found /; } elsif (/^i/) { next if /^ib[0-9] at /; next if /^ie[0-9] at /; } elsif (/^l/) { next if /^le[0-9] at /; } elsif (/^m/) { next if /^mem = /; next if /^mt[0-9] at /; next if /^mti[0-9] at /; $pfx = '*' if /^mode = /; } elsif (/^n/) { next if /^not found /; } elsif (/^p/) { next if /^page map /; next if /^pi[0-9] at /; $pfx = '*' if /^panic/; } elsif (/^q/) { next if /^qqq /; } elsif (/^r/) { next if /^read /; next if /^revarp: Requesting/; next if /^root [od]/; } elsif (/^s/) { next if /^sc[0-9] at /; next if /^sd[0-9] at /; next if /^sd[0-9]: oldmsgs.tmp') || die "Can't create tmp file: $!\n"; while ($_ = pop(@seen)) { print tmp $_; } close(tmp); open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file: $!\n"; while () { if (/^nd:/) { next if $seen{$_} < 20; } if (/NFS/) { next if $seen{$_} < 20; } if (/no carrier/) { next if $seen{$_} < 20; } if (/silo overflow/) { next if $seen{$_} < 20; } print $seen{$_},":\t",$_; } print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`; gs); open(tmp,'|sort >oldmsgs.tmp') || die "Can'perl/eg/scan/scan_suid 644 473 0 4232 4747105056 10250 #!/usr/bin/perl -P # $Header: scan_suid,v 3.0 89/10/18 15:15:57 lwall Locked $ # Look for new setuid root files. chdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n"; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('oldsuid'); if ($nlink) { $lasttime = $mtime; $tmp = $ctime - $atime; if ($tmp <= 0 || $tmp >= 10) { print "WARNING: somebody has read oldsuid!\n"; } $tmp = $ctime - $mtime; if ($tmp <= 0 || $tmp >= 10) { print "WARNING: somebody has modified oldsuid!!!\n"; } } else { $lasttime = time - 60 * 60 * 24; # one day ago } $thistime = time; #if defined(mc300) || defined(mc500) || defined(mc700) open(Find, 'find / -perm -04000 -print |') || die "scan_find: can't run find"; #else open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') || die "scan_find: can't run find"; #endif open(suid, '>newsuid.tmp'); while () { #if defined(mc300) || defined(mc500) || defined(mc700) $x = `/bin/ls -il $_`; $_ = $x; s/^ *//; ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split; #else s/^ *//; ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split; #endif if ($perm =~ /[sS]/ && $owner eq 'root') { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($name); $foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n", $perm,$links,$owner,$group,$size,$month,$day,$name,$inode); print suid $foo; if ($ctime > $lasttime) { if ($ctime > $thistime) { print "Future file: $foo"; } else { $ct .= $foo; } } } } close(suid); print `sort +7 -8 newsuid.tmp >newsuid 2>&1`; $foo = `/bin/diff oldsuid newsuid 2>&1`; print "Differences in suid info:\n",$foo if $foo; print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`; print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`; print `rm -f newsuid.tmp 2>&1`; @ct = split(/\n/,$ct); $ct = ''; $* = 1; while ($#ct >= 0) { $tmp = shift(@ct); unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; } } print "Inode changed since last time:\n",$ct if $ct; } } 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; wperl/eg/scan/scanner 644 473 0 4050 4747105056 7727 #!/usr/bin/perl # $Header: scanner,v 3.0 89/10/18 15:16:02 lwall Locked $ # This runs all the scan_* routines on all the machines in /etc/ghosts. # We run this every morning at about 6 am: # !/bin/sh # cd /usr/adm/private # decrypt scanner | perl >scan.out 2>&1 # mail admin = 0) { @scanlist = @ARGV; } else { @scanlist = split(/[ \t\n]+/,`echo scan_*`); } scan: while ($scan = shift(@scanlist)) { print "\n********** $scan **********\n"; $showhost++; $systype = 'all'; open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file'; $one_of_these = ":$systype:"; if ($systype =~ s/\+/[+]/g) { $one_of_these =~ s/\+/:/g; } line: while () { s/[ \t]*\n//; if (!$_ || /^#/) { next line; } if (/^([a-zA-Z_0-9]+)=(.+)/) { $name = $1; $repl = $2; $repl =~ s/\+/:/g; $one_of_these =~ s/:$name:/:$repl:/; next line; } @gh = split; $host = $gh[0]; if ($showhost) { $showhost = "$host:\t"; } class: while ($class = pop(gh)) { if (index($one_of_these,":$class:") >=0) { $iter = 0; `exec crypt -inquire <$scan >.x 2>/dev/null`; unless (open(scan,'.x')) { print "Can't run $scan: $!\n"; next scan; } $cmd = ; unless ($cmd =~ s/#!(.*)\n/$1/) { $cmd = '/usr/bin/perl'; } close(scan); if (open(pipe,"exec rsh $host '$cmd' <.x|")) { sleep(5); unlink '.x'; while () { last if $iter++ > 1000; # must be looping next if /^[0-9.]+u [0-9.]+s/; print $showhost,$_; } close(pipe); } else { print "(Can't execute rsh: $!)\n"; } last class; } } } } unless (open(scan,'.x')) { print "Can't run $scan: $!\n"; next scan; } $cmd = ; unless ($cmd =~ s/#!(.*)\n/$1/) { $cmd = '/usr/bin/perl'; } close(scan); if (open(pipe,"exec rsh $host '$cmd' <.x|")) { sleep(5); unlink '.x'; while () { last if $iter++ > 1000; # must be looping next if /^[0-9.]+u [0-9.]+s/; print $showhost,$_; } close(pipe); } else { print "(Can't execute rsh: $!)\perl/eg/scan/scan_df 644 473 0 2467 4747105057 7706 #!/usr/bin/perl -P # $Header: scan_df,v 3.0 89/10/18 15:15:26 lwall Locked $ # This report points out filesystems that are in danger of overflowing. (chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; `df >newdf`; open(Df, 'olddf'); while () { ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; next if $fs =~ /:/; next if $fs eq ''; $oldused{$fs} = $used; } open(Df, 'newdf') || die "scan_df: can't open newdf"; while () { ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; next if $fs =~ /:/; next if $fs eq ''; $oldused = $oldused{$fs}; next if ($oldused == $used && $capacity < 99); # inactive filesystem if ($capacity >= 90) { #if defined(mc300) || defined(mc500) || defined(mc700) $_ = substr($_,0,13) . ' ' . substr($_,13,1000); $kbytes /= 2; # translate blocks to K $used /= 2; $oldused /= 2; $avail /= 2; #endif $diff = int($used - $oldused); if ($avail < $diff * 2) { # mark specially if in danger $mounted_on .= ' *'; } next if $diff < 50 && $mounted_on eq '/'; $fs =~ s|/dev/||; if ($diff >= 0) { $diff = '(+' . $diff . ')'; } else { $diff = '(' . $diff . ')'; } printf "%-8s%8d%8d %-8s%8d%7s %s\n", $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on; } } rename('newdf','olddf'); 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 $mounteperl/eg/scan/scan_last 644 473 0 2423 4747105057 10250 #!/usr/bin/perl -P # $Header: scan_last,v 3.0 89/10/18 15:15:31 lwall Locked $ # This reports who was logged on at weird hours ($dy, $mo, $lastdt) = split(/ +/,`date`); open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last"; while () { #if defined(mc300) || defined(mc500) || defined(mc700) $_ = substr($_,0,19) . substr($_,23,100); #endif next if /^$/; (print),next if m|^/|; $login = substr($_,0,8); $tty = substr($_,10,7); $from = substr($_,19,15); $day = substr($_,36,3); $mo = substr($_,40,3); $dt = substr($_,44,2); $hr = substr($_,47,2); $min = substr($_,50,2); $dash = substr($_,53,1); $tohr = substr($_,55,2); $tomin = substr($_,58,2); $durhr = substr($_,63,2); $durmin = substr($_,66,2); next unless $hr; next if $login eq 'reboot '; next if $login eq 'shutdown'; if ($dt != $lastdt) { if ($lastdt < $dt) { $seen += $dt - $lastdt; } else { $seen++; } $lastdt = $dt; } $inat = $hr + $min / 60; if ($tohr =~ /^[a-z]/) { $outat = 12; # something innocuous } else { $outat = $tohr + $tomin / 60; } last if $seen + ($inat < 8) > 1; if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) { print; } } $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 =perl/eg/scan/scan_sudo 644 473 0 2104 4747105057 10253 #!/usr/bin/perl -P # $Header: scan_sudo,v 3.0 89/10/18 15:15:52 lwall Locked $ # Analyze the sudo log. chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; if (open(Oldsudo,'oldsudo')) { $maxpos = ; close Oldsudo; } else { $maxpos = 0; `echo 0 >oldsudo`; } unless (open(Sudo, '/usr/adm/sudo.log')) { print "Somebody removed sudo.log!!!\n" if $maxpos; exit 0; } ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat(Sudo); if ($size < $maxpos) { $maxpos = 0; print "Somebody reset sudo.log!!!\n"; } seek(Sudo,$maxpos,0); while () { s/^.* :[ \t]+//; s/ipcrm.*/ipcrm/; s/kill.*/kill/; unless ($seen{$_}++) { push(@seen,$_); } $last = $_; } $max = tell(Sudo); open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n"; while ($_ = pop(@seen)) { print tmp $_; } close(tmp); open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n"; while () { print $seen{$_},":\t",$_; } print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`; dy reset sudo.log!!!\n"; } seek(Sudo,$maxpos,0); while () { s/^.* :[ \t]+//; s/ipcrm.*/ipcrm/; s/kill.*/kill/; unless ($seen{$_}++) { push(@seen,$_); } $last = $_; } $max = tell(Sudo); open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n"; while ($_ = pop(@seen)) { print tmp $_; } close(tmp); open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n"; while () { print $seen{$_},perl/eg/scan/scan_ps 644 473 0 1354 4747105060 7723 #!/usr/bin/perl -P # $Header: scan_ps,v 3.0 89/10/18 15:15:47 lwall Locked $ # This looks for looping processes. #if defined(mc300) || defined(mc500) || defined(mc700) open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps"; while () { next if /rwhod/; print if index(' T', substr($_,62,1)) < 0; } #else open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps"; while () { next if /dataserver/; next if /nfsd/; next if /update/; next if /ypserv/; next if /rwhod/; next if /routed/; next if /pagedaemon/; #ifdef vax ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split; #else ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split; #endif print if length($time) > 4; } #endif ) { next if /rwhod/; print if index(' T', substr($_,62,1)) < 0; } #else open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps"; while () { next if /dataserver/; next if /nfsd/; next if /update/; next if /ypserv/; next if /rwhod/; neperl/eg/findcp 644 473 0 2255 4747105060 6615 #!/usr/bin/perl # $Header: findcp,v 3.0 89/10/18 15:13:47 lwall Locked $ # This is a wrapper around the find command that pretends find has a switch # of the form -cp host:destination. It presumes your find implements -ls. # It uses tar to do the actual copy. If your tar knows about the I switch # you may prefer to use findtar, since this one has to do the tar in batches. sub copy { `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`; } $sourcedir = $ARGV[0]; if ($sourcedir =~ /^\//) { $ARGV[0] = '.'; unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; } } $args = join(' ',@ARGV); if ($args =~ s/-cp *([^ ]+)/-ls/) { $dest = $1; if ($dest =~ /(.*):(.*)/) { $desthost = $1; $destdir = $2; } else { die "Malformed destination--should be host:directory"; } } else { die("No destination specified"); } open(find,"find $args |") || die "Can't run find for you: $!"; while () { @x = split(' '); if ($x[2] =~ /^d/) { next;} chop($filename = $x[10]); if (length($list) > 5000) { do copy(); $list = ''; } else { $list .= ' '; } $list .= $filename; } if ($list) { do copy(); } 1; if ($dest =~ /(.*):(.*)/) { $desthost = $1; $destdir = $2; } else { die "Malformed destination--should be host:directory"; } } else { die("No destination specified"); } open(find,"find $args |") || die "Can't run find for you: $!"; while () { @x = split(' '); if ($x[2] =~ /^d/) { next;} chop(perl/eg/g/gsh.man 644 473 0 3756 4747105061 7143 .\" $Header: gsh.man,v 3.0 89/10/18 15:14:42 lwall Locked $ .TH GSH 8 "13 May 1988" .SH NAME gsh \- global shell .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. put to each invokaperl/eg/g/gsh 644 473 0 6075 4747105061 6366 #! /usr/bin/perl # $Header: gsh,v 3.0.1.1 90/02/28 17:14:10 lwall Locked $ # 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(@ARGV),next); $ARGV[0] =~ /^-s/ && ($silent++,shift(@ARGV),next); $ARGV[0] =~ /^-d/ && ($dodist++,shift(@ARGV),next); $ARGV[0] =~ /^-n/ && ($n=' -n',shift(@ARGV),next); $ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift(@ARGV),shift(@ARGV), 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 = " ) { # for each line of ghosts s/[ \t]*\n//; # trim trailing whitespace if (!$_ || /^#/) { # skip blank line or comment next line; } if (/^(\w+)=(.+)/) { # a macro line? $name = $1; $repl = $2; $repl =~ s/\+/:/g; $repl =~ s/-/:-/g; $one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list $repl =~ s/:/:-/g; $one_of_these =~ s/:-$name:/:-$repl:/; next line; } # we have a normal line @attr = split(' '); # a list of attributes to match against # which we put into an array $host = $attr[0]; # the first attribute is the host name if ($showhost) { $showhost = "$host:\t"; } $wanted = 0; foreach $attr (@attr) { # iterate over attribute array $wanted++ if index($one_of_these,":$attr:") >= 0; $wanted = -9999 if index($one_of_these,":-$attr:") >= 0; } if ($wanted > 0) { print "rsh $host$l$n '$cmd'\n" unless $silent; $SIG{'INT'} = 'DEFAULT'; if (open(pipe,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh $SIG{'INT'} = 'cont'; for ($iter=0; ; $iter++) { unless ($iter) { $remainder .= "$host+" if /Connection timed out|Permission denied/; } print $showhost,$_; } close(pipe); } else { print "(Can't execute rsh: $!)\n"; $SIG{'INT'} = 'cont'; } } } 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, $$; } $!)\n"; $SIG{'INT'} = 'cont'; } } } 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 { $| perl/eg/g/gcp 644 473 0 4564 4747105061 6357 #!/usr/bin/perl # $Header: gcp,v 3.0 89/10/18 15:13:59 lwall Locked $ # 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+"; } ype:/ $host:/g; print "$cmd\n"; $result = `$cmd 2>&1`; $remainder .= "$host+" if $result =~ /Connection timed out|Permission denied/perl/eg/g/ghosts 644 473 0 1457 4747105061 7113 # 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 ets. 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 definperl/eg/g/gcp.man 644 473 0 3651 4747105062 7126 .\" $Header: gcp.man,v 3.0 89/10/18 15:14:09 lwall Locked $ .TH GCP 1C "13 May 1988" .SH NAME gcp \- global file copy .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. abc+foo comes out to xyz+def. You can define private host sets by creating .ghosts inperl/eg/g/ged 644 473 0 643 4747105062 6320 #!/usr/bin/perl # $Header: ged,v 3.0 89/10/18 15:14:22 lwall Locked $ # Does inplace edits on a set of files on a set of machines. # # Typical invokation: # # ged vax+sun /etc/passwd # s/Freddy/Freddie/; # ^D # $class = shift; $files = join(' ',@ARGV); die "Usage: ged class files ) { ($name,$dep) = split; $dep =~ s|^\./||; (print $missing,"$key: $dep\n"),($missing='') unless ($dep{"$key: $dep"} += 2) > 2; } } $extra = "\nExtraneous dependencies:\n"; foreach $key (sort keys(dep)) { if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) { print $extra,$key,"\n"; $extra = ''; } } sub scan { local($makefile) = @_; local($MF) = $MF; print stderr "Analyzing $makefile.\n" if $opt_v; $MF++; open($MF,$makefile) || die "Can't open $makefile: $!"; while (<$MF>) { chop; chop($_ = $_ . <$MF>) while s/\\$//; next if /^#/; next if /^$/; s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; s/\$\((\w+)\)/$mac{$1}/eg; $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/; if (/^include\s+(.*)/) { do scan($1); print stderr "Continuing $makefile.\n" if $opt_v; next; } if (/^([^:]+):\s*(.*)/) { $left = $1; $right = $2; if ($right =~ /^([^;]*);(.*)/) { $right = $1; $action = $2; } else { $action = ''; } while (<$MF>) { last unless /^\t/; chop; chop($_ = $_ . <$MF>) while s/\\$//; next if /^#/; last if /^$/; s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; s/\$\((\w+)\)/$mac{$1}/eg; $action .= $_; } foreach $targ (split(' ',$left)) { $targ =~ s|^\./||; foreach $src (split(' ',$right)) { $src =~ s|^\./||; $deplist{$targ} .= ' ' . $src; $dep{"$targ: $src"} = 1; $o{$src} = 1 if $src =~ /\.o$/; $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/; } $action{$targ} .= $action; } redo if $_; } } close($MF); } sub subst { local($foo,$from,$to) = @_; $foo = $mac{$foo}; $from =~ s/\./[.]/; y/a/a/; $foo =~ s/\b$from\b/$to/g; $foo; } $targ (split(' ',$left)) { $targ =~ s|^\./||; foreach $src (split(' ',$right)) { $src =~ s|^\./||; $deplist{$targ} .= ' ' . $src; $dep{"$targ: $src"} = 1; $o{$srcperl/eg/van/unvanish 644 473 0 2521 4747105063 7770 #!/usr/bin/perl # $Header: unvanish,v 3.0 89/10/18 15:16:35 lwall Locked $ 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: $!\n"; } } if ($#ARGV < 0) { open(lastcmd,'.deleted/.lastcmd') || open(lastcmd,'.lastcmd') || die "No previous vanish in this dir"; $ARGV = ; close(lastcmd); @ARGV = split(/[\n ]+/,$ARGV); } while ($ARGV[0] =~ /^-/) { $_ = shift; /^-f/ && ($force = ' >/dev/null 2>&1'); /^-i/ && ($interactive = 1); if (/^-+$/) { $startfiles = '- '; last; } } while ($file = shift) { if ($file =~ s|^(.*)/||) { $dir = $1; } else { $dir = '.'; } if ($dir ne $olddir) { do it() if $olddir; $olddir = $dir; } if ($interactive) { print "unvanish: restore $dir/$file? "; next unless =~ /^y/i; } $filelist .= $file; $filelist .= ' '; } do it() if $olddir; ARGV[0] =~ /^-/) { $_ = shift; /^-f/ && ($force = ' >/dev/null 2>&1'); /^-i/ && ($interactive = 1); if (/^-+$/) { $startfiles = '- '; last; } } while ($perl/eg/van/vanish 644 473 0 2472 4747105063 7432 #!/usr/bin/perl # $Header: vanish,v 3.0 89/10/18 15:16:46 lwall Locked $ 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: $!\n"; } } while ($ARGV[0] =~ /^-/) { $_ = shift; /^-f/ && ($force = ' >/dev/null 2>&1'); /^-i/ && ($interactive = 1); if (/^-+$/) { $startfiles = '- '; last; } } chop($pwd = `pwd`); while ($file = shift) { if ($file =~ s|^(.*)/||) { $dir = $1; } else { $dir = '.'; } if ($interactive) { print "vanish: remove $dir/$file? "; next unless =~ /^y/i; } if ($file eq '.deleted') { print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n"; next; } if ($dir ne $olddir) { do it() if $olddir; $olddir = $dir; } $filelist .= $file; $filelist .= ' '; } do it() if $olddir; es = '- '; last; } } chop($pwd = `pwd`); while ($file = shift) { if ($file =~ s|^(.*)/||) { $dir = $1; } else { $dir = '.'; } if ($interactive) { print "vanish: removeperl/eg/van/empty 644 473 0 1421 4747105063 7271 #!/usr/bin/perl # $Header: empty,v 3.0 89/10/18 15:16:28 lwall Locked $ # 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(' ',@_)); } 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 =~ perl/eg/van/vanexp 644 473 0 673 4747105063 7424 #!/usr/bin/perl # $Header: vanexp,v 3.0 89/10/18 15:16:41 lwall Locked $ # This is for running from a find at night to expire old .deleteds $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 {} \;`; } o cmd('rm -rf .deleted'); } else { if ($dir eq '.' && $pwd =~ perl/eg/changes 644 473 0 1570 4747105064 6765 #!/usr/bin/perl -P # $Header: changes,v 3.0 89/10/18 15:13:23 lwall Locked $ ($dir, $days) = @ARGV; $dir = '/' if $dir eq ''; $days = '14' if $days eq ''; # Masscomps do things differently from Suns #if defined(mc300) || defined(mc500) || defined(mc700) open(Find, "find $dir -mtime -$days -print |") || die "changes: can't run find"; #else open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") || die "changes: can't run find"; #endif while () { #if defined(mc300) || defined(mc500) || defined(mc700) $x = `/bin/ls -ild $_`; $_ = $x; ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split(' '); #else ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) = split(' '); #endif printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n", $perm,$links,$owner,$group,$size,$month,$day,$name); } ype nfs -prune \\) -o -mtime -$days -ls |") || die "changes: can't run find"; #endif while () { #if defined(mc300) || defined(mperl/eg/myrup 644 473 0 1563 4747105064 6533 #!/usr/bin/perl # $Header: myrup,v 3.0 89/10/18 15:15:06 lwall Locked $ # This was a customization of ruptime requested by someone here who wanted # to be able to find the least loaded machine easily. It uses the # /etc/ghosts file that's defined for gsh and gcp to prune down the # number of entries to those hosts we have administrative control over. print "node load (u)\n------- --------\n"; open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!"; line: while () { next line if /^#/; next line if /^$/; next line if /=/; ($host) = split; $wanted{$host} = 1; } open(ruptime,'ruptime|') || die "Can't run ruptime: $!"; open(sort,'|sort +1n'); while () { ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/); if ($wanted{$host} && $upness eq 'up') { printf sort "%s\t%s (%d)\n", $host, $load, $users; } } load (u)\n------- --------\n"; open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!"; line: while () { next line if /^perl/eg/shmkill 644 473 0 1106 4747105065 7014 #!/usr/bin/perl # $Header: shmkill,v 3.0 89/10/18 15:16:09 lwall Locked $ # A script to call from crontab periodically when people are leaving shared # memory sitting around unattached. open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!"; while () { $tmp = index($_,'NATTCH'); $pos = $tmp if $tmp >= 0; if (/^m/) { ($m,$id,$key,$mode,$owner,$group,$attach) = split; if ($attach != substr($_,$pos,6)) { die "Different ipcs format--can't parse!\n"; } if ($attach == 0) { push(@goners,'-m',$id); } } } exec 'ipcrm', @goners if $#goners >= 0; ed $ # A script to call from crontab periodically when people are leaving shared # memory sitting around unattached. open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!"; while () { $tmp = index($_,'NATTCH'); $pos = $tmp if $tmp >= 0; if (/^m/) { ($m,$id,$key,$mode,$owner,$group,$attach) = split; if ($attach != substr($_,$pos,6)) { die "Different ipcs format--can't parse!\n"; } if ($attach == 0) { push(@perl/eg/muck.man 644 473 0 1104 4747105065 7060 .\" $Header: muck.man,v 3.0 89/10/18 15:14:55 lwall Locked $ .TH MUCK 1 "10 Jan 1989" .SH NAME muck \- make usage checker .SH SYNOPSIS .B muck [options] .SH DESCRIPTION .I muck looks at your current makefile and complains if you've left out any dependencies between .o and .h files. It also complains about extraneous dependencies. .PP You can use the -f FILENAME option to specify an alternate name for your makefile. The -v option is a little more verbose about what muck is mucking around with at the moment. .SH SEE ALSO make(1) .SH BUGS Only knows about .h, .c and .o files. K 1 "10 Jan 1989" .SH NAME muck \- make usage checker .SH SYNOPSIS .B muck [options] .SH DESCRIPTION .I muck looks at your current makefile and complains if you've left out any dependencies between .o and .h files. It also complains about extraneous dependencies. .PP You can use the -f FILENAME option to specify an alternate name for your makefile. The -v option is a little more verbose about what muck is mucking around with at the moment. perl/eg/dus 644 473 0 1055 4747105065 6147 #!/usr/bin/perl # $Header: dus,v 3.0 89/10/18 15:13:43 lwall Locked $ # This script does a du -s on any directories in the current directory that # are not mount points for another filesystem. ($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('.'); open(ls,'ls -F1|'); while () { chop; next unless s|/$||; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($_); next unless $dev == $mydev; push(@ary,$_); } exec 'du', '-s', @ary; 8 15:13:43 lwall Locked $ # This script does a du -s on any directories in the current directory that # are not mount points for another filesystem. ($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('.'); open(ls,'ls -F1|'); while () { chop; next unless s|/$||; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($_); next unless $dev == $mydev; perl/eg/findtar 644 473 0 761 4747105065 6766 #!/usr/bin/perl # $Header: findtar,v 3.0 89/10/18 15:13:52 lwall Locked $ # findtar takes find-style arguments and spits out a tarfile on stdout. # It won't work unless your find supports -ls and your tar the I flag. $args = join(' ',@ARGV); open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you."; open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!"; while () { @x = split(' '); if ($x[2] =~ /^d/) { print tar '-d ';} print tar $x[10],"\n"; } dev == $mydev; perl/eg/down 644 473 0 730 4747105065 6302 #!/usr/bin/perl $| = 1; if ($#ARGV >= 0) { $cmd = join(' ',@ARGV); } else { print "Command: "; $cmd = ; chop($cmd); while ($cmd =~ s/\\$//) { print "+ "; $cmd .= ; chop($cmd); } } $cwd = `pwd`; chop($cwd); open(FIND,'find . -type d -print|') || die "Can't run find"; while () { chop; unless (chdir $_) { print stderr "Can't cd to $_\n"; next; } print "\t--> ",$_,"\n"; system $cmd; chdir $cwd; } print tar $x[10],"\n"; } dev == $mydev; perl/eg/who 644 473 0 713 4747105066 6132 #!/usr/bin/perl # This assumes your /etc/utmp file looks like ours open(utmp,'/etc/utmp'); @mo = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'); while (read(utmp,$utmp,36)) { ($line,$name,$host,$time) = unpack('A8A8A16l',$utmp); if ($name) { $host = "($host)" if $host; ($sec,$min,$hour,$mday,$mon) = localtime($time); printf "%-9s%-8s%s %2d %02d:%02d %s\n", $name,$line,$mo[$mon],$mday,$hour,$min,$host; } } hdir $cwd; } print tar $x[10],"\n"; } dev == $mydev; perl/eg/nih 644 473 0 561 4747105066 6114 eval "exec /usr/bin/perl -Spi.bak $0 $*" if $running_under_some_shell; # $Header: nih,v 3.0 89/10/18 15:15:12 lwall Locked $ # This script makes #! scripts directly executable on machines that don't # support #!. It edits in place any scripts mentioned on the command line. s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;| if $. == 1; %-8s%s %2d %02d:%02d %s\n", $name,$line,$mo[$mon],$mday,$hour,$min,$host; } } hdir $cwd; } print tar $x[10],"\n"; } dev == $mydev; perl/eg/rename 644 473 0 427 4747105066 6606 #!/usr/bin/perl ($op = shift) || die "Usage: rename perlexpr [filenames]\n"; if (!@ARGV) { if (-t) { @ARGV = <*>; } else { @ARGV = ; chop(@ARGV); } } for (@ARGV) { $was = $_; eval $op; die $@ if $@; rename($was,$_) unless $was eq $_; } s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;| if $. == 1; %-8s%s %2d %02d:%02d %s\n", $name,$line,$mo[$mon],$mday,$hour,$min,$host; } } hdir $cwd; } print tar $x[10],"\n"; } dev == $mydev; perl/eg/ADB 644 473 0 307 4747105066 5722 #!/usr/bin/perl # $Header: ADB,v 3.0 89/10/18 15:13:04 lwall Locked $ # This script is only useful when used in your crash directory. $num = shift; exec 'adb', '-k', "vmunix.$num", "vmcore.$num"; = $_; eval $op; die $@ if $@; rename($was,$_) unless $was eq $_; } s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;| if $. == 1; %-8s%s %2d %02d:%02d %s\n", $name,$line,$mo[$mon],$mday,$hour,$min,$host; } } hdir $cwd; } print tar $x[10],"\n"; } dev == $mydev; perl/eg/rmfrom 644 473 0 236 4747105067 6640 #!/usr/bin/perl -n # $Header: rmfrom,v 3.0 89/10/18 15:15:20 lwall Locked $ # A handy (but dangerous) script to put after a find ... -print. chop; unlink; db', '-k', "vmunix.$num", "vmcore.$num"; = $_; eval $op; die $@ if $@; rename($was,$_) unless $was eq $_; } s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;| if $. == 1; %-8s%s %2d %02d:%02d %s\n", $name,$line,$mo[$mon],$mday,$hour,$min,$host; } } hdir $cwd; } print tar $x[10],"\n"; } dev == $mydev; perl/eg/relink 644 473 0 576 4747105067 6631 #!/usr/bin/perl ($op = shift) || die "Usage: relink perlexpr [filenames]\n"; if (!@ARGV) { if (-t) { @ARGV = <*>; } else { @ARGV = ; chop(@ARGV); } } for (@ARGV) { next unless -l; # symbolic link? $name = $_; $_ = readlink($_); $was = $_; eval $op; die $@ if $@; if ($was ne $_) { unlink($name); symlink($_, $name); } } 2d:%02d %s\n", $name,$line,$mo[$mon],$mday,$hour,$min,$host; } } hdir $cwd; } print tar $x[10],"\n"; } dev == $mydev; perl/eg/travesty 644 473 0 1403 4747105070 7226 #!/usr/bin/perl while (<>) { next if /^\./; next if /^From / .. /^$/; next if /^Path: / .. /^$/; s/^\W+//; push(@ary,split(' ')); while ($#ary > 1) { $a = $p; $p = $n; $w = shift(@ary); $n = $num{$w}; if ($n eq '') { push(@word,$w); $n = pack('S',$#word); $num{$w} = $n; } $lookup{$a . $p} .= $n; } } for (;;) { $n = $lookup{$a . $p}; ($foo,$n) = each(lookup) if $n eq ''; $n = substr($n,int(rand(length($n))) & 0177776,2); $a = $p; $p = $n; ($w) = unpack('S',$n); $w = $word[$w]; $col += length($w) + 1; if ($col >= 65) { $col = 0; print "\n"; } else { print ' '; } print $w; if ($w =~ /\.$/) { if (rand() < .1) { print "\n"; $col = 80; } } } ord,$w); $n = pack('S',$#word); $num{$w} = $n; } $lookup{$a . $p} .= $n; } } for (;;) { $n = $lookup{$a . $p}; ($foo,$n) = each(lookup) if $n eq ''; $n = substr($n,int(rand(length($n))) & 0177776,2); $a = $p; $p = $nperl/t/README 644 473 0 1031 4747105071 6150 This is the perl test library. To run all the tests, just type 'TEST'. To add new tests, just look at the current tests and do likewise. If a test fails, run it by itself to see if it prints any informative diagnostics. If not, modify the test to print informative diagnostics. If you put out extra lines with a '#' character on the front, you don't have to worry about removing the extra print statements later since TEST ignores lines beginning with '#'. If you come up with new tests, send them to lwall@jpl-devvax.jpl.nasa.gov. rary. To run all the tests, just type 'TEST'. To add new tests, just look at the current tests and do likewise. If a test fails, run it by itself to see if it prints any informative diagnostics. If not, modify the test to print informative diagnostics. If you put out extra lines with a '#' character on the front, you don't have to worry about removing the extra print statements later since TEST ignores lines beginning with '#'. If you come up with new tests, send them to lwall@perl/t/op.exp 755 473 0 1224 4747105071 6433 #!./perl # $Header: op.exp,v 3.0 89/10/18 15:29:01 lwall Locked $ print "1..6\n"; # compile time evaluation $s = sqrt(2); if (substr($s,0,5) eq '1.414') {print "ok 1\n";} else {print "not ok 1\n";} $s = exp(1); if (substr($s,0,7) eq '2.71828') {print "ok 2\n";} else {print "not ok 2\n";} if (exp(log(1)) == 1) {print "ok 3\n";} else {print "not ok 3\n";} # run time evaluation $x1 = 1; $x2 = 2; $s = sqrt($x2); if (substr($s,0,5) eq '1.414') {print "ok 4\n";} else {print "not ok 4\n";} $s = exp($x1); if (substr($s,0,7) eq '2.71828') {print "ok 5\n";} else {print "not ok 5\n";} if (exp(log($x1)) == 1) {print "ok 6\n";} else {print "not ok 6\n";} '1.414') {print "ok 1\n";} else {print "not ok 1\n";} $s = exp(1); if (substr($s,0,7) eq '2.71828') {print "ok 2\n";} else {print "not ok 2\n";} if (exp(log(1)) == 1) {print "ok 3\n";} else {print "not ok 3\n";} # run time evaluation $x1 = 1; $x2 = 2; $s = sqrt($x2); if (substr($s,0,5) eq '1.414') {print "ok 4\n";} else {print "not ok 4\n";} $s = exp($x1); perl/t/op.sleep 755 473 0 237 4747105071 6732 #!./perl # $Header: op.sleep,v 3.0 89/10/18 15:31:15 lwall Locked $ print "1..1\n"; $x = sleep 2; if ($x == 2) {print "ok 1\n";} else {print "not ok 1\n";} rint "ok 1\n";} else {print "not ok 1\n";} $s = exp(1); if (substr($s,0,7) eq '2.71828') {print "ok 2\n";} else {print "not ok 2\n";} if (exp(log(1)) == 1) {print "ok 3\n";} else {print "not ok 3\n";} # run time evaluation $x1 = 1; $x2 = 2; $s = sqrt($x2); if (substr($s,0,5) eq '1.414') {print "ok 4\n";} else {print "not ok 4\n";} $s = exp($x1); perl/t/op.list 755 473 0 4641 4747105071 6620 #!./perl # $Header: op.list,v 3.0 89/10/18 15:29:44 lwall Locked $ print "1..27\n"; @foo = (1, 2, 3, 4); if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";} $_ = join(':',@foo); if ($_ eq '1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";} ($a,$b,$c,$d) = (1,2,3,4); if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 3\n";} else {print "not ok 3\n";} ($c,$b,$a) = split(/ /,"111 222 333"); if ("$a;$b;$c" eq '333;222;111') {print "ok 4\n";} else {print "not ok 4\n";} ($a,$b,$c) = ($c,$b,$a); if ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5 $a;$b;$c\n";} ($a, $b) = ($b, $a); if ("$a;$b;$c" eq '222;111;333') {print "ok 6\n";} else {print "not ok 6\n";} ($a, $b[1], $c{2}, $d) = (1, 2, 3, 4); if ($a eq 1) {print "ok 7\n";} else {print "not ok 7\n";} if ($b[1] eq 2) {print "ok 8\n";} else {print "not ok 8\n";} if ($c{2} eq 3) {print "ok 9\n";} else {print "not ok 9\n";} if ($d eq 4) {print "ok 10\n";} else {print "not ok 10\n";} @foo = (1,2,3,4,5,6,7,8); ($a, $b, $c, $d) = @foo; print "#11 $a;$b;$c;$d eq 1;2;3;4\n"; if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";} @foo = @bar = (1); if (join(':',@foo,@bar) eq '1:1') {print "ok 12\n";} else {print "not ok 12\n";} @foo = (); @foo = 1+2+3; 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";} if (join('',1,2,(3,4,5)) eq '12345'){print "ok 19\n";}else{print "not ok 19\n";} if (join('',(1,2,3,4,5)) eq '12345'){print "ok 20\n";}else{print "not ok 20\n";} if (join('',(1,2,3,4),5) eq '12345'){print "ok 21\n";}else{print "not ok 21\n";} if (join('',1,(2,3,4),5) eq '12345'){print "ok 22\n";}else{print "not ok 22\n";} if (join('',1,2,(3,4),5) eq '12345'){print "ok 23\n";}else{print "not ok 23\n";} if (join('',1,2,3,(4),5) eq '12345'){print "ok 24\n";}else{print "not ok 24\n";} for ($x = 0; $x < 3; $x++) { ($a, $b, $c) = do { if ($x == 0) { ('ok ', 25, "\n"); } elsif ($x == 1) { ('ok ', 26, "\n"); } else { ('ok ', 27, "\n"); } }; print $a,$b,$c; } 5'){print "ok 21\n";}else{print "not ok 21\n";} if (join('',1,(2,3,4),5) eq '12345'){print "ok perl/t/cmd.switch 755 473 0 3043 4747105072 7267 #!./perl # $Header: cmd.switch,v 3.0 89/10/18 15:25:00 lwall Locked $ print "1..18\n"; sub foo1 { $_ = shift(@_); $a = 0; until ($a++) { next if $_ eq 1; next if $_ eq 2; next if $_ eq 3; next if $_ eq 4; return 20; } continue { return $_; } } print do foo1(0) == 20 ? "ok 1\n" : "not ok 1\n"; print do foo1(1) == 1 ? "ok 2\n" : "not ok 2\n"; print do foo1(2) == 2 ? "ok 3\n" : "not ok 3\n"; print do foo1(3) == 3 ? "ok 4\n" : "not ok 4\n"; print do foo1(4) == 4 ? "ok 5\n" : "not ok 5\n"; print do foo1(5) == 20 ? "ok 6\n" : "not ok 6\n"; sub foo2 { $_ = shift(@_); { last if $_ == 1; last if $_ == 2; last if $_ == 3; last if $_ == 4; } continue { return 20; } return $_; } print do foo2(0) == 20 ? "ok 7\n" : "not ok 1\n"; print do foo2(1) == 1 ? "ok 8\n" : "not ok 8\n"; print do foo2(2) == 2 ? "ok 9\n" : "not ok 9\n"; print do foo2(3) == 3 ? "ok 10\n" : "not ok 10\n"; print do foo2(4) == 4 ? "ok 11\n" : "not ok 11\n"; print do foo2(5) == 20 ? "ok 12\n" : "not ok 12\n"; sub foo3 { $_ = shift(@_); if (/^1/) { return 1; } elsif (/^2/) { return 2; } elsif (/^3/) { return 3; } elsif (/^4/) { return 4; } else { return 20; } return 40; } print do foo3(0) == 20 ? "ok 13\n" : "not ok 13\n"; print do foo3(1) == 1 ? "ok 14\n" : "not ok 14\n"; print do foo3(2) == 2 ? "ok 15\n" : "not ok 15\n"; print do foo3(3) == 3 ? "ok 16\n" : "not ok 16\n"; print do foo3(4) == 4 ? "ok 17\n" : "not ok 17\n"; print do foo3(5) == 20 ? "ok 18\n" : "not ok 18\n"; $_ = shift(@_); if (/^1/) { return 1; } elsif (/^2/) { return 2; } elsif (/^3/) { return 3; } elsif (/^4/) { return 4; } else { return 20; } return 40; } print do foo3(0) == 20 ? "ok 13\n" : "not ok 13\n"; print do foo3(1) == 1 ? "ok 14\n" : "not ok 14\n"; print do foo3(2) == 2 ? "ok 15\n" : "not ok 15\n"; print do foo3(3) == 3 ? "ok 16\n" : "not ok 16\n"; print do foo3(4) == 4 ? "ok 17\n" : "not ok 17\n"; print do foo3(5) perl/t/op.split 755 473 0 3362 4747105072 7000 #!./perl # $Header: op.split,v 3.0.1.1 89/11/11 05:01:44 lwall Locked $ print "1..12\n"; $FS = ':'; $_ = 'a:b:c'; ($a,$b,$c) = split($FS,$_); if (join(';',$a,$b,$c) eq 'a;b;c') {print "ok 1\n";} else {print "not ok 1\n";} @ary = split(/:b:/); if (join("$_",@ary) eq 'aa:b:cc') {print "ok 2\n";} else {print "not ok 2\n";} $_ = "abc\n"; @xyz = (@ary = split(//)); if (join(".",@ary) eq "a.b.c.\n") {print "ok 3\n";} else {print "not ok 3\n";} $_ = "a:b:c::::"; @ary = split(/:/); if (join(".",@ary) eq "a.b.c") {print "ok 4\n";} else {print "not ok 4\n";} $_ = 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";} # Can we say how many fields to split to? $_ = join(':', split(' ','1 2 3 4 5 6', 3)); print $_ eq '1:2:3 4 5 6' ? "ok 8\n" : "not ok 8 $_\n"; # Can we do it as a variable? $x = 4; $_ = join(':', split(' ','1 2 3 4 5 6', $x)); print $_ eq '1:2:3:4 5 6' ? "ok 9\n" : "not ok 9 $_\n"; # Does the 999 suppress null field chopping? $_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999)); print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; # Does assignment to a list imply split to one more field than that? $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`; print $foo =~ /DEBUGGING/ || $foo =~ /num\(3\)/ ? "ok 11\n" : "not ok 11\n"; # Can we say how many fields to split to when assigning to a list? ($a,$b) = split(' ','1 2 3 4 5 6', 2); $_ = join(':',$a,$b); print $_ eq '1:2 3 4 5 6' ? "ok 12\n" : "not ok 12 $_\n"; ld chopping? $_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999)); print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; # Does assignment to a list imply split to one more field than that? $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`; print $foo =~ /DEBUGGINperl/t/op.push 755 473 0 436 4747105072 6603 #!./perl # $Header: op.push,v 3.0 89/10/18 15:30:48 lwall Locked $ print "1..2\n"; @x = (1,2,3); push(@x,@x); if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} push(x,4); if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";} :4:5:6:::', 999)); print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; # Does assignment to a list imply split to one more field than that? $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`; print $foo =~ /DEBUGGINperl/t/op.auto 755 473 0 5150 4747105072 6612 #!./perl # $Header: op.auto,v 3.0 89/10/18 15:27:00 lwall Locked $ print "1..34\n"; $x = 10000; if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";} if (0 + $x-- - 1 == 10000) { print "ok 2\n";} else {print "not ok 2\n";} if (1 * $x == 10000) { print "ok 3\n";} else {print "not ok 3\n";} if (0 + $x-- - 0 == 10000) { print "ok 4\n";} else {print "not ok 4\n";} if (1 + $x == 10000) { print "ok 5\n";} else {print "not ok 5\n";} if (1 + $x++ == 10000) { print "ok 6\n";} else {print "not ok 6\n";} if (0 + $x == 10000) { print "ok 7\n";} else {print "not ok 7\n";} if (0 + --$x + 1 == 10000) { print "ok 8\n";} else {print "not ok 8\n";} if (0 + ++$x + 0 == 10000) { print "ok 9\n";} else {print "not ok 9\n";} if ($x == 10000) { print "ok 10\n";} else {print "not ok 10\n";} $x[0] = 10000; if (0 + ++$x[0] - 1 == 10000) { print "ok 11\n";} else {print "not ok 11\n";} if (0 + $x[0]-- - 1 == 10000) { print "ok 12\n";} else {print "not ok 12\n";} if (1 * $x[0] == 10000) { print "ok 13\n";} else {print "not ok 13\n";} if (0 + $x[0]-- - 0 == 10000) { print "ok 14\n";} else {print "not ok 14\n";} if (1 + $x[0] == 10000) { print "ok 15\n";} else {print "not ok 15\n";} if (1 + $x[0]++ == 10000) { print "ok 16\n";} else {print "not ok 16\n";} if (0 + $x[0] == 10000) { print "ok 17\n";} else {print "not ok 17\n";} if (0 + --$x[0] + 1 == 10000) { print "ok 18\n";} else {print "not ok 18\n";} if (0 + ++$x[0] + 0 == 10000) { print "ok 19\n";} else {print "not ok 19\n";} if ($x[0] == 10000) { print "ok 20\n";} else {print "not ok 20\n";} $x{0} = 10000; if (0 + ++$x{0} - 1 == 10000) { print "ok 21\n";} else {print "not ok 21\n";} if (0 + $x{0}-- - 1 == 10000) { print "ok 22\n";} else {print "not ok 22\n";} if (1 * $x{0} == 10000) { print "ok 23\n";} else {print "not ok 23\n";} if (0 + $x{0}-- - 0 == 10000) { print "ok 24\n";} else {print "not ok 24\n";} if (1 + $x{0} == 10000) { print "ok 25\n";} else {print "not ok 25\n";} if (1 + $x{0}++ == 10000) { print "ok 26\n";} else {print "not ok 26\n";} if (0 + $x{0} == 10000) { print "ok 27\n";} else {print "not ok 27\n";} if (0 + --$x{0} + 1 == 10000) { print "ok 28\n";} else {print "not ok 28\n";} if (0 + ++$x{0} + 0 == 10000) { print "ok 29\n";} else {print "not ok 29\n";} if ($x{0} == 10000) { print "ok 30\n";} else {print "not ok 30\n";} # 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";} 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";} eperl/t/op.stat 755 473 0 11614 4747105073 6640 #!./perl # $Header: op.stat,v 3.0.1.3 90/02/28 18:36:51 lwall Locked $ print "1..56\n"; unlink "Op.stat.tmp"; open(foo, ">Op.stat.tmp"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat(foo); if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";} if ($mtime && $mtime == $ctime) {print "ok 2\n";} else {print "not ok 2\n";} print foo "Now is the time for all good men to come to.\n"; close(foo); sleep 2; `rm -f Op.stat.tmp2; ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('Op.stat.tmp'); if ($nlink == 2) {print "ok 3\n";} else {print "not ok 3\n";} if ($mtime && $mtime != $ctime) {print "ok 4\n";} else {print "not ok 4\n";} print "#4 :$mtime: != :$ctime:\n"; `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' || -c '/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; chop($cwd = `pwd`); die "Can't run op.stat test 35 without pwd working" unless $cwd; chdir '/usr/bin' || die "Can't cd to /usr/bin"; while (<*>) { $cnt++; $uid++ if -u; last if $uid && $uid < $cnt; } chdir $cwd || die "Can't cd back to $cwd"; # 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 || -e '/xenix') {print "ok 39\n";} else {print "not ok 39\n";} close(null); if (-t) {print "ok 40\n";} else {print "not ok 40\n";} # 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";} $_ = ; 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'); $_ = ; 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";} n";} close(foo); open(foo,'op.stat'); $_ = ; if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";} if (-Tperl/t/op.subst 755 473 0 10020 4747105073 7013 #!./perl # $Header: op.subst,v 3.0.1.1 90/02/28 18:37:30 lwall Locked $ print "1..42\n"; $x = 'foo'; $_ = "x"; s/x/\$x/; print "#1\t:$_: eq :\$x:\n"; if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";} $_ = "x"; s/x/$x/; print "#2\t:$_: eq :foo:\n"; if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";} $_ = "x"; s/x/\$x $x/; print "#3\t:$_: eq :\$x foo:\n"; if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";} $b = 'cd'; ($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";} $a = 'abacada'; if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx') {print "ok 5\n";} else {print "not ok 5\n";} if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx') {print "ok 6\n";} else {print "not ok 6 $a\n";} if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx') {print "ok 7\n";} else {print "not ok 7 $a\n";} $_ = 'ABACADA'; if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";} $_ = '\\' 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";} $_ = 'aaaXXXXbbb'; s/^a//; print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n"; $_ = 'aaaXXXXbbb'; s/a//; print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n"; $_ = 'aaaXXXXbbb'; s/^a/b/; print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n"; $_ = 'aaaXXXXbbb'; s/a/b/; print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n"; $_ = 'aaaXXXXbbb'; s/aa//; print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n"; $_ = 'aaaXXXXbbb'; s/aa/b/; print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n"; $_ = 'aaaXXXXbbb'; s/b$//; print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n"; $_ = 'aaaXXXXbbb'; s/b//; print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n"; $_ = 'aaaXXXXbbb'; s/bb//; print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n"; $_ = 'aaaXXXXbbb'; s/aX/y/; print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n"; $_ = 'aaaXXXXbbb'; s/Xb/z/; print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n"; $_ = 'aaaXXXXbbb'; s/aaX.*Xbb//; print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n"; $_ = 'aaaXXXXbbb'; s/bb/x/; print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n"; # now for some unoptimized versions of the same. $_ = 'aaaXXXXbbb'; $x ne $x || s/^a//; print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/a//; print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/^a/b/; print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/a/b/; print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/aa//; print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/aa/b/; print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/b$//; print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/b//; print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/bb//; print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/aX/y/; print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/Xb/z/; print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/aaX.*Xbb//; print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/bb/x/; print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n"; $_ = 'abc123xyz'; s/\d+/$&*2/e; # yields 'abc246xyz' print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n"; s/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz' print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n"; s/\w/$& x 2/eg; # yields 'aabbcc 224466xxyyzz' print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n"; ne $x || s/aaX.*Xbb//; print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n"; $_ = 'aaaXXXXbbb'; $x ne $x || s/bb/x/; print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n"; $_ = 'abc123xyz'; s/\d+/$&*2/e; # yields 'abc246xyz' print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n"; s/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz' print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n"; s/\w/$& x 2/eg; # yields 'aabbcc 224466xxyyzz' print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" :perl/t/op.pat 755 473 0 6614 4747105073 6435 #!./perl # $Header: op.pat,v 3.0 89/10/18 15:30:44 lwall Locked $ print "1..43\n"; $x = "abc\ndef\n"; if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";} $* = 1; if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";} $* = 0; $_ = '123'; if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";} if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";} if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";} if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";} if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";} if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";} if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";} if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";} if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";} $_ = 'aaabbbccc'; if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') { print "ok 13\n"; } else { print "not ok 13\n"; } if (/(a+b+c+)/ && $1 eq 'aaabbbccc') { print "ok 14\n"; } else { print "not ok 14\n"; } if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";} $_ = 'aaabccc'; if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";} if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";} $_ = 'aaaccc'; if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";} if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";} $_ = 'abcdef'; if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";} if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";} if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";} 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";} $_ = 'abcdefghi'; /def/; # optimized up to cmd if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";} /cde/ + 0; # optimized only to spat if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";} /[d][e][f]/; # not optimized if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";} $_ = 'now is the {time for all} good men to come to.'; / {([^}]*)}/; if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";} $_ = 'xxx {3,4} yyy zzz'; print /( {3,4})/ ? "ok 35\n" : "not ok 35\n"; print $1 eq ' ' ? "ok 36\n" : "not ok 36\n"; print /( {4,})/ ? "not ok 37\n" : "ok 37\n"; print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n"; print $1 eq ' y' ? "ok 39\n" : "not ok 39\n"; print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n"; print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n"; print /x {3,4}/ ? "not ok 42\n" : "ok 42\n"; print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n"; e for all') {print "ok 34\n";} else {print "not ok 34 $1\n";} $_ = 'xxx {3,4} yyy zzz'; print /( {3,4})/ ? "ok 3perl/t/op.array 755 473 0 6227 4747105073 6767 #!./perl # $Header: op.array,v 3.0 89/10/18 15:26:55 lwall Locked $ print "1..30\n"; @ary = (1,2,3,4,5); if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";} $tmp = $ary[$#ary]; --$#ary; if ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";} if ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";} if (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";} $[ = 1; @ary = (1,2,3,4,5); if (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";} $tmp = $ary[$#ary]; --$#ary; if ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";} if ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";} if (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";} if ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";} $#ary += 1; # see if we can recover element 5 if ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";} if ($ary[5] == 5) {print "ok 11\n";} else {print "not ok 11\n";} $[ = 0; @foo = (); $r = join(',', $#foo, @foo); if ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";} $foo[0] = '0'; $r = join(',', $#foo, @foo); if ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";} $foo[2] = '2'; $r = join(',', $#foo, @foo); if ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";} @bar = (); $bar[0] = '0'; $bar[1] = '1'; $r = join(',', $#bar, @bar); if ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";} @bar = (); $r = join(',', $#bar, @bar); if ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";} $bar[0] = '0'; $r = join(',', $#bar, @bar); if ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";} $bar[2] = '2'; $r = join(',', $#bar, @bar); if ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";} reset 'b'; @bar = (); $bar[0] = '0'; $r = join(',', $#bar, @bar); if ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";} $bar[2] = '2'; $r = join(',', $#bar, @bar); if ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";} $foo = 'now is the time'; if (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) { if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') { print "ok 21\n"; } else { print "not ok 21\n"; } } else { print "not ok 21\n"; } $foo = 'lskjdf'; if ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) { print "not ok 22 $cnt $F1:$F2:$Etc\n"; } else { print "ok 22\n"; } %foo = ('blurfl','dyick','foo','bar','etc.','etc.'); %bar = %foo; print $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n"; %bar = (); print $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n"; (%bar,$a,$b) = (%foo,'how','now'); print $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n"; print $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n"; @bar{keys %foo} = values %foo; print $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n"; print $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n"; @foo = grep(/e/,split(' ','now is the time for all good men to come to')); print join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n"; @foo = grep(!/e/,split(' ','now is the time for all good men to come to')); print join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n"; 5\n"; print $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n"; @bar{keys %foo} = values %foo; print $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n"; print $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n"; @foo = grep(/e/,split(' ','now is the time for all good men to come to')); print join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n"; @foo =perl/t/re_tests 644 473 0 5743 4747105074 7064 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{0,}bc abbbbc y $& abbbbc ab+bc abbc y $& abbc ab+bc abc n - - ab+bc abq n - - ab{1,}bc abq n - - ab+bc abbbbc y $& abbbbc ab{1,}bc abbbbc y $& abbbbc ab{1,3}bc abbbbc y $& abbbbc ab{3,4}bc abbbbc y $& abbbbc ab{4,5}bc abbbbc n - - ab?bc abbc y $& abbc ab?bc abc y $& abc ab{0,1}bc abc y $& abc ab?bc abbbbc n - - ab?c abc y $& abc ab{0,1}c abc y $& abc ^abc$ abc y $& abc ^abc$ abcc n - - ^abc abcc y $& abc ^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{1,}b{1,}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){0,} ab y $&-$1 ab-b (a+|b)+ ab y $&-$1 ab-b (a+|b){1,} ab y $&-$1 ab-b (a+|b)? ab y $&-$1 a-a (a+|b){0,1} ab y $&-$1 a-a (^)* - c - - (ab|)* - c - - )( - c - - [^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 ij-j (bc+d$|ef*g.|h?i(j|k)) eperl/t/io.fs 755 473 0 5716 4747105074 6255 #!./perl # $Header: io.fs,v 3.0 89/10/18 15:26:20 lwall Locked $ print "1..22\n"; $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); if (umask(0) == 022) {print "ok 1\n";} else {print "not ok 1\n";} open(fh,'>x') || die "Can't create x"; close(fh); open(fh,'>a') || die "Can't create a"; close(fh); if (link('a','b')) {print "ok 2\n";} else {print "not ok 2\n";} if (link('b','c')) {print "ok 3\n";} else {print "not ok 3\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); if ($nlink == 3) {print "ok 4\n";} else {print "not ok 4\n";} if (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";} if ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); if (($mode & 0777) == 0777) {print "ok 7\n";} else {print "not ok 7\n";} if ((chmod 0700,'c','x') == 2) {print "ok 8\n";} else {print "not ok 8\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); if (($mode & 0777) == 0700) {print "ok 9\n";} else {print "not ok 9\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('x'); if (($mode & 0777) == 0700) {print "ok 10\n";} else {print "not ok 10\n";} if ((unlink 'b','x') == 2) {print "ok 11\n";} else {print "not ok 11\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); if ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('x'); if ($ino == 0) {print "ok 13\n";} else {print "not ok 13\n";} if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('a'); if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";} $foo = (utime 500000000,500000001,'b'); if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); if ($ino) {print "ok 17\n";} else {print "not ok 17\n";} if ($atime == 500000000 && $mtime == 500000001) {print "ok 18\n";} else {print "not ok 18 $atime $mtime\n";} if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); 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"; } 19\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sperl/t/comp.cmdopt 755 473 0 5640 4747105074 7456 #!./perl # $Header: comp.cmdopt,v 3.0 89/10/18 15:25:13 lwall Locked $ print "1..40\n"; # test the optimization of constants if (1) { print "ok 1\n";} else { print "not ok 1\n";} unless (0) { print "ok 2\n";} else { print "not ok 2\n";} if (0) { print "not ok 3\n";} else { print "ok 3\n";} unless (1) { print "not ok 4\n";} else { print "ok 4\n";} unless (!1) { print "ok 5\n";} else { print "not ok 5\n";} if (!0) { print "ok 6\n";} else { print "not ok 6\n";} unless (!0) { print "not ok 7\n";} else { print "ok 7\n";} if (!1) { print "not ok 8\n";} else { print "ok 8\n";} $x = 1; if (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";} if (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";} $x = ''; if (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";} if (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";} $x = 1; if (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";} if (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";} $x = ''; if (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";} if (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";} # test the optimization of registers $x = 1; if ($x) { print "ok 17\n";} else { print "not ok 17\n";} unless ($x) { print "not ok 18\n";} else { print "ok 18\n";} $x = ''; if ($x) { print "not ok 19\n";} else { print "ok 19\n";} unless ($x) { print "ok 20\n";} else { print "not ok 20\n";} # test optimization of string operations $a = 'a'; if ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";} if ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";} if ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";} if ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";} # test interaction of logicals and other operations $a = 'a'; $x = 1; if ($a eq 'a' && $x) { print "ok 25\n";} else { print "not ok 25\n";} if ($a ne 'a' && $x) { print "not ok 26\n";} else { print "ok 26\n";} $x = ''; if ($a eq 'a' && $x) { print "not ok 27\n";} else { print "ok 27\n";} if ($a ne 'a' && $x) { print "not ok 28\n";} else { print "ok 28\n";} $x = 1; if ($a eq 'a' || $x) { print "ok 29\n";} else { print "not ok 29\n";} if ($a ne 'a' || $x) { print "ok 30\n";} else { print "not ok 30\n";} $x = ''; if ($a eq 'a' || $x) { print "ok 31\n";} else { print "not ok 31\n";} if ($a ne 'a' || $x) { print "not ok 32\n";} else { print "ok 32\n";} $x = 1; if ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";} if ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";} $x = ''; if ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";} if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";} $x = 1; if ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";} if ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";} $x = ''; if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";} if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";} /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";} $x = ''; if ($a =~ /a/ && $x) { priperl/t/cmd.while 755 473 0 4512 4747105074 7102 #!./perl # $Header: cmd.while,v 3.0 89/10/18 15:25:07 lwall Locked $ print "1..10\n"; open (tmp,'>Cmd.while.tmp') || die "Can't create Cmd.while.tmp."; print tmp "tvi925\n"; print tmp "tvi920\n"; print tmp "vt100\n"; print tmp "Amiga\n"; print tmp "paper\n"; close tmp; # test "last" command open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; while () { last if /vt100/; } if (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1 $_\n";} # test "next" command $bad = ''; open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; while () { next if /vt100/; $bad = 1 if /vt100/; } if (!eof || /vt100/ || $bad) {print "not ok 2\n";} else {print "ok 2\n";} # test "redo" command $bad = ''; open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; while () { if (s/vt100/VT100/g) { s/VT100/Vt100/g; redo; } $bad = 1 if /vt100/; $bad = 1 if /VT100/; } if (!eof || $bad) {print "not ok 3\n";} else {print "ok 3\n";} # now do the same with a label and a continue block # test "last" command $badcont = ''; open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; line: while () { if (/vt100/) {last line;} } continue { $badcont = 1 if /vt100/; } if (!eof && /vt100/) {print "ok 4\n";} else {print "not ok 4\n";} if (!$badcont) {print "ok 5\n";} else {print "not ok 5\n";} # test "next" command $bad = ''; $badcont = 1; open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; entry: while () { next entry if /vt100/; $bad = 1 if /vt100/; } continue { $badcont = '' if /vt100/; } if (!eof || /vt100/ || $bad) {print "not ok 6\n";} else {print "ok 6\n";} if (!$badcont) {print "ok 7\n";} else {print "not ok 7\n";} # test "redo" command $bad = ''; $badcont = ''; open(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp."; loop: while () { if (s/vt100/VT100/g) { s/VT100/Vt100/g; redo loop; } $bad = 1 if /vt100/; $bad = 1 if /VT100/; } continue { $badcont = 1 if /vt100/; } if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";} if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";} `/bin/rm -f Cmd.while.tmp`; #$x = 0; #while (1) { # if ($x > 1) {last;} # next; #} continue { # if ($x++ > 10) {last;} # next; #} # #if ($x < 10) {print "ok 10\n";} else {print "not ok 10\n";} $i = 9; { $i++; } print "ok $i\n"; /VT100/g) { s/VT100/Vt100/g; redo loop; } $bad = 1 if /vt100/; $bad = 1 if /VT100/; } continue { $badcont = 1 if /vt100/; } if (!eof || $bad) {print "not ok 8\n";} perl/t/cmd.subval 755 473 0 4121 4747105075 7263 #!./perl # $Header: cmd.subval,v 3.0 89/10/18 15:24:52 lwall Locked $ sub foo1 { 'true1'; if ($_[0]) { 'true2'; } } sub foo2 { 'true1'; if ($_[0]) { return 'true2'; } else { return 'true3'; } 'true0'; } sub foo3 { 'true1'; unless ($_[0]) { 'true2'; } } sub foo4 { 'true1'; unless ($_[0]) { 'true2'; } else { 'true3'; } } sub foo5 { 'true1'; 'true2' if $_[0]; } sub foo6 { 'true1'; 'true2' unless $_[0]; } print "1..26\n"; if (do foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";} if (do foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";} if (do foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";} if (do foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";} if (do foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";} if (do foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";} if (do foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";} if (do foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";} if (do foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";} if (do foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";} if (do foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";} if (do foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\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"; } } sub ary1 { (1,2,3); } print &ary1 eq 3 ? "ok 23\n" : "not ok 23\n"; print join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n"; sub ary2 { do { return (1,2,3); (3,2,1); }; 0; } print &ary2 eq 3 ? "ok 25\n" : "not ok 25\n"; $x = join(':',&ary2); print $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n"; (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"; } } sub ary1 { (1,2,3); } print &ary1 eq 3 ? "ok 23\n" : "not ok 23\n"; print join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n"; sub ary2 { do { return (1,2,3); (3,2,1); }; 0; } print &ary2 eq 3 ? "ok 25\n" : "not ok 25perl/t/op.dbm 755 473 0 4112 4747105075 6404 #!./perl # $Header: op.dbm,v 3.0 89/10/18 15:28:31 lwall Locked $ if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') { print "1..0\n"; exit; } print "1..9\n"; unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; umask(0); print (dbmopen(h,'Op.dbmx',0640) ? "ok 1\n" : "not ok 1\n"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('Op.dbmx.pag'); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); while (($key,$value) = each(h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); $h{'goner1'} = 'snork'; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; $h{'jkl','mno'} = "JKL\034MNO"; $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); $h{'a'} = 'A'; $h{'b'} = 'B'; $h{'c'} = 'C'; $h{'d'} = 'D'; $h{'e'} = 'E'; $h{'f'} = 'F'; $h{'g'} = 'G'; $h{'h'} = 'H'; $h{'i'} = 'I'; $h{'goner2'} = 'snork'; delete $h{'goner2'}; dbmclose(h); print (dbmopen(h,'Op.dbmx',0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; $h{'l'} = 'L'; $h{'m'} = 'M'; $h{'n'} = 'N'; $h{'o'} = 'O'; $h{'p'} = 'P'; $h{'q'} = 'Q'; $h{'r'} = 'R'; $h{'s'} = 'S'; $h{'t'} = 'T'; $h{'u'} = 'U'; $h{'v'} = 'V'; $h{'w'} = 'W'; $h{'x'} = 'X'; $h{'y'} = 'Y'; $h{'z'} = 'Z'; $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; @keys = keys(%h); @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} while (($key,$value) = each(h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } } if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} @keys = ('blurfl', keys(h), 'dyick'); if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} # check cache overflow and numeric keys and contents $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('Op.dbmx.pag'); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; ys = ('blurfl', keys(h), 'dyick'); if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} # check cache overflow and numeric keys and contents $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('Op.dbmx.pag'); print ($sperl/t/op.study 755 473 0 3606 4747105075 7021 #!./perl # $Header: op.study,v 3.0 89/10/18 15:31:38 lwall Locked $ 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";} 8\n";} else {print "not ok 18\n";} if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";} $_ = 'abcdef'; study; if perl/t/TEST 755 473 0 3536 4747105075 6015 #!./perl # $Header: TEST,v 3.0.1.1 89/11/11 04:58:01 lwall Locked $ # This is written in a peculiar style, since we're trying to avoid # most of the constructs we'll be testing for. $| = 1; if ($ARGV[0] eq '-v') { $verbose = 1; shift; } chdir 't' if -f 't/TEST'; if ($ARGV[0] eq '') { @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.*`); } open(config,"../config.sh"); while () { if (/sharpbang='(.*)'/) { $sharpbang = ($1 eq '#!'); last; } } $bad = 0; while ($test = shift) { if ($test =~ /\.orig$/) { next; } if ($test =~ /\.rej$/) { next; } if ($test =~ /~$/) { next; } print "$test" . '.' x (16 - length($test)); if ($sharpbang) { open(results,"./$test|") || (print "can't run.\n"); } else { open(script,"$test") || die "Can't run $test.\n"; $_ =